-2011-01-03 Glenn Morris <rgm@gnu.org>
++2011-01-14 Glenn Morris <rgm@gnu.org>
+
+ * admin.el (set-copyright): Also handle \year in refcards/*.tex.
+
-2010-12-31 Eli Zaretskii <eliz@gnu.org>
++2011-01-14 Eli Zaretskii <eliz@gnu.org>
+2011-01-14 Glenn Morris <rgm@gnu.org>
+
+ * bzrmerge.el: Require cl when compiling.
+ (bzrmerge-merges): Doc fix.
+
+2011-01-07 Paul Eggert <eggert@cs.ucla.edu>
+
+ * notes/copyright: There's only one install-sh, not two, so fix a
+ typo claiming that there's two. Add move-if-change to the list of
+ GPL files imported from gnulib.
+
+2011-01-07 Paul Eggert <eggert@cs.ucla.edu>
+
+ * notes/copyright: Report status more accurately for non-GPL files.
+ Report copyright status more accurately for mkinstalldirs,
+ configure, m4/getopt.m4, and msdos/sed*.inp.
+
+2011-01-02 Eli Zaretskii <eliz@gnu.org>
* nt/README.W32: Update the information about PNG support libraries.
(Bug#7716)
(format-time-string "%Y")))))
(unless (file-exists-p (expand-file-name "src/emacs.c" root))
(error "%s doesn't seem to be the root of an Emacs source tree" root))
- (set-version-in-file root "lisp/version.el" copyright
- (rx (and "emacs-copyright" (0+ space)
+ (set-version-in-file root "src/emacs.c" copyright
+ (rx (and "emacs_copyright" (0+ (not (in ?\")))
- ?\" (submatch (1+ (not (in ?\")))) ?\")))
+ ?\" (submatch (1+ (not (in ?\")))) ?\")))
(set-version-in-file root "lib-src/ebrowse.c" copyright
(rx (and "emacs_copyright" (0+ (not (in ?\")))
- ?\" (submatch (1+ (not (in ?\")))) ?\")))
+ ?\" (submatch (1+ (not (in ?\")))) ?\")))
(set-version-in-file root "lib-src/etags.c" copyright
(rx (and "emacs_copyright" (0+ (not (in ?\")))
- ?\" (submatch (1+ (not (in ?\")))) ?\")))
+ ?\" (submatch (1+ (not (in ?\")))) ?\")))
(set-version-in-file root "lib-src/rcs2log" copyright
- (rx (and "Copyright" (0+ space) ?= (0+ space)
- ?\' (submatch (1+ nonl)))))
+ (rx (and "Copyright" (0+ space) ?= (0+ space)
+ ?\' (submatch (1+ nonl)))))
;; This one is a nuisance, as it needs to be split over two lines.
(string-match "\\(.*[0-9]\\{4\\} *\\)\\(.*\\)" copyright)
;; nextstep.
@c This is part of the Emacs manual.
@c Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1997, 2001, 2002,
- @c 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+ @c 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
@c See file emacs.texi for copying conditions.
-@node Registers, Display, CUA Bindings, Top
+@node Registers, Display, Killing, Top
@chapter Registers
@cindex registers
;; Local Variables:
;; coding: utf-8
-;; add-log-time-zone-rule: t
;; End:
- Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
- 2010 Free Software Foundation, Inc.
+ Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007,
+ 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
-2011-01-03 Eduard Wiebe <usenet@pusto.de>
++2011-01-14 Eduard Wiebe <usenet@pusto.de>
+
+ * nxml-mode.texi (Introduction): Fix file name typos.
+
-2010-12-02 Glenn Morris <rgm@gnu.org>
++2011-01-14 Glenn Morris <rgm@gnu.org>
+2011-01-13 Christian Ohler <ohler@gnu.org>
+
+ * ert.texi: New file.
+
+ * Makefile.in:
+ * makefile.w32-in: Add ert.texi.
+
+2011-01-10 Jan Moringen <jan.moringen@uni-bielefeld.de>
+
+ * dbus.texi (Receiving Method Calls): New function
+ dbus-register-service. Rearrange node.
+
+2011-01-07 Paul Eggert <eggert@cs.ucla.edu>
+
+ * texinfo.tex: Update to version 2010-12-23.17 from gnulib,
+ which in turn is copied from ftp://tug.org/tex/.
+
+2011-01-04 Jan Moringen <jan.moringen@uni-bielefeld.de>
+
+ * dbus.texi (Receiving Method Calls): Describe new optional
+ parameter dont-register-service of dbus-register-{method,property}.
+
+2010-12-17 Daiki Ueno <ueno@unixuser.org>
+
+ * epa.texi (Encrypting/decrypting *.gpg files): Mention
+ epa-file-select-keys.
+
+2010-12-16 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus.texi (Archived Messages): Remove outdated text.
+
+2010-12-16 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * gnus.texi (Foreign Groups): Added clarification of foreign groups.
+
+2010-12-15 Andrew Cohen <cohen@andy.bu.edu>
+
+ * gnus.texi (The hyrex Engine): Say that this engine is obsolete.
+
+2010-12-14 Andrew Cohen <cohen@andy.bu.edu>
+
+ * gnus.texi (The swish++ Engine): Add customizable parameters
+ descriptions.
+ (The swish-e Engine): Ditto.
+
+2010-12-14 Michael Albinus <michael.albinus@gmx.de>
+
+ * tramp.texi (Inline methods): Add "ksu" method.
+ (Remote processes): Add example with remote `default-directory'.
+
+2010-12-14 Glenn Morris <rgm@gnu.org>
+
+ * faq.texi (Expanding aliases when sending mail):
+ Now build-mail-aliases is interactive.
+
+2010-12-13 Andrew Cohen <cohen@andy.bu.edu>
+
+ * gnus.texi: First pass at adding (rough) nnir documentation.
+
+2010-12-13 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus.texi (Filtering New Groups):
+ Mention gnus-auto-subscribed-categories.
+ (The First Time): Remove, since default-subscribed-newsgroups has been
+ removed.
+
+2010-12-13 Glenn Morris <rgm@gnu.org>
* cl.texi (For Clauses): Small fixes for frames and windows.
@c Uncomment 1st line before texing this file alone.
@c %**start of header
@c Copyright (C) 1995, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
- @c 2009, 2010 Free Software Foundation, Inc.
+ @c 2009, 2010, 2011 Free Software Foundation, Inc.
@c
-@c Do not modify this file, it was generated from gnus-faq.xml, available from
-@c <URL:http://my.gnus.org/FAQ/>.
-@c
@setfilename gnus-faq.info
@settitle Frequently Asked Questions
@c %**end of header
@copying
This manual is for Org version @value{VERSION}.
- Copyright @copyright{} 2004, 2005, 2006, 2007, 2008, 2009, 2010
-Copyright @copyright{} 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation
++Copyright @copyright{} 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
+Free Software Foundation, Inc.
@quotation
Permission is granted to copy, distribute and/or modify this document
-2011-01-03 Glenn Morris <rgm@gnu.org>
++2011-01-14 Glenn Morris <rgm@gnu.org>
+
+ * refcards/calccard.tex, refcards/cs-dired-ref.tex:
+ * refcards/cs-refcard.tex, refcards/cs-survival.tex:
+ * refcards/de-refcard.tex, refcards/dired-ref.tex:
+ * refcards/fr-dired-ref.tex, refcards/fr-refcard.tex:
+ * refcards/fr-survival.tex, refcards/orgcard.tex:
+ * refcards/pl-refcard.tex, refcards/pt-br-refcard.tex:
+ * refcards/refcard.tex, refcards/ru-refcard.tex:
+ * refcards/sk-dired-ref.tex, refcards/sk-refcard.tex:
+ * refcards/sk-survival.tex, refcards/survival.tex:
+ * refcards/vipcard.tex, refcards/viperCard.tex:
+ Update short copyright year to 2011.
+
-2010-12-24 Kenichi Handa <handa@m17n.org>
++2011-01-14 Kenichi Handa <handa@m17n.org>
+
+ * NEWS: Describe the changes for rmail's MIME handling.
+
-2010-12-04 W. Martin Borgert <debacle@debian.org> (tiny change)
++2011-01-14 W. Martin Borgert <debacle@debian.org> (tiny change)
+2011-01-13 Christian Ohler <ohler@gnu.org>
+
+ * NEWS: Mention ERT.
+
+2011-01-10 Jan Moringen <jan.moringen@uni-bielefeld.de>
+
+ * NEWS: Add new function dbus-register-service.
+
+2011-01-09 Chong Yidong <cyd@stupidchicken.com>
+
+ * themes/tango-theme.el, themes/tango-dark-theme.el: Let-bind
+ tango palette colors. Only define faces for color displays.
+ Customize the ansi-color-names-vector variable. Add Ediff,
+ Flyspell, and Semantic faces as suggested by Jan Moringen.
+
+2011-01-08 Andreas Schwab <schwab@linux-m68k.org>
+
+ * compilation.txt: Add column to gcc-include sample.
+
+2011-01-08 Glenn Morris <rgm@gnu.org>
+
+ * PROBLEMS: -batch implies -q.
+
+2011-01-07 Tassilo Horn <tassilo@member.fsf.org>
+
+ * themes/tsdh-light-theme.el, themes/tsdh-dark-theme.el: Remove
+ dev-prefix from file names, so that the files don't clash on 8x3
+ filesystems.
+
+2011-01-06 Tassilo Horn <tassilo@member.fsf.org>
+
+ * themes/dev-tsdh-light-theme.el (dev-tsdh-light): New theme.
+ * themes/dev-tsdh-dark-theme.el (dev-tsdh-dark): New theme.
+
+2011-01-04 Jan Moringen <jan.moringen@uni-bielefeld.de>
+
+ * NEWS: Extended behaviour of dbus-register-{method,property}.
+
+2011-01-02 Kenichi Handa <handa@m17n.org>
+
+ * NEWS.23: Describe the changes for rmail's MIME handling.
+
+2010-12-18 Chong Yidong <cyd@stupidchicken.com>
+
+ * images/separator.xpm: Tweak colors.
+
+2010-12-14 Michael Albinus <michael.albinus@gmx.de>
+
+ * NEWS: Mention new Tramp method "ksu".
+
+2010-12-13 W. Martin Borgert <debacle@debian.org> (tiny change)
* schema/schemas.xml: Add DocBook (Bug#7491).
--- /dev/null
- Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+GNU Emacs NEWS -- history of user-visible changes.
+
++Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+See the end of the file for license conditions.
+
+Please send Emacs bug reports to bug-gnu-emacs@gnu.org.
+If possible, use M-x report-emacs-bug.
+
+This file is about changes in Emacs version 23.
+
+See files NEWS.22, NEWS.21, NEWS.20, NEWS.19, NEWS.18, and NEWS.1-17
+for changes in older Emacs versions.
+
+You can narrow news to a specific version by calling `view-emacs-news'
+with a prefix argument or by typing C-u C-h C-n.
+
+\f
+* Installation Changes in Emacs 23.3
+
+* Startup Changes in Emacs 23.3
+
+* Changes in Emacs 23.3
+
+\f
+* Editing Changes in Emacs 23.3
+
+\f
+* Changes in Specialized Modes and Packages in Emacs 23.3
+
+---
+** The appt-add command takes an optional argument for the warning time.
+This can be used in place of the default appt-message-warning-time.
+
+---
+** You can allow inferior Python processes to load modules from the
+current directory by setting `python-remove-cwd-from-path' to nil.
+
+** VC and related modes
+
+*** New VC command `vc-log-incoming', bound to `C-x v I'.
+This shows a log of changes to be received with a pull operation.
+For Git, this runs "git fetch" to make the necessary data available
+locally; this requires version 1.7 or newer.
+
+*** New VC command `vc-log-outgoing', bound to `C-x v O'.
+This shows a log of changes to be sent in the next commit.
+
+*** New VC command vc-find-conflicted-file.
+
++++
+*** The 'g' key in VC diff, log, log-incoming and log-outgoing buffers
+reruns the corresponding VC command to compute an up to date version
+of the buffer.
+
+*** vc-dir for Bzr supports viewing shelve contents and shelving snapshots.
+
++++
+*** Special markup can be added to log-edit buffers.
+You can add headers specifying additional information to be supplied
+to the version control system. For example:
+
+ Author: J. R. Hacker <jrh@example.com>
+ Fixes: 4204
+ Actual text of log entry...
+
+Bazaar recognizes the headers "Author", "Date" and "Fixes".
+Git, Mercurial, and Monotone recognize "Author" and "Date".
+Any unknown header is left as is in the message, so it is not lost.
+
+** Rmail
+
+*** The default value of `rmail-enable-mime' is now t. Rmail decodes
+MIME contents automatically. You can customize the variable
+`rmail-enable-mime' back to `nil' to disable this automatic MIME
+decoding.
+
+*** The command `rmail-mime' change the displaying of a MIME message
+between decoded presentation form and raw data if `rmail-enable-mime'
+is non-nil. And, with prefix argument, it change only the displaying
+of the MIME entity at point.
+
+*** The new command `rmail-mime-next-item' (bound to TAB) moves point
+to the next item of MIME message.
+
+*** The new command `rmail-mime-previous-item' (bound to backtab) moves
+point to the previous item of MIME message.
+
+*** The new command `rmail-mime-toggle-hidden' (RET) hide or show the
+body of the MIME entity at point.
+
+** Obsolete packages
+
++++
+*** lmenu.el and cl-compat.el are now obsolete.
+
+\f
+* New Modes and Packages in Emacs 23.3
+
+** smie.el is a generic navigation and indentation engine.
+It takes a simple BNF description of the grammar, and provides both
+sexp-style navigation (jumping over begin..end pairs) as well as
+indentation, which can be adjusted via ad-hoc indentation rules.
+
+\f
+* Incompatible Lisp Changes in Emacs 23.3
+
+** posn-col-row now excludes the header line from the row count
+If the frame has a header line, posn-col-row will count row numbers
+starting from the first line of text below the header line.
+
+\f
+* Lisp changes in Emacs 23.3
+
++++
+** `e' and `pi' are now called `float-e' and `float-pi'.
+ The old names are obsolete.
+
++++
+** The use of unintern without an obarray arg is now obsolete.
+
+---
+** The function `princ-list' is now obsolete.
+
++++
+** The yank-handler argument to kill-region and friends is now obsolete.
+
++++
+** New function byte-to-string, like char-to-string but for bytes.
+
+\f
+* Changes in Emacs 23.3 on non-free operating systems
+
++++
+** The nextstep port can have different modifiers for the left and right
+alt/option key by customizing the value for ns-right-alternate-modifier.
+
+\f
+* Installation Changes in Emacs 23.2
+
+** New configure options for Emacs developers.
+These are not new features; only the configure flags are new.
+
+*** --enable-profiling builds Emacs with profiling enabled.
+This might not work on all platforms.
+
+*** --enable-checking[=OPTIONS] builds emacs with extra runtime checks.
+
+** `make install' now consistently ignores umask, creating a
+world-readable install.
+
+** Emacs compiles with Gconf support, if it is detected.
+Use the configure option --without-gconf to disable this.
+This is used by the `font-use-system-font' feature (see below).
+
+* Startup Changes in Emacs 23.2
+
+** The command-line option -Q (--quick) also inhibits loading X resources.
+However, if Emacs is compiled with the Lucid or Motif toolkit, X
+resource settings for the graphical widgets are still applied.
+On Windows, the -Q option causes Emacs to ignore Registry settings,
+but environment variables set on the Registry are still honored.
+
+*** The new variable `inhibit-x-resources' shows whether X resources
+were loaded.
+
+** New command-line option -mm (--maximized) maximizes the initial frame.
+
+* Changes in Emacs 23.2
+
+** The maximum size of buffers (and the largest fixnum) is doubled.
+On typical 32bit systems, buffers can now be up to 512MB.
+
+** The default value of `trash-directory' is now nil.
+This means that `move-file-to-trash' trashes files according to
+freedesktop.org specifications, the same method used by the Gnome,
+KDE, and XFCE desktops. (This change has no effect on Windows, which
+uses `system-move-file-to-trash' for trashing.)
+
+** The pointer now becomes invisible when typing.
+Customize `make-pointer-invisible' to disable this feature.
+
+** Font changes
+
+*** Emacs can use the system default monospaced font in Gnome.
+To enable this feature, set `font-use-system-font' to non-nil (it is
+nil by default). If the system default changes, Emacs changes also.
+This feature requires Gconf support, which is automatically included
+at compile-time if configure detects the gconf libraries (you can
+disable this with the configure option --without-gconf).
+
+*** On X11, Emacs reacts to Xft changes made by configuration tools,
+via the XSETTINGS mechanism. This includes antialias, hinting,
+hintstyle, RGBA, DPI and lcdfilter changes.
+
+** Killing a buffer with a running process now asks for confirmation.
+To remove this query, remove `process-kill-buffer-query-function' from
+`kill-buffer-query-functions', or set the appropriate process flag
+with `set-process-query-on-exit-flag'.
+
+** File-local variable changes
+
+*** Specifying a minor mode as a local variables enables that mode,
+unconditionally. The previous behavior, toggling the mode, was
+neither reliable nor generally desirable.
+
+*** There are new commands for adding and removing file-local variables:
+`add-file-local-variable', `delete-file-local-variable',
+`add-file-local-variable-prop-line', and
+`delete-file-local-variable-prop-line'.
+
+*** There are new commands for adding and removing directory-local variables,
+and copying them to and from file-local variable lists:
+`add-dir-local-variable', `delete-dir-local-variable',
+`copy-dir-locals-to-file-locals',
+`copy-dir-locals-to-file-locals-prop-line' and
+`copy-file-locals-to-dir-locals'.
+
+** Internationalization changes
+
+*** Unibyte sessions are now considered obsolete.
+This refers to the EMACS_UNIBYTE environment variable as well as the
+--unibyte, --multibyte, --no-multibyte, and --no-unibyte command line
+arguments. Customizing enable-multibyte-characters and setting
+default-enable-multibyte-characters are also deprecated.
+
+*** New coding system `utf-8-hfs'.
+This is suitable for default-file-name-coding-system on Mac OS X; see
+international/ucs-normalize.el.
+
+** Function arguments in *Help* buffers are now shown in upper-case.
+Customize `help-downcase-arguments' to t to show them in lower-case.
+
+** New command `async-shell-command', bound globally to `M-&'.
+This executes the command asynchronously, similar to calling `M-!' and
+manually adding an ampersand to the end of the command. With `M-&',
+you don't need the ampersand. The output appears in the buffer
+`*Async Shell Command*'.
+
+** When running in a new enough xterm (newer than version 242), Emacs
+asks xterm what the background color is and it sets up faces
+accordingly for a dark background if needed (the current default is to
+consider the background light).
+
+\f
+* Editing Changes in Emacs 23.2
+
+** Kill-ring and selection changes
+
+*** If `select-active-regions' is t, any active region automatically
+becomes the primary selection (for interaction with other window
+applications). If you enable this, you might want to bind
+`mouse-yank-primary' to Mouse-2.
+
+*** When `save-interprogram-paste-before-kill' is non-nil, the kill
+commands save the interprogram-paste selection into the kill ring
+before doing anything else. This avoids losing the selection.
+
+*** When `kill-do-not-save-duplicates' is non-nil, identical
+subsequent kills are not duplicated in the `kill-ring'.
+
+** Completion changes
+
+*** The new command `completion-at-point' provides mode-sensitive completion.
+
+*** tab-always-indent set to `complete' lets TAB do completion as well.
+
+*** The new completion-style `initials' is available.
+For instance, this can complete M-x lch to list-command-history.
+
+*** The new variable `completions-format' determines how completions
+are displayed in the *Completions* buffer. If you set it to
+`vertical', completions are sorted vertically in columns.
+
+** The default value of `blink-matching-paren-distance' is increased.
+
+** M-n provides more default values in the minibuffer for commands
+that read file names. These include the file name at point (when ffap
+is loaded without ffap-bindings), the file name on the current line
+(in Dired buffers), and the directory names of adjacent Dired windows
+(for Dired commands that operate on several directories, such as copy,
+rename, or diff).
+
+** M-r is bound to the new `move-to-window-line-top-bottom'.
+This moves point to the window center, top and bottom on successive
+invocations, in the same spirit as the C-l (recenter-top-bottom)
+command.
+
+** The new variable `recenter-positions' determines the default
+cycling order of C-l (`recenter-top-bottom').
+
+** The abbrevs file is now a file named abbrev_defs in
+user-emacs-directory; but the old location, ~/.abbrev_defs, is used if
+that file exists.
+
+\f
+* Changes in Specialized Modes and Packages in Emacs 23.2
+
+** The bookmark menu has a narrowing search via bookmark-bmenu-search.
+
+** Calc
+
+*** The Calc settings file is now a file named calc.el in
+user-emacs-directory; but the old location, ~/.calc.el, is used if
+that file exists.
+
+*** Graphing commands (`g f' etc.) now work on MS-Windows, if you have
+the native Windows port of Gnuplot version 3.8 or later installed.
+
+** Calendar and diary
+
+*** Fancy diary display is now the default.
+If you prefer the simple display, customize `diary-display-function'.
+
+*** The diary's fancy display now enables view-mode.
+
+*** The command `calendar-current-date' accepts an optional argument
+giving an offset from today.
+
+** Desktop
+
+*** The default value for `desktop-buffers-not-to-save' is nil.
+This means Desktop will try restoring all buffers, when you restart
+your Emacs session. Also, `desktop-buffers-not-to-save' is only
+effective for buffers that have no associated file. If you want to
+exempt buffers that do correspond to files, customize the value of
+`desktop-files-not-to-save' instead.
+
+** Dired
+
+*** The new variable `dired-auto-revert-buffer', if non-nil, causes
+Dired buffers to be reverted automatically on revisiting them.
+
+** DocView
+
+*** When `doc-view-continuous' is non-nil, scrolling a line
+on the page edge advances to the next/previous page.
+
+** Elint
+
+*** Elint now uses compilation-mode.
+
+*** Elint can now scan individual files and whole directories,
+and can be run in batch mode.
+
+*** Elint does a more thorough initialization, and recognizes more built-in
+functions and variables. Customize `elint-scan-preloaded' if you want
+to sacrifice some accuracy for a faster startup.
+
+*** Elint attempts some basic understanding of featurep and (f)boundp tests.
+
+*** Customize `elint-ignored-warnings' to suppress some warnings.
+
+** GDB-UI
+
+*** Toolbar functionality for reverse debugging. Display of STL
+collections as watch expressions. These features require GDB 7.0 or later.
+
+** Grep
+
+*** A new command `zrgrep' searches recursively in gzipped files.
+
+** Info
+
+*** The new command `Info-virtual-index' bound to "I" displays a menu of
+matched topics found in the index.
+
+*** The new command `info-finder' replaces finder.el with a virtual Info
+manual that generates an Info file which gives the same information
+through a menu structure.
+
+** LaTeX mode now provides completion (via completion-at-point).
+
+** Message mode is now the default mode for composing mail.
+
+The default for `mail-user-agent' is now message-user-agent, so the
+C-x m (`compose-mail') command uses Message mode instead of Mail mode.
+
+Message mode has been included in Emacs, as part of the Gnus package,
+for several years. It provides several features that are absent in
+Mail mode, such as MIME handling.
+
+*** If the user has not customized mail-user-agent, `compose-mail'
+checks for Mail mode customizations, and issues a warning if these
+customizations are found. This alerts users who may otherwise be
+unaware that their mail configuration has changed.
+
+To disable this check, set compose-mail-user-agent-warnings to nil.
+
+** The default value of mail-interactive is t, since Emacs 23.1.
+(This was not announced at the time.) It means that when sending mail,
+Emacs will wait for the process sending mail to return. If you
+experience delays when sending mail, you may wish to set this to nil.
+
+** nXML mode is now the default for editing XML files.
+
+** pcomplete provides a new command `pcomplete-std-completion' which
+is similar to `pcomplete' but using the standard completion UI code.
+
+** Shell (and other comint modes)
+
+*** M-s is no longer bound to `comint-next-matching-input'.
+
+*** M-r is now bound to `comint-history-isearch-backward-regexp'.
+This starts an incremental search of the comint/shell input history.
+
+*** ansi-color is now enabled by default in Shell mode.
+To disable it, set ansi-color-for-comint-mode to nil.
+
+** Tramp
+
+*** New connection methods "rsyncc", "imap" and "imaps".
+On systems which support GVFS-Fuse, Tramp offers also the new
+connection methods "dav", "davs", "obex" and "synce".
+
+** VC and related modes
+
+*** When using C-x v v or C-x v i on a unregistered file that is in a
+directory not controlled by any VCS, ask the user what VC backend to
+use to create a repository, create a new repository and register the
+file.
+
+*** New command `vc-root-print-log', bound to `C-x v L'.
+This displays a `*vc-change-log*' buffer showing the history of the
+version-controlled directory tree as a whole.
+
+*** New command `vc-root-diff', bound to `C-x v D'.
+This is similar to `vc-diff', but compares the entire directory tree
+of the current VC directory with its working revision.
+
+*** `C-x v l' and `C-x v L' do not show the full log by default.
+The number of entries shown can be chosen interactively with a prefix
+argument, or by customizing vc-log-show-limit. The `*vc-change-log*'
+buffer now contains buttons at the end of the buffer, which can be
+used to increase the number of entries shown. RCS, SCCS, and CVS do
+not support this feature.
+
+*** vc-annotate supports annotations through file copies and renames,
+it displays the old names for the files and it can show logs/diffs for
+the corresponding lines. Currently only Git and Mercurial take
+advantage of this feature.
+
+*** The log command in vc-annotate can display a single log entry
+instead of redisplaying the full log. The RCS, CVS and SCCS VC
+backends do not support this.
+
+*** When a file is not found, VC will not try to check it out of RCS anymore.
+
+*** Diff and log operations can be used from Dired buffers.
+
+*** vc-git changes
+
+**** The short log format for git makes use of the graph display,
+so it's not supported on git versions earlier than 1.5.6.
+
+**** vc-dir uses the --relative option of git, and so requires at least
+git version 1.5.5.
+
+**** Support for operating with stashes has been added to vc-dir:
+the stash list is displayed in the *vc-dir* header, stashes can be
+created, removed, applied and their content displayed.
+
+*** vc-bzr supports operating with shelves: the shelve list is
+displayed in the *vc-dir* header, shelves can be created, removed and applied.
+
+*** log-edit-strip-single-file-name controls whether or not single filenames
+are stripped when copying text from the ChangeLog to the *VC-Log* buffer.
+
+** Miscellaneous
+
+*** Interactively `multi-isearch-buffers' and `multi-isearch-buffers-regexp'
+read buffer names to search, one by one, ended with RET. With a prefix
+argument, they ask for a regexp, and search in buffers whose names match
+the specified regexp. Interactively `multi-isearch-files' and
+`multi-isearch-files-regexp' read file names to search, one by one,
+ended with RET. With a prefix argument, they ask for a wildcard, and
+search in file buffers whose file names match the specified wildcard.
+
+*** Autorevert Tail mode now works also for remote files.
+
+*** The new eshell built-in commands `su' and `sudo' support Tramp.
+Thus, they change `default-directory' to reflect the new user id, and
+let commands run under that user's permissions. This works even when
+`default-directory' is already remote. Calling the external commands
+is possible via `*su' or `*sudo', respectively.
+
+** Obsolete packages
+
+*** sym-comp.el is now obsolete, superseded by completion-at-point.
+
+*** lucid.el and levents.el are now obsolete.
+
+\f
+* New Modes and Packages in Emacs 23.2
+
+** CEDET (the Collection of Emacs Development Tools) is now in Emacs.
+This is a collection of packages to aid with using Emacs as an IDE
+(integrated development environment):
+
+*** The Semantic package allows the use of parsers to intelligently
+edit and navigate source code. Parsers for C/C++, Java, Javascript,
+and several other languages are included by default, and Semantic can
+also interface with external tools such as GNU Global and GNU Idutils.
+
+To enable Semantic, use the global minor mode `semantic-mode'.
+See the Semantic manual for details.
+
+*** EDE (Emacs Development Environment) is a package for managing code
+projects, including features such as automatic Makefile generation.
+
+To enable EDE, use the minor mode `global-ede-mode'.
+See the EDE manual for details.
+
+*** SRecode is a library for recoding Semantic tags back into source
+code. It is currently used by some parts of Semantic and EDE; in the
+future, it may be used for code generation features.
+
+*** The EIEIO library implements a subset of the Common Lisp Object
+System (CLOS). It is used by the other CEDET packages.
+
+** mpc.el is a front end for the Music Player Daemon. Run it with M-x mpc.
+
+** htmlfontify.el turns a fontified Emacs buffer into an HTML page.
+
+** js.el is a new major mode for JavaScript files.
+
+** imap-hash.el is a new library to address IMAP mailboxes as hashtables.
+
+\f
+* Incompatible Lisp Changes in Emacs 23.2
+
+** The Lisp reader turns integers that are too large/small into floats.
+For instance, on machines where `536870911' is the largest integer,
+reading `536870912' gives the floating-point object `536870912.0'.
+
+This change only concerns the Lisp reader; it does not affect how
+actual integer objects overflow.
+
+** Several obsolete functions removed.
+The functions have been obsolete since Emacs 19, and are unlikely to
+be in use:
+
+ time-stamp-month-dd-yyyy, time-stamp-dd/mm/yyyy, time-stamp-mon-dd-yyyy
+ time-stamp-dd-mon-yy, time-stamp-yy/mm/dd, time-stamp-yyyy/mm/dd,
+ time-stamp-yyyy-mm-dd, time-stamp-yymmdd, time-stamp-hh:mm:ss,
+ time-stamp-hhmm, baud-rate
+
+** Support for generating Emacs 18 compatible bytecode (by setting
+the variable `byte-compile-compatibility') has been removed.
+
+** In image-mode.el `image-mode-maybe' is obsolete.
+Instead, you can either use `image-mode' (which displays an image file
+as the actual image initially), or `image-mode-as-text' (when you want
+to display an image file as text initially). `image-mode-as-text' is a
+combination of a non-image mode from `auto-mode-alist' (or Fundamental
+mode) and `image-minor-mode'. `image-minor-mode' provides a `C-c C-c'
+key binding to toggle image display.
+`image-toggle-display-text' removes image properties.
+`image-toggle-display-image' adds image properties.
+`image-toggle-display' toggles between `image-mode-as-text' and `image-mode'.
+
+\f
+* Lisp changes in Emacs 23.2
+
+** All the default-FOO variables that hold the default value of the FOO
+variable, are now declared obsolete.
+
+** read-key is a function halfway between read-event and read-key-sequence.
+It reads a single key, but obeys input and escape sequence decoding.
+
+** Frame parameter changes
+
+*** You can give the `fullscreen' frame parameter the value `maximized'.
+This maximizes the frame.
+
+*** The new frame parameter `sticky' makes Emacs frames sticky in
+virtual desktops.
+
+** Completion changes
+
+*** completion-base-size is obsoleted by completion-base-position.
+This change causes a few backward incompatibilities, mostly with
+choose-completion-string-functions where the `mini-p' argument has
+been replaced by a `base-position' argument, and where the `base-size'
+argument is now always nil.
+
+*** New function `completion-in-region' to use the standard completion
+facilities on a particular region of text.
+
+*** The 4th arg to all-completions (aka hide-spaces) is declared obsolete.
+
+*** completion-annotate-function specifies how to compute annotations
+for completions displayed in *Completions*.
+
+** Minibuffer changes
+
+*** read-file-name-predicate is obsolete. It was used to pass the predicate
+to read-file-name-internal because read-file-name-internal abused its `pred'
+argument to pass the current directory, but this hack is not needed
+any more.
+
+** Changes to file-manipulation functions
+
+*** `delete-directory' has an optional parameter RECURSIVE.
+
+*** New function `copy-directory', which copies a directory recursively.
+
+** called-interactively-p now takes one argument and replaces interactive-p
+which is now marked obsolete.
+
+** New function set-advertised-calling-convention makes it possible
+to obsolete arguments as well as make some arguments mandatory.
+
+** You can control which binding is preferentially shown in menus and
+docstrings by adding a `:advertised-binding' property to the corresponding
+command's symbol. That property can hold a single binding or a list
+of bindings.
+
+** Network and process changes
+
+*** start-process-shell-command and start-file-process-shell-command
+now only take a single `command' argument.
+
+*** The new variable `process-file-side-effects' should be set to nil
+if a `process-file' call does not change a remote file. This allows
+file name handlers such as Tramp to optimizations.
+
+*** make-network-process can now also create `seqpacket' Unix sockets.
+
+** Loading changes
+
+*** eval-next-after-load is obsolete.
+
+*** New hook `after-load-functions' run after loading an Elisp file.
+
+** Byte compilation changes
+
+*** Changing the file-names generated by byte-compilation by redefining
+the function `byte-compile-dest-file' before loading bytecomp.el is obsolete.
+Instead, customize byte-compile-dest-file-function.
+
+*** `byte-compile-warnings' has new members, `constants' and `suspicious'.
+
+** New macro with-silent-modifications to tweak text properties without
+affecting the buffer's modification state.
+
+** Hash tables have a new printed representation that is readable.
+The feature `hashtable-print-readable' identifies this new
+functionality.
+
+** New functions for performing Unicode normalization:
+ucs-normalize-NFD-region, ucs-normalize-NFD-string,
+ucs-normalize-NFC-region, ucs-normalize-NFC-string,
+ucs-normalize-NFKD-region, ucs-normalize-NFKD-string,
+ucs-normalize-NFKC-region, ucs-normalize-NFKC-string,
+ucs-normalize-HFS-NFD-region, ucs-normalize-HFS-NFD-string,
+ucs-normalize-HFS-NFC-region, ucs-normalize-HFS-NFC-string.
+
+** Face aliases can now be marked as obsolete, using the macro
+`define-obsolete-face-alias'.
+
+** New function `window-full-height-p', analogous to the full-width version.
+
+\f
+* Changes in Emacs 23.2 on non-free operating systems
+
+** On MS-Windows, `display-time' now displays the system load average
+as well as the time, as it does on GNU and Unix.
+
+\f
+* Installation Changes in Emacs 23.1
+
+** The default X toolkit is now Gtk+, rather than Lucid.
+The configure option `--with-gtk' has been removed. Gtk is now the
+default toolkit, but you can use --with-x-toolkit=gtk if necessary.
+
+** New font code.
+Fonts are handled by new code capable of dealing with multiple font
+backends. This uses the freetype and fontconfig libraries.
+
+*** Emacs now accepts font names supplied in the fontconfig format
+(e.g. "monospace-12:bold") and GTK format (e.g. "Monospace Bold 12").
+
+*** Added support for local fonts (fonts installed on the machine
+where Emacs is running).
+
+*** Added support for the Xft library for antialiasing.
+
+*** Added support for the otf library for complex text layout by
+OpenType fonts.
+
+*** Added support for the m17n library for text shaping.
+
+** Changes to image support
+
+*** configure now checks for libgif before libungif when searching for
+a GIF library.
+
+*** Emacs now supports the SVG image format through librsvg2.
+
+*** Emacs now supports multi-page TIFF images.
+
+** New NeXTSTEP-based port.
+This provides support for GNUstep (via the GNUstep libraries) and Mac
+OS X (via the Cocoa libraries).
+
+Specify --with-ns to configure for this. By default, a self-contained
+app will be built (containing all lisp). To install/share lisp with
+other emacsen (e.g. X11 build) use --disable-ns-self-contained. See
+nextstep/README and nextstep/INSTALL in the Emacs source directory.
+
+** Mac OS X is no longer supported via Carbon.
+Use the NeXTSTEP port, described above.
+
+** The new configuration option "--with-dbus" enables D-Bus language
+bindings for Emacs.
+
+** Support for many obsolete platforms has been removed.
+See the list at the end of etc/MACHINES for details.
+
+*** Support for systems without alloca has been removed.
+
+*** Support for Sun windows has been removed.
+
+*** The `emacstool' utility has been removed.
+
+** The following platforms will be removed in a future Emacs version:
+If you are still using Emacs on one of these platforms, please email
+emacs-devel@gnu.org to inform the Emacs developers.
+
+*** Old GNU/Linux systems based on libc version 5.
+
+*** Old FreeBSD, NetBSD, and OpenBSD systems based on the COFF
+executable format.
+
+*** Solaris versions 2.6 and below.
+
+*** Solaris on IBM RS6000 machines.
+
+*** UNIX System V (the original SysV, not later platforms based on it).
+
+*** Unixware on non-x86 machines.
+
+*** Platforms not supporting shared libraries (i.e., requiring the
+NO_SHARED_LIBS compilation flag).
+
+** The configure options `--with-gcc', `--without-gcc' have been removed.
+Configure will use gcc by default. Set the CC environment variable if
+you need control over which C compiler is used.
+
+** The refcards are now shipped as PDF files.
+
+** The manuals are now licensed under the GNU Free Documentation License v1.3,
+or any later version.
+
+** Emacs 23 comes with a new set of default icons.
+Various resolutions are available as etc/images/icons/hicolor/*/apps/emacs.png.
+The Emacs 22 icon is available as `emacs22.png' in the same location.
+\f
+* Changes in Emacs 23.1
+
+** Improved X Window System support
+
+*** Emacs now supports using both X displays and ttys in one session.
+With an Emacs server active (M-x server-start), `emacsclient -t'
+creates a tty frame connected to the running emacs server. You can
+use any number of different ttys. `emacsclient -c' creates a new X11
+frame on the current $DISPLAY (or a tty frame if $DISPLAY is not set).
+There may be problems if a display exits unexpectedly and Emacs is compiled
+with Gtk+, see etc/PROBLEMS.
+
+You can test for the presence of this feature in your Lisp code by
+testing for the `multi-tty' feature.
+
+*** Emacs starts in the background, as a daemon, when given the
+--daemon command line argument. It disconnects from the terminal and
+starts the server. Clients can connect and create graphical or
+terminal frames using emacsclient.
+
+**** emacsclient starts emacs in daemon mode and connects to it when
+--alternate-editor="" is used (or when the evironment variable
+ALTERNATE_EDITOR is set to "") and emacsclient cannot connect to an
+emacs server.
+
+*** The new command close-display-connection closes a connection to a
+remote display. There are some bugs for Gtk+. See etc/PROBLEMS.
+
+*** Emacs now supports the XEmbed specification.
+You can embed Emacs in another application on X11. The new command line
+option --parent-id is used to pass the parent window id to Emacs. See
+http://standards.freedesktop.org/xembed-spec/xembed-spec-latest.html
+for details about XEmbed.
+
+*** Emacs can now set the frame opacity.
+The opacity of a frame can be controlled by setting the `alpha' frame
+parameter. This only takes effect on a compositing window manager for
+the X Window System, such as Compiz, Beryl and Compiz Fusion, on Mac
+OS X, or on Windows 2000 and later versions of Windows.
+
+The alpha parameter should be an integer between 0 (transparent) and
+100 (opaque), or a float number between 0.0 and 1.0. It can also be a
+cons cell (ACTIVE . INACTIVE), where ACTIVE is the opacity of an
+active frame and INACTIVE is the opacity of non-active frames.
+
+The variable `frame-alpha-lower-limit' defines a lower bound for the
+opacity; the default is 20.
+
+** Internationalization changes
+
+*** The Emacs character set is now a superset of Unicode.
+(It has about four times the code space, which should be plenty).
+
+The internal encoding used for buffers and strings is now
+Unicode-based and called `utf-8-emacs' (`emacs-internal' is an alias
+for this). This encoding is backward-compatible with Unicode's UTF-8
+encoding. The internal encoding previously used by Emacs,
+`emacs-mule', is still available for reading and writing files.
+
+During byte-compilation, Emacs 23 uses `utf-8-emacs' to write files.
+As a result, byte-compiled files containing non-ASCII characters can't
+be read by earlier versions of Emacs. Files compiled by Emacs 20, 21,
+or 22 are loaded correctly as `emacs-mule' (whether or not they
+contain multibyte characters). This takes somewhat more time, so it
+may be worth recompiling existing .elc files which don't need to be
+shared with older Emacsen.
+
+*** There are new coding systems/aliases; see M-x list-coding-systems.
+
+*** There is a new charset implementation with many new charsets.
+See M-x list-character-sets. New charsets can be defined conveniently
+as tables of unicodes.
+
+*** There are new language environments for Chinese-GBK,
+Chinese-GB18030, Khmer, Bengali, Punjabi, Gujarati, Oriya, Telugu,
+Sinhala, and TaiViet.
+
+*** The minor modes unify-8859-on-encoding-mode and
+unify-8859-on-decoding-mode are obsolete.
+
+*** `ucs-insert' is bound to `C-x 8 RET' and in addition to hex numbers
+accepts numbers in hash notation (e.g. #o21430 for octal, or #10r8984 for
+decimal). It also accepts Unicode character names with completion.
+
+*** The `cyrillic-translit' input method supports many new characters.
+Common typographical characters available from Unicode were added to
+`cyrillic-translit': punctuation marks, accented characters, fractions,
+and others.
+
+** Emacs now supports serial port access on GNU/Linux, Unix, and
+Windows. The new command `serial-term' starts an interactive terminal
+on a serial port. The serial port can be configured at runtime with
+the mode-line mouse menu.
+
+** Menu Bar changes
+
+*** In the Options menu, the "Set Default Font" item applies the
+selected font to the `default' face on all frames, not just the
+current frame. Furthermore, if Emacs is compiled with both GTK and
+Fontconfig support, the "Set Default Font" item uses the GTK font
+selection dialog instead of an Emacs pop-up menu.
+
+*** The font setting chosen by "Set Default Font" is saved if the
+"Save Options" item is used.
+
+*** The Tools menu contains a new Encryption/Decryption submenu.
+This contains commands provided by EasyPG, the newly-included
+interface to GnuPG (see New Modes and Packages).
+
+*** In the Options menu, the "Truncate Long Lines in the Buffer" entry
+has been replaced with a submenu offering three different ways to
+handle long lines: truncation, continuation at the window edge, and
+the new word wrapping behavior (see Editing Changes, below).
+
+*** Improvements to menus for major and minor modes
+More major and minor modes now have a mode specific menu, and existing
+mode menus have been improved to include more functionality.
+
+** Mode-line changes
+
+*** The mode-line displays a `@', instead of `-', if the
+default-directory for the current buffer is on a remote machine.
+
+*** The mode-line displays a mode menu when mouse-1 is clicked on a
+minor mode, in the same way as it already did for major modes.
+
+*** The `mode-line-emphasis' face is used to highlight certain
+mode-line information (e.g. waiting for a VC command to finish).
+
+*** The mode-line tooltips have been improved to provide more details.
+
+*** The VC, line/colum number and minor mode indicators on the mode
+line are now interactive: mouse-1 can be used on them to pop up a menu.
+
+** File deletion can make use of the Recycle Bin or system Trash folder.
+Set `delete-by-moving-to-trash' non-nil to use this. Deleted files
+and directories will then be sent to the Recycle Bin on Windows, and
+to `trash-directory' on other systems.
+
+** Directory-local variables can now be defined.
+By default, Emacs looks in .dir-locals.el for directory-local
+variables. For more information, see `dir-locals-set-directory-class'
+and `dir-locals-set-class-variables'.
+
+** Emacs can now use `auth-source' for authentication.
+`smtpmail' and `url' (Tramp and Gnus also) use `auth-source' to obtain
+login names and passwords. The match, if found, is reported
+in *Messages* with the password blanked out.
+
+** `where-is-preferred-modifier' can specify your favorite modifier.
+
+\f
+* Startup Changes in Emacs 23.1
+
+** The option `inhibit-startup-screen' (with aliases to old names
+`inhibit-splash-screen' and `inhibit-startup-message') doesn't inhibit
+display of the initial message in the *scratch* buffer. If you don't
+want to display the initial message in the *scratch* buffer at startup,
+you can set the option `initial-scratch-message' to nil.
+
+** New user option `initial-buffer-choice' specifies what to display
+after starting Emacs: startup screen, *scratch* buffer, visiting a
+file or directory.
+
+** New alias `argv' for `command-line-args-left'
+This is a convenience alias, so that one can write `(pop argv)'
+inside of --eval command line arguments in order to access
+following arguments.
+
+** The abbrev file is no longer read at startup in batch mode.
+
+** Emacs now supports invocation by an X session manager.
+It can save a session and restore it later. See the documentation of
+the functions `emacs-session-save' and `emacs-session-restore'.
+(Actually, this feature was introduced with Emacs 22, but it was not
+documented.)
+\f
+* Incompatible Editing Changes in Emacs 23.1
+
+** In Dired, `dired-flag-garbage-files' is rebound from `&' to `%&'
+on the regexp command prefix map.
+
+** In Dired-x, all command guesses for ! are now added to the default
+list accessible by M-n instead of pushing all guesses temporarily into
+the history list.
+
+** In Isearch mode, a special case of typing `C-w' at the beginning of
+the minibuffer that toggles word search (i.e. using key sequences
+`C-s RET C-w' or `C-s M-e C-w') is obsolete. You can use the global key
+`M-s w' to start word search, or type `M-s w' in Isearch mode to
+toggle word search. To start nonincremental word search you can now use
+`M-s w RET' and `M-s w C-r RET' instead of `C-s RET C-w' and `C-r RET C-w'.
+
+** In Info, `Info-search' is unbound from `M-s' to allow using `M-s w'
+for word search as well as other search commands from the global prefix
+key `M-s'. `Info-search' is still bound to `s', and also incremental
+search commands `C-s', `C-M-s', `C-r', `C-M-r' are available for searching
+through multiple Info nodes, together with their nonincremental versions
+`C-s RET', `C-r RET', `C-M-s RET', `C-M-r RET', `M-s w RET'.
+
+** In Text mode, `center-line' and `center-paragraph' are rebound from
+`M-s' and `M-S' to global keys `M-o M-s' and `M-o M-S' on the global
+prefix map `M-o', which is intended for such formatting commands.
+
+** The following input methods were removed in Emacs 22.2, but this was
+not advertised: danish-alt-postfix, esperanto-alt-postfix,
+finnish-alt-postfix, german-alt-postfix, icelandic-alt-postfix,
+norwegian-alt-postfix, scandinavian-alt-postfix, spanish-alt-postfix,
+and swedish-alt-postfix. Use the versions without "alt-", which are
+identical.
+
+\f
+* Editing Changes in Emacs 23.1
+
+** The C-n and C-p line-motion commands now move by screen lines,
+taking continued lines and variable-width characters into account.
+Setting `line-move-visual' to nil reverts this to the previous
+behavior (i.e., motion by logical lines based on buffer contents
+alone).
+
+** C-x C-c now invokes `save-buffers-kill-terminal', and C-z now
+invokes `suspend-frame'. These changes are for compatibility with the
+new multi-tty support (see `Improved X Window System support' above).
+
+** Mark changes
+
+*** Transient Mark mode is now on by default.
+
+*** mark-even-if-inactive now defaults to t
+
+*** When Transient Mark mode is on, C-SPC C-SPC pushes a mark without
+activating it.
+
+*** When Transient Mark mode is on, M-q now fills the region if the
+region is active. Otherwise, it fills the current paragraph.
+
+*** When Transient Mark mode is on, M-$ now checks spelling of the
+region if the region is active. Otherwise, it checks spelling of the
+word at point.
+
+*** When Transient Mark mode is on, TAB now indents the region if the
+region is active.
+
+*** The variable `use-empty-active-region' controls whether an empty
+active region in Transient Mark mode should make commands operate on
+that empty region.
+
+** Temporarily active regions
+
+*** The new variable shift-select-mode, non-nil by default, controls
+shift-selection. When Shift Select mode is on, shift-translated
+motion keys (e.g. S-left and S-down) activate and extend a temporary
+region, similar to mouse-selection.
+
+*** Temporarily active regions, created using shift-selection or
+mouse-selection, are not necessarily deactivated in the next command.
+They are only deactivated after point motion commands that are not
+shift-translated, or after commands that would ordinarily deactivate
+the mark in Transient Mark mode (e.g., any command that modifies the
+buffer).
+
+** Minibuffer and completion changes
+
+*** Emacs may ask for confirmation before opening a non-existent file
+or buffer. By default, Emacs requests confirmation if you type RET
+immediately after TAB, and the resulting input is not an existing file
+or buffer; this usually happens when the minibuffer input did not
+complete far enough and you entered RET by mistake. In that case,
+Emacs puts the message "[Confirm]" in the minibuffer; type RET again
+to create the file or buffer.
+
+The new variable confirm-nonexistent-file-or-buffer determines whether
+Emacs asks for confirmation. The default value is `after-completion'.
+If you change it to t, Emacs always asks for confirmation; if you
+change it to nil, Emacs never asks for confirmation.
+
+*** The rules for performing completion have been changed.
+When generating completion alternatives, Emacs now takes the
+minibuffer text after point, if any, into account: this text is
+treated as a substring of the remaining part of the completion
+alternative (i.e., the part not matched by the minibuffer text before
+point). If no completion alternatives are found this way, Emacs
+attempts to perform partial-completion. If still no completion
+alternatives are found, we fall back on the Emacs 22 rules for
+performing completion.
+
+The new variable `completion-styles' can be customized to choose your
+favorite completion style.
+
+*** When M-n in the minibuffer reaches the end of the list of defaults,
+it adds the completion list to the end, so next M-n continues putting
+completion items to the minibuffer. The same principle applies to
+incremental search commands as well: C-s or C-M-s starts searching
+the default values and after the end of defaults they continue
+searching minibuffer completion items.
+
+*** Minibuffer input of shell commands now comes with completion.
+
+*** In the `C-x d' (Dired) prompt, typing M-n gives the visited file
+name of the current buffer.
+
+*** In the M-! (shell-command) prompt, M-n provides some default commands.
+These are guessed using the file extension of the current file, based
+on the file-handlers specified in the operating system's `mailcap'
+file. The ! command in Dired (dired-do-shell-command) works
+similarly, using the file displayed on the current line.
+
+*** A list of regexp default values is available via M-n for `occur',
+`keep-lines', `flush-lines' and `how-many'. This list includes the active
+region in transient-mark-mode, the word under the cursor, the last Isearch
+regexp, the last Isearch string and the last replacement regexp.
+
+*** When enable-recursive-minibuffers is non-nil, operations which use
+switch-to-buffer (such as C-x b and C-x C-f) do not fail any more when
+used in a minibuffer or a dedicated window. Instead, they fallback on
+using pop-to-buffer, which will use some other window. This change
+has no effect when enable-recursive-minibuffers is nil (the default).
+
+*** Isearch started in the minibuffer searches in the minibuffer history.
+Reverse Isearch commands (C-r, C-M-r) search in previous minibuffer
+history elements, and forward Isearch commands (C-s, C-M-s) search in
+next history elements. When the reverse search reaches the first history
+element, it wraps to the last history element, and the forward search
+wraps to the first history element. When the search is terminated, the
+history element containing the search string becomes the current.
+
+*** The variable read-file-name-completion-ignore-case overrides
+completion-ignore-case for file name completion.
+
+*** The variable read-buffer-completion-ignore-case overrides
+completion-ignore-case for buffer name completion.
+
+*** The new command `minibuffer-force-complete' chooses one of the
+possible completions, rather than stopping at the common prefix.
+
+*** If `completion-auto-help' is `lazy', Emacs shows the completions
+buffer only on the second attempt to complete. This was already
+supported in `partial-completion-mode'.
+
+** Face changes
+
+*** S-down-mouse-1 now pops up a menu for changing the font and text
+size of the default face in the current buffer. The face is changed
+via face remapping (see Lisp changes, below).
+
+*** New commands to change the default face size in the current buffer.
+To increase it, type `C-x C-+' or `C-x C-='. To decrease it, type
+`C-x C--'. To restore the default (global) face size, type `C-x C-0'.
+These work via Text Scale mode, a new minor mode.
+
+The final key in the above commands may be repeated without the
+leading `C-x', e.g. `C-x C-= C-= C-=' increases the face height by
+three steps. Each step scales the height of the default face by the
+value of the variable `text-scale-mode-step'.
+
+*** The commands buffer-face-mode and buffer-face-set can be used to
+remap the default face in the current buffer. See "Buffer Face mode",
+under New Modes and Packages.
+
+** Primary selection changes
+
+*** You can disable kill ring commands from accessing the primary
+selection by setting `x-select-enable-primary' to nil.
+
+** Continuation lines can now be wrapped at word boundaries
+(word-wrapping). This is controlled by the new per-buffer variable
+`word-wrap'. Word wrapping does not take place if continuation lines
+are not shown, e.g. if truncate-lines is non-nil. The most convenient
+way to enable word-wrapping is using the new minor mode Visual Line
+mode; in addition to setting `word-wrap' to t, this rebinds some
+editing commands to work on screen lines rather than text lines. See
+New Modes and Packages, below.
+
+** Window management changes
+
+*** truncate-partial-width-windows now accepts integer values, which
+specify a minimum window width for partial-width windows, below which
+lines are truncated. The default has been changed to 50.
+
+*** The new command balance-windows-area balances windows both
+vertically and horizontally.
+
+*** pop-to-buffer now always sets input focus when the popped-to window
+is on a different frame.
+
+** Miscellaneous changes:
+
+*** C-l is bound to the new command recenter-top-bottom, rather than recenter.
+This moves the current line to window center, top and bottom on
+successive invocations.
+
+*** scroll-preserve-screen-position also preserves the column position.
+
+*** If `yank-pop-change-selection' is t, rotating the kill ring also
+updates the selection or clipboard to the current yank, just as M-w
+would do so with the text it copies to the kill ring.
+
+*** C-M-% now shows replacement as it would look in the buffer, with
+`\N' and `\&' substituted according to the match. Old behavior can be
+restored by customizing `query-replace-show-replacement'.
+
+*** The command shell prompts for the default directory, when it is
+called with a prefix and the default directory is a remote file name.
+This is because some file name handlers (like ange-ftp) are not able to
+run processes remotely.
+
+*** The new command kill-matching-buffers kills buffers whose name
+matches a regexp.
+
+*** The value of comment-style now defaults to `indent'.
+Thefore, comment-start markers are inserted at the current indentation
+of the region to comment, rather than the leftmost column.
+
+*** The new commands `pp-macroexpand-expression' and
+`pp-macroexpand-last-sexp' pretty-print macro expansions.
+
+*** The new command `set-file-modes' allows to set file's mode bits.
+The mode bits can be specified in symbolic notation, like with GNU
+Coreutils, in addition to an octal number. `chmod' is a new
+convenience alias for this function.
+
+*** `next-error-recenter' specifies how next-error should recenter the
+visited source file. Its value can be a number (for example, 0 for
+top line, -1 for bottom line), or nil for no recentering.
+
+*** When typing in a password in the echo area, C-y yanks the current
+kill into the password.
+
+*** Tooltip frame parameters `font' and `color' in `tooltip-frame-parameters'
+are ignored. Customize the `tooltip' face instead.
+
+*** `mkdir' is a new convenience alias for `make-directory'.
+\f
+* New Modes and Packages in Emacs 23.1
+
+** Auto Composition Mode is a minor mode that composes characters
+automatically when they are displayed. It is globally on by default.
+It uses `auto-composition-function' (default `auto-compose-chars').
+
+** Bubbles, a new game, is similar to SameGame.
+
+** Buffer Face mode is a minor mode for remapping the default face in
+the current buffer. The variable `buffer-face-mode-face' specifies
+the face to remap to. The command `buffer-face-set' prompts for a
+face name, sets `buffer-face-mode-face' to it, and enables
+buffer-face-mode. See "Face changes", under Editing Changes, for a
+description of face remapping.
+
+** butterfly flips the desired bit on the drive platter.
+See http://xkcd.com/378/
+
+** bug-reference.el provides clickable links to bug reports.
+
+** dbus.el provides D-Bus language bindings.
+D-Bus is an inter-process communication mechanism for applications
+residing on the same host. See the manual for details.
+
+** DocView mode allows viewing of PDF, PostScript and DVI documents.
+One can also search for a regular expression in the document. For
+details, see the commentary in doc-view.el.
+
+PDF and DVI files are now opened in Doc View mode by default.
+
+In Postcript mode, C-c C-c launches Doc View minor mode for viewing
+the postscript file.
+
+** EasyPG provides an interface to the GNU Privacy Guard (GnuPG).
+It includes a GnuPG keyring browser, cryptographic operations on
+regions and files, and automatic encryption of *.gpg files. For
+details, see the EasyPG Assistant User's Manual.
+
+** json.el is a library for parsing and generating JSON
+(JavaScript Object Notation), a lightweight data-interchange format.
+
+** linum.el is a new minor mode to display line numbers for the
+current buffer.
+
+** mairix.el is an interface to mairix, a free tool for indexing and
+searching locally stored mail. It allows you to query mairix and
+display the search results with Rmail, Gnus and VM. Note that there
+is an existing Gnus back end, nnmairix.el, which should be used with
+Maildir/MH setups.
+
+** minibuffer-depth-indicate-mode shows the minibuffer depth in the prompt.
+
+** nXML Mode
+This is a new mode for editing XML documents. It allows a schema to
+be associated with the XML document being edited, using Relax NG as
+the schema language. The schema is used to provide two key features:
+
+*** Continuous validation. nXML validates as you type, highlighting
+any invalid parts of your document.
+
+*** Completion. nXML can assist you in entering an element name,
+attribute name or data value by using information about what is
+allowed by the schema in that context.
+
+** proced.el provides a Dired-like interface for operating on
+processes. Proced makes an Emacs buffer containing a listing of the
+current processes. You can use the normal Emacs commands to move
+around in this buffer, and special Proced commands to operate on the
+processes listed. It is currently only functional on GNU/Linux,
+MS-Windows and Solaris.
+
+** Remember Mode is a mode for jotting down things to remember.
+Notes can be saved to a Diary file. For details, see the Remember
+Manual.
+
+** RST mode is a major mode for editing reStructuredText files.
+
+** Ruby mode is a major mode for Ruby files.
+
+** Visual Line mode provides support for editing by visual lines.
+It turns on word-wrapping in the current buffer, and rebinds C-a, C-e,
+and C-k to commands that operate by visual lines instead of logical
+lines. This is a more reliable replacement for longlines-mode.
+This can also be turned on using the menu bar, via
+Options -> Line Wrapping in this Buffer -> Word Wrap
+
+** xesam.el is an implementation of Xesam, an interface to (desktop)
+search engines like Beagle, Strigi, and Tracker. The Xesam API
+requires D-Bus for communication.
+
+** zeroconf.el offers service discovery and service publishing
+interfaces according to the zeroconf specification. It communicates
+with Avahi, a zeroconf implementation, via D-Bus messages on systems
+which have installed this software.
+
+** There is a new `whitespace' package.
+(The pre-existing one has been renamed to `old-whitespace'.)
+Now, besides reporting bogus blanks, the whitespace package has a
+minor mode and a global minor mode to visualize blanks (TAB, (HARD)
+SPACE and NEWLINE). The visualization is made via faces and/or display
+table. It can also indicate lines that extend beyond a given column,
+trailing blanks, and empty lines at the start or end of a buffer.
+See `whitespace-style' for more details. The `whitespace-action' option
+specifies what to do when a buffer is visited, killed, or written.
+
+\f
+* Changes in Specialized Modes and Packages in Emacs 23.1
+
+** Abbrev has been rewritten in Elisp and extended with more flexibility.
+
+*** New functions: abbrev-get, abbrev-put, abbrev-table-get, abbrev-table-put,
+abbrev-table-p, abbrev-insert, abbrev-table-menu.
+
+*** Special hook `abbrev-expand-functions' obsoletes `pre-abbrev-expand-hook'.
+
+*** `make-abbrev-table', `define-abbrev', `define-abbrev-table' all take
+extra arguments for arbitrary properties.
+
+*** New variable `abbrev-minor-mode-table-alist'.
+
+*** `local-abbrev-table' can hold a list of abbrev-tables.
+
+*** Abbrevs have now the following special properties:
+`:count', `:system', `:enable-function', `:case-fixed'.
+
+*** Abbrev-tables have now the following special properties:
+`:parents', `:case-fixed', `:enable-function', `:regexp',
+`abbrev-table-modiff'.
+
+** Apropos
+
+*** `apropos-library' describes the elements defined in a given library.
+
+*** Set `apropos-compact-layout' is you want a more compact (but wider) layout.
+
+** Archive Mode has basic support to browse Rar archives.
+Note, however, that the free version of the unrar command only handles
+versions 1 and 2 of the Rar format.
+
+** BibTeX mode
+
+*** New command `bibtex-initialize' (re)initializes BibTeX buffers.
+
+*** New `bibtex-entry-format' options `whitespace', `braces', and
+`string', disabled by default.
+
+*** New variable `bibtex-cite-matcher-alist' contains rules to
+identify cited keys in BibTeX entries, used by `bibtex-find-crossref'.
+
+*** Command `bibtex-url' allows multiple URLs per entry.
+
+** Bookmarks
+
+*** bookmark.el saves bookmarks in a pre-Emacs-23-incompatible file format
+bookmark.el can read a .emacs.bmk file saved by an older Emacs, but an
+older Emacs cannot read one saved by Emacs 23.
+
+** Calendar and diary
+
+*** There is a new date style, `iso', essentially year/month/day.
+The variable `european-calendar-style' is obsolete - use `calendar-date-style'.
+Similarly, the commands `american-calendar' and `european-calendar'
+should be replaced by `calendar-set-date-style'.
+
+*** The calendar namespace has been rationalized.
+All functions and variables now begin with a `calendar-', `diary-', or
+`holiday-' prefix. The various calendar systems have secondary
+prefixes, eg `calendar-french-'. The old names you are likely to use
+directly still exist, for the time being, as aliases, but please start
+using the new names.
+
+*** The whitespace in the calendar layout can be customized.
+See the variables:
+calendar-left-margin, calendar-intermonth-spacing, calendar-column-width,
+calendar-day-header-width, and calendar-day-digit-width.
+
+*** Text (e.g. ISO weeks) can be displayed between the calendar months.
+See the variables calendar-intermonth-header and calendar-intermonth-text.
+
+*** The function `holiday-chinese' computes holidays on the Chinese calendar.
+It has been used to add items to the list `holiday-oriental-holidays'.
+
+*** `diary-remind' accepts a negative number -DAYS as a shorthand for
+the list (1 2 ... DAYS).
+
+** Change Log mode
+
+*** The new command C-c C-f (change-log-find-file) finds the file
+associated with the current log entry.
+
+*** The new command C-c C-c (change-log-goto-source) goes to the
+source code associated with a log entry.
+
+** Compile and grep modes
+
+*** The mode-line entry for the *compilation* and *grep* buffer is color coded.
+It has different colors for to show that: (a) the command is still
+running, (b) successful completion, (c) error.
+
+*** compilation-auto-jump-to-first-error tells `compile' to jump to
+the first error encountered during compilations.
+
+*** compilation-scroll-output accepts a new value, `first-error', which
+says to stop auto scrolling at the first error that occurs.
+
+*** The `cc' alias for C++ files in `grep-file-aliases' has been
+improved. `hh' can be used to match C++ header files and `cchh' both
+C++ sources and headers.
+
+** Copyright
+
+*** You can specify your copyright holders' names.
+Only copyright lines with holders matching `copyright-names-regexp' are
+considered for update.
+
+*** Copyrights can be at the end of the buffer.
+This is controlled by `copyright-at-end-flag' (used by, e.g., change-log-mode).
+
+** Custom
+
+*** defcustom accepts new keyword arguments, `:safe' and `:risky', which
+set a variable's `safe-local-variable' and `risky-local-variable' property.
+
+** Diff mode
+
+*** diff-refine-hunk highlights word-level details of changes in a diff hunk.
+It's used automatically as you move through hunks, see
+diff-auto-refine-mode. It is bound to `C-c C-b'.
+
+*** diff-add-change-log-entries-other-window iterates through the diff
+buffer and tries to create ChangeLog entries for each change.
+It is bound to `C-x 4 A'.
+
+*** Turning on `whitespace-mode' in a diff buffer will show trailing
+whitespace problems in the modified lines.
+
+** Dired
+
+*** In Dired, C-x C-q now runs the command wdired-change-to-wdired-mode,
+and C-x C-q in wdired-mode exits it with asking a question about
+saving changes.
+
+*** `&' runs the command `dired-do-async-shell-command' that executes
+the command asynchronously without the need to manually add ampersand
+to the end of the command. Its output appears in the buffer `*Async Shell
+Command*'.
+
+*** `M-s f C-s' and `M-s f M-C-s' run Isearch that matches only at file names.
+When a new user option `dired-isearch-filenames' is t, then even ordinary
+Isearch started with `C-s' and `C-M-s' matches only at file names in the
+Dired buffer. When `dired-isearch-filenames' is `dwim' then activation of
+file name Isearch depends on the position of point - if point is on a file
+name initially, then Isearch matches only file names, otherwise it matches
+everywhere in the Dired buffer. You can toggle file names matching on or
+off by typing `M-s f' in Isearch mode.
+
+*** `M-s a C-s' and `M-s a M-C-s' run multi-file Isearch on the marked files.
+They visit the first marked file in the sequence and display the usual Isearch
+prompt for a string or a regexp where all Isearch commands are available.
+
+*** `Q' in Dired provides two new keys for multi-file replacement.
+The upper case key `Y' replaces all remaining matches in all remaining files
+with no more questions. The upper case key `N' stops doing replacements
+in the current file and skips to the next file. These multi-file keys
+are available for all commands that use `tags-query-replace'
+including `dired-do-query-replace-regexp', `vc-dir-query-replace-regexp',
+`reftex-query-replace-document'.
+
+** Fortran
+
+*** The line length of fixed-form Fortran is not fixed at 72 any more.
+Customize the variable `fortran-line-length' to change it.
+
+*** In Fortran mode, M-; is now bound to the standard comment-dwim,
+rather than fortran-indent-comment.
+
+*** (The increasingly misnamed) F90 mode supports Fortran 2003 syntax.
+
+** Gnus
+
+*** The Gnus package has been updated
+There are many new features, bug fixes and improvements; see the file
+GNUS-NEWS or the node "No Gnus" in the Gnus manual for details.
+
+*** In Emacs 23, Gnus uses Emacs' new internal coding system `utf-8-emacs' for
+saving articles, drafts, and ~/.newsrc.eld. These file may not be read
+correctly in Emacs 22 and below. If you want to Gnus across different Emacs
+versions, you may set `mm-auto-save-coding-system' to `emacs-mule'.
+
+*** Passwords are consistently loaded through `auth-source'
+Gnus can use `auth-source' for POP and IMAP passwords. Also see that
+`smtpmail' and `url' support `auth-source' for SMTP and HTTP/HTTPS/RSS
+authentication respectively.
+
+** Help mode
+
+*** New macro `with-help-window' should set up help windows better
+than `with-output-to-temp-buffer' with `print-help-return-message'.
+
+*** New option `help-window-select' permits to customize whether help
+window shall be automatically selected when invoking help.
+
+*** New variable `help-window-point-marker' permits one to specify a new
+position for point in help window (for example in `view-lossage').
+
+** Isearch
+
+*** New command `isearch-forward-word' bound globally to `M-s w' starts
+incremental word search. New command `isearch-toggle-word' bound to the
+same key `M-s w' in Isearch mode toggles word searching on or off
+while Isearch is active.
+
+*** New command `isearch-highlight-regexp' bound to `M-s h r' in Isearch
+mode runs `highlight-regexp' (`hi-lock-face-buffer') with the current
+search string as its regexp argument. The same key `M-s h r' and
+other keys on the `M-s h' prefix are bound globally to the command
+`highlight-regexp' and other hi-lock commands.
+
+*** New command `isearch-occur' bound to `M-s o' in Isearch mode
+runs `occur' with the current search string. The same key `M-s o'
+is bound globally to the command `occur'.
+
+*** Isearch can now search through multiple ChangeLog files.
+When running Isearch in a ChangeLog file, if the search fails,
+then another C-s tries searching the previous ChangeLog,
+if there is one (e.g. going from ChangeLog to ChangeLog.12).
+This is enabled if multi-isearch-search is non-nil.
+
+*** Two new commands to start Isearch on a list of marked buffers
+for buff-menu.el and ibuffer.el are bound to the keys `M-s a C-s' and
+`M-s a M-C-s'.
+
+*** The part of an Isearch that failed to match is highlighted in
+`isearch-fail' face.
+
+*** `C-h C-h' in Isearch mode displays isearch-specific Help screen,
+`C-h b' displays all Isearch key bindings, `C-h k' displays the full
+documentation of the given Isearch key sequence, `C-h m' displays
+documentation for Isearch mode. All the other Help commands exit
+Isearch mode and execute their global definitions.
+
+*** When started in the minibuffer, Isearch searches in the minibuffer
+history. See `Minibuffer changes', above.
+
+** MH-E
+
+*** Upgraded to MH-E version 8.2. See MH-E-NEWS for details.
+
+** Python
+*** The file etc/emacs.py now supports both Python 2 and 3, meaning
+that either version can be used as inferior Python by python.el.
+
+*** Python mode now has `pdbtrack' functionality. When using pdb to
+debug a Python program, pdbtrack notices the pdb prompt and displays
+the source file and line that the program is stopped at, much the same
+way as gud-mode does for debugging C programs with gdb.
+
+** Recentf
+
+*** The default value of `recentf-keep' prevents from checking of
+remote files, if there is no established connection to the
+corresponding remote host.
+
+** Rmail
+
+*** Rmail no longer converts the messages to Babyl format.
+Instead, it uses UNIX mbox format, both on disk and in Rmail buffers,
+and does conversion and decoding when a message is displayed.
+
+The first time you visit an Rmail file in Babyl format, Rmail
+automatically converts it to mbox format. This is a one-time
+conversion, but it can take a few minutes, depending on how fast is
+your machine and on the size of the file. You should find the rest of
+Rmail usage unaltered.
+
+However, M-x set-rmail-inbox-list now lasts only for one session
+because there is no way to save the list of inbox files in an
+mbox-format file.
+
+Also, whereas with Babyl format M-x find-file would switch to Rmail
+mode, with mbox format this is no longer the case (there being no way
+to add an "-*- rmail-*-" cookie to an mbox file). Use C-u M-x rmail
+instead.
+
+If you have written any extensions to Rmail, they are likely to need
+updating. Conceptually, the Rmail buffer that you see is no longer
+just a narrowed portion of the whole. So you cannot access the whole
+of a message (or message collection) by a simple save-restriction and
+widen. Instead, there are two buffers: the rmail-buffer, and the
+rmail-view-buffer. The former is the buffer that you see, the latter
+is invisible. Most of the time, the invisible `view' buffer contains
+the full contents of the Rmail file, and the Rmail buffer contains a
+decoded copy of the current message (with only a subset of the
+headers). In this state, Rmail is said to be `swapped'.
+
+You may find the following functions useful:
+
+`rmail-get-header' and `rmail-set-header' get or set the value of a
+message header, whether or not it is currently visible.
+
+`rmail-apply-in-message' is a general purpose function that calls a
+function (with arguments) which you specify on the full text of a given
+message. To further narrow to just the headers, search forward for "\n\n".
+
+*** The new command `rmail-mime' displays MIME messages.
+It is bound to `v' in Rmail buffers and summaries. It displays plain
+text and multipart messages in a temporary buffer, and offers buttons
+to save attachments.
+
+*** The command `rmail-redecode-body' no longer accepts the optional arg RAW.
+Since Rmail now holds messages in their original undecoded form in a
+separate buffer, `rmail-redecode-body' no longer encodes the original
+message, and therefore there should be no need to avoid encoding it.
+
+*** The o command is now `rmail-output'. It is an all-purpose command
+for copying messages from Rmail and appending them to files. It
+handles Babyl-format files as well as mbox-format files, and it
+handles both kinds properly when they are visited in Emacs. It always
+copies the full headers of the message.
+
+*** The C-o command is now `rmail-output-as-seen'. It uses
+the message as displayed, appending it to an mbox file.
+
+*** The modified status of the Rmail buffer is reported in the mode-line.
+Previously, this information was hidden.
+
+** TeX modes
+
+*** New option latex-indent-within-escaped-parens
+permits to customize indentation of LaTeX environments delimited
+by escaped parens.
+
+** T-mouse Mode
+
+*** If the gpm mouse server is running and t-mouse-mode is enabled,
+Emacs uses a Unix socket in a GNU/Linux console to talk to server,
+rather than faking events using the client program mev. This C level
+approach provides mouse highlighting and help echoing in the
+minibuffer.
+
+** Tramp
+
+*** New connection methods.
+The new methods "plinkx", "plink2", "psftp", "sftp" and "fish" have
+been introduced. There are also new so-called gateway methods
+"tunnel" and "socks".
+
+*** IPv6 addresses.
+IPv6 addresses are supported now as host names. They must be embedded
+in square brackets, like in "/ssh:[::1]:".
+
+*** Multihop syntax has been removed.
+The pseudo-method "multi" has been removed. Instead, multi hops
+can be specified by the new variable `tramp-default-proxies-alist'.
+
+*** More default settings.
+Default values can be set via the variables `tramp-default-user',
+`tramp-default-user-alist' and `tramp-default-host'.
+
+*** Connection information is cached.
+In order to reduce connection setup, information about used
+connections is kept persistently in a file. The name of this file is
+defined in the variable `tramp-persistency-file-name'.
+
+*** Control of remote processes.
+Running processes on a remote host can be controlled by settings in
+`tramp-remote-path' and `tramp-remote-process-environment'.
+
+*** Success of remote copy is checked.
+When the variable `file-precious-flag' is set, the success of a remote
+file copy is checked via the file's checksum.
+
+*** Passwords can be read from an authentification file.
+Tramp uses the package `auth-source' to read passwords from a file, if
+necessary.
+
+** VC and related modes
+
+*** VC now supports applying VC operations to a set of files at a time.
+This enables VC to work much more effectively with changeset-oriented
+version-control systems such as Subversion, GNU Arch, Mercurial, Git
+and Bzr. VC will now pass a multiple-file commit to these systems as
+a single changeset.
+
+*** vc-dir is a new command that displays file names and their VC
+status. It allows to apply various VC operations to a file, a
+directory or a set of files/directories.
+
+*** VC switches are no longer appended, rather the first non-nil value is used.
+(This was for the most part true in Emacs 22, but was not advertised).
+This is because there is an increasing variety of VC systems, and they
+do not all accept the same "common" options. For example, a CVS diff
+command used to append the values of `vc-cvs-diff-switches',
+`vc-diff-switches', and `diff-switches'. Now the first non-nil value
+from that sequence is used. The special value `t' means "no switches".
+
+*** Clicking on the VC mode-line entry now pops the VC menu.
+
+*** The VC mode-line entry now has a tooltip that explains the VC file status.
+
+*** In VC Annotate mode, the key bindings have changed to use lower
+case keys instead of the upper case keys used in the past.
+
+*** In VC Annotate mode, for VC systems that support changesets, you can
+see the diff for the whole changeset (not only for the current file)
+by typing the D key. Using the "Show changeset diff of revision at
+line" menu entry does the same thing.
+
+*** In VC Annotate mode, you can type v to toggle the annotation visibility.
+
+*** In VC Annotate mode, you can type f to show the file revision on
+the current line.
+
+*** Asynchronous VC commands display [Waiting...] in the mode-line
+of the corresponding buffer as long as the asynchronous process is
+active.
+
+*** Log entries can be modified using the key "e" in log-view.
+For now only CVS, RCS, SCCS and SVN support this functionality.
+This is done by the `modify-change-comment' backend function.
+
+*** In log-view-mode, for VC systems that support changesets, you can
+see the diff for the whole changeset (not only for the current file)
+by typing the D key or using the "Changeset Diff" menu entry.
+
+*** In Log Edit mode, C-c C-d now shows the diff for the files involved.
+
+*** vc-git supports the "git grep" command.
+
+*** VC Support for Meta-CVS has been removed for lack of a maintainer able
+to update it to the new VC.
+
+** Miscellaneous
+
+*** comint-mode uses `start-file-process' now (see Lisp Changes).
+If `default-directory' is a remote file name, subprocesses are started
+on the corresponding remote system.
+
+*** Eldoc highlights the function argument under point
+with the face `eldoc-highlight-function-argument'.
+
+*** In Etags, the --members option is now the default.
+Use --no-members if you want the old default behavior of not tagging
+struct members in C, members variables in C++ and variables in PHP.
+
+*** The `gdb' command only works with the graphical interface now.
+Use `gud-gdb' if you want the (old) text command mode.
+
+*** goto-address.el provides two new minor modes, goto-address-mode and
+goto-address-prog-mode, which buttonize URLS and email addresses.
+
+*** The new command `eshell/info' runs info in an eshell buffer.
+
+*** The new variable `ffap-rfc-directories' specifies a list of local
+directories in which `ffap-rfc' will first search for RFCs.
+
+*** hide-ifdef-mode allows shadowing ifdef-blocks instead of hiding them.
+See option `hide-ifdef-shadow' and function `hide-ifdef-toggle-shadowing'.
+
+*** `icomplete-prospects-height' now supercedes `icomplete-prospects-length'.
+
+*** Info displays breadcrumbs in the header of the page.
+See Info-breadcrumbs-depth to control it.
+
+*** net-utils has an `iwconfig' command, similar to the existing `ifconfig'.
+It is used to configure wireless interfaces.
+
+*** The pcmpl-unix package supports hostname completion for ssh and scp.
+
+*** sgml-electric-tag-pair-mode lets you simultaneously edit matched tag pairs.
+
+*** smerge-refine highlights word-level details of changes in conflict.
+It's used automatically as you move through conflicts, see
+smerge-auto-refine-mode.
+
+*** talk.el has been extended for multiple tty support.
+
+*** A new command `display-time-world' has been added to the Time
+package. It creates a buffer with an updating time display using
+several time zones.
+
+*** The appearance of superscript and subscript in TeX is more customizable.
+See the documentation of the variables: tex-fontify-script,
+tex-font-script-display, tex-suscript-height-ratio, and
+tex-suscript-height-minimum.
+
+*** view-remove-frame-by-deleting is now by default t
+since users found iconification of view-mode frames distracting.
+
+*** WoMan tries to add locale-specific manual page directories to the
+search path. This can be disabled by setting `woman-locale' to nil.
+
+\f
+* Changes in Emacs 23.1 on non-free operating systems
+
+** Case is now considered significant in completion on MS-Windows.
+The default value of `completion-ignore-case' is now nil on
+MS-Windows, the same as it is for other operating systems. The
+variable doesn't apply to reading a file name -- in that case Emacs
+heeds `read-file-name-completion-ignore-case' instead.
+
+** IPv6 is supported on MS-Windows.
+Emacs now supports IPv6 on Windows XP and later, and earlier versions
+of Windows with third party IPv6 stacks installed. In Emacs 22, IPv6 was
+supported on other platforms, but not on Windows due to using the winsock
+1.1 header file, even though Emacs was linking to the winsock 2 library.
+
+** Busy cursor (hourglass) now displays on MS-Windows.
+When Emacs is busy, an hourglass mouse cursor is displayed on Windows.
+In Emacs 22 only X supported the busy cursor.
+
+** Battery status is available on MS-Windows
+Emacs can now display the battery status in the mode-line when enabled with
+display-battery-mode or from the Options menu. More verbose battery
+information is also available with the command `battery'. In Emacs 22
+battery status was supported only on GNU/Linux and Mac.
+
+** More keys available on MS-Windows.
+Keys normally associated with IMEs, and some exotic keys not normally found
+on standard keyboards have been given names so they can be bound to functions
+inside Emacs. If there are keys on your keyboard that have not been exposed
+to Emacs in the past, try C-h k to see if they are available now.
+
+Emacs can now bind functions to the extra buttons for media player and
+browser control present on some keyboards. These buttons are disabled
+by default, since enabling them prevents their system-wide use when
+Emacs has focus. To enable them, set the variable
+w32-pass-multimedia-buttons to nil. See the doc string of that variable
+for the list of extra keys that are available.
+
+** BDF fonts no longer supported on MS-Windows.
+The font backend was completely rewritten for this release. The focus
+on Windows has been getting acceptable performance and full unicode
+support, including complex script shaping for native Windows fonts. A
+rewrite of the BDF font support has not happened due to lack of time
+and developers. If demand still exists for such a backend even with
+the improved language support for native Windows fonts, future
+development in this direction will most likely be based on the
+freetype library, giving access to a wider range of font formats.
+
+\f
+* Incompatible Lisp Changes in Emacs 23.1
+
+** Variables cannot be both buffer-local and frame-local any more.
+
+** `functionp' returns nil for special forms.
+I.e., it only returns t for objects that can be passed to `funcall'.
+
+** The behavior of map-char-table has changed. It may call the
+specified function with a cons (FROM . TO) as a key if characters in
+that range have the same value.
+
+** Process changes
+
+*** The function `dired-call-process' has been removed.
+
+*** The multibyteness of process filters is now determined by the
+coding-system used for decoding. The functions
+`process-filter-multibyte-p' and `set-process-filter-multibyte' are
+obsolete.
+
+** The variable `byte-compile-warnings' can now be a list starting with `not',
+meaning to disable the specified warnings. The meaning of this list
+may therefore be the reverse of what you expect (of course, this is
+only an issue if you make use of the new `not' syntax). Rather than
+checking/manipulating elements directly, use the new functions
+`byte-compile-warning-enabled-p', `byte-compile-disable-warning', and
+`byte-compile-enable-warning.'
+
+** `mode-name' is no longer guaranteed to be a string.
+Use `(format-mode-line mode-name)' to ensure a string value.
+
+** The function x-font-family-list has been removed.
+Use the new function font-family-list (see Lisp Changes, below).
+
+** Internationalization changes
+
+*** The value of the function `charset-id' is now always 0.
+
+*** The functions `register-char-codings' and `coding-system-spec'
+have been removed.
+
+*** The cpXXX coding systems are now supported automatically.
+The functions cp-...-codepage, which you had to use in Emacs 22 to
+enable support for these coding systems, have been deleted.
+
+*** The following features have been removed. They were used for
+displaying various scripts with specific fonts, and are no longer
+needed now that OpenType font support is available:
+
+**** `devanagari' and `devan-util', and all associated devanagari-* and
+dev-* functions and variables (formerly used for Devanagari script).
+
+**** `kannada' and `knd-util', and all associated kannada-* and knd-*
+functions and variables (formerly used for Kannada script).
+
+**** `malayalam' and `mlm-util', and all associated malayalam-* and
+mlm-* functions and variables (formerly used for Malayalam script).
+
+**** `tamil' and `tml-util, and all associated tamil-* and tml-*
+functions and variables (formerly used for Tamil script).
+
+*** The meaning of NAME argument of `set-fontset-font' is changed.
+Previously nil is accepted as the default fontset. Now, nil is for
+the fontset of the selected frame and t is for the default fontset.
+
+*** The meaning of FONTSET argument of `print-fontset' is changed.
+Now, nil is for the fontset of the selected frame and t is for the
+default fontset.
+
+** If a function in write-region-annotate-functions returns with a
+different buffer current, Emacs no longer kills that buffer
+automatically. This behavior existed in previous versions of Emacs,
+but was undocumented. To kill a buffer after write-region, give the
+variable `write-region-post-annotation-function' a buffer-local value
+of `kill-buffer'.
+
+** The variable temp-file-name-pattern has been removed.
+This variable was only used by call-process-region, which now uses
+temporary-file-directory instead.
+
+** The COUNT and SYSTEM-FLAG arguments to define-abbrev have been
+removed. The function now takes extra arguments for specifying
+arbitrary abbrev properties.
+
+** end-of-defun-function is now guaranteed to work only when called
+from the start of a defun. It must now leave point exactly at the end
+of defun, since `end-of-defun' now itself moves forward over
+whitespace after calling it.
+
+\f
+* Lisp Changes in Emacs 23.1
+
+** The new variable `generate-autoload-cookie' controls the magic comment
+string used by `update-file-autoloads' to find autoloaded forms. The
+variable `generated-autoload-file' similarly controls the name of the
+file where `update-file-autoloads' writes the calls to `autoload'.
+The default values are ";;;###autoload" and `loaddefs.el',
+respectively.
+
+** New primitives `list-system-processes' and `process-attributes'
+let Lisp programs access the processes that are running on the local
+machine. See the doc strings of these functions for more details.
+Not all platforms support accessing this information; on those that
+don't, these primitives will return nil.
+
+** New variable `user-emacs-directory'.
+Use this instead of "~/.emacs.d".
+
+** If a local hook function has a non-nil `permanent-local-hook'
+property, `kill-all-local-variables' does not remove it from the local
+value of the hook variable; it remains even if you change major modes.
+
+** `frame-inherited-parameters' lets new frames inherit parameters from
+the selected frame.
+
+** New keymap `input-decode-map' overrides like key-translation-map, but
+applies before function-key-map. Also it is terminal-local contrary to
+key-translation-map. Terminal-specific key-sequences are generally added to
+this map rather than to function-key-map now.
+
+** `ignore-errors' is now a standard macro (does not require the CL package).
+
+** `interprogram-paste-function' can now return one string or a list
+of strings. In the latter case, Emacs puts the second and following
+strings on the kill ring.
+
+** In `condition-case', a handler can specify "let the debugger run first".
+You do this by writing `debug' in the list of conditions to be handled,
+like this:
+
+ (condition-case nil
+ (foo bar)
+ ((debug error) nil))
+
+** clone-indirect-buffer now runs the clone-indirect-buffer-hook.
+
+** `beginning-of-defun-function' now takes one argument, the count given to
+`beginning-of-defun'. (N.B. `end-of-defun-function' doesn't take any
+arguments.)
+
+** `file-remote-p' has new optional parameters IDENTIFICATION and CONNECTED.
+IDENTIFICATION specifies which part of the remote identifier has to be
+returned. With CONNECTED passed non-nil, it is checked whether a
+remote connection has been established already.
+
+** The new macro `declare-function' suppresses compiler warnings about
+undefined functions.
+
+** Changes to interactive function handling
+
+*** The new interactive spec code ^ says to first call
+handle-shift-selection if shift-select-mode is non-nil, before reading
+the command arguments. This is used for shift-selection (see above).
+
+*** Built-in functions can now have an interactive specification that
+is not a prompt string. If the `intspec' parameter of a `DEFUN'
+starts with a `(', the string is evaluated as a Lisp form.
+
+*** The interactive-form of a function can be added post-facto via the
+`interactive-form' symbol property. Mostly useful to add complex
+interactive forms to subroutines.
+
+** Region changes
+
+*** Commands should use `use-region-p' to test whether there is
+an active region that they should operate on.
+
+*** `region-active-p' returns non-nil when Transient Mark mode is
+enabled and the mark is active. Most commands that act specially on
+the active region in Transient Mark mode should use `use-region-p'
+instead of `region-active-p', because `use-region-p' obeys the new
+user option `use-empty-active-region' (see Editing Changes, above).
+
+*** If a command sets `transient-mark-mode' to (only . OLDVAL), that
+means to activate transient-mark-mode temporarily, until the next
+unshifted point motion command or mark deactivation. Afterwards,
+reset transient-mark-mode to the value OLDVAL. The values `only' and
+`identity', introduced in Emacs 22, are now deprecated.
+
+** Emacs session information
+
+*** The new variables `before-init-time' and `after-init-time' record the
+value of `current-time' before and after Emacs loads the init files.
+
+*** The new function `emacs-uptime' returns the uptime of an Emacs instance.
+
+*** The new function `emacs-init-time' returns the duration of the
+Emacs initialization.
+
+** Changes affecting display-buffer
+
+*** display-buffer tries to be smarter when splitting windows.
+The new option split-window-preferred-function lets you specify your own
+function to pop up new windows. Its default value split-window-sensibly
+can split a window either vertically or horizontally, whichever seems
+more suitable in the current configuration. You can tune the behavior
+of split-window-sensibly by customizing split-height-threshold and the
+new option split-width-threshold. Both options now take the value nil
+to inhibit splitting in one direction. Setting split-width-threshold to
+nil inhibits horizontal splitting and gets you the behavior of Emacs 22
+in this respect. In any case, display-buffer may now split the largest
+window vertically even when it is not as wide as the containing frame.
+
+*** If pop-up-frames has the value `graphic-only', display-buffer only
+makes a separate frame on graphic displays.
+
+*** select-frame and set-frame-selected-window have a new optional
+argument NORECORD. If non-nil, this will avoid messing with the order
+of recently selected windows and the buffer list.
+
+** Window parameters can now be defined.
+These are analogous to frame parameters, but are associated with
+individual windows.
+
+*** The new functions window-parameters, window-parameter, and
+set-window-parameter are used to query and set window parameters.
+
+** Minibuffer and completion changes
+
+*** A list of default values can be specified for the DEFAULT argument of
+functions `read-from-minibuffer', `read-string', `read-command',
+`read-variable', `read-buffer', `completing-read'. Elements of this list
+are available for inserting into the minibuffer by typing `M-n'.
+For empty input these functions return the first element of this list.
+
+*** New function `read-regexp' uses the regexp history and some useful
+regexp defaults (string at point, last Isearch/replacement regexp/string)
+via M-n when reading a regexp in the minibuffer.
+
+*** minibuffer-local-must-match-filename-map is now named
+minibuffer-local-filename-must-match-map.
+
+*** The `require-match' argument to `completing-read' accepts the new
+values `confirm-only' and `confirm-after-completion'.
+
+** Search and replacement changes
+
+*** The regexp form \(?<num>:<regexp>\) specifies the group number explicitly.
+
+*** New function `match-substitute-replacement' returns the result of
+`replace-match' without actually using it in the buffer.
+
+*** The new variable `replace-search-function' determines the function
+to use for searching in query-replace and replace-string. The
+function it specifies is called by `perform-replace' when its 4th
+argument is nil.
+
+*** The new variable `replace-re-search-function' determines the
+function to use for searching in `query-replace-regexp',
+`replace-regexp', `query-replace-regexp-eval', and
+`map-query-replace-regexp'. The function it specifies is called by
+`perform-replace' when its 4th argument is non-nil.
+
+*** New keymap `search-map' bound to `M-s' provides global bindings
+for search related commands.
+
+*** New keymap `multi-query-replace-map' contains additonal keys bound
+to `automatic-all' and `exit-current' for multi-buffer interactive replacement.
+
+*** The variable `inhibit-changing-match-data', if non-nil, prevents
+the search and match primitives from changing the match data.
+
+*** New functions `word-search-forward-lax' and `word-search-backward-lax'.
+These are like `word-search-forward and `word-search-backward', except
+that the end of the search string need not match a word boundary,
+unless it ends in whitespace.
+
+** File handling changes
+
+*** set-file-modes is now interactive and can take the mode value in
+symbolic notation thanks to auxiliary functions.
+
+*** file-local-variables-alist stores an alist of file-local
+variables defined in the current buffer.
+
+** Face-remapping
+
+*** Each face can be remapped to a different face definition using the
+variable `face-remapping-alist'. This is an alist that maps faces to
+replacement definitions (which can be face names, lists of face names,
+or attribute/value plists. If this variable is buffer-local, the
+remapping occurs only in that buffer.
+
+*** text-scale-mode remaps the default face to a larger or smaller
+size in the current buffer. This feature is used by the Buffer Face
+menu and the new `C-x C-+', `C-x C--', and `C-x C-0' commands (see
+Editing Changes, above).
+
+*** New functions:
+
+**** `face-remap-add-relative' adds a face remapping entry to the
+current buffer.
+
+**** ``face-remap-remove-relative' removes a face remapping entry from
+the current buffer.
+
+**** `face-remap-reset-base' restores a face to its global definition.
+
+**** `face-remap-set-base' sets the base remapping of a face.
+
+** Process changes
+
+*** The new function `start-file-process' is similar to `start-process',
+but obeys file handlers. The file handler is chosen based on
+`default-directory'. The functions `start-file-process-shell-command'
+and `process-file-shell-command' are also new; they call internally
+`start-file-process' and `process-file', respectively.
+
+*** The new function `process-lines' executes an external program and
+returns its output as a list of lines.
+
+** Character code, representation, and charset changes.
+
+*** In multibyte buffers and strings, characters are represented by
+UTF-8 byte sequences. The character code space is now 0x0..0x3FFFFF
+with no gap; code points 0x0..0x10FFFF are Unicode characters of the
+same code points, while code points 0x3FFF80..0x3FFFFF are raw 8-bit
+bytes.
+
+*** Generic characters no longer exist.
+
+*** The concept of a charset has changed. A single character may
+belong to multiple charsets (e.g. a-grave, U+00E0, belongs to charsets
+unicode, iso-8859-1, iso-8859-3, etc).
+
+**** The dimension of a charset is now 1, 2, 3, or 4, and the size of
+each dimension is no longer limited to 94 or 96.
+
+**** A dynamic charset priority list is used to infer the charset of
+characters for display.
+
+*** The functions `split-char' and `make-char' now accept up to 4
+positional codes instead of just 2.
+
+*** The functions `encode-char' and `decode-char' now accept any character sets.
+
+*** The function `define-charset' now accepts a completely different
+form of arguments (old-style arguments still work).
+
+*** The value of the function `char-charset' depends on the current
+priorities of charsets.
+
+*** The function get-char-code-property now accepts many Unicode base
+character properties. They are `name', `general-category',
+`canonical-combining-class', `bidi-class', `decomposition',
+`decimal-digit-value', `digit-value', `numeric-value', `mirrored',
+`old-name', `iso-10646-comment', `uppercase', `lowercase', and
+`titlecase'.
+
+*** The functions `modify-syntax-entry' and `modify-category-entry' now
+accept a cons of characters as the first argument, and modify all
+entries in that range of characters.
+
+*** Use of `translation-table-for-input' for character code unification
+is now obsolete, since Emacs 23.1 and later uses Unicode as basis for
+internal representation of characters.
+
+*** New functions:
+
+**** `characterp' returns t if and only if the argument is a character.
+This replaces `char-valid-p', which is now obsolete.
+
+**** `max-char' returns the maximum character code (currently #x3FFFFF).
+
+**** `define-charset-alias' defines an alias of a charset.
+
+**** `set-charset-priority' sets priorities of charsets.
+
+**** `charset-priority-list' returns a prioritized list of charsets.
+
+**** `unibyte-string' makes a unibyte string from bytes.
+
+**** `define-char-code-property' defines a character code property.
+
+**** `char-code-property-description' returns the description string of
+a character code property.
+
+*** New variables:
+
+**** `find-word-boundary-function-table' is a char-table of functions to
+search for a word boundary.
+
+**** `char-script-table' is a char-table of script names.
+
+**** `char-width-table' is a char-table of character widths.
+
+**** `print-charset-text-property' controls how to handle `charset' text
+property on printing a string.
+
+**** `printable-chars' is a char-table of printable characters.
+
+** Code conversion changes
+
+*** The new function `define-coding-system' should be used to define a
+coding system instead of `make-coding-system' (which is now obsolete).
+
+*** The functions `encode-coding-region' and `decode-coding-region'
+have an optional 4th argument to specify where the result of
+conversion should go.
+
+*** The functions `encode-coding-string' and `decode-coding-string'
+have an optional 4th argument specifying a buffer to store the result
+of conversion.
+
+*** The new variable `inhibit-null-byte-detection' controls whether to
+consider text with null bytes as binary data. By default, it is
+`nil', and Emacs uses `no-conversion' for any text containing null
+bytes.
+
+*** The functions `set-coding-priority' and `make-coding-system' are obsolete.
+
+*** New functions:
+
+**** `with-coding-priority' executes Lisp code using the specified
+coding system priority order.
+
+**** `check-coding-systems-region' checks if the text in the region is
+encodable by the specified coding systems.
+
+**** `coding-system-aliases' returns a list of aliases of a coding system.
+
+**** `coding-system-charset-list' returns a list of charsets supported
+by a coding system.
+
+**** `coding-system-priority-list' returns a list of coding systems
+ordered by their priorities.
+
+**** `set-coding-system-priority' sets priorities of coding systems.
+
+**** `coding-system-from-name' returns a coding system matching with
+the argument name.
+
+** There is a new input method, Robin, different from Quail.
+It has three functionalities:
+ i) a simple input method (converts an ASCII sequence into a string).
+ii) converts an existing buffer substring into another string
+iii) reverse conversion (each character produced by a
+robin rule can hold the original ASCII sequence as a char-code-property)
+
+*** The new function `robin-define-package' defines a Robin package.
+
+*** The new function `robin-modify-package' modifies an existing Robin package.
+
+*** The new function `robin-use-package' starts using a Robin package
+as an input method.
+
+*** The new function `string-to-unibyte' is like `string-as-unibyte'
+but signals an error if STRING contains a non-ASCII, non-eight-bit
+character.
+
+** Changes related to the new font backend
+
+*** Which font backends to use can be specified by the X resource
+"FontBackend". For instance, to use both X core fonts and Xft fonts:
+
+Emacs.FontBackend: x,xft
+
+If this resource is not set, Emacs tries to use all font backends
+available on your graphic device.
+
+*** New frame parameter `font-backend' specifies a list of
+font-backends supported by the frame's graphic device. On X, they are
+currently `x' and `xft'.
+
+*** The function `set-fontset-font' now accepts a script name as the
+second argument, and has an optional 5th argument to control how to
+set the font.
+
+*** New functions:
+
+**** `fontp' checks if the argument is a font-spec or font-entity.
+
+**** `font-spec' creates a new font-spec object.
+
+**** `font-get' returns a font property value.
+
+**** `font-put' sets a font property value.
+
+**** `font-face-attributes' returns a plist of face attributes set by a font.
+
+**** `list-fonts' returns a list of font-entities matching a font spec.
+
+**** `find-font' returns the font-entity best matching the given font spec.
+
+**** `font-family-list' returns a list of family names of available fonts.
+
+**** `font-xlfd-name' returns an XLFD name of a given font spec, font
+entity, or font object.
+
+**** `clear-font-cache' clears all font caches.
+
+** Changes related to multiple-terminal (multi-tty) support
+
+*** $TERM is now set to `dumb' for subprocesses. If you want to know the
+$TERM inherited by Emacs you will have to look inside initial-environment.
+
+*** $DISPLAY is now dynamically inherited from the frame's `display'.
+
+*** The `window-system' variable is now frame-local. The new
+`initial-window-system' variable contains the `window-system' value
+for the first frame. `window-system' is also now a function that
+takes a frame argument.
+
+*** The `keyboard-translate-table' variable and the terminal and
+keyboard coding systems are now terminal-local.
+
+*** You can specify a terminal device (`tty' parameter) and a terminal
+type (`tty-type' parameter) to `make-terminal-frame'.
+
+*** The function `make-frame-on-display' now works during a tty
+session.
+
+*** A new `terminal' data type.
+The functions `get-device-terminal', `terminal-parameters',
+`terminal-parameter', `set-terminal-parameter' use this data type.
+
+*** Function key sequences are now mapped using `local-function-key-map',
+a new variable. This inherits from the global variable function-key-map,
+which is not used directly any more.
+
+*** New hooks:
+
+**** before-hack-local-variables-hook is called after setting new
+variable file-local-variables-alist, and before actually applying the
+file-local variables.
+
+**** `suspend-tty-functions' and `resume-tty-functions' are called
+after a tty frame has been suspended or resumed, respectively. The
+functions are called with the terminal id of the frame being
+suspended/resumed as a parameter.
+
+**** The special hook `delete-terminal-functions' is called before
+deleting a terminal.
+
+*** New functions:
+
+**** `delete-terminal'
+
+**** `suspend-tty'
+
+**** `resume-tty'.
+
+*** `initial-environment' holds the environment inherited from Emacs's parent.
+
+** Redisplay changes
+
+*** For underlined characters, the distance between the underline and
+the baseline is controlled by a new variable, `underline-minimum-offset'.
+
+*** You can now pass the value of the `invisible' property to
+invisible-p to check whether it would cause the text to be invisible.
+This is convenient when checking invisibility of text with no buffer
+position (e.g. in before/after-strings).
+
+*** `clear-image-cache' can be told to flush only images of a specific file.
+
+*** `vertical-motion' can now be given a goal column.
+It now accepts a cons cell (COLS . LINES) in its first argument, which
+says to stop, where possible, at a pixel x-position equal to COLS
+times the default column width.
+
+*** redisplay-end-trigger-functions, set-window-redisplay-end-trigger,
+and window-redisplay-end-trigger are obsolete. Use `jit-lock-register'
+instead.
+
+*** The new variables `wrap-prefix' and `line-prefix' specify display
+specs which are appended at display-time to every continuation line
+and non-continuation line, respectively. In addition, Emacs
+recognizes the `wrap-prefix' and `line-prefix' text or overlay
+properties; these have the same effects as the variables of the same
+name, but take precedence.
+
+** The Lisp interpreter now treats non-breaking space as whitespace.
+
+** Miscellaneous new functions
+
+*** `apply-partially' performs a "curried" application of a function.
+
+*** `buffer-swap-text' swaps text between two buffers. This can be
+useful for modes such as tar-mode, archive-mode, RMAIL.
+
+*** `combine-and-quote-strings' produces a single string from a list of strings
+sticking a separator string in between each pair, and quoting those
+strings that include the separator as their substring. Useful for
+consing shell command lines from the individual arguments.
+
+*** `custom-note-var-changed' tells Custom to treat the change in a
+certain variable as having been made within Custom.
+
+*** `face-all-attributes' returns an alist describing all the basic
+attributes of a given face.
+
+*** `format-seconds' converts a number of seconds into a readable
+string of days, hours, etc.
+
+*** `image-refresh' refreshes all images associated with a given image
+specification.
+
+*** `locate-user-emacs-file' helps packages to select the appropriate
+place to save user-specific files. It defaults to `user-emacs-directory'
+unless the file already exists at $HOME.
+
+*** `read-color' reads a color name using the minibuffer.
+
+*** `read-shell-command' does what its name says, with completion. It
+uses the minibuffer-local-shell-command-map for that.
+
+*** `split-string-and-unquote' splits a string into a list of substrings
+on the boundaries of a given delimiter, and unquotes the substrings that
+are quoted. Useful for taking apart shell commands.
+
+*** The two new functions `looking-at-p' and `string-match-p' can do
+the same matching as `looking-at' and `string-match' without changing
+the match data.
+
+*** The two new functions `make-serial-process' and
+`serial-process-configure' provide a Lisp interface to the new serial
+port support (see Emacs changes, above).
+
+** Miscellaneous new variables
+
+*** `auto-save-include-big-deletions', if non-nil, means auto-save is
+not turned off automatically after a big deletion.
+
+*** `read-circle', if nil, disables the reading of recursive Lisp
+structures using the #N= and #N# syntax.
+
+*** `this-command-keys-shift-translated' is non-nil if the key
+sequence invoking the current command was found by shift-translation.
+
+*** `window-point-insertion-type' determines the insertion-type of the
+marker used for window-point.
+
+*** bookmark provides `bookmark-make-record-function' so special major
+modes like Info can teach bookmark.el how to save and restore the
+relevant data.
+
+*** `fill-forward-paragraph-function' specifies which function the
+filling code should use to find paragraph boundaries.
+
+\f
+* New Packages for Lisp Programming in Emacs 23.1
+
+** The new package avl-tree.el deals with the AVL tree data structure.
+
+** The new package check-declare.el verifies the accuracy of
+declare-function macros (see Lisp Changes, above).
+
+** find-cmd.el can build `find' commands using lisp syntax.
+
+** The package misearch.el has been added. It allows Isearch to search
+through multiple buffers. A variable `multi-isearch-next-buffer-function'
+defines the function to call to get the next buffer to search in the series
+of multiple buffers. Top-level functions `multi-isearch-buffers',
+`multi-isearch-buffers-regexp', `multi-isearch-files' and
+`multi-isearch-files-regexp' accept a single argument that specifies
+a list of buffers/files to search for a string/regexp.
+
+** The new major mode `special-mode' is intended as a parent for
+major modes such as those that set the "'mode-class 'special" property.
+
+\f
+----------------------------------------------------------------------
+This file is part of GNU Emacs.
+
+GNU Emacs is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+\f
+Local variables:
+mode: outline
+paragraph-separate: "[ \f]*$"
+end:
+
+arch-tag: e759449d-88b3-4de4-9900-3a6c3dfa23e2
Files: splash.png, splash.svg
Author: Francesc Rocher <rocher@member.fsf.org>
- Copyright (C) 2008, 2009, 2010 Free Software Foundation, Inc.
+ Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+Files: checked.xpm, unchecked.xpm
+ Author: Chong Yidong <cyd@stupidchicken.com>
+ Copyright (C) 2010 Free Software Foundation, Inc.
+
* The following icons are from GTK+ 2.x. They are not part of Emacs, but
are distributed and used by Emacs. They are licensed under the
% Reference Card for Org Mode
-\def\orgversionnumber{6.33x}
-\def\versionyear{2009} % latest update
+\def\orgversionnumber{7.4}
+\def\versionyear{2010} % latest update
- \def\year{2010} % latest copyright year
+ \def\year{2011} % latest copyright year
%**start of header
\newcount\columnsperpage
-2011-01-03 Brent Goodrick <bgoodr@gmail.com> (tiny change)
++2011-01-14 Brent Goodrick <bgoodr@gmail.com> (tiny change)
+
+ * abbrev.el (prepare-abbrev-list-buffer): If listing local abbrev
+ table, get the value before switching to the output buffer. (Bug#7733)
+
-2011-01-03 Stefan Monnier <monnier@iro.umontreal.ca>
++2011-01-14 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * progmodes/python.el (python-mode): Don't impose font-lock (bug#3628).
+
-2011-01-02 Stefan Monnier <monnier@iro.umontreal.ca>
++2011-01-14 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * files.el (file-local-variables-alist):
+ Make permanent-local (bug#7767).
+
-2011-01-02 Glenn Morris <rgm@gnu.org>
++2011-01-14 Glenn Morris <rgm@gnu.org>
+
+ * version.el (emacs-copyright): Set short copyright year to 2011.
+
-2011-01-02 Mark Lillibridge <mark.lillibridge@hp.com> (tiny change)
++2011-01-14 Mark Lillibridge <mark.lillibridge@hp.com> (tiny change)
+
+ * mail/mail-utils.el (mail-strip-quoted-names): Avoid clobbering
+ an existing temp buffer. (Bug#7746)
+
-2011-01-02 Glenn Morris <rgm@gnu.org>
++2011-01-14 Glenn Morris <rgm@gnu.org>
+
+ * mail/mail-utils.el (mail-mbox-from): Handle From: headers with
+ multiple addresses. (Bug#7760)
+
-2010-12-31 Michael Albinus <michael.albinus@gmx.de>
++2011-01-14 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-methods): Add recursive options to "scpc",
+ "scpx", "pscp" and "psftp".
+
-2010-12-31 Eli Zaretskii <eliz@gnu.org>
++2011-01-14 Eli Zaretskii <eliz@gnu.org>
+
+ * term/w32-win.el (image-library-alist): Set up correctly for
+2011-01-14 Kim F. Storm <storm@cua.dk>
+
+ * emulation/cua-base.el (cua--init-keymaps):
+ Remap exchange-point-and-mark in cua-global-keymap.
+
+2011-01-14 Tassilo Horn <tassilo@member.fsf.org>
+
+ * progmodes/sh-script.el (sh-other-keywords): Add ZSH's foreach
+ loop keyword.
+
+2011-01-14 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/easymenu.el: Add :enable (bug#7754), and obey :label.
+ Require CL.
+ (easy-menu-create-menu, easy-menu-convert-item-1):
+ Use :label rather than nil for labels. Use `case'.
+ Add :enable as alias for :active.
+ (easy-menu-binding): Obey :label.
+
+2011-01-13 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Use run-mode-hooks for major mode hooks (bug#513).
+ * textmodes/reftex-toc.el (reftex-toc-mode-map):
+ Rename from reftex-toc-map.
+ (reftex-toc-mode): Use define-derived-mode.
+ * textmodes/reftex-sel.el (reftex-select-shared-map): New map.
+ (reftex-select-label-mode-map, reftex-select-bib-mode-map):
+ Rename from reftex-select-(label|bib)-map. Move init into declaration.
+ (reftex-select-label-mode, reftex-select-bib-mode):
+ Use define-derived-mode.
+ * textmodes/reftex-index.el (reftex-index-phrases-mode-map)
+ (reftex-index-mode-map): Rename from reftex-index(-phrases)-map.
+ Move init into delcaration.
+ (reftex-index-mode, reftex-index-phrases-mode):
+ Use define-derived-mode.
+ * speedbar.el (speedbar-mode-syntax-table): Renaqme from
+ speedbar-syntax-table. Move init into declaration.
+ (speedbar-mode-map): Rename from speedbar-key-map.
+ Move init into declaration.
+ (speedbar-file-key-map): Move init into declaration.
+ (speedbar-mode): Use define-derived-mode.
+ * recentf.el (recentf-mode): Don't run hook (or message) redundantly.
+ * net/rcirc.el (rcirc-mode): Use run-mode-hooks.
+ * emacs-lisp/chart.el (chart-mode-map): Rename from chart-map.
+ (chart-face-list): Move initialization into declaration.
+ (chart-mode): Use define-derived-mode.
+ * calculator.el (calculator-mode-map): Move init into declaration.
+ (calculator-mode): Use define-derived-mode.
+
+ * mail/mail-utils.el (mail-strip-quoted-names): Make the regexp code
+ work for nested comments.
+
+ * progmodes/prolog.el: Use syntax-propertize. Further code cleanup.
+ (prolog-use-prolog-tokenizer-flag): Change default when
+ syntax-propertize can be used.
+ (prolog-syntax-propertize-function): New var.
+ (prolog-mode-variables): Move make-local-variable into `set'.
+ Don't make comment-column local since we don't set it.
+ Set comment-add (as it was in previous prolog.el). Use dolist.
+ Set syntax-propertize-function.
+ (prolog-mode, prolog-inferior-mode):
+ Call prolog(-inferior)-menu directly, not through the mode-hook.
+ (prolog-buffer-module, prolog-indent-level)
+ (prolog-paren-is-the-first-on-line-p, prolog-paren-balance)
+ (prolog-comment-limits, prolog-goto-comment-column):
+ Use line-(end|beginning)-position.
+ (prolog-build-prolog-command): Tighten up regexp.
+ (prolog-consult-compile): Move make-local-variable into `set'.
+ (prolog-consult-compile-filter, prolog-goto-next-paren)
+ (prolog-help-on-predicate, prolog-clause-info)
+ (prolog-mark-predicate): Don't let+setq.
+ (prolog-indent-line): Use indent-line-to.
+ Only call prolog-goto-comment-column if necessary.
+ (prolog-indent-level): Use bobp.
+ (prolog-first-pos-on-line): Remove, not used any more.
+ (prolog-in-string-or-comment): Use syntax-ppss if available.
+ (prolog-help-on-predicate): Use read-string.
+ (prolog-goto-predicate-info): Simplify.
+ (prolog-read-predicate): Use `default' rather than `initial'.
+ (prolog-temporary-file): Use make-temp-file to close a security hole.
+ (prolog-toggle-sicstus-sd): New command.
+ (prolog-electric-underscore, prolog-variables-to-anonymous):
+ Use dynamic-scoping as it was meant.
+ (prolog-menu): Move menu definitions to top-level.
+ Use a toggle-button for Sicstus's source debugger.
+ Change "Code" to the more usual "Prolog", and hence change "Prolog"
+ to "System".
+ (prolog-inferior-menu): Reuse prolog-menu's help menu.
+ Move other menu definition to top-level.
+
+2011-01-13 Tassilo Horn <tassilo@member.fsf.org>
+
+ * doc-view.el (doc-view-open-text): Use meaningful text buffer
+ name. Keep original document's directory as default-directory
+ (bug#6446).
+ (doc-view-initiate-display): Fall back to normal mode when
+ doc-view-mode cannot be enabled, also when extracting the document
+ text into a separate buffer (bug#6446).
+
+ * simple.el (shell-command): Don't error out if shell command
+ buffer contains text with non-nil read-only property when erasing
+ the buffer.
+
+2011-01-13 Kim F. Storm <storm@cua.dk>
+
+ * ido.el (ido-may-cache-directory): Move "too-big" check later.
+ (ido-next-match, ido-prev-match): Fix stray reordering of matching
+ items when cycling through the matches.
+
+2011-01-13 Tassilo Horn <tassilo@member.fsf.org>
+
+ * dired-x.el (dired-omit-verbose): New defcustom that allows
+ disabling the omit messages.
+ (dired-omit-expunge): Use it.
+
+2011-01-13 Christian Ohler <ohler@gnu.org>
+
+ * emacs-lisp/ert.el, emacs-lisp/ert-x.el: New files.
+
+2011-01-13 Chong Yidong <cyd@stupidchicken.com>
+
+ * font-lock.el (font-lock-verbose): Default to nil.
+
+2011-01-13 Chong Yidong <cyd@stupidchicken.com>
+
+ * simple.el (sendmail-user-agent-compose): Move to sendmail.el.
+ (compose-mail): New arg RETURN-ACTION.
+ (compose-mail-other-window, compose-mail-other-frame): Likewise.
+
+ * mail/sendmail.el (mail-return-action): New var.
+ (mail-mode): Make it buffer-local.
+ (mail-bury): Obey it. Move special Rmail window handling to
+ rmail-mail-return.
+ (mail, mail-setup): New arg RETURN-ACTION.
+ (sendmail-user-agent-compose): Move from simple.el.
+
+ * mail/rmail.el (rmail-mail-return): New function.
+ (rmail-start-mail): Pass it to compose-mail.
+
+2011-01-12 Chong Yidong <cyd@stupidchicken.com>
+
+ * menu-bar.el (menu-bar-custom-menu): Tweak Mule and Customize
+ menus. Add menu item for customize-themes.
+
+ * cus-theme.el (customize-themes):
+ * emacs-lisp/package.el (package--list-packages): Use
+ switch-to-buffer.
+
+2011-01-11 Johan Bockgård <bojohan@gnu.org>
+
+ * emacs-lisp/unsafep.el (unsafep): Handle backquoted forms.
+
+2011-01-11 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * progmodes/prolog.el: Fix up coding convention and such.
+ (prolog-indent-width): Use the same default as in
+ previous prolog.el rather than tab-width which depends on which buffer
+ is current when the file is loaded.
+ (prolog-electric-newline-flag): Only enable if electric-indent-mode
+ is not available.
+ (prolog-emacs): Remove. Use (featurep 'xemacs) instead.
+ (prolog-known-systems): Remove.
+ (prolog-mode-syntax-table, prolog-inferior-mode-map):
+ Move initialization into declaration.
+ (prolog-mode-map): Move initialization into declaration.
+ Remove system-specific mode-map vars, since they referred to the same
+ keymap anyway.
+ (prolog-mode-variables): Obey the user's preference w.r.t
+ adaptive-fill-mode. Prefer symbol-value to `eval'.
+ (prolog-mode-keybindings-edit): Add compatibility bindings.
+ (prolog-mode): Use define-derived-mode. Don't handle mercury here.
+ (mercury-mode-map): New var.
+ (mercury-mode, prolog-inferior-mode): Use define-derived-mode.
+ (prolog-ensure-process, prolog-process-insert-string)
+ (prolog-consult-compile): Use with-current-buffer.
+ (prolog-guess-fill-prefix): Simplify data flow.
+ (prolog-replace-in-string): New function to use instead of
+ replace-in-string.
+ (prolog-enable-sicstus-sd): Don't abuse `eval'.
+ (prolog-uncomment-region): Use `uncomment-region' when available.
+ (prolog-electric-colon, prolog-electric-dash): Use `eolp'.
+ (prolog-int-to-char, prolog-char-to-int): New functions to use instead
+ of int-to-char and char-to-int.
+ (prolog-mode-hook, prolog-inferior-mode-hook): Don't force font-lock.
+
+2011-01-11 Stefan Bruda <stefan@bruda.ca>
+
+ * progmodes/prolog.el: Replace by a whole new file.
+
+2011-01-11 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * subr.el (eval-after-load): Fix timing for features (bug#7769).
+ (declare-function, undefined, insert-for-yank)
+ (replace-regexp-in-string): Follow checkdoc's recommendations.
+
+2011-01-10 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * calendar/diary-lib.el (diary-mode): Refresh *Calendar* after
+ refreshing the diary buffer.
+
+2011-01-10 Ken Manheimer <ken.manheimer@gmail.com>
+
+ * allout.el: Add 2011 to the file copyright.
+ (allout-encrypt-string): Prevent encryption from adding an extra
+ newline at the end of the topic body.
+ (allout-version): Increment to 2.3.
+
+2011-01-10 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/dbus.el (dbus-unregister-service): Complete doc.
+ Fix call of dbus-error signal.
+ (dbus-register-property): Use `dont-register' keyword.
+
+2011-01-10 Jan Moringen <jan.moringen@uni-bielefeld.de>
+
+ * net/dbus.el (dbus-unregister-service): Translate returned
+ integer into a symbol.
+ (dbus-register-property): Use `dbus-register-service' to do the
+ name registration.
+
+2011-01-09 Chong Yidong <cyd@stupidchicken.com>
+
+ * progmodes/idlw-help.el (idlwave-help-link): Inherit from link face.
+ Suggested by Joakim Verona.
+
+ * comint.el (comint-highlight-prompt): Inherit minibuffer-prompt.
+
+ * wid-edit.el (visibility): Replace :on-image and :off-image
+ widget properties with :on-glyph and :off-glyph, for consistency
+ with the `visibility' widget.
+ (widget-toggle-value-create, widget-visibility-value-create):
+ Merge into a single function `widget-toggle-value-create'.
+
+ * cus-edit.el (custom-variable-value-create, custom-visibility)
+ (custom-face-edit-value-create, custom-face-value-create):
+ Replace :on-image and :off-image widget properties with :on-glyph and
+ :off-glyph, for consistency with the `visibility' widget.
+
+2011-01-09 Andreas Schwab <schwab@linux-m68k.org>
+
+ * net/ldap.el (ldap-search-internal): Don't use eval.
+
+2011-01-09 Chong Yidong <cyd@stupidchicken.com>
+
+ * subr.el (read-char-choice): Use read-key.
+
+ * custom.el (custom-safe-themes): Rename from
+ custom-safe-theme-files. Add :risky tag.
+ (load-theme, custom-theme-load-confirm): Save sha1 hashes to
+ custom-safe-themes, not filenames. Suggested by Stefan Monnier.
+
+2011-01-09 Chong Yidong <cyd@stupidchicken.com>
+
+ * tool-bar.el (tool-bar-setup): Remove Help button. Remove label
+ from Search and add a label to Undo.
+
+ * vc/vc-dir.el (vc-dir-tool-bar-map): Rearrange, removing
+ inappropriate buttons and adding :vert-only tags.
+
+ * progmodes/compile.el (compilation-mode-tool-bar-map): Adjust to
+ removal of Help tool-bar button. Remove Undo button for space.
+
+ * info.el (info-tool-bar-map): Add :vert-only tags.
+
+2011-01-08 Tassilo Horn <tassilo@member.fsf.org>
+
+ * doc-view.el (doc-view-mode-p): Check for png or imagemagick
+ image backend support. Either of them is fine.
+
+2011-01-08 Chong Yidong <cyd@stupidchicken.com>
+
+ * subr.el (y-or-n-p): Doc fix.
+
+ * custom.el (custom-safe-theme-files): New defcustom.
+ (custom-theme-load-confirm): New function.
+ (load-theme): Load theme using `load', confirming with
+ custom-theme-load-confirm if necessary.
+
+ * subr.el (read-char-choice): New function, factored out from
+ dired-query and hack-local-variables-confirm.
+
+ * dired-aux.el (dired-query):
+ * files.el (hack-local-variables-confirm): Use it.
+
+ * dired-aux.el (dired-compress-file):
+ * files.el (abort-if-file-too-large, find-alternate-file)
+ (set-visited-file-name, write-file, backup-buffer)
+ (basic-save-buffer, basic-save-buffer-2, save-some-buffers)
+ (delete-directory, revert-buffer, recover-file, kill-buffer-ask):
+ Use new format string args for y-or-n-p and yes-or-no-p.
+
+2011-01-08 Andreas Schwab <schwab@linux-m68k.org>
+
+ * progmodes/compile.el (compilation-error-regexp-alist-alist)
+ [gcc-include]: Tighten file name match, add match for column
+ number. (Bug#7806)
+ [gnu]: Remove unused group.
+
+2011-01-08 Glenn Morris <rgm@gnu.org>
+
+ * makefile.w32-in (EMACSOPT): Add --no-site-lisp.
+
+ * makefile.w32-in (EMACSOPT): -batch implies --no-init-file.
+
+2011-01-07 Sam Steingold <sds@gnu.org>
+
+ * w32-fns.el (w32-shell-name): Use `shell-file-name' instead of
+ the `explicit-shell-file-name' because that is the
+ non-interactive shell.
+
+2011-01-07 Chong Yidong <cyd@stupidchicken.com>
+
+ * subr.el (y-or-n-p): Accept format string args.
+
+2011-01-07 Glenn Morris <rgm@gnu.org>
+
+ * Makefile.in (EMACSOPT): Add --no-site-lisp.
+
+2011-01-06 Ken Manheimer <ken.manheimer@gmail.com>
+
+ * allout.el (allout-back-to-current-heading): Ensure return to
+ the visible containing topic, rather than a collapsed one.
+ (allout-view-change-hook): Remove hook that was deprecated long ago.
+ (allout-exposure-change-hook): Remove documentation remarks
+ concerning removed allout-view-change-hook.
+ (allout-flag-region): Remove invocation of and documentation
+ remarks concerning allout-view-change-hook.
+
+2011-01-06 Glenn Morris <rgm@gnu.org>
+
+ * vc/vc-bzr.el (vc-bzr-annotate-command, vc-bzr-annotate-time)
+ (vc-bzr-annotate-extract-revision-at-line):
+ Handle authors with embedded spaces. (Bug#7792)
+
+2011-01-05 Tassilo Horn <tassilo@member.fsf.org>
+
+ * doc-view.el (doc-view-image-width): New variable.
+ (doc-view-enlarge, doc-view-insert-image): Prefer imagemagick
+ backend for PNG images, and do dynamic rescaling instead of
+ reconverting the whole doc.
+
+2011-01-05 Glenn Morris <rgm@gnu.org>
+
+ * emacs-lisp/rx.el (rx-repeat): Replace CL function.
+
+2011-01-04 Ken Manheimer <ken.manheimer@gmail.com>
+
+ * allout.el: Reconcile with changes in line movement behavior for
+ long text lines that cross more than a single physical window
+ line, ie when truncate-lines is nil.
+ (allout-next-visible-heading): Provide for change in line-move
+ behavior on long lines when truncate-lines is nil. In that case,
+ line-move can wind up on the same textual line when it moves to
+ the next window line, and moving to the bullet position after the
+ move yields zero advancement. Add logic to detect and compensate
+ for the lack of progress.
+ (allout-current-topic-collapsed-p): move-end-of-line respect for
+ field boundaries is different when operating with body lines
+ shorter than window width versus ones greater than window width,
+ which can yield false negatives in this function. Avoid
+ difference by applying move-end-of-line while field-text-motion is
+ inhibited.
+
+2011-01-04 Glenn Morris <rgm@gnu.org>
+
+ * textmodes/rst.el (rst-compile-toolsets):
+ Add pdf and s5 to option alist.
+
+2011-01-04 Jan Moringen <jan.moringen@uni-bielefeld.de>
+
+ * net/dbus.el (dbus-register-property): Add optional parameter
+ dont-register-service. Updated docstring accordingly.
+
+2011-01-04 Andreas Schwab <schwab@linux-m68k.org>
+
+ * textmodes/rst.el (rst-compile-pdf-preview)
+ (rst-compile-slides-preview): Remove extra line.
+
+2011-01-04 Glenn Morris <rgm@gnu.org>
+
+ * textmodes/rst.el (rst-compile-toolsets): Make it a defcustom.
+ Add `pdf' and `s5' entries. Use `prog.py' if found, otherwise
+ default to `prog' without a .py extension.
+ (rst-compile-pdf-preview, rst-compile-slides-preview):
+ Use program names from rst-compile-toolsets, rather than hard-coding.
+ (rst-portable-mark-active-p): Fix presumed typo.
+
+2011-01-02 Eli Zaretskii <eliz@gnu.org>
+
+ * term/w32-win.el (dynamic-library-alist): Set up correctly for
libpng versions both before and after 1.4.0. (Bug#7716)
-2010-12-25 Eli Zaretskii <eliz@gnu.org>
+2011-01-02 Eli Zaretskii <eliz@gnu.org>
* time.el (display-time-mode): Mention display-time-interval in
the doc string. (Bug#7713)
;;; cedet-cscope.el --- CScope support for CEDET
- ;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+ ;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
+;; Package: cedet
;; This file is part of GNU Emacs.
;;; cedet-files.el --- Common routines dealing with file names.
- ;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+ ;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
+;; Package: cedet
;; This file is part of GNU Emacs.
;;; cedet-global.el --- GNU Global support for CEDET.
- ;; Copyright (C) 2008, 2009, 2010 Free Software Foundation, Inc.
+ ;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
+;; Package: cedet
;; This file is part of GNU Emacs.
;;; ede-pmake.el --- EDE Generic Project Makefile code generator.
- ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007,
- ;; 2008, 2009, 2010 Free Software Foundation, Inc.
-;;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-;;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
++;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
++;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: project, make
;;; ede/speedbar.el --- Speedbar viewing of EDE projects
- ;; Copyright (C) 1998, 1999, 2000, 2001, 2003, 2005, 2007, 2008,
- ;; 2009, 2010 Free Software Foundation, Inc.
-;;; Copyright (C) 1998, 1999, 2000, 2001, 2003, 2005, 2007, 2008, 2009, 2010, 2011
-;;; Free Software Foundation, Inc.
++;; Copyright (C) 1998, 1999, 2000, 2001, 2003, 2005, 2007, 2008, 2009, 2010, 2011
++;; Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: project, make, tags
;;; semantic/ede-grammar.el --- EDE support for Semantic Grammar Files
- ;; Copyright (C) 2003, 2004, 2007, 2008, 2009, 2010
- ;; Free Software Foundation, Inc.
-;;; Copyright (C) 2003, 2004, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
++;; Copyright (C) 2003, 2004, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: project, make
;;; dframe --- dedicate frame support modes
-;;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
- ;; 2005, 2006, 2007, 2008, 2009, 2010
++;; 2005, 2006, 2007, 2008, 2009, 2010, 2011
+;; Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: file, tags, tools
--- /dev/null
- ;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+;;; dynamic-setting.el --- Support dynamic changes
+
++;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+
+;; Author: Jan Djärv <jan.h.d@swipnet.se>
+;; Maintainer: FSF
+;; Keywords: font, system-font, tool-bar-style
+;; Package: emacs
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file provides the lisp part of the GConf and XSetting code in
+;; xsetting.c. But it is nothing that prevents it from being used by
+;; other configuration schemes.
+
+;;; Code:
+
+;;; Customizable variables
+
+(declare-function font-get-system-font "xsettings.c" ())
+
+(defvar font-use-system-font)
+
+(defun font-setting-change-default-font (display-or-frame set-font)
+ "Change font and/or font settings for frames on display DISPLAY-OR-FRAME.
+If DISPLAY-OR-FRAME is a frame, the display is the one for that frame.
+
+If SET-FONT is non-nil, change the font for frames. Otherwise re-apply the
+current form for the frame (i.e. hinting or somesuch changed)."
+
+ (let ((new-font (and (fboundp 'font-get-system-font)
+ (font-get-system-font))))
+ (when new-font
+ ;; Be careful here: when set-face-attribute is called for the
+ ;; :font attribute, Emacs tries to guess the best matching font
+ ;; by examining the other face attributes (Bug#2476).
+
+ (clear-font-cache)
+ ;; Set for current frames. Only change font for those that have
+ ;; the old font now. If they don't have the old font, the user
+ ;; probably changed it.
+ (dolist (f (frames-on-display-list display-or-frame))
+ (if (display-graphic-p f)
+ (let* ((frame-font
+ (or (font-get (face-attribute 'default :font f
+ 'default) :user-spec)
+ (frame-parameter f 'font-parameter)))
+ (font-to-set
+ (if set-font new-font
+ ;; else set font again, hinting etc. may have changed.
+ frame-font)))
+ (if font-to-set
+ (progn
+ (set-frame-parameter f 'font-parameter font-to-set)
+ (set-face-attribute 'default f
+ :width 'normal
+ :weight 'normal
+ :slant 'normal
+ :font font-to-set))))))
+
+ ;; Set for future frames.
+ (set-face-attribute 'default t :font new-font)
+ (let ((spec (list (list t (face-attr-construct 'default)))))
+ (progn
+ (put 'default 'customized-face spec)
+ (custom-push-theme 'theme-face 'default 'user 'set spec)
+ (put 'default 'face-modified nil))))))
+
+(defun dynamic-setting-handle-config-changed-event (event)
+ "Handle config-changed-event on the display in EVENT.
+Changes can be
+ The monospace font. If `font-use-system-font' is nil, the font
+ is not changed.
+ Xft parameters, like DPI and hinting.
+ The tool bar style."
+ (interactive "e")
+ (let ((type (nth 1 event))
+ (display-name (nth 2 event)))
+ (cond ((and (eq type 'monospace-font-name) font-use-system-font)
+ (font-setting-change-default-font display-name t))
+
+ ((eq type 'font-render)
+ (font-setting-change-default-font display-name nil))
+
+ ;; This is a bit heavy, ideally we would just clear faces
+ ;; on the affected display, and perhaps only the relevant
+ ;; faces. Oh well.
+ ((eq type 'theme-name) (clear-face-cache))
+
+ ((eq type 'tool-bar-style) (force-mode-line-update t)))))
+
+(define-key special-event-map [config-changed-event]
+ 'dynamic-setting-handle-config-changed-event)
+
+;; arch-tag: 3a57e78f-1cd6-48b6-ab75-98f160dcc017
;;; cl-specs.el --- Edebug specs for cl.el -*- no-byte-compile: t -*-
;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005,
- ;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+ ;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
;; Author: Daniel LaLiberte <liberte@holonexus.org>
;; Keywords: lisp, tools, maint
+;; Package: emacs
;; LCD Archive Entry:
;; cl-specs.el|Daniel LaLiberte|liberte@holonexus.org
;;; timer.el --- run a function with args at some time in future
;; Copyright (C) 1996, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
- ;; 2009, 2010 Free Software Foundation, Inc.
+ ;; 2009, 2010, 2011 Free Software Foundation, Inc.
;; Maintainer: FSF
+;; Package: emacs
;; This file is part of GNU Emacs.
-;;; edt.el --- enhanced EDT keypad mode emulation for GNU Emacs 19
+;;; edt.el --- enhanced EDT keypad mode emulation for GNU Emacs
;; Copyright (C) 1986, 1992, 1993, 1994, 1995, 2000, 2001, 2002, 2003,
- ;; 2004, 2005, 2006, 2007, 2008, 2009, 2010
- ;; Free Software Foundation, Inc.
+ ;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
;; Author: Kevin Gallagher <Kevin.Gallagher@boeing.com>
;; Maintainer: Kevin Gallagher <Kevin.Gallagher@boeing.com>
;;; viper-cmd.el --- Vi command support for Viper
- ;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- ;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+ ;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
+ ;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: viper
;; This file is part of GNU Emacs.
;;; viper-ex.el --- functions implementing the Ex commands for Viper
;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003,
- ;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+ ;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: viper
;; This file is part of GNU Emacs.
;;; viper-init.el --- some common definitions for Viper
- ;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- ;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+ ;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
+ ;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: viper
;; This file is part of GNU Emacs.
;;; viper-keym.el --- Viper keymaps
;; Copyright (C) 1994, 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2004,
- ;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+ ;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: viper
;; This file is part of GNU Emacs.
;;; viper-macs.el --- functions implementing keyboard macros for Viper
;; Copyright (C) 1994, 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2004,
- ;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+ ;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: viper
;; This file is part of GNU Emacs.
;;; viper-mous.el --- mouse support for Viper
;; Copyright (C) 1994, 1995, 1996, 1997, 2001, 2002, 2003, 2004,
- ;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+ ;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: viper
;; This file is part of GNU Emacs.
;;; viper-util.el --- Utilities used by viper.el
;; Copyright (C) 1994, 1995, 1996, 1997, 1999, 2000, 2001, 2002, 2003,
- ;; 2004, 2005, 2006, 2007, 2008, 2009, 2010
- ;; Free Software Foundation, Inc.
+ ;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: viper
;; This file is part of GNU Emacs.
;;; face-remap.el --- Functions for managing `face-remapping-alist'
;;
- ;; Copyright (C) 2008, 2009, 2010 Free Software Foundation, Inc.
+ ;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
;;
;; Author: Miles Bader <miles@gnu.org>
-;; Keywords: faces face remapping display user commands
+;; Keywords: faces, face remapping, display, user commands
;;
;; This file is part of GNU Emacs.
;;
;;; format.el --- read and save files in multiple formats
;; Copyright (C) 1994, 1995, 1997, 1999, 2001, 2002, 2003, 2004, 2005,
- ;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+ ;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
;; Author: Boris Goldowsky <boris@gnu.org>
+;; Package: emacs
;; This file is part of GNU Emacs.
;;; indent.el --- indentation commands for Emacs
;; Copyright (C) 1985, 1995, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
- ;; 2008, 2009, 2010 Free Software Foundation, Inc.
+ ;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
;; Maintainer: FSF
+;; Package: emacs
;; This file is part of GNU Emacs.
-;;; hebrew.el --- support for Hebrew -*- coding: iso-2022-7bit; no-byte-compile: t -*-
+;;; hebrew.el --- support for Hebrew -*- coding: utf-8 -*-
- ;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+ ;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
;; Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
- ;; 2005, 2006, 2007, 2008, 2009, 2010
+ ;; 2005, 2006, 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
;; Registration Number H14PRO021
;;; midnight.el --- run something every midnight, e.g., kill old buffers
;; Copyright (C) 1998, 2001, 2002, 2003, 2004, 2005,
- ;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+ ;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
-;; Author: Sam Steingold <sds@usa.net>
-;; Maintainer: Sam Steingold <sds@usa.net>
+;; Author: Sam Steingold <sds@gnu.org>
+;; Maintainer: Sam Steingold <sds@gnu.org>
;; Created: 1998-05-18
;; Keywords: utilities
;;; minibuffer.el --- Minibuffer completion functions
- ;; Copyright (C) 2008, 2009, 2010 Free Software Foundation, Inc.
+ ;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; Package: emacs
;; This file is part of GNU Emacs.
;;; mwheel.el --- Wheel mouse support
;; Copyright (C) 1998, 2000, 2001, 2002, 2002, 2004, 2005, 2006, 2007,
- ;; 2008, 2009, 2010 Free Software Foundation, Inc.
+ ;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
;; Maintainer: William M. Perry <wmperry@gnu.org>
;; Keywords: mouse
+;; Package: emacs
;; This file is part of GNU Emacs.
;;; hmac-def.el --- A macro for defining HMAC functions.
- ;; Copyright (C) 1999, 2001, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+ ;; Copyright (C) 1999, 2001, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
-;; Keywords: HMAC, RFC-2104
+;; Keywords: HMAC, RFC2104
;; This file is part of GNU Emacs.
;;; hmac-md5.el --- Compute HMAC-MD5.
- ;; Copyright (C) 1999, 2001, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+ ;; Copyright (C) 1999, 2001, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
-;; Keywords: HMAC, RFC-2104, HMAC-MD5, MD5, KEYED-MD5, CRAM-MD5
+;; Keywords: HMAC, RFC2104, HMAC-MD5, MD5, KEYED-MD5, CRAM-MD5
;; This file is part of GNU Emacs.
--- /dev/null
- ;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;;; tramp-sh.el --- Tramp access functions for (s)sh-like connections
+
+;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
- # Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
++;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+
+;; (copyright statements below in code to be updated with the above notice)
+
+;; Author: Kai Großjohann <kai.grossjohann@gmx.net>
+;; Michael Albinus <michael.albinus@gmx.de>
+;; Keywords: comm, processes
+;; Package: tramp
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(eval-when-compile (require 'cl)) ; ignore-errors
+(require 'tramp)
+(require 'shell)
+
+;; Pacify byte-compiler. The function is needed on XEmacs only. I'm
+;; not sure at all that this is the right way to do it, but let's hope
+;; it works for now, and wait for a guru to point out the Right Way to
+;; achieve this.
+;;(eval-when-compile
+;; (unless (fboundp 'dired-insert-set-properties)
+;; (fset 'dired-insert-set-properties 'ignore)))
+;; Gerd suggests this:
+(eval-when-compile (require 'dired))
+;; Note that dired is required at run-time, too, when it is needed.
+;; It is only needed on XEmacs for the function
+;; `dired-insert-set-properties'.
+
+(defcustom tramp-inline-compress-start-size 4096
+ "*The minimum size of compressing where inline transfer.
+When inline transfer, compress transfered data of file
+whose size is this value or above (up to `tramp-copy-size-limit').
+If it is nil, no compression at all will be applied."
+ :group 'tramp
+ :type '(choice (const nil) integer))
+
+(defcustom tramp-copy-size-limit 10240
+ "*The maximum file size where inline copying is preferred over an out-of-the-band copy.
+If it is nil, inline out-of-the-band copy will be used without a check."
+ :group 'tramp
+ :type '(choice (const nil) integer))
+
+;;;###tramp-autoload
+(defcustom tramp-terminal-type "dumb"
+ "*Value of TERM environment variable for logging in to remote host.
+Because Tramp wants to parse the output of the remote shell, it is easily
+confused by ANSI color escape sequences and suchlike. Often, shell init
+files conditionalize this setup based on the TERM environment variable."
+ :group 'tramp
+ :type 'string)
+
+;; ksh on OpenBSD 4.5 requires, that $PS1 contains a `#' character for
+;; root users. It uses the `$' character for other users. In order
+;; to guarantee a proper prompt, we use "#$" for the prompt.
+
+(defvar tramp-end-of-output
+ (format
+ "///%s#$"
+ (md5 (concat (prin1-to-string process-environment) (current-time-string))))
+ "String used to recognize end of output.
+The '$' character at the end is quoted; the string cannot be
+detected as prompt when being sent on echoing hosts, therefore.")
+
+;;;###tramp-autoload
+(defconst tramp-initial-end-of-output "#$ "
+ "Prompt when establishing a connection.")
+
+;; Initialize `tramp-methods' with the supported methods.
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("rcp"
+ (tramp-login-program "rsh")
+ (tramp-login-args (("%h") ("-l" "%u")))
+ (tramp-remote-sh "/bin/sh")
+ (tramp-copy-program "rcp")
+ (tramp-copy-args (("%k" "-p") ("-r")))
+ (tramp-copy-keep-date t)
+ (tramp-copy-recursive t)))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("remcp"
+ (tramp-login-program "remsh")
+ (tramp-login-args (("%h") ("-l" "%u")))
+ (tramp-remote-sh "/bin/sh")
+ (tramp-copy-program "rcp")
+ (tramp-copy-args (("%k" "-p")))
+ (tramp-copy-keep-date t)))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("scp"
+ (tramp-login-program "ssh")
+ (tramp-login-args (("-l" "%u") ("-p" "%p") ("-e" "none") ("%h")))
+ (tramp-async-args (("-q")))
+ (tramp-remote-sh "/bin/sh")
+ (tramp-copy-program "scp")
+ (tramp-copy-args (("-P" "%p") ("%k" "-p") ("-q") ("-r")))
+ (tramp-copy-keep-date t)
+ (tramp-copy-recursive t)
+ (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null")
+ ("-o" "UserKnownHostsFile=/dev/null")
+ ("-o" "StrictHostKeyChecking=no")))
+ (tramp-default-port 22)))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("scp1"
+ (tramp-login-program "ssh")
+ (tramp-login-args (("-l" "%u") ("-p" "%p")
+ ("-1") ("-e" "none") ("%h")))
+ (tramp-async-args (("-q")))
+ (tramp-remote-sh "/bin/sh")
+ (tramp-copy-program "scp")
+ (tramp-copy-args (("-1") ("-P" "%p") ("%k" "-p") ("-q") ("-r")))
+ (tramp-copy-keep-date t)
+ (tramp-copy-recursive t)
+ (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null")
+ ("-o" "UserKnownHostsFile=/dev/null")
+ ("-o" "StrictHostKeyChecking=no")))
+ (tramp-default-port 22)))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("scp2"
+ (tramp-login-program "ssh")
+ (tramp-login-args (("-l" "%u") ("-p" "%p")
+ ("-2") ("-e" "none") ("%h")))
+ (tramp-async-args (("-q")))
+ (tramp-remote-sh "/bin/sh")
+ (tramp-copy-program "scp")
+ (tramp-copy-args (("-2") ("-P" "%p") ("%k" "-p") ("-q") ("-r")))
+ (tramp-copy-keep-date t)
+ (tramp-copy-recursive t)
+ (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null")
+ ("-o" "UserKnownHostsFile=/dev/null")
+ ("-o" "StrictHostKeyChecking=no")))
+ (tramp-default-port 22)))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("scpc"
+ (tramp-login-program "ssh")
+ (tramp-login-args (("-l" "%u") ("-p" "%p")
+ ("-o" "ControlPath=%t.%%r@%%h:%%p")
+ ("-o" "ControlMaster=yes")
+ ("-e" "none") ("%h")))
+ (tramp-async-args (("-q")))
+ (tramp-remote-sh "/bin/sh")
+ (tramp-copy-program "scp")
+ (tramp-copy-args (("-P" "%p") ("%k" "-p") ("-q") ("-r")
+ ("-o" "ControlPath=%t.%%r@%%h:%%p")
+ ("-o" "ControlMaster=auto")))
+ (tramp-copy-keep-date t)
+ (tramp-copy-recursive t)
+ (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null")
+ ("-o" "UserKnownHostsFile=/dev/null")
+ ("-o" "StrictHostKeyChecking=no")))
+ (tramp-default-port 22)))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("scpx"
+ (tramp-login-program "ssh")
+ (tramp-login-args (("-l" "%u") ("-p" "%p")
+ ("-e" "none") ("-t" "-t")
+ ("%h") ("/bin/sh")))
+ (tramp-async-args (("-q")))
+ (tramp-remote-sh "/bin/sh")
+ (tramp-copy-program "scp")
+ (tramp-copy-args (("-P" "%p") ("%k" "-p") ("-q") ("-r")))
+ (tramp-copy-keep-date t)
+ (tramp-copy-recursive t)
+ (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null")
+ ("-o" "UserKnownHostsFile=/dev/null")
+ ("-o" "StrictHostKeyChecking=no")))
+ (tramp-default-port 22)))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("sftp"
+ (tramp-login-program "ssh")
+ (tramp-login-args (("-l" "%u") ("-p" "%p") ("-e" "none") ("%h")))
+ (tramp-async-args (("-q")))
+ (tramp-remote-sh "/bin/sh")
+ (tramp-copy-program "sftp")))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("rsync"
+ (tramp-login-program "ssh")
+ (tramp-login-args (("-l" "%u") ("-p" "%p") ("-e" "none") ("%h")))
+ (tramp-async-args (("-q")))
+ (tramp-remote-sh "/bin/sh")
+ (tramp-copy-program "rsync")
+ (tramp-copy-args (("-e" "ssh") ("%k" "-t") ("-r")))
+ (tramp-copy-keep-date t)
+ (tramp-copy-keep-tmpfile t)
+ (tramp-copy-recursive t)))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ `("rsyncc"
+ (tramp-login-program "ssh")
+ (tramp-login-args (("-l" "%u") ("-p" "%p")
+ ("-o" "ControlPath=%t.%%r@%%h:%%p")
+ ("-o" "ControlMaster=yes")
+ ("-e" "none") ("%h")))
+ (tramp-async-args (("-q")))
+ (tramp-remote-sh "/bin/sh")
+ (tramp-copy-program "rsync")
+ (tramp-copy-args (("%k" "-t") ("-r")))
+ (tramp-copy-env (("RSYNC_RSH")
+ (,(concat
+ "ssh"
+ " -o ControlPath=%t.%%r@%%h:%%p"
+ " -o ControlMaster=auto"))))
+ (tramp-copy-keep-date t)
+ (tramp-copy-keep-tmpfile t)
+ (tramp-copy-recursive t)))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("rsh"
+ (tramp-login-program "rsh")
+ (tramp-login-args (("%h") ("-l" "%u")))
+ (tramp-remote-sh "/bin/sh")))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("remsh"
+ (tramp-login-program "remsh")
+ (tramp-login-args (("%h") ("-l" "%u")))
+ (tramp-remote-sh "/bin/sh")))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("ssh"
+ (tramp-login-program "ssh")
+ (tramp-login-args (("-l" "%u") ("-p" "%p") ("-e" "none") ("%h")))
+ (tramp-async-args (("-q")))
+ (tramp-remote-sh "/bin/sh")
+ (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null")
+ ("-o" "UserKnownHostsFile=/dev/null")
+ ("-o" "StrictHostKeyChecking=no")))
+ (tramp-default-port 22)))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("ssh1"
+ (tramp-login-program "ssh")
+ (tramp-login-args (("-l" "%u") ("-p" "%p")
+ ("-1") ("-e" "none") ("%h")))
+ (tramp-async-args (("-q")))
+ (tramp-remote-sh "/bin/sh")
+ (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null")
+ ("-o" "UserKnownHostsFile=/dev/null")
+ ("-o" "StrictHostKeyChecking=no")))
+ (tramp-default-port 22)))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("ssh2"
+ (tramp-login-program "ssh")
+ (tramp-login-args (("-l" "%u") ("-p" "%p")
+ ("-2") ("-e" "none") ("%h")))
+ (tramp-async-args (("-q")))
+ (tramp-remote-sh "/bin/sh")
+ (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null")
+ ("-o" "UserKnownHostsFile=/dev/null")
+ ("-o" "StrictHostKeyChecking=no")))
+ (tramp-default-port 22)))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("sshx"
+ (tramp-login-program "ssh")
+ (tramp-login-args (("-l" "%u") ("-p" "%p")
+ ("-e" "none") ("-t" "-t")
+ ("%h") ("/bin/sh")))
+ (tramp-async-args (("-q")))
+ (tramp-remote-sh "/bin/sh")
+ (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null")
+ ("-o" "UserKnownHostsFile=/dev/null")
+ ("-o" "StrictHostKeyChecking=no")))
+ (tramp-default-port 22)))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("telnet"
+ (tramp-login-program "telnet")
+ (tramp-login-args (("%h") ("%p")))
+ (tramp-remote-sh "/bin/sh")
+ (tramp-default-port 23)))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("su"
+ (tramp-login-program "su")
+ (tramp-login-args (("-") ("%u")))
+ (tramp-remote-sh "/bin/sh")))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("sudo"
+ (tramp-login-program "sudo")
+ (tramp-login-args (("-u" "%u") ("-s") ("-H") ("-p" "Password:")))
+ (tramp-remote-sh "/bin/sh")))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("ksu"
+ (tramp-login-program "ksu")
+ (tramp-login-args (("%u") ("-q")))
+ (tramp-remote-sh "/bin/sh")))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("krlogin"
+ (tramp-login-program "krlogin")
+ (tramp-login-args (("%h") ("-l" "%u") ("-x")))
+ (tramp-remote-sh "/bin/sh")))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("plink"
+ (tramp-login-program "plink")
+ (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("%h")))
+ (tramp-remote-sh "/bin/sh")
+ (tramp-password-end-of-line "xy") ;see docstring for "xy"
+ (tramp-default-port 22)))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("plink1"
+ (tramp-login-program "plink")
+ (tramp-login-args (("-l" "%u") ("-P" "%p") ("-1" "-ssh") ("%h")))
+ (tramp-remote-sh "/bin/sh")
+ (tramp-password-end-of-line "xy") ;see docstring for "xy"
+ (tramp-default-port 22)))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ `("plinkx"
+ (tramp-login-program "plink")
+ ;; ("%h") must be a single element, see
+ ;; `tramp-compute-multi-hops'.
+ (tramp-login-args (("-load") ("%h") ("-t")
+ (,(format
+ "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'"
+ tramp-terminal-type
+ tramp-initial-end-of-output))
+ ("/bin/sh")))
+ (tramp-remote-sh "/bin/sh")))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("pscp"
+ (tramp-login-program "plink")
+ (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("%h")))
+ (tramp-remote-sh "/bin/sh")
+ (tramp-copy-program "pscp")
+ (tramp-copy-args (("-P" "%p") ("-scp") ("%k" "-p")
+ ("-q") ("-r")))
+ (tramp-copy-keep-date t)
+ (tramp-copy-recursive t)
+ (tramp-password-end-of-line "xy") ;see docstring for "xy"
+ (tramp-default-port 22)))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("psftp"
+ (tramp-login-program "plink")
+ (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("%h")))
+ (tramp-remote-sh "/bin/sh")
+ (tramp-copy-program "pscp")
+ (tramp-copy-args (("-P" "%p") ("-sftp") ("%k" "-p")
+ ("-q") ("-r")))
+ (tramp-copy-keep-date t)
+ (tramp-copy-recursive t)
+ (tramp-password-end-of-line "xy"))) ;see docstring for "xy"
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("fcp"
+ (tramp-login-program "fsh")
+ (tramp-login-args (("%h") ("-l" "%u") ("sh" "-i")))
+ (tramp-remote-sh "/bin/sh -i")
+ (tramp-copy-program "fcp")
+ (tramp-copy-args (("%k" "-p")))
+ (tramp-copy-keep-date t)))
+
+;;;###tramp-autoload
+(add-to-list 'tramp-default-method-alist
+ `(,tramp-local-host-regexp "\\`root\\'" "su"))
+
+;;;###tramp-autoload
+(add-to-list 'tramp-default-user-alist
+ `(,(concat "\\`" (regexp-opt '("su" "sudo" "ksu")) "\\'")
+ nil "root"))
+;; Do not add "ssh" based methods, otherwise ~/.ssh/config would be ignored.
+;;;###tramp-autoload
+(add-to-list 'tramp-default-user-alist
+ `(,(concat
+ "\\`"
+ (regexp-opt
+ '("rcp" "remcp" "rsh" "telnet" "krlogin"
+ "plink" "plink1" "pscp" "psftp" "fcp"))
+ "\\'")
+ nil ,(user-login-name)))
+
+(defconst tramp-completion-function-alist-rsh
+ '((tramp-parse-rhosts "/etc/hosts.equiv")
+ (tramp-parse-rhosts "~/.rhosts"))
+ "Default list of (FUNCTION FILE) pairs to be examined for rsh methods.")
+
+(defconst tramp-completion-function-alist-ssh
+ '((tramp-parse-rhosts "/etc/hosts.equiv")
+ (tramp-parse-rhosts "/etc/shosts.equiv")
+ (tramp-parse-shosts "/etc/ssh_known_hosts")
+ (tramp-parse-sconfig "/etc/ssh_config")
+ (tramp-parse-shostkeys "/etc/ssh2/hostkeys")
+ (tramp-parse-sknownhosts "/etc/ssh2/knownhosts")
+ (tramp-parse-rhosts "~/.rhosts")
+ (tramp-parse-rhosts "~/.shosts")
+ (tramp-parse-shosts "~/.ssh/known_hosts")
+ (tramp-parse-sconfig "~/.ssh/config")
+ (tramp-parse-shostkeys "~/.ssh2/hostkeys")
+ (tramp-parse-sknownhosts "~/.ssh2/knownhosts"))
+ "Default list of (FUNCTION FILE) pairs to be examined for ssh methods.")
+
+(defconst tramp-completion-function-alist-telnet
+ '((tramp-parse-hosts "/etc/hosts"))
+ "Default list of (FUNCTION FILE) pairs to be examined for telnet methods.")
+
+(defconst tramp-completion-function-alist-su
+ '((tramp-parse-passwd "/etc/passwd"))
+ "Default list of (FUNCTION FILE) pairs to be examined for su methods.")
+
+(defconst tramp-completion-function-alist-putty
+ '((tramp-parse-putty
+ "HKEY_CURRENT_USER\\Software\\SimonTatham\\PuTTY\\Sessions"))
+ "Default list of (FUNCTION REGISTRY) pairs to be examined for putty methods.")
+
+(tramp-set-completion-function "rcp" tramp-completion-function-alist-rsh)
+(tramp-set-completion-function "remcp" tramp-completion-function-alist-rsh)
+(tramp-set-completion-function "scp" tramp-completion-function-alist-ssh)
+(tramp-set-completion-function "scp1" tramp-completion-function-alist-ssh)
+(tramp-set-completion-function "scp2" tramp-completion-function-alist-ssh)
+(tramp-set-completion-function "scpc" tramp-completion-function-alist-ssh)
+(tramp-set-completion-function "scpx" tramp-completion-function-alist-ssh)
+(tramp-set-completion-function "sftp" tramp-completion-function-alist-ssh)
+(tramp-set-completion-function "rsync" tramp-completion-function-alist-ssh)
+(tramp-set-completion-function "rsyncc" tramp-completion-function-alist-ssh)
+(tramp-set-completion-function "rsh" tramp-completion-function-alist-rsh)
+(tramp-set-completion-function "remsh" tramp-completion-function-alist-rsh)
+(tramp-set-completion-function "ssh" tramp-completion-function-alist-ssh)
+(tramp-set-completion-function "ssh1" tramp-completion-function-alist-ssh)
+(tramp-set-completion-function "ssh2" tramp-completion-function-alist-ssh)
+(tramp-set-completion-function "ssh1_old" tramp-completion-function-alist-ssh)
+(tramp-set-completion-function "ssh2_old" tramp-completion-function-alist-ssh)
+(tramp-set-completion-function "sshx" tramp-completion-function-alist-ssh)
+(tramp-set-completion-function "telnet" tramp-completion-function-alist-telnet)
+(tramp-set-completion-function "su" tramp-completion-function-alist-su)
+(tramp-set-completion-function "sudo" tramp-completion-function-alist-su)
+(tramp-set-completion-function "ksu" tramp-completion-function-alist-su)
+(tramp-set-completion-function "krlogin" tramp-completion-function-alist-rsh)
+(tramp-set-completion-function "plink" tramp-completion-function-alist-ssh)
+(tramp-set-completion-function "plink1" tramp-completion-function-alist-ssh)
+(tramp-set-completion-function "plinkx" tramp-completion-function-alist-putty)
+(tramp-set-completion-function "pscp" tramp-completion-function-alist-ssh)
+(tramp-set-completion-function "fcp" tramp-completion-function-alist-ssh)
+
+;; "getconf PATH" yields:
+;; HP-UX: /usr/bin:/usr/ccs/bin:/opt/ansic/bin:/opt/langtools/bin:/opt/fortran/bin
+;; Solaris: /usr/xpg4/bin:/usr/ccs/bin:/usr/bin:/opt/SUNWspro/bin
+;; GNU/Linux (Debian, Suse): /bin:/usr/bin
+;; FreeBSD: /usr/bin:/bin:/usr/sbin:/sbin: - beware trailing ":"!
+;; IRIX64: /usr/bin
+(defcustom tramp-remote-path
+ '(tramp-default-remote-path "/usr/sbin" "/usr/local/bin"
+ "/local/bin" "/local/freeware/bin" "/local/gnu/bin"
+ "/usr/freeware/bin" "/usr/pkg/bin" "/usr/contrib/bin")
+ "*List of directories to search for executables on remote host.
+For every remote host, this variable will be set buffer local,
+keeping the list of existing directories on that host.
+
+You can use `~' in this list, but when searching for a shell which groks
+tilde expansion, all directory names starting with `~' will be ignored.
+
+`Default Directories' represent the list of directories given by
+the command \"getconf PATH\". It is recommended to use this
+entry on top of this list, because these are the default
+directories for POSIX compatible commands.
+
+`Private Directories' are the settings of the $PATH environment,
+as given in your `~/.profile'."
+ :group 'tramp
+ :type '(repeat (choice
+ (const :tag "Default Directories" tramp-default-remote-path)
+ (const :tag "Private Directories" tramp-own-remote-path)
+ (string :tag "Directory"))))
+
+(defcustom tramp-remote-process-environment
+ `("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)
+ "CDPATH=" "HISTORY=" "MAIL=" "MAILCHECK=" "MAILPATH="
+ "autocorrect=" "correct=")
+
+ "*List of environment variables to be set on the remote host.
+
+Each element should be a string of the form ENVVARNAME=VALUE. An
+entry ENVVARNAME= diables the corresponding environment variable,
+which might have been set in the init files like ~/.profile.
+
+Special handling is applied to the PATH environment, which should
+not be set here. Instead of, it should be set via `tramp-remote-path'."
+ :group 'tramp
+ :type '(repeat string))
+
+(defcustom tramp-sh-extra-args '(("/bash\\'" . "-norc -noprofile"))
+ "*Alist specifying extra arguments to pass to the remote shell.
+Entries are (REGEXP . ARGS) where REGEXP is a regular expression
+matching the shell file name and ARGS is a string specifying the
+arguments.
+
+This variable is only used when Tramp needs to start up another shell
+for tilde expansion. The extra arguments should typically prevent the
+shell from reading its init file."
+ :group 'tramp
+ ;; This might be the wrong way to test whether the widget type
+ ;; `alist' is available. Who knows the right way to test it?
+ :type (if (get 'alist 'widget-type)
+ '(alist :key-type string :value-type string)
+ '(repeat (cons string string))))
+
+(defconst tramp-actions-before-shell
+ '((tramp-login-prompt-regexp tramp-action-login)
+ (tramp-password-prompt-regexp tramp-action-password)
+ (tramp-wrong-passwd-regexp tramp-action-permission-denied)
+ (shell-prompt-pattern tramp-action-succeed)
+ (tramp-shell-prompt-pattern tramp-action-succeed)
+ (tramp-yesno-prompt-regexp tramp-action-yesno)
+ (tramp-yn-prompt-regexp tramp-action-yn)
+ (tramp-terminal-prompt-regexp tramp-action-terminal)
+ (tramp-process-alive-regexp tramp-action-process-alive))
+ "List of pattern/action pairs.
+Whenever a pattern matches, the corresponding action is performed.
+Each item looks like (PATTERN ACTION).
+
+The PATTERN should be a symbol, a variable. The value of this
+variable gives the regular expression to search for. Note that the
+regexp must match at the end of the buffer, \"\\'\" is implicitly
+appended to it.
+
+The ACTION should also be a symbol, but a function. When the
+corresponding PATTERN matches, the ACTION function is called.")
+
+(defconst tramp-actions-copy-out-of-band
+ '((tramp-password-prompt-regexp tramp-action-password)
+ (tramp-wrong-passwd-regexp tramp-action-permission-denied)
+ (tramp-copy-failed-regexp tramp-action-permission-denied)
+ (tramp-process-alive-regexp tramp-action-out-of-band))
+ "List of pattern/action pairs.
+This list is used for copying/renaming with out-of-band methods.
+
+See `tramp-actions-before-shell' for more info.")
+
+(defconst tramp-uudecode
+ "(echo begin 600 /tmp/tramp.$$; tail +2) | uudecode
+cat /tmp/tramp.$$
+rm -f /tmp/tramp.$$"
+ "Shell function to implement `uudecode' to standard output.
+Many systems support `uudecode -o /dev/stdout' or `uudecode -o -'
+for this or `uudecode -p', but some systems don't, and for them
+we have this shell function.")
+
+(defconst tramp-perl-file-truename
+ "%s -e '
+use File::Spec;
+use Cwd \"realpath\";
+
+sub recursive {
+ my ($volume, @dirs) = @_;
+ my $real = realpath(File::Spec->catpath(
+ $volume, File::Spec->catdir(@dirs), \"\"));
+ if ($real) {
+ my ($vol, $dir) = File::Spec->splitpath($real, 1);
+ return ($vol, File::Spec->splitdir($dir));
+ }
+ else {
+ my $last = pop(@dirs);
+ ($volume, @dirs) = recursive($volume, @dirs);
+ push(@dirs, $last);
+ return ($volume, @dirs);
+ }
+}
+
+$result = realpath($ARGV[0]);
+if (!$result) {
+ my ($vol, $dir) = File::Spec->splitpath($ARGV[0], 1);
+ ($vol, @dirs) = recursive($vol, File::Spec->splitdir($dir));
+
+ $result = File::Spec->catpath($vol, File::Spec->catdir(@dirs), \"\");
+}
+
+if ($ARGV[0] =~ /\\/$/) {
+ $result = $result . \"/\";
+}
+
+print \"\\\"$result\\\"\\n\";
+' \"$1\" 2>/dev/null"
+ "Perl script to produce output suitable for use with `file-truename'
+on the remote file system.
+Escape sequence %s is replaced with name of Perl binary.
+This string is passed to `format', so percent characters need to be doubled.")
+
+(defconst tramp-perl-file-name-all-completions
+ "%s -e 'sub case {
+ my $str = shift;
+ if ($ARGV[2]) {
+ return lc($str);
+ }
+ else {
+ return $str;
+ }
+}
+opendir(d, $ARGV[0]) || die(\"$ARGV[0]: $!\\nfail\\n\");
+@files = readdir(d); closedir(d);
+foreach $f (@files) {
+ if (case(substr($f, 0, length($ARGV[1]))) eq case($ARGV[1])) {
+ if (-d \"$ARGV[0]/$f\") {
+ print \"$f/\\n\";
+ }
+ else {
+ print \"$f\\n\";
+ }
+ }
+}
+print \"ok\\n\"
+' \"$1\" \"$2\" \"$3\" 2>/dev/null"
+ "Perl script to produce output suitable for use with
+`file-name-all-completions' on the remote file system. Escape
+sequence %s is replaced with name of Perl binary. This string is
+passed to `format', so percent characters need to be doubled.")
+
+;; Perl script to implement `file-attributes' in a Lisp `read'able
+;; output. If you are hacking on this, note that you get *no* output
+;; unless this spits out a complete line, including the '\n' at the
+;; end.
+;; The device number is returned as "-1", because there will be a virtual
+;; device number set in `tramp-sh-handle-file-attributes'.
+(defconst tramp-perl-file-attributes
+ "%s -e '
+@stat = lstat($ARGV[0]);
+if (!@stat) {
+ print \"nil\\n\";
+ exit 0;
+}
+if (($stat[2] & 0170000) == 0120000)
+{
+ $type = readlink($ARGV[0]);
+ $type = \"\\\"$type\\\"\";
+}
+elsif (($stat[2] & 0170000) == 040000)
+{
+ $type = \"t\";
+}
+else
+{
+ $type = \"nil\"
+};
+$uid = ($ARGV[1] eq \"integer\") ? $stat[4] : \"\\\"\" . getpwuid($stat[4]) . \"\\\"\";
+$gid = ($ARGV[1] eq \"integer\") ? $stat[5] : \"\\\"\" . getgrgid($stat[5]) . \"\\\"\";
+printf(
+ \"(%%s %%u %%s %%s (%%u %%u) (%%u %%u) (%%u %%u) %%u.0 %%u t (%%u . %%u) -1)\\n\",
+ $type,
+ $stat[3],
+ $uid,
+ $gid,
+ $stat[8] >> 16 & 0xffff,
+ $stat[8] & 0xffff,
+ $stat[9] >> 16 & 0xffff,
+ $stat[9] & 0xffff,
+ $stat[10] >> 16 & 0xffff,
+ $stat[10] & 0xffff,
+ $stat[7],
+ $stat[2],
+ $stat[1] >> 16 & 0xffff,
+ $stat[1] & 0xffff
+);' \"$1\" \"$2\" 2>/dev/null"
+ "Perl script to produce output suitable for use with `file-attributes'
+on the remote file system.
+Escape sequence %s is replaced with name of Perl binary.
+This string is passed to `format', so percent characters need to be doubled.")
+
+(defconst tramp-perl-directory-files-and-attributes
+ "%s -e '
+chdir($ARGV[0]) or printf(\"\\\"Cannot change to $ARGV[0]: $''!''\\\"\\n\"), exit();
+opendir(DIR,\".\") or printf(\"\\\"Cannot open directory $ARGV[0]: $''!''\\\"\\n\"), exit();
+@list = readdir(DIR);
+closedir(DIR);
+$n = scalar(@list);
+printf(\"(\\n\");
+for($i = 0; $i < $n; $i++)
+{
+ $filename = $list[$i];
+ @stat = lstat($filename);
+ if (($stat[2] & 0170000) == 0120000)
+ {
+ $type = readlink($filename);
+ $type = \"\\\"$type\\\"\";
+ }
+ elsif (($stat[2] & 0170000) == 040000)
+ {
+ $type = \"t\";
+ }
+ else
+ {
+ $type = \"nil\"
+ };
+ $uid = ($ARGV[1] eq \"integer\") ? $stat[4] : \"\\\"\" . getpwuid($stat[4]) . \"\\\"\";
+ $gid = ($ARGV[1] eq \"integer\") ? $stat[5] : \"\\\"\" . getgrgid($stat[5]) . \"\\\"\";
+ printf(
+ \"(\\\"%%s\\\" %%s %%u %%s %%s (%%u %%u) (%%u %%u) (%%u %%u) %%u.0 %%u t (%%u . %%u) (%%u . %%u))\\n\",
+ $filename,
+ $type,
+ $stat[3],
+ $uid,
+ $gid,
+ $stat[8] >> 16 & 0xffff,
+ $stat[8] & 0xffff,
+ $stat[9] >> 16 & 0xffff,
+ $stat[9] & 0xffff,
+ $stat[10] >> 16 & 0xffff,
+ $stat[10] & 0xffff,
+ $stat[7],
+ $stat[2],
+ $stat[1] >> 16 & 0xffff,
+ $stat[1] & 0xffff,
+ $stat[0] >> 16 & 0xffff,
+ $stat[0] & 0xffff);
+}
+printf(\")\\n\");' \"$1\" \"$2\" 2>/dev/null"
+ "Perl script implementing `directory-files-attributes' as Lisp `read'able
+output.
+Escape sequence %s is replaced with name of Perl binary.
+This string is passed to `format', so percent characters need to be doubled.")
+
+;; These two use base64 encoding.
+(defconst tramp-perl-encode-with-module
+ "%s -MMIME::Base64 -0777 -ne 'print encode_base64($_)' 2>/dev/null"
+ "Perl program to use for encoding a file.
+Escape sequence %s is replaced with name of Perl binary.
+This string is passed to `format', so percent characters need to be doubled.
+This implementation requires the MIME::Base64 Perl module to be installed
+on the remote host.")
+
+(defconst tramp-perl-decode-with-module
+ "%s -MMIME::Base64 -0777 -ne 'print decode_base64($_)' 2>/dev/null"
+ "Perl program to use for decoding a file.
+Escape sequence %s is replaced with name of Perl binary.
+This string is passed to `format', so percent characters need to be doubled.
+This implementation requires the MIME::Base64 Perl module to be installed
+on the remote host.")
+
+(defconst tramp-perl-encode
+ "%s -e '
+# This script contributed by Juanma Barranquero <lektu@terra.es>.
++# Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
+# Free Software Foundation, Inc.
+use strict;
+
+my %%trans = do {
+ my $i = 0;
+ map {(substr(unpack(q(B8), chr $i++), 2, 6), $_)}
+ split //, q(ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/);
+};
+
+binmode(\\*STDIN);
+
+# We read in chunks of 54 bytes, to generate output lines
+# of 72 chars (plus end of line)
+$/ = \\54;
+
+while (my $data = <STDIN>) {
+ my $pad = q();
+
+ # Only for the last chunk, and only if did not fill the last three-byte packet
+ if (eof) {
+ my $mod = length($data) %% 3;
+ $pad = q(=) x (3 - $mod) if $mod;
+ }
+
+ # Not the fastest method, but it is simple: unpack to binary string, split
+ # by groups of 6 bits and convert back from binary to byte; then map into
+ # the translation table
+ print
+ join q(),
+ map($trans{$_},
+ (substr(unpack(q(B*), $data) . q(00000), 0, 432) =~ /....../g)),
+ $pad,
+ qq(\\n);
+}' 2>/dev/null"
+ "Perl program to use for encoding a file.
+Escape sequence %s is replaced with name of Perl binary.
+This string is passed to `format', so percent characters need to be doubled.")
+
+(defconst tramp-perl-decode
+ "%s -e '
+# This script contributed by Juanma Barranquero <lektu@terra.es>.
+# Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+# Free Software Foundation, Inc.
+use strict;
+
+my %%trans = do {
+ my $i = 0;
+ map {($_, substr(unpack(q(B8), chr $i++), 2, 6))}
+ split //, q(ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/)
+};
+
+my %%bytes = map {(unpack(q(B8), chr $_), chr $_)} 0 .. 255;
+
+binmode(\\*STDOUT);
+
+# We are going to accumulate into $pending to accept any line length
+# (we do not check they are <= 76 chars as the RFC says)
+my $pending = q();
+
+while (my $data = <STDIN>) {
+ chomp $data;
+
+ # If we find one or two =, we have reached the end and
+ # any following data is to be discarded
+ my $finished = $data =~ s/(==?).*/$1/;
+ $pending .= $data;
+
+ my $len = length($pending);
+ my $chunk = substr($pending, 0, $len & ~3);
+ $pending = substr($pending, $len & ~3 + 1);
+
+ # Easy method: translate from chars to (pregenerated) six-bit packets, join,
+ # split in 8-bit chunks and convert back to char.
+ print join q(),
+ map $bytes{$_},
+ ((join q(), map {$trans{$_} || q()} split //, $chunk) =~ /......../g);
+
+ last if $finished;
+}' 2>/dev/null"
+ "Perl program to use for decoding a file.
+Escape sequence %s is replaced with name of Perl binary.
+This string is passed to `format', so percent characters need to be doubled.")
+
+(defconst tramp-vc-registered-read-file-names
+ "echo \"(\"
+while read file; do
+ if %s \"$file\"; then
+ echo \"(\\\"$file\\\" \\\"file-exists-p\\\" t)\"
+ else
+ echo \"(\\\"$file\\\" \\\"file-exists-p\\\" nil)\"
+ fi
+ if %s \"$file\"; then
+ echo \"(\\\"$file\\\" \\\"file-readable-p\\\" t)\"
+ else
+ echo \"(\\\"$file\\\" \\\"file-readable-p\\\" nil)\"
+ fi
+done
+echo \")\""
+ "Script to check existence of VC related files.
+It must be send formatted with two strings; the tests for file
+existence, and file readability. Input shall be read via
+here-document, otherwise the command could exceed maximum length
+of command line.")
+
+(defconst tramp-file-mode-type-map
+ '((0 . "-") ; Normal file (SVID-v2 and XPG2)
+ (1 . "p") ; fifo
+ (2 . "c") ; character device
+ (3 . "m") ; multiplexed character device (v7)
+ (4 . "d") ; directory
+ (5 . "?") ; Named special file (XENIX)
+ (6 . "b") ; block device
+ (7 . "?") ; multiplexed block device (v7)
+ (8 . "-") ; regular file
+ (9 . "n") ; network special file (HP-UX)
+ (10 . "l") ; symlink
+ (11 . "?") ; ACL shadow inode (Solaris, not userspace)
+ (12 . "s") ; socket
+ (13 . "D") ; door special (Solaris)
+ (14 . "w")) ; whiteout (BSD)
+ "A list of file types returned from the `stat' system call.
+This is used to map a mode number to a permission string.")
+
+;; New handlers should be added here. The following operations can be
+;; handled using the normal primitives: file-name-sans-versions,
+;; get-file-buffer.
+(defconst tramp-sh-file-name-handler-alist
+ '((load . tramp-handle-load)
+ (make-symbolic-link . tramp-sh-handle-make-symbolic-link)
+ (file-name-as-directory . tramp-handle-file-name-as-directory)
+ (file-name-directory . tramp-handle-file-name-directory)
+ (file-name-nondirectory . tramp-handle-file-name-nondirectory)
+ (file-truename . tramp-sh-handle-file-truename)
+ (file-exists-p . tramp-sh-handle-file-exists-p)
+ (file-directory-p . tramp-sh-handle-file-directory-p)
+ (file-executable-p . tramp-sh-handle-file-executable-p)
+ (file-readable-p . tramp-sh-handle-file-readable-p)
+ (file-regular-p . tramp-handle-file-regular-p)
+ (file-symlink-p . tramp-handle-file-symlink-p)
+ (file-writable-p . tramp-sh-handle-file-writable-p)
+ (file-ownership-preserved-p . tramp-sh-handle-file-ownership-preserved-p)
+ (file-newer-than-file-p . tramp-sh-handle-file-newer-than-file-p)
+ (file-attributes . tramp-sh-handle-file-attributes)
+ (file-modes . tramp-handle-file-modes)
+ (directory-files . tramp-handle-directory-files)
+ (directory-files-and-attributes
+ . tramp-sh-handle-directory-files-and-attributes)
+ (file-name-all-completions . tramp-sh-handle-file-name-all-completions)
+ (file-name-completion . tramp-handle-file-name-completion)
+ (add-name-to-file . tramp-sh-handle-add-name-to-file)
+ (copy-file . tramp-sh-handle-copy-file)
+ (copy-directory . tramp-sh-handle-copy-directory)
+ (rename-file . tramp-sh-handle-rename-file)
+ (set-file-modes . tramp-sh-handle-set-file-modes)
+ (set-file-times . tramp-sh-handle-set-file-times)
+ (make-directory . tramp-sh-handle-make-directory)
+ (delete-directory . tramp-sh-handle-delete-directory)
+ (delete-file . tramp-sh-handle-delete-file)
+ (directory-file-name . tramp-handle-directory-file-name)
+ ;; `executable-find' is not official yet.
+ (executable-find . tramp-sh-handle-executable-find)
+ (start-file-process . tramp-sh-handle-start-file-process)
+ (process-file . tramp-sh-handle-process-file)
+ (shell-command . tramp-sh-handle-shell-command)
+ (insert-directory . tramp-sh-handle-insert-directory)
+ (expand-file-name . tramp-sh-handle-expand-file-name)
+ (substitute-in-file-name . tramp-handle-substitute-in-file-name)
+ (file-local-copy . tramp-sh-handle-file-local-copy)
+ (file-remote-p . tramp-handle-file-remote-p)
+ (insert-file-contents . tramp-handle-insert-file-contents)
+ (insert-file-contents-literally
+ . tramp-sh-handle-insert-file-contents-literally)
+ (write-region . tramp-sh-handle-write-region)
+ (find-backup-file-name . tramp-handle-find-backup-file-name)
+ (make-auto-save-file-name . tramp-sh-handle-make-auto-save-file-name)
+ (unhandled-file-name-directory . tramp-handle-unhandled-file-name-directory)
+ (dired-compress-file . tramp-sh-handle-dired-compress-file)
+ (dired-recursive-delete-directory
+ . tramp-sh-handle-dired-recursive-delete-directory)
+ (dired-uncache . tramp-handle-dired-uncache)
+ (set-visited-file-modtime . tramp-sh-handle-set-visited-file-modtime)
+ (verify-visited-file-modtime . tramp-sh-handle-verify-visited-file-modtime)
+ (file-selinux-context . tramp-sh-handle-file-selinux-context)
+ (set-file-selinux-context . tramp-sh-handle-set-file-selinux-context)
+ (vc-registered . tramp-sh-handle-vc-registered))
+ "Alist of handler functions.
+Operations not mentioned here will be handled by the normal Emacs functions.")
+
+;; This must be the last entry, because `identity' always matches.
+;;;###tramp-autoload
+(add-to-list 'tramp-foreign-file-name-handler-alist
+ '(identity . tramp-sh-file-name-handler) 'append)
+
+;;; File Name Handler Functions:
+
+(defun tramp-sh-handle-make-symbolic-link
+ (filename linkname &optional ok-if-already-exists)
+ "Like `make-symbolic-link' for Tramp files.
+If LINKNAME is a non-Tramp file, it is used verbatim as the target of
+the symlink. If LINKNAME is a Tramp file, only the localname component is
+used as the target of the symlink.
+
+If LINKNAME is a Tramp file and the localname component is relative, then
+it is expanded first, before the localname component is taken. Note that
+this can give surprising results if the user/host for the source and
+target of the symlink differ."
+ (with-parsed-tramp-file-name linkname l
+ (let ((ln (tramp-get-remote-ln l))
+ (cwd (tramp-run-real-handler
+ 'file-name-directory (list l-localname))))
+ (unless ln
+ (tramp-error
+ l 'file-error
+ "Making a symbolic link. ln(1) does not exist on the remote host."))
+
+ ;; Do the 'confirm if exists' thing.
+ (when (file-exists-p linkname)
+ ;; What to do?
+ (if (or (null ok-if-already-exists) ; not allowed to exist
+ (and (numberp ok-if-already-exists)
+ (not (yes-or-no-p
+ (format
+ "File %s already exists; make it a link anyway? "
+ l-localname)))))
+ (tramp-error
+ l 'file-already-exists "File %s already exists" l-localname)
+ (delete-file linkname)))
+
+ ;; If FILENAME is a Tramp name, use just the localname component.
+ (when (tramp-tramp-file-p filename)
+ (setq filename
+ (tramp-file-name-localname
+ (tramp-dissect-file-name (expand-file-name filename)))))
+
+ (tramp-flush-file-property l (file-name-directory l-localname))
+ (tramp-flush-file-property l l-localname)
+
+ ;; Right, they are on the same host, regardless of user, method, etc.
+ ;; We now make the link on the remote machine. This will occur as the user
+ ;; that FILENAME belongs to.
+ (tramp-send-command-and-check
+ l
+ (format
+ "cd %s && %s -sf %s %s"
+ (tramp-shell-quote-argument cwd)
+ ln
+ (tramp-shell-quote-argument filename)
+ (tramp-shell-quote-argument l-localname))
+ t))))
+
+(defun tramp-sh-handle-file-truename (filename &optional counter prev-dirs)
+ "Like `file-truename' for Tramp files."
+ (with-parsed-tramp-file-name (expand-file-name filename) nil
+ (with-file-property v localname "file-truename"
+ (let ((result nil)) ; result steps in reverse order
+ (tramp-message v 4 "Finding true name for `%s'" filename)
+ (cond
+ ;; Use GNU readlink --canonicalize-missing where available.
+ ((tramp-get-remote-readlink v)
+ (setq result
+ (tramp-send-command-and-read
+ v
+ (format "echo \"\\\"`%s --canonicalize-missing %s`\\\"\""
+ (tramp-get-remote-readlink v)
+ (tramp-shell-quote-argument localname)))))
+
+ ;; Use Perl implementation.
+ ((and (tramp-get-remote-perl v)
+ (tramp-get-connection-property v "perl-file-spec" nil)
+ (tramp-get-connection-property v "perl-cwd-realpath" nil))
+ (tramp-maybe-send-script
+ v tramp-perl-file-truename "tramp_perl_file_truename")
+ (setq result
+ (tramp-send-command-and-read
+ v
+ (format "tramp_perl_file_truename %s"
+ (tramp-shell-quote-argument localname)))))
+
+ ;; Do it yourself. We bind `directory-sep-char' here for
+ ;; XEmacs on Windows, which would otherwise use backslash.
+ (t (let* ((directory-sep-char ?/)
+ (steps (tramp-compat-split-string localname "/"))
+ (localnamedir (tramp-run-real-handler
+ 'file-name-as-directory (list localname)))
+ (is-dir (string= localname localnamedir))
+ (thisstep nil)
+ (numchase 0)
+ ;; Don't make the following value larger than
+ ;; necessary. People expect an error message in a
+ ;; timely fashion when something is wrong;
+ ;; otherwise they might think that Emacs is hung.
+ ;; Of course, correctness has to come first.
+ (numchase-limit 20)
+ symlink-target)
+ (while (and steps (< numchase numchase-limit))
+ (setq thisstep (pop steps))
+ (tramp-message
+ v 5 "Check %s"
+ (mapconcat 'identity
+ (append '("") (reverse result) (list thisstep))
+ "/"))
+ (setq symlink-target
+ (nth 0 (file-attributes
+ (tramp-make-tramp-file-name
+ method user host
+ (mapconcat 'identity
+ (append '("")
+ (reverse result)
+ (list thisstep))
+ "/")))))
+ (cond ((string= "." thisstep)
+ (tramp-message v 5 "Ignoring step `.'"))
+ ((string= ".." thisstep)
+ (tramp-message v 5 "Processing step `..'")
+ (pop result))
+ ((stringp symlink-target)
+ ;; It's a symlink, follow it.
+ (tramp-message v 5 "Follow symlink to %s" symlink-target)
+ (setq numchase (1+ numchase))
+ (when (file-name-absolute-p symlink-target)
+ (setq result nil))
+ ;; If the symlink was absolute, we'll get a string like
+ ;; "/user@host:/some/target"; extract the
+ ;; "/some/target" part from it.
+ (when (tramp-tramp-file-p symlink-target)
+ (unless (tramp-equal-remote filename symlink-target)
+ (tramp-error
+ v 'file-error
+ "Symlink target `%s' on wrong host" symlink-target))
+ (setq symlink-target localname))
+ (setq steps
+ (append (tramp-compat-split-string
+ symlink-target "/")
+ steps)))
+ (t
+ ;; It's a file.
+ (setq result (cons thisstep result)))))
+ (when (>= numchase numchase-limit)
+ (tramp-error
+ v 'file-error
+ "Maximum number (%d) of symlinks exceeded" numchase-limit))
+ (setq result (reverse result))
+ ;; Combine list to form string.
+ (setq result
+ (if result
+ (mapconcat 'identity (cons "" result) "/")
+ "/"))
+ (when (and is-dir (or (string= "" result)
+ (not (string= (substring result -1) "/"))))
+ (setq result (concat result "/"))))))
+
+ (tramp-message v 4 "True name of `%s' is `%s'" filename result)
+ (tramp-make-tramp-file-name method user host result)))))
+
+;; Basic functions.
+
+(defun tramp-sh-handle-file-exists-p (filename)
+ "Like `file-exists-p' for Tramp files."
+ (with-parsed-tramp-file-name filename nil
+ (with-file-property v localname "file-exists-p"
+ (or (not (null (tramp-get-file-property
+ v localname "file-attributes-integer" nil)))
+ (not (null (tramp-get-file-property
+ v localname "file-attributes-string" nil)))
+ (tramp-send-command-and-check
+ v
+ (format
+ "%s %s"
+ (tramp-get-file-exists-command v)
+ (tramp-shell-quote-argument localname)))))))
+
+;; CCC: This should check for an error condition and signal failure
+;; when something goes wrong.
+;; Daniel Pittman <daniel@danann.net>
+(defun tramp-sh-handle-file-attributes (filename &optional id-format)
+ "Like `file-attributes' for Tramp files."
+ (unless id-format (setq id-format 'integer))
+ ;; Don't modify `last-coding-system-used' by accident.
+ (let ((last-coding-system-used last-coding-system-used))
+ (with-parsed-tramp-file-name (expand-file-name filename) nil
+ (with-file-property v localname (format "file-attributes-%s" id-format)
+ (save-excursion
+ (tramp-convert-file-attributes
+ v
+ (cond
+ ((tramp-get-remote-stat v)
+ (tramp-do-file-attributes-with-stat v localname id-format))
+ ((tramp-get-remote-perl v)
+ (tramp-do-file-attributes-with-perl v localname id-format))
+ (t
+ (tramp-do-file-attributes-with-ls v localname id-format)))))))))
+
+(defun tramp-do-file-attributes-with-ls (vec localname &optional id-format)
+ "Implement `file-attributes' for Tramp files using the ls(1) command."
+ (let (symlinkp dirp
+ res-inode res-filemodes res-numlinks
+ res-uid res-gid res-size res-symlink-target)
+ (tramp-message vec 5 "file attributes with ls: %s" localname)
+ (tramp-send-command
+ vec
+ (format "(%s %s || %s -h %s) && %s %s %s"
+ (tramp-get-file-exists-command vec)
+ (tramp-shell-quote-argument localname)
+ (tramp-get-test-command vec)
+ (tramp-shell-quote-argument localname)
+ (tramp-get-ls-command vec)
+ (if (eq id-format 'integer) "-ildn" "-ild")
+ (tramp-shell-quote-argument localname)))
+ ;; parse `ls -l' output ...
+ (with-current-buffer (tramp-get-buffer vec)
+ (when (> (buffer-size) 0)
+ (goto-char (point-min))
+ ;; ... inode
+ (setq res-inode
+ (condition-case err
+ (read (current-buffer))
+ (invalid-read-syntax
+ (when (and (equal (cadr err)
+ "Integer constant overflow in reader")
+ (string-match
+ "^[0-9]+\\([0-9][0-9][0-9][0-9][0-9]\\)\\'"
+ (car (cddr err))))
+ (let* ((big (read (substring (car (cddr err)) 0
+ (match-beginning 1))))
+ (small (read (match-string 1 (car (cddr err)))))
+ (twiddle (/ small 65536)))
+ (cons (+ big twiddle)
+ (- small (* twiddle 65536))))))))
+ ;; ... file mode flags
+ (setq res-filemodes (symbol-name (read (current-buffer))))
+ ;; ... number links
+ (setq res-numlinks (read (current-buffer)))
+ ;; ... uid and gid
+ (setq res-uid (read (current-buffer)))
+ (setq res-gid (read (current-buffer)))
+ (if (eq id-format 'integer)
+ (progn
+ (unless (numberp res-uid) (setq res-uid -1))
+ (unless (numberp res-gid) (setq res-gid -1)))
+ (progn
+ (unless (stringp res-uid) (setq res-uid (symbol-name res-uid)))
+ (unless (stringp res-gid) (setq res-gid (symbol-name res-gid)))))
+ ;; ... size
+ (setq res-size (read (current-buffer)))
+ ;; From the file modes, figure out other stuff.
+ (setq symlinkp (eq ?l (aref res-filemodes 0)))
+ (setq dirp (eq ?d (aref res-filemodes 0)))
+ ;; if symlink, find out file name pointed to
+ (when symlinkp
+ (search-forward "-> ")
+ (setq res-symlink-target (buffer-substring (point) (point-at-eol))))
+ ;; return data gathered
+ (list
+ ;; 0. t for directory, string (name linked to) for symbolic
+ ;; link, or nil.
+ (or dirp res-symlink-target)
+ ;; 1. Number of links to file.
+ res-numlinks
+ ;; 2. File uid.
+ res-uid
+ ;; 3. File gid.
+ res-gid
+ ;; 4. Last access time, as a list of two integers. First
+ ;; integer has high-order 16 bits of time, second has low 16
+ ;; bits.
+ ;; 5. Last modification time, likewise.
+ ;; 6. Last status change time, likewise.
+ '(0 0) '(0 0) '(0 0) ;CCC how to find out?
+ ;; 7. Size in bytes (-1, if number is out of range).
+ res-size
+ ;; 8. File modes, as a string of ten letters or dashes as in ls -l.
+ res-filemodes
+ ;; 9. t if file's gid would change if file were deleted and
+ ;; recreated. Will be set in `tramp-convert-file-attributes'
+ t
+ ;; 10. inode number.
+ res-inode
+ ;; 11. Device number. Will be replaced by a virtual device number.
+ -1
+ )))))
+
+(defun tramp-do-file-attributes-with-perl
+ (vec localname &optional id-format)
+ "Implement `file-attributes' for Tramp files using a Perl script."
+ (tramp-message vec 5 "file attributes with perl: %s" localname)
+ (tramp-maybe-send-script
+ vec tramp-perl-file-attributes "tramp_perl_file_attributes")
+ (tramp-send-command-and-read
+ vec
+ (format "tramp_perl_file_attributes %s %s"
+ (tramp-shell-quote-argument localname) id-format)))
+
+(defun tramp-do-file-attributes-with-stat
+ (vec localname &optional id-format)
+ "Implement `file-attributes' for Tramp files using stat(1) command."
+ (tramp-message vec 5 "file attributes with stat: %s" localname)
+ (tramp-send-command-and-read
+ vec
+ (format
+ ;; On Opsware, pdksh (which is the true name of ksh there) doesn't
+ ;; parse correctly the sequence "((". Therefore, we add a space.
+ "( (%s %s || %s -h %s) && %s -c '((\"%%N\") %%h %s %s %%Xe0 %%Ye0 %%Ze0 %%se0 \"%%A\" t %%ie0 -1)' %s || echo nil)"
+ (tramp-get-file-exists-command vec)
+ (tramp-shell-quote-argument localname)
+ (tramp-get-test-command vec)
+ (tramp-shell-quote-argument localname)
+ (tramp-get-remote-stat vec)
+ (if (eq id-format 'integer) "%u" "\"%U\"")
+ (if (eq id-format 'integer) "%g" "\"%G\"")
+ (tramp-shell-quote-argument localname))))
+
+(defun tramp-sh-handle-set-visited-file-modtime (&optional time-list)
+ "Like `set-visited-file-modtime' for Tramp files."
+ (unless (buffer-file-name)
+ (error "Can't set-visited-file-modtime: buffer `%s' not visiting a file"
+ (buffer-name)))
+ (if time-list
+ (tramp-run-real-handler 'set-visited-file-modtime (list time-list))
+ (let ((f (buffer-file-name))
+ coding-system-used)
+ (with-parsed-tramp-file-name f nil
+ (let* ((attr (file-attributes f))
+ ;; '(-1 65535) means file doesn't exists yet.
+ (modtime (or (nth 5 attr) '(-1 65535))))
+ (when (boundp 'last-coding-system-used)
+ (setq coding-system-used (symbol-value 'last-coding-system-used)))
+ ;; We use '(0 0) as a don't-know value. See also
+ ;; `tramp-do-file-attributes-with-ls'.
+ (if (not (equal modtime '(0 0)))
+ (tramp-run-real-handler 'set-visited-file-modtime (list modtime))
+ (progn
+ (tramp-send-command
+ v
+ (format "%s -ild %s"
+ (tramp-get-ls-command v)
+ (tramp-shell-quote-argument localname)))
+ (setq attr (buffer-substring (point)
+ (progn (end-of-line) (point)))))
+ (tramp-set-file-property
+ v localname "visited-file-modtime-ild" attr))
+ (when (boundp 'last-coding-system-used)
+ (set 'last-coding-system-used coding-system-used))
+ nil)))))
+
+;; This function makes the same assumption as
+;; `tramp-sh-handle-set-visited-file-modtime'.
+(defun tramp-sh-handle-verify-visited-file-modtime (buf)
+ "Like `verify-visited-file-modtime' for Tramp files.
+At the time `verify-visited-file-modtime' calls this function, we
+already know that the buffer is visiting a file and that
+`visited-file-modtime' does not return 0. Do not call this
+function directly, unless those two cases are already taken care
+of."
+ (with-current-buffer buf
+ (let ((f (buffer-file-name)))
+ ;; There is no file visiting the buffer, or the buffer has no
+ ;; recorded last modification time, or there is no established
+ ;; connection.
+ (if (or (not f)
+ (eq (visited-file-modtime) 0)
+ (not (tramp-file-name-handler 'file-remote-p f nil 'connected)))
+ t
+ (with-parsed-tramp-file-name f nil
+ (let* ((remote-file-name-inhibit-cache t)
+ (attr (file-attributes f))
+ (modtime (nth 5 attr))
+ (mt (visited-file-modtime)))
+
+ (cond
+ ;; File exists, and has a known modtime.
+ ((and attr (not (equal modtime '(0 0))))
+ (< (abs (tramp-time-diff
+ modtime
+ ;; For compatibility, deal with both the old
+ ;; (HIGH . LOW) and the new (HIGH LOW) return
+ ;; values of `visited-file-modtime'.
+ (if (atom (cdr mt))
+ (list (car mt) (cdr mt))
+ mt)))
+ 2))
+ ;; Modtime has the don't know value.
+ (attr
+ (tramp-send-command
+ v
+ (format "%s -ild %s"
+ (tramp-get-ls-command v)
+ (tramp-shell-quote-argument localname)))
+ (with-current-buffer (tramp-get-buffer v)
+ (setq attr (buffer-substring
+ (point) (progn (end-of-line) (point)))))
+ (equal
+ attr
+ (tramp-get-file-property
+ v localname "visited-file-modtime-ild" "")))
+ ;; If file does not exist, say it is not modified if and
+ ;; only if that agrees with the buffer's record.
+ (t (equal mt '(-1 65535))))))))))
+
+(defun tramp-sh-handle-set-file-modes (filename mode)
+ "Like `set-file-modes' for Tramp files."
+ (with-parsed-tramp-file-name filename nil
+ (tramp-flush-file-property v localname)
+ ;; FIXME: extract the proper text from chmod's stderr.
+ (tramp-barf-unless-okay
+ v
+ (format "chmod %s %s"
+ (tramp-compat-decimal-to-octal mode)
+ (tramp-shell-quote-argument localname))
+ "Error while changing file's mode %s" filename)))
+
+(defun tramp-sh-handle-set-file-times (filename &optional time)
+ "Like `set-file-times' for Tramp files."
+ (if (file-remote-p filename)
+ (with-parsed-tramp-file-name filename nil
+ (tramp-flush-file-property v localname)
+ (let ((time (if (or (null time) (equal time '(0 0)))
+ (current-time)
+ time))
+ ;; With GNU Emacs, `format-time-string' has an optional
+ ;; parameter UNIVERSAL. This is preferred, because we
+ ;; could handle the case when the remote host is located
+ ;; in a different time zone as the local host.
+ (utc (not (featurep 'xemacs))))
+ (tramp-send-command-and-check
+ v (format "%s touch -t %s %s"
+ (if utc "TZ=UTC; export TZ;" "")
+ (if utc
+ (format-time-string "%Y%m%d%H%M.%S" time t)
+ (format-time-string "%Y%m%d%H%M.%S" time))
+ (tramp-shell-quote-argument localname)))))
+
+ ;; We handle also the local part, because in older Emacsen,
+ ;; without `set-file-times', this function is an alias for this.
+ ;; We are local, so we don't need the UTC settings.
+ (zerop
+ (tramp-compat-call-process
+ "touch" nil nil nil "-t"
+ (format-time-string "%Y%m%d%H%M.%S" time)
+ (tramp-shell-quote-argument filename)))))
+
+(defun tramp-set-file-uid-gid (filename &optional uid gid)
+ "Set the ownership for FILENAME.
+If UID and GID are provided, these values are used; otherwise uid
+and gid of the corresponding user is taken. Both parameters must be integers."
+ ;; Modern Unices allow chown only for root. So we might need
+ ;; another implementation, see `dired-do-chown'. OTOH, it is mostly
+ ;; working with su(do)? when it is needed, so it shall succeed in
+ ;; the majority of cases.
+ ;; Don't modify `last-coding-system-used' by accident.
+ (let ((last-coding-system-used last-coding-system-used))
+ (if (file-remote-p filename)
+ (with-parsed-tramp-file-name filename nil
+ (if (and (zerop (user-uid)) (tramp-local-host-p v))
+ ;; If we are root on the local host, we can do it directly.
+ (tramp-set-file-uid-gid localname uid gid)
+ (let ((uid (or (and (integerp uid) uid)
+ (tramp-get-remote-uid v 'integer)))
+ (gid (or (and (integerp gid) gid)
+ (tramp-get-remote-gid v 'integer))))
+ (tramp-send-command
+ v (format
+ "chown %d:%d %s" uid gid
+ (tramp-shell-quote-argument localname))))))
+
+ ;; We handle also the local part, because there doesn't exist
+ ;; `set-file-uid-gid'. On W32 "chown" might not work.
+ (let ((uid (or (and (integerp uid) uid) (tramp-get-local-uid 'integer)))
+ (gid (or (and (integerp gid) gid) (tramp-get-local-gid 'integer))))
+ (tramp-compat-call-process
+ "chown" nil nil nil
+ (format "%d:%d" uid gid) (tramp-shell-quote-argument filename))))))
+
+(defun tramp-remote-selinux-p (vec)
+ "Check, whether SELINUX is enabled on the remote host."
+ (with-connection-property (tramp-get-connection-process vec) "selinux-p"
+ (let ((result (tramp-find-executable
+ vec "getenforce" (tramp-get-remote-path vec) t t)))
+ (and result
+ (string-equal
+ (tramp-send-command-and-read
+ vec (format "echo \\\"`%S`\\\"" result))
+ "Enforcing")))))
+
+(defun tramp-sh-handle-file-selinux-context (filename)
+ "Like `file-selinux-context' for Tramp files."
+ (with-parsed-tramp-file-name filename nil
+ (with-file-property v localname "file-selinux-context"
+ (let ((context '(nil nil nil nil))
+ (regexp (concat "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\):"
+ "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\)")))
+ (when (and (tramp-remote-selinux-p v)
+ (tramp-send-command-and-check
+ v (format
+ "%s -d -Z %s"
+ (tramp-get-ls-command v)
+ (tramp-shell-quote-argument localname))))
+ (with-current-buffer (tramp-get-connection-buffer v)
+ (goto-char (point-min))
+ (when (re-search-forward regexp (point-at-eol) t)
+ (setq context (list (match-string 1) (match-string 2)
+ (match-string 3) (match-string 4))))))
+ ;; Return the context.
+ context))))
+
+(defun tramp-sh-handle-set-file-selinux-context (filename context)
+ "Like `set-file-selinux-context' for Tramp files."
+ (with-parsed-tramp-file-name filename nil
+ (if (and (consp context)
+ (tramp-remote-selinux-p v)
+ (tramp-send-command-and-check
+ v (format "chcon %s %s %s %s %s"
+ (if (stringp (nth 0 context))
+ (format "--user=%s" (nth 0 context)) "")
+ (if (stringp (nth 1 context))
+ (format "--role=%s" (nth 1 context)) "")
+ (if (stringp (nth 2 context))
+ (format "--type=%s" (nth 2 context)) "")
+ (if (stringp (nth 3 context))
+ (format "--range=%s" (nth 3 context)) "")
+ (tramp-shell-quote-argument localname))))
+ (tramp-set-file-property v localname "file-selinux-context" context)
+ (tramp-set-file-property v localname "file-selinux-context" 'undef)))
+ ;; We always return nil.
+ nil)
+
+;; Simple functions using the `test' command.
+
+(defun tramp-sh-handle-file-executable-p (filename)
+ "Like `file-executable-p' for Tramp files."
+ (with-parsed-tramp-file-name filename nil
+ (with-file-property v localname "file-executable-p"
+ ;; Examine `file-attributes' cache to see if request can be
+ ;; satisfied without remote operation.
+ (or (tramp-check-cached-permissions v ?x)
+ (tramp-run-test "-x" filename)))))
+
+(defun tramp-sh-handle-file-readable-p (filename)
+ "Like `file-readable-p' for Tramp files."
+ (with-parsed-tramp-file-name filename nil
+ (with-file-property v localname "file-readable-p"
+ ;; Examine `file-attributes' cache to see if request can be
+ ;; satisfied without remote operation.
+ (or (tramp-check-cached-permissions v ?r)
+ (tramp-run-test "-r" filename)))))
+
+;; When the remote shell is started, it looks for a shell which groks
+;; tilde expansion. Here, we assume that all shells which grok tilde
+;; expansion will also provide a `test' command which groks `-nt' (for
+;; newer than). If this breaks, tell me about it and I'll try to do
+;; something smarter about it.
+(defun tramp-sh-handle-file-newer-than-file-p (file1 file2)
+ "Like `file-newer-than-file-p' for Tramp files."
+ (cond ((not (file-exists-p file1))
+ nil)
+ ((not (file-exists-p file2))
+ t)
+ ;; We are sure both files exist at this point.
+ (t
+ (save-excursion
+ ;; We try to get the mtime of both files. If they are not
+ ;; equal to the "dont-know" value, then we subtract the times
+ ;; and obtain the result.
+ (let ((fa1 (file-attributes file1))
+ (fa2 (file-attributes file2)))
+ (if (and (not (equal (nth 5 fa1) '(0 0)))
+ (not (equal (nth 5 fa2) '(0 0))))
+ (> 0 (tramp-time-diff (nth 5 fa2) (nth 5 fa1)))
+ ;; If one of them is the dont-know value, then we can
+ ;; still try to run a shell command on the remote host.
+ ;; However, this only works if both files are Tramp
+ ;; files and both have the same method, same user, same
+ ;; host.
+ (unless (tramp-equal-remote file1 file2)
+ (with-parsed-tramp-file-name
+ (if (tramp-tramp-file-p file1) file1 file2) nil
+ (tramp-error
+ v 'file-error
+ "Files %s and %s must have same method, user, host"
+ file1 file2)))
+ (with-parsed-tramp-file-name file1 nil
+ (tramp-run-test2
+ (tramp-get-test-nt-command v) file1 file2))))))))
+
+;; Functions implemented using the basic functions above.
+
+(defun tramp-sh-handle-file-directory-p (filename)
+ "Like `file-directory-p' for Tramp files."
+ ;; Care must be taken that this function returns `t' for symlinks
+ ;; pointing to directories. Surely the most obvious implementation
+ ;; would be `test -d', but that returns false for such symlinks.
+ ;; CCC: Stefan Monnier says that `test -d' follows symlinks. And
+ ;; I now think he's right. So we could be using `test -d', couldn't
+ ;; we?
+ ;;
+ ;; Alternatives: `cd %s', `test -d %s'
+ (with-parsed-tramp-file-name filename nil
+ (with-file-property v localname "file-directory-p"
+ (tramp-run-test "-d" filename))))
+
+(defun tramp-sh-handle-file-writable-p (filename)
+ "Like `file-writable-p' for Tramp files."
+ (with-parsed-tramp-file-name filename nil
+ (with-file-property v localname "file-writable-p"
+ (if (file-exists-p filename)
+ ;; Examine `file-attributes' cache to see if request can be
+ ;; satisfied without remote operation.
+ (or (tramp-check-cached-permissions v ?w)
+ (tramp-run-test "-w" filename))
+ ;; If file doesn't exist, check if directory is writable.
+ (and (tramp-run-test "-d" (file-name-directory filename))
+ (tramp-run-test "-w" (file-name-directory filename)))))))
+
+(defun tramp-sh-handle-file-ownership-preserved-p (filename)
+ "Like `file-ownership-preserved-p' for Tramp files."
+ (with-parsed-tramp-file-name filename nil
+ (with-file-property v localname "file-ownership-preserved-p"
+ (let ((attributes (file-attributes filename)))
+ ;; Return t if the file doesn't exist, since it's true that no
+ ;; information would be lost by an (attempted) delete and create.
+ (or (null attributes)
+ (= (nth 2 attributes) (tramp-get-remote-uid v 'integer)))))))
+
+;; Directory listings.
+
+(defun tramp-sh-handle-directory-files-and-attributes
+ (directory &optional full match nosort id-format)
+ "Like `directory-files-and-attributes' for Tramp files."
+ (unless id-format (setq id-format 'integer))
+ (when (file-directory-p directory)
+ (setq directory (expand-file-name directory))
+ (let* ((temp
+ (copy-tree
+ (with-parsed-tramp-file-name directory nil
+ (with-file-property
+ v localname
+ (format "directory-files-and-attributes-%s" id-format)
+ (save-excursion
+ (mapcar
+ (lambda (x)
+ (cons (car x)
+ (tramp-convert-file-attributes v (cdr x))))
+ (cond
+ ((tramp-get-remote-stat v)
+ (tramp-do-directory-files-and-attributes-with-stat
+ v localname id-format))
+ ((tramp-get-remote-perl v)
+ (tramp-do-directory-files-and-attributes-with-perl
+ v localname id-format)))))))))
+ result item)
+
+ (while temp
+ (setq item (pop temp))
+ (when (or (null match) (string-match match (car item)))
+ (when full
+ (setcar item (expand-file-name (car item) directory)))
+ (push item result)))
+
+ (if nosort
+ result
+ (sort result (lambda (x y) (string< (car x) (car y))))))))
+
+(defun tramp-do-directory-files-and-attributes-with-perl
+ (vec localname &optional id-format)
+ "Implement `directory-files-and-attributes' for Tramp files using a Perl script."
+ (tramp-message vec 5 "directory-files-and-attributes with perl: %s" localname)
+ (tramp-maybe-send-script
+ vec tramp-perl-directory-files-and-attributes
+ "tramp_perl_directory_files_and_attributes")
+ (let ((object
+ (tramp-send-command-and-read
+ vec
+ (format "tramp_perl_directory_files_and_attributes %s %s"
+ (tramp-shell-quote-argument localname) id-format))))
+ (when (stringp object) (tramp-error vec 'file-error object))
+ object))
+
+(defun tramp-do-directory-files-and-attributes-with-stat
+ (vec localname &optional id-format)
+ "Implement `directory-files-and-attributes' for Tramp files using stat(1) command."
+ (tramp-message vec 5 "directory-files-and-attributes with stat: %s" localname)
+ (tramp-send-command-and-read
+ vec
+ (format
+ (concat
+ ;; We must care about filenames with spaces, or starting with
+ ;; "-"; this would confuse xargs. "ls -aQ" might be a solution,
+ ;; but it does not work on all remote systems. Therefore, we
+ ;; quote the filenames via sed.
+ "cd %s; echo \"(\"; (%s -a | sed -e s/\\$/\\\"/g -e s/^/\\\"/g | xargs "
+ "%s -c '(\"%%n\" (\"%%N\") %%h %s %s %%Xe0 %%Ye0 %%Ze0 %%se0 \"%%A\" t %%ie0 -1)'); "
+ "echo \")\"")
+ (tramp-shell-quote-argument localname)
+ (tramp-get-ls-command vec)
+ (tramp-get-remote-stat vec)
+ (if (eq id-format 'integer) "%u" "\"%U\"")
+ (if (eq id-format 'integer) "%g" "\"%G\""))))
+
+;; This function should return "foo/" for directories and "bar" for
+;; files.
+(defun tramp-sh-handle-file-name-all-completions (filename directory)
+ "Like `file-name-all-completions' for Tramp files."
+ (unless (save-match-data (string-match "/" filename))
+ (with-parsed-tramp-file-name (expand-file-name directory) nil
+
+ (all-completions
+ filename
+ (mapcar
+ 'list
+ (or
+ ;; Try cache entries for filename, filename with last
+ ;; character removed, filename with last two characters
+ ;; removed, ..., and finally the empty string - all
+ ;; concatenated to the local directory name.
+ (let ((remote-file-name-inhibit-cache
+ (or remote-file-name-inhibit-cache
+ tramp-completion-reread-directory-timeout)))
+
+ ;; This is inefficient for very long filenames, pity
+ ;; `reduce' is not available...
+ (car
+ (apply
+ 'append
+ (mapcar
+ (lambda (x)
+ (let ((cache-hit
+ (tramp-get-file-property
+ v
+ (concat localname (substring filename 0 x))
+ "file-name-all-completions"
+ nil)))
+ (when cache-hit (list cache-hit))))
+ (tramp-compat-number-sequence (length filename) 0 -1)))))
+
+ ;; Cache expired or no matching cache entry found so we need
+ ;; to perform a remote operation.
+ (let (result)
+ ;; Get a list of directories and files, including reliably
+ ;; tagging the directories with a trailing '/'. Because I
+ ;; rock. --daniel@danann.net
+
+ ;; Changed to perform `cd' in the same remote op and only
+ ;; get entries starting with `filename'. Capture any `cd'
+ ;; error messages. Ensure any `cd' and `echo' aliases are
+ ;; ignored.
+ (tramp-send-command
+ v
+ (if (tramp-get-remote-perl v)
+ (progn
+ (tramp-maybe-send-script
+ v tramp-perl-file-name-all-completions
+ "tramp_perl_file_name_all_completions")
+ (format "tramp_perl_file_name_all_completions %s %s %d"
+ (tramp-shell-quote-argument localname)
+ (tramp-shell-quote-argument filename)
+ (if (symbol-value
+ ;; `read-file-name-completion-ignore-case'
+ ;; is introduced with Emacs 22.1.
+ (if (boundp
+ 'read-file-name-completion-ignore-case)
+ 'read-file-name-completion-ignore-case
+ 'completion-ignore-case))
+ 1 0)))
+
+ (format (concat
+ "(\\cd %s 2>&1 && (%s %s -a 2>/dev/null"
+ ;; `ls' with wildcard might fail with `Argument
+ ;; list too long' error in some corner cases; if
+ ;; `ls' fails after `cd' succeeded, chances are
+ ;; that's the case, so let's retry without
+ ;; wildcard. This will return "too many" entries
+ ;; but that isn't harmful.
+ " || %s -a 2>/dev/null)"
+ " | while read f; do"
+ " if %s -d \"$f\" 2>/dev/null;"
+ " then \\echo \"$f/\"; else \\echo \"$f\"; fi; done"
+ " && \\echo ok) || \\echo fail")
+ (tramp-shell-quote-argument localname)
+ (tramp-get-ls-command v)
+ ;; When `filename' is empty, just `ls' without
+ ;; filename argument is more efficient than `ls *'
+ ;; for very large directories and might avoid the
+ ;; `Argument list too long' error.
+ ;;
+ ;; With and only with wildcard, we need to add
+ ;; `-d' to prevent `ls' from descending into
+ ;; sub-directories.
+ (if (zerop (length filename))
+ "."
+ (concat (tramp-shell-quote-argument filename) "* -d"))
+ (tramp-get-ls-command v)
+ (tramp-get-test-command v))))
+
+ ;; Now grab the output.
+ (with-current-buffer (tramp-get-buffer v)
+ (goto-char (point-max))
+
+ ;; Check result code, found in last line of output
+ (forward-line -1)
+ (if (looking-at "^fail$")
+ (progn
+ ;; Grab error message from line before last line
+ ;; (it was put there by `cd 2>&1')
+ (forward-line -1)
+ (tramp-error
+ v 'file-error
+ "tramp-sh-handle-file-name-all-completions: %s"
+ (buffer-substring (point) (point-at-eol))))
+ ;; For peace of mind, if buffer doesn't end in `fail'
+ ;; then it should end in `ok'. If neither are in the
+ ;; buffer something went seriously wrong on the remote
+ ;; side.
+ (unless (looking-at "^ok$")
+ (tramp-error
+ v 'file-error
+ "\
+tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'"
+ (tramp-shell-quote-argument localname) (buffer-string))))
+
+ (while (zerop (forward-line -1))
+ (push (buffer-substring (point) (point-at-eol)) result)))
+
+ ;; Because the remote op went through OK we know the
+ ;; directory we `cd'-ed to exists
+ (tramp-set-file-property
+ v localname "file-exists-p" t)
+
+ ;; Because the remote op went through OK we know every
+ ;; file listed by `ls' exists.
+ (mapc (lambda (entry)
+ (tramp-set-file-property
+ v (concat localname entry) "file-exists-p" t))
+ result)
+
+ ;; Store result in the cache
+ (tramp-set-file-property
+ v (concat localname filename)
+ "file-name-all-completions"
+ result))))))))
+
+;; cp, mv and ln
+
+(defun tramp-sh-handle-add-name-to-file
+ (filename newname &optional ok-if-already-exists)
+ "Like `add-name-to-file' for Tramp files."
+ (unless (tramp-equal-remote filename newname)
+ (with-parsed-tramp-file-name
+ (if (tramp-tramp-file-p filename) filename newname) nil
+ (tramp-error
+ v 'file-error
+ "add-name-to-file: %s"
+ "only implemented for same method, same user, same host")))
+ (with-parsed-tramp-file-name filename v1
+ (with-parsed-tramp-file-name newname v2
+ (let ((ln (when v1 (tramp-get-remote-ln v1))))
+ (when (and (not ok-if-already-exists)
+ (file-exists-p newname)
+ (not (numberp ok-if-already-exists))
+ (y-or-n-p
+ (format
+ "File %s already exists; make it a new name anyway? "
+ newname)))
+ (tramp-error
+ v2 'file-error
+ "add-name-to-file: file %s already exists" newname))
+ (tramp-flush-file-property v2 (file-name-directory v2-localname))
+ (tramp-flush-file-property v2 v2-localname)
+ (tramp-barf-unless-okay
+ v1
+ (format "%s %s %s" ln (tramp-shell-quote-argument v1-localname)
+ (tramp-shell-quote-argument v2-localname))
+ "error with add-name-to-file, see buffer `%s' for details"
+ (buffer-name))))))
+
+(defun tramp-sh-handle-copy-file
+ (filename newname &optional ok-if-already-exists keep-date
+ preserve-uid-gid preserve-selinux-context)
+ "Like `copy-file' for Tramp files."
+ (setq filename (expand-file-name filename))
+ (setq newname (expand-file-name newname))
+ (cond
+ ;; At least one file a Tramp file?
+ ((or (tramp-tramp-file-p filename)
+ (tramp-tramp-file-p newname))
+ (tramp-do-copy-or-rename-file
+ 'copy filename newname ok-if-already-exists keep-date
+ preserve-uid-gid preserve-selinux-context))
+ ;; Compat section.
+ (preserve-selinux-context
+ (tramp-run-real-handler
+ 'copy-file
+ (list filename newname ok-if-already-exists keep-date
+ preserve-uid-gid preserve-selinux-context)))
+ (preserve-uid-gid
+ (tramp-run-real-handler
+ 'copy-file
+ (list filename newname ok-if-already-exists keep-date preserve-uid-gid)))
+ (t
+ (tramp-run-real-handler
+ 'copy-file (list filename newname ok-if-already-exists keep-date)))))
+
+(defun tramp-sh-handle-copy-directory
+ (dirname newname &optional keep-date parents)
+ "Like `copy-directory' for Tramp files."
+ (let ((t1 (tramp-tramp-file-p dirname))
+ (t2 (tramp-tramp-file-p newname)))
+ (with-parsed-tramp-file-name (if t1 dirname newname) nil
+ (if (and (tramp-get-method-parameter method 'tramp-copy-recursive)
+ ;; When DIRNAME and NEWNAME are remote, they must have
+ ;; the same method.
+ (or (null t1) (null t2)
+ (string-equal
+ (tramp-file-name-method (tramp-dissect-file-name dirname))
+ (tramp-file-name-method (tramp-dissect-file-name newname)))))
+ ;; scp or rsync DTRT.
+ (progn
+ (setq dirname (directory-file-name (expand-file-name dirname))
+ newname (directory-file-name (expand-file-name newname)))
+ (if (and (file-directory-p newname)
+ (not (string-equal (file-name-nondirectory dirname)
+ (file-name-nondirectory newname))))
+ (setq newname
+ (expand-file-name
+ (file-name-nondirectory dirname) newname)))
+ (if (not (file-directory-p (file-name-directory newname)))
+ (make-directory (file-name-directory newname) parents))
+ (tramp-do-copy-or-rename-file-out-of-band
+ 'copy dirname newname keep-date))
+ ;; We must do it file-wise.
+ (tramp-run-real-handler
+ 'copy-directory (list dirname newname keep-date parents)))
+
+ ;; When newname did exist, we have wrong cached values.
+ (when t2
+ (with-parsed-tramp-file-name newname nil
+ (tramp-flush-file-property v (file-name-directory localname))
+ (tramp-flush-file-property v localname))))))
+
+(defun tramp-sh-handle-rename-file
+ (filename newname &optional ok-if-already-exists)
+ "Like `rename-file' for Tramp files."
+ ;; Check if both files are local -- invoke normal rename-file.
+ ;; Otherwise, use Tramp from local system.
+ (setq filename (expand-file-name filename))
+ (setq newname (expand-file-name newname))
+ ;; At least one file a Tramp file?
+ (if (or (tramp-tramp-file-p filename)
+ (tramp-tramp-file-p newname))
+ (tramp-do-copy-or-rename-file
+ 'rename filename newname ok-if-already-exists t t)
+ (tramp-run-real-handler
+ 'rename-file (list filename newname ok-if-already-exists))))
+
+(defun tramp-do-copy-or-rename-file
+ (op filename newname &optional ok-if-already-exists keep-date
+ preserve-uid-gid preserve-selinux-context)
+ "Copy or rename a remote file.
+OP must be `copy' or `rename' and indicates the operation to perform.
+FILENAME specifies the file to copy or rename, NEWNAME is the name of
+the new file (for copy) or the new name of the file (for rename).
+OK-IF-ALREADY-EXISTS means don't barf if NEWNAME exists already.
+KEEP-DATE means to make sure that NEWNAME has the same timestamp
+as FILENAME. PRESERVE-UID-GID, when non-nil, instructs to keep
+the uid and gid if both files are on the same host.
+PRESERVE-SELINUX-CONTEXT activates selinux commands.
+
+This function is invoked by `tramp-sh-handle-copy-file' and
+`tramp-sh-handle-rename-file'. It is an error if OP is neither
+of `copy' and `rename'. FILENAME and NEWNAME must be absolute
+file names."
+ (unless (memq op '(copy rename))
+ (error "Unknown operation `%s', must be `copy' or `rename'" op))
+ (let ((t1 (tramp-tramp-file-p filename))
+ (t2 (tramp-tramp-file-p newname))
+ (context (and preserve-selinux-context
+ (apply 'file-selinux-context (list filename))))
+ pr tm)
+
+ (with-parsed-tramp-file-name (if t1 filename newname) nil
+ (when (and (not ok-if-already-exists) (file-exists-p newname))
+ (tramp-error
+ v 'file-already-exists "File %s already exists" newname))
+
+ (with-progress-reporter
+ v 0 (format "%s %s to %s"
+ (if (eq op 'copy) "Copying" "Renaming")
+ filename newname)
+
+ (cond
+ ;; Both are Tramp files.
+ ((and t1 t2)
+ (with-parsed-tramp-file-name filename v1
+ (with-parsed-tramp-file-name newname v2
+ (cond
+ ;; Shortcut: if method, host, user are the same for
+ ;; both files, we invoke `cp' or `mv' on the remote
+ ;; host directly.
+ ((tramp-equal-remote filename newname)
+ (tramp-do-copy-or-rename-file-directly
+ op filename newname
+ ok-if-already-exists keep-date preserve-uid-gid))
+
+ ;; Try out-of-band operation.
+ ((tramp-method-out-of-band-p
+ v1 (nth 7 (file-attributes (file-truename filename))))
+ (tramp-do-copy-or-rename-file-out-of-band
+ op filename newname keep-date))
+
+ ;; No shortcut was possible. So we copy the file
+ ;; first. If the operation was `rename', we go back
+ ;; and delete the original file (if the copy was
+ ;; successful). The approach is simple-minded: we
+ ;; create a new buffer, insert the contents of the
+ ;; source file into it, then write out the buffer to
+ ;; the target file. The advantage is that it doesn't
+ ;; matter which filename handlers are used for the
+ ;; source and target file.
+ (t
+ (tramp-do-copy-or-rename-file-via-buffer
+ op filename newname keep-date))))))
+
+ ;; One file is a Tramp file, the other one is local.
+ ((or t1 t2)
+ (cond
+ ;; Fast track on local machine.
+ ((tramp-local-host-p v)
+ (tramp-do-copy-or-rename-file-directly
+ op filename newname
+ ok-if-already-exists keep-date preserve-uid-gid))
+
+ ;; If the Tramp file has an out-of-band method, the
+ ;; corresponding copy-program can be invoked.
+ ((tramp-method-out-of-band-p
+ v (nth 7 (file-attributes (file-truename filename))))
+ (tramp-do-copy-or-rename-file-out-of-band
+ op filename newname keep-date))
+
+ ;; Use the inline method via a Tramp buffer.
+ (t (tramp-do-copy-or-rename-file-via-buffer
+ op filename newname keep-date))))
+
+ (t
+ ;; One of them must be a Tramp file.
+ (error "Tramp implementation says this cannot happen")))
+
+ ;; Handle `preserve-selinux-context'.
+ (when context (apply 'set-file-selinux-context (list newname context)))
+
+ ;; In case of `rename', we must flush the cache of the source file.
+ (when (and t1 (eq op 'rename))
+ (with-parsed-tramp-file-name filename v1
+ (tramp-flush-file-property v1 (file-name-directory localname))
+ (tramp-flush-file-property v1 localname)))
+
+ ;; When newname did exist, we have wrong cached values.
+ (when t2
+ (with-parsed-tramp-file-name newname v2
+ (tramp-flush-file-property v2 (file-name-directory localname))
+ (tramp-flush-file-property v2 localname)))))))
+
+(defun tramp-do-copy-or-rename-file-via-buffer (op filename newname keep-date)
+ "Use an Emacs buffer to copy or rename a file.
+First arg OP is either `copy' or `rename' and indicates the operation.
+FILENAME is the source file, NEWNAME the target file.
+KEEP-DATE is non-nil if NEWNAME should have the same timestamp as FILENAME."
+ (with-temp-buffer
+ ;; We must disable multibyte, because binary data shall not be
+ ;; converted.
+ (set-buffer-multibyte nil)
+ (let ((coding-system-for-read 'binary)
+ (jka-compr-inhibit t))
+ (insert-file-contents-literally filename))
+ ;; We don't want the target file to be compressed, so we let-bind
+ ;; `jka-compr-inhibit' to t.
+ (let ((coding-system-for-write 'binary)
+ (jka-compr-inhibit t))
+ (write-region (point-min) (point-max) newname)))
+ ;; KEEP-DATE handling.
+ (when keep-date (set-file-times newname (nth 5 (file-attributes filename))))
+ ;; Set the mode.
+ (set-file-modes newname (tramp-default-file-modes filename))
+ ;; If the operation was `rename', delete the original file.
+ (unless (eq op 'copy) (delete-file filename)))
+
+(defun tramp-do-copy-or-rename-file-directly
+ (op filename newname ok-if-already-exists keep-date preserve-uid-gid)
+ "Invokes `cp' or `mv' on the remote system.
+OP must be one of `copy' or `rename', indicating `cp' or `mv',
+respectively. FILENAME specifies the file to copy or rename,
+NEWNAME is the name of the new file (for copy) or the new name of
+the file (for rename). Both files must reside on the same host.
+KEEP-DATE means to make sure that NEWNAME has the same timestamp
+as FILENAME. PRESERVE-UID-GID, when non-nil, instructs to keep
+the uid and gid from FILENAME."
+ (let ((t1 (tramp-tramp-file-p filename))
+ (t2 (tramp-tramp-file-p newname))
+ (file-times (nth 5 (file-attributes filename)))
+ (file-modes (tramp-default-file-modes filename)))
+ (with-parsed-tramp-file-name (if t1 filename newname) nil
+ (let* ((cmd (cond ((and (eq op 'copy) preserve-uid-gid) "cp -f -p")
+ ((eq op 'copy) "cp -f")
+ ((eq op 'rename) "mv -f")
+ (t (tramp-error
+ v 'file-error
+ "Unknown operation `%s', must be `copy' or `rename'"
+ op))))
+ (localname1
+ (if t1
+ (tramp-file-name-handler 'file-remote-p filename 'localname)
+ filename))
+ (localname2
+ (if t2
+ (tramp-file-name-handler 'file-remote-p newname 'localname)
+ newname))
+ (prefix (file-remote-p (if t1 filename newname)))
+ cmd-result)
+
+ (cond
+ ;; Both files are on a remote host, with same user.
+ ((and t1 t2)
+ (setq cmd-result
+ (tramp-send-command-and-check
+ v (format "%s %s %s" cmd
+ (tramp-shell-quote-argument localname1)
+ (tramp-shell-quote-argument localname2))))
+ (with-current-buffer (tramp-get-buffer v)
+ (goto-char (point-min))
+ (unless
+ (or
+ (and keep-date
+ ;; Mask cp -f error.
+ (re-search-forward
+ tramp-operation-not-permitted-regexp nil t))
+ cmd-result)
+ (tramp-error-with-buffer
+ nil v 'file-error
+ "Copying directly failed, see buffer `%s' for details."
+ (buffer-name)))))
+
+ ;; We are on the local host.
+ ((or t1 t2)
+ (cond
+ ;; We can do it directly.
+ ((let (file-name-handler-alist)
+ (and (file-readable-p localname1)
+ (file-writable-p (file-name-directory localname2))
+ (or (file-directory-p localname2)
+ (file-writable-p localname2))))
+ (if (eq op 'copy)
+ (tramp-compat-copy-file
+ localname1 localname2 ok-if-already-exists
+ keep-date preserve-uid-gid)
+ (tramp-run-real-handler
+ 'rename-file (list localname1 localname2 ok-if-already-exists))))
+
+ ;; We can do it directly with `tramp-send-command'
+ ((and (file-readable-p (concat prefix localname1))
+ (file-writable-p
+ (file-name-directory (concat prefix localname2)))
+ (or (file-directory-p (concat prefix localname2))
+ (file-writable-p (concat prefix localname2))))
+ (tramp-do-copy-or-rename-file-directly
+ op (concat prefix localname1) (concat prefix localname2)
+ ok-if-already-exists keep-date t)
+ ;; We must change the ownership to the local user.
+ (tramp-set-file-uid-gid
+ (concat prefix localname2)
+ (tramp-get-local-uid 'integer)
+ (tramp-get-local-gid 'integer)))
+
+ ;; We need a temporary file in between.
+ (t
+ ;; Create the temporary file.
+ (let ((tmpfile (tramp-compat-make-temp-file localname1)))
+ (unwind-protect
+ (progn
+ (cond
+ (t1
+ (tramp-barf-unless-okay
+ v (format
+ "%s %s %s" cmd
+ (tramp-shell-quote-argument localname1)
+ (tramp-shell-quote-argument tmpfile))
+ "Copying directly failed, see buffer `%s' for details."
+ (tramp-get-buffer v))
+ ;; We must change the ownership as remote user.
+ ;; Since this does not work reliable, we also
+ ;; give read permissions.
+ (set-file-modes
+ (concat prefix tmpfile)
+ (tramp-compat-octal-to-decimal "0777"))
+ (tramp-set-file-uid-gid
+ (concat prefix tmpfile)
+ (tramp-get-local-uid 'integer)
+ (tramp-get-local-gid 'integer)))
+ (t2
+ (if (eq op 'copy)
+ (tramp-compat-copy-file
+ localname1 tmpfile t
+ keep-date preserve-uid-gid)
+ (tramp-run-real-handler
+ 'rename-file
+ (list localname1 tmpfile t)))
+ ;; We must change the ownership as local user.
+ ;; Since this does not work reliable, we also
+ ;; give read permissions.
+ (set-file-modes
+ tmpfile (tramp-compat-octal-to-decimal "0777"))
+ (tramp-set-file-uid-gid
+ tmpfile
+ (tramp-get-remote-uid v 'integer)
+ (tramp-get-remote-gid v 'integer))))
+
+ ;; Move the temporary file to its destination.
+ (cond
+ (t2
+ (tramp-barf-unless-okay
+ v (format
+ "cp -f -p %s %s"
+ (tramp-shell-quote-argument tmpfile)
+ (tramp-shell-quote-argument localname2))
+ "Copying directly failed, see buffer `%s' for details."
+ (tramp-get-buffer v)))
+ (t1
+ (tramp-run-real-handler
+ 'rename-file
+ (list tmpfile localname2 ok-if-already-exists)))))
+
+ ;; Save exit.
+ (ignore-errors (delete-file tmpfile)))))))))
+
+ ;; Set the time and mode. Mask possible errors.
+ (ignore-errors
+ (when keep-date
+ (set-file-times newname file-times)
+ (set-file-modes newname file-modes))))))
+
+(defun tramp-do-copy-or-rename-file-out-of-band (op filename newname keep-date)
+ "Invoke rcp program to copy.
+The method used must be an out-of-band method."
+ (let* ((t1 (tramp-tramp-file-p filename))
+ (t2 (tramp-tramp-file-p newname))
+ (orig-vec (tramp-dissect-file-name (if t1 filename newname)))
+ copy-program copy-args copy-env copy-keep-date port spec
+ source target)
+
+ (with-parsed-tramp-file-name (if t1 filename newname) nil
+ (if (and t1 t2)
+
+ ;; Both are Tramp files. We shall optimize it, when the
+ ;; methods for filename and newname are the same.
+ (let* ((dir-flag (file-directory-p filename))
+ (tmpfile (tramp-compat-make-temp-file localname dir-flag)))
+ (if dir-flag
+ (setq tmpfile
+ (expand-file-name
+ (file-name-nondirectory newname) tmpfile)))
+ (unwind-protect
+ (progn
+ (tramp-do-copy-or-rename-file-out-of-band
+ op filename tmpfile keep-date)
+ (tramp-do-copy-or-rename-file-out-of-band
+ 'rename tmpfile newname keep-date))
+ ;; Save exit.
+ (ignore-errors
+ (if dir-flag
+ (tramp-compat-delete-directory
+ (expand-file-name ".." tmpfile) 'recursive)
+ (delete-file tmpfile)))))
+
+ ;; Set variables for computing the prompt for reading
+ ;; password.
+ (setq tramp-current-method (tramp-file-name-method v)
+ tramp-current-user (tramp-file-name-user v)
+ tramp-current-host (tramp-file-name-host v))
+
+ ;; Expand hops. Might be necessary for gateway methods.
+ (setq v (car (tramp-compute-multi-hops v)))
+ (aset v 3 localname)
+
+ ;; Check which ones of source and target are Tramp files.
+ (setq source (if t1 (tramp-make-copy-program-file-name v) filename)
+ target (funcall
+ (if (and (file-directory-p filename)
+ (string-equal
+ (file-name-nondirectory filename)
+ (file-name-nondirectory newname)))
+ 'file-name-directory
+ 'identity)
+ (if t2 (tramp-make-copy-program-file-name v) newname)))
+
+ ;; Check for port number. Until now, there's no need for handling
+ ;; like method, user, host.
+ (setq host (tramp-file-name-real-host v)
+ port (tramp-file-name-port v)
+ port (or (and port (number-to-string port)) ""))
+
+ ;; Compose copy command.
+ (setq spec (format-spec-make
+ ?h host ?u user ?p port
+ ?t (tramp-get-connection-property
+ (tramp-get-connection-process v) "temp-file" "")
+ ?k (if keep-date " " ""))
+ copy-program (tramp-get-method-parameter
+ method 'tramp-copy-program)
+ copy-keep-date (tramp-get-method-parameter
+ method 'tramp-copy-keep-date)
+ copy-args
+ (delete
+ ;; " " has either been a replacement of "%k" (when
+ ;; keep-date argument is non-nil), or a replacemtent
+ ;; for the whole keep-date sublist.
+ " "
+ (dolist
+ (x
+ (tramp-get-method-parameter method 'tramp-copy-args)
+ copy-args)
+ (setq copy-args
+ (append
+ copy-args
+ (let ((y (mapcar (lambda (z) (format-spec z spec)) x)))
+ (if (zerop (length (car y))) '(" ") y))))))
+ copy-env
+ (delq
+ nil
+ (mapcar
+ (lambda (x)
+ (setq x (mapcar (lambda (y) (format-spec y spec)) x))
+ (unless (member "" x) (mapconcat 'identity x " ")))
+ (tramp-get-method-parameter method 'tramp-copy-env))))
+
+ ;; Check for program.
+ (when (and (fboundp 'executable-find)
+ (not (let ((default-directory
+ (tramp-compat-temporary-file-directory)))
+ (executable-find copy-program))))
+ (tramp-error
+ v 'file-error "Cannot find copy program: %s" copy-program))
+
+ (with-temp-buffer
+ (unwind-protect
+ ;; The default directory must be remote.
+ (let ((default-directory
+ (file-name-directory (if t1 filename newname)))
+ (process-environment (copy-sequence process-environment)))
+ ;; Set the transfer process properties.
+ (tramp-set-connection-property
+ v "process-name" (buffer-name (current-buffer)))
+ (tramp-set-connection-property
+ v "process-buffer" (current-buffer))
+ (while copy-env
+ (tramp-message
+ orig-vec 5 "%s=\"%s\"" (car copy-env) (cadr copy-env))
+ (setenv (pop copy-env) (pop copy-env)))
+
+ ;; Use an asynchronous process. By this, password can
+ ;; be handled. The default directory must be local, in
+ ;; order to apply the correct `copy-program'. We don't
+ ;; set a timeout, because the copying of large files can
+ ;; last longer than 60 secs.
+ (let ((p (let ((default-directory
+ (tramp-compat-temporary-file-directory)))
+ (apply 'start-process
+ (tramp-get-connection-name v)
+ (tramp-get-connection-buffer v)
+ copy-program
+ (append copy-args (list source target))))))
+ (tramp-message
+ orig-vec 6 "%s"
+ (mapconcat 'identity (process-command p) " "))
+ (tramp-compat-set-process-query-on-exit-flag p nil)
+ (tramp-process-actions p v tramp-actions-copy-out-of-band)))
+
+ ;; Reset the transfer process properties.
+ (tramp-message orig-vec 6 "%s" (buffer-string))
+ (tramp-set-connection-property v "process-name" nil)
+ (tramp-set-connection-property v "process-buffer" nil)))
+
+ ;; Handle KEEP-DATE argument.
+ (when (and keep-date (not copy-keep-date))
+ (set-file-times newname (nth 5 (file-attributes filename))))
+
+ ;; Set the mode.
+ (unless (and keep-date copy-keep-date)
+ (ignore-errors
+ (set-file-modes newname (tramp-default-file-modes filename)))))
+
+ ;; If the operation was `rename', delete the original file.
+ (unless (eq op 'copy)
+ (if (file-regular-p filename)
+ (delete-file filename)
+ (tramp-compat-delete-directory filename 'recursive))))))
+
+(defun tramp-sh-handle-make-directory (dir &optional parents)
+ "Like `make-directory' for Tramp files."
+ (setq dir (expand-file-name dir))
+ (with-parsed-tramp-file-name dir nil
+ (tramp-flush-directory-property v (file-name-directory localname))
+ (save-excursion
+ (tramp-barf-unless-okay
+ v (format "%s %s"
+ (if parents "mkdir -p" "mkdir")
+ (tramp-shell-quote-argument localname))
+ "Couldn't make directory %s" dir))))
+
+(defun tramp-sh-handle-delete-directory (directory &optional recursive)
+ "Like `delete-directory' for Tramp files."
+ (setq directory (expand-file-name directory))
+ (with-parsed-tramp-file-name directory nil
+ (tramp-flush-file-property v (file-name-directory localname))
+ (tramp-flush-directory-property v localname)
+ (tramp-barf-unless-okay
+ v (format "%s %s"
+ (if recursive "rm -rf" "rmdir")
+ (tramp-shell-quote-argument localname))
+ "Couldn't delete %s" directory)))
+
+(defun tramp-sh-handle-delete-file (filename &optional trash)
+ "Like `delete-file' for Tramp files."
+ (setq filename (expand-file-name filename))
+ (with-parsed-tramp-file-name filename nil
+ (tramp-flush-file-property v (file-name-directory localname))
+ (tramp-flush-file-property v localname)
+ (tramp-barf-unless-okay
+ v (format "%s %s"
+ (or (and trash (tramp-get-remote-trash v)) "rm -f")
+ (tramp-shell-quote-argument localname))
+ "Couldn't delete %s" filename)))
+
+;; Dired.
+
+;; CCC: This does not seem to be enough. Something dies when
+;; we try and delete two directories under Tramp :/
+(defun tramp-sh-handle-dired-recursive-delete-directory (filename)
+ "Recursively delete the directory given.
+This is like `dired-recursive-delete-directory' for Tramp files."
+ (with-parsed-tramp-file-name filename nil
+ ;; Run a shell command 'rm -r <localname>'
+ ;; Code shamelessly stolen from the dired implementation and, um, hacked :)
+ (unless (file-exists-p filename)
+ (tramp-error v 'file-error "No such directory: %s" filename))
+ ;; Which is better, -r or -R? (-r works for me <daniel@danann.net>)
+ (tramp-send-command
+ v
+ (format "rm -rf %s" (tramp-shell-quote-argument localname))
+ ;; Don't read the output, do it explicitely.
+ nil t)
+ ;; Wait for the remote system to return to us...
+ ;; This might take a while, allow it plenty of time.
+ (tramp-wait-for-output (tramp-get-connection-process v) 120)
+ ;; Make sure that it worked...
+ (tramp-flush-file-property v (file-name-directory localname))
+ (tramp-flush-directory-property v localname)
+ (and (file-exists-p filename)
+ (tramp-error
+ v 'file-error "Failed to recursively delete %s" filename))))
+
+(defun tramp-sh-handle-dired-compress-file (file &rest ok-flag)
+ "Like `dired-compress-file' for Tramp files."
+ ;; OK-FLAG is valid for XEmacs only, but not implemented.
+ ;; Code stolen mainly from dired-aux.el.
+ (with-parsed-tramp-file-name file nil
+ (tramp-flush-file-property v localname)
+ (save-excursion
+ (let ((suffixes
+ (if (not (featurep 'xemacs))
+ ;; Emacs case
+ (symbol-value 'dired-compress-file-suffixes)
+ ;; XEmacs has `dired-compression-method-alist', which is
+ ;; transformed into `dired-compress-file-suffixes' structure.
+ (mapcar
+ (lambda (x)
+ (list (concat (regexp-quote (nth 1 x)) "\\'")
+ nil
+ (mapconcat 'identity (nth 3 x) " ")))
+ (symbol-value 'dired-compression-method-alist))))
+ suffix)
+ ;; See if any suffix rule matches this file name.
+ (while suffixes
+ (let (case-fold-search)
+ (if (string-match (car (car suffixes)) localname)
+ (setq suffix (car suffixes) suffixes nil))
+ (setq suffixes (cdr suffixes))))
+
+ (cond ((file-symlink-p file)
+ nil)
+ ((and suffix (nth 2 suffix))
+ ;; We found an uncompression rule.
+ (with-progress-reporter v 0 (format "Uncompressing %s" file)
+ (when (tramp-send-command-and-check
+ v (concat (nth 2 suffix) " "
+ (tramp-shell-quote-argument localname)))
+ ;; `dired-remove-file' is not defined in XEmacs.
+ (tramp-compat-funcall 'dired-remove-file file)
+ (string-match (car suffix) file)
+ (concat (substring file 0 (match-beginning 0))))))
+ (t
+ ;; We don't recognize the file as compressed, so compress it.
+ ;; Try gzip.
+ (with-progress-reporter v 0 (format "Compressing %s" file)
+ (when (tramp-send-command-and-check
+ v (concat "gzip -f "
+ (tramp-shell-quote-argument localname)))
+ ;; `dired-remove-file' is not defined in XEmacs.
+ (tramp-compat-funcall 'dired-remove-file file)
+ (cond ((file-exists-p (concat file ".gz"))
+ (concat file ".gz"))
+ ((file-exists-p (concat file ".z"))
+ (concat file ".z"))
+ (t nil))))))))))
+
+(defun tramp-sh-handle-insert-directory
+ (filename switches &optional wildcard full-directory-p)
+ "Like `insert-directory' for Tramp files."
+ (setq filename (expand-file-name filename))
+ (with-parsed-tramp-file-name filename nil
+ (if (and (featurep 'ls-lisp)
+ (not (symbol-value 'ls-lisp-use-insert-directory-program)))
+ (tramp-run-real-handler
+ 'insert-directory (list filename switches wildcard full-directory-p))
+ (when (stringp switches)
+ (setq switches (split-string switches)))
+ (when (and (member "--dired" switches)
+ (not (tramp-get-ls-command-with-dired v)))
+ (setq switches (delete "--dired" switches)))
+ (when wildcard
+ (setq wildcard (tramp-run-real-handler
+ 'file-name-nondirectory (list localname)))
+ (setq localname (tramp-run-real-handler
+ 'file-name-directory (list localname))))
+ (unless full-directory-p
+ (setq switches (add-to-list 'switches "-d" 'append)))
+ (setq switches (mapconcat 'tramp-shell-quote-argument switches " "))
+ (when wildcard
+ (setq switches (concat switches " " wildcard)))
+ (tramp-message
+ v 4 "Inserting directory `ls %s %s', wildcard %s, fulldir %s"
+ switches filename (if wildcard "yes" "no")
+ (if full-directory-p "yes" "no"))
+ ;; If `full-directory-p', we just say `ls -l FILENAME'.
+ ;; Else we chdir to the parent directory, then say `ls -ld BASENAME'.
+ (if full-directory-p
+ (tramp-send-command
+ v
+ (format "%s %s %s 2>/dev/null"
+ (tramp-get-ls-command v)
+ switches
+ (if wildcard
+ localname
+ (tramp-shell-quote-argument (concat localname ".")))))
+ (tramp-barf-unless-okay
+ v
+ (format "cd %s" (tramp-shell-quote-argument
+ (tramp-run-real-handler
+ 'file-name-directory (list localname))))
+ "Couldn't `cd %s'"
+ (tramp-shell-quote-argument
+ (tramp-run-real-handler 'file-name-directory (list localname))))
+ (tramp-send-command
+ v
+ (format "%s %s %s"
+ (tramp-get-ls-command v)
+ switches
+ (if (or wildcard
+ (zerop (length
+ (tramp-run-real-handler
+ 'file-name-nondirectory (list localname)))))
+ ""
+ (tramp-shell-quote-argument
+ (tramp-run-real-handler
+ 'file-name-nondirectory (list localname)))))))
+ (let ((beg (point)))
+ ;; We cannot use `insert-buffer-substring' because the Tramp
+ ;; buffer changes its contents before insertion due to calling
+ ;; `expand-file' and alike.
+ (insert
+ (with-current-buffer (tramp-get-buffer v)
+ (buffer-string)))
+
+ ;; Check for "--dired" output.
+ (forward-line -2)
+ (when (looking-at "//SUBDIRED//")
+ (forward-line -1))
+ (when (looking-at "//DIRED//\\s-+")
+ (let ((databeg (match-end 0))
+ (end (point-at-eol)))
+ ;; Now read the numeric positions of file names.
+ (goto-char databeg)
+ (while (< (point) end)
+ (let ((start (+ beg (read (current-buffer))))
+ (end (+ beg (read (current-buffer)))))
+ (if (memq (char-after end) '(?\n ?\ ))
+ ;; End is followed by \n or by " -> ".
+ (put-text-property start end 'dired-filename t))))))
+ ;; Remove trailing lines.
+ (goto-char (point-at-bol))
+ (while (looking-at "//")
+ (forward-line 1)
+ (delete-region (match-beginning 0) (point)))
+
+ ;; The inserted file could be from somewhere else.
+ (when (and (not wildcard) (not full-directory-p))
+ (goto-char (point-max))
+ (when (file-symlink-p filename)
+ (goto-char (search-backward "->" beg 'noerror)))
+ (search-backward
+ (if (zerop (length (file-name-nondirectory filename)))
+ "."
+ (file-name-nondirectory filename))
+ beg 'noerror)
+ (replace-match (file-relative-name filename) t))
+
+ (goto-char (point-max))))))
+
+;; Canonicalization of file names.
+
+(defun tramp-sh-handle-expand-file-name (name &optional dir)
+ "Like `expand-file-name' for Tramp files.
+If the localname part of the given filename starts with \"/../\" then
+the result will be a local, non-Tramp, filename."
+ ;; If DIR is not given, use DEFAULT-DIRECTORY or "/".
+ (setq dir (or dir default-directory "/"))
+ ;; Unless NAME is absolute, concat DIR and NAME.
+ (unless (file-name-absolute-p name)
+ (setq name (concat (file-name-as-directory dir) name)))
+ ;; If NAME is not a Tramp file, run the real handler.
+ (if (not (tramp-connectable-p name))
+ (tramp-run-real-handler 'expand-file-name (list name nil))
+ ;; Dissect NAME.
+ (with-parsed-tramp-file-name name nil
+ (unless (tramp-run-real-handler 'file-name-absolute-p (list localname))
+ (setq localname (concat "~/" localname)))
+ ;; Tilde expansion if necessary. This needs a shell which
+ ;; groks tilde expansion! The function `tramp-find-shell' is
+ ;; supposed to find such a shell on the remote host. Please
+ ;; tell me about it when this doesn't work on your system.
+ (when (string-match "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname)
+ (let ((uname (match-string 1 localname))
+ (fname (match-string 2 localname)))
+ ;; We cannot simply apply "~/", because under sudo "~/" is
+ ;; expanded to the local user home directory but to the
+ ;; root home directory. On the other hand, using always
+ ;; the default user name for tilde expansion is not
+ ;; appropriate either, because ssh and companions might
+ ;; use a user name from the config file.
+ (when (and (string-equal uname "~")
+ (string-match "\\`su\\(do\\)?\\'" method))
+ (setq uname (concat uname user)))
+ (setq uname
+ (with-connection-property v uname
+ (tramp-send-command
+ v (format "cd %s; pwd" (tramp-shell-quote-argument uname)))
+ (with-current-buffer (tramp-get-buffer v)
+ (goto-char (point-min))
+ (buffer-substring (point) (point-at-eol)))))
+ (setq localname (concat uname fname))))
+ ;; There might be a double slash, for example when "~/"
+ ;; expands to "/". Remove this.
+ (while (string-match "//" localname)
+ (setq localname (replace-match "/" t t localname)))
+ ;; No tilde characters in file name, do normal
+ ;; `expand-file-name' (this does "/./" and "/../"). We bind
+ ;; `directory-sep-char' here for XEmacs on Windows, which would
+ ;; otherwise use backslash. `default-directory' is bound,
+ ;; because on Windows there would be problems with UNC shares or
+ ;; Cygwin mounts.
+ (let ((directory-sep-char ?/)
+ (default-directory (tramp-compat-temporary-file-directory)))
+ (tramp-make-tramp-file-name
+ method user host
+ (tramp-drop-volume-letter
+ (tramp-run-real-handler
+ 'expand-file-name (list localname))))))))
+
+;;; Remote commands:
+
+(defun tramp-sh-handle-executable-find (command)
+ "Like `executable-find' for Tramp files."
+ (with-parsed-tramp-file-name default-directory nil
+ (tramp-find-executable v command (tramp-get-remote-path v) t)))
+
+(defun tramp-process-sentinel (proc event)
+ "Flush file caches."
+ (unless (memq (process-status proc) '(run open))
+ (let ((vec (tramp-get-connection-property proc "vector" nil)))
+ (when vec
+ (tramp-message vec 5 "Sentinel called: `%s' `%s'" proc event)
+ (tramp-flush-directory-property vec "")))))
+
+;; We use BUFFER also as connection buffer during setup. Because of
+;; this, its original contents must be saved, and restored once
+;; connection has been setup.
+(defun tramp-sh-handle-start-file-process (name buffer program &rest args)
+ "Like `start-file-process' for Tramp files."
+ (with-parsed-tramp-file-name default-directory nil
+ ;; When PROGRAM is nil, we just provide a tty.
+ (let ((command
+ (when (stringp program)
+ (format "cd %s; exec %s"
+ (tramp-shell-quote-argument localname)
+ (mapconcat 'tramp-shell-quote-argument
+ (cons program args) " "))))
+ (tramp-process-connection-type
+ (or (null program) tramp-process-connection-type))
+ (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer)))
+ (name1 name)
+ (i 0))
+ (unwind-protect
+ (save-excursion
+ (save-restriction
+ (unless buffer
+ ;; BUFFER can be nil. We use a temporary buffer.
+ (setq buffer (generate-new-buffer tramp-temp-buffer-name)))
+ (while (get-process name1)
+ ;; NAME must be unique as process name.
+ (setq i (1+ i)
+ name1 (format "%s<%d>" name i)))
+ (setq name name1)
+ ;; Set the new process properties.
+ (tramp-set-connection-property v "process-name" name)
+ (tramp-set-connection-property v "process-buffer" buffer)
+ ;; Activate narrowing in order to save BUFFER contents.
+ ;; Clear also the modification time; otherwise we might
+ ;; be interrupted by `verify-visited-file-modtime'.
+ (with-current-buffer (tramp-get-connection-buffer v)
+ (let ((buffer-undo-list t))
+ (clear-visited-file-modtime)
+ (narrow-to-region (point-max) (point-max))
+ (if command
+ ;; Send the command.
+ (tramp-send-command v command nil t) ; nooutput
+ ;; Check, whether a pty is associated.
+ (tramp-maybe-open-connection v)
+ (unless (tramp-compat-process-get
+ (tramp-get-connection-process v) 'remote-tty)
+ (tramp-error
+ v 'file-error
+ "pty association is not supported for `%s'" name)))))
+ (let ((p (tramp-get-connection-process v)))
+ ;; Set sentinel and query flag for this process.
+ (tramp-set-connection-property p "vector" v)
+ (set-process-sentinel p 'tramp-process-sentinel)
+ (tramp-compat-set-process-query-on-exit-flag p t)
+ ;; Return process.
+ p)))
+ ;; Save exit.
+ (with-current-buffer (tramp-get-connection-buffer v)
+ (if (string-match tramp-temp-buffer-name (buffer-name))
+ (progn
+ (set-process-buffer (tramp-get-connection-process v) nil)
+ (kill-buffer (current-buffer)))
+ (set-buffer-modified-p bmp)))
+ (tramp-set-connection-property v "process-name" nil)
+ (tramp-set-connection-property v "process-buffer" nil)))))
+
+(defun tramp-sh-handle-process-file
+ (program &optional infile destination display &rest args)
+ "Like `process-file' for Tramp files."
+ ;; The implementation is not complete yet.
+ (when (and (numberp destination) (zerop destination))
+ (error "Implementation does not handle immediate return"))
+
+ (with-parsed-tramp-file-name default-directory nil
+ (let (command input tmpinput stderr tmpstderr outbuf ret)
+ ;; Compute command.
+ (setq command (mapconcat 'tramp-shell-quote-argument
+ (cons program args) " "))
+ ;; Determine input.
+ (if (null infile)
+ (setq input "/dev/null")
+ (setq infile (expand-file-name infile))
+ (if (tramp-equal-remote default-directory infile)
+ ;; INFILE is on the same remote host.
+ (setq input (with-parsed-tramp-file-name infile nil localname))
+ ;; INFILE must be copied to remote host.
+ (setq input (tramp-make-tramp-temp-file v)
+ tmpinput (tramp-make-tramp-file-name method user host input))
+ (copy-file infile tmpinput t)))
+ (when input (setq command (format "%s <%s" command input)))
+
+ ;; Determine output.
+ (cond
+ ;; Just a buffer.
+ ((bufferp destination)
+ (setq outbuf destination))
+ ;; A buffer name.
+ ((stringp destination)
+ (setq outbuf (get-buffer-create destination)))
+ ;; (REAL-DESTINATION ERROR-DESTINATION)
+ ((consp destination)
+ ;; output.
+ (cond
+ ((bufferp (car destination))
+ (setq outbuf (car destination)))
+ ((stringp (car destination))
+ (setq outbuf (get-buffer-create (car destination))))
+ ((car destination)
+ (setq outbuf (current-buffer))))
+ ;; stderr.
+ (cond
+ ((stringp (cadr destination))
+ (setcar (cdr destination) (expand-file-name (cadr destination)))
+ (if (tramp-equal-remote default-directory (cadr destination))
+ ;; stderr is on the same remote host.
+ (setq stderr (with-parsed-tramp-file-name
+ (cadr destination) nil localname))
+ ;; stderr must be copied to remote host. The temporary
+ ;; file must be deleted after execution.
+ (setq stderr (tramp-make-tramp-temp-file v)
+ tmpstderr (tramp-make-tramp-file-name
+ method user host stderr))))
+ ;; stderr to be discarded.
+ ((null (cadr destination))
+ (setq stderr "/dev/null"))))
+ ;; 't
+ (destination
+ (setq outbuf (current-buffer))))
+ (when stderr (setq command (format "%s 2>%s" command stderr)))
+
+ ;; Send the command. It might not return in time, so we protect
+ ;; it. Call it in a subshell, in order to preserve working
+ ;; directory.
+ (condition-case nil
+ (unwind-protect
+ (setq ret
+ (if (tramp-send-command-and-check
+ v (format "\\cd %s; %s"
+ (tramp-shell-quote-argument localname)
+ command)
+ t t)
+ 0 1))
+ ;; We should show the output anyway.
+ (when outbuf
+ (with-current-buffer outbuf
+ (insert
+ (with-current-buffer (tramp-get-connection-buffer v)
+ (buffer-string))))
+ (when display (display-buffer outbuf))))
+ ;; When the user did interrupt, we should do it also. We use
+ ;; return code -1 as marker.
+ (quit
+ (kill-buffer (tramp-get-connection-buffer v))
+ (setq ret -1))
+ ;; Handle errors.
+ (error
+ (kill-buffer (tramp-get-connection-buffer v))
+ (setq ret 1)))
+
+ ;; Provide error file.
+ (when tmpstderr (rename-file tmpstderr (cadr destination) t))
+
+ ;; Cleanup. We remove all file cache values for the connection,
+ ;; because the remote process could have changed them.
+ (when tmpinput (delete-file tmpinput))
+
+ ;; `process-file-side-effects' has been introduced with GNU
+ ;; Emacs 23.2. If set to `nil', no remote file will be changed
+ ;; by `program'. If it doesn't exist, we assume its default
+ ;; value 't'.
+ (unless (and (boundp 'process-file-side-effects)
+ (not (symbol-value 'process-file-side-effects)))
+ (tramp-flush-directory-property v ""))
+
+ ;; Return exit status.
+ (if (equal ret -1)
+ (keyboard-quit)
+ ret))))
+
+(defun tramp-sh-handle-call-process-region
+ (start end program &optional delete buffer display &rest args)
+ "Like `call-process-region' for Tramp files."
+ (let ((tmpfile (tramp-compat-make-temp-file "")))
+ (write-region start end tmpfile)
+ (when delete (delete-region start end))
+ (unwind-protect
+ (apply 'call-process program tmpfile buffer display args)
+ (delete-file tmpfile))))
+
+(defun tramp-sh-handle-shell-command
+ (command &optional output-buffer error-buffer)
+ "Like `shell-command' for Tramp files."
+ (let* ((asynchronous (string-match "[ \t]*&[ \t]*\\'" command))
+ ;; We cannot use `shell-file-name' and `shell-command-switch',
+ ;; they are variables of the local host.
+ (args (list
+ (tramp-get-method-parameter
+ (tramp-file-name-method
+ (tramp-dissect-file-name default-directory))
+ 'tramp-remote-sh)
+ "-c" (substring command 0 asynchronous)))
+ current-buffer-p
+ (output-buffer
+ (cond
+ ((bufferp output-buffer) output-buffer)
+ ((stringp output-buffer) (get-buffer-create output-buffer))
+ (output-buffer
+ (setq current-buffer-p t)
+ (current-buffer))
+ (t (get-buffer-create
+ (if asynchronous
+ "*Async Shell Command*"
+ "*Shell Command Output*")))))
+ (error-buffer
+ (cond
+ ((bufferp error-buffer) error-buffer)
+ ((stringp error-buffer) (get-buffer-create error-buffer))))
+ (buffer
+ (if (and (not asynchronous) error-buffer)
+ (with-parsed-tramp-file-name default-directory nil
+ (list output-buffer (tramp-make-tramp-temp-file v)))
+ output-buffer))
+ (p (get-buffer-process output-buffer)))
+
+ ;; Check whether there is another process running. Tramp does not
+ ;; support 2 (asynchronous) processes in parallel.
+ (when p
+ (if (yes-or-no-p "A command is running. Kill it? ")
+ (ignore-errors (kill-process p))
+ (error "Shell command in progress")))
+
+ (if current-buffer-p
+ (progn
+ (barf-if-buffer-read-only)
+ (push-mark nil t))
+ (with-current-buffer output-buffer
+ (setq buffer-read-only nil)
+ (erase-buffer)))
+
+ (if (and (not current-buffer-p) (integerp asynchronous))
+ (prog1
+ ;; Run the process.
+ (apply 'start-file-process "*Async Shell*" buffer args)
+ ;; Display output.
+ (pop-to-buffer output-buffer)
+ (setq mode-line-process '(":%s"))
+ (shell-mode))
+
+ (prog1
+ ;; Run the process.
+ (apply 'process-file (car args) nil buffer nil (cdr args))
+ ;; Insert error messages if they were separated.
+ (when (listp buffer)
+ (with-current-buffer error-buffer
+ (insert-file-contents (cadr buffer)))
+ (delete-file (cadr buffer)))
+ (if current-buffer-p
+ ;; This is like exchange-point-and-mark, but doesn't
+ ;; activate the mark. It is cleaner to avoid activation,
+ ;; even though the command loop would deactivate the mark
+ ;; because we inserted text.
+ (goto-char (prog1 (mark t)
+ (set-marker (mark-marker) (point)
+ (current-buffer))))
+ ;; There's some output, display it.
+ (when (with-current-buffer output-buffer (> (point-max) (point-min)))
+ (if (functionp 'display-message-or-buffer)
+ (tramp-compat-funcall 'display-message-or-buffer output-buffer)
+ (pop-to-buffer output-buffer))))))))
+
+(defun tramp-sh-handle-file-local-copy (filename)
+ "Like `file-local-copy' for Tramp files."
+ (with-parsed-tramp-file-name filename nil
+ (unless (file-exists-p filename)
+ (tramp-error
+ v 'file-error
+ "Cannot make local copy of non-existing file `%s'" filename))
+
+ (let* ((size (nth 7 (file-attributes (file-truename filename))))
+ (rem-enc (tramp-get-inline-coding v "remote-encoding" size))
+ (loc-dec (tramp-get-inline-coding v "local-decoding" size))
+ (tmpfile (tramp-compat-make-temp-file filename)))
+
+ (condition-case err
+ (cond
+ ;; `copy-file' handles direct copy and out-of-band methods.
+ ((or (tramp-local-host-p v)
+ (tramp-method-out-of-band-p v size))
+ (copy-file filename tmpfile t t))
+
+ ;; Use inline encoding for file transfer.
+ (rem-enc
+ (save-excursion
+ (with-progress-reporter
+ v 3 (format "Encoding remote file %s" filename)
+ (tramp-barf-unless-okay
+ v (format rem-enc (tramp-shell-quote-argument localname))
+ "Encoding remote file failed"))
+
+ (if (functionp loc-dec)
+ ;; If local decoding is a function, we call it. We
+ ;; must disable multibyte, because
+ ;; `uudecode-decode-region' doesn't handle it
+ ;; correctly.
+ (with-temp-buffer
+ (set-buffer-multibyte nil)
+ (insert-buffer-substring (tramp-get-buffer v))
+ (with-progress-reporter
+ v 3 (format "Decoding remote file %s with function %s"
+ filename loc-dec)
+ (funcall loc-dec (point-min) (point-max))
+ ;; Unset `file-name-handler-alist'. Otherwise,
+ ;; epa-file gets confused.
+ (let (file-name-handler-alist
+ (coding-system-for-write 'binary))
+ (write-region (point-min) (point-max) tmpfile))))
+
+ ;; If tramp-decoding-function is not defined for this
+ ;; method, we invoke tramp-decoding-command instead.
+ (let ((tmpfile2 (tramp-compat-make-temp-file filename)))
+ ;; Unset `file-name-handler-alist'. Otherwise,
+ ;; epa-file gets confused.
+ (let (file-name-handler-alist
+ (coding-system-for-write 'binary))
+ (write-region (point-min) (point-max) tmpfile2))
+ (with-progress-reporter
+ v 3 (format "Decoding remote file %s with command %s"
+ filename loc-dec)
+ (unwind-protect
+ (tramp-call-local-coding-command
+ loc-dec tmpfile2 tmpfile)
+ (delete-file tmpfile2)))))
+
+ ;; Set proper permissions.
+ (set-file-modes tmpfile (tramp-default-file-modes filename))
+ ;; Set local user ownership.
+ (tramp-set-file-uid-gid tmpfile)))
+
+ ;; Oops, I don't know what to do.
+ (t (tramp-error
+ v 'file-error "Wrong method specification for `%s'" method)))
+
+ ;; Error handling.
+ ((error quit)
+ (delete-file tmpfile)
+ (signal (car err) (cdr err))))
+
+ (run-hooks 'tramp-handle-file-local-copy-hook)
+ tmpfile)))
+
+;; This is needed for XEmacs only. Code stolen from files.el.
+(defun tramp-sh-handle-insert-file-contents-literally
+ (filename &optional visit beg end replace)
+ "Like `insert-file-contents-literally' for Tramp files."
+ (let ((format-alist nil)
+ (after-insert-file-functions nil)
+ (coding-system-for-read 'no-conversion)
+ (coding-system-for-write 'no-conversion)
+ (find-buffer-file-type-function
+ (if (fboundp 'find-buffer-file-type)
+ (symbol-function 'find-buffer-file-type)
+ nil))
+ (inhibit-file-name-handlers '(jka-compr-handler image-file-handler))
+ (inhibit-file-name-operation 'insert-file-contents))
+ (unwind-protect
+ (progn
+ (fset 'find-buffer-file-type (lambda (filename) t))
+ (insert-file-contents filename visit beg end replace))
+ ;; Save exit.
+ (if find-buffer-file-type-function
+ (fset 'find-buffer-file-type find-buffer-file-type-function)
+ (fmakunbound 'find-buffer-file-type)))))
+
+(defun tramp-sh-handle-make-auto-save-file-name ()
+ "Like `make-auto-save-file-name' for Tramp files.
+Returns a file name in `tramp-auto-save-directory' for autosaving this file."
+ (let ((tramp-auto-save-directory tramp-auto-save-directory)
+ (buffer-file-name
+ (tramp-subst-strs-in-string
+ '(("_" . "|")
+ ("/" . "_a")
+ (":" . "_b")
+ ("|" . "__")
+ ("[" . "_l")
+ ("]" . "_r"))
+ (buffer-file-name))))
+ ;; File name must be unique. This is ensured with Emacs 22 (see
+ ;; UNIQUIFY element of `auto-save-file-name-transforms'); but for
+ ;; all other cases we must do it ourselves.
+ (when (boundp 'auto-save-file-name-transforms)
+ (mapc
+ (lambda (x)
+ (when (and (string-match (car x) buffer-file-name)
+ (not (car (cddr x))))
+ (setq tramp-auto-save-directory
+ (or tramp-auto-save-directory
+ (tramp-compat-temporary-file-directory)))))
+ (symbol-value 'auto-save-file-name-transforms)))
+ ;; Create directory.
+ (when tramp-auto-save-directory
+ (setq buffer-file-name
+ (expand-file-name buffer-file-name tramp-auto-save-directory))
+ (unless (file-exists-p tramp-auto-save-directory)
+ (make-directory tramp-auto-save-directory t)))
+ ;; Run plain `make-auto-save-file-name'. There might be an advice when
+ ;; it is not a magic file name operation (since Emacs 22).
+ ;; We must deactivate it temporarily.
+ (if (not (ad-is-active 'make-auto-save-file-name))
+ (tramp-run-real-handler 'make-auto-save-file-name nil)
+ ;; else
+ (ad-deactivate 'make-auto-save-file-name)
+ (prog1
+ (tramp-run-real-handler 'make-auto-save-file-name nil)
+ (ad-activate 'make-auto-save-file-name)))))
+
+;; CCC grok LOCKNAME
+(defun tramp-sh-handle-write-region
+ (start end filename &optional append visit lockname confirm)
+ "Like `write-region' for Tramp files."
+ (setq filename (expand-file-name filename))
+ (with-parsed-tramp-file-name filename nil
+ ;; Following part commented out because we don't know what to do about
+ ;; file locking, and it does not appear to be a problem to ignore it.
+ ;; Ange-ftp ignores it, too.
+ ;; (when (and lockname (stringp lockname))
+ ;; (setq lockname (expand-file-name lockname)))
+ ;; (unless (or (eq lockname nil)
+ ;; (string= lockname filename))
+ ;; (error
+ ;; "tramp-sh-handle-write-region: LOCKNAME must be nil or equal FILENAME"))
+
+ ;; XEmacs takes a coding system as the seventh argument, not `confirm'.
+ (when (and (not (featurep 'xemacs)) confirm (file-exists-p filename))
+ (unless (y-or-n-p (format "File %s exists; overwrite anyway? " filename))
+ (tramp-error v 'file-error "File not overwritten")))
+
+ (let ((uid (or (nth 2 (tramp-compat-file-attributes filename 'integer))
+ (tramp-get-remote-uid v 'integer)))
+ (gid (or (nth 3 (tramp-compat-file-attributes filename 'integer))
+ (tramp-get-remote-gid v 'integer))))
+
+ (if (and (tramp-local-host-p v)
+ ;; `file-writable-p' calls `file-expand-file-name'. We
+ ;; cannot use `tramp-run-real-handler' therefore.
+ (let (file-name-handler-alist)
+ (and
+ (file-writable-p (file-name-directory localname))
+ (or (file-directory-p localname)
+ (file-writable-p localname)))))
+ ;; Short track: if we are on the local host, we can run directly.
+ (tramp-run-real-handler
+ 'write-region
+ (list start end localname append 'no-message lockname confirm))
+
+ (let ((modes (save-excursion (tramp-default-file-modes filename)))
+ ;; We use this to save the value of
+ ;; `last-coding-system-used' after writing the tmp
+ ;; file. At the end of the function, we set
+ ;; `last-coding-system-used' to this saved value. This
+ ;; way, any intermediary coding systems used while
+ ;; talking to the remote shell or suchlike won't hose
+ ;; this variable. This approach was snarfed from
+ ;; ange-ftp.el.
+ coding-system-used
+ ;; Write region into a tmp file. This isn't really
+ ;; needed if we use an encoding function, but currently
+ ;; we use it always because this makes the logic
+ ;; simpler.
+ (tmpfile (or tramp-temp-buffer-file-name
+ (tramp-compat-make-temp-file filename))))
+
+ ;; If `append' is non-nil, we copy the file locally, and let
+ ;; the native `write-region' implementation do the job.
+ (when append (copy-file filename tmpfile 'ok))
+
+ ;; We say `no-message' here because we don't want the
+ ;; visited file modtime data to be clobbered from the temp
+ ;; file. We call `set-visited-file-modtime' ourselves later
+ ;; on. We must ensure that `file-coding-system-alist'
+ ;; matches `tmpfile'.
+ (let (file-name-handler-alist
+ (file-coding-system-alist
+ (tramp-find-file-name-coding-system-alist filename tmpfile)))
+ (condition-case err
+ (tramp-run-real-handler
+ 'write-region
+ (list start end tmpfile append 'no-message lockname confirm))
+ ((error quit)
+ (setq tramp-temp-buffer-file-name nil)
+ (delete-file tmpfile)
+ (signal (car err) (cdr err))))
+
+ ;; Now, `last-coding-system-used' has the right value. Remember it.
+ (when (boundp 'last-coding-system-used)
+ (setq coding-system-used
+ (symbol-value 'last-coding-system-used))))
+
+ ;; The permissions of the temporary file should be set. If
+ ;; filename does not exist (eq modes nil) it has been
+ ;; renamed to the backup file. This case `save-buffer'
+ ;; handles permissions.
+ ;; Ensure, that it is still readable.
+ (when modes
+ (set-file-modes
+ tmpfile
+ (logior (or modes 0) (tramp-compat-octal-to-decimal "0400"))))
+
+ ;; This is a bit lengthy due to the different methods
+ ;; possible for file transfer. First, we check whether the
+ ;; method uses an rcp program. If so, we call it.
+ ;; Otherwise, both encoding and decoding command must be
+ ;; specified. However, if the method _also_ specifies an
+ ;; encoding function, then that is used for encoding the
+ ;; contents of the tmp file.
+ (let* ((size (nth 7 (file-attributes tmpfile)))
+ (rem-dec (tramp-get-inline-coding v "remote-decoding" size))
+ (loc-enc (tramp-get-inline-coding v "local-encoding" size)))
+ (cond
+ ;; `copy-file' handles direct copy and out-of-band methods.
+ ((or (tramp-local-host-p v)
+ (tramp-method-out-of-band-p v size))
+ (if (and (not (stringp start))
+ (= (or end (point-max)) (point-max))
+ (= (or start (point-min)) (point-min))
+ (tramp-get-method-parameter
+ method 'tramp-copy-keep-tmpfile))
+ (progn
+ (setq tramp-temp-buffer-file-name tmpfile)
+ (condition-case err
+ ;; We keep the local file for performance
+ ;; reasons, useful for "rsync".
+ (copy-file tmpfile filename t)
+ ((error quit)
+ (setq tramp-temp-buffer-file-name nil)
+ (delete-file tmpfile)
+ (signal (car err) (cdr err)))))
+ (setq tramp-temp-buffer-file-name nil)
+ ;; Don't rename, in order to keep context in SELinux.
+ (unwind-protect
+ (copy-file tmpfile filename t)
+ (delete-file tmpfile))))
+
+ ;; Use inline file transfer.
+ (rem-dec
+ ;; Encode tmpfile.
+ (unwind-protect
+ (with-temp-buffer
+ (set-buffer-multibyte nil)
+ ;; Use encoding function or command.
+ (if (functionp loc-enc)
+ (with-progress-reporter
+ v 3 (format "Encoding region using function `%s'"
+ loc-enc)
+ (let ((coding-system-for-read 'binary))
+ (insert-file-contents-literally tmpfile))
+ ;; The following `let' is a workaround for the
+ ;; base64.el that comes with pgnus-0.84. If
+ ;; both of the following conditions are
+ ;; satisfied, it tries to write to a local
+ ;; file in default-directory, but at this
+ ;; point, default-directory is remote.
+ ;; (`call-process-region' can't write to
+ ;; remote files, it seems.) The file in
+ ;; question is a tmp file anyway.
+ (let ((default-directory
+ (tramp-compat-temporary-file-directory)))
+ (funcall loc-enc (point-min) (point-max))))
+
+ (with-progress-reporter
+ v 3 (format "Encoding region using command `%s'"
+ loc-enc)
+ (unless (zerop (tramp-call-local-coding-command
+ loc-enc tmpfile t))
+ (tramp-error
+ v 'file-error
+ (concat "Cannot write to `%s', "
+ "local encoding command `%s' failed")
+ filename loc-enc))))
+
+ ;; Send buffer into remote decoding command which
+ ;; writes to remote file. Because this happens on
+ ;; the remote host, we cannot use the function.
+ (with-progress-reporter
+ v 3
+ (format "Decoding region into remote file %s" filename)
+ (goto-char (point-max))
+ (unless (bolp) (newline))
+ (tramp-send-command
+ v
+ (format
+ (concat rem-dec " <<'EOF'\n%sEOF")
+ (tramp-shell-quote-argument localname)
+ (buffer-string)))
+ (tramp-barf-unless-okay
+ v nil
+ "Couldn't write region to `%s', decode using `%s' failed"
+ filename rem-dec)
+ ;; When `file-precious-flag' is set, the region is
+ ;; written to a temporary file. Check that the
+ ;; checksum is equal to that from the local tmpfile.
+ (when file-precious-flag
+ (erase-buffer)
+ (and
+ ;; cksum runs locally, if possible.
+ (zerop (tramp-compat-call-process "cksum" tmpfile t))
+ ;; cksum runs remotely.
+ (tramp-send-command-and-check
+ v
+ (format
+ "cksum <%s" (tramp-shell-quote-argument localname)))
+ ;; ... they are different.
+ (not
+ (string-equal
+ (buffer-string)
+ (with-current-buffer (tramp-get-buffer v)
+ (buffer-string))))
+ (tramp-error
+ v 'file-error
+ (concat "Couldn't write region to `%s',"
+ " decode using `%s' failed")
+ filename rem-dec)))))
+
+ ;; Save exit.
+ (delete-file tmpfile)))
+
+ ;; That's not expected.
+ (t
+ (tramp-error
+ v 'file-error
+ (concat "Method `%s' should specify both encoding and "
+ "decoding command or an rcp program")
+ method))))
+
+ ;; Make `last-coding-system-used' have the right value.
+ (when coding-system-used
+ (set 'last-coding-system-used coding-system-used))))
+
+ (tramp-flush-file-property v (file-name-directory localname))
+ (tramp-flush-file-property v localname)
+
+ ;; We must protect `last-coding-system-used', now we have set it
+ ;; to its correct value.
+ (let (last-coding-system-used (need-chown t))
+ ;; Set file modification time.
+ (when (or (eq visit t) (stringp visit))
+ (let ((file-attr (file-attributes filename)))
+ (set-visited-file-modtime
+ ;; We must pass modtime explicitely, because filename can
+ ;; be different from (buffer-file-name), f.e. if
+ ;; `file-precious-flag' is set.
+ (nth 5 file-attr))
+ (when (and (eq (nth 2 file-attr) uid)
+ (eq (nth 3 file-attr) gid))
+ (setq need-chown nil))))
+
+ ;; Set the ownership.
+ (when need-chown
+ (tramp-set-file-uid-gid filename uid gid))
+ (when (or (eq visit t) (null visit) (stringp visit))
+ (tramp-message v 0 "Wrote %s" filename))
+ (run-hooks 'tramp-handle-write-region-hook)))))
+
+(defvar tramp-vc-registered-file-names nil
+ "List used to collect file names, which are checked during `vc-registered'.")
+
+;; VC backends check for the existence of various different special
+;; files. This is very time consuming, because every single check
+;; requires a remote command (the file cache must be invalidated).
+;; Therefore, we apply a kind of optimization. We install the file
+;; name handler `tramp-vc-file-name-handler', which does nothing but
+;; remembers all file names for which `file-exists-p' or
+;; `file-readable-p' has been applied. A first run of `vc-registered'
+;; is performed. Afterwards, a script is applied for all collected
+;; file names, using just one remote command. The result of this
+;; script is used to fill the file cache with actual values. Now we
+;; can reset the file name handlers, and we make a second run of
+;; `vc-registered', which returns the expected result without sending
+;; any other remote command.
+(defun tramp-sh-handle-vc-registered (file)
+ "Like `vc-registered' for Tramp files."
+ (tramp-compat-with-temp-message ""
+ (with-parsed-tramp-file-name file nil
+ (with-progress-reporter
+ v 3 (format "Checking `vc-registered' for %s" file)
+
+ ;; There could be new files, created by the vc backend. We
+ ;; cannot reuse the old cache entries, therefore.
+ (let (tramp-vc-registered-file-names
+ (remote-file-name-inhibit-cache (current-time))
+ (file-name-handler-alist
+ `((,tramp-file-name-regexp . tramp-vc-file-name-handler))))
+
+ ;; Here we collect only file names, which need an operation.
+ (tramp-run-real-handler 'vc-registered (list file))
+ (tramp-message v 10 "\n%s" tramp-vc-registered-file-names)
+
+ ;; Send just one command, in order to fill the cache.
+ (when tramp-vc-registered-file-names
+ (tramp-maybe-send-script
+ v
+ (format tramp-vc-registered-read-file-names
+ (tramp-get-file-exists-command v)
+ (format "%s -r" (tramp-get-test-command v)))
+ "tramp_vc_registered_read_file_names")
+
+ (dolist
+ (elt
+ (tramp-send-command-and-read
+ v
+ (format
+ "tramp_vc_registered_read_file_names <<'EOF'\n%s\nEOF\n"
+ (mapconcat 'tramp-shell-quote-argument
+ tramp-vc-registered-file-names
+ "\n"))))
+
+ (tramp-set-file-property
+ v (car elt) (cadr elt) (cadr (cdr elt))))))
+
+ ;; Second run. Now all `file-exists-p' or `file-readable-p'
+ ;; calls shall be answered from the file cache. We unset
+ ;; `process-file-side-effects' in order to keep the cache when
+ ;; `process-file' calls appear.
+ (let (process-file-side-effects)
+ (tramp-run-real-handler 'vc-registered (list file)))))))
+
+;;;###tramp-autoload
+(defun tramp-sh-file-name-handler (operation &rest args)
+ "Invoke remote-shell Tramp file name handler.
+Fall back to normal file name handler if no Tramp handler exists."
+ (when (and tramp-locked (not tramp-locker))
+ (setq tramp-locked nil)
+ (signal 'file-error (list "Forbidden reentrant call of Tramp")))
+ (let ((tl tramp-locked))
+ (unwind-protect
+ (progn
+ (setq tramp-locked t)
+ (let ((tramp-locker t))
+ (save-match-data
+ (let ((fn (assoc operation tramp-sh-file-name-handler-alist)))
+ (if fn
+ (apply (cdr fn) args)
+ (tramp-run-real-handler operation args))))))
+ (setq tramp-locked tl))))
+
+(defun tramp-vc-file-name-handler (operation &rest args)
+ "Invoke special file name handler, which collects files to be handled."
+ (save-match-data
+ (let ((filename
+ (tramp-replace-environment-variables
+ (apply 'tramp-file-name-for-operation operation args)))
+ (fn (assoc operation tramp-sh-file-name-handler-alist)))
+ (with-parsed-tramp-file-name filename nil
+ (cond
+ ;; That's what we want: file names, for which checks are
+ ;; applied. We assume, that VC uses only `file-exists-p' and
+ ;; `file-readable-p' checks; otherwise we must extend the
+ ;; list. We do not perform any action, but return nil, in
+ ;; order to keep `vc-registered' running.
+ ((and fn (memq operation '(file-exists-p file-readable-p)))
+ (add-to-list 'tramp-vc-registered-file-names localname 'append)
+ nil)
+ ;; Tramp file name handlers like `expand-file-name'. They
+ ;; must still work.
+ (fn
+ (save-match-data (apply (cdr fn) args)))
+ ;; Default file name handlers, we don't care.
+ (t (tramp-run-real-handler operation args)))))))
+
+;;; Internal Functions:
+
+(defun tramp-maybe-send-script (vec script name)
+ "Define in remote shell function NAME implemented as SCRIPT.
+Only send the definition if it has not already been done."
+ (let* ((p (tramp-get-connection-process vec))
+ (scripts (tramp-get-connection-property p "scripts" nil)))
+ (unless (member name scripts)
+ (with-progress-reporter vec 5 (format "Sending script `%s'" name)
+ ;; The script could contain a call of Perl. This is masked with `%s'.
+ (tramp-barf-unless-okay
+ vec
+ (format "%s () {\n%s\n}" name
+ (format script (tramp-get-remote-perl vec)))
+ "Script %s sending failed" name)
+ (tramp-set-connection-property p "scripts" (cons name scripts))))))
+
+(defun tramp-set-auto-save ()
+ (when (and ;; ange-ftp has its own auto-save mechanism
+ (eq (tramp-find-foreign-file-name-handler (buffer-file-name))
+ 'tramp-sh-file-name-handler)
+ auto-save-default)
+ (auto-save-mode 1)))
+(add-hook 'find-file-hooks 'tramp-set-auto-save t)
+(add-hook 'tramp-unload-hook
+ (lambda ()
+ (remove-hook 'find-file-hooks 'tramp-set-auto-save)))
+
+(defun tramp-run-test (switch filename)
+ "Run `test' on the remote system, given a SWITCH and a FILENAME.
+Returns the exit code of the `test' program."
+ (with-parsed-tramp-file-name filename nil
+ (tramp-send-command-and-check
+ v
+ (format
+ "%s %s %s"
+ (tramp-get-test-command v)
+ switch
+ (tramp-shell-quote-argument localname)))))
+
+(defun tramp-run-test2 (format-string file1 file2)
+ "Run `test'-like program on the remote system, given FILE1, FILE2.
+FORMAT-STRING contains the program name, switches, and place holders.
+Returns the exit code of the `test' program. Barfs if the methods,
+hosts, or files, disagree."
+ (unless (tramp-equal-remote file1 file2)
+ (with-parsed-tramp-file-name (if (tramp-tramp-file-p file1) file1 file2) nil
+ (tramp-error
+ v 'file-error
+ "tramp-run-test2 only implemented for same method, user, host")))
+ (with-parsed-tramp-file-name file1 v1
+ (with-parsed-tramp-file-name file1 v2
+ (tramp-send-command-and-check
+ v1
+ (format format-string
+ (tramp-shell-quote-argument v1-localname)
+ (tramp-shell-quote-argument v2-localname))))))
+
+(defun tramp-find-executable
+ (vec progname dirlist &optional ignore-tilde ignore-path)
+ "Searches for PROGNAME in $PATH and all directories mentioned in DIRLIST.
+First arg VEC specifies the connection, PROGNAME is the program
+to search for, and DIRLIST gives the list of directories to
+search. If IGNORE-TILDE is non-nil, directory names starting
+with `~' will be ignored. If IGNORE-PATH is non-nil, searches
+only in DIRLIST.
+
+Returns the absolute file name of PROGNAME, if found, and nil otherwise.
+
+This function expects to be in the right *tramp* buffer."
+ (with-current-buffer (tramp-get-connection-buffer vec)
+ (let (result)
+ ;; Check whether the executable is in $PATH. "which(1)" does not
+ ;; report always a correct error code; therefore we check the
+ ;; number of words it returns.
+ (unless ignore-path
+ (tramp-send-command vec (format "which \\%s | wc -w" progname))
+ (goto-char (point-min))
+ (if (looking-at "^\\s-*1$")
+ (setq result (concat "\\" progname))))
+ (unless result
+ (when ignore-tilde
+ ;; Remove all ~/foo directories from dirlist. In XEmacs,
+ ;; `remove' is in CL, and we want to avoid CL dependencies.
+ (let (newdl d)
+ (while dirlist
+ (setq d (car dirlist))
+ (setq dirlist (cdr dirlist))
+ (unless (char-equal ?~ (aref d 0))
+ (setq newdl (cons d newdl))))
+ (setq dirlist (nreverse newdl))))
+ (tramp-send-command
+ vec
+ (format (concat "while read d; "
+ "do if test -x $d/%s -a -f $d/%s; "
+ "then echo tramp_executable $d/%s; "
+ "break; fi; done <<'EOF'\n"
+ "%s\nEOF")
+ progname progname progname (mapconcat 'identity dirlist "\n")))
+ (goto-char (point-max))
+ (when (search-backward "tramp_executable " nil t)
+ (skip-chars-forward "^ ")
+ (skip-chars-forward " ")
+ (setq result (buffer-substring (point) (point-at-eol)))))
+ result)))
+
+(defun tramp-set-remote-path (vec)
+ "Sets the remote environment PATH to existing directories.
+I.e., for each directory in `tramp-remote-path', it is tested
+whether it exists and if so, it is added to the environment
+variable PATH."
+ (tramp-message vec 5 (format "Setting $PATH environment variable"))
+ (tramp-send-command
+ vec (format "PATH=%s; export PATH"
+ (mapconcat 'identity (tramp-get-remote-path vec) ":"))))
+
+;; ------------------------------------------------------------
+;; -- Communication with external shell --
+;; ------------------------------------------------------------
+
+(defun tramp-find-file-exists-command (vec)
+ "Find a command on the remote host for checking if a file exists.
+Here, we are looking for a command which has zero exit status if the
+file exists and nonzero exit status otherwise."
+ (let ((existing "/")
+ (nonexisting
+ (tramp-shell-quote-argument "/ this file does not exist "))
+ result)
+ ;; The algorithm is as follows: we try a list of several commands.
+ ;; For each command, we first run `$cmd /' -- this should return
+ ;; true, as the root directory always exists. And then we run
+ ;; `$cmd /this\ file\ does\ not\ exist ', hoping that the file indeed
+ ;; does not exist. This should return false. We use the first
+ ;; command we find that seems to work.
+ ;; The list of commands to try is as follows:
+ ;; `ls -d' This works on most systems, but NetBSD 1.4
+ ;; has a bug: `ls' always returns zero exit
+ ;; status, even for files which don't exist.
+ ;; `test -e' Some Bourne shells have a `test' builtin
+ ;; which does not know the `-e' option.
+ ;; `/bin/test -e' For those, the `test' binary on disk normally
+ ;; provides the option. Alas, the binary
+ ;; is sometimes `/bin/test' and sometimes it's
+ ;; `/usr/bin/test'.
+ ;; `/usr/bin/test -e' In case `/bin/test' does not exist.
+ (unless (or
+ (and (setq result (format "%s -e" (tramp-get-test-command vec)))
+ (tramp-send-command-and-check
+ vec (format "%s %s" result existing))
+ (not (tramp-send-command-and-check
+ vec (format "%s %s" result nonexisting))))
+ (and (setq result "/bin/test -e")
+ (tramp-send-command-and-check
+ vec (format "%s %s" result existing))
+ (not (tramp-send-command-and-check
+ vec (format "%s %s" result nonexisting))))
+ (and (setq result "/usr/bin/test -e")
+ (tramp-send-command-and-check
+ vec (format "%s %s" result existing))
+ (not (tramp-send-command-and-check
+ vec (format "%s %s" result nonexisting))))
+ (and (setq result (format "%s -d" (tramp-get-ls-command vec)))
+ (tramp-send-command-and-check
+ vec (format "%s %s" result existing))
+ (not (tramp-send-command-and-check
+ vec (format "%s %s" result nonexisting)))))
+ (tramp-error
+ vec 'file-error "Couldn't find command to check if file exists"))
+ result))
+
+(defun tramp-open-shell (vec shell)
+ "Opens shell SHELL."
+ (with-progress-reporter vec 5 (format "Opening remote shell `%s'" shell)
+ ;; Find arguments for this shell.
+ (let ((tramp-end-of-output tramp-initial-end-of-output)
+ (alist tramp-sh-extra-args)
+ item extra-args)
+ (while (and alist (null extra-args))
+ (setq item (pop alist))
+ (when (string-match (car item) shell)
+ (setq extra-args (cdr item))))
+ (when extra-args (setq shell (concat shell " " extra-args)))
+ (tramp-send-command
+ vec (format "exec env ENV='' PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s"
+ (shell-quote-argument tramp-end-of-output) shell)
+ t))
+ ;; Setting prompts.
+ (tramp-send-command
+ vec (format "PS1=%s" (shell-quote-argument tramp-end-of-output)) t)
+ (tramp-send-command vec "PS2=''" t)
+ (tramp-send-command vec "PS3=''" t)
+ (tramp-send-command vec "PROMPT_COMMAND=''" t)))
+
+(defun tramp-find-shell (vec)
+ "Opens a shell on the remote host which groks tilde expansion."
+ (unless (tramp-get-connection-property vec "remote-shell" nil)
+ (let (shell)
+ (with-current-buffer (tramp-get-buffer vec)
+ (tramp-send-command vec "echo ~root" t)
+ (cond
+ ((or (string-match "^~root$" (buffer-string))
+ ;; The default shell (ksh93) of OpenSolaris is buggy.
+ (string-equal (tramp-get-connection-property vec "uname" "")
+ "SunOS 5.11"))
+ (setq shell
+ (or (tramp-find-executable
+ vec "bash" (tramp-get-remote-path vec) t t)
+ (tramp-find-executable
+ vec "ksh" (tramp-get-remote-path vec) t t)))
+ (unless shell
+ (tramp-error
+ vec 'file-error
+ "Couldn't find a shell which groks tilde expansion"))
+ (tramp-message
+ vec 5 "Starting remote shell `%s' for tilde expansion" shell)
+ (tramp-open-shell vec shell))
+
+ (t (tramp-message
+ vec 5 "Remote `%s' groks tilde expansion, good"
+ (tramp-set-connection-property
+ vec "remote-shell"
+ (tramp-get-method-parameter
+ (tramp-file-name-method vec) 'tramp-remote-sh)))))))))
+
+;; Utility functions.
+
+(defun tramp-barf-if-no-shell-prompt (proc timeout &rest error-args)
+ "Wait for shell prompt and barf if none appears.
+Looks at process PROC to see if a shell prompt appears in TIMEOUT
+seconds. If not, it produces an error message with the given ERROR-ARGS."
+ (unless
+ (tramp-wait-for-regexp
+ proc timeout
+ (format
+ "\\(%s\\|%s\\)\\'" shell-prompt-pattern tramp-shell-prompt-pattern))
+ (apply 'tramp-error-with-buffer nil proc 'file-error error-args)))
+
+(defun tramp-open-connection-setup-interactive-shell (proc vec)
+ "Set up an interactive shell.
+Mainly sets the prompt and the echo correctly. PROC is the shell
+process to set up. VEC specifies the connection."
+ (let ((tramp-end-of-output tramp-initial-end-of-output))
+ ;; It is useful to set the prompt in the following command because
+ ;; some people have a setting for $PS1 which /bin/sh doesn't know
+ ;; about and thus /bin/sh will display a strange prompt. For
+ ;; example, if $PS1 has "${CWD}" in the value, then ksh will
+ ;; display the current working directory but /bin/sh will display
+ ;; a dollar sign. The following command line sets $PS1 to a sane
+ ;; value, and works under Bourne-ish shells as well as csh-like
+ ;; shells. Daniel Pittman reports that the unusual positioning of
+ ;; the single quotes makes it work under `rc', too. We also unset
+ ;; the variable $ENV because that is read by some sh
+ ;; implementations (eg, bash when called as sh) on startup; this
+ ;; way, we avoid the startup file clobbering $PS1. $PROMPT_COMMAND
+ ;; is another way to set the prompt in /bin/bash, it must be
+ ;; discarded as well.
+ (tramp-open-shell
+ vec
+ (tramp-get-method-parameter (tramp-file-name-method vec) 'tramp-remote-sh))
+
+ ;; Disable echo.
+ (tramp-message vec 5 "Setting up remote shell environment")
+ (tramp-send-command vec "stty -inlcr -echo kill '^U' erase '^H'" t)
+ ;; Check whether the echo has really been disabled. Some
+ ;; implementations, like busybox of embedded GNU/Linux, don't
+ ;; support disabling.
+ (tramp-send-command vec "echo foo" t)
+ (with-current-buffer (process-buffer proc)
+ (goto-char (point-min))
+ (when (looking-at "echo foo")
+ (tramp-set-connection-property proc "remote-echo" t)
+ (tramp-message vec 5 "Remote echo still on. Ok.")
+ ;; Make sure backspaces and their echo are enabled and no line
+ ;; width magic interferes with them.
+ (tramp-send-command vec "stty icanon erase ^H cols 32767" t))))
+
+ (tramp-message vec 5 "Setting shell prompt")
+ (tramp-send-command
+ vec (format "PS1=%s" (shell-quote-argument tramp-end-of-output)) t)
+ (tramp-send-command vec "PS2=''" t)
+ (tramp-send-command vec "PS3=''" t)
+ (tramp-send-command vec "PROMPT_COMMAND=''" t)
+
+ ;; Try to set up the coding system correctly.
+ ;; CCC this can't be the right way to do it. Hm.
+ (tramp-message vec 5 "Determining coding system")
+ (tramp-send-command vec "echo foo ; echo bar" t)
+ (with-current-buffer (process-buffer proc)
+ (goto-char (point-min))
+ (if (featurep 'mule)
+ ;; Use MULE to select the right EOL convention for communicating
+ ;; with the process.
+ (let* ((cs (or (tramp-compat-funcall 'process-coding-system proc)
+ (cons 'undecided 'undecided)))
+ cs-decode cs-encode)
+ (when (symbolp cs) (setq cs (cons cs cs)))
+ (setq cs-decode (car cs))
+ (setq cs-encode (cdr cs))
+ (unless cs-decode (setq cs-decode 'undecided))
+ (unless cs-encode (setq cs-encode 'undecided))
+ (setq cs-encode (tramp-compat-coding-system-change-eol-conversion
+ cs-encode 'unix))
+ (when (search-forward "\r" nil t)
+ (setq cs-decode (tramp-compat-coding-system-change-eol-conversion
+ cs-decode 'dos)))
+ (tramp-compat-funcall
+ 'set-buffer-process-coding-system cs-decode cs-encode)
+ (tramp-message
+ vec 5 "Setting coding system to `%s' and `%s'" cs-decode cs-encode))
+ ;; Look for ^M and do something useful if found.
+ (when (search-forward "\r" nil t)
+ ;; We have found a ^M but cannot frob the process coding system
+ ;; because we're running on a non-MULE Emacs. Let's try
+ ;; stty, instead.
+ (tramp-send-command vec "stty -onlcr" t))))
+
+ (tramp-send-command vec "set +o vi +o emacs" t)
+
+ ;; Check whether the output of "uname -sr" has been changed. If
+ ;; yes, this is a strong indication that we must expire all
+ ;; connection properties. We start again with
+ ;; `tramp-maybe-open-connection', it will be catched there.
+ (tramp-message vec 5 "Checking system information")
+ (let ((old-uname (tramp-get-connection-property vec "uname" nil))
+ (new-uname
+ (tramp-set-connection-property
+ vec "uname"
+ (tramp-send-command-and-read vec "echo \\\"`uname -sr`\\\""))))
+ (when (and (stringp old-uname) (not (string-equal old-uname new-uname)))
+ (with-current-buffer (tramp-get-debug-buffer vec)
+ ;; Keep the debug buffer.
+ (rename-buffer
+ (generate-new-buffer-name tramp-temp-buffer-name) 'unique)
+ (tramp-cleanup-connection vec)
+ (if (= (point-min) (point-max))
+ (kill-buffer nil)
+ (rename-buffer (tramp-debug-buffer-name vec) 'unique))
+ ;; We call `tramp-get-buffer' in order to keep the debug buffer.
+ (tramp-get-buffer vec)
+ (tramp-message
+ vec 3
+ "Connection reset, because remote host changed from `%s' to `%s'"
+ old-uname new-uname)
+ (throw 'uname-changed (tramp-maybe-open-connection vec)))))
+
+ ;; Check whether the remote host suffers from buggy
+ ;; `send-process-string'. This is known for FreeBSD (see comment in
+ ;; `send_process', file process.c). I've tested sending 624 bytes
+ ;; successfully, sending 625 bytes failed. Emacs makes a hack when
+ ;; this host type is detected locally. It cannot handle remote
+ ;; hosts, though.
+ (with-connection-property proc "chunksize"
+ (cond
+ ((and (integerp tramp-chunksize) (> tramp-chunksize 0))
+ tramp-chunksize)
+ (t
+ (tramp-message
+ vec 5 "Checking remote host type for `send-process-string' bug")
+ (if (string-match
+ "^FreeBSD" (tramp-get-connection-property vec "uname" ""))
+ 500 0))))
+
+ ;; Set remote PATH variable.
+ (tramp-set-remote-path vec)
+
+ ;; Search for a good shell before searching for a command which
+ ;; checks if a file exists. This is done because Tramp wants to use
+ ;; "test foo; echo $?" to check if various conditions hold, and
+ ;; there are buggy /bin/sh implementations which don't execute the
+ ;; "echo $?" part if the "test" part has an error. In particular,
+ ;; the OpenSolaris /bin/sh is a problem. There are also other
+ ;; problems with /bin/sh of OpenSolaris, like redirection of stderr
+ ;; in function declarations, or changing HISTFILE in place.
+ ;; Therefore, OpenSolaris' /bin/sh is replaced by bash, when
+ ;; detected.
+ (tramp-find-shell vec)
+
+ ;; Disable unexpected output.
+ (tramp-send-command vec "mesg n; biff n" t)
+
+ ;; IRIX64 bash expands "!" even when in single quotes. This
+ ;; destroys our shell functions, we must disable it. See
+ ;; <http://stackoverflow.com/questions/3291692/irix-bash-shell-expands-expression-in-single-quotes-yet-shouldnt>.
+ (when (string-match "^IRIX64" (tramp-get-connection-property vec "uname" ""))
+ (tramp-send-command vec "set +H" t))
+
+ ;; On BSD-like systems, ?\t is expanded to spaces. Suppress this.
+ (when (string-match "BSD\\|Darwin"
+ (tramp-get-connection-property vec "uname" ""))
+ (tramp-send-command vec "stty -oxtabs" t))
+
+ ;; Set `remote-tty' process property.
+ (ignore-errors
+ (let ((tty (tramp-send-command-and-read vec "echo \\\"`tty`\\\"")))
+ (unless (zerop (length tty))
+ (tramp-compat-process-put proc 'remote-tty tty))))
+
+ ;; Dump stty settings in the traces.
+ (when (>= tramp-verbose 9)
+ (tramp-send-command vec "stty -a" t))
+
+ ;; Set the environment.
+ (tramp-message vec 5 "Setting default environment")
+
+ (let ((env (copy-sequence tramp-remote-process-environment))
+ unset item)
+ (while env
+ (setq item (tramp-compat-split-string (car env) "="))
+ (setcdr item (mapconcat 'identity (cdr item) "="))
+ (if (and (stringp (cdr item)) (not (string-equal (cdr item) "")))
+ (tramp-send-command
+ vec (format "%s=%s; export %s" (car item) (cdr item) (car item)) t)
+ (push (car item) unset))
+ (setq env (cdr env)))
+ (when unset
+ (tramp-send-command
+ vec (format "unset %s" (mapconcat 'identity unset " ")) t))))
+
+;; CCC: We should either implement a Perl version of base64 encoding
+;; and decoding. Then we just use that in the last item. The other
+;; alternative is to use the Perl version of UU encoding. But then
+;; we need a Lisp version of uuencode.
+;;
+;; Old text from documentation of tramp-methods:
+;; Using a uuencode/uudecode inline method is discouraged, please use one
+;; of the base64 methods instead since base64 encoding is much more
+;; reliable and the commands are more standardized between the different
+;; Unix versions. But if you can't use base64 for some reason, please
+;; note that the default uudecode command does not work well for some
+;; Unices, in particular AIX and Irix. For AIX, you might want to use
+;; the following command for uudecode:
+;;
+;; sed '/^begin/d;/^[` ]$/d;/^end/d' | iconv -f uucode -t ISO8859-1
+;;
+;; For Irix, no solution is known yet.
+
+(autoload 'uudecode-decode-region "uudecode")
+
+(defconst tramp-local-coding-commands
+ '((b64 base64-encode-region base64-decode-region)
+ (uu tramp-uuencode-region uudecode-decode-region)
+ (pack
+ "perl -e 'binmode STDIN; binmode STDOUT; print pack(q{u*}, join q{}, <>)'"
+ "perl -e 'binmode STDIN; binmode STDOUT; print unpack(q{u*}, join q{}, <>)'"))
+ "List of local coding commands for inline transfer.
+Each item is a list that looks like this:
+
+\(FORMAT ENCODING DECODING\)
+
+FORMAT is symbol describing the encoding/decoding format. It can be
+`b64' for base64 encoding, `uu' for uu encoding, or `pack' for simple packing.
+
+ENCODING and DECODING can be strings, giving commands, or symbols,
+giving functions. If they are strings, then they can contain
+the \"%s\" format specifier. If that specifier is present, the input
+filename will be put into the command line at that spot. If the
+specifier is not present, the input should be read from standard
+input.
+
+If they are functions, they will be called with two arguments, start
+and end of region, and are expected to replace the region contents
+with the encoded or decoded results, respectively.")
+
+(defconst tramp-remote-coding-commands
+ '((b64 "base64" "base64 -d -i")
+ ;; "-i" is more robust with older base64 from GNU coreutils.
+ ;; However, I don't know whether all base64 versions do supports
+ ;; this option.
+ (b64 "base64" "base64 -d")
+ (b64 "mimencode -b" "mimencode -u -b")
+ (b64 "mmencode -b" "mmencode -u -b")
+ (b64 "recode data..base64" "recode base64..data")
+ (b64 tramp-perl-encode-with-module tramp-perl-decode-with-module)
+ (b64 tramp-perl-encode tramp-perl-decode)
+ (uu "uuencode xxx" "uudecode -o /dev/stdout")
+ (uu "uuencode xxx" "uudecode -o -")
+ (uu "uuencode xxx" "uudecode -p")
+ (uu "uuencode xxx" tramp-uudecode)
+ (pack
+ "perl -e 'binmode STDIN; binmode STDOUT; print pack(q{u*}, join q{}, <>)'"
+ "perl -e 'binmode STDIN; binmode STDOUT; print unpack(q{u*}, join q{}, <>)'"))
+ "List of remote coding commands for inline transfer.
+Each item is a list that looks like this:
+
+\(FORMAT ENCODING DECODING\)
+
+FORMAT is symbol describing the encoding/decoding format. It can be
+`b64' for base64 encoding, `uu' for uu encoding, or `pack' for simple packing.
+
+ENCODING and DECODING can be strings, giving commands, or symbols,
+giving variables. If they are strings, then they can contain
+the \"%s\" format specifier. If that specifier is present, the input
+filename will be put into the command line at that spot. If the
+specifier is not present, the input should be read from standard
+input.
+
+If they are variables, this variable is a string containing a Perl
+implementation for this functionality. This Perl program will be transferred
+to the remote host, and it is available as shell function with the same name.")
+
+(defun tramp-find-inline-encoding (vec)
+ "Find an inline transfer encoding that works.
+Goes through the list `tramp-local-coding-commands' and
+`tramp-remote-coding-commands'."
+ (save-excursion
+ (let ((local-commands tramp-local-coding-commands)
+ (magic "xyzzy")
+ loc-enc loc-dec rem-enc rem-dec litem ritem found)
+ (while (and local-commands (not found))
+ (setq litem (pop local-commands))
+ (catch 'wont-work-local
+ (let ((format (nth 0 litem))
+ (remote-commands tramp-remote-coding-commands))
+ (setq loc-enc (nth 1 litem))
+ (setq loc-dec (nth 2 litem))
+ ;; If the local encoder or decoder is a string, the
+ ;; corresponding command has to work locally.
+ (if (not (stringp loc-enc))
+ (tramp-message
+ vec 5 "Checking local encoding function `%s'" loc-enc)
+ (tramp-message
+ vec 5 "Checking local encoding command `%s' for sanity" loc-enc)
+ (unless (zerop (tramp-call-local-coding-command
+ loc-enc nil nil))
+ (throw 'wont-work-local nil)))
+ (if (not (stringp loc-dec))
+ (tramp-message
+ vec 5 "Checking local decoding function `%s'" loc-dec)
+ (tramp-message
+ vec 5 "Checking local decoding command `%s' for sanity" loc-dec)
+ (unless (zerop (tramp-call-local-coding-command
+ loc-dec nil nil))
+ (throw 'wont-work-local nil)))
+ ;; Search for remote coding commands with the same format
+ (while (and remote-commands (not found))
+ (setq ritem (pop remote-commands))
+ (catch 'wont-work-remote
+ (when (equal format (nth 0 ritem))
+ (setq rem-enc (nth 1 ritem))
+ (setq rem-dec (nth 2 ritem))
+ ;; Check if remote encoding and decoding commands can be
+ ;; called remotely with null input and output. This makes
+ ;; sure there are no syntax errors and the command is really
+ ;; found. Note that we do not redirect stdout to /dev/null,
+ ;; for two reasons: when checking the decoding command, we
+ ;; actually check the output it gives. And also, when
+ ;; redirecting "mimencode" output to /dev/null, then as root
+ ;; it might change the permissions of /dev/null!
+ (when (not (stringp rem-enc))
+ (let ((name (symbol-name rem-enc)))
+ (while (string-match (regexp-quote "-") name)
+ (setq name (replace-match "_" nil t name)))
+ (tramp-maybe-send-script vec (symbol-value rem-enc) name)
+ (setq rem-enc name)))
+ (tramp-message
+ vec 5
+ "Checking remote encoding command `%s' for sanity" rem-enc)
+ (unless (tramp-send-command-and-check
+ vec (format "%s </dev/null" rem-enc) t)
+ (throw 'wont-work-remote nil))
+
+ (when (not (stringp rem-dec))
+ (let ((name (symbol-name rem-dec)))
+ (while (string-match (regexp-quote "-") name)
+ (setq name (replace-match "_" nil t name)))
+ (tramp-maybe-send-script vec (symbol-value rem-dec) name)
+ (setq rem-dec name)))
+ (tramp-message
+ vec 5
+ "Checking remote decoding command `%s' for sanity" rem-dec)
+ (unless (tramp-send-command-and-check
+ vec
+ (format "echo %s | %s | %s" magic rem-enc rem-dec)
+ t)
+ (throw 'wont-work-remote nil))
+
+ (with-current-buffer (tramp-get-buffer vec)
+ (goto-char (point-min))
+ (unless (looking-at (regexp-quote magic))
+ (throw 'wont-work-remote nil)))
+
+ ;; `rem-enc' and `rem-dec' could be a string meanwhile.
+ (setq rem-enc (nth 1 ritem))
+ (setq rem-dec (nth 2 ritem))
+ (setq found t)))))))
+
+ ;; Did we find something?
+ (unless found
+ (tramp-error
+ vec 'file-error "Couldn't find an inline transfer encoding"))
+
+ ;; Set connection properties.
+ (tramp-message vec 5 "Using local encoding `%s'" loc-enc)
+ (tramp-set-connection-property vec "local-encoding" loc-enc)
+ (tramp-message vec 5 "Using local decoding `%s'" loc-dec)
+ (tramp-set-connection-property vec "local-decoding" loc-dec)
+ (tramp-message vec 5 "Using remote encoding `%s'" rem-enc)
+ (tramp-set-connection-property vec "remote-encoding" rem-enc)
+ (tramp-message vec 5 "Using remote decoding `%s'" rem-dec)
+ (tramp-set-connection-property vec "remote-decoding" rem-dec))))
+
+(defun tramp-call-local-coding-command (cmd input output)
+ "Call the local encoding or decoding command.
+If CMD contains \"%s\", provide input file INPUT there in command.
+Otherwise, INPUT is passed via standard input.
+INPUT can also be nil which means `/dev/null'.
+OUTPUT can be a string (which specifies a filename), or t (which
+means standard output and thus the current buffer), or nil (which
+means discard it)."
+ (tramp-compat-call-process
+ tramp-encoding-shell
+ (when (and input (not (string-match "%s" cmd))) input)
+ (if (eq output t) t nil)
+ nil
+ tramp-encoding-command-switch
+ (concat
+ (if (string-match "%s" cmd) (format cmd input) cmd)
+ (if (stringp output) (concat "> " output) ""))))
+
+(defconst tramp-inline-compress-commands
+ '(("gzip" "gzip -d")
+ ("bzip2" "bzip2 -d")
+ ("compress" "compress -d"))
+ "List of compress and decompress commands for inline transfer.
+Each item is a list that looks like this:
+
+\(COMPRESS DECOMPRESS\)
+
+COMPRESS or DECOMPRESS are strings with the respective commands.")
+
+(defun tramp-find-inline-compress (vec)
+ "Find an inline transfer compress command that works.
+Goes through the list `tramp-inline-compress-commands'."
+ (save-excursion
+ (let ((commands tramp-inline-compress-commands)
+ (magic "xyzzy")
+ item compress decompress
+ found)
+ (while (and commands (not found))
+ (catch 'next
+ (setq item (pop commands)
+ compress (nth 0 item)
+ decompress (nth 1 item))
+ (tramp-message
+ vec 5
+ "Checking local compress command `%s', `%s' for sanity"
+ compress decompress)
+ (unless (zerop (tramp-call-local-coding-command
+ (format "echo %s | %s | %s"
+ magic compress decompress) nil nil))
+ (throw 'next nil))
+ (tramp-message
+ vec 5
+ "Checking remote compress command `%s', `%s' for sanity"
+ compress decompress)
+ (unless (tramp-send-command-and-check
+ vec (format "echo %s | %s | %s" magic compress decompress) t)
+ (throw 'next nil))
+ (setq found t)))
+
+ ;; Did we find something?
+ (if found
+ (progn
+ ;; Set connection properties.
+ (tramp-message
+ vec 5 "Using inline transfer compress command `%s'" compress)
+ (tramp-set-connection-property vec "inline-compress" compress)
+ (tramp-message
+ vec 5 "Using inline transfer decompress command `%s'" decompress)
+ (tramp-set-connection-property vec "inline-decompress" decompress))
+
+ (tramp-set-connection-property vec "inline-compress" nil)
+ (tramp-set-connection-property vec "inline-decompress" nil)
+ (tramp-message
+ vec 2 "Couldn't find an inline transfer compress command")))))
+
+(defun tramp-compute-multi-hops (vec)
+ "Expands VEC according to `tramp-default-proxies-alist'.
+Gateway hops are already opened."
+ (let ((target-alist `(,vec))
+ (choices tramp-default-proxies-alist)
+ item proxy)
+
+ ;; Look for proxy hosts to be passed.
+ (while choices
+ (setq item (pop choices)
+ proxy (eval (nth 2 item)))
+ (when (and
+ ;; host
+ (string-match (or (eval (nth 0 item)) "")
+ (or (tramp-file-name-host (car target-alist)) ""))
+ ;; user
+ (string-match (or (eval (nth 1 item)) "")
+ (or (tramp-file-name-user (car target-alist)) "")))
+ (if (null proxy)
+ ;; No more hops needed.
+ (setq choices nil)
+ ;; Replace placeholders.
+ (setq proxy
+ (format-spec
+ proxy
+ (format-spec-make
+ ?u (or (tramp-file-name-user (car target-alist)) "")
+ ?h (or (tramp-file-name-host (car target-alist)) ""))))
+ (with-parsed-tramp-file-name proxy l
+ ;; Add the hop.
+ (add-to-list 'target-alist l)
+ ;; Start next search.
+ (setq choices tramp-default-proxies-alist)))))
+
+ ;; Handle gateways.
+ (when (string-match
+ (format
+ "^\\(%s\\|%s\\)$" tramp-gw-tunnel-method tramp-gw-socks-method)
+ (tramp-file-name-method (car target-alist)))
+ (let ((gw (pop target-alist))
+ (hop (pop target-alist)))
+ ;; Is the method prepared for gateways?
+ (unless (tramp-file-name-port hop)
+ (tramp-error
+ vec 'file-error
+ "Connection `%s' is not supported for gateway access." hop))
+ ;; Open the gateway connection.
+ (add-to-list
+ 'target-alist
+ (vector
+ (tramp-file-name-method hop) (tramp-file-name-user hop)
+ (tramp-compat-funcall 'tramp-gw-open-connection vec gw hop) nil))
+ ;; For the password prompt, we need the correct values.
+ ;; Therefore, we must remember the gateway vector. But we
+ ;; cannot do it as connection property, because it shouldn't
+ ;; be persistent. And we have no started process yet either.
+ (tramp-set-file-property (car target-alist) "" "gateway" hop)))
+
+ ;; Foreign and out-of-band methods are not supported for multi-hops.
+ (when (cdr target-alist)
+ (setq choices target-alist)
+ (while choices
+ (setq item (pop choices))
+ (when
+ (or
+ (not
+ (tramp-get-method-parameter
+ (tramp-file-name-method item) 'tramp-login-program))
+ (tramp-get-method-parameter
+ (tramp-file-name-method item) 'tramp-copy-program))
+ (tramp-error
+ vec 'file-error
+ "Method `%s' is not supported for multi-hops."
+ (tramp-file-name-method item)))))
+
+ ;; In case the host name is not used for the remote shell
+ ;; command, the user could be misguided by applying a random
+ ;; hostname.
+ (let* ((v (car target-alist))
+ (method (tramp-file-name-method v))
+ (host (tramp-file-name-host v)))
+ (unless
+ (or
+ ;; There are multi-hops.
+ (cdr target-alist)
+ ;; The host name is used for the remote shell command.
+ (member
+ '("%h") (tramp-get-method-parameter method 'tramp-login-args))
+ ;; The host is local. We cannot use `tramp-local-host-p'
+ ;; here, because it opens a connection as well.
+ (string-match tramp-local-host-regexp host))
+ (tramp-error
+ v 'file-error
+ "Host `%s' looks like a remote host, `%s' can only use the local host"
+ host method)))
+
+ ;; Result.
+ target-alist))
+
+(defun tramp-maybe-open-connection (vec)
+ "Maybe open a connection VEC.
+Does not do anything if a connection is already open, but re-opens the
+connection if a previous connection has died for some reason."
+ (catch 'uname-changed
+ (let ((p (tramp-get-connection-process vec))
+ (process-name (tramp-get-connection-property vec "process-name" nil))
+ (process-environment (copy-sequence process-environment)))
+
+ ;; If too much time has passed since last command was sent, look
+ ;; whether process is still alive. If it isn't, kill it. When
+ ;; using ssh, it can sometimes happen that the remote end has
+ ;; hung up but the local ssh client doesn't recognize this until
+ ;; it tries to send some data to the remote end. So that's why
+ ;; we try to send a command from time to time, then look again
+ ;; whether the process is really alive.
+ (condition-case nil
+ (when (and (> (tramp-time-diff
+ (current-time)
+ (tramp-get-connection-property
+ p "last-cmd-time" '(0 0 0)))
+ 60)
+ p (processp p) (memq (process-status p) '(run open)))
+ (tramp-send-command vec "echo are you awake" t t)
+ (unless (and (memq (process-status p) '(run open))
+ (tramp-wait-for-output p 10))
+ ;; The error will be catched locally.
+ (tramp-error vec 'file-error "Awake did fail")))
+ (file-error
+ (tramp-flush-connection-property vec)
+ (tramp-flush-connection-property p)
+ (delete-process p)
+ (setq p nil)))
+
+ ;; New connection must be opened.
+ (unless (and p (processp p) (memq (process-status p) '(run open)))
+
+ ;; We call `tramp-get-buffer' in order to get a debug buffer for
+ ;; messages from the beginning.
+ (tramp-get-buffer vec)
+ (with-progress-reporter
+ vec 3
+ (if (zerop (length (tramp-file-name-user vec)))
+ (format "Opening connection for %s using %s"
+ (tramp-file-name-host vec)
+ (tramp-file-name-method vec))
+ (format "Opening connection for %s@%s using %s"
+ (tramp-file-name-user vec)
+ (tramp-file-name-host vec)
+ (tramp-file-name-method vec)))
+
+ ;; Start new process.
+ (when (and p (processp p))
+ (delete-process p))
+ (setenv "TERM" tramp-terminal-type)
+ (setenv "LC_ALL" "C")
+ (setenv "PROMPT_COMMAND")
+ (setenv "PS1" tramp-initial-end-of-output)
+ (let* ((target-alist (tramp-compute-multi-hops vec))
+ (process-connection-type tramp-process-connection-type)
+ (process-adaptive-read-buffering nil)
+ (coding-system-for-read nil)
+ ;; This must be done in order to avoid our file name handler.
+ (p (let ((default-directory
+ (tramp-compat-temporary-file-directory)))
+ (start-process
+ (tramp-get-connection-name vec)
+ (tramp-get-connection-buffer vec)
+ tramp-encoding-shell))))
+
+ (tramp-message
+ vec 6 "%s" (mapconcat 'identity (process-command p) " "))
+
+ ;; Check whether process is alive.
+ (tramp-compat-set-process-query-on-exit-flag p nil)
+ (tramp-barf-if-no-shell-prompt
+ p 60 "Couldn't find local shell prompt %s" tramp-encoding-shell)
+
+ ;; Now do all the connections as specified.
+ (while target-alist
+ (let* ((hop (car target-alist))
+ (l-method (tramp-file-name-method hop))
+ (l-user (tramp-file-name-user hop))
+ (l-host (tramp-file-name-host hop))
+ (l-port nil)
+ (login-program
+ (tramp-get-method-parameter
+ l-method 'tramp-login-program))
+ (login-args
+ (tramp-get-method-parameter l-method 'tramp-login-args))
+ (async-args
+ (tramp-get-method-parameter l-method 'tramp-async-args))
+ (gw-args
+ (tramp-get-method-parameter l-method 'tramp-gw-args))
+ (gw (tramp-get-file-property hop "" "gateway" nil))
+ (g-method (and gw (tramp-file-name-method gw)))
+ (g-user (and gw (tramp-file-name-user gw)))
+ (g-host (and gw (tramp-file-name-host gw)))
+ (command login-program)
+ ;; We don't create the temporary file. In fact,
+ ;; it is just a prefix for the ControlPath option
+ ;; of ssh; the real temporary file has another
+ ;; name, and it is created and protected by ssh.
+ ;; It is also removed by ssh, when the connection
+ ;; is closed.
+ (tmpfile
+ (tramp-set-connection-property
+ p "temp-file"
+ (make-temp-name
+ (expand-file-name
+ tramp-temp-name-prefix
+ (tramp-compat-temporary-file-directory)))))
+ spec)
+
+ ;; Add arguments for asynchrononous processes.
+ (when (and process-name async-args)
+ (setq login-args (append async-args login-args)))
+
+ ;; Add gateway arguments if necessary.
+ (when (and gw gw-args)
+ (setq login-args (append gw-args login-args)))
+
+ ;; Check for port number. Until now, there's no need
+ ;; for handling like method, user, host.
+ (when (string-match tramp-host-with-port-regexp l-host)
+ (setq l-port (match-string 2 l-host)
+ l-host (match-string 1 l-host)))
+
+ ;; Set variables for computing the prompt for reading
+ ;; password. They can also be derived from a gateway.
+ (setq tramp-current-method (or g-method l-method)
+ tramp-current-user (or g-user l-user)
+ tramp-current-host (or g-host l-host))
+
+ ;; Replace login-args place holders.
+ (setq
+ l-host (or l-host "")
+ l-user (or l-user "")
+ l-port (or l-port "")
+ spec (format-spec-make
+ ?h l-host ?u l-user ?p l-port ?t tmpfile)
+ command
+ (concat
+ ;; We do not want to see the trailing local prompt in
+ ;; `start-file-process'.
+ (unless (memq system-type '(windows-nt)) "exec ")
+ command " "
+ (mapconcat
+ (lambda (x)
+ (setq x (mapcar (lambda (y) (format-spec y spec)) x))
+ (unless (member "" x) (mapconcat 'identity x " ")))
+ login-args " ")
+ ;; Local shell could be a Windows COMSPEC. It
+ ;; doesn't know the ";" syntax, but we must exit
+ ;; always for `start-file-process'. "exec" does not
+ ;; work either.
+ (if (memq system-type '(windows-nt)) " && exit || exit")))
+
+ ;; Send the command.
+ (tramp-message vec 3 "Sending command `%s'" command)
+ (tramp-send-command vec command t t)
+ (tramp-process-actions p vec tramp-actions-before-shell 60)
+ (tramp-message
+ vec 3 "Found remote shell prompt on `%s'" l-host))
+ ;; Next hop.
+ (setq target-alist (cdr target-alist)))
+
+ ;; Make initial shell settings.
+ (tramp-open-connection-setup-interactive-shell p vec)))))))
+
+(defun tramp-send-command (vec command &optional neveropen nooutput)
+ "Send the COMMAND to connection VEC.
+Erases temporary buffer before sending the command. If optional
+arg NEVEROPEN is non-nil, never try to open the connection. This
+is meant to be used from `tramp-maybe-open-connection' only. The
+function waits for output unless NOOUTPUT is set."
+ (unless neveropen (tramp-maybe-open-connection vec))
+ (let ((p (tramp-get-connection-process vec)))
+ (when (tramp-get-connection-property p "remote-echo" nil)
+ ;; We mark the command string that it can be erased in the output buffer.
+ (tramp-set-connection-property p "check-remote-echo" t)
+ (setq command (format "%s%s%s" tramp-echo-mark command tramp-echo-mark)))
+ (when (string-match "<<'EOF'" command)
+ ;; Unset $PS1 when using here documents, in order to avoid
+ ;; multiple prompts.
+ (setq command (concat "(PS1= ; " command "\n)")))
+ ;; Send the command.
+ (tramp-message vec 6 "%s" command)
+ (tramp-send-string vec command)
+ (unless nooutput (tramp-wait-for-output p))))
+
+(defun tramp-wait-for-output (proc &optional timeout)
+ "Wait for output from remote command."
+ (unless (buffer-live-p (process-buffer proc))
+ (delete-process proc)
+ (tramp-error proc 'file-error "Process `%s' not available, try again" proc))
+ (with-current-buffer (process-buffer proc)
+ (let* (;; Initially, `tramp-end-of-output' is "#$ ". There might
+ ;; be leading escape sequences, which must be ignored.
+ (regexp (format "[^#$\n]*%s\r?$" (regexp-quote tramp-end-of-output)))
+ ;; Sometimes, the commands do not return a newline but a
+ ;; null byte before the shell prompt, for example "git
+ ;; ls-files -c -z ...".
+ (regexp1 (format "\\(^\\|\000\\)%s" regexp))
+ (found (tramp-wait-for-regexp proc timeout regexp1)))
+ (if found
+ (let (buffer-read-only)
+ ;; A simple-minded busybox has sent " ^H" sequences.
+ ;; Delete them.
+ (goto-char (point-min))
+ (when (re-search-forward "^\\(.\b\\)+$" (point-at-eol) t)
+ (forward-line 1)
+ (delete-region (point-min) (point)))
+ ;; Delete the prompt.
+ (goto-char (point-max))
+ (re-search-backward regexp nil t)
+ (delete-region (point) (point-max)))
+ (if timeout
+ (tramp-error
+ proc 'file-error
+ "[[Remote prompt `%s' not found in %d secs]]"
+ tramp-end-of-output timeout)
+ (tramp-error
+ proc 'file-error
+ "[[Remote prompt `%s' not found]]" tramp-end-of-output)))
+ ;; Return value is whether end-of-output sentinel was found.
+ found)))
+
+(defun tramp-send-command-and-check
+ (vec command &optional subshell dont-suppress-err)
+ "Run COMMAND and check its exit status.
+Sends `echo $?' along with the COMMAND for checking the exit status. If
+COMMAND is nil, just sends `echo $?'. Returns the exit status found.
+
+If the optional argument SUBSHELL is non-nil, the command is
+executed in a subshell, ie surrounded by parentheses. If
+DONT-SUPPRESS-ERR is non-nil, stderr won't be sent to /dev/null."
+ (tramp-send-command
+ vec
+ (concat (if subshell "( " "")
+ command
+ (if command (if dont-suppress-err "; " " 2>/dev/null; ") "")
+ "echo tramp_exit_status $?"
+ (if subshell " )" "")))
+ (with-current-buffer (tramp-get-connection-buffer vec)
+ (goto-char (point-max))
+ (unless (re-search-backward "tramp_exit_status [0-9]+" nil t)
+ (tramp-error
+ vec 'file-error "Couldn't find exit status of `%s'" command))
+ (skip-chars-forward "^ ")
+ (prog1
+ (zerop (read (current-buffer)))
+ (let (buffer-read-only)
+ (delete-region (match-beginning 0) (point-max))))))
+
+(defun tramp-barf-unless-okay (vec command fmt &rest args)
+ "Run COMMAND, check exit status, throw error if exit status not okay.
+Similar to `tramp-send-command-and-check' but accepts two more arguments
+FMT and ARGS which are passed to `error'."
+ (unless (tramp-send-command-and-check vec command)
+ (apply 'tramp-error vec 'file-error fmt args)))
+
+(defun tramp-send-command-and-read (vec command)
+ "Run COMMAND and return the output, which must be a Lisp expression.
+In case there is no valid Lisp expression, it raises an error"
+ (tramp-barf-unless-okay vec command "`%s' returns with error" command)
+ (with-current-buffer (tramp-get-connection-buffer vec)
+ ;; Read the expression.
+ (goto-char (point-min))
+ (condition-case nil
+ (prog1 (read (current-buffer))
+ ;; Error handling.
+ (when (re-search-forward "\\S-" (point-at-eol) t)
+ (error nil)))
+ (error (tramp-error
+ vec 'file-error
+ "`%s' does not return a valid Lisp expression: `%s'"
+ command (buffer-string))))))
+
+(defun tramp-convert-file-attributes (vec attr)
+ "Convert file-attributes ATTR generated by perl script, stat or ls.
+Convert file mode bits to string and set virtual device number.
+Return ATTR."
+ (when attr
+ ;; Convert last access time.
+ (unless (listp (nth 4 attr))
+ (setcar (nthcdr 4 attr)
+ (list (floor (nth 4 attr) 65536)
+ (floor (mod (nth 4 attr) 65536)))))
+ ;; Convert last modification time.
+ (unless (listp (nth 5 attr))
+ (setcar (nthcdr 5 attr)
+ (list (floor (nth 5 attr) 65536)
+ (floor (mod (nth 5 attr) 65536)))))
+ ;; Convert last status change time.
+ (unless (listp (nth 6 attr))
+ (setcar (nthcdr 6 attr)
+ (list (floor (nth 6 attr) 65536)
+ (floor (mod (nth 6 attr) 65536)))))
+ ;; Convert file size.
+ (when (< (nth 7 attr) 0)
+ (setcar (nthcdr 7 attr) -1))
+ (when (and (floatp (nth 7 attr))
+ (<= (nth 7 attr) (tramp-compat-most-positive-fixnum)))
+ (setcar (nthcdr 7 attr) (round (nth 7 attr))))
+ ;; Convert file mode bits to string.
+ (unless (stringp (nth 8 attr))
+ (setcar (nthcdr 8 attr) (tramp-file-mode-from-int (nth 8 attr)))
+ (when (stringp (car attr))
+ (aset (nth 8 attr) 0 ?l)))
+ ;; Convert directory indication bit.
+ (when (string-match "^d" (nth 8 attr))
+ (setcar attr t))
+ ;; Convert symlink from `tramp-do-file-attributes-with-stat'.
+ (when (consp (car attr))
+ (if (and (stringp (caar attr))
+ (string-match ".+ -> .\\(.+\\)." (caar attr)))
+ (setcar attr (match-string 1 (caar attr)))
+ (setcar attr nil)))
+ ;; Set file's gid change bit.
+ (setcar (nthcdr 9 attr)
+ (if (numberp (nth 3 attr))
+ (not (= (nth 3 attr)
+ (tramp-get-remote-gid vec 'integer)))
+ (not (string-equal
+ (nth 3 attr)
+ (tramp-get-remote-gid vec 'string)))))
+ ;; Convert inode.
+ (unless (listp (nth 10 attr))
+ (setcar (nthcdr 10 attr)
+ (condition-case nil
+ (cons (floor (nth 10 attr) 65536)
+ (floor (mod (nth 10 attr) 65536)))
+ ;; Inodes can be incredible huge. We must hide this.
+ (error (tramp-get-inode vec)))))
+ ;; Set virtual device number.
+ (setcar (nthcdr 11 attr)
+ (tramp-get-device vec))
+ attr))
+
+(defun tramp-check-cached-permissions (vec access)
+ "Check `file-attributes' caches for VEC.
+Return t if according to the cache access type ACCESS is known to
+be granted."
+ (let ((result nil)
+ (offset (cond
+ ((eq ?r access) 1)
+ ((eq ?w access) 2)
+ ((eq ?x access) 3))))
+ (dolist (suffix '("string" "integer") result)
+ (setq
+ result
+ (or
+ result
+ (let ((file-attr
+ (tramp-get-file-property
+ vec (tramp-file-name-localname vec)
+ (concat "file-attributes-" suffix) nil))
+ (remote-uid
+ (tramp-get-connection-property
+ vec (concat "uid-" suffix) nil))
+ (remote-gid
+ (tramp-get-connection-property
+ vec (concat "gid-" suffix) nil)))
+ (and
+ file-attr
+ (or
+ ;; Not a symlink
+ (eq t (car file-attr))
+ (null (car file-attr)))
+ (or
+ ;; World accessible.
+ (eq access (aref (nth 8 file-attr) (+ offset 6)))
+ ;; User accessible and owned by user.
+ (and
+ (eq access (aref (nth 8 file-attr) offset))
+ (equal remote-uid (nth 2 file-attr)))
+ ;; Group accessible and owned by user's
+ ;; principal group.
+ (and
+ (eq access (aref (nth 8 file-attr) (+ offset 3)))
+ (equal remote-gid (nth 3 file-attr)))))))))))
+
+(defun tramp-file-mode-from-int (mode)
+ "Turn an integer representing a file mode into an ls(1)-like string."
+ (let ((type (cdr
+ (assoc (logand (lsh mode -12) 15) tramp-file-mode-type-map)))
+ (user (logand (lsh mode -6) 7))
+ (group (logand (lsh mode -3) 7))
+ (other (logand (lsh mode -0) 7))
+ (suid (> (logand (lsh mode -9) 4) 0))
+ (sgid (> (logand (lsh mode -9) 2) 0))
+ (sticky (> (logand (lsh mode -9) 1) 0)))
+ (setq user (tramp-file-mode-permissions user suid "s"))
+ (setq group (tramp-file-mode-permissions group sgid "s"))
+ (setq other (tramp-file-mode-permissions other sticky "t"))
+ (concat type user group other)))
+
+(defun tramp-file-mode-permissions (perm suid suid-text)
+ "Convert a permission bitset into a string.
+This is used internally by `tramp-file-mode-from-int'."
+ (let ((r (> (logand perm 4) 0))
+ (w (> (logand perm 2) 0))
+ (x (> (logand perm 1) 0)))
+ (concat (or (and r "r") "-")
+ (or (and w "w") "-")
+ (or (and suid x suid-text) ; suid, execute
+ (and suid (upcase suid-text)) ; suid, !execute
+ (and x "x") "-")))) ; !suid
+
+(defun tramp-shell-case-fold (string)
+ "Converts STRING to shell glob pattern which ignores case."
+ (mapconcat
+ (lambda (c)
+ (if (equal (downcase c) (upcase c))
+ (vector c)
+ (format "[%c%c]" (downcase c) (upcase c))))
+ string
+ ""))
+
+(defun tramp-make-copy-program-file-name (vec)
+ "Create a file name suitable to be passed to `rcp' and workalikes."
+ (let ((user (tramp-file-name-user vec))
+ (host (tramp-file-name-real-host vec))
+ (localname (tramp-shell-quote-argument
+ (tramp-file-name-localname vec))))
+ (if (not (zerop (length user)))
+ (format "%s@%s:%s" user host localname)
+ (format "%s:%s" host localname))))
+
+(defun tramp-method-out-of-band-p (vec size)
+ "Return t if this is an out-of-band method, nil otherwise."
+ (and
+ ;; It shall be an out-of-band method.
+ (tramp-get-method-parameter (tramp-file-name-method vec) 'tramp-copy-program)
+ ;; Either the file size is large enough, or (in rare cases) there
+ ;; does not exist a remote encoding.
+ (or (null tramp-copy-size-limit)
+ (> size tramp-copy-size-limit)
+ (null (tramp-get-inline-coding vec "remote-encoding" size)))))
+
+;; Variables local to connection.
+
+(defun tramp-get-remote-path (vec)
+ (with-connection-property
+ ;; When `tramp-own-remote-path' is in `tramp-remote-path', we
+ ;; cache the result for the session only. Otherwise, the result
+ ;; is cached persistently.
+ (if (memq 'tramp-own-remote-path tramp-remote-path)
+ (tramp-get-connection-process vec)
+ vec)
+ "remote-path"
+ (let* ((remote-path (copy-tree tramp-remote-path))
+ (elt1 (memq 'tramp-default-remote-path remote-path))
+ (elt2 (memq 'tramp-own-remote-path remote-path))
+ (default-remote-path
+ (when elt1
+ (condition-case nil
+ (tramp-send-command-and-read
+ vec "echo \\\"`getconf PATH`\\\"")
+ ;; Default if "getconf" is not available.
+ (error
+ (tramp-message
+ vec 3
+ "`getconf PATH' not successful, using default value \"%s\"."
+ "/bin:/usr/bin")
+ "/bin:/usr/bin"))))
+ (own-remote-path
+ (when elt2
+ (condition-case nil
+ (tramp-send-command-and-read vec "echo \\\"$PATH\\\"")
+ ;; Default if "getconf" is not available.
+ (error
+ (tramp-message
+ vec 3 "$PATH not set, ignoring `tramp-own-remote-path'.")
+ nil)))))
+
+ ;; Replace place holder `tramp-default-remote-path'.
+ (when elt1
+ (setcdr elt1
+ (append
+ (tramp-compat-split-string default-remote-path ":")
+ (cdr elt1)))
+ (setq remote-path (delq 'tramp-default-remote-path remote-path)))
+
+ ;; Replace place holder `tramp-own-remote-path'.
+ (when elt2
+ (setcdr elt2
+ (append
+ (tramp-compat-split-string own-remote-path ":")
+ (cdr elt2)))
+ (setq remote-path (delq 'tramp-own-remote-path remote-path)))
+
+ ;; Remove double entries.
+ (setq elt1 remote-path)
+ (while (consp elt1)
+ (while (and (car elt1) (setq elt2 (member (car elt1) (cdr elt1))))
+ (setcar elt2 nil))
+ (setq elt1 (cdr elt1)))
+
+ ;; Remove non-existing directories.
+ (delq
+ nil
+ (mapcar
+ (lambda (x)
+ (and
+ (stringp x)
+ (file-directory-p
+ (tramp-make-tramp-file-name
+ (tramp-file-name-method vec)
+ (tramp-file-name-user vec)
+ (tramp-file-name-host vec)
+ x))
+ x))
+ remote-path)))))
+
+(defun tramp-get-remote-tmpdir (vec)
+ (with-connection-property vec "tmp-directory"
+ (let ((dir (tramp-shell-quote-argument "/tmp")))
+ (if (and (tramp-send-command-and-check
+ vec (format "%s -d %s" (tramp-get-test-command vec) dir))
+ (tramp-send-command-and-check
+ vec (format "%s -w %s" (tramp-get-test-command vec) dir)))
+ dir
+ (tramp-error vec 'file-error "Directory %s not accessible" dir)))))
+
+(defun tramp-get-ls-command (vec)
+ (with-connection-property vec "ls"
+ (tramp-message vec 5 "Finding a suitable `ls' command")
+ (or
+ (catch 'ls-found
+ (dolist (cmd '("ls" "gnuls" "gls"))
+ (let ((dl (tramp-get-remote-path vec))
+ result)
+ (while (and dl (setq result (tramp-find-executable vec cmd dl t t)))
+ ;; Check parameters. On busybox, "ls" output coloring is
+ ;; enabled by default sometimes. So we try to disable it
+ ;; when possible. $LS_COLORING is not supported there.
+ ;; Some "ls" versions are sensible wrt the order of
+ ;; arguments, they fail when "-al" is after the
+ ;; "--color=never" argument (for example on FreeBSD).
+ (when (tramp-send-command-and-check
+ vec (format "%s -lnd /" result))
+ (when (tramp-send-command-and-check
+ vec (format
+ "%s --color=never -al /dev/null" result))
+ (setq result (concat result " --color=never")))
+ (throw 'ls-found result))
+ (setq dl (cdr dl))))))
+ (tramp-error vec 'file-error "Couldn't find a proper `ls' command"))))
+
+(defun tramp-get-ls-command-with-dired (vec)
+ (save-match-data
+ (with-connection-property vec "ls-dired"
+ (tramp-message vec 5 "Checking, whether `ls --dired' works")
+ ;; Some "ls" versions are sensible wrt the order of arguments,
+ ;; they fail when "-al" is after the "--dired" argument (for
+ ;; example on FreeBSD).
+ (tramp-send-command-and-check
+ vec (format "%s --dired -al /dev/null" (tramp-get-ls-command vec))))))
+
+(defun tramp-get-test-command (vec)
+ (with-connection-property vec "test"
+ (tramp-message vec 5 "Finding a suitable `test' command")
+ (if (tramp-send-command-and-check vec "test 0")
+ "test"
+ (tramp-find-executable vec "test" (tramp-get-remote-path vec)))))
+
+(defun tramp-get-test-nt-command (vec)
+ ;; Does `test A -nt B' work? Use abominable `find' construct if it
+ ;; doesn't. BSD/OS 4.0 wants the parentheses around the command,
+ ;; for otherwise the shell crashes.
+ (with-connection-property vec "test-nt"
+ (or
+ (progn
+ (tramp-send-command
+ vec (format "( %s / -nt / )" (tramp-get-test-command vec)))
+ (with-current-buffer (tramp-get-buffer vec)
+ (goto-char (point-min))
+ (when (looking-at (regexp-quote tramp-end-of-output))
+ (format "%s %%s -nt %%s" (tramp-get-test-command vec)))))
+ (progn
+ (tramp-send-command
+ vec
+ (format
+ "tramp_test_nt () {\n%s -n \"`find $1 -prune -newer $2 -print`\"\n}"
+ (tramp-get-test-command vec)))
+ "tramp_test_nt %s %s"))))
+
+(defun tramp-get-file-exists-command (vec)
+ (with-connection-property vec "file-exists"
+ (tramp-message vec 5 "Finding command to check if file exists")
+ (tramp-find-file-exists-command vec)))
+
+(defun tramp-get-remote-ln (vec)
+ (with-connection-property vec "ln"
+ (tramp-message vec 5 "Finding a suitable `ln' command")
+ (tramp-find-executable vec "ln" (tramp-get-remote-path vec))))
+
+(defun tramp-get-remote-perl (vec)
+ (with-connection-property vec "perl"
+ (tramp-message vec 5 "Finding a suitable `perl' command")
+ (let ((result
+ (or (tramp-find-executable vec "perl5" (tramp-get-remote-path vec))
+ (tramp-find-executable
+ vec "perl" (tramp-get-remote-path vec)))))
+ ;; We must check also for some Perl modules.
+ (when result
+ (with-connection-property vec "perl-file-spec"
+ (tramp-send-command-and-check
+ vec (format "%s -e 'use File::Spec;'" result)))
+ (with-connection-property vec "perl-cwd-realpath"
+ (tramp-send-command-and-check
+ vec (format "%s -e 'use Cwd \"realpath\";'" result))))
+ result)))
+
+(defun tramp-get-remote-stat (vec)
+ (with-connection-property vec "stat"
+ (tramp-message vec 5 "Finding a suitable `stat' command")
+ (let ((result (tramp-find-executable
+ vec "stat" (tramp-get-remote-path vec)))
+ tmp)
+ ;; Check whether stat(1) returns usable syntax. %s does not
+ ;; work on older AIX systems.
+ (when result
+ (setq tmp
+ ;; We don't want to display an error message.
+ (tramp-compat-with-temp-message (or (current-message) "")
+ (ignore-errors
+ (tramp-send-command-and-read
+ vec (format "%s -c '(\"%%N\" %%s)' /" result)))))
+ (unless (and (listp tmp) (stringp (car tmp))
+ (string-match "^./.$" (car tmp))
+ (integerp (cadr tmp)))
+ (setq result nil)))
+ result)))
+
+(defun tramp-get-remote-readlink (vec)
+ (with-connection-property vec "readlink"
+ (tramp-message vec 5 "Finding a suitable `readlink' command")
+ (let ((result (tramp-find-executable
+ vec "readlink" (tramp-get-remote-path vec))))
+ (when (and result
+ ;; We don't want to display an error message.
+ (tramp-compat-with-temp-message (or (current-message) "")
+ (ignore-errors
+ (tramp-send-command-and-check
+ vec (format "%s --canonicalize-missing /" result)))))
+ result))))
+
+(defun tramp-get-remote-trash (vec)
+ (with-connection-property vec "trash"
+ (tramp-message vec 5 "Finding a suitable `trash' command")
+ (tramp-find-executable vec "trash" (tramp-get-remote-path vec))))
+
+(defun tramp-get-remote-id (vec)
+ (with-connection-property vec "id"
+ (tramp-message vec 5 "Finding POSIX `id' command")
+ (or
+ (catch 'id-found
+ (let ((dl (tramp-get-remote-path vec))
+ result)
+ (while (and dl (setq result (tramp-find-executable vec "id" dl t t)))
+ ;; Check POSIX parameter.
+ (when (tramp-send-command-and-check vec (format "%s -u" result))
+ (throw 'id-found result))
+ (setq dl (cdr dl)))))
+ (tramp-error vec 'file-error "Couldn't find a POSIX `id' command"))))
+
+(defun tramp-get-remote-uid (vec id-format)
+ (with-connection-property vec (format "uid-%s" id-format)
+ (let ((res (tramp-send-command-and-read
+ vec
+ (format "%s -u%s %s"
+ (tramp-get-remote-id vec)
+ (if (equal id-format 'integer) "" "n")
+ (if (equal id-format 'integer)
+ "" "| sed -e s/^/\\\"/ -e s/\$/\\\"/")))))
+ ;; The command might not always return a number.
+ (if (and (equal id-format 'integer) (not (integerp res))) -1 res))))
+
+(defun tramp-get-remote-gid (vec id-format)
+ (with-connection-property vec (format "gid-%s" id-format)
+ (let ((res (tramp-send-command-and-read
+ vec
+ (format "%s -g%s %s"
+ (tramp-get-remote-id vec)
+ (if (equal id-format 'integer) "" "n")
+ (if (equal id-format 'integer)
+ "" "| sed -e s/^/\\\"/ -e s/\$/\\\"/")))))
+ ;; The command might not always return a number.
+ (if (and (equal id-format 'integer) (not (integerp res))) -1 res))))
+
+(defun tramp-get-local-uid (id-format)
+ (if (equal id-format 'integer) (user-uid) (user-login-name)))
+
+(defun tramp-get-local-gid (id-format)
+ (nth 3 (tramp-compat-file-attributes "~/" id-format)))
+
+;; Some predefined connection properties.
+(defun tramp-get-inline-compress (vec prop size)
+ "Return the compress command related to PROP.
+PROP is either `inline-compress' or `inline-decompress'. SIZE is
+the length of the file to be compressed.
+
+If no corresponding command is found, nil is returned."
+ (when (and (integerp tramp-inline-compress-start-size)
+ (> size tramp-inline-compress-start-size))
+ (with-connection-property vec prop
+ (tramp-find-inline-compress vec)
+ (tramp-get-connection-property vec prop nil))))
+
+(defun tramp-get-inline-coding (vec prop size)
+ "Return the coding command related to PROP.
+PROP is either `remote-encoding', `remode-decoding',
+`local-encoding' or `local-decoding'.
+
+SIZE is the length of the file to be coded. Depending on SIZE,
+compression might be applied.
+
+If no corresponding command is found, nil is returned.
+Otherwise, either a string is returned which contains a `%s' mark
+to be used for the respective input or output file; or a Lisp
+function cell is returned to be applied on a buffer."
+ ;; We must catch the errors, because we want to return `nil', when
+ ;; no inline coding is found.
+ (ignore-errors
+ (let ((coding
+ (with-connection-property vec prop
+ (tramp-find-inline-encoding vec)
+ (tramp-get-connection-property vec prop nil)))
+ (prop1 (if (string-match "encoding" prop)
+ "inline-compress" "inline-decompress"))
+ compress)
+ ;; The connection property might have been cached. So we must
+ ;; send the script to the remote side - maybe.
+ (when (and coding (symbolp coding) (string-match "remote" prop))
+ (let ((name (symbol-name coding)))
+ (while (string-match (regexp-quote "-") name)
+ (setq name (replace-match "_" nil t name)))
+ (tramp-maybe-send-script vec (symbol-value coding) name)
+ (setq coding name)))
+ (when coding
+ ;; Check for the `compress' command.
+ (setq compress (tramp-get-inline-compress vec prop1 size))
+ ;; Return the value.
+ (cond
+ ((and compress (symbolp coding))
+ (if (string-match "decompress" prop1)
+ `(lambda (beg end)
+ (,coding beg end)
+ (let ((coding-system-for-write 'binary)
+ (coding-system-for-read 'binary))
+ (apply
+ 'call-process-region (point-min) (point-max)
+ (car (split-string ,compress)) t t nil
+ (cdr (split-string ,compress)))))
+ `(lambda (beg end)
+ (let ((coding-system-for-write 'binary)
+ (coding-system-for-read 'binary))
+ (apply
+ 'call-process-region beg end
+ (car (split-string ,compress)) t t nil
+ (cdr (split-string ,compress))))
+ (,coding (point-min) (point-max)))))
+ ((symbolp coding)
+ coding)
+ ((and compress (string-match "decoding" prop))
+ (format "(%s | %s >%%s)" coding compress))
+ (compress
+ (format "(%s <%%s | %s)" compress coding))
+ ((string-match "decoding" prop)
+ (format "%s >%%s" coding))
+ (t
+ (format "%s <%%s" coding)))))))
+
+;;; Integration of eshell.el:
+
+(eval-when-compile
+ (defvar eshell-path-env))
+
+;; eshell.el keeps the path in `eshell-path-env'. We must change it
+;; when `default-directory' points to another host.
+(defun tramp-eshell-directory-change ()
+ "Set `eshell-path-env' to $PATH of the host related to `default-directory'."
+ (setq eshell-path-env
+ (if (file-remote-p default-directory)
+ (with-parsed-tramp-file-name default-directory nil
+ (mapconcat
+ 'identity
+ (tramp-get-remote-path v)
+ ":"))
+ (getenv "PATH"))))
+
+(eval-after-load "esh-util"
+ '(progn
+ (tramp-eshell-directory-change)
+ (add-hook 'eshell-directory-change-hook
+ 'tramp-eshell-directory-change)
+ (add-hook 'tramp-unload-hook
+ (lambda ()
+ (remove-hook 'eshell-directory-change-hook
+ 'tramp-eshell-directory-change)))))
+
+(add-hook 'tramp-unload-hook
+ (lambda ()
+ (unload-feature 'tramp-sh 'force)))
+
+(provide 'tramp-sh)
+
+;;; TODO:
+
+;; * Don't use globbing for directories with many files, as this is
+;; likely to produce long command lines, and some shells choke on
+;; long command lines.
+;; * Make it work for different encodings, and for different file name
+;; encodings, too. (Daniel Pittman)
+;; * Don't search for perl5 and perl. Instead, only search for perl and
+;; then look if it's the right version (with `perl -v').
+;; * When editing a remote CVS controlled file as a different user, VC
+;; gets confused about the file locking status. Try to find out why
+;; the workaround doesn't work.
+;; * Allow out-of-band methods as _last_ multi-hop. Open a connection
+;; until the last but one hop via `start-file-process'. Apply it
+;; also for ftp and smb.
+;; * WIBNI if we had a command "trampclient"? If I was editing in
+;; some shell with root priviledges, it would be nice if I could
+;; just call
+;; trampclient filename.c
+;; as an editor, and the _current_ shell would connect to an Emacs
+;; server and would be used in an existing non-priviledged Emacs
+;; session for doing the editing in question.
+;; That way, I need not tell Emacs my password again and be afraid
+;; that it makes it into core dumps or other ugly stuff (I had Emacs
+;; once display a just typed password in the context of a keyboard
+;; sequence prompt for a question immediately following in a shell
+;; script run within Emacs -- nasty).
+;; And if I have some ssh session running to a different computer,
+;; having the possibility of passing a local file there to a local
+;; Emacs session (in case I can arrange for a connection back) would
+;; be nice.
+;; Likely the corresponding Tramp server should not allow the
+;; equivalent of the emacsclient -eval option in order to make this
+;; reasonably unproblematic. And maybe trampclient should have some
+;; way of passing credentials, like by using an SSL socket or
+;; something. (David Kastrup)
+;; * Reconnect directly to a compliant shell without first going
+;; through the user's default shell. (Pete Forman)
+;; * How can I interrupt the remote process with a signal
+;; (interrupt-process seems not to work)? (Markus Triska)
+;; * Avoid the local shell entirely for starting remote processes. If
+;; so, I think even a signal, when delivered directly to the local
+;; SSH instance, would correctly be propagated to the remote process
+;; automatically; possibly SSH would have to be started with
+;; "-t". (Markus Triska)
+;; * It makes me wonder if tramp couldn't fall back to ssh when scp
+;; isn't on the remote host. (Mark A. Hershberger)
+;; * Use lsh instead of ssh. (Alfred M. Szmidt)
+;; * Optimize out-of-band copying, when both methods are scp-like (not
+;; rsync).
+;; * Keep a second connection open for out-of-band methods like scp or
+;; rsync.
+;; * Try telnet+curl as new method. It might be useful for busybox,
+;; without built-in uuencode/uudecode.
+
+;;; tramp-sh.el ends here
;;; tramp.el --- Transparent Remote Access, Multiple Protocol
;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
- ;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+ ;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
-;; (copyright statements below in code to be updated with the above notice)
-
;; Author: Kai Großjohann <kai.grossjohann@gmx.net>
;; Michael Albinus <michael.albinus@gmx.de>
;; Keywords: comm, processes
--- /dev/null
- ;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;;; complete.el --- partial completion mechanism plus other goodies
+
+;; Copyright (C) 1990, 1991, 1992, 1993, 1999, 2000, 2001, 2002, 2003,
++;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+
+;; Author: Dave Gillespie <daveg@synaptics.com>
+;; Keywords: abbrev convenience
+;; Obsolete-since: 24.1
+;;
+;; Special thanks to Hallvard Furuseth for his many ideas and contributions.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Extended completion for the Emacs minibuffer.
+;;
+;; The basic idea is that the command name or other completable text is
+;; divided into words and each word is completed separately, so that
+;; "M-x p-b" expands to "M-x print-buffer". If the entry is ambiguous
+;; each word is completed as much as possible and then the cursor is
+;; left at the first position where typing another letter will resolve
+;; the ambiguity.
+;;
+;; Word separators for this purpose are hyphen, space, and period.
+;; These would most likely occur in command names, Info menu items,
+;; and file names, respectively. But all word separators are treated
+;; alike at all times.
+;;
+;; This completion package replaces the old-style completer's key
+;; bindings for TAB, SPC, RET, and `?'. The old completer is still
+;; available on the Meta versions of those keys. If you set
+;; PC-meta-flag to nil, the old completion keys will be left alone
+;; and the partial completer will use the Meta versions of the keys.
+
+
+;; Usage: M-x partial-completion-mode. During completable minibuffer entry,
+;;
+;; TAB means to do a partial completion;
+;; SPC means to do a partial complete-word;
+;; RET means to do a partial complete-and-exit;
+;; ? means to do a partial completion-help.
+;;
+;; If you set PC-meta-flag to nil, then TAB, SPC, RET, and ? perform
+;; original Emacs completions, and M-TAB etc. do partial completion.
+;; To do this, put the command,
+;;
+;; (setq PC-meta-flag nil)
+;;
+;; in your .emacs file. To load partial completion automatically, put
+;;
+;; (partial-completion-mode t)
+;;
+;; in your .emacs file, too. Things will be faster if you byte-compile
+;; this file when you install it.
+;;
+;; As an extra feature, in cases where RET would not normally
+;; complete (such as `C-x b'), the M-RET key will always do a partial
+;; complete-and-exit. Thus `C-x b f.c RET' will select or create a
+;; buffer called "f.c", but `C-x b f.c M-RET' will select the existing
+;; buffer whose name matches that pattern (perhaps "filing.c").
+;; (PC-meta-flag does not affect this behavior; M-RET used to be
+;; undefined in this situation.)
+;;
+;; The regular M-TAB (lisp-complete-symbol) command also supports
+;; partial completion in this package.
+
+;; In addition, this package includes a feature for accessing include
+;; files. For example, `C-x C-f <sys/time.h> RET' reads the file
+;; /usr/include/sys/time.h. The variable PC-include-file-path is a
+;; list of directories in which to search for include files. Completion
+;; is supported in include file names.
+
+
+;;; Code:
+
+(defgroup partial-completion nil
+ "Partial Completion of items."
+ :prefix "pc-"
+ :group 'minibuffer
+ :group 'convenience)
+
+(defcustom PC-first-char 'find-file
+ "Control how the first character of a string is to be interpreted.
+If nil, the first character of a string is not taken literally if it is a word
+delimiter, so that \".e\" matches \"*.e*\".
+If t, the first character of a string is always taken literally even if it is a
+word delimiter, so that \".e\" matches \".e*\".
+If non-nil and non-t, the first character is taken literally only for file name
+completion."
+ :type '(choice (const :tag "delimiter" nil)
+ (const :tag "literal" t)
+ (other :tag "find-file" find-file))
+ :group 'partial-completion)
+
+(defcustom PC-meta-flag t
+ "If non-nil, TAB means PC completion and M-TAB means normal completion.
+Otherwise, TAB means normal completion and M-TAB means Partial Completion."
+ :type 'boolean
+ :group 'partial-completion)
+
+(defcustom PC-word-delimiters "-_. "
+ "A string of characters treated as word delimiters for completion.
+Some arcane rules:
+If `]' is in this string, it must come first.
+If `^' is in this string, it must not come first.
+If `-' is in this string, it must come first or right after `]'.
+In other words, if S is this string, then `[S]' must be a valid Emacs regular
+expression (not containing character ranges like `a-z')."
+ :type 'string
+ :group 'partial-completion)
+
+(defcustom PC-include-file-path '("/usr/include" "/usr/local/include")
+ "A list of directories in which to look for include files.
+If nil, means use the colon-separated path in the variable $INCPATH instead."
+ :type '(repeat directory)
+ :group 'partial-completion)
+
+(defcustom PC-disable-includes nil
+ "If non-nil, include-file support in \\[find-file] is disabled."
+ :type 'boolean
+ :group 'partial-completion)
+
+(defvar PC-default-bindings t
+ "If non-nil, default partial completion key bindings are suppressed.")
+
+(defvar PC-env-vars-alist nil
+ "A list of the environment variable names and values.")
+
+\f
+(defun PC-bindings (bind)
+ (let ((completion-map minibuffer-local-completion-map)
+ (must-match-map minibuffer-local-must-match-map))
+ (cond ((not bind)
+ ;; These bindings are the default bindings. It would be better to
+ ;; restore the previous bindings.
+ (define-key read-expression-map "\e\t" 'lisp-complete-symbol)
+
+ (define-key completion-map "\t" 'minibuffer-complete)
+ (define-key completion-map " " 'minibuffer-complete-word)
+ (define-key completion-map "?" 'minibuffer-completion-help)
+
+ (define-key must-match-map "\r" 'minibuffer-complete-and-exit)
+ (define-key must-match-map "\n" 'minibuffer-complete-and-exit)
+
+ (define-key global-map [remap lisp-complete-symbol] nil))
+ (PC-default-bindings
+ (define-key read-expression-map "\e\t" 'PC-lisp-complete-symbol)
+
+ (define-key completion-map "\t" 'PC-complete)
+ (define-key completion-map " " 'PC-complete-word)
+ (define-key completion-map "?" 'PC-completion-help)
+
+ (define-key completion-map "\e\t" 'PC-complete)
+ (define-key completion-map "\e " 'PC-complete-word)
+ (define-key completion-map "\e\r" 'PC-force-complete-and-exit)
+ (define-key completion-map "\e\n" 'PC-force-complete-and-exit)
+ (define-key completion-map "\e?" 'PC-completion-help)
+
+ (define-key must-match-map "\r" 'PC-complete-and-exit)
+ (define-key must-match-map "\n" 'PC-complete-and-exit)
+
+ (define-key must-match-map "\e\r" 'PC-complete-and-exit)
+ (define-key must-match-map "\e\n" 'PC-complete-and-exit)
+
+ (define-key global-map [remap lisp-complete-symbol] 'PC-lisp-complete-symbol)))))
+
+(defvar PC-do-completion-end nil
+ "Internal variable used by `PC-do-completion'.")
+
+(make-variable-buffer-local 'PC-do-completion-end)
+
+(defvar PC-goto-end nil
+ "Internal variable set in `PC-do-completion', used in
+`choose-completion-string-functions'.")
+
+(make-variable-buffer-local 'PC-goto-end)
+
+;;;###autoload
+(define-minor-mode partial-completion-mode
+ "Toggle Partial Completion mode.
+With prefix ARG, turn Partial Completion mode on if ARG is positive.
+
+When Partial Completion mode is enabled, TAB (or M-TAB if `PC-meta-flag' is
+nil) is enhanced so that if some string is divided into words and each word is
+delimited by a character in `PC-word-delimiters', partial words are completed
+as much as possible and `*' characters are treated likewise in file names.
+
+For example, M-x p-c-m expands to M-x partial-completion-mode since no other
+command begins with that sequence of characters, and
+\\[find-file] f_b.c TAB might complete to foo_bar.c if that file existed and no
+other file in that directory begins with that sequence of characters.
+
+Unless `PC-disable-includes' is non-nil, the `<...>' sequence is interpreted
+specially in \\[find-file]. For example,
+\\[find-file] <sys/time.h> RET finds the file `/usr/include/sys/time.h'.
+See also the variable `PC-include-file-path'.
+
+Partial Completion mode extends the meaning of `completion-auto-help' (which
+see), so that if it is neither nil nor t, Emacs shows the `*Completions*'
+buffer only on the second attempt to complete. That is, if TAB finds nothing
+to complete, the first TAB just says \"Next char not unique\" and the
+second TAB brings up the `*Completions*' buffer."
+ :global t :group 'partial-completion
+ ;; Deal with key bindings...
+ (PC-bindings partial-completion-mode)
+ ;; Deal with include file feature...
+ (cond ((not partial-completion-mode)
+ (remove-hook 'find-file-not-found-functions 'PC-look-for-include-file))
+ ((not PC-disable-includes)
+ (add-hook 'find-file-not-found-functions 'PC-look-for-include-file)))
+ ;; Adjust the completion selection in *Completion* buffers to the way
+ ;; we work. The default minibuffer completion code only completes the
+ ;; text before point and leaves the text after point alone (new in
+ ;; Emacs-22). In contrast we use the whole text and we even sometimes
+ ;; move point to a place before EOB, to indicate the first position where
+ ;; there's a difference, so when the user uses choose-completion, we have
+ ;; to trick choose-completion into replacing the whole minibuffer text
+ ;; rather than only the text before point. --Stef
+ (funcall
+ (if partial-completion-mode 'add-hook 'remove-hook)
+ 'choose-completion-string-functions
+ (lambda (choice buffer &rest ignored)
+ ;; When completing M-: (lisp- ) with point before the ), it is
+ ;; not appropriate to go to point-max (unlike the filename case).
+ (if (and (not PC-goto-end)
+ (minibufferp buffer))
+ (goto-char (point-max))
+ ;; Need a similar hack for the non-minibuffer-case -- gm.
+ (when PC-do-completion-end
+ (goto-char PC-do-completion-end)
+ (setq PC-do-completion-end nil)))
+ (setq PC-goto-end nil)
+ nil))
+ ;; Build the env-completion and mapping table.
+ (when (and partial-completion-mode (null PC-env-vars-alist))
+ (setq PC-env-vars-alist
+ (mapcar (lambda (string)
+ (let ((d (string-match "=" string)))
+ (cons (concat "$" (substring string 0 d))
+ (and d (substring string (1+ d))))))
+ process-environment))))
+
+\f
+(defun PC-complete ()
+ "Like minibuffer-complete, but allows \"b--di\"-style abbreviations.
+For example, \"M-x b--di\" would match `byte-recompile-directory', or any
+name which consists of three or more words, the first beginning with \"b\"
+and the third beginning with \"di\".
+
+The pattern \"b--d\" is ambiguous for `byte-recompile-directory' and
+`beginning-of-defun', so this would produce a list of completions
+just like when normal Emacs completions are ambiguous.
+
+Word-delimiters for the purposes of Partial Completion are \"-\", \"_\",
+\".\", and SPC."
+ (interactive)
+ (if (PC-was-meta-key)
+ (minibuffer-complete)
+ ;; If the previous command was not this one,
+ ;; never scroll, always retry completion.
+ (or (eq last-command this-command)
+ (setq minibuffer-scroll-window nil))
+ (let ((window minibuffer-scroll-window))
+ ;; If there's a fresh completion window with a live buffer,
+ ;; and this command is repeated, scroll that window.
+ (if (and window (window-buffer window)
+ (buffer-name (window-buffer window)))
+ (with-current-buffer (window-buffer window)
+ (if (pos-visible-in-window-p (point-max) window)
+ (set-window-start window (point-min) nil)
+ (scroll-other-window)))
+ (PC-do-completion nil)))))
+
+
+(defun PC-complete-word ()
+ "Like `minibuffer-complete-word', but allows \"b--di\"-style abbreviations.
+See `PC-complete' for details.
+This can be bound to other keys, like `-' and `.', if you wish."
+ (interactive)
+ (if (eq (PC-was-meta-key) PC-meta-flag)
+ (if (eq last-command-event ? )
+ (minibuffer-complete-word)
+ (self-insert-command 1))
+ (self-insert-command 1)
+ (if (eobp)
+ (PC-do-completion 'word))))
+
+
+(defun PC-complete-space ()
+ "Like `minibuffer-complete-word', but allows \"b--di\"-style abbreviations.
+See `PC-complete' for details.
+This is suitable for binding to other keys which should act just like SPC."
+ (interactive)
+ (if (eq (PC-was-meta-key) PC-meta-flag)
+ (minibuffer-complete-word)
+ (insert " ")
+ (if (eobp)
+ (PC-do-completion 'word))))
+
+
+(defun PC-complete-and-exit ()
+ "Like `minibuffer-complete-and-exit', but allows \"b--di\"-style abbreviations.
+See `PC-complete' for details."
+ (interactive)
+ (if (eq (PC-was-meta-key) PC-meta-flag)
+ (minibuffer-complete-and-exit)
+ (PC-do-complete-and-exit)))
+
+(defun PC-force-complete-and-exit ()
+ "Like `minibuffer-complete-and-exit', but allows \"b--di\"-style abbreviations.
+See `PC-complete' for details."
+ (interactive)
+ (let ((minibuffer-completion-confirm nil))
+ (PC-do-complete-and-exit)))
+
+(defun PC-do-complete-and-exit ()
+ (cond
+ ((= (point-max) (minibuffer-prompt-end))
+ ;; Duplicate the "bug" that Info-menu relies on...
+ (exit-minibuffer))
+ ((eq minibuffer-completion-confirm 'confirm)
+ (if (or (eq last-command this-command)
+ (test-completion (field-string)
+ minibuffer-completion-table
+ minibuffer-completion-predicate))
+ (exit-minibuffer)
+ (PC-temp-minibuffer-message " [Confirm]")))
+ ((eq minibuffer-completion-confirm 'confirm-after-completion)
+ ;; Similar to the above, but only if trying to exit immediately
+ ;; after typing TAB (this catches most minibuffer typos).
+ (if (and (memq last-command minibuffer-confirm-exit-commands)
+ (not (test-completion (field-string)
+ minibuffer-completion-table
+ minibuffer-completion-predicate)))
+ (PC-temp-minibuffer-message " [Confirm]")
+ (exit-minibuffer)))
+ (t
+ (let ((flag (PC-do-completion 'exit)))
+ (and flag
+ (if (or (eq flag 'complete)
+ (not minibuffer-completion-confirm))
+ (exit-minibuffer)
+ (PC-temp-minibuffer-message " [Confirm]")))))))
+
+
+(defun PC-completion-help ()
+ "Like `minibuffer-completion-help', but allows \"b--di\"-style abbreviations.
+See `PC-complete' for details."
+ (interactive)
+ (if (eq (PC-was-meta-key) PC-meta-flag)
+ (minibuffer-completion-help)
+ (PC-do-completion 'help)))
+
+(defun PC-was-meta-key ()
+ (or (/= (length (this-command-keys)) 1)
+ (let ((key (aref (this-command-keys) 0)))
+ (if (integerp key)
+ (>= key 128)
+ (not (null (memq 'meta (event-modifiers key))))))))
+
+
+(defvar PC-ignored-extensions 'empty-cache)
+(defvar PC-delims 'empty-cache)
+(defvar PC-ignored-regexp nil)
+(defvar PC-word-failed-flag nil)
+(defvar PC-delim-regex nil)
+(defvar PC-ndelims-regex nil)
+(defvar PC-delims-list nil)
+
+(defvar PC-completion-as-file-name-predicate
+ (lambda () minibuffer-completing-file-name)
+ "A function testing whether a minibuffer completion now will work filename-style.
+The function takes no arguments, and typically looks at the value
+of `minibuffer-completion-table' and the minibuffer contents.")
+
+;; Returns the sequence of non-delimiter characters that follow regexp in string.
+(defun PC-chunk-after (string regexp)
+ (if (not (string-match regexp string))
+ (let ((message "String %s didn't match regexp %s"))
+ (message message string regexp)
+ (error message string regexp)))
+ (let ((result (substring string (match-end 0))))
+ ;; result may contain multiple chunks
+ (if (string-match PC-delim-regex result)
+ (setq result (substring result 0 (match-beginning 0))))
+ result))
+
+(defun test-completion-ignore-case (str table pred)
+ "Like `test-completion', but ignores case when possible."
+ ;; Binding completion-ignore-case to nil ensures, for compatibility with
+ ;; standard completion, that the return value is exactly one of the
+ ;; possibilities. Do this binding only if pred is nil, out of paranoia;
+ ;; perhaps it is safe even if pred is non-nil.
+ (if pred
+ (test-completion str table pred)
+ (let ((completion-ignore-case nil))
+ (test-completion str table pred))))
+
+;; The following function is an attempt to work around two problems:
+
+;; (1) When complete.el was written, (try-completion "" '(("") (""))) used to
+;; return the value "". With a change from 2002-07-07 it returns t which caused
+;; `PC-lisp-complete-symbol' to fail with a "Wrong type argument: sequencep, t"
+;; error. `PC-try-completion' returns STRING in this case.
+
+;; (2) (try-completion "" '((""))) returned t before the above-mentioned change.
+;; Since `PC-chop-word' operates on the return value of `try-completion' this
+;; case might have provoked a similar error as in (1). `PC-try-completion'
+;; returns "" instead. I don't know whether this is a real problem though.
+
+;; Since `PC-try-completion' is not a guaranteed to fix these bugs reliably, you
+;; should try to look at the following discussions when you encounter problems:
+;; - emacs-pretest-bug ("Partial Completion" starting 2007-02-23),
+;; - emacs-devel ("[address-of-OP: Partial completion]" starting 2007-02-24),
+;; - emacs-devel ("[address-of-OP: EVAL and mouse selection in *Completions*]"
+;; starting 2007-03-05).
+(defun PC-try-completion (string alist &optional predicate)
+ "Like `try-completion' but return STRING instead of t."
+ (let ((result (try-completion string alist predicate)))
+ (if (eq result t) string result)))
+
+;; TODO document MODE magic...
+(defun PC-do-completion (&optional mode beg end goto-end)
+ "Internal function to do the work of partial completion.
+Text to be completed lies between BEG and END. Normally when
+replacing text in the minibuffer, this function replaces up to
+point-max (as is appropriate for completing a file name). If
+GOTO-END is non-nil, however, it instead replaces up to END."
+ (or beg (setq beg (minibuffer-prompt-end)))
+ (or end (setq end (point-max)))
+ (let* ((table (if (eq minibuffer-completion-table 'read-file-name-internal)
+ 'PC-read-file-name-internal
+ minibuffer-completion-table))
+ (pred minibuffer-completion-predicate)
+ (filename (funcall PC-completion-as-file-name-predicate))
+ (dirname nil) ; non-nil only if a filename is being completed
+ ;; The following used to be "(dirlength 0)" which caused the erasure of
+ ;; the entire buffer text before `point' when inserting a completion
+ ;; into a buffer.
+ dirlength
+ (str (buffer-substring beg end))
+ (incname (and filename (string-match "<\\([^\"<>]*\\)>?$" str)))
+ (ambig nil)
+ basestr origstr
+ env-on
+ regex
+ p offset
+ abbreviated
+ (poss nil)
+ helpposs
+ (case-fold-search completion-ignore-case))
+
+ ;; Check if buffer contents can already be considered complete
+ (if (and (eq mode 'exit)
+ (test-completion str table pred))
+ 'complete
+
+ ;; Do substitutions in directory names
+ (and filename
+ (setq basestr (or (file-name-directory str) ""))
+ (setq dirlength (length basestr))
+ ;; Do substitutions in directory names
+ (setq p (substitute-in-file-name basestr))
+ (not (string-equal basestr p))
+ (setq str (concat p (file-name-nondirectory str)))
+ (progn
+ (delete-region beg end)
+ (insert str)
+ (setq end (+ beg (length str)))))
+
+ ;; Prepare various delimiter strings
+ (or (equal PC-word-delimiters PC-delims)
+ (setq PC-delims PC-word-delimiters
+ PC-delim-regex (concat "[" PC-delims "]")
+ PC-ndelims-regex (concat "[^" PC-delims "]*")
+ PC-delims-list (append PC-delims nil)))
+
+ ;; Add wildcards if necessary
+ (and filename
+ (let ((dir (file-name-directory str))
+ (file (file-name-nondirectory str))
+ ;; The base dir for file-completion was passed in `predicate'.
+ (default-directory (if (stringp pred) (expand-file-name pred)
+ default-directory)))
+ (while (and (stringp dir) (not (file-directory-p dir)))
+ (setq dir (directory-file-name dir))
+ (setq file (concat (replace-regexp-in-string
+ PC-delim-regex "*\\&"
+ (file-name-nondirectory dir))
+ "*/" file))
+ (setq dir (file-name-directory dir)))
+ (setq origstr str str (concat dir file))))
+
+ ;; Look for wildcard expansions in directory name
+ (and filename
+ (string-match "\\*.*/" str)
+ (let ((pat str)
+ ;; The base dir for file-completion was passed in `predicate'.
+ (default-directory (if (stringp pred) (expand-file-name pred)
+ default-directory))
+ files)
+ (setq p (1+ (string-match "/[^/]*\\'" pat)))
+ (while (setq p (string-match PC-delim-regex pat p))
+ (setq pat (concat (substring pat 0 p)
+ "*"
+ (substring pat p))
+ p (+ p 2)))
+ (setq files (file-expand-wildcards (concat pat "*")))
+ (if files
+ (let ((dir (file-name-directory (car files)))
+ (p files))
+ (while (and (setq p (cdr p))
+ (equal dir (file-name-directory (car p)))))
+ (if p
+ (setq filename nil table nil
+ pred (if (stringp pred) nil pred)
+ ambig t)
+ (delete-region beg end)
+ (setq str (concat dir (file-name-nondirectory str)))
+ (insert str)
+ (setq end (+ beg (length str)))))
+ (if origstr
+ ;; If the wildcards were introduced by us, it's
+ ;; possible that PC-read-file-name-internal can
+ ;; still find matches for the original string
+ ;; even if we couldn't, so remove the added
+ ;; wildcards.
+ (setq str origstr)
+ (setq filename nil table nil
+ pred (if (stringp pred) nil pred))))))
+
+ ;; Strip directory name if appropriate
+ (if filename
+ (if incname
+ (setq basestr (substring str incname)
+ dirname (substring str 0 incname))
+ (setq basestr (file-name-nondirectory str)
+ dirname (file-name-directory str))
+ ;; Make sure str is consistent with its directory and basename
+ ;; parts. This is important on DOZe'NT systems when str only
+ ;; includes a drive letter, like in "d:".
+ (setq str (concat dirname basestr)))
+ (setq basestr str))
+
+ ;; Convert search pattern to a standard regular expression
+ (setq regex (regexp-quote basestr)
+ offset (if (and (> (length regex) 0)
+ (not (eq (aref basestr 0) ?\*))
+ (or (eq PC-first-char t)
+ (and PC-first-char filename))) 1 0)
+ p offset)
+ (while (setq p (string-match PC-delim-regex regex p))
+ (if (eq (aref regex p) ? )
+ (setq regex (concat (substring regex 0 p)
+ PC-ndelims-regex
+ PC-delim-regex
+ (substring regex (1+ p)))
+ p (+ p (length PC-ndelims-regex) (length PC-delim-regex)))
+ (let ((bump (if (memq (aref regex p)
+ '(?$ ?^ ?\. ?* ?+ ?? ?[ ?] ?\\))
+ -1 0)))
+ (setq regex (concat (substring regex 0 (+ p bump))
+ PC-ndelims-regex
+ (substring regex (+ p bump)))
+ p (+ p (length PC-ndelims-regex) 1)))))
+ (setq p 0)
+ (if filename
+ (while (setq p (string-match "\\\\\\*" regex p))
+ (setq regex (concat (substring regex 0 p)
+ "[^/]*"
+ (substring regex (+ p 2))))))
+ ;;(setq the-regex regex)
+ (setq regex (concat "\\`" regex))
+
+ (and (> (length basestr) 0)
+ (= (aref basestr 0) ?$)
+ (setq env-on t
+ table PC-env-vars-alist
+ pred nil))
+
+ ;; Find an initial list of possible completions
+ (unless (setq p (string-match (concat PC-delim-regex
+ (if filename "\\|\\*" ""))
+ str
+ (+ (length dirname) offset)))
+
+ ;; Minibuffer contains no hyphens -- simple case!
+ (setq poss (all-completions (if env-on basestr str)
+ table
+ pred))
+ (unless (or poss (string-equal str ""))
+ ;; Try completion as an abbreviation, e.g. "mvb" ->
+ ;; "m-v-b" -> "multiple-value-bind", but only for
+ ;; non-empty strings.
+ (setq origstr str
+ abbreviated t)
+ (if filename
+ (cond
+ ;; "alpha" or "/alpha" -> expand whole path.
+ ((string-match "^/?\\([A-Za-z0-9]+\\)$" str)
+ (setq
+ basestr ""
+ p nil
+ poss (file-expand-wildcards
+ (concat "/"
+ (mapconcat #'list (match-string 1 str) "*/")
+ "*"))
+ beg (1- beg)))
+ ;; Alphanumeric trailer -> expand trailing file
+ ((string-match "^\\(.+/\\)\\([A-Za-z0-9]+\\)$" str)
+ (setq regex (concat "\\`"
+ (mapconcat #'list
+ (match-string 2 str)
+ "[A-Za-z0-9]*[^A-Za-z0-9]"))
+ p (1+ (length (match-string 1 str))))))
+ (setq regex (concat "\\`" (mapconcat (lambda (c)
+ (regexp-quote (string c)))
+ str "[^-]*-"))
+ p 1))))
+ (when p
+ ;; Use all-completions to do an initial cull. This is a big win,
+ ;; since all-completions is written in C!
+ (let ((compl (all-completions (if env-on
+ (file-name-nondirectory (substring str 0 p))
+ (substring str 0 p))
+ table
+ pred)))
+ (setq p compl)
+ (when (and compl abbreviated)
+ (if filename
+ (progn
+ (setq p nil)
+ (dolist (x compl)
+ (when (string-match regex x)
+ (push x p)))
+ (setq basestr (try-completion "" p)))
+ (setq basestr (mapconcat 'list str "-"))
+ (delete-region beg end)
+ (setq end (+ beg (length basestr)))
+ (insert basestr))))
+ (while p
+ (and (string-match regex (car p))
+ (progn
+ (set-text-properties 0 (length (car p)) '() (car p))
+ (setq poss (cons (car p) poss))))
+ (setq p (cdr p))))
+
+ ;; If table had duplicates, they can be here.
+ (delete-dups poss)
+
+ ;; Handle completion-ignored-extensions
+ (and filename
+ (not (eq mode 'help))
+ (let ((p2 poss))
+
+ ;; Build a regular expression representing the extensions list
+ (or (equal completion-ignored-extensions PC-ignored-extensions)
+ (setq PC-ignored-regexp
+ (concat "\\("
+ (mapconcat
+ 'regexp-quote
+ (setq PC-ignored-extensions
+ completion-ignored-extensions)
+ "\\|")
+ "\\)\\'")))
+
+ ;; Check if there are any without an ignored extension.
+ ;; Also ignore `.' and `..'.
+ (setq p nil)
+ (while p2
+ (or (string-match PC-ignored-regexp (car p2))
+ (string-match "\\(\\`\\|/\\)[.][.]?/?\\'" (car p2))
+ (setq p (cons (car p2) p)))
+ (setq p2 (cdr p2)))
+
+ ;; If there are "good" names, use them
+ (and p (setq poss p))))
+
+ ;; Now we have a list of possible completions
+
+ (cond
+
+ ;; No valid completions found
+ ((null poss)
+ (if (and (eq mode 'word)
+ (not PC-word-failed-flag))
+ (let ((PC-word-failed-flag t))
+ (delete-char -1)
+ (PC-do-completion 'word))
+ (when abbreviated
+ (delete-region beg end)
+ (insert origstr))
+ (beep)
+ (PC-temp-minibuffer-message (if ambig
+ " [Ambiguous dir name]"
+ (if (eq mode 'help)
+ " [No completions]"
+ " [No match]")))
+ nil))
+
+ ;; More than one valid completion found
+ ((or (cdr (setq helpposs poss))
+ (memq mode '(help word)))
+
+ ;; Is the actual string one of the possible completions?
+ (setq p (and (not (eq mode 'help)) poss))
+ (while (and p
+ (not (string-equal (car p) basestr)))
+ (setq p (cdr p)))
+ (and p (null mode)
+ (PC-temp-minibuffer-message " [Complete, but not unique]"))
+ (if (and p
+ (not (and (null mode)
+ (eq this-command last-command))))
+ t
+
+ ;; If ambiguous, try for a partial completion
+ (let ((improved nil)
+ prefix
+ (pt nil)
+ (skip "\\`"))
+
+ ;; Check if next few letters are the same in all cases
+ (if (and (not (eq mode 'help))
+ (setq prefix (PC-try-completion
+ (PC-chunk-after basestr skip) poss)))
+ (let ((first t) i)
+ (if (eq mode 'word)
+ (setq prefix (PC-chop-word prefix basestr)))
+ (goto-char (+ beg (length dirname)))
+ (while (and (progn
+ (setq i 0) ; index into prefix string
+ (while (< i (length prefix))
+ (if (and (< (point) end)
+ (or (eq (downcase (aref prefix i))
+ (downcase (following-char)))
+ (and (looking-at " ")
+ (memq (aref prefix i)
+ PC-delims-list))))
+ ;; replace " " by the actual delimiter
+ ;; or input char by prefix char
+ (progn
+ (delete-char 1)
+ (insert (substring prefix i (1+ i))))
+ ;; insert a new character
+ (progn
+ (and filename (looking-at "\\*")
+ (progn
+ (delete-char 1)
+ (setq end (1- end))))
+ (setq improved t)
+ (insert (substring prefix i (1+ i)))
+ (setq end (1+ end))))
+ (setq i (1+ i)))
+ (or pt (setq pt (point)))
+ (looking-at PC-delim-regex))
+ (setq skip (concat skip
+ (regexp-quote prefix)
+ PC-ndelims-regex)
+ prefix (PC-try-completion
+ (PC-chunk-after
+ ;; not basestr, because that does
+ ;; not reflect insertions
+ (buffer-substring
+ (+ beg (length dirname)) end)
+ skip)
+ (mapcar
+ (lambda (x)
+ (when (string-match skip x)
+ (substring x (match-end 0))))
+ poss)))
+ (or (> i 0) (> (length prefix) 0))
+ (or (not (eq mode 'word))
+ (and first (> (length prefix) 0)
+ (setq first nil
+ prefix (substring prefix 0 1))))))
+ (goto-char (if (eq mode 'word) end
+ (or pt beg)))))
+
+ (if (and (eq mode 'word)
+ (not PC-word-failed-flag))
+
+ (if improved
+
+ ;; We changed it... would it be complete without the space?
+ (if (test-completion (buffer-substring
+ (field-beginning) (1- end))
+ table pred)
+ (delete-region (1- end) end)))
+
+ (if improved
+
+ ;; We changed it... enough to be complete?
+ (and (eq mode 'exit)
+ (test-completion-ignore-case (field-string) table pred))
+
+ ;; If totally ambiguous, display a list of completions
+ (if (or (eq completion-auto-help t)
+ (and completion-auto-help
+ (eq last-command this-command))
+ (eq mode 'help))
+ (let ((prompt-end (minibuffer-prompt-end)))
+ (with-output-to-temp-buffer "*Completions*"
+ (display-completion-list (sort helpposs 'string-lessp))
+ (setq PC-do-completion-end end
+ PC-goto-end goto-end)
+ (with-current-buffer standard-output
+ ;; Record which part of the buffer we are completing
+ ;; so that choosing a completion from the list
+ ;; knows how much old text to replace.
+ ;; This was briefly nil in the non-dirname case.
+ ;; However, if one calls PC-lisp-complete-symbol
+ ;; on "(ne-f" with point on the hyphen, PC offers
+ ;; all completions starting with "(ne", some of
+ ;; which do not match the "-f" part (maybe it
+ ;; should not, but it does). In such cases,
+ ;; completion gets confused trying to figure out
+ ;; how much to replace, so we tell it explicitly
+ ;; (ie, the number of chars in the buffer before beg).
+ ;;
+ ;; Note that choose-completion-string-functions
+ ;; plays around with point.
+ (setq completion-base-size (if dirname
+ dirlength
+ (- beg prompt-end))))))
+ (PC-temp-minibuffer-message " [Next char not unique]"))
+ ;; Expansion of filenames is not reversible,
+ ;; so just keep the prefix.
+ (when (and abbreviated filename)
+ (delete-region (point) end))
+ nil)))))
+
+ ;; Only one possible completion
+ (t
+ (if (and (equal basestr (car poss))
+ (not (and env-on filename))
+ (not abbreviated))
+ (if (null mode)
+ (PC-temp-minibuffer-message " [Sole completion]"))
+ (delete-region beg end)
+ (insert (format "%s"
+ (if filename
+ (substitute-in-file-name (concat dirname (car poss)))
+ (car poss)))))
+ t)))))
+
+(defun PC-chop-word (new old)
+ (let ((i -1)
+ (j -1))
+ (while (and (setq i (string-match PC-delim-regex old (1+ i)))
+ (setq j (string-match PC-delim-regex new (1+ j)))))
+ (if (and j
+ (or (not PC-word-failed-flag)
+ (setq j (string-match PC-delim-regex new (1+ j)))))
+ (substring new 0 (1+ j))
+ new)))
+
+(defvar PC-not-minibuffer nil)
+
+(defun PC-temp-minibuffer-message (message)
+ "A Lisp version of `temp_minibuffer_message' from minibuf.c."
+ (cond (PC-not-minibuffer
+ (message "%s" message)
+ (sit-for 2)
+ (message ""))
+ ((fboundp 'temp-minibuffer-message)
+ (temp-minibuffer-message message))
+ (t
+ (let ((point-max (point-max)))
+ (save-excursion
+ (goto-char point-max)
+ (insert message))
+ (let ((inhibit-quit t))
+ (sit-for 2)
+ (delete-region point-max (point-max))
+ (when quit-flag
+ (setq quit-flag nil
+ unread-command-events '(7))))))))
+
+;; Does not need to be buffer-local (?) because only used when one
+;; PC-l-c-s immediately follows another.
+(defvar PC-lisp-complete-end nil
+ "Internal variable used by `PC-lisp-complete-symbol'.")
+
+(defun PC-lisp-complete-symbol ()
+ "Perform completion on Lisp symbol preceding point.
+That symbol is compared against the symbols that exist
+and any additional characters determined by what is there
+are inserted.
+If the symbol starts just after an open-parenthesis,
+only symbols with function definitions are considered.
+Otherwise, all symbols with function definitions, values
+or properties are considered."
+ (interactive)
+ (let* ((end
+ (save-excursion
+ (with-syntax-table lisp-mode-syntax-table
+ (skip-syntax-forward "_w")
+ (point))))
+ (beg (save-excursion
+ (with-syntax-table lisp-mode-syntax-table
+ (backward-sexp 1)
+ (while (= (char-syntax (following-char)) ?\')
+ (forward-char 1))
+ (point))))
+ (minibuffer-completion-table obarray)
+ (minibuffer-completion-predicate
+ (if (eq (char-after (1- beg)) ?\()
+ 'fboundp
+ (function (lambda (sym)
+ (or (boundp sym) (fboundp sym)
+ (symbol-plist sym))))))
+ (PC-not-minibuffer t))
+ ;; http://lists.gnu.org/archive/html/emacs-devel/2007-03/msg01211.html
+ ;;
+ ;; This deals with cases like running PC-l-c-s on "M-: (n-f".
+ ;; The first call to PC-l-c-s expands this to "(ne-f", and moves
+ ;; point to the hyphen [1]. If one calls PC-l-c-s immediately after,
+ ;; then without the last-command check, one is offered all
+ ;; completions of "(ne", which is presumably not what one wants.
+ ;;
+ ;; This is arguably (at least, it seems to be the existing intended
+ ;; behavior) what one _does_ want if point has been explicitly
+ ;; positioned on the hyphen. Note that if PC-do-completion (qv) binds
+ ;; completion-base-size to nil, then completion does not replace the
+ ;; correct amount of text in such cases.
+ ;;
+ ;; Neither of these problems occur when using PC for filenames in the
+ ;; minibuffer, because in that case PC-do-completion is called without
+ ;; an explicit value for END, and so uses (point-max). This is fine for
+ ;; a filename, because the end of the filename must be at the end of
+ ;; the minibuffer. The same is not true for lisp symbols.
+ ;;
+ ;; [1] An alternate fix would be to not move point to the hyphen
+ ;; in such cases, but that would make the behavior different from
+ ;; that for filenames. It seems PC moves point to the site of the
+ ;; first difference between the possible completions.
+ ;;
+ ;; Alternatively alternatively, maybe end should be computed in
+ ;; the same way as beg. That would change the behavior though.
+ (if (equal last-command 'PC-lisp-complete-symbol)
+ (PC-do-completion nil beg PC-lisp-complete-end t)
+ (if PC-lisp-complete-end
+ (move-marker PC-lisp-complete-end end)
+ (setq PC-lisp-complete-end (copy-marker end t)))
+ (PC-do-completion nil beg end t))))
+
+(defun PC-complete-as-file-name ()
+ "Perform completion on file names preceding point.
+ Environment vars are converted to their values."
+ (interactive)
+ (let* ((end (point))
+ (beg (if (re-search-backward "[^\\][ \t\n\"\`\'][^ \t\n\"\`\']"
+ (point-min) t)
+ (+ (point) 2)
+ (point-min)))
+ (minibuffer-completion-table 'PC-read-file-name-internal)
+ (minibuffer-completion-predicate nil)
+ (PC-not-minibuffer t))
+ (goto-char end)
+ (PC-do-completion nil beg end)))
+
+;; Facilities for loading C header files. This is independent from the
+;; main completion code. See also the variable `PC-include-file-path'
+;; at top of this file.
+
+(defun PC-look-for-include-file ()
+ (if (string-match "[\"<]\\([^\"<>]*\\)[\">]?$" (buffer-file-name))
+ (let ((name (substring (buffer-file-name)
+ (match-beginning 1) (match-end 1)))
+ (punc (aref (buffer-file-name) (match-beginning 0)))
+ (path nil)
+ new-buf)
+ (kill-buffer (current-buffer))
+ (if (equal name "")
+ (with-current-buffer (car (buffer-list))
+ (save-excursion
+ (beginning-of-line)
+ (if (looking-at
+ "[ \t]*#[ \t]*include[ \t]+[<\"]\\(.+\\)[>\"][ \t]*[\n/]")
+ (setq name (buffer-substring (match-beginning 1)
+ (match-end 1))
+ punc (char-after (1- (match-beginning 1))))
+ ;; Suggested by Frank Siebenlist:
+ (if (or (looking-at
+ "[ \t]*([ \t]*load[ \t]+\"\\([^\"]+\\)\"")
+ (looking-at
+ "[ \t]*([ \t]*load-library[ \t]+\"\\([^\"]+\\)\"")
+ (looking-at
+ "[ \t]*([ \t]*require[ \t]+'\\([^\t )]+\\)[\t )]"))
+ (progn
+ (setq name (buffer-substring (match-beginning 1)
+ (match-end 1))
+ punc ?\<
+ path load-path)
+ (if (string-match "\\.elc$" name)
+ (setq name (substring name 0 -1))
+ (or (string-match "\\.el$" name)
+ (setq name (concat name ".el")))))
+ (error "Not on an #include line"))))))
+ (or (string-match "\\.[[:alnum:]]+$" name)
+ (setq name (concat name ".h")))
+ (if (eq punc ?\<)
+ (let ((path (or path (PC-include-file-path))))
+ (while (and path
+ (not (file-exists-p
+ (concat (file-name-as-directory (car path))
+ name))))
+ (setq path (cdr path)))
+ (if path
+ (setq name (concat (file-name-as-directory (car path)) name))
+ (error "No such include file: <%s>" name)))
+ (let ((dir (with-current-buffer (car (buffer-list))
+ default-directory)))
+ (if (file-exists-p (concat dir name))
+ (setq name (concat dir name))
+ (error "No such include file: `%s'" name))))
+ (setq new-buf (get-file-buffer name))
+ (if new-buf
+ ;; no need to verify last-modified time for this!
+ (set-buffer new-buf)
+ (set-buffer (create-file-buffer name))
+ (erase-buffer)
+ (insert-file-contents name t))
+ ;; Returning non-nil with the new buffer current
+ ;; is sufficient to tell find-file to use it.
+ t)
+ nil))
+
+(defun PC-include-file-path ()
+ (or PC-include-file-path
+ (let ((env (getenv "INCPATH"))
+ (path nil)
+ pos)
+ (or env (error "No include file path specified"))
+ (while (setq pos (string-match ":[^:]+$" env))
+ (setq path (cons (substring env (1+ pos)) path)
+ env (substring env 0 pos)))
+ path)))
+
+;; This is adapted from lib-complete.el, by Mike Williams.
+(defun PC-include-file-all-completions (file search-path &optional full)
+ "Return all completions for FILE in any directory on SEARCH-PATH.
+If optional third argument FULL is non-nil, returned pathnames should be
+absolute rather than relative to some directory on the SEARCH-PATH."
+ (setq search-path
+ (mapcar (lambda (dir)
+ (if dir (file-name-as-directory dir) default-directory))
+ search-path))
+ (if (file-name-absolute-p file)
+ ;; It's an absolute file name, so don't need search-path
+ (progn
+ (setq file (expand-file-name file))
+ (file-name-all-completions
+ (file-name-nondirectory file) (file-name-directory file)))
+ (let ((subdir (file-name-directory file))
+ (ndfile (file-name-nondirectory file))
+ file-lists)
+ ;; Append subdirectory part to each element of search-path
+ (if subdir
+ (setq search-path
+ (mapcar (lambda (dir) (concat dir subdir))
+ search-path)
+ file ))
+ ;; Make list of completions in each directory on search-path
+ (while search-path
+ (let* ((dir (car search-path))
+ (subdir (if full dir subdir)))
+ (if (file-directory-p dir)
+ (progn
+ (setq file-lists
+ (cons
+ (mapcar (lambda (file) (concat subdir file))
+ (file-name-all-completions ndfile
+ (car search-path)))
+ file-lists))))
+ (setq search-path (cdr search-path))))
+ ;; Compress out duplicates while building complete list (slloooow!)
+ (let ((sorted (sort (apply 'nconc file-lists)
+ (lambda (x y) (not (string-lessp x y)))))
+ compressed)
+ (while sorted
+ (if (equal (car sorted) (car compressed)) nil
+ (setq compressed (cons (car sorted) compressed)))
+ (setq sorted (cdr sorted)))
+ compressed))))
+
+(defun PC-read-file-name-internal (string pred action)
+ "Extend `read-file-name-internal' to handle include files.
+This is only used by "
+ (if (string-match "<\\([^\"<>]*\\)>?\\'" string)
+ (let* ((name (match-string 1 string))
+ (str2 (substring string (match-beginning 0)))
+ (completion-table
+ (mapcar (lambda (x)
+ (format (if (string-match "/\\'" x) "<%s" "<%s>") x))
+ (PC-include-file-all-completions
+ name (PC-include-file-path)))))
+ (cond
+ ((not completion-table) nil)
+ ((eq action 'lambda) (test-completion str2 completion-table nil))
+ ((eq action nil) (PC-try-completion str2 completion-table nil))
+ ((eq action t) (all-completions str2 completion-table nil))))
+ (read-file-name-internal string pred action)))
+\f
+
+(provide 'complete)
+
+;; arch-tag: fc7e2768-ff44-4e22-b579-4d825b968458
+;;; complete.el ends here
--- /dev/null
- ;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;;; pgg-def.el --- functions/macros for defining PGG functions
+
+;; Copyright (C) 1999, 2002, 2003, 2004, 2005,
++;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+
+;; Author: Daiki Ueno <ueno@unixuser.org>
+;; Created: 1999/11/02
+;; Keywords: PGP, OpenPGP, GnuPG
+;; Package: pgg
+;; Obsolete-since: 24.1
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(defgroup pgg ()
+ "Glue for the various PGP implementations."
+ :group 'mime
+ :version "22.1")
+
+(defcustom pgg-default-scheme 'gpg
+ "Default PGP scheme."
+ :group 'pgg
+ :type '(choice (const :tag "GnuPG" gpg)
+ (const :tag "PGP 5" pgp5)
+ (const :tag "PGP" pgp)))
+
+(defcustom pgg-default-user-id (user-login-name)
+ "User ID of your default identity."
+ :group 'pgg
+ :type 'string)
+
+(defcustom pgg-default-keyserver-address "subkeys.pgp.net"
+ "Host name of keyserver."
+ :group 'pgg
+ :type 'string)
+
+(defcustom pgg-query-keyserver nil
+ "Whether PGG queries keyservers for missing keys when verifying messages."
+ :version "22.1"
+ :group 'pgg
+ :type 'boolean)
+
+(defcustom pgg-encrypt-for-me t
+ "If t, encrypt all outgoing messages with user's public key."
+ :group 'pgg
+ :type 'boolean)
+
+(defcustom pgg-cache-passphrase t
+ "If t, cache passphrase."
+ :group 'pgg
+ :type 'boolean)
+
+(defcustom pgg-passphrase-cache-expiry 16
+ "How many seconds the passphrase is cached.
+Whether the passphrase is cached at all is controlled by
+`pgg-cache-passphrase'."
+ :group 'pgg
+ :type 'integer)
+
+(defcustom pgg-passphrase-coding-system nil
+ "Coding system to encode passphrase."
+ :group 'pgg
+ :type 'coding-system)
+
+(defvar pgg-messages-coding-system nil
+ "Coding system used when reading from a PGP external process.")
+
+(defvar pgg-status-buffer " *PGG status*")
+(defvar pgg-errors-buffer " *PGG errors*")
+(defvar pgg-output-buffer " *PGG output*")
+
+(defvar pgg-echo-buffer "*PGG-echo*")
+
+(defvar pgg-scheme nil
+ "Current scheme of PGP implementation.")
+
+(defvar pgg-text-mode nil
+ "If t, inform the recipient that the input is text.")
+
+(defmacro pgg-truncate-key-identifier (key)
+ `(if (> (length ,key) 8) (substring ,key -8) ,key))
+
+(provide 'pgg-def)
+
+;;; pgg-def.el ends here
--- /dev/null
- ;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;;; pgg-gpg.el --- GnuPG support for PGG.
+
+;; Copyright (C) 1999, 2000, 2002, 2003, 2004,
++;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+
+;; Author: Daiki Ueno <ueno@unixuser.org>
+;; Symmetric encryption and gpg-agent support added by:
+;; Sascha Wilde <wilde@sha-bang.de>
+;; Created: 1999/10/28
+;; Keywords: PGP, OpenPGP, GnuPG
+;; Package: pgg
+;; Obsolete-since: 24.1
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(eval-when-compile
+ (require 'cl) ; for gpg macros
+ (require 'pgg))
+
+(defgroup pgg-gpg ()
+ "GnuPG interface."
+ :group 'pgg)
+
+(defcustom pgg-gpg-program "gpg"
+ "The GnuPG executable."
+ :group 'pgg-gpg
+ :type 'string)
+
+(defcustom pgg-gpg-extra-args nil
+ "Extra arguments for every GnuPG invocation."
+ :group 'pgg-gpg
+ :type '(repeat (string :tag "Argument")))
+
+(defcustom pgg-gpg-recipient-argument "--recipient"
+ "GnuPG option to specify recipient."
+ :group 'pgg-gpg
+ :type '(choice (const :tag "New `--recipient' option" "--recipient")
+ (const :tag "Old `--remote-user' option" "--remote-user")))
+
+(defcustom pgg-gpg-use-agent t
+ "Whether to use gnupg agent for key caching."
+ :group 'pgg-gpg
+ :type 'boolean)
+
+(defvar pgg-gpg-user-id nil
+ "GnuPG ID of your default identity.")
+
+(defun pgg-gpg-process-region (start end passphrase program args)
+ (let* ((use-agent (and (null passphrase) (pgg-gpg-use-agent-p)))
+ (output-file-name (pgg-make-temp-file "pgg-output"))
+ (args
+ `("--status-fd" "2"
+ ,@(if use-agent '("--use-agent")
+ (if passphrase '("--passphrase-fd" "0")))
+ "--yes" ; overwrite
+ "--output" ,output-file-name
+ ,@pgg-gpg-extra-args ,@args))
+ (output-buffer pgg-output-buffer)
+ (errors-buffer pgg-errors-buffer)
+ (orig-mode (default-file-modes))
+ (process-connection-type nil)
+ (inhibit-redisplay t)
+ process status exit-status
+ passphrase-with-newline
+ encoded-passphrase-with-new-line)
+ (with-current-buffer (get-buffer-create errors-buffer)
+ (buffer-disable-undo)
+ (erase-buffer))
+ (unwind-protect
+ (progn
+ (set-default-file-modes 448)
+ (let ((coding-system-for-write 'binary))
+ (setq process
+ (apply #'start-process "*GnuPG*" errors-buffer
+ program args)))
+ (set-process-sentinel process #'ignore)
+ (when passphrase
+ (setq passphrase-with-newline (concat passphrase "\n"))
+ (if pgg-passphrase-coding-system
+ (progn
+ (setq encoded-passphrase-with-new-line
+ (encode-coding-string
+ passphrase-with-newline
+ (coding-system-change-eol-conversion
+ pgg-passphrase-coding-system 'unix)))
+ (pgg-clear-string passphrase-with-newline))
+ (setq encoded-passphrase-with-new-line passphrase-with-newline
+ passphrase-with-newline nil))
+ (process-send-string process encoded-passphrase-with-new-line))
+ (process-send-region process start end)
+ (process-send-eof process)
+ (while (eq 'run (process-status process))
+ (accept-process-output process 5))
+ ;; Accept any remaining pending output coming after the
+ ;; status change.
+ (accept-process-output process 5)
+ (setq status (process-status process)
+ exit-status (process-exit-status process))
+ (delete-process process)
+ (with-current-buffer (get-buffer-create output-buffer)
+ (buffer-disable-undo)
+ (erase-buffer)
+ (if (file-exists-p output-file-name)
+ (let ((coding-system-for-read (if pgg-text-mode
+ 'raw-text
+ 'binary)))
+ (insert-file-contents output-file-name)))
+ (set-buffer errors-buffer)
+ (if (memq status '(stop signal))
+ (error "%s exited abnormally: '%s'" program exit-status))
+ (if (= 127 exit-status)
+ (error "%s could not be found" program))))
+ (if passphrase-with-newline
+ (pgg-clear-string passphrase-with-newline))
+ (if encoded-passphrase-with-new-line
+ (pgg-clear-string encoded-passphrase-with-new-line))
+ (if (and process (eq 'run (process-status process)))
+ (interrupt-process process))
+ (if (file-exists-p output-file-name)
+ (delete-file output-file-name))
+ (set-default-file-modes orig-mode))))
+
+(defun pgg-gpg-possibly-cache-passphrase (passphrase &optional key notruncate)
+ (if (and passphrase
+ pgg-cache-passphrase
+ (progn
+ (goto-char (point-min))
+ (re-search-forward "^\\[GNUPG:] \\(GOOD_PASSPHRASE\\>\\)\\|\\(SIG_CREATED\\)" nil t)))
+ (pgg-add-passphrase-to-cache
+ (or key
+ (progn
+ (goto-char (point-min))
+ (if (re-search-forward
+ "^\\[GNUPG:] NEED_PASSPHRASE\\(_PIN\\)? \\w+ ?\\w*" nil t)
+ (substring (match-string 0) -8))))
+ passphrase
+ notruncate)))
+
+(defvar pgg-gpg-all-secret-keys 'unknown)
+
+(defun pgg-gpg-lookup-all-secret-keys ()
+ "Return all secret keys present in secret key ring."
+ (when (eq pgg-gpg-all-secret-keys 'unknown)
+ (setq pgg-gpg-all-secret-keys '())
+ (let ((args (list "--with-colons" "--no-greeting" "--batch"
+ "--list-secret-keys")))
+ (with-temp-buffer
+ (apply #'call-process pgg-gpg-program nil t nil args)
+ (goto-char (point-min))
+ (while (re-search-forward
+ "^\\(sec\\|pub\\):[^:]*:[^:]*:[^:]*:\\([^:]*\\)" nil t)
+ (push (substring (match-string 2) 8)
+ pgg-gpg-all-secret-keys)))))
+ pgg-gpg-all-secret-keys)
+
+(defun pgg-gpg-lookup-key (string &optional type)
+ "Search keys associated with STRING."
+ (let ((args (list "--with-colons" "--no-greeting" "--batch"
+ (if type "--list-secret-keys" "--list-keys")
+ string)))
+ (with-temp-buffer
+ (apply #'call-process pgg-gpg-program nil t nil args)
+ (goto-char (point-min))
+ (if (re-search-forward "^\\(sec\\|pub\\):[^:]*:[^:]*:[^:]*:\\([^:]*\\)"
+ nil t)
+ (substring (match-string 2) 8)))))
+
+(defun pgg-gpg-lookup-key-owner (string &optional all)
+ "Search keys associated with STRING and return owner of identified key.
+
+The value may be just the bare key id, or it may be a combination of the
+user name associated with the key and the key id, with the key id enclosed
+in \"<...>\" angle brackets.
+
+Optional ALL non-nil means search all keys, including secret keys."
+ (let ((args (list "--with-colons" "--no-greeting" "--batch"
+ (if all "--list-secret-keys" "--list-keys")
+ string))
+ (key-regexp (concat "^\\(sec\\|pub\\|uid\\)"
+ ":[^:]*:[^:]*:[^:]*:\\([^:]*\\):[^:]*"
+ ":[^:]*:[^:]*:[^:]*:\\([^:]+\\):")))
+ (with-temp-buffer
+ (apply #'call-process pgg-gpg-program nil t nil args)
+ (goto-char (point-min))
+ (if (re-search-forward key-regexp
+ nil t)
+ (match-string 3)))))
+
+(defun pgg-gpg-key-id-from-key-owner (key-owner)
+ (cond ((not key-owner) nil)
+ ;; Extract bare key id from outermost paired angle brackets, if any:
+ ((string-match "[^<]*<\\(.+\\)>[^>]*" key-owner)
+ (substring key-owner (match-beginning 1)(match-end 1)))
+ (key-owner)))
+
+(defun pgg-gpg-encrypt-region (start end recipients &optional sign passphrase)
+ "Encrypt the current region between START and END.
+
+If optional argument SIGN is non-nil, do a combined sign and encrypt.
+
+If optional PASSPHRASE is not specified, it will be obtained from the
+passphrase cache or user."
+ (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id))
+ (passphrase (or passphrase
+ (when (and sign (not (pgg-gpg-use-agent-p)))
+ (pgg-read-passphrase
+ (format "GnuPG passphrase for %s: "
+ pgg-gpg-user-id)
+ pgg-gpg-user-id))))
+ (args
+ (append
+ (list "--batch" "--armor" "--always-trust" "--encrypt")
+ (if pgg-text-mode (list "--textmode"))
+ (if sign (list "--sign" "--local-user" pgg-gpg-user-id))
+ (if (or recipients pgg-encrypt-for-me)
+ (apply #'nconc
+ (mapcar (lambda (rcpt)
+ (list pgg-gpg-recipient-argument rcpt))
+ (append recipients
+ (if pgg-encrypt-for-me
+ (list pgg-gpg-user-id)))))))))
+ (pgg-gpg-process-region start end passphrase pgg-gpg-program args)
+ (when sign
+ (with-current-buffer pgg-errors-buffer
+ ;; Possibly cache passphrase under, e.g. "jas", for future sign.
+ (pgg-gpg-possibly-cache-passphrase passphrase pgg-gpg-user-id)
+ ;; Possibly cache passphrase under, e.g. B565716F, for future decrypt.
+ (pgg-gpg-possibly-cache-passphrase passphrase)))
+ (pgg-process-when-success)))
+
+(defun pgg-gpg-encrypt-symmetric-region (start end &optional passphrase)
+ "Encrypt the current region between START and END with symmetric cipher.
+
+If optional PASSPHRASE is not specified, it will be obtained from the
+passphrase cache or user."
+ (let* ((passphrase (or passphrase
+ (when (not (pgg-gpg-use-agent-p))
+ (pgg-read-passphrase
+ "GnuPG passphrase for symmetric encryption: "))))
+ (args
+ (append (list "--batch" "--armor" "--symmetric" )
+ (if pgg-text-mode (list "--textmode")))))
+ (pgg-gpg-process-region start end passphrase pgg-gpg-program args)
+ (pgg-process-when-success)))
+
+(defun pgg-gpg-decrypt-region (start end &optional passphrase)
+ "Decrypt the current region between START and END.
+
+If optional PASSPHRASE is not specified, it will be obtained from the
+passphrase cache or user."
+ (let* ((current-buffer (current-buffer))
+ (message-keys (with-temp-buffer
+ (insert-buffer-substring current-buffer)
+ (pgg-decode-armor-region (point-min) (point-max))))
+ (secret-keys (pgg-gpg-lookup-all-secret-keys))
+ ;; XXX the user is stuck if they need to use the passphrase for
+ ;; any but the first secret key for which the message is
+ ;; encrypted. ideally, we would incrementally give them a
+ ;; chance with subsequent keys each time they fail with one.
+ (key (pgg-gpg-select-matching-key message-keys secret-keys))
+ (key-owner (and key (pgg-gpg-lookup-key-owner key t)))
+ (key-id (pgg-gpg-key-id-from-key-owner key-owner))
+ (pgg-gpg-user-id (or key-id key
+ pgg-gpg-user-id pgg-default-user-id))
+ (passphrase (or passphrase
+ (when (not (pgg-gpg-use-agent-p))
+ (pgg-read-passphrase
+ (format (if (pgg-gpg-symmetric-key-p message-keys)
+ "Passphrase for symmetric decryption: "
+ "GnuPG passphrase for %s: ")
+ (or key-owner "??"))
+ pgg-gpg-user-id))))
+ (args '("--batch" "--decrypt")))
+ (pgg-gpg-process-region start end passphrase pgg-gpg-program args)
+ (with-current-buffer pgg-errors-buffer
+ (pgg-gpg-possibly-cache-passphrase passphrase pgg-gpg-user-id)
+ (goto-char (point-min))
+ (re-search-forward "^\\[GNUPG:] DECRYPTION_OKAY\\>" nil t))))
+
+;;;###autoload
+(defun pgg-gpg-symmetric-key-p (message-keys)
+ "True if decoded armor MESSAGE-KEYS has symmetric encryption indicator."
+ (let (result)
+ (dolist (key message-keys result)
+ (when (and (eq (car key) 3)
+ (member '(symmetric-key-algorithm) key))
+ (setq result key)))))
+
+(defun pgg-gpg-select-matching-key (message-keys secret-keys)
+ "Choose a key from MESSAGE-KEYS that matches one of the keys in SECRET-KEYS."
+ (loop for message-key in message-keys
+ for message-key-id = (and (equal (car message-key) 1)
+ (cdr (assq 'key-identifier
+ (cdr message-key))))
+ for key = (and message-key-id (pgg-lookup-key message-key-id 'encrypt))
+ when (and key (member key secret-keys)) return key))
+
+(defun pgg-gpg-sign-region (start end &optional cleartext passphrase)
+ "Make detached signature from text between START and END."
+ (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id))
+ (passphrase (or passphrase
+ (when (not (pgg-gpg-use-agent-p))
+ (pgg-read-passphrase
+ (format "GnuPG passphrase for %s: "
+ pgg-gpg-user-id)
+ pgg-gpg-user-id))))
+ (args
+ (append (list (if cleartext "--clearsign" "--detach-sign")
+ "--armor" "--batch" "--verbose"
+ "--local-user" pgg-gpg-user-id)
+ (if pgg-text-mode (list "--textmode"))))
+ (inhibit-read-only t)
+ buffer-read-only)
+ (pgg-gpg-process-region start end passphrase pgg-gpg-program args)
+ (with-current-buffer pgg-errors-buffer
+ ;; Possibly cache passphrase under, e.g. "jas", for future sign.
+ (pgg-gpg-possibly-cache-passphrase passphrase pgg-gpg-user-id)
+ ;; Possibly cache passphrase under, e.g. B565716F, for future decrypt.
+ (pgg-gpg-possibly-cache-passphrase passphrase))
+ (pgg-process-when-success)))
+
+(defun pgg-gpg-verify-region (start end &optional signature)
+ "Verify region between START and END as the detached signature SIGNATURE."
+ (let ((args '("--batch" "--verify")))
+ (when (stringp signature)
+ (setq args (append args (list signature))))
+ (setq args (append args '("-")))
+ (pgg-gpg-process-region start end nil pgg-gpg-program args)
+ (with-current-buffer pgg-errors-buffer
+ (goto-char (point-min))
+ (while (re-search-forward "^gpg: \\(.*\\)\n" nil t)
+ (with-current-buffer pgg-output-buffer
+ (insert-buffer-substring pgg-errors-buffer
+ (match-beginning 1) (match-end 0)))
+ (delete-region (match-beginning 0) (match-end 0)))
+ (goto-char (point-min))
+ (re-search-forward "^\\[GNUPG:] GOODSIG\\>" nil t))))
+
+(defun pgg-gpg-insert-key ()
+ "Insert public key at point."
+ (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id))
+ (args (list "--batch" "--export" "--armor"
+ pgg-gpg-user-id)))
+ (pgg-gpg-process-region (point)(point) nil pgg-gpg-program args)
+ (insert-buffer-substring pgg-output-buffer)))
+
+(defun pgg-gpg-snarf-keys-region (start end)
+ "Add all public keys in region between START and END to the keyring."
+ (let ((args '("--import" "--batch" "-")) status)
+ (pgg-gpg-process-region start end nil pgg-gpg-program args)
+ (set-buffer pgg-errors-buffer)
+ (goto-char (point-min))
+ (when (re-search-forward "^\\[GNUPG:] IMPORT_RES\\>" nil t)
+ (setq status (buffer-substring (match-end 0)
+ (progn (end-of-line)(point)))
+ status (vconcat (mapcar #'string-to-number (split-string status))))
+ (erase-buffer)
+ (insert (format "Imported %d key(s).
+\tArmor contains %d key(s) [%d bad, %d old].\n"
+ (+ (aref status 2)
+ (aref status 10))
+ (aref status 0)
+ (aref status 1)
+ (+ (aref status 4)
+ (aref status 11)))
+ (if (zerop (aref status 9))
+ ""
+ "\tSecret keys are imported.\n")))
+ (append-to-buffer pgg-output-buffer (point-min)(point-max))
+ (pgg-process-when-success)))
+
+(defun pgg-gpg-update-agent ()
+ "Try to connet to gpg-agent and send UPDATESTARTUPTTY."
+ (if (fboundp 'make-network-process)
+ (let* ((agent-info (getenv "GPG_AGENT_INFO"))
+ (socket (and agent-info
+ (string-match "^\\([^:]*\\)" agent-info)
+ (match-string 1 agent-info)))
+ (conn (and socket
+ (make-network-process :name "gpg-agent-process"
+ :host 'local :family 'local
+ :service socket))))
+ (when (and conn (eq (process-status conn) 'open))
+ (process-send-string conn "UPDATESTARTUPTTY\n")
+ (delete-process conn)
+ t))
+ ;; We can't check, so assume gpg-agent is up.
+ t))
+
+(defun pgg-gpg-use-agent-p ()
+ "Return t if `pgg-gpg-use-agent' is t and gpg-agent is available."
+ (and pgg-gpg-use-agent (pgg-gpg-update-agent)))
+
+(provide 'pgg-gpg)
+
+;;; pgg-gpg.el ends here
--- /dev/null
- ;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;;; pgg-parse.el --- OpenPGP packet parsing
+
+;; Copyright (C) 1999, 2002, 2003, 2004, 2005,
++;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+
+;; Author: Daiki Ueno <ueno@unixuser.org>
+;; Created: 1999/10/28
+;; Keywords: PGP, OpenPGP, GnuPG
+;; Package: pgg
+;; Obsolete-since: 24.1
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This module is based on
+
+;; [OpenPGP] RFC 2440: "OpenPGP Message Format"
+;; by John W. Noerenberg, II <jwn2@qualcomm.com>,
+;; Jon Callas <jon@pgp.com>, Lutz Donnerhacke <lutz@iks-jena.de>,
+;; Hal Finney <hal@pgp.com> and Rodney Thayer <rodney@unitran.com>
+;; (1998/11)
+
+;;; Code:
+
+(eval-when-compile
+ ;; For Emacs <22.2 and XEmacs.
+ (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))
+ (require 'cl))
+
+(defgroup pgg-parse ()
+ "OpenPGP packet parsing."
+ :group 'pgg)
+
+(defcustom pgg-parse-public-key-algorithm-alist
+ '((1 . RSA) (2 . RSA-E) (3 . RSA-S) (16 . ELG-E) (17 . DSA) (20 . ELG))
+ "Alist of the assigned number to the public key algorithm."
+ :group 'pgg-parse
+ :type '(repeat
+ (cons (sexp :tag "Number") (sexp :tag "Type"))))
+
+(defcustom pgg-parse-symmetric-key-algorithm-alist
+ '((1 . IDEA) (2 . 3DES) (4 . CAST5) (5 . SAFER-SK128))
+ "Alist of the assigned number to the simmetric key algorithm."
+ :group 'pgg-parse
+ :type '(repeat
+ (cons (sexp :tag "Number") (sexp :tag "Type"))))
+
+(defcustom pgg-parse-hash-algorithm-alist
+ '((1 . MD5) (2 . SHA1) (3 . RIPEMD160) (5 . MD2) (8 . SHA256) (9 . SHA384)
+ (10 . SHA512))
+ "Alist of the assigned number to the cryptographic hash algorithm."
+ :group 'pgg-parse
+ :type '(repeat
+ (cons (sexp :tag "Number") (sexp :tag "Type"))))
+
+(defcustom pgg-parse-compression-algorithm-alist
+ '((0 . nil); Uncompressed
+ (1 . ZIP)
+ (2 . ZLIB))
+ "Alist of the assigned number to the compression algorithm."
+ :group 'pgg-parse
+ :type '(repeat
+ (cons (sexp :tag "Number") (sexp :tag "Type"))))
+
+(defcustom pgg-parse-signature-type-alist
+ '((0 . "Signature of a binary document")
+ (1 . "Signature of a canonical text document")
+ (2 . "Standalone signature")
+ (16 . "Generic certification of a User ID and Public Key packet")
+ (17 . "Persona certification of a User ID and Public Key packet")
+ (18 . "Casual certification of a User ID and Public Key packet")
+ (19 . "Positive certification of a User ID and Public Key packet")
+ (24 . "Subkey Binding Signature")
+ (31 . "Signature directly on a key")
+ (32 . "Key revocation signature")
+ (40 . "Subkey revocation signature")
+ (48 . "Certification revocation signature")
+ (64 . "Timestamp signature."))
+ "Alist of the assigned number to the signature type."
+ :group 'pgg-parse
+ :type '(repeat
+ (cons (sexp :tag "Number") (sexp :tag "Type"))))
+
+(defcustom pgg-ignore-packet-checksum t; XXX
+ "If non-nil checksum of each ascii armored packet will be ignored."
+ :group 'pgg-parse
+ :type 'boolean)
+
+(defvar pgg-armor-header-lines
+ '("^-----BEGIN PGP MESSAGE\\(, PART [0-9]+\\(/[0-9]+\\)?\\)?-----\r?$"
+ "^-----BEGIN PGP PUBLIC KEY BLOCK-----\r?$"
+ "^-----BEGIN PGP PRIVATE KEY BLOCK-----\r?$"
+ "^-----BEGIN PGP SIGNATURE-----\r?$")
+ "Armor headers.")
+
+(eval-and-compile
+ (defalias 'pgg-char-int (if (fboundp 'char-int)
+ 'char-int
+ 'identity)))
+
+(defmacro pgg-format-key-identifier (string)
+ `(mapconcat (lambda (c) (format "%02X" (pgg-char-int c)))
+ ,string "")
+ ;; `(upcase (apply #'format "%02x%02x%02x%02x%02x%02x%02x%02x"
+ ;; (string-to-number-list ,string)))
+ )
+
+(defmacro pgg-parse-time-field (bytes)
+ `(list (logior (lsh (car ,bytes) 8)
+ (nth 1 ,bytes))
+ (logior (lsh (nth 2 ,bytes) 8)
+ (nth 3 ,bytes))
+ 0))
+
+(defmacro pgg-byte-after (&optional pos)
+ `(pgg-char-int (char-after ,(or pos `(point)))))
+
+(defmacro pgg-read-byte ()
+ `(pgg-char-int (char-after (prog1 (point) (forward-char)))))
+
+(defmacro pgg-read-bytes-string (nbytes)
+ `(buffer-substring
+ (point) (prog1 (+ ,nbytes (point))
+ (forward-char ,nbytes))))
+
+(defmacro pgg-read-bytes (nbytes)
+ `(mapcar #'pgg-char-int (pgg-read-bytes-string ,nbytes))
+ ;; `(string-to-number-list (pgg-read-bytes-string ,nbytes))
+ )
+
+(defmacro pgg-read-body-string (ptag)
+ `(if (nth 1 ,ptag)
+ (pgg-read-bytes-string (nth 1 ,ptag))
+ (pgg-read-bytes-string (- (point-max) (point)))))
+
+(defmacro pgg-read-body (ptag)
+ `(mapcar #'pgg-char-int (pgg-read-body-string ,ptag))
+ ;; `(string-to-number-list (pgg-read-body-string ,ptag))
+ )
+
+(defalias 'pgg-skip-bytes 'forward-char)
+
+(defmacro pgg-skip-header (ptag)
+ `(pgg-skip-bytes (nth 2 ,ptag)))
+
+(defmacro pgg-skip-body (ptag)
+ `(pgg-skip-bytes (nth 1 ,ptag)))
+
+(defmacro pgg-set-alist (alist key value)
+ `(setq ,alist (nconc ,alist (list (cons ,key ,value)))))
+
+(when (fboundp 'define-ccl-program)
+
+ (define-ccl-program pgg-parse-crc24
+ '(1
+ ((loop
+ (read r0) (r1 ^= r0) (r2 ^= 0)
+ (r5 = 0)
+ (loop
+ (r1 <<= 1)
+ (r1 += ((r2 >> 15) & 1))
+ (r2 <<= 1)
+ (if (r1 & 256)
+ ((r1 ^= 390) (r2 ^= 19707)))
+ (if (r5 < 7)
+ ((r5 += 1)
+ (repeat))))
+ (repeat)))))
+
+ (defvar pgg-parse-crc24)
+
+ (defun pgg-parse-crc24-string (string)
+ (let ((h (vector nil 183 1230 nil nil nil nil nil nil)))
+ (ccl-execute-on-string pgg-parse-crc24 h string)
+ (format "%c%c%c"
+ (logand (aref h 1) 255)
+ (logand (lsh (aref h 2) -8) 255)
+ (logand (aref h 2) 255)))))
+
+(defmacro pgg-parse-length-type (c)
+ `(cond
+ ((< ,c 192) (cons ,c 1))
+ ((< ,c 224)
+ (cons (+ (lsh (- ,c 192) 8)
+ (pgg-byte-after (+ 2 (point)))
+ 192)
+ 2))
+ ((= ,c 255)
+ (cons (cons (logior (lsh (pgg-byte-after (+ 2 (point))) 8)
+ (pgg-byte-after (+ 3 (point))))
+ (logior (lsh (pgg-byte-after (+ 4 (point))) 8)
+ (pgg-byte-after (+ 5 (point)))))
+ 5))
+ (t;partial body length
+ '(0 . 0))))
+
+(defun pgg-parse-packet-header ()
+ (let ((ptag (pgg-byte-after))
+ length-type content-tag packet-bytes header-bytes)
+ (if (zerop (logand 64 ptag));Old format
+ (progn
+ (setq length-type (logand ptag 3)
+ length-type (if (= 3 length-type) 0 (lsh 1 length-type))
+ content-tag (logand 15 (lsh ptag -2))
+ packet-bytes 0
+ header-bytes (1+ length-type))
+ (dotimes (i length-type)
+ (setq packet-bytes
+ (logior (lsh packet-bytes 8)
+ (pgg-byte-after (+ 1 i (point)))))))
+ (setq content-tag (logand 63 ptag)
+ length-type (pgg-parse-length-type
+ (pgg-byte-after (1+ (point))))
+ packet-bytes (car length-type)
+ header-bytes (1+ (cdr length-type))))
+ (list content-tag packet-bytes header-bytes)))
+
+(defun pgg-parse-packet (ptag)
+ (case (car ptag)
+ (1 ;Public-Key Encrypted Session Key Packet
+ (pgg-parse-public-key-encrypted-session-key-packet ptag))
+ (2 ;Signature Packet
+ (pgg-parse-signature-packet ptag))
+ (3 ;Symmetric-Key Encrypted Session Key Packet
+ (pgg-parse-symmetric-key-encrypted-session-key-packet ptag))
+ ;; 4 -- One-Pass Signature Packet
+ ;; 5 -- Secret Key Packet
+ (6 ;Public Key Packet
+ (pgg-parse-public-key-packet ptag))
+ ;; 7 -- Secret Subkey Packet
+ ;; 8 -- Compressed Data Packet
+ (9 ;Symmetrically Encrypted Data Packet
+ (pgg-read-body-string ptag))
+ (10 ;Marker Packet
+ (pgg-read-body-string ptag))
+ (11 ;Literal Data Packet
+ (pgg-read-body-string ptag))
+ ;; 12 -- Trust Packet
+ (13 ;User ID Packet
+ (pgg-read-body-string ptag))
+ ;; 14 -- Public Subkey Packet
+ ;; 60 .. 63 -- Private or Experimental Values
+ ))
+
+(defun pgg-parse-packets (&optional header-parser body-parser)
+ (let ((header-parser
+ (or header-parser
+ (function pgg-parse-packet-header)))
+ (body-parser
+ (or body-parser
+ (function pgg-parse-packet)))
+ result ptag)
+ (while (> (point-max) (1+ (point)))
+ (setq ptag (funcall header-parser))
+ (pgg-skip-header ptag)
+ (push (cons (car ptag)
+ (save-excursion
+ (funcall body-parser ptag)))
+ result)
+ (if (zerop (nth 1 ptag))
+ (goto-char (point-max))
+ (forward-char (nth 1 ptag))))
+ result))
+
+(defun pgg-parse-signature-subpacket-header ()
+ (let ((length-type (pgg-parse-length-type (pgg-byte-after))))
+ (list (pgg-byte-after (+ (cdr length-type) (point)))
+ (1- (car length-type))
+ (1+ (cdr length-type)))))
+
+(defun pgg-parse-signature-subpacket (ptag)
+ (case (car ptag)
+ (2 ;signature creation time
+ (cons 'creation-time
+ (let ((bytes (pgg-read-bytes 4)))
+ (pgg-parse-time-field bytes))))
+ (3 ;signature expiration time
+ (cons 'signature-expiry
+ (let ((bytes (pgg-read-bytes 4)))
+ (pgg-parse-time-field bytes))))
+ (4 ;exportable certification
+ (cons 'exportability (pgg-read-byte)))
+ (5 ;trust signature
+ (cons 'trust-level (pgg-read-byte)))
+ (6 ;regular expression
+ (cons 'regular-expression
+ (pgg-read-body-string ptag)))
+ (7 ;revocable
+ (cons 'revocability (pgg-read-byte)))
+ (9 ;key expiration time
+ (cons 'key-expiry
+ (let ((bytes (pgg-read-bytes 4)))
+ (pgg-parse-time-field bytes))))
+ ;; 10 = placeholder for backward compatibility
+ (11 ;preferred symmetric algorithms
+ (cons 'preferred-symmetric-key-algorithm
+ (cdr (assq (pgg-read-byte)
+ pgg-parse-symmetric-key-algorithm-alist))))
+ (12 ;revocation key
+ )
+ (16 ;issuer key ID
+ (cons 'key-identifier
+ (pgg-format-key-identifier (pgg-read-body-string ptag))))
+ (20 ;notation data
+ (pgg-skip-bytes 4)
+ (cons 'notation
+ (let ((name-bytes (pgg-read-bytes 2))
+ (value-bytes (pgg-read-bytes 2)))
+ (cons (pgg-read-bytes-string
+ (logior (lsh (car name-bytes) 8)
+ (nth 1 name-bytes)))
+ (pgg-read-bytes-string
+ (logior (lsh (car value-bytes) 8)
+ (nth 1 value-bytes)))))))
+ (21 ;preferred hash algorithms
+ (cons 'preferred-hash-algorithm
+ (cdr (assq (pgg-read-byte)
+ pgg-parse-hash-algorithm-alist))))
+ (22 ;preferred compression algorithms
+ (cons 'preferred-compression-algorithm
+ (cdr (assq (pgg-read-byte)
+ pgg-parse-compression-algorithm-alist))))
+ (23 ;key server preferences
+ (cons 'key-server-preferences
+ (pgg-read-body ptag)))
+ (24 ;preferred key server
+ (cons 'preferred-key-server
+ (pgg-read-body-string ptag)))
+ ;; 25 = primary user id
+ (26 ;policy URL
+ (cons 'policy-url (pgg-read-body-string ptag)))
+ ;; 27 = key flags
+ ;; 28 = signer's user id
+ ;; 29 = reason for revocation
+ ;; 100 to 110 = internal or user-defined
+ ))
+
+(defun pgg-parse-signature-packet (ptag)
+ (let* ((signature-version (pgg-byte-after))
+ (result (list (cons 'version signature-version)))
+ hashed-material field n)
+ (cond
+ ((= signature-version 3)
+ (pgg-skip-bytes 2)
+ (setq hashed-material (pgg-read-bytes 5))
+ (pgg-set-alist result
+ 'signature-type
+ (cdr (assq (pop hashed-material)
+ pgg-parse-signature-type-alist)))
+ (pgg-set-alist result
+ 'creation-time
+ (pgg-parse-time-field hashed-material))
+ (pgg-set-alist result
+ 'key-identifier
+ (pgg-format-key-identifier
+ (pgg-read-bytes-string 8)))
+ (pgg-set-alist result
+ 'public-key-algorithm (pgg-read-byte))
+ (pgg-set-alist result
+ 'hash-algorithm (pgg-read-byte)))
+ ((= signature-version 4)
+ (pgg-skip-bytes 1)
+ (pgg-set-alist result
+ 'signature-type
+ (cdr (assq (pgg-read-byte)
+ pgg-parse-signature-type-alist)))
+ (pgg-set-alist result
+ 'public-key-algorithm
+ (pgg-read-byte))
+ (pgg-set-alist result
+ 'hash-algorithm (pgg-read-byte))
+ (when (>= 10000 (setq n (pgg-read-bytes 2)
+ n (logior (lsh (car n) 8)
+ (nth 1 n))))
+ (save-restriction
+ (narrow-to-region (point)(+ n (point)))
+ (nconc result
+ (mapcar (function cdr) ;remove packet types
+ (pgg-parse-packets
+ #'pgg-parse-signature-subpacket-header
+ #'pgg-parse-signature-subpacket)))
+ (goto-char (point-max))))
+ (when (>= 10000 (setq n (pgg-read-bytes 2)
+ n (logior (lsh (car n) 8)
+ (nth 1 n))))
+ (save-restriction
+ (narrow-to-region (point)(+ n (point)))
+ (nconc result
+ (mapcar (function cdr) ;remove packet types
+ (pgg-parse-packets
+ #'pgg-parse-signature-subpacket-header
+ #'pgg-parse-signature-subpacket)))))))
+
+ (setcdr (setq field (assq 'public-key-algorithm
+ result))
+ (cdr (assq (cdr field)
+ pgg-parse-public-key-algorithm-alist)))
+ (setcdr (setq field (assq 'hash-algorithm
+ result))
+ (cdr (assq (cdr field)
+ pgg-parse-hash-algorithm-alist)))
+ result))
+
+(defun pgg-parse-public-key-encrypted-session-key-packet (ptag)
+ (let (result)
+ (pgg-set-alist result
+ 'version (pgg-read-byte))
+ (pgg-set-alist result
+ 'key-identifier
+ (pgg-format-key-identifier
+ (pgg-read-bytes-string 8)))
+ (pgg-set-alist result
+ 'public-key-algorithm
+ (cdr (assq (pgg-read-byte)
+ pgg-parse-public-key-algorithm-alist)))
+ result))
+
+(defun pgg-parse-symmetric-key-encrypted-session-key-packet (ptag)
+ (let (result)
+ (pgg-set-alist result
+ 'version
+ (pgg-read-byte))
+ (pgg-set-alist result
+ 'symmetric-key-algorithm
+ (cdr (assq (pgg-read-byte)
+ pgg-parse-symmetric-key-algorithm-alist)))
+ result))
+
+(defun pgg-parse-public-key-packet (ptag)
+ (let* ((key-version (pgg-read-byte))
+ (result (list (cons 'version key-version)))
+ field)
+ (cond
+ ((= 3 key-version)
+ (pgg-set-alist result
+ 'creation-time
+ (let ((bytes (pgg-read-bytes 4)))
+ (pgg-parse-time-field bytes)))
+ (pgg-set-alist result
+ 'key-expiry (pgg-read-bytes 2))
+ (pgg-set-alist result
+ 'public-key-algorithm (pgg-read-byte)))
+ ((= 4 key-version)
+ (pgg-set-alist result
+ 'creation-time
+ (let ((bytes (pgg-read-bytes 4)))
+ (pgg-parse-time-field bytes)))
+ (pgg-set-alist result
+ 'public-key-algorithm (pgg-read-byte))))
+
+ (setcdr (setq field (assq 'public-key-algorithm
+ result))
+ (cdr (assq (cdr field)
+ pgg-parse-public-key-algorithm-alist)))
+ result))
+
+;; p-d-p only calls this if it is defined, but the compiler does not
+;; recognize that.
+(declare-function pgg-parse-crc24-string "pgg-parse" (string))
+
+(defun pgg-decode-packets ()
+ (if (re-search-forward "^=\\([A-Za-z0-9+/]\\{4\\}\\)$" nil t)
+ (let ((p (match-beginning 0))
+ (checksum (match-string 1)))
+ (delete-region p (point-max))
+ (if (ignore-errors (base64-decode-region (point-min) p))
+ (or (not (fboundp 'pgg-parse-crc24-string))
+ pgg-ignore-packet-checksum
+ (string-equal (base64-encode-string (pgg-parse-crc24-string
+ (buffer-string)))
+ checksum)
+ (progn
+ (message "PGP packet checksum does not match")
+ nil))
+ (message "PGP packet contain invalid base64")
+ nil))
+ (message "PGP packet checksum not found")
+ nil))
+
+(defun pgg-decode-armor-region (start end)
+ (save-restriction
+ (narrow-to-region start end)
+ (goto-char (point-min))
+ (re-search-forward "^-+BEGIN PGP" nil t)
+ (delete-region (point-min)
+ (and (search-forward "\n\n")
+ (match-end 0)))
+ (when (pgg-decode-packets)
+ (goto-char (point-min))
+ (pgg-parse-packets))))
+
+(defun pgg-parse-armor (string)
+ (with-temp-buffer
+ (buffer-disable-undo)
+ (unless (featurep 'xemacs)
+ (set-buffer-multibyte nil))
+ (insert string)
+ (pgg-decode-armor-region (point-min)(point))))
+
+(eval-and-compile
+ (defalias 'pgg-string-as-unibyte (if (fboundp 'string-as-unibyte)
+ 'string-as-unibyte
+ 'identity)))
+
+(defun pgg-parse-armor-region (start end)
+ (pgg-parse-armor (pgg-string-as-unibyte (buffer-substring start end))))
+
+(provide 'pgg-parse)
+
+;;; pgg-parse.el ends here
--- /dev/null
- ;; 2009, 2010 Free Software Foundation, Inc.
+;;; pgg-pgp.el --- PGP 2.* and 6.* support for PGG.
+
+;; Copyright (C) 1999, 2000, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
++;; 2009, 2010, 2011 Free Software Foundation, Inc.
+
+;; Author: Daiki Ueno <ueno@unixuser.org>
+;; Created: 1999/11/02
+;; Keywords: PGP, OpenPGP
+;; Package: pgg
+;; Obsolete-since: 24.1
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(eval-when-compile
+ (require 'cl) ; for pgg macros
+ (require 'pgg))
+
+(defgroup pgg-pgp ()
+ "PGP 2.* and 6.* interface."
+ :group 'pgg)
+
+(defcustom pgg-pgp-program "pgp"
+ "PGP 2.* and 6.* executable."
+ :group 'pgg-pgp
+ :type 'string)
+
+(defcustom pgg-pgp-shell-file-name "/bin/sh"
+ "File name to load inferior shells from.
+Bourne shell or its equivalent \(not tcsh) is needed for \"2>\"."
+ :group 'pgg-pgp
+ :type 'string)
+
+(defcustom pgg-pgp-shell-command-switch "-c"
+ "Switch used to have the shell execute its command line argument."
+ :group 'pgg-pgp
+ :type 'string)
+
+(defcustom pgg-pgp-extra-args nil
+ "Extra arguments for every PGP invocation."
+ :group 'pgg-pgp
+ :type '(choice
+ (const :tag "None" nil)
+ (string :tag "Arguments")))
+
+(defvar pgg-pgp-user-id nil
+ "PGP ID of your default identity.")
+
+(defun pgg-pgp-process-region (start end passphrase program args)
+ (let* ((errors-file-name (pgg-make-temp-file "pgg-errors"))
+ (args
+ (concat args
+ pgg-pgp-extra-args
+ " 2>" (shell-quote-argument errors-file-name)))
+ (shell-file-name pgg-pgp-shell-file-name)
+ (shell-command-switch pgg-pgp-shell-command-switch)
+ (process-environment process-environment)
+ (output-buffer pgg-output-buffer)
+ (errors-buffer pgg-errors-buffer)
+ (process-connection-type nil)
+ process status exit-status)
+ (with-current-buffer (get-buffer-create output-buffer)
+ (buffer-disable-undo)
+ (erase-buffer))
+ (when passphrase
+ (setenv "PGPPASSFD" "0"))
+ (unwind-protect
+ (progn
+ (let ((coding-system-for-read 'binary)
+ (coding-system-for-write 'binary))
+ (setq process
+ (start-process-shell-command "*PGP*" output-buffer
+ (concat program " " args))))
+ (set-process-sentinel process #'ignore)
+ (when passphrase
+ (process-send-string process (concat passphrase "\n")))
+ (process-send-region process start end)
+ (process-send-eof process)
+ (while (eq 'run (process-status process))
+ (accept-process-output process 5))
+ (setq status (process-status process)
+ exit-status (process-exit-status process))
+ (delete-process process)
+ (with-current-buffer output-buffer
+ (pgg-convert-lbt-region (point-min)(point-max) 'LF)
+
+ (if (memq status '(stop signal))
+ (error "%s exited abnormally: '%s'" program exit-status))
+ (if (= 127 exit-status)
+ (error "%s could not be found" program))
+
+ (set-buffer (get-buffer-create errors-buffer))
+ (buffer-disable-undo)
+ (erase-buffer)
+ (insert-file-contents errors-file-name)))
+ (if (and process (eq 'run (process-status process)))
+ (interrupt-process process))
+ (condition-case nil
+ (delete-file errors-file-name)
+ (file-error nil)))))
+
+(defun pgg-pgp-lookup-key (string &optional type)
+ "Search keys associated with STRING."
+ (let ((args (list "+batchmode" "+language=en" "-kv" string)))
+ (with-current-buffer (get-buffer-create pgg-output-buffer)
+ (buffer-disable-undo)
+ (erase-buffer)
+ (apply #'call-process pgg-pgp-program nil t nil args)
+ (goto-char (point-min))
+ (cond
+ ((re-search-forward "^pub\\s +[0-9]+/" nil t);PGP 2.*
+ (buffer-substring (point)(+ 8 (point))))
+ ((re-search-forward "^Type" nil t);PGP 6.*
+ (beginning-of-line 2)
+ (substring
+ (nth 2 (split-string
+ (buffer-substring (point)(progn (end-of-line) (point)))))
+ 2))))))
+
+(defun pgg-pgp-encrypt-region (start end recipients &optional sign passphrase)
+ "Encrypt the current region between START and END."
+ (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id))
+ (passphrase (or passphrase
+ (when sign
+ (pgg-read-passphrase
+ (format "PGP passphrase for %s: "
+ pgg-pgp-user-id)
+ pgg-pgp-user-id))))
+ (args
+ (concat
+ "+encrypttoself=off +verbose=1 +batchmode +language=us -fate "
+ (if (or recipients pgg-encrypt-for-me)
+ (mapconcat 'shell-quote-argument
+ (append recipients
+ (if pgg-encrypt-for-me
+ (list pgg-pgp-user-id))) " "))
+ (if sign (concat " -s -u " (shell-quote-argument pgg-pgp-user-id))))))
+ (pgg-pgp-process-region start end nil pgg-pgp-program args)
+ (pgg-process-when-success nil)))
+
+(defun pgg-pgp-decrypt-region (start end &optional passphrase)
+ "Decrypt the current region between START and END.
+
+If optional PASSPHRASE is not specified, it will be obtained from the
+passphrase cache or user."
+ (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id))
+ (key (pgg-pgp-lookup-key pgg-pgp-user-id 'encrypt))
+ (passphrase
+ (or passphrase
+ (pgg-read-passphrase
+ (format "PGP passphrase for %s: " pgg-pgp-user-id) key)))
+ (args
+ "+verbose=1 +batchmode +language=us -f"))
+ (pgg-pgp-process-region start end passphrase pgg-pgp-program args)
+ (pgg-process-when-success
+ (if pgg-cache-passphrase
+ (pgg-add-passphrase-to-cache key passphrase)))))
+
+(defun pgg-pgp-sign-region (start end &optional clearsign passphrase)
+ "Make detached signature from text between START and END.
+
+If optional PASSPHRASE is not specified, it will be obtained from the
+passphrase cache or user."
+ (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id))
+ (passphrase
+ (or passphrase
+ (pgg-read-passphrase
+ (format "PGP passphrase for %s: " pgg-pgp-user-id)
+ (pgg-pgp-lookup-key pgg-pgp-user-id 'sign))))
+ (args
+ (concat (if clearsign "-fast" "-fbast")
+ " +verbose=1 +language=us +batchmode"
+ " -u " (shell-quote-argument pgg-pgp-user-id))))
+ (pgg-pgp-process-region start end passphrase pgg-pgp-program args)
+ (pgg-process-when-success
+ (goto-char (point-min))
+ (when (re-search-forward "^-+BEGIN PGP" nil t);XXX
+ (let ((packet
+ (cdr (assq 2 (pgg-parse-armor-region
+ (progn (beginning-of-line 2)
+ (point))
+ (point-max))))))
+ (if pgg-cache-passphrase
+ (pgg-add-passphrase-to-cache
+ (cdr (assq 'key-identifier packet))
+ passphrase)))))))
+
+(defun pgg-pgp-verify-region (start end &optional signature)
+ "Verify region between START and END as the detached signature SIGNATURE."
+ (let* ((orig-file (pgg-make-temp-file "pgg"))
+ (args "+verbose=1 +batchmode +language=us")
+ (orig-mode (default-file-modes)))
+ (unwind-protect
+ (progn
+ (set-default-file-modes 448)
+ (let ((coding-system-for-write 'binary)
+ jka-compr-compression-info-list jam-zcat-filename-list)
+ (write-region start end orig-file)))
+ (set-default-file-modes orig-mode))
+ (if (stringp signature)
+ (progn
+ (copy-file signature (setq signature (concat orig-file ".asc")))
+ (setq args (concat args " " (shell-quote-argument signature)))))
+ (setq args (concat args " " (shell-quote-argument orig-file)))
+ (pgg-pgp-process-region (point)(point) nil pgg-pgp-program args)
+ (delete-file orig-file)
+ (if signature (delete-file signature))
+ (pgg-process-when-success
+ (goto-char (point-min))
+ (let ((case-fold-search t))
+ (while (re-search-forward "^warning: " nil t)
+ (delete-region (match-beginning 0)
+ (progn (beginning-of-line 2) (point)))))
+ (goto-char (point-min))
+ (when (re-search-forward "^\\.$" nil t)
+ (delete-region (point-min)
+ (progn (beginning-of-line 2)
+ (point)))))))
+
+(defun pgg-pgp-insert-key ()
+ "Insert public key at point."
+ (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id))
+ (args
+ (concat "+verbose=1 +batchmode +language=us -kxaf "
+ (shell-quote-argument pgg-pgp-user-id))))
+ (pgg-pgp-process-region (point)(point) nil pgg-pgp-program args)
+ (insert-buffer-substring pgg-output-buffer)))
+
+(defun pgg-pgp-snarf-keys-region (start end)
+ "Add all public keys in region between START and END to the keyring."
+ (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id))
+ (key-file (pgg-make-temp-file "pgg"))
+ (args
+ (concat "+verbose=1 +batchmode +language=us -kaf "
+ (shell-quote-argument key-file))))
+ (let ((coding-system-for-write 'raw-text-dos))
+ (write-region start end key-file))
+ (pgg-pgp-process-region start end nil pgg-pgp-program args)
+ (delete-file key-file)
+ (pgg-process-when-success nil)))
+
+(provide 'pgg-pgp)
+
+;;; pgg-pgp.el ends here
--- /dev/null
- ;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;;; pgg-pgp5.el --- PGP 5.* support for PGG.
+
+;; Copyright (C) 1999, 2000, 2002, 2003, 2004,
++;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+
+;; Author: Daiki Ueno <ueno@unixuser.org>
+;; Created: 1999/11/02
+;; Keywords: PGP, OpenPGP
+;; Package: pgg
+;; Obsolete-since: 24.1
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(eval-when-compile
+ (require 'cl) ; for pgg macros
+ (require 'pgg))
+
+(defgroup pgg-pgp5 ()
+ "PGP 5.* interface."
+ :group 'pgg)
+
+(defcustom pgg-pgp5-pgpe-program "pgpe"
+ "PGP 5.* 'pgpe' executable."
+ :group 'pgg-pgp5
+ :type 'string)
+
+(defcustom pgg-pgp5-pgps-program "pgps"
+ "PGP 5.* 'pgps' executable."
+ :group 'pgg-pgp5
+ :type 'string)
+
+(defcustom pgg-pgp5-pgpk-program "pgpk"
+ "PGP 5.* 'pgpk' executable."
+ :group 'pgg-pgp5
+ :type 'string)
+
+(defcustom pgg-pgp5-pgpv-program "pgpv"
+ "PGP 5.* 'pgpv' executable."
+ :group 'pgg-pgp5
+ :type 'string)
+
+(defcustom pgg-pgp5-shell-file-name "/bin/sh"
+ "File name to load inferior shells from.
+Bourne shell or its equivalent \(not tcsh) is needed for \"2>\"."
+ :group 'pgg-pgp5
+ :type 'string)
+
+(defcustom pgg-pgp5-shell-command-switch "-c"
+ "Switch used to have the shell execute its command line argument."
+ :group 'pgg-pgp5
+ :type 'string)
+
+(defcustom pgg-pgp5-extra-args nil
+ "Extra arguments for every PGP 5.* invocation."
+ :group 'pgg-pgp5
+ :type '(choice
+ (const :tag "None" nil)
+ (string :tag "Arguments")))
+
+(defvar pgg-pgp5-user-id nil
+ "PGP 5.* ID of your default identity.")
+
+(defun pgg-pgp5-process-region (start end passphrase program args)
+ (let* ((errors-file-name (pgg-make-temp-file "pgg-errors"))
+ (args
+ (append args
+ pgg-pgp5-extra-args
+ (list (concat "2>" errors-file-name))))
+ (shell-file-name pgg-pgp5-shell-file-name)
+ (shell-command-switch pgg-pgp5-shell-command-switch)
+ (process-environment process-environment)
+ (output-buffer pgg-output-buffer)
+ (errors-buffer pgg-errors-buffer)
+ (process-connection-type nil)
+ process status exit-status)
+ (with-current-buffer (get-buffer-create output-buffer)
+ (buffer-disable-undo)
+ (erase-buffer))
+ (when passphrase
+ (setenv "PGPPASSFD" "0"))
+ (unwind-protect
+ (progn
+ (let ((coding-system-for-read 'binary)
+ (coding-system-for-write 'binary))
+ (setq process
+ (apply #'funcall
+ #'start-process-shell-command "*PGP*" output-buffer
+ program args)))
+ (set-process-sentinel process #'ignore)
+ (when passphrase
+ (process-send-string process (concat passphrase "\n")))
+ (process-send-region process start end)
+ (process-send-eof process)
+ (while (eq 'run (process-status process))
+ (accept-process-output process 5))
+ (setq status (process-status process)
+ exit-status (process-exit-status process))
+ (delete-process process)
+ (with-current-buffer output-buffer
+ (pgg-convert-lbt-region (point-min)(point-max) 'LF)
+
+ (if (memq status '(stop signal))
+ (error "%s exited abnormally: '%s'" program exit-status))
+ (if (= 127 exit-status)
+ (error "%s could not be found" program))
+
+ (set-buffer (get-buffer-create errors-buffer))
+ (buffer-disable-undo)
+ (erase-buffer)
+ (insert-file-contents errors-file-name)))
+ (if (and process (eq 'run (process-status process)))
+ (interrupt-process process))
+ (condition-case nil
+ (delete-file errors-file-name)
+ (file-error nil)))))
+
+(defun pgg-pgp5-lookup-key (string &optional type)
+ "Search keys associated with STRING."
+ (let ((args (list "+language=en" "-l" string)))
+ (with-current-buffer (get-buffer-create pgg-output-buffer)
+ (buffer-disable-undo)
+ (erase-buffer)
+ (apply #'call-process pgg-pgp5-pgpk-program nil t nil args)
+ (goto-char (point-min))
+ (when (re-search-forward "^sec" nil t)
+ (substring
+ (nth 2 (split-string
+ (buffer-substring (match-end 0)(progn (end-of-line)(point)))))
+ 2)))))
+
+(defun pgg-pgp5-encrypt-region (start end recipients &optional sign passphrase)
+ "Encrypt the current region between START and END."
+ (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id))
+ (passphrase (or passphrase
+ (when sign
+ (pgg-read-passphrase
+ (format "PGP passphrase for %s: "
+ pgg-pgp5-user-id)
+ pgg-pgp5-user-id))))
+ (args
+ (append
+ `("+NoBatchInvalidKeys=off" "-fat" "+batchmode=1"
+ ,@(if (or recipients pgg-encrypt-for-me)
+ (apply #'append
+ (mapcar (lambda (rcpt)
+ (list "-r"
+ (concat "\"" rcpt "\"")))
+ (append recipients
+ (if pgg-encrypt-for-me
+ (list pgg-pgp5-user-id)))))))
+ (if sign '("-s" "-u" pgg-pgp5-user-id)))))
+ (pgg-pgp5-process-region start end nil pgg-pgp5-pgpe-program args)
+ (pgg-process-when-success nil)))
+
+(defun pgg-pgp5-decrypt-region (start end &optional passphrase)
+ "Decrypt the current region between START and END."
+ (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id))
+ (passphrase
+ (or passphrase
+ (pgg-read-passphrase
+ (format "PGP passphrase for %s: " pgg-pgp5-user-id)
+ (pgg-pgp5-lookup-key pgg-pgp5-user-id 'encrypt))))
+ (args
+ '("+verbose=1" "+batchmode=1" "+language=us" "-f")))
+ (pgg-pgp5-process-region start end passphrase pgg-pgp5-pgpv-program args)
+ (pgg-process-when-success nil)))
+
+(defun pgg-pgp5-sign-region (start end &optional clearsign passphrase)
+ "Make detached signature from text between START and END."
+ (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id))
+ (passphrase
+ (or passphrase
+ (pgg-read-passphrase
+ (format "PGP passphrase for %s: " pgg-pgp5-user-id)
+ (pgg-pgp5-lookup-key pgg-pgp5-user-id 'sign))))
+ (args
+ (list (if clearsign "-fat" "-fbat")
+ "+verbose=1" "+language=us" "+batchmode=1"
+ "-u" pgg-pgp5-user-id)))
+ (pgg-pgp5-process-region start end passphrase pgg-pgp5-pgps-program args)
+ (pgg-process-when-success
+ (when (re-search-forward "^-+BEGIN PGP SIGNATURE" nil t);XXX
+ (let ((packet
+ (cdr (assq 2 (pgg-parse-armor-region
+ (progn (beginning-of-line 2)
+ (point))
+ (point-max))))))
+ (if pgg-cache-passphrase
+ (pgg-add-passphrase-to-cache
+ (cdr (assq 'key-identifier packet))
+ passphrase)))))))
+
+(defun pgg-pgp5-verify-region (start end &optional signature)
+ "Verify region between START and END as the detached signature SIGNATURE."
+ (let ((orig-file (pgg-make-temp-file "pgg"))
+ (args '("+verbose=1" "+batchmode=1" "+language=us"))
+ (orig-mode (default-file-modes)))
+ (unwind-protect
+ (progn
+ (set-default-file-modes 448)
+ (let ((coding-system-for-write 'binary)
+ jka-compr-compression-info-list jam-zcat-filename-list)
+ (write-region start end orig-file)))
+ (set-default-file-modes orig-mode))
+ (when (stringp signature)
+ (copy-file signature (setq signature (concat orig-file ".asc")))
+ (setq args (append args (list signature))))
+ (pgg-pgp5-process-region (point)(point) nil pgg-pgp5-pgpv-program args)
+ (delete-file orig-file)
+ (if signature (delete-file signature))
+ (with-current-buffer pgg-errors-buffer
+ (goto-char (point-min))
+ (if (re-search-forward "^Good signature" nil t)
+ (progn
+ (set-buffer pgg-output-buffer)
+ (insert-buffer-substring pgg-errors-buffer)
+ t)
+ nil))))
+
+(defun pgg-pgp5-insert-key ()
+ "Insert public key at point."
+ (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id))
+ (args
+ (list "+verbose=1" "+batchmode=1" "+language=us" "-x"
+ (concat "\"" pgg-pgp5-user-id "\""))))
+ (pgg-pgp5-process-region (point)(point) nil pgg-pgp5-pgpk-program args)
+ (insert-buffer-substring pgg-output-buffer)))
+
+(defun pgg-pgp5-snarf-keys-region (start end)
+ "Add all public keys in region between START and END to the keyring."
+ (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id))
+ (key-file (pgg-make-temp-file "pgg"))
+ (args
+ (list "+verbose=1" "+batchmode=1" "+language=us" "-a"
+ key-file)))
+ (let ((coding-system-for-write 'raw-text-dos))
+ (write-region start end key-file))
+ (pgg-pgp5-process-region start end nil pgg-pgp5-pgpk-program args)
+ (delete-file key-file)
+ (pgg-process-when-success nil)))
+
+(provide 'pgg-pgp5)
+
+;;; pgg-pgp5.el ends here
--- /dev/null
- ;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;;; pgg.el --- glue for the various PGP implementations.
+
+;; Copyright (C) 1999, 2000, 2002, 2003, 2004,
++;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+
+;; Author: Daiki Ueno <ueno@unixuser.org>
+;; Symmetric encryption added by: Sascha Wilde <wilde@sha-bang.de>
+;; Created: 1999/10/28
+;; Keywords: PGP
+;; Obsolete-since: 24.1
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'pgg-def)
+(require 'pgg-parse)
+(autoload 'run-at-time "timer")
+
+;; Don't merge these two `eval-when-compile's.
+(eval-when-compile
+ ;; For Emacs <22.2 and XEmacs.
+ (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))
+ (require 'cl))
+
+;;; @ utility functions
+;;;
+
+(eval-when-compile
+ (when (featurep 'xemacs)
+ (defmacro pgg-run-at-time-1 (time repeat function args)
+ (if (condition-case nil
+ (let ((delete-itimer 'delete-itimer)
+ (itimer-driver-start 'itimer-driver-start)
+ (itimer-value 'itimer-value)
+ (start-itimer 'start-itimer))
+ (unless (or (symbol-value 'itimer-process)
+ (symbol-value 'itimer-timer))
+ (funcall itimer-driver-start))
+ ;; Check whether there is a bug to which the difference of
+ ;; the present time and the time when the itimer driver was
+ ;; woken up is subtracted from the initial itimer value.
+ (let* ((inhibit-quit t)
+ (ctime (current-time))
+ (itimer-timer-last-wakeup
+ (prog1
+ ctime
+ (setcar ctime (1- (car ctime)))))
+ (itimer-list nil)
+ (itimer (funcall start-itimer "pgg-run-at-time"
+ 'ignore 5)))
+ (sleep-for 0.1) ;; Accept the timeout interrupt.
+ (prog1
+ (> (funcall itimer-value itimer) 0)
+ (funcall delete-itimer itimer))))
+ (error nil))
+ `(let ((time ,time))
+ (apply #'start-itimer "pgg-run-at-time"
+ ,function (if time (max time 1e-9) 1e-9)
+ ,repeat nil t ,args))
+ `(let ((time ,time)
+ (itimers (list nil)))
+ (setcar
+ itimers
+ (apply #'start-itimer "pgg-run-at-time"
+ (lambda (itimers repeat function &rest args)
+ (let ((itimer (car itimers)))
+ (if repeat
+ (progn
+ (set-itimer-function
+ itimer
+ (lambda (itimer repeat function &rest args)
+ (set-itimer-restart itimer repeat)
+ (set-itimer-function itimer function)
+ (set-itimer-function-arguments itimer args)
+ (apply function args)))
+ (set-itimer-function-arguments
+ itimer
+ (append (list itimer repeat function) args)))
+ (set-itimer-function
+ itimer
+ (lambda (itimer function &rest args)
+ (delete-itimer itimer)
+ (apply function args)))
+ (set-itimer-function-arguments
+ itimer
+ (append (list itimer function) args)))))
+ 1e-9 (if time (max time 1e-9) 1e-9)
+ nil t itimers ,repeat ,function ,args)))))))
+
+(eval-and-compile
+ (if (featurep 'xemacs)
+ (progn
+ (defun pgg-run-at-time (time repeat function &rest args)
+ "Emulating function run as `run-at-time'.
+TIME should be nil meaning now, or a number of seconds from now.
+Return an itimer object which can be used in either `delete-itimer'
+or `cancel-timer'."
+ (pgg-run-at-time-1 time repeat function args))
+ (defun pgg-cancel-timer (timer)
+ "Emulate cancel-timer for xemacs."
+ (let ((delete-itimer 'delete-itimer))
+ (funcall delete-itimer timer))))
+ (defalias 'pgg-run-at-time 'run-at-time)
+ (defalias 'pgg-cancel-timer 'cancel-timer)))
+
+(defun pgg-invoke (func scheme &rest args)
+ (progn
+ (require (intern (format "pgg-%s" scheme)))
+ (apply 'funcall (intern (format "pgg-%s-%s" scheme func)) args)))
+
+(put 'pgg-save-coding-system 'lisp-indent-function 2)
+
+(defmacro pgg-save-coding-system (start end &rest body)
+ `(if (called-interactively-p 'interactive)
+ (let ((buffer (current-buffer)))
+ (with-temp-buffer
+ (let (buffer-undo-list)
+ (insert-buffer-substring buffer ,start ,end)
+ (encode-coding-region (point-min)(point-max)
+ buffer-file-coding-system)
+ (prog1 (save-excursion ,@body)
+ (push nil buffer-undo-list)
+ (ignore-errors (undo))))))
+ (save-restriction
+ (narrow-to-region ,start ,end)
+ ,@body)))
+
+(defun pgg-temp-buffer-show-function (buffer)
+ (let ((window (or (get-buffer-window buffer 'visible)
+ (split-window-vertically))))
+ (set-window-buffer window buffer)
+ (shrink-window-if-larger-than-buffer window)))
+
+;; XXX `pgg-display-output-buffer' is a horrible name for this function.
+;; It should be something like `pgg-situate-output-or-display-error'.
+(defun pgg-display-output-buffer (start end status)
+ "Situate en/decryption results or pop up an error buffer.
+
+Text from START to END is replaced by contents of output buffer if STATUS
+is true, or else the output buffer is displayed."
+ (if status
+ (pgg-situate-output start end)
+ (pgg-display-error-buffer)))
+
+(defun pgg-situate-output (start end)
+ "Place en/decryption result in place of current text from START to END."
+ (delete-region start end)
+ (insert-buffer-substring pgg-output-buffer)
+ (decode-coding-region start (point) buffer-file-coding-system))
+
+(defun pgg-display-error-buffer ()
+ "Pop up an error buffer indicating the reason for an en/decryption failure."
+ (let ((temp-buffer-show-function
+ (function pgg-temp-buffer-show-function)))
+ (with-output-to-temp-buffer pgg-echo-buffer
+ (set-buffer standard-output)
+ (insert-buffer-substring pgg-errors-buffer))))
+
+(defvar pgg-passphrase-cache (make-vector 7 0))
+
+(defvar pgg-pending-timers (make-vector 7 0)
+ "Hash table for managing scheduled pgg cache management timers.
+
+We associate key and timer, so the timer can be cancelled if a new
+timeout for the key is set while an old one is still pending.")
+
+(defun pgg-read-passphrase (prompt &optional key notruncate)
+ "Using PROMPT, obtain passphrase for KEY from cache or user.
+
+Truncate the key to 8 trailing characters unless NOTRUNCATE is true
+\(default false).
+
+Custom variables `pgg-cache-passphrase' and `pgg-passphrase-cache-expiry'
+regulate cache behavior."
+ (or (pgg-read-passphrase-from-cache key notruncate)
+ (read-passwd prompt)))
+
+(defun pgg-read-passphrase-from-cache (key &optional notruncate)
+ "Obtain passphrase for KEY from time-limited passphrase cache.
+
+Truncate the key to 8 trailing characters unless NOTRUNCATE is true
+\(default false).
+
+Custom variables `pgg-cache-passphrase' and `pgg-passphrase-cache-expiry'
+regulate cache behavior."
+ (and pgg-cache-passphrase
+ key (or notruncate
+ (setq key (pgg-truncate-key-identifier key)))
+ (symbol-value (intern-soft key pgg-passphrase-cache))))
+
+(defun pgg-add-passphrase-to-cache (key passphrase &optional notruncate)
+ "Associate KEY with PASSPHRASE in time-limited passphrase cache.
+
+Truncate the key to 8 trailing characters unless NOTRUNCATE is true
+\(default false).
+
+Custom variables `pgg-cache-passphrase' and `pgg-passphrase-cache-expiry'
+regulate cache behavior."
+
+ (let* ((key (if notruncate key (pgg-truncate-key-identifier key)))
+ (interned-timer-key (intern-soft key pgg-pending-timers))
+ (old-timer (symbol-value interned-timer-key))
+ new-timer)
+ (when old-timer
+ (cancel-timer old-timer)
+ (unintern interned-timer-key pgg-pending-timers))
+ (set (intern key pgg-passphrase-cache)
+ passphrase)
+ (set (intern key pgg-pending-timers)
+ (pgg-run-at-time pgg-passphrase-cache-expiry nil
+ #'pgg-remove-passphrase-from-cache
+ key notruncate))))
+
+(if (fboundp 'clear-string)
+ (defalias 'pgg-clear-string 'clear-string)
+ (defun pgg-clear-string (string)
+ (fillarray string ?_)))
+
+(declare-function pgg-clear-string "pgg" (string))
+
+(defun pgg-remove-passphrase-from-cache (key &optional notruncate)
+ "Omit passphrase associated with KEY in time-limited passphrase cache.
+
+Truncate the key to 8 trailing characters unless NOTRUNCATE is true
+\(default false).
+
+This is a no-op if there is not entry for KEY (eg, it's already expired.
+
+The memory for the passphrase is filled with underscores to clear any
+references to it.
+
+Custom variables `pgg-cache-passphrase' and `pgg-passphrase-cache-expiry'
+regulate cache behavior."
+ (let* ((passphrase (pgg-read-passphrase-from-cache key notruncate))
+ (key (if notruncate key (pgg-truncate-key-identifier key)))
+ (interned-timer-key (intern-soft key pgg-pending-timers))
+ (old-timer (symbol-value interned-timer-key)))
+ (when passphrase
+ (pgg-clear-string passphrase)
+ (unintern key pgg-passphrase-cache))
+ (when old-timer
+ (pgg-cancel-timer old-timer)
+ (unintern interned-timer-key pgg-pending-timers))))
+
+(defmacro pgg-convert-lbt-region (start end lbt)
+ `(let ((pgg-conversion-end (set-marker (make-marker) ,end)))
+ (goto-char ,start)
+ (case ,lbt
+ (CRLF
+ (while (progn
+ (end-of-line)
+ (> (marker-position pgg-conversion-end) (point)))
+ (insert "\r")
+ (forward-line 1)))
+ (LF
+ (while (re-search-forward "\r$" pgg-conversion-end t)
+ (replace-match ""))))))
+
+(put 'pgg-as-lbt 'lisp-indent-function 3)
+
+(defmacro pgg-as-lbt (start end lbt &rest body)
+ `(let ((inhibit-read-only t)
+ buffer-read-only
+ buffer-undo-list)
+ (pgg-convert-lbt-region ,start ,end ,lbt)
+ (let ((,end (point)))
+ ,@body)
+ (push nil buffer-undo-list)
+ (ignore-errors (undo))))
+
+(put 'pgg-process-when-success 'lisp-indent-function 0)
+
+(defmacro pgg-process-when-success (&rest body)
+ `(with-current-buffer pgg-output-buffer
+ (if (zerop (buffer-size)) nil ,@body t)))
+
+(defalias 'pgg-make-temp-file
+ (if (fboundp 'make-temp-file)
+ 'make-temp-file
+ (lambda (prefix &optional dir-flag)
+ (let ((file (expand-file-name
+ (make-temp-name prefix)
+ (if (fboundp 'temp-directory)
+ (temp-directory)
+ temporary-file-directory))))
+ (if dir-flag
+ (make-directory file))
+ file))))
+
+;;; @ interface functions
+;;;
+
+;;;###autoload
+(defun pgg-encrypt-region (start end rcpts &optional sign passphrase)
+ "Encrypt the current region between START and END for RCPTS.
+
+If optional argument SIGN is non-nil, do a combined sign and encrypt.
+
+If optional PASSPHRASE is not specified, it will be obtained from the
+passphrase cache or user."
+ (interactive
+ (list (region-beginning)(region-end)
+ (split-string (read-string "Recipients: ") "[ \t,]+")))
+ (let ((status
+ (pgg-save-coding-system start end
+ (pgg-invoke "encrypt-region" (or pgg-scheme pgg-default-scheme)
+ (point-min) (point-max) rcpts sign passphrase))))
+ (when (called-interactively-p 'interactive)
+ (pgg-display-output-buffer start end status))
+ status))
+
+;;;###autoload
+(defun pgg-encrypt-symmetric-region (start end &optional passphrase)
+ "Encrypt the current region between START and END symmetric with passphrase.
+
+If optional PASSPHRASE is not specified, it will be obtained from the
+cache or user."
+ (interactive "r")
+ (let ((status
+ (pgg-save-coding-system start end
+ (pgg-invoke "encrypt-symmetric-region"
+ (or pgg-scheme pgg-default-scheme)
+ (point-min) (point-max) passphrase))))
+ (when (called-interactively-p 'interactive)
+ (pgg-display-output-buffer start end status))
+ status))
+
+;;;###autoload
+(defun pgg-encrypt-symmetric (&optional start end passphrase)
+ "Encrypt the current buffer using a symmetric, rather than key-pair, cipher.
+
+If optional arguments START and END are specified, only encrypt within
+the region.
+
+If optional PASSPHRASE is not specified, it will be obtained from the
+passphrase cache or user."
+ (interactive)
+ (let* ((start (or start (point-min)))
+ (end (or end (point-max)))
+ (status (pgg-encrypt-symmetric-region start end passphrase)))
+ (when (called-interactively-p 'interactive)
+ (pgg-display-output-buffer start end status))
+ status))
+
+;;;###autoload
+(defun pgg-encrypt (rcpts &optional sign start end passphrase)
+ "Encrypt the current buffer for RCPTS.
+
+If optional argument SIGN is non-nil, do a combined sign and encrypt.
+
+If optional arguments START and END are specified, only encrypt within
+the region.
+
+If optional PASSPHRASE is not specified, it will be obtained from the
+passphrase cache or user."
+ (interactive (list (split-string (read-string "Recipients: ") "[ \t,]+")))
+ (let* ((start (or start (point-min)))
+ (end (or end (point-max)))
+ (status (pgg-encrypt-region start end rcpts sign passphrase)))
+ (when (called-interactively-p 'interactive)
+ (pgg-display-output-buffer start end status))
+ status))
+
+;;;###autoload
+(defun pgg-decrypt-region (start end &optional passphrase)
+ "Decrypt the current region between START and END.
+
+If optional PASSPHRASE is not specified, it will be obtained from the
+passphrase cache or user."
+ (interactive "r")
+ (let* ((buf (current-buffer))
+ (status
+ (pgg-save-coding-system start end
+ (pgg-invoke "decrypt-region" (or pgg-scheme pgg-default-scheme)
+ (point-min) (point-max) passphrase))))
+ (when (called-interactively-p 'interactive)
+ (pgg-display-output-buffer start end status))
+ status))
+
+;;;###autoload
+(defun pgg-decrypt (&optional start end passphrase)
+ "Decrypt the current buffer.
+
+If optional arguments START and END are specified, only decrypt within
+the region.
+
+If optional PASSPHRASE is not specified, it will be obtained from the
+passphrase cache or user."
+ (interactive "")
+ (let* ((start (or start (point-min)))
+ (end (or end (point-max)))
+ (status (pgg-decrypt-region start end passphrase)))
+ (when (called-interactively-p 'interactive)
+ (pgg-display-output-buffer start end status))
+ status))
+
+;;;###autoload
+(defun pgg-sign-region (start end &optional cleartext passphrase)
+ "Make the signature from text between START and END.
+
+If the optional 3rd argument CLEARTEXT is non-nil, it does not create
+a detached signature.
+
+If this function is called interactively, CLEARTEXT is enabled
+and the output is displayed.
+
+If optional PASSPHRASE is not specified, it will be obtained from the
+passphrase cache or user."
+ (interactive "r")
+ (let ((status (pgg-save-coding-system start end
+ (pgg-invoke "sign-region" (or pgg-scheme pgg-default-scheme)
+ (point-min) (point-max)
+ (or (called-interactively-p 'interactive)
+ cleartext)
+ passphrase))))
+ (when (called-interactively-p 'interactive)
+ (pgg-display-output-buffer start end status))
+ status))
+
+;;;###autoload
+(defun pgg-sign (&optional cleartext start end passphrase)
+ "Sign the current buffer.
+
+If the optional argument CLEARTEXT is non-nil, it does not create a
+detached signature.
+
+If optional arguments START and END are specified, only sign data
+within the region.
+
+If this function is called interactively, CLEARTEXT is enabled
+and the output is displayed.
+
+If optional PASSPHRASE is not specified, it will be obtained from the
+passphrase cache or user."
+ (interactive "")
+ (let* ((start (or start (point-min)))
+ (end (or end (point-max)))
+ (status (pgg-sign-region start end
+ (or (called-interactively-p 'interactive)
+ cleartext)
+ passphrase)))
+ (when (called-interactively-p 'interactive)
+ (pgg-display-output-buffer start end status))
+ status))
+
+;;;###autoload
+(defun pgg-verify-region (start end &optional signature fetch)
+ "Verify the current region between START and END.
+If the optional 3rd argument SIGNATURE is non-nil, it is treated as
+the detached signature of the current region.
+
+If the optional 4th argument FETCH is non-nil, we attempt to fetch the
+signer's public key from `pgg-default-keyserver-address'."
+ (interactive "r")
+ (let* ((packet
+ (if (null signature) nil
+ (with-temp-buffer
+ (buffer-disable-undo)
+ (unless (featurep 'xemacs)
+ (set-buffer-multibyte nil))
+ (insert-file-contents signature)
+ (cdr (assq 2 (pgg-decode-armor-region
+ (point-min)(point-max)))))))
+ (key (cdr (assq 'key-identifier packet)))
+ status keyserver)
+ (and (stringp key)
+ pgg-query-keyserver
+ (setq key (concat "0x" (pgg-truncate-key-identifier key)))
+ (null (pgg-lookup-key key))
+ (or fetch (called-interactively-p 'interactive))
+ (y-or-n-p (format "Key %s not found; attempt to fetch? " key))
+ (setq keyserver
+ (or (cdr (assq 'preferred-key-server packet))
+ pgg-default-keyserver-address))
+ (pgg-fetch-key keyserver key))
+ (setq status
+ (pgg-save-coding-system start end
+ (pgg-invoke "verify-region" (or pgg-scheme pgg-default-scheme)
+ (point-min) (point-max) signature)))
+ (when (called-interactively-p 'interactive)
+ (let ((temp-buffer-show-function
+ (function pgg-temp-buffer-show-function)))
+ (with-output-to-temp-buffer pgg-echo-buffer
+ (set-buffer standard-output)
+ (insert-buffer-substring (if status pgg-output-buffer
+ pgg-errors-buffer)))))
+ status))
+
+;;;###autoload
+(defun pgg-verify (&optional signature fetch start end)
+ "Verify the current buffer.
+If the optional argument SIGNATURE is non-nil, it is treated as
+the detached signature of the current region.
+If the optional argument FETCH is non-nil, we attempt to fetch the
+signer's public key from `pgg-default-keyserver-address'.
+If optional arguments START and END are specified, only verify data
+within the region."
+ (interactive "")
+ (let* ((start (or start (point-min)))
+ (end (or end (point-max)))
+ (status (pgg-verify-region start end signature fetch)))
+ (when (called-interactively-p 'interactive)
+ (let ((temp-buffer-show-function
+ (function pgg-temp-buffer-show-function)))
+ (with-output-to-temp-buffer pgg-echo-buffer
+ (set-buffer standard-output)
+ (insert-buffer-substring (if status pgg-output-buffer
+ pgg-errors-buffer)))))
+ status))
+
+;;;###autoload
+(defun pgg-insert-key ()
+ "Insert the ASCII armored public key."
+ (interactive)
+ (pgg-invoke "insert-key" (or pgg-scheme pgg-default-scheme)))
+
+;;;###autoload
+(defun pgg-snarf-keys-region (start end)
+ "Import public keys in the current region between START and END."
+ (interactive "r")
+ (pgg-save-coding-system start end
+ (pgg-invoke "snarf-keys-region" (or pgg-scheme pgg-default-scheme)
+ start end)))
+
+;;;###autoload
+(defun pgg-snarf-keys ()
+ "Import public keys in the current buffer."
+ (interactive "")
+ (pgg-snarf-keys-region (point-min) (point-max)))
+
+(defun pgg-lookup-key (string &optional type)
+ (pgg-invoke "lookup-key" (or pgg-scheme pgg-default-scheme) string type))
+
+(defvar pgg-insert-url-function (function pgg-insert-url-with-w3))
+
+(defun pgg-insert-url-with-w3 (url)
+ (ignore-errors
+ (require 'url)
+ (let (buffer-file-name)
+ (url-insert-file-contents url))))
+
+(defvar pgg-insert-url-extra-arguments nil)
+(defvar pgg-insert-url-program nil)
+
+(defun pgg-insert-url-with-program (url)
+ (let ((args (copy-sequence pgg-insert-url-extra-arguments))
+ process)
+ (insert
+ (with-temp-buffer
+ (setq process
+ (apply #'start-process " *PGG url*" (current-buffer)
+ pgg-insert-url-program (nconc args (list url))))
+ (set-process-sentinel process #'ignore)
+ (while (eq 'run (process-status process))
+ (accept-process-output process 5))
+ (delete-process process)
+ (if (and process (eq 'run (process-status process)))
+ (interrupt-process process))
+ (buffer-string)))))
+
+(defun pgg-fetch-key (keyserver key)
+ "Attempt to fetch a KEY from KEYSERVER for addition to PGP or GnuPG keyring."
+ (with-current-buffer (get-buffer-create pgg-output-buffer)
+ (buffer-disable-undo)
+ (erase-buffer)
+ (let ((proto (if (string-match "^[a-zA-Z\\+\\.\\\\-]+:" keyserver)
+ (substring keyserver 0 (1- (match-end 0))))))
+ (save-excursion
+ (funcall pgg-insert-url-function
+ (if proto keyserver
+ (format "http://%s:11371/pks/lookup?op=get&search=%s"
+ keyserver key))))
+ (when (re-search-forward "^-+BEGIN" nil 'last)
+ (delete-region (point-min) (match-beginning 0))
+ (when (re-search-forward "^-+END" nil t)
+ (delete-region (progn (end-of-line) (point))
+ (point-max)))
+ (insert "\n")
+ (with-temp-buffer
+ (insert-buffer-substring pgg-output-buffer)
+ (pgg-snarf-keys-region (point-min)(point-max)))))))
+
+
+(provide 'pgg)
+
+;;; pgg.el ends here
--- /dev/null
- ;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;;; s-region.el --- set region using shift key
+
+;; Copyright (C) 1994, 1995, 2001, 2002, 2003, 2004,
++;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+
+;; Author: Morten Welinder <terra@diku.dk>
+;; Keywords: terminals
+;; Favourite-brand-of-beer: None, I hate beer.
+;; Obsolete-since: 24.1
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Having loaded this code you can set the region by holding down the
+;; shift key and move the cursor to the other end of the region. The
+;; functionality provided by this code is similar to that provided by
+;; the editors of Borland International's compilers for ms-dos.
+
+;; Currently, s-region-move may be bound only to events that are vectors
+;; of length one and whose last element is a symbol. Also, the functions
+;; that are given this kind of overlay should be (interactive "p")
+;; functions.
+
+;; If the following keys are not already bound then...
+;; C-insert is bound to copy-region-as-kill
+;; S-delete is bound to kill-region
+;; S-insert is bound to yank
+
+;;; Code:
+
+(defvar s-region-overlay (make-overlay 1 1))
+(overlay-put s-region-overlay 'face 'region)
+(overlay-put s-region-overlay 'priority 1000000) ; for hilit19
+
+(defun s-region-unshift (key)
+ "Remove shift modifier from last keypress KEY and return that as a key."
+ (if (vectorp key)
+ (let ((last (aref key (1- (length key)))))
+ (if (symbolp last)
+ (let* ((keyname (symbol-name last))
+ (pos (string-match "S-" keyname)))
+ (if pos
+ ;; We skip all initial parts of the event assuming that
+ ;; those are setting up the prefix argument to the command.
+ (vector (intern (concat (substring keyname 0 pos)
+ (substring keyname (+ 2 pos)))))
+ (error "Non-shifted key: %S" key)))
+ (error "Key does not end in a symbol: %S" key)))
+ (error "Non-vector key: %S" key)))
+
+(defun s-region-move-p1 (&rest arg)
+ "This is an overlay function to point-moving keys that are interactive \"p\"."
+ (interactive "p")
+ (apply (function s-region-move) arg))
+
+(defun s-region-move-p2 (&rest arg)
+ "This is an overlay function to point-moving keys that are interactive \"P\"."
+ (interactive "P")
+ (apply (function s-region-move) arg))
+
+(defun s-region-move (&rest arg)
+ (if (if mark-active (not (equal last-command 's-region-move)) t)
+ (set-mark-command nil)
+ (message "")) ; delete the "Mark set" message
+ (setq this-command 's-region-move)
+ (apply (key-binding (s-region-unshift (this-command-keys))) arg)
+ (move-overlay s-region-overlay (mark) (point) (current-buffer))
+ (sit-for 1)
+ (delete-overlay s-region-overlay))
+
+(defun s-region-bind (keylist &optional map)
+ "Bind shifted keys in KEYLIST to `s-region-move-p1' or `s-region-move-p2'.
+Each key in KEYLIST is shifted and bound to one of the `s-region-move'
+functions provided it is already bound to some command or other.
+Optional second argument MAP specifies keymap to add binding to, defaulting
+to global keymap."
+ (let ((p2 (list 'scroll-up 'scroll-down
+ 'beginning-of-buffer 'end-of-buffer)))
+ (or map (setq map global-map))
+ (while keylist
+ (let* ((key (car keylist))
+ (binding (key-binding key)))
+ (if (commandp binding)
+ (define-key
+ map
+ (vector (intern (concat "S-" (symbol-name (aref key 0)))))
+ (cond ((memq binding p2)
+ 's-region-move-p2)
+ (t 's-region-move-p1)))))
+ (setq keylist (cdr keylist)))))
+
+;; Single keys (plus modifiers) only!
+(s-region-bind
+ (list [right] [left] [up] [down]
+ [C-left] [C-right] [C-up] [C-down]
+ [M-left] [M-right] [M-up] [M-down]
+ [next] [previous] [home] [end]
+ [C-next] [C-previous] [C-home] [C-end]
+ [M-next] [M-previous] [M-home] [M-end]))
+
+(or (global-key-binding [C-insert])
+ (global-set-key [C-insert] 'copy-region-as-kill))
+(or (global-key-binding [S-delete])
+ (global-set-key [S-delete] 'kill-region))
+(or (global-key-binding [S-insert])
+ (global-set-key [S-insert] 'yank))
+
+(provide 's-region)
+
+;; arch-tag: a471e912-18d7-4247-a29b-2100bca180ff
+;;; s-region.el ends here
--- /dev/null
- ;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;;; sregex.el --- symbolic regular expressions
+
+;; Copyright (C) 1997, 1998, 2000, 2001, 2002, 2003, 2004,
++;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+
+;; Author: Bob Glickstein <bobg+sregex@zanshin.com>
+;; Maintainer: Bob Glickstein <bobg+sregex@zanshin.com>
+;; Keywords: extensions
+;; Obsolete-since: 24.1
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This package allows you to write regular expressions using a
+;; totally new, Lisp-like syntax.
+
+;; A "symbolic regular expression" (sregex for short) is a Lisp form
+;; that, when evaluated, produces the string form of the specified
+;; regular expression. Here's a simple example:
+
+;; (sregexq (or "Bob" "Robert")) => "Bob\\|Robert"
+
+;; As you can see, an sregex is specified by placing one or more
+;; special clauses in a call to `sregexq'. The clause in this case is
+;; the `or' of two strings (not to be confused with the Lisp function
+;; `or'). The list of allowable clauses appears below.
+
+;; With sregex, it is never necessary to "escape" magic characters
+;; that are meant to be taken literally; that happens automatically.
+;; For example:
+
+;; (sregexq "M*A*S*H") => "M\\*A\\*S\\*H"
+
+;; It is also unnecessary to "group" parts of the expression together
+;; to overcome operator precedence; that also happens automatically.
+;; For example:
+
+;; (sregexq (opt (or "Bob" "Robert"))) => "\\(?:Bob\\|Robert\\)?"
+
+;; It *is* possible to group parts of the expression in order to refer
+;; to them with numbered backreferences:
+
+;; (sregexq (group (or "Go" "Run"))
+;; ", Spot, "
+;; (backref 1)) => "\\(Go\\|Run\\), Spot, \\1"
+
+;; `sregexq' is a macro. Each time it is used, it constructs a simple
+;; Lisp expression that then invokes a moderately complex engine to
+;; interpret the sregex and render the string form. Because of this,
+;; I don't recommend sprinkling calls to `sregexq' throughout your
+;; code, the way one normally does with string regexes (which are
+;; cheap to evaluate). Instead, it's wiser to precompute the regexes
+;; you need wherever possible instead of repeatedly constructing the
+;; same ones over and over. Example:
+
+;; (let ((field-regex (sregexq (opt "resent-")
+;; (or "to" "cc" "bcc"))))
+;; ...
+;; (while ...
+;; ...
+;; (re-search-forward field-regex ...)
+;; ...))
+
+;; The arguments to `sregexq' are automatically quoted, but the
+;; flipside of this is that it is not straightforward to include
+;; computed (i.e., non-constant) values in `sregexq' expressions. So
+;; `sregex' is a function that is like `sregexq' but which does not
+;; automatically quote its values. Literal sregex clauses must be
+;; explicitly quoted like so:
+
+;; (sregex '(or "Bob" "Robert")) => "Bob\\|Robert"
+
+;; but computed clauses can be included easily, allowing for the reuse
+;; of common clauses:
+
+;; (let ((dotstar '(0+ any))
+;; (whitespace '(1+ (syntax ?-)))
+;; (digits '(1+ (char (?0 . ?9)))))
+;; (sregex 'bol dotstar ":" whitespace digits)) => "^.*:\\s-+[0-9]+"
+
+;; To use this package in a Lisp program, simply (require 'sregex).
+
+;; Here are the clauses allowed in an `sregex' or `sregexq'
+;; expression:
+
+;; - a string
+;; This stands for the literal string. If it contains
+;; metacharacters, they will be escaped in the resulting regex
+;; (using `regexp-quote').
+
+;; - the symbol `any'
+;; This stands for ".", a regex matching any character except
+;; newline.
+
+;; - the symbol `bol'
+;; Stands for "^", matching the empty string at the beginning of a line
+
+;; - the symbol `eol'
+;; Stands for "$", matching the empty string at the end of a line
+
+;; - (group CLAUSE ...)
+;; Groups the given CLAUSEs using "\\(" and "\\)".
+
+;; - (sequence CLAUSE ...)
+
+;; Groups the given CLAUSEs; may or may not use "\\(?:" and "\\)".
+;; Clauses grouped by `sequence' do not count for purposes of
+;; numbering backreferences. Use `sequence' in situations like
+;; this:
+
+;; (sregexq (or "dog" "cat"
+;; (sequence (opt "sea ") "monkey")))
+;; => "dog\\|cat\\|\\(?:sea \\)?monkey"
+
+;; where a single `or' alternate needs to contain multiple
+;; subclauses.
+
+;; - (backref N)
+;; Matches the same string previously matched by the Nth "group" in
+;; the same sregex. N is a positive integer.
+
+;; - (or CLAUSE ...)
+;; Matches any one of the CLAUSEs by separating them with "\\|".
+
+;; - (0+ CLAUSE ...)
+;; Concatenates the given CLAUSEs and matches zero or more
+;; occurrences by appending "*".
+
+;; - (1+ CLAUSE ...)
+;; Concatenates the given CLAUSEs and matches one or more
+;; occurrences by appending "+".
+
+;; - (opt CLAUSE ...)
+;; Concatenates the given CLAUSEs and matches zero or one occurrence
+;; by appending "?".
+
+;; - (repeat MIN MAX CLAUSE ...)
+;; Concatenates the given CLAUSEs and constructs a regex matching at
+;; least MIN occurrences and at most MAX occurrences. MIN must be a
+;; non-negative integer. MAX must be a non-negative integer greater
+;; than or equal to MIN; or MAX can be nil to mean "infinity."
+
+;; - (char CHAR-CLAUSE ...)
+;; Creates a "character class" matching one character from the given
+;; set. See below for how to construct a CHAR-CLAUSE.
+
+;; - (not-char CHAR-CLAUSE ...)
+;; Creates a "character class" matching any one character not in the
+;; given set. See below for how to construct a CHAR-CLAUSE.
+
+;; - the symbol `bot'
+;; Stands for "\\`", matching the empty string at the beginning of
+;; text (beginning of a string or of a buffer).
+
+;; - the symbol `eot'
+;; Stands for "\\'", matching the empty string at the end of text.
+
+;; - the symbol `point'
+;; Stands for "\\=", matching the empty string at point.
+
+;; - the symbol `word-boundary'
+;; Stands for "\\b", matching the empty string at the beginning or
+;; end of a word.
+
+;; - the symbol `not-word-boundary'
+;; Stands for "\\B", matching the empty string not at the beginning
+;; or end of a word.
+
+;; - the symbol `bow'
+;; Stands for "\\<", matching the empty string at the beginning of a
+;; word.
+
+;; - the symbol `eow'
+;; Stands for "\\>", matching the empty string at the end of a word.
+
+;; - the symbol `wordchar'
+;; Stands for the regex "\\w", matching a word-constituent character
+;; (as determined by the current syntax table)
+
+;; - the symbol `not-wordchar'
+;; Stands for the regex "\\W", matching a non-word-constituent
+;; character.
+
+;; - (syntax CODE)
+;; Stands for the regex "\\sCODE", where CODE is a syntax table code
+;; (a single character). Matches any character with the requested
+;; syntax.
+
+;; - (not-syntax CODE)
+;; Stands for the regex "\\SCODE", where CODE is a syntax table code
+;; (a single character). Matches any character without the
+;; requested syntax.
+
+;; - (regex REGEX)
+;; This is a "trapdoor" for including ordinary regular expression
+;; strings in the result. Some regular expressions are clearer when
+;; written the old way: "[a-z]" vs. (sregexq (char (?a . ?z))), for
+;; instance. However, see the note under "Bugs," below.
+
+;; Each CHAR-CLAUSE that is passed to (char ...) and (not-char ...)
+;; has one of the following forms:
+
+;; - a character
+;; Adds that character to the set.
+
+;; - a string
+;; Adds all the characters in the string to the set.
+
+;; - A pair (MIN . MAX)
+;; Where MIN and MAX are characters, adds the range of characters
+;; from MIN through MAX to the set.
+
+;;; To do:
+
+;; An earlier version of this package could optionally translate the
+;; symbolic regex into other languages' syntaxes, e.g. Perl. For
+;; instance, with Perl syntax selected, (sregexq (or "ab" "cd")) would
+;; yield "ab|cd" instead of "ab\\|cd". It might be useful to restore
+;; such a facility.
+
+;; - handle multibyte chars in sregex--char-aux
+;; - add support for character classes ([:blank:], ...)
+;; - add support for non-greedy operators *? and +?
+;; - bug: (sregexq (opt (opt ?a))) returns "a??" which is a non-greedy "a?"
+
+;;; Bugs:
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+;; Compatibility code for when we didn't have shy-groups
+(defvar sregex--current-sregex nil)
+(defun sregex-info () nil)
+(defmacro sregex-save-match-data (&rest forms) (cons 'save-match-data forms))
+(defun sregex-replace-match (r &optional f l str subexp x)
+ (replace-match r f l str subexp))
+(defun sregex-match-string (c &optional i x) (match-string c i))
+(defun sregex-match-string-no-properties (count &optional in-string sregex)
+ (match-string-no-properties count in-string))
+(defun sregex-match-beginning (count &optional sregex) (match-beginning count))
+(defun sregex-match-end (count &optional sregex) (match-end count))
+(defun sregex-match-data (&optional sregex) (match-data))
+(defun sregex-backref-num (n &optional sregex) n)
+
+
+(defun sregex (&rest exps)
+ "Symbolic regular expression interpreter.
+This is exactly like `sregexq' (q.v.) except that it evaluates all its
+arguments, so literal sregex clauses must be quoted. For example:
+
+ (sregex '(or \"Bob\" \"Robert\")) => \"Bob\\\\|Robert\"
+
+An argument-evaluating sregex interpreter lets you reuse sregex
+subexpressions:
+
+ (let ((dotstar '(0+ any))
+ (whitespace '(1+ (syntax ?-)))
+ (digits '(1+ (char (?0 . ?9)))))
+ (sregex 'bol dotstar \":\" whitespace digits)) => \"^.*:\\\\s-+[0-9]+\""
+ (sregex--sequence exps nil))
+
+(defmacro sregexq (&rest exps)
+ "Symbolic regular expression interpreter.
+This macro allows you to specify a regular expression (regexp) in
+symbolic form, and converts it into the string form required by Emacs's
+regex functions such as `re-search-forward' and `looking-at'. Here is
+a simple example:
+
+ (sregexq (or \"Bob\" \"Robert\")) => \"Bob\\\\|Robert\"
+
+As you can see, an sregex is specified by placing one or more special
+clauses in a call to `sregexq'. The clause in this case is the `or'
+of two strings (not to be confused with the Lisp function `or'). The
+list of allowable clauses appears below.
+
+With `sregex', it is never necessary to \"escape\" magic characters
+that are meant to be taken literally; that happens automatically.
+For example:
+
+ (sregexq \"M*A*S*H\") => \"M\\\\*A\\\\*S\\\\*H\"
+
+It is also unnecessary to \"group\" parts of the expression together
+to overcome operator precedence; that also happens automatically.
+For example:
+
+ (sregexq (opt (or \"Bob\" \"Robert\"))) => \"\\\\(Bob\\\\|Robert\\\\)?\"
+
+It *is* possible to group parts of the expression in order to refer
+to them with numbered backreferences:
+
+ (sregexq (group (or \"Go\" \"Run\"))
+ \", Spot, \"
+ (backref 1)) => \"\\\\(Go\\\\|Run\\\\), Spot, \\\\1\"
+
+If `sregexq' needs to introduce its own grouping parentheses, it will
+automatically renumber your backreferences:
+
+ (sregexq (opt \"resent-\")
+ (group (or \"to\" \"cc\" \"bcc\"))
+ \": \"
+ (backref 1)) => \"\\\\(resent-\\\\)?\\\\(to\\\\|cc\\\\|bcc\\\\): \\\\2\"
+
+`sregexq' is a macro. Each time it is used, it constructs a simple
+Lisp expression that then invokes a moderately complex engine to
+interpret the sregex and render the string form. Because of this, I
+don't recommend sprinkling calls to `sregexq' throughout your code,
+the way one normally does with string regexes (which are cheap to
+evaluate). Instead, it's wiser to precompute the regexes you need
+wherever possible instead of repeatedly constructing the same ones
+over and over. Example:
+
+ (let ((field-regex (sregexq (opt \"resent-\")
+ (or \"to\" \"cc\" \"bcc\"))))
+ ...
+ (while ...
+ ...
+ (re-search-forward field-regex ...)
+ ...))
+
+The arguments to `sregexq' are automatically quoted, but the
+flipside of this is that it is not straightforward to include
+computed (i.e., non-constant) values in `sregexq' expressions. So
+`sregex' is a function that is like `sregexq' but which does not
+automatically quote its values. Literal sregex clauses must be
+explicitly quoted like so:
+
+ (sregex '(or \"Bob\" \"Robert\")) => \"Bob\\\\|Robert\"
+
+but computed clauses can be included easily, allowing for the reuse
+of common clauses:
+
+ (let ((dotstar '(0+ any))
+ (whitespace '(1+ (syntax ?-)))
+ (digits '(1+ (char (?0 . ?9)))))
+ (sregex 'bol dotstar \":\" whitespace digits)) => \"^.*:\\\\s-+[0-9]+\"
+
+Here are the clauses allowed in an `sregex' or `sregexq' expression:
+
+- a string
+ This stands for the literal string. If it contains
+ metacharacters, they will be escaped in the resulting regex
+ (using `regexp-quote').
+
+- the symbol `any'
+ This stands for \".\", a regex matching any character except
+ newline.
+
+- the symbol `bol'
+ Stands for \"^\", matching the empty string at the beginning of a line
+
+- the symbol `eol'
+ Stands for \"$\", matching the empty string at the end of a line
+
+- (group CLAUSE ...)
+ Groups the given CLAUSEs using \"\\\\(\" and \"\\\\)\".
+
+- (sequence CLAUSE ...)
+
+ Groups the given CLAUSEs; may or may not use \"\\\\(\" and \"\\\\)\".
+ Clauses grouped by `sequence' do not count for purposes of
+ numbering backreferences. Use `sequence' in situations like
+ this:
+
+ (sregexq (or \"dog\" \"cat\"
+ (sequence (opt \"sea \") \"monkey\")))
+ => \"dog\\\\|cat\\\\|\\\\(?:sea \\\\)?monkey\"
+
+ where a single `or' alternate needs to contain multiple
+ subclauses.
+
+- (backref N)
+ Matches the same string previously matched by the Nth \"group\" in
+ the same sregex. N is a positive integer.
+
+- (or CLAUSE ...)
+ Matches any one of the CLAUSEs by separating them with \"\\\\|\".
+
+- (0+ CLAUSE ...)
+ Concatenates the given CLAUSEs and matches zero or more
+ occurrences by appending \"*\".
+
+- (1+ CLAUSE ...)
+ Concatenates the given CLAUSEs and matches one or more
+ occurrences by appending \"+\".
+
+- (opt CLAUSE ...)
+ Concatenates the given CLAUSEs and matches zero or one occurrence
+ by appending \"?\".
+
+- (repeat MIN MAX CLAUSE ...)
+ Concatenates the given CLAUSEs and constructs a regex matching at
+ least MIN occurrences and at most MAX occurrences. MIN must be a
+ non-negative integer. MAX must be a non-negative integer greater
+ than or equal to MIN; or MAX can be nil to mean \"infinity.\"
+
+- (char CHAR-CLAUSE ...)
+ Creates a \"character class\" matching one character from the given
+ set. See below for how to construct a CHAR-CLAUSE.
+
+- (not-char CHAR-CLAUSE ...)
+ Creates a \"character class\" matching any one character not in the
+ given set. See below for how to construct a CHAR-CLAUSE.
+
+- the symbol `bot'
+ Stands for \"\\\\`\", matching the empty string at the beginning of
+ text (beginning of a string or of a buffer).
+
+- the symbol `eot'
+ Stands for \"\\\\'\", matching the empty string at the end of text.
+
+- the symbol `point'
+ Stands for \"\\\\=\\=\", matching the empty string at point.
+
+- the symbol `word-boundary'
+ Stands for \"\\\\b\", matching the empty string at the beginning or
+ end of a word.
+
+- the symbol `not-word-boundary'
+ Stands for \"\\\\B\", matching the empty string not at the beginning
+ or end of a word.
+
+- the symbol `bow'
+ Stands for \"\\\\=\\<\", matching the empty string at the beginning of a
+ word.
+
+- the symbol `eow'
+ Stands for \"\\\\=\\>\", matching the empty string at the end of a word.
+
+- the symbol `wordchar'
+ Stands for the regex \"\\\\w\", matching a word-constituent character
+ (as determined by the current syntax table)
+
+- the symbol `not-wordchar'
+ Stands for the regex \"\\\\W\", matching a non-word-constituent
+ character.
+
+- (syntax CODE)
+ Stands for the regex \"\\\\sCODE\", where CODE is a syntax table code
+ (a single character). Matches any character with the requested
+ syntax.
+
+- (not-syntax CODE)
+ Stands for the regex \"\\\\SCODE\", where CODE is a syntax table code
+ (a single character). Matches any character without the
+ requested syntax.
+
+- (regex REGEX)
+ This is a \"trapdoor\" for including ordinary regular expression
+ strings in the result. Some regular expressions are clearer when
+ written the old way: \"[a-z]\" vs. (sregexq (char (?a . ?z))), for
+ instance.
+
+Each CHAR-CLAUSE that is passed to (char ...) and (not-char ...)
+has one of the following forms:
+
+- a character
+ Adds that character to the set.
+
+- a string
+ Adds all the characters in the string to the set.
+
+- A pair (MIN . MAX)
+ Where MIN and MAX are characters, adds the range of characters
+ from MIN through MAX to the set."
+ `(apply 'sregex ',exps))
+
+(defun sregex--engine (exp combine)
+ (cond
+ ((stringp exp)
+ (if (and combine
+ (eq combine 'suffix)
+ (/= (length exp) 1))
+ (concat "\\(?:" (regexp-quote exp) "\\)")
+ (regexp-quote exp)))
+ ((symbolp exp)
+ (ecase exp
+ (any ".")
+ (bol "^")
+ (eol "$")
+ (wordchar "\\w")
+ (not-wordchar "\\W")
+ (bot "\\`")
+ (eot "\\'")
+ (point "\\=")
+ (word-boundary "\\b")
+ (not-word-boundary "\\B")
+ (bow "\\<")
+ (eow "\\>")))
+ ((consp exp)
+ (funcall (intern (concat "sregex--"
+ (symbol-name (car exp))))
+ (cdr exp)
+ combine))
+ (t (error "Invalid expression: %s" exp))))
+
+(defun sregex--sequence (exps combine)
+ (if (= (length exps) 1) (sregex--engine (car exps) combine)
+ (let ((re (mapconcat
+ (lambda (e) (sregex--engine e 'concat))
+ exps "")))
+ (if (eq combine 'suffix)
+ (concat "\\(?:" re "\\)")
+ re))))
+
+(defun sregex--or (exps combine)
+ (if (= (length exps) 1) (sregex--engine (car exps) combine)
+ (let ((re (mapconcat
+ (lambda (e) (sregex--engine e 'or))
+ exps "\\|")))
+ (if (not (eq combine 'or))
+ (concat "\\(?:" re "\\)")
+ re))))
+
+(defun sregex--group (exps combine) (concat "\\(" (sregex--sequence exps nil) "\\)"))
+
+(defun sregex--backref (exps combine) (concat "\\" (int-to-string (car exps))))
+(defun sregex--opt (exps combine) (concat (sregex--sequence exps 'suffix) "?"))
+(defun sregex--0+ (exps combine) (concat (sregex--sequence exps 'suffix) "*"))
+(defun sregex--1+ (exps combine) (concat (sregex--sequence exps 'suffix) "+"))
+
+(defun sregex--char (exps combine) (sregex--char-aux nil exps))
+(defun sregex--not-char (exps combine) (sregex--char-aux t exps))
+
+(defun sregex--syntax (exps combine) (format "\\s%c" (car exps)))
+(defun sregex--not-syntax (exps combine) (format "\\S%c" (car exps)))
+
+(defun sregex--regex (exps combine)
+ (if combine (concat "\\(?:" (car exps) "\\)") (car exps)))
+
+(defun sregex--repeat (exps combine)
+ (let* ((min (or (pop exps) 0))
+ (minstr (number-to-string min))
+ (max (pop exps)))
+ (concat (sregex--sequence exps 'suffix)
+ (concat "\\{" minstr ","
+ (when max (number-to-string max)) "\\}"))))
+
+(defun sregex--char-range (start end)
+ (let ((startc (char-to-string start))
+ (endc (char-to-string end)))
+ (cond
+ ((> end (+ start 2)) (concat startc "-" endc))
+ ((> end (+ start 1)) (concat startc (char-to-string (1+ start)) endc))
+ ((> end start) (concat startc endc))
+ (t startc))))
+
+(defun sregex--char-aux (complement args)
+ ;; regex-opt does the same, we should join effort.
+ (let ((chars (make-bool-vector 256 nil))) ; Yeah, right!
+ (dolist (arg args)
+ (cond ((integerp arg) (aset chars arg t))
+ ((stringp arg) (mapc (lambda (c) (aset chars c t)) arg))
+ ((consp arg)
+ (let ((start (car arg))
+ (end (cdr arg)))
+ (when (> start end)
+ (let ((tmp start)) (setq start end) (setq end tmp)))
+ ;; now start <= end
+ (let ((i start))
+ (while (<= i end)
+ (aset chars i t)
+ (setq i (1+ i))))))))
+ ;; now chars is a map of the characters in the class
+ (let ((caret (aref chars ?^))
+ (dash (aref chars ?-))
+ (class (if (aref chars ?\]) "]" "")))
+ (aset chars ?^ nil)
+ (aset chars ?- nil)
+ (aset chars ?\] nil)
+
+ (let (start end)
+ (dotimes (i 256)
+ (if (aref chars i)
+ (progn
+ (unless start (setq start i))
+ (setq end i)
+ (aset chars i nil))
+ (when start
+ (setq class (concat class (sregex--char-range start end)))
+ (setq start nil))))
+ (if start
+ (setq class (concat class (sregex--char-range start end)))))
+
+ (if (> (length class) 0)
+ (setq class (concat class (if caret "^") (if dash "-")))
+ (setq class (concat class (if dash "-") (if caret "^"))))
+ (if (and (not complement) (= (length class) 1))
+ (regexp-quote class)
+ (concat "[" (if complement "^") class "]")))))
+
+(provide 'sregex)
+
+;; arch-tag: 460c1f5a-eb6e-42ec-a451-ffac78bdf492
+;;; sregex.el ends here
;;; pcmpl-cvs.el --- functions for dealing with cvs completions
;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
- ;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+ ;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
+;; Package: pcomplete
;; This file is part of GNU Emacs.
;;; pcmpl-gnu.el --- completions for GNU project tools
;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
- ;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+ ;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Package: pcomplete
+
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;;; pcmpl-linux.el --- functions for dealing with GNU/Linux completions
;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
- ;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+ ;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Package: pcomplete
+
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;;; pcmpl-rpm.el --- functions for dealing with rpm completions
;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
- ;; 2008, 2009, 2010 Free Software Foundation, Inc.
+ ;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Package: pcomplete
+
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;;; pcmpl-unix.el --- standard UNIX completions
;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
- ;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+ ;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Package: pcomplete
+
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;;; octave-mod.el --- editing Octave source files under Emacs
- ;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
- ;; 2009, 2010 Free Software Foundation, Inc.
+ ;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
+ ;; Free Software Foundation, Inc.
;; Author: Kurt Hornik <Kurt.Hornik@wu-wien.ac.at>
-;; Author: John Eaton <jwe@bevo.che.wisc.edu>
+;; Author: John Eaton <jwe@octave.org>
;; Maintainer: Kurt Hornik <Kurt.Hornik@wu-wien.ac.at>
;; Keywords: languages
;;; select.el --- lisp portion of standard selection support
- ;; 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 1994, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
++;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+
;; Maintainer: FSF
;; Keywords: internal
;;; tabify.el --- tab conversion commands for Emacs
;; Copyright (C) 1985, 1994, 2001, 2002, 2003, 2004,
- ;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+ ;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
;; Maintainer: FSF
+;; Package: emacs
;; This file is part of GNU Emacs.
;;; tool-bar.el --- setting up the tool bar
-
- ;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
- ;; 2009, 2010 Free Software Foundation, Inc.
-
+ ;;
+ ;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
+ ;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ ;;
;; Author: Dave Love <fx@gnu.org>
;; Keywords: mouse frames
+;; Package: emacs
;; This file is part of GNU Emacs.
;; Local variables:
;; coding: utf-8
-;; add-log-time-zone-rule: t
;; End:
- Copyright (C) 1999, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009,
- 2010 Free Software Foundation, Inc.
+ Copyright (C) 1999, 2001, 2002, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
-;;; url-cookie.el --- Netscape Cookie support
+;;; url-cookie.el --- URL cookie support
;; Copyright (C) 1996, 1997, 1998, 1999, 2004, 2005, 2006, 2007, 2008,
- ;; 2009, 2010 Free Software Foundation, Inc.
+ ;; 2009, 2010, 2011 Free Software Foundation, Inc.
;; Keywords: comm, data, processes, hypermedia
--- /dev/null
- ;; 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;;; 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, 2011
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This facility is documented in the Emacs Manual.
+
+;; Todo:
+
+;; - Find/use/create _MTN/log if there's a _MTN directory.
+;; - Find/use/create ++log.* if there's an {arch} directory.
+;; - Use an open *VC-Log* or *cvs-commit* buffer if it's related to the
+;; source file.
+;; - Don't add TAB indents (and username?) if inserting entries in those
+;; special places.
+
+;;; Code:
+
+(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 (derived-mode-p '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
+ (let* ((dir (file-name-directory log-file))
+ (rel (file-relative-name buffer-file dir)))
+ ;; Sometimes with symlinks, the two buffers may have names that
+ ;; appear to belong to different directory trees. So check the
+ ;; file-truenames, to see if we get a better result.
+ (if (not (string-match "\\`\\.\\./" rel))
+ rel
+ (let ((new (file-relative-name (file-truename buffer-file)
+ (file-truename dir))))
+ (if (< (length new) (length rel))
+ new rel)))))
+ ;; If we have a backup file, it's presumably because we're
+ ;; comparing old and new versions (e.g. for deleted
+ ;; functions) and we'll want to use the original name.
+ (if (backup-file-name-p buffer-file)
+ (file-name-sans-versions buffer-file)
+ buffer-file))))
+
+;;;###autoload
+(defun add-change-log-entry (&optional whoami file-name other-window new-entry
+ put-new-entry-on-new-line)
+ "Find change log file, and add an entry for today and an item for this file.
+Optional arg WHOAMI (interactive prefix) non-nil means prompt for user
+name and email (stored in `add-log-full-name' and `add-log-mailing-address').
+
+Second arg FILE-NAME is file name of the change log.
+If nil, use the value of `change-log-default-name'.
+
+Third arg OTHER-WINDOW non-nil means visit in other window.
+
+Fourth arg NEW-ENTRY non-nil means always create a new entry at the front;
+never append to an existing entry. Option `add-log-keep-changes-together'
+otherwise affects whether a new entry is created.
+
+Fifth arg PUT-NEW-ENTRY-ON-NEW-LINE non-nil means that if a new
+entry is created, put it on a new line by itself, do not put it
+after a comma on an existing line.
+
+Option `add-log-always-start-new-record' non-nil means always create a
+new record, even when the last record was made on the same date and by
+the same person.
+
+The change log file can start with a copyright notice and a copying
+permission notice. The first blank line indicates the end of these
+notices.
+
+Today's date is calculated according to `add-log-time-zone-rule' if
+non-nil, otherwise in local time."
+ (interactive (list current-prefix-arg
+ (prompt-for-change-log-name)))
+ (let* ((defun (add-log-current-defun))
+ (version (and change-log-version-info-enabled
+ (change-log-version-number-search)))
+ (buf-file-name (if add-log-buffer-file-name-function
+ (funcall add-log-buffer-file-name-function)
+ buffer-file-name))
+ (buffer-file (if buf-file-name (expand-file-name buf-file-name)))
+ (file-name (expand-file-name (find-change-log file-name buffer-file)))
+ ;; Set ITEM to the file name to use in the new item.
+ (item (add-log-file-name buffer-file file-name)))
+
+ (unless (equal file-name buffer-file-name)
+ (cond
+ ((equal file-name (buffer-file-name (window-buffer (selected-window))))
+ ;; If the selected window already shows the desired buffer don't show
+ ;; it again (particularly important if other-window is true).
+ ;; This is important for diff-add-change-log-entries-other-window.
+ (set-buffer (window-buffer (selected-window))))
+ ((or other-window (window-dedicated-p (selected-window)))
+ (find-file-other-window file-name))
+ (t (find-file file-name))))
+ (or (derived-mode-p 'change-log-mode)
+ (change-log-mode))
+ (undo-boundary)
+ (goto-char (point-min))
+
+ (let ((full-name (or add-log-full-name (user-full-name)))
+ (mailing-address (or add-log-mailing-address user-mail-address)))
+
+ (when whoami
+ (setq full-name (read-string "Full name: " full-name))
+ ;; Note that some sites have room and phone number fields in
+ ;; full name which look silly when inserted. Rather than do
+ ;; anything about that here, let user give prefix argument so that
+ ;; s/he can edit the full name field in prompter if s/he wants.
+ (setq mailing-address
+ (read-string "Mailing address: " mailing-address)))
+
+ ;; If file starts with a copyright and permission notice, skip them.
+ ;; Assume they end at first blank line.
+ (when (looking-at "Copyright")
+ (search-forward "\n\n")
+ (skip-chars-forward "\n"))
+
+ ;; Advance into first entry if it is usable; else make new one.
+ (let ((new-entries
+ (mapcar (lambda (addr)
+ (concat
+ (if (stringp add-log-time-zone-rule)
+ (let ((tz (getenv "TZ")))
+ (unwind-protect
+ (progn
+ (set-time-zone-rule add-log-time-zone-rule)
+ (funcall add-log-time-format))
+ (set-time-zone-rule tz)))
+ (funcall add-log-time-format))
+ " " full-name
+ " <" addr ">"))
+ (if (consp mailing-address)
+ mailing-address
+ (list mailing-address)))))
+ (if (and (not add-log-always-start-new-record)
+ (let ((hit nil))
+ (dolist (entry new-entries hit)
+ (when (looking-at (regexp-quote entry))
+ (setq hit t)))))
+ (forward-line 1)
+ (insert (nth (random (length new-entries))
+ new-entries)
+ (if use-hard-newlines hard-newline "\n")
+ (if use-hard-newlines hard-newline "\n"))
+ (forward-line -1))))
+
+ ;; Determine where we should stop searching for a usable
+ ;; item to add to, within this entry.
+ (let ((bound
+ (save-excursion
+ (if (looking-at "\n*[^\n* \t]")
+ (skip-chars-forward "\n")
+ (if add-log-keep-changes-together
+ (forward-page) ; page delimits entries for date
+ (forward-paragraph))) ; paragraph delimits entries for file
+ (point))))
+
+ ;; Now insert the new line for this item.
+ (cond ((re-search-forward "^\\s *\\*\\s *$" bound t)
+ ;; Put this file name into the existing empty item.
+ (if item
+ (insert item)))
+ ((and (not new-entry)
+ (let (case-fold-search)
+ (re-search-forward
+ (concat (regexp-quote (concat "* " item))
+ ;; Don't accept `foo.bar' when
+ ;; looking for `foo':
+ "\\(\\s \\|[(),:]\\)")
+ bound t)))
+ ;; Add to the existing item for the same file.
+ (re-search-forward "^\\s *$\\|^\\s \\*")
+ (goto-char (match-beginning 0))
+ ;; Delete excess empty lines; make just 2.
+ (while (and (not (eobp)) (looking-at "^\\s *$"))
+ (delete-region (point) (line-beginning-position 2)))
+ (insert (if use-hard-newlines hard-newline "\n")
+ (if use-hard-newlines hard-newline "\n"))
+ (forward-line -2)
+ (indent-relative-maybe))
+ (t
+ ;; Make a new item.
+ (while (looking-at "\\sW")
+ (forward-line 1))
+ (while (and (not (eobp)) (looking-at "^\\s *$"))
+ (delete-region (point) (line-beginning-position 2)))
+ (insert (if use-hard-newlines hard-newline "\n")
+ (if use-hard-newlines hard-newline "\n")
+ (if use-hard-newlines hard-newline "\n"))
+ (forward-line -2)
+ (indent-to left-margin)
+ (insert "* ")
+ (if item (insert item)))))
+ ;; Now insert the function name, if we have one.
+ ;; Point is at the item for this file,
+ ;; either at the end of the line or at the first blank line.
+ (if (not defun)
+ ;; No function name, so put in a colon unless we have just a star.
+ (unless (save-excursion
+ (beginning-of-line 1)
+ (looking-at "\\s *\\(\\*\\s *\\)?$"))
+ (insert ": ")
+ (if version (insert version ?\s)))
+ ;; Make it easy to get rid of the function name.
+ (undo-boundary)
+ (unless (save-excursion
+ (beginning-of-line 1)
+ (looking-at "\\s *$"))
+ (insert ?\s))
+ ;; See if the prev function name has a message yet or not.
+ ;; If not, merge the two items.
+ (let ((pos (point-marker)))
+ (skip-syntax-backward " ")
+ (skip-chars-backward "):")
+ (if (and (not put-new-entry-on-new-line)
+ (looking-at "):")
+ (let ((pos (save-excursion (backward-sexp 1) (point))))
+ (when (equal (buffer-substring pos (point)) defun)
+ (delete-region pos (point)))
+ (> fill-column (+ (current-column) (length defun) 4))))
+ (progn (skip-chars-backward ", ")
+ (delete-region (point) pos)
+ (unless (memq (char-before) '(?\()) (insert ", ")))
+ (when (and (not put-new-entry-on-new-line) (looking-at "):"))
+ (delete-region (+ 1 (point)) (line-end-position)))
+ (goto-char pos)
+ (insert "("))
+ (set-marker pos nil))
+ (insert defun "): ")
+ (if version (insert version ?\s)))))
+
+;;;###autoload
+(defun add-change-log-entry-other-window (&optional whoami file-name)
+ "Find change log file in other window and add entry and item.
+This is just like `add-change-log-entry' except that it displays
+the change log file in another window."
+ (interactive (if current-prefix-arg
+ (list current-prefix-arg
+ (prompt-for-change-log-name))))
+ (add-change-log-entry whoami file-name t))
+
+
+(defvar change-log-indent-text 0)
+
+(defun change-log-fill-parenthesized-list ()
+ ;; Fill parenthesized lists of names according to GNU standards.
+ ;; * file-name.ext (very-long-foo, very-long-bar, very-long-foobar):
+ ;; should be filled as
+ ;; * file-name.ext (very-long-foo, very-long-bar)
+ ;; (very-long-foobar):
+ (save-excursion
+ (end-of-line 0)
+ (skip-chars-backward " \t")
+ (when (and (equal (char-before) ?\,)
+ (> (point) (1+ (point-min))))
+ (condition-case nil
+ (when (save-excursion
+ (and (prog2
+ (up-list -1)
+ (equal (char-after) ?\()
+ (skip-chars-backward " \t"))
+ (or (bolp)
+ ;; Skip everything but a whitespace or asterisk.
+ (and (not (zerop (skip-chars-backward "^ \t\n*")))
+ (skip-chars-backward " \t")
+ ;; We want one asterisk here.
+ (= (skip-chars-backward "*") -1)
+ (skip-chars-backward " \t")
+ (bolp)))))
+ ;; Delete the comma.
+ (delete-char -1)
+ ;; Close list on previous line.
+ (insert ")")
+ (skip-chars-forward " \t\n")
+ ;; Start list on new line.
+ (insert-before-markers "("))
+ (error nil)))))
+
+(defun change-log-indent ()
+ (change-log-fill-parenthesized-list)
+ (let* ((indent
+ (save-excursion
+ (beginning-of-line)
+ (skip-chars-forward " \t")
+ (cond
+ ((and (looking-at "\\(.*\\) [^ \n].*[^ \n] <.*>\\(?: +(.*)\\)? *$")
+ ;; Matching the output of add-log-time-format is difficult,
+ ;; but I'll get it has at least two adjacent digits.
+ (string-match "[[:digit:]][[:digit:]]" (match-string 1)))
+ 0)
+ ((looking-at "[^*(]")
+ (+ (current-left-margin) change-log-indent-text))
+ (t (current-left-margin)))))
+ (pos (save-excursion (indent-line-to indent) (point))))
+ (if (> pos (point)) (goto-char pos))))
+
+
+(defvar smerge-resolve-function)
+(defvar copyright-at-end-flag)
+
+;;;###autoload
+(define-derived-mode change-log-mode text-mode "Change Log"
+ "Major mode for editing change logs; like Indented Text mode.
+Prevents numeric backups and sets `left-margin' to 8 and `fill-column' to 74.
+New log entries are usually made with \\[add-change-log-entry] or \\[add-change-log-entry-other-window].
+Each entry behaves as a paragraph, and the entries for one day as a page.
+Runs `change-log-mode-hook'.
+\n\\{change-log-mode-map}"
+ (setq left-margin 8
+ fill-column 74
+ indent-tabs-mode t
+ tab-width 8
+ show-trailing-whitespace t)
+ (set (make-local-variable 'fill-forward-paragraph-function)
+ 'change-log-fill-forward-paragraph)
+ ;; Make sure we call `change-log-indent' when filling.
+ (set (make-local-variable 'fill-indent-according-to-mode) t)
+ ;; Avoid that filling leaves behind a single "*" on a line.
+ (add-hook 'fill-nobreak-predicate
+ '(lambda ()
+ (looking-back "^\\s *\\*\\s *" (line-beginning-position)))
+ nil t)
+ (set (make-local-variable 'indent-line-function) 'change-log-indent)
+ (set (make-local-variable 'tab-always-indent) nil)
+ (set (make-local-variable 'copyright-at-end-flag) t)
+ ;; We really do want "^" in paragraph-start below: it is only the
+ ;; lines that begin at column 0 (despite the left-margin of 8) that
+ ;; we are looking for. Adding `* ' allows eliding the blank line
+ ;; between entries for different files.
+ (set (make-local-variable 'paragraph-start) "\\s *$\\|\f\\|^\\<")
+ (set (make-local-variable 'paragraph-separate) paragraph-start)
+ ;; Match null string on the date-line so that the date-line
+ ;; is grouped with what follows.
+ (set (make-local-variable 'page-delimiter) "^\\<\\|^\f")
+ (set (make-local-variable 'version-control) 'never)
+ (set (make-local-variable 'smerge-resolve-function)
+ 'change-log-resolve-conflict)
+ (set (make-local-variable 'adaptive-fill-regexp) "\\s *")
+ (set (make-local-variable 'font-lock-defaults)
+ '(change-log-font-lock-keywords t nil nil backward-paragraph))
+ (set (make-local-variable 'multi-isearch-next-buffer-function)
+ 'change-log-next-buffer)
+ (set (make-local-variable 'beginning-of-defun-function)
+ 'change-log-beginning-of-defun)
+ (set (make-local-variable 'end-of-defun-function)
+ 'change-log-end-of-defun)
+ ;; next-error function glue
+ (setq next-error-function 'change-log-next-error)
+ (setq next-error-last-buffer (current-buffer)))
+
+(defun change-log-next-buffer (&optional buffer wrap)
+ "Return the next buffer in the series of ChangeLog file buffers.
+This function is used for multiple buffers isearch.
+A sequence of buffers is formed by ChangeLog files with decreasing
+numeric file name suffixes in the directory of the initial ChangeLog
+file were isearch was started."
+ (let* ((name (change-log-name))
+ (files (cons name (sort (file-expand-wildcards
+ (concat name "[-.][0-9]*"))
+ (lambda (a b)
+ ;; The file's extension may not have a valid
+ ;; version form (e.g. VC backup revisions).
+ (ignore-errors
+ (version< (substring b (length name))
+ (substring a (length name))))))))
+ (files (if isearch-forward files (reverse files))))
+ (find-file-noselect
+ (if wrap
+ (car files)
+ (cadr (member (file-name-nondirectory (buffer-file-name buffer))
+ files))))))
+
+(defun change-log-fill-forward-paragraph (n)
+ "Cut paragraphs so filling preserves open parentheses at beginning of lines."
+ (let (;; Add lines starting with whitespace followed by a left paren or an
+ ;; asterisk.
+ (paragraph-start (concat paragraph-start "\\|\\s *\\(?:\\s(\\|\\*\\)")))
+ (forward-paragraph n)))
+\f
+(defcustom add-log-current-defun-header-regexp
+ "^\\([[:upper:]][[:upper:]_ ]*[[:upper:]_]\\|[-_[:alpha:]]+\\)[ \t]*[:=]"
+ "Heuristic regexp used by `add-log-current-defun' for unknown major modes.
+The regexp's first submatch is placed in the ChangeLog entry, in
+parentheses."
+ :type 'regexp
+ :group 'change-log)
+
+;;;###autoload
+(defvar add-log-lisp-like-modes
+ '(emacs-lisp-mode lisp-mode scheme-mode dsssl-mode lisp-interaction-mode)
+ "*Modes that look like Lisp to `add-log-current-defun'.")
+
+;;;###autoload
+(defvar add-log-c-like-modes
+ '(c-mode c++-mode c++-c-mode objc-mode)
+ "*Modes that look like C to `add-log-current-defun'.")
+
+;;;###autoload
+(defvar add-log-tex-like-modes
+ '(TeX-mode plain-TeX-mode LaTeX-mode tex-mode)
+ "*Modes that look like TeX to `add-log-current-defun'.")
+
+(declare-function c-cpp-define-name "cc-cmds" ())
+(declare-function c-defun-name "cc-cmds" ())
+
+;;;###autoload
+(defun add-log-current-defun ()
+ "Return name of function definition point is in, or nil.
+
+Understands C, Lisp, LaTeX (\"functions\" are chapters, sections, ...),
+Texinfo (@node titles) and Perl.
+
+Other modes are handled by a heuristic that looks in the 10K before
+point for uppercase headings starting in the first column or
+identifiers followed by `:' or `='. See variables
+`add-log-current-defun-header-regexp' and
+`add-log-current-defun-function'.
+
+Has a preference of looking backwards."
+ (condition-case nil
+ (save-excursion
+ (let ((location (point)))
+ (cond (add-log-current-defun-function
+ (funcall add-log-current-defun-function))
+ ((apply 'derived-mode-p add-log-lisp-like-modes)
+ ;; If we are now precisely at the beginning of a defun,
+ ;; make sure beginning-of-defun finds that one
+ ;; rather than the previous one.
+ (or (eobp) (forward-char 1))
+ (beginning-of-defun)
+ ;; Make sure we are really inside the defun found,
+ ;; not after it.
+ (when (and (looking-at "\\s(")
+ (progn (end-of-defun)
+ (< location (point)))
+ (progn (forward-sexp -1)
+ (>= location (point))))
+ (if (looking-at "\\s(")
+ (forward-char 1))
+ ;; Skip the defining construct name, typically "defun"
+ ;; or "defvar".
+ (forward-sexp 1)
+ ;; The second element is usually a symbol being defined.
+ ;; If it is not, use the first symbol in it.
+ (skip-chars-forward " \t\n'(")
+ (buffer-substring-no-properties (point)
+ (progn (forward-sexp 1)
+ (point)))))
+ ((apply 'derived-mode-p add-log-c-like-modes)
+ (or (c-cpp-define-name)
+ (c-defun-name)))
+ ((apply #'derived-mode-p add-log-tex-like-modes)
+ (if (re-search-backward
+ "\\\\\\(sub\\)*\\(section\\|paragraph\\|chapter\\)"
+ nil t)
+ (progn
+ (goto-char (match-beginning 0))
+ (buffer-substring-no-properties
+ (1+ (point)) ; without initial backslash
+ (line-end-position)))))
+ ((derived-mode-p 'texinfo-mode)
+ (if (re-search-backward "^@node[ \t]+\\([^,\n]+\\)" nil t)
+ (match-string-no-properties 1)))
+ ((derived-mode-p 'perl-mode 'cperl-mode)
+ (if (re-search-backward "^sub[ \t]+\\([^({ \t\n]+\\)" nil t)
+ (match-string-no-properties 1)))
+ ;; Emacs's autoconf-mode installs its own
+ ;; `add-log-current-defun-function'. This applies to
+ ;; a different mode apparently for editing .m4
+ ;; autoconf source.
+ ((derived-mode-p 'autoconf-mode)
+ (if (re-search-backward
+ "^\\(\\(m4_\\)?define\\|A._DEFUN\\)(\\[?\\([A-Za-z0-9_]+\\)" nil t)
+ (match-string-no-properties 3)))
+ (t
+ ;; If all else fails, try heuristics
+ (let (case-fold-search
+ result)
+ (end-of-line)
+ (when (re-search-backward
+ add-log-current-defun-header-regexp
+ (- (point) 10000)
+ t)
+ (setq result (or (match-string-no-properties 1)
+ (match-string-no-properties 0)))
+ ;; Strip whitespace away
+ (when (string-match "\\([^ \t\n\r\f].*[^ \t\n\r\f]\\)"
+ result)
+ (setq result (match-string-no-properties 1 result)))
+ result))))))
+ (error nil)))
+
+(defvar change-log-get-method-definition-md)
+
+;; Subroutine used within change-log-get-method-definition.
+;; Add the last match in the buffer to the end of `md',
+;; followed by the string END; move to the end of that match.
+(defun change-log-get-method-definition-1 (end)
+ (setq change-log-get-method-definition-md
+ (concat change-log-get-method-definition-md
+ (match-string 1)
+ end))
+ (goto-char (match-end 0)))
+
+(defun change-log-get-method-definition ()
+"For Objective C, return the method name if we are in a method."
+ (let ((change-log-get-method-definition-md "["))
+ (save-excursion
+ (if (re-search-backward "^@implementation\\s-*\\([A-Za-z_]*\\)" nil t)
+ (change-log-get-method-definition-1 " ")))
+ (save-excursion
+ (cond
+ ((re-search-forward "^\\([-+]\\)[ \t\n\f\r]*\\(([^)]*)\\)?\\s-*" nil t)
+ (change-log-get-method-definition-1 "")
+ (while (not (looking-at "[{;]"))
+ (looking-at
+ "\\([A-Za-z_]*:?\\)\\s-*\\(([^)]*)\\)?[A-Za-z_]*[ \t\n\f\r]*")
+ (change-log-get-method-definition-1 ""))
+ (concat change-log-get-method-definition-md "]"))))))
+\f
+(autoload 'timezone-make-date-sortable "timezone")
+
+(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."
+ (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))
+ (ignore-errors (timezone-make-date-sortable date)))))
+ (error "Bad date")))
+
+(defun change-log-resolve-conflict ()
+ "Function to be used in `smerge-resolve-function'."
+ (save-excursion
+ (save-restriction
+ (narrow-to-region (match-beginning 0) (match-end 0))
+ (let ((mb1 (match-beginning 1))
+ (me1 (match-end 1))
+ (mb3 (match-beginning 3))
+ (me3 (match-end 3))
+ (tmp1 (generate-new-buffer " *changelog-resolve-1*"))
+ (tmp2 (generate-new-buffer " *changelog-resolve-2*")))
+ (unwind-protect
+ (let ((buf (current-buffer)))
+ (with-current-buffer tmp1
+ (change-log-mode)
+ (insert-buffer-substring buf mb1 me1))
+ (with-current-buffer tmp2
+ (change-log-mode)
+ (insert-buffer-substring buf mb3 me3)
+ ;; Do the merge here instead of inside `buf' so as to be
+ ;; more robust in case change-log-merge fails.
+ (change-log-merge tmp1))
+ (goto-char (point-max))
+ (delete-region (point-min)
+ (prog1 (point)
+ (insert-buffer-substring tmp2))))
+ (kill-buffer tmp1)
+ (kill-buffer tmp2))))))
+
+;;;###autoload
+(defun change-log-merge (other-log)
+ "Merge the contents of change log file OTHER-LOG with this buffer.
+Both must be found in Change Log mode (since the merging depends on
+the appropriate motion commands). OTHER-LOG can be either a file name
+or a buffer.
+
+Entries are inserted in chronological order. Both the current and
+old-style time formats for entries are supported."
+ (interactive "*fLog file name to merge: ")
+ (if (not (derived-mode-p 'change-log-mode))
+ (error "Not in Change Log mode"))
+ (let ((other-buf (if (bufferp other-log) other-log
+ (find-file-noselect other-log)))
+ (buf (current-buffer))
+ date1 start end)
+ (save-excursion
+ (goto-char (point-min))
+ (set-buffer other-buf)
+ (goto-char (point-min))
+ (if (not (derived-mode-p 'change-log-mode))
+ (error "%s not found in Change Log mode" other-log))
+ ;; Loop through all the entries in OTHER-LOG.
+ (while (not (eobp))
+ (setq date1 (change-log-sortable-date-at))
+ (setq start (point)
+ end (progn (forward-page) (point)))
+ ;; Look for an entry in original buffer that isn't later.
+ (with-current-buffer buf
+ (while (and (not (eobp))
+ (string< date1 (change-log-sortable-date-at)))
+ (forward-page))
+ (if (not (eobp))
+ (insert-buffer-substring other-buf start end)
+ ;; At the end of the original buffer, insert a newline to
+ ;; separate entries and then the rest of the file being
+ ;; merged.
+ (unless (or (bobp)
+ (and (= ?\n (char-before))
+ (or (<= (1- (point)) (point-min))
+ (= ?\n (char-before (1- (point)))))))
+ (insert (if use-hard-newlines hard-newline "\n")))
+ ;; Move to the end of it to terminate outer loop.
+ (with-current-buffer other-buf
+ (goto-char (point-max)))
+ (insert-buffer-substring other-buf start)))))))
+
+(defun change-log-beginning-of-defun ()
+ (re-search-backward change-log-start-entry-re nil 'move))
+
+(defun change-log-end-of-defun ()
+ ;; Look back and if there is no entry there it means we are before
+ ;; the first ChangeLog entry, so go forward until finding one.
+ (unless (save-excursion (re-search-backward change-log-start-entry-re nil t))
+ (re-search-forward change-log-start-entry-re nil t))
+
+ ;; In case we are at the end of log entry going forward a line will
+ ;; make us find the next entry when searching. If we are inside of
+ ;; an entry going forward a line will still keep the point inside
+ ;; the same entry.
+ (forward-line 1)
+
+ ;; In case we are at the beginning of an entry, move past it.
+ (when (looking-at change-log-start-entry-re)
+ (goto-char (match-end 0))
+ (forward-line 1))
+
+ ;; Search for the start of the next log entry. Go to the end of the
+ ;; buffer if we could not find a next entry.
+ (when (re-search-forward change-log-start-entry-re nil 'move)
+ (goto-char (match-beginning 0))
+ (forward-line -1)))
+
+(provide 'add-log)
+
+;; arch-tag: 81eee6fc-088f-4372-a37f-80ad9620e762
+;;; add-log.el ends here
--- /dev/null
- ;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;;; compare-w.el --- compare text between windows for Emacs
+
+;; Copyright (C) 1986, 1989, 1993, 1997, 2001, 2002, 2003, 2004,
++;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+
+;; Maintainer: FSF
+;; Keywords: convenience files 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 <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This package provides one entry point, compare-windows. It compares
+;; text starting from point in two adjacent windows, advancing point
+;; until it finds a difference. Option variables permit you to ignore
+;; whitespace differences, or case differences, or both.
+
+;;; Code:
+
+(defgroup compare-windows nil
+ "Compare text between windows."
+ :prefix "compare-"
+ :group 'tools)
+
+(defcustom compare-windows-whitespace "\\(\\s-\\|\n\\)+"
+ "Regexp or function that defines whitespace sequences for `compare-windows'.
+That command optionally ignores changes in whitespace.
+
+The value of `compare-windows-whitespace' is normally a regexp, but it
+can also be a function. The function's job is to categorize any
+whitespace around (including before) point; it should also advance
+past any whitespace. The function is called in each window, with
+point at the current scanning point. It gets one argument, the point
+where \\[compare-windows] was originally called; it should not look at
+any text before that point.
+
+If the function returns the same value for both windows, then the
+whitespace is considered to match, and is skipped."
+ :type '(choice regexp function)
+ :group 'compare-windows)
+
+(defcustom compare-ignore-whitespace nil
+ "Non-nil means `compare-windows' ignores whitespace."
+ :type 'boolean
+ :group 'compare-windows
+ :version "22.1")
+
+(defcustom compare-ignore-case nil
+ "Non-nil means `compare-windows' ignores case differences."
+ :type 'boolean
+ :group 'compare-windows)
+
+(defcustom compare-windows-sync 'compare-windows-sync-default-function
+ "Function or regexp that is used to synchronize points in two
+windows if before calling `compare-windows' points are located
+on mismatched positions.
+
+The value of `compare-windows-sync' can be a function. The
+function's job is to advance points in both windows to the next
+matching text. If the value of `compare-windows-sync' is a
+regexp, then points in both windows are advanced to the next
+occurrence of this regexp.
+
+The current default value is the general function
+`compare-windows-sync-default-function' that is able to
+synchronize points by using quadratic algorithm to find the first
+matching 32-character string in two windows.
+
+The other useful values of this variable could be such functions
+as `forward-word', `forward-sentence', `forward-paragraph', or a
+regexp containing some field separator or a newline, depending on
+the nature of the difference units separator. The variable can
+be made buffer-local.
+
+If the value of this variable is `nil' (option \"No sync\"), then
+no synchronization is performed, and the function `ding' is called
+to beep or flash the screen when points are mismatched."
+ :type '(choice function regexp (const :tag "No sync" nil))
+ :group 'compare-windows
+ :version "22.1")
+
+(defcustom compare-windows-sync-string-size 32
+ "Size of string from one window that is searched in second window.
+
+Small number makes difference regions more fine-grained, but it
+may fail by finding the wrong match. The bigger number makes
+difference regions more coarse-grained.
+
+The default value 32 is good for the most cases."
+ :type 'integer
+ :group 'compare-windows
+ :version "22.1")
+
+(defcustom compare-windows-recenter nil
+ "List of two values, each of which is used as argument of
+function `recenter' called in each of two windows to place
+matching points side-by-side.
+
+The value `(-1 0)' is useful if windows are split vertically,
+and the value `((4) (4))' for horizontally split windows."
+ :type '(list sexp sexp)
+ :group 'compare-windows
+ :version "22.1")
+
+(defcustom compare-windows-highlight t
+ "Non-nil means compare-windows highlights the differences.
+The value t removes highlighting immediately after invoking a command
+other than `compare-windows'.
+The value `persistent' leaves all highlighted differences. You can clear
+out all highlighting later with the command `compare-windows-dehighlight'."
+ :type '(choice (const :tag "No highlighting" nil)
+ (const :tag "Persistent highlighting" persistent)
+ (other :tag "Highlight until next command" t))
+ :group 'compare-windows
+ :version "22.1")
+
+(defface compare-windows
+ '((t :inherit lazy-highlight))
+ "Face for highlighting of compare-windows difference regions."
+ :group 'compare-windows
+ :version "22.1")
+
+(defvar compare-windows-overlay1 nil)
+(defvar compare-windows-overlay2 nil)
+(defvar compare-windows-overlays1 nil)
+(defvar compare-windows-overlays2 nil)
+(defvar compare-windows-sync-point nil)
+
+;;;###autoload
+(defun compare-windows (ignore-whitespace)
+ "Compare text in current window with text in next window.
+Compares the text starting at point in each window,
+moving over text in each one as far as they match.
+
+This command pushes the mark in each window
+at the prior location of point in that window.
+If both windows display the same buffer,
+the mark is pushed twice in that buffer:
+first in the other window, then in the selected window.
+
+A prefix arg means reverse the value of variable
+`compare-ignore-whitespace'. If `compare-ignore-whitespace' is
+nil, then a prefix arg means ignore changes in whitespace. If
+`compare-ignore-whitespace' is non-nil, then a prefix arg means
+don't ignore changes in whitespace. The variable
+`compare-windows-whitespace' controls how whitespace is skipped.
+If `compare-ignore-case' is non-nil, changes in case are also
+ignored.
+
+If `compare-windows-sync' is non-nil, then successive calls of
+this command work in interlaced mode:
+on first call it advances points to the next difference,
+on second call it synchronizes points by skipping the difference,
+on third call it again advances points to the next difference and so on."
+ (interactive "P")
+ (if compare-ignore-whitespace
+ (setq ignore-whitespace (not ignore-whitespace)))
+ (let* (p1 p2 maxp1 maxp2 b1 b2 w2
+ (progress 1)
+ (opoint1 (point))
+ opoint2
+ skip-func-1
+ skip-func-2
+ (sync-func (if (stringp compare-windows-sync)
+ 'compare-windows-sync-regexp
+ compare-windows-sync)))
+ (setq p1 (point) b1 (current-buffer))
+ (setq w2 (next-window (selected-window)))
+ (if (eq w2 (selected-window))
+ (setq w2 (next-window (selected-window) nil 'visible)))
+ (if (eq w2 (selected-window))
+ (error "No other window"))
+ (setq p2 (window-point w2)
+ b2 (window-buffer w2))
+ (setq opoint2 p2)
+ (setq maxp1 (point-max))
+
+ (setq skip-func-1 (if ignore-whitespace
+ (if (stringp compare-windows-whitespace)
+ (lambda (pos)
+ (compare-windows-skip-whitespace pos)
+ t)
+ compare-windows-whitespace)))
+
+ (with-current-buffer b2
+ (setq skip-func-2 (if ignore-whitespace
+ (if (stringp compare-windows-whitespace)
+ (lambda (pos)
+ (compare-windows-skip-whitespace pos)
+ t)
+ compare-windows-whitespace)))
+ (push-mark p2 t)
+ (setq maxp2 (point-max)))
+ (push-mark)
+
+ (while (> progress 0)
+ ;; If both windows have whitespace next to point,
+ ;; optionally skip over it.
+ (and skip-func-1
+ (save-excursion
+ (let (p1a p2a w1 w2 result1 result2)
+ (setq result1 (funcall skip-func-1 opoint1))
+ (setq p1a (point))
+ (set-buffer b2)
+ (goto-char p2)
+ (setq result2 (funcall skip-func-2 opoint2))
+ (setq p2a (point))
+ (if (and result1 result2 (eq result1 result2))
+ (setq p1 p1a
+ p2 p2a)))))
+
+ (let ((size (min (- maxp1 p1) (- maxp2 p2)))
+ (case-fold-search compare-ignore-case))
+ (setq progress (compare-buffer-substrings b2 p2 (+ size p2)
+ b1 p1 (+ size p1)))
+ (setq progress (if (zerop progress) size (1- (abs progress))))
+ (setq p1 (+ p1 progress) p2 (+ p2 progress)))
+ ;; Advance point now rather than later, in case we're interrupted.
+ (goto-char p1)
+ (set-window-point w2 p2)
+ (when compare-windows-recenter
+ (recenter (car compare-windows-recenter))
+ (with-selected-window w2 (recenter (cadr compare-windows-recenter)))))
+
+ (if (= (point) opoint1)
+ (if (not sync-func)
+ (ding)
+ ;; If points are not advanced (i.e. already on mismatch position),
+ ;; then synchronize points between both windows
+ (save-excursion
+ (setq compare-windows-sync-point nil)
+ (funcall sync-func)
+ (setq p1 (point))
+ (set-buffer b2)
+ (goto-char p2)
+ (funcall sync-func)
+ (setq p2 (point)))
+ (goto-char p1)
+ (set-window-point w2 p2)
+ (when compare-windows-recenter
+ (recenter (car compare-windows-recenter))
+ (with-selected-window w2 (recenter (cadr compare-windows-recenter))))
+ ;; If points are still not synchronized, then ding
+ (when (and (= p1 opoint1) (= p2 opoint2))
+ ;; Display error message when current points in two windows
+ ;; are unmatched and next matching points can't be found.
+ (compare-windows-dehighlight)
+ (ding)
+ (message "No more matching points"))))))
+
+;; Move forward over whatever might be called whitespace.
+;; compare-windows-whitespace is a regexp that matches whitespace.
+;; Match it at various starting points before the original point
+;; and find the latest point at which a match ends.
+;; Don't try starting points before START, though.
+;; Value is non-nil if whitespace is found.
+;; If there is whitespace before point, but none after,
+;; then return t, but don't advance point.
+(defun compare-windows-skip-whitespace (start)
+ (let ((end (point))
+ (beg (point))
+ (opoint (point)))
+ (while (or (and (looking-at compare-windows-whitespace)
+ (<= end (match-end 0))
+ ;; This match goes past END, so advance END.
+ (progn (setq end (match-end 0))
+ (> (point) start)))
+ (and (/= (point) start)
+ ;; Consider at least the char before point,
+ ;; unless it is also before START.
+ (= (point) opoint)))
+ ;; keep going back until whitespace
+ ;; doesn't extend to or past end
+ (forward-char -1))
+ (setq beg (point))
+ (goto-char end)
+ (or (/= beg opoint)
+ (/= end opoint))))
+
+;; Move forward to the next synchronization regexp.
+(defun compare-windows-sync-regexp ()
+ (if (stringp compare-windows-sync)
+ (re-search-forward compare-windows-sync nil t)))
+
+;; Function works in two passes: one call on each window.
+;; On the first call both matching points are computed,
+;; and one of them is stored in compare-windows-sync-point
+;; to be used when this function is called on second window.
+(defun compare-windows-sync-default-function ()
+ (if (not compare-windows-sync-point)
+ (let* ((w1 (selected-window))
+ (w2 (next-window w1))
+ (b2 (window-buffer w2))
+ (point-max2 (with-current-buffer b2 (point-max)))
+ (op2 (window-point w2))
+ (op1 (point))
+ (region-size compare-windows-sync-string-size)
+ (string-size compare-windows-sync-string-size)
+ in-bounds-p s1 p2 p12s p12)
+ (while (and
+ ;; until matching points are found
+ (not p12s)
+ ;; until size exceeds the maximum points of both buffers
+ ;; (bounds below take care to not overdo in each of them)
+ (or (setq in-bounds-p (< region-size (max (- (point-max) op1)
+ (- point-max2 op2))))
+ ;; until string size becomes smaller than 4
+ (> string-size 4)))
+ (if in-bounds-p
+ ;; make the next search in the double-sized region;
+ ;; on first iteration it is 2*compare-windows-sync-string-size,
+ ;; on last iterations it exceeds both buffers maximum points
+ (setq region-size (* region-size 2))
+ ;; if region size exceeds the maximum points of both buffers,
+ ;; then start to halve the string size until 4;
+ ;; this helps to find differences near the end of buffers
+ (setq string-size (/ string-size 2)))
+ (let ((p1 op1)
+ (bound1 (- (min (+ op1 region-size) (point-max)) string-size))
+ (bound2 (min (+ op2 region-size) point-max2)))
+ (while (< p1 bound1)
+ (setq s1 (buffer-substring-no-properties p1 (+ p1 string-size)))
+ (setq p2 (with-current-buffer b2
+ (goto-char op2)
+ (let ((case-fold-search compare-ignore-case))
+ (search-forward s1 bound2 t))))
+ (when p2
+ (setq p2 (- p2 string-size))
+ (setq p12s (cons (list (+ p1 p2) p1 p2) p12s)))
+ (setq p1 (1+ p1)))))
+ (when p12s
+ ;; use closest matching points (i.e. points with minimal sum)
+ (setq p12 (cdr (assq (apply 'min (mapcar 'car p12s)) p12s)))
+ (goto-char (car p12))
+ (compare-windows-highlight op1 (car p12) (current-buffer) w1
+ op2 (cadr p12) b2 w2))
+ (setq compare-windows-sync-point (or (cadr p12) t)))
+ ;; else set point in the second window to the pre-calculated value
+ (if (numberp compare-windows-sync-point)
+ (goto-char compare-windows-sync-point))
+ (setq compare-windows-sync-point nil)))
+
+;; Highlight differences
+(defun compare-windows-highlight (beg1 end1 b1 w1 beg2 end2 b2 w2)
+ (when compare-windows-highlight
+ (if compare-windows-overlay1
+ (move-overlay compare-windows-overlay1 beg1 end1 b1)
+ (setq compare-windows-overlay1 (make-overlay beg1 end1 b1))
+ (overlay-put compare-windows-overlay1 'face 'compare-windows)
+ (overlay-put compare-windows-overlay1 'priority 1000))
+ (overlay-put compare-windows-overlay1 'window w1)
+ (if compare-windows-overlay2
+ (move-overlay compare-windows-overlay2 beg2 end2 b2)
+ (setq compare-windows-overlay2 (make-overlay beg2 end2 b2))
+ (overlay-put compare-windows-overlay2 'face 'compare-windows)
+ (overlay-put compare-windows-overlay2 'priority 1000))
+ (overlay-put compare-windows-overlay2 'window w2)
+ (if (not (eq compare-windows-highlight 'persistent))
+ ;; Remove highlighting before next command is executed
+ (add-hook 'pre-command-hook 'compare-windows-dehighlight)
+ (when compare-windows-overlay1
+ (push (copy-overlay compare-windows-overlay1) compare-windows-overlays1)
+ (delete-overlay compare-windows-overlay1))
+ (when compare-windows-overlay2
+ (push (copy-overlay compare-windows-overlay2) compare-windows-overlays2)
+ (delete-overlay compare-windows-overlay2)))))
+
+(defun compare-windows-dehighlight ()
+ "Remove highlighting created by `compare-windows-highlight'."
+ (interactive)
+ (remove-hook 'pre-command-hook 'compare-windows-dehighlight)
+ (mapc 'delete-overlay compare-windows-overlays1)
+ (mapc 'delete-overlay compare-windows-overlays2)
+ (and compare-windows-overlay1 (delete-overlay compare-windows-overlay1))
+ (and compare-windows-overlay2 (delete-overlay compare-windows-overlay2)))
+
+(provide 'compare-w)
+
+;; arch-tag: 4177aab1-48e6-4a98-b7a1-000ee285de46
+;;; compare-w.el ends here
--- /dev/null
- ;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;;; 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, 2011 Free Software Foundation, Inc.
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Todo:
+
+;; - Somehow allow cvs-status-tree to work on-the-fly
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+(require 'pcvs-util)
+
+;;;
+
+(defgroup cvs-status nil
+ "Major mode for browsing `cvs status' output."
+ :group 'pcl-cvs
+ :prefix "cvs-status-")
+
+(easy-mmode-defmap cvs-status-mode-map
+ '(("n" . next-line)
+ ("p" . previous-line)
+ ("N" . cvs-status-next)
+ ("P" . cvs-status-prev)
+ ("\M-n" . cvs-status-next)
+ ("\M-p" . cvs-status-prev)
+ ("t" . cvs-status-cvstrees)
+ ("T" . cvs-status-trees)
+ (">" . cvs-mode-checkout))
+ "CVS-Status' keymap."
+ :group 'cvs-status
+ :inherit 'cvs-mode-map)
+
+;;(easy-menu-define cvs-status-menu cvs-status-mode-map
+;; "Menu for `cvs-status-mode'."
+;; '("CVS-Status"
+;; ["Show Tag Trees" cvs-status-tree t]
+;; ))
+
+(defvar cvs-status-mode-hook nil
+ "Hook run at the end of `cvs-status-mode'.")
+
+(defconst cvs-status-tags-leader-re "^ Existing Tags:$")
+(defconst cvs-status-entry-leader-re
+ "^File:\\s-+\\(?:no file \\)?\\(.*\\S-\\)\\s-+Status: \\(.+\\)$")
+(defconst cvs-status-dir-re "^cvs[.ex]* [a-z]+: Examining \\(.+\\)$")
+(defconst cvs-status-rev-re "[0-9][.0-9]*\\.[.0-9]*[0-9]")
+(defconst cvs-status-tag-re "[ \t]\\([a-zA-Z][^ \t\n.]*\\)")
+
+(defconst cvs-status-font-lock-keywords
+ `((,cvs-status-entry-leader-re
+ (1 'cvs-filename)
+ (2 'cvs-need-action))
+ (,cvs-status-tags-leader-re
+ (,cvs-status-rev-re
+ (save-excursion (re-search-forward "^\n" nil 'move) (point))
+ (progn (re-search-backward cvs-status-tags-leader-re nil t)
+ (forward-line 1))
+ (0 font-lock-comment-face))
+ (,cvs-status-tag-re
+ (save-excursion (re-search-forward "^\n" nil 'move) (point))
+ (progn (re-search-backward cvs-status-tags-leader-re nil t)
+ (forward-line 1))
+ (1 font-lock-function-name-face)))))
+(defconst cvs-status-font-lock-defaults
+ '(cvs-status-font-lock-keywords t nil nil nil (font-lock-multiline . t)))
+
+(defvar cvs-minor-wrap-function)
+(put 'cvs-status-mode 'mode-class 'special)
+;;;###autoload
+(define-derived-mode cvs-status-mode fundamental-mode "CVS-Status"
+ "Mode used for cvs status output."
+ (set (make-local-variable 'font-lock-defaults) cvs-status-font-lock-defaults)
+ (set (make-local-variable 'cvs-minor-wrap-function) 'cvs-status-minor-wrap))
+
+;; Define cvs-status-next and cvs-status-prev
+(easy-mmode-define-navigation cvs-status cvs-status-entry-leader-re "entry")
+
+(defun cvs-status-current-file ()
+ (save-excursion
+ (forward-line 1)
+ (or (re-search-backward cvs-status-entry-leader-re nil t)
+ (re-search-forward cvs-status-entry-leader-re))
+ (let* ((file (match-string 1))
+ (cvsdir (and (re-search-backward cvs-status-dir-re nil t)
+ (match-string 1)))
+ (pcldir (and (if (boundp 'cvs-pcl-cvs-dirchange-re)
+ (re-search-backward cvs-pcl-cvs-dirchange-re nil t))
+ (match-string 1)))
+ (dir ""))
+ (let ((default-directory ""))
+ (when pcldir (setq dir (expand-file-name pcldir dir)))
+ (when cvsdir (setq dir (expand-file-name cvsdir dir)))
+ (expand-file-name file dir)))))
+
+(defun cvs-status-current-tag ()
+ (save-excursion
+ (let ((pt (point))
+ (col (current-column))
+ (start (progn (re-search-backward cvs-status-tags-leader-re nil t) (point)))
+ (end (progn (re-search-forward "^$" nil t) (point))))
+ (when (and (< start pt) (> end pt))
+ (goto-char pt)
+ (end-of-line)
+ (let ((tag nil) (dist pt) (end (point)))
+ (beginning-of-line)
+ (while (re-search-forward cvs-status-tag-re end t)
+ (let* ((cole (current-column))
+ (colb (save-excursion
+ (goto-char (match-beginning 1)) (current-column)))
+ (ndist (min (abs (- cole col)) (abs (- colb col)))))
+ (when (< ndist dist)
+ (setq dist ndist)
+ (setq tag (match-string 1)))))
+ tag)))))
+
+(defun cvs-status-minor-wrap (buf f)
+ (let ((data (with-current-buffer buf
+ (cons
+ (cons (cvs-status-current-file)
+ (cvs-status-current-tag))
+ (when mark-active
+ (save-excursion
+ (goto-char (mark))
+ (cons (cvs-status-current-file)
+ (cvs-status-current-tag))))))))
+ (let ((cvs-branch-prefix (cdar data))
+ (cvs-secondary-branch-prefix (and (cdar data) (cddr data)))
+ (cvs-minor-current-files
+ (cons (caar data)
+ (when (and (cadr data) (not (equal (caar data) (cadr data))))
+ (list (cadr data)))))
+ ;; FIXME: I need to force because the fileinfos are UNKNOWN
+ (cvs-force-command "/F"))
+ (funcall f))))
+
+;;
+;; Tagelt, tag element
+;;
+
+(defstruct (cvs-tag
+ (:constructor nil)
+ (:constructor cvs-tag-make
+ (vlist &optional name type))
+ (:conc-name cvs-tag->))
+ vlist
+ name
+ type)
+
+(defsubst cvs-status-vl-to-str (vl) (mapconcat 'number-to-string vl "."))
+
+(defun cvs-tag->string (tag)
+ (if (stringp tag) tag
+ (let ((name (cvs-tag->name tag))
+ (vl (cvs-tag->vlist tag)))
+ (if (null name) (cvs-status-vl-to-str vl)
+ (let ((rev (if vl (concat " (" (cvs-status-vl-to-str vl) ")") "")))
+ (if (consp name) (mapcar (lambda (name) (concat name rev)) name)
+ (concat name rev)))))))
+
+(defun cvs-tag-compare-1 (vl1 vl2)
+ (cond
+ ((and (null vl1) (null vl2)) 'equal)
+ ((null vl1) 'more2)
+ ((null vl2) 'more1)
+ (t (let ((v1 (car vl1))
+ (v2 (car vl2)))
+ (cond
+ ((> v1 v2) 'more1)
+ ((< v1 v2) 'more2)
+ (t (cvs-tag-compare-1 (cdr vl1) (cdr vl2))))))))
+
+(defsubst cvs-tag-compare (tag1 tag2)
+ (cvs-tag-compare-1 (cvs-tag->vlist tag1) (cvs-tag->vlist tag2)))
+
+(defun cvs-tag-merge (tag1 tag2)
+ "Merge TAG1 and TAG2 into one."
+ (let ((type1 (cvs-tag->type tag1))
+ (type2 (cvs-tag->type tag2))
+ (name1 (cvs-tag->name tag1))
+ (name2 (cvs-tag->name tag2)))
+ (unless (equal (cvs-tag->vlist tag1) (cvs-tag->vlist tag2))
+ (setf (cvs-tag->vlist tag1) nil))
+ (if type1
+ (unless (or (not type2) (equal type1 type2))
+ (setf (cvs-tag->type tag1) nil))
+ (setf (cvs-tag->type tag1) type2))
+ (if name1
+ (setf (cvs-tag->name tag1) (cvs-append name1 name2))
+ (setf (cvs-tag->name tag1) name2))
+ tag1))
+
+(defun cvs-tree-print (tags printer column)
+ "Print the tree of TAGS where each tag's string is given by PRINTER.
+PRINTER should accept both a tag (in which case it should return a string)
+or a string (in which case it should simply return its argument).
+A tag cannot be a CONS. The return value can also be a list of strings,
+if several nodes where merged into one.
+The tree will be printed no closer than column COLUMN."
+
+ (let* ((eol (save-excursion (end-of-line) (current-column)))
+ (column (max (+ eol 2) column)))
+ (if (null tags) column
+ (let* ((rev (cvs-car tags))
+ (name (funcall printer (cvs-car rev)))
+ (rest (append (cvs-cdr name) (cvs-cdr tags)))
+ (prefix
+ (save-excursion
+ (or (= (forward-line 1) 0) (insert "\n"))
+ (cvs-tree-print rest printer column))))
+ (assert (>= prefix column))
+ (move-to-column prefix t)
+ (assert (eolp))
+ (insert (cvs-car name))
+ (dolist (br (cvs-cdr rev))
+ (let* ((column (current-column))
+ (brrev (funcall printer (cvs-car br)))
+ (brlength (length (cvs-car brrev)))
+ (brfill (concat (make-string (/ brlength 2) ? ) "|"))
+ (prefix
+ (save-excursion
+ (insert " -- ")
+ (cvs-tree-print (cvs-append brrev brfill (cvs-cdr br))
+ printer (current-column)))))
+ (delete-region (save-excursion (move-to-column prefix) (point))
+ (point))
+ (insert " " (make-string (- prefix column 2) ?-) " ")
+ (end-of-line)))
+ prefix))))
+
+(defun cvs-tree-merge (tree1 tree2)
+ "Merge tags trees TREE1 and TREE2 into one.
+BEWARE: because of stability issues, this is not a symetric operation."
+ (assert (and (listp tree1) (listp tree2)))
+ (cond
+ ((null tree1) tree2)
+ ((null tree2) tree1)
+ (t
+ (let* ((rev1 (car tree1))
+ (tag1 (cvs-car rev1))
+ (vl1 (cvs-tag->vlist tag1))
+ (l1 (length vl1))
+ (rev2 (car tree2))
+ (tag2 (cvs-car rev2))
+ (vl2 (cvs-tag->vlist tag2))
+ (l2 (length vl2)))
+ (cond
+ ((= l1 l2)
+ (case (cvs-tag-compare tag1 tag2)
+ (more1 (list* rev2 (cvs-tree-merge tree1 (cdr tree2))))
+ (more2 (list* rev1 (cvs-tree-merge (cdr tree1) tree2)))
+ (equal
+ (cons (cons (cvs-tag-merge tag1 tag2)
+ (cvs-tree-merge (cvs-cdr rev1) (cvs-cdr rev2)))
+ (cvs-tree-merge (cdr tree1) (cdr tree2))))))
+ ((> l1 l2)
+ (cvs-tree-merge
+ (list (cons (cvs-tag-make (butlast vl1)) tree1)) tree2))
+ ((< l1 l2)
+ (cvs-tree-merge
+ tree1 (list (cons (cvs-tag-make (butlast vl2)) tree2)))))))))
+
+(defun cvs-tag-make-tag (tag)
+ (let ((vl (mapcar 'string-to-number (split-string (nth 2 tag) "\\."))))
+ (cvs-tag-make vl (nth 0 tag) (intern (nth 1 tag)))))
+
+(defun cvs-tags->tree (tags)
+ "Make a tree out of a list of TAGS."
+ (let ((tags
+ (mapcar
+ (lambda (tag)
+ (let ((tag (cvs-tag-make-tag tag)))
+ (list (if (not (eq (cvs-tag->type tag) 'branch)) tag
+ (list (cvs-tag-make (butlast (cvs-tag->vlist tag)))
+ tag)))))
+ tags)))
+ (while (cdr tags)
+ (let (tl)
+ (while tags
+ (push (cvs-tree-merge (pop tags) (pop tags)) tl))
+ (setq tags (nreverse tl))))
+ (car tags)))
+
+(defun cvs-status-get-tags ()
+ "Look for a list of tags, read them in and delete them.
+Return nil if there was an empty list of tags and t if there wasn't
+even a list. Else, return the list of tags where each element of
+the list is a three-string list TAG, KIND, REV."
+ (let ((tags nil))
+ (if (not (re-search-forward cvs-status-tags-leader-re nil t)) t
+ (forward-char 1)
+ (let ((pt (point))
+ (lastrev nil)
+ (case-fold-search t))
+ (or
+ (looking-at "\\s-+no\\s-+tags")
+
+ (progn ; normal listing
+ (while (looking-at "^[ \t]+\\([^ \t\n]+\\)[ \t]+(\\([a-z]+\\): \\(.+\\))$")
+ (push (list (match-string 1) (match-string 2) (match-string 3)) tags)
+ (forward-line 1))
+ (unless (looking-at "^$") (setq tags nil) (goto-char pt))
+ tags)
+
+ (progn ; cvstree-style listing
+ (while (or (looking-at "^ .+\\(.\\) \\([0-9.]+\\): \\([^\n\t .0-9][^\n\t ]*\\)?$")
+ (and lastrev
+ (looking-at "^ .+\\(\\) \\(8\\)? \\([^\n\t .0-9][^\n\t ]*\\)$")))
+ (setq lastrev (or (match-string 2) lastrev))
+ (push (list (match-string 3)
+ (if (equal (match-string 1) " ") "branch" "revision")
+ lastrev) tags)
+ (forward-line 1))
+ (unless (looking-at "^$") (setq tags nil) (goto-char pt))
+ (setq tags (nreverse tags)))
+
+ (progn ; new tree style listing
+ (let* ((re-lead "[ \t]*\\(-+\\)?\\(|\n?[ \t]+\\)*")
+ (re3 (concat re-lead "\\(\\.\\)?\\(" cvs-status-rev-re "\\)"))
+ (re2 (concat re-lead cvs-status-tag-re "\\(\\)"))
+ (re1 (concat re-lead cvs-status-tag-re
+ " (\\(" cvs-status-rev-re "\\))")))
+ (while (or (looking-at re1) (looking-at re2) (looking-at re3))
+ (push (list (match-string 3)
+ (if (match-string 1) "branch" "revision")
+ (match-string 4)) tags)
+ (goto-char (match-end 0))
+ (when (eolp) (forward-char 1))))
+ (unless (looking-at "^$") (setq tags nil) (goto-char pt))
+ (setq tags (nreverse tags))))
+
+ (delete-region pt (point)))
+ tags)))
+
+(defvar font-lock-mode)
+;; (defun cvs-refontify (beg end)
+;; (when (and (boundp 'font-lock-mode)
+;; font-lock-mode
+;; (fboundp 'font-lock-fontify-region))
+;; (font-lock-fontify-region (1- beg) (1+ end))))
+
+(defun cvs-status-trees ()
+ "Look for a lists of tags, and replace them with trees."
+ (interactive)
+ (save-excursion
+ (goto-char (point-min))
+ (let ((inhibit-read-only t)
+ (tags nil))
+ (while (listp (setq tags (cvs-status-get-tags)))
+ ;;(let ((pt (save-excursion (forward-line -1) (point))))
+ (save-restriction
+ (narrow-to-region (point) (point))
+ ;;(newline)
+ (combine-after-change-calls
+ (cvs-tree-print (cvs-tags->tree tags) 'cvs-tag->string 3)))
+ ;;(cvs-refontify pt (point))
+ ;;(sit-for 0)
+ ;;)
+ ))))
+
+;;;;
+;;;; CVSTree-style trees
+;;;;
+
+(defvar cvs-tree-use-jisx0208 nil) ;Old compat var.
+(defvar cvs-tree-use-charset
+ (cond
+ (cvs-tree-use-jisx0208 'jisx0208)
+ ((char-displayable-p ?━) 'unicode)
+ ((char-displayable-p (make-char 'japanese-jisx0208 40 44)) 'jisx0208))
+ "*Non-nil if we should use the graphical glyphs from `japanese-jisx0208'.
+Otherwise, default to ASCII chars like +, - and |.")
+
+(defconst cvs-tree-char-space
+ (case cvs-tree-use-charset
+ (jisx0208 (make-char 'japanese-jisx0208 33 33))
+ (unicode " ")
+ (t " ")))
+(defconst cvs-tree-char-hbar
+ (case cvs-tree-use-charset
+ (jisx0208 (make-char 'japanese-jisx0208 40 44))
+ (unicode "━")
+ (t "--")))
+(defconst cvs-tree-char-vbar
+ (case cvs-tree-use-charset
+ (jisx0208 (make-char 'japanese-jisx0208 40 45))
+ (unicode "┃")
+ (t "| ")))
+(defconst cvs-tree-char-branch
+ (case cvs-tree-use-charset
+ (jisx0208 (make-char 'japanese-jisx0208 40 50))
+ (unicode "┣")
+ (t "+-")))
+(defconst cvs-tree-char-eob ;end of branch
+ (case cvs-tree-use-charset
+ (jisx0208 (make-char 'japanese-jisx0208 40 49))
+ (unicode "┗")
+ (t "`-")))
+(defconst cvs-tree-char-bob ;beginning of branch
+ (case cvs-tree-use-charset
+ (jisx0208 (make-char 'japanese-jisx0208 40 51))
+ (unicode "┳")
+ (t "+-")))
+
+(defun cvs-tag-lessp (tag1 tag2)
+ (eq (cvs-tag-compare tag1 tag2) 'more2))
+
+(defvar cvs-tree-nomerge nil)
+
+(defun cvs-status-cvstrees (&optional arg)
+ "Look for a list of tags, and replace it with a tree.
+Optional prefix ARG chooses between two representations."
+ (interactive "P")
+ (when (and cvs-tree-use-charset
+ (not enable-multibyte-characters))
+ ;; We need to convert the buffer from unibyte to multibyte
+ ;; since we'll use multibyte chars for the tree.
+ (let ((modified (buffer-modified-p))
+ (inhibit-read-only t)
+ (inhibit-modification-hooks t))
+ (unwind-protect
+ (progn
+ (decode-coding-region (point-min) (point-max) 'undecided)
+ (set-buffer-multibyte t))
+ (restore-buffer-modified-p modified))))
+ (save-excursion
+ (goto-char (point-min))
+ (let ((inhibit-read-only t)
+ (tags nil)
+ (cvs-tree-nomerge (if arg (not cvs-tree-nomerge) cvs-tree-nomerge)))
+ (while (listp (setq tags (cvs-status-get-tags)))
+ (let ((tags (mapcar 'cvs-tag-make-tag tags))
+ ;;(pt (save-excursion (forward-line -1) (point)))
+ )
+ (setq tags (sort tags 'cvs-tag-lessp))
+ (let* ((first (car tags))
+ (prev (if (cvs-tag-p first)
+ (list (car (cvs-tag->vlist first))) nil)))
+ (combine-after-change-calls
+ (cvs-tree-tags-insert tags prev))
+ ;;(cvs-refontify pt (point))
+ ;;(sit-for 0)
+ ))))))
+
+(defun cvs-tree-tags-insert (tags prev)
+ (when tags
+ (let* ((tag (car tags))
+ (vlist (cvs-tag->vlist tag))
+ (nprev ;"next prev"
+ (let* ((next (cvs-car (cadr tags)))
+ (nprev (if (and cvs-tree-nomerge next
+ (equal vlist (cvs-tag->vlist next)))
+ prev vlist)))
+ (cvs-map (lambda (v p) v) nprev prev)))
+ (after (save-excursion
+ (newline)
+ (cvs-tree-tags-insert (cdr tags) nprev)))
+ (pe t) ;"prev equal"
+ (nas nil)) ;"next afters" to be returned
+ (insert " ")
+ (do* ((vs vlist (cdr vs))
+ (ps prev (cdr ps))
+ (as after (cdr as)))
+ ((and (null as) (null vs) (null ps))
+ (let ((revname (cvs-status-vl-to-str vlist)))
+ (if (cvs-every 'identity (cvs-map 'equal prev vlist))
+ (insert (make-string (+ 4 (length revname)) ? )
+ (or (cvs-tag->name tag) ""))
+ (insert " " revname ": " (or (cvs-tag->name tag) "")))))
+ (let* ((eq (and pe (equal (car ps) (car vs))))
+ (next-eq (equal (cadr ps) (cadr vs))))
+ (let* ((na+char
+ (if (car as)
+ (if eq
+ (if next-eq (cons t cvs-tree-char-vbar)
+ (cons t cvs-tree-char-branch))
+ (cons nil cvs-tree-char-bob))
+ (if eq
+ (if next-eq (cons nil cvs-tree-char-space)
+ (cons t cvs-tree-char-eob))
+ (cons nil (if (and (eq (cvs-tag->type tag) 'branch)
+ (cvs-every 'null as))
+ cvs-tree-char-space
+ cvs-tree-char-hbar))))))
+ (insert (cdr na+char))
+ (push (car na+char) nas))
+ (setq pe eq)))
+ (nreverse nas))))
+
+;;;;
+;;;; Merged trees from different files
+;;;;
+
+(defun cvs-tree-fuzzy-merge-1 (trees tree prev)
+ )
+
+(defun cvs-tree-fuzzy-merge (trees tree)
+ "Do the impossible: merge TREE into TREES."
+ ())
+
+(defun cvs-tree ()
+ "Get tags from the status output and merge tham all into a big tree."
+ (save-excursion
+ (goto-char (point-min))
+ (let ((inhibit-read-only t)
+ (trees (make-vector 31 0)) tree)
+ (while (listp (setq tree (cvs-tags->tree (cvs-status-get-tags))))
+ (cvs-tree-fuzzy-merge trees tree))
+ (erase-buffer)
+ (let ((cvs-tag-print-rev nil))
+ (cvs-tree-print tree 'cvs-tag->string 3)))))
+
+
+(provide 'cvs-status)
+
+;; arch-tag: db8b5094-d02a-473e-a476-544e89ff5ad0
+;;; cvs-status.el ends here
--- /dev/null
- ;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;;; 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, 2011 Free Software Foundation, Inc.
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Provides support for font-lock, outline, navigation
+;; commands, editing and various conversions as well as jumping
+;; to the corresponding source file.
+
+;; Inspired by Pavel Machek's patch-mode.el (<pavel@@atrey.karlin.mff.cuni.cz>)
+;; Some efforts were spent to have it somewhat compatible with XEmacs'
+;; diff-mode as well as with compilation-minor-mode
+
+;; Bugs:
+
+;; - Reverse doesn't work with normal diffs.
+
+;; Todo:
+
+;; - Improve `diff-add-change-log-entries-other-window',
+;; it is very simplistic now.
+;;
+;; - Add a `delete-after-apply' so C-c C-a automatically deletes hunks.
+;; Also allow C-c C-a to delete already-applied hunks.
+;;
+;; - Try `diff <file> <hunk>' to try and fuzzily discover the source location
+;; of a hunk. Show then the changes between <file> and <hunk> and make it
+;; possible to apply them to <file>, <hunk-src>, or <hunk-dst>.
+;; Or maybe just make it into a ".rej to diff3-markers converter".
+;; Maybe just use `wiggle' (by Neil Brown) to do it for us.
+;;
+;; - in diff-apply-hunk, strip context in replace-match to better
+;; preserve markers and spacing.
+;; - Handle `diff -b' output in context->unified.
+
+;;; Code:
+(eval-when-compile (require 'cl))
+
+(defvar add-log-buffer-file-name-function)
+
+
+(defgroup diff-mode ()
+ "Major mode for viewing/editing diffs."
+ :version "21.1"
+ :group 'tools
+ :group 'diff)
+
+(defcustom diff-default-read-only nil
+ "If non-nil, `diff-mode' buffers default to being read-only."
+ :type 'boolean
+ :group 'diff-mode)
+
+(defcustom diff-jump-to-old-file nil
+ "Non-nil means `diff-goto-source' jumps to the old file.
+Else, it jumps to the new file."
+ :type 'boolean
+ :group 'diff-mode)
+
+(defcustom diff-update-on-the-fly t
+ "Non-nil means hunk headers are kept up-to-date on-the-fly.
+When editing a diff file, the line numbers in the hunk headers
+need to be kept consistent with the actual diff. This can
+either be done on the fly (but this sometimes interacts poorly with the
+undo mechanism) or whenever the file is written (can be slow
+when editing big diffs)."
+ :type 'boolean
+ :group 'diff-mode)
+
+(defcustom diff-advance-after-apply-hunk t
+ "Non-nil means `diff-apply-hunk' will move to the next hunk after applying."
+ :type 'boolean
+ :group 'diff-mode)
+
+(defcustom diff-mode-hook nil
+ "Run after setting up the `diff-mode' major mode."
+ :type 'hook
+ :options '(diff-delete-empty-files diff-make-unified)
+ :group 'diff-mode)
+
+(defvar diff-vc-backend nil
+ "The VC backend that created the current Diff buffer, if any.")
+
+(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)
+ ("g" . revert-buffer)
+ ("q" . quit-window))
+ "Basic keymap for `diff-mode', bound to various prefix keys.")
+
+(easy-mmode-defmap diff-mode-map
+ `(("\e" . ,diff-mode-shared-map)
+ ;; From compilation-minor-mode.
+ ("\C-c\C-c" . diff-goto-source)
+ ;; By analogy with the global C-x 4 a binding.
+ ("\C-x4A" . diff-add-change-log-entries-other-window)
+ ;; Misc operations.
+ ("\C-c\C-a" . diff-apply-hunk)
+ ("\C-c\C-e" . diff-ediff-patch)
+ ("\C-c\C-n" . diff-restrict-view)
+ ("\C-c\C-s" . diff-split-hunk)
+ ("\C-c\C-t" . diff-test-hunk)
+ ("\C-c\C-r" . diff-reverse-direction)
+ ("\C-c\C-u" . diff-context->unified)
+ ;; `d' because it duplicates the context :-( --Stef
+ ("\C-c\C-d" . diff-unified->context)
+ ("\C-c\C-w" . diff-ignore-whitespace-hunk)
+ ("\C-c\C-b" . diff-refine-hunk) ;No reason for `b' :-(
+ ("\C-c\C-f" . next-error-follow-minor-mode))
+ "Keymap for `diff-mode'. See also `diff-mode-shared-map'.")
+
+(easy-menu-define diff-mode-menu diff-mode-map
+ "Menu for `diff-mode'."
+ '("Diff"
+ ["Jump to Source" diff-goto-source
+ :help "Jump to the corresponding source line"]
+ ["Apply hunk" diff-apply-hunk
+ :help "Apply the current hunk to the source file and go to the next"]
+ ["Test applying hunk" diff-test-hunk
+ :help "See whether it's possible to apply the current hunk"]
+ ["Apply diff with Ediff" diff-ediff-patch
+ :help "Call `ediff-patch-file' on the current buffer"]
+ ["Create Change Log entries" diff-add-change-log-entries-other-window
+ :help "Create ChangeLog entries for the changes in the diff buffer"]
+ "-----"
+ ["Reverse direction" diff-reverse-direction
+ :help "Reverse the direction of the diffs"]
+ ["Context -> Unified" diff-context->unified
+ :help "Convert context diffs to unified diffs"]
+ ["Unified -> Context" diff-unified->context
+ :help "Convert unified diffs to context diffs"]
+ ;;["Fixup Headers" diff-fixup-modifs (not buffer-read-only)]
+ ["Show trailing whitespace" whitespace-mode
+ :style toggle :selected (bound-and-true-p whitespace-mode)
+ :help "Show trailing whitespace in modified lines"]
+ "-----"
+ ["Split hunk" diff-split-hunk
+ :active (diff-splittable-p)
+ :help "Split the current (unified diff) hunk at point into two hunks"]
+ ["Ignore whitespace changes" diff-ignore-whitespace-hunk
+ :help "Re-diff the current hunk, ignoring whitespace differences"]
+ ["Highlight fine changes" diff-refine-hunk
+ :help "Highlight changes of hunk at point at a finer granularity"]
+ ["Kill current hunk" diff-hunk-kill
+ :help "Kill current hunk"]
+ ["Kill current file's hunks" diff-file-kill
+ :help "Kill all current file's hunks"]
+ "-----"
+ ["Previous Hunk" diff-hunk-prev
+ :help "Go to the previous count'th hunk"]
+ ["Next Hunk" diff-hunk-next
+ :help "Go to the next count'th hunk"]
+ ["Previous File" diff-file-prev
+ :help "Go to the previous count'th file"]
+ ["Next File" diff-file-next
+ :help "Go to the next count'th file"]
+ ))
+
+(defcustom diff-minor-mode-prefix "\C-c="
+ "Prefix key for `diff-minor-mode' commands."
+ :type '(choice (string "\e") (string "C-c=") string)
+ :group 'diff-mode)
+
+(easy-mmode-defmap diff-minor-mode-map
+ `((,diff-minor-mode-prefix . ,diff-mode-shared-map))
+ "Keymap for `diff-minor-mode'. See also `diff-mode-shared-map'.")
+
+(define-minor-mode diff-auto-refine-mode
+ "Automatically highlight changes in detail as the user visits hunks.
+When transitioning from disabled to enabled,
+try to refine the current hunk, as well."
+ :group 'diff-mode :init-value t :lighter nil ;; " Auto-Refine"
+ (when diff-auto-refine-mode
+ (condition-case-no-debug nil (diff-refine-hunk) (error nil))))
+
+;;;;
+;;;; font-lock support
+;;;;
+
+(defface diff-header
+ '((((class color) (min-colors 88) (background light))
+ :background "grey80")
+ (((class color) (min-colors 88) (background dark))
+ :background "grey45")
+ (((class color) (background light))
+ :foreground "blue1" :weight bold)
+ (((class color) (background dark))
+ :foreground "green" :weight bold)
+ (t :weight bold))
+ "`diff-mode' face inherited by hunk and index header faces."
+ :group 'diff-mode)
+(define-obsolete-face-alias 'diff-header-face 'diff-header "22.1")
+(defvar diff-header-face 'diff-header)
+
+(defface diff-file-header
+ '((((class color) (min-colors 88) (background light))
+ :background "grey70" :weight bold)
+ (((class color) (min-colors 88) (background dark))
+ :background "grey60" :weight bold)
+ (((class color) (background light))
+ :foreground "green" :weight bold)
+ (((class color) (background dark))
+ :foreground "cyan" :weight bold)
+ (t :weight bold)) ; :height 1.3
+ "`diff-mode' face used to highlight file header lines."
+ :group 'diff-mode)
+(define-obsolete-face-alias 'diff-file-header-face 'diff-file-header "22.1")
+(defvar diff-file-header-face 'diff-file-header)
+
+(defface diff-index
+ '((t :inherit diff-file-header))
+ "`diff-mode' face used to highlight index header lines."
+ :group 'diff-mode)
+(define-obsolete-face-alias 'diff-index-face 'diff-index "22.1")
+(defvar diff-index-face 'diff-index)
+
+(defface diff-hunk-header
+ '((t :inherit diff-header))
+ "`diff-mode' face used to highlight hunk header lines."
+ :group 'diff-mode)
+(define-obsolete-face-alias 'diff-hunk-header-face 'diff-hunk-header "22.1")
+(defvar diff-hunk-header-face 'diff-hunk-header)
+
+(defface diff-removed
+ '((t :inherit diff-changed))
+ "`diff-mode' face used to highlight removed lines."
+ :group 'diff-mode)
+(define-obsolete-face-alias 'diff-removed-face 'diff-removed "22.1")
+(defvar diff-removed-face 'diff-removed)
+
+(defface diff-added
+ '((t :inherit diff-changed))
+ "`diff-mode' face used to highlight added lines."
+ :group 'diff-mode)
+(define-obsolete-face-alias 'diff-added-face 'diff-added "22.1")
+(defvar diff-added-face 'diff-added)
+
+(defface diff-changed
+ '((((type tty pc) (class color) (background light))
+ :foreground "magenta" :weight bold :slant italic)
+ (((type tty pc) (class color) (background dark))
+ :foreground "yellow" :weight bold :slant italic))
+ "`diff-mode' face used to highlight changed lines."
+ :group 'diff-mode)
+(define-obsolete-face-alias 'diff-changed-face 'diff-changed "22.1")
+(defvar diff-changed-face 'diff-changed)
+
+(defface diff-indicator-removed
+ '((t :inherit diff-removed))
+ "`diff-mode' face used to highlight indicator of removed lines (-, <)."
+ :group 'diff-mode
+ :version "22.1")
+(defvar diff-indicator-removed-face 'diff-indicator-removed)
+
+(defface diff-indicator-added
+ '((t :inherit diff-added))
+ "`diff-mode' face used to highlight indicator of added lines (+, >)."
+ :group 'diff-mode
+ :version "22.1")
+(defvar diff-indicator-added-face 'diff-indicator-added)
+
+(defface diff-indicator-changed
+ '((t :inherit diff-changed))
+ "`diff-mode' face used to highlight indicator of changed lines."
+ :group 'diff-mode
+ :version "22.1")
+(defvar diff-indicator-changed-face 'diff-indicator-changed)
+
+(defface diff-function
+ '((t :inherit diff-header))
+ "`diff-mode' face used to highlight function names produced by \"diff -p\"."
+ :group 'diff-mode)
+(define-obsolete-face-alias 'diff-function-face 'diff-function "22.1")
+(defvar diff-function-face 'diff-function)
+
+(defface diff-context
+ '((((class color grayscale) (min-colors 88)) :inherit shadow))
+ "`diff-mode' face used to highlight context and other side-information."
+ :group 'diff-mode)
+(define-obsolete-face-alias 'diff-context-face 'diff-context "22.1")
+(defvar diff-context-face 'diff-context)
+
+(defface diff-nonexistent
+ '((t :inherit diff-file-header))
+ "`diff-mode' face used to highlight nonexistent files in recursive diffs."
+ :group 'diff-mode)
+(define-obsolete-face-alias 'diff-nonexistent-face 'diff-nonexistent "22.1")
+(defvar diff-nonexistent-face 'diff-nonexistent)
+
+(defconst diff-yank-handler '(diff-yank-function))
+(defun diff-yank-function (text)
+ ;; FIXME: the yank-handler is now called separately on each piece of text
+ ;; with a yank-handler property, so the next-single-property-change call
+ ;; below will always return nil :-( --stef
+ (let ((mixed (next-single-property-change 0 'yank-handler text))
+ (start (point)))
+ ;; First insert the text.
+ (insert text)
+ ;; If the text does not include any diff markers and if we're not
+ ;; yanking back into a diff-mode buffer, get rid of the prefixes.
+ (unless (or mixed (derived-mode-p 'diff-mode))
+ (undo-boundary) ; Just in case the user wanted the prefixes.
+ (let ((re (save-excursion
+ (if (re-search-backward "^[><!][ \t]" start t)
+ (if (eq (char-after) ?!)
+ "^[!+- ][ \t]" "^[<>][ \t]")
+ "^[ <>!+-]"))))
+ (save-excursion
+ (while (re-search-backward re start t)
+ (replace-match "" t t)))))))
+
+(defconst diff-hunk-header-re-unified
+ "^@@ -\\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)? \\+\\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)? @@")
+(defconst diff-context-mid-hunk-header-re
+ "--- \\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)? ----$")
+
+(defvar diff-font-lock-keywords
+ `((,(concat "\\(" diff-hunk-header-re-unified "\\)\\(.*\\)$")
+ (1 diff-hunk-header-face) (6 diff-function-face))
+ ("^\\(\\*\\{15\\}\\)\\(.*\\)$" ;context
+ (1 diff-hunk-header-face) (2 diff-function-face))
+ ("^\\*\\*\\* .+ \\*\\*\\*\\*". diff-hunk-header-face) ;context
+ (,diff-context-mid-hunk-header-re . diff-hunk-header-face) ;context
+ ("^[0-9,]+[acd][0-9,]+$" . diff-hunk-header-face) ;normal
+ ("^---$" . diff-hunk-header-face) ;normal
+ ;; For file headers, accept files with spaces, but be careful to rule
+ ;; out false-positives when matching hunk headers.
+ ("^\\(---\\|\\+\\+\\+\\|\\*\\*\\*\\) \\([^\t\n]+?\\)\\(?:\t.*\\| \\(\\*\\*\\*\\*\\|----\\)\\)?\n"
+ (0 diff-header-face)
+ (2 (if (not (match-end 3)) diff-file-header-face) prepend))
+ ("^\\([-<]\\)\\(.*\n\\)"
+ (1 diff-indicator-removed-face) (2 diff-removed-face))
+ ("^\\([+>]\\)\\(.*\n\\)"
+ (1 diff-indicator-added-face) (2 diff-added-face))
+ ("^\\(!\\)\\(.*\n\\)"
+ (1 diff-indicator-changed-face) (2 diff-changed-face))
+ ("^Index: \\(.+\\).*\n"
+ (0 diff-header-face) (1 diff-index-face prepend))
+ ("^Only in .*\n" . diff-nonexistent-face)
+ ("^\\(#\\)\\(.*\\)"
+ (1 font-lock-comment-delimiter-face)
+ (2 font-lock-comment-face))
+ ("^[^-=+*!<>#].*\n" (0 diff-context-face))))
+
+(defconst diff-font-lock-defaults
+ '(diff-font-lock-keywords t nil nil nil (font-lock-multiline . nil)))
+
+(defvar diff-imenu-generic-expression
+ ;; Prefer second name as first is most likely to be a backup or
+ ;; version-control name. The [\t\n] at the end of the unidiff pattern
+ ;; catches Debian source diff files (which lack the trailing date).
+ '((nil "\\+\\+\\+\\ \\([^\t\n]+\\)[\t\n]" 1) ; unidiffs
+ (nil "^--- \\([^\t\n]+\\)\t.*\n\\*" 1))) ; context diffs
+
+;;;;
+;;;; Movement
+;;;;
+
+(defvar diff-valid-unified-empty-line t
+ "If non-nil, empty lines are valid in unified diffs.
+Some versions of diff replace all-blank context lines in unified format with
+empty lines. This makes the format less robust, but is tolerated.
+See http://lists.gnu.org/archive/html/emacs-devel/2007-11/msg01990.html")
+
+(defconst diff-hunk-header-re
+ (concat "^\\(?:" diff-hunk-header-re-unified ".*\\|\\*\\{15\\}.*\n\\*\\*\\* .+ \\*\\*\\*\\*\\|[0-9]+\\(,[0-9]+\\)?[acd][0-9]+\\(,[0-9]+\\)?\\)$"))
+(defconst diff-file-header-re (concat "^\\(--- .+\n\\+\\+\\+ \\|\\*\\*\\* .+\n--- \\|[^-+!<>0-9@* \n]\\).+\n" (substring diff-hunk-header-re 1)))
+(defvar diff-narrowed-to nil)
+
+(defun diff-hunk-style (&optional style)
+ (when (looking-at diff-hunk-header-re)
+ (setq style (cdr (assq (char-after) '((?@ . unified) (?* . context)))))
+ (goto-char (match-end 0)))
+ style)
+
+(defun diff-end-of-hunk (&optional style donttrustheader)
+ (let (end)
+ (when (looking-at diff-hunk-header-re)
+ ;; Especially important for unified (because headers are ambiguous).
+ (setq style (diff-hunk-style style))
+ (goto-char (match-end 0))
+ (when (and (not donttrustheader) (match-end 2))
+ (let* ((nold (string-to-number (or (match-string 2) "1")))
+ (nnew (string-to-number (or (match-string 4) "1")))
+ (endold
+ (save-excursion
+ (re-search-forward (if diff-valid-unified-empty-line
+ "^[- \n]" "^[- ]")
+ nil t nold)
+ (line-beginning-position 2)))
+ (endnew
+ ;; The hunk may end with a bunch of "+" lines, so the `end' is
+ ;; then further than computed above.
+ (save-excursion
+ (re-search-forward (if diff-valid-unified-empty-line
+ "^[+ \n]" "^[+ ]")
+ nil t nnew)
+ (line-beginning-position 2))))
+ (setq end (max endold endnew)))))
+ ;; We may have a first evaluation of `end' thanks to the hunk header.
+ (unless end
+ (setq end (and (re-search-forward
+ (case style
+ (unified (concat (if diff-valid-unified-empty-line
+ "^[^-+# \\\n]\\|" "^[^-+# \\]\\|")
+ ;; A `unified' header is ambiguous.
+ diff-file-header-re))
+ (context "^[^-+#! \\]")
+ (normal "^[^<>#\\]")
+ (t "^[^-+#!<> \\]"))
+ nil t)
+ (match-beginning 0)))
+ (when diff-valid-unified-empty-line
+ ;; While empty lines may be valid inside hunks, they are also likely
+ ;; to be unrelated to the hunk.
+ (goto-char (or end (point-max)))
+ (while (eq ?\n (char-before (1- (point))))
+ (forward-char -1)
+ (setq end (point)))))
+ ;; The return value is used by easy-mmode-define-navigation.
+ (goto-char (or end (point-max)))))
+
+(defun diff-beginning-of-hunk (&optional try-harder)
+ "Move back to beginning of hunk.
+If TRY-HARDER is non-nil, try to cater to the case where we're not in a hunk
+but in the file header instead, in which case move forward to the first hunk."
+ (beginning-of-line)
+ (unless (looking-at diff-hunk-header-re)
+ (forward-line 1)
+ (condition-case ()
+ (re-search-backward diff-hunk-header-re)
+ (error
+ (if (not try-harder)
+ (error "Can't find the beginning of the hunk")
+ (diff-beginning-of-file-and-junk)
+ (diff-hunk-next))))))
+
+(defun diff-unified-hunk-p ()
+ (save-excursion
+ (ignore-errors
+ (diff-beginning-of-hunk)
+ (looking-at "^@@"))))
+
+(defun diff-beginning-of-file ()
+ (beginning-of-line)
+ (unless (looking-at diff-file-header-re)
+ (let ((start (point))
+ res)
+ ;; diff-file-header-re may need to match up to 4 lines, so in case
+ ;; we're inside the header, we need to move up to 3 lines forward.
+ (forward-line 3)
+ (if (and (setq res (re-search-backward diff-file-header-re nil t))
+ ;; Maybe the 3 lines forward were too much and we matched
+ ;; a file header after our starting point :-(
+ (or (<= (point) start)
+ (setq res (re-search-backward diff-file-header-re nil t))))
+ res
+ (goto-char start)
+ (error "Can't find the beginning of the file")))))
+
+
+(defun diff-end-of-file ()
+ (re-search-forward "^[-+#!<>0-9@* \\]" nil t)
+ (re-search-forward (concat "^[^-+#!<>0-9@* \\]\\|" diff-file-header-re)
+ nil 'move)
+ (if (match-beginning 1)
+ (goto-char (match-beginning 1))
+ (beginning-of-line)))
+
+;; Define diff-{hunk,file}-{prev,next}
+(easy-mmode-define-navigation
+ diff-hunk diff-hunk-header-re "hunk" diff-end-of-hunk diff-restrict-view
+ (if diff-auto-refine-mode
+ (condition-case-no-debug nil (diff-refine-hunk) (error nil))))
+
+(easy-mmode-define-navigation
+ diff-file diff-file-header-re "file" diff-end-of-hunk)
+
+(defun diff-restrict-view (&optional arg)
+ "Restrict the view to the current hunk.
+If the prefix ARG is given, restrict the view to the current file instead."
+ (interactive "P")
+ (save-excursion
+ (if arg (diff-beginning-of-file) (diff-beginning-of-hunk 'try-harder))
+ (narrow-to-region (point)
+ (progn (if arg (diff-end-of-file) (diff-end-of-hunk))
+ (point)))
+ (set (make-local-variable 'diff-narrowed-to) (if arg 'file 'hunk))))
+
+
+(defun diff-hunk-kill ()
+ "Kill current hunk."
+ (interactive)
+ (diff-beginning-of-hunk)
+ (let* ((start (point))
+ ;; Search the second match, since we're looking at the first.
+ (nexthunk (when (re-search-forward diff-hunk-header-re nil t 2)
+ (match-beginning 0)))
+ (firsthunk (ignore-errors
+ (goto-char start)
+ (diff-beginning-of-file) (diff-hunk-next) (point)))
+ (nextfile (ignore-errors (diff-file-next) (point)))
+ (inhibit-read-only t))
+ (goto-char start)
+ (if (and firsthunk (= firsthunk start)
+ (or (null nexthunk)
+ (and nextfile (> nexthunk nextfile))))
+ ;; It's the only hunk for this file, so kill the file.
+ (diff-file-kill)
+ (diff-end-of-hunk)
+ (kill-region start (point)))))
+
+;; "index ", "old mode", "new mode", "new file mode" and
+;; "deleted file mode" are output by git-diff.
+(defconst diff-file-junk-re
+ "diff \\|index \\|\\(?:deleted file\\|new\\(?: file\\)?\\|old\\) mode")
+
+(defun diff-beginning-of-file-and-junk ()
+ "Go to the beginning of file-related diff-info.
+This is like `diff-beginning-of-file' except it tries to skip back over leading
+data such as \"Index: ...\" and such."
+ (let* ((orig (point))
+ ;; Skip forward over what might be "leading junk" so as to get
+ ;; closer to the actual diff.
+ (_ (progn (beginning-of-line)
+ (while (looking-at diff-file-junk-re)
+ (forward-line 1))))
+ (start (point))
+ (prevfile (condition-case err
+ (save-excursion (diff-beginning-of-file) (point))
+ (error err)))
+ (err (if (consp prevfile) prevfile))
+ (nextfile (ignore-errors
+ (save-excursion
+ (goto-char start) (diff-file-next) (point))))
+ ;; prevhunk is one of the limits.
+ (prevhunk (save-excursion
+ (ignore-errors
+ (if (numberp prevfile) (goto-char prevfile))
+ (diff-hunk-prev) (point))))
+ (previndex (save-excursion
+ (forward-line 1) ;In case we're looking at "Index:".
+ (re-search-backward "^Index: " prevhunk t))))
+ ;; If we're in the junk, we should use nextfile instead of prevfile.
+ (if (and (numberp nextfile)
+ (or (not (numberp prevfile))
+ (and previndex (> previndex prevfile))))
+ (setq prevfile nextfile))
+ (if (and previndex (numberp prevfile) (< previndex prevfile))
+ (setq prevfile previndex))
+ (if (and (numberp prevfile) (<= prevfile start))
+ (progn
+ (goto-char prevfile)
+ ;; Now skip backward over the leading junk we may have before the
+ ;; diff itself.
+ (while (save-excursion
+ (and (zerop (forward-line -1))
+ (looking-at diff-file-junk-re)))
+ (forward-line -1)))
+ ;; File starts *after* the starting point: we really weren't in
+ ;; a file diff but elsewhere.
+ (goto-char orig)
+ (signal (car err) (cdr err)))))
+
+(defun diff-file-kill ()
+ "Kill current file's hunks."
+ (interactive)
+ (let ((orig (point))
+ (start (progn (diff-beginning-of-file-and-junk) (point)))
+ (inhibit-read-only t))
+ (diff-end-of-file)
+ (if (looking-at "^\n") (forward-char 1)) ;`tla' generates such diffs.
+ (if (> orig (point)) (error "Not inside a file diff"))
+ (kill-region start (point))))
+
+(defun diff-kill-junk ()
+ "Kill spurious empty diffs."
+ (interactive)
+ (save-excursion
+ (let ((inhibit-read-only t))
+ (goto-char (point-min))
+ (while (re-search-forward (concat "^\\(Index: .*\n\\)"
+ "\\([^-+!* <>].*\n\\)*?"
+ "\\(\\(Index:\\) \\|"
+ diff-file-header-re "\\)")
+ nil t)
+ (delete-region (if (match-end 4) (match-beginning 0) (match-end 1))
+ (match-beginning 3))
+ (beginning-of-line)))))
+
+(defun diff-count-matches (re start end)
+ (save-excursion
+ (let ((n 0))
+ (goto-char start)
+ (while (re-search-forward re end t) (incf n))
+ n)))
+
+(defun diff-splittable-p ()
+ (save-excursion
+ (beginning-of-line)
+ (and (looking-at "^[-+ ]")
+ (progn (forward-line -1) (looking-at "^[-+ ]"))
+ (diff-unified-hunk-p))))
+
+(defun diff-split-hunk ()
+ "Split the current (unified diff) hunk at point into two hunks."
+ (interactive)
+ (beginning-of-line)
+ (let ((pos (point))
+ (start (progn (diff-beginning-of-hunk) (point))))
+ (unless (looking-at diff-hunk-header-re-unified)
+ (error "diff-split-hunk only works on unified context diffs"))
+ (forward-line 1)
+ (let* ((start1 (string-to-number (match-string 1)))
+ (start2 (string-to-number (match-string 3)))
+ (newstart1 (+ start1 (diff-count-matches "^[- \t]" (point) pos)))
+ (newstart2 (+ start2 (diff-count-matches "^[+ \t]" (point) pos)))
+ (inhibit-read-only t))
+ (goto-char pos)
+ ;; Hopefully the after-change-function will not screw us over.
+ (insert "@@ -" (number-to-string newstart1) ",1 +"
+ (number-to-string newstart2) ",1 @@\n")
+ ;; Fix the original hunk-header.
+ (diff-fixup-modifs start pos))))
+
+
+;;;;
+;;;; jump to other buffers
+;;;;
+
+(defvar diff-remembered-files-alist nil)
+(defvar diff-remembered-defdir nil)
+
+(defun diff-filename-drop-dir (file)
+ (when (string-match "/" file) (substring file (match-end 0))))
+
+(defun diff-merge-strings (ancestor from to)
+ "Merge the diff between ANCESTOR and FROM into TO.
+Returns the merged string if successful or nil otherwise.
+The strings are assumed not to contain any \"\\n\" (i.e. end of line).
+If ANCESTOR = FROM, returns TO.
+If ANCESTOR = TO, returns FROM.
+The heuristic is simplistic and only really works for cases
+like \(diff-merge-strings \"b/foo\" \"b/bar\" \"/a/c/foo\")."
+ ;; Ideally, we want:
+ ;; AMB ANB CMD -> CND
+ ;; but that's ambiguous if `foo' or `bar' is empty:
+ ;; a/foo a/foo1 b/foo.c -> b/foo1.c but not 1b/foo.c or b/foo.c1
+ (let ((str (concat ancestor "\n" from "\n" to)))
+ (when (and (string-match (concat
+ "\\`\\(.*?\\)\\(.*\\)\\(.*\\)\n"
+ "\\1\\(.*\\)\\3\n"
+ "\\(.*\\(\\2\\).*\\)\\'") str)
+ (equal to (match-string 5 str)))
+ (concat (substring str (match-beginning 5) (match-beginning 6))
+ (match-string 4 str)
+ (substring str (match-end 6) (match-end 5))))))
+
+(defun diff-tell-file-name (old name)
+ "Tell Emacs where the find the source file of the current hunk.
+If the OLD prefix arg is passed, tell the file NAME of the old file."
+ (interactive
+ (let* ((old current-prefix-arg)
+ (fs (diff-hunk-file-names current-prefix-arg)))
+ (unless fs (error "No file name to look for"))
+ (list old (read-file-name (format "File for %s: " (car fs))
+ nil (diff-find-file-name old 'noprompt) t))))
+ (let ((fs (diff-hunk-file-names old)))
+ (unless fs (error "No file name to look for"))
+ (push (cons fs name) diff-remembered-files-alist)))
+
+(defun diff-hunk-file-names (&optional old)
+ "Give the list of file names textually mentioned for the current hunk."
+ (save-excursion
+ (unless (looking-at diff-file-header-re)
+ (or (ignore-errors (diff-beginning-of-file))
+ (re-search-forward diff-file-header-re nil t)))
+ (let ((limit (save-excursion
+ (condition-case ()
+ (progn (diff-hunk-prev) (point))
+ (error (point-min)))))
+ (header-files
+ (if (looking-at "[-*][-*][-*] \\(\\S-+\\)\\(\\s-.*\\)?\n[-+][-+][-+] \\(\\S-+\\)")
+ (list (if old (match-string 1) (match-string 3))
+ (if old (match-string 3) (match-string 1)))
+ (forward-line 1) nil)))
+ (delq nil
+ (append
+ (when (and (not old)
+ (save-excursion
+ (re-search-backward "^Index: \\(.+\\)" limit t)))
+ (list (match-string 1)))
+ header-files
+ (when (re-search-backward
+ "^diff \\(-\\S-+ +\\)*\\(\\S-+\\)\\( +\\(\\S-+\\)\\)?"
+ nil t)
+ (list (if old (match-string 2) (match-string 4))
+ (if old (match-string 4) (match-string 2)))))))))
+
+(defun diff-find-file-name (&optional old noprompt prefix)
+ "Return the file corresponding to the current patch.
+Non-nil OLD means that we want the old file.
+Non-nil NOPROMPT means to prefer returning nil than to prompt the user.
+PREFIX is only used internally: don't use it."
+ (unless (equal diff-remembered-defdir default-directory)
+ ;; Flush diff-remembered-files-alist if the default-directory is changed.
+ (set (make-local-variable 'diff-remembered-defdir) default-directory)
+ (set (make-local-variable 'diff-remembered-files-alist) nil))
+ (save-excursion
+ (unless (looking-at diff-file-header-re)
+ (or (ignore-errors (diff-beginning-of-file))
+ (re-search-forward diff-file-header-re nil t)))
+ (let ((fs (diff-hunk-file-names old)))
+ (if prefix (setq fs (mapcar (lambda (f) (concat prefix f)) fs)))
+ (or
+ ;; use any previously used preference
+ (cdr (assoc fs diff-remembered-files-alist))
+ ;; try to be clever and use previous choices as an inspiration
+ (dolist (rf diff-remembered-files-alist)
+ (let ((newfile (diff-merge-strings (caar rf) (car fs) (cdr rf))))
+ (if (and newfile (file-exists-p newfile)) (return newfile))))
+ ;; look for each file in turn. If none found, try again but
+ ;; ignoring the first level of directory, ...
+ (do* ((files fs (delq nil (mapcar 'diff-filename-drop-dir files)))
+ (file nil nil))
+ ((or (null files)
+ (setq file (do* ((files files (cdr files))
+ (file (car files) (car files)))
+ ;; Use file-regular-p to avoid
+ ;; /dev/null, directories, etc.
+ ((or (null file) (file-regular-p file))
+ file))))
+ file))
+ ;; <foo>.rej patches implicitly apply to <foo>
+ (and (string-match "\\.rej\\'" (or buffer-file-name ""))
+ (let ((file (substring buffer-file-name 0 (match-beginning 0))))
+ (when (file-exists-p file) file)))
+ ;; If we haven't found the file, maybe it's because we haven't paid
+ ;; attention to the PCL-CVS hint.
+ (and (not prefix)
+ (boundp 'cvs-pcl-cvs-dirchange-re)
+ (save-excursion
+ (re-search-backward cvs-pcl-cvs-dirchange-re nil t))
+ (diff-find-file-name old noprompt (match-string 1)))
+ ;; if all else fails, ask the user
+ (unless noprompt
+ (let ((file (read-file-name (format "Use file %s: "
+ (or (first fs) ""))
+ nil (first fs) t (first fs))))
+ (set (make-local-variable 'diff-remembered-files-alist)
+ (cons (cons fs file) diff-remembered-files-alist))
+ file))))))
+
+
+(defun diff-ediff-patch ()
+ "Call `ediff-patch-file' on the current buffer."
+ (interactive)
+ (condition-case err
+ (ediff-patch-file nil (current-buffer))
+ (wrong-number-of-arguments (ediff-patch-file))))
+
+;;;;
+;;;; Conversion functions
+;;;;
+
+;;(defvar diff-inhibit-after-change nil
+;; "Non-nil means inhibit `diff-mode's after-change functions.")
+
+(defun diff-unified->context (start end)
+ "Convert unified diffs to context diffs.
+START and END are either taken from the region (if a prefix arg is given) or
+else cover the whole buffer."
+ (interactive (if (or current-prefix-arg (and transient-mark-mode mark-active))
+ (list (region-beginning) (region-end))
+ (list (point-min) (point-max))))
+ (unless (markerp end) (setq end (copy-marker end t)))
+ (let (;;(diff-inhibit-after-change t)
+ (inhibit-read-only t))
+ (save-excursion
+ (goto-char start)
+ (while (and (re-search-forward
+ (concat "^\\(\\(---\\) .+\n\\(\\+\\+\\+\\) .+\\|"
+ diff-hunk-header-re-unified ".*\\)$")
+ nil t)
+ (< (point) end))
+ (combine-after-change-calls
+ (if (match-beginning 2)
+ ;; we matched a file header
+ (progn
+ ;; use reverse order to make sure the indices are kept valid
+ (replace-match "---" t t nil 3)
+ (replace-match "***" t t nil 2))
+ ;; we matched a hunk header
+ (let ((line1 (match-string 4))
+ (lines1 (or (match-string 5) "1"))
+ (line2 (match-string 6))
+ (lines2 (or (match-string 7) "1"))
+ ;; Variables to use the special undo function.
+ (old-undo buffer-undo-list)
+ (old-end (marker-position end))
+ (start (match-beginning 0))
+ (reversible t))
+ (replace-match
+ (concat "***************\n*** " line1 ","
+ (number-to-string (+ (string-to-number line1)
+ (string-to-number lines1)
+ -1))
+ " ****"))
+ (save-restriction
+ (narrow-to-region (line-beginning-position 2)
+ ;; Call diff-end-of-hunk from just before
+ ;; the hunk header so it can use the hunk
+ ;; header info.
+ (progn (diff-end-of-hunk 'unified) (point)))
+ (let ((hunk (buffer-string)))
+ (goto-char (point-min))
+ (if (not (save-excursion (re-search-forward "^-" nil t)))
+ (delete-region (point) (point-max))
+ (goto-char (point-max))
+ (let ((modif nil) last-pt)
+ (while (progn (setq last-pt (point))
+ (= (forward-line -1) 0))
+ (case (char-after)
+ (?\s (insert " ") (setq modif nil) (backward-char 1))
+ (?+ (delete-region (point) last-pt) (setq modif t))
+ (?- (if (not modif)
+ (progn (forward-char 1)
+ (insert " "))
+ (delete-char 1)
+ (insert "! "))
+ (backward-char 2))
+ (?\\ (when (save-excursion (forward-line -1)
+ (= (char-after) ?+))
+ (delete-region (point) last-pt) (setq modif t)))
+ ;; diff-valid-unified-empty-line.
+ (?\n (insert " ") (setq modif nil) (backward-char 2))
+ (t (setq modif nil))))))
+ (goto-char (point-max))
+ (save-excursion
+ (insert "--- " line2 ","
+ (number-to-string (+ (string-to-number line2)
+ (string-to-number lines2)
+ -1))
+ " ----\n" hunk))
+ ;;(goto-char (point-min))
+ (forward-line 1)
+ (if (not (save-excursion (re-search-forward "^+" nil t)))
+ (delete-region (point) (point-max))
+ (let ((modif nil) (delete nil))
+ (if (save-excursion (re-search-forward "^\\+.*\n-" nil t))
+ ;; Normally, lines in a substitution come with
+ ;; first the removals and then the additions, and
+ ;; the context->unified function follows this
+ ;; convention, of course. Yet, other alternatives
+ ;; are valid as well, but they preclude the use of
+ ;; context->unified as an undo command.
+ (setq reversible nil))
+ (while (not (eobp))
+ (case (char-after)
+ (?\s (insert " ") (setq modif nil) (backward-char 1))
+ (?- (setq delete t) (setq modif t))
+ (?+ (if (not modif)
+ (progn (forward-char 1)
+ (insert " "))
+ (delete-char 1)
+ (insert "! "))
+ (backward-char 2))
+ (?\\ (when (save-excursion (forward-line 1)
+ (not (eobp)))
+ (setq delete t) (setq modif t)))
+ ;; diff-valid-unified-empty-line.
+ (?\n (insert " ") (setq modif nil) (backward-char 2)
+ (setq reversible nil))
+ (t (setq modif nil)))
+ (let ((last-pt (point)))
+ (forward-line 1)
+ (when delete
+ (delete-region last-pt (point))
+ (setq delete nil)))))))
+ (unless (or (not reversible) (eq buffer-undo-list t))
+ ;; Drop the many undo entries and replace them with
+ ;; a single entry that uses diff-context->unified to do
+ ;; the work.
+ (setq buffer-undo-list
+ (cons (list 'apply (- old-end end) start (point-max)
+ 'diff-context->unified start (point-max))
+ old-undo)))))))))))
+
+(defun diff-context->unified (start end &optional to-context)
+ "Convert context diffs to unified diffs.
+START and END are either taken from the region
+\(when it is highlighted) or else cover the whole buffer.
+With a prefix argument, convert unified format to context format."
+ (interactive (if (and transient-mark-mode mark-active)
+ (list (region-beginning) (region-end) current-prefix-arg)
+ (list (point-min) (point-max) current-prefix-arg)))
+ (if to-context
+ (diff-unified->context start end)
+ (unless (markerp end) (setq end (copy-marker end t)))
+ (let ( ;;(diff-inhibit-after-change t)
+ (inhibit-read-only t))
+ (save-excursion
+ (goto-char start)
+ (while (and (re-search-forward "^\\(\\(\\*\\*\\*\\) .+\n\\(---\\) .+\\|\\*\\{15\\}.*\n\\*\\*\\* \\([0-9]+\\),\\(-?[0-9]+\\) \\*\\*\\*\\*\\)$" nil t)
+ (< (point) end))
+ (combine-after-change-calls
+ (if (match-beginning 2)
+ ;; we matched a file header
+ (progn
+ ;; use reverse order to make sure the indices are kept valid
+ (replace-match "+++" t t nil 3)
+ (replace-match "---" t t nil 2))
+ ;; we matched a hunk header
+ (let ((line1s (match-string 4))
+ (line1e (match-string 5))
+ (pt1 (match-beginning 0))
+ ;; Variables to use the special undo function.
+ (old-undo buffer-undo-list)
+ (old-end (marker-position end))
+ (reversible t))
+ (replace-match "")
+ (unless (re-search-forward
+ diff-context-mid-hunk-header-re nil t)
+ (error "Can't find matching `--- n1,n2 ----' line"))
+ (let ((line2s (match-string 1))
+ (line2e (match-string 2))
+ (pt2 (progn
+ (delete-region (progn (beginning-of-line) (point))
+ (progn (forward-line 1) (point)))
+ (point-marker))))
+ (goto-char pt1)
+ (forward-line 1)
+ (while (< (point) pt2)
+ (case (char-after)
+ (?! (delete-char 2) (insert "-") (forward-line 1))
+ (?- (forward-char 1) (delete-char 1) (forward-line 1))
+ (?\s ;merge with the other half of the chunk
+ (let* ((endline2
+ (save-excursion
+ (goto-char pt2) (forward-line 1) (point))))
+ (case (char-after pt2)
+ ((?! ?+)
+ (insert "+"
+ (prog1 (buffer-substring (+ pt2 2) endline2)
+ (delete-region pt2 endline2))))
+ (?\s
+ (unless (= (- endline2 pt2)
+ (- (line-beginning-position 2) (point)))
+ ;; If the two lines we're merging don't have the
+ ;; same length (can happen with "diff -b"), then
+ ;; diff-unified->context will not properly undo
+ ;; this operation.
+ (setq reversible nil))
+ (delete-region pt2 endline2)
+ (delete-char 1)
+ (forward-line 1))
+ (?\\ (forward-line 1))
+ (t (setq reversible nil)
+ (delete-char 1) (forward-line 1)))))
+ (t (setq reversible nil) (forward-line 1))))
+ (while (looking-at "[+! ] ")
+ (if (/= (char-after) ?!) (forward-char 1)
+ (delete-char 1) (insert "+"))
+ (delete-char 1) (forward-line 1))
+ (save-excursion
+ (goto-char pt1)
+ (insert "@@ -" line1s ","
+ (number-to-string (- (string-to-number line1e)
+ (string-to-number line1s)
+ -1))
+ " +" line2s ","
+ (number-to-string (- (string-to-number line2e)
+ (string-to-number line2s)
+ -1)) " @@"))
+ (set-marker pt2 nil)
+ ;; The whole procedure succeeded, let's replace the myriad
+ ;; of undo elements with just a single special one.
+ (unless (or (not reversible) (eq buffer-undo-list t))
+ (setq buffer-undo-list
+ (cons (list 'apply (- old-end end) pt1 (point)
+ 'diff-unified->context pt1 (point))
+ old-undo)))
+ )))))))))
+
+(defun diff-reverse-direction (start end)
+ "Reverse the direction of the diffs.
+START and END are either taken from the region (if a prefix arg is given) or
+else cover the whole buffer."
+ (interactive (if (or current-prefix-arg (and transient-mark-mode mark-active))
+ (list (region-beginning) (region-end))
+ (list (point-min) (point-max))))
+ (unless (markerp end) (setq end (copy-marker end t)))
+ (let (;;(diff-inhibit-after-change t)
+ (inhibit-read-only t))
+ (save-excursion
+ (goto-char start)
+ (while (and (re-search-forward "^\\(\\([-*][-*][-*] \\)\\(.+\\)\n\\([-+][-+][-+] \\)\\(.+\\)\\|\\*\\{15\\}.*\n\\*\\*\\* \\(.+\\) \\*\\*\\*\\*\\|@@ -\\([0-9,]+\\) \\+\\([0-9,]+\\) @@.*\\)$" nil t)
+ (< (point) end))
+ (combine-after-change-calls
+ (cond
+ ;; a file header
+ ((match-beginning 2) (replace-match "\\2\\5\n\\4\\3" nil))
+ ;; a context-diff hunk header
+ ((match-beginning 6)
+ (let ((pt-lines1 (match-beginning 6))
+ (lines1 (match-string 6)))
+ (replace-match "" nil nil nil 6)
+ (forward-line 1)
+ (let ((half1s (point)))
+ (while (looking-at "[-! \\][ \t]\\|#")
+ (when (= (char-after) ?-) (delete-char 1) (insert "+"))
+ (forward-line 1))
+ (let ((half1 (delete-and-extract-region half1s (point))))
+ (unless (looking-at diff-context-mid-hunk-header-re)
+ (insert half1)
+ (error "Can't find matching `--- n1,n2 ----' line"))
+ (let* ((str1end (or (match-end 2) (match-end 1)))
+ (str1 (buffer-substring (match-beginning 1) str1end)))
+ (goto-char str1end)
+ (insert lines1)
+ (delete-region (match-beginning 1) str1end)
+ (forward-line 1)
+ (let ((half2s (point)))
+ (while (looking-at "[!+ \\][ \t]\\|#")
+ (when (= (char-after) ?+) (delete-char 1) (insert "-"))
+ (forward-line 1))
+ (let ((half2 (delete-and-extract-region half2s (point))))
+ (insert (or half1 ""))
+ (goto-char half1s)
+ (insert (or half2 ""))))
+ (goto-char pt-lines1)
+ (insert str1))))))
+ ;; a unified-diff hunk header
+ ((match-beginning 7)
+ (replace-match "@@ -\\8 +\\7 @@" nil)
+ (forward-line 1)
+ (let ((c (char-after)) first last)
+ (while (case (setq c (char-after))
+ (?- (setq first (or first (point)))
+ (delete-char 1) (insert "+") t)
+ (?+ (setq last (or last (point)))
+ (delete-char 1) (insert "-") t)
+ ((?\\ ?#) t)
+ (t (when (and first last (< first last))
+ (insert (delete-and-extract-region first last)))
+ (setq first nil last nil)
+ (memq c (if diff-valid-unified-empty-line
+ '(?\s ?\n) '(?\s)))))
+ (forward-line 1))))))))))
+
+(defun diff-fixup-modifs (start end)
+ "Fixup the hunk headers (in case the buffer was modified).
+START and END are either taken from the region (if a prefix arg is given) or
+else cover the whole buffer."
+ (interactive (if (or current-prefix-arg (and transient-mark-mode mark-active))
+ (list (region-beginning) (region-end))
+ (list (point-min) (point-max))))
+ (let ((inhibit-read-only t))
+ (save-excursion
+ (goto-char end) (diff-end-of-hunk nil 'donttrustheader)
+ (let ((plus 0) (minus 0) (space 0) (bang 0))
+ (while (and (= (forward-line -1) 0) (<= start (point)))
+ (if (not (looking-at
+ (concat diff-hunk-header-re-unified
+ "\\|[-*][-*][-*] [0-9,]+ [-*][-*][-*][-*]$"
+ "\\|--- .+\n\\+\\+\\+ ")))
+ (case (char-after)
+ (?\s (incf space))
+ (?+ (incf plus))
+ (?- (incf minus))
+ (?! (incf bang))
+ ((?\\ ?#) nil)
+ (t (setq space 0 plus 0 minus 0 bang 0)))
+ (cond
+ ((looking-at diff-hunk-header-re-unified)
+ (let* ((old1 (match-string 2))
+ (old2 (match-string 4))
+ (new1 (number-to-string (+ space minus)))
+ (new2 (number-to-string (+ space plus))))
+ (if old2
+ (unless (string= new2 old2) (replace-match new2 t t nil 4))
+ (goto-char (match-end 4)) (insert "," new2))
+ (if old1
+ (unless (string= new1 old1) (replace-match new1 t t nil 2))
+ (goto-char (match-end 2)) (insert "," new1))))
+ ((looking-at diff-context-mid-hunk-header-re)
+ (when (> (+ space bang plus) 0)
+ (let* ((old1 (match-string 1))
+ (old2 (match-string 2))
+ (new (number-to-string
+ (+ space bang plus -1 (string-to-number old1)))))
+ (unless (string= new old2) (replace-match new t t nil 2)))))
+ ((looking-at "\\*\\*\\* \\([0-9]+\\),\\(-?[0-9]*\\) \\*\\*\\*\\*$")
+ (when (> (+ space bang minus) 0)
+ (let* ((old (match-string 1))
+ (new (format
+ (concat "%0" (number-to-string (length old)) "d")
+ (+ space bang minus -1 (string-to-number old)))))
+ (unless (string= new old) (replace-match new t t nil 2))))))
+ (setq space 0 plus 0 minus 0 bang 0)))))))
+
+;;;;
+;;;; Hooks
+;;;;
+
+(defun diff-write-contents-hooks ()
+ "Fixup hunk headers if necessary."
+ (if (buffer-modified-p) (diff-fixup-modifs (point-min) (point-max)))
+ nil)
+
+;; It turns out that making changes in the buffer from within an
+;; *-change-function is asking for trouble, whereas making them
+;; from a post-command-hook doesn't pose much problems
+(defvar diff-unhandled-changes nil)
+(defun diff-after-change-function (beg end len)
+ "Remember to fixup the hunk header.
+See `after-change-functions' for the meaning of BEG, END and LEN."
+ ;; Ignoring changes when inhibit-read-only is set is strictly speaking
+ ;; incorrect, but it turns out that inhibit-read-only is normally not set
+ ;; inside editing commands, while it tends to be set when the buffer gets
+ ;; updated by an async process or by a conversion function, both of which
+ ;; would rather not be uselessly slowed down by this hook.
+ (when (and (not undo-in-progress) (not inhibit-read-only))
+ (if diff-unhandled-changes
+ (setq diff-unhandled-changes
+ (cons (min beg (car diff-unhandled-changes))
+ (max end (cdr diff-unhandled-changes))))
+ (setq diff-unhandled-changes (cons beg end)))))
+
+(defun diff-post-command-hook ()
+ "Fixup hunk headers if necessary."
+ (when (consp diff-unhandled-changes)
+ (ignore-errors
+ (save-excursion
+ (goto-char (car diff-unhandled-changes))
+ ;; Maybe we've cut the end of the hunk before point.
+ (if (and (bolp) (not (bobp))) (backward-char 1))
+ ;; We used to fixup modifs on all the changes, but it turns out that
+ ;; it's safer not to do it on big changes, e.g. when yanking a big
+ ;; diff, or when the user edits the header, since we might then
+ ;; screw up perfectly correct values. --Stef
+ (diff-beginning-of-hunk)
+ (let* ((style (if (looking-at "\\*\\*\\*") 'context))
+ (start (line-beginning-position (if (eq style 'context) 3 2)))
+ (mid (if (eq style 'context)
+ (save-excursion
+ (re-search-forward diff-context-mid-hunk-header-re
+ nil t)))))
+ (when (and ;; Don't try to fixup changes in the hunk header.
+ (> (car diff-unhandled-changes) start)
+ ;; Don't try to fixup changes in the mid-hunk header either.
+ (or (not mid)
+ (< (cdr diff-unhandled-changes) (match-beginning 0))
+ (> (car diff-unhandled-changes) (match-end 0)))
+ (save-excursion
+ (diff-end-of-hunk nil 'donttrustheader)
+ ;; Don't try to fixup changes past the end of the hunk.
+ (>= (point) (cdr diff-unhandled-changes))))
+ (diff-fixup-modifs (point) (cdr diff-unhandled-changes)))))
+ (setq diff-unhandled-changes nil))))
+
+(defun diff-next-error (arg reset)
+ ;; Select a window that displays the current buffer so that point
+ ;; movements are reflected in that window. Otherwise, the user might
+ ;; never see the hunk corresponding to the source she's jumping to.
+ (pop-to-buffer (current-buffer))
+ (if reset (goto-char (point-min)))
+ (diff-hunk-next arg)
+ (diff-goto-source))
+
+(defvar whitespace-style)
+(defvar whitespace-trailing-regexp)
+
+;;;###autoload
+(define-derived-mode diff-mode fundamental-mode "Diff"
+ "Major mode for viewing/editing context diffs.
+Supports unified and context diffs as well as (to a lesser extent)
+normal diffs.
+
+When the buffer is read-only, the ESC prefix is not necessary.
+If you edit the buffer manually, diff-mode will try to update the hunk
+headers for you on-the-fly.
+
+You can also switch between context diff and unified diff with \\[diff-context->unified],
+or vice versa with \\[diff-unified->context] and you can also reverse the direction of
+a diff with \\[diff-reverse-direction].
+
+ \\{diff-mode-map}"
+
+ (set (make-local-variable 'font-lock-defaults) diff-font-lock-defaults)
+ (set (make-local-variable 'outline-regexp) diff-outline-regexp)
+ (set (make-local-variable 'imenu-generic-expression)
+ diff-imenu-generic-expression)
+ ;; These are not perfect. They would be better done separately for
+ ;; context diffs and unidiffs.
+ ;; (set (make-local-variable 'paragraph-start)
+ ;; (concat "@@ " ; unidiff hunk
+ ;; "\\|\\*\\*\\* " ; context diff hunk or file start
+ ;; "\\|--- [^\t]+\t")) ; context or unidiff file
+ ;; ; start (first or second line)
+ ;; (set (make-local-variable 'paragraph-separate) paragraph-start)
+ ;; (set (make-local-variable 'page-delimiter) "--- [^\t]+\t")
+ ;; compile support
+ (set (make-local-variable 'next-error-function) 'diff-next-error)
+
+ (set (make-local-variable 'beginning-of-defun-function)
+ 'diff-beginning-of-file-and-junk)
+ (set (make-local-variable 'end-of-defun-function)
+ 'diff-end-of-file)
+
+ ;; Set up `whitespace-mode' so that turning it on will show trailing
+ ;; whitespace problems on the modified lines of the diff.
+ (set (make-local-variable 'whitespace-style) '(trailing))
+ (set (make-local-variable 'whitespace-trailing-regexp)
+ "^[-\+!<>].*?\\([\t ]+\\)$")
+
+ (setq buffer-read-only diff-default-read-only)
+ ;; setup change hooks
+ (if (not diff-update-on-the-fly)
+ (add-hook 'write-contents-functions 'diff-write-contents-hooks nil t)
+ (make-local-variable 'diff-unhandled-changes)
+ (add-hook 'after-change-functions 'diff-after-change-function nil t)
+ (add-hook 'post-command-hook 'diff-post-command-hook nil t))
+ ;; Neat trick from Dave Love to add more bindings in read-only mode:
+ (lexical-let ((ro-bind (cons 'buffer-read-only diff-mode-shared-map)))
+ (add-to-list 'minor-mode-overriding-map-alist ro-bind)
+ ;; Turn off this little trick in case the buffer is put in view-mode.
+ (add-hook 'view-mode-hook
+ (lambda ()
+ (setq minor-mode-overriding-map-alist
+ (delq ro-bind minor-mode-overriding-map-alist)))
+ nil t))
+ ;; add-log support
+ (set (make-local-variable 'add-log-current-defun-function)
+ 'diff-current-defun)
+ (set (make-local-variable 'add-log-buffer-file-name-function)
+ (lambda () (diff-find-file-name nil 'noprompt)))
+ (unless (buffer-file-name)
+ (hack-dir-local-variables-non-file-buffer)))
+
+;;;###autoload
+(define-minor-mode diff-minor-mode
+ "Minor mode for viewing/editing context diffs.
+\\{diff-minor-mode-map}"
+ :group 'diff-mode :lighter " Diff"
+ ;; FIXME: setup font-lock
+ ;; setup change hooks
+ (if (not diff-update-on-the-fly)
+ (add-hook 'write-contents-functions 'diff-write-contents-hooks nil t)
+ (make-local-variable 'diff-unhandled-changes)
+ (add-hook 'after-change-functions 'diff-after-change-function nil t)
+ (add-hook 'post-command-hook 'diff-post-command-hook nil t)))
+
+;;; Handy hook functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun diff-delete-if-empty ()
+ ;; An empty diff file means there's no more diffs to integrate, so we
+ ;; can just remove the file altogether. Very handy for .rej files if we
+ ;; remove hunks as we apply them.
+ (when (and buffer-file-name
+ (eq 0 (nth 7 (file-attributes buffer-file-name))))
+ (delete-file buffer-file-name)))
+
+(defun diff-delete-empty-files ()
+ "Arrange for empty diff files to be removed."
+ (add-hook 'after-save-hook 'diff-delete-if-empty nil t))
+
+(defun diff-make-unified ()
+ "Turn context diffs into unified diffs if applicable."
+ (if (save-excursion
+ (goto-char (point-min))
+ (and (looking-at diff-hunk-header-re) (eq (char-after) ?*)))
+ (let ((mod (buffer-modified-p)))
+ (unwind-protect
+ (diff-context->unified (point-min) (point-max))
+ (restore-buffer-modified-p mod)))))
+
+;;;
+;;; Misc operations that have proved useful at some point.
+;;;
+
+(defun diff-next-complex-hunk ()
+ "Jump to the next \"complex\" hunk.
+\"Complex\" is approximated by \"the hunk changes the number of lines\".
+Only works for unified diffs."
+ (interactive)
+ (while
+ (and (re-search-forward diff-hunk-header-re-unified nil t)
+ (equal (match-string 2) (match-string 4)))))
+
+(defun diff-sanity-check-context-hunk-half (lines)
+ (let ((count lines))
+ (while
+ (cond
+ ((and (memq (char-after) '(?\s ?! ?+ ?-))
+ (memq (char-after (1+ (point))) '(?\s ?\t)))
+ (decf count) t)
+ ((or (zerop count) (= count lines)) nil)
+ ((memq (char-after) '(?! ?+ ?-))
+ (if (not (and (eq (char-after (1+ (point))) ?\n)
+ (y-or-n-p "Try to auto-fix whitespace loss damage? ")))
+ (error "End of hunk ambiguously marked")
+ (forward-char 1) (insert " ") (forward-line -1) t))
+ ((< lines 0)
+ (error "End of hunk ambiguously marked"))
+ ((not (y-or-n-p "Try to auto-fix whitespace loss and word-wrap damage? "))
+ (error "Abort!"))
+ ((eolp) (insert " ") (forward-line -1) t)
+ (t (insert " ") (delete-region (- (point) 2) (- (point) 1)) t))
+ (forward-line))))
+
+(defun diff-sanity-check-hunk ()
+ (let (;; Every modification is protected by a y-or-n-p, so it's probably
+ ;; OK to override a read-only setting.
+ (inhibit-read-only t))
+ (save-excursion
+ (cond
+ ((not (looking-at diff-hunk-header-re))
+ (error "Not recognizable hunk header"))
+
+ ;; A context diff.
+ ((eq (char-after) ?*)
+ (if (not (looking-at "\\*\\{15\\}\\(?: .*\\)?\n\\*\\*\\* \\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)? \\*\\*\\*\\*"))
+ (error "Unrecognized context diff first hunk header format")
+ (forward-line 2)
+ (diff-sanity-check-context-hunk-half
+ (if (match-end 2)
+ (1+ (- (string-to-number (match-string 2))
+ (string-to-number (match-string 1))))
+ 1))
+ (if (not (looking-at diff-context-mid-hunk-header-re))
+ (error "Unrecognized context diff second hunk header format")
+ (forward-line)
+ (diff-sanity-check-context-hunk-half
+ (if (match-end 2)
+ (1+ (- (string-to-number (match-string 2))
+ (string-to-number (match-string 1))))
+ 1)))))
+
+ ;; A unified diff.
+ ((eq (char-after) ?@)
+ (if (not (looking-at diff-hunk-header-re-unified))
+ (error "Unrecognized unified diff hunk header format")
+ (let ((before (string-to-number (or (match-string 2) "1")))
+ (after (string-to-number (or (match-string 4) "1"))))
+ (forward-line)
+ (while
+ (case (char-after)
+ (?\s (decf before) (decf after) t)
+ (?-
+ (if (and (looking-at diff-file-header-re)
+ (zerop before) (zerop after))
+ ;; No need to query: this is a case where two patches
+ ;; are concatenated and only counting the lines will
+ ;; give the right result. Let's just add an empty
+ ;; line so that our code which doesn't count lines
+ ;; will not get confused.
+ (progn (save-excursion (insert "\n")) nil)
+ (decf before) t))
+ (?+ (decf after) t)
+ (t
+ (cond
+ ((and diff-valid-unified-empty-line
+ ;; Not just (eolp) so we don't infloop at eob.
+ (eq (char-after) ?\n)
+ (> before 0) (> after 0))
+ (decf before) (decf after) t)
+ ((and (zerop before) (zerop after)) nil)
+ ((or (< before 0) (< after 0))
+ (error (if (or (zerop before) (zerop after))
+ "End of hunk ambiguously marked"
+ "Hunk seriously messed up")))
+ ((not (y-or-n-p (concat "Try to auto-fix " (if (eolp) "whitespace loss" "word-wrap damage") "? ")))
+ (error "Abort!"))
+ ((eolp) (insert " ") (forward-line -1) t)
+ (t (insert " ")
+ (delete-region (- (point) 2) (- (point) 1)) t))))
+ (forward-line)))))
+
+ ;; A plain diff.
+ (t
+ ;; TODO.
+ )))))
+
+(defun diff-hunk-text (hunk destp char-offset)
+ "Return the literal source text from HUNK as (TEXT . OFFSET).
+If DESTP is nil, TEXT is the source, otherwise the destination text.
+CHAR-OFFSET is a char-offset in HUNK, and OFFSET is the corresponding
+char-offset in TEXT."
+ (with-temp-buffer
+ (insert hunk)
+ (goto-char (point-min))
+ (let ((src-pos nil)
+ (dst-pos nil)
+ (divider-pos nil)
+ (num-pfx-chars 2))
+ ;; Set the following variables:
+ ;; SRC-POS buffer pos of the source part of the hunk or nil if none
+ ;; DST-POS buffer pos of the destination part of the hunk or nil
+ ;; DIVIDER-POS buffer pos of any divider line separating the src & dst
+ ;; NUM-PFX-CHARS number of line-prefix characters used by this format"
+ (cond ((looking-at "^@@")
+ ;; unified diff
+ (setq num-pfx-chars 1)
+ (forward-line 1)
+ (setq src-pos (point) dst-pos (point)))
+ ((looking-at "^\\*\\*")
+ ;; context diff
+ (forward-line 2)
+ (setq src-pos (point))
+ (re-search-forward diff-context-mid-hunk-header-re nil t)
+ (forward-line 0)
+ (setq divider-pos (point))
+ (forward-line 1)
+ (setq dst-pos (point)))
+ ((looking-at "^[0-9]+a[0-9,]+$")
+ ;; normal diff, insert
+ (forward-line 1)
+ (setq dst-pos (point)))
+ ((looking-at "^[0-9,]+d[0-9]+$")
+ ;; normal diff, delete
+ (forward-line 1)
+ (setq src-pos (point)))
+ ((looking-at "^[0-9,]+c[0-9,]+$")
+ ;; normal diff, change
+ (forward-line 1)
+ (setq src-pos (point))
+ (re-search-forward "^---$" nil t)
+ (forward-line 0)
+ (setq divider-pos (point))
+ (forward-line 1)
+ (setq dst-pos (point)))
+ (t
+ (error "Unknown diff hunk type")))
+
+ (if (if destp (null dst-pos) (null src-pos))
+ ;; Implied empty text
+ (if char-offset '("" . 0) "")
+
+ ;; For context diffs, either side can be empty, (if there's only
+ ;; added or only removed text). We should then use the other side.
+ (cond ((equal src-pos divider-pos) (setq src-pos dst-pos))
+ ((equal dst-pos (point-max)) (setq dst-pos src-pos)))
+
+ (when char-offset (goto-char (+ (point-min) char-offset)))
+
+ ;; Get rid of anything except the desired text.
+ (save-excursion
+ ;; Delete unused text region
+ (let ((keep (if destp dst-pos src-pos)))
+ (when (and divider-pos (> divider-pos keep))
+ (delete-region divider-pos (point-max)))
+ (delete-region (point-min) keep))
+ ;; Remove line-prefix characters, and unneeded lines (unified diffs).
+ (let ((kill-char (if destp ?- ?+)))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (if (eq (char-after) kill-char)
+ (delete-region (point) (progn (forward-line 1) (point)))
+ (delete-char num-pfx-chars)
+ (forward-line 1)))))
+
+ (let ((text (buffer-substring-no-properties (point-min) (point-max))))
+ (if char-offset (cons text (- (point) (point-min))) text))))))
+
+
+(defun diff-find-text (text)
+ "Return the buffer position (BEG . END) of the nearest occurrence of TEXT.
+If TEXT isn't found, nil is returned."
+ (let* ((orig (point))
+ (forw (and (search-forward text nil t)
+ (cons (match-beginning 0) (match-end 0))))
+ (back (and (goto-char (+ orig (length text)))
+ (search-backward text nil t)
+ (cons (match-beginning 0) (match-end 0)))))
+ ;; Choose the closest match.
+ (if (and forw back)
+ (if (> (- (car forw) orig) (- orig (car back))) back forw)
+ (or back forw))))
+
+(defun diff-find-approx-text (text)
+ "Return the buffer position (BEG . END) of the nearest occurrence of TEXT.
+Whitespace differences are ignored."
+ (let* ((orig (point))
+ (re (concat "^[ \t\n\f]*"
+ (mapconcat 'regexp-quote (split-string text) "[ \t\n\f]+")
+ "[ \t\n\f]*\n"))
+ (forw (and (re-search-forward re nil t)
+ (cons (match-beginning 0) (match-end 0))))
+ (back (and (goto-char (+ orig (length text)))
+ (re-search-backward re nil t)
+ (cons (match-beginning 0) (match-end 0)))))
+ ;; Choose the closest match.
+ (if (and forw back)
+ (if (> (- (car forw) orig) (- orig (car back))) back forw)
+ (or back forw))))
+
+(defsubst diff-xor (a b) (if a (if (not b) a) b))
+
+(defun diff-find-source-location (&optional other-file reverse noprompt)
+ "Find out (BUF LINE-OFFSET POS SRC DST SWITCHED).
+BUF is the buffer corresponding to the source file.
+LINE-OFFSET is the offset between the expected and actual positions
+ of the text of the hunk or nil if the text was not found.
+POS is a pair (BEG . END) indicating the position of the text in the buffer.
+SRC and DST are the two variants of text as returned by `diff-hunk-text'.
+ SRC is the variant that was found in the buffer.
+SWITCHED is non-nil if the patch is already applied.
+NOPROMPT, if non-nil, means not to prompt the user."
+ (save-excursion
+ (let* ((other (diff-xor other-file diff-jump-to-old-file))
+ (char-offset (- (point) (progn (diff-beginning-of-hunk 'try-harder)
+ (point))))
+ ;; Check that the hunk is well-formed. Otherwise diff-mode and
+ ;; the user may disagree on what constitutes the hunk
+ ;; (e.g. because an empty line truncates the hunk mid-course),
+ ;; leading to potentially nasty surprises for the user.
+ ;;
+ ;; Suppress check when NOPROMPT is non-nil (Bug#3033).
+ (_ (unless noprompt (diff-sanity-check-hunk)))
+ (hunk (buffer-substring
+ (point) (save-excursion (diff-end-of-hunk) (point))))
+ (old (diff-hunk-text hunk reverse char-offset))
+ (new (diff-hunk-text hunk (not reverse) char-offset))
+ ;; Find the location specification.
+ (line (if (not (looking-at "\\(?:\\*\\{15\\}.*\n\\)?[-@* ]*\\([0-9,]+\\)\\([ acd+]+\\([0-9,]+\\)\\)?"))
+ (error "Can't find the hunk header")
+ (if other (match-string 1)
+ (if (match-end 3) (match-string 3)
+ (unless (re-search-forward
+ diff-context-mid-hunk-header-re nil t)
+ (error "Can't find the hunk separator"))
+ (match-string 1)))))
+ (file (or (diff-find-file-name other noprompt)
+ (error "Can't find the file")))
+ (buf (find-file-noselect file)))
+ ;; Update the user preference if he so wished.
+ (when (> (prefix-numeric-value other-file) 8)
+ (setq diff-jump-to-old-file other))
+ (with-current-buffer buf
+ (goto-char (point-min)) (forward-line (1- (string-to-number line)))
+ (let* ((orig-pos (point))
+ (switched nil)
+ ;; FIXME: Check for case where both OLD and NEW are found.
+ (pos (or (diff-find-text (car old))
+ (progn (setq switched t) (diff-find-text (car new)))
+ (progn (setq switched nil)
+ (condition-case nil
+ (diff-find-approx-text (car old))
+ (invalid-regexp nil))) ;Regex too big.
+ (progn (setq switched t)
+ (condition-case nil
+ (diff-find-approx-text (car new))
+ (invalid-regexp nil))) ;Regex too big.
+ (progn (setq switched nil) nil))))
+ (nconc
+ (list buf)
+ (if pos
+ (list (count-lines orig-pos (car pos)) pos)
+ (list nil (cons orig-pos (+ orig-pos (length (car old))))))
+ (if switched (list new old t) (list old new))))))))
+
+
+(defun diff-hunk-status-msg (line-offset reversed dry-run)
+ (let ((msg (if dry-run
+ (if reversed "already applied" "not yet applied")
+ (if reversed "undone" "applied"))))
+ (message (cond ((null line-offset) "Hunk text not found")
+ ((= line-offset 0) "Hunk %s")
+ ((= line-offset 1) "Hunk %s at offset %d line")
+ (t "Hunk %s at offset %d lines"))
+ msg line-offset)))
+
+(defvar diff-apply-hunk-to-backup-file nil)
+
+(defun diff-apply-hunk (&optional reverse)
+ "Apply the current hunk to the source file and go to the next.
+By default, the new source file is patched, but if the variable
+`diff-jump-to-old-file' is non-nil, then the old source file is
+patched instead (some commands, such as `diff-goto-source' can change
+the value of this variable when given an appropriate prefix argument).
+
+With a prefix argument, REVERSE the hunk."
+ (interactive "P")
+ (destructuring-bind (buf line-offset pos old new &optional switched)
+ ;; Sometimes we'd like to have the following behavior: if REVERSE go
+ ;; to the new file, otherwise go to the old. But that means that by
+ ;; default we use the old file, which is the opposite of the default
+ ;; for diff-goto-source, and is thus confusing. Also when you don't
+ ;; know about it it's pretty surprising.
+ ;; TODO: make it possible to ask explicitly for this behavior.
+ ;;
+ ;; This is duplicated in diff-test-hunk.
+ (diff-find-source-location nil reverse)
+ (cond
+ ((null line-offset)
+ (error "Can't find the text to patch"))
+ ((with-current-buffer buf
+ (and buffer-file-name
+ (backup-file-name-p buffer-file-name)
+ (not diff-apply-hunk-to-backup-file)
+ (not (set (make-local-variable 'diff-apply-hunk-to-backup-file)
+ (yes-or-no-p (format "Really apply this hunk to %s? "
+ (file-name-nondirectory
+ buffer-file-name)))))))
+ (error "%s"
+ (substitute-command-keys
+ (format "Use %s\\[diff-apply-hunk] to apply it to the other file"
+ (if (not reverse) "\\[universal-argument] ")))))
+ ((and switched
+ ;; A reversed patch was detected, perhaps apply it in reverse.
+ (not (save-window-excursion
+ (pop-to-buffer buf)
+ (goto-char (+ (car pos) (cdr old)))
+ (y-or-n-p
+ (if reverse
+ "Hunk hasn't been applied yet; apply it now? "
+ "Hunk has already been applied; undo it? ")))))
+ (message "(Nothing done)"))
+ (t
+ ;; Apply the hunk
+ (with-current-buffer buf
+ (goto-char (car pos))
+ (delete-region (car pos) (cdr pos))
+ (insert (car new)))
+ ;; Display BUF in a window
+ (set-window-point (display-buffer buf) (+ (car pos) (cdr new)))
+ (diff-hunk-status-msg line-offset (diff-xor switched reverse) nil)
+ (when diff-advance-after-apply-hunk
+ (diff-hunk-next))))))
+
+
+(defun diff-test-hunk (&optional reverse)
+ "See whether it's possible to apply the current hunk.
+With a prefix argument, try to REVERSE the hunk."
+ (interactive "P")
+ (destructuring-bind (buf line-offset pos src dst &optional switched)
+ (diff-find-source-location nil reverse)
+ (set-window-point (display-buffer buf) (+ (car pos) (cdr src)))
+ (diff-hunk-status-msg line-offset (diff-xor reverse switched) t)))
+
+
+(defalias 'diff-mouse-goto-source 'diff-goto-source)
+
+(defun diff-goto-source (&optional other-file event)
+ "Jump to the corresponding source line.
+`diff-jump-to-old-file' (or its opposite if the OTHER-FILE prefix arg
+is given) determines whether to jump to the old or the new file.
+If the prefix arg is bigger than 8 (for example with \\[universal-argument] \\[universal-argument])
+then `diff-jump-to-old-file' is also set, for the next invocations."
+ (interactive (list current-prefix-arg last-input-event))
+ ;; When pointing at a removal line, we probably want to jump to
+ ;; the old location, and else to the new (i.e. as if reverting).
+ ;; This is a convenient detail when using smerge-diff.
+ (if event (posn-set-point (event-end event)))
+ (let ((rev (not (save-excursion (beginning-of-line) (looking-at "[-<]")))))
+ (destructuring-bind (buf line-offset pos src dst &optional switched)
+ (diff-find-source-location other-file rev)
+ (pop-to-buffer buf)
+ (goto-char (+ (car pos) (cdr src)))
+ (diff-hunk-status-msg line-offset (diff-xor rev switched) t))))
+
+
+(defun diff-current-defun ()
+ "Find the name of function at point.
+For use in `add-log-current-defun-function'."
+ ;; Kill change-log-default-name so it gets recomputed each time, since
+ ;; each hunk may belong to another file which may belong to another
+ ;; directory and hence have a different ChangeLog file.
+ (kill-local-variable 'change-log-default-name)
+ (save-excursion
+ (when (looking-at diff-hunk-header-re)
+ (forward-line 1)
+ (re-search-forward "^[^ ]" nil t))
+ (destructuring-bind (&optional buf line-offset pos src dst switched)
+ ;; Use `noprompt' since this is used in which-func-mode and such.
+ (ignore-errors ;Signals errors in place of prompting.
+ (diff-find-source-location nil nil 'noprompt))
+ (when buf
+ (beginning-of-line)
+ (or (when (memq (char-after) '(?< ?-))
+ ;; Cursor is pointing at removed text. This could be a removed
+ ;; function, in which case, going to the source buffer will
+ ;; not help since the function is now removed. Instead,
+ ;; try to figure out the function name just from the
+ ;; code-fragment.
+ (let ((old (if switched dst src)))
+ (with-temp-buffer
+ (insert (car old))
+ (funcall (buffer-local-value 'major-mode buf))
+ (goto-char (+ (point-min) (cdr old)))
+ (add-log-current-defun))))
+ (with-current-buffer buf
+ (goto-char (+ (car pos) (cdr src)))
+ (add-log-current-defun)))))))
+
+(defun diff-ignore-whitespace-hunk ()
+ "Re-diff the current hunk, ignoring whitespace differences."
+ (interactive)
+ (let* ((char-offset (- (point) (progn (diff-beginning-of-hunk 'try-harder)
+ (point))))
+ (opts (case (char-after) (?@ "-bu") (?* "-bc") (t "-b")))
+ (line-nb (and (or (looking-at "[^0-9]+\\([0-9]+\\)")
+ (error "Can't find line number"))
+ (string-to-number (match-string 1))))
+ (inhibit-read-only t)
+ (hunk (delete-and-extract-region
+ (point) (save-excursion (diff-end-of-hunk) (point))))
+ (lead (make-string (1- line-nb) ?\n)) ;Line nums start at 1.
+ (file1 (make-temp-file "diff1"))
+ (file2 (make-temp-file "diff2"))
+ (coding-system-for-read buffer-file-coding-system)
+ old new)
+ (unwind-protect
+ (save-excursion
+ (setq old (diff-hunk-text hunk nil char-offset))
+ (setq new (diff-hunk-text hunk t char-offset))
+ (write-region (concat lead (car old)) nil file1 nil 'nomessage)
+ (write-region (concat lead (car new)) nil file2 nil 'nomessage)
+ (with-temp-buffer
+ (let ((status
+ (call-process diff-command nil t nil
+ opts file1 file2)))
+ (case status
+ (0 nil) ;Nothing to reformat.
+ (1 (goto-char (point-min))
+ ;; Remove the file-header.
+ (when (re-search-forward diff-hunk-header-re nil t)
+ (delete-region (point-min) (match-beginning 0))))
+ (t (goto-char (point-max))
+ (unless (bolp) (insert "\n"))
+ (insert hunk)))
+ (setq hunk (buffer-string))
+ (unless (memq status '(0 1))
+ (error "Diff returned: %s" status)))))
+ ;; Whatever happens, put back some equivalent text: either the new
+ ;; one or the original one in case some error happened.
+ (insert hunk)
+ (delete-file file1)
+ (delete-file file2))))
+
+;;; Fine change highlighting.
+
+(defface diff-refine-change
+ '((((class color) (min-colors 88) (background light))
+ :background "grey85")
+ (((class color) (min-colors 88) (background dark))
+ :background "grey60")
+ (((class color) (background light))
+ :background "yellow")
+ (((class color) (background dark))
+ :background "green")
+ (t :weight bold))
+ "Face used for char-based changes shown by `diff-refine-hunk'."
+ :group 'diff-mode)
+
+(defun diff-refine-preproc ()
+ (while (re-search-forward "^[+>]" nil t)
+ ;; Remove spurious changes due to the fact that one side of the hunk is
+ ;; marked with leading + or > and the other with leading - or <.
+ ;; We used to replace all the prefix chars with " " but this only worked
+ ;; when we did char-based refinement (or when using
+ ;; smerge-refine-weight-hack) since otherwise, the `forward' motion done
+ ;; in chopup do not necessarily do the same as the ones in highlight
+ ;; since the "_" is not treated the same as " ".
+ (replace-match (cdr (assq (char-before) '((?+ . "-") (?> . "<"))))))
+ )
+
+(defun diff-refine-hunk ()
+ "Highlight changes of hunk at point at a finer granularity."
+ (interactive)
+ (eval-and-compile (require 'smerge-mode))
+ (save-excursion
+ (diff-beginning-of-hunk 'try-harder)
+ (let* ((start (point))
+ (style (diff-hunk-style)) ;Skips the hunk header as well.
+ (beg (point))
+ (props '((diff-mode . fine) (face diff-refine-change)))
+ ;; Be careful to go back to `start' so diff-end-of-hunk gets
+ ;; to read the hunk header's line info.
+ (end (progn (goto-char start) (diff-end-of-hunk) (point))))
+
+ (remove-overlays beg end 'diff-mode 'fine)
+
+ (goto-char beg)
+ (case style
+ (unified
+ (while (re-search-forward "^\\(?:-.*\n\\)+\\(\\)\\(?:\\+.*\n\\)+"
+ end t)
+ (smerge-refine-subst (match-beginning 0) (match-end 1)
+ (match-end 1) (match-end 0)
+ props 'diff-refine-preproc)))
+ (context
+ (let* ((middle (save-excursion (re-search-forward "^---")))
+ (other middle))
+ (while (re-search-forward "^\\(?:!.*\n\\)+" middle t)
+ (smerge-refine-subst (match-beginning 0) (match-end 0)
+ (save-excursion
+ (goto-char other)
+ (re-search-forward "^\\(?:!.*\n\\)+" end)
+ (setq other (match-end 0))
+ (match-beginning 0))
+ other
+ props 'diff-refine-preproc))))
+ (t ;; Normal diffs.
+ (let ((beg1 (1+ (point))))
+ (when (re-search-forward "^---.*\n" end t)
+ ;; It's a combined add&remove, so there's something to do.
+ (smerge-refine-subst beg1 (match-beginning 0)
+ (match-end 0) end
+ props 'diff-refine-preproc))))))))
+
+
+(defun diff-add-change-log-entries-other-window ()
+ "Iterate through the current diff and create ChangeLog entries.
+I.e. like `add-change-log-entry-other-window' but applied to all hunks."
+ (interactive)
+ ;; XXX: Currently add-change-log-entry-other-window is only called
+ ;; once per hunk. Some hunks have multiple changes, it would be
+ ;; good to call it for each change.
+ (save-excursion
+ (goto-char (point-min))
+ (let ((orig-buffer (current-buffer)))
+ (condition-case nil
+ ;; Call add-change-log-entry-other-window for each hunk in
+ ;; the diff buffer.
+ (while (progn
+ (diff-hunk-next)
+ ;; Move to where the changes are,
+ ;; `add-change-log-entry-other-window' works better in
+ ;; that case.
+ (re-search-forward
+ (concat "\n[!+-<>]"
+ ;; If the hunk is a context hunk with an empty first
+ ;; half, recognize the "--- NNN,MMM ----" line
+ "\\(-- [0-9]+\\(,[0-9]+\\)? ----\n"
+ ;; and skip to the next non-context line.
+ "\\( .*\n\\)*[+]\\)?")
+ nil t))
+ (save-excursion
+ ;; FIXME: this pops up windows of all the buffers.
+ (add-change-log-entry nil nil t nil t)))
+ ;; When there's no more hunks, diff-hunk-next signals an error.
+ (error nil)))))
+
+;; provide the package
+(provide 'diff-mode)
+
+;;; Old Change Log from when diff-mode wasn't part of Emacs:
+;; Revision 1.11 1999/10/09 23:38:29 monnier
+;; (diff-mode-load-hook): dropped.
+;; (auto-mode-alist): also catch *.diffs.
+;; (diff-find-file-name, diff-mode): add smarts to find the right file
+;; for *.rej files (that lack any file name indication).
+;;
+;; Revision 1.10 1999/09/30 15:32:11 monnier
+;; added support for "\ No newline at end of file".
+;;
+;; Revision 1.9 1999/09/15 00:01:13 monnier
+;; - added basic `compile' support.
+;; - have diff-kill-hunk call diff-kill-file if it's the only hunk.
+;; - diff-kill-file now tries to kill the leading garbage as well.
+;;
+;; Revision 1.8 1999/09/13 21:10:09 monnier
+;; - don't use CL in the autoloaded code
+;; - accept diffs using -T
+;;
+;; Revision 1.7 1999/09/05 20:53:03 monnier
+;; interface to ediff-patch
+;;
+;; Revision 1.6 1999/09/01 20:55:13 monnier
+;; (ediff=patch-file): add bindings to call ediff-patch.
+;; (diff-find-file-name): taken out of diff-goto-source.
+;; (diff-unified->context, diff-context->unified, diff-reverse-direction,
+;; diff-fixup-modifs): only use the region if a prefix arg is given.
+;;
+;; Revision 1.5 1999/08/31 19:18:52 monnier
+;; (diff-beginning-of-file, diff-prev-file): fixed wrong parenthesis.
+;;
+;; Revision 1.4 1999/08/31 13:01:44 monnier
+;; use `combine-after-change-calls' to minimize the slowdown of font-lock.
+;;
+
+;; arch-tag: 2571d7ff-bc28-4cf9-8585-42e21890be66
+;;; diff-mode.el ends here
--- /dev/null
- ;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;;; diff.el --- run `diff' in compilation-mode
+
+;; Copyright (C) 1992, 1994, 1996, 2001, 2002, 2003, 2004, 2005, 2006,
++;; 2007, 2008, 2009, 2010, 2011 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 <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This package helps you explore differences between files, using the
+;; UNIX command diff(1). The commands are `diff' and `diff-backup'.
+;; You can specify options with `diff-switches'.
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+(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)
+
+;; 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 &optional old-temp-file new-temp-file)
+ "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 old-temp-file (delete-file old-temp-file))
+ (if new-temp-file (delete-file 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))))))
+
+;;;###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* ((newf (if (and buffer-file-name (file-exists-p buffer-file-name))
+ (read-file-name
+ (concat "Diff new file (default "
+ (file-name-nondirectory buffer-file-name) "): ")
+ nil buffer-file-name t)
+ (read-file-name "Diff new file: " nil nil t)))
+ (oldf (file-newest-backup newf)))
+ (setq 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))))
+ (display-buffer
+ (diff-no-select old new switches no-async)))
+
+(defun diff-file-local-copy (file-or-buf)
+ (if (bufferp file-or-buf)
+ (with-current-buffer file-or-buf
+ (let ((tempfile (make-temp-file "buffer-content-")))
+ (write-region nil nil tempfile nil 'nomessage)
+ tempfile))
+ (file-local-copy file-or-buf)))
+
+(defun diff-no-select (old new &optional switches no-async buf)
+ ;; Noninteractive helper for creating and reverting diff buffers
+ (unless (bufferp new) (setq new (expand-file-name new)))
+ (unless (bufferp old) (setq old (expand-file-name old)))
+ (or switches (setq switches diff-switches)) ; If not specified, use default.
+ (unless (listp switches) (setq switches (list switches)))
+ (or buf (setq buf (get-buffer-create "*Diff*")))
+ (let* ((old-alt (diff-file-local-copy old))
+ (new-alt (diff-file-local-copy new))
+ (command
+ (mapconcat 'identity
+ `(,diff-command
+ ;; Use explicitly specified switches
+ ,@switches
+ ,@(mapcar #'shell-quote-argument
+ (nconc
+ (when (or old-alt new-alt)
+ (list "-L" (if (stringp old)
+ old (prin1-to-string old))
+ "-L" (if (stringp new)
+ new (prin1-to-string new))))
+ (list (or old-alt old)
+ (or new-alt new)))))
+ " "))
+ (thisdir default-directory))
+ (with-current-buffer buf
+ (setq buffer-read-only t)
+ (buffer-disable-undo (current-buffer))
+ (let ((inhibit-read-only t))
+ (erase-buffer))
+ (buffer-enable-undo (current-buffer))
+ (diff-mode)
+ (set (make-local-variable 'revert-buffer-function)
+ (lexical-let ((old old) (new new)
+ (switches switches)
+ (no-async no-async))
+ (lambda (ignore-auto noconfirm)
+ (diff-no-select old new switches no-async (current-buffer)))))
+ (setq default-directory thisdir)
+ (let ((inhibit-read-only t))
+ (insert command "\n"))
+ (if (and (not no-async) (fboundp 'start-process))
+ (let ((proc (start-process "Diff" buf shell-file-name
+ shell-command-switch command)))
+ (set-process-filter proc 'diff-process-filter)
+ (lexical-let ((old-alt old-alt) (new-alt new-alt))
+ (set-process-sentinel
+ proc (lambda (proc msg)
+ (with-current-buffer (process-buffer proc)
+ (diff-sentinel (process-exit-status proc)
+ old-alt new-alt))))))
+ ;; Async processes aren't available.
+ (let ((inhibit-read-only t))
+ (diff-sentinel
+ (call-process shell-file-name nil buf nil
+ shell-command-switch command)
+ old-alt new-alt))))
+ 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))))
+
+;;;###autoload
+(defun diff-buffer-with-file (&optional buffer)
+ "View the differences between BUFFER and its associated file.
+This requires the external program `diff' to be in your `exec-path'."
+ (interactive "bBuffer: ")
+ (with-current-buffer (get-buffer (or buffer (current-buffer)))
+ (diff buffer-file-name (current-buffer) nil 'noasync)))
+
+(provide 'diff)
+
+;;; diff.el ends here
--- /dev/null
- ;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
- ;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
- ;; Free Software Foundation, Inc.
+;;; 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, 2011 Free Software Foundation, Inc.
+
+;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: ediff
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+
+(provide 'ediff-diff)
+
+(eval-when-compile
+ (require 'ediff-util))
+
+(require 'ediff-init)
+
+(defgroup ediff-diff nil
+ "Diff related utilities."
+ :prefix "ediff-"
+ :group 'ediff)
+
+(defcustom ediff-diff-program "diff"
+ "Program to use for generating the differential of the two files."
+ :type 'string
+ :group 'ediff-diff)
+(defcustom ediff-diff3-program "diff3"
+ "Program to be used for three-way comparison.
+Must produce output compatible with Unix's diff3 program."
+ :type 'string
+ :group 'ediff-diff)
+
+
+;; The following functions must precede all defcustom-defined variables.
+
+(fset 'ediff-set-actual-diff-options '(lambda () nil))
+
+(defcustom ediff-shell
+ (cond ((memq system-type '(ms-dos windows-nt))
+ 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)) "--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 '(ms-dos windows-nt))
+ synch)
+ ;; In Windows do it synchronously, since Windows 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.
+ ;; 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:
+
+;;; ediff-diff.el ends here
--- /dev/null
- ;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;;; 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, 2011 Free Software Foundation, Inc.
+
+;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: ediff
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+
+;; Compiler pacifier start
+(defvar ediff-multiframe)
+;; end pacifier
+
+(require 'ediff-init)
+
+;; Help messages
+
+(defconst ediff-long-help-message-head
+ " Move around | Toggle features | Manipulate
+=====================|===========================|============================="
+ "The head of the full help message.")
+(defconst ediff-long-help-message-tail
+ "=====================|===========================|=============================
+ R -show registry | = -compare regions | M -show session group
+ D -diff output | E -browse Ediff manual| G -send bug report
+ i -status info | ? -help off | z/q -suspend/quit
+-------------------------------------------------------------------------------
+For help on a specific command: Click Button 2 over it; or
+ Put the cursor over it and type RET."
+ "The tail of the full-help message.")
+
+(defconst ediff-long-help-message-compare3
+ "
+p,DEL -previous diff | | -vert/horiz split | xy -copy buf X's region to Y
+n,SPC -next diff | h -hilighting | rx -restore buf X's old diff
+ j -jump to diff | @ -auto-refinement | * -refine current region
+ gx -goto X's point| ## -ignore whitespace | ! -update diff regions
+ C-l -recenter | #c -ignore case |
+ v/V -scroll up/dn | #f/#h -focus/hide regions | wx -save buf X
+ </> -scroll lt/rt | X -read-only in buf X | wd -save diff output
+ ~ -rotate buffers| m -wide display |
+"
+ "Help message usually used for 3-way comparison.
+Normally, not a user option. See `ediff-help-message' for details.")
+
+(defconst ediff-long-help-message-compare2
+ "
+p,DEL -previous diff | | -vert/horiz split |a/b -copy A/B's region to B/A
+n,SPC -next diff | h -hilighting | rx -restore buf X's old diff
+ j -jump to diff | @ -auto-refinement | * -refine current region
+ gx -goto X's point| ## -ignore whitespace | ! -update diff regions
+ C-l -recenter | #c -ignore case |
+ v/V -scroll up/dn | #f/#h -focus/hide regions | wx -save buf X
+ </> -scroll lt/rt | X -read-only in buf X | wd -save diff output
+ ~ -swap variants | m -wide display |
+"
+ "Help message usually used for 2-way comparison.
+Normally, not a user option. See `ediff-help-message' for details.")
+
+(defconst ediff-long-help-message-narrow2
+ "
+p,DEL -previous diff | | -vert/horiz split |a/b -copy A/B's region to B/A
+n,SPC -next diff | h -hilighting | rx -restore buf X's old diff
+ j -jump to diff | @ -auto-refinement | * -refine current region
+ gx -goto X's point| ## -ignore whitespace | ! -update diff regions
+ C-l -recenter | #c -ignore case | % -narrow/widen buffs
+ v/V -scroll up/dn | #f/#h -focus/hide regions | wx -save buf X
+ </> -scroll lt/rt | X -read-only in buf X | wd -save diff output
+ ~ -swap variants | m -wide display |
+"
+ "Help message when comparing windows or regions line-by-line.
+Normally, not a user option. See `ediff-help-message' for details.")
+
+(defconst ediff-long-help-message-word-mode
+ "
+p,DEL -previous diff | | -vert/horiz split | xy -copy buf X's region to Y
+n,SPC -next diff | h -hilighting | rx -restore buf X's old diff
+ j -jump to diff | |
+ gx -goto X's point| % -narrow/widen buffs | ! -recompute diffs
+ C-l -recenter | #c -ignore case |
+ v/V -scroll up/dn | #f/#h -focus/hide regions | wx -save buf X
+ </> -scroll lt/rt | X -read-only in buf X | wd -save diff output
+ ~ -swap variants | m -wide display |
+"
+ "Help message when comparing windows or regions word-by-word.
+Normally, not a user option. See `ediff-help-message' for details.")
+
+(defconst ediff-long-help-message-merge
+ "
+p,DEL -previous diff | | -vert/horiz split | x -copy buf X's region to C
+n,SPC -next diff | h -hilighting | r -restore buf C's old diff
+ j -jump to diff | @ -auto-refinement | * -refine current region
+ gx -goto X's point| ## -ignore whitespace | ! -update diff regions
+ C-l -recenter | #f/#h -focus/hide regions | + -combine diff regions
+ v/V -scroll up/dn | X -read-only in buf X | wx -save buf X
+ </> -scroll lt/rt | m -wide display | wd -save diff output
+ ~ -swap variants | s -shrink window C | / -show ancestor buff
+ | $$ -show clashes only | & -merge w/new default
+ | $* -skip changed regions |
+"
+ "Help message for merge sessions.
+Normally, not a user option. See `ediff-help-message' for details.")
+
+;; The actual long help message.
+(ediff-defvar-local ediff-long-help-message ""
+ "Normally, not a user option. See `ediff-help-message' for details.")
+
+(defconst ediff-brief-message-string
+ " Type ? for help"
+ "Contents of the brief help message.")
+;; The actual brief help message
+(ediff-defvar-local ediff-brief-help-message ""
+ "Normally, not a user option. See `ediff-help-message' for details.")
+
+(ediff-defvar-local ediff-brief-help-message-function nil
+ "The brief help message that the user can customize.
+If the user sets this to a parameter-less function, Ediff will use it to
+produce the brief help message. This function must return a string.")
+(ediff-defvar-local ediff-long-help-message-function nil
+ "The long help message that the user can customize.
+See `ediff-brief-help-message-function' for more.")
+
+(defcustom ediff-use-long-help-message nil
+ "If t, Ediff displays a long help message. Short help message otherwise."
+ :type 'boolean
+ :group 'ediff-window)
+
+;; The actual help message.
+(ediff-defvar-local ediff-help-message ""
+ "The actual help message.
+Normally, the user shouldn't touch this. However, if you want Ediff to
+start up with different help messages for different jobs, you can change
+the value of this variable and the variables `ediff-help-message-*' in
+`ediff-startup-hook'.")
+
+
+;; the keymap that defines clicks over the quick help regions
+(defvar ediff-help-region-map (make-sparse-keymap))
+
+(define-key
+ ediff-help-region-map
+ (if (featurep 'emacs) [mouse-2] [button2])
+ 'ediff-help-for-quick-help)
+
+;; runs in the control buffer
+(defun ediff-set-help-overlays ()
+ (goto-char (point-min))
+ (let (overl beg end cmd)
+ (while (re-search-forward " *\\([^ \t\n|]+\\||\\) +-[^|\n]+" nil 'noerror)
+ (setq beg (match-beginning 0)
+ end (match-end 0)
+ cmd (buffer-substring (match-beginning 1) (match-end 1)))
+ (setq overl (ediff-make-overlay beg end))
+ (if (featurep 'emacs)
+ (ediff-overlay-put overl 'mouse-face 'highlight)
+ (ediff-overlay-put overl 'highlight t))
+ (ediff-overlay-put overl 'ediff-help-info cmd))))
+
+
+(defun ediff-help-for-quick-help ()
+ "Explain Ediff commands in more detail."
+ (interactive)
+ (ediff-barf-if-not-control-buffer)
+ (let ((pos (ediff-event-point last-command-event))
+ overl cmd)
+
+ (if (featurep 'xemacs)
+ (setq overl (extent-at pos (current-buffer) 'ediff-help-info)
+ cmd (ediff-overlay-get overl 'ediff-help-info))
+ (setq cmd (car (mapcar (lambda (elt)
+ (overlay-get elt 'ediff-help-info))
+ (overlays-at pos)))))
+
+ (if (not (stringp cmd))
+ (error "Hmm... I don't see an Ediff command around here..."))
+
+ (ediff-documentation "Quick Help Commands")
+
+ (let (case-fold-search)
+ (cond ((string= cmd "?") (re-search-forward "^`\\?'"))
+ ((string= cmd "G") (re-search-forward "^`G'"))
+ ((string= cmd "E") (re-search-forward "^`E'"))
+ ((string= cmd "wd") (re-search-forward "^`wd'"))
+ ((string= cmd "wx") (re-search-forward "^`wa'"))
+ ((string= cmd "a/b") (re-search-forward "^`a'"))
+ ((string= cmd "x") (re-search-forward "^`a'"))
+ ((string= cmd "xy") (re-search-forward "^`ab'"))
+ ((string= cmd "p,DEL") (re-search-forward "^`p'"))
+ ((string= cmd "n,SPC") (re-search-forward "^`n'"))
+ ((string= cmd "j") (re-search-forward "^`j'"))
+ ((string= cmd "gx") (re-search-forward "^`ga'"))
+ ((string= cmd "!") (re-search-forward "^`!'"))
+ ((string= cmd "*") (re-search-forward "^`\\*'"))
+ ((string= cmd "m") (re-search-forward "^`m'"))
+ ((string= cmd "|") (re-search-forward "^`|'"))
+ ((string= cmd "@") (re-search-forward "^`@'"))
+ ((string= cmd "h") (re-search-forward "^`h'"))
+ ((string= cmd "r") (re-search-forward "^`r'"))
+ ((string= cmd "rx") (re-search-forward "^`ra'"))
+ ((string= cmd "##") (re-search-forward "^`##'"))
+ ((string= cmd "#c") (re-search-forward "^`#c'"))
+ ((string= cmd "#f/#h") (re-search-forward "^`#f'"))
+ ((string= cmd "X") (re-search-forward "^`A'"))
+ ((string= cmd "v/V") (re-search-forward "^`v'"))
+ ((string= cmd "</>") (re-search-forward "^`<'"))
+ ((string= cmd "~") (re-search-forward "^`~'"))
+ ((string= cmd "i") (re-search-forward "^`i'"))
+ ((string= cmd "D") (re-search-forward "^`D'"))
+ ((string= cmd "R") (re-search-forward "^`R'"))
+ ((string= cmd "M") (re-search-forward "^`M'"))
+ ((string= cmd "z/q") (re-search-forward "^`z'"))
+ ((string= cmd "%") (re-search-forward "^`%'"))
+ ((string= cmd "C-l") (re-search-forward "^`C-l'"))
+ ((string= cmd "$$") (re-search-forward "^`\\$\\$'"))
+ ((string= cmd "$*") (re-search-forward "^`\\$\\*'"))
+ ((string= cmd "/") (re-search-forward "^`/'"))
+ ((string= cmd "&") (re-search-forward "^`&'"))
+ ((string= cmd "s") (re-search-forward "^`s'"))
+ ((string= cmd "+") (re-search-forward "^`\\+'"))
+ ((string= cmd "=") (re-search-forward "^`='"))
+ (t (error "Undocumented command! Type `G' in Ediff Control Panel to drop a note to the Ediff maintainer")))
+ ) ; let case-fold-search
+ ))
+
+
+;; assuming we are in control window, calculate length of the first line in
+;; help message
+(defun ediff-help-message-line-length ()
+ (save-excursion
+ (goto-char (point-min))
+ (if ediff-use-long-help-message
+ (forward-line 1))
+ (end-of-line)
+ (current-column)))
+
+
+(defun ediff-indent-help-message ()
+ (let* ((shift (/ (max 0 (- (window-width (selected-window))
+ (ediff-help-message-line-length)))
+ 2))
+ (str (make-string shift ?\ )))
+ (save-excursion
+ (goto-char (point-min))
+ (while (< (point) (point-max))
+ (insert str)
+ (beginning-of-line)
+ (forward-line 1)))))
+
+
+;; compose the help message as a string
+(defun ediff-set-help-message ()
+ (setq ediff-long-help-message
+ (cond ((and ediff-long-help-message-function
+ (or (symbolp ediff-long-help-message-function)
+ (consp ediff-long-help-message-function)))
+ (funcall ediff-long-help-message-function))
+ (ediff-word-mode
+ (concat ediff-long-help-message-head
+ ediff-long-help-message-word-mode
+ ediff-long-help-message-tail))
+ (ediff-narrow-job
+ (concat ediff-long-help-message-head
+ ediff-long-help-message-narrow2
+ ediff-long-help-message-tail))
+ (ediff-merge-job
+ (concat ediff-long-help-message-head
+ ediff-long-help-message-merge
+ ediff-long-help-message-tail))
+ (ediff-diff3-job
+ (concat ediff-long-help-message-head
+ ediff-long-help-message-compare3
+ ediff-long-help-message-tail))
+ (t
+ (concat ediff-long-help-message-head
+ ediff-long-help-message-compare2
+ ediff-long-help-message-tail))))
+ (setq ediff-brief-help-message
+ (cond ((and ediff-brief-help-message-function
+ (or (symbolp ediff-brief-help-message-function)
+ (consp ediff-brief-help-message-function)))
+ (funcall ediff-brief-help-message-function))
+ ((stringp ediff-brief-help-message-function)
+ ediff-brief-help-message-function)
+ ((ediff-multiframe-setup-p) ediff-brief-message-string)
+ (t ; long brief msg, not multiframe --- put in the middle
+ ediff-brief-message-string)
+ ))
+ (setq ediff-help-message (if ediff-use-long-help-message
+ ediff-long-help-message
+ ediff-brief-help-message))
+ (run-hooks 'ediff-display-help-hook))
+
+;;;###autoload
+(defun ediff-customize ()
+ (interactive)
+ (customize-group "ediff"))
+
+
+(provide 'ediff-help)
+
+
+;; arch-tag: 05659813-7fcf-4274-964f-d2f577431a9d
+;;; ediff-help.el ends here
--- /dev/null
- ;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;;; 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, 2011 Free Software Foundation, Inc.
+
+;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: ediff
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+;;; These must be placed in menu-bar.el in Emacs
+;;
+;; (define-key menu-bar-tools-menu [ediff-misc]
+;; '("Ediff Miscellanea" . menu-bar-ediff-misc-menu))
+;; (define-key menu-bar-tools-menu [epatch]
+;; '("Apply Patch" . menu-bar-epatch-menu))
+;; (define-key menu-bar-tools-menu [ediff-merge]
+;; '("Merge" . menu-bar-ediff-merge-menu))
+;; (define-key menu-bar-tools-menu [ediff]
+;; '("Compare" . menu-bar-ediff-menu))
+
+;; Compiler pacifier
+(defvar ediff-menu)
+(defvar ediff-merge-menu)
+(defvar epatch-menu)
+(defvar ediff-misc-menu)
+;; end pacifier
+
+;; allow menus to be set up without ediff-wind.el being loaded
+(defvar ediff-window-setup-function)
+
+;; This autoload is useless in Emacs because ediff-hook.el is dumped with
+;; emacs, but it is needed in XEmacs
+;;;###autoload
+(if (featurep 'xemacs)
+ (progn
+ (defun ediff-xemacs-init-menus ()
+ (when (featurep 'menubar)
+ (add-submenu
+ '("Tools") ediff-menu "OO-Browser...")
+ (add-submenu
+ '("Tools") ediff-merge-menu "OO-Browser...")
+ (add-submenu
+ '("Tools") epatch-menu "OO-Browser...")
+ (add-submenu
+ '("Tools") ediff-misc-menu "OO-Browser...")
+ (add-menu-button
+ '("Tools") "-------" "OO-Browser...")
+ ))
+ (defvar ediff-menu
+ '("Compare"
+ ["Two Files..." ediff-files t]
+ ["Two Buffers..." ediff-buffers t]
+ ["Three Files..." ediff-files3 t]
+ ["Three Buffers..." ediff-buffers3 t]
+ "---"
+ ["Two Directories..." ediff-directories t]
+ ["Three Directories..." ediff-directories3 t]
+ "---"
+ ["File with Revision..." ediff-revision t]
+ ["Directory Revisions..." ediff-directory-revisions t]
+ "---"
+ ["Windows Word-by-word..." ediff-windows-wordwise t]
+ ["Windows Line-by-line..." ediff-windows-linewise t]
+ "---"
+ ["Regions Word-by-word..." ediff-regions-wordwise t]
+ ["Regions Line-by-line..." ediff-regions-linewise t]
+ ))
+ (defvar ediff-merge-menu
+ '("Merge"
+ ["Files..." ediff-merge-files t]
+ ["Files with Ancestor..." ediff-merge-files-with-ancestor t]
+ ["Buffers..." ediff-merge-buffers t]
+ ["Buffers with Ancestor..."
+ ediff-merge-buffers-with-ancestor t]
+ "---"
+ ["Directories..." ediff-merge-directories t]
+ ["Directories with Ancestor..."
+ ediff-merge-directories-with-ancestor t]
+ "---"
+ ["Revisions..." ediff-merge-revisions t]
+ ["Revisions with Ancestor..."
+ ediff-merge-revisions-with-ancestor t]
+ ["Directory Revisions..." ediff-merge-directory-revisions t]
+ ["Directory Revisions with Ancestor..."
+ ediff-merge-directory-revisions-with-ancestor t]
+ ))
+ (defvar epatch-menu
+ '("Apply Patch"
+ ["To a file..." ediff-patch-file t]
+ ["To a buffer..." ediff-patch-buffer t]
+ ))
+ (defvar ediff-misc-menu
+ '("Ediff Miscellanea"
+ ["Ediff Manual" ediff-documentation t]
+ ["Customize Ediff" ediff-customize t]
+ ["List Ediff Sessions" ediff-show-registry t]
+ ["Use separate frame for Ediff control buffer"
+ ediff-toggle-multiframe
+ :style toggle
+ :selected (if (and (featurep 'ediff-util)
+ (boundp 'ediff-window-setup-function))
+ (eq ediff-window-setup-function
+ 'ediff-setup-windows-multiframe))]
+ ["Use a toolbar with Ediff control buffer"
+ ediff-toggle-use-toolbar
+ :style toggle
+ :selected (if (featurep 'ediff-tbar)
+ (ediff-use-toolbar-p))]))
+
+ ;; put these menus before Object-Oriented-Browser in Tools menu
+ (if (and (featurep 'menubar) (not (featurep 'infodock))
+ (not (featurep 'ediff-hook)))
+ (ediff-xemacs-init-menus)))
+ ;; Emacs
+ ;; initialize menu bar keymaps
+ (defvar menu-bar-ediff-misc-menu
+ (make-sparse-keymap "Ediff Miscellanea"))
+ (fset 'menu-bar-ediff-misc-menu
+ (symbol-value 'menu-bar-ediff-misc-menu))
+ (defvar menu-bar-epatch-menu (make-sparse-keymap "Apply Patch"))
+ (fset 'menu-bar-epatch-menu (symbol-value 'menu-bar-epatch-menu))
+ (defvar menu-bar-ediff-merge-menu (make-sparse-keymap "Merge"))
+ (fset 'menu-bar-ediff-merge-menu
+ (symbol-value 'menu-bar-ediff-merge-menu))
+ (defvar menu-bar-ediff-menu (make-sparse-keymap "Compare"))
+ (fset 'menu-bar-ediff-menu (symbol-value 'menu-bar-ediff-menu))
+
+ ;; define ediff compare menu
+ (define-key menu-bar-ediff-menu [ediff-misc]
+ `(menu-item ,(purecopy "Ediff Miscellanea") menu-bar-ediff-misc-menu))
+ (define-key menu-bar-ediff-menu [separator-ediff-misc] menu-bar-separator)
+ (define-key menu-bar-ediff-menu [window]
+ `(menu-item ,(purecopy "This Window and Next Window") compare-windows
+ :help ,(purecopy "Compare the current window and the next window")))
+ (define-key menu-bar-ediff-menu [ediff-windows-linewise]
+ `(menu-item ,(purecopy "Windows Line-by-line...") ediff-windows-linewise
+ :help ,(purecopy "Compare windows line-wise")))
+ (define-key menu-bar-ediff-menu [ediff-windows-wordwise]
+ `(menu-item ,(purecopy "Windows Word-by-word...") ediff-windows-wordwise
+ :help ,(purecopy "Compare windows word-wise")))
+ (define-key menu-bar-ediff-menu [separator-ediff-windows] menu-bar-separator)
+ (define-key menu-bar-ediff-menu [ediff-regions-linewise]
+ `(menu-item ,(purecopy "Regions Line-by-line...") ediff-regions-linewise
+ :help ,(purecopy "Compare regions line-wise")))
+ (define-key menu-bar-ediff-menu [ediff-regions-wordwise]
+ `(menu-item ,(purecopy "Regions Word-by-word...") ediff-regions-wordwise
+ :help ,(purecopy "Compare regions word-wise")))
+ (define-key menu-bar-ediff-menu [separator-ediff-regions] menu-bar-separator)
+ (define-key menu-bar-ediff-menu [ediff-dir-revision]
+ `(menu-item ,(purecopy "Directory Revisions...") ediff-directory-revisions
+ :help ,(purecopy "Compare directory files with their older versions")))
+ (define-key menu-bar-ediff-menu [ediff-revision]
+ `(menu-item ,(purecopy "File with Revision...") ediff-revision
+ :help ,(purecopy "Compare file with its older versions")))
+ (define-key menu-bar-ediff-menu [separator-ediff-directories] menu-bar-separator)
+ (define-key menu-bar-ediff-menu [ediff-directories3]
+ `(menu-item ,(purecopy "Three Directories...") ediff-directories3
+ :help ,(purecopy "Compare files common to three directories simultaneously")))
+ (define-key menu-bar-ediff-menu [ediff-directories]
+ `(menu-item ,(purecopy "Two Directories...") ediff-directories
+ :help ,(purecopy "Compare files common to two directories simultaneously")))
+ (define-key menu-bar-ediff-menu [separator-ediff-files] menu-bar-separator)
+ (define-key menu-bar-ediff-menu [ediff-buffers3]
+ `(menu-item ,(purecopy "Three Buffers...") ediff-buffers3
+ :help ,(purecopy "Compare three buffers simultaneously")))
+ (define-key menu-bar-ediff-menu [ediff-files3]
+ `(menu-item ,(purecopy "Three Files...") ediff-files3
+ :help ,(purecopy "Compare three files simultaneously")))
+ (define-key menu-bar-ediff-menu [ediff-buffers]
+ `(menu-item ,(purecopy "Two Buffers...") ediff-buffers
+ :help ,(purecopy "Compare two buffers simultaneously")))
+ (define-key menu-bar-ediff-menu [ediff-files]
+ `(menu-item ,(purecopy "Two Files...") ediff-files
+ :help ,(purecopy "Compare two files simultaneously")))
+
+ ;; define ediff merge menu
+ (define-key
+ menu-bar-ediff-merge-menu [ediff-merge-dir-revisions-with-ancestor]
+ `(menu-item ,(purecopy "Directory Revisions with Ancestor...")
+ ediff-merge-directory-revisions-with-ancestor
+ :help ,(purecopy "Merge versions of the files in the same directory by comparing the files with common ancestors")))
+ (define-key
+ menu-bar-ediff-merge-menu [ediff-merge-dir-revisions]
+ `(menu-item ,(purecopy "Directory Revisions...") ediff-merge-directory-revisions
+ :help ,(purecopy "Merge versions of the files in the same directory (without using ancestor information)")))
+ (define-key
+ menu-bar-ediff-merge-menu [ediff-merge-revisions-with-ancestor]
+ `(menu-item ,(purecopy "Revisions with Ancestor...")
+ ediff-merge-revisions-with-ancestor
+ :help ,(purecopy "Merge versions of the same file by comparing them with a common ancestor")))
+ (define-key menu-bar-ediff-merge-menu [ediff-merge-revisions]
+ `(menu-item ,(purecopy "Revisions...") ediff-merge-revisions
+ :help ,(purecopy "Merge versions of the same file (without using ancestor information)")))
+ (define-key menu-bar-ediff-merge-menu [separator-ediff-merge] menu-bar-separator)
+ (define-key
+ menu-bar-ediff-merge-menu [ediff-merge-directories-with-ancestor]
+ `(menu-item ,(purecopy "Directories with Ancestor...")
+ ediff-merge-directories-with-ancestor
+ :help ,(purecopy "Merge files common to a pair of directories by comparing the files with common ancestors")))
+ (define-key menu-bar-ediff-merge-menu [ediff-merge-directories]
+ `(menu-item ,(purecopy "Directories...") ediff-merge-directories
+ :help ,(purecopy "Merge files common to a pair of directories")))
+ (define-key
+ menu-bar-ediff-merge-menu [separator-ediff-merge-dirs] menu-bar-separator)
+ (define-key
+ menu-bar-ediff-merge-menu [ediff-merge-buffers-with-ancestor]
+ `(menu-item ,(purecopy "Buffers with Ancestor...") ediff-merge-buffers-with-ancestor
+ :help ,(purecopy "Merge buffers by comparing their contents with a common ancestor")))
+ (define-key menu-bar-ediff-merge-menu [ediff-merge-buffers]
+ `(menu-item ,(purecopy "Buffers...") ediff-merge-buffers
+ :help ,(purecopy "Merge buffers (without using ancestor information)")))
+ (define-key menu-bar-ediff-merge-menu [ediff-merge-files-with-ancestor]
+ `(menu-item ,(purecopy "Files with Ancestor...") ediff-merge-files-with-ancestor
+ :help ,(purecopy "Merge files by comparing them with a common ancestor")))
+ (define-key menu-bar-ediff-merge-menu [ediff-merge-files]
+ `(menu-item ,(purecopy "Files...") ediff-merge-files
+ :help ,(purecopy "Merge files (without using ancestor information)")))
+
+ ;; define epatch menu
+ (define-key menu-bar-epatch-menu [ediff-patch-buffer]
+ `(menu-item ,(purecopy "To a Buffer...") ediff-patch-buffer
+ :help ,(purecopy "Apply a patch to the contents of a buffer")))
+ (define-key menu-bar-epatch-menu [ediff-patch-file]
+ `(menu-item ,(purecopy "To a File...") ediff-patch-file
+ :help ,(purecopy "Apply a patch to a file")))
+
+ ;; define ediff miscellanea
+ (define-key menu-bar-ediff-misc-menu [emultiframe]
+ `(menu-item ,(purecopy "Use separate control buffer frame")
+ ediff-toggle-multiframe
+ :help ,(purecopy "Switch between the single-frame presentation mode and the multi-frame mode")))
+ (define-key menu-bar-ediff-misc-menu [eregistry]
+ `(menu-item ,(purecopy "List Ediff Sessions") ediff-show-registry
+ :help ,(purecopy "List all active Ediff sessions; it is a convenient way to find and resume such a session")))
+ (define-key menu-bar-ediff-misc-menu [ediff-cust]
+ `(menu-item ,(purecopy "Customize Ediff") ediff-customize
+ :help ,(purecopy "Change some of the parameters that govern the behavior of Ediff")))
+ (define-key menu-bar-ediff-misc-menu [ediff-doc]
+ `(menu-item ,(purecopy "Ediff Manual") ediff-documentation
+ :help ,(purecopy "Bring up the Ediff manual"))))
+
+(provide 'ediff-hook)
+
+
+;; arch-tag: 512f8656-8a4b-4789-af5d-5c6144498df3
+;;; ediff-hook.el ends here
--- /dev/null
- ;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;;; 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, 2011 Free Software Foundation, Inc.
+
+;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: ediff
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+;; Start compiler pacifier
+(defvar ediff-metajob-name)
+(defvar ediff-meta-buffer)
+(defvar ediff-grab-mouse)
+(defvar ediff-mouse-pixel-position)
+(defvar ediff-mouse-pixel-threshold)
+(defvar ediff-whitespace)
+(defvar ediff-multiframe)
+(defvar ediff-use-toolbar-p)
+(defvar mswindowsx-bitmap-file-path)
+;; end pacifier
+
+(defvar ediff-force-faces nil
+ "If t, Ediff will think that it is running on a display that supports faces.
+This is provided as a temporary relief for users of face-capable displays
+that Ediff doesn't know about.")
+
+;; Are we running as a window application or on a TTY?
+(defsubst ediff-device-type ()
+ (if (featurep 'xemacs)
+ (device-type (selected-device))
+ window-system))
+
+;; in XEmacs: device-type is tty on tty and stream in batch.
+(defun ediff-window-display-p ()
+ (and (ediff-device-type) (not (memq (ediff-device-type) '(tty pc stream)))))
+
+;; test if supports faces
+(defun ediff-has-face-support-p ()
+ (cond ((ediff-window-display-p))
+ (ediff-force-faces)
+ ((ediff-color-display-p))
+ ((featurep 'emacs) (memq (ediff-device-type) '(pc)))
+ ((featurep 'xemacs) (memq (ediff-device-type) '(tty pc)))
+ ))
+
+;; toolbar support for emacs hasn't been implemented in ediff
+(defun ediff-has-toolbar-support-p ()
+ (if (featurep 'xemacs)
+ (if (featurep 'toolbar) (console-on-window-system-p))))
+
+
+(defun ediff-has-gutter-support-p ()
+ (if (featurep 'xemacs)
+ (if (featurep 'gutter) (console-on-window-system-p))))
+
+(defun ediff-use-toolbar-p ()
+ (and (ediff-has-toolbar-support-p) ;Can it do it ?
+ (boundp 'ediff-use-toolbar-p)
+ ediff-use-toolbar-p)) ;Does the user want it ?
+
+;; Defines VAR as an advertised local variable.
+;; Performs a defvar, then executes `make-variable-buffer-local' on
+;; the variable. Also sets the `permanent-local' property,
+;; so that `kill-all-local-variables' (called by major-mode setting
+;; commands) won't destroy Ediff control variables.
+;;
+;; Plagiarised from `emerge-defvar-local' for XEmacs.
+(defmacro ediff-defvar-local (var value doc)
+ "Defines VAR as a local variable."
+ (declare (indent defun))
+ `(progn
+ (defvar ,var ,value ,doc)
+ (make-variable-buffer-local ',var)
+ (put ',var 'permanent-local t)))
+
+
+
+;; Variables that control each Ediff session---local to the control buffer.
+
+;; Mode variables
+;; The buffer in which the A variant is stored.
+(ediff-defvar-local ediff-buffer-A nil "")
+;; The buffer in which the B variant is stored.
+(ediff-defvar-local ediff-buffer-B nil "")
+;; The buffer in which the C variant is stored or where the merge buffer lives.
+(ediff-defvar-local ediff-buffer-C nil "")
+;; Ancestor buffer
+(ediff-defvar-local ediff-ancestor-buffer nil "")
+;; The Ediff control buffer
+(ediff-defvar-local ediff-control-buffer nil "")
+
+(ediff-defvar-local ediff-temp-indirect-buffer nil
+ "If t, the buffer is a temporary indirect buffer.
+It needs to be killed when we quit the session.")
+
+
+;; Association between buff-type and ediff-buffer-*
+(defconst ediff-buffer-alist
+ '((?A . ediff-buffer-A)
+ (?B . ediff-buffer-B)
+ (?C . ediff-buffer-C)))
+
+;;; Macros
+(defmacro ediff-odd-p (arg)
+ `(eq (logand ,arg 1) 1))
+
+(defmacro ediff-buffer-live-p (buf)
+ `(and ,buf (get-buffer ,buf) (buffer-name (get-buffer ,buf))))
+
+(defmacro ediff-get-buffer (arg)
+ `(cond ((eq ,arg 'A) ediff-buffer-A)
+ ((eq ,arg 'B) ediff-buffer-B)
+ ((eq ,arg 'C) ediff-buffer-C)
+ ((eq ,arg 'Ancestor) ediff-ancestor-buffer)
+ ))
+
+(defmacro ediff-get-value-according-to-buffer-type (buf-type list)
+ `(cond ((eq ,buf-type 'A) (nth 0 ,list))
+ ((eq ,buf-type 'B) (nth 1 ,list))
+ ((eq ,buf-type 'C) (nth 2 ,list))
+ ))
+
+(defmacro ediff-char-to-buftype (arg)
+ `(cond ((memq ,arg '(?a ?A)) 'A)
+ ((memq ,arg '(?b ?B)) 'B)
+ ((memq ,arg '(?c ?C)) 'C)
+ ))
+
+
+;; A-list is supposed to be of the form (A . symb) (B . symb)...)
+;; where the first part of any association is a buffer type and the second is
+;; an appropriate symbol. Given buffer-type, this function returns the
+;; symbol. This is used to avoid using `intern'
+(defsubst ediff-get-symbol-from-alist (buf-type alist)
+ (cdr (assoc buf-type alist)))
+
+(defconst ediff-difference-vector-alist
+ '((A . ediff-difference-vector-A)
+ (B . ediff-difference-vector-B)
+ (C . ediff-difference-vector-C)
+ (Ancestor . ediff-difference-vector-Ancestor)))
+
+(defmacro ediff-get-difference (n buf-type)
+ `(aref
+ (symbol-value
+ (ediff-get-symbol-from-alist
+ ,buf-type ediff-difference-vector-alist))
+ ,n))
+
+;; Tell if it has been previously determined that the region has
+;; no diffs other than the white space and newlines
+;; The argument, N, is the diff region number used by Ediff to index the
+;; diff vector. It is 1 less than the number seen by the user.
+;; Returns:
+;; t if the diffs are whitespace in all buffers
+;; 'A (in 3-buf comparison only) if there are only whitespace
+;; diffs in bufs B and C
+;; 'B (in 3-buf comparison only) if there are only whitespace
+;; diffs in bufs A and C
+;; 'C (in 3-buf comparison only) if there are only whitespace
+;; diffs in bufs A and B
+;;
+;; A Difference Vector has the form:
+;; [diff diff diff ...]
+;; where each diff has the form:
+;; [overlay fine-diff-vector no-fine-diffs-flag state-of-difference]
+;; fine-diff-vector is a vector [fine-diff fine-diff fine-diff ...]
+;; no-fine-diffs-flag says if there are fine differences.
+;; state-of-difference is A, B, C, or nil, indicating which buffer is
+;; different from the other two (used only in 3-way jobs).
+(defmacro ediff-no-fine-diffs-p (n)
+ `(aref (ediff-get-difference ,n 'A) 2))
+
+(defmacro ediff-get-diff-overlay-from-diff-record (diff-rec)
+ `(aref ,diff-rec 0))
+
+(defmacro ediff-get-diff-overlay (n buf-type)
+ `(ediff-get-diff-overlay-from-diff-record
+ (ediff-get-difference ,n ,buf-type)))
+
+(defmacro ediff-get-fine-diff-vector-from-diff-record (diff-rec)
+ `(aref ,diff-rec 1))
+
+(defmacro ediff-set-fine-diff-vector (n buf-type fine-vec)
+ `(aset (ediff-get-difference ,n ,buf-type) 1 ,fine-vec))
+
+(defmacro ediff-get-state-of-diff (n buf-type)
+ `(if (ediff-buffer-live-p ediff-buffer-C)
+ (aref (ediff-get-difference ,n ,buf-type) 3)))
+(defmacro ediff-set-state-of-diff (n buf-type val)
+ `(aset (ediff-get-difference ,n ,buf-type) 3 ,val))
+
+(defmacro ediff-get-state-of-merge (n)
+ `(if ediff-state-of-merge
+ (aref (aref ediff-state-of-merge ,n) 0)))
+(defmacro ediff-set-state-of-merge (n val)
+ `(if ediff-state-of-merge
+ (aset (aref ediff-state-of-merge ,n) 0 ,val)))
+
+(defmacro ediff-get-state-of-ancestor (n)
+ `(if ediff-state-of-merge
+ (aref (aref ediff-state-of-merge ,n) 1)))
+
+;; if flag is t, puts a mark on diff region saying that
+;; the differences are in white space only. If flag is nil,
+;; the region is marked as essential (i.e., differences are
+;; not just in the white space and newlines.)
+(defmacro ediff-mark-diff-as-space-only (n flag)
+ `(aset (ediff-get-difference ,n 'A) 2 ,flag))
+
+(defmacro ediff-get-fine-diff-vector (n buf-type)
+ `(ediff-get-fine-diff-vector-from-diff-record
+ (ediff-get-difference ,n ,buf-type)))
+
+;; Macro to switch to BUFFER, evaluate BODY, returns to original buffer.
+;; Doesn't save the point and mark.
+;; This is `with-current-buffer' with the added test for live buffers."
+(defmacro ediff-with-current-buffer (buffer &rest body)
+ "Evaluates BODY in BUFFER."
+ (declare (indent 1) (debug (form body)))
+ `(if (ediff-buffer-live-p ,buffer)
+ (save-current-buffer
+ (set-buffer ,buffer)
+ ,@body)
+ (or (eq this-command 'ediff-quit)
+ (error ediff-KILLED-VITAL-BUFFER))
+ ))
+
+
+(defsubst ediff-multiframe-setup-p ()
+ (and (ediff-window-display-p) ediff-multiframe))
+
+(defmacro ediff-narrow-control-frame-p ()
+ `(and (ediff-multiframe-setup-p)
+ (equal ediff-help-message ediff-brief-message-string)))
+
+(defmacro ediff-3way-comparison-job ()
+ `(memq
+ ediff-job-name
+ '(ediff-files3 ediff-buffers3)))
+(ediff-defvar-local ediff-3way-comparison-job nil "")
+
+(defmacro ediff-merge-job ()
+ `(memq
+ ediff-job-name
+ '(ediff-merge-files
+ ediff-merge-buffers
+ ediff-merge-files-with-ancestor
+ ediff-merge-buffers-with-ancestor
+ ediff-merge-revisions
+ ediff-merge-revisions-with-ancestor)))
+(ediff-defvar-local ediff-merge-job nil "")
+
+(defmacro ediff-patch-job ()
+ `(eq ediff-job-name 'epatch))
+
+(defmacro ediff-merge-with-ancestor-job ()
+ `(memq
+ ediff-job-name
+ '(ediff-merge-files-with-ancestor
+ ediff-merge-buffers-with-ancestor
+ ediff-merge-revisions-with-ancestor)))
+(ediff-defvar-local ediff-merge-with-ancestor-job nil "")
+
+(defmacro ediff-3way-job ()
+ `(or ediff-3way-comparison-job ediff-merge-job))
+(ediff-defvar-local ediff-3way-job nil "")
+
+;; A diff3 job is like a 3way job, but ediff-merge doesn't require the use
+;; of diff3.
+(defmacro ediff-diff3-job ()
+ `(or ediff-3way-comparison-job
+ ediff-merge-with-ancestor-job))
+(ediff-defvar-local ediff-diff3-job nil "")
+
+(defmacro ediff-windows-job ()
+ `(memq ediff-job-name '(ediff-windows-wordwise ediff-windows-linewise)))
+(ediff-defvar-local ediff-windows-job nil "")
+
+(defmacro ediff-word-mode-job ()
+ `(memq ediff-job-name '(ediff-windows-wordwise ediff-regions-wordwise)))
+(ediff-defvar-local ediff-word-mode-job nil "")
+
+(defmacro ediff-narrow-job ()
+ `(memq ediff-job-name '(ediff-windows-wordwise
+ ediff-regions-wordwise
+ ediff-windows-linewise
+ ediff-regions-linewise)))
+(ediff-defvar-local ediff-narrow-job nil "")
+
+;; Note: ediff-merge-directory-revisions-with-ancestor is not treated as an
+;; ancestor metajob, since it behaves differently.
+(defsubst ediff-ancestor-metajob (&optional metajob)
+ (memq (or metajob ediff-metajob-name)
+ '(ediff-merge-directories-with-ancestor
+ ediff-merge-filegroups-with-ancestor)))
+(defsubst ediff-revision-metajob (&optional metajob)
+ (memq (or metajob ediff-metajob-name)
+ '(ediff-directory-revisions
+ ediff-merge-directory-revisions
+ ediff-merge-directory-revisions-with-ancestor)))
+(defsubst ediff-patch-metajob (&optional metajob)
+ (memq (or metajob ediff-metajob-name)
+ '(ediff-multifile-patch)))
+;; metajob involving only one group of files, such as multipatch or directory
+;; revision
+(defsubst ediff-one-filegroup-metajob (&optional metajob)
+ (or (ediff-revision-metajob metajob)
+ (ediff-patch-metajob metajob)
+ ;; add more here
+ ))
+;; jobs suitable for the operation of collecting diffs into a multifile patch
+(defsubst ediff-collect-diffs-metajob (&optional metajob)
+ (memq (or metajob ediff-metajob-name)
+ '(ediff-directories
+ ediff-merge-directories
+ ediff-merge-directories-with-ancestor
+ ediff-directory-revisions
+ ediff-merge-directory-revisions
+ ediff-merge-directory-revisions-with-ancestor
+ ;; add more here
+ )))
+(defsubst ediff-merge-metajob (&optional metajob)
+ (memq (or metajob ediff-metajob-name)
+ '(ediff-merge-directories
+ ediff-merge-directories-with-ancestor
+ ediff-merge-directory-revisions
+ ediff-merge-directory-revisions-with-ancestor
+ ediff-merge-filegroups-with-ancestor
+ ;; add more here
+ )))
+
+(defsubst ediff-metajob3 (&optional metajob)
+ (memq (or metajob ediff-metajob-name)
+ '(ediff-merge-directories-with-ancestor
+ ediff-merge-filegroups-with-ancestor
+ ediff-directories3
+ ediff-filegroups3)))
+(defsubst ediff-comparison-metajob3 (&optional metajob)
+ (memq (or metajob ediff-metajob-name)
+ '(ediff-directories3 ediff-filegroups3)))
+
+;; with no argument, checks if we are in ediff-control-buffer
+;; with argument, checks if we are in ediff-meta-buffer
+(defun ediff-in-control-buffer-p (&optional meta-buf-p)
+ (and (boundp 'ediff-control-buffer)
+ (eq (if meta-buf-p ediff-meta-buffer ediff-control-buffer)
+ (current-buffer))))
+
+(defsubst ediff-barf-if-not-control-buffer (&optional meta-buf-p)
+ (or (ediff-in-control-buffer-p meta-buf-p)
+ (error "%S: This command runs in Ediff Control Buffer only!"
+ this-command)))
+
+(defgroup ediff-highlighting nil
+ "Hilighting of difference regions in Ediff."
+ :prefix "ediff-"
+ :group 'ediff)
+
+(defgroup ediff-merge nil
+ "Merging utilities."
+ :prefix "ediff-"
+ :group 'ediff)
+
+(defgroup ediff-hook nil
+ "Hooks run by Ediff."
+ :prefix "ediff-"
+ :group 'ediff)
+
+;; Hook variables
+
+(defcustom ediff-before-setup-hook nil
+ "Hooks to run before Ediff begins to set up windows and buffers.
+This hook can be used to save the previous window config, which can be restored
+on ediff-quit or ediff-suspend."
+ :type 'hook
+ :group 'ediff-hook)
+(defcustom ediff-before-setup-windows-hook nil
+ "Hooks to run before Ediff sets its window configuration.
+This hook is run every time when Ediff arranges its windows.
+This happens each time Ediff detects that the windows were messed up by the
+user."
+ :type 'hook
+ :group 'ediff-hook)
+(defcustom ediff-after-setup-windows-hook nil
+ "Hooks to run after Ediff sets its window configuration.
+This can be used to set up control window or icon in a desired place."
+ :type 'hook
+ :group 'ediff-hook)
+(defcustom ediff-before-setup-control-frame-hook nil
+ "Hooks run before setting up the frame to display Ediff Control Panel.
+Can be used to change control frame parameters to position it where it
+is desirable."
+ :type 'hook
+ :group 'ediff-hook)
+(defcustom ediff-after-setup-control-frame-hook nil
+ "Hooks run after setting up the frame to display Ediff Control Panel.
+Can be used to move the frame where it is desired."
+ :type 'hook
+ :group 'ediff-hook)
+(defcustom ediff-startup-hook nil
+ "Hooks to run in the control buffer after Ediff has been set up and is ready for the job."
+ :type 'hook
+ :group 'ediff-hook)
+(defcustom ediff-select-hook nil
+ "Hooks to run after a difference has been selected."
+ :type 'hook
+ :group 'ediff-hook)
+(defcustom ediff-unselect-hook nil
+ "Hooks to run after a difference has been unselected."
+ :type 'hook
+ :group 'ediff-hook)
+(defcustom ediff-prepare-buffer-hook nil
+ "Hooks run after buffers A, B, and C are set up.
+For each buffer, the hooks are run with that buffer made current."
+ :type 'hook
+ :group 'ediff-hook)
+(defcustom ediff-load-hook nil
+ "Hook run after Ediff is loaded. Can be used to change defaults."
+ :type 'hook
+ :group 'ediff-hook)
+
+(defcustom ediff-mode-hook nil
+ "Hook run just after ediff-mode is set up in the control buffer.
+This is done before any windows or frames are created. One can use it to
+set local variables that determine how the display looks like."
+ :type 'hook
+ :group 'ediff-hook)
+(defcustom ediff-keymap-setup-hook nil
+ "Hook run just after the default bindings in Ediff keymap are set up."
+ :type 'hook
+ :group 'ediff-hook)
+
+(defcustom ediff-display-help-hook nil
+ "Hooks run after preparing the help message."
+ :type 'hook
+ :group 'ediff-hook)
+
+(defcustom ediff-suspend-hook nil
+ "Hooks to run in the Ediff control buffer when Ediff is suspended."
+ :type 'hook
+ :group 'ediff-hook)
+(defcustom ediff-quit-hook nil
+ "Hooks to run in the Ediff control buffer after finishing Ediff."
+ :type 'hook
+ :group 'ediff-hook)
+(defcustom ediff-cleanup-hook nil
+ "Hooks to run on exiting Ediff but before killing the control and variant buffers."
+ :type 'hook
+ :group 'ediff-hook)
+
+;; Error messages
+(defconst ediff-KILLED-VITAL-BUFFER
+ "You have killed a vital Ediff buffer---you must leave Ediff now!")
+(defconst ediff-NO-DIFFERENCES
+ "Sorry, comparison of identical variants is not what I am made for...")
+(defconst ediff-BAD-DIFF-NUMBER
+ ;; %S stands for this-command, %d - diff number, %d - max diff
+ "%S: Bad diff region number, %d. Valid numbers are 1 to %d")
+(defconst ediff-BAD-INFO (format "
+*** The Info file for Ediff, a part of the standard distribution
+*** of %sEmacs, does not seem to be properly installed.
+***
+*** Please contact your system administrator. "
+ (if (featurep 'xemacs) "X" "")))
+
+;; Selective browsing
+
+(ediff-defvar-local ediff-skip-diff-region-function 'ediff-show-all-diffs
+ "Function that determines the next/previous diff region to show.
+Should return t for regions to be ignored and nil otherwise.
+This function gets a region number as an argument. The region number
+is the one used internally by Ediff. It is 1 less than the number seen
+by the user.")
+
+(ediff-defvar-local ediff-hide-regexp-matches-function
+ 'ediff-hide-regexp-matches
+ "Function to use in determining which regions to hide.
+See the documentation string of `ediff-hide-regexp-matches' for details.")
+(ediff-defvar-local ediff-focus-on-regexp-matches-function
+ 'ediff-focus-on-regexp-matches
+ "Function to use in determining which regions to focus on.
+See the documentation string of `ediff-focus-on-regexp-matches' for details.")
+
+;; Regexp that determines buf A regions to focus on when skipping to diff
+(ediff-defvar-local ediff-regexp-focus-A "" "")
+;; Regexp that determines buf B regions to focus on when skipping to diff
+(ediff-defvar-local ediff-regexp-focus-B "" "")
+;; Regexp that determines buf C regions to focus on when skipping to diff
+(ediff-defvar-local ediff-regexp-focus-C "" "")
+;; connective that determines whether to focus regions that match both or
+;; one of the regexps
+(ediff-defvar-local ediff-focus-regexp-connective 'and "")
+
+;; Regexp that determines buf A regions to ignore when skipping to diff
+(ediff-defvar-local ediff-regexp-hide-A "" "")
+;; Regexp that determines buf B regions to ignore when skipping to diff
+(ediff-defvar-local ediff-regexp-hide-B "" "")
+;; Regexp that determines buf C regions to ignore when skipping to diff
+(ediff-defvar-local ediff-regexp-hide-C "" "")
+;; connective that determines whether to hide regions that match both or
+;; one of the regexps
+(ediff-defvar-local ediff-hide-regexp-connective 'and "")
+
+
+;;; Copying difference regions between buffers.
+
+;; A list of killed diffs.
+;; A diff is saved here if it is replaced by a diff
+;; from another buffer. This alist has the form:
+;; \((num (buff-object . diff) (buff-object . diff) (buff-object . diff)) ...),
+;; where some buffer-objects may be missing.
+(ediff-defvar-local ediff-killed-diffs-alist nil "")
+
+;; Syntax table to use in ediff-forward-word-function
+;; This is chosen by a heuristic. The important thing is for all buffers to
+;; have the same syntax table. Which is not too important.
+(ediff-defvar-local ediff-syntax-table nil "")
+
+
+;; Highlighting
+(defcustom ediff-before-flag-bol (if (featurep 'xemacs) (make-glyph "->>") "->>")
+ "Flag placed before a highlighted block of differences, if block starts at beginning of a line."
+ :type 'string
+ :tag "Region before-flag at beginning of line"
+ :group 'ediff)
+
+(defcustom ediff-after-flag-eol (if (featurep 'xemacs) (make-glyph "<<-") "<<-")
+ "Flag placed after a highlighted block of differences, if block ends at end of a line."
+ :type 'string
+ :tag "Region after-flag at end of line"
+ :group 'ediff)
+
+(defcustom ediff-before-flag-mol (if (featurep 'xemacs) (make-glyph "->>") "->>")
+ "Flag placed before a highlighted block of differences, if block starts in mid-line."
+ :type 'string
+ :tag "Region before-flag in the middle of line"
+ :group 'ediff)
+(defcustom ediff-after-flag-mol (if (featurep 'xemacs) (make-glyph "<<-") "<<-")
+ "Flag placed after a highlighted block of differences, if block ends in mid-line."
+ :type 'string
+ :tag "Region after-flag in the middle of line"
+ :group 'ediff)
+
+
+(ediff-defvar-local ediff-use-faces t "")
+(defcustom ediff-use-faces t
+ "If t, differences are highlighted using faces, if device supports faces.
+If nil, differences are highlighted using ASCII flags, ediff-before-flag
+and ediff-after-flag. On a non-window system, differences are always
+highlighted using ASCII flags."
+ :type 'boolean
+ :group 'ediff-highlighting)
+
+;; this indicates that diff regions are word-size, so fine diffs are
+;; permanently nixed; used in ediff-windows-wordwise and ediff-regions-wordwise
+(ediff-defvar-local ediff-word-mode nil "")
+;; Name of the job (ediff-files, ediff-windows, etc.)
+(ediff-defvar-local ediff-job-name nil "")
+
+;; Narrowing and ediff-region/windows support
+;; This is a list (overlay-A overlay-B overlay-C)
+;; If set, Ediff compares only those parts of buffers A/B/C that lie within
+;; the bounds of these overlays.
+(ediff-defvar-local ediff-narrow-bounds nil "")
+
+;; List (overlay-A overlay-B overlay-C), where each overlay spans the
+;; entire corresponding buffer.
+(ediff-defvar-local ediff-wide-bounds nil "")
+
+;; Current visibility boundaries in buffers A, B, and C.
+;; This is also a list of overlays. When the user toggles narrow/widen,
+;; this list changes from ediff-wide-bounds to ediff-narrow-bounds.
+;; and back.
+(ediff-defvar-local ediff-visible-bounds nil "")
+
+(ediff-defvar-local ediff-start-narrowed t
+ "Non-nil means start narrowed, if doing ediff-windows-* or ediff-regions-*")
+(ediff-defvar-local ediff-quit-widened t
+ "*Non-nil means: when finished, Ediff widens buffers A/B.
+Actually, Ediff restores the scope of visibility that existed at startup.")
+
+(defcustom ediff-keep-variants t
+ "nil means prompt to remove unmodified buffers A/B/C at session end.
+Supplying a prefix argument to the quit command `q' temporarily reverses the
+meaning of this variable."
+ :type 'boolean
+ :group 'ediff)
+
+(ediff-defvar-local ediff-highlight-all-diffs t "")
+(defcustom ediff-highlight-all-diffs t
+ "If nil, only the selected differences are highlighted.
+Otherwise, all difference regions are highlighted, but the selected region is
+shown in brighter colors."
+ :type 'boolean
+ :group 'ediff-highlighting)
+
+
+;; The suffix of the control buffer name.
+(ediff-defvar-local ediff-control-buffer-suffix nil "")
+;; Same as ediff-control-buffer-suffix, but without <,>.
+;; It's a number rather than string.
+(ediff-defvar-local ediff-control-buffer-number nil "")
+
+
+;; The original values of ediff-protected-variables for buffer A
+(ediff-defvar-local ediff-buffer-values-orig-A nil "")
+;; The original values of ediff-protected-variables for buffer B
+(ediff-defvar-local ediff-buffer-values-orig-B nil "")
+;; The original values of ediff-protected-variables for buffer C
+(ediff-defvar-local ediff-buffer-values-orig-C nil "")
+;; The original values of ediff-protected-variables for buffer Ancestor
+(ediff-defvar-local ediff-buffer-values-orig-Ancestor nil "")
+
+;; association between buff-type and ediff-buffer-values-orig-*
+(defconst ediff-buffer-values-orig-alist
+ '((A . ediff-buffer-values-orig-A)
+ (B . ediff-buffer-values-orig-B)
+ (C . ediff-buffer-values-orig-C)
+ (Ancestor . ediff-buffer-values-orig-Ancestor)))
+
+;; Buffer-local variables to be saved then restored during Ediff sessions
+(defconst ediff-protected-variables '(
+ ;;buffer-read-only
+ mode-line-format))
+
+;; Vector of differences between the variants. Each difference is
+;; represented by a vector of two overlays plus a vector of fine diffs,
+;; plus a no-fine-diffs flag. The first overlay spans the
+;; difference region in the A buffer and the second overlays the diff in
+;; the B buffer. If a difference section is empty, the corresponding
+;; overlay's endpoints coincide.
+;;
+;; The precise form of a Difference Vector for one buffer is:
+;; [diff diff diff ...]
+;; where each diff has the form:
+;; [diff-overlay fine-diff-vector no-fine-diffs-flag state-of-diff]
+;; fine-diff-vector is a vector [fine-diff-overlay fine-diff-overlay ...]
+;; no-fine-diffs-flag says if there are fine differences.
+;; state-of-difference is A, B, C, or nil, indicating which buffer is
+;; different from the other two (used only in 3-way jobs.
+(ediff-defvar-local ediff-difference-vector-A nil "")
+(ediff-defvar-local ediff-difference-vector-B nil "")
+(ediff-defvar-local ediff-difference-vector-C nil "")
+(ediff-defvar-local ediff-difference-vector-Ancestor nil "")
+;; A-list of diff vector types associated with buffer types
+(defconst ediff-difference-vector-alist
+ '((A . ediff-difference-vector-A)
+ (B . ediff-difference-vector-B)
+ (C . ediff-difference-vector-C)
+ (Ancestor . ediff-difference-vector-Ancestor)))
+
+;; [ status status status ...]
+;; Each status: [state-of-merge state-of-ancestor]
+;; state-of-merge is default-A, default-B, prefer-A, or prefer-B. It
+;; indicates the way a diff region was created in buffer C.
+;; state-of-ancestor says if the corresponding region in ancestor buffer is
+;; empty.
+(ediff-defvar-local ediff-state-of-merge nil "")
+
+;; The difference that is currently selected.
+(ediff-defvar-local ediff-current-difference -1 "")
+;; Number of differences found.
+(ediff-defvar-local ediff-number-of-differences nil "")
+
+;; Buffer containing the output of diff, which is used by Ediff to step
+;; through files.
+(ediff-defvar-local ediff-diff-buffer nil "")
+;; Like ediff-diff-buffer, but contains context diff. It is not used by
+;; Ediff, but it is saved in a file, if user requests so.
+(ediff-defvar-local ediff-custom-diff-buffer nil "")
+;; Buffer used for diff-style fine differences between regions.
+(ediff-defvar-local ediff-fine-diff-buffer nil "")
+;; Temporary buffer used for computing fine differences.
+(defconst ediff-tmp-buffer " *ediff-tmp*" "")
+;; Buffer used for messages
+(defconst ediff-msg-buffer " *ediff-message*" "")
+;; Buffer containing the output of diff when diff returns errors.
+(ediff-defvar-local ediff-error-buffer nil "")
+;; Buffer to display debug info
+(ediff-defvar-local ediff-debug-buffer "*ediff-debug*" "")
+
+;; List of ediff control panels associated with each buffer A/B/C/Ancestor.
+;; Not used any more, but may be needed in the future.
+(ediff-defvar-local ediff-this-buffer-ediff-sessions nil "")
+
+;; to be deleted in due time
+;; List of difference overlays disturbed by working with the current diff.
+(defvar ediff-disturbed-overlays nil "")
+
+;; Priority of non-selected overlays.
+(defvar ediff-shadow-overlay-priority 100 "")
+
+(defcustom ediff-version-control-package 'vc
+ "Version control package used.
+Currently, Ediff supports vc.el, rcs.el, pcl-cvs.el, and generic-sc.el. The
+standard Emacs interface to RCS, CVS, SCCS, etc., is vc.el. However, some
+people find the other two packages more convenient. Set this variable to the
+appropriate symbol: `rcs', `pcl-cvs', or `generic-sc' if you so desire."
+ :type 'symbol
+ :group 'ediff)
+
+(defcustom ediff-coding-system-for-read 'raw-text
+ "The coding system for read to use when running the diff program as a subprocess.
+In most cases, the default will do. However, under certain circumstances in
+MS-Windows you might need to use something like 'raw-text-dos here.
+So, if the output that your diff program sends to Emacs contains extra ^M's,
+you might need to experiment here, if the default or 'raw-text-dos doesn't
+work."
+ :type 'symbol
+ :group 'ediff)
+
+(defcustom ediff-coding-system-for-write (if (featurep 'xemacs)
+ 'escape-quoted
+ 'emacs-internal)
+ "The coding system for write to use when writing out difference regions
+to temp files in buffer jobs and when Ediff needs to find fine differences."
+ :type 'symbol
+ :group 'ediff)
+
+
+(defalias 'ediff-read-event
+ (if (featurep 'xemacs) 'next-command-event 'read-event))
+
+(defalias 'ediff-overlayp
+ (if (featurep 'xemacs) 'extentp 'overlayp))
+
+(defalias 'ediff-make-overlay
+ (if (featurep 'xemacs) 'make-extent 'make-overlay))
+
+(defalias 'ediff-delete-overlay
+ (if (featurep 'xemacs) 'delete-extent 'delete-overlay))
+
+;; Assumes that emacs-major-version and emacs-minor-version are defined.
+(defun ediff-check-version (op major minor &optional type-of-emacs)
+ "Check the current version against MAJOR and MINOR version numbers.
+The comparison uses operator OP, which may be any of: =, >, >=, <, <=.
+TYPE-OF-EMACS is either 'xemacs or 'emacs."
+ (and (cond ((eq type-of-emacs 'xemacs) (featurep 'xemacs))
+ ((eq type-of-emacs 'emacs) (featurep 'emacs))
+ (t))
+ (cond ((eq op '=) (and (= emacs-minor-version minor)
+ (= emacs-major-version major)))
+ ((memq op '(> >= < <=))
+ (and (or (funcall op emacs-major-version major)
+ (= emacs-major-version major))
+ (if (= emacs-major-version major)
+ (funcall op emacs-minor-version minor)
+ t)))
+ (t
+ (error "%S: Invalid op in ediff-check-version" op)))))
+
+;; ediff-check-version seems to be totally unused anyway.
+(make-obsolete 'ediff-check-version 'version< "23.1")
+
+(defun ediff-color-display-p ()
+ (condition-case nil
+ (if (featurep 'xemacs)
+ (eq (device-class (selected-device)) 'color) ; xemacs form
+ (display-color-p)) ; emacs form
+ (error nil)))
+
+
+;; A var local to each control panel buffer. Indicates highlighting style
+;; in effect for this buffer: `face', `ascii',
+;; `off' -- turned off \(on a dumb terminal only\).
+(ediff-defvar-local ediff-highlighting-style
+ (if (and (ediff-has-face-support-p) ediff-use-faces) 'face 'ascii)
+ "")
+
+
+(if (ediff-window-display-p)
+ (if (featurep 'xemacs)
+ (progn
+ (defalias 'ediff-display-pixel-width 'device-pixel-width)
+ (defalias 'ediff-display-pixel-height 'device-pixel-height))
+ (defalias 'ediff-display-pixel-width
+ (if (fboundp 'display-pixel-width)
+ 'display-pixel-width
+ 'x-display-pixel-width))
+ (defalias 'ediff-display-pixel-height
+ (if (fboundp 'display-pixel-height)
+ 'display-pixel-height
+ 'x-display-pixel-height))))
+
+;; A-list of current-diff-overlay symbols associated with buf types
+(defconst ediff-current-diff-overlay-alist
+ '((A . ediff-current-diff-overlay-A)
+ (B . ediff-current-diff-overlay-B)
+ (C . ediff-current-diff-overlay-C)
+ (Ancestor . ediff-current-diff-overlay-Ancestor)))
+
+;; A-list of current-diff-face-* symbols associated with buf types
+(defconst ediff-current-diff-face-alist
+ '((A . ediff-current-diff-A)
+ (B . ediff-current-diff-B)
+ (C . ediff-current-diff-C)
+ (Ancestor . ediff-current-diff-Ancestor)))
+
+
+(defun ediff-set-overlay-face (extent face)
+ (ediff-overlay-put extent 'face face)
+ (ediff-overlay-put extent 'help-echo 'ediff-region-help-echo))
+
+(defun ediff-region-help-echo (extent-or-window &optional overlay point)
+ (unless overlay
+ (setq overlay extent-or-window))
+ (let ((is-current (ediff-overlay-get overlay 'ediff))
+ (face (ediff-overlay-get overlay 'face))
+ (diff-num (ediff-overlay-get overlay 'ediff-diff-num))
+ face-help)
+
+ ;; This happens only for refinement overlays
+ (if (stringp face)
+ (setq face (intern face)))
+ (setq face-help (and face (get face 'ediff-help-echo)))
+
+ (cond ((and is-current diff-num) ; current diff region
+ (format "Difference region %S -- current" (1+ diff-num)))
+ (face-help) ; refinement of current diff region
+ (diff-num ; non-current
+ (format "Difference region %S -- non-current" (1+ diff-num)))
+ (t "")) ; none
+ ))
+
+
+(defun ediff-set-face-pixmap (face pixmap)
+ "Set face pixmap on a monochrome display."
+ (if (and (ediff-window-display-p) (not (ediff-color-display-p)))
+ (condition-case nil
+ (set-face-background-pixmap face pixmap)
+ (error
+ (message "Pixmap not found for %S: %s" (face-name face) pixmap)
+ (sit-for 1)))))
+
+(defun ediff-hide-face (face)
+ (if (and (ediff-has-face-support-p)
+ (boundp 'add-to-list)
+ (boundp 'facemenu-unlisted-faces))
+ (add-to-list 'facemenu-unlisted-faces face)))
+
+
+
+(defface ediff-current-diff-A
+ (if (featurep 'emacs)
+ '((((class color) (min-colors 16))
+ (:foreground "firebrick" :background "pale green"))
+ (((class color))
+ (:foreground "blue3" :background "yellow3"))
+ (t (:inverse-video t)))
+ '((((type tty)) (:foreground "blue3" :background "yellow3"))
+ (((class color)) (:foreground "firebrick" :background "pale green"))
+ (t (:inverse-video t))))
+ "Face for highlighting the selected difference in buffer A."
+ :group 'ediff-highlighting)
+;; An internal variable. Ediff takes the face from here. When unhighlighting,
+;; this variable is set to nil, then again to the appropriate face.
+(defvar ediff-current-diff-face-A 'ediff-current-diff-A
+ "Face for highlighting the selected difference in buffer A.
+DO NOT CHANGE this variable. Instead, use the customization
+widget to customize the actual face object `ediff-current-diff-A'
+this variable represents.")
+(ediff-hide-face ediff-current-diff-face-A)
+;; Until custom.el for XEmacs starts supporting :inverse-video we do this.
+;; This means that some user customization may be trashed.
+(and (featurep 'xemacs)
+ (ediff-has-face-support-p)
+ (not (ediff-color-display-p))
+ (copy-face 'modeline ediff-current-diff-face-A))
+
+
+
+(defface ediff-current-diff-B
+ (if (featurep 'emacs)
+ '((((class color) (min-colors 16))
+ (:foreground "DarkOrchid" :background "Yellow"))
+ (((class color))
+ (:foreground "magenta3" :background "yellow3"
+ :weight bold))
+ (t (:inverse-video t)))
+ '((((type tty)) (:foreground "magenta3" :background "yellow3"
+ :weight bold))
+ (((class color)) (:foreground "DarkOrchid" :background "Yellow"))
+ (t (:inverse-video t))))
+ "Face for highlighting the selected difference in buffer B."
+ :group 'ediff-highlighting)
+;; An internal variable. Ediff takes the face from here. When unhighlighting,
+;; this variable is set to nil, then again to the appropriate face.
+(defvar ediff-current-diff-face-B 'ediff-current-diff-B
+ "Face for highlighting the selected difference in buffer B.
+ this variable. Instead, use the customization
+widget to customize the actual face `ediff-current-diff-B'
+this variable represents.")
+(ediff-hide-face ediff-current-diff-face-B)
+;; Until custom.el for XEmacs starts supporting :inverse-video we do this.
+;; This means that some user customization may be trashed.
+(and (featurep 'xemacs)
+ (ediff-has-face-support-p)
+ (not (ediff-color-display-p))
+ (copy-face 'modeline ediff-current-diff-face-B))
+
+
+(defface ediff-current-diff-C
+ (if (featurep 'emacs)
+ '((((class color) (min-colors 16))
+ (:foreground "Navy" :background "Pink"))
+ (((class color))
+ (:foreground "cyan3" :background "yellow3" :weight bold))
+ (t (:inverse-video t)))
+ '((((type tty)) (:foreground "cyan3" :background "yellow3" :weight bold))
+ (((class color)) (:foreground "Navy" :background "Pink"))
+ (t (:inverse-video t))))
+ "Face for highlighting the selected difference in buffer C."
+ :group 'ediff-highlighting)
+;; An internal variable. Ediff takes the face from here. When unhighlighting,
+;; this variable is set to nil, then again to the appropriate face.
+(defvar ediff-current-diff-face-C 'ediff-current-diff-C
+ "Face for highlighting the selected difference in buffer C.
+DO NOT CHANGE this variable. Instead, use the customization
+widget to customize the actual face object `ediff-current-diff-C'
+this variable represents.")
+(ediff-hide-face ediff-current-diff-face-C)
+;; Until custom.el for XEmacs starts supporting :inverse-video we do this.
+;; This means that some user customization may be trashed.
+(and (featurep 'xemacs)
+ (ediff-has-face-support-p)
+ (not (ediff-color-display-p))
+ (copy-face 'modeline ediff-current-diff-face-C))
+
+
+(defface ediff-current-diff-Ancestor
+ (if (featurep 'emacs)
+ '((((class color) (min-colors 16))
+ (:foreground "Black" :background "VioletRed"))
+ (((class color))
+ (:foreground "black" :background "magenta3"))
+ (t (:inverse-video t)))
+ '((((type tty)) (:foreground "black" :background "magenta3"))
+ (((class color)) (:foreground "Black" :background "VioletRed"))
+ (t (:inverse-video t))))
+ "Face for highlighting the selected difference in buffer Ancestor."
+ :group 'ediff-highlighting)
+;; An internal variable. Ediff takes the face from here. When unhighlighting,
+;; this variable is set to nil, then again to the appropriate face.
+(defvar ediff-current-diff-face-Ancestor 'ediff-current-diff-Ancestor
+ "Face for highlighting the selected difference in buffer Ancestor.
+DO NOT CHANGE this variable. Instead, use the customization
+widget to customize the actual face object `ediff-current-diff-Ancestor'
+this variable represents.")
+(ediff-hide-face ediff-current-diff-face-Ancestor)
+;; Until custom.el for XEmacs starts supporting :inverse-video we do this.
+;; This means that some user customization may be trashed.
+(and (featurep 'xemacs)
+ (ediff-has-face-support-p)
+ (not (ediff-color-display-p))
+ (copy-face 'modeline ediff-current-diff-face-Ancestor))
+
+
+(defface ediff-fine-diff-A
+ (if (featurep 'emacs)
+ '((((class color) (min-colors 16))
+ (:foreground "Navy" :background "sky blue"))
+ (((class color))
+ (:foreground "white" :background "sky blue" :weight bold))
+ (t (:underline t :stipple "gray3")))
+ '((((type tty)) (:foreground "white" :background "sky blue" :weight bold))
+ (((class color)) (:foreground "Navy" :background "sky blue"))
+ (t (:underline t :stipple "gray3"))))
+ "Face for highlighting the refinement of the selected diff in buffer A."
+ :group 'ediff-highlighting)
+;; An internal variable. Ediff takes the face from here. When unhighlighting,
+;; this variable is set to nil, then again to the appropriate face.
+(defvar ediff-fine-diff-face-A 'ediff-fine-diff-A
+ "Face for highlighting the fine differences in buffer A.
+DO NOT CHANGE this variable. Instead, use the customization
+widget to customize the actual face object `ediff-fine-diff-A'
+this variable represents.")
+(ediff-hide-face ediff-fine-diff-face-A)
+
+(defface ediff-fine-diff-B
+ (if (featurep 'emacs)
+ '((((class color) (min-colors 16))
+ (:foreground "Black" :background "cyan"))
+ (((class color))
+ (:foreground "magenta3" :background "cyan3"))
+ (t (:underline t :stipple "gray3")))
+ '((((type tty)) (:foreground "magenta3" :background "cyan3"))
+ (((class color)) (:foreground "Black" :background "cyan"))
+ (t (:underline t :stipple "gray3"))))
+ "Face for highlighting the refinement of the selected diff in buffer B."
+ :group 'ediff-highlighting)
+;; An internal variable. Ediff takes the face from here. When unhighlighting,
+;; this variable is set to nil, then again to the appropriate face.
+(defvar ediff-fine-diff-face-B 'ediff-fine-diff-B
+ "Face for highlighting the fine differences in buffer B.
+DO NOT CHANGE this variable. Instead, use the customization
+widget to customize the actual face object `ediff-fine-diff-B'
+this variable represents.")
+(ediff-hide-face ediff-fine-diff-face-B)
+
+(defface ediff-fine-diff-C
+ (if (featurep 'emacs)
+ '((((type pc))
+ (:foreground "white" :background "Turquoise"))
+ (((class color) (min-colors 16))
+ (:foreground "Black" :background "Turquoise"))
+ (((class color))
+ (:foreground "yellow3" :background "Turquoise"
+ :weight bold))
+ (t (:underline t :stipple "gray3")))
+ '((((type tty)) (:foreground "yellow3" :background "Turquoise"
+ :weight bold))
+ (((type pc)) (:foreground "white" :background "Turquoise"))
+ (((class color)) (:foreground "Black" :background "Turquoise"))
+ (t (:underline t :stipple "gray3"))))
+ "Face for highlighting the refinement of the selected diff in buffer C."
+ :group 'ediff-highlighting)
+;; An internal variable. Ediff takes the face from here. When unhighlighting,
+;; this variable is set to nil, then again to the appropriate face.
+(defvar ediff-fine-diff-face-C 'ediff-fine-diff-C
+ "Face for highlighting the fine differences in buffer C.
+DO NOT CHANGE this variable. Instead, use the customization
+widget to customize the actual face object `ediff-fine-diff-C'
+this variable represents.")
+(ediff-hide-face ediff-fine-diff-face-C)
+
+(defface ediff-fine-diff-Ancestor
+ (if (featurep 'emacs)
+ '((((class color) (min-colors 16))
+ (:foreground "Black" :background "Green"))
+ (((class color))
+ (:foreground "red3" :background "green"))
+ (t (:underline t :stipple "gray3")))
+ '((((type tty)) (:foreground "red3" :background "green"))
+ (((class color)) (:foreground "Black" :background "Green"))
+ (t (:underline t :stipple "gray3"))))
+ "Face for highlighting the refinement of the selected diff in the ancestor buffer.
+At present, this face is not used and no fine differences are computed for the
+ancestor buffer."
+ :group 'ediff-highlighting)
+;; An internal variable. Ediff takes the face from here. When unhighlighting,
+;; this variable is set to nil, then again to the appropriate face.
+(defvar ediff-fine-diff-face-Ancestor 'ediff-fine-diff-Ancestor
+ "Face for highlighting the fine differences in buffer Ancestor.
+DO NOT CHANGE this variable. Instead, use the customization
+widget to customize the actual face object `ediff-fine-diff-Ancestor'
+this variable represents.")
+(ediff-hide-face ediff-fine-diff-face-Ancestor)
+
+;; Some installs don't have stipple or Stipple. So, try them in turn.
+(defvar stipple-pixmap
+ (cond ((not (ediff-has-face-support-p)) nil)
+ ((and (boundp 'x-bitmap-file-path)
+ (locate-library "stipple" t x-bitmap-file-path)) "stipple")
+ ((and (boundp 'mswindowsx-bitmap-file-path)
+ (locate-library "stipple" t mswindowsx-bitmap-file-path)) "stipple")
+ (t "Stipple")))
+
+(defface ediff-even-diff-A
+ (if (featurep 'emacs)
+ `((((type pc))
+ (:foreground "green3" :background "light grey"))
+ (((class color) (min-colors 16))
+ (:foreground "Black" :background "light grey"))
+ (((class color))
+ (:foreground "red3" :background "light grey"
+ :weight bold))
+ (t (:italic t :stipple ,stipple-pixmap)))
+ `((((type tty)) (:foreground "red3" :background "light grey"
+ :weight bold))
+ (((type pc)) (:foreground "green3" :background "light grey"))
+ (((class color)) (:foreground "Black" :background "light grey"))
+ (t (:italic t :stipple ,stipple-pixmap))))
+ "Face for highlighting even-numbered non-current differences in buffer A."
+ :group 'ediff-highlighting)
+;; An internal variable. Ediff takes the face from here. When unhighlighting,
+;; this variable is set to nil, then again to the appropriate face.
+(defvar ediff-even-diff-face-A 'ediff-even-diff-A
+ "Face for highlighting even-numbered non-current differences in buffer A.
+DO NOT CHANGE this variable. Instead, use the customization
+widget to customize the actual face object `ediff-even-diff-A'
+this variable represents.")
+(ediff-hide-face ediff-even-diff-face-A)
+
+(defface ediff-even-diff-B
+ (if (featurep 'emacs)
+ `((((class color) (min-colors 16))
+ (:foreground "White" :background "Grey"))
+ (((class color))
+ (:foreground "blue3" :background "Grey" :weight bold))
+ (t (:italic t :stipple ,stipple-pixmap)))
+ `((((type tty)) (:foreground "blue3" :background "Grey" :weight bold))
+ (((class color)) (:foreground "White" :background "Grey"))
+ (t (:italic t :stipple ,stipple-pixmap))))
+ "Face for highlighting even-numbered non-current differences in buffer B."
+ :group 'ediff-highlighting)
+;; An internal variable. Ediff takes the face from here. When unhighlighting,
+;; this variable is set to nil, then again to the appropriate face.
+(defvar ediff-even-diff-face-B 'ediff-even-diff-B
+ "Face for highlighting even-numbered non-current differences in buffer B.
+DO NOT CHANGE this variable. Instead, use the customization
+widget to customize the actual face object `ediff-even-diff-B'
+this variable represents.")
+(ediff-hide-face ediff-even-diff-face-B)
+
+(defface ediff-even-diff-C
+ (if (featurep 'emacs)
+ `((((type pc))
+ (:foreground "yellow3" :background "light grey"))
+ (((class color) (min-colors 16))
+ (:foreground "Black" :background "light grey"))
+ (((class color))
+ (:foreground "yellow3" :background "light grey"
+ :weight bold))
+ (t (:italic t :stipple ,stipple-pixmap)))
+ `((((type tty)) (:foreground "yellow3" :background "light grey"
+ :weight bold))
+ (((type pc)) (:foreground "yellow3" :background "light grey"))
+ (((class color)) (:foreground "Black" :background "light grey"))
+ (t (:italic t :stipple ,stipple-pixmap))))
+ "Face for highlighting even-numbered non-current differences in buffer C."
+ :group 'ediff-highlighting)
+;; An internal variable. Ediff takes the face from here. When unhighlighting,
+;; this variable is set to nil, then again to the appropriate face.
+(defvar ediff-even-diff-face-C 'ediff-even-diff-C
+ "Face for highlighting even-numbered non-current differences in buffer C.
+DO NOT CHANGE this variable. Instead, use the customization
+widget to customize the actual face object `ediff-even-diff-C'
+this variable represents.")
+(ediff-hide-face ediff-even-diff-face-C)
+
+(defface ediff-even-diff-Ancestor
+ (if (featurep 'emacs)
+ `((((type pc))
+ (:foreground "cyan3" :background "light grey"))
+ (((class color) (min-colors 16))
+ (:foreground "White" :background "Grey"))
+ (((class color))
+ (:foreground "cyan3" :background "light grey"
+ :weight bold))
+ (t (:italic t :stipple ,stipple-pixmap)))
+ `((((type tty)) (:foreground "cyan3" :background "light grey"
+ :weight bold))
+ (((type pc)) (:foreground "cyan3" :background "light grey"))
+ (((class color)) (:foreground "White" :background "Grey"))
+ (t (:italic t :stipple ,stipple-pixmap))))
+ "Face for highlighting even-numbered non-current differences in the ancestor buffer."
+ :group 'ediff-highlighting)
+;; An internal variable. Ediff takes the face from here. When unhighlighting,
+;; this variable is set to nil, then again to the appropriate face.
+(defvar ediff-even-diff-face-Ancestor 'ediff-even-diff-Ancestor
+ "Face for highlighting even-numbered non-current differences in buffer Ancestor.
+DO NOT CHANGE this variable. Instead, use the customization
+widget to customize the actual face object `ediff-even-diff-Ancestor'
+this variable represents.")
+(ediff-hide-face ediff-even-diff-face-Ancestor)
+
+;; Association between buffer types and even-diff-face symbols
+(defconst ediff-even-diff-face-alist
+ '((A . ediff-even-diff-A)
+ (B . ediff-even-diff-B)
+ (C . ediff-even-diff-C)
+ (Ancestor . ediff-even-diff-Ancestor)))
+
+(defface ediff-odd-diff-A
+ (if (featurep 'emacs)
+ '((((type pc))
+ (:foreground "green3" :background "gray40"))
+ (((class color) (min-colors 16))
+ (:foreground "White" :background "Grey"))
+ (((class color))
+ (:foreground "red3" :background "black" :weight bold))
+ (t (:italic t :stipple "gray1")))
+ '((((type tty)) (:foreground "red3" :background "black" :weight bold))
+ (((type pc)) (:foreground "green3" :background "gray40"))
+ (((class color)) (:foreground "White" :background "Grey"))
+ (t (:italic t :stipple "gray1"))))
+ "Face for highlighting odd-numbered non-current differences in buffer A."
+ :group 'ediff-highlighting)
+;; An internal variable. Ediff takes the face from here. When unhighlighting,
+;; this variable is set to nil, then again to the appropriate face.
+(defvar ediff-odd-diff-face-A 'ediff-odd-diff-A
+ "Face for highlighting odd-numbered non-current differences in buffer A.
+DO NOT CHANGE this variable. Instead, use the customization
+widget to customize the actual face object `ediff-odd-diff-A'
+this variable represents.")
+(ediff-hide-face ediff-odd-diff-face-A)
+
+
+(defface ediff-odd-diff-B
+ (if (featurep 'emacs)
+ '((((type pc))
+ (:foreground "White" :background "gray40"))
+ (((class color) (min-colors 16))
+ (:foreground "Black" :background "light grey"))
+ (((class color))
+ (:foreground "cyan3" :background "black" :weight bold))
+ (t (:italic t :stipple "gray1")))
+ '((((type tty)) (:foreground "cyan3" :background "black" :weight bold))
+ (((type pc)) (:foreground "White" :background "gray40"))
+ (((class color)) (:foreground "Black" :background "light grey"))
+ (t (:italic t :stipple "gray1"))))
+ "Face for highlighting odd-numbered non-current differences in buffer B."
+ :group 'ediff-highlighting)
+;; An internal variable. Ediff takes the face from here. When unhighlighting,
+;; this variable is set to nil, then again to the appropriate face.
+(defvar ediff-odd-diff-face-B 'ediff-odd-diff-B
+ "Face for highlighting odd-numbered non-current differences in buffer B.
+DO NOT CHANGE this variable. Instead, use the customization
+widget to customize the actual face object `ediff-odd-diff-B'
+this variable represents.")
+(ediff-hide-face ediff-odd-diff-face-B)
+
+(defface ediff-odd-diff-C
+ (if (featurep 'emacs)
+ '((((type pc))
+ (:foreground "yellow3" :background "gray40"))
+ (((class color) (min-colors 16))
+ (:foreground "White" :background "Grey"))
+ (((class color))
+ (:foreground "yellow3" :background "black" :weight bold))
+ (t (:italic t :stipple "gray1")))
+ '((((type tty)) (:foreground "yellow3" :background "black" :weight bold))
+ (((type pc)) (:foreground "yellow3" :background "gray40"))
+ (((class color)) (:foreground "White" :background "Grey"))
+ (t (:italic t :stipple "gray1"))))
+ "Face for highlighting odd-numbered non-current differences in buffer C."
+ :group 'ediff-highlighting)
+;; An internal variable. Ediff takes the face from here. When unhighlighting,
+;; this variable is set to nil, then again to the appropriate face.
+(defvar ediff-odd-diff-face-C 'ediff-odd-diff-C
+ "Face for highlighting odd-numbered non-current differences in buffer C.
+DO NOT CHANGE this variable. Instead, use the customization
+widget to customize the actual face object `ediff-odd-diff-C'
+this variable represents.")
+(ediff-hide-face ediff-odd-diff-face-C)
+
+(defface ediff-odd-diff-Ancestor
+ (if (featurep 'emacs)
+ '((((class color) (min-colors 16))
+ (:foreground "cyan3" :background "gray40"))
+ (((class color))
+ (:foreground "green3" :background "black" :weight bold))
+ (t (:italic t :stipple "gray1")))
+ '((((type tty)) (:foreground "green3" :background "black" :weight bold))
+ (((class color)) (:foreground "cyan3" :background "gray40"))
+ (t (:italic t :stipple "gray1"))))
+ "Face for highlighting odd-numbered non-current differences in the ancestor buffer."
+ :group 'ediff-highlighting)
+;; An internal variable. Ediff takes the face from here. When unhighlighting,
+;; this variable is set to nil, then again to the appropriate face.
+(defvar ediff-odd-diff-face-Ancestor 'ediff-odd-diff-Ancestor
+ "Face for highlighting odd-numbered non-current differences in buffer Ancestor.
+DO NOT CHANGE this variable. Instead, use the customization
+widget to customize the actual face object `ediff-odd-diff-Ancestor'
+this variable represents.")
+(ediff-hide-face ediff-odd-diff-face-Ancestor)
+
+;; Association between buffer types and odd-diff-face symbols
+(defconst ediff-odd-diff-face-alist
+ '((A . ediff-odd-diff-A)
+ (B . ediff-odd-diff-B)
+ (C . ediff-odd-diff-C)
+ (Ancestor . ediff-odd-diff-Ancestor)))
+
+;; A-list of fine-diff face symbols associated with buffer types
+(defconst ediff-fine-diff-face-alist
+ '((A . ediff-fine-diff-A)
+ (B . ediff-fine-diff-B)
+ (C . ediff-fine-diff-C)
+ (Ancestor . ediff-fine-diff-Ancestor)))
+
+;; Help echo
+(put ediff-fine-diff-face-A 'ediff-help-echo
+ "A `refinement' of the current difference region")
+(put ediff-fine-diff-face-B 'ediff-help-echo
+ "A `refinement' of the current difference region")
+(put ediff-fine-diff-face-C 'ediff-help-echo
+ "A `refinement' of the current difference region")
+(put ediff-fine-diff-face-Ancestor 'ediff-help-echo
+ "A `refinement' of the current difference region")
+
+(add-hook 'ediff-quit-hook 'ediff-cleanup-mess)
+(add-hook 'ediff-suspend-hook 'ediff-default-suspend-function)
+
+
+;;; Overlays
+
+(ediff-defvar-local ediff-current-diff-overlay-A nil
+ "Overlay for the current difference region in buffer A.")
+(ediff-defvar-local ediff-current-diff-overlay-B nil
+ "Overlay for the current difference region in buffer B.")
+(ediff-defvar-local ediff-current-diff-overlay-C nil
+ "Overlay for the current difference region in buffer C.")
+(ediff-defvar-local ediff-current-diff-overlay-Ancestor nil
+ "Overlay for the current difference region in the ancestor buffer.")
+
+;; Compute priority of a current ediff overlay.
+(defun ediff-highest-priority (start end buffer)
+ (let ((pos (max 1 (1- start)))
+ ovr-list)
+ (if (featurep 'xemacs)
+ (1+ ediff-shadow-overlay-priority)
+ (ediff-with-current-buffer buffer
+ (while (< pos (min (point-max) (1+ end)))
+ (setq ovr-list (append (overlays-at pos) ovr-list))
+ (setq pos (next-overlay-change pos)))
+ (+ 1 ediff-shadow-overlay-priority
+ (apply 'max
+ (cons
+ 1
+ (mapcar
+ (lambda (ovr)
+ (if (and ovr
+ ;; exclude ediff overlays from priority
+ ;; calculation, or else priority will keep
+ ;; increasing
+ (null (ediff-overlay-get ovr 'ediff))
+ (null (ediff-overlay-get ovr 'ediff-diff-num)))
+ ;; use the overlay priority or 0
+ (or (ediff-overlay-get ovr 'priority) 0)
+ 0))
+ ovr-list))))))))
+
+
+(defvar ediff-toggle-read-only-function nil
+ "*Specifies the function to be used to toggle read-only.
+If nil, Ediff tries to deduce the function from the binding of C-x C-q.
+Normally, this is the `toggle-read-only' function, but, if version
+control is used, it could be `vc-toggle-read-only' or `rcs-toggle-read-only'.")
+
+(defcustom ediff-make-buffers-readonly-at-startup nil
+ "Make all variant buffers read-only when Ediff starts up.
+This property can be toggled interactively."
+ :type 'boolean
+ :group 'ediff)
+
+
+;;; Misc
+
+;; if nil, this silences some messages
+(defvar ediff-verbose-p t)
+
+(defcustom ediff-autostore-merges 'group-jobs-only
+ "Save the results of merge jobs automatically.
+With value nil, don't save automatically. With value t, always
+save. Anything else means save automatically only if the merge
+job is part of a group of jobs, such as `ediff-merge-directory'
+or `ediff-merge-directory-revisions'."
+ :type '(choice (const nil) (const t) (const group-jobs-only))
+ :group 'ediff-merge)
+(make-variable-buffer-local 'ediff-autostore-merges)
+
+;; file where the result of the merge is to be saved. used internally
+(ediff-defvar-local ediff-merge-store-file nil "")
+
+(defcustom ediff-merge-filename-prefix "merge_"
+ "Prefix to be attached to saved merge buffers."
+ :type 'string
+ :group 'ediff-merge)
+
+(defcustom ediff-no-emacs-help-in-control-buffer nil
+ "Non-nil means C-h should not invoke Emacs help in control buffer.
+Instead, C-h would jump to previous difference."
+ :type 'boolean
+ :group 'ediff)
+
+;; This is the same as temporary-file-directory from Emacs 20.3.
+;; Copied over here because XEmacs doesn't have this variable.
+(defcustom ediff-temp-file-prefix
+ (file-name-as-directory
+ (cond ((boundp 'temporary-file-directory) temporary-file-directory)
+ ((fboundp 'temp-directory) (temp-directory))
+ (t "/tmp/")))
+;;; (file-name-as-directory
+;;; (cond ((memq system-type '(ms-dos windows-nt))
+;;; (or (getenv "TEMP") (getenv "TMPDIR") (getenv "TMP") "c:/temp"))
+;;; (t
+;;; (or (getenv "TMPDIR") (getenv "TMP") (getenv "TEMP") "/tmp"))))
+ "Prefix to put on Ediff temporary file names.
+Do not start with `~/' or `~USERNAME/'."
+ :type 'string
+ :group 'ediff)
+
+(defcustom ediff-temp-file-mode 384 ; u=rw only
+ "Mode for Ediff temporary files."
+ :type 'integer
+ :group 'ediff)
+
+;; Metacharacters that have to be protected from the shell when executing
+;; a diff/diff3 command.
+(defcustom ediff-metachars "[ \t\n!\"#$&'()*;<=>?[\\^`{|~]"
+ "Regexp that matches characters that must be quoted with `\\' in shell command line.
+This default should work without changes."
+ :type 'string
+ :group 'ediff)
+
+;; needed to simulate frame-char-width in XEmacs.
+(defvar ediff-H-glyph (if (featurep 'xemacs) (make-glyph "H")))
+
+
+;; Temporary file used for refining difference regions in buffer A.
+(ediff-defvar-local ediff-temp-file-A nil "")
+;; Temporary file used for refining difference regions in buffer B.
+(ediff-defvar-local ediff-temp-file-B nil "")
+;; Temporary file used for refining difference regions in buffer C.
+(ediff-defvar-local ediff-temp-file-C nil "")
+
+
+(defun ediff-file-remote-p (file-name)
+ (file-remote-p file-name))
+
+;; File for which we can get attributes, such as size or date
+(defun ediff-listable-file (file-name)
+ (let ((handler (find-file-name-handler file-name 'file-local-copy)))
+ (or (null handler) (eq handler 'dired-handler-fn))))
+
+
+(defsubst ediff-frame-unsplittable-p (frame)
+ (cdr (assq 'unsplittable (frame-parameters frame))))
+
+(defsubst ediff-get-next-window (wind prev-wind)
+ (cond ((window-live-p wind) wind)
+ (prev-wind (next-window wind))
+ (t (selected-window))
+ ))
+
+
+(defsubst ediff-kill-buffer-carefully (buf)
+ "Kill buffer BUF if it exists."
+ (if (ediff-buffer-live-p buf)
+ (kill-buffer (get-buffer buf))))
+
+(defsubst ediff-background-face (buf-type dif-num)
+ ;; The value of dif-num is always 1- the one that user sees.
+ ;; This is why even face is used when dif-num is odd.
+ (ediff-get-symbol-from-alist
+ buf-type (if (ediff-odd-p dif-num)
+ ediff-even-diff-face-alist
+ ediff-odd-diff-face-alist)
+ ))
+
+
+;; activate faces on diff regions in buffer
+(defun ediff-paint-background-regions-in-one-buffer (buf-type unhighlight)
+ (let ((diff-vector
+ (eval (ediff-get-symbol-from-alist
+ buf-type ediff-difference-vector-alist)))
+ overl diff-num)
+ (mapcar (lambda (rec)
+ (setq overl (ediff-get-diff-overlay-from-diff-record rec)
+ diff-num (ediff-overlay-get overl 'ediff-diff-num))
+ (if (ediff-overlay-buffer overl)
+ ;; only if overlay is alive
+ (ediff-set-overlay-face
+ overl
+ (if (not unhighlight)
+ (ediff-background-face buf-type diff-num))))
+ )
+ diff-vector)))
+
+
+;; activate faces on diff regions in all buffers
+(defun ediff-paint-background-regions (&optional unhighlight)
+ (ediff-paint-background-regions-in-one-buffer
+ 'A unhighlight)
+ (ediff-paint-background-regions-in-one-buffer
+ 'B unhighlight)
+ (ediff-paint-background-regions-in-one-buffer
+ 'C unhighlight)
+ (ediff-paint-background-regions-in-one-buffer
+ 'Ancestor unhighlight))
+
+
+;; arg is a record for a given diff in a difference vector
+;; this record is itself a vector
+(defsubst ediff-clear-fine-diff-vector (diff-record)
+ (if diff-record
+ (mapc 'ediff-delete-overlay
+ (ediff-get-fine-diff-vector-from-diff-record diff-record))))
+
+(defsubst ediff-clear-fine-differences-in-one-buffer (n buf-type)
+ (ediff-clear-fine-diff-vector (ediff-get-difference n buf-type))
+ (ediff-set-fine-diff-vector n buf-type nil))
+
+(defsubst ediff-clear-fine-differences (n)
+ (ediff-clear-fine-differences-in-one-buffer n 'A)
+ (ediff-clear-fine-differences-in-one-buffer n 'B)
+ (if ediff-3way-job
+ (ediff-clear-fine-differences-in-one-buffer n 'C)))
+
+
+(defsubst ediff-mouse-event-p (event)
+ (if (featurep 'xemacs)
+ (button-event-p event)
+ (string-match "mouse" (format "%S" (event-basic-type event)))))
+
+
+(defsubst ediff-key-press-event-p (event)
+ (if (featurep 'xemacs)
+ (key-press-event-p event)
+ (or (char-or-string-p event) (symbolp event))))
+
+(defun ediff-event-point (event)
+ (cond ((ediff-mouse-event-p event)
+ (if (featurep 'xemacs)
+ (event-point event)
+ (posn-point (event-start event))))
+ ((ediff-key-press-event-p event)
+ (point))
+ (t (error "Error"))))
+
+(defun ediff-event-buffer (event)
+ (cond ((ediff-mouse-event-p event)
+ (if (featurep 'xemacs)
+ (event-buffer event)
+ (window-buffer (posn-window (event-start event)))))
+ ((ediff-key-press-event-p event)
+ (current-buffer))
+ (t (error "Error"))))
+
+(defun ediff-event-key (event-or-key)
+ (if (featurep 'xemacs)
+ ;;(if (eventp event-or-key) (event-key event-or-key) event-or-key)
+ (if (eventp event-or-key) (event-to-character event-or-key t t) event-or-key)
+ event-or-key))
+
+(defun ediff-last-command-char ()
+ (ediff-event-key last-command-event))
+
+
+(defsubst ediff-frame-iconified-p (frame)
+ (and (ediff-window-display-p) (frame-live-p frame)
+ (if (featurep 'xemacs)
+ (frame-iconified-p frame)
+ (eq (frame-visible-p frame) 'icon))))
+
+(defsubst ediff-window-visible-p (wind)
+ ;; under TTY, window-live-p also means window is visible
+ (and (window-live-p wind)
+ (or (not (ediff-window-display-p))
+ (frame-visible-p (window-frame wind)))))
+
+
+(defsubst ediff-frame-char-width (frame)
+ (if (featurep 'xemacs)
+ (/ (frame-pixel-width frame) (frame-width frame))
+ (frame-char-width frame)))
+
+(defun ediff-reset-mouse (&optional frame do-not-grab-mouse)
+ (or frame (setq frame (selected-frame)))
+ (if (ediff-window-display-p)
+ (let ((frame-or-wind frame))
+ (if (featurep 'xemacs)
+ (setq frame-or-wind (frame-selected-window frame)))
+ (or do-not-grab-mouse
+ ;; don't set mouse if the user said to never do this
+ (not ediff-grab-mouse)
+ ;; Don't grab on quit, if the user doesn't want to.
+ ;; If ediff-grab-mouse = t, then mouse won't be grabbed for
+ ;; sessions that are not part of a group (this is done in
+ ;; ediff-recenter). The condition below affects only terminating
+ ;; sessions in session groups (in which case mouse is warped into
+ ;; a meta buffer).
+ (and (eq ediff-grab-mouse 'maybe)
+ (memq this-command '(ediff-quit ediff-update-diffs)))
+ (set-mouse-position frame-or-wind 1 0))
+ )))
+
+(defsubst ediff-spy-after-mouse ()
+ (setq ediff-mouse-pixel-position (mouse-pixel-position)))
+
+;; It is not easy to find out when the user grabs the mouse, since emacs and
+;; xemacs behave differently when mouse is not in any frame. Also, this is
+;; sensitive to when the user grabbed mouse. Not used for now.
+(defun ediff-user-grabbed-mouse ()
+ (if ediff-mouse-pixel-position
+ (cond ((not (eq (car ediff-mouse-pixel-position)
+ (car (mouse-pixel-position)))))
+ ((and (car (cdr ediff-mouse-pixel-position))
+ (car (cdr (mouse-pixel-position)))
+ (cdr (cdr ediff-mouse-pixel-position))
+ (cdr (cdr (mouse-pixel-position))))
+ (not (and (< (abs (- (car (cdr ediff-mouse-pixel-position))
+ (car (cdr (mouse-pixel-position)))))
+ ediff-mouse-pixel-threshold)
+ (< (abs (- (cdr (cdr ediff-mouse-pixel-position))
+ (cdr (cdr (mouse-pixel-position)))))
+ ediff-mouse-pixel-threshold))))
+ (t nil))))
+
+(defsubst ediff-frame-char-height (frame)
+ (if (featurep 'xemacs)
+ (glyph-height ediff-H-glyph (frame-selected-window frame))
+ (frame-char-height frame)))
+
+;; Some overlay functions
+
+(defsubst ediff-overlay-start (overl)
+ (if (ediff-overlayp overl)
+ (if (featurep 'xemacs)
+ (extent-start-position overl)
+ (overlay-start overl))))
+
+(defsubst ediff-overlay-end (overl)
+ (if (ediff-overlayp overl)
+ (if (featurep 'xemacs)
+ (extent-end-position overl)
+ (overlay-end overl))))
+
+(defsubst ediff-empty-overlay-p (overl)
+ (= (ediff-overlay-start overl) (ediff-overlay-end overl)))
+
+;; like overlay-buffer in Emacs. In XEmacs, returns nil if the extent is
+;; dead. Otherwise, works like extent-buffer
+(defun ediff-overlay-buffer (overl)
+ (if (featurep 'xemacs)
+ (and (extent-live-p overl) (extent-object overl))
+ (overlay-buffer overl)))
+
+;; like overlay-get in Emacs. In XEmacs, returns nil if the extent is
+;; dead. Otherwise, like extent-property
+(defun ediff-overlay-get (overl property)
+ (if (featurep 'xemacs)
+ (and (extent-live-p overl) (extent-property overl property))
+ (overlay-get overl property)))
+
+
+;; These two functions are here because XEmacs refuses to
+;; handle overlays whose buffers were deleted.
+(defun ediff-move-overlay (overlay beg end &optional buffer)
+ "Calls `move-overlay' in Emacs and `set-extent-endpoints' in Lemacs.
+Checks if overlay's buffer exists before actually doing the move."
+ (let ((buf (and overlay (ediff-overlay-buffer overlay))))
+ (if (ediff-buffer-live-p buf)
+ (if (featurep 'xemacs)
+ (set-extent-endpoints overlay beg end)
+ (move-overlay overlay beg end buffer))
+ ;; buffer's dead
+ (if overlay
+ (ediff-delete-overlay overlay)))))
+
+(defun ediff-overlay-put (overlay prop value)
+ "Calls `overlay-put' or `set-extent-property' depending on Emacs version.
+Checks if overlay's buffer exists."
+ (if (ediff-buffer-live-p (ediff-overlay-buffer overlay))
+ (if (featurep 'xemacs)
+ (set-extent-property overlay prop value)
+ (overlay-put overlay prop value))
+ (ediff-delete-overlay overlay)))
+
+;; temporarily uses DIR to abbreviate file name
+;; if DIR is nil, use default-directory
+(defun ediff-abbreviate-file-name (file &optional dir)
+ (cond ((stringp dir)
+ (let ((directory-abbrev-alist (list (cons dir ""))))
+ (abbreviate-file-name file)))
+ (t
+ (if (featurep 'xemacs)
+ ;; XEmacs requires addl argument
+ (abbreviate-file-name file t)
+ (abbreviate-file-name file)))))
+
+;; Takes a directory and returns the parent directory.
+;; does nothing to `/'. If the ARG is a regular file,
+;; strip the file AND the last dir.
+(defun ediff-strip-last-dir (dir)
+ (if (not (stringp dir)) (setq dir default-directory))
+ (setq dir (expand-file-name dir))
+ (or (file-directory-p dir) (setq dir (file-name-directory dir)))
+ (let* ((pos (1- (length dir)))
+ (last-char (aref dir pos)))
+ (if (and (> pos 0) (= last-char ?/))
+ (setq dir (substring dir 0 pos)))
+ (ediff-abbreviate-file-name (file-name-directory dir))))
+
+(defun ediff-truncate-string-left (str newlen)
+ ;; leave space for ... on the left
+ (let ((len (length str))
+ substr)
+ (if (<= len newlen)
+ str
+ (setq newlen (max 0 (- newlen 3)))
+ (setq substr (substring str (max 0 (- len 1 newlen))))
+ (concat "..." substr))))
+
+(defsubst ediff-nonempty-string-p (string)
+ (and (stringp string) (not (string= string ""))))
+
+(unless (fboundp 'subst-char-in-string)
+ (defun subst-char-in-string (fromchar tochar string &optional inplace)
+ "Replace FROMCHAR with TOCHAR in STRING each time it occurs.
+Unless optional argument INPLACE is non-nil, return a new string."
+ (let ((i (length string))
+ (newstr (if inplace string (copy-sequence string))))
+ (while (> i 0)
+ (setq i (1- i))
+ (if (eq (aref newstr i) fromchar)
+ (aset newstr i tochar)))
+ newstr)))
+
+(defun ediff-abbrev-jobname (jobname)
+ (cond ((eq jobname 'ediff-directories)
+ "Compare two directories")
+ ((eq jobname 'ediff-files)
+ "Compare two files")
+ ((eq jobname 'ediff-buffers)
+ "Compare two buffers")
+ ((eq jobname 'ediff-directories3)
+ "Compare three directories")
+ ((eq jobname 'ediff-files3)
+ "Compare three files")
+ ((eq jobname 'ediff-buffers3)
+ "Compare three buffers")
+ ((eq jobname 'ediff-revision)
+ "Compare file with a version")
+ ((eq jobname 'ediff-directory-revisions)
+ "Compare dir files with versions")
+ ((eq jobname 'ediff-merge-directory-revisions)
+ "Merge dir files with versions")
+ ((eq jobname 'ediff-merge-directory-revisions-with-ancestor)
+ "Merge dir versions via ancestors")
+ (t
+ (capitalize
+ (subst-char-in-string ?- ?\s (substring (symbol-name jobname) 6))))
+ ))
+
+
+;; If ediff modified mode line, strip the modification
+(defsubst ediff-strip-mode-line-format ()
+ (if (member (car mode-line-format) '(" A: " " B: " " C: " " Ancestor: "))
+ (setq mode-line-format (nth 2 mode-line-format))))
+
+;; Verify that we have a difference selected.
+(defsubst ediff-valid-difference-p (&optional n)
+ (or n (setq n ediff-current-difference))
+ (and (>= n 0) (< n ediff-number-of-differences)))
+
+(defsubst ediff-show-all-diffs (n)
+ "Don't skip difference regions."
+ nil)
+
+(defsubst ediff-message-if-verbose (string &rest args)
+ (if ediff-verbose-p
+ (apply 'message string args)))
+
+(defun ediff-file-attributes (filename attr-number)
+ (if (ediff-listable-file filename)
+ (nth attr-number (file-attributes filename))
+ -1)
+ )
+
+(defsubst ediff-file-size (filename)
+ (ediff-file-attributes filename 7))
+(defsubst ediff-file-modtime (filename)
+ (ediff-file-attributes filename 5))
+
+
+(defun ediff-convert-standard-filename (fname)
+ (if (fboundp 'convert-standard-filename)
+ (convert-standard-filename fname)
+ fname))
+
+(if (featurep 'emacs)
+ (defalias 'ediff-with-syntax-table 'with-syntax-table)
+ (if (fboundp 'with-syntax-table)
+ (defalias 'ediff-with-syntax-table 'with-syntax-table)
+ ;; stolen from subr.el in emacs 21
+ (defmacro ediff-with-syntax-table (table &rest body)
+ (let ((old-table (make-symbol "table"))
+ (old-buffer (make-symbol "buffer")))
+ `(let ((,old-table (syntax-table))
+ (,old-buffer (current-buffer)))
+ (unwind-protect
+ (progn
+ (set-syntax-table (copy-syntax-table ,table))
+ ,@body)
+ (save-current-buffer
+ (set-buffer ,old-buffer)
+ (set-syntax-table ,old-table))))))))
+
+
+(provide 'ediff-init)
+
+
+
+;; Local Variables:
+;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun)
+;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1)
+;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body))
+;; End:
+
+;; arch-tag: fa31d384-1e70-4d4b-82a7-3e96307c46f5
+;;; ediff-init.el ends here
--- /dev/null
- ;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;;; ediff-merg.el --- merging utilities
+
+;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
++;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+
+;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: ediff
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+
+;; compiler pacifier
+(defvar ediff-window-A)
+(defvar ediff-window-B)
+(defvar ediff-window-C)
+(defvar ediff-merge-window-share)
+(defvar ediff-window-config-saved)
+
+(eval-when-compile
+ (require 'ediff-util))
+;; end pacifier
+
+(require 'ediff-init)
+
+(defcustom ediff-quit-merge-hook 'ediff-maybe-save-and-delete-merge
+ "Hooks to run before quitting a merge job.
+The most common use is to save and delete the merge buffer."
+ :type 'hook
+ :group 'ediff-merge)
+
+
+(defcustom ediff-default-variant 'combined
+ "The variant to be used as a default for buffer C in merging.
+Valid values are the symbols `default-A', `default-B', and `combined'."
+ :type '(radio (const default-A) (const default-B) (const combined))
+ :group 'ediff-merge)
+
+(defcustom ediff-combination-pattern
+ '("<<<<<<< variant A" A ">>>>>>> variant B" B "####### Ancestor" Ancestor "======= end")
+ "Pattern to be used for combining difference regions in buffers A and B.
+The value must be a list of the form
+\(STRING1 bufspec1 STRING2 bufspec2 STRING3 bufspec3 STRING4)
+where bufspec is the symbol A, B, or Ancestor. For instance, if the value is
+'(STRING1 A STRING2 Ancestor STRING3 B STRING4) then the
+combined text will look like this:
+
+STRING1
+diff region from variant A
+STRING2
+diff region from the ancestor
+STRING3
+diff region from variant B
+STRING4
+"
+ :type '(choice (list string symbol string symbol string)
+ (list string symbol string symbol string symbol string))
+ :group 'ediff-merge)
+
+(defcustom ediff-show-clashes-only nil
+ "If t, show only those diff regions where both buffers disagree with the ancestor.
+This means that regions that have status prefer-A or prefer-B will be
+skipped over. A value of nil means show all regions."
+ :type 'boolean
+ :group 'ediff-merge
+ )
+(make-variable-buffer-local 'ediff-show-clashes-only)
+
+(defcustom ediff-skip-merge-regions-that-differ-from-default nil
+ "If t, show only the regions that have not been changed by the user.
+A region is considered to have been changed if it is different from the current
+default (`default-A', `default-B', `combined') and it hasn't been marked as
+`prefer-A' or `prefer-B'.
+A region is considered to have been changed also when it is marked as
+as `prefer-A', but is different from the corresponding difference region in
+Buffer A or if it is marked as `prefer-B' and is different from the region in
+Buffer B."
+ :type 'boolean
+ :group 'ediff-merge
+ )
+(make-variable-buffer-local 'ediff-skip-merge-regions-that-differ-from-default)
+
+;; check if there is no clash between the ancestor and one of the variants.
+;; if it is not a merge job then return true
+(defun ediff-merge-region-is-non-clash (n)
+ (if (ediff-merge-job)
+ (string-match "prefer" (or (ediff-get-state-of-merge n) ""))
+ t))
+
+;; If ediff-show-clashes-only, check if there is no clash between the ancestor
+;; and one of the variants.
+(defun ediff-merge-region-is-non-clash-to-skip (n)
+ (and (ediff-merge-job)
+ ediff-show-clashes-only
+ (ediff-merge-region-is-non-clash n)))
+
+;; If ediff-skip-changed-regions, check if the merge region differs from
+;; the current default. If a region is different from the default, it means
+;; that the user has made determination as to how to merge for this particular
+;; region.
+(defun ediff-skip-merge-region-if-changed-from-default-p (n)
+ (and (ediff-merge-job)
+ ediff-skip-merge-regions-that-differ-from-default
+ (ediff-merge-changed-from-default-p n 'prefers-too)))
+
+
+(defun ediff-get-combined-region (n)
+ (let ((pattern-list ediff-combination-pattern)
+ (combo-region "")
+ (err-msg
+ "ediff-combination-pattern: Invalid format. Please consult the documentation")
+ region-delim region-spec)
+
+ (if (< (length pattern-list) 5)
+ (error err-msg))
+
+ (while (> (length pattern-list) 2)
+ (setq region-delim (nth 0 pattern-list)
+ region-spec (nth 1 pattern-list))
+ (or (and (stringp region-delim) (memq region-spec '(A B Ancestor)))
+ (error err-msg))
+
+ (condition-case nil
+ (setq combo-region
+ (concat combo-region
+ region-delim "\n"
+ (ediff-get-region-contents
+ n region-spec ediff-control-buffer)))
+ (error ""))
+ (setq pattern-list (cdr (cdr pattern-list)))
+ )
+
+ (setq region-delim (nth 0 pattern-list))
+ (or (stringp region-delim)
+ (error err-msg))
+ (setq combo-region (concat combo-region region-delim "\n"))
+ ))
+
+;;(defsubst ediff-make-combined-diff (regA regB)
+;; (concat (nth 0 ediff-combination-pattern) "\n"
+;; regA
+;; (nth 1 ediff-combination-pattern) "\n"
+;; regB
+;; (nth 2 ediff-combination-pattern) "\n"))
+
+(defsubst ediff-set-state-of-all-diffs-in-all-buffers (ctl-buf)
+ (let ((n 0))
+ (while (< n ediff-number-of-differences)
+ (ediff-set-state-of-diff-in-all-buffers n ctl-buf)
+ (setq n (1+ n)))))
+
+(defun ediff-set-state-of-diff-in-all-buffers (n ctl-buf)
+ (let ((regA (ediff-get-region-contents n 'A ctl-buf))
+ (regB (ediff-get-region-contents n 'B ctl-buf))
+ (regC (ediff-get-region-contents n 'C ctl-buf)))
+ (cond ((and (string= regA regB) (string= regA regC))
+ (ediff-set-state-of-diff n 'A "=diff(B)")
+ (ediff-set-state-of-diff n 'B "=diff(C)")
+ (ediff-set-state-of-diff n 'C "=diff(A)"))
+ ((string= regA regB)
+ (ediff-set-state-of-diff n 'A "=diff(B)")
+ (ediff-set-state-of-diff n 'B "=diff(A)")
+ (ediff-set-state-of-diff n 'C nil))
+ ((string= regA regC)
+ (ediff-set-state-of-diff n 'A "=diff(C)")
+ (ediff-set-state-of-diff n 'C "=diff(A)")
+ (ediff-set-state-of-diff n 'B nil))
+ ((string= regB regC)
+ (ediff-set-state-of-diff n 'C "=diff(B)")
+ (ediff-set-state-of-diff n 'B "=diff(C)")
+ (ediff-set-state-of-diff n 'A nil))
+ ((string= regC (ediff-get-combined-region n))
+ (ediff-set-state-of-diff n 'A nil)
+ (ediff-set-state-of-diff n 'B nil)
+ (ediff-set-state-of-diff n 'C "=diff(A+B)"))
+ (t (ediff-set-state-of-diff n 'A nil)
+ (ediff-set-state-of-diff n 'B nil)
+ (ediff-set-state-of-diff n 'C nil)))
+ ))
+
+(defun ediff-set-merge-mode ()
+ (normal-mode t)
+ (remove-hook 'local-write-file-hooks 'ediff-set-merge-mode))
+
+
+;; Go over all diffs starting with DIFF-NUM and copy regions into buffer C
+;; according to the state of the difference.
+;; Since ediff-copy-diff refuses to copy identical diff regions, there is
+;; no need to optimize ediff-do-merge any further.
+;;
+;; If re-merging, change state of merge in all diffs starting with
+;; DIFF-NUM, except those where the state is prefer-* or where it is
+;; `default-*' or `combined' but the buf C region appears to be modified
+;; since last set by default.
+(defun ediff-do-merge (diff-num &optional remerging)
+ (if (< diff-num 0) (setq diff-num 0))
+ (let ((n diff-num)
+ ;;(default-state-of-merge (format "%S" ediff-default-variant))
+ do-not-copy state-of-merge)
+ (while (< n ediff-number-of-differences)
+ (setq do-not-copy nil) ; reset after each cycle
+ (if (= (mod n 10) 0)
+ (message "%s buffers A & B into C ... region %d of %d"
+ (if remerging "Re-merging" "Merging")
+ n
+ ediff-number-of-differences))
+
+ (setq state-of-merge (ediff-get-state-of-merge n))
+
+ (if remerging
+ ;;(let ((reg-A (ediff-get-region-contents n 'A ediff-control-buffer))
+ ;; (reg-B (ediff-get-region-contents n 'B ediff-control-buffer))
+ ;; (reg-C (ediff-get-region-contents n 'C ediff-control-buffer)))
+ (progn
+
+ ;; if region was edited since it was first set by default
+ (if (or (ediff-merge-changed-from-default-p n)
+ ;; was preferred
+ (string-match "prefer" state-of-merge))
+ ;; then ignore
+ (setq do-not-copy t))
+
+ ;; change state of merge for this diff, if necessary
+ (if (and (string-match "\\(default\\|combined\\)" state-of-merge)
+ (not do-not-copy))
+ (ediff-set-state-of-merge
+ n (format "%S" ediff-default-variant)))
+ ))
+
+ ;; state-of-merge may have changed via ediff-set-state-of-merge, so
+ ;; check it once again
+ (setq state-of-merge (ediff-get-state-of-merge n))
+
+ (or do-not-copy
+ (if (string= state-of-merge "combined")
+ ;; use n+1 because ediff-combine-diffs works via user numbering
+ ;; of diffs, which is 1+ to what ediff uses internally
+ (ediff-combine-diffs (1+ n) 'batch)
+ (ediff-copy-diff
+ n (if (string-match "-A" state-of-merge) 'A 'B) 'C 'batch)))
+ (setq n (1+ n)))
+ (message "Merging buffers A & B into C ... Done")
+ ))
+
+
+(defun ediff-re-merge ()
+ "Remerge unmodified diff regions using a new default. Start with the current region."
+ (interactive)
+ (let* ((default-variant-alist
+ (list '("default-A") '("default-B") '("combined")))
+ (actual-alist
+ (delete (list (symbol-name ediff-default-variant))
+ default-variant-alist)))
+ (setq ediff-default-variant
+ (intern
+ (completing-read
+ (format "Current merge default is `%S'. New default: "
+ ediff-default-variant)
+ actual-alist nil 'must-match)))
+ (ediff-do-merge ediff-current-difference 'remerge)
+ (ediff-recenter)
+ ))
+
+(defun ediff-shrink-window-C (arg)
+ "Shrink window C to just one line.
+With a prefix argument, returns window C to its normal size.
+Used only for merging jobs."
+ (interactive "P")
+ (if (not ediff-merge-job)
+ (error "ediff-shrink-window-C can be used only for merging jobs"))
+ (cond ((eq arg '-) (setq arg -1))
+ ((not (numberp arg)) (setq arg nil)))
+ (cond ((null arg)
+ (let ((ediff-merge-window-share
+ (if (< (window-height ediff-window-C) 3)
+ ediff-merge-window-share 0)))
+ (setq ediff-window-config-saved "") ; force redisplay
+ (ediff-recenter 'no-rehighlight)))
+ ((and (< arg 0) (> (window-height ediff-window-C) 2))
+ (setq ediff-merge-window-share (* ediff-merge-window-share 0.9))
+ (setq ediff-window-config-saved "") ; force redisplay
+ (ediff-recenter 'no-rehighlight))
+ ((and (> arg 0) (> (window-height ediff-window-A) 2))
+ (setq ediff-merge-window-share (* ediff-merge-window-share 1.1))
+ (setq ediff-window-config-saved "") ; force redisplay
+ (ediff-recenter 'no-rehighlight))))
+
+
+;; N here is the user's region number. It is 1+ what Ediff uses internally.
+(defun ediff-combine-diffs (n &optional batch-invocation)
+ "Combine Nth diff regions of buffers A and B and place the combination in C.
+N is a prefix argument. If nil, combine the current difference regions.
+Combining is done according to the specifications in variable
+`ediff-combination-pattern'."
+ (interactive "P")
+ (setq n (if (numberp n) (1- n) ediff-current-difference))
+
+ (let (reg-combined)
+ ;;(setq regA (ediff-get-region-contents n 'A ediff-control-buffer)
+ ;; regB (ediff-get-region-contents n 'B ediff-control-buffer))
+ ;;(setq reg-combined (ediff-make-combined-diff regA regB))
+ (setq reg-combined (ediff-get-combined-region n))
+
+ (ediff-copy-diff n nil 'C batch-invocation reg-combined))
+ (or batch-invocation (ediff-jump-to-difference (1+ n))))
+
+
+;; Checks if the region in buff C looks like a combination of the regions
+;; in buffers A and B. Return a list (reg-a-beg reg-a-end reg-b-beg reg-b-end)
+;; These refer to where the delimiters for region A, B, Ancestor start and end
+;; in buffer C
+(defun ediff-looks-like-combined-merge (region-num)
+ (if ediff-merge-job
+ (let ((combined (string-match (regexp-quote "(A+B)")
+ (or (ediff-get-state-of-diff region-num 'C)
+ "")))
+ (mrgreg-beg (ediff-get-diff-posn 'C 'beg region-num))
+ (mrgreg-end (ediff-get-diff-posn 'C 'end region-num))
+ (pattern-list ediff-combination-pattern)
+ delim reg-beg reg-end delim-regs-list)
+
+ (if combined
+ (ediff-with-current-buffer ediff-buffer-C
+ (while pattern-list
+ (goto-char mrgreg-beg)
+ (setq delim (nth 0 pattern-list))
+ (search-forward delim mrgreg-end 'noerror)
+ (setq reg-beg (match-beginning 0))
+ (setq reg-end (match-end 0))
+ (if (and reg-beg reg-end)
+ (setq delim-regs-list
+ ;; in reverse
+ (cons reg-end (cons reg-beg delim-regs-list))))
+ (if (> (length pattern-list) 1)
+ (setq pattern-list (cdr (cdr pattern-list)))
+ (setq pattern-list nil))
+ )))
+
+ (reverse delim-regs-list)
+ )))
+
+(defvar state-of-merge) ; dynamic var
+
+;; Check if the non-preferred merge has been modified since originally set.
+;; This affects only the regions that are marked as default-A/B or combined.
+;; If PREFERS-TOO is non-nil, then look at the regions marked as prefers-A/B as
+;; well.
+(defun ediff-merge-changed-from-default-p (diff-num &optional prefers-too)
+ (let ((reg-A (ediff-get-region-contents diff-num 'A ediff-control-buffer))
+ (reg-B (ediff-get-region-contents diff-num 'B ediff-control-buffer))
+ (reg-C (ediff-get-region-contents diff-num 'C ediff-control-buffer)))
+
+ (setq state-of-merge (ediff-get-state-of-merge diff-num))
+
+ ;; if region was edited since it was first set by default
+ (or (and (string= state-of-merge "default-A")
+ (not (string= reg-A reg-C)))
+ (and (string= state-of-merge "default-B")
+ (not (string= reg-B reg-C)))
+ (and (string= state-of-merge "combined")
+ ;;(not (string= (ediff-make-combined-diff reg-A reg-B) reg-C)))
+ (not (string= (ediff-get-combined-region diff-num) reg-C)))
+ (and prefers-too
+ (string= state-of-merge "prefer-A")
+ (not (string= reg-A reg-C)))
+ (and prefers-too
+ (string= state-of-merge "prefer-B")
+ (not (string= reg-B reg-C)))
+ )))
+
+
+(provide 'ediff-merg)
+
+
+;; Local Variables:
+;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun)
+;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1)
+;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body))
+;; End:
+
+;; arch-tag: 9b798cf9-02ba-487f-a62e-b63aa823dbfb
+;;; ediff-merg.el ends here
--- /dev/null
- ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
- ;; 2005, 2006, 2007, 2008, 2009, 2010
- ;; Free Software Foundation, Inc.
+;;; ediff-ptch.el --- Ediff's patch support
+
++;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002,
++;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+
+;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: ediff
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+
+(provide 'ediff-ptch)
+
+(defgroup ediff-ptch nil
+ "Ediff patch support."
+ :tag "Patch"
+ :prefix "ediff-"
+ :group 'ediff)
+
+;; compiler pacifier
+(eval-when-compile
+ (require 'ediff))
+;; end pacifier
+
+(require 'ediff-init)
+
+(defcustom ediff-patch-program "patch"
+ "Name of the program that applies patches.
+It is recommended to use GNU-compatible versions."
+ :type 'string
+ :group 'ediff-ptch)
+(defcustom ediff-patch-options "-f"
+ "Options to pass to ediff-patch-program.
+
+Note: the `-b' option should be specified in `ediff-backup-specs'.
+
+It is recommended to pass the `-f' option to the patch program, so it won't ask
+questions. However, some implementations don't accept this option, in which
+case the default value for this variable should be changed."
+ :type 'string
+ :group 'ediff-ptch)
+
+(defvar ediff-last-dir-patch nil
+ "Last directory used by an Ediff command for file to patch.")
+
+;; the default backup extension
+(defconst ediff-default-backup-extension
+ (if (eq system-type '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:
+
+;;; ediff-ptch.el ends here
--- /dev/null
- ;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;;; ediff-vers.el --- version control interface to Ediff
+
+;; Copyright (C) 1995, 1996, 1997, 2001, 2002, 2003, 2004,
++;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+
+;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: ediff
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+;; Compiler pacifier
+(defvar rcs-default-co-switches)
+
+(and noninteractive
+ (eval-when-compile
+ (condition-case nil
+ ;; for compatibility with current stable version of xemacs
+ (progn
+ ;;(require 'pcvs nil 'noerror)
+ ;;(require 'rcs nil 'noerror)
+ (require 'pcvs)
+ (require 'rcs))
+ (error nil))
+ (require 'vc)
+ (require 'ediff-init)
+ ))
+;; end pacifier
+
+(defcustom ediff-keep-tmp-versions nil
+ "If t, do not delete temporary previous versions for the files on which
+comparison or merge operations are being performed."
+ :type 'boolean
+ :group 'ediff-vers
+ )
+
+(defalias 'ediff-vc-revision-other-window
+ (if (fboundp 'vc-revision-other-window)
+ 'vc-revision-other-window
+ 'vc-version-other-window))
+
+(defalias 'ediff-vc-working-revision
+ (if (fboundp 'vc-working-revision)
+ 'vc-working-revision
+ 'vc-workfile-version))
+
+;; VC.el support
+
+(eval-when-compile
+ (require 'vc-hooks)) ;; for vc-call macro
+
+
+(defun ediff-vc-latest-version (file)
+ "Return the version level of the latest version of FILE in repository."
+ (if (fboundp 'vc-latest-version)
+ (vc-latest-version file)
+ (or (vc-file-getprop file 'vc-latest-revision)
+ (cond ((vc-backend file)
+ (vc-call state file)
+ (vc-file-getprop file 'vc-latest-revision))
+ (t (error "File %s is not under version control" file))))
+ ))
+
+
+(defun ediff-vc-internal (rev1 rev2 &optional startup-hooks)
+ ;; Run Ediff on versions of the current buffer.
+ ;; If REV1 is "", use the latest version of the current buffer's file.
+ ;; If REV2 is "" then compare current buffer with REV1.
+ ;; If the current buffer is named `F', the version is named `F.~REV~'.
+ ;; If `F.~REV~' already exists, it is used instead of being re-created.
+ (let (file1 file2 rev1buf rev2buf)
+ (if (string= rev1 "")
+ (setq rev1 (ediff-vc-latest-version (buffer-file-name))))
+ (save-window-excursion
+ (save-excursion
+ (ediff-vc-revision-other-window rev1)
+ (setq rev1buf (current-buffer)
+ file1 (buffer-file-name)))
+ (save-excursion
+ (or (string= rev2 "") ; use current buffer
+ (ediff-vc-revision-other-window rev2))
+ (setq rev2buf (current-buffer)
+ file2 (buffer-file-name)))
+ (setq startup-hooks
+ (cons `(lambda ()
+ (ediff-delete-version-file ,file1)
+ (or ,(string= rev2 "") (ediff-delete-version-file ,file2)))
+ startup-hooks)))
+ (ediff-buffers
+ rev1buf rev2buf
+ startup-hooks
+ 'ediff-revision)))
+
+;; RCS.el support
+(defun rcs-ediff-view-revision (&optional rev)
+;; View previous RCS revision of current file.
+;; With prefix argument, prompts for a revision name.
+ (interactive (list (if current-prefix-arg
+ (read-string "Revision: "))))
+ (let* ((filename (buffer-file-name (current-buffer)))
+ (switches (append '("-p")
+ (if rev (list (concat "-r" rev)) nil)))
+ (buff (concat (file-name-nondirectory filename) ".~" rev "~")))
+ (message "Working ...")
+ (setq filename (expand-file-name filename))
+ (with-output-to-temp-buffer buff
+ (ediff-with-current-buffer standard-output
+ (fundamental-mode))
+ (let ((output-buffer (ediff-rcs-get-output-buffer filename buff)))
+ (delete-windows-on output-buffer)
+ (with-current-buffer output-buffer
+ (apply 'call-process "co" nil t nil
+ ;; -q: quiet (no diagnostics)
+ (append switches rcs-default-co-switches
+ (list "-q" filename)))))
+ (message "")
+ buff)))
+
+(defun ediff-rcs-get-output-buffer (file name)
+ ;; Get a buffer for RCS output for FILE, make it writable and clean it up.
+ ;; Optional NAME is name to use instead of `*RCS-output*'.
+ ;; This is a modified version from rcs.el v1.1. I use it here to make
+ ;; Ediff immune to changes in rcs.el
+ (let ((buf (get-buffer-create name)))
+ (with-current-buffer buf
+ (setq buffer-read-only nil
+ default-directory (file-name-directory (expand-file-name file)))
+ (erase-buffer))
+ buf))
+
+(defun ediff-rcs-internal (rev1 rev2 &optional startup-hooks)
+;; Run Ediff on versions of the current buffer.
+;; If REV2 is "" then use current buffer.
+ (let (rev2buf rev1buf)
+ (save-window-excursion
+ (setq rev2buf (if (string= rev2 "")
+ (current-buffer)
+ (rcs-ediff-view-revision rev2))
+ rev1buf (rcs-ediff-view-revision rev1)))
+
+ ;; rcs.el doesn't create temp version files, so we don't have to delete
+ ;; anything in startup hooks to ediff-buffers
+ (ediff-buffers rev1buf rev2buf startup-hooks 'ediff-revision)
+ ))
+
+;;; Merge with Version Control
+
+(defun ediff-vc-merge-internal (rev1 rev2 ancestor-rev
+ &optional startup-hooks merge-buffer-file)
+;; If ANCESTOR-REV non-nil, merge with ancestor
+ (let (buf1 buf2 ancestor-buf)
+ (save-window-excursion
+ (save-excursion
+ (ediff-vc-revision-other-window rev1)
+ (setq buf1 (current-buffer)))
+ (save-excursion
+ (or (string= rev2 "")
+ (ediff-vc-revision-other-window rev2))
+ (setq buf2 (current-buffer)))
+ (if ancestor-rev
+ (save-excursion
+ (if (string= ancestor-rev "")
+ (setq ancestor-rev (ediff-vc-working-revision buffer-file-name)))
+ (ediff-vc-revision-other-window ancestor-rev)
+ (setq ancestor-buf (current-buffer))))
+ (setq startup-hooks
+ (cons
+ `(lambda ()
+ (ediff-delete-version-file ,(buffer-file-name buf1))
+ (or ,(string= rev2 "")
+ (ediff-delete-version-file ,(buffer-file-name buf2)))
+ (or ,(string= ancestor-rev "")
+ ,(not ancestor-rev)
+ (ediff-delete-version-file ,(buffer-file-name ancestor-buf)))
+ )
+ startup-hooks)))
+ (if ancestor-rev
+ (ediff-merge-buffers-with-ancestor
+ buf1 buf2 ancestor-buf
+ startup-hooks 'ediff-merge-revisions-with-ancestor merge-buffer-file)
+ (ediff-merge-buffers
+ buf1 buf2 startup-hooks 'ediff-merge-revisions merge-buffer-file))
+ ))
+
+(defun ediff-rcs-merge-internal (rev1 rev2 ancestor-rev
+ &optional
+ startup-hooks merge-buffer-file)
+ ;; If ANCESTOR-REV non-nil, merge with ancestor
+ (let (buf1 buf2 ancestor-buf)
+ (save-window-excursion
+ (setq buf1 (rcs-ediff-view-revision rev1)
+ buf2 (if (string= rev2 "")
+ (current-buffer)
+ (rcs-ediff-view-revision rev2))
+ ancestor-buf (if ancestor-rev
+ (if (string= ancestor-rev "")
+ (current-buffer)
+ (rcs-ediff-view-revision ancestor-rev)))))
+ ;; rcs.el doesn't create temp version files, so we don't have to delete
+ ;; anything in startup hooks to ediff-buffers
+ (if ancestor-rev
+ (ediff-merge-buffers-with-ancestor
+ buf1 buf2 ancestor-buf
+ startup-hooks 'ediff-merge-revisions-with-ancestor merge-buffer-file)
+ (ediff-merge-buffers
+ buf1 buf2 startup-hooks 'ediff-merge-revisions merge-buffer-file))))
+
+
+;; delete version file on exit unless ediff-keep-tmp-versions is true
+(defun ediff-delete-version-file (file)
+ (or ediff-keep-tmp-versions (delete-file file)))
+
+
+(provide 'ediff-vers)
+
+
+;; Local Variables:
+;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun)
+;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1)
+;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body))
+;; End:
+
+;; arch-tag: bbb34f0c-2a90-426a-a77a-c75f479ebbbf
+;;; ediff-vers.el ends here
--- /dev/null
- ;; Copyright (C) 1994, 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2004,
- ;; 2005, 2006, 2007, 2008, 2009, 2010
- ;; Free Software Foundation, Inc.
+;;; ediff-wind.el --- window manipulation utilities
+
++;; Copyright (C) 1994, 1995, 1996, 1997, 2000, 2001, 2002, 2003,
++;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+
+;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: ediff
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+
+;; Compiler pacifier
+(defvar icon-title-format)
+(defvar top-toolbar-height)
+(defvar bottom-toolbar-height)
+(defvar left-toolbar-height)
+(defvar right-toolbar-height)
+(defvar left-toolbar-width)
+(defvar right-toolbar-width)
+(defvar default-menubar)
+(defvar top-gutter)
+(defvar frame-icon-title-format)
+(defvar ediff-diff-status)
+
+;; declare-function does not exist in XEmacs
+(eval-and-compile
+ (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
+
+(eval-when-compile
+ (require 'ediff-util)
+ (require 'ediff-help))
+;; end pacifier
+
+(require 'ediff-init)
+
+;; be careful with ediff-tbar
+(if (featurep 'xemacs)
+ (require 'ediff-tbar)
+ (defun ediff-compute-toolbar-width () 0))
+
+(defgroup ediff-window nil
+ "Ediff window manipulation."
+ :prefix "ediff-"
+ :group 'ediff
+ :group 'frames)
+
+
+;; Determine which window setup function to use based on current window system.
+(defun ediff-choose-window-setup-function-automatically ()
+ (if (ediff-window-display-p)
+ 'ediff-setup-windows-multiframe
+ 'ediff-setup-windows-plain))
+
+(defcustom ediff-window-setup-function (ediff-choose-window-setup-function-automatically)
+ "Function called to set up windows.
+Ediff provides a choice of two functions: `ediff-setup-windows-plain', for
+doing everything in one frame and `ediff-setup-windows-multiframe', which sets
+the control panel in a separate frame. By default, the appropriate function is
+chosen automatically depending on the current window system.
+However, `ediff-toggle-multiframe' can be used to toggle between the multiframe
+display and the single frame display.
+If the multiframe function detects that one of the buffers A/B is seen in some
+other frame, it will try to keep that buffer in that frame.
+
+If you don't like any of the two provided functions, write your own one.
+The basic guidelines:
+ 1. It should leave the control buffer current and the control window
+ selected.
+ 2. It should set `ediff-window-A', `ediff-window-B', `ediff-window-C',
+ and `ediff-control-window' to contain window objects that display
+ the corresponding buffers.
+ 3. It should accept the following arguments:
+ buffer-A, buffer-B, buffer-C, control-buffer
+ Buffer C may not be used in jobs that compare only two buffers.
+If you plan to do something fancy, take a close look at how the two
+provided functions are written."
+ :type '(choice (const :tag "Multi Frame" ediff-setup-windows-multiframe)
+ (const :tag "Single Frame" ediff-setup-windows-plain)
+ (function :tag "Other function"))
+ :group 'ediff-window)
+
+;; indicates if we are in a multiframe setup
+(ediff-defvar-local ediff-multiframe nil "")
+
+;; Share of the frame occupied by the merge window (buffer C)
+(ediff-defvar-local ediff-merge-window-share 0.45 "")
+
+;; The control window.
+(ediff-defvar-local ediff-control-window nil "")
+;; Official window for buffer A
+(ediff-defvar-local ediff-window-A nil "")
+;; Official window for buffer B
+(ediff-defvar-local ediff-window-B nil "")
+;; Official window for buffer C
+(ediff-defvar-local ediff-window-C nil "")
+;; Ediff's window configuration.
+;; Used to minimize the need to rearrange windows.
+(ediff-defvar-local ediff-window-config-saved "" "")
+
+;; Association between buff-type and ediff-window-*
+(defconst ediff-window-alist
+ '((A . ediff-window-A)
+ (?A . ediff-window-A)
+ (B . ediff-window-B)
+ (?B . ediff-window-B)
+ (C . ediff-window-C)
+ (?C . ediff-window-C)))
+
+
+(defcustom ediff-split-window-function 'split-window-vertically
+ "The function used to split the main window between buffer-A and buffer-B.
+You can set it to a horizontal split instead of the default vertical split
+by setting this variable to `split-window-horizontally'.
+You can also have your own function to do fancy splits.
+This variable has no effect when buffer-A/B are shown in different frames.
+In this case, Ediff will use those frames to display these buffers."
+ :type '(choice
+ (const :tag "Split vertically" split-window-vertically)
+ (const :tag "Split horizontally" split-window-horizontally)
+ function)
+ :group 'ediff-window)
+
+(defcustom ediff-merge-split-window-function 'split-window-horizontally
+ "The function used to split the main window between buffer-A and buffer-B.
+You can set it to a vertical split instead of the default horizontal split
+by setting this variable to `split-window-vertically'.
+You can also have your own function to do fancy splits.
+This variable has no effect when buffer-A/B/C are shown in different frames.
+In this case, Ediff will use those frames to display these buffers."
+ :type '(choice
+ (const :tag "Split vertically" split-window-vertically)
+ (const :tag "Split horizontally" split-window-horizontally)
+ function)
+ :group 'ediff-window)
+
+;; Definitions hidden from the compiler by compat wrappers.
+(declare-function ediff-display-pixel-width "ediff-init")
+(declare-function ediff-display-pixel-height "ediff-init")
+
+(defconst ediff-control-frame-parameters
+ (list
+ '(name . "Ediff")
+ ;;'(unsplittable . t)
+ '(minibuffer . nil)
+ '(user-position . t) ; Emacs only
+ '(vertical-scroll-bars . nil) ; Emacs only
+ '(scrollbar-width . 0) ; XEmacs only
+ '(scrollbar-height . 0) ; XEmacs only
+ '(menu-bar-lines . 0) ; Emacs only
+ '(tool-bar-lines . 0) ; Emacs 21+ only
+ '(left-fringe . 0)
+ '(right-fringe . 0)
+ ;; don't lower but auto-raise
+ '(auto-lower . nil)
+ '(auto-raise . t)
+ '(visibility . nil)
+ ;; make initial frame small to avoid distraction
+ '(width . 1) '(height . 1)
+ ;; this blocks queries from window manager as to where to put
+ ;; ediff's control frame. we put the frame outside the display,
+ ;; so the initial frame won't jump all over the screen
+ (cons 'top (if (fboundp 'ediff-display-pixel-height)
+ (1+ (ediff-display-pixel-height))
+ 3000))
+ (cons 'left (if (fboundp 'ediff-display-pixel-width)
+ (1+ (ediff-display-pixel-width))
+ 3000))
+ )
+ "Frame parameters for displaying Ediff Control Panel.
+Used internally---not a user option.")
+
+;; position of the mouse; used to decide whether to warp the mouse into ctl
+;; frame
+(ediff-defvar-local ediff-mouse-pixel-position nil "")
+
+;; not used for now
+(defvar ediff-mouse-pixel-threshold 30
+ "If the user moves mouse more than this many pixels, Ediff won't warp mouse into control window.")
+
+(defcustom ediff-grab-mouse t
+ "If t, Ediff will always grab the mouse and put it in the control frame.
+If 'maybe, Ediff will do it sometimes, but not after operations that require
+relatively long time. If nil, the mouse will be entirely user's
+responsibility."
+ :type 'boolean
+ :group 'ediff-window)
+
+(defcustom ediff-control-frame-position-function 'ediff-make-frame-position
+ "Function to call to determine the desired location for the control panel.
+Expects three parameters: the control buffer, the desired width and height
+of the control frame. It returns an association list
+of the form \(\(top . <position>\) \(left . <position>\)\)"
+ :type 'function
+ :group 'ediff-window)
+
+(defcustom ediff-control-frame-upward-shift 42
+ "The upward shift of control frame from the top of buffer A's frame.
+Measured in pixels.
+This is used by the default control frame positioning function,
+`ediff-make-frame-position'. This variable is provided for easy
+customization of the default control frame positioning."
+ :type 'integer
+ :group 'ediff-window)
+
+(defcustom ediff-narrow-control-frame-leftward-shift (if (featurep 'xemacs) 7 3)
+ "The leftward shift of control frame from the right edge of buf A's frame.
+Measured in characters.
+This is used by the default control frame positioning function,
+`ediff-make-frame-position' to adjust the position of the control frame
+when it shows the short menu. This variable is provided for easy
+customization of the default."
+ :type 'integer
+ :group 'ediff-window)
+
+(defcustom ediff-wide-control-frame-rightward-shift 7
+ "The rightward shift of control frame from the left edge of buf A's frame.
+Measured in characters.
+This is used by the default control frame positioning function,
+`ediff-make-frame-position' to adjust the position of the control frame
+when it shows the full menu. This variable is provided for easy
+customization of the default."
+ :type 'integer
+ :group 'ediff-window)
+
+
+;; Wide frame display
+
+;; t means Ediff is using wide display
+(ediff-defvar-local ediff-wide-display-p nil "")
+;; keeps frame config for toggling wide display
+(ediff-defvar-local ediff-wide-display-orig-parameters nil
+ "Frame parameters to be restored when the user wants to toggle the wide
+display off.")
+(ediff-defvar-local ediff-wide-display-frame nil
+ "Frame to be used for wide display.")
+(ediff-defvar-local ediff-make-wide-display-function 'ediff-make-wide-display
+ "The value is a function that is called to create a wide display.
+The function is called without arguments. It should resize the frame in
+which buffers A, B, and C are to be displayed, and it should save the old
+frame parameters in `ediff-wide-display-orig-parameters'.
+The variable `ediff-wide-display-frame' should be set to contain
+the frame used for the wide display.")
+
+;; Frame used for the control panel in a windowing system.
+(ediff-defvar-local ediff-control-frame nil "")
+
+(defcustom ediff-prefer-iconified-control-frame nil
+ "If t, keep control panel iconified when help message is off.
+This has effect only on a windowing system.
+If t, hitting `?' to toggle control panel off iconifies it.
+
+This is only useful in Emacs and only for certain kinds of window managers,
+such as TWM and its derivatives, since the window manager must permit
+keyboard input to go into icons. XEmacs completely ignores keyboard input
+into icons, regardless of the window manager."
+ :type 'boolean
+ :group 'ediff-window)
+
+;;; Functions
+
+(defun ediff-get-window-by-clicking (wind prev-wind wind-number)
+ (let (event)
+ (message
+ "Select windows by clicking. Please click on Window %d " wind-number)
+ (while (not (ediff-mouse-event-p (setq event (ediff-read-event))))
+ (if (sit-for 1) ; if sequence of events, wait till the final word
+ (beep 1))
+ (message "Please click on Window %d " wind-number))
+ (ediff-read-event) ; discard event
+ (setq wind (if (featurep 'xemacs)
+ (event-window event)
+ (posn-window (event-start event))))))
+
+
+;; Select the lowest window on the frame.
+(defun ediff-select-lowest-window ()
+ (if (featurep 'xemacs)
+ (select-window (frame-lowest-window))
+ (let* ((lowest-window (selected-window))
+ (bottom-edge (car (cdr (cdr (cdr (window-edges))))))
+ (last-window (save-excursion
+ (other-window -1) (selected-window)))
+ (window-search t))
+ (while window-search
+ (let* ((this-window (next-window))
+ (next-bottom-edge
+ (car (cdr (cdr (cdr (window-edges this-window)))))))
+ (if (< bottom-edge next-bottom-edge)
+ (setq bottom-edge next-bottom-edge
+ lowest-window this-window))
+ (select-window this-window)
+ (when (eq last-window this-window)
+ (select-window lowest-window)
+ (setq window-search nil)))))))
+
+
+;;; Common window setup routines
+
+;; Set up the window configuration. If POS is given, set the points to
+;; the beginnings of the buffers.
+;; When 3way comparison is added, this will have to choose the appropriate
+;; setup function based on ediff-job-name
+(defun ediff-setup-windows (buffer-A buffer-B buffer-C control-buffer)
+ ;; Make sure we are not in the minibuffer window when we try to delete
+ ;; all other windows.
+ (run-hooks 'ediff-before-setup-windows-hook)
+ (if (eq (selected-window) (minibuffer-window))
+ (other-window 1))
+
+ ;; in case user did a no-no on a tty
+ (or (ediff-window-display-p)
+ (setq ediff-window-setup-function 'ediff-setup-windows-plain))
+
+ (or (ediff-keep-window-config control-buffer)
+ (funcall
+ (ediff-with-current-buffer control-buffer ediff-window-setup-function)
+ buffer-A buffer-B buffer-C control-buffer))
+ (run-hooks 'ediff-after-setup-windows-hook))
+
+;; Just set up 3 windows.
+;; Usually used without windowing systems
+;; With windowing, we want to use dedicated frames.
+(defun ediff-setup-windows-plain (buffer-A buffer-B buffer-C control-buffer)
+ (ediff-with-current-buffer control-buffer
+ (setq ediff-multiframe nil))
+ (if ediff-merge-job
+ (ediff-setup-windows-plain-merge
+ buffer-A buffer-B buffer-C control-buffer)
+ (ediff-setup-windows-plain-compare
+ buffer-A buffer-B buffer-C control-buffer)))
+
+(defun ediff-setup-windows-plain-merge (buf-A buf-B buf-C control-buffer)
+ ;; skip dedicated and unsplittable frames
+ (ediff-destroy-control-frame control-buffer)
+ (let ((window-min-height 1)
+ split-window-function
+ merge-window-share merge-window-lines
+ wind-A wind-B wind-C)
+ (ediff-with-current-buffer control-buffer
+ (setq merge-window-share ediff-merge-window-share
+ ;; this lets us have local versions of ediff-split-window-function
+ split-window-function ediff-split-window-function))
+ (delete-other-windows)
+ (set-window-dedicated-p (selected-window) nil)
+ (split-window-vertically)
+ (ediff-select-lowest-window)
+ (ediff-setup-control-buffer control-buffer)
+
+ ;; go to the upper window and split it betw A, B, and possibly C
+ (other-window 1)
+ (setq merge-window-lines
+ (max 2 (round (* (window-height) merge-window-share))))
+ (switch-to-buffer buf-A)
+ (setq wind-A (selected-window))
+
+ ;; XEmacs used to have a lot of trouble with display
+ ;; It did't set things right unless we tell it to sit still
+ ;; 19.12 seems ok.
+ ;;(if (featurep 'xemacs) (sit-for 0))
+
+ (split-window-vertically (max 2 (- (window-height) merge-window-lines)))
+ (if (eq (selected-window) wind-A)
+ (other-window 1))
+ (setq wind-C (selected-window))
+ (switch-to-buffer buf-C)
+
+ (select-window wind-A)
+ (funcall split-window-function)
+
+ (if (eq (selected-window) wind-A)
+ (other-window 1))
+ (switch-to-buffer buf-B)
+ (setq wind-B (selected-window))
+
+ (ediff-with-current-buffer control-buffer
+ (setq ediff-window-A wind-A
+ ediff-window-B wind-B
+ ediff-window-C wind-C))
+
+ (ediff-select-lowest-window)
+ (ediff-setup-control-buffer control-buffer)
+ ))
+
+
+;; This function handles all comparison jobs, including 3way jobs
+(defun ediff-setup-windows-plain-compare (buf-A buf-B buf-C control-buffer)
+ ;; skip dedicated and unsplittable frames
+ (ediff-destroy-control-frame control-buffer)
+ (let ((window-min-height 1)
+ split-window-function wind-width-or-height
+ three-way-comparison
+ wind-A-start wind-B-start wind-A wind-B wind-C)
+ (ediff-with-current-buffer control-buffer
+ (setq wind-A-start (ediff-overlay-start
+ (ediff-get-value-according-to-buffer-type
+ 'A ediff-narrow-bounds))
+ wind-B-start (ediff-overlay-start
+ (ediff-get-value-according-to-buffer-type
+ 'B ediff-narrow-bounds))
+ ;; this lets us have local versions of ediff-split-window-function
+ split-window-function ediff-split-window-function
+ three-way-comparison ediff-3way-comparison-job))
+ ;; if in minibuffer go somewhere else
+ (if (save-match-data
+ (string-match "\*Minibuf-" (buffer-name (window-buffer))))
+ (select-window (next-window nil 'ignore-minibuf)))
+ (delete-other-windows)
+ (set-window-dedicated-p (selected-window) nil)
+ (split-window-vertically)
+ (ediff-select-lowest-window)
+ (ediff-setup-control-buffer control-buffer)
+
+ ;; go to the upper window and split it betw A, B, and possibly C
+ (other-window 1)
+ (switch-to-buffer buf-A)
+ (setq wind-A (selected-window))
+ (if three-way-comparison
+ (setq wind-width-or-height
+ (/ (if (eq split-window-function 'split-window-vertically)
+ (window-height wind-A)
+ (window-width wind-A))
+ 3)))
+
+ ;; XEmacs used to have a lot of trouble with display
+ ;; It did't set things right unless we told it to sit still
+ ;; 19.12 seems ok.
+ ;;(if (featurep 'xemacs) (sit-for 0))
+
+ (funcall split-window-function wind-width-or-height)
+
+ (if (eq (selected-window) wind-A)
+ (other-window 1))
+ (switch-to-buffer buf-B)
+ (setq wind-B (selected-window))
+
+ (if three-way-comparison
+ (progn
+ (funcall split-window-function) ; equally
+ (if (eq (selected-window) wind-B)
+ (other-window 1))
+ (switch-to-buffer buf-C)
+ (setq wind-C (selected-window))))
+
+ (ediff-with-current-buffer control-buffer
+ (setq ediff-window-A wind-A
+ ediff-window-B wind-B
+ ediff-window-C wind-C))
+
+ ;; It is unlikely that we will want to implement 3way window comparison.
+ ;; So, only buffers A and B are used here.
+ (if ediff-windows-job
+ (progn
+ (set-window-start wind-A wind-A-start)
+ (set-window-start wind-B wind-B-start)))
+
+ (ediff-select-lowest-window)
+ (ediff-setup-control-buffer control-buffer)
+ ))
+
+
+;; dispatch an appropriate window setup function
+(defun ediff-setup-windows-multiframe (buf-A buf-B buf-C control-buf)
+ (ediff-with-current-buffer control-buf
+ (setq ediff-multiframe t))
+ (if ediff-merge-job
+ (ediff-setup-windows-multiframe-merge buf-A buf-B buf-C control-buf)
+ (ediff-setup-windows-multiframe-compare buf-A buf-B buf-C control-buf)))
+
+(defun ediff-setup-windows-multiframe-merge (buf-A buf-B buf-C control-buf)
+;;; Algorithm:
+;;; 1. Never use frames that have dedicated windows in them---it is bad to
+;;; destroy dedicated windows.
+;;; 2. If A and B are in the same frame but C's frame is different--- use one
+;;; frame for A and B and use a separate frame for C.
+;;; 3. If C's frame is non-existent, then: if the first suitable
+;;; non-dedicated frame is different from A&B's, then use it for C.
+;;; Otherwise, put A,B, and C in one frame.
+;;; 4. If buffers A, B, C are is separate frames, use them to display these
+;;; buffers.
+
+ ;; Skip dedicated or iconified frames.
+ ;; Unsplittable frames are taken care of later.
+ (ediff-skip-unsuitable-frames 'ok-unsplittable)
+
+ (let* ((window-min-height 1)
+ (wind-A (ediff-get-visible-buffer-window buf-A))
+ (wind-B (ediff-get-visible-buffer-window buf-B))
+ (wind-C (ediff-get-visible-buffer-window buf-C))
+ (frame-A (if wind-A (window-frame wind-A)))
+ (frame-B (if wind-B (window-frame wind-B)))
+ (frame-C (if wind-C (window-frame wind-C)))
+ ;; on wide display, do things in one frame
+ (force-one-frame
+ (ediff-with-current-buffer control-buf ediff-wide-display-p))
+ ;; this lets us have local versions of ediff-split-window-function
+ (split-window-function
+ (ediff-with-current-buffer control-buf ediff-split-window-function))
+ (orig-wind (selected-window))
+ (orig-frame (selected-frame))
+ (use-same-frame (or force-one-frame
+ ;; A and C must be in one frame
+ (eq frame-A (or frame-C orig-frame))
+ ;; B and C must be in one frame
+ (eq frame-B (or frame-C orig-frame))
+ ;; A or B is not visible
+ (not (frame-live-p frame-A))
+ (not (frame-live-p frame-B))
+ ;; A or B is not suitable for display
+ (not (ediff-window-ok-for-display wind-A))
+ (not (ediff-window-ok-for-display wind-B))
+ ;; A and B in the same frame, and no good frame
+ ;; for C
+ (and (eq frame-A frame-B)
+ (not (frame-live-p frame-C)))
+ ))
+ ;; use-same-frame-for-AB implies wind A and B are ok for display
+ (use-same-frame-for-AB (and (not use-same-frame)
+ (eq frame-A frame-B)))
+ (merge-window-share (ediff-with-current-buffer control-buf
+ ediff-merge-window-share))
+ merge-window-lines
+ designated-minibuffer-frame
+ done-A done-B done-C)
+
+ ;; buf-A on its own
+ (if (and (window-live-p wind-A)
+ (null use-same-frame) ; implies wind-A is suitable
+ (null use-same-frame-for-AB))
+ (progn ; bug A on its own
+ ;; buffer buf-A is seen in live wind-A
+ (select-window wind-A)
+ (delete-other-windows)
+ (setq wind-A (selected-window))
+ (setq done-A t)))
+
+ ;; buf-B on its own
+ (if (and (window-live-p wind-B)
+ (null use-same-frame) ; implies wind-B is suitable
+ (null use-same-frame-for-AB))
+ (progn ; buf B on its own
+ ;; buffer buf-B is seen in live wind-B
+ (select-window wind-B)
+ (delete-other-windows)
+ (setq wind-B (selected-window))
+ (setq done-B t)))
+
+ ;; buf-C on its own
+ (if (and (window-live-p wind-C)
+ (ediff-window-ok-for-display wind-C)
+ (null use-same-frame)) ; buf C on its own
+ (progn
+ ;; buffer buf-C is seen in live wind-C
+ (select-window wind-C)
+ (delete-other-windows)
+ (setq wind-C (selected-window))
+ (setq done-C t)))
+
+ (if (and use-same-frame-for-AB ; implies wind A and B are suitable
+ (window-live-p wind-A))
+ (progn
+ ;; wind-A must already be displaying buf-A
+ (select-window wind-A)
+ (delete-other-windows)
+ (setq wind-A (selected-window))
+
+ (funcall split-window-function)
+ (if (eq (selected-window) wind-A)
+ (other-window 1))
+ (switch-to-buffer buf-B)
+ (setq wind-B (selected-window))
+
+ (setq done-A t
+ done-B t)))
+
+ (if use-same-frame
+ (let ((window-min-height 1))
+ (if (and (eq frame-A frame-B)
+ (eq frame-B frame-C)
+ (frame-live-p frame-A))
+ (select-frame frame-A)
+ ;; avoid dedicated and non-splittable windows
+ (ediff-skip-unsuitable-frames))
+ (delete-other-windows)
+ (setq merge-window-lines
+ (max 2 (round (* (window-height) merge-window-share))))
+ (switch-to-buffer buf-A)
+ (setq wind-A (selected-window))
+
+ (split-window-vertically
+ (max 2 (- (window-height) merge-window-lines)))
+ (if (eq (selected-window) wind-A)
+ (other-window 1))
+ (setq wind-C (selected-window))
+ (switch-to-buffer buf-C)
+
+ (select-window wind-A)
+
+ (funcall split-window-function)
+ (if (eq (selected-window) wind-A)
+ (other-window 1))
+ (switch-to-buffer buf-B)
+ (setq wind-B (selected-window))
+
+ (setq done-A t
+ done-B t
+ done-C t)
+ ))
+
+ (or done-A ; Buf A to be set in its own frame,
+ ;;; or it was set before because use-same-frame = 1
+ (progn
+ ;; Buf-A was not set up yet as it wasn't visible,
+ ;; and use-same-frame = nil, use-same-frame-for-AB = nil
+ (select-window orig-wind)
+ (delete-other-windows)
+ (switch-to-buffer buf-A)
+ (setq wind-A (selected-window))
+ ))
+ (or done-B ; Buf B to be set in its own frame,
+ ;;; or it was set before because use-same-frame = 1
+ (progn
+ ;; Buf-B was not set up yet as it wasn't visible
+ ;; and use-same-frame = nil, use-same-frame-for-AB = nil
+ (select-window orig-wind)
+ (delete-other-windows)
+ (switch-to-buffer buf-B)
+ (setq wind-B (selected-window))
+ ))
+
+ (or done-C ; Buf C to be set in its own frame,
+ ;;; or it was set before because use-same-frame = 1
+ (progn
+ ;; Buf-C was not set up yet as it wasn't visible
+ ;; and use-same-frame = nil
+ (select-window orig-wind)
+ (delete-other-windows)
+ (switch-to-buffer buf-C)
+ (setq wind-C (selected-window))
+ ))
+
+ (ediff-with-current-buffer control-buf
+ (setq ediff-window-A wind-A
+ ediff-window-B wind-B
+ ediff-window-C wind-C)
+ (setq frame-A (window-frame ediff-window-A)
+ designated-minibuffer-frame
+ (window-frame (minibuffer-window frame-A))))
+
+ (ediff-setup-control-frame control-buf designated-minibuffer-frame)
+ ))
+
+
+;; Window setup for all comparison jobs, including 3way comparisons
+(defun ediff-setup-windows-multiframe-compare (buf-A buf-B buf-C control-buf)
+;;; Algorithm:
+;;; If a buffer is seen in a frame, use that frame for that buffer.
+;;; If it is not seen, use the current frame.
+;;; If both buffers are not seen, they share the current frame. If one
+;;; of the buffers is not seen, it is placed in the current frame (where
+;;; ediff started). If that frame is displaying the other buffer, it is
+;;; shared between the two buffers.
+;;; However, if we decide to put both buffers in one frame
+;;; and the selected frame isn't splittable, we create a new frame and
+;;; put both buffers there, event if one of this buffers is visible in
+;;; another frame.
+
+ ;; Skip dedicated or iconified frames.
+ ;; Unsplittable frames are taken care of later.
+ (ediff-skip-unsuitable-frames 'ok-unsplittable)
+
+ (let* ((window-min-height 1)
+ (wind-A (ediff-get-visible-buffer-window buf-A))
+ (wind-B (ediff-get-visible-buffer-window buf-B))
+ (wind-C (ediff-get-visible-buffer-window buf-C))
+ (frame-A (if wind-A (window-frame wind-A)))
+ (frame-B (if wind-B (window-frame wind-B)))
+ (frame-C (if wind-C (window-frame wind-C)))
+ (ctl-frame-exists-p (ediff-with-current-buffer control-buf
+ (frame-live-p ediff-control-frame)))
+ ;; on wide display, do things in one frame
+ (force-one-frame
+ (ediff-with-current-buffer control-buf ediff-wide-display-p))
+ ;; this lets us have local versions of ediff-split-window-function
+ (split-window-function
+ (ediff-with-current-buffer control-buf ediff-split-window-function))
+ (three-way-comparison
+ (ediff-with-current-buffer control-buf ediff-3way-comparison-job))
+ (orig-wind (selected-window))
+ (use-same-frame (or force-one-frame
+ (eq frame-A frame-B)
+ (not (ediff-window-ok-for-display wind-A))
+ (not (ediff-window-ok-for-display wind-B))
+ (if three-way-comparison
+ (or (eq frame-A frame-C)
+ (eq frame-B frame-C)
+ (not (ediff-window-ok-for-display wind-C))
+ (not (frame-live-p frame-A))
+ (not (frame-live-p frame-B))
+ (not (frame-live-p frame-C))))
+ (and (not (frame-live-p frame-B))
+ (or ctl-frame-exists-p
+ (eq frame-A (selected-frame))))
+ (and (not (frame-live-p frame-A))
+ (or ctl-frame-exists-p
+ (eq frame-B (selected-frame))))))
+ wind-A-start wind-B-start
+ designated-minibuffer-frame
+ done-A done-B done-C)
+
+ (ediff-with-current-buffer control-buf
+ (setq wind-A-start (ediff-overlay-start
+ (ediff-get-value-according-to-buffer-type
+ 'A ediff-narrow-bounds))
+ wind-B-start (ediff-overlay-start
+ (ediff-get-value-according-to-buffer-type
+ 'B ediff-narrow-bounds))))
+
+ (if (and (window-live-p wind-A) (null use-same-frame)) ; buf-A on its own
+ (progn
+ ;; buffer buf-A is seen in live wind-A
+ (select-window wind-A) ; must be displaying buf-A
+ (delete-other-windows)
+ (setq wind-A (selected-window))
+ (setq done-A t)))
+
+ (if (and (window-live-p wind-B) (null use-same-frame)) ; buf B on its own
+ (progn
+ ;; buffer buf-B is seen in live wind-B
+ (select-window wind-B) ; must be displaying buf-B
+ (delete-other-windows)
+ (setq wind-B (selected-window))
+ (setq done-B t)))
+
+ (if (and (window-live-p wind-C) (null use-same-frame)) ; buf C on its own
+ (progn
+ ;; buffer buf-C is seen in live wind-C
+ (select-window wind-C) ; must be displaying buf-C
+ (delete-other-windows)
+ (setq wind-C (selected-window))
+ (setq done-C t)))
+
+ (if use-same-frame
+ (let (wind-width-or-height) ; this affects 3way setups only
+ (if (and (eq frame-A frame-B) (frame-live-p frame-A))
+ (select-frame frame-A)
+ ;; avoid dedicated and non-splittable windows
+ (ediff-skip-unsuitable-frames))
+ (delete-other-windows)
+ (switch-to-buffer buf-A)
+ (setq wind-A (selected-window))
+
+ (if three-way-comparison
+ (setq wind-width-or-height
+ (/
+ (if (eq split-window-function 'split-window-vertically)
+ (window-height wind-A)
+ (window-width wind-A))
+ 3)))
+
+ (funcall split-window-function wind-width-or-height)
+ (if (eq (selected-window) wind-A)
+ (other-window 1))
+ (switch-to-buffer buf-B)
+ (setq wind-B (selected-window))
+
+ (if three-way-comparison
+ (progn
+ (funcall split-window-function) ; equally
+ (if (memq (selected-window) (list wind-A wind-B))
+ (other-window 1))
+ (switch-to-buffer buf-C)
+ (setq wind-C (selected-window))))
+ (setq done-A t
+ done-B t
+ done-C t)
+ ))
+
+ (or done-A ; Buf A to be set in its own frame
+ ;;; or it was set before because use-same-frame = 1
+ (progn
+ ;; Buf-A was not set up yet as it wasn't visible,
+ ;; and use-same-frame = nil
+ (select-window orig-wind)
+ (delete-other-windows)
+ (switch-to-buffer buf-A)
+ (setq wind-A (selected-window))
+ ))
+ (or done-B ; Buf B to be set in its own frame
+ ;;; or it was set before because use-same-frame = 1
+ (progn
+ ;; Buf-B was not set up yet as it wasn't visible,
+ ;; and use-same-frame = nil
+ (select-window orig-wind)
+ (delete-other-windows)
+ (switch-to-buffer buf-B)
+ (setq wind-B (selected-window))
+ ))
+
+ (if three-way-comparison
+ (or done-C ; Buf C to be set in its own frame
+ ;;; or it was set before because use-same-frame = 1
+ (progn
+ ;; Buf-C was not set up yet as it wasn't visible,
+ ;; and use-same-frame = nil
+ (select-window orig-wind)
+ (delete-other-windows)
+ (switch-to-buffer buf-C)
+ (setq wind-C (selected-window))
+ )))
+
+ (ediff-with-current-buffer control-buf
+ (setq ediff-window-A wind-A
+ ediff-window-B wind-B
+ ediff-window-C wind-C)
+
+ (setq frame-A (window-frame ediff-window-A)
+ designated-minibuffer-frame
+ (window-frame (minibuffer-window frame-A))))
+
+ ;; It is unlikely that we'll implement a version of ediff-windows that
+ ;; would compare 3 windows at once. So, we don't use buffer C here.
+ (if ediff-windows-job
+ (progn
+ (set-window-start wind-A wind-A-start)
+ (set-window-start wind-B wind-B-start)))
+
+ (ediff-setup-control-frame control-buf designated-minibuffer-frame)
+ ))
+
+;; skip unsplittable frames and frames that have dedicated windows.
+;; create a new splittable frame if none is found
+(defun ediff-skip-unsuitable-frames (&optional ok-unsplittable)
+ (if (ediff-window-display-p)
+ (let ((wind-frame (window-frame (selected-window)))
+ seen-windows)
+ (while (and (not (memq (selected-window) seen-windows))
+ (or
+ (ediff-frame-has-dedicated-windows wind-frame)
+ (ediff-frame-iconified-p wind-frame)
+ ;; skip small windows
+ (< (frame-height wind-frame)
+ (* 3 window-min-height))
+ (if ok-unsplittable
+ nil
+ (ediff-frame-unsplittable-p wind-frame))))
+ ;; remember history
+ (setq seen-windows (cons (selected-window) seen-windows))
+ ;; try new window
+ (other-window 1 t)
+ (setq wind-frame (window-frame (selected-window)))
+ )
+ (if (memq (selected-window) seen-windows)
+ ;; fed up, no appropriate frames
+ (setq wind-frame (make-frame '((unsplittable)))))
+
+ (select-frame wind-frame)
+ )))
+
+(defun ediff-frame-has-dedicated-windows (frame)
+ (let (ans)
+ (walk-windows
+ (lambda (wind) (if (window-dedicated-p wind)
+ (setq ans t)))
+ 'ignore-minibuffer
+ frame)
+ ans))
+
+;; window is ok, if it is only one window on the frame, not counting the
+;; minibuffer, or none of the frame's windows is dedicated.
+;; The idea is that it is bad to destroy dedicated windows while creating an
+;; ediff window setup
+(defun ediff-window-ok-for-display (wind)
+ (and
+ (window-live-p wind)
+ (or
+ ;; only one window
+ (eq wind (next-window wind 'ignore-minibuffer (window-frame wind)))
+ ;; none is dedicated (in multiframe setup)
+ (not (ediff-frame-has-dedicated-windows (window-frame wind)))
+ )))
+
+;; Prepare or refresh control frame
+(defun ediff-setup-control-frame (ctl-buffer designated-minibuffer-frame)
+ (let ((window-min-height 1)
+ ctl-frame-iconified-p dont-iconify-ctl-frame deiconify-ctl-frame
+ ctl-frame old-ctl-frame lines
+ ;; user-grabbed-mouse
+ fheight fwidth adjusted-parameters)
+
+ (ediff-with-current-buffer ctl-buffer
+ (if (and (featurep 'xemacs) (featurep 'menubar))
+ (set-buffer-menubar nil))
+ ;;(setq user-grabbed-mouse (ediff-user-grabbed-mouse))
+ (run-hooks 'ediff-before-setup-control-frame-hook))
+
+ (setq old-ctl-frame (ediff-with-current-buffer ctl-buffer ediff-control-frame))
+ (ediff-with-current-buffer ctl-buffer
+ (setq ctl-frame (if (frame-live-p old-ctl-frame)
+ old-ctl-frame
+ (make-frame ediff-control-frame-parameters))
+ ediff-control-frame ctl-frame)
+ ;; protect against undefined face-attribute
+ (condition-case nil
+ (if (and (featurep 'emacs) (face-attribute 'mode-line :box))
+ (set-face-attribute 'mode-line ctl-frame :box nil))
+ (error)))
+
+ (setq ctl-frame-iconified-p (ediff-frame-iconified-p ctl-frame))
+ (select-frame ctl-frame)
+ (if (window-dedicated-p (selected-window))
+ ()
+ (delete-other-windows)
+ (switch-to-buffer ctl-buffer))
+
+ ;; must be before ediff-setup-control-buffer
+ ;; just a precaution--we should be in ctl-buffer already
+ (ediff-with-current-buffer ctl-buffer
+ (make-local-variable 'frame-title-format)
+ (make-local-variable 'frame-icon-title-format) ; XEmacs
+ (make-local-variable 'icon-title-format)) ; Emacs
+
+ (ediff-setup-control-buffer ctl-buffer)
+ (setq dont-iconify-ctl-frame
+ (not (string= ediff-help-message ediff-brief-help-message)))
+ (setq deiconify-ctl-frame
+ (and (eq this-command 'ediff-toggle-help)
+ dont-iconify-ctl-frame))
+
+ ;; 1 more line for the modeline
+ (setq lines (1+ (count-lines (point-min) (point-max)))
+ fheight lines
+ fwidth (max (+ (ediff-help-message-line-length) 2)
+ (ediff-compute-toolbar-width))
+ adjusted-parameters
+ (list
+ ;; possibly change surrogate minibuffer
+ (cons 'minibuffer
+ (minibuffer-window
+ designated-minibuffer-frame))
+ (cons 'width fwidth)
+ (cons 'height fheight)
+ (cons 'user-position t)
+ ))
+
+ ;; adjust autoraise
+ (setq adjusted-parameters
+ (cons (if ediff-use-long-help-message
+ '(auto-raise . nil)
+ '(auto-raise . t))
+ adjusted-parameters))
+
+ ;; In XEmacs, buffer menubar needs to be killed before frame parameters
+ ;; are changed.
+ (if (ediff-has-toolbar-support-p)
+ (when (featurep 'xemacs)
+ (if (ediff-has-gutter-support-p)
+ (set-specifier top-gutter (list ctl-frame nil)))
+ (sit-for 0)
+ (set-specifier top-toolbar-height (list ctl-frame 0))
+ ;;(set-specifier bottom-toolbar-height (list ctl-frame 0))
+ (set-specifier left-toolbar-width (list ctl-frame 0))
+ (set-specifier right-toolbar-width (list ctl-frame 0))))
+
+ ;; As a precaution, we call modify frame parameters twice, in
+ ;; order to make sure that at least once we do it for
+ ;; a non-iconified frame. (It appears that in the Windows port of
+ ;; Emacs, one can't modify frame parameters of iconified frames.)
+ (if (eq system-type 'windows-nt)
+ (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:
+
+;;; ediff-wind.el ends here
--- /dev/null
- ;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;;; 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, 2011 Free Software Foundation, Inc.
+
+;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Created: February 2, 1994
+;; Keywords: comparing, merging, patching, vc, tools, unix
+;; Version: 2.81.4
+
+;; Yoni Rabkin <yoni@rabkins.net> contacted the maintainer of this
+;; file on 20/3/2008, and the maintainer agreed that when a bug is
+;; filed in the Emacs bug reporting system against this file, a copy
+;; of the bug report be sent to the maintainer's email address.
+
+(defconst ediff-version "2.81.4" "The current version of Ediff")
+(defconst ediff-date "December 7, 2009" "Date of last update")
+
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Never read that diff output again!
+;; Apply patch interactively!
+;; Merge with ease!
+
+;; This package provides a convenient way of simultaneous browsing through
+;; the differences between a pair (or a triple) of files or buffers. The
+;; files being compared, file-A, file-B, and file-C (if applicable) are
+;; shown in separate windows (side by side, one above the another, or in
+;; separate frames), and the differences are highlighted as you step
+;; through them. You can also copy difference regions from one buffer to
+;; another (and recover old differences if you change your mind).
+
+;; Ediff also supports merging operations on files and buffers, including
+;; merging using ancestor versions. Both comparison and merging operations can
+;; be performed on directories, i.e., by pairwise comparison of files in those
+;; directories.
+
+;; In addition, Ediff can apply a patch to a file and then let you step
+;; though both files, the patched and the original one, simultaneously,
+;; difference-by-difference. You can even apply a patch right out of a
+;; mail buffer, i.e., patches received by mail don't even have to be saved.
+;; Since Ediff lets you copy differences between buffers, you can, in
+;; effect, apply patches selectively (i.e., you can copy a difference
+;; region from file_orig to file, thereby undoing any particular patch that
+;; you don't like).
+
+;; Ediff is aware of version control, which lets the user compare
+;; files with their older versions. Ediff can also work with remote and
+;; compressed files. Details are given below.
+
+;; Finally, Ediff supports directory-level comparison, merging and patching.
+;; See the on-line manual for details.
+
+;; This package builds upon the ideas borrowed from emerge.el and several
+;; Ediff's functions are adaptations from emerge.el. Much of the functionality
+;; Ediff provides is also influenced by emerge.el.
+
+;; The present version of Ediff supersedes Emerge. It provides a superior user
+;; interface and has numerous major features not found in Emerge. In
+;; particular, it can do patching, and 2-way and 3-way file comparison,
+;; merging, and directory operations.
+
+
+
+;;; Bugs:
+
+;; 1. The undo command doesn't restore deleted regions well. That is, if
+;; you delete all characters in a difference region and then invoke
+;; `undo', the reinstated text will most likely be inserted outside of
+;; what Ediff thinks is the current difference region. (This problem
+;; doesn't seem to exist with XEmacs.)
+;;
+;; If at any point you feel that difference regions are no longer correct,
+;; you can hit '!' to recompute the differences.
+
+;; 2. On a monochrome display, the repertoire of faces with which to
+;; highlight fine differences is limited. By default, Ediff is using
+;; underlining. However, if the region is already underlined by some other
+;; overlays, there is no simple way to temporarily remove that residual
+;; underlining. This problem occurs when a buffer is highlighted with
+;; hilit19.el or font-lock.el packages. If this residual highlighting gets
+;; in the way, you can do the following. Both font-lock.el and hilit19.el
+;; provide commands for unhighlighting buffers. You can either place these
+;; commands in `ediff-prepare-buffer-hook' (which will unhighlight every
+;; buffer used by Ediff) or you can execute them interactively, at any time
+;; and on any buffer.
+
+
+;;; Acknowledgements:
+
+;; Ediff was inspired by Dale R. Worley's <drw@math.mit.edu> emerge.el.
+;; Ediff would not have been possible without the help and encouragement of
+;; its many users. See Ediff on-line Info for the full list of those who
+;; helped. Improved defaults in Ediff file-name reading commands.
+
+;;; Code:
+
+(provide 'ediff)
+
+;; Compiler pacifier
+(eval-and-compile
+ (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
+
+
+(eval-when-compile
+ (require 'dired)
+ (require 'ediff-util)
+ (require 'ediff-ptch))
+;; end pacifier
+
+(require 'ediff-init)
+(require 'ediff-mult) ; required because of the registry stuff
+
+(defgroup ediff nil
+ "A comprehensive visual interface to diff & patch."
+ :tag "Ediff"
+ :group 'tools)
+
+
+(defcustom ediff-use-last-dir nil
+ "If t, Ediff will use previous directory as default when reading file name."
+ :type 'boolean
+ :group 'ediff)
+
+;; Last directory used by an Ediff command for file-A.
+(defvar ediff-last-dir-A nil)
+;; Last directory used by an Ediff command for file-B.
+(defvar ediff-last-dir-B nil)
+;; Last directory used by an Ediff command for file-C.
+(defvar ediff-last-dir-C nil)
+;; Last directory used by an Ediff command for the ancestor file.
+(defvar ediff-last-dir-ancestor nil)
+;; Last directory used by an Ediff command as the output directory for merge.
+(defvar ediff-last-merge-autostore-dir nil)
+
+
+;; Used as a startup hook to set `_orig' patch file read-only.
+(defun ediff-set-read-only-in-buf-A ()
+ (ediff-with-current-buffer ediff-buffer-A
+ (toggle-read-only 1)))
+
+;; Return a plausible default for ediff's first file:
+;; In dired, return the file number FILENO (or 0) in the list
+;; (all-selected-files, filename under the cursor), where directories are
+;; ignored. Otherwise, return DEFAULT file name, if non-nil. Else,
+;; if the buffer is visiting a file, return that file name.
+(defun ediff-get-default-file-name (&optional default fileno)
+ (cond ((eq major-mode 'dired-mode)
+ (let ((current (dired-get-filename nil 'no-error))
+ (marked (condition-case nil
+ (dired-get-marked-files 'no-dir)
+ (error nil)))
+ aux-list choices result)
+ (or (integerp fileno) (setq fileno 0))
+ (if (stringp default)
+ (setq aux-list (cons default aux-list)))
+ (if (and (stringp current) (not (file-directory-p current)))
+ (setq aux-list (cons current aux-list)))
+ (setq choices (nconc marked aux-list))
+ (setq result (elt choices fileno))
+ (or result
+ default)))
+ ((stringp default) default)
+ ((buffer-file-name (current-buffer))
+ (file-name-nondirectory (buffer-file-name (current-buffer))))
+ ))
+
+;;; Compare files/buffers
+
+;;;###autoload
+(defun ediff-files (file-A file-B &optional startup-hooks)
+ "Run Ediff on a pair of files, FILE-A and FILE-B."
+ (interactive
+ (let ((dir-A (if ediff-use-last-dir
+ ediff-last-dir-A
+ default-directory))
+ dir-B f)
+ (list (setq f (ediff-read-file-name
+ "File A to compare"
+ dir-A
+ (ediff-get-default-file-name)
+ 'no-dirs))
+ (ediff-read-file-name "File B to compare"
+ (setq dir-B
+ (if ediff-use-last-dir
+ ediff-last-dir-B
+ (file-name-directory f)))
+ (progn
+ (ediff-add-to-history
+ 'file-name-history
+ (ediff-abbreviate-file-name
+ (expand-file-name
+ (file-name-nondirectory f)
+ dir-B)))
+ (ediff-get-default-file-name f 1)))
+ )))
+ (ediff-files-internal file-A
+ (if (file-directory-p file-B)
+ (expand-file-name
+ (file-name-nondirectory file-A) file-B)
+ file-B)
+ nil ; file-C
+ startup-hooks
+ 'ediff-files))
+
+;;;###autoload
+(defun ediff-files3 (file-A file-B file-C &optional startup-hooks)
+ "Run Ediff on three files, FILE-A, FILE-B, and FILE-C."
+ (interactive
+ (let ((dir-A (if ediff-use-last-dir
+ ediff-last-dir-A
+ default-directory))
+ dir-B dir-C f ff)
+ (list (setq f (ediff-read-file-name
+ "File A to compare"
+ dir-A
+ (ediff-get-default-file-name)
+ 'no-dirs))
+ (setq ff (ediff-read-file-name "File B to compare"
+ (setq dir-B
+ (if ediff-use-last-dir
+ ediff-last-dir-B
+ (file-name-directory f)))
+ (progn
+ (ediff-add-to-history
+ 'file-name-history
+ (ediff-abbreviate-file-name
+ (expand-file-name
+ (file-name-nondirectory f)
+ dir-B)))
+ (ediff-get-default-file-name f 1))))
+ (ediff-read-file-name "File C to compare"
+ (setq dir-C (if ediff-use-last-dir
+ ediff-last-dir-C
+ (file-name-directory ff)))
+ (progn
+ (ediff-add-to-history
+ 'file-name-history
+ (ediff-abbreviate-file-name
+ (expand-file-name
+ (file-name-nondirectory ff)
+ dir-C)))
+ (ediff-get-default-file-name ff 2)))
+ )))
+ (ediff-files-internal file-A
+ (if (file-directory-p file-B)
+ (expand-file-name
+ (file-name-nondirectory file-A) file-B)
+ file-B)
+ (if (file-directory-p file-C)
+ (expand-file-name
+ (file-name-nondirectory file-A) file-C)
+ file-C)
+ startup-hooks
+ 'ediff-files3))
+
+;;;###autoload
+(defalias 'ediff3 'ediff-files3)
+
+
+(defun ediff-find-file (file-var buffer-name &optional last-dir hooks-var)
+ "Visit FILE and arrange its buffer to Ediff's liking.
+FILE-VAR is actually a variable symbol whose value must contain a true
+file name.
+BUFFER-NAME is a variable symbol, which will get the buffer object into
+which FILE is read.
+LAST-DIR is the directory variable symbol where FILE's
+directory name should be returned. HOOKS-VAR is a variable symbol that will
+be assigned the hook to be executed after `ediff-startup' is finished.
+`ediff-find-file' arranges that the temp files it might create will be
+deleted."
+ (let* ((file (symbol-value file-var))
+ (file-magic (ediff-filename-magic-p file))
+ (temp-file-name-prefix (file-name-nondirectory file)))
+ (cond ((not (file-readable-p file))
+ (error "File `%s' does not exist or is not readable" file))
+ ((file-directory-p file)
+ (error "File `%s' is a directory" file)))
+
+ ;; some of the commands, below, require full file name
+ (setq file (expand-file-name file))
+
+ ;; Record the directory of the file
+ (if last-dir
+ (set last-dir (expand-file-name (file-name-directory file))))
+
+ ;; Setup the buffer
+ (set buffer-name (find-file-noselect file))
+
+ (ediff-with-current-buffer (symbol-value buffer-name)
+ (widen) ; Make sure the entire file is seen
+ (cond (file-magic ; file has a handler, such as jka-compr-handler or
+ ;;; ange-ftp-hook-function--arrange for temp file
+ (ediff-verify-file-buffer 'magic)
+ (setq file
+ (ediff-make-temp-file
+ (current-buffer) temp-file-name-prefix))
+ (set hooks-var (cons `(lambda () (delete-file ,file))
+ (symbol-value hooks-var))))
+ ;; file processed via auto-mode-alist, a la uncompress.el
+ ((not (equal (file-truename file)
+ (file-truename (buffer-file-name))))
+ (setq file
+ (ediff-make-temp-file
+ (current-buffer) temp-file-name-prefix))
+ (set hooks-var (cons `(lambda () (delete-file ,file))
+ (symbol-value hooks-var))))
+ (t ;; plain file---just check that the file matches the buffer
+ (ediff-verify-file-buffer))))
+ (set file-var file)))
+
+;; MERGE-BUFFER-FILE is the file to be associated with the merge buffer
+(defun ediff-files-internal (file-A file-B file-C startup-hooks job-name
+ &optional merge-buffer-file)
+ (let (buf-A buf-B buf-C)
+ (if (string= file-A file-B)
+ (error "Files A and B are the same"))
+ (if (stringp file-C)
+ (or (and (string= file-A file-C) (error "Files A and C are the same"))
+ (and (string= file-B file-C) (error "Files B and C are the same"))))
+ (message "Reading file %s ... " file-A)
+ ;;(sit-for 0)
+ (ediff-find-file 'file-A 'buf-A 'ediff-last-dir-A 'startup-hooks)
+ (message "Reading file %s ... " file-B)
+ ;;(sit-for 0)
+ (ediff-find-file 'file-B 'buf-B 'ediff-last-dir-B 'startup-hooks)
+ (if (stringp file-C)
+ (progn
+ (message "Reading file %s ... " file-C)
+ ;;(sit-for 0)
+ (ediff-find-file
+ 'file-C 'buf-C
+ (if (eq job-name 'ediff-merge-files-with-ancestor)
+ 'ediff-last-dir-ancestor 'ediff-last-dir-C)
+ 'startup-hooks)))
+ (ediff-setup buf-A file-A
+ buf-B file-B
+ buf-C file-C
+ startup-hooks
+ (list (cons 'ediff-job-name job-name))
+ merge-buffer-file)))
+
+(declare-function diff-latest-backup-file "diff" (fn))
+
+;;;###autoload
+(defalias 'ediff 'ediff-files)
+
+;;;###autoload
+(defun ediff-current-file ()
+ "Start ediff between current buffer and its file on disk.
+This command can be used instead of `revert-buffer'. If there is
+nothing to revert then this command fails."
+ (interactive)
+ (unless (or revert-buffer-function
+ revert-buffer-insert-file-contents-function
+ (and buffer-file-number
+ (or (buffer-modified-p)
+ (not (verify-visited-file-modtime
+ (current-buffer))))))
+ (error "Nothing to revert"))
+ (let* ((auto-save-p (and (recent-auto-save-p)
+ buffer-auto-save-file-name
+ (file-readable-p buffer-auto-save-file-name)
+ (y-or-n-p
+ "Buffer has been auto-saved recently. Compare with auto-save file? ")))
+ (file-name (if auto-save-p
+ buffer-auto-save-file-name
+ buffer-file-name))
+ (revert-buf-name (concat "FILE=" file-name))
+ (revert-buf (get-buffer revert-buf-name))
+ (current-major major-mode))
+ (unless file-name
+ (error "Buffer does not seem to be associated with any file"))
+ (when revert-buf
+ (kill-buffer revert-buf)
+ (setq revert-buf nil))
+ (setq revert-buf (get-buffer-create revert-buf-name))
+ (with-current-buffer revert-buf
+ (insert-file-contents file-name)
+ ;; Assume same modes:
+ (funcall current-major))
+ (ediff-buffers revert-buf (current-buffer))))
+
+
+;;;###autoload
+(defun ediff-backup (file)
+ "Run Ediff on FILE and its backup file.
+Uses the latest backup, if there are several numerical backups.
+If this file is a backup, `ediff' it with its original."
+ (interactive (list (read-file-name "Ediff (file with backup): ")))
+ ;; The code is taken from `diff-backup'.
+ (require 'diff)
+ (let (bak ori)
+ (if (backup-file-name-p file)
+ (setq bak file
+ ori (file-name-sans-versions file))
+ (setq bak (or (diff-latest-backup-file file)
+ (error "No backup found for %s" file))
+ ori file))
+ (ediff-files bak ori)))
+
+;;;###autoload
+(defun ediff-buffers (buffer-A buffer-B &optional startup-hooks job-name)
+ "Run Ediff on a pair of buffers, BUFFER-A and BUFFER-B."
+ (interactive
+ (let (bf)
+ (list (setq bf (read-buffer "Buffer A to compare: "
+ (ediff-other-buffer "") t))
+ (read-buffer "Buffer B to compare: "
+ (progn
+ ;; realign buffers so that two visible bufs will be
+ ;; at the top
+ (save-window-excursion (other-window 1))
+ (ediff-other-buffer bf))
+ t))))
+ (or job-name (setq job-name 'ediff-buffers))
+ (ediff-buffers-internal buffer-A buffer-B nil startup-hooks job-name))
+
+;;;###autoload
+(defalias 'ebuffers 'ediff-buffers)
+
+
+;;;###autoload
+(defun ediff-buffers3 (buffer-A buffer-B buffer-C
+ &optional startup-hooks job-name)
+ "Run Ediff on three buffers, BUFFER-A, BUFFER-B, and BUFFER-C."
+ (interactive
+ (let (bf bff)
+ (list (setq bf (read-buffer "Buffer A to compare: "
+ (ediff-other-buffer "") t))
+ (setq bff (read-buffer "Buffer B to compare: "
+ (progn
+ ;; realign buffers so that two visible
+ ;; bufs will be at the top
+ (save-window-excursion (other-window 1))
+ (ediff-other-buffer bf))
+ t))
+ (read-buffer "Buffer C to compare: "
+ (progn
+ ;; realign buffers so that three visible
+ ;; bufs will be at the top
+ (save-window-excursion (other-window 1))
+ (ediff-other-buffer (list bf bff)))
+ t)
+ )))
+ (or job-name (setq job-name 'ediff-buffers3))
+ (ediff-buffers-internal buffer-A buffer-B buffer-C startup-hooks job-name))
+
+;;;###autoload
+(defalias 'ebuffers3 'ediff-buffers3)
+
+
+
+;; MERGE-BUFFER-FILE is the file to be associated with the merge buffer
+(defun ediff-buffers-internal (buf-A buf-B buf-C startup-hooks job-name
+ &optional merge-buffer-file)
+ (let* ((buf-A-file-name (buffer-file-name (get-buffer buf-A)))
+ (buf-B-file-name (buffer-file-name (get-buffer buf-B)))
+ (buf-C-is-alive (ediff-buffer-live-p buf-C))
+ (buf-C-file-name (if buf-C-is-alive
+ (buffer-file-name (get-buffer buf-B))))
+ file-A file-B file-C)
+ (unwind-protect
+ (progn
+ (if (not (ediff-buffer-live-p buf-A))
+ (error "Buffer %S doesn't exist" buf-A))
+ (if (not (ediff-buffer-live-p buf-B))
+ (error "Buffer %S doesn't exist" buf-B))
+ (let ((ediff-job-name job-name))
+ (if (and ediff-3way-comparison-job
+ (not buf-C-is-alive))
+ (error "Buffer %S doesn't exist" buf-C)))
+ (if (stringp buf-A-file-name)
+ (setq buf-A-file-name (file-name-nondirectory buf-A-file-name)))
+ (if (stringp buf-B-file-name)
+ (setq buf-B-file-name (file-name-nondirectory buf-B-file-name)))
+ (if (stringp buf-C-file-name)
+ (setq buf-C-file-name (file-name-nondirectory buf-C-file-name)))
+
+ (setq file-A (ediff-make-temp-file buf-A buf-A-file-name)
+ file-B (ediff-make-temp-file buf-B buf-B-file-name))
+ (if buf-C-is-alive
+ (setq file-C (ediff-make-temp-file buf-C buf-C-file-name)))
+
+ (ediff-setup (get-buffer buf-A) file-A
+ (get-buffer buf-B) file-B
+ (if buf-C-is-alive (get-buffer buf-C))
+ file-C
+ (cons `(lambda ()
+ (delete-file ,file-A)
+ (delete-file ,file-B)
+ (if (stringp ,file-C) (delete-file ,file-C)))
+ startup-hooks)
+ (list (cons 'ediff-job-name job-name))
+ merge-buffer-file))
+ (if (and (stringp file-A) (file-exists-p file-A))
+ (delete-file file-A))
+ (if (and (stringp file-B) (file-exists-p file-B))
+ (delete-file file-B))
+ (if (and (stringp file-C) (file-exists-p file-C))
+ (delete-file file-C)))))
+
+
+;;; Directory and file group operations
+
+;; Get appropriate default name for directory:
+;; If ediff-use-last-dir, use ediff-last-dir-A.
+;; In dired mode, use the directory that is under the point (if any);
+;; otherwise, use default-directory
+(defun ediff-get-default-directory-name ()
+ (cond (ediff-use-last-dir ediff-last-dir-A)
+ ((eq major-mode 'dired-mode)
+ (let ((f (dired-get-filename nil 'noerror)))
+ (if (and (stringp f) (file-directory-p f))
+ f
+ default-directory)))
+ (t default-directory)))
+
+
+;;;###autoload
+(defun ediff-directories (dir1 dir2 regexp)
+ "Run Ediff on a pair of directories, DIR1 and DIR2, comparing files that have
+the same name in both. The third argument, REGEXP, is nil or a regular
+expression; only file names that match the regexp are considered."
+ (interactive
+ (let ((dir-A (ediff-get-default-directory-name))
+ (default-regexp (eval ediff-default-filtering-regexp))
+ f)
+ (list (setq f (read-directory-name
+ "Directory A to compare:" dir-A nil 'must-match))
+ (read-directory-name "Directory B to compare:"
+ (if ediff-use-last-dir
+ ediff-last-dir-B
+ (ediff-strip-last-dir f))
+ nil 'must-match)
+ (read-string
+ (if (stringp default-regexp)
+ (format "Filter through regular expression (default %s): "
+ default-regexp)
+ "Filter through regular expression: ")
+ nil
+ 'ediff-filtering-regexp-history
+ (eval ediff-default-filtering-regexp))
+ )))
+ (ediff-directories-internal
+ dir1 dir2 nil regexp 'ediff-files 'ediff-directories
+ ))
+
+;;;###autoload
+(defalias 'edirs 'ediff-directories)
+
+
+;;;###autoload
+(defun ediff-directory-revisions (dir1 regexp)
+ "Run Ediff on a directory, DIR1, comparing its files with their revisions.
+The second argument, REGEXP, is a regular expression that filters the file
+names. Only the files that are under revision control are taken into account."
+ (interactive
+ (let ((dir-A (ediff-get-default-directory-name))
+ (default-regexp (eval ediff-default-filtering-regexp))
+ )
+ (list (read-directory-name
+ "Directory to compare with revision:" dir-A nil 'must-match)
+ (read-string
+ (if (stringp default-regexp)
+ (format "Filter through regular expression (default %s): "
+ default-regexp)
+ "Filter through regular expression: ")
+ nil
+ 'ediff-filtering-regexp-history
+ (eval ediff-default-filtering-regexp))
+ )))
+ (ediff-directory-revisions-internal
+ dir1 regexp 'ediff-revision 'ediff-directory-revisions
+ ))
+
+;;;###autoload
+(defalias 'edir-revisions 'ediff-directory-revisions)
+
+
+;;;###autoload
+(defun ediff-directories3 (dir1 dir2 dir3 regexp)
+ "Run Ediff on three directories, DIR1, DIR2, and DIR3, comparing files that
+have the same name in all three. The last argument, REGEXP, is nil or a
+regular expression; only file names that match the regexp are considered."
+
+ (interactive
+ (let ((dir-A (ediff-get-default-directory-name))
+ (default-regexp (eval ediff-default-filtering-regexp))
+ f)
+ (list (setq f (read-directory-name "Directory A to compare:" dir-A nil))
+ (setq f (read-directory-name "Directory B to compare:"
+ (if ediff-use-last-dir
+ ediff-last-dir-B
+ (ediff-strip-last-dir f))
+ nil 'must-match))
+ (read-directory-name "Directory C to compare:"
+ (if ediff-use-last-dir
+ ediff-last-dir-C
+ (ediff-strip-last-dir f))
+ nil 'must-match)
+ (read-string
+ (if (stringp default-regexp)
+ (format "Filter through regular expression (default %s): "
+ default-regexp)
+ "Filter through regular expression: ")
+ nil
+ 'ediff-filtering-regexp-history
+ (eval ediff-default-filtering-regexp))
+ )))
+ (ediff-directories-internal
+ dir1 dir2 dir3 regexp 'ediff-files3 'ediff-directories3
+ ))
+
+;;;###autoload
+(defalias 'edirs3 'ediff-directories3)
+
+;;;###autoload
+(defun ediff-merge-directories (dir1 dir2 regexp &optional merge-autostore-dir)
+ "Run Ediff on a pair of directories, DIR1 and DIR2, merging files that have
+the same name in both. The third argument, REGEXP, is nil or a regular
+expression; only file names that match the regexp are considered."
+ (interactive
+ (let ((dir-A (ediff-get-default-directory-name))
+ (default-regexp (eval ediff-default-filtering-regexp))
+ f)
+ (list (setq f (read-directory-name "Directory A to merge:"
+ dir-A nil 'must-match))
+ (read-directory-name "Directory B to merge:"
+ (if ediff-use-last-dir
+ ediff-last-dir-B
+ (ediff-strip-last-dir f))
+ nil 'must-match)
+ (read-string
+ (if (stringp default-regexp)
+ (format "Filter through regular expression (default %s): "
+ default-regexp)
+ "Filter through regular expression: ")
+ nil
+ 'ediff-filtering-regexp-history
+ (eval ediff-default-filtering-regexp))
+ )))
+ (ediff-directories-internal
+ dir1 dir2 nil regexp 'ediff-merge-files 'ediff-merge-directories
+ nil merge-autostore-dir
+ ))
+
+;;;###autoload
+(defalias 'edirs-merge 'ediff-merge-directories)
+
+;;;###autoload
+(defun ediff-merge-directories-with-ancestor (dir1 dir2 ancestor-dir regexp
+ &optional
+ merge-autostore-dir)
+ "Merge files in directories DIR1 and DIR2 using files in ANCESTOR-DIR as ancestors.
+Ediff merges files that have identical names in DIR1, DIR2. If a pair of files
+in DIR1 and DIR2 doesn't have an ancestor in ANCESTOR-DIR, Ediff will merge
+without ancestor. The fourth argument, REGEXP, is nil or a regular expression;
+only file names that match the regexp are considered."
+ (interactive
+ (let ((dir-A (ediff-get-default-directory-name))
+ (default-regexp (eval ediff-default-filtering-regexp))
+ f)
+ (list (setq f (read-directory-name "Directory A to merge:" dir-A nil))
+ (setq f (read-directory-name "Directory B to merge:"
+ (if ediff-use-last-dir
+ ediff-last-dir-B
+ (ediff-strip-last-dir f))
+ nil 'must-match))
+ (read-directory-name "Ancestor directory:"
+ (if ediff-use-last-dir
+ ediff-last-dir-C
+ (ediff-strip-last-dir f))
+ nil 'must-match)
+ (read-string
+ (if (stringp default-regexp)
+ (format "Filter through regular expression (default %s): "
+ default-regexp)
+ "Filter through regular expression: ")
+ nil
+ 'ediff-filtering-regexp-history
+ (eval ediff-default-filtering-regexp))
+ )))
+ (ediff-directories-internal
+ dir1 dir2 ancestor-dir regexp
+ 'ediff-merge-files-with-ancestor 'ediff-merge-directories-with-ancestor
+ nil merge-autostore-dir
+ ))
+
+;;;###autoload
+(defun ediff-merge-directory-revisions (dir1 regexp
+ &optional merge-autostore-dir)
+ "Run Ediff on a directory, DIR1, merging its files with their revisions.
+The second argument, REGEXP, is a regular expression that filters the file
+names. Only the files that are under revision control are taken into account."
+ (interactive
+ (let ((dir-A (ediff-get-default-directory-name))
+ (default-regexp (eval ediff-default-filtering-regexp))
+ )
+ (list (read-directory-name
+ "Directory to merge with revisions:" dir-A nil 'must-match)
+ (read-string
+ (if (stringp default-regexp)
+ (format "Filter through regular expression (default %s): "
+ default-regexp)
+ "Filter through regular expression: ")
+ nil
+ 'ediff-filtering-regexp-history
+ (eval ediff-default-filtering-regexp))
+ )))
+ (ediff-directory-revisions-internal
+ dir1 regexp 'ediff-merge-revisions 'ediff-merge-directory-revisions
+ nil merge-autostore-dir
+ ))
+
+;;;###autoload
+(defalias 'edir-merge-revisions 'ediff-merge-directory-revisions)
+
+;;;###autoload
+(defun ediff-merge-directory-revisions-with-ancestor (dir1 regexp
+ &optional
+ merge-autostore-dir)
+ "Run Ediff on a directory, DIR1, merging its files with their revisions and ancestors.
+The second argument, REGEXP, is a regular expression that filters the file
+names. Only the files that are under revision control are taken into account."
+ (interactive
+ (let ((dir-A (ediff-get-default-directory-name))
+ (default-regexp (eval ediff-default-filtering-regexp))
+ )
+ (list (read-directory-name
+ "Directory to merge with revisions and ancestors:"
+ dir-A nil 'must-match)
+ (read-string
+ (if (stringp default-regexp)
+ (format "Filter through regular expression (default %s): "
+ default-regexp)
+ "Filter through regular expression: ")
+ nil
+ 'ediff-filtering-regexp-history
+ (eval ediff-default-filtering-regexp))
+ )))
+ (ediff-directory-revisions-internal
+ dir1 regexp 'ediff-merge-revisions-with-ancestor
+ 'ediff-merge-directory-revisions-with-ancestor
+ nil merge-autostore-dir
+ ))
+
+;;;###autoload
+(defalias
+ 'edir-merge-revisions-with-ancestor
+ 'ediff-merge-directory-revisions-with-ancestor)
+
+;;;###autoload
+(defalias 'edirs-merge-with-ancestor 'ediff-merge-directories-with-ancestor)
+
+;; Run ediff-action (ediff-files, ediff-merge, ediff-merge-with-ancestors)
+;; on a pair of directories (three directories, in case of ancestor).
+;; The third argument, REGEXP, is nil or a regular expression;
+;; only file names that match the regexp are considered.
+;; JOBNAME is the symbol indicating the meta-job to be performed.
+;; MERGE-AUTOSTORE-DIR is the directory in which to store merged files.
+(defun ediff-directories-internal (dir1 dir2 dir3 regexp action jobname
+ &optional startup-hooks
+ merge-autostore-dir)
+ (if (stringp dir3)
+ (setq dir3 (if (file-directory-p dir3) dir3 (file-name-directory dir3))))
+
+ (cond ((string= dir1 dir2)
+ (error "Directories A and B are the same: %s" dir1))
+ ((and (eq jobname 'ediff-directories3)
+ (string= dir1 dir3))
+ (error "Directories A and C are the same: %s" dir1))
+ ((and (eq jobname 'ediff-directories3)
+ (string= dir2 dir3))
+ (error "Directories B and C are the same: %s" dir1)))
+
+ (if merge-autostore-dir
+ (or (stringp merge-autostore-dir)
+ (error "%s: Directory for storing merged files must be a string"
+ jobname)))
+ (let (;; dir-diff-struct is of the form (common-list diff-list)
+ ;; It is a structure where ediff-intersect-directories returns
+ ;; commonalities and differences among directories
+ dir-diff-struct
+ meta-buf)
+ (if (and ediff-autostore-merges
+ (ediff-merge-metajob jobname)
+ (not merge-autostore-dir))
+ (setq merge-autostore-dir
+ (read-directory-name "Save merged files in directory: "
+ (if ediff-use-last-dir
+ ediff-last-merge-autostore-dir
+ (ediff-strip-last-dir dir1))
+ nil
+ 'must-match)))
+ ;; verify we are not merging into an orig directory
+ (if merge-autostore-dir
+ (cond ((and (stringp dir1) (string= merge-autostore-dir dir1))
+ (or (y-or-n-p
+ "Directory for saving merged files = Directory A. Sure? ")
+ (error "Directory merge aborted")))
+ ((and (stringp dir2) (string= merge-autostore-dir dir2))
+ (or (y-or-n-p
+ "Directory for saving merged files = Directory B. Sure? ")
+ (error "Directory merge aborted")))
+ ((and (stringp dir3) (string= merge-autostore-dir dir3))
+ (or (y-or-n-p
+ "Directory for saving merged files = Ancestor Directory. Sure? ")
+ (error "Directory merge aborted")))))
+
+ (setq dir-diff-struct (ediff-intersect-directories
+ jobname
+ regexp dir1 dir2 dir3 merge-autostore-dir))
+ (setq startup-hooks
+ ;; this sets various vars in the meta buffer inside
+ ;; ediff-prepare-meta-buffer
+ (cons `(lambda ()
+ ;; tell what to do if the user clicks on a session record
+ (setq ediff-session-action-function (quote ,action))
+ ;; set ediff-dir-difference-list
+ (setq ediff-dir-difference-list
+ (cdr (quote ,dir-diff-struct))))
+ startup-hooks))
+ (setq meta-buf (ediff-prepare-meta-buffer
+ 'ediff-filegroup-action
+ (car dir-diff-struct)
+ "*Ediff Session Group Panel"
+ 'ediff-redraw-directory-group-buffer
+ jobname
+ startup-hooks))
+ (ediff-show-meta-buffer meta-buf)
+ ))
+
+;; MERGE-AUTOSTORE-DIR can be given to tell ediff where to store the merged
+;; files
+(defun ediff-directory-revisions-internal (dir1 regexp action jobname
+ &optional startup-hooks
+ merge-autostore-dir)
+ (setq dir1 (if (file-directory-p dir1) dir1 (file-name-directory dir1)))
+
+ (if merge-autostore-dir
+ (or (stringp merge-autostore-dir)
+ (error "%S: Directory for storing merged files must be a string"
+ jobname)))
+ (let (file-list meta-buf)
+ (if (and ediff-autostore-merges
+ (ediff-merge-metajob jobname)
+ (not merge-autostore-dir))
+ (setq merge-autostore-dir
+ (read-directory-name "Save merged files in directory: "
+ (if ediff-use-last-dir
+ ediff-last-merge-autostore-dir
+ (ediff-strip-last-dir dir1))
+ nil
+ 'must-match)))
+ ;; verify merge-autostore-dir != dir1
+ (if (and merge-autostore-dir
+ (stringp dir1)
+ (string= merge-autostore-dir dir1))
+ (or (y-or-n-p
+ "Directory for saving merged file = directory A. Sure? ")
+ (error "Merge of directory revisions aborted")))
+
+ (setq file-list
+ (ediff-get-directory-files-under-revision
+ jobname regexp dir1 merge-autostore-dir))
+ (setq startup-hooks
+ ;; this sets various vars in the meta buffer inside
+ ;; ediff-prepare-meta-buffer
+ (cons `(lambda ()
+ ;; tell what to do if the user clicks on a session record
+ (setq ediff-session-action-function (quote ,action)))
+ startup-hooks))
+ (setq meta-buf (ediff-prepare-meta-buffer
+ 'ediff-filegroup-action
+ file-list
+ "*Ediff Session Group Panel"
+ 'ediff-redraw-directory-group-buffer
+ jobname
+ startup-hooks))
+ (ediff-show-meta-buffer meta-buf)
+ ))
+
+
+;;; Compare regions and windows
+
+;;;###autoload
+(defun ediff-windows-wordwise (dumb-mode &optional wind-A wind-B startup-hooks)
+ "Compare WIND-A and WIND-B, which are selected by clicking, wordwise.
+With prefix argument, DUMB-MODE, or on a non-windowing display, works as
+follows:
+If WIND-A is nil, use selected window.
+If WIND-B is nil, use window next to WIND-A."
+ (interactive "P")
+ (ediff-windows dumb-mode wind-A wind-B
+ startup-hooks 'ediff-windows-wordwise 'word-mode))
+
+;;;###autoload
+(defun ediff-windows-linewise (dumb-mode &optional wind-A wind-B startup-hooks)
+ "Compare WIND-A and WIND-B, which are selected by clicking, linewise.
+With prefix argument, DUMB-MODE, or on a non-windowing display, works as
+follows:
+If WIND-A is nil, use selected window.
+If WIND-B is nil, use window next to WIND-A."
+ (interactive "P")
+ (ediff-windows dumb-mode wind-A wind-B
+ startup-hooks 'ediff-windows-linewise nil))
+
+;; Compare WIND-A and WIND-B, which are selected by clicking.
+;; With prefix argument, DUMB-MODE, or on a non-windowing display,
+;; works as follows:
+;; If WIND-A is nil, use selected window.
+;; If WIND-B is nil, use window next to WIND-A.
+(defun ediff-windows (dumb-mode wind-A wind-B startup-hooks job-name word-mode)
+ (if (or dumb-mode (not (ediff-window-display-p)))
+ (setq wind-A (ediff-get-next-window wind-A nil)
+ wind-B (ediff-get-next-window wind-B wind-A))
+ (setq wind-A (ediff-get-window-by-clicking wind-A nil 1)
+ wind-B (ediff-get-window-by-clicking wind-B wind-A 2)))
+
+ (let ((buffer-A (window-buffer wind-A))
+ (buffer-B (window-buffer wind-B))
+ beg-A end-A beg-B end-B)
+
+ (save-excursion
+ (save-window-excursion
+ (sit-for 0) ; sync before using window-start/end -- a precaution
+ (select-window wind-A)
+ (setq beg-A (window-start)
+ end-A (window-end))
+ (select-window wind-B)
+ (setq beg-B (window-start)
+ end-B (window-end))))
+ (setq buffer-A
+ (ediff-clone-buffer-for-window-comparison
+ buffer-A wind-A "-Window.A-")
+ buffer-B
+ (ediff-clone-buffer-for-window-comparison
+ buffer-B wind-B "-Window.B-"))
+ (ediff-regions-internal
+ buffer-A beg-A end-A buffer-B beg-B end-B
+ startup-hooks job-name word-mode nil)))
+
+
+;;;###autoload
+(defun ediff-regions-wordwise (buffer-A buffer-B &optional startup-hooks)
+ "Run Ediff on a pair of regions in specified buffers.
+Regions \(i.e., point and mark\) can be set in advance or marked interactively.
+This function is effective only for relatively small regions, up to 200
+lines. For large regions, use `ediff-regions-linewise'."
+ (interactive
+ (let (bf)
+ (list (setq bf (read-buffer "Region's A buffer: "
+ (ediff-other-buffer "") t))
+ (read-buffer "Region's B buffer: "
+ (progn
+ ;; realign buffers so that two visible bufs will be
+ ;; at the top
+ (save-window-excursion (other-window 1))
+ (ediff-other-buffer bf))
+ t))))
+ (if (not (ediff-buffer-live-p buffer-A))
+ (error "Buffer %S doesn't exist" buffer-A))
+ (if (not (ediff-buffer-live-p buffer-B))
+ (error "Buffer %S doesn't exist" buffer-B))
+
+
+ (let ((buffer-A
+ (ediff-clone-buffer-for-region-comparison buffer-A "-Region.A-"))
+ (buffer-B
+ (ediff-clone-buffer-for-region-comparison buffer-B "-Region.B-"))
+ reg-A-beg reg-A-end reg-B-beg reg-B-end)
+ (with-current-buffer buffer-A
+ (setq reg-A-beg (region-beginning)
+ reg-A-end (region-end))
+ (set-buffer buffer-B)
+ (setq reg-B-beg (region-beginning)
+ reg-B-end (region-end)))
+
+ (ediff-regions-internal
+ (get-buffer buffer-A) reg-A-beg reg-A-end
+ (get-buffer buffer-B) reg-B-beg reg-B-end
+ startup-hooks 'ediff-regions-wordwise 'word-mode nil)))
+
+;;;###autoload
+(defun ediff-regions-linewise (buffer-A buffer-B &optional startup-hooks)
+ "Run Ediff on a pair of regions in specified buffers.
+Regions \(i.e., point and mark\) can be set in advance or marked interactively.
+Each region is enlarged to contain full lines.
+This function is effective for large regions, over 100-200
+lines. For small regions, use `ediff-regions-wordwise'."
+ (interactive
+ (let (bf)
+ (list (setq bf (read-buffer "Region A's buffer: "
+ (ediff-other-buffer "") t))
+ (read-buffer "Region B's buffer: "
+ (progn
+ ;; realign buffers so that two visible bufs will be
+ ;; at the top
+ (save-window-excursion (other-window 1))
+ (ediff-other-buffer bf))
+ t))))
+ (if (not (ediff-buffer-live-p buffer-A))
+ (error "Buffer %S doesn't exist" buffer-A))
+ (if (not (ediff-buffer-live-p buffer-B))
+ (error "Buffer %S doesn't exist" buffer-B))
+
+ (let ((buffer-A
+ (ediff-clone-buffer-for-region-comparison buffer-A "-Region.A-"))
+ (buffer-B
+ (ediff-clone-buffer-for-region-comparison buffer-B "-Region.B-"))
+ reg-A-beg reg-A-end reg-B-beg reg-B-end)
+ (with-current-buffer buffer-A
+ (setq reg-A-beg (region-beginning)
+ reg-A-end (region-end))
+ ;; enlarge the region to hold full lines
+ (goto-char reg-A-beg)
+ (beginning-of-line)
+ (setq reg-A-beg (point))
+ (goto-char reg-A-end)
+ (end-of-line)
+ (or (eobp) (forward-char)) ; include the newline char
+ (setq reg-A-end (point))
+
+ (set-buffer buffer-B)
+ (setq reg-B-beg (region-beginning)
+ reg-B-end (region-end))
+ ;; enlarge the region to hold full lines
+ (goto-char reg-B-beg)
+ (beginning-of-line)
+ (setq reg-B-beg (point))
+ (goto-char reg-B-end)
+ (end-of-line)
+ (or (eobp) (forward-char)) ; include the newline char
+ (setq reg-B-end (point))
+ ) ; save excursion
+
+ (ediff-regions-internal
+ (get-buffer buffer-A) reg-A-beg reg-A-end
+ (get-buffer buffer-B) reg-B-beg reg-B-end
+ startup-hooks 'ediff-regions-linewise nil nil))) ; no word mode
+
+;; compare region beg-A to end-A of buffer-A
+;; to regions beg-B -- end-B in buffer-B.
+(defun ediff-regions-internal (buffer-A beg-A end-A buffer-B beg-B end-B
+ startup-hooks job-name word-mode
+ setup-parameters)
+ (let ((tmp-buffer (get-buffer-create ediff-tmp-buffer))
+ overl-A overl-B
+ file-A file-B)
+ (unwind-protect
+ (progn
+ ;; in case beg/end-A/B aren't markers--make them into markers
+ (ediff-with-current-buffer buffer-A
+ (setq beg-A (move-marker (make-marker) beg-A)
+ end-A (move-marker (make-marker) end-A)))
+ (ediff-with-current-buffer buffer-B
+ (setq beg-B (move-marker (make-marker) beg-B)
+ end-B (move-marker (make-marker) end-B)))
+
+ ;; make file-A
+ (if word-mode
+ (ediff-wordify beg-A end-A buffer-A tmp-buffer)
+ (ediff-copy-to-buffer beg-A end-A buffer-A tmp-buffer))
+ (setq file-A (ediff-make-temp-file tmp-buffer "regA"))
+
+ ;; make file-B
+ (if word-mode
+ (ediff-wordify beg-B end-B buffer-B tmp-buffer)
+ (ediff-copy-to-buffer beg-B end-B buffer-B tmp-buffer))
+ (setq file-B (ediff-make-temp-file tmp-buffer "regB"))
+
+ (setq overl-A (ediff-make-bullet-proof-overlay beg-A end-A buffer-A))
+ (setq overl-B (ediff-make-bullet-proof-overlay beg-B end-B buffer-B))
+ (ediff-setup buffer-A file-A
+ buffer-B file-B
+ nil nil ; buffer & file C
+ (cons `(lambda ()
+ (delete-file ,file-A)
+ (delete-file ,file-B))
+ startup-hooks)
+ (append
+ (list (cons 'ediff-word-mode word-mode)
+ (cons 'ediff-narrow-bounds (list overl-A overl-B))
+ (cons 'ediff-job-name job-name))
+ setup-parameters)))
+ (if (and (stringp file-A) (file-exists-p file-A))
+ (delete-file file-A))
+ (if (and (stringp file-B) (file-exists-p file-B))
+ (delete-file file-B)))
+ ))
+
+
+;;; Merge files and buffers
+
+;;;###autoload
+(defalias 'ediff-merge 'ediff-merge-files)
+
+(defsubst ediff-merge-on-startup ()
+ (ediff-do-merge 0)
+ ;; Can't remember why this is here, but it may cause the automatically merged
+ ;; buffer to be lost. So, keep the buffer modified.
+ ;;(ediff-with-current-buffer ediff-buffer-C
+ ;; (set-buffer-modified-p nil))
+ )
+
+;;;###autoload
+(defun ediff-merge-files (file-A file-B
+ ;; MERGE-BUFFER-FILE is the file to be
+ ;; associated with the merge buffer
+ &optional startup-hooks merge-buffer-file)
+ "Merge two files without ancestor."
+ (interactive
+ (let ((dir-A (if ediff-use-last-dir
+ ediff-last-dir-A
+ default-directory))
+ dir-B f)
+ (list (setq f (ediff-read-file-name
+ "File A to merge"
+ dir-A
+ (ediff-get-default-file-name)
+ 'no-dirs))
+ (ediff-read-file-name "File B to merge"
+ (setq dir-B
+ (if ediff-use-last-dir
+ ediff-last-dir-B
+ (file-name-directory f)))
+ (progn
+ (ediff-add-to-history
+ 'file-name-history
+ (ediff-abbreviate-file-name
+ (expand-file-name
+ (file-name-nondirectory f)
+ dir-B)))
+ (ediff-get-default-file-name f 1)))
+ )))
+ (setq startup-hooks (cons 'ediff-merge-on-startup startup-hooks))
+ (ediff-files-internal file-A
+ (if (file-directory-p file-B)
+ (expand-file-name
+ (file-name-nondirectory file-A) file-B)
+ file-B)
+ nil ; file-C
+ startup-hooks
+ 'ediff-merge-files
+ merge-buffer-file))
+
+;;;###autoload
+(defun ediff-merge-files-with-ancestor (file-A file-B file-ancestor
+ &optional
+ startup-hooks
+ ;; MERGE-BUFFER-FILE is the file
+ ;; to be associated with the
+ ;; merge buffer
+ merge-buffer-file)
+ "Merge two files with ancestor."
+ (interactive
+ (let ((dir-A (if ediff-use-last-dir
+ ediff-last-dir-A
+ default-directory))
+ dir-B dir-ancestor f ff)
+ (list (setq f (ediff-read-file-name
+ "File A to merge"
+ dir-A
+ (ediff-get-default-file-name)
+ 'no-dirs))
+ (setq ff (ediff-read-file-name "File B to merge"
+ (setq dir-B
+ (if ediff-use-last-dir
+ ediff-last-dir-B
+ (file-name-directory f)))
+ (progn
+ (ediff-add-to-history
+ 'file-name-history
+ (ediff-abbreviate-file-name
+ (expand-file-name
+ (file-name-nondirectory f)
+ dir-B)))
+ (ediff-get-default-file-name f 1))))
+ (ediff-read-file-name "Ancestor file"
+ (setq dir-ancestor
+ (if ediff-use-last-dir
+ ediff-last-dir-ancestor
+ (file-name-directory ff)))
+ (progn
+ (ediff-add-to-history
+ 'file-name-history
+ (ediff-abbreviate-file-name
+ (expand-file-name
+ (file-name-nondirectory ff)
+ dir-ancestor)))
+ (ediff-get-default-file-name ff 2)))
+ )))
+ (setq startup-hooks (cons 'ediff-merge-on-startup startup-hooks))
+ (ediff-files-internal file-A
+ (if (file-directory-p file-B)
+ (expand-file-name
+ (file-name-nondirectory file-A) file-B)
+ file-B)
+ file-ancestor
+ startup-hooks
+ 'ediff-merge-files-with-ancestor
+ merge-buffer-file))
+
+;;;###autoload
+(defalias 'ediff-merge-with-ancestor 'ediff-merge-files-with-ancestor)
+
+;;;###autoload
+(defun ediff-merge-buffers (buffer-A buffer-B
+ &optional
+ ;; MERGE-BUFFER-FILE is the file to be
+ ;; associated with the merge buffer
+ startup-hooks job-name merge-buffer-file)
+ "Merge buffers without ancestor."
+ (interactive
+ (let (bf)
+ (list (setq bf (read-buffer "Buffer A to merge: "
+ (ediff-other-buffer "") t))
+ (read-buffer "Buffer B to merge: "
+ (progn
+ ;; realign buffers so that two visible bufs will be
+ ;; at the top
+ (save-window-excursion (other-window 1))
+ (ediff-other-buffer bf))
+ t))))
+
+ (setq startup-hooks (cons 'ediff-merge-on-startup startup-hooks))
+ (or job-name (setq job-name 'ediff-merge-buffers))
+ (ediff-buffers-internal
+ buffer-A buffer-B nil startup-hooks job-name merge-buffer-file))
+
+;;;###autoload
+(defun ediff-merge-buffers-with-ancestor (buffer-A buffer-B buffer-ancestor
+ &optional
+ startup-hooks
+ job-name
+ ;; MERGE-BUFFER-FILE is the
+ ;; file to be associated
+ ;; with the merge buffer
+ merge-buffer-file)
+ "Merge buffers with ancestor."
+ (interactive
+ (let (bf bff)
+ (list (setq bf (read-buffer "Buffer A to merge: "
+ (ediff-other-buffer "") t))
+ (setq bff (read-buffer "Buffer B to merge: "
+ (progn
+ ;; realign buffers so that two visible
+ ;; bufs will be at the top
+ (save-window-excursion (other-window 1))
+ (ediff-other-buffer bf))
+ t))
+ (read-buffer "Ancestor buffer: "
+ (progn
+ ;; realign buffers so that three visible
+ ;; bufs will be at the top
+ (save-window-excursion (other-window 1))
+ (ediff-other-buffer (list bf bff)))
+ t)
+ )))
+
+ (setq startup-hooks (cons 'ediff-merge-on-startup startup-hooks))
+ (or job-name (setq job-name 'ediff-merge-buffers-with-ancestor))
+ (ediff-buffers-internal
+ buffer-A buffer-B buffer-ancestor startup-hooks job-name merge-buffer-file))
+
+
+;;;###autoload
+(defun ediff-merge-revisions (&optional file startup-hooks merge-buffer-file)
+ ;; MERGE-BUFFER-FILE is the file to be associated with the merge buffer
+ "Run Ediff by merging two revisions of a file.
+The file is the optional FILE argument or the file visited by the current
+buffer."
+ (interactive)
+ (if (stringp file) (find-file file))
+ (let (rev1 rev2)
+ (setq rev1
+ (read-string
+ (format
+ "Version 1 to merge (default %s's working version): "
+ (if (stringp file)
+ (file-name-nondirectory file) "current buffer")))
+ rev2
+ (read-string
+ (format
+ "Version 2 to merge (default %s): "
+ (if (stringp file)
+ (file-name-nondirectory file) "current buffer"))))
+ (ediff-load-version-control)
+ ;; ancestor-revision=nil
+ (funcall
+ (intern (format "ediff-%S-merge-internal" ediff-version-control-package))
+ rev1 rev2 nil startup-hooks merge-buffer-file)))
+
+
+;;;###autoload
+(defun ediff-merge-revisions-with-ancestor (&optional
+ file startup-hooks
+ ;; MERGE-BUFFER-FILE is the file to
+ ;; be associated with the merge
+ ;; buffer
+ merge-buffer-file)
+ "Run Ediff by merging two revisions of a file with a common ancestor.
+The file is the optional FILE argument or the file visited by the current
+buffer."
+ (interactive)
+ (if (stringp file) (find-file file))
+ (let (rev1 rev2 ancestor-rev)
+ (setq rev1
+ (read-string
+ (format
+ "Version 1 to merge (default %s's working version): "
+ (if (stringp file)
+ (file-name-nondirectory file) "current buffer")))
+ rev2
+ (read-string
+ (format
+ "Version 2 to merge (default %s): "
+ (if (stringp file)
+ (file-name-nondirectory file) "current buffer")))
+ ancestor-rev
+ (read-string
+ (format
+ "Ancestor version (default %s's base revision): "
+ (if (stringp file)
+ (file-name-nondirectory file) "current buffer"))))
+ (ediff-load-version-control)
+ (funcall
+ (intern (format "ediff-%S-merge-internal" ediff-version-control-package))
+ rev1 rev2 ancestor-rev startup-hooks merge-buffer-file)))
+
+;;; Apply patch
+
+;;;###autoload
+(defun ediff-patch-file (&optional arg patch-buf)
+ "Run Ediff by patching SOURCE-FILENAME.
+If optional PATCH-BUF is given, use the patch in that buffer
+and don't ask the user.
+If prefix argument, then: if even argument, assume that the patch is in a
+buffer. If odd -- assume it is in a file."
+ (interactive "P")
+ (let (source-dir source-file)
+ (require 'ediff-ptch)
+ (setq patch-buf
+ (ediff-get-patch-buffer
+ (if arg (prefix-numeric-value arg)) patch-buf))
+ (setq source-dir (cond (ediff-use-last-dir ediff-last-dir-patch)
+ ((and (not ediff-patch-default-directory)
+ (buffer-file-name patch-buf))
+ (file-name-directory
+ (expand-file-name
+ (buffer-file-name patch-buf))))
+ (t default-directory)))
+ (setq source-file
+ (read-file-name
+ "File to patch (directory, if multifile patch): "
+ ;; use an explicit initial file
+ source-dir nil nil (ediff-get-default-file-name)))
+ (ediff-dispatch-file-patching-job patch-buf source-file)))
+
+;;;###autoload
+(defun ediff-patch-buffer (&optional arg patch-buf)
+ "Run Ediff by patching the buffer specified at prompt.
+Without the optional prefix ARG, asks if the patch is in some buffer and
+prompts for the buffer or a file, depending on the answer.
+With ARG=1, assumes the patch is in a file and prompts for the file.
+With ARG=2, assumes the patch is in a buffer and prompts for the buffer.
+PATCH-BUF is an optional argument, which specifies the buffer that contains the
+patch. If not given, the user is prompted according to the prefix argument."
+ (interactive "P")
+ (require 'ediff-ptch)
+ (setq patch-buf
+ (ediff-get-patch-buffer
+ (if arg (prefix-numeric-value arg)) patch-buf))
+ (ediff-patch-buffer-internal
+ patch-buf
+ (read-buffer
+ "Which buffer to patch? "
+ (ediff-other-buffer patch-buf))))
+
+
+;;;###autoload
+(defalias 'epatch 'ediff-patch-file)
+;;;###autoload
+(defalias 'epatch-buffer 'ediff-patch-buffer)
+
+
+
+\f
+;;; Versions Control functions
+
+;;;###autoload
+(defun ediff-revision (&optional file startup-hooks)
+ "Run Ediff by comparing versions of a file.
+The file is an optional FILE argument or the file entered at the prompt.
+Default: the file visited by the current buffer.
+Uses `vc.el' or `rcs.el' depending on `ediff-version-control-package'."
+ ;; if buffer is non-nil, use that buffer instead of the current buffer
+ (interactive "P")
+ (if (not (stringp file))
+ (setq file
+ (ediff-read-file-name "Compare revisions for file"
+ (if ediff-use-last-dir
+ ediff-last-dir-A
+ default-directory)
+ (ediff-get-default-file-name)
+ 'no-dirs)))
+ (find-file file)
+ (if (and (buffer-modified-p)
+ (y-or-n-p (format "Buffer %s is modified. Save buffer? "
+ (buffer-name))))
+ (save-buffer (current-buffer)))
+ (let (rev1 rev2)
+ (setq rev1
+ (read-string
+ (format "Revision 1 to compare (default %s's latest revision): "
+ (file-name-nondirectory file)))
+ rev2
+ (read-string
+ (format "Revision 2 to compare (default %s's current state): "
+ (file-name-nondirectory file))))
+ (ediff-load-version-control)
+ (funcall
+ (intern (format "ediff-%S-internal" ediff-version-control-package))
+ rev1 rev2 startup-hooks)
+ ))
+
+
+;;;###autoload
+(defalias 'erevision 'ediff-revision)
+
+
+;; Test if version control package is loaded and load if not
+;; Is SILENT is non-nil, don't report error if package is not found.
+(defun ediff-load-version-control (&optional silent)
+ (require 'ediff-vers)
+ (or (featurep ediff-version-control-package)
+ (if (locate-library (symbol-name ediff-version-control-package))
+ (progn
+ (message "") ; kill the message from `locate-library'
+ (require ediff-version-control-package))
+ (or silent
+ (error "Version control package %S.el not found. Use vc.el instead"
+ ediff-version-control-package)))))
+
+
+;;;###autoload
+(defun ediff-version ()
+ "Return string describing the version of Ediff.
+When called interactively, displays the version."
+ (interactive)
+ ;; called-interactively-p - not in XEmacs
+ ;; (if (called-interactively-p 'interactive)
+ (if (interactive-p)
+ (message "%s" (ediff-version))
+ (format "Ediff %s of %s" ediff-version ediff-date)))
+
+;; info is run first, and will autoload info.el.
+(declare-function Info-goto-node "info" (nodename &optional fork))
+
+;;;###autoload
+(defun ediff-documentation (&optional node)
+ "Display Ediff's manual.
+With optional NODE, goes to that node."
+ (interactive)
+ (let ((ctl-window ediff-control-window)
+ (ctl-buf ediff-control-buffer))
+
+ (ediff-skip-unsuitable-frames)
+ (condition-case nil
+ (progn
+ (pop-to-buffer (get-buffer-create "*info*"))
+ (info (if (featurep 'xemacs) "ediff.info" "ediff"))
+ (if node
+ (Info-goto-node node)
+ (message "Type `i' to search for a specific topic"))
+ (raise-frame (selected-frame)))
+ (error (beep 1)
+ (with-output-to-temp-buffer ediff-msg-buffer
+ (ediff-with-current-buffer standard-output
+ (fundamental-mode))
+ (princ ediff-BAD-INFO))
+ (if (window-live-p ctl-window)
+ (progn
+ (select-window ctl-window)
+ (set-window-buffer ctl-window ctl-buf)))))))
+
+
+(dolist (mess '("^Errors in diff output. Diff output is in "
+ "^Hmm... I don't see an Ediff command around here...$"
+ "^Undocumented command! Type `G' in Ediff Control Panel to drop a note to the Ediff maintainer$"
+ ": This command runs in Ediff Control Buffer only!$"
+ ": Invalid op in ediff-check-version$"
+ "^ediff-shrink-window-C can be used only for merging jobs$"
+ "^Lost difference info on these directories$"
+ "^This command is inapplicable in the present context$"
+ "^This session group has no parent$"
+ "^Can't hide active session, $"
+ "^Ediff: something wrong--no multiple diffs buffer$"
+ "^Can't make context diff for Session $"
+ "^The patch buffer wasn't found$"
+ "^Aborted$"
+ "^This Ediff session is not part of a session group$"
+ "^No active Ediff sessions or corrupted session registry$"
+ "^No session info in this line$"
+ "^`.*' is not an ordinary file$"
+ "^Patch appears to have failed$"
+ "^Recomputation of differences cancelled$"
+ "^No fine differences in this mode$"
+ "^Lost connection to ancestor buffer...sorry$"
+ "^Not merging with ancestor$"
+ "^Don't know how to toggle read-only in buffer "
+ "Emacs is not running as a window application$"
+ "^This command makes sense only when merging with an ancestor$"
+ "^At end of the difference list$"
+ "^At beginning of the difference list$"
+ "^Nothing saved for diff .* in buffer "
+ "^Buffer is out of sync for file "
+ "^Buffer out of sync for file "
+ "^Output from `diff' not found$"
+ "^You forgot to specify a region in buffer "
+ "^All right. Make up your mind and come back...$"
+ "^Current buffer is not visiting any file$"
+ "^Failed to retrieve revision: $"
+ "^Can't determine display width.$"
+ "^File `.*' does not exist or is not readable$"
+ "^File `.*' is a directory$"
+ "^Buffer .* doesn't exist$"
+ "^Directories . and . are the same: "
+ "^Directory merge aborted$"
+ "^Merge of directory revisions aborted$"
+ "^Buffer .* doesn't exist$"
+ "^There is no file to merge$"
+ "^Version control package .*.el not found. Use vc.el instead$"))
+ (add-to-list 'debug-ignored-errors mess))
+
+
+(require 'ediff-util)
+
+(run-hooks 'ediff-load-hook)
+
+
+;; Local Variables:
+;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun)
+;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1)
+;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body))
+;; End:
+
+;; arch-tag: 97c71396-db02-4f41-8b48-6a51c3348fcc
+;;; ediff.el ends here
--- /dev/null
- ;; 2008, 2009, 2010 Free Software Foundation, Inc.
+;;; log-edit.el --- Major mode for editing CVS commit messages
+
+;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
++;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Todo:
+
+;; - Move in VC's code
+;; - Add compatibility for VC's hook variables
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+(require 'add-log) ; for all the ChangeLog goodies
+(require 'pcvs-util)
+(require 'ring)
+
+;;;;
+;;;; Global Variables
+;;;;
+
+(defgroup log-edit nil
+ "Major mode for editing RCS and CVS commit messages."
+ :group 'pcl-cvs
+ :group 'vc ; It's used by VC.
+ :version "21.1"
+ :prefix "log-edit-")
+
+;; compiler pacifiers
+(defvar cvs-buffer)
+
+\f
+;; The main keymap
+
+(easy-mmode-defmap log-edit-mode-map
+ `(("\C-c\C-c" . log-edit-done)
+ ("\C-c\C-a" . log-edit-insert-changelog)
+ ("\C-c\C-d" . log-edit-show-diff)
+ ("\C-c\C-f" . log-edit-show-files)
+ ("\M-n" . log-edit-next-comment)
+ ("\M-p" . log-edit-previous-comment)
+ ("\M-r" . log-edit-comment-search-backward)
+ ("\M-s" . log-edit-comment-search-forward)
+ ("\C-c?" . log-edit-mode-help))
+ "Keymap for the `log-edit-mode' (to edit version control log messages)."
+ :group 'log-edit)
+
+;; Compatibility with old names. Should we bother ?
+(defvar vc-log-mode-map log-edit-mode-map)
+(defvar vc-log-entry-mode vc-log-mode-map)
+
+(easy-menu-define log-edit-menu log-edit-mode-map
+ "Menu used for `log-edit-mode'."
+ '("Log-Edit"
+ ["Done" log-edit-done
+ :help "Exit log-edit and proceed with the actual action."]
+ "--"
+ ["Insert ChangeLog" log-edit-insert-changelog
+ :help "Insert a log message by looking at the ChangeLog"]
+ ["Add to ChangeLog" log-edit-add-to-changelog
+ :help "Insert this log message into the appropriate ChangeLog file"]
+ "--"
+ ["Show diff" log-edit-show-diff
+ :help "Show the diff for the files to be committed."]
+ ["List files" log-edit-show-files
+ :help "Show the list of relevant files."]
+ "--"
+ ["Previous comment" log-edit-previous-comment
+ :help "Cycle backwards through comment history"]
+ ["Next comment" log-edit-next-comment
+ :help "Cycle forwards through comment history."]
+ ["Search comment forward" log-edit-comment-search-forward
+ :help "Search forwards through comment history for a substring match of str"]
+ ["Search comment backward" log-edit-comment-search-backward
+ :help "Search backwards through comment history for substring match of str"]))
+
+(defcustom log-edit-confirm 'changed
+ "If non-nil, `log-edit-done' will request confirmation.
+If 'changed, only request confirmation if the list of files has
+ changed since the beginning of the log-edit session."
+ :group 'log-edit
+ :type '(choice (const changed) (const t) (const nil)))
+
+(defcustom log-edit-keep-buffer nil
+ "If non-nil, don't hide the buffer after `log-edit-done'."
+ :group 'log-edit
+ :type 'boolean)
+
+(defvar cvs-commit-buffer-require-final-newline t)
+(make-obsolete-variable 'cvs-commit-buffer-require-final-newline
+ 'log-edit-require-final-newline
+ "21.1")
+
+(defcustom log-edit-require-final-newline
+ cvs-commit-buffer-require-final-newline
+ "Enforce a newline at the end of commit log messages.
+Enforce it silently if t, query if non-nil and don't do anything if nil."
+ :group 'log-edit
+ :type '(choice (const ask) (const t) (const nil)))
+
+(defcustom log-edit-setup-invert nil
+ "Non-nil means `log-edit' should invert the meaning of its SETUP arg.
+If SETUP is 'force, this variable has no effect."
+ :group 'log-edit
+ :type 'boolean)
+
+(defcustom log-edit-hook '(log-edit-insert-cvs-template
+ log-edit-show-files
+ log-edit-insert-changelog)
+ "Hook run at the end of `log-edit'."
+ :group 'log-edit
+ :type '(hook :options (log-edit-insert-changelog
+ log-edit-insert-cvs-rcstemplate
+ log-edit-insert-cvs-template
+ log-edit-insert-filenames)))
+
+(defcustom log-edit-mode-hook (if (boundp 'vc-log-mode-hook) vc-log-mode-hook)
+ "Hook run when entering `log-edit-mode'."
+ :group 'log-edit
+ :type 'hook)
+
+(defcustom log-edit-done-hook nil
+ "Hook run before doing the actual commit.
+This hook can be used to cleanup the message, enforce various
+conventions, or to allow recording the message in some other database,
+such as a bug-tracking system. The list of files about to be committed
+can be obtained from `log-edit-files'."
+ :group 'log-edit
+ :type '(hook :options (log-edit-set-common-indentation
+ log-edit-add-to-changelog)))
+
+(defcustom log-edit-strip-single-file-name nil
+ "If non-nil, remove file name from single-file log entries."
+ :type 'boolean
+ :safe 'booleanp
+ :group 'log-edit
+ :version "24.1")
+
+(defvar cvs-changelog-full-paragraphs t)
+(make-obsolete-variable 'cvs-changelog-full-paragraphs
+ 'log-edit-changelog-full-paragraphs
+ "21.1")
+
+(defvar log-edit-changelog-full-paragraphs cvs-changelog-full-paragraphs
+ "*If non-nil, include full ChangeLog paragraphs in the log.
+This may be set in the ``local variables'' section of a ChangeLog, to
+indicate the policy for that ChangeLog.
+
+A ChangeLog paragraph is a bunch of log text containing no blank lines;
+a paragraph usually describes a set of changes with a single purpose,
+but perhaps spanning several functions in several files. Changes in
+different paragraphs are unrelated.
+
+You could argue that the log entry for a file should contain the
+full ChangeLog paragraph mentioning the change to the file, even though
+it may mention other files, because that gives you the full context you
+need to understand the change. This is the behavior you get when this
+variable is set to t.
+
+On the other hand, you could argue that the log entry for a change
+should contain only the text for the changes which occurred in that
+file, because the log is per-file. This is the behavior you get
+when this variable is set to nil.")
+
+;;;; Internal global or buffer-local vars
+
+(defconst log-edit-files-buf "*log-edit-files*")
+(defvar log-edit-initial-files nil)
+(defvar log-edit-callback nil)
+(defvar log-edit-diff-function nil)
+(defvar log-edit-listfun nil)
+
+(defvar log-edit-parent-buffer nil)
+
+;;; Originally taken from VC-Log mode
+
+(defconst log-edit-maximum-comment-ring-size 32
+ "Maximum number of saved comments in the comment ring.")
+(defvar log-edit-comment-ring (make-ring log-edit-maximum-comment-ring-size))
+(defvar log-edit-comment-ring-index nil)
+(defvar log-edit-last-comment-match "")
+
+(defun log-edit-new-comment-index (stride len)
+ "Return the comment index STRIDE elements from the current one.
+LEN is the length of `log-edit-comment-ring'."
+ (mod (cond
+ (log-edit-comment-ring-index (+ log-edit-comment-ring-index stride))
+ ;; Initialize the index on the first use of this command
+ ;; so that the first M-p gets index 0, and the first M-n gets
+ ;; index -1.
+ ((> stride 0) (1- stride))
+ (t stride))
+ len))
+
+(defun log-edit-previous-comment (arg)
+ "Cycle backwards through comment history.
+With a numeric prefix ARG, go back ARG comments."
+ (interactive "*p")
+ (let ((len (ring-length log-edit-comment-ring)))
+ (if (<= len 0)
+ (progn (message "Empty comment ring") (ding))
+ ;; Don't use `erase-buffer' because we don't want to `widen'.
+ (delete-region (point-min) (point-max))
+ (setq log-edit-comment-ring-index (log-edit-new-comment-index arg len))
+ (message "Comment %d" (1+ log-edit-comment-ring-index))
+ (insert (ring-ref log-edit-comment-ring log-edit-comment-ring-index)))))
+
+(defun log-edit-next-comment (arg)
+ "Cycle forwards through comment history.
+With a numeric prefix ARG, go forward ARG comments."
+ (interactive "*p")
+ (log-edit-previous-comment (- arg)))
+
+(defun log-edit-comment-search-backward (str &optional stride)
+ "Search backwards through comment history for substring match of STR.
+If the optional argument STRIDE is present, that is a step-width to use
+when going through the comment ring."
+ ;; Why substring rather than regexp ? -sm
+ (interactive
+ (list (read-string "Comment substring: " nil nil log-edit-last-comment-match)))
+ (unless stride (setq stride 1))
+ (if (string= str "")
+ (setq str log-edit-last-comment-match)
+ (setq log-edit-last-comment-match str))
+ (let* ((str (regexp-quote str))
+ (len (ring-length log-edit-comment-ring))
+ (n (log-edit-new-comment-index stride len)))
+ (while (progn (when (or (>= n len) (< n 0)) (error "Not found"))
+ (not (string-match str (ring-ref log-edit-comment-ring n))))
+ (setq n (+ n stride)))
+ (setq log-edit-comment-ring-index n)
+ (log-edit-previous-comment 0)))
+
+(defun log-edit-comment-search-forward (str)
+ "Search forwards through comment history for a substring match of STR."
+ (interactive
+ (list (read-string "Comment substring: " nil nil log-edit-last-comment-match)))
+ (log-edit-comment-search-backward str -1))
+
+(defun log-edit-comment-to-change-log (&optional whoami file-name)
+ "Enter last VC comment into the change log for the current file.
+WHOAMI (interactive prefix) non-nil means prompt for user name
+and site. FILE-NAME is the name of the change log; if nil, use
+`change-log-default-name'.
+
+This may be useful as a `log-edit-checkin-hook' to update change logs
+automatically."
+ (interactive (if current-prefix-arg
+ (list current-prefix-arg
+ (prompt-for-change-log-name))))
+ (let (;; Extract the comment first so we get any error before doing anything.
+ (comment (ring-ref log-edit-comment-ring 0))
+ ;; Don't let add-change-log-entry insert a defun name.
+ (add-log-current-defun-function 'ignore)
+ end)
+ ;; Call add-log to do half the work.
+ (add-change-log-entry whoami file-name t t)
+ ;; Insert the VC comment, leaving point before it.
+ (setq end (save-excursion (insert comment) (point-marker)))
+ (if (looking-at "\\s *\\s(")
+ ;; It starts with an open-paren, as in "(foo): Frobbed."
+ ;; So remove the ": " add-log inserted.
+ (delete-char -2))
+ ;; Canonicalize the white space between the file name and comment.
+ (just-one-space)
+ ;; Indent rest of the text the same way add-log indented the first line.
+ (let ((indentation (current-indentation)))
+ (save-excursion
+ (while (< (point) end)
+ (forward-line 1)
+ (indent-to indentation))
+ (setq end (point))))
+ ;; Fill the inserted text, preserving open-parens at bol.
+ (let ((paragraph-start (concat paragraph-start "\\|\\s *\\s(")))
+ (beginning-of-line)
+ (fill-region (point) end))
+ ;; Canonicalize the white space at the end of the entry so it is
+ ;; separated from the next entry by a single blank line.
+ (skip-syntax-forward " " end)
+ (delete-char (- (skip-syntax-backward " ")))
+ (or (eobp) (looking-at "\n\n")
+ (insert "\n"))))
+
+;; Compatibility with old names.
+(define-obsolete-variable-alias 'vc-comment-ring 'log-edit-comment-ring "22.1")
+(define-obsolete-variable-alias 'vc-comment-ring-index 'log-edit-comment-ring-index "22.1")
+(define-obsolete-function-alias 'vc-previous-comment 'log-edit-previous-comment "22.1")
+(define-obsolete-function-alias 'vc-next-comment 'log-edit-next-comment "22.1")
+(define-obsolete-function-alias 'vc-comment-search-reverse 'log-edit-comment-search-backward "22.1")
+(define-obsolete-function-alias 'vc-comment-search-forward 'log-edit-comment-search-forward "22.1")
+(define-obsolete-function-alias 'vc-comment-to-change-log 'log-edit-comment-to-change-log "22.1")
+
+;;;
+;;; Actual code
+;;;
+
+(defface log-edit-summary '((t :inherit font-lock-function-name-face))
+ "Face for the summary in `log-edit-mode' buffers.")
+
+(defface log-edit-header '((t :inherit font-lock-keyword-face))
+ "Face for the headers in `log-edit-mode' buffers.")
+
+(defface log-edit-unknown-header '((t :inherit font-lock-comment-face))
+ "Face for unknown headers in `log-edit-mode' buffers.")
+
+(defvar log-edit-headers-alist '(("Summary" . log-edit-summary)
+ ("Fixes") ("Author"))
+ "AList of known headers and the face to use to highlight them.")
+
+(defconst log-edit-header-contents-regexp
+ "[ \t]*\\(.*\\(\n[ \t].*\\)*\\)\n?")
+
+(defun log-edit-match-to-eoh (limit)
+ ;; FIXME: copied from message-match-to-eoh.
+ (let ((start (point)))
+ (rfc822-goto-eoh)
+ ;; Typical situation: some temporary change causes the header to be
+ ;; incorrect, so EOH comes earlier than intended: the last lines of the
+ ;; intended headers are now not considered part of the header any more,
+ ;; so they don't have the multiline property set. When the change is
+ ;; completed and the header has its correct shape again, the lack of the
+ ;; multiline property means we won't rehighlight the last lines of
+ ;; the header.
+ (if (< (point) start)
+ nil ;No header within start..limit.
+ ;; Here we disregard LIMIT so that we may extend the area again.
+ (set-match-data (list start (point)))
+ (point))))
+
+(defvar log-edit-font-lock-keywords
+ ;; Copied/inspired by message-font-lock-keywords.
+ `((log-edit-match-to-eoh
+ (,(concat "^\\(\\([a-z]+\\):\\)" log-edit-header-contents-regexp)
+ (progn (goto-char (match-beginning 0)) (match-end 0)) nil
+ (1 (if (assoc (match-string 2) log-edit-headers-alist)
+ 'log-edit-header
+ 'log-edit-unknown-header)
+ nil lax)
+ ;; From `log-edit-header-contents-regexp':
+ (3 (or (cdr (assoc (match-string 2) log-edit-headers-alist))
+ 'log-edit-header)
+ nil lax)))))
+
+;;;###autoload
+(defun log-edit (callback &optional setup params buffer mode &rest ignore)
+ "Setup a buffer to enter a log message.
+\\<log-edit-mode-map>The buffer will be put in mode MODE or `log-edit-mode'
+if MODE is nil.
+If SETUP is non-nil, the buffer is then erased and `log-edit-hook' is run.
+Mark and point will be set around the entire contents of the buffer so
+that it is easy to kill the contents of the buffer with \\[kill-region].
+Once you're done editing the message, pressing \\[log-edit-done] will call
+`log-edit-done' which will end up calling CALLBACK to do the actual commit.
+
+PARAMS if non-nil is an alist. Possible keys and associated values:
+ `log-edit-listfun' -- function taking no arguments that returns the list of
+ files that are concerned by the current operation (using relative names);
+ `log-edit-diff-function' -- function taking no arguments that
+ displays a diff of the files concerned by the current operation.
+
+If BUFFER is non-nil `log-edit' will jump to that buffer, use it to edit the
+log message and go back to the current buffer when done. Otherwise, it
+uses the current buffer."
+ (let ((parent (current-buffer)))
+ (if buffer (pop-to-buffer buffer))
+ (when (and log-edit-setup-invert (not (eq setup 'force)))
+ (setq setup (not setup)))
+ (when setup
+ (erase-buffer)
+ (insert "Summary: ")
+ (save-excursion (insert "\n\n")))
+ (if mode
+ (funcall mode)
+ (log-edit-mode))
+ (set (make-local-variable 'log-edit-callback) callback)
+ (if (listp params)
+ (dolist (crt params)
+ (set (make-local-variable (car crt)) (cdr crt)))
+ ;; For backward compatibility with log-edit up to version 22.2
+ ;; accept non-list PARAMS to mean `log-edit-list'.
+ (set (make-local-variable 'log-edit-listfun) params))
+
+ (if buffer (set (make-local-variable 'log-edit-parent-buffer) parent))
+ (set (make-local-variable 'log-edit-initial-files) (log-edit-files))
+ (when setup (run-hooks 'log-edit-hook))
+ (goto-char (point-min)) (push-mark (point-max))
+ (message "%s" (substitute-command-keys
+ "Press \\[log-edit-done] when you are done editing."))))
+
+(define-derived-mode log-edit-mode text-mode "Log-Edit"
+ "Major mode for editing version-control log messages.
+When done editing the log entry, just type \\[log-edit-done] which
+will trigger the actual commit of the file(s).
+Several other handy support commands are provided of course and
+the package from which this is used might also provide additional
+commands (under C-x v for VC, for example).
+
+\\{log-edit-mode-map}"
+ (set (make-local-variable 'font-lock-defaults)
+ '(log-edit-font-lock-keywords t t))
+ (make-local-variable 'log-edit-comment-ring-index)
+ (hack-dir-local-variables-non-file-buffer))
+
+(defun log-edit-hide-buf (&optional buf where)
+ (when (setq buf (get-buffer (or buf log-edit-files-buf)))
+ (let ((win (get-buffer-window buf where)))
+ (if win (ignore-errors (delete-window win))))
+ (bury-buffer buf)))
+
+(defun log-edit-done ()
+ "Finish editing the log message and commit the files.
+If you want to abort the commit, simply delete the buffer."
+ (interactive)
+ ;; Clean up empty headers.
+ (goto-char (point-min))
+ (while (looking-at (concat "^[a-z]*:" log-edit-header-contents-regexp))
+ (let ((beg (match-beginning 0)))
+ (goto-char (match-end 0))
+ (if (string-match "\\`[ \n\t]*\\'" (match-string 1))
+ (delete-region beg (point)))))
+ ;; Get rid of leading empty lines.
+ (goto-char (point-min))
+ (when (looking-at "\\([ \t]*\n\\)+")
+ (delete-region (match-beginning 0) (match-end 0)))
+ ;; Get rid of trailing empty lines
+ (goto-char (point-max))
+ (skip-syntax-backward " ")
+ (when (equal (char-after) ?\n) (forward-char 1))
+ (delete-region (point) (point-max))
+ ;; Check for final newline
+ (if (and (> (point-max) (point-min))
+ (/= (char-before (point-max)) ?\n)
+ (or (eq log-edit-require-final-newline t)
+ (and log-edit-require-final-newline
+ (y-or-n-p
+ (format "Buffer %s does not end in newline. Add one? "
+ (buffer-name))))))
+ (save-excursion
+ (goto-char (point-max))
+ (insert ?\n)))
+ (let ((comment (buffer-string)))
+ (when (or (ring-empty-p log-edit-comment-ring)
+ (not (equal comment (ring-ref log-edit-comment-ring 0))))
+ (ring-insert log-edit-comment-ring comment)))
+ (let ((win (get-buffer-window log-edit-files-buf)))
+ (if (and log-edit-confirm
+ (not (and (eq log-edit-confirm 'changed)
+ (equal (log-edit-files) log-edit-initial-files)))
+ (progn
+ (log-edit-show-files)
+ (not (y-or-n-p "Really commit? "))))
+ (progn (when (not win) (log-edit-hide-buf))
+ (message "Oh, well! Later maybe?"))
+ (run-hooks 'log-edit-done-hook)
+ (log-edit-hide-buf)
+ (unless (or log-edit-keep-buffer (not log-edit-parent-buffer))
+ (cvs-bury-buffer (current-buffer) log-edit-parent-buffer))
+ (call-interactively log-edit-callback))))
+
+(defun log-edit-files ()
+ "Return the list of files that are about to be committed."
+ (ignore-errors (funcall log-edit-listfun)))
+
+(defun log-edit-mode-help ()
+ "Provide help for the `log-edit-mode-map'."
+ (interactive)
+ (if (eq last-command 'log-edit-mode-help)
+ (describe-function major-mode)
+ (message "%s"
+ (substitute-command-keys
+ "Type `\\[log-edit-done]' to finish commit. Try `\\[describe-function] log-edit-done' for more help."))))
+
+(defcustom log-edit-common-indent 0
+ "Minimum indentation to use in `log-edit-set-common-indentation'."
+ :group 'log-edit
+ :type 'integer)
+
+(defun log-edit-set-common-indentation ()
+ "(Un)Indent the current buffer rigidly to `log-edit-common-indent'."
+ (save-excursion
+ (let ((common (point-max)))
+ (rfc822-goto-eoh)
+ (while (< (point) (point-max))
+ (if (not (looking-at "^[ \t]*$"))
+ (setq common (min common (current-indentation))))
+ (forward-line 1))
+ (rfc822-goto-eoh)
+ (indent-rigidly (point) (point-max)
+ (- log-edit-common-indent common)))))
+
+(defun log-edit-show-diff ()
+ "Show the diff for the files to be committed."
+ (interactive)
+ (if (functionp log-edit-diff-function)
+ (funcall log-edit-diff-function)
+ (error "Diff functionality has not been setup")))
+
+(defun log-edit-show-files ()
+ "Show the list of files to be committed."
+ (interactive)
+ (let* ((files (log-edit-files))
+ (buf (get-buffer-create log-edit-files-buf)))
+ (with-current-buffer buf
+ (log-edit-hide-buf buf 'all)
+ (setq buffer-read-only nil)
+ (erase-buffer)
+ (cvs-insert-strings files)
+ (setq buffer-read-only t)
+ (goto-char (point-min))
+ (save-selected-window
+ (cvs-pop-to-buffer-same-frame buf)
+ (shrink-window-if-larger-than-buffer)
+ (selected-window)))))
+
+(defun log-edit-insert-cvs-template ()
+ "Insert the template specified by the CVS administrator, if any.
+This simply uses the local CVS/Template file."
+ (interactive)
+ (when (or (called-interactively-p 'interactive)
+ (= (point-min) (point-max)))
+ (when (file-readable-p "CVS/Template")
+ (insert-file-contents "CVS/Template"))))
+
+(defun log-edit-insert-cvs-rcstemplate ()
+ "Insert the rcstemplate from the CVS repository.
+This contacts the repository to get the rcstemplate file and
+can thus take some time."
+ (interactive)
+ (when (or (called-interactively-p 'interactive)
+ (= (point-min) (point-max)))
+ (when (file-readable-p "CVS/Root")
+ ;; Ignore the stderr stuff, even if it's an error.
+ (call-process "cvs" nil '(t nil) nil
+ "checkout" "-p" "CVSROOT/rcstemplate"))))
+
+(defun log-edit-insert-filenames ()
+ "Insert the list of files that are to be committed."
+ (interactive)
+ (insert "Affected files: \n"
+ (mapconcat 'identity (log-edit-files) " \n")))
+
+(defun log-edit-add-to-changelog ()
+ "Insert this log message into the appropriate ChangeLog file."
+ (interactive)
+ ;; Yuck!
+ (unless (string= (buffer-string) (ring-ref log-edit-comment-ring 0))
+ (ring-insert log-edit-comment-ring (buffer-string)))
+ (dolist (f (log-edit-files))
+ (let ((buffer-file-name (expand-file-name f)))
+ (save-excursion
+ (log-edit-comment-to-change-log)))))
+
+(defvar log-edit-changelog-use-first nil)
+
+(defvar log-edit-rewrite-fixes nil
+ "Rule to rewrite bug numbers into Fixes: headers.
+The value should be of the form (REGEXP . REPLACEMENT)
+where REGEXP should match the expression referring to a bug number
+in the text, and REPLACEMENT is an expression to pass to `replace-match'
+to build the Fixes: header.")
+(put 'log-edit-rewrite-fixes 'safe-local-variable
+ (lambda (v) (and (stringp (car-safe v)) (stringp (cdr v)))))
+
+(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 ((author
+ (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)
+ ;; Add an Author: field if appropriate.
+ (when author
+ (rfc822-goto-eoh)
+ (insert "Author: " author "\n" (if (looking-at "\n") "" "\n")))
+ ;; Add a Fixes: field if applicable.
+ (when (consp log-edit-rewrite-fixes)
+ (rfc822-goto-eoh)
+ (when (re-search-forward (car log-edit-rewrite-fixes) nil t)
+ (let ((start (match-beginning 0))
+ (end (match-end 0))
+ (fixes (match-substitute-replacement
+ (cdr log-edit-rewrite-fixes))))
+ (delete-region start end)
+ (rfc822-goto-eoh)
+ (insert "Fixes: " fixes "\n" (if (looking-at "\n") "" "\n")))))
+ (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)
+
+(defvar log-edit-author) ;Dynamically scoped.
+
+(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"))))
+ (if (null log-edit-changelog-use-first)
+ (looking-at (regexp-quote (format "%s %s <%s>" time name mail)))
+ ;; Check the author, to potentially add it as a "Author: " header.
+ (when (looking-at "[^ \t]")
+ (when (and (boundp 'log-edit-author)
+ (not (looking-at (format ".+ .+ <%s>"
+ (regexp-quote mail))))
+ (looking-at ".+ \\(.+ <.+>\\)"))
+ (let ((author (replace-regexp-in-string " " " "
+ (match-string 1))))
+ (unless (and log-edit-author
+ (string-match (regexp-quote author) log-edit-author))
+ (setq log-edit-author
+ (if log-edit-author
+ (concat log-edit-author ", " author)
+ author)))))
+ t))))
+
+(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:]]\\)"
+ (regexp-quote 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)
+ (log-edit-author 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"))
+ log-edit-author))
+
+(defun log-edit-extract-headers (headers comment)
+ "Extract headers from COMMENT to form command line arguments.
+HEADERS should be an alist with elements of the form (HEADER . CMDARG)
+associating header names to the corresponding cmdline option name and the
+result is then a list of the form (MSG CMDARG1 HDRTEXT1 CMDARG2 HDRTEXT2...).
+where MSG is the remaining text from STRING.
+If \"Summary\" is not in HEADERS, then the \"Summary\" header is extracted
+anyway and put back as the first line of MSG."
+ (with-temp-buffer
+ (insert comment)
+ (rfc822-goto-eoh)
+ (narrow-to-region (point-min) (point))
+ (let ((case-fold-search t)
+ (summary ())
+ (res ()))
+ (dolist (header (if (assoc "Summary" headers) headers
+ (cons '("Summary" . t) headers)))
+ (goto-char (point-min))
+ (while (re-search-forward (concat "^" (car header)
+ ":" log-edit-header-contents-regexp)
+ nil t)
+ (if (eq t (cdr header))
+ (setq summary (match-string 1))
+ (push (match-string 1) res)
+ (push (or (cdr header) (car header)) res))
+ (replace-match "" t t)))
+ ;; Remove header separator if the header is empty.
+ (widen)
+ (goto-char (point-min))
+ (when (looking-at "\\([ \t]*\n\\)+")
+ (delete-region (match-beginning 0) (match-end 0)))
+ (if summary (insert summary "\n"))
+ (cons (buffer-string) res))))
+
+(provide 'log-edit)
+
+;; arch-tag: 8089b39c-983b-4e83-93cd-ed0a64c7fdcc
+;;; log-edit.el ends here
--- /dev/null
- ;; 2008, 2009, 2010 Free Software Foundation, Inc.
+;;; 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, 2011 Free Software Foundation, Inc.
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Major mode to browse revision log histories.
+;; Currently supports the format output by:
+;; RCS, SCCS, CVS, Subversion, and DaRCS.
+
+;; Examples of log output:
+
+;;;; RCS/CVS:
+
+;; ----------------------------
+;; revision 1.35 locked by: turlutut
+;; date: 2005-03-22 18:48:38 +0000; author: monnier; state: Exp; lines: +6 -8
+;; (gnus-display-time-event-handler):
+;; Check display-time-timer at runtime rather than only at load time
+;; in case display-time-mode is turned off in the mean time.
+;; ----------------------------
+;; revision 1.34
+;; date: 2005-02-09 15:50:38 +0000; author: kfstorm; state: Exp; lines: +7 -7
+;; branches: 1.34.2;
+;; Change release version from 21.4 to 22.1 throughout.
+;; Change development version from 21.3.50 to 22.0.50.
+
+;;;; SCCS:
+
+;;;; Subversion:
+
+;; ------------------------------------------------------------------------
+;; r4622 | ckuethe | 2007-12-23 18:18:01 -0500 (Sun, 23 Dec 2007) | 2 lines
+;;
+;; uBlox AEK-4T in binary mode. Added to unstable because it breaks gpsfake
+;;
+;; ------------------------------------------------------------------------
+;; r4621 | ckuethe | 2007-12-23 16:48:11 -0500 (Sun, 23 Dec 2007) | 3 lines
+;;
+;; Add a note about requiring usbfs to use the garmin gps18 (usb)
+;; Mention firmware testing the AC12 with firmware BQ00 and BQ04
+;;
+;; ------------------------------------------------------------------------
+;; r4620 | ckuethe | 2007-12-23 15:52:34 -0500 (Sun, 23 Dec 2007) | 1 line
+;;
+;; add link to latest hardware reference
+;; ------------------------------------------------------------------------
+;; r4619 | ckuethe | 2007-12-23 14:37:31 -0500 (Sun, 23 Dec 2007) | 1 line
+;;
+;; there is now a regression test for AC12 without raw data output
+
+;;;; Darcs:
+
+;; Changes to darcsum.el:
+;;
+;; Mon Nov 28 15:19:38 GMT 2005 Dave Love <fx@gnu.org>
+;; * Abstract process startup into darcsum-start-process. Use TERM=dumb.
+;; TERM=dumb avoids escape characters, at least, for any old darcs that
+;; doesn't understand DARCS_DONT_COLOR & al.
+;;
+;; Thu Nov 24 15:20:45 GMT 2005 Dave Love <fx@gnu.org>
+;; * darcsum-mode-related changes.
+;; Don't call font-lock-mode (unnecessary) or use-local-map (redundant).
+;; Use mode-class 'special. Add :group.
+;; Add trailing-whitespace option to mode hook and fix
+;; darcsum-display-changeset not to use trailing whitespace.
+
+;;;; Mercurial
+
+;; changeset: 11:8ff1a4166444
+;; tag: tip
+;; user: Eric S. Raymond <esr@thyrsus.com>
+;; date: Wed Dec 26 12:18:58 2007 -0500
+;; summary: Explain keywords. Add markup fixes.
+;;
+;; changeset: 10:20abc7ab09c3
+;; user: Eric S. Raymond <esr@thyrsus.com>
+;; date: Wed Dec 26 11:37:28 2007 -0500
+;; summary: Typo fixes.
+;;
+;; changeset: 9:ada9f4da88aa
+;; user: Eric S. Raymond <esr@thyrsus.com>
+;; date: Wed Dec 26 11:23:00 2007 -0500
+;; summary: Add RCS example session.
+
+;;; Todo:
+
+;; - add ability to modify a log-entry (via cvs-mode-admin ;-)
+;; - remove references to cvs-*
+;; - make it easier to add support for new backends without changing the code.
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+(require 'pcvs-util)
+(autoload 'vc-find-revision "vc")
+(autoload 'vc-diff-internal "vc")
+
+(defvar cvs-minor-wrap-function)
+
+(defgroup log-view nil
+ "Major mode for browsing log output of RCS/CVS/SCCS."
+ :group 'pcl-cvs
+ :prefix "log-view-")
+
+;; Needed because log-view-mode-map inherits from widget-keymap. (Bug#5311)
+(require 'wid-edit)
+
+(easy-mmode-defmap log-view-mode-map
+ '(("z" . kill-this-buffer)
+ ("q" . quit-window)
+ ("g" . revert-buffer)
+ ("m" . log-view-toggle-mark-entry)
+ ("e" . log-view-modify-change-comment)
+ ("d" . log-view-diff)
+ ("=" . log-view-diff)
+ ("D" . log-view-diff-changeset)
+ ("a" . log-view-annotate-version)
+ ("f" . log-view-find-revision)
+ ("n" . log-view-msg-next)
+ ("p" . log-view-msg-prev)
+ ("\t" . log-view-msg-next)
+ ([backtab] . log-view-msg-prev)
+ ("N" . log-view-file-next)
+ ("P" . log-view-file-prev)
+ ("\M-n" . log-view-file-next)
+ ("\M-p" . log-view-file-prev))
+ "Log-View's keymap."
+ :inherit widget-keymap
+ :group 'log-view)
+
+(easy-menu-define log-view-mode-menu log-view-mode-map
+ "Log-View Display Menu"
+ `("Log-View"
+ ;; XXX Do we need menu entries for these?
+ ;; ["Quit" quit-window]
+ ;; ["Kill This Buffer" kill-this-buffer]
+ ["Mark Log Entry for Diff" set-mark-command
+ :help ""]
+ ["Diff Revisions" log-view-diff
+ :help "Get the diff between two revisions"]
+ ["Changeset Diff" log-view-diff-changeset
+ :help "Get the changeset diff between two revisions"]
+ ["Visit Version" log-view-find-revision
+ :help "Visit the version at point"]
+ ["Annotate Version" log-view-annotate-version
+ :help "Annotate the version at point"]
+ ["Modify Log Comment" log-view-modify-change-comment
+ :help "Edit the change comment displayed at point"]
+ "-----"
+ ["Next Log Entry" log-view-msg-next
+ :help "Go to the next count'th log message"]
+ ["Previous Log Entry" log-view-msg-prev
+ :help "Go to the previous count'th log message"]
+ ["Next File" log-view-file-next
+ :help "Go to the next count'th file"]
+ ["Previous File" log-view-file-prev
+ :help "Go to the previous count'th file"]))
+
+(defvar log-view-mode-hook nil
+ "Hook run at the end of `log-view-mode'.")
+
+(defface log-view-file
+ '((((class color) (background light))
+ (:background "grey70" :weight bold))
+ (t (:weight bold)))
+ "Face for the file header line in `log-view-mode'."
+ :group 'log-view)
+(define-obsolete-face-alias 'log-view-file-face 'log-view-file "22.1")
+(defvar log-view-file-face 'log-view-file)
+
+(defface log-view-message
+ '((((class color) (background light))
+ (:background "grey85"))
+ (t (:weight bold)))
+ "Face for the message header line in `log-view-mode'."
+ :group 'log-view)
+;; backward-compatibility alias
+(define-obsolete-face-alias 'log-view-message-face 'log-view-message "22.1")
+(defvar log-view-message-face 'log-view-message)
+
+(defvar log-view-file-re
+ (concat "^\\(?:Working file: \\(?1:.+\\)" ;RCS and CVS.
+ ;; Subversion has no such thing??
+ "\\|\\(?:SCCS/s\\.\\|Changes to \\)\\(?1:.+\\):" ;SCCS and Darcs.
+ "\\)\n") ;Include the \n for font-lock reasons.
+ "Regexp matching the text identifying the file.
+The match group number 1 should match the file name itself.")
+
+(defvar log-view-per-file-logs t
+ "Set if to t if the logs are shown one file at a time.")
+
+(defvar log-view-message-re
+ (concat "^\\(?:revision \\(?1:[.0-9]+\\)\\(?:\t.*\\)?" ; RCS and CVS.
+ "\\|r\\(?1:[0-9]+\\) | .* | .*" ; Subversion.
+ "\\|D \\(?1:[.0-9]+\\) .*" ; SCCS.
+ ;; Darcs doesn't have revision names. VC-darcs uses patch names
+ ;; instead. Darcs patch names are hashcodes, which do not appear
+ ;; in the log output :-(, but darcs accepts any prefix of the log
+ ;; message as a patch name, so we match the first line of the log
+ ;; message.
+ ;; First loosely match the date format.
+ (concat "\\|[^ \n].*[^0-9\n][0-9][0-9]:[0-9][0-9][^0-9\n].*[^ \n]"
+ ;;Email of user and finally Msg, used as revision name.
+ " .*@.*\n\\(?: \\* \\(?1:.*\\)\\)?")
+ "\\)$")
+ "Regexp matching the text identifying a revision.
+The match group number 1 should match the revision number itself.")
+
+(defvar log-view-font-lock-keywords
+ ;; We use `eval' so as to use the buffer-local value of log-view-file-re
+ ;; and log-view-message-re, if applicable.
+ '((eval . `(,log-view-file-re
+ (1 (if (boundp 'cvs-filename-face) cvs-filename-face))
+ (0 log-view-file-face append)))
+ (eval . `(,log-view-message-re . log-view-message-face))))
+
+(defconst log-view-font-lock-defaults
+ '(log-view-font-lock-keywords t nil nil nil))
+
+(defvar log-view-vc-fileset nil
+ "Set this to the fileset corresponding to the current log.")
+
+(defvar log-view-vc-backend nil
+ "Set this to the VC backend that created the current log.")
+
+;;;;
+;;;; Actual code
+;;;;
+
+;;;###autoload
+(define-derived-mode log-view-mode special-mode "Log-View"
+ "Major mode for browsing CVS log output."
+ (setq buffer-read-only t)
+ (set (make-local-variable 'font-lock-defaults) log-view-font-lock-defaults)
+ (set (make-local-variable 'beginning-of-defun-function)
+ 'log-view-beginning-of-defun)
+ (set (make-local-variable 'end-of-defun-function)
+ 'log-view-end-of-defun)
+ (set (make-local-variable 'cvs-minor-wrap-function) 'log-view-minor-wrap)
+ (hack-dir-local-variables-non-file-buffer))
+
+;;;;
+;;;; Navigation
+;;;;
+
+;; define log-view-{msg,file}-{next,prev}
+(easy-mmode-define-navigation log-view-msg log-view-message-re "log message")
+(easy-mmode-define-navigation log-view-file log-view-file-re "file")
+
+(defun log-view-goto-rev (rev)
+ (goto-char (point-min))
+ (ignore-errors
+ (while (not (equal rev (log-view-current-tag)))
+ (log-view-msg-next))
+ t))
+
+;;;;
+;;;; Linkage to PCL-CVS (mostly copied from cvs-status.el)
+;;;;
+
+(defconst log-view-dir-re "^cvs[.ex]* [a-z]+: Logging \\(.+\\)$")
+
+(defun log-view-current-file ()
+ (save-excursion
+ (forward-line 1)
+ (or (re-search-backward log-view-file-re nil t)
+ (re-search-forward log-view-file-re nil t)
+ (error "Unable to determine the current file"))
+ (let* ((file (match-string 1))
+ (cvsdir (and (re-search-backward log-view-dir-re nil t)
+ (match-string 1)))
+ (pcldir (and (boundp 'cvs-pcl-cvs-dirchange-re)
+ (re-search-backward cvs-pcl-cvs-dirchange-re nil t)
+ (match-string 1)))
+ (dir ""))
+ (let ((default-directory ""))
+ (when pcldir (setq dir (expand-file-name pcldir dir)))
+ (when cvsdir (setq dir (expand-file-name cvsdir dir))))
+ (expand-file-name file dir))))
+
+(defun log-view-current-tag (&optional where)
+ (save-excursion
+ (when where (goto-char where))
+ (forward-line 1)
+ (let ((pt (point)))
+ (when (re-search-backward log-view-message-re nil t)
+ (let ((rev (match-string-no-properties 1)))
+ (unless (re-search-forward log-view-file-re pt t)
+ rev))))))
+
+(defun log-view-toggle-mark-entry ()
+ "Toggle the marked state for the log entry at point.
+Individual log entries can be marked and unmarked. The marked
+entries are denoted by changing their background color.
+`log-view-get-marked' returns the list of tags for the marked
+log entries."
+ (interactive)
+ (save-excursion
+ (forward-line 1)
+ (let ((pt (point)))
+ (when (re-search-backward log-view-message-re nil t)
+ (let ((beg (match-beginning 0))
+ end ov ovlist found tag)
+ (unless (re-search-forward log-view-file-re pt t)
+ ;; Look to see if the current entry is marked.
+ (setq found (get-char-property (point) 'log-view-self))
+ (if found
+ (delete-overlay found)
+ ;; Create an overlay that covers this entry and change
+ ;; its color.
+ (setq tag (log-view-current-tag (point)))
+ (forward-line 1)
+ (setq end
+ (if (re-search-forward log-view-message-re nil t)
+ (match-beginning 0)
+ (point-max)))
+ (setq ov (make-overlay beg end))
+ (overlay-put ov 'face 'log-view-file)
+ ;; This is used to check if the overlay is present.
+ (overlay-put ov 'log-view-self ov)
+ (overlay-put ov 'log-view-marked tag))))))))
+
+(defun log-view-get-marked ()
+ "Return the list of tags for the marked log entries."
+ (save-excursion
+ (let ((pos (point-min))
+ marked-list ov)
+ (while (setq pos (next-single-property-change pos 'face))
+ (when (setq ov (get-char-property pos 'log-view-self))
+ (push (overlay-get ov 'log-view-marked) marked-list)
+ (setq pos (overlay-end ov))))
+ marked-list)))
+
+(defun log-view-beginning-of-defun ()
+ ;; This assumes that a log entry starts with a line matching
+ ;; `log-view-message-re'. Modes that derive from `log-view-mode'
+ ;; for which this assumption is not valid will have to provide
+ ;; another implementation of this function. `log-view-msg-prev'
+ ;; does a similar job to this function, we can't use it here
+ ;; directly because it prints messages that are not appropriate in
+ ;; this context and it does not move to the beginning of the buffer
+ ;; when the point is before the first log entry.
+
+ ;; `log-view-beginning-of-defun' and `log-view-end-of-defun' have
+ ;; been checked to work with logs produced by RCS, CVS, git,
+ ;; mercurial and subversion.
+
+ (re-search-backward log-view-message-re nil 'move))
+
+(defun log-view-end-of-defun ()
+ ;; The idea in this function is to search for the beginning of the
+ ;; next log entry using `log-view-message-re' and then go back one
+ ;; line when finding it. Modes that derive from `log-view-mode' for
+ ;; which this assumption is not valid will have to provide another
+ ;; implementation of this function.
+
+ ;; Look back and if there is no entry there it means we are before
+ ;; the first log entry, so go forward until finding one.
+ (unless (save-excursion (re-search-backward log-view-message-re nil t))
+ (re-search-forward log-view-message-re nil t))
+
+ ;; In case we are at the end of log entry going forward a line will
+ ;; make us find the next entry when searching. If we are inside of
+ ;; an entry going forward a line will still keep the point inside
+ ;; the same entry.
+ (forward-line 1)
+
+ ;; In case we are at the beginning of an entry, move past it.
+ (when (looking-at log-view-message-re)
+ (goto-char (match-end 0))
+ (forward-line 1))
+
+ ;; Search for the start of the next log entry. Go to the end of the
+ ;; buffer if we could not find a next entry.
+ (when (re-search-forward log-view-message-re nil 'move)
+ (goto-char (match-beginning 0))
+ (forward-line -1)))
+
+(defvar cvs-minor-current-files)
+(defvar cvs-branch-prefix)
+(defvar cvs-secondary-branch-prefix)
+
+(defun log-view-minor-wrap (buf f)
+ (let ((data (with-current-buffer buf
+ (let* ((beg (point))
+ (end (if mark-active (mark) (point)))
+ (fr (log-view-current-tag beg))
+ (to (log-view-current-tag end)))
+ (when (string-equal fr to)
+ (save-excursion
+ (goto-char end)
+ (log-view-msg-next)
+ (setq to (log-view-current-tag))))
+ (cons
+ ;; The first revision has to be the one at point, for
+ ;; operations that only take one revision
+ ;; (e.g. cvs-mode-edit).
+ (cons (log-view-current-file) fr)
+ (cons (log-view-current-file) to))))))
+ (let ((cvs-branch-prefix (cdar data))
+ (cvs-secondary-branch-prefix (and (cdar data) (cddr data)))
+ (cvs-minor-current-files
+ (cons (caar data)
+ (when (and (cadr data) (not (equal (caar data) (cadr data))))
+ (list (cadr data)))))
+ ;; FIXME: I need to force because the fileinfos are UNKNOWN
+ (cvs-force-command "/F"))
+ (funcall f))))
+
+(defun log-view-find-revision (pos)
+ "Visit the version at point."
+ (interactive "d")
+ (unless log-view-per-file-logs
+ (when (> (length log-view-vc-fileset) 1)
+ (error "Multiple files shown in this buffer, cannot use this command here")))
+ (save-excursion
+ (goto-char pos)
+ (switch-to-buffer (vc-find-revision (if log-view-per-file-logs
+ (log-view-current-file)
+ (car log-view-vc-fileset))
+ (log-view-current-tag)))))
+
+
+(defun log-view-extract-comment ()
+ "Parse comment from around the current point in the log."
+ (save-excursion
+ (let (st en (backend (vc-backend (log-view-current-file))))
+ (log-view-end-of-defun)
+ (cond ((eq backend 'SVN)
+ (forward-line -1)))
+ (setq en (point))
+ (log-view-beginning-of-defun)
+ (cond ((memq backend '(SCCS RCS CVS MCVS SVN))
+ (forward-line 2))
+ ((eq backend 'Hg)
+ (forward-line 4)
+ (re-search-forward "summary: *" nil t)))
+ (setq st (point))
+ (buffer-substring st en))))
+
+(declare-function vc-modify-change-comment "vc" (files rev oldcomment))
+
+(defun log-view-modify-change-comment ()
+ "Edit the change comment displayed at point."
+ (interactive)
+ (vc-modify-change-comment (list (if log-view-per-file-logs
+ (log-view-current-file)
+ (car log-view-vc-fileset)))
+ (log-view-current-tag)
+ (log-view-extract-comment)))
+
+(defun log-view-annotate-version (pos)
+ "Annotate the version at point."
+ (interactive "d")
+ (unless log-view-per-file-logs
+ (when (> (length log-view-vc-fileset) 1)
+ (error "Multiple files shown in this buffer, cannot use this command here")))
+ (save-excursion
+ (goto-char pos)
+ (vc-annotate (if log-view-per-file-logs
+ (log-view-current-file)
+ (car log-view-vc-fileset))
+ (log-view-current-tag))))
+
+;;
+;; diff
+;;
+
+(defun log-view-diff (beg end)
+ "Get the diff between two revisions.
+If the mark is not active or the mark is on the revision at point,
+get the diff between the revision at point and its previous revision.
+Otherwise, get the diff between the revisions where the region starts
+and ends.
+Contrary to `log-view-diff-changeset', it will only show the part of the
+changeset that affected the currently considered file(s)."
+ (interactive
+ (list (if mark-active (region-beginning) (point))
+ (if mark-active (region-end) (point))))
+ (let ((fr (log-view-current-tag beg))
+ (to (log-view-current-tag end)))
+ (when (string-equal fr to)
+ (save-excursion
+ (goto-char end)
+ (log-view-msg-next)
+ (setq to (log-view-current-tag))))
+ (vc-diff-internal
+ t (list log-view-vc-backend
+ (if log-view-per-file-logs
+ (list (log-view-current-file))
+ log-view-vc-fileset))
+ to fr)))
+
+(declare-function vc-diff-internal "vc"
+ (async vc-fileset rev1 rev2 &optional verbose))
+
+(defun log-view-diff-changeset (beg end)
+ "Get the diff between two revisions.
+If the mark is not active or the mark is on the revision at point,
+get the diff between the revision at point and its previous revision.
+Otherwise, get the diff between the revisions where the region starts
+and ends.
+Contrary to `log-view-diff', it will show the whole changeset including
+the changes that affected other files than the currently considered file(s)."
+ (interactive
+ (list (if mark-active (region-beginning) (point))
+ (if mark-active (region-end) (point))))
+ (when (eq (vc-call-backend log-view-vc-backend 'revision-granularity) 'file)
+ (error "The %s backend does not support changeset diffs" log-view-vc-backend))
+ (let ((fr (log-view-current-tag beg))
+ (to (log-view-current-tag end)))
+ (when (string-equal fr to)
+ ;; TO and FR are the same, look at the previous revision.
+ (setq to (vc-call-backend log-view-vc-backend 'previous-revision nil fr)))
+ (vc-diff-internal
+ t
+ ;; We want to see the diff for all the files in the changeset, so
+ ;; pass NIL for the file list. The value passed here should
+ ;; follow what `vc-deduce-fileset' returns.
+ (list log-view-vc-backend nil)
+ to fr)))
+
+(provide 'log-view)
+
+;; arch-tag: 0d64220b-ce7e-4f62-9c2a-6b04c2f81f4f
+;;; log-view.el ends here
--- /dev/null
- ;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;;; 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, 2011
+;; Free Software Foundation, Inc.
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; Keywords: pcl-cvs
+;; Package: pcvs
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+(require 'pcvs-util)
+
+;;;; -------------------------------------------------------
+;;;; START OF THINGS TO CHECK WHEN INSTALLING
+
+(defvar cvs-program "cvs"
+ "*Name or full path of the cvs executable.")
+
+(defvar cvs-version
+ ;; With the divergence of the CVSNT codebase and version numbers, this is
+ ;; not really good any more.
+ (ignore-errors
+ (with-temp-buffer
+ (call-process cvs-program nil t nil "-v")
+ (goto-char (point-min))
+ (when (re-search-forward "(CVS\\(NT\\)?) \\([0-9]+\\)\\.\\([0-9]+\\)"
+ nil t)
+ (cons (string-to-number (match-string 1))
+ (string-to-number (match-string 2))))))
+ "*Version of `cvs' installed on your system.
+It must be in the (MAJOR . MINOR) format.")
+
+;; FIXME: this is only used by cvs-mode-diff-backup
+(defvar cvs-diff-program (or (and (boundp 'diff-command) diff-command) "diff")
+ "*Name or full path of the best diff program you've got.
+NOTE: there are some nasty bugs in the context diff variants of some vendor
+versions, such as the one in SunOS-4.")
+
+;;;; END OF THINGS TO CHECK WHEN INSTALLING
+;;;; --------------------------------------------------------
+
+;;;;
+;;;; User configuration variables:
+;;;;
+;;;; NOTE: these should be set in your ~/.emacs (or site-lisp/default.el) file.
+;;;;
+
+(defgroup pcl-cvs nil
+ "Special support for the CVS versioning system."
+ :version "21.1"
+ :group 'tools
+ :prefix "cvs-")
+
+;;
+;; cvsrc options
+;;
+
+(defcustom cvs-cvsrc-file (convert-standard-filename "~/.cvsrc")
+ "Path to your cvsrc file."
+ :group 'pcl-cvs
+ :type '(file))
+
+(defvar cvs-shared-start 4
+ "Index of the first shared flag.
+If set to 4, for instance, a numeric argument smaller than 4 will
+select a non-shared flag, while a numeric argument greater than 3
+will select a shared-flag.")
+
+(defvar cvs-shared-flags (make-list cvs-shared-start nil)
+ "List of flags whose settings is shared among several commands.")
+
+(defvar cvs-cvsroot nil
+ "*Specifies where the (current) cvs master repository is.
+Overrides the environment variable $CVSROOT by sending \" -d dir\" to
+all CVS commands. This switch is useful if you have multiple CVS
+repositories. It can be set interactively with \\[cvs-change-cvsroot.]
+There is no need to set this if $CVSROOT is set to a correct value.")
+
+(defcustom cvs-auto-remove-handled nil
+ "If up-to-date files should be acknowledged automatically.
+If T, they will be removed from the *cvs* buffer after every command.
+If DELAYED, they will be removed from the *cvs* buffer before every command.
+If STATUS, they will only be removed after a `cvs-mode-status' command.
+Else, they will never be automatically removed from the *cvs* buffer."
+ :group 'pcl-cvs
+ :type '(choice (const nil) (const status) (const delayed) (const t)))
+
+(defcustom cvs-auto-remove-directories 'handled
+ "If ALL, directory entries will never be shown.
+If HANDLED, only non-handled directories will be shown.
+If EMPTY, only non-empty directories will be shown."
+ :group 'pcl-cvs
+ :type '(choice (const :tag "No" nil) (const all) (const handled) (const empty)))
+
+(defcustom cvs-auto-revert t
+ "Non-nil if changed files should automatically be reverted."
+ :group 'pcl-cvs
+ :type '(boolean))
+
+(defcustom cvs-sort-ignore-file t
+ "Non-nil if `cvs-mode-ignore' should sort the .cvsignore automatically."
+ :group 'pcl-cvs
+ :type '(boolean))
+
+(defcustom cvs-force-dir-tag t
+ "If non-nil, tagging can only be applied to directories.
+Tagging should generally be applied a directory at a time, but sometimes it is
+useful to be able to tag a single file. The normal way to do that is to use
+`cvs-mode-force-command' so as to temporarily override the restrictions,"
+ :group 'pcl-cvs
+ :type '(boolean))
+
+(defcustom cvs-default-ignore-marks nil
+ "Non-nil if cvs mode commands should ignore any marked files.
+Normally they run on the files that are marked (with `cvs-mode-mark'),
+or the file under the cursor if no files are marked. If this variable
+is set to a non-nil value they will by default run on the file on the
+current line. See also `cvs-invert-ignore-marks'"
+ :group 'pcl-cvs
+ :type '(boolean))
+
+(defvar cvs-diff-ignore-marks t)
+(make-obsolete-variable 'cvs-diff-ignore-marks
+ 'cvs-invert-ignore-marks
+ "21.1")
+
+(defcustom cvs-invert-ignore-marks
+ (let ((l ()))
+ (unless (equal cvs-diff-ignore-marks cvs-default-ignore-marks)
+ (push "diff" l))
+ (when (and cvs-force-dir-tag (not cvs-default-ignore-marks))
+ (push "tag" l))
+ l)
+ "List of cvs commands that invert the default ignore-mark behavior.
+Commands in this set will use the opposite default from the one set
+in `cvs-default-ignore-marks'."
+ :group 'pcl-cvs
+ :type '(set (const "diff")
+ (const "tag")
+ (const "ignore")))
+
+(defcustom cvs-confirm-removals t
+ "Ask for confirmation before removing files.
+Non-nil means that PCL-CVS will ask confirmation before removing files
+except for files whose content can readily be recovered from the repository.
+A value of `list' means that the list of files to be deleted will be
+displayed when asking for confirmation."
+ :group 'pcl-cvs
+ :type '(choice (const list)
+ (const t)
+ (const nil)))
+
+(defcustom cvs-add-default-message nil
+ "Default message to use when adding files.
+If set to nil, `cvs-mode-add' will always prompt for a message."
+ :group 'pcl-cvs
+ :type '(choice (const :tag "Prompt" nil)
+ (string)))
+
+(defvar cvs-diff-buffer-name "*cvs-diff*")
+(make-obsolete-variable 'cvs-diff-buffer-name
+ 'cvs-buffer-name-alist
+ "21.1")
+
+(defcustom cvs-find-file-and-jump nil
+ "Jump to the modified area when finding a file.
+If non-nil, `cvs-mode-file-file' will place the cursor at the beginning of
+the modified area. If the file is not locally modified, this will obviously
+have no effect."
+ :group 'pcl-cvs
+ :type '(boolean))
+
+(defcustom cvs-buffer-name-alist
+ '(("diff" cvs-diff-buffer-name diff-mode)
+ ("status" "*cvs-info*" cvs-status-mode)
+ ("tree" "*cvs-info*" cvs-status-mode)
+ ("message" "*cvs-commit*" nil log-edit)
+ ("log" "*cvs-info*" log-view-mode))
+ "Buffer name and mode to be used for each command.
+This is a list of elements of the form
+
+ (CMD BUFNAME MODE &optional POSTPROC)
+
+CMD is the name of the command.
+BUFNAME is an expression that should evaluate to a string used as
+ a buffer name. It can use the variable CMD if it wants to.
+MODE is the command to use to setup the buffer.
+POSTPROC is a function that should be executed when the command terminates
+
+The CMD used for `cvs-mode-commit' is \"message\". For that special
+ case, POSTPROC is called just after MODE with special arguments."
+ :group 'pcl-cvs
+ :type '(repeat
+ (list (choice (const "diff")
+ (const "status")
+ (const "tree")
+ (const "message")
+ (const "log")
+ (string))
+ (choice (const "*vc-diff*")
+ (const "*cvs-info*")
+ (const "*cvs-commit*")
+ (const (expand-file-name "*cvs-commit*"))
+ (const (format "*cvs-%s*" cmd))
+ (const (expand-file-name (format "*cvs-%s*" cmd)))
+ (sexp :value "my-cvs-info-buffer")
+ (const nil))
+ (choice (function-item diff-mode)
+ (function-item cvs-edit-mode)
+ (function-item cvs-status-mode)
+ function
+ (const nil))
+ (set :inline t
+ (choice (function-item cvs-status-cvstrees)
+ (function-item cvs-status-trees)
+ function)))))
+
+(defvar cvs-buffer-name '(expand-file-name "*cvs*" dir) ;; "*cvs*"
+ "Name of the cvs buffer.
+This expression will be evaluated in an environment where DIR is set to
+the directory name of the cvs buffer.")
+
+(defvar cvs-temp-buffer-name
+ ;; Was '(expand-file-name " *cvs-tmp*" dir), but that causes them to
+ ;; become non-hidden if uniquification is done `forward'.
+ " *cvs-tmp*"
+ "*Name of the cvs temporary buffer.
+Output from cvs is placed here for asynchronous commands.")
+
+(defcustom cvs-idiff-imerge-handlers
+ (if (fboundp 'ediff)
+ '(cvs-ediff-diff . cvs-ediff-merge)
+ '(cvs-emerge-diff . cvs-emerge-merge))
+ "Pair of functions to be used for resp. diff'ing and merg'ing interactively."
+ :group 'pcl-cvs
+ :type '(choice (const :tag "Ediff" (cvs-ediff-diff . cvs-ediff-merge))
+ (const :tag "Emerge" (cvs-emerge-diff . cvs-emerge-merge))))
+
+(defvar cvs-mode-hook nil
+ "Run after `cvs-mode' was setup.")
+
+\f
+;;;;
+;;;; Internal variables, used in the process buffer.
+;;;;
+
+(defvar cvs-postprocess nil
+ "(Buffer local) what to do once the process exits.")
+
+;;;;
+;;;; Internal variables for the *cvs* buffer.
+;;;;
+
+(defcustom cvs-reuse-cvs-buffer 'subdir
+ "When to reuse an existing cvs buffer.
+Alternatives are:
+ CURRENT: just reuse the current buffer if it is a cvs buffer
+ SAMEDIR: reuse any cvs buffer displaying the same directory
+ SUBDIR: or reuse any cvs buffer displaying any sub- or super- directory
+ ALWAYS: reuse any cvs buffer."
+ :group 'pcl-cvs
+ :type '(choice (const always) (const subdir) (const samedir) (const current)))
+
+(defvar cvs-temp-buffer nil
+ "(Buffer local) The temporary buffer associated with this *cvs* buffer.")
+
+(defvar cvs-lock-file nil
+ "Full path to a lock file that CVS is waiting for (or was waiting for).
+This variable is buffer local and only used in the *cvs* buffer.")
+
+(defvar cvs-lock-file-regexp "^#cvs\\.\\([trw]fl\\.[-.a-z0-9]+\\|lock\\)\\'"
+ "Regexp matching the possible names of locks in the CVS repository.")
+
+(defconst cvs-cursor-column 22
+ "Column to position cursor in in `cvs-mode'.")
+
+;;;;
+;;;; Global internal variables
+;;;;
+
+(defconst cvs-vendor-branch "1.1.1"
+ "The default branch used by CVS for vendor code.")
+
+(easy-mmode-defmap cvs-mode-diff-map
+ '(("E" "imerge" . cvs-mode-imerge)
+ ("=" . cvs-mode-diff)
+ ("e" "idiff" . cvs-mode-idiff)
+ ("2" "other" . cvs-mode-idiff-other)
+ ("d" "diff" . cvs-mode-diff)
+ ("b" "backup" . cvs-mode-diff-backup)
+ ("h" "head" . cvs-mode-diff-head)
+ ("r" "repository" . cvs-mode-diff-repository)
+ ("y" "yesterday" . cvs-mode-diff-yesterday)
+ ("v" "vendor" . cvs-mode-diff-vendor))
+ "Keymap for diff-related operations in `cvs-mode'."
+ :name "Diff")
+;; This is necessary to allow correct handling of \\[cvs-mode-diff-map]
+;; in substitute-command-keys.
+(fset 'cvs-mode-diff-map cvs-mode-diff-map)
+
+(easy-mmode-defmap cvs-mode-map
+ ;;(define-prefix-command 'cvs-mode-map-diff-prefix)
+ ;;(define-prefix-command 'cvs-mode-map-control-c-prefix)
+ '(;; various
+ ;; (undo . cvs-mode-undo)
+ ("?" . cvs-help)
+ ("h" . cvs-help)
+ ("q" . cvs-bury-buffer)
+ ("z" . kill-this-buffer)
+ ("F" . cvs-mode-set-flags)
+ ;; ("\M-f" . cvs-mode-force-command)
+ ("!" . cvs-mode-force-command)
+ ("\C-c\C-c" . cvs-mode-kill-process)
+ ;; marking
+ ("m" . cvs-mode-mark)
+ ("M" . cvs-mode-mark-all-files)
+ ("S" . cvs-mode-mark-on-state)
+ ("u" . cvs-mode-unmark)
+ ("\C-?". cvs-mode-unmark-up)
+ ("%" . cvs-mode-mark-matching-files)
+ ("T" . cvs-mode-toggle-marks)
+ ("\M-\C-?" . cvs-mode-unmark-all-files)
+ ;; navigation keys
+ (" " . cvs-mode-next-line)
+ ("n" . cvs-mode-next-line)
+ ("p" . cvs-mode-previous-line)
+ ("\t" . cvs-mode-next-line)
+ ([backtab] . cvs-mode-previous-line)
+ ;; M- keys are usually those that operate on modules
+ ;;("\M-C". cvs-mode-rcs2log) ; i.e. "Create a ChangeLog"
+ ;;("\M-t". cvs-rtag)
+ ;;("\M-l". cvs-rlog)
+ ("\M-c". cvs-checkout)
+ ("\M-e". cvs-examine)
+ ("g" . cvs-mode-revert-buffer)
+ ("\M-u". cvs-update)
+ ("\M-s". cvs-status)
+ ;; diff commands
+ ("=" . cvs-mode-diff)
+ ("d" . cvs-mode-diff-map)
+ ;; keys that operate on individual files
+ ("\C-k" . cvs-mode-acknowledge)
+ ("A" . cvs-mode-add-change-log-entry-other-window)
+ ;;("B" . cvs-mode-byte-compile-files)
+ ("C" . cvs-mode-commit-setup)
+ ("O" . cvs-mode-update)
+ ("U" . cvs-mode-undo)
+ ("I" . cvs-mode-insert)
+ ("a" . cvs-mode-add)
+ ("b" . cvs-set-branch-prefix)
+ ("B" . cvs-set-secondary-branch-prefix)
+ ("c" . cvs-mode-commit)
+ ("e" . cvs-mode-examine)
+ ("f" . cvs-mode-find-file)
+ ("\C-m" . cvs-mode-find-file)
+ ("i" . cvs-mode-ignore)
+ ("l" . cvs-mode-log)
+ ("o" . cvs-mode-find-file-other-window)
+ ("r" . cvs-mode-remove)
+ ("s" . cvs-mode-status)
+ ("t" . cvs-mode-tag)
+ ("v" . cvs-mode-view-file)
+ ("x" . cvs-mode-remove-handled)
+ ;; cvstree bindings
+ ("+" . cvs-mode-tree)
+ ;; mouse bindings
+ ([mouse-2] . cvs-mode-find-file)
+ ([follow-link] . (lambda (pos)
+ (if (eq (get-char-property pos 'face) 'cvs-filename) t)))
+ ([(down-mouse-3)] . cvs-menu)
+ ;; dired-like bindings
+ ("\C-o" . cvs-mode-display-file)
+ ;; Emacs-21 toolbar
+ ;;([tool-bar item1] . (menu-item "Examine" cvs-examine :image (image :file "/usr/share/icons/xpaint.xpm" :type xpm)))
+ ;;([tool-bar item2] . (menu-item "Update" cvs-update :image (image :file "/usr/share/icons/mail1.xpm" :type xpm)))
+ )
+ "Keymap for `cvs-mode'."
+ :dense t
+ :suppress t)
+
+(fset 'cvs-mode-map cvs-mode-map)
+
+(easy-menu-define cvs-menu cvs-mode-map "Menu used in `cvs-mode'."
+ '("CVS"
+ ["Open file" cvs-mode-find-file t]
+ ["Open in other window" cvs-mode-find-file-other-window t]
+ ["Display in other window" cvs-mode-display-file t]
+ ["Interactive merge" cvs-mode-imerge t]
+ ("View diff"
+ ["Interactive diff" cvs-mode-idiff t]
+ ["Current diff" cvs-mode-diff t]
+ ["Diff with head" cvs-mode-diff-head t]
+ ["Diff with vendor" cvs-mode-diff-vendor t]
+ ["Diff against yesterday" cvs-mode-diff-yesterday t]
+ ["Diff with backup" cvs-mode-diff-backup t])
+ ["View log" cvs-mode-log t]
+ ["View status" cvs-mode-status t]
+ ["View tag tree" cvs-mode-tree t]
+ "----"
+ ["Insert" cvs-mode-insert]
+ ["Update" cvs-mode-update (cvs-enabledp 'update)]
+ ["Re-examine" cvs-mode-examine t]
+ ["Commit" cvs-mode-commit-setup (cvs-enabledp 'commit)]
+ ["Tag" cvs-mode-tag (cvs-enabledp (when cvs-force-dir-tag 'tag))]
+ ["Undo changes" cvs-mode-undo (cvs-enabledp 'undo)]
+ ["Add" cvs-mode-add (cvs-enabledp 'add)]
+ ["Remove" cvs-mode-remove (cvs-enabledp 'remove)]
+ ["Ignore" cvs-mode-ignore (cvs-enabledp 'ignore)]
+ ["Add ChangeLog" cvs-mode-add-change-log-entry-other-window t]
+ "----"
+ ["Mark" cvs-mode-mark t]
+ ["Mark all" cvs-mode-mark-all-files t]
+ ["Mark by regexp..." cvs-mode-mark-matching-files t]
+ ["Mark by state..." cvs-mode-mark-on-state t]
+ ["Unmark" cvs-mode-unmark t]
+ ["Unmark all" cvs-mode-unmark-all-files t]
+ ["Hide handled" cvs-mode-remove-handled t]
+ "----"
+ ["PCL-CVS Manual" (lambda () (interactive)
+ (info "(pcl-cvs)Top")) t]
+ "----"
+ ["Quit" cvs-mode-quit t]))
+
+;;;;
+;;;; CVS-Minor mode
+;;;;
+
+(defcustom cvs-minor-mode-prefix "\C-xc"
+ "Prefix key for the `cvs-mode' bindings in `cvs-minor-mode'."
+ :group 'pcl-cvs)
+
+(easy-mmode-defmap cvs-minor-mode-map
+ `((,cvs-minor-mode-prefix . cvs-mode-map)
+ ("e" . (menu-item nil cvs-mode-edit-log
+ :filter (lambda (x) (if (derived-mode-p 'log-view-mode) x)))))
+ "Keymap for `cvs-minor-mode', used in buffers related to PCL-CVS.")
+
+(defvar cvs-buffer nil
+ "(Buffer local) The *cvs* buffer associated with this buffer.")
+(put 'cvs-buffer 'permanent-local t)
+;;(make-variable-buffer-local 'cvs-buffer)
+
+(defvar cvs-minor-wrap-function nil
+ "Function to call when switching to the *cvs* buffer.
+Takes two arguments:
+- a *cvs* buffer.
+- a zero-arg function which is guaranteed not to switch buffer.
+It is expected to call the function.")
+;;(make-variable-buffer-local 'cvs-minor-wrap-function)
+
+(defvar cvs-minor-current-files)
+;;"Current files in a `cvs-minor-mode' buffer."
+;; This should stay `void' because we want to be able to tell the difference
+;; between an empty list and no list at all.
+
+(defconst cvs-pcl-cvs-dirchange-re "^pcl-cvs: descending directory \\(.*\\)$")
+
+;;;;
+;;;; autoload the global menu
+;;;;
+
+;;;###autoload
+(defvar cvs-global-menu
+ (let ((m (make-sparse-keymap "PCL-CVS")))
+ (define-key m [status]
+ `(menu-item ,(purecopy "Directory Status") cvs-status
+ :help ,(purecopy "A more verbose status of a workarea")))
+ (define-key m [checkout]
+ `(menu-item ,(purecopy "Checkout Module") cvs-checkout
+ :help ,(purecopy "Check out a module from the repository")))
+ (define-key m [update]
+ `(menu-item ,(purecopy "Update Directory") cvs-update
+ :help ,(purecopy "Fetch updates from the repository")))
+ (define-key m [examine]
+ `(menu-item ,(purecopy "Examine Directory") cvs-examine
+ :help ,(purecopy "Examine the current state of a workarea")))
+ (fset 'cvs-global-menu m)))
+
+
+;; cvs-1.10 and above can take file arguments in other directories
+;; while others need to be executed once per directory
+(defvar cvs-execute-single-dir
+ (if (or (null cvs-version)
+ (or (>= (cdr cvs-version) 10) (> (car cvs-version) 1)))
+ ;; Supposedly some recent versions of CVS output some directory info
+ ;; as they recurse downthe tree, but it's not good enough in the case
+ ;; where we run "cvs status foo bar/foo".
+ '("status")
+ t)
+ "Whether cvs commands should be executed a directory at a time.
+If a list, specifies for which commands the single-dir mode should be used.
+If T, single-dir mode should be used for all operations.
+
+CVS versions before 1.10 did not allow passing them arguments in different
+directories, so pcl-cvs checks what version you're using to determine
+whether to use the new feature or not.
+Sadly, even with a new cvs executable, if you connect to an older cvs server
+\(typically a cvs-1.9 on the server), the old restriction applies. In such
+a case the sanity check made by pcl-cvs fails and you will have to manually
+set this variable to t (until the cvs server is upgraded).
+When the above problem occurs, pcl-cvs should (hopefully) catch cvs' error
+message and replace it with a message telling you to change this variable.")
+
+;;
+(provide 'pcvs-defs)
+
+;; arch-tag: c7c701d0-d1d4-4aa9-a302-007bb03aca5e
+;;; pcvs-defs.el ends here
--- /dev/null
- ;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;;; 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, 2011
+;; Free Software Foundation, Inc.
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; Keywords: pcl-cvs
+;; Package: pcvs
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; The cvs-fileinfo data structure:
+;;
+;; When the `cvs update' is ready we parse the output. Every file
+;; that is affected in some way is added to the cookie collection as
+;; a "fileinfo" (as defined below in cvs-create-fileinfo).
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+(require 'pcvs-util)
+;;(require 'pcvs-defs)
+
+;;;;
+;;;; config variables
+;;;;
+
+(define-obsolete-variable-alias 'cvs-display-full-path
+ 'cvs-display-full-name "22.1")
+
+(defcustom cvs-display-full-name t
+ "Specifies how the filenames should be displayed in the listing.
+If non-nil, their full filename name will be displayed, else only the
+non-directory part."
+ :group 'pcl-cvs
+ :type '(boolean))
+
+(defcustom cvs-allow-dir-commit nil
+ "Allow `cvs-mode-commit' on directories.
+If you commit without any marked file and with the cursor positioned
+on a directory entry, cvs would commit the whole directory. This seems
+to confuse some users sometimes."
+ :group 'pcl-cvs
+ :type '(boolean))
+
+;;;;
+;;;; Faces for fontification
+;;;;
+
+(defface cvs-header
+ '((((class color) (background dark))
+ (:foreground "lightyellow" :weight bold))
+ (((class color) (background light))
+ (:foreground "blue4" :weight bold))
+ (t (:weight bold)))
+ "PCL-CVS face used to highlight directory changes."
+ :group 'pcl-cvs)
+(define-obsolete-face-alias 'cvs-header-face 'cvs-header "22.1")
+
+(defface cvs-filename
+ '((((class color) (background dark))
+ (:foreground "lightblue"))
+ (((class color) (background light))
+ (:foreground "blue4"))
+ (t ()))
+ "PCL-CVS face used to highlight file names."
+ :group 'pcl-cvs)
+(define-obsolete-face-alias 'cvs-filename-face 'cvs-filename "22.1")
+
+(defface cvs-unknown
+ '((((class color) (background dark))
+ (:foreground "red1"))
+ (((class color) (background light))
+ (:foreground "red1"))
+ (t (:slant italic)))
+ "PCL-CVS face used to highlight unknown file status."
+ :group 'pcl-cvs)
+(define-obsolete-face-alias 'cvs-unknown-face 'cvs-unknown "22.1")
+
+(defface cvs-handled
+ '((((class color) (background dark))
+ (:foreground "pink"))
+ (((class color) (background light))
+ (:foreground "pink"))
+ (t ()))
+ "PCL-CVS face used to highlight handled file status."
+ :group 'pcl-cvs)
+(define-obsolete-face-alias 'cvs-handled-face 'cvs-handled "22.1")
+
+(defface cvs-need-action
+ '((((class color) (background dark))
+ (:foreground "orange"))
+ (((class color) (background light))
+ (:foreground "orange"))
+ (t (:slant italic)))
+ "PCL-CVS face used to highlight status of files needing action."
+ :group 'pcl-cvs)
+(define-obsolete-face-alias 'cvs-need-action-face 'cvs-need-action "22.1")
+
+(defface cvs-marked
+ '((((min-colors 88) (class color) (background dark))
+ (:foreground "green1" :weight bold))
+ (((class color) (background dark))
+ (:foreground "green" :weight bold))
+ (((class color) (background light))
+ (:foreground "green3" :weight bold))
+ (t (:weight bold)))
+ "PCL-CVS face used to highlight marked file indicator."
+ :group 'pcl-cvs)
+(define-obsolete-face-alias 'cvs-marked-face 'cvs-marked "22.1")
+
+(defface cvs-msg
+ '((t (:slant italic)))
+ "PCL-CVS face used to highlight CVS messages."
+ :group 'pcl-cvs)
+(define-obsolete-face-alias 'cvs-msg-face 'cvs-msg "22.1")
+
+(defvar cvs-fi-up-to-date-face 'cvs-handled)
+(defvar cvs-fi-unknown-face 'cvs-unknown)
+(defvar cvs-fi-conflict-face 'font-lock-warning-face)
+
+;; There is normally no need to alter the following variable, but if
+;; your site has installed CVS in a non-standard way you might have
+;; to change it.
+
+(defvar cvs-bakprefix ".#"
+ "The prefix that CVS prepends to files when rcsmerge'ing.")
+
+(easy-mmode-defmap cvs-status-map
+ '(([(mouse-2)] . cvs-mode-toggle-mark))
+ "Local keymap for text properties of status")
+
+;; Constructor:
+
+(defstruct (cvs-fileinfo
+ (:constructor nil)
+ (:copier nil)
+ (:constructor -cvs-create-fileinfo (type dir file full-log
+ &key marked subtype
+ merge
+ base-rev
+ head-rev))
+ (:conc-name cvs-fileinfo->))
+ marked ;; t/nil.
+ type ;; See below
+ subtype ;; See below
+ dir ;; Relative directory the file resides in.
+ ;; (concat dir file) should give a valid path.
+ file ;; The file name sans the directory.
+ base-rev ;; During status: This is the revision that the
+ ;; working file is based on.
+ head-rev ;; During status: This is the highest revision in
+ ;; the repository.
+ merge ;; A cons cell containing the (ancestor . head) revisions
+ ;; of the merge that resulted in the current file.
+ ;;removed ;; t if the file no longer exists.
+ full-log ;; The output from cvs, unparsed.
+ ;;mod-time ;; Not used.
+
+ ;; In addition to the above, the following values can be extracted:
+
+ ;; handled ;; t if this file doesn't require further action.
+ ;; full-name ;; The complete relative filename.
+ ;; pp-name ;; The printed file name
+ ;; backup-file;; For MERGED and CONFLICT files after a \"cvs update\",
+ ;; this is a full path to the backup file where the
+ ;; untouched version resides.
+
+ ;; The meaning of the type field:
+
+ ;; Value ---Used by--- Explanation
+ ;; update status
+ ;; NEED-UPDATE x file needs update
+ ;; MODIFIED x x modified by you, unchanged in repository
+ ;; MERGED x x successful merge
+ ;; ADDED x x added by you, not yet committed
+ ;; MISSING x rm'd, but not yet `cvs remove'd
+ ;; REMOVED x x removed by you, not yet committed
+ ;; NEED-MERGE x need merge
+ ;; CONFLICT x conflict when merging
+ ;; ;;MOD-CONFLICT x removed locally, changed in repository.
+ ;; DIRCHANGE x x A change of directory.
+ ;; UNKNOWN x An unknown file.
+ ;; UP-TO-DATE x The file is up-to-date.
+ ;; UPDATED x x file copied from repository
+ ;; PATCHED x x diff applied from repository
+ ;; COMMITTED x x cvs commit'd
+ ;; DEAD An entry that should be removed
+ ;; MESSAGE x x This is a special fileinfo that is used
+ ;; to display a text that should be in
+ ;; full-log."
+ ;; TEMP A temporary message that should be removed
+ )
+(defun cvs-create-fileinfo (type dir file msg &rest keys)
+ (cvs-check-fileinfo (apply #'-cvs-create-fileinfo type dir file msg keys)))
+
+;; Fake selectors:
+
+(defun cvs-fileinfo->full-name (fileinfo)
+ "Return the full path for the file that is described in FILEINFO."
+ (let ((dir (cvs-fileinfo->dir fileinfo)))
+ (if (eq (cvs-fileinfo->type fileinfo) 'DIRCHANGE)
+ (if (string= dir "") "." (directory-file-name dir))
+ ;; Here, I use `concat' rather than `expand-file-name' because I want
+ ;; the resulting path to stay relative if `dir' is relative.
+ (concat dir (cvs-fileinfo->file fileinfo)))))
+(define-obsolete-function-alias 'cvs-fileinfo->full-path
+ 'cvs-fileinfo->full-name "22.1")
+
+(defun cvs-fileinfo->pp-name (fi)
+ "Return the filename of FI as it should be displayed."
+ (if cvs-display-full-name
+ (cvs-fileinfo->full-name fi)
+ (cvs-fileinfo->file fi)))
+
+(defun cvs-fileinfo->backup-file (fileinfo)
+ "Construct the file name of the backup file for FILEINFO."
+ (let* ((dir (cvs-fileinfo->dir fileinfo))
+ (file (cvs-fileinfo->file fileinfo))
+ (default-directory (file-name-as-directory (expand-file-name dir)))
+ (files (directory-files "." nil
+ (concat "\\`" (regexp-quote cvs-bakprefix)
+ (regexp-quote file) "\\(\\.[0-9]+\\.[0-9]+\\)+\\'")))
+ bf)
+ (dolist (f files)
+ (when (and (file-readable-p f)
+ (or (null bf) (file-newer-than-file-p f bf)))
+ (setq bf f)))
+ (concat dir bf)))
+
+;; (defun cvs-fileinfo->handled (fileinfo)
+;; "Tell if this requires further action"
+;; (memq (cvs-fileinfo->type fileinfo) '(UP-TO-DATE DEAD)))
+
+\f
+;; Predicate:
+
+(defun cvs-check-fileinfo (fi)
+ "Check FI's conformance to some conventions."
+ (let ((check 'none)
+ (type (cvs-fileinfo->type fi))
+ (subtype (cvs-fileinfo->subtype fi))
+ (marked (cvs-fileinfo->marked fi))
+ (dir (cvs-fileinfo->dir fi))
+ (file (cvs-fileinfo->file fi))
+ (base-rev (cvs-fileinfo->base-rev fi))
+ (head-rev (cvs-fileinfo->head-rev fi))
+ (full-log (cvs-fileinfo->full-log fi)))
+ (if (and (setq check 'marked) (memq marked '(t nil))
+ (setq check 'base-rev) (or (null base-rev) (stringp base-rev))
+ (setq check 'head-rev) (or (null head-rev) (stringp head-rev))
+ (setq check 'full-log) (stringp full-log)
+ (setq check 'dir)
+ (and (stringp dir)
+ (not (file-name-absolute-p dir))
+ (or (string= dir "")
+ (string= dir (file-name-as-directory dir))))
+ (setq check 'file)
+ (and (stringp file)
+ (string= file (file-name-nondirectory file)))
+ (setq check 'type) (symbolp type)
+ (setq check 'consistency)
+ (case type
+ (DIRCHANGE (and (null subtype) (string= "." file)))
+ ((NEED-UPDATE ADDED MISSING DEAD MODIFIED MESSAGE UP-TO-DATE
+ REMOVED NEED-MERGE CONFLICT UNKNOWN MESSAGE)
+ t)))
+ fi
+ (error "Invalid :%s in cvs-fileinfo %s" check fi))))
+
+\f
+;;;;
+;;;; State table to indicate what you can do when.
+;;;;
+
+(defconst cvs-states
+ `((NEED-UPDATE update diff ignore)
+ (UP-TO-DATE update nil remove diff safe-rm revert)
+ (MODIFIED update commit undo remove diff merge diff-base)
+ (ADDED update commit remove)
+ (MISSING remove undo update safe-rm revert)
+ (REMOVED commit add undo safe-rm)
+ (NEED-MERGE update undo diff diff-base)
+ (CONFLICT merge remove undo commit diff diff-base)
+ (DIRCHANGE remove update diff ,(if cvs-allow-dir-commit 'commit) tag)
+ (UNKNOWN ignore add remove)
+ (DEAD )
+ (MESSAGE))
+ "Fileinfo state descriptions for pcl-cvs.
+This is an assoc list. Each element consists of (STATE . FUNS)
+- STATE (described in `cvs-create-fileinfo') is the key
+- FUNS is the list of applicable operations.
+ The first one (if any) should be the \"default\" action.
+Most of the actions have the obvious meaning.
+`safe-rm' indicates that the file can be removed without losing
+ any information.")
+
+;;;;
+;;;; Utility functions
+;;;;
+
+(defun cvs-applicable-p (fi-or-type func)
+ "Check if FUNC is applicable to FI-OR-TYPE.
+If FUNC is nil, always return t.
+FI-OR-TYPE can either be a symbol (a fileinfo-type) or a fileinfo."
+ (let ((type (if (symbolp fi-or-type) fi-or-type
+ (cvs-fileinfo->type fi-or-type))))
+ (and (not (eq type 'MESSAGE))
+ (eq (car (memq func (cdr (assq type cvs-states)))) func))))
+
+(defun cvs-add-face (str face &optional keymap &rest props)
+ (when keymap
+ (when (keymapp keymap)
+ (setq props (list* 'keymap keymap props)))
+ (setq props (list* 'mouse-face 'highlight props)))
+ (add-text-properties 0 (length str) (list* 'font-lock-face face props) str)
+ str)
+
+(defun cvs-fileinfo-pp (fileinfo)
+ "Pretty print FILEINFO. Insert a printed representation in current buffer.
+For use by the cookie package."
+ (cvs-check-fileinfo fileinfo)
+ (let ((type (cvs-fileinfo->type fileinfo))
+ (subtype (cvs-fileinfo->subtype fileinfo)))
+ (insert
+ (case type
+ (DIRCHANGE (concat "In directory "
+ (cvs-add-face (cvs-fileinfo->full-name fileinfo)
+ 'cvs-header t 'cvs-goal-column t)
+ ":"))
+ (MESSAGE
+ (cvs-add-face (format "Message: %s" (cvs-fileinfo->full-log fileinfo))
+ 'cvs-msg))
+ (t
+ (let* ((status (if (cvs-fileinfo->marked fileinfo)
+ (cvs-add-face "*" 'cvs-marked)
+ " "))
+ (file (cvs-add-face (cvs-fileinfo->pp-name fileinfo)
+ 'cvs-filename t 'cvs-goal-column t))
+ (base (or (cvs-fileinfo->base-rev fileinfo) ""))
+ (head (cvs-fileinfo->head-rev fileinfo))
+ (type
+ (let ((str (case type
+ ;;(MOD-CONFLICT "Not Removed")
+ (DEAD "")
+ (t (capitalize (symbol-name type)))))
+ (face (let ((sym (intern
+ (concat "cvs-fi-"
+ (downcase (symbol-name type))
+ "-face"))))
+ (or (and (boundp sym) (symbol-value sym))
+ 'cvs-need-action))))
+ (cvs-add-face str face cvs-status-map)))
+ (side (or
+ ;; maybe a subtype
+ (when subtype (downcase (symbol-name subtype)))
+ ;; or the head-rev
+ (when (and head (not (string= head base))) head)
+ ;; or nothing
+ "")))
+ (format "%-11s %s %-11s %-11s %s"
+ side status type base file))))
+ "\n")))
+
+
+(defun cvs-fileinfo-update (fi fi-new)
+ "Update FI with the information provided in FI-NEW."
+ (let ((type (cvs-fileinfo->type fi-new))
+ (merge (cvs-fileinfo->merge fi-new)))
+ (setf (cvs-fileinfo->type fi) type)
+ (setf (cvs-fileinfo->subtype fi) (cvs-fileinfo->subtype fi-new))
+ (setf (cvs-fileinfo->full-log fi) (cvs-fileinfo->full-log fi-new))
+ (setf (cvs-fileinfo->base-rev fi) (cvs-fileinfo->base-rev fi-new))
+ (setf (cvs-fileinfo->head-rev fi) (cvs-fileinfo->head-rev fi-new))
+ (cond
+ (merge (setf (cvs-fileinfo->merge fi) merge))
+ ((memq type '(UP-TO-DATE NEED-UPDATE))
+ (setf (cvs-fileinfo->merge fi) nil)))))
+
+(defun cvs-fileinfo< (a b)
+ "Compare fileinfo A with fileinfo B and return t if A is `less'.
+The ordering defined by this function is such that directories are
+sorted alphabetically, and inside every directory the DIRCHANGE
+fileinfo will appear first, followed by all files (alphabetically)."
+ (let ((subtypea (cvs-fileinfo->subtype a))
+ (subtypeb (cvs-fileinfo->subtype b)))
+ (cond
+ ;; Sort according to directories.
+ ((string< (cvs-fileinfo->dir a) (cvs-fileinfo->dir b)) t)
+ ((not (string= (cvs-fileinfo->dir a) (cvs-fileinfo->dir b))) nil)
+
+ ;; The DIRCHANGE entry is always first within the directory.
+ ((eq (cvs-fileinfo->type b) 'DIRCHANGE) nil)
+ ((eq (cvs-fileinfo->type a) 'DIRCHANGE) t)
+
+ ;; All files are sorted by file name.
+ ((string< (cvs-fileinfo->file a) (cvs-fileinfo->file b))))))
+
+;;;
+;;; Look at CVS/Entries to quickly find a first approximation of the status
+;;;
+
+(defun cvs-fileinfo-from-entries (dir &optional all)
+ "List of fileinfos for DIR, extracted from CVS/Entries.
+Unless ALL is optional, returns only the files that are not up-to-date.
+DIR can also be a file."
+ (let* ((singlefile
+ (cond
+ ((equal dir "") nil)
+ ((file-directory-p dir) (setq dir (file-name-as-directory dir)) nil)
+ (t (prog1 (file-name-nondirectory dir)
+ (setq dir (or (file-name-directory dir) ""))))))
+ (file (expand-file-name "CVS/Entries" dir))
+ (fis nil))
+ (if (not (file-readable-p file))
+ (push (cvs-create-fileinfo (if singlefile 'UNKNOWN 'DIRCHANGE)
+ dir (or singlefile ".") "") fis)
+ (with-temp-buffer
+ (insert-file-contents file)
+ (goto-char (point-min))
+ ;; Select the single file entry in case we're only interested in a file.
+ (cond
+ ((not singlefile)
+ (push (cvs-create-fileinfo 'DIRCHANGE dir "." "") fis))
+ ((re-search-forward
+ (concat "^[^/]*/" (regexp-quote singlefile) "/.*") nil t)
+ (setq all t)
+ (goto-char (match-beginning 0))
+ (narrow-to-region (point) (match-end 0)))
+ (t
+ (push (cvs-create-fileinfo 'UNKNOWN dir singlefile "") fis)
+ (narrow-to-region (point-min) (point-min))))
+ (while (looking-at "\\([^/]*\\)/\\([^/]*\\)/\\([^/]*\\)/\\([^/]*\\)/")
+ (if (/= (match-beginning 1) (match-end 1))
+ (setq fis (append (cvs-fileinfo-from-entries
+ (concat dir (file-name-as-directory
+ (match-string 2)))
+ all)
+ fis))
+ (let ((f (match-string 2))
+ (rev (match-string 3))
+ (date (match-string 4))
+ timestamp
+ (type 'MODIFIED)
+ (subtype nil))
+ (cond
+ ((equal (substring rev 0 1) "-")
+ (setq type 'REMOVED rev (substring rev 1)))
+ ((not (file-exists-p (concat dir f))) (setq type 'MISSING))
+ ((equal rev "0") (setq type 'ADDED rev nil))
+ ((equal date "Result of merge") (setq subtype 'MERGED))
+ ((let ((mtime (nth 5 (file-attributes (concat dir f))))
+ (system-time-locale "C"))
+ (setq timestamp (format-time-string "%c" mtime 'utc))
+ ;; Solaris sometimes uses "Wed Sep 05", not "Wed Sep 5".
+ ;; See "grep '[^a-z_]ctime' cvs/src/*.c" for reference.
+ (if (= (aref timestamp 8) ?0)
+ (setq timestamp (concat (substring timestamp 0 8)
+ " " (substring timestamp 9))))
+ (equal timestamp date))
+ (setq type (if all 'UP-TO-DATE)))
+ ((equal date (concat "Result of merge+" timestamp))
+ (setq type 'CONFLICT)))
+ (when type
+ (push (cvs-create-fileinfo type dir f ""
+ :base-rev rev :subtype subtype)
+ fis))))
+ (forward-line 1))))
+ fis))
+
+(provide 'pcvs-info)
+
+;; arch-tag: d85dde07-bdc2-400a-882f-92f398c7b0ba
+;;; pcvs-info.el ends here
--- /dev/null
- ;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;;; 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, 2011 Free Software Foundation, Inc.
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; Keywords: pcl-cvs
+;; Package: pcvs
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Bugs:
+
+;; - when merging a modified file, if the merge says that the file already
+;; contained in the changes, it marks the file as `up-to-date' although
+;; it might still contain further changes.
+;; Example: merging a zero-change commit.
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+(require 'pcvs-util)
+(require 'pcvs-info)
+
+;; imported from pcvs.el
+(defvar cvs-execute-single-dir)
+
+;; parse vars
+
+(defcustom cvs-update-prog-output-skip-regexp "$"
+ "A regexp that matches the end of the output from all cvs update programs.
+That is, output from any programs that are run by CVS (by the flag -u
+in the `modules' file - see cvs(5)) when `cvs update' is performed should
+terminate with a line that this regexp matches. It is enough that
+some part of the line is matched.
+
+The default (a single $) fits programs without output."
+ :group 'pcl-cvs
+ :type '(regexp :value "$"))
+
+(defcustom cvs-parse-ignored-messages
+ '("Executing ssh-askpass to query the password.*$"
+ ".*Remote host denied X11 forwarding.*$")
+ "A list of regexps matching messages that should be ignored by the parser.
+Each regexp should match a whole set of lines and should hence be terminated
+by `$'."
+ :group 'pcl-cvs
+ :type '(repeat regexp))
+
+;; a few more defvars just to shut up the compiler
+(defvar cvs-start)
+(defvar cvs-current-dir)
+(defvar cvs-current-subdir)
+(defvar dont-change-disc)
+
+;;;; The parser
+
+(defconst cvs-parse-known-commands
+ '("status" "add" "commit" "update" "remove" "checkout" "ci")
+ "List of CVS commands whose output is understood by the parser.")
+
+(defun cvs-parse-buffer (parse-spec dont-change-disc &optional subdir)
+ "Parse current buffer according to PARSE-SPEC.
+PARSE-SPEC is a function of no argument advancing the point and returning
+ either a fileinfo or t (if the matched text should be ignored) or
+ nil if it didn't match anything.
+DONT-CHANGE-DISC just indicates whether the command was changing the disc
+ or not (useful to tell the difference between `cvs-examine' and `cvs-update'
+ output.
+The path names should be interpreted as relative to SUBDIR (defaults
+ to the `default-directory').
+Return a list of collected entries, or t if an error occurred."
+ (goto-char (point-min))
+ (let ((fileinfos ())
+ (cvs-current-dir "")
+ (case-fold-search nil)
+ (cvs-current-subdir (or subdir "")))
+ (while (not (or (eobp) (eq fileinfos t)))
+ (let ((ret (cvs-parse-run-table parse-spec)))
+ (cond
+ ;; it matched a known information message
+ ((cvs-fileinfo-p ret) (push ret fileinfos))
+ ;; it didn't match anything at all (impossible)
+ ((and (consp ret) (cvs-fileinfo-p (car ret)))
+ (setq fileinfos (append ret fileinfos)))
+ ((null ret) (setq fileinfos t))
+ ;; it matched something that should be ignored
+ (t nil))))
+ (nreverse fileinfos)))
+
+
+;; All those parsing macros/functions should return a success indicator
+(defsubst cvs-parse-msg () (buffer-substring cvs-start (1- (point))))
+
+;;(defsubst COLLECT (exp) (push exp *result*))
+;;(defsubst PROG (e) t)
+;;(defmacro SEQ (&rest seqs) (cons 'and seqs))
+
+(defmacro cvs-match (re &rest matches)
+ "Try to match RE and extract submatches.
+If RE matches, advance the point until the line after the match and
+then assign the variables as specified in MATCHES (via `setq')."
+ (cons 'cvs-do-match
+ (cons re (mapcar (lambda (match)
+ `(cons ',(first match) ,(second match)))
+ matches))))
+
+(defun cvs-do-match (re &rest matches)
+ "Internal function for the `cvs-match' macro.
+Match RE and if successful, execute MATCHES."
+ ;; Is it a match?
+ (when (looking-at re)
+ (goto-char (match-end 0))
+ ;; Skip the newline (unless we already are at the end of the buffer).
+ (when (and (eolp) (< (point) (point-max))) (forward-char))
+ ;; assign the matches
+ (dolist (match matches t)
+ (let ((val (cdr match)))
+ (set (car match) (if (integerp val) (match-string val) val))))))
+
+(defmacro cvs-or (&rest alts)
+ "Try each one of the ALTS alternatives until one matches."
+ `(let ((-cvs-parse-point (point)))
+ ,(cons 'or
+ (mapcar (lambda (es)
+ `(or ,es (ignore (goto-char -cvs-parse-point))))
+ alts))))
+(def-edebug-spec cvs-or t)
+
+;; This is how parser tables should be executed
+(defun cvs-parse-run-table (parse-spec)
+ "Run PARSE-SPEC and provide sensible default behavior."
+ (unless (bolp) (forward-line 1)) ;this should never be needed
+ (let ((cvs-start (point)))
+ (cvs-or
+ (funcall parse-spec)
+
+ (dolist (re cvs-parse-ignored-messages)
+ (when (cvs-match re) (return t)))
+
+ ;; This is a parse error. Create a message-type fileinfo.
+ (and
+ (cvs-match ".*$")
+ (cvs-create-fileinfo 'MESSAGE cvs-current-dir " "
+ ;; (concat " Unknown msg: '"
+ (cvs-parse-msg) ;; "'")
+ :subtype 'ERROR)))))
+
+\f
+(defun cvs-parsed-fileinfo (type path &optional directory &rest keys)
+ "Create a fileinfo.
+TYPE can either be a type symbol or a cons of the form (TYPE . SUBTYPE).
+PATH is the filename.
+DIRECTORY influences the way PATH is interpreted:
+- if it's a string, it denotes the directory in which PATH (which should then be
+ a plain file name with no directory component) resides.
+- if it's nil, the PATH should not be trusted: if it has a directory
+ component, use it, else, assume it is relative to the current directory.
+- else, the PATH should be trusted to be relative to the root
+ directory (i.e. if there is no directory component, it means the file
+ is inside the main directory).
+The remaining KEYS are passed directly to `cvs-create-fileinfo'."
+ (let ((dir directory)
+ (file path))
+ ;; only trust the directory if it's a string
+ (unless (stringp directory)
+ ;; else, if the directory is true, the path should be trusted
+ (setq dir (or (file-name-directory path) (if directory "")))
+ (setq file (file-name-nondirectory path)))
+
+ (let ((type (if (consp type) (car type) type))
+ (subtype (if (consp type) (cdr type))))
+ (when dir (setq cvs-current-dir dir))
+ (apply 'cvs-create-fileinfo type
+ (concat cvs-current-subdir (or dir cvs-current-dir))
+ file (cvs-parse-msg) :subtype subtype keys))))
+\f
+;;;; CVS Process Parser Tables:
+;;;;
+;;;; The table for status and update could actually be merged since they
+;;;; don't conflict. But they don't overlap much either.
+
+(defun cvs-parse-table ()
+ "Table of message objects for `cvs-parse-process'."
+ (let (c file dir path base-rev subtype)
+ (cvs-or
+
+ (cvs-parse-status)
+ (cvs-parse-merge)
+ (cvs-parse-commit)
+
+ ;; this is not necessary because the fileinfo merging will remove
+ ;; such duplicate info and luckily the second info is the one we want.
+ ;; (and (cvs-match "M \\(.*\\)$" (path 1))
+ ;; (cvs-parse-merge path))
+
+ ;; Normal file state indicator.
+ (and
+ (cvs-match "\\([MARCUPNJ?]\\) \\(.*\\)$" (c 1) (path 2))
+ ;; M: The file is modified by the user, and untouched in the repository.
+ ;; A: The file is "cvs add"ed, but not "cvs ci"ed.
+ ;; R: The file is "cvs remove"ed, but not "cvs ci"ed.
+ ;; C: Conflict
+ ;; U: The file is copied from the repository.
+ ;; P: The file was patched from the repository.
+ ;; ?: Unknown file.
+ (let ((code (aref c 0)))
+ (cvs-parsed-fileinfo
+ (case code
+ (?M 'MODIFIED)
+ (?A 'ADDED)
+ (?R 'REMOVED)
+ (?? 'UNKNOWN)
+ (?C
+ (if (not dont-change-disc) 'CONFLICT
+ ;; This is ambiguous. We should look for conflict markers in the
+ ;; file to decide between CONFLICT and NEED-MERGE. With CVS-1.10
+ ;; servers, this should not be necessary, because they return
+ ;; a complete merge output.
+ (with-temp-buffer
+ (ignore-errors (insert-file-contents path))
+ (goto-char (point-min))
+ (if (re-search-forward "^<<<<<<< " nil t)
+ 'CONFLICT 'NEED-MERGE))))
+ (?J 'NEED-MERGE) ;not supported by standard CVS
+ ((?U ?P)
+ (if dont-change-disc 'NEED-UPDATE
+ (cons 'UP-TO-DATE (if (eq code ?U) 'UPDATED 'PATCHED)))))
+ path 'trust)))
+
+ (and
+ (cvs-match "pcl-cvs: descending directory \\(.*\\)$" (dir 1))
+ (setq cvs-current-subdir dir))
+
+ ;; A special cvs message
+ (and
+ (let ((case-fold-search t))
+ (cvs-match "cvs[.a-z]* [a-z]+: "))
+ (cvs-or
+
+ ;; CVS is descending a subdirectory
+ ;; (status says `examining' while update says `updating')
+ (and
+ (cvs-match "\\(Examining\\|Updating\\) \\(.*\\)$" (dir 2))
+ (let ((dir (if (string= "." dir) "" (file-name-as-directory dir))))
+ (cvs-parsed-fileinfo 'DIRCHANGE "." dir)))
+
+ ;; [-n update] A new (or pruned) directory appeared but isn't traversed
+ (and
+ (cvs-match "New directory `\\(.*\\)' -- ignored$" (dir 1))
+ ;; (cvs-parsed-fileinfo 'MESSAGE " " (file-name-as-directory dir))
+ ;; These messages either correspond to a true new directory
+ ;; that an update will bring in, or to a directory that's empty
+ ;; on the current branch (either because it only exists in other
+ ;; branches, or because it's been removed).
+ (if (ignore-errors
+ (with-temp-buffer
+ (ignore-errors
+ (insert-file-contents
+ (expand-file-name ".cvsignore" (file-name-directory dir))))
+ (goto-char (point-min))
+ (re-search-forward
+ (concat "^" (regexp-quote (file-name-nondirectory dir)) "/$")
+ nil t)))
+ t ;The user requested to ignore those messages.
+ (cvs-parsed-fileinfo '(NEED-UPDATE . NEW-DIR) dir t)))
+
+ ;; File removed, since it is removed (by third party) in repository.
+ (and
+ (cvs-or
+ ;; some cvs versions output quotes around these files
+ (cvs-match "warning: `\\(.*\\)' is not (any longer) pertinent$" (file 1))
+ (cvs-match "warning: \\(.*\\) is not (any longer) pertinent$" (file 1))
+ (cvs-match "`\\(.*\\)' is no longer in the repository$" (file 1))
+ (cvs-match "\\(.*\\) is no longer in the repository$" (file 1)))
+ (cvs-parsed-fileinfo
+ (if dont-change-disc '(NEED-UPDATE . REMOVED) 'DEAD) file))
+
+ ;; [add]
+ (and
+ (cvs-or
+ (cvs-match "scheduling file `\\(.*\\)' for addition.*$" (path 1))
+ (cvs-match "re-adding file \\(.*\\) (in place of .*)$" (path 1)))
+ (cvs-parsed-fileinfo 'ADDED path))
+
+ ;; [add] this will also show up as a `U <file>'
+ (and
+ (cvs-match "`?\\(.*?\\)'?, version \\(.*\\), resurrected$"
+ (path 1) (base-rev 2))
+ ;; FIXME: resurrection only brings back the original version,
+ ;; not the latest on the branch, so `up-to-date' is not always
+ ;; what we want.
+ (cvs-parsed-fileinfo '(UP-TO-DATE . RESURRECTED) path nil
+ :base-rev base-rev))
+
+ ;; [remove]
+ (and
+ (cvs-match "removed `\\(.*\\)'$" (path 1))
+ (cvs-parsed-fileinfo 'DEAD path))
+
+ ;; [remove,merge]
+ (and
+ (cvs-match "scheduling `\\(.*\\)' for removal$" (file 1))
+ (cvs-parsed-fileinfo 'REMOVED file))
+
+ ;; [update] File removed by you, but not cvs rm'd
+ (and
+ (cvs-match "warning: \\(.*\\) was lost$" (path 1))
+ (cvs-match (concat "U " (regexp-quote path) "$"))
+ (cvs-parsed-fileinfo (if dont-change-disc
+ 'MISSING
+ '(UP-TO-DATE . UPDATED))
+ path))
+
+ ;; Mode conflicts (rather than contents)
+ (and
+ (cvs-match "conflict: ")
+ (cvs-or
+ (cvs-match "removed \\(.*\\) was modified by second party$"
+ (path 1) (subtype 'REMOVED))
+ (cvs-match "\\(.*\\) created independently by second party$"
+ (path 1) (subtype 'ADDED))
+ (cvs-match "\\(.*\\) is modified but no longer in the repository$"
+ (path 1) (subtype 'MODIFIED)))
+ (cvs-match (concat "C " (regexp-quote path)))
+ (cvs-parsed-fileinfo (cons 'CONFLICT subtype) path))
+
+ ;; Messages that should be shown to the user
+ (and
+ (cvs-or
+ (cvs-match "move away \\(.*\\); it is in the way$" (file 1))
+ (cvs-match "warning: new-born \\(.*\\) has disappeared$" (file 1))
+ (cvs-match "sticky tag .* for file `\\(.*\\)' is not a branch$"
+ (file 1)))
+ (cvs-parsed-fileinfo 'MESSAGE file))
+
+ ;; File unknown.
+ (and (cvs-match "use `.+ add' to create an entry for \\(.*\\)$" (path 1))
+ (cvs-parsed-fileinfo 'UNKNOWN path))
+
+ ;; [commit]
+ (and (cvs-match "Up-to-date check failed for `\\(.+\\)'$" (file 1))
+ (cvs-parsed-fileinfo 'NEED-MERGE file))
+
+ ;; We use cvs-execute-multi-dir but cvs can't handle it
+ ;; Probably because the cvs-client can but the cvs-server can't
+ (and (cvs-match ".* files with '?/'? in their name.*$")
+ (not cvs-execute-single-dir)
+ (setq cvs-execute-single-dir t)
+ (cvs-create-fileinfo
+ 'MESSAGE "" " "
+ "*** Add (setq cvs-execute-single-dir t) to your .emacs ***
+ See the FAQ file or the variable's documentation for more info."))
+
+ ;; Cvs waits for a lock. Ignored: already handled by the process filter
+ (cvs-match "\\[..:..:..\\] \\(waiting for\\|obtained\\) .*lock in .*$")
+ ;; File you removed still exists. Ignore (will be noted as removed).
+ (cvs-match ".* should be removed and is still there$")
+ ;; just a note
+ (cvs-match "use ['`].+ commit' to \\sw+ th\\sw+ files? permanently$")
+ ;; [add,status] followed by a more complete status description anyway
+ (and (cvs-match "nothing known about \\(.*\\)$" (path 1))
+ (cvs-parsed-fileinfo 'DEAD path 'trust))
+ ;; [update] problem with patch
+ (cvs-match "checksum failure after patch to .*; will refetch$")
+ (cvs-match "refetching unpatchable files$")
+ ;; [commit]
+ (cvs-match "Rebuilding administrative file database$")
+ ;; ???
+ (cvs-match "--> Using per-directory sticky tag `.*'")
+
+ ;; CVS is running a *info program.
+ (and
+ (cvs-match "Executing.*$")
+ ;; Skip by any output the program may generate to stdout.
+ ;; Note that pcl-cvs will get seriously confused if the
+ ;; program prints anything to stderr.
+ (re-search-forward cvs-update-prog-output-skip-regexp))))
+
+ (and
+ (cvs-match "cvs[.ex]* \\[[a-z]+ aborted\\]:.*$")
+ (cvs-parsed-fileinfo 'MESSAGE ""))
+
+ ;; sadly you can't do much with these since the path is in the repository
+ (cvs-match "Directory .* added to the repository$")
+ )))
+
+
+(defun cvs-parse-merge ()
+ (let (path base-rev head-rev type)
+ ;; A merge (maybe with a conflict).
+ (and
+ (cvs-match "RCS file: .*$")
+ ;; Squirrel away info about the files that were retrieved for merging
+ (cvs-match "retrieving revision \\([0-9.]+\\)$" (base-rev 1))
+ (cvs-match "retrieving revision \\([0-9.]+\\)$" (head-rev 1))
+ (cvs-match "Merging differences between [0-9.]+ and [0-9.]+ into \\(.*\\)$"
+ (path 1))
+
+ ;; eat up potential conflict warnings
+ (cvs-or (cvs-match "\\(rcs\\)?merge:?\\( warning\\)?: \\(overlaps\\|conflicts\\) \\(or other problems \\)?during merge$" (type 'CONFLICT)) t)
+ (cvs-or
+ (and
+ (cvs-match "cvs[.ex]* [a-z]+: ")
+ (cvs-or
+ (cvs-match "conflicts found in \\(.*\\)$" (path 1) (type 'CONFLICT))
+ (cvs-match "could not merge .*$")
+ (cvs-match "restoring \\(.*\\) from backup file .*$" (path 1))))
+ t)
+
+ ;; Is it a succesful merge?
+ ;; Figure out result of merging (ie, was there a conflict?)
+ (let ((qfile (regexp-quote path)))
+ (cvs-or
+ ;; Conflict
+ (and
+ (cvs-match (concat "C \\(.*" qfile "\\)$") (path 1) (type 'CONFLICT))
+ ;; C might be followed by a "suprious" U for non-mergeable files
+ (cvs-or (cvs-match (concat "U \\(.*" qfile "\\)$")) t))
+ ;; Successful merge
+ (cvs-match (concat "M \\(.*" qfile "\\)$") (path 1))
+ ;; The file already contained the modifications
+ (cvs-match (concat "^\\(.*" qfile
+ "\\) already contains the differences between .*$")
+ (path 1) (type '(UP-TO-DATE . MERGED)))
+ t)
+ ;; FIXME: PATH might not be set yet. Sometimes the only path
+ ;; information is in `RCS file: ...' (yuck!!).
+ (cvs-parsed-fileinfo (if dont-change-disc 'NEED-MERGE
+ (or type '(MODIFIED . MERGED))) path nil
+ :merge (cons base-rev head-rev))))))
+
+(defun cvs-parse-status ()
+ (let (nofile path base-rev head-rev type)
+ (and
+ (cvs-match
+ "===================================================================$")
+ (cvs-match "File: \\(no file \\)?\\(.*[^ \t]\\)[ \t]+Status: "
+ (nofile 1) (path 2))
+ (cvs-or
+ (cvs-match "Needs \\(Checkout\\|Patch\\)$"
+ (type (if nofile 'MISSING 'NEED-UPDATE)))
+ (cvs-match "Up-to-date$"
+ (type (if nofile '(UP-TO-DATE . REMOVED) 'UP-TO-DATE)))
+ (cvs-match "File had conflicts on merge$" (type 'MODIFIED))
+ (cvs-match ".*[Cc]onflict.*$" (type 'CONFLICT))
+ (cvs-match "Locally Added$" (type 'ADDED))
+ (cvs-match "Locally Removed$" (type 'REMOVED))
+ (cvs-match "Locally Modified$" (type 'MODIFIED))
+ (cvs-match "Needs Merge$" (type 'NEED-MERGE))
+ (cvs-match "Entry Invalid" (type '(NEED-MERGE . REMOVED)))
+ (cvs-match ".*$" (type 'UNKNOWN)))
+ (cvs-match "$")
+ (cvs-or
+ (cvs-match " *Version:[ \t]*\\([0-9.]+\\).*$" (base-rev 1))
+ ;; NOTE: there's no date on the end of the following for server mode...
+ (cvs-match " *Working revision:[ \t]*-?\\([0-9.]+\\).*$" (base-rev 1))
+ ;; Let's not get all worked up if the format changes a bit
+ (cvs-match " *Working revision:.*$"))
+ (cvs-or
+ (cvs-match " *RCS Version:[ \t]*\\([0-9.]+\\)[ \t]*.*$" (head-rev 1))
+ (cvs-match " *Repository revision:[ \t]*\\([0-9.]+\\)[ \t]*\\(.*\\)$"
+ (head-rev 1))
+ (cvs-match " *Repository revision:.*"))
+ (cvs-or (cvs-match " *Expansion option:.*") t) ;Optional CVSNT thingie.
+ (cvs-or (cvs-match " *Commit Identifier:.*") t) ;Optional CVSNT thingie.
+ (cvs-or
+ (and ;; Sometimes those fields are missing.
+ (cvs-match " *Sticky Tag:[ \t]*\\(.*\\)$") ; FIXME: use it.
+ (cvs-match " *Sticky Date:[ \t]*\\(.*\\)$") ; FIXME: use it.
+ (cvs-match " *Sticky Options:[ \t]*\\(.*\\)$")) ; FIXME: use it.
+ t)
+ (cvs-or (cvs-match " *Merge From:.*") t) ;Optional CVSNT thingie.
+ (cvs-match "$")
+ ;; ignore the tags-listing in the case of `status -v'
+ (cvs-or (cvs-match " *Existing Tags:\n\\(\t.*\n\\)*$") t)
+ (cvs-parsed-fileinfo type path nil
+ :base-rev base-rev
+ :head-rev head-rev))))
+
+(defun cvs-parse-commit ()
+ (let (path file base-rev subtype)
+ (cvs-or
+
+ (and
+ (cvs-or
+ (cvs-match "\\(Checking in\\|Removing\\) \\(.*\\);$" (path 2))
+ t)
+ (cvs-match ".*,v <-- \\(.*\\)$" (file 1))
+ (cvs-or
+ ;; deletion
+ (cvs-match "new revision: delete; previous revision: \\([0-9.]*\\)$"
+ (subtype 'REMOVED) (base-rev 1))
+ ;; addition
+ (cvs-match "initial revision: \\([0-9.]*\\)$"
+ (subtype 'ADDED) (base-rev 1))
+ ;; update
+ (cvs-match "new revision: \\([0-9.]*\\); previous revision: .*$"
+ (subtype 'COMMITTED) (base-rev 1)))
+ (cvs-or (cvs-match "done$") t)
+ ;; In cvs-1.12.9 commit messages have been changed and became
+ ;; ambiguous. More specifically, the `path' above is not given.
+ ;; We assume here that in future releases the corresponding info will
+ ;; be put into `file'.
+ (progn
+ ;; Try to remove the temp files used by VC.
+ (vc-delete-automatic-version-backups (expand-file-name (or path file)))
+ ;; it's important here not to rely on the default directory management
+ ;; because `cvs commit' might begin by a series of Examining messages
+ ;; so the processing of the actual checkin messages might begin with
+ ;; a `current-dir' set to something different from ""
+ (cvs-parsed-fileinfo (cons 'UP-TO-DATE subtype)
+ (or path file) 'trust
+ :base-rev base-rev)))
+
+ ;; useless message added before the actual addition: ignored
+ (cvs-match "RCS file: .*\ndone$"))))
+
+
+(provide 'pcvs-parse)
+
+;; arch-tag: 35418375-1a23-40a0-957d-96b0262f91d6
+;;; pcvs-parse.el ends here
--- /dev/null
- ;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;;; 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, 2011 Free Software Foundation, Inc.
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; Keywords: pcl-cvs
+;; Package: pcvs
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+;;;;
+;;;; list processing
+;;;;
+
+(defsubst cvs-car (x) (if (consp x) (car x) x))
+(defalias 'cvs-cdr 'cdr-safe)
+(defsubst cvs-append (&rest xs)
+ (apply 'append (mapcar (lambda (x) (if (listp x) x (list x))) xs)))
+
+(defsubst cvs-every (-cvs-every-f -cvs-every-l)
+ (while (consp -cvs-every-l)
+ (unless (funcall -cvs-every-f (pop -cvs-every-l))
+ (setq -cvs-every-l t)))
+ (not -cvs-every-l))
+
+(defun cvs-union (xs ys)
+ (let ((zs ys))
+ (dolist (x xs zs)
+ (unless (member x ys) (push x zs)))))
+
+(defun cvs-map (-cvs-map-f &rest -cvs-map-ls)
+ (let ((accum ()))
+ (while (not (cvs-every 'null -cvs-map-ls))
+ (push (apply -cvs-map-f (mapcar 'car -cvs-map-ls)) accum)
+ (setq -cvs-map-ls (mapcar 'cdr -cvs-map-ls)))
+ (nreverse accum)))
+
+(defun cvs-first (l &optional n)
+ (if (null n) (car l)
+ (when l
+ (let* ((nl (list (pop l)))
+ (ret nl))
+ (while (and l (> n 1))
+ (setcdr nl (list (pop l)))
+ (setq nl (cdr nl))
+ (decf n))
+ ret))))
+
+(defun cvs-partition (p l)
+ "Partition a list L into two lists based on predicate P.
+The function returns a `cons' cell where the `car' contains
+elements of L for which P is true while the `cdr' contains
+the other elements. The ordering among elements is maintained."
+ (let (car cdr)
+ (dolist (x l)
+ (if (funcall p x) (push x car) (push x cdr)))
+ (cons (nreverse car) (nreverse cdr))))
+
+;;;
+;;; frame, window, buffer handling
+;;;
+
+(defun cvs-pop-to-buffer-same-frame (buf)
+ "Pop to BUF like `pop-to-buffer' but staying on the same frame.
+If `pop-to-buffer' would have opened a new frame, this function would
+try to split a new window instead."
+ (let ((pop-up-windows (or pop-up-windows pop-up-frames))
+ (pop-up-frames nil))
+ (or (let ((buf (get-buffer-window buf))) (and buf (select-window buf)))
+ (and pop-up-windows
+ (ignore-errors (select-window (split-window-vertically)))
+ (switch-to-buffer buf))
+ (pop-to-buffer (current-buffer)))))
+
+(defun cvs-bury-buffer (buf &optional mainbuf)
+ "Hide the buffer BUF that was temporarily popped up.
+BUF is assumed to be a temporary buffer used from the buffer MAINBUF."
+ (interactive (list (current-buffer)))
+ (save-current-buffer
+ (let ((win (if (eq buf (window-buffer (selected-window))) (selected-window)
+ (get-buffer-window buf t))))
+ (when win
+ (if (window-dedicated-p win)
+ (condition-case ()
+ (delete-window win)
+ (error (iconify-frame (window-frame win))))
+;;; (if (and mainbuf (get-buffer-window mainbuf))
+;;; ;; FIXME: if the buffer popped into a pre-existing window,
+;;; ;; we don't want to delete that window.
+;;; t ;;(delete-window win)
+;;; )
+ )))
+ (with-current-buffer buf
+ (bury-buffer (unless (and (eq buf (window-buffer (selected-window)))
+ (not (window-dedicated-p (selected-window))))
+ buf)))
+ (when mainbuf
+ (let ((mainwin (or (get-buffer-window mainbuf)
+ (get-buffer-window mainbuf 'visible))))
+ (when mainwin (select-window mainwin))))))
+
+(defun cvs-get-buffer-create (name &optional noreuse)
+ "Create a buffer NAME unless such a buffer already exists.
+If the NAME looks like an absolute file name, the buffer will be created
+with `create-file-buffer' and will probably get another name than NAME.
+In such a case, the search for another buffer with the same name doesn't
+use the buffer name but the buffer's `list-buffers-directory' variable.
+If NOREUSE is non-nil, always return a new buffer."
+ (or (and (not (file-name-absolute-p name))
+ (if noreuse (generate-new-buffer name)
+ (get-buffer-create name)))
+ (unless noreuse
+ (dolist (buf (buffer-list))
+ (with-current-buffer buf
+ (when (equal name list-buffers-directory)
+ (return buf)))))
+ (with-current-buffer (create-file-buffer name)
+ (setq list-buffers-directory name)
+ (current-buffer))))
+
+;;;;
+;;;; string processing
+;;;;
+
+(defun cvs-insert-strings (strings)
+ "Insert a list of STRINGS into the current buffer.
+Uses columns to keep the listing readable but compact."
+ (when (consp strings)
+ (let* ((length (apply 'max (mapcar 'length strings)))
+ (wwidth (1- (window-width)))
+ (columns (min
+ ;; At least 2 columns; at least 2 spaces between columns.
+ (max 2 (/ wwidth (+ 2 length)))
+ ;; Don't allocate more columns than we can fill.
+ ;; Windows can't show less than 3 lines anyway.
+ (max 1 (/ (length strings) 2))))
+ (colwidth (/ wwidth columns)))
+ ;; Use tab-width rather than indent-to.
+ (setq tab-width colwidth)
+ ;; The insertion should be "sensible" no matter what choices were made.
+ (dolist (str strings)
+ (unless (bolp)
+ (insert " \t")
+ (when (< wwidth (+ (max colwidth (length str)) (current-column)))
+ (delete-char -2) (insert "\n")))
+ (insert str)))))
+
+
+(defun cvs-file-to-string (file &optional oneline args)
+ "Read the content of FILE and return it as a string.
+If ONELINE is t, only the first line (no \\n) will be returned.
+If ARGS is non-nil, the file will be executed with ARGS as its
+arguments. If ARGS is not a list, no argument will be passed."
+ (condition-case nil
+ (with-temp-buffer
+ (if args
+ (apply 'call-process
+ file nil t nil (when (listp args) args))
+ (insert-file-contents file))
+ (goto-char (point-min))
+ (buffer-substring (point)
+ (if oneline (line-end-position) (point-max))))
+ (file-error nil)))
+
+(defun cvs-string-prefix-p (str1 str2)
+ "Tell whether STR1 is a prefix of STR2."
+ (eq t (compare-strings str2 nil (length str1) str1 nil nil)))
+
+;;;;
+;;;; file names
+;;;;
+
+(defsubst cvs-expand-dir-name (d)
+ (file-name-as-directory (expand-file-name d)))
+
+;;;;
+;;;; (interactive <foo>) support function
+;;;;
+
+(defstruct (cvs-qtypedesc
+ (:constructor nil) (:copier nil)
+ (:constructor cvs-qtypedesc-create
+ (str2obj obj2str &optional complete hist-sym require)))
+ str2obj
+ obj2str
+ hist-sym
+ complete
+ require)
+
+
+(defconst cvs-qtypedesc-string1 (cvs-qtypedesc-create 'identity 'identity t))
+(defconst cvs-qtypedesc-string (cvs-qtypedesc-create 'identity 'identity))
+(defconst cvs-qtypedesc-strings
+ (cvs-qtypedesc-create 'split-string-and-unquote
+ 'combine-and-quote-strings nil))
+
+(defun cvs-query-read (default prompt qtypedesc &optional hist-sym)
+ (let* ((qtypedesc (or qtypedesc cvs-qtypedesc-strings))
+ (hist-sym (or hist-sym (cvs-qtypedesc-hist-sym qtypedesc)))
+ (complete (cvs-qtypedesc-complete qtypedesc))
+ (completions (and (functionp complete) (funcall complete)))
+ (initval (funcall (cvs-qtypedesc-obj2str qtypedesc) default)))
+ (funcall (cvs-qtypedesc-str2obj qtypedesc)
+ (cond
+ ((null complete) (read-string prompt initval hist-sym))
+ ((functionp complete)
+ (completing-read prompt completions
+ nil (cvs-qtypedesc-require qtypedesc)
+ initval hist-sym))
+ (t initval)))))
+
+;;;;
+;;;; Flags handling
+;;;;
+
+(defstruct (cvs-flags
+ (:constructor nil)
+ (:constructor -cvs-flags-make
+ (desc defaults &optional qtypedesc hist-sym)))
+ defaults persist desc qtypedesc hist-sym)
+
+(defmacro cvs-flags-define (sym defaults
+ &optional desc qtypedesc hist-sym docstring)
+ `(defconst ,sym
+ (let ((bound (boundp ',sym)))
+ (if (and bound (cvs-flags-p ,sym)) ,sym
+ (let ((defaults ,defaults))
+ (-cvs-flags-make ,desc
+ (if bound (cons ,sym (cdr defaults)) defaults)
+ ,qtypedesc ,hist-sym))))
+ ,docstring))
+
+(defun cvs-flags-query (sym &optional desc arg)
+ "Query flags based on SYM.
+Optional argument DESC will be used for the prompt.
+If ARG (or a prefix argument) is nil, just use the 0th default.
+If it is a non-negative integer, use the corresponding default.
+If it is a negative integer query for a new value of the corresponding
+ default and return that new value.
+If it is \\[universal-argument], just query and return a value without
+ altering the defaults.
+If it is \\[universal-argument] \\[universal-argument], behave just
+ as if a negative zero was provided."
+ (let* ((flags (symbol-value sym))
+ (desc (or desc (cvs-flags-desc flags)))
+ (qtypedesc (cvs-flags-qtypedesc flags))
+ (hist-sym (cvs-flags-hist-sym flags))
+ (arg (if (eq arg 'noquery) 0 (or arg current-prefix-arg 0)))
+ (numarg (prefix-numeric-value arg))
+ (defaults (cvs-flags-defaults flags))
+ (permstr (if (< numarg 0) (format " (%sth default)" (- numarg)))))
+ ;; special case for universal-argument
+ (when (consp arg)
+ (setq permstr (if (> numarg 4) " (permanent)" ""))
+ (setq numarg 0))
+
+ ;; sanity check
+ (unless (< (abs numarg) (length defaults))
+ (error "There is no %sth default" (abs numarg)))
+
+ (if permstr
+ (let* ((prompt (format "%s%s: " desc permstr))
+ (fs (cvs-query-read (nth (- numarg) (cvs-flags-defaults flags))
+ prompt qtypedesc hist-sym)))
+ (when (not (equal permstr ""))
+ (setf (nth (- numarg) (cvs-flags-defaults flags)) fs))
+ fs)
+ (nth numarg defaults))))
+
+(defsubst cvs-flags-set (sym index value)
+ "Set SYM's INDEX'th setting to VALUE."
+ (setf (nth index (cvs-flags-defaults (symbol-value sym))) value))
+
+;;;;
+;;;; Prefix keys
+;;;;
+
+(defconst cvs-prefix-number 10)
+
+(defsubst cvs-prefix-sym (sym) (intern (concat (symbol-name sym) "-cps")))
+
+(defmacro cvs-prefix-define (sym docstring desc defaults
+ &optional qtypedesc hist-sym)
+ (let ((cps (cvs-prefix-sym sym)))
+ `(progn
+ (defvar ,sym nil ,(concat (or docstring "") "
+See `cvs-prefix-set' for further description of the behavior."))
+ (defvar ,cps
+ (let ((defaults ,defaults))
+ ;; sanity ensurance
+ (unless (>= (length defaults) cvs-prefix-number)
+ (setq defaults (append defaults
+ (make-list (1- cvs-prefix-number)
+ (nth 0 defaults)))))
+ (-cvs-flags-make ,desc defaults ,qtypedesc ,hist-sym))))))
+
+(defun cvs-prefix-make-local (sym)
+ (let ((cps (cvs-prefix-sym sym)))
+ (make-local-variable sym)
+ (set (make-local-variable cps) (copy-cvs-flags (symbol-value cps)))))
+
+(defun cvs-prefix-set (sym arg)
+ ;; we could distinguish between numeric and non-numeric prefix args instead of
+ ;; relying on that magic `4'.
+ "Set the cvs-prefix contained in SYM.
+If ARG is between 0 and 9, it selects the corresponding default.
+If ARG is negative (or \\[universal-argument] which corresponds to negative 0),
+ it queries the user and sets the -ARG'th default.
+If ARG is greater than 9 (or \\[universal-argument] \\[universal-argument]),
+ the (ARG mod 10)'th prefix is made persistent.
+If ARG is nil toggle the PREFIX's value between its 0th default and nil
+ and reset the persistence."
+ (let* ((prefix (symbol-value (cvs-prefix-sym sym)))
+ (numarg (if (integerp arg) arg 0))
+ ;; (defs (cvs-flags-defaults prefix))
+ )
+
+ ;; set persistence if requested
+ (when (> (prefix-numeric-value arg) 9)
+ (setf (cvs-flags-persist prefix) t)
+ (setq numarg (mod numarg 10)))
+
+ ;; set the value
+ (set sym
+ (cond
+ ((null arg)
+ (setf (cvs-flags-persist prefix) nil)
+ (unless (symbol-value sym) (nth 0 (cvs-flags-defaults prefix))))
+
+ ((or (consp arg) (< numarg 0))
+ (setf (nth (- numarg) (cvs-flags-defaults prefix))
+ (cvs-query-read (nth (- numarg) (cvs-flags-defaults prefix))
+ (format "%s: " (cvs-flags-desc prefix))
+ (cvs-flags-qtypedesc prefix)
+ (cvs-flags-hist-sym prefix))))
+ (t (nth numarg (cvs-flags-defaults prefix)))))
+ (force-mode-line-update)))
+
+(defun cvs-prefix-get (sym &optional read-only)
+ "Return the current value of the prefix SYM.
+And reset it unless READ-ONLY is non-nil."
+ (prog1 (symbol-value sym)
+ (unless (or read-only
+ (cvs-flags-persist (symbol-value (cvs-prefix-sym sym))))
+ (set sym nil)
+ (force-mode-line-update))))
+
+(provide 'pcvs-util)
+
+;; arch-tag: 3b2588bb-2ae3-4f1f-bf5b-dea91b1f8a59
+;;; pcvs-util.el ends here
--- /dev/null
- ;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;;; 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, 2011 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 <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; PCL-CVS is a front-end to the CVS version control system. For people
+;; familiar with VC, it is somewhat like VC-dired: it presents the status of
+;; all the files in your working area and allows you to commit/update several
+;; of them at a time. Compared to VC-dired, it is considerably better and
+;; faster (but only for CVS).
+
+;; PCL-CVS was originally written by Per Cederqvist many years ago. This
+;; version derives from the XEmacs-21 version, itself based on the 2.0b2
+;; version (last release from Per). It is a thorough rework.
+
+;; Contrary to what you'd expect, PCL-CVS is not a replacement for VC but only
+;; for VC-dired. As such, I've tried to make PCL-CVS and VC interoperate
+;; seamlessly (I also use VC).
+
+;; To use PCL-CVS just use `M-x cvs-examine RET <dir> RET'.
+;; There is a TeXinfo manual, which can be helpful to get started.
+
+;;; Bugs:
+
+;; - Extracting an old version seems not to recognize encoding correctly.
+;; That's probably because it's done via a process rather than a file.
+
+;;; Todo:
+
+;; ******** FIX THE DOCUMENTATION *********
+;;
+;; - rework the displaying of error messages.
+;; - allow to flush messages only
+;; - allow to protect files like ChangeLog from flushing
+;; - automatically cvs-mode-insert files from find-file-hook
+;; (and don't flush them as long as they are visited)
+;; - query the user for cvs-get-marked (for some cmds or if nothing's selected)
+;; - don't return the first (resp last) FI if the cursor is before
+;; (resp after) it.
+;; - allow cvs-confirm-removals to force always confirmation.
+;; - cvs-checkout should ask for a revision (with completion).
+;; - removal confirmation should allow specifying another file name.
+;;
+;; - hide fileinfos without getting rid of them (will require ewok work).
+;; - add toolbar entries
+;; - marking
+;; marking directories should jump to just after the dir.
+;; allow (un)marking directories at a time with the mouse.
+;; allow cvs-cmd-do to either clear the marks or not.
+;; add a "marks active" notion, like transient-mark-mode does.
+;; - liveness indicator
+;; - indicate in docstring if the cmd understands the `b' prefix(es).
+;; - call smerge-mode when opening CONFLICT files.
+;; - have vc-checkin delegate to cvs-mode-commit when applicable
+;; - higher-level CVS operations
+;; cvs-mode-rename
+;; cvs-mode-branch
+;; - module-level commands
+;; add support for parsing 'modules' file ("cvs co -c")
+;; cvs-mode-rcs2log
+;; cvs-rdiff
+;; cvs-release
+;; cvs-import
+;; C-u M-x cvs-checkout should ask for a cvsroot
+;; cvs-mode-handle-new-vendor-version
+;; - checks out module, or alternately does update join
+;; - does "cvs -n tag LAST_VENDOR" to find old files into *cvs*
+;; cvs-export
+;; (with completion on tag names and hooks to help generate full releases)
+;; - display stickiness information. And current CVS/Tag as well.
+;; - write 'cvs-mode-admin' to do arbitrary 'cvs admin' commands
+;; Most interesting would be version removal and log message replacement.
+;; The last one would be neat when called from log-view-mode.
+;; - cvs-mode-incorporate
+;; It would merge in the status from one *cvs* buffer into another.
+;; This would be used to populate such a buffer that had been created with
+;; a `cvs {update,status,checkout} -l'.
+;; - cvs-mode-(i)diff-other-{file,buffer,cvs-buffer}
+;; - offer the choice to kill the process when the user kills the cvs buffer.
+;; right now, it's killed without further ado.
+;; - make `cvs-mode-ignore' allow manually entering a pattern.
+;; to which dir should it apply ?
+;; - cvs-mode-ignore should try to remove duplicate entries.
+;; - maybe poll/check CVS/Entries files to react to external `cvs' commands ?
+;; - some kind of `cvs annotate' support ?
+;; but vc-annotate can be used instead.
+;; - proper `g' that passes safe args and uses either cvs-status or cvs-examine
+;; maybe also use cvs-update depending on I-don't-know-what.
+;; - add message-levels so that we can hide some levels of messages
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+(require 'ewoc) ;Ewoc was once cookie
+(require 'pcvs-defs)
+(require 'pcvs-util)
+(require 'pcvs-parse)
+(require 'pcvs-info)
+
+\f
+;;;;
+;;;; global vars
+;;;;
+
+(defvar cvs-cookies) ;;nil
+ ;;"Handle for the cookie structure that is displayed in the *cvs* buffer.")
+;;(make-variable-buffer-local 'cvs-cookies)
+
+;;;;
+;;;; Dynamically scoped variables
+;;;;
+
+(defvar cvs-from-vc nil "Bound to t inside VC advice.")
+
+;;;;
+;;;; flags variables
+;;;;
+
+(defun cvs-defaults (&rest defs)
+ (let ((defs (cvs-first defs cvs-shared-start)))
+ (append defs
+ (make-list (- cvs-shared-start (length defs)) (car defs))
+ cvs-shared-flags)))
+
+;; For cvs flags, we need to add "-f" to override the cvsrc settings
+;; we also want to evict the annoying -q and -Q options that hide useful
+;; information from pcl-cvs.
+(cvs-flags-define cvs-cvs-flags '(("-f")))
+
+(cvs-flags-define cvs-checkout-flags (cvs-defaults '("-P")))
+(cvs-flags-define cvs-status-flags (cvs-defaults '("-v") nil))
+(cvs-flags-define cvs-log-flags (cvs-defaults nil))
+(cvs-flags-define cvs-diff-flags (cvs-defaults '("-u" "-N") '("-c" "-N") '("-u" "-b")))
+(cvs-flags-define cvs-tag-flags (cvs-defaults nil))
+(cvs-flags-define cvs-add-flags (cvs-defaults nil))
+(cvs-flags-define cvs-commit-flags (cvs-defaults nil))
+(cvs-flags-define cvs-remove-flags (cvs-defaults nil))
+;;(cvs-flags-define cvs-undo-flags (cvs-defaults nil))
+(cvs-flags-define cvs-update-flags (cvs-defaults '("-d" "-P")))
+
+(defun cvs-reread-cvsrc ()
+ "Reset the default arguments to those in the `cvs-cvsrc-file'."
+ (interactive)
+ (condition-case nil
+ (with-temp-buffer
+ (insert-file-contents cvs-cvsrc-file)
+ ;; fetch the values
+ (dolist (cmd '("cvs" "checkout" "status" "log" "diff" "tag"
+ "add" "commit" "remove" "update"))
+ (goto-char (point-min))
+ (when (re-search-forward
+ (concat "^" cmd "\\(\\s-+\\(.*\\)\\)?$") nil t)
+ (let* ((sym (intern (concat "cvs-" cmd "-flags")))
+ (val (split-string-and-unquote (or (match-string 2) ""))))
+ (cvs-flags-set sym 0 val))))
+ ;; ensure that cvs doesn't have -q or -Q
+ (cvs-flags-set 'cvs-cvs-flags 0
+ (cons "-f"
+ (cdr (cvs-partition
+ (lambda (x) (member x '("-q" "-Q" "-f")))
+ (cvs-flags-query 'cvs-cvs-flags
+ nil 'noquery))))))
+ (file-error nil)))
+
+;; initialize to cvsrc's default values
+(cvs-reread-cvsrc)
+
+\f
+;;;;
+;;;; Mouse bindings and mode motion
+;;;;
+
+(defvar cvs-minor-current-files)
+
+(defun cvs-menu (e)
+ "Popup the CVS menu."
+ (interactive "e")
+ (let ((cvs-minor-current-files
+ (list (ewoc-data (ewoc-locate
+ cvs-cookies (posn-point (event-end e)))))))
+ (popup-menu cvs-menu e)))
+
+(defvar cvs-mode-line-process nil
+ "Mode-line control for displaying info on cvs process status.")
+
+
+;;;;
+;;;; Query-Type-Descriptor for Tags
+;;;;
+
+(autoload 'cvs-status-get-tags "cvs-status")
+(defun cvs-tags-list ()
+ "Return a list of acceptable tags, ready for completions."
+ (assert (cvs-buffer-p))
+ (let ((marked (cvs-get-marked)))
+ (list* '("BASE") '("HEAD")
+ (when marked
+ (with-temp-buffer
+ (process-file cvs-program
+ nil ;no input
+ t ;output to current-buffer
+ nil ;don't update display while running
+ "status"
+ "-v"
+ (cvs-fileinfo->full-name (car marked)))
+ (goto-char (point-min))
+ (let ((tags (cvs-status-get-tags)))
+ (when (listp tags) tags)))))))
+
+(defvar cvs-tag-history nil)
+(defconst cvs-qtypedesc-tag
+ (cvs-qtypedesc-create 'identity 'identity 'cvs-tags-list 'cvs-tag-history))
+
+;;;;
+
+(defun cvs-mode! (&optional -cvs-mode!-fun)
+ "Switch to the *cvs* buffer.
+If -CVS-MODE!-FUN is provided, it is executed *cvs* being the current buffer
+ and with its window selected. Else, the *cvs* buffer is simply selected.
+-CVS-MODE!-FUN is called interactively if applicable and else with no argument."
+ (let* ((-cvs-mode!-buf (current-buffer))
+ (cvsbuf (cond ((cvs-buffer-p) (current-buffer))
+ ((and cvs-buffer (cvs-buffer-p cvs-buffer)) cvs-buffer)
+ (t (error "can't find the *cvs* buffer"))))
+ (-cvs-mode!-wrapper cvs-minor-wrap-function)
+ (-cvs-mode!-cont (lambda ()
+ (save-current-buffer
+ (if (commandp -cvs-mode!-fun)
+ (call-interactively -cvs-mode!-fun)
+ (funcall -cvs-mode!-fun))))))
+ (if (not -cvs-mode!-fun) (set-buffer cvsbuf)
+ (let ((cvs-mode!-buf (current-buffer))
+ (cvs-mode!-owin (selected-window))
+ (cvs-mode!-nwin (get-buffer-window cvsbuf 'visible)))
+ (unwind-protect
+ (progn
+ (set-buffer cvsbuf)
+ (when cvs-mode!-nwin (select-window cvs-mode!-nwin))
+ (if -cvs-mode!-wrapper
+ (funcall -cvs-mode!-wrapper -cvs-mode!-buf -cvs-mode!-cont)
+ (funcall -cvs-mode!-cont)))
+ (set-buffer cvs-mode!-buf)
+ (when (and cvs-mode!-nwin (eq cvs-mode!-nwin (selected-window)))
+ ;; the selected window has not been changed by FUN
+ (select-window cvs-mode!-owin)))))))
+
+;;;;
+;;;; Prefixes
+;;;;
+
+(defvar cvs-branches (list cvs-vendor-branch "HEAD" "HEAD"))
+(cvs-prefix-define cvs-branch-prefix
+ "Current selected branch."
+ "version"
+ (cons cvs-vendor-branch cvs-branches)
+ cvs-qtypedesc-tag)
+
+(defun cvs-set-branch-prefix (arg)
+ "Set the branch prefix to take action at the next command.
+See `cvs-prefix-set' for a further the description of the behavior.
+\\[universal-argument] 1 selects the vendor branch
+and \\[universal-argument] 2 selects the HEAD."
+ (interactive "P")
+ (cvs-mode!)
+ (cvs-prefix-set 'cvs-branch-prefix arg))
+
+(defun cvs-add-branch-prefix (flags &optional arg)
+ "Add branch selection argument if the branch prefix was set.
+The argument is added (or not) to the list of FLAGS and is constructed
+by appending the branch to ARG which defaults to \"-r\"."
+ (let ((branch (cvs-prefix-get 'cvs-branch-prefix)))
+ ;; deactivate the secondary prefix, even if not used.
+ (cvs-prefix-get 'cvs-secondary-branch-prefix)
+ (if branch (cons (concat (or arg "-r") branch) flags) flags)))
+
+(cvs-prefix-define cvs-secondary-branch-prefix
+ "Current secondary selected branch."
+ "version"
+ (cons cvs-vendor-branch cvs-branches)
+ cvs-qtypedesc-tag)
+
+(defun cvs-set-secondary-branch-prefix (arg)
+ "Set the branch prefix to take action at the next command.
+See `cvs-prefix-set' for a further the description of the behavior.
+\\[universal-argument] 1 selects the vendor branch
+and \\[universal-argument] 2 selects the HEAD."
+ (interactive "P")
+ (cvs-mode!)
+ (cvs-prefix-set 'cvs-secondary-branch-prefix arg))
+
+(defun cvs-add-secondary-branch-prefix (flags &optional arg)
+ "Add branch selection argument if the secondary branch prefix was set.
+The argument is added (or not) to the list of FLAGS and is constructed
+by appending the branch to ARG which defaults to \"-r\".
+Since the `cvs-secondary-branch-prefix' is only active if the primary
+prefix is active, it is important to read the secondary prefix before
+the primay since reading the primary can deactivate it."
+ (let ((branch (and (cvs-prefix-get 'cvs-branch-prefix 'read-only)
+ (cvs-prefix-get 'cvs-secondary-branch-prefix))))
+ (if branch (cons (concat (or arg "-r") branch) flags) flags)))
+
+;;;;
+
+(define-minor-mode cvs-minor-mode
+ "This mode is used for buffers related to a main *cvs* buffer.
+All the `cvs-mode' buffer operations are simply rebound under
+the \\[cvs-mode-map] prefix."
+ nil " CVS"
+ :group 'pcl-cvs)
+(put 'cvs-minor-mode 'permanent-local t)
+
+
+(defvar cvs-temp-buffers nil)
+(defun cvs-temp-buffer (&optional cmd normal nosetup)
+ "Create a temporary buffer to run CMD in.
+If CMD is a string, use it to lookup `cvs-buffer-name-alist' to find
+the buffer name to be used and its `major-mode'.
+
+The selected window will not be changed. The new buffer will not maintain undo
+information and will be read-only unless NORMAL is non-nil. It will be emptied
+\(unless NOSETUP is non-nil\) and its `default-directory' will be inherited
+from the current buffer."
+ (let* ((cvs-buf (current-buffer))
+ (info (cdr (assoc cmd cvs-buffer-name-alist)))
+ (name (eval (nth 0 info)))
+ (mode (nth 1 info))
+ (dir default-directory)
+ (buf (cond
+ (name (cvs-get-buffer-create name))
+ ((and (bufferp cvs-temp-buffer) (buffer-live-p cvs-temp-buffer))
+ cvs-temp-buffer)
+ (t
+ (set (make-local-variable 'cvs-temp-buffer)
+ (cvs-get-buffer-create
+ (eval cvs-temp-buffer-name) 'noreuse))))))
+
+ ;; handle the potential pre-existing process
+ (let ((proc (get-buffer-process buf)))
+ (when (and (not normal) (processp proc)
+ (memq (process-status proc) '(run stop)))
+ (if cmd
+ ;; When CMD is specified, the buffer is normally shown to the
+ ;; user, so interrupting the process is not harmful.
+ ;; Use `delete-process' rather than `kill-process' otherwise
+ ;; the pending output of the process will still get inserted
+ ;; after we erase the buffer.
+ (delete-process proc)
+ (error "Can not run two cvs processes simultaneously"))))
+
+ (if (not name) (kill-local-variable 'other-window-scroll-buffer)
+ ;; Strangely, if no window is created, `display-buffer' ends up
+ ;; doing a `switch-to-buffer' which does a `set-buffer', hence
+ ;; the need for `save-excursion'.
+ (unless nosetup (save-excursion (display-buffer buf)))
+ ;; FIXME: this doesn't do the right thing if the user later on
+ ;; does a `find-file-other-window' and `scroll-other-window'
+ (set (make-local-variable 'other-window-scroll-buffer) buf))
+
+ (add-to-list 'cvs-temp-buffers buf)
+
+ (with-current-buffer buf
+ (setq buffer-read-only nil)
+ (setq default-directory dir)
+ (unless nosetup
+ ;; Disable undo before calling erase-buffer since it may generate
+ ;; a very large and unwanted undo record.
+ (buffer-disable-undo)
+ (erase-buffer))
+ (set (make-local-variable 'cvs-buffer) cvs-buf)
+ ;;(cvs-minor-mode 1)
+ (let ((lbd list-buffers-directory))
+ (if (fboundp mode) (funcall mode) (fundamental-mode))
+ (when lbd (setq list-buffers-directory lbd)))
+ (cvs-minor-mode 1)
+ ;;(set (make-local-variable 'cvs-buffer) cvs-buf)
+ (if normal
+ (buffer-enable-undo)
+ (setq buffer-read-only t)
+ (buffer-disable-undo))
+ buf)))
+
+(defun cvs-mode-kill-buffers ()
+ "Kill all the \"temporary\" buffers created by the *cvs* buffer."
+ (interactive)
+ (dolist (buf cvs-temp-buffers) (ignore-errors (kill-buffer buf))))
+
+(defun cvs-make-cvs-buffer (dir &optional new)
+ "Create the *cvs* buffer for directory DIR.
+If non-nil, NEW means to create a new buffer no matter what."
+ ;; the real cvs-buffer creation
+ (setq dir (cvs-expand-dir-name dir))
+ (let* ((buffer-name (eval cvs-buffer-name))
+ (buffer
+ (or (and (not new)
+ (eq cvs-reuse-cvs-buffer 'current)
+ (cvs-buffer-p) ;reuse the current buffer if possible
+ (current-buffer))
+ ;; look for another cvs buffer visiting the same directory
+ (save-excursion
+ (unless new
+ (dolist (buffer (cons (current-buffer) (buffer-list)))
+ (set-buffer buffer)
+ (and (cvs-buffer-p)
+ (case cvs-reuse-cvs-buffer
+ (always t)
+ (subdir
+ (or (cvs-string-prefix-p default-directory dir)
+ (cvs-string-prefix-p dir default-directory)))
+ (samedir (string= default-directory dir)))
+ (return buffer)))))
+ ;; we really have to create a new buffer:
+ ;; we temporarily bind cwd to "" to prevent
+ ;; create-file-buffer from using directory info
+ ;; unless it is explicitly in the cvs-buffer-name.
+ (cvs-get-buffer-create buffer-name new))))
+ (with-current-buffer buffer
+ (or
+ (and (string= dir default-directory) (cvs-buffer-p)
+ ;; just a refresh
+ (ignore-errors
+ (cvs-cleanup-collection cvs-cookies nil nil t)
+ (current-buffer)))
+ ;; setup from scratch
+ (progn
+ (setq default-directory dir)
+ (setq buffer-read-only nil)
+ (erase-buffer)
+ (insert "Repository : " (directory-file-name (cvs-get-cvsroot))
+ "\nModule : " (cvs-get-module)
+ "\nWorking dir: " (abbreviate-file-name dir)
+ (if (not (file-readable-p "CVS/Tag")) "\n"
+ (let ((tag (cvs-file-to-string "CVS/Tag")))
+ (cond
+ ((string-match "\\`T" tag)
+ (concat "\nTag : " (substring tag 1)))
+ ((string-match "\\`D" tag)
+ (concat "\nDate : " (substring tag 1)))
+ ("\n"))))
+ "\n")
+ (setq buffer-read-only t)
+ (cvs-mode)
+ (set (make-local-variable 'list-buffers-directory) buffer-name)
+ ;;(set (make-local-variable 'cvs-temp-buffer) (cvs-temp-buffer))
+ (let ((cookies (ewoc-create 'cvs-fileinfo-pp "\n\n" "\n" t)))
+ (set (make-local-variable 'cvs-cookies) cookies)
+ (add-hook 'kill-buffer-hook
+ (lambda ()
+ (ignore-errors (kill-buffer cvs-temp-buffer)))
+ nil t)
+ ;;(set-buffer buf)
+ buffer))))))
+
+(defun* cvs-cmd-do (cmd dir flags fis new
+ &key cvsargs noexist dont-change-disc noshow)
+ (let* ((dir (file-name-as-directory
+ (abbreviate-file-name (expand-file-name dir))))
+ (cvsbuf (cvs-make-cvs-buffer dir new)))
+ ;; Check that dir is under CVS control.
+ (unless (file-directory-p dir)
+ (error "%s is not a directory" dir))
+ (unless (or noexist (file-directory-p (expand-file-name "CVS" dir))
+ (file-expand-wildcards (expand-file-name "*/CVS" dir)))
+ (error "%s does not contain CVS controlled files" dir))
+
+ (set-buffer cvsbuf)
+ (cvs-mode-run cmd flags fis
+ :cvsargs cvsargs :dont-change-disc dont-change-disc)
+
+ (if noshow cvsbuf
+ (let ((pop-up-windows nil)) (pop-to-buffer cvsbuf)))))
+;; (funcall (if (and (boundp 'pop-up-frames) pop-up-frames)
+;; 'pop-to-buffer 'switch-to-buffer)
+;; cvsbuf))))
+
+(defun cvs-run-process (args fis postprocess &optional single-dir)
+ (assert (cvs-buffer-p cvs-buffer))
+ (save-current-buffer
+ (let ((procbuf (current-buffer))
+ (cvsbuf cvs-buffer)
+ (single-dir (or single-dir (eq cvs-execute-single-dir t))))
+
+ (set-buffer procbuf)
+ (goto-char (point-max))
+ (unless (bolp) (let ((inhibit-read-only t)) (insert "\n")))
+ ;; find the set of files we'll process in this round
+ (let* ((dir+files+rest
+ (if (or (null fis) (not single-dir))
+ ;; not single-dir mode: just process the whole thing
+ (list "" (mapcar 'cvs-fileinfo->full-name fis) nil)
+ ;; single-dir mode: extract the same-dir-elements
+ (let ((dir (cvs-fileinfo->dir (car fis))))
+ ;; output the concerned dir so the parser can translate paths
+ (let ((inhibit-read-only t))
+ (insert "pcl-cvs: descending directory " dir "\n"))
+ ;; loop to find the same-dir-elems
+ (do* ((files () (cons (cvs-fileinfo->file fi) files))
+ (fis fis (cdr fis))
+ (fi (car fis) (car fis)))
+ ((not (and fis (string= dir (cvs-fileinfo->dir fi))))
+ (list dir files fis))))))
+ (dir (nth 0 dir+files+rest))
+ (files (nth 1 dir+files+rest))
+ (rest (nth 2 dir+files+rest)))
+
+ (add-hook 'kill-buffer-hook
+ (lambda ()
+ (let ((proc (get-buffer-process (current-buffer))))
+ (when (processp proc)
+ (set-process-filter proc nil)
+ ;; Abort postprocessing but leave the sentinel so it
+ ;; will update the list of running procs.
+ (process-put proc 'cvs-postprocess nil)
+ (interrupt-process proc))))
+ nil t)
+
+ ;; create the new process and setup the procbuffer correspondingly
+ (let* ((msg (cvs-header-msg args fis))
+ (args (append (cvs-flags-query 'cvs-cvs-flags nil 'noquery)
+ (if cvs-cvsroot (list "-d" cvs-cvsroot))
+ args
+ files))
+ ;; If process-connection-type is nil and the repository
+ ;; is accessed via SSH, a bad interaction between libc,
+ ;; CVS and SSH can lead to garbled output.
+ ;; It might be a glibc-specific problem (but it can also happens
+ ;; under Mac OS X, it seems).
+ ;; It seems that using a pty can help circumvent the problem,
+ ;; but at the cost of screwing up when the process thinks it
+ ;; can ask for user input (such as password or host-key
+ ;; confirmation). A better workaround is to set CVS_RSH to
+ ;; an appropriate script, or to use a later version of CVS.
+ (process-connection-type nil) ; Use a pipe, not a pty.
+ (process
+ ;; the process will be run in the selected dir
+ (let ((default-directory (cvs-expand-dir-name dir)))
+ (apply 'start-file-process "cvs" procbuf cvs-program args))))
+ ;; setup the process.
+ (process-put process 'cvs-buffer cvs-buffer)
+ (with-current-buffer cvs-buffer (cvs-update-header msg 'add))
+ (process-put process 'cvs-header msg)
+ (process-put
+ process 'cvs-postprocess
+ (if (null rest)
+ ;; this is the last invocation
+ postprocess
+ ;; else, we have to register ourselves to be rerun on the rest
+ `(cvs-run-process ',args ',rest ',postprocess ',single-dir)))
+ (set-process-sentinel process 'cvs-sentinel)
+ (set-process-filter process 'cvs-update-filter)
+ (set-marker (process-mark process) (point-max))
+ (ignore-errors (process-send-eof process)) ;close its stdin to avoid hangs
+
+ ;; now finish setting up the cvs-buffer
+ (set-buffer cvsbuf)
+ (setq cvs-mode-line-process (symbol-name (process-status process)))
+ (force-mode-line-update)))))
+
+ ;; The following line is said to improve display updates on some
+ ;; emacsen. It shouldn't be needed, but it does no harm.
+ (sit-for 0))
+
+(defun cvs-header-msg (args fis)
+ (let* ((lastarg nil)
+ (args (mapcar (lambda (arg)
+ (cond
+ ;; filter out the largish commit message
+ ((and (eq lastarg nil) (string= arg "commit"))
+ (setq lastarg 'commit) arg)
+ ((and (eq lastarg 'commit) (string= arg "-m"))
+ (setq lastarg '-m) arg)
+ ((eq lastarg '-m)
+ (setq lastarg 'done) "<log message>")
+ ;; filter out the largish `admin -mrev:msg' message
+ ((and (eq lastarg nil) (string= arg "admin"))
+ (setq lastarg 'admin) arg)
+ ((and (eq lastarg 'admin)
+ (string-match "\\`-m[^:]*:" arg))
+ (setq lastarg 'done)
+ (concat (match-string 0 arg) "<log message>"))
+ ;; Keep the rest as is.
+ (t arg)))
+ args)))
+ (concat cvs-program " "
+ (combine-and-quote-strings
+ (append (cvs-flags-query 'cvs-cvs-flags nil 'noquery)
+ (if cvs-cvsroot (list "-d" cvs-cvsroot))
+ args
+ (mapcar 'cvs-fileinfo->full-name fis))))))
+
+(defun cvs-update-header (cmd add)
+ (let* ((hf (ewoc-get-hf cvs-cookies))
+ (str (car hf))
+ (done "")
+ (tin (ewoc-nth cvs-cookies 0)))
+ ;; look for the first *real* fileinfo (to determine emptyness)
+ (while
+ (and tin
+ (memq (cvs-fileinfo->type (ewoc-data tin))
+ '(MESSAGE DIRCHANGE)))
+ (setq tin (ewoc-next cvs-cookies tin)))
+ (if add
+ (progn
+ ;; Remove the default empty line, if applicable.
+ (if (not (string-match "." str)) (setq str "\n"))
+ (setq str (concat "-- Running " cmd " ...\n" str)))
+ (if (not (string-match
+ ;; FIXME: If `cmd' is large, this will bump into the
+ ;; compiled-regexp size limit. We could drop the "^" anchor
+ ;; and use search-forward to circumvent the problem.
+ (concat "^-- Running " (regexp-quote cmd) " \\.\\.\\.\n") str))
+ (error "Internal PCL-CVS error while removing message")
+ (setq str (replace-match "" t t str))
+ ;; Re-add the default empty line, if applicable.
+ (if (not (string-match "." str)) (setq str "\n\n"))
+ (setq done (concat "-- last cmd: " cmd " --\n"))))
+ ;; set the new header and footer
+ (ewoc-set-hf cvs-cookies
+ str (concat "\n--------------------- "
+ (if tin "End" "Empty")
+ " ---------------------\n"
+ done))))
+
+
+(defun cvs-sentinel (proc msg)
+ "Sentinel for the cvs update process.
+This is responsible for parsing the output from the cvs update when
+it is finished."
+ (when (memq (process-status proc) '(signal exit))
+ (let ((cvs-postproc (process-get proc 'cvs-postprocess))
+ (cvs-buf (process-get proc 'cvs-buffer))
+ (procbuf (process-buffer proc)))
+ (unless (buffer-live-p cvs-buf) (setq cvs-buf nil))
+ (unless (buffer-live-p procbuf) (setq procbuf nil))
+ ;; Since the buffer and mode line will show that the
+ ;; process is dead, we can delete it now. Otherwise it
+ ;; will stay around until M-x list-processes.
+ (process-put proc 'postprocess nil)
+ (delete-process proc)
+ ;; Don't do anything if the main buffer doesn't exist any more.
+ (when cvs-buf
+ (with-current-buffer cvs-buf
+ (cvs-update-header (process-get proc 'cvs-header) nil)
+ (setq cvs-mode-line-process (symbol-name (process-status proc)))
+ (force-mode-line-update)
+ (when cvs-postproc
+ (if (null procbuf)
+ ;;(set-process-buffer proc nil)
+ (error "cvs' process buffer was killed")
+ (with-current-buffer procbuf
+ ;; Do the postprocessing like parsing and such.
+ (save-excursion (eval cvs-postproc)))))))
+ ;; Check whether something is left.
+ (when (and procbuf (not (get-buffer-process procbuf)))
+ (with-current-buffer procbuf
+ ;; IIRC, we enable undo again once the process is finished
+ ;; for cases where the output was inserted in *vc-diff* or
+ ;; in a file-like buffer. --Stef
+ (buffer-enable-undo)
+ (with-current-buffer (or cvs-buf (current-buffer))
+ (message "CVS process has completed in %s"
+ (buffer-name))))))))
+
+(defun cvs-parse-process (dcd &optional subdir old-fis)
+ "Parse the output of a cvs process.
+DCD is the `dont-change-disc' flag to use when parsing that output.
+SUBDIR is the subdirectory (if any) where this command was run.
+OLD-FIS is the list of fileinfos on which the cvs command was applied and
+ which should be considered up-to-date if they are missing from the output."
+ (when (eq system-type 'darwin)
+ ;; Fixup the ^D^H^H inserted at beginning of buffer sometimes on MacOSX
+ ;; because of the call to `process-send-eof'.
+ (save-excursion
+ (goto-char (point-min))
+ (while (re-search-forward "^\\^D\b+" nil t)
+ (let ((inhibit-read-only t))
+ (delete-region (match-beginning 0) (match-end 0))))))
+ (let* ((fileinfos (cvs-parse-buffer 'cvs-parse-table dcd subdir))
+ last)
+ (with-current-buffer cvs-buffer
+ ;; Expand OLD-FIS to actual files.
+ (let ((fis nil))
+ (dolist (fi old-fis)
+ (setq fis (if (eq (cvs-fileinfo->type fi) 'DIRCHANGE)
+ (nconc (ewoc-collect cvs-cookies 'cvs-dir-member-p
+ (cvs-fileinfo->dir fi))
+ fis)
+ (cons fi fis))))
+ (setq old-fis fis))
+ ;; Drop OLD-FIS which were already up-to-date.
+ (let ((fis nil))
+ (dolist (fi old-fis)
+ (unless (eq (cvs-fileinfo->type fi) 'UP-TO-DATE) (push fi fis)))
+ (setq old-fis fis))
+ ;; Add the new fileinfos to the ewoc.
+ (dolist (fi fileinfos)
+ (setq last (cvs-addto-collection cvs-cookies fi last))
+ ;; This FI was in the output, so remove it from OLD-FIS.
+ (setq old-fis (delq (ewoc-data last) old-fis)))
+ ;; Process the "silent output" (i.e. absence means up-to-date).
+ (dolist (fi old-fis)
+ (setf (cvs-fileinfo->type fi) 'UP-TO-DATE)
+ (setq last (cvs-addto-collection cvs-cookies fi last)))
+ (setq fileinfos (nconc old-fis fileinfos))
+ ;; Clean up the ewoc as requested by the user.
+ (cvs-cleanup-collection cvs-cookies
+ (eq cvs-auto-remove-handled t)
+ cvs-auto-remove-directories
+ nil)
+ ;; Revert buffers if necessary.
+ (when (and cvs-auto-revert (not dcd) (not cvs-from-vc))
+ (cvs-revert-if-needed fileinfos)))))
+
+(defmacro defun-cvs-mode (fun args docstring interact &rest body)
+ "Define a function to be used in a *cvs* buffer.
+This will look for a *cvs* buffer and execute BODY in it.
+Since the interactive arguments might need to be queried after
+switching to the *cvs* buffer, the generic code is rather ugly,
+but luckily we can often use simpler alternatives.
+
+FUN can be either a symbol (i.e. STYLE is nil) or a cons (FUN . STYLE).
+ARGS and DOCSTRING are the normal argument list.
+INTERACT is the interactive specification or nil for non-commands.
+
+STYLE can be either SIMPLE, NOARGS or DOUBLE. It's an error for it
+to have any other value, unless other details of the function make it
+clear what alternative to use.
+- SIMPLE will get all the interactive arguments from the original buffer.
+- NOARGS will get all the arguments from the *cvs* buffer and will
+ always behave as if called interactively.
+- DOUBLE is the generic case."
+ (declare (debug (&define sexp lambda-list stringp ("interactive" interactive) def-body))
+ (doc-string 3))
+ (let ((style (cvs-cdr fun))
+ (fun (cvs-car fun)))
+ (cond
+ ;; a trivial interaction, no need to move it
+ ((or (eq style 'SIMPLE)
+ (null (nth 1 interact))
+ (stringp (nth 1 interact)))
+ `(defun ,fun ,args ,docstring ,interact
+ (cvs-mode! (lambda () ,@body))))
+
+ ;; fun is only called interactively: move all the args to the inner fun
+ ((eq style 'NOARGS)
+ `(defun ,fun () ,docstring (interactive)
+ (cvs-mode! (lambda ,args ,interact ,@body))))
+
+ ;; bad case
+ ((eq style 'DOUBLE)
+ (string-match ".*" docstring)
+ (let ((line1 (match-string 0 docstring))
+ (fun-1 (intern (concat (symbol-name fun) "-1"))))
+ `(progn
+ (defun ,fun-1 ,args
+ ,(concat docstring "\nThis function only works within a *cvs* buffer.
+For interactive use, use `" (symbol-name fun) "' instead.")
+ ,interact
+ ,@body)
+ (put ',fun-1 'definition-name ',fun)
+ (defun ,fun ()
+ ,(concat line1 "\nWrapper function that switches to a *cvs* buffer
+before calling the real function `" (symbol-name fun-1) "'.\n")
+ (interactive)
+ (cvs-mode! ',fun-1)))))
+
+ (t (error "Unknown style %s in `defun-cvs-mode'" style)))))
+
+(defun-cvs-mode cvs-mode-kill-process ()
+ "Kill the temporary buffer and associated process."
+ (interactive)
+ (when (and (bufferp cvs-temp-buffer) (buffer-live-p cvs-temp-buffer))
+ (let ((proc (get-buffer-process cvs-temp-buffer)))
+ (when proc (delete-process proc)))))
+
+;;
+;; Maintaining the collection in the face of updates
+;;
+
+(defun cvs-addto-collection (c fi &optional tin)
+ "Add FI to C and return FI's corresponding tin.
+FI is inserted in its proper place or maybe even merged with a preexisting
+ fileinfo if applicable.
+TIN specifies an optional starting point."
+ (unless tin (setq tin (ewoc-nth c 0)))
+ (while (and tin (cvs-fileinfo< fi (ewoc-data tin)))
+ (setq tin (ewoc-prev c tin)))
+ (if (null tin) (ewoc-enter-first c fi) ;empty collection
+ (assert (not (cvs-fileinfo< fi (ewoc-data tin))))
+ (let ((next-tin (ewoc-next c tin)))
+ (while (not (or (null next-tin)
+ (cvs-fileinfo< fi (ewoc-data next-tin))))
+ (setq tin next-tin next-tin (ewoc-next c next-tin)))
+ (if (or (cvs-fileinfo< (ewoc-data tin) fi)
+ (eq (cvs-fileinfo->type fi) 'MESSAGE))
+ ;; tin < fi < next-tin
+ (ewoc-enter-after c tin fi)
+ ;; fi == tin
+ (cvs-fileinfo-update (ewoc-data tin) fi)
+ (ewoc-invalidate c tin)
+ ;; Move cursor back to where it belongs.
+ (when (bolp) (cvs-move-to-goal-column))
+ tin))))
+
+(defcustom cvs-cleanup-functions nil
+ "Functions to tweak the cleanup process.
+The functions are called with a single argument (a FILEINFO) and should
+return a non-nil value if that fileinfo should be removed."
+ :group 'pcl-cvs
+ :type '(hook :options (cvs-cleanup-removed)))
+
+(defun cvs-cleanup-removed (fi)
+ "Non-nil if FI has been cvs-removed but still exists.
+This is intended for use on `cvs-cleanup-functions' when you have cvs-removed
+automatically generated files (which should hence not be under CVS control)
+but can't commit the removal because the repository's owner doesn't understand
+the problem."
+ (and (or (eq (cvs-fileinfo->type fi) 'REMOVED)
+ (and (eq (cvs-fileinfo->type fi) 'CONFLICT)
+ (eq (cvs-fileinfo->subtype fi) 'REMOVED)))
+ (file-exists-p (cvs-fileinfo->full-name fi))))
+
+;; called at the following times:
+;; - postparse ((eq cvs-auto-remove-handled t) cvs-auto-remove-directories nil)
+;; - pre-run ((eq cvs-auto-remove-handled 'delayed) nil t)
+;; - remove-handled (t (or cvs-auto-remove-directories 'handled) t)
+;; - cvs-cmd-do (nil nil t)
+;; - post-ignore (nil nil nil)
+;; - acknowledge (nil nil nil)
+;; - remove (nil nil nil)
+(defun cvs-cleanup-collection (c rm-handled rm-dirs rm-msgs)
+ "Remove undesired entries.
+C is the collection
+RM-HANDLED if non-nil means remove handled entries.
+RM-DIRS behaves like `cvs-auto-remove-directories'.
+RM-MSGS if non-nil means remove messages."
+ (let (last-fi first-dir (rerun t))
+ (while rerun
+ (setq rerun nil)
+ (setq first-dir t)
+ (setq last-fi (cvs-create-fileinfo 'DEAD "../" "" "")) ;place-holder
+ (ewoc-filter
+ c (lambda (fi)
+ (let* ((type (cvs-fileinfo->type fi))
+ (subtype (cvs-fileinfo->subtype fi))
+ (keep
+ (case type
+ ;; remove temp messages and keep the others
+ (MESSAGE (not (or rm-msgs (eq subtype 'TEMP))))
+ ;; remove entries
+ (DEAD nil)
+ ;; handled also?
+ (UP-TO-DATE (not rm-handled))
+ ;; keep the rest
+ (t (not (run-hook-with-args-until-success
+ 'cvs-cleanup-functions fi))))))
+
+ ;; mark dirs for removal
+ (when (and keep rm-dirs
+ (eq (cvs-fileinfo->type last-fi) 'DIRCHANGE)
+ (not (when first-dir (setq first-dir nil) t))
+ (or (eq rm-dirs 'all)
+ (not (cvs-string-prefix-p
+ (cvs-fileinfo->dir last-fi)
+ (cvs-fileinfo->dir fi)))
+ (and (eq type 'DIRCHANGE) (eq rm-dirs 'empty))
+ (eq subtype 'FOOTER)))
+ (setf (cvs-fileinfo->type last-fi) 'DEAD)
+ (setq rerun t))
+ (when keep (setq last-fi fi)))))
+ ;; remove empty last dir
+ (when (and rm-dirs
+ (not first-dir)
+ (eq (cvs-fileinfo->type last-fi) 'DIRCHANGE))
+ (setf (cvs-fileinfo->type last-fi) 'DEAD)
+ (setq rerun t)))))
+
+(defun cvs-get-cvsroot ()
+ "Gets the CVSROOT for DIR."
+ (let ((cvs-cvsroot-file (expand-file-name "Root" "CVS")))
+ (or (cvs-file-to-string cvs-cvsroot-file t)
+ cvs-cvsroot
+ (getenv "CVSROOT")
+ "?????")))
+
+(defun cvs-get-module ()
+ "Return the current CVS module.
+This usually doesn't really work but is a handy initval in a prompt."
+ (let* ((repfile (expand-file-name "Repository" "CVS"))
+ (rep (cvs-file-to-string repfile t)))
+ (cond
+ ((null rep) "")
+ ((not (file-name-absolute-p rep)) rep)
+ (t
+ (let* ((root (cvs-get-cvsroot))
+ (str (concat (file-name-as-directory (or root "/")) " || " rep)))
+ (if (and root (string-match "\\(.*\\) || \\1\\(.*\\)\\'" str))
+ (match-string 2 str)
+ (file-name-nondirectory rep)))))))
+
+
+\f
+;;;;
+;;;; running a "cvs checkout".
+;;;;
+
+;;;###autoload
+(defun cvs-checkout (modules dir flags &optional root)
+ "Run a 'cvs checkout MODULES' in DIR.
+Feed the output to a *cvs* buffer, display it in the current window,
+and run `cvs-mode' on it.
+
+With a prefix argument, prompt for cvs FLAGS to use."
+ (interactive
+ (let ((root (cvs-get-cvsroot)))
+ (if (or (null root) current-prefix-arg)
+ (setq root (read-string "CVS Root: ")))
+ (list (split-string-and-unquote
+ (read-string "Module(s): " (cvs-get-module)))
+ (read-directory-name "CVS Checkout Directory: "
+ nil default-directory nil)
+ (cvs-add-branch-prefix
+ (cvs-flags-query 'cvs-checkout-flags "cvs checkout flags"))
+ root)))
+ (when (eq flags t)
+ (setf flags (cvs-flags-query 'cvs-checkout-flags nil 'noquery)))
+ (let ((cvs-cvsroot root))
+ (cvs-cmd-do "checkout" (or dir default-directory)
+ (append flags modules) nil 'new
+ :noexist t)))
+
+(defun-cvs-mode (cvs-mode-checkout . NOARGS) (dir)
+ "Run cvs checkout against the current branch.
+The files are stored to DIR."
+ (interactive
+ (let* ((branch (cvs-prefix-get 'cvs-branch-prefix))
+ (prompt (format "CVS Checkout Directory for `%s%s': "
+ (cvs-get-module)
+ (if branch (format " (branch: %s)" branch)
+ ""))))
+ (list (read-directory-name prompt nil default-directory nil))))
+ (let ((modules (split-string-and-unquote (cvs-get-module)))
+ (flags (cvs-add-branch-prefix
+ (cvs-flags-query 'cvs-checkout-flags "cvs checkout flags")))
+ (cvs-cvsroot (cvs-get-cvsroot)))
+ (cvs-checkout modules dir flags)))
+\f
+;;;;
+;;;; The code for running a "cvs update" and friends in various ways.
+;;;;
+
+(defun-cvs-mode (cvs-mode-revert-buffer . SIMPLE)
+ (&optional ignore-auto noconfirm)
+ "Rerun `cvs-examine' on the current directory with the default flags."
+ (interactive)
+ (cvs-examine default-directory t))
+
+(defun cvs-query-directory (prompt)
+ "Read directory name, prompting with PROMPT.
+If in a *cvs* buffer, don't prompt unless a prefix argument is given."
+ (if (and (cvs-buffer-p)
+ (not current-prefix-arg))
+ default-directory
+ (read-directory-name prompt nil default-directory nil)))
+
+;;;###autoload
+(defun cvs-quickdir (dir &optional flags noshow)
+ "Open a *cvs* buffer on DIR without running cvs.
+With a prefix argument, prompt for a directory to use.
+A prefix arg >8 (ex: \\[universal-argument] \\[universal-argument]),
+ prevents reuse of an existing *cvs* buffer.
+Optional argument NOSHOW if non-nil means not to display the buffer.
+FLAGS is ignored."
+ (interactive (list (cvs-query-directory "CVS quickdir (directory): ")))
+ ;; FIXME: code duplication with cvs-cmd-do and cvs-parse-process
+ (let* ((dir (file-name-as-directory
+ (abbreviate-file-name (expand-file-name dir))))
+ (new (> (prefix-numeric-value current-prefix-arg) 8))
+ (cvsbuf (cvs-make-cvs-buffer dir new))
+ last)
+ ;; Check that dir is under CVS control.
+ (unless (file-directory-p dir)
+ (error "%s is not a directory" dir))
+ (unless (file-directory-p (expand-file-name "CVS" dir))
+ (error "%s does not contain CVS controlled files" dir))
+ (set-buffer cvsbuf)
+ (dolist (fi (cvs-fileinfo-from-entries ""))
+ (setq last (cvs-addto-collection cvs-cookies fi last)))
+ (cvs-cleanup-collection cvs-cookies
+ (eq cvs-auto-remove-handled t)
+ cvs-auto-remove-directories
+ nil)
+ (if noshow cvsbuf
+ (let ((pop-up-windows nil)) (pop-to-buffer cvsbuf)))))
+
+;;;###autoload
+(defun cvs-examine (directory flags &optional noshow)
+ "Run a `cvs -n update' in the specified DIRECTORY.
+That is, check what needs to be done, but don't change the disc.
+Feed the output to a *cvs* buffer and run `cvs-mode' on it.
+With a prefix argument, prompt for a directory and cvs FLAGS to use.
+A prefix arg >8 (ex: \\[universal-argument] \\[universal-argument]),
+ prevents reuse of an existing *cvs* buffer.
+Optional argument NOSHOW if non-nil means not to display the buffer."
+ (interactive (list (cvs-query-directory "CVS Examine (directory): ")
+ (cvs-flags-query 'cvs-update-flags "cvs -n update flags")))
+ (when (eq flags t)
+ (setf flags (cvs-flags-query 'cvs-update-flags nil 'noquery)))
+ (when find-file-visit-truename (setq directory (file-truename directory)))
+ (cvs-cmd-do "update" directory flags nil
+ (> (prefix-numeric-value current-prefix-arg) 8)
+ :cvsargs '("-n")
+ :noshow noshow
+ :dont-change-disc t))
+
+
+;;;###autoload
+(defun cvs-update (directory flags)
+ "Run a `cvs update' in the current working DIRECTORY.
+Feed the output to a *cvs* buffer and run `cvs-mode' on it.
+With a \\[universal-argument] prefix argument, prompt for a directory to use.
+A prefix arg >8 (ex: \\[universal-argument] \\[universal-argument]),
+ prevents reuse of an existing *cvs* buffer.
+The prefix is also passed to `cvs-flags-query' to select the FLAGS
+ passed to cvs."
+ (interactive (list (cvs-query-directory "CVS Update (directory): ")
+ (cvs-flags-query 'cvs-update-flags "cvs update flags")))
+ (when (eq flags t)
+ (setf flags (cvs-flags-query 'cvs-update-flags nil 'noquery)))
+ (cvs-cmd-do "update" directory flags nil
+ (> (prefix-numeric-value current-prefix-arg) 8)))
+
+
+;;;###autoload
+(defun cvs-status (directory flags &optional noshow)
+ "Run a `cvs status' in the current working DIRECTORY.
+Feed the output to a *cvs* buffer and run `cvs-mode' on it.
+With a prefix argument, prompt for a directory and cvs FLAGS to use.
+A prefix arg >8 (ex: \\[universal-argument] \\[universal-argument]),
+ prevents reuse of an existing *cvs* buffer.
+Optional argument NOSHOW if non-nil means not to display the buffer."
+ (interactive (list (cvs-query-directory "CVS Status (directory): ")
+ (cvs-flags-query 'cvs-status-flags "cvs status flags")))
+ (when (eq flags t)
+ (setf flags (cvs-flags-query 'cvs-status-flags nil 'noquery)))
+ (cvs-cmd-do "status" directory flags nil
+ (> (prefix-numeric-value current-prefix-arg) 8)
+ :noshow noshow :dont-change-disc t))
+
+(defun cvs-update-filter (proc string)
+ "Filter function for pcl-cvs.
+This function gets the output that CVS sends to stdout. It inserts
+the STRING into (process-buffer PROC) but it also checks if CVS is waiting
+for a lock file. If so, it inserts a message cookie in the *cvs* buffer."
+ (save-match-data
+ (with-current-buffer (process-buffer proc)
+ (let ((inhibit-read-only t))
+ (save-excursion
+ ;; Insert the text, moving the process-marker.
+ (goto-char (process-mark proc))
+ (insert string)
+ (set-marker (process-mark proc) (point))
+ ;; FIXME: Delete any old lock message
+ ;;(if (tin-nth cookies 1)
+ ;; (tin-delete cookies
+ ;; (tin-nth cookies 1)))
+ ;; Check if CVS is waiting for a lock.
+ (beginning-of-line 0) ;Move to beginning of last complete line.
+ (when (looking-at "^[ a-z]+: \\(.*waiting for .*lock in \\(.*\\)\\)$")
+ (let ((msg (match-string 1))
+ (lock (match-string 2)))
+ (with-current-buffer cvs-buffer
+ (set (make-local-variable 'cvs-lock-file) lock)
+ ;; display the lock situation in the *cvs* buffer:
+ (ewoc-enter-last
+ cvs-cookies
+ (cvs-create-fileinfo
+ 'MESSAGE "" " "
+ (concat msg
+ (when (file-exists-p lock)
+ (substitute-command-keys
+ "\n\t(type \\[cvs-mode-delete-lock] to delete it)")))
+ :subtype 'TEMP))
+ (pop-to-buffer (current-buffer))
+ (goto-char (point-max))
+ (beep)))))))))
+
+\f
+;;;;
+;;;; The cvs-mode and its associated commands.
+;;;;
+
+(cvs-prefix-define cvs-force-command "" "" '("/F") cvs-qtypedesc-string1)
+(defun-cvs-mode cvs-mode-force-command (arg)
+ "Force the next cvs command to operate on all the selected files.
+By default, cvs commands only operate on files on which the command
+\"makes sense\". This overrides the safety feature on the next cvs command.
+It actually behaves as a toggle. If prefixed by \\[universal-argument] \\[universal-argument],
+the override will persist until the next toggle."
+ (interactive "P")
+ (cvs-prefix-set 'cvs-force-command arg))
+
+(put 'cvs-mode 'mode-class 'special)
+(define-derived-mode cvs-mode nil "CVS"
+ "Mode used for PCL-CVS, a frontend to CVS.
+Full documentation is in the Texinfo file."
+ (setq mode-line-process
+ '("" cvs-force-command cvs-ignore-marks-modif
+ ":" (cvs-branch-prefix
+ ("" cvs-branch-prefix (cvs-secondary-branch-prefix
+ ("->" cvs-secondary-branch-prefix))))
+ " " cvs-mode-line-process))
+ (if buffer-file-name
+ (error "Use M-x cvs-quickdir to get a *cvs* buffer"))
+ (buffer-disable-undo)
+ ;;(set (make-local-variable 'goal-column) cvs-cursor-column)
+ (set (make-local-variable 'revert-buffer-function) 'cvs-mode-revert-buffer)
+ (setq truncate-lines t)
+ (cvs-prefix-make-local 'cvs-branch-prefix)
+ (cvs-prefix-make-local 'cvs-secondary-branch-prefix)
+ (cvs-prefix-make-local 'cvs-force-command)
+ (cvs-prefix-make-local 'cvs-ignore-marks-modif)
+ (make-local-variable 'cvs-mode-line-process)
+ (make-local-variable 'cvs-temp-buffers))
+
+
+(defun cvs-buffer-p (&optional buffer)
+ "Return whether the (by default current) BUFFER is a `cvs-mode' buffer."
+ (save-excursion
+ (if buffer (set-buffer buffer))
+ (and (eq major-mode 'cvs-mode))))
+
+(defun cvs-buffer-check ()
+ "Check that the current buffer follows cvs-buffer's conventions."
+ (let ((buf (current-buffer))
+ (check 'none))
+ (or (and (setq check 'collection)
+ (eq (ewoc-buffer cvs-cookies) buf)
+ (setq check 'cvs-temp-buffer)
+ (or (null cvs-temp-buffer)
+ (null (buffer-live-p cvs-temp-buffer))
+ (and (eq (with-current-buffer cvs-temp-buffer cvs-buffer) buf)
+ (equal (with-current-buffer cvs-temp-buffer
+ default-directory)
+ default-directory)))
+ t)
+ (error "Inconsistent %s in buffer %s" check (buffer-name buf)))))
+
+
+(defun cvs-mode-quit ()
+ "Quit PCL-CVS, killing the *cvs* buffer."
+ (interactive)
+ (and (y-or-n-p "Quit pcl-cvs? ") (kill-buffer (current-buffer))))
+
+;; Give help....
+
+(defun cvs-help ()
+ "Display help for various PCL-CVS commands."
+ (interactive)
+ (if (eq last-command 'cvs-help)
+ (describe-function 'cvs-mode) ; would need minor-mode for log-edit-mode
+ (message "%s"
+ (substitute-command-keys
+ "`\\[cvs-help]':help `\\[cvs-mode-add]':add `\\[cvs-mode-commit]':commit \
+`\\[cvs-mode-diff-map]':diff* `\\[cvs-mode-log]':log \
+`\\[cvs-mode-remove]':remove `\\[cvs-mode-status]':status \
+`\\[cvs-mode-undo]':undo"))))
+
+;; Move around in the buffer
+
+(defun cvs-move-to-goal-column ()
+ (let* ((eol (line-end-position))
+ (fpos (next-single-property-change (point) 'cvs-goal-column nil eol)))
+ (when (< fpos eol)
+ (goto-char fpos))))
+
+(defun-cvs-mode cvs-mode-previous-line (arg)
+ "Go to the previous line.
+If a prefix argument is given, move by that many lines."
+ (interactive "p")
+ (ewoc-goto-prev cvs-cookies arg)
+ (cvs-move-to-goal-column))
+
+(defun-cvs-mode cvs-mode-next-line (arg)
+ "Go to the next line.
+If a prefix argument is given, move by that many lines."
+ (interactive "p")
+ (ewoc-goto-next cvs-cookies arg)
+ (cvs-move-to-goal-column))
+
+;;;;
+;;;; Mark handling
+;;;;
+
+(defun-cvs-mode cvs-mode-mark (&optional arg)
+ "Mark the fileinfo on the current line.
+If the fileinfo is a directory, all the contents of that directory are
+marked instead. A directory can never be marked."
+ (interactive)
+ (let* ((tin (ewoc-locate cvs-cookies))
+ (fi (ewoc-data tin)))
+ (if (eq (cvs-fileinfo->type fi) 'DIRCHANGE)
+ ;; it's a directory: let's mark all files inside
+ (ewoc-map
+ (lambda (f dir)
+ (when (cvs-dir-member-p f dir)
+ (setf (cvs-fileinfo->marked f)
+ (not (if (eq arg 'toggle) (cvs-fileinfo->marked f) arg)))
+ t)) ;Tell cookie to redisplay this cookie.
+ cvs-cookies
+ (cvs-fileinfo->dir fi))
+ ;; not a directory: just do the obvious
+ (setf (cvs-fileinfo->marked fi)
+ (not (if (eq arg 'toggle) (cvs-fileinfo->marked fi) arg)))
+ (ewoc-invalidate cvs-cookies tin)
+ (cvs-mode-next-line 1))))
+
+(defalias 'cvs-mouse-toggle-mark 'cvs-mode-toggle-mark)
+(defun cvs-mode-toggle-mark (e)
+ "Toggle the mark of the entry at point."
+ (interactive (list last-input-event))
+ (save-excursion
+ (posn-set-point (event-end e))
+ (cvs-mode-mark 'toggle)))
+
+(defun-cvs-mode cvs-mode-unmark ()
+ "Unmark the fileinfo on the current line."
+ (interactive)
+ (cvs-mode-mark t))
+
+(defun-cvs-mode cvs-mode-mark-all-files ()
+ "Mark all files."
+ (interactive)
+ (ewoc-map (lambda (cookie)
+ (unless (eq (cvs-fileinfo->type cookie) 'DIRCHANGE)
+ (setf (cvs-fileinfo->marked cookie) t)))
+ cvs-cookies))
+
+(defun-cvs-mode (cvs-mode-mark-on-state . SIMPLE) (state)
+ "Mark all files in state STATE."
+ (interactive
+ (list
+ (let ((default
+ (condition-case nil
+ (downcase
+ (symbol-name
+ (cvs-fileinfo->type
+ (cvs-mode-marked nil nil :read-only t :one t :noquery t))))
+ (error nil))))
+ (intern
+ (upcase
+ (completing-read
+ (concat
+ "Mark files in state" (if default (concat " [" default "]")) ": ")
+ (mapcar (lambda (x)
+ (list (downcase (symbol-name (car x)))))
+ cvs-states)
+ nil t nil nil default))))))
+ (ewoc-map (lambda (fi)
+ (when (eq (cvs-fileinfo->type fi) state)
+ (setf (cvs-fileinfo->marked fi) t)))
+ cvs-cookies))
+
+(defun-cvs-mode cvs-mode-mark-matching-files (regex)
+ "Mark all files matching REGEX."
+ (interactive "sMark files matching: ")
+ (ewoc-map (lambda (cookie)
+ (when (and (not (eq (cvs-fileinfo->type cookie) 'DIRCHANGE))
+ (string-match regex (cvs-fileinfo->file cookie)))
+ (setf (cvs-fileinfo->marked cookie) t)))
+ cvs-cookies))
+
+(defun-cvs-mode cvs-mode-unmark-all-files ()
+ "Unmark all files.
+Directories are also unmarked, but that doesn't matter, since
+they should always be unmarked."
+ (interactive)
+ (ewoc-map (lambda (cookie)
+ (setf (cvs-fileinfo->marked cookie) nil)
+ t)
+ cvs-cookies))
+
+(defun-cvs-mode cvs-mode-unmark-up ()
+ "Unmark the file on the previous line."
+ (interactive)
+ (let ((tin (ewoc-goto-prev cvs-cookies 1)))
+ (when tin
+ (setf (cvs-fileinfo->marked (ewoc-data tin)) nil)
+ (ewoc-invalidate cvs-cookies tin)))
+ (cvs-move-to-goal-column))
+
+(defconst cvs-ignore-marks-alternatives
+ '(("toggle-marks" . "/TM")
+ ("force-marks" . "/FM")
+ ("ignore-marks" . "/IM")))
+
+(cvs-prefix-define cvs-ignore-marks-modif
+ "Prefix to decide whether to ignore marks or not."
+ "active"
+ (mapcar 'cdr cvs-ignore-marks-alternatives)
+ (cvs-qtypedesc-create
+ (lambda (str) (cdr (assoc str cvs-ignore-marks-alternatives)))
+ (lambda (obj) (car (rassoc obj cvs-ignore-marks-alternatives)))
+ (lambda () cvs-ignore-marks-alternatives)
+ nil t))
+
+(defun-cvs-mode cvs-mode-toggle-marks (arg)
+ "Toggle whether the next CVS command uses marks.
+See `cvs-prefix-set' for further description of the behavior.
+\\[universal-argument] 1 selects `force-marks',
+\\[universal-argument] 2 selects `ignore-marks',
+\\[universal-argument] 3 selects `toggle-marks'."
+ (interactive "P")
+ (cvs-prefix-set 'cvs-ignore-marks-modif arg))
+
+(defun cvs-ignore-marks-p (cmd &optional read-only)
+ (let ((default (if (member cmd cvs-invert-ignore-marks)
+ (not cvs-default-ignore-marks)
+ cvs-default-ignore-marks))
+ (modif (cvs-prefix-get 'cvs-ignore-marks-modif read-only)))
+ (cond
+ ((equal modif "/IM") t)
+ ((equal modif "/TM") (not default))
+ ((equal modif "/FM") nil)
+ (t default))))
+
+(defun cvs-mode-mark-get-modif (cmd)
+ (if (cvs-ignore-marks-p cmd 'read-only) "/IM" "/FM"))
+
+(defun cvs-get-marked (&optional ignore-marks ignore-contents)
+ "Return a list of all selected fileinfos.
+If there are any marked tins, and IGNORE-MARKS is nil, return them.
+Otherwise, if the cursor selects a directory, and IGNORE-CONTENTS is
+nil, return all files in it, else return just the directory.
+Otherwise return (a list containing) the file the cursor points to, or
+an empty list if it doesn't point to a file at all."
+ (let ((fis nil))
+ (dolist (fi (if (and (boundp 'cvs-minor-current-files)
+ (consp cvs-minor-current-files))
+ (mapcar
+ (lambda (f)
+ (if (cvs-fileinfo-p f) f
+ (let ((f (file-relative-name f)))
+ (if (file-directory-p f)
+ (cvs-create-fileinfo
+ 'DIRCHANGE (file-name-as-directory f) "." "")
+ (let ((dir (file-name-directory f))
+ (file (file-name-nondirectory f)))
+ (cvs-create-fileinfo
+ 'UNKNOWN (or dir "") file ""))))))
+ cvs-minor-current-files)
+ (or (and (not ignore-marks)
+ (ewoc-collect cvs-cookies 'cvs-fileinfo->marked))
+ (list (ewoc-data (ewoc-locate cvs-cookies))))))
+
+ (if (or ignore-contents (not (eq (cvs-fileinfo->type fi) 'DIRCHANGE)))
+ (push fi fis)
+ ;; If a directory is selected, return members, if any.
+ (setq fis
+ (append (ewoc-collect
+ cvs-cookies 'cvs-dir-member-p (cvs-fileinfo->dir fi))
+ fis))))
+ (nreverse fis)))
+
+(defun* cvs-mode-marked (filter &optional cmd
+ &key read-only one file noquery)
+ "Get the list of marked FIS.
+CMD is used to determine whether to use the marks or not.
+Only files for which FILTER is applicable are returned.
+If READ-ONLY is non-nil, the current toggling is left intact.
+If ONE is non-nil, marks are ignored and a single FI is returned.
+If FILE is non-nil, directory entries won't be selected."
+ (unless cmd (setq cmd (symbol-name filter)))
+ (let* ((fis (cvs-get-marked (or one (cvs-ignore-marks-p cmd read-only))
+ (and (not file)
+ (cvs-applicable-p 'DIRCHANGE filter))))
+ (force (cvs-prefix-get 'cvs-force-command))
+ (fis (car (cvs-partition
+ (lambda (fi) (cvs-applicable-p fi (and (not force) filter)))
+ fis))))
+ (when (and (or (null fis) (and one (cdr fis))) (not noquery))
+ (message (if (null fis)
+ "`%s' is not applicable to any of the selected files."
+ "`%s' is only applicable to a single file.") cmd)
+ (sit-for 1)
+ (setq fis (list (cvs-insert-file
+ (read-file-name (format "File to %s: " cmd))))))
+ (if one (car fis) fis)))
+
+(defun cvs-enabledp (filter)
+ "Determine whether FILTER applies to at least one of the selected files."
+ (ignore-errors (cvs-mode-marked filter nil :read-only t :noquery t)))
+
+(defun cvs-mode-files (&rest -cvs-mode-files-args)
+ (cvs-mode!
+ (lambda ()
+ (mapcar 'cvs-fileinfo->full-name
+ (apply 'cvs-mode-marked -cvs-mode-files-args)))))
+
+;;
+;; Interface between Log-Edit and PCL-CVS
+;;
+
+(defun cvs-mode-commit-setup ()
+ "Run `cvs-mode-commit' with setup."
+ (interactive)
+ (cvs-mode-commit 'force))
+
+(defcustom cvs-mode-commit-hook nil
+ "Hook run after setting up the commit buffer."
+ :type 'hook
+ :options '(cvs-mode-diff)
+ :group 'pcl-cvs)
+
+(defun cvs-mode-commit (setup)
+ "Check in all marked files, or the current file.
+The user will be asked for a log message in a buffer.
+The buffer's mode and name is determined by the \"message\" setting
+ of `cvs-buffer-name-alist'.
+The POSTPROC specified there (typically `log-edit') is then called,
+ passing it the SETUP argument."
+ (interactive "P")
+ ;; It seems that the save-excursion that happens if I use the better
+ ;; form of `(cvs-mode! (lambda ...))' screws up a couple things which
+ ;; end up being rather annoying (like log-edit-mode's message being
+ ;; displayed in the wrong minibuffer).
+ (cvs-mode!)
+ (let ((buf (cvs-temp-buffer "message" 'normal 'nosetup))
+ (setupfun (or (nth 2 (cdr (assoc "message" cvs-buffer-name-alist)))
+ 'log-edit)))
+ (funcall setupfun 'cvs-do-commit setup
+ '((log-edit-listfun . cvs-commit-filelist)
+ (log-edit-diff-function . cvs-mode-diff)) buf)
+ (set (make-local-variable 'cvs-minor-wrap-function) 'cvs-commit-minor-wrap)
+ (run-hooks 'cvs-mode-commit-hook)))
+
+(defun cvs-commit-minor-wrap (buf f)
+ (let ((cvs-ignore-marks-modif (cvs-mode-mark-get-modif "commit")))
+ (funcall f)))
+
+(defun cvs-commit-filelist ()
+ (cvs-mode-files 'commit nil :read-only t :file t :noquery t))
+
+(defun cvs-do-commit (flags)
+ "Do the actual commit, using the current buffer as the log message."
+ (interactive (list (cvs-flags-query 'cvs-commit-flags "cvs commit flags")))
+ (let ((msg (buffer-substring-no-properties (point-min) (point-max))))
+ (cvs-mode!)
+ ;;(pop-to-buffer cvs-buffer)
+ (cvs-mode-do "commit" (list* "-m" msg flags) 'commit)))
+
+
+;;;; Editing existing commit log messages.
+
+(defun cvs-edit-log-text-at-point ()
+ (save-excursion
+ (end-of-line)
+ (when (re-search-backward "^revision " nil t)
+ (forward-line 1)
+ (if (looking-at "date:") (forward-line 1))
+ (if (looking-at "branches:") (forward-line 1))
+ (buffer-substring
+ (point)
+ (if (re-search-forward
+ "^\\(-\\{28\\}\\|=\\{77\\}\\|revision [.0-9]+\\)$"
+ nil t)
+ (match-beginning 0)
+ (point))))))
+
+(defvar cvs-edit-log-revision)
+(defvar cvs-edit-log-files) (put 'cvs-edit-log-files 'permanent-local t)
+(defun cvs-mode-edit-log (file rev &optional text)
+ "Edit the log message at point.
+This is best called from a `log-view-mode' buffer."
+ (interactive
+ (list
+ (or (cvs-mode! (lambda ()
+ (car (cvs-mode-files nil nil
+ :read-only t :file t :noquery t))))
+ (read-string "File name: "))
+ (or (cvs-mode! (lambda () (cvs-prefix-get 'cvs-branch-prefix)))
+ (read-string "Revision to edit: "))
+ (cvs-edit-log-text-at-point)))
+ ;; It seems that the save-excursion that happens if I use the better
+ ;; form of `(cvs-mode! (lambda ...))' screws up a couple things which
+ ;; end up being rather annoying (like log-edit-mode's message being
+ ;; displayed in the wrong minibuffer).
+ (cvs-mode!)
+ (let ((buf (cvs-temp-buffer "message" 'normal 'nosetup))
+ (setupfun (or (nth 2 (cdr (assoc "message" cvs-buffer-name-alist)))
+ 'log-edit)))
+ (with-current-buffer buf
+ ;; Set the filename before, so log-edit can correctly setup its
+ ;; log-edit-initial-files variable.
+ (set (make-local-variable 'cvs-edit-log-files) (list file)))
+ (funcall setupfun 'cvs-do-edit-log nil
+ '((log-edit-listfun . cvs-edit-log-filelist)
+ (log-edit-diff-function . cvs-mode-diff))
+ buf)
+ (when text (erase-buffer) (insert text))
+ (set (make-local-variable 'cvs-edit-log-revision) rev)
+ (set (make-local-variable 'cvs-minor-wrap-function)
+ 'cvs-edit-log-minor-wrap)
+ ;; (run-hooks 'cvs-mode-commit-hook)
+ ))
+
+(defun cvs-edit-log-minor-wrap (buf f)
+ (let ((cvs-branch-prefix (with-current-buffer buf cvs-edit-log-revision))
+ (cvs-minor-current-files
+ (with-current-buffer buf cvs-edit-log-files))
+ ;; FIXME: I need to force because the fileinfos are UNKNOWN
+ (cvs-force-command "/F"))
+ (funcall f)))
+
+(defun cvs-edit-log-filelist ()
+ (if cvs-minor-wrap-function
+ (cvs-mode-files nil nil :read-only t :file t :noquery t)
+ cvs-edit-log-files))
+
+(defun cvs-do-edit-log (rev)
+ "Do the actual commit, using the current buffer as the log message."
+ (interactive (list cvs-edit-log-revision))
+ (let ((msg (buffer-substring-no-properties (point-min) (point-max))))
+ (cvs-mode!
+ (lambda ()
+ (cvs-mode-do "admin" (list (concat "-m" rev ":" msg)) nil)))))
+
+
+;;;;
+;;;; CVS Mode commands
+;;;;
+
+(defun-cvs-mode (cvs-mode-insert . NOARGS) (file)
+ "Insert an entry for a specific file into the current listing.
+This is typically used if the file is up-to-date (or has been added
+outside of PCL-CVS) and one wants to do some operation on it."
+ (interactive
+ (list (read-file-name
+ "File to insert: "
+ ;; Can't use ignore-errors here because interactive
+ ;; specs aren't byte-compiled.
+ (condition-case nil
+ (file-name-as-directory
+ (expand-file-name
+ (cvs-fileinfo->dir
+ (cvs-mode-marked nil nil :read-only t :one t :noquery t))))
+ (error nil)))))
+ (cvs-insert-file file))
+
+(defun cvs-insert-file (file)
+ "Insert FILE (and its contents if it's a dir) and return its FI."
+ (let ((file (file-relative-name (directory-file-name file))) last)
+ (dolist (fi (cvs-fileinfo-from-entries file))
+ (setq last (cvs-addto-collection cvs-cookies fi last)))
+ ;; There should have been at least one entry.
+ (goto-char (ewoc-location last))
+ (ewoc-data last)))
+
+(defun cvs-mark-fis-dead (fis)
+ ;; Helper function, introduced because of the need for macro-expansion.
+ (dolist (fi fis)
+ (setf (cvs-fileinfo->type fi) 'DEAD)))
+
+(defun-cvs-mode (cvs-mode-add . SIMPLE) (flags)
+ "Add marked files to the cvs repository.
+With prefix argument, prompt for cvs flags."
+ (interactive (list (cvs-flags-query 'cvs-add-flags "cvs add flags")))
+ (let ((fis (cvs-mode-marked 'add))
+ (needdesc nil) (dirs nil))
+ ;; find directories and look for fis needing a description
+ (dolist (fi fis)
+ (cond
+ ((file-directory-p (cvs-fileinfo->full-name fi)) (push fi dirs))
+ ((eq (cvs-fileinfo->type fi) 'UNKNOWN) (setq needdesc t))))
+ ;; prompt for description if necessary
+ (let* ((msg (if (and needdesc
+ (or current-prefix-arg (not cvs-add-default-message)))
+ (read-from-minibuffer "Enter description: ")
+ (or cvs-add-default-message "")))
+ (flags (list* "-m" msg flags))
+ (postproc
+ ;; setup postprocessing for the directory entries
+ (when dirs
+ `((cvs-run-process (list "-n" "update")
+ ',dirs
+ '(cvs-parse-process t))
+ (cvs-mark-fis-dead ',dirs)))))
+ (cvs-mode-run "add" flags fis :postproc postproc))))
+
+(defun-cvs-mode (cvs-mode-diff . DOUBLE) (flags)
+ "Diff the selected files against the repository.
+This command compares the files in your working area against the
+revision which they are based upon."
+ (interactive
+ (list (cvs-add-branch-prefix
+ (cvs-add-secondary-branch-prefix
+ (cvs-flags-query 'cvs-diff-flags "cvs diff flags")))))
+ (cvs-mode-do "diff" flags 'diff
+ :show t)) ;; :ignore-exit t
+
+(defun-cvs-mode (cvs-mode-diff-head . SIMPLE) (flags)
+ "Diff the selected files against the head of the current branch.
+See ``cvs-mode-diff'' for more info."
+ (interactive (list (cvs-flags-query 'cvs-diff-flags "cvs diff flags")))
+ (cvs-mode-diff-1 (cons "-rHEAD" flags)))
+
+(defun-cvs-mode (cvs-mode-diff-repository . SIMPLE) (flags)
+ "Diff the files for changes in the repository since last co/update/commit.
+See ``cvs-mode-diff'' for more info."
+ (interactive (list (cvs-flags-query 'cvs-diff-flags "cvs diff flags")))
+ (cvs-mode-diff-1 (cons "-rBASE" (cons "-rHEAD" flags))))
+
+(defun-cvs-mode (cvs-mode-diff-yesterday . SIMPLE) (flags)
+ "Diff the selected files against yesterday's head of the current branch.
+See ``cvs-mode-diff'' for more info."
+ (interactive (list (cvs-flags-query 'cvs-diff-flags "cvs diff flags")))
+ (cvs-mode-diff-1 (cons "-Dyesterday" flags)))
+
+(defun-cvs-mode (cvs-mode-diff-vendor . SIMPLE) (flags)
+ "Diff the selected files against the head of the vendor branch.
+See ``cvs-mode-diff'' for more info."
+ (interactive (list (cvs-flags-query 'cvs-diff-flags "cvs diff flags")))
+ (cvs-mode-diff-1 (cons (concat "-r" cvs-vendor-branch) flags)))
+
+;; sadly, this is not provided by cvs, so we have to roll our own
+(defun-cvs-mode (cvs-mode-diff-backup . SIMPLE) (flags)
+ "Diff the files against the backup file.
+This command can be used on files that are marked with \"Merged\"
+or \"Conflict\" in the *cvs* buffer."
+ (interactive (list (cvs-flags-query 'cvs-diff-flags "diff flags")))
+ (unless (listp flags) (error "flags should be a list of strings"))
+ (save-some-buffers)
+ (let* ((marked (cvs-get-marked (cvs-ignore-marks-p "diff")))
+ (fis (car (cvs-partition 'cvs-fileinfo->backup-file marked))))
+ (unless (consp fis)
+ (error "No files with a backup file selected!"))
+ ;; let's extract some info into the environment for `buffer-name'
+ (let* ((dir (cvs-fileinfo->dir (car fis)))
+ (file (cvs-fileinfo->file (car fis))))
+ (set-buffer (cvs-temp-buffer "diff")))
+ (message "cvs diff backup...")
+ (cvs-execute-single-file-list fis 'cvs-diff-backup-extractor
+ cvs-diff-program flags))
+ (message "cvs diff backup... Done."))
+
+(defun cvs-diff-backup-extractor (fileinfo)
+ "Return the filename and the name of the backup file as a list.
+Signal an error if there is no backup file."
+ (let ((backup-file (cvs-fileinfo->backup-file fileinfo)))
+ (unless backup-file
+ (error "%s has no backup file" (cvs-fileinfo->full-name fileinfo)))
+ (list backup-file (cvs-fileinfo->full-name fileinfo))))
+
+;;
+;; Emerge support
+;;
+(defun cvs-emerge-diff (b1 b2) (emerge-buffers b1 b2 b1))
+(defun cvs-emerge-merge (b1 b2 base out)
+ (emerge-buffers-with-ancestor b1 b2 base (find-file-noselect out)))
+
+;;
+;; Ediff support
+;;
+
+(defvar ediff-after-quit-destination-buffer)
+(defvar ediff-after-quit-hook-internal)
+(defvar cvs-transient-buffers)
+(defun cvs-ediff-startup-hook ()
+ (add-hook 'ediff-after-quit-hook-internal
+ `(lambda ()
+ (cvs-ediff-exit-hook
+ ',ediff-after-quit-destination-buffer ',cvs-transient-buffers))
+ nil 'local))
+
+(defun cvs-ediff-exit-hook (cvs-buf tmp-bufs)
+ ;; kill the temp buffers (and their associated windows)
+ (dolist (tb tmp-bufs)
+ (when (and tb (buffer-live-p tb) (not (buffer-modified-p tb)))
+ (let ((win (get-buffer-window tb t)))
+ (kill-buffer tb)
+ (when (window-live-p win) (ignore-errors (delete-window win))))))
+ ;; switch back to the *cvs* buffer
+ (when (and cvs-buf (buffer-live-p cvs-buf)
+ (not (get-buffer-window cvs-buf t)))
+ (ignore-errors (switch-to-buffer cvs-buf))))
+
+(defun cvs-ediff-diff (b1 b2)
+ (let ((ediff-after-quit-destination-buffer (current-buffer))
+ (startup-hook '(cvs-ediff-startup-hook)))
+ (ediff-buffers b1 b2 startup-hook 'ediff-revision)))
+
+(defun cvs-ediff-merge (b1 b2 base out)
+ (let ((ediff-after-quit-destination-buffer (current-buffer))
+ (startup-hook '(cvs-ediff-startup-hook)))
+ (ediff-merge-buffers-with-ancestor
+ b1 b2 base startup-hook
+ 'ediff-merge-revisions-with-ancestor
+ out)))
+
+;;
+;; Interactive merge/diff support.
+;;
+
+(defun cvs-retrieve-revision (fileinfo rev)
+ "Retrieve the given REVision of the file in FILEINFO into a new buffer."
+ (let* ((file (cvs-fileinfo->full-name fileinfo))
+ (buffile (concat file "." rev)))
+ (or (find-buffer-visiting buffile)
+ (with-current-buffer (create-file-buffer buffile)
+ (message "Retrieving revision %s..." rev)
+ ;; Discard stderr output to work around the CVS+SSH+libc
+ ;; problem when stdout and stderr are the same.
+ (let ((res
+ (let ((coding-system-for-read 'binary))
+ (apply 'process-file cvs-program nil '(t nil) nil
+ "-q" "update" "-p"
+ ;; If `rev' is HEAD, don't pass it at all:
+ ;; the default behavior is to get the head
+ ;; of the current branch whereas "-r HEAD"
+ ;; stupidly gives you the head of the trunk.
+ (append (unless (equal rev "HEAD") (list "-r" rev))
+ (list file))))))
+ (when (and res (not (and (equal 0 res))))
+ (error "Something went wrong retrieving revision %s: %s" rev res))
+ ;; Figure out the encoding used and decode the byte-sequence
+ ;; into a sequence of chars.
+ (decode-coding-inserted-region
+ (point-min) (point-max) file t nil nil t)
+ ;; Set buffer-file-coding-system.
+ (after-insert-file-set-coding (buffer-size) t)
+ (set-buffer-modified-p nil)
+ (let ((buffer-file-name (expand-file-name file)))
+ (after-find-file))
+ (toggle-read-only 1)
+ (message "Retrieving revision %s... Done" rev)
+ (current-buffer))))))
+
+;; FIXME: The user should be able to specify ancestor/head/backup and we should
+;; provide sensible defaults when merge info is unavailable (rather than rely
+;; on smerge-ediff). Also provide sane defaults for need-merge files.
+(defun-cvs-mode cvs-mode-imerge ()
+ "Merge interactively appropriate revisions of the selected file."
+ (interactive)
+ (let ((fi (cvs-mode-marked 'merge nil :one t :file t)))
+ (let ((merge (cvs-fileinfo->merge fi))
+ (file (cvs-fileinfo->full-name fi))
+ (backup-file (cvs-fileinfo->backup-file fi)))
+ (if (not (and merge backup-file))
+ (let ((buf (find-file-noselect file)))
+ (message "Missing merge info or backup file, using VC.")
+ (with-current-buffer buf
+ (smerge-ediff)))
+ (let* ((ancestor-buf (cvs-retrieve-revision fi (car merge)))
+ (head-buf (cvs-retrieve-revision fi (cdr merge)))
+ (backup-buf (let ((auto-mode-alist nil))
+ (find-file-noselect backup-file)))
+ ;; this binding is used by cvs-ediff-startup-hook
+ (cvs-transient-buffers (list ancestor-buf backup-buf head-buf)))
+ (with-current-buffer backup-buf
+ (let ((buffer-file-name (expand-file-name file)))
+ (after-find-file)))
+ (funcall (cdr cvs-idiff-imerge-handlers)
+ backup-buf head-buf ancestor-buf file))))))
+
+(cvs-flags-define cvs-idiff-version
+ (list "BASE" cvs-vendor-branch cvs-vendor-branch "BASE" "BASE")
+ "version: " cvs-qtypedesc-tag)
+
+(defun-cvs-mode (cvs-mode-idiff . NOARGS) (&optional rev1 rev2)
+ "Diff interactively current file to revisions."
+ (interactive
+ (let* ((rev1 (cvs-prefix-get 'cvs-branch-prefix))
+ (rev2 (and rev1 (cvs-prefix-get 'cvs-secondary-branch-prefix))))
+ (list (or rev1 (cvs-flags-query 'cvs-idiff-version))
+ rev2)))
+ (let ((fi (cvs-mode-marked 'diff "idiff" :one t :file t)))
+ (let* ((file (cvs-fileinfo->full-name fi))
+ (rev1-buf (cvs-retrieve-revision fi (or rev1 "BASE")))
+ (rev2-buf (if rev2 (cvs-retrieve-revision fi rev2)))
+ ;; this binding is used by cvs-ediff-startup-hook
+ (cvs-transient-buffers (list rev1-buf rev2-buf)))
+ (funcall (car cvs-idiff-imerge-handlers)
+ rev1-buf (or rev2-buf (find-file-noselect file))))))
+
+(defun-cvs-mode (cvs-mode-idiff-other . NOARGS) ()
+ "Diff interactively current file to revisions."
+ (interactive)
+ (let* ((rev1 (cvs-prefix-get 'cvs-branch-prefix))
+ (rev2 (and rev1 (cvs-prefix-get 'cvs-secondary-branch-prefix)))
+ (fis (cvs-mode-marked 'diff "idiff" :file t)))
+ (when (> (length fis) 2)
+ (error "idiff-other cannot be applied to more than 2 files at a time"))
+ (let* ((fi1 (car fis))
+ (rev1-buf (if rev1 (cvs-retrieve-revision fi1 rev1)
+ (find-file-noselect (cvs-fileinfo->full-name fi1))))
+ rev2-buf)
+ (if (cdr fis)
+ (let ((fi2 (nth 1 fis)))
+ (setq rev2-buf
+ (if rev2 (cvs-retrieve-revision fi2 rev2)
+ (find-file-noselect (cvs-fileinfo->full-name fi2)))))
+ (error "idiff-other doesn't know what other file/buffer to use"))
+ (let* (;; this binding is used by cvs-ediff-startup-hook
+ (cvs-transient-buffers (list rev1-buf rev2-buf)))
+ (funcall (car cvs-idiff-imerge-handlers)
+ rev1-buf rev2-buf)))))
+
+
+(defun cvs-is-within-p (fis dir)
+ "Non-nil if buffer is inside one of FIS (in DIR)."
+ (when (stringp buffer-file-name)
+ (setq buffer-file-name (expand-file-name buffer-file-name))
+ (let (ret)
+ (dolist (fi (or fis (list (cvs-create-fileinfo 'DIRCHANGE "" "." ""))))
+ (when (cvs-string-prefix-p
+ (expand-file-name (cvs-fileinfo->full-name fi) dir)
+ buffer-file-name)
+ (setq ret t)))
+ ret)))
+
+(defun* cvs-mode-run (cmd flags fis
+ &key (buf (cvs-temp-buffer))
+ dont-change-disc cvsargs postproc)
+ "Generic cvs-mode-<foo> function.
+Executes `cvs CVSARGS CMD FLAGS FIS'.
+BUF is the buffer to be used for cvs' output.
+DONT-CHANGE-DISC non-nil indicates that the command will not change the
+ contents of files. This is only used by the parser.
+POSTPROC is a list of expressions to be evaluated at the very end (after
+ parsing if applicable). It will be prepended with `progn' if necessary."
+ (let ((def-dir default-directory))
+ ;; Save the relevant buffers
+ (save-some-buffers nil (lambda () (cvs-is-within-p fis def-dir))))
+ (unless (listp flags) (error "flags should be a list of strings"))
+ ;; Some w32 versions of CVS don't like an explicit . too much.
+ (when (and (car fis) (null (cdr fis))
+ (eq (cvs-fileinfo->type (car fis)) 'DIRCHANGE)
+ ;; (equal (cvs-fileinfo->file (car fis)) ".")
+ (equal (cvs-fileinfo->dir (car fis)) ""))
+ (setq fis nil))
+ (let* ((single-dir (or (not (listp cvs-execute-single-dir))
+ (member cmd cvs-execute-single-dir)))
+ (parse (member cmd cvs-parse-known-commands))
+ (args (append cvsargs (list cmd) flags))
+ (after-mode (nth 2 (cdr (assoc cmd cvs-buffer-name-alist)))))
+ (cvs-cleanup-collection cvs-cookies ;cleanup remaining messages
+ (eq cvs-auto-remove-handled 'delayed) nil t)
+ (when (fboundp after-mode)
+ (setq postproc (append postproc `((,after-mode)))))
+ (when parse
+ (let ((old-fis
+ (when (member cmd '("status" "update")) ;FIXME: Yuck!!
+ ;; absence of `cvs update' output has a specific meaning.
+ (or fis (list (cvs-create-fileinfo 'DIRCHANGE "" "." ""))))))
+ (push `(cvs-parse-process ',dont-change-disc nil ',old-fis) postproc)))
+ (setq postproc (if (cdr postproc) (cons 'progn postproc) (car postproc)))
+ (with-current-buffer buf
+ (let ((inhibit-read-only t)) (erase-buffer))
+ (message "Running cvs %s ..." cmd)
+ (cvs-run-process args fis postproc single-dir))))
+
+
+(defun* cvs-mode-do (cmd flags filter
+ &key show dont-change-disc cvsargs postproc)
+ "Generic cvs-mode-<foo> function.
+Executes `cvs CVSARGS CMD FLAGS' on the selected files.
+FILTER is passed to `cvs-applicable-p' to only apply the command to
+ files for which it makes sense.
+SHOW indicates that CMD should be not be run in the default temp buffer and
+ should be shown to the user. The buffer and mode to be used is determined
+ by `cvs-buffer-name-alist'.
+DONT-CHANGE-DISC non-nil indicates that the command will not change the
+ contents of files. This is only used by the parser."
+ (cvs-mode-run cmd flags (cvs-mode-marked filter cmd)
+ :buf (cvs-temp-buffer (when show cmd))
+ :dont-change-disc dont-change-disc
+ :cvsargs cvsargs
+ :postproc postproc))
+
+(defun-cvs-mode (cvs-mode-status . SIMPLE) (flags)
+ "Show cvs status for all marked files.
+With prefix argument, prompt for cvs flags."
+ (interactive (list (cvs-flags-query 'cvs-status-flags "cvs status flags")))
+ (cvs-mode-do "status" flags nil :dont-change-disc t :show t
+ :postproc (when (eq cvs-auto-remove-handled 'status)
+ `((with-current-buffer ,(current-buffer)
+ (cvs-mode-remove-handled))))))
+
+(defun-cvs-mode (cvs-mode-tree . SIMPLE) (flags)
+ "Call cvstree using the file under the point as a keyfile."
+ (interactive (list (cvs-flags-query 'cvs-status-flags "cvs status flags")))
+ (cvs-mode-run "status" (cons "-v" flags) (cvs-mode-marked nil "status")
+ :buf (cvs-temp-buffer "tree")
+ :dont-change-disc t
+ :postproc '((cvs-status-cvstrees))))
+
+;; cvs log
+
+(defun-cvs-mode (cvs-mode-log . NOARGS) (flags)
+ "Display the cvs log of all selected files.
+With prefix argument, prompt for cvs flags."
+ (interactive (list (cvs-add-branch-prefix
+ (cvs-flags-query 'cvs-log-flags "cvs log flags"))))
+ (cvs-mode-do "log" flags nil :show t))
+
+
+(defun-cvs-mode (cvs-mode-update . NOARGS) (flags)
+ "Update all marked files.
+With a prefix argument, prompt for cvs flags."
+ (interactive
+ (list (cvs-add-branch-prefix
+ (cvs-add-secondary-branch-prefix
+ (cvs-flags-query 'cvs-update-flags "cvs update flags")
+ "-j") "-j")))
+ (cvs-mode-do "update" flags 'update))
+
+
+(defun-cvs-mode (cvs-mode-examine . NOARGS) (flags)
+ "Re-examine all marked files.
+With a prefix argument, prompt for cvs flags."
+ (interactive
+ (list (cvs-add-branch-prefix
+ (cvs-add-secondary-branch-prefix
+ (cvs-flags-query 'cvs-update-flags "cvs -n update flags")
+ "-j") "-j")))
+ (cvs-mode-do "update" flags nil :cvsargs '("-n") :dont-change-disc t))
+
+
+(defun-cvs-mode cvs-mode-ignore (&optional pattern)
+ "Arrange so that CVS ignores the selected files.
+This command ignores files that are not flagged as `Unknown'."
+ (interactive)
+ (dolist (fi (cvs-mode-marked 'ignore))
+ (cvs-append-to-ignore (cvs-fileinfo->dir fi) (cvs-fileinfo->file fi)
+ (eq (cvs-fileinfo->subtype fi) 'NEW-DIR))
+ (setf (cvs-fileinfo->type fi) 'DEAD))
+ (cvs-cleanup-collection cvs-cookies nil nil nil))
+
+(declare-function vc-editable-p "vc" (file))
+(declare-function vc-checkout "vc" (file &optional writable rev))
+
+(defun cvs-append-to-ignore (dir str &optional old-dir)
+ "Add STR to the .cvsignore file in DIR.
+If OLD-DIR is non-nil, then this is a directory that we don't want
+to hear about anymore."
+ (with-current-buffer
+ (find-file-noselect (expand-file-name ".cvsignore" dir))
+ (when (ignore-errors
+ (and buffer-read-only
+ (eq 'CVS (vc-backend buffer-file-name))
+ (not (vc-editable-p buffer-file-name))))
+ ;; CVSREAD=on special case
+ (vc-checkout buffer-file-name t))
+ (goto-char (point-max))
+ (unless (bolp) (insert "\n"))
+ (insert str (if old-dir "/\n" "\n"))
+ (if cvs-sort-ignore-file (sort-lines nil (point-min) (point-max)))
+ (save-buffer)))
+
+
+(defun cvs-mode-find-file-other-window (e)
+ "Select a buffer containing the file in another window."
+ (interactive (list last-input-event))
+ (cvs-mode-find-file e t))
+
+
+(defun cvs-mode-display-file (e)
+ "Show a buffer containing the file in another window."
+ (interactive (list last-input-event))
+ (cvs-mode-find-file e 'dont-select))
+
+
+(defun cvs-mode-view-file (e)
+ "View the file."
+ (interactive (list last-input-event))
+ (cvs-mode-find-file e nil t))
+
+
+(defun cvs-mode-view-file-other-window (e)
+ "View the file."
+ (interactive (list last-input-event))
+ (cvs-mode-find-file e t t))
+
+
+(defun cvs-find-modif (fi)
+ (with-temp-buffer
+ (process-file cvs-program nil (current-buffer) nil
+ "-f" "diff" (cvs-fileinfo->file fi))
+ (goto-char (point-min))
+ (if (re-search-forward "^\\([0-9]+\\)" nil t)
+ (string-to-number (match-string 1))
+ 1)))
+
+
+(defun cvs-mode-find-file (e &optional other view)
+ "Select a buffer containing the file.
+With a prefix, opens the buffer in an OTHER window."
+ (interactive (list last-input-event current-prefix-arg))
+ ;; If the event moves point, check that it moves it to a valid location.
+ (when (and (/= (point) (progn (posn-set-point (event-end e)) (point)))
+ (not (memq (get-text-property (1- (line-end-position))
+ 'font-lock-face)
+ '(cvs-header cvs-filename))))
+ (error "Not a file name"))
+ (cvs-mode!
+ (lambda (&optional rev)
+ (interactive (list (cvs-prefix-get 'cvs-branch-prefix)))
+ (let* ((cvs-buf (current-buffer))
+ (fi (cvs-mode-marked nil nil :one t)))
+ (if (eq (cvs-fileinfo->type fi) 'DIRCHANGE)
+ (let ((odir default-directory))
+ (setq default-directory
+ (cvs-expand-dir-name (cvs-fileinfo->dir fi)))
+ (cond ((eq other 'dont-select)
+ (display-buffer (find-file-noselect default-directory)))
+ (other (dired-other-window default-directory))
+ (t (dired default-directory)))
+ (set-buffer cvs-buf)
+ (setq default-directory odir))
+ (let ((buf (if rev (cvs-retrieve-revision fi rev)
+ (find-file-noselect (cvs-fileinfo->full-name fi)))))
+ (funcall (cond ((eq other 'dont-select) 'display-buffer)
+ (other
+ (if view 'view-buffer-other-window
+ 'switch-to-buffer-other-window))
+ (t (if view 'view-buffer 'switch-to-buffer)))
+ buf)
+ (when (and cvs-find-file-and-jump (cvs-applicable-p fi 'diff-base))
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (forward-line (1- (cvs-find-modif fi)))))
+ buf))))))
+
+
+(defun-cvs-mode (cvs-mode-undo . SIMPLE) (flags)
+ "Undo local changes to all marked files.
+The file is removed and `cvs update FILE' is run."
+ ;;"With prefix argument, prompt for cvs FLAGS."
+ (interactive (list nil));; (cvs-flags-query 'cvs-undo-flags "undo flags")
+ (if current-prefix-arg (call-interactively 'cvs-mode-revert-to-rev)
+ (let* ((fis (cvs-do-removal 'undo "update" 'all))
+ (removedp (lambda (fi)
+ (or (eq (cvs-fileinfo->type fi) 'REMOVED)
+ (and (eq (cvs-fileinfo->type fi) 'CONFLICT)
+ (eq (cvs-fileinfo->subtype fi) 'REMOVED)))))
+ (fis-split (cvs-partition removedp fis))
+ (fis-removed (car fis-split))
+ (fis-other (cdr fis-split)))
+ (if (null fis-other)
+ (when fis-removed (cvs-mode-run "add" nil fis-removed))
+ (cvs-mode-run "update" flags fis-other
+ :postproc
+ (when fis-removed
+ `((with-current-buffer ,(current-buffer)
+ (cvs-mode-run "add" nil ',fis-removed)))))))))
+
+
+(defun-cvs-mode (cvs-mode-revert-to-rev . NOARGS) (rev)
+ "Revert the selected files to an old revision."
+ (interactive
+ (list (or (cvs-prefix-get 'cvs-branch-prefix)
+ (let ((current-prefix-arg '(4)))
+ (cvs-flags-query 'cvs-idiff-version)))))
+ (let* ((fis (cvs-mode-marked 'revert "revert" :file t))
+ (tag (concat "tmp_pcl_tag_" (make-temp-name "")))
+ (untag `((with-current-buffer ,(current-buffer)
+ (cvs-mode-run "tag" (list "-d" ',tag) ',fis))))
+ (update `((with-current-buffer ,(current-buffer)
+ (cvs-mode-run "update" (list "-j" ',tag "-j" ',rev) ',fis
+ :postproc ',untag)))))
+ (cvs-mode-run "tag" (list tag) fis :postproc update)))
+
+
+(defun-cvs-mode cvs-mode-delete-lock ()
+ "Delete the lock file that CVS is waiting for.
+Note that this can be dangerous. You should only do this
+if you are convinced that the process that created the lock is dead."
+ (interactive)
+ (let* ((default-directory (cvs-expand-dir-name cvs-lock-file))
+ (locks (directory-files default-directory nil cvs-lock-file-regexp)))
+ (cond
+ ((not locks) (error "No lock files found"))
+ ((yes-or-no-p (concat "Really delete locks in " cvs-lock-file "? "))
+ (dolist (lock locks)
+ (cond ((file-directory-p lock) (delete-directory lock))
+ ((file-exists-p lock) (delete-file lock))))))))
+
+
+(defun-cvs-mode cvs-mode-remove-handled ()
+ "Remove all lines that are handled.
+Empty directories are removed."
+ (interactive)
+ (cvs-cleanup-collection cvs-cookies
+ t (or cvs-auto-remove-directories 'handled) t))
+
+
+(defun-cvs-mode cvs-mode-acknowledge ()
+ "Remove all marked files from the buffer."
+ (interactive)
+ (dolist (fi (cvs-get-marked (cvs-ignore-marks-p "acknowledge") t))
+ (setf (cvs-fileinfo->type fi) 'DEAD))
+ (cvs-cleanup-collection cvs-cookies nil nil nil))
+
+(defun cvs-do-removal (filter &optional cmd all)
+ "Remove files.
+Returns a list of FIS that should be `cvs remove'd."
+ (let* ((files (cvs-mode-marked filter cmd :file t :read-only t))
+ (fis (cdr (cvs-partition (lambda (fi)
+ (eq (cvs-fileinfo->type fi) 'UNKNOWN))
+ (cvs-mode-marked filter cmd))))
+ (silent (or (not cvs-confirm-removals)
+ (cvs-every (lambda (fi)
+ (or (not (file-exists-p
+ (cvs-fileinfo->full-name fi)))
+ (cvs-applicable-p fi 'safe-rm)))
+ files)))
+ (tmpbuf (cvs-temp-buffer)))
+ (when (and (not silent) (equal cvs-confirm-removals 'list))
+ (with-current-buffer tmpbuf
+ (let ((inhibit-read-only t))
+ (cvs-insert-strings (mapcar 'cvs-fileinfo->full-name fis))
+ (cvs-pop-to-buffer-same-frame (current-buffer))
+ (shrink-window-if-larger-than-buffer))))
+ (if (not (or silent
+ (unwind-protect
+ (yes-or-no-p
+ (let ((nfiles (length files))
+ (verb (if (eq filter 'undo) "Undo" "Delete")))
+ (if (= 1 nfiles)
+ (format "%s file: \"%s\" ? "
+ verb
+ (cvs-fileinfo->file (car files)))
+ (format "%s %d files? "
+ verb
+ nfiles))))
+ (cvs-bury-buffer tmpbuf cvs-buffer))))
+ (progn (message "Aborting") nil)
+ (dolist (fi files)
+ (let* ((type (cvs-fileinfo->type fi))
+ (file (cvs-fileinfo->full-name fi)))
+ (when (or all (eq type 'UNKNOWN))
+ (when (file-exists-p file) (delete-file file))
+ (unless all (setf (cvs-fileinfo->type fi) 'DEAD) t))))
+ fis)))
+
+(defun-cvs-mode (cvs-mode-remove . SIMPLE) (flags)
+ "Remove all marked files.
+With prefix argument, prompt for cvs flags."
+ (interactive (list (cvs-flags-query 'cvs-remove-flags "cvs remove flags")))
+ (let ((fis (cvs-do-removal 'remove)))
+ (if fis (cvs-mode-run "remove" (cons "-f" flags) fis)
+ (cvs-cleanup-collection cvs-cookies nil nil nil))))
+
+
+(defvar cvs-tag-name "")
+(defun-cvs-mode (cvs-mode-tag . SIMPLE) (tag &optional flags)
+ "Run `cvs tag TAG' on all selected files.
+With prefix argument, prompt for cvs flags.
+By default this can only be used on directories.
+Use \\[cvs-mode-force-command] or change `cvs-force-dir-tag' if you need
+to use it on individual files."
+ (interactive
+ (list (setq cvs-tag-name
+ (cvs-query-read cvs-tag-name "Tag name: " cvs-qtypedesc-tag))
+ (cvs-flags-query 'cvs-tag-flags "tag flags")))
+ (cvs-mode-do "tag" (append flags (list tag))
+ (when cvs-force-dir-tag 'tag)))
+
+(defun-cvs-mode (cvs-mode-untag . SIMPLE) (tag &optional flags)
+ "Run `cvs tag -d TAG' on all selected files.
+With prefix argument, prompt for cvs flags."
+ (interactive
+ (list (setq cvs-tag-name
+ (cvs-query-read cvs-tag-name "Tag to delete: " cvs-qtypedesc-tag))
+ (cvs-flags-query 'cvs-tag-flags "tag flags")))
+ (cvs-mode-do "tag" (append '("-d") flags (list tag))
+ (when cvs-force-dir-tag 'tag)))
+
+
+;; Byte compile files.
+
+(defun-cvs-mode cvs-mode-byte-compile-files ()
+ "Run byte-compile-file on all selected files that end in '.el'."
+ (interactive)
+ (let ((marked (cvs-get-marked (cvs-ignore-marks-p "byte-compile"))))
+ (dolist (fi marked)
+ (let ((filename (cvs-fileinfo->full-name fi)))
+ (when (string-match "\\.el\\'" filename)
+ (byte-compile-file filename))))))
+
+;; ChangeLog support.
+
+(defun-cvs-mode cvs-mode-add-change-log-entry-other-window ()
+ "Add a ChangeLog entry in the ChangeLog of the current directory."
+ (interactive)
+ ;; Require `add-log' explicitly, because if it gets autoloaded when we call
+ ;; add-change-log-entry-other-window below, the
+ ;; add-log-buffer-file-name-function ends up unbound when we leave the `let'.
+ (require 'add-log)
+ (dolist (fi (cvs-mode-marked nil nil))
+ (let* ((default-directory (cvs-expand-dir-name (cvs-fileinfo->dir fi)))
+ (add-log-buffer-file-name-function
+ (lambda ()
+ (let ((file (expand-file-name (cvs-fileinfo->file fi))))
+ (if (file-directory-p file)
+ ;; Be careful to use a directory name, otherwise add-log
+ ;; starts looking for a ChangeLog file in the
+ ;; parent dir.
+ (file-name-as-directory file)
+ file)))))
+ (kill-local-variable 'change-log-default-name)
+ (save-excursion (add-change-log-entry-other-window)))))
+
+;; interactive commands to set optional flags
+
+(defun cvs-mode-set-flags (flag)
+ "Ask for new setting of cvs-FLAG-flags."
+ (interactive
+ (list (completing-read
+ "Which flag: "
+ '("cvs" "diff" "update" "status" "log" "tag" ;"rtag"
+ "commit" "remove" "undo" "checkout")
+ nil t)))
+ (let* ((sym (intern (concat "cvs-" flag "-flags"))))
+ (let ((current-prefix-arg '(16)))
+ (cvs-flags-query sym (concat flag " flags")))))
+
+\f
+;;;;
+;;;; Utilities for the *cvs* buffer
+;;;;
+
+(defun cvs-dir-member-p (fileinfo dir)
+ "Return true if FILEINFO represents a file in directory DIR."
+ (and (not (eq (cvs-fileinfo->type fileinfo) 'DIRCHANGE))
+ (cvs-string-prefix-p dir (cvs-fileinfo->dir fileinfo))))
+
+(defun cvs-execute-single-file (fi extractor program constant-args)
+ "Internal function for `cvs-execute-single-file-list'."
+ (let* ((arg-list (funcall extractor fi))
+ (inhibit-read-only t))
+
+ ;; Execute the command unless extractor returned t.
+ (when (listp arg-list)
+ (let* ((args (append constant-args arg-list)))
+
+ (insert (format "=== %s %s\n\n"
+ program (split-string-and-unquote args)))
+
+ ;; FIXME: return the exit status?
+ (apply 'process-file program nil t t args)
+ (goto-char (point-max))))))
+
+;; FIXME: make this run in the background ala cvs-run-process...
+(defun cvs-execute-single-file-list (fis extractor program constant-args)
+ "Run PROGRAM on all elements on FIS.
+CONSTANT-ARGS is a list of strings to pass as arguments to PROGRAM.
+The arguments given to the program will be CONSTANT-ARGS followed by
+the list that EXTRACTOR returns.
+
+EXTRACTOR will be called once for each file on FIS. It is given
+one argument, the cvs-fileinfo. It can return t, which means ignore
+this file, or a list of arguments to send to the program."
+ (dolist (fi fis)
+ (cvs-execute-single-file fi extractor program constant-args)))
+
+\f
+(defun cvs-revert-if-needed (fis)
+ (dolist (fileinfo fis)
+ (let* ((file (cvs-fileinfo->full-name fileinfo))
+ (buffer (find-buffer-visiting file)))
+ ;; For a revert to happen the user must be editing the file...
+ (unless (or (null buffer)
+ (memq (cvs-fileinfo->type fileinfo) '(MESSAGE UNKNOWN))
+ ;; FIXME: check whether revert is really needed.
+ ;; `(verify-visited-file-modtime buffer)' doesn't cut it
+ ;; because it only looks at the time stamp (it ignores
+ ;; read-write changes) which is not changed by `commit'.
+ (buffer-modified-p buffer))
+ (with-current-buffer buffer
+ (ignore-errors
+ (revert-buffer 'ignore-auto 'dont-ask 'preserve-modes)
+ ;; `preserve-modes' avoids changing the (minor) modes. But we
+ ;; do want to reset the mode for VC, so we do it explicitly.
+ (vc-find-file-hook)
+ (when (eq (cvs-fileinfo->type fileinfo) 'CONFLICT)
+ (smerge-start-session))))))))
+
+\f
+(defun cvs-change-cvsroot (newroot)
+ "Change the cvsroot."
+ (interactive "DNew repository: ")
+ (if (or (file-directory-p (expand-file-name "CVSROOT" newroot))
+ (y-or-n-p (concat "Warning: no CVSROOT found inside repository."
+ " Change cvs-cvsroot anyhow? ")))
+ (setq cvs-cvsroot newroot)))
+
+;;;;
+;;;; useful global settings
+;;;;
+
+;;
+;; Hook to allow calling PCL-CVS by visiting the /CVS subdirectory
+;;
+
+;;;###autoload
+(defcustom cvs-dired-action 'cvs-quickdir
+ "The action to be performed when opening a CVS directory.
+Sensible values are `cvs-examine', `cvs-status' and `cvs-quickdir'."
+ :group 'pcl-cvs
+ :type '(choice (const cvs-examine) (const cvs-status) (const cvs-quickdir)))
+
+;;;###autoload
+(defcustom cvs-dired-use-hook '(4)
+ "Whether or not opening a CVS directory should run PCL-CVS.
+A value of nil means never do it.
+ALWAYS means to always do it unless a prefix argument is given to the
+ command that prompted the opening of the directory.
+Anything else means to do it only if the prefix arg is equal to this value."
+ :group 'pcl-cvs
+ :type '(choice (const :tag "Never" nil)
+ (const :tag "Always" always)
+ (const :tag "Prefix" (4))))
+
+;;;###autoload
+(progn (defun cvs-dired-noselect (dir)
+ "Run `cvs-examine' if DIR is a CVS administrative directory.
+The exact behavior is determined also by `cvs-dired-use-hook'."
+ (when (stringp dir)
+ (setq dir (directory-file-name dir))
+ (when (and (string= "CVS" (file-name-nondirectory dir))
+ (file-readable-p (expand-file-name "Entries" dir))
+ cvs-dired-use-hook
+ (if (eq cvs-dired-use-hook 'always)
+ (not current-prefix-arg)
+ (equal current-prefix-arg cvs-dired-use-hook)))
+ (save-excursion
+ (funcall cvs-dired-action (file-name-directory dir) t t))))))
+
+;;
+;; hook into VC
+;;
+
+(add-hook 'vc-post-command-functions 'cvs-vc-command-advice)
+
+(defun cvs-vc-command-advice (command files flags)
+ (when (and (equal command "cvs")
+ (progn
+ (while (and (stringp (car flags))
+ (string-match "\\`-" (car flags)))
+ (pop flags))
+ ;; don't parse output we don't understand.
+ (member (car flags) cvs-parse-known-commands))
+ ;; Don't parse "update -p" output.
+ (not (and (member (car flags) '("update" "checkout"))
+ (let ((found-p nil))
+ (dolist (flag flags found-p)
+ (if (equal flag "-p") (setq found-p t)))))))
+ (save-current-buffer
+ (let ((buffer (current-buffer))
+ (dir default-directory)
+ (cvs-from-vc t))
+ (dolist (cvs-buf (buffer-list))
+ (set-buffer cvs-buf)
+ ;; look for a corresponding pcl-cvs buffer
+ (when (and (eq major-mode 'cvs-mode)
+ (cvs-string-prefix-p default-directory dir))
+ (let ((subdir (substring dir (length default-directory))))
+ (set-buffer buffer)
+ (set (make-local-variable 'cvs-buffer) cvs-buf)
+ ;; `cvs -q add file' produces no useful output :-(
+ (when (and (equal (car flags) "add")
+ (goto-char (point-min))
+ (looking-at ".*to add this file permanently\n\\'"))
+ (dolist (file (if (listp files) files (list files)))
+ (insert "cvs add: scheduling file `"
+ (file-name-nondirectory file)
+ "' for addition\n")))
+ ;; VC never (?) does `cvs -n update' so dcd=nil
+ ;; should probably always be the right choice.
+ (cvs-parse-process nil subdir))))))))
+
+;;
+;; Hook into write-buffer
+;;
+
+(defun cvs-mark-buffer-changed ()
+ (let* ((file (expand-file-name buffer-file-name))
+ (version (and (fboundp 'vc-backend)
+ (eq (vc-backend file) 'CVS)
+ (vc-working-revision file))))
+ (when version
+ (save-excursion
+ (dolist (cvs-buf (buffer-list))
+ (set-buffer cvs-buf)
+ ;; look for a corresponding pcl-cvs buffer
+ (when (and (eq major-mode 'cvs-mode)
+ (cvs-string-prefix-p default-directory file))
+ (let* ((file (substring file (length default-directory)))
+ (fi (cvs-create-fileinfo
+ (if (string= "0" version)
+ 'ADDED 'MODIFIED)
+ (or (file-name-directory file) "")
+ (file-name-nondirectory file)
+ "cvs-mark-buffer-changed")))
+ (cvs-addto-collection cvs-cookies fi))))))))
+
+(add-hook 'after-save-hook 'cvs-mark-buffer-changed)
+
+\f
+(provide 'pcvs)
+
+;; arch-tag: 8e3a7494-0453-4389-9ab3-a557ce9fab61
+;;; pcvs.el ends here
--- /dev/null
- ;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;;; smerge-mode.el --- Minor mode to resolve diff3 conflicts
+
+;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
++;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Provides a lightweight alternative to emerge/ediff.
+;; To use it, simply add to your .emacs the following lines:
+;;
+;; (autoload 'smerge-mode "smerge-mode" nil t)
+;;
+;; you can even have it turned on automatically with the following
+;; piece of code in your .emacs:
+;;
+;; (defun sm-try-smerge ()
+;; (save-excursion
+;; (goto-char (point-min))
+;; (when (re-search-forward "^<<<<<<< " nil t)
+;; (smerge-mode 1))))
+;; (add-hook 'find-file-hook 'sm-try-smerge t)
+
+;;; Todo:
+
+;; - if requested, ask the user whether he wants to call ediff right away
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+(require 'diff-mode) ;For diff-auto-refine-mode.
+
+
+;;; The real definition comes later.
+(defvar smerge-mode)
+
+(defgroup smerge ()
+ "Minor mode to highlight and resolve diff3 conflicts."
+ :group 'tools
+ :prefix "smerge-")
+
+(defcustom smerge-diff-buffer-name "*vc-diff*"
+ "Buffer name to use for displaying diffs."
+ :group 'smerge
+ :type '(choice
+ (const "*vc-diff*")
+ (const "*cvs-diff*")
+ (const "*smerge-diff*")
+ string))
+
+(defcustom smerge-diff-switches
+ (append '("-d" "-b")
+ (if (listp diff-switches) diff-switches (list diff-switches)))
+ "A list of strings specifying switches to be passed to diff.
+Used in `smerge-diff-base-mine' and related functions."
+ :group 'smerge
+ :type '(repeat string))
+
+(defcustom smerge-auto-leave t
+ "Non-nil means to leave `smerge-mode' when the last conflict is resolved."
+ :group 'smerge
+ :type 'boolean)
+
+(defface smerge-mine
+ '((((min-colors 88) (background light))
+ (:foreground "blue1"))
+ (((background light))
+ (:foreground "blue"))
+ (((min-colors 88) (background dark))
+ (:foreground "cyan1"))
+ (((background dark))
+ (:foreground "cyan")))
+ "Face for your code."
+ :group 'smerge)
+(define-obsolete-face-alias 'smerge-mine-face 'smerge-mine "22.1")
+(defvar smerge-mine-face 'smerge-mine)
+
+(defface smerge-other
+ '((((background light))
+ (:foreground "darkgreen"))
+ (((background dark))
+ (:foreground "lightgreen")))
+ "Face for the other code."
+ :group 'smerge)
+(define-obsolete-face-alias 'smerge-other-face 'smerge-other "22.1")
+(defvar smerge-other-face 'smerge-other)
+
+(defface smerge-base
+ '((((min-colors 88) (background light))
+ (:foreground "red1"))
+ (((background light))
+ (:foreground "red"))
+ (((background dark))
+ (:foreground "orange")))
+ "Face for the base code."
+ :group 'smerge)
+(define-obsolete-face-alias 'smerge-base-face 'smerge-base "22.1")
+(defvar smerge-base-face 'smerge-base)
+
+(defface smerge-markers
+ '((((background light))
+ (:background "grey85"))
+ (((background dark))
+ (:background "grey30")))
+ "Face for the conflict markers."
+ :group 'smerge)
+(define-obsolete-face-alias 'smerge-markers-face 'smerge-markers "22.1")
+(defvar smerge-markers-face 'smerge-markers)
+
+(defface smerge-refined-change
+ '((t :background "yellow"))
+ "Face used for char-based changes shown by `smerge-refine'."
+ :group 'smerge)
+
+(easy-mmode-defmap smerge-basic-map
+ `(("n" . smerge-next)
+ ("p" . smerge-prev)
+ ("r" . smerge-resolve)
+ ("a" . smerge-keep-all)
+ ("b" . smerge-keep-base)
+ ("o" . smerge-keep-other)
+ ("m" . smerge-keep-mine)
+ ("E" . smerge-ediff)
+ ("C" . smerge-combine-with-next)
+ ("R" . smerge-refine)
+ ("\C-m" . smerge-keep-current)
+ ("=" . ,(make-sparse-keymap "Diff"))
+ ("=<" "base-mine" . smerge-diff-base-mine)
+ ("=>" "base-other" . smerge-diff-base-other)
+ ("==" "mine-other" . smerge-diff-mine-other))
+ "The base keymap for `smerge-mode'.")
+
+(defcustom smerge-command-prefix "\C-c^"
+ "Prefix for `smerge-mode' commands."
+ :group 'smerge
+ :type '(choice (const :tag "ESC" "\e")
+ (const :tag "C-c ^" "\C-c^" )
+ (const :tag "none" "")
+ string))
+
+(easy-mmode-defmap smerge-mode-map
+ `((,smerge-command-prefix . ,smerge-basic-map))
+ "Keymap for `smerge-mode'.")
+
+(defvar smerge-check-cache nil)
+(make-variable-buffer-local 'smerge-check-cache)
+(defun smerge-check (n)
+ (condition-case nil
+ (let ((state (cons (point) (buffer-modified-tick))))
+ (unless (equal (cdr smerge-check-cache) state)
+ (smerge-match-conflict)
+ (setq smerge-check-cache (cons (match-data) state)))
+ (nth (* 2 n) (car smerge-check-cache)))
+ (error nil)))
+
+(easy-menu-define smerge-mode-menu smerge-mode-map
+ "Menu for `smerge-mode'."
+ '("SMerge"
+ ["Next" smerge-next :help "Go to next conflict"]
+ ["Previous" smerge-prev :help "Go to previous conflict"]
+ "--"
+ ["Keep All" smerge-keep-all :help "Keep all three versions"
+ :active (smerge-check 1)]
+ ["Keep Current" smerge-keep-current :help "Use current (at point) version"
+ :active (and (smerge-check 1) (> (smerge-get-current) 0))]
+ "--"
+ ["Revert to Base" smerge-keep-base :help "Revert to base version"
+ :active (smerge-check 2)]
+ ["Keep Other" smerge-keep-other :help "Keep `other' version"
+ :active (smerge-check 3)]
+ ["Keep Yours" smerge-keep-mine :help "Keep your version"
+ :active (smerge-check 1)]
+ "--"
+ ["Diff Base/Mine" smerge-diff-base-mine
+ :help "Diff `base' and `mine' for current conflict"
+ :active (smerge-check 2)]
+ ["Diff Base/Other" smerge-diff-base-other
+ :help "Diff `base' and `other' for current conflict"
+ :active (smerge-check 2)]
+ ["Diff Mine/Other" smerge-diff-mine-other
+ :help "Diff `mine' and `other' for current conflict"
+ :active (smerge-check 1)]
+ "--"
+ ["Invoke Ediff" smerge-ediff
+ :help "Use Ediff to resolve the conflicts"
+ :active (smerge-check 1)]
+ ["Auto Resolve" smerge-resolve
+ :help "Try auto-resolution heuristics"
+ :active (smerge-check 1)]
+ ["Combine" smerge-combine-with-next
+ :help "Combine current conflict with next"
+ :active (smerge-check 1)]
+ ))
+
+(easy-menu-define smerge-context-menu nil
+ "Context menu for mine area in `smerge-mode'."
+ '(nil
+ ["Keep Current" smerge-keep-current :help "Use current (at point) version"]
+ ["Kill Current" smerge-kill-current :help "Remove current (at point) version"]
+ ["Keep All" smerge-keep-all :help "Keep all three versions"]
+ "---"
+ ["More..." (popup-menu smerge-mode-menu) :help "Show full SMerge mode menu"]
+ ))
+
+(defconst smerge-font-lock-keywords
+ '((smerge-find-conflict
+ (1 smerge-mine-face prepend t)
+ (2 smerge-base-face prepend t)
+ (3 smerge-other-face prepend t)
+ ;; FIXME: `keep' doesn't work right with syntactic fontification.
+ (0 smerge-markers-face keep)
+ (4 nil t t)
+ (5 nil t t)))
+ "Font lock patterns for `smerge-mode'.")
+
+(defconst smerge-begin-re "^<<<<<<< \\(.*\\)\n")
+(defconst smerge-end-re "^>>>>>>> .*\n")
+(defconst smerge-base-re "^||||||| .*\n")
+(defconst smerge-other-re "^=======\n")
+
+(defvar smerge-conflict-style nil
+ "Keep track of which style of conflict is in use.
+Can be nil if the style is undecided, or else:
+- `diff3-E'
+- `diff3-A'")
+
+;; Compiler pacifiers
+(defvar font-lock-mode)
+(defvar font-lock-keywords)
+
+;;;;
+;;;; Actual code
+;;;;
+
+;; Define smerge-next and smerge-prev
+(easy-mmode-define-navigation smerge smerge-begin-re "conflict" nil nil
+ (if diff-auto-refine-mode
+ (condition-case nil (smerge-refine) (error nil))))
+
+(defconst smerge-match-names ["conflict" "mine" "base" "other"])
+
+(defun smerge-ensure-match (n)
+ (unless (match-end n)
+ (error "No `%s'" (aref smerge-match-names n))))
+
+(defun smerge-auto-leave ()
+ (when (and smerge-auto-leave
+ (save-excursion (goto-char (point-min))
+ (not (re-search-forward smerge-begin-re nil t))))
+ (when (and (listp buffer-undo-list) smerge-mode)
+ (push (list 'apply 'smerge-mode 1) buffer-undo-list))
+ (smerge-mode -1)))
+
+
+(defun smerge-keep-all ()
+ "Concatenate all versions."
+ (interactive)
+ (smerge-match-conflict)
+ (let ((mb2 (or (match-beginning 2) (point-max)))
+ (me2 (or (match-end 2) (point-min))))
+ (delete-region (match-end 3) (match-end 0))
+ (delete-region (max me2 (match-end 1)) (match-beginning 3))
+ (if (and (match-end 2) (/= (match-end 1) (match-end 3)))
+ (delete-region (match-end 1) (match-beginning 2)))
+ (delete-region (match-beginning 0) (min (match-beginning 1) mb2))
+ (smerge-auto-leave)))
+
+(defun smerge-keep-n (n)
+ (smerge-remove-props (match-beginning 0) (match-end 0))
+ ;; We used to use replace-match, but that did not preserve markers so well.
+ (delete-region (match-end n) (match-end 0))
+ (delete-region (match-beginning 0) (match-beginning n)))
+
+(defun smerge-combine-with-next ()
+ "Combine the current conflict with the next one."
+ ;; `smerge-auto-combine' relies on the finish position (at the beginning
+ ;; of the closing marker).
+ (interactive)
+ (smerge-match-conflict)
+ (let ((ends nil))
+ (dolist (i '(3 2 1 0))
+ (push (if (match-end i) (copy-marker (match-end i) t)) ends))
+ (setq ends (apply 'vector ends))
+ (goto-char (aref ends 0))
+ (if (not (re-search-forward smerge-begin-re nil t))
+ (error "No next conflict")
+ (smerge-match-conflict)
+ (let ((match-data (mapcar (lambda (m) (if m (copy-marker m)))
+ (match-data))))
+ ;; First copy the in-between text in each alternative.
+ (dolist (i '(1 2 3))
+ (when (aref ends i)
+ (goto-char (aref ends i))
+ (insert-buffer-substring (current-buffer)
+ (aref ends 0) (car match-data))))
+ (delete-region (aref ends 0) (car match-data))
+ ;; Then move the second conflict's alternatives into the first.
+ (dolist (i '(1 2 3))
+ (set-match-data match-data)
+ (when (and (aref ends i) (match-end i))
+ (goto-char (aref ends i))
+ (insert-buffer-substring (current-buffer)
+ (match-beginning i) (match-end i))))
+ (delete-region (car match-data) (cadr match-data))
+ ;; Free the markers.
+ (dolist (m match-data) (if m (move-marker m nil)))
+ (mapc (lambda (m) (if m (move-marker m nil))) ends)))))
+
+(defvar smerge-auto-combine-max-separation 2
+ "Max number of lines between conflicts that should be combined.")
+
+(defun smerge-auto-combine ()
+ "Automatically combine conflicts that are near each other."
+ (interactive)
+ (save-excursion
+ (goto-char (point-min))
+ (while (smerge-find-conflict)
+ ;; 2 is 1 (default) + 1 (the begin markers).
+ (while (save-excursion
+ (smerge-find-conflict
+ (line-beginning-position
+ (+ 2 smerge-auto-combine-max-separation))))
+ (forward-line -1) ;Go back inside the conflict.
+ (smerge-combine-with-next)
+ (forward-line 1) ;Move past the end of the conflict.
+ ))))
+
+(defvar smerge-resolve-function
+ (lambda () (error "Don't know how to resolve"))
+ "Mode-specific merge function.
+The function is called with zero or one argument (non-nil if the resolution
+function should only apply safe heuristics) and with the match data set
+according to `smerge-match-conflict'.")
+(add-to-list 'debug-ignored-errors "Don't know how to resolve")
+
+(defvar smerge-text-properties
+ `(help-echo "merge conflict: mouse-3 shows a menu"
+ ;; mouse-face highlight
+ keymap (keymap (down-mouse-3 . smerge-popup-context-menu))))
+
+(defun smerge-remove-props (beg end)
+ (remove-overlays beg end 'smerge 'refine)
+ (remove-overlays beg end 'smerge 'conflict)
+ ;; Now that we use overlays rather than text-properties, this function
+ ;; does not cause refontification any more. It can be seen very clearly
+ ;; in buffers where jit-lock-contextually is not t, in which case deleting
+ ;; the "<<<<<<< foobar" leading line leaves the rest of the conflict
+ ;; highlighted as if it were still a valid conflict. Note that in many
+ ;; important cases (such as the previous example) we're actually called
+ ;; during font-locking so inhibit-modification-hooks is non-nil, so we
+ ;; can't just modify the buffer and expect font-lock to be triggered as in:
+ ;; (put-text-property beg end 'smerge-force-highlighting nil)
+ (with-silent-modifications
+ (remove-text-properties beg end '(fontified nil))))
+
+(defun smerge-popup-context-menu (event)
+ "Pop up the Smerge mode context menu under mouse."
+ (interactive "e")
+ (if (and smerge-mode
+ (save-excursion (posn-set-point (event-end event)) (smerge-check 1)))
+ (progn
+ (posn-set-point (event-end event))
+ (smerge-match-conflict)
+ (let ((i (smerge-get-current))
+ o)
+ (if (<= i 0)
+ ;; Out of range
+ (popup-menu smerge-mode-menu)
+ ;; Install overlay.
+ (setq o (make-overlay (match-beginning i) (match-end i)))
+ (unwind-protect
+ (progn
+ (overlay-put o 'face 'highlight)
+ (sit-for 0) ;Display the new highlighting.
+ (popup-menu smerge-context-menu))
+ ;; Delete overlay.
+ (delete-overlay o)))))
+ ;; There's no conflict at point, the text-props are just obsolete.
+ (save-excursion
+ (let ((beg (re-search-backward smerge-end-re nil t))
+ (end (re-search-forward smerge-begin-re nil t)))
+ (smerge-remove-props (or beg (point-min)) (or end (point-max)))
+ (push event unread-command-events)))))
+
+(defun smerge-apply-resolution-patch (buf m0b m0e m3b m3e &optional m2b)
+ "Replace the conflict with a bunch of subconflicts.
+BUF contains a plain diff between match-1 and match-3."
+ (let ((line 1)
+ (textbuf (current-buffer))
+ (name1 (progn (goto-char m0b)
+ (buffer-substring (+ (point) 8) (line-end-position))))
+ (name2 (when m2b (goto-char m2b) (forward-line -1)
+ (buffer-substring (+ (point) 8) (line-end-position))))
+ (name3 (progn (goto-char m0e) (forward-line -1)
+ (buffer-substring (+ (point) 8) (line-end-position)))))
+ (smerge-remove-props m0b m0e)
+ (delete-region m3e m0e)
+ (delete-region m0b m3b)
+ (setq m3b m0b)
+ (setq m3e (- m3e (- m3b m0b)))
+ (goto-char m3b)
+ (with-current-buffer buf
+ (goto-char (point-min))
+ (while (not (eobp))
+ (if (not (looking-at "\\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)?\\([acd]\\)\\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)?$"))
+ (error "Unexpected patch hunk header: %s"
+ (buffer-substring (point) (line-end-position)))
+ (let* ((op (char-after (match-beginning 3)))
+ (startline (+ (string-to-number (match-string 1))
+ ;; No clue why this is the way it is, but line
+ ;; numbers seem to be off-by-one for `a' ops.
+ (if (eq op ?a) 1 0)))
+ (endline (if (eq op ?a) startline
+ (1+ (if (match-end 2)
+ (string-to-number (match-string 2))
+ startline))))
+ (lines (- endline startline))
+ (otherlines (cond
+ ((eq op ?d) nil)
+ ((null (match-end 5)) 1)
+ (t (- (string-to-number (match-string 5))
+ (string-to-number (match-string 4)) -1))))
+ othertext)
+ (forward-line 1) ;Skip header.
+ (forward-line lines) ;Skip deleted text.
+ (if (eq op ?c) (forward-line 1)) ;Skip separator.
+ (setq othertext
+ (if (null otherlines) ""
+ (let ((pos (point)))
+ (dotimes (i otherlines) (delete-char 2) (forward-line 1))
+ (buffer-substring pos (point)))))
+ (with-current-buffer textbuf
+ (forward-line (- startline line))
+ (insert "<<<<<<< " name1 "\n" othertext
+ (if name2 (concat "||||||| " name2 "\n") "")
+ "=======\n")
+ (forward-line lines)
+ (insert ">>>>>>> " name3 "\n")
+ (setq line endline))))))))
+
+(defun smerge-resolve (&optional safe)
+ "Resolve the conflict at point intelligently.
+This relies on mode-specific knowledge and thus only works in some
+major modes. Uses `smerge-resolve-function' to do the actual work."
+ (interactive)
+ (smerge-match-conflict)
+ (smerge-remove-props (match-beginning 0) (match-end 0))
+ (let ((md (match-data))
+ (m0b (match-beginning 0))
+ (m1b (match-beginning 1))
+ (m2b (match-beginning 2))
+ (m3b (match-beginning 3))
+ (m0e (match-end 0))
+ (m1e (match-end 1))
+ (m2e (match-end 2))
+ (m3e (match-end 3))
+ (buf (generate-new-buffer " *smerge*"))
+ m b o)
+ (unwind-protect
+ (progn
+ (cond
+ ;; Trivial diff3 -A non-conflicts.
+ ((and (eq (match-end 1) (match-end 3))
+ (eq (match-beginning 1) (match-beginning 3)))
+ (smerge-keep-n 3))
+ ;; Mode-specific conflict resolution.
+ ((condition-case nil
+ (atomic-change-group
+ (if safe
+ (funcall smerge-resolve-function safe)
+ (funcall smerge-resolve-function))
+ t)
+ (error nil))
+ ;; Nothing to do: the resolution function has done it already.
+ nil)
+ ;; Non-conflict.
+ ((and (eq m1e m3e) (eq m1b m3b))
+ (set-match-data md) (smerge-keep-n 3))
+ ;; Refine a 2-way conflict using "diff -b".
+ ;; In case of a 3-way conflict with an empty base
+ ;; (i.e. 2 conflicting additions), we do the same, presuming
+ ;; that the 2 additions should be somehow merged rather
+ ;; than concatenated.
+ ((let ((lines (count-lines m3b m3e)))
+ (setq m (make-temp-file "smm"))
+ (write-region m1b m1e m nil 'silent)
+ (setq o (make-temp-file "smo"))
+ (write-region m3b m3e o nil 'silent)
+ (not (or (eq m1b m1e) (eq m3b m3e)
+ (and (not (zerop (call-process diff-command
+ nil buf nil "-b" o m)))
+ ;; TODO: We don't know how to do the refinement
+ ;; if there's a non-empty ancestor and m1 and m3
+ ;; aren't just plain equal.
+ m2b (not (eq m2b m2e)))
+ (with-current-buffer buf
+ (goto-char (point-min))
+ ;; Make sure there's some refinement.
+ (looking-at
+ (concat "1," (number-to-string lines) "c"))))))
+ (smerge-apply-resolution-patch buf m0b m0e m3b m3e m2b))
+ ;; "Mere whitespace changes" conflicts.
+ ((when m2e
+ (setq b (make-temp-file "smb"))
+ (write-region m2b m2e b nil 'silent)
+ (with-current-buffer buf (erase-buffer))
+ ;; Only minor whitespace changes made locally.
+ ;; BEWARE: pass "-c" 'cause the output is reused in the next test.
+ (zerop (call-process diff-command nil buf nil "-bc" b m)))
+ (set-match-data md)
+ (smerge-keep-n 3))
+ ;; Try "diff -b BASE MINE | patch OTHER".
+ ((when (and (not safe) m2e b
+ ;; If the BASE is empty, this would just concatenate
+ ;; the two, which is rarely right.
+ (not (eq m2b m2e)))
+ ;; BEWARE: we're using here the patch of the previous test.
+ (with-current-buffer buf
+ (zerop (call-process-region
+ (point-min) (point-max) "patch" t nil nil
+ "-r" "/dev/null" "--no-backup-if-mismatch"
+ "-fl" o))))
+ (save-restriction
+ (narrow-to-region m0b m0e)
+ (smerge-remove-props m0b m0e)
+ (insert-file-contents o nil nil nil t)))
+ ;; Try "diff -b BASE OTHER | patch MINE".
+ ((when (and (not safe) m2e b
+ ;; If the BASE is empty, this would just concatenate
+ ;; the two, which is rarely right.
+ (not (eq m2b m2e)))
+ (write-region m3b m3e o nil 'silent)
+ (call-process diff-command nil buf nil "-bc" b o)
+ (with-current-buffer buf
+ (zerop (call-process-region
+ (point-min) (point-max) "patch" t nil nil
+ "-r" "/dev/null" "--no-backup-if-mismatch"
+ "-fl" m))))
+ (save-restriction
+ (narrow-to-region m0b m0e)
+ (smerge-remove-props m0b m0e)
+ (insert-file-contents m nil nil nil t)))
+ (t
+ (error "Don't know how to resolve"))))
+ (if (buffer-name buf) (kill-buffer buf))
+ (if m (delete-file m))
+ (if b (delete-file b))
+ (if o (delete-file o))))
+ (smerge-auto-leave))
+
+(defun smerge-resolve-all ()
+ "Perform automatic resolution on all conflicts."
+ (interactive)
+ (save-excursion
+ (goto-char (point-min))
+ (while (re-search-forward smerge-begin-re nil t)
+ (condition-case nil
+ (progn
+ (smerge-match-conflict)
+ (smerge-resolve 'safe))
+ (error nil)))))
+
+(defun smerge-batch-resolve ()
+ ;; command-line-args-left is what is left of the command line.
+ (if (not noninteractive)
+ (error "`smerge-batch-resolve' is to be used only with -batch"))
+ (while command-line-args-left
+ (let ((file (pop command-line-args-left)))
+ (if (string-match "\\.rej\\'" file)
+ ;; .rej files should never contain diff3 markers, on the other hand,
+ ;; in Arch, .rej files are sometimes used to indicate that the
+ ;; main file has diff3 markers. So you can pass **/*.rej and
+ ;; it will DTRT.
+ (setq file (substring file 0 (match-beginning 0))))
+ (message "Resolving conflicts in %s..." file)
+ (when (file-readable-p file)
+ (with-current-buffer (find-file-noselect file)
+ (smerge-resolve-all)
+ (save-buffer)
+ (kill-buffer (current-buffer)))))))
+
+(defun smerge-keep-base ()
+ "Revert to the base version."
+ (interactive)
+ (smerge-match-conflict)
+ (smerge-ensure-match 2)
+ (smerge-keep-n 2)
+ (smerge-auto-leave))
+
+(defun smerge-keep-other ()
+ "Use \"other\" version."
+ (interactive)
+ (smerge-match-conflict)
+ ;;(smerge-ensure-match 3)
+ (smerge-keep-n 3)
+ (smerge-auto-leave))
+
+(defun smerge-keep-mine ()
+ "Keep your version."
+ (interactive)
+ (smerge-match-conflict)
+ ;;(smerge-ensure-match 1)
+ (smerge-keep-n 1)
+ (smerge-auto-leave))
+
+(defun smerge-get-current ()
+ (let ((i 3))
+ (while (or (not (match-end i))
+ (< (point) (match-beginning i))
+ (>= (point) (match-end i)))
+ (decf i))
+ i))
+
+(defun smerge-keep-current ()
+ "Use the current (under the cursor) version."
+ (interactive)
+ (smerge-match-conflict)
+ (let ((i (smerge-get-current)))
+ (if (<= i 0) (error "Not inside a version")
+ (smerge-keep-n i)
+ (smerge-auto-leave))))
+
+(defun smerge-kill-current ()
+ "Remove the current (under the cursor) version."
+ (interactive)
+ (smerge-match-conflict)
+ (let ((i (smerge-get-current)))
+ (if (<= i 0) (error "Not inside a version")
+ (let ((left nil))
+ (dolist (n '(3 2 1))
+ (if (and (match-end n) (/= (match-end n) (match-end i)))
+ (push n left)))
+ (if (and (cdr left)
+ (/= (match-end (car left)) (match-end (cadr left))))
+ (ding) ;We don't know how to do that.
+ (smerge-keep-n (car left))
+ (smerge-auto-leave))))))
+
+(defun smerge-diff-base-mine ()
+ "Diff 'base' and 'mine' version in current conflict region."
+ (interactive)
+ (smerge-diff 2 1))
+
+(defun smerge-diff-base-other ()
+ "Diff 'base' and 'other' version in current conflict region."
+ (interactive)
+ (smerge-diff 2 3))
+
+(defun smerge-diff-mine-other ()
+ "Diff 'mine' and 'other' version in current conflict region."
+ (interactive)
+ (smerge-diff 1 3))
+
+(defun smerge-match-conflict ()
+ "Get info about the conflict. Puts the info in the `match-data'.
+The submatches contain:
+ 0: the whole conflict.
+ 1: your code.
+ 2: the base code.
+ 3: other code.
+An error is raised if not inside a conflict."
+ (save-excursion
+ (condition-case nil
+ (let* ((orig-point (point))
+
+ (_ (forward-line 1))
+ (_ (re-search-backward smerge-begin-re))
+
+ (start (match-beginning 0))
+ (mine-start (match-end 0))
+ (filename (or (match-string 1) ""))
+
+ (_ (re-search-forward smerge-end-re))
+ (_ (assert (< orig-point (match-end 0))))
+
+ (other-end (match-beginning 0))
+ (end (match-end 0))
+
+ (_ (re-search-backward smerge-other-re start))
+
+ (mine-end (match-beginning 0))
+ (other-start (match-end 0))
+
+ base-start base-end)
+
+ ;; handle the various conflict styles
+ (cond
+ ((save-excursion
+ (goto-char mine-start)
+ (re-search-forward smerge-begin-re end t))
+ ;; There's a nested conflict and we're after the beginning
+ ;; of the outer one but before the beginning of the inner one.
+ ;; Of course, maybe this is not a nested conflict but in that
+ ;; case it can only be something nastier that we don't know how
+ ;; to handle, so may as well arbitrarily decide to treat it as
+ ;; a nested conflict. --Stef
+ (error "There is a nested conflict"))
+
+ ((re-search-backward smerge-base-re start t)
+ ;; a 3-parts conflict
+ (set (make-local-variable 'smerge-conflict-style) 'diff3-A)
+ (setq base-end mine-end)
+ (setq mine-end (match-beginning 0))
+ (setq base-start (match-end 0)))
+
+ ((string= filename (file-name-nondirectory
+ (or buffer-file-name "")))
+ ;; a 2-parts conflict
+ (set (make-local-variable 'smerge-conflict-style) 'diff3-E))
+
+ ((and (not base-start)
+ (or (eq smerge-conflict-style 'diff3-A)
+ (equal filename "ANCESTOR")
+ (string-match "\\`[.0-9]+\\'" filename)))
+ ;; a same-diff conflict
+ (setq base-start mine-start)
+ (setq base-end mine-end)
+ (setq mine-start other-start)
+ (setq mine-end other-end)))
+
+ (store-match-data (list start end
+ mine-start mine-end
+ base-start base-end
+ other-start other-end
+ (when base-start (1- base-start)) base-start
+ (1- other-start) other-start))
+ t)
+ (search-failed (error "Point not in conflict region")))))
+
+(add-to-list 'debug-ignored-errors "Point not in conflict region")
+
+(defun smerge-conflict-overlay (pos)
+ "Return the conflict overlay at POS if any."
+ (let ((ols (overlays-at pos))
+ conflict)
+ (dolist (ol ols)
+ (if (and (eq (overlay-get ol 'smerge) 'conflict)
+ (> (overlay-end ol) pos))
+ (setq conflict ol)))
+ conflict))
+
+(defun smerge-find-conflict (&optional limit)
+ "Find and match a conflict region. Intended as a font-lock MATCHER.
+The submatches are the same as in `smerge-match-conflict'.
+Returns non-nil if a match is found between point and LIMIT.
+Point is moved to the end of the conflict."
+ (let ((found nil)
+ (pos (point))
+ conflict)
+ ;; First check to see if point is already inside a conflict, using
+ ;; the conflict overlays.
+ (while (and (not found) (setq conflict (smerge-conflict-overlay pos)))
+ ;; Check the overlay's validity and kill it if it's out of date.
+ (condition-case nil
+ (progn
+ (goto-char (overlay-start conflict))
+ (smerge-match-conflict)
+ (goto-char (match-end 0))
+ (if (<= (point) pos)
+ (error "Matching backward!")
+ (setq found t)))
+ (error (smerge-remove-props
+ (overlay-start conflict) (overlay-end conflict))
+ (goto-char pos))))
+ ;; If we're not already inside a conflict, look for the next conflict
+ ;; and add/update its overlay.
+ (while (and (not found) (re-search-forward smerge-begin-re limit t))
+ (condition-case nil
+ (progn
+ (smerge-match-conflict)
+ (goto-char (match-end 0))
+ (let ((conflict (smerge-conflict-overlay (1- (point)))))
+ (if conflict
+ ;; Update its location, just in case it got messed up.
+ (move-overlay conflict (match-beginning 0) (match-end 0))
+ (setq conflict (make-overlay (match-beginning 0) (match-end 0)
+ nil 'front-advance nil))
+ (overlay-put conflict 'evaporate t)
+ (overlay-put conflict 'smerge 'conflict)
+ (let ((props smerge-text-properties))
+ (while props
+ (overlay-put conflict (pop props) (pop props))))))
+ (setq found t))
+ (error nil)))
+ found))
+
+;;; Refined change highlighting
+
+(defvar smerge-refine-forward-function 'smerge-refine-forward
+ "Function used to determine an \"atomic\" element.
+You can set it to `forward-char' to get char-level granularity.
+Its behavior has mainly two restrictions:
+- if this function encounters a newline, it's important that it stops right
+ after the newline.
+ This only matters if `smerge-refine-ignore-whitespace' is nil.
+- it needs to be unaffected by changes performed by the `preproc' argument
+ to `smerge-refine-subst'.
+ This only matters if `smerge-refine-weight-hack' is nil.")
+
+(defvar smerge-refine-ignore-whitespace t
+ "If non-nil, indicate that `smerge-refine' should try to ignore change in whitespace.")
+
+(defvar smerge-refine-weight-hack t
+ "If non-nil, pass to diff as many lines as there are chars in the region.
+I.e. each atomic element (e.g. word) will be copied as many times (on different
+lines) as it has chars. This has two advantages:
+- if `diff' tries to minimize the number *lines* (rather than chars)
+ added/removed, this adjust the weights so that adding/removing long
+ symbols is considered correspondingly more costly.
+- `smerge-refine-forward-function' only needs to be called when chopping up
+ the regions, and `forward-char' can be used afterwards.
+It has the following disadvantages:
+- cannot use `diff -w' because the weighting causes added spaces in a line
+ to be represented as added copies of some line, so `diff -w' can't do the
+ right thing any more.
+- may in degenerate cases take a 1KB input region and turn it into a 1MB
+ file to pass to diff.")
+
+(defun smerge-refine-forward (n)
+ (let ((case-fold-search nil)
+ (re "[[:upper:]]?[[:lower:]]+\\|[[:upper:]]+\\|[[:digit:]]+\\|.\\|\n"))
+ (when (and smerge-refine-ignore-whitespace
+ ;; smerge-refine-weight-hack causes additional spaces to
+ ;; appear as additional lines as well, so even if diff ignore
+ ;; whitespace changes, it'll report added/removed lines :-(
+ (not smerge-refine-weight-hack))
+ (setq re (concat "[ \t]*\\(?:" re "\\)")))
+ (dotimes (i n)
+ (unless (looking-at re) (error "Smerge refine internal error"))
+ (goto-char (match-end 0)))))
+
+(defun smerge-refine-chopup-region (beg end file &optional preproc)
+ "Chopup the region into small elements, one per line.
+Save the result into FILE.
+If non-nil, PREPROC is called with no argument in a buffer that contains
+a copy of the text, just before chopping it up. It can be used to replace
+chars to try and eliminate some spurious differences."
+ ;; We used to chop up char-by-char rather than word-by-word like ediff
+ ;; does. It had the benefit of simplicity and very fine results, but it
+ ;; often suffered from problem that diff would find correlations where
+ ;; there aren't any, so the resulting "change" didn't make much sense.
+ ;; You can still get this behavior by setting
+ ;; `smerge-refine-forward-function' to `forward-char'.
+ (let ((buf (current-buffer)))
+ (with-temp-buffer
+ (insert-buffer-substring buf beg end)
+ (when preproc (goto-char (point-min)) (funcall preproc))
+ (when smerge-refine-ignore-whitespace
+ ;; It doesn't make much of a difference for diff-fine-highlight
+ ;; because we still have the _/+/</>/! prefix anyway. Can still be
+ ;; useful in other circumstances.
+ (subst-char-in-region (point-min) (point-max) ?\n ?\s))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (funcall smerge-refine-forward-function 1)
+ (let ((s (if (prog2 (forward-char -1) (bolp) (forward-char 1))
+ nil
+ (buffer-substring (line-beginning-position) (point)))))
+ ;; We add \n after each char except after \n, so we get
+ ;; one line per text char, where each line contains
+ ;; just one char, except for \n chars which are
+ ;; represented by the empty line.
+ (unless (eq (char-before) ?\n) (insert ?\n))
+ ;; HACK ALERT!!
+ (if smerge-refine-weight-hack
+ (dotimes (i (1- (length s))) (insert s "\n")))))
+ (unless (bolp) (error "Smerge refine internal error"))
+ (let ((coding-system-for-write 'emacs-mule))
+ (write-region (point-min) (point-max) file nil 'nomessage)))))
+
+(defun smerge-refine-highlight-change (buf beg match-num1 match-num2 props)
+ (with-current-buffer buf
+ (goto-char beg)
+ (let* ((startline (- (string-to-number match-num1) 1))
+ (beg (progn (funcall (if smerge-refine-weight-hack
+ 'forward-char
+ smerge-refine-forward-function)
+ startline)
+ (point)))
+ (end (progn (funcall (if smerge-refine-weight-hack
+ 'forward-char
+ smerge-refine-forward-function)
+ (if match-num2
+ (- (string-to-number match-num2)
+ startline)
+ 1))
+ (point))))
+ (when smerge-refine-ignore-whitespace
+ (skip-chars-backward " \t\n" beg) (setq end (point))
+ (goto-char beg)
+ (skip-chars-forward " \t\n" end) (setq beg (point)))
+ (when (> end beg)
+ (let ((ol (make-overlay
+ beg end nil
+ ;; Make them tend to shrink rather than spread when editing.
+ 'front-advance nil)))
+ (overlay-put ol 'evaporate t)
+ (dolist (x props) (overlay-put ol (car x) (cdr x)))
+ ol)))))
+
+(defun smerge-refine-subst (beg1 end1 beg2 end2 props &optional preproc)
+ "Show fine differences in the two regions BEG1..END1 and BEG2..END2.
+PROPS is an alist of properties to put (via overlays) on the changes.
+If non-nil, PREPROC is called with no argument in a buffer that contains
+a copy of a region, just before preparing it to for `diff'. It can be
+used to replace chars to try and eliminate some spurious differences."
+ (let* ((buf (current-buffer))
+ (pos (point))
+ (file1 (make-temp-file "diff1"))
+ (file2 (make-temp-file "diff2")))
+ ;; Chop up regions into smaller elements and save into files.
+ (smerge-refine-chopup-region beg1 end1 file1 preproc)
+ (smerge-refine-chopup-region beg2 end2 file2 preproc)
+
+ ;; Call diff on those files.
+ (unwind-protect
+ (with-temp-buffer
+ (let ((coding-system-for-read 'emacs-mule))
+ (call-process diff-command nil t nil
+ (if (and smerge-refine-ignore-whitespace
+ (not smerge-refine-weight-hack))
+ ;; Pass -a so diff treats it as a text file even
+ ;; if it contains \0 and such.
+ ;; Pass -d so as to get the smallest change, but
+ ;; also and more importantly because otherwise it
+ ;; may happen that diff doesn't behave like
+ ;; smerge-refine-weight-hack expects it to.
+ ;; See http://thread.gmane.org/gmane.emacs.devel/82685.
+ "-awd" "-ad")
+ file1 file2))
+ ;; Process diff's output.
+ (goto-char (point-min))
+ (let ((last1 nil)
+ (last2 nil))
+ (while (not (eobp))
+ (if (not (looking-at "\\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)?\\([acd]\\)\\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)?$"))
+ (error "Unexpected patch hunk header: %s"
+ (buffer-substring (point) (line-end-position))))
+ (let ((op (char-after (match-beginning 3)))
+ (m1 (match-string 1))
+ (m2 (match-string 2))
+ (m4 (match-string 4))
+ (m5 (match-string 5)))
+ (when (memq op '(?d ?c))
+ (setq last1
+ (smerge-refine-highlight-change buf beg1 m1 m2 props)))
+ (when (memq op '(?a ?c))
+ (setq last2
+ (smerge-refine-highlight-change buf beg2 m4 m5 props))))
+ (forward-line 1) ;Skip hunk header.
+ (and (re-search-forward "^[0-9]" nil 'move) ;Skip hunk body.
+ (goto-char (match-beginning 0))))
+ ;; (assert (or (null last1) (< (overlay-start last1) end1)))
+ ;; (assert (or (null last2) (< (overlay-start last2) end2)))
+ (if smerge-refine-weight-hack
+ (progn
+ ;; (assert (or (null last1) (<= (overlay-end last1) end1)))
+ ;; (assert (or (null last2) (<= (overlay-end last2) end2)))
+ )
+ ;; smerge-refine-forward-function when calling in chopup may
+ ;; have stopped because it bumped into EOB whereas in
+ ;; smerge-refine-weight-hack it may go a bit further.
+ (if (and last1 (> (overlay-end last1) end1))
+ (move-overlay last1 (overlay-start last1) end1))
+ (if (and last2 (> (overlay-end last2) end2))
+ (move-overlay last2 (overlay-start last2) end2))
+ )))
+ (goto-char pos)
+ (delete-file file1)
+ (delete-file file2))))
+
+(defun smerge-refine (&optional part)
+ "Highlight the words of the conflict that are different.
+For 3-way conflicts, highlights only two of the three parts.
+A numeric argument PART can be used to specify which two parts;
+repeating the command will highlight other two parts."
+ (interactive
+ (if (integerp current-prefix-arg) (list current-prefix-arg)
+ (smerge-match-conflict)
+ (let* ((prop (get-text-property (match-beginning 0) 'smerge-refine-part))
+ (part (if (and (consp prop)
+ (eq (buffer-chars-modified-tick) (car prop)))
+ (cdr prop))))
+ ;; If already highlighted, cycle.
+ (list (if (integerp part) (1+ (mod part 3)))))))
+
+ (if (and (integerp part) (or (< part 1) (> part 3)))
+ (error "No conflict part nb %s" part))
+ (smerge-match-conflict)
+ (remove-overlays (match-beginning 0) (match-end 0) 'smerge 'refine)
+ ;; Ignore `part' if not applicable, and default it if not provided.
+ (setq part (cond ((null (match-end 2)) 2)
+ ((eq (match-end 1) (match-end 3)) 1)
+ ((integerp part) part)
+ ;; If one of the parts is empty, any refinement using
+ ;; it will be trivial and uninteresting.
+ ((eq (match-end 1) (match-beginning 1)) 1)
+ ((eq (match-end 3) (match-beginning 3)) 3)
+ (t 2)))
+ (let ((n1 (if (eq part 1) 2 1))
+ (n2 (if (eq part 3) 2 3)))
+ (smerge-ensure-match n1)
+ (smerge-ensure-match n2)
+ (with-silent-modifications
+ (put-text-property (match-beginning 0) (1+ (match-beginning 0))
+ 'smerge-refine-part
+ (cons (buffer-chars-modified-tick) part)))
+ (smerge-refine-subst (match-beginning n1) (match-end n1)
+ (match-beginning n2) (match-end n2)
+ '((smerge . refine)
+ (face . smerge-refined-change)))))
+
+(defun smerge-diff (n1 n2)
+ (smerge-match-conflict)
+ (smerge-ensure-match n1)
+ (smerge-ensure-match n2)
+ (let ((name1 (aref smerge-match-names n1))
+ (name2 (aref smerge-match-names n2))
+ ;; Read them before the match-data gets clobbered.
+ (beg1 (match-beginning n1))
+ (end1 (match-end n1))
+ (beg2 (match-beginning n2))
+ (end2 (match-end n2))
+ (file1 (make-temp-file "smerge1"))
+ (file2 (make-temp-file "smerge2"))
+ (dir default-directory)
+ (file (if buffer-file-name (file-relative-name buffer-file-name)))
+ ;; We would want to use `emacs-mule-unix' for read&write, but we
+ ;; bump into problems with the coding-system used by diff to write
+ ;; the file names and the time stamps in the header.
+ ;; `buffer-file-coding-system' is not always correct either, but if
+ ;; the OS/user uses only one coding-system, then it works.
+ (coding-system-for-read buffer-file-coding-system))
+ (write-region beg1 end1 file1 nil 'nomessage)
+ (write-region beg2 end2 file2 nil 'nomessage)
+ (unwind-protect
+ (with-current-buffer (get-buffer-create smerge-diff-buffer-name)
+ (setq default-directory dir)
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (let ((status
+ (apply 'call-process diff-command nil t nil
+ (append smerge-diff-switches
+ (list "-L" (concat name1 "/" file)
+ "-L" (concat name2 "/" file)
+ file1 file2)))))
+ (if (eq status 0) (insert "No differences found.\n"))))
+ (goto-char (point-min))
+ (diff-mode)
+ (display-buffer (current-buffer) t))
+ (delete-file file1)
+ (delete-file file2))))
+
+;; compiler pacifiers
+(defvar smerge-ediff-windows)
+(defvar smerge-ediff-buf)
+(defvar ediff-buffer-A)
+(defvar ediff-buffer-B)
+(defvar ediff-buffer-C)
+(defvar ediff-ancestor-buffer)
+(defvar ediff-quit-hook)
+(declare-function ediff-cleanup-mess "ediff-util" nil)
+
+;;;###autoload
+(defun smerge-ediff (&optional name-mine name-other name-base)
+ "Invoke ediff to resolve the conflicts.
+NAME-MINE, NAME-OTHER, and NAME-BASE, if non-nil, are used for the
+buffer names."
+ (interactive)
+ (let* ((buf (current-buffer))
+ (mode major-mode)
+ ;;(ediff-default-variant 'default-B)
+ (config (current-window-configuration))
+ (filename (file-name-nondirectory buffer-file-name))
+ (mine (generate-new-buffer
+ (or name-mine (concat "*" filename " MINE*"))))
+ (other (generate-new-buffer
+ (or name-other (concat "*" filename " OTHER*"))))
+ base)
+ (with-current-buffer mine
+ (buffer-disable-undo)
+ (insert-buffer-substring buf)
+ (goto-char (point-min))
+ (while (smerge-find-conflict)
+ (when (match-beginning 2) (setq base t))
+ (smerge-keep-n 1))
+ (buffer-enable-undo)
+ (set-buffer-modified-p nil)
+ (funcall mode))
+
+ (with-current-buffer other
+ (buffer-disable-undo)
+ (insert-buffer-substring buf)
+ (goto-char (point-min))
+ (while (smerge-find-conflict)
+ (smerge-keep-n 3))
+ (buffer-enable-undo)
+ (set-buffer-modified-p nil)
+ (funcall mode))
+
+ (when base
+ (setq base (generate-new-buffer
+ (or name-base (concat "*" filename " BASE*"))))
+ (with-current-buffer base
+ (buffer-disable-undo)
+ (insert-buffer-substring buf)
+ (goto-char (point-min))
+ (while (smerge-find-conflict)
+ (if (match-end 2)
+ (smerge-keep-n 2)
+ (delete-region (match-beginning 0) (match-end 0))))
+ (buffer-enable-undo)
+ (set-buffer-modified-p nil)
+ (funcall mode)))
+
+ ;; the rest of the code is inspired from vc.el
+ ;; Fire up ediff.
+ (set-buffer
+ (if base
+ (ediff-merge-buffers-with-ancestor mine other base)
+ ;; nil 'ediff-merge-revisions-with-ancestor buffer-file-name)
+ (ediff-merge-buffers mine other)))
+ ;; nil 'ediff-merge-revisions buffer-file-name)))
+
+ ;; Ediff is now set up, and we are in the control buffer.
+ ;; Do a few further adjustments and take precautions for exit.
+ (set (make-local-variable 'smerge-ediff-windows) config)
+ (set (make-local-variable 'smerge-ediff-buf) buf)
+ (set (make-local-variable 'ediff-quit-hook)
+ (lambda ()
+ (let ((buffer-A ediff-buffer-A)
+ (buffer-B ediff-buffer-B)
+ (buffer-C ediff-buffer-C)
+ (buffer-Ancestor ediff-ancestor-buffer)
+ (buf smerge-ediff-buf)
+ (windows smerge-ediff-windows))
+ (ediff-cleanup-mess)
+ (with-current-buffer buf
+ (erase-buffer)
+ (insert-buffer-substring buffer-C)
+ (kill-buffer buffer-A)
+ (kill-buffer buffer-B)
+ (kill-buffer buffer-C)
+ (when (bufferp buffer-Ancestor) (kill-buffer buffer-Ancestor))
+ (set-window-configuration windows)
+ (message "Conflict resolution finished; you may save the buffer")))))
+ (message "Please resolve conflicts now; exit ediff when done")))
+
+(defun smerge-makeup-conflict (pt1 pt2 pt3 &optional pt4)
+ "Insert diff3 markers to make a new conflict.
+Uses point and mark for two of the relevant positions and previous marks
+for the other ones.
+By default, makes up a 2-way conflict,
+with a \\[universal-argument] prefix, makes up a 3-way conflict."
+ (interactive
+ (list (point)
+ (mark)
+ (progn (pop-mark) (mark))
+ (when current-prefix-arg (pop-mark) (mark))))
+ ;; Start from the end so as to avoid problems with pos-changes.
+ (destructuring-bind (pt1 pt2 pt3 &optional pt4)
+ (sort (list* pt1 pt2 pt3 (if pt4 (list pt4))) '>=)
+ (goto-char pt1) (beginning-of-line)
+ (insert ">>>>>>> OTHER\n")
+ (goto-char pt2) (beginning-of-line)
+ (insert "=======\n")
+ (goto-char pt3) (beginning-of-line)
+ (when pt4
+ (insert "||||||| BASE\n")
+ (goto-char pt4) (beginning-of-line))
+ (insert "<<<<<<< MINE\n"))
+ (if smerge-mode nil (smerge-mode 1))
+ (smerge-refine))
+
+
+(defconst smerge-parsep-re
+ (concat smerge-begin-re "\\|" smerge-end-re "\\|"
+ smerge-base-re "\\|" smerge-other-re "\\|"))
+
+;;;###autoload
+(define-minor-mode smerge-mode
+ "Minor mode to simplify editing output from the diff3 program.
+\\{smerge-mode-map}"
+ :group 'smerge :lighter " SMerge"
+ (when (and (boundp 'font-lock-mode) font-lock-mode)
+ (save-excursion
+ (if smerge-mode
+ (font-lock-add-keywords nil smerge-font-lock-keywords 'append)
+ (font-lock-remove-keywords nil smerge-font-lock-keywords))
+ (goto-char (point-min))
+ (while (smerge-find-conflict)
+ (save-excursion
+ (font-lock-fontify-region (match-beginning 0) (match-end 0) nil)))))
+ (if (string-match (regexp-quote smerge-parsep-re) paragraph-separate)
+ (unless smerge-mode
+ (set (make-local-variable 'paragraph-separate)
+ (replace-match "" t t paragraph-separate)))
+ (when smerge-mode
+ (set (make-local-variable 'paragraph-separate)
+ (concat smerge-parsep-re paragraph-separate))))
+ (unless smerge-mode
+ (smerge-remove-props (point-min) (point-max))))
+
+;;;###autoload
+(defun smerge-start-session ()
+ "Turn on `smerge-mode' and move point to first conflict marker.
+If no conflict maker is found, turn off `smerge-mode'."
+ (interactive)
+ (smerge-mode 1)
+ (condition-case nil
+ (unless (looking-at smerge-begin-re)
+ (smerge-next))
+ (error (smerge-auto-leave))))
+
+(provide 'smerge-mode)
+
+;; arch-tag: 605c8d1e-e43d-4943-a6f3-1bcc4333e690
+;;; smerge-mode.el ends here
--- /dev/null
- ;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;;; vc-annotate.el --- VC Annotate Support
+
+;; Copyright (C) 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
++;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+
+;; Author: Martin Lorentzson <emwson@emw.ericsson.se>
+;; Maintainer: FSF
+;; Keywords: vc tools
+;; Package: 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 <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+
+(require 'vc-hooks)
+(require 'vc)
+
+;;; Code:
+(eval-when-compile
+ (require 'cl))
+
+(defcustom vc-annotate-display-mode 'fullscale
+ "Which mode to color the output of \\[vc-annotate] with by default."
+ :type '(choice (const :tag "By Color Map Range" nil)
+ (const :tag "Scale to Oldest" scale)
+ (const :tag "Scale Oldest->Newest" fullscale)
+ (number :tag "Specify Fractional Number of Days"
+ :value "20.5"))
+ :group 'vc)
+
+(defcustom vc-annotate-color-map
+ (if (and (tty-display-color-p) (<= (display-color-cells) 8))
+ ;; A custom sorted TTY colormap
+ (let* ((colors
+ (sort
+ (delq nil
+ (mapcar (lambda (x)
+ (if (not (or
+ (string-equal (car x) "white")
+ (string-equal (car x) "black") ))
+ (car x)))
+ (tty-color-alist)))
+ (lambda (a b)
+ (cond
+ ((or (string-equal a "red") (string-equal b "blue")) t)
+ ((or (string-equal b "red") (string-equal a "blue")) nil)
+ ((string-equal a "yellow") t)
+ ((string-equal b "yellow") nil)
+ ((string-equal a "cyan") t)
+ ((string-equal b "cyan") nil)
+ ((string-equal a "green") t)
+ ((string-equal b "green") nil)
+ ((string-equal a "magenta") t)
+ ((string-equal b "magenta") nil)
+ (t (string< a b))))))
+ (date 20.)
+ (delta (/ (- 360. date) (1- (length colors)))))
+ (mapcar (lambda (x)
+ (prog1
+ (cons date x)
+ (setq date (+ date delta)))) colors))
+ ;; Normal colormap: hue stepped from 0-240deg, value=1., saturation=0.75
+ '(( 20. . "#FF3F3F")
+ ( 40. . "#FF6C3F")
+ ( 60. . "#FF993F")
+ ( 80. . "#FFC63F")
+ (100. . "#FFF33F")
+ (120. . "#DDFF3F")
+ (140. . "#B0FF3F")
+ (160. . "#83FF3F")
+ (180. . "#56FF3F")
+ (200. . "#3FFF56")
+ (220. . "#3FFF83")
+ (240. . "#3FFFB0")
+ (260. . "#3FFFDD")
+ (280. . "#3FF3FF")
+ (300. . "#3FC6FF")
+ (320. . "#3F99FF")
+ (340. . "#3F6CFF")
+ (360. . "#3F3FFF")))
+ "Association list of age versus color, for \\[vc-annotate].
+Ages are given in units of fractional days. Default is eighteen
+steps using a twenty day increment, from red to blue. For TTY
+displays with 8 or fewer colors, the default is red to blue with
+all other colors between (excluding black and white)."
+ :type 'alist
+ :group 'vc)
+
+(defcustom vc-annotate-very-old-color "#3F3FFF"
+ "Color for lines older than the current color range in \\[vc-annotate]."
+ :type 'string
+ :group 'vc)
+
+(defcustom vc-annotate-background "black"
+ "Background color for \\[vc-annotate].
+Default color is used if nil."
+ :type '(choice (const :tag "Default background" nil) (color))
+ :group 'vc)
+
+(defcustom vc-annotate-menu-elements '(2 0.5 0.1 0.01)
+ "Menu elements for the mode-specific menu of VC-Annotate mode.
+List of factors, used to expand/compress the time scale. See `vc-annotate'."
+ :type '(repeat number)
+ :group 'vc)
+
+(defvar vc-annotate-mode-map
+ (let ((m (make-sparse-keymap)))
+ (define-key m "a" 'vc-annotate-revision-previous-to-line)
+ (define-key m "d" 'vc-annotate-show-diff-revision-at-line)
+ (define-key m "D" 'vc-annotate-show-changeset-diff-revision-at-line)
+ (define-key m "f" 'vc-annotate-find-revision-at-line)
+ (define-key m "j" 'vc-annotate-revision-at-line)
+ (define-key m "l" 'vc-annotate-show-log-revision-at-line)
+ (define-key m "n" 'vc-annotate-next-revision)
+ (define-key m "p" 'vc-annotate-prev-revision)
+ (define-key m "w" 'vc-annotate-working-revision)
+ (define-key m "v" 'vc-annotate-toggle-annotation-visibility)
+ m)
+ "Local keymap used for VC-Annotate mode.")
+
+;;; Annotate functionality
+
+;; Declare globally instead of additional parameter to
+;; temp-buffer-show-function (not possible to pass more than one
+;; parameter). The use of annotate-ratio is deprecated in favor of
+;; annotate-mode, which replaces it with the more sensible "span-to
+;; days", along with autoscaling support.
+(defvar vc-annotate-ratio nil "Global variable.")
+
+;; internal buffer-local variables
+(defvar vc-annotate-backend nil)
+(defvar vc-annotate-parent-file nil)
+(defvar vc-annotate-parent-rev nil)
+(defvar vc-annotate-parent-display-mode nil)
+
+(defconst vc-annotate-font-lock-keywords
+ ;; The fontification is done by vc-annotate-lines instead of font-lock.
+ '((vc-annotate-lines)))
+
+(define-derived-mode vc-annotate-mode special-mode "Annotate"
+ "Major mode for output buffers of the `vc-annotate' command.
+
+You can use the mode-specific menu to alter the time-span of the used
+colors. See variable `vc-annotate-menu-elements' for customizing the
+menu items."
+ ;; Frob buffer-invisibility-spec so that if it is originally a naked t,
+ ;; it will become a list, to avoid initial annotations being invisible.
+ (add-to-invisibility-spec 'foo)
+ (remove-from-invisibility-spec 'foo)
+ (set (make-local-variable 'truncate-lines) t)
+ (set (make-local-variable 'font-lock-defaults)
+ '(vc-annotate-font-lock-keywords t))
+ (hack-dir-local-variables-non-file-buffer))
+
+(defun vc-annotate-toggle-annotation-visibility ()
+ "Toggle whether or not the annotation is visible."
+ (interactive)
+ (funcall (if (memq 'vc-annotate-annotation buffer-invisibility-spec)
+ 'remove-from-invisibility-spec
+ 'add-to-invisibility-spec)
+ 'vc-annotate-annotation)
+ (force-window-update (current-buffer)))
+
+(defun vc-annotate-display-default (ratio)
+ "Display the output of \\[vc-annotate] using the default color range.
+The color range is given by `vc-annotate-color-map', scaled by RATIO.
+The current time is used as the offset."
+ (interactive (progn (kill-local-variable 'vc-annotate-color-map) '(1.0)))
+ (message "Redisplaying annotation...")
+ (vc-annotate-display ratio)
+ (message "Redisplaying annotation...done"))
+
+(defun vc-annotate-oldest-in-map (color-map)
+ "Return the oldest time in the COLOR-MAP."
+ ;; Since entries should be sorted, we can just use the last one.
+ (caar (last color-map)))
+
+(defun vc-annotate-get-time-set-line-props ()
+ (let ((bol (point))
+ (date (vc-call-backend vc-annotate-backend 'annotate-time))
+ (inhibit-read-only t))
+ (assert (>= (point) bol))
+ (put-text-property bol (point) 'invisible 'vc-annotate-annotation)
+ date))
+
+(defun vc-annotate-display-autoscale (&optional full)
+ "Highlight the output of \\[vc-annotate] using an autoscaled color map.
+Autoscaling means that the map is scaled from the current time to the
+oldest annotation in the buffer, or, with prefix argument FULL, to
+cover the range from the oldest annotation to the newest."
+ (interactive "P")
+ (let ((newest 0.0)
+ (oldest 999999.) ;Any CVS users at the founding of Rome?
+ (current (vc-annotate-convert-time (current-time)))
+ date)
+ (message "Redisplaying annotation...")
+ ;; Run through this file and find the oldest and newest dates annotated.
+ (save-excursion
+ (goto-char (point-min))
+ (while (not (eobp))
+ (when (setq date (vc-annotate-get-time-set-line-props))
+ (when (> date newest)
+ (setq newest date))
+ (when (< date oldest)
+ (setq oldest date)))
+ (forward-line 1)))
+ (vc-annotate-display
+ (/ (- (if full newest current) oldest)
+ (vc-annotate-oldest-in-map vc-annotate-color-map))
+ (if full newest))
+ (message "Redisplaying annotation...done \(%s\)"
+ (if full
+ (format "Spanned from %.1f to %.1f days old"
+ (- current oldest)
+ (- current newest))
+ (format "Spanned to %.1f days old" (- current oldest))))))
+
+;; Menu -- Using easymenu.el
+(easy-menu-define vc-annotate-mode-menu vc-annotate-mode-map
+ "VC Annotate Display Menu"
+ `("VC-Annotate"
+ ["By Color Map Range" (unless (null vc-annotate-display-mode)
+ (setq vc-annotate-display-mode nil)
+ (vc-annotate-display-select))
+ :style toggle :selected (null vc-annotate-display-mode)]
+ ,@(let ((oldest-in-map (vc-annotate-oldest-in-map vc-annotate-color-map)))
+ (mapcar (lambda (element)
+ (let ((days (* element oldest-in-map)))
+ `[,(format "Span %.1f days" days)
+ (vc-annotate-display-select nil ,days)
+ :style toggle :selected
+ (eql vc-annotate-display-mode ,days) ]))
+ vc-annotate-menu-elements))
+ ["Span ..."
+ (vc-annotate-display-select
+ nil (float (string-to-number (read-string "Span how many days? "))))]
+ "--"
+ ["Span to Oldest"
+ (unless (eq vc-annotate-display-mode 'scale)
+ (vc-annotate-display-select nil 'scale))
+ :help
+ "Use an autoscaled color map from the oldest annotation to the current time"
+ :style toggle :selected
+ (eq vc-annotate-display-mode 'scale)]
+ ["Span Oldest->Newest"
+ (unless (eq vc-annotate-display-mode 'fullscale)
+ (vc-annotate-display-select nil 'fullscale))
+ :help
+ "Use an autoscaled color map from the oldest to the newest annotation"
+ :style toggle :selected
+ (eq vc-annotate-display-mode 'fullscale)]
+ "--"
+ ["Toggle annotation visibility" vc-annotate-toggle-annotation-visibility
+ :help
+ "Toggle whether the annotation is visible or not"]
+ ["Annotate previous revision" vc-annotate-prev-revision
+ :help "Visit the annotation of the revision previous to this one"]
+ ["Annotate next revision" vc-annotate-next-revision
+ :help "Visit the annotation of the revision after this one"]
+ ["Annotate revision at line" vc-annotate-revision-at-line
+ :help
+ "Visit the annotation of the revision identified in the current line"]
+ ["Annotate revision previous to line" vc-annotate-revision-previous-to-line
+ :help "Visit the annotation of the revision before the revision at line"]
+ ["Annotate latest revision" vc-annotate-working-revision
+ :help "Visit the annotation of the working revision of this file"]
+ "--"
+ ["Show log of revision at line" vc-annotate-show-log-revision-at-line
+ :help "Visit the log of the revision at line"]
+ ["Show diff of revision at line" vc-annotate-show-diff-revision-at-line
+ :help "Visit the diff of the revision at line from its previous revision"]
+ ["Show changeset diff of revision at line"
+ vc-annotate-show-changeset-diff-revision-at-line
+ :enable
+ (eq 'repository (vc-call-backend ,vc-annotate-backend 'revision-granularity))
+ :help "Visit the diff of the revision at line from its previous revision"]
+ ["Visit revision at line" vc-annotate-find-revision-at-line
+ :help "Visit the revision identified in the current line"]))
+
+(defun vc-annotate-display-select (&optional buffer mode)
+ "Highlight the output of \\[vc-annotate].
+By default, the current buffer is highlighted, unless overridden by
+BUFFER. `vc-annotate-display-mode' specifies the highlighting mode to
+use; you may override this using the second optional arg MODE."
+ (interactive)
+ (when mode (setq vc-annotate-display-mode mode))
+ (pop-to-buffer (or buffer (current-buffer)))
+ (cond ((null vc-annotate-display-mode)
+ ;; The ratio is global, thus relative to the global color-map.
+ (kill-local-variable 'vc-annotate-color-map)
+ (vc-annotate-display-default (or vc-annotate-ratio 1.0)))
+ ;; One of the auto-scaling modes
+ ((eq vc-annotate-display-mode 'scale)
+ (vc-exec-after `(vc-annotate-display-autoscale)))
+ ((eq vc-annotate-display-mode 'fullscale)
+ (vc-exec-after `(vc-annotate-display-autoscale t)))
+ ((numberp vc-annotate-display-mode) ; A fixed number of days lookback
+ (vc-annotate-display-default
+ (/ vc-annotate-display-mode
+ (vc-annotate-oldest-in-map vc-annotate-color-map))))
+ (t (error "No such display mode: %s"
+ vc-annotate-display-mode))))
+
+;;;###autoload
+(defun vc-annotate (file rev &optional display-mode buf move-point-to vc-bk)
+ "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 REV; 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.
+
+If VC-BK is given used that VC backend.
+
+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
+ (vc-read-revision
+ (format "Annotate from revision (default %s): " def)
+ (list buffer-file-name) 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 (or vc-bk (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) vc-annotate-backend))))))
+
+(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
+ (if filediff fname nil) 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)))
+ vc-annotate-backend)))))
+
+(defun vc-annotate-compcar (threshold a-list)
+ "Test successive cons cells of A-LIST against THRESHOLD.
+Return the first cons cell with a car that is not less than THRESHOLD,
+nil if no such cell exists."
+ (let ((i 1)
+ (tmp-cons (car a-list)))
+ (while (and tmp-cons (< (car tmp-cons) threshold))
+ (setq tmp-cons (car (nthcdr i a-list)))
+ (setq i (+ i 1)))
+ tmp-cons)) ; Return the appropriate value
+
+(defun vc-annotate-convert-time (time)
+ "Convert a time value to a floating-point number of days.
+The argument TIME is a list as returned by `current-time' or
+`encode-time', only the first two elements of that list are considered."
+ (/ (+ (* (float (car time)) (lsh 1 16)) (cadr time)) 24 3600))
+
+(defun vc-annotate-difference (&optional offset)
+ "Return the time span in days to the next annotation.
+This calls the backend function annotate-time, and returns the
+difference in days between the time returned and the current time,
+or OFFSET if present."
+ (let ((next-time (vc-annotate-get-time-set-line-props)))
+ (when next-time
+ (- (or offset
+ (vc-call-backend vc-annotate-backend 'annotate-current-time))
+ next-time))))
+
+(defun vc-default-annotate-current-time (backend)
+ "Return the current time, encoded as fractional days."
+ (vc-annotate-convert-time (current-time)))
+
+(defvar vc-annotate-offset nil)
+
+(defun vc-annotate-display (ratio &optional offset)
+ "Highlight `vc-annotate' output in the current buffer.
+RATIO is the expansion that should be applied to `vc-annotate-color-map'.
+The annotations are relative to the current time, unless overridden by OFFSET."
+ (when (/= ratio 1.0)
+ (set (make-local-variable 'vc-annotate-color-map)
+ (mapcar (lambda (elem) (cons (* (car elem) ratio) (cdr elem)))
+ vc-annotate-color-map)))
+ (set (make-local-variable 'vc-annotate-offset) offset)
+ (font-lock-mode 1))
+
+(defun vc-annotate-lines (limit)
+ (while (< (point) limit)
+ (let ((difference (vc-annotate-difference vc-annotate-offset))
+ (start (point))
+ (end (progn (forward-line 1) (point))))
+ (when difference
+ (let* ((color (or (vc-annotate-compcar difference vc-annotate-color-map)
+ (cons nil vc-annotate-very-old-color)))
+ ;; substring from index 1 to remove any leading `#' in the name
+ (face-name (concat "vc-annotate-face-"
+ (if (string-equal
+ (substring (cdr color) 0 1) "#")
+ (substring (cdr color) 1)
+ (cdr color))))
+ ;; Make the face if not done.
+ (face (or (intern-soft face-name)
+ (let ((tmp-face (make-face (intern face-name))))
+ (set-face-foreground tmp-face (cdr color))
+ (when vc-annotate-background
+ (set-face-background tmp-face
+ vc-annotate-background))
+ tmp-face)))) ; Return the face
+ (put-text-property start end 'face face)))))
+ ;; Pretend to font-lock there were no matches.
+ nil)
+
+(provide 'vc-annotate)
+
+;; arch-tag: c3454a89-80e5-4ffd-8993-671b59612898
+;;; vc-annotate.el ends here
--- /dev/null
- ;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;;; vc-arch.el --- VC backend for the Arch version-control system
+
++;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
+;; Free Software Foundation, Inc.
+
+;; Author: FSF (see vc.el for full credits)
+;; Maintainer: Stefan Monnier <monnier@gnu.org>
+;; Package: 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 <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; The home page of the Arch version control system is at
+;;
+;; http://www.gnuarch.org/
+;;
+;; This is derived from vc-mcvs.el as follows:
+;; - cp vc-mcvs.el vc-arch.el and then M-% mcvs RET arch RET
+;;
+;; Then of course started the hacking.
+;;
+;; What has been partly tested:
+;; - Open a file.
+;; - C-x v = without any prefix arg.
+;; - C-x v v to commit a change to a single file.
+
+;; Bugs:
+
+;; - *VC-log*'s initial content lacks the `Summary:' lines.
+;; - All files under the tree are considered as "under Arch's control"
+;; without regards to =tagging-method and such.
+;; - Files are always considered as `edited'.
+;; - C-x v l does not work.
+;; - C-x v i does not work.
+;; - C-x v ~ does not work.
+;; - C-x v u does not work.
+;; - C-x v s does not work.
+;; - C-x v r does not work.
+;; - VC directory listings do not work.
+;; - And more...
+
+;;; Code:
+
+(eval-when-compile (require 'vc) (require 'cl))
+
+;;; Properties of the backend
+
+(defun vc-arch-revision-granularity () 'repository)
+(defun vc-arch-checkout-model (files) 'implicit)
+
+;;;
+;;; Customization options
+;;;
+
+;; It seems Arch diff does not accept many options, so this is not
+;; very useful. It exists mainly so that the VC backends are all
+;; consistent with regards to their treatment of diff switches.
+(defcustom vc-arch-diff-switches t
+ "String or list of strings specifying switches for Arch diff under VC.
+If nil, use the value of `vc-diff-switches'. If t, use no switches."
+ :type '(choice (const :tag "Unspecified" nil)
+ (const :tag "None" t)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List" :value ("") string))
+ :version "23.1"
+ :group 'vc)
+
+(define-obsolete-variable-alias 'vc-arch-command 'vc-arch-program "23.1")
+
+(defcustom vc-arch-program
+ (let ((candidates '("tla" "baz")))
+ (while (and candidates (not (executable-find (car candidates))))
+ (setq candidates (cdr candidates)))
+ (or (car candidates) "tla"))
+ "Name of the Arch executable."
+ :type 'string
+ :group 'vc)
+
+;; Clear up the cache to force vc-call to check again and discover
+;; new functions when we reload this file.
+(put 'Arch 'vc-functions nil)
+
+;;;###autoload (defun vc-arch-registered (file)
+;;;###autoload (if (vc-find-root file "{arch}/=tagging-method")
+;;;###autoload (progn
+;;;###autoload (load "vc-arch")
+;;;###autoload (vc-arch-registered file))))
+
+(defun vc-arch-add-tagline ()
+ "Add an `arch-tag' to the end of the current file."
+ (interactive)
+ (comment-normalize-vars)
+ (goto-char (point-max))
+ (forward-comment -1)
+ (skip-chars-forward " \t\n")
+ (cond
+ ((not (bolp)) (insert "\n\n"))
+ ((not (eq ?\n (char-before (1- (point))))) (insert "\n")))
+ (let ((beg (point))
+ (idfile (and buffer-file-name
+ (expand-file-name
+ (concat ".arch-ids/"
+ (file-name-nondirectory buffer-file-name)
+ ".id")
+ (file-name-directory buffer-file-name)))))
+ (insert "arch-tag: ")
+ (if (and idfile (file-exists-p idfile))
+ ;; If the file is unreadable, we do want to get an error here.
+ (progn
+ (insert-file-contents idfile)
+ (forward-line 1)
+ (delete-file idfile))
+ (condition-case nil
+ (call-process "uuidgen" nil t)
+ (file-error (insert (format "%s <%s> %s"
+ (current-time-string)
+ user-mail-address
+ (+ (nth 2 (current-time))
+ (buffer-size)))))))
+ (comment-region beg (point))))
+
+(defconst vc-arch-tagline-re "^\\W*arch-tag:[ \t]*\\(.*[^ \t\n]\\)")
+
+(defmacro vc-with-current-file-buffer (file &rest body)
+ (declare (indent 2) (debug t))
+ `(let ((-kill-buf- nil)
+ (-file- ,file))
+ (with-current-buffer (or (find-buffer-visiting -file-)
+ (setq -kill-buf- (generate-new-buffer " temp")))
+ ;; Avoid find-file-literally since it can do many undesirable extra
+ ;; things (among which, call us back into an infinite loop).
+ (if -kill-buf- (insert-file-contents -file-))
+ (unwind-protect
+ (progn ,@body)
+ (if (buffer-live-p -kill-buf-) (kill-buffer -kill-buf-))))))
+
+(defun vc-arch-file-source-p (file)
+ "Can return nil, `maybe' or a non-nil value.
+Only the value `maybe' can be trusted :-(."
+ ;; FIXME: Check the tag and name of parent dirs.
+ (unless (string-match "\\`[,+]" (file-name-nondirectory file))
+ (or (string-match "\\`{arch}/"
+ (file-relative-name file (vc-arch-root file)))
+ (file-exists-p
+ ;; Check the presence of an ID file.
+ (expand-file-name
+ (concat ".arch-ids/" (file-name-nondirectory file) ".id")
+ (file-name-directory file)))
+ ;; Check the presence of a tagline.
+ (vc-with-current-file-buffer file
+ (save-excursion
+ (goto-char (point-max))
+ (or (re-search-backward vc-arch-tagline-re (- (point) 1000) t)
+ (progn
+ (goto-char (point-min))
+ (re-search-forward vc-arch-tagline-re (+ (point) 1000) t)))))
+ ;; FIXME: check =tagging-method to see whether untagged files might
+ ;; be source or not.
+ (with-current-buffer
+ (find-file-noselect (expand-file-name "{arch}/=tagging-method"
+ (vc-arch-root file)))
+ (let ((untagged-source t)) ;Default is `names'.
+ (save-excursion
+ (goto-char (point-min))
+ (if (re-search-forward "^[ \t]*\\(\\(tagline\\|implicit\\|names\\)\\|explicit\\)" nil t)
+ (setq untagged-source (match-end 2)))
+ (if (re-search-forward "^[ \t]*untagged-source[ \t]+\\(\\(source\\)\\|precious\\|backup\\|junk\\|unrecognized\\)" nil t)
+ (setq untagged-source (match-end 2))))
+ (if untagged-source 'maybe))))))
+
+(defun vc-arch-file-id (file)
+ ;; Don't include the kind of ID this is because it seems to be too messy.
+ (let ((idfile (expand-file-name
+ (concat ".arch-ids/" (file-name-nondirectory file) ".id")
+ (file-name-directory file))))
+ (if (file-exists-p idfile)
+ (with-temp-buffer
+ (insert-file-contents idfile)
+ (looking-at ".*[^ \n\t]")
+ (match-string 0))
+ (with-current-buffer (find-file-noselect file)
+ (save-excursion
+ (goto-char (point-max))
+ (if (or (re-search-backward vc-arch-tagline-re (- (point) 1000) t)
+ (progn
+ (goto-char (point-min))
+ (re-search-forward vc-arch-tagline-re (+ (point) 1000) t)))
+ (match-string 1)
+ (concat "./" (file-relative-name file (vc-arch-root file)))))))))
+
+(defun vc-arch-tagging-method (file)
+ (with-current-buffer
+ (find-file-noselect
+ (expand-file-name "{arch}/=tagging-method" (vc-arch-root file)))
+ (save-excursion
+ (goto-char (point-min))
+ (if (re-search-forward
+ "^[ \t]*\\(tagline\\|implicit\\|names\\|explicit\\)" nil t)
+ (intern (match-string 1))
+ 'names))))
+
+(defun vc-arch-root (file)
+ "Return the root directory of an Arch project, if any."
+ (or (vc-file-getprop file 'arch-root)
+ ;; Check the =tagging-method, in case someone naively manually
+ ;; creates a {arch} directory somewhere.
+ (let ((root (vc-find-root file "{arch}/=tagging-method")))
+ (when root
+ (vc-file-setprop
+ file 'arch-root root)))))
+
+(defun vc-arch-register (files &optional rev comment)
+ (if rev (error "Explicit initial revision not supported for Arch"))
+ (dolist (file files)
+ (let ((tagmet (vc-arch-tagging-method file)))
+ (if (and (memq tagmet '(tagline implicit)) comment-start)
+ (with-current-buffer (find-file-noselect file)
+ (if (buffer-modified-p)
+ (error "Save %s first" (buffer-name)))
+ (vc-arch-add-tagline)
+ (save-buffer)))))
+ (vc-arch-command nil 0 files "add"))
+
+(defun vc-arch-registered (file)
+ ;; Don't seriously check whether it's source or not. Checking would
+ ;; require running TLA, so it's better to not do it, so it also works if
+ ;; TLA is not installed.
+ (and (vc-arch-root file)
+ (vc-arch-file-source-p file)))
+
+(defun vc-arch-default-version (file)
+ (or (vc-file-getprop (vc-arch-root file) 'arch-default-version)
+ (let* ((root (vc-arch-root file))
+ (f (expand-file-name "{arch}/++default-version" root)))
+ (if (file-readable-p f)
+ (vc-file-setprop
+ root 'arch-default-version
+ (with-temp-buffer
+ (insert-file-contents f)
+ ;; Strip the terminating newline.
+ (buffer-substring (point-min) (1- (point-max)))))))))
+
+(defun vc-arch-workfile-unchanged-p (file)
+ "Stub: arch workfiles are always considered to be in a changed state,"
+ nil)
+
+(defun vc-arch-state (file)
+ ;; There's no checkout operation and merging is not done from VC
+ ;; so the only operation that's state dependent that VC supports is commit
+ ;; which is only activated if the file is `edited'.
+ (let* ((root (vc-arch-root file))
+ (ver (vc-arch-default-version file))
+ (pat (concat "\\`" (subst-char-in-string ?/ ?% ver)))
+ (dir (expand-file-name ",,inode-sigs/"
+ (expand-file-name "{arch}" root)))
+ (sigfile nil))
+ (dolist (f (if (file-directory-p dir) (directory-files dir t pat)))
+ (if (or (not sigfile) (file-newer-than-file-p f sigfile))
+ (setq sigfile f)))
+ (if (not sigfile)
+ 'edited ;We know nothing.
+ (let ((id (vc-arch-file-id file)))
+ (setq id (replace-regexp-in-string "[ \t]" "_" id))
+ (with-current-buffer (find-file-noselect sigfile)
+ (goto-char (point-min))
+ (while (and (search-forward id nil 'move)
+ (save-excursion
+ (goto-char (- (match-beginning 0) 2))
+ ;; For `names', the lines start with `?./foo/bar'.
+ ;; For others there's 2 chars before the ./foo/bar.
+ (or (not (or (bolp) (looking-at "\n?")))
+ ;; Ignore E_ entries used for foo.id files.
+ (looking-at "E_")))))
+ (if (eobp)
+ ;; ID not found.
+ (if (equal (file-name-nondirectory sigfile)
+ (subst-char-in-string
+ ?/ ?% (vc-arch-working-revision file)))
+ 'added
+ ;; Might be `added' or `up-to-date' as well.
+ ;; FIXME: Check in the patch logs to find out.
+ 'edited)
+ ;; Found the ID, let's check the inode.
+ (if (not (re-search-forward
+ "\t.*mtime=\\([0-9]+\\):size=\\([0-9]+\\)"
+ (line-end-position) t))
+ ;; Buh? Unexpected format.
+ 'edited
+ (let ((ats (file-attributes file)))
+ (if (and (eq (nth 7 ats) (string-to-number (match-string 2)))
+ (equal (format-time-string "%s" (nth 5 ats))
+ (match-string 1)))
+ 'up-to-date
+ 'edited)))))))))
+
+(defun vc-arch-dir-status (dir callback)
+ "Run 'tla inventory' for DIR and pass results to CALLBACK.
+CALLBACK expects (ENTRIES &optional MORE-TO-COME); see
+`vc-dir-refresh'."
+ (let ((default-directory dir))
+ (vc-arch-command t 'async nil "changes"))
+ ;; The updating could be done asynchronously.
+ (vc-exec-after
+ `(vc-arch-after-dir-status ',callback)))
+
+(defun vc-arch-after-dir-status (callback)
+ (let* ((state-map '(("M " . edited)
+ ("Mb" . edited) ;binary
+ ("D " . removed)
+ ("D/" . removed) ;directory
+ ("A " . added)
+ ("A/" . added) ;directory
+ ("=>" . renamed)
+ ("/>" . renamed) ;directory
+ ("lf" . symlink-to-file)
+ ("fl" . file-to-symlink)
+ ("--" . permissions-changed)
+ ("-/" . permissions-changed) ;directory
+ ))
+ (state-map-regexp (regexp-opt (mapcar 'car state-map) t))
+ (entry-regexp (concat "^" state-map-regexp " \\(.*\\)$"))
+ result)
+ (goto-char (point-min))
+ ;;(message "Got %s" (buffer-string))
+ (while (re-search-forward entry-regexp nil t)
+ (let* ((state-string (match-string 1))
+ (state (cdr (assoc state-string state-map)))
+ (filename (match-string 2)))
+ (push (list filename state) result)))
+
+ (funcall callback result nil)))
+
+(defun vc-arch-working-revision (file)
+ (let* ((root (expand-file-name "{arch}" (vc-arch-root file)))
+ (defbranch (vc-arch-default-version file)))
+ (when (and defbranch (string-match "\\`\\(.+@[^/\n]+\\)/\\(\\(\\(.*?\\)\\(?:--.*\\)?\\)--.*\\)\\'" defbranch))
+ (let* ((archive (match-string 1 defbranch))
+ (category (match-string 4 defbranch))
+ (branch (match-string 3 defbranch))
+ (version (match-string 2 defbranch))
+ (sealed nil) (rev-nb 0)
+ (rev nil)
+ logdir tmp)
+ (setq logdir (expand-file-name category root))
+ (setq logdir (expand-file-name branch logdir))
+ (setq logdir (expand-file-name version logdir))
+ (setq logdir (expand-file-name archive logdir))
+ (setq logdir (expand-file-name "patch-log" logdir))
+ (dolist (file (if (file-directory-p logdir) (directory-files logdir)))
+ ;; Revision names go: base-0, patch-N, version-0, versionfix-M.
+ (when (and (eq (aref file 0) ?v) (not sealed))
+ (setq sealed t rev-nb 0))
+ (if (and (string-match "-\\([0-9]+\\)\\'" file)
+ (setq tmp (string-to-number (match-string 1 file)))
+ (or (not sealed) (eq (aref file 0) ?v))
+ (>= tmp rev-nb))
+ (setq rev-nb tmp rev file)))
+ ;; Use "none-000" if the tree hasn't yet been committed on the
+ ;; default branch. We'll then get "Arch:000[branch]" on the mode-line.
+ (concat defbranch "--" (or rev "none-000"))))))
+
+
+(defcustom vc-arch-mode-line-rewrite
+ '(("\\`.*--\\(.*--.*\\)--\\(v?\\).*-\\([0-9]+\\)\\'" . "\\2\\3[\\1]"))
+ "Rewrite rules to shorten Arch's revision names on the mode-line."
+ :type '(repeat (cons regexp string))
+ :group 'vc)
+
+(defun vc-arch-mode-line-string (file)
+ "Return string for placement in modeline by `vc-mode-line' for FILE."
+ (let ((rev (vc-working-revision file)))
+ (dolist (rule vc-arch-mode-line-rewrite)
+ (if (string-match (car rule) rev)
+ (setq rev (replace-match (cdr rule) t nil rev))))
+ (format "Arch%c%s"
+ (case (vc-state file)
+ ((up-to-date needs-update) ?-)
+ (added ?@)
+ (t ?:))
+ rev)))
+
+(defun vc-arch-diff3-rej-p (rej)
+ (let ((attrs (file-attributes rej)))
+ (and attrs (< (nth 7 attrs) 60)
+ (with-temp-buffer
+ (insert-file-contents rej)
+ (goto-char (point-min))
+ (looking-at "Conflicts occured, diff3 conflict markers left in file\\.")))))
+
+(defun vc-arch-delete-rej-if-obsolete ()
+ "For use in `after-save-hook'."
+ (save-excursion
+ (let ((rej (concat buffer-file-name ".rej")))
+ (when (and buffer-file-name (vc-arch-diff3-rej-p rej))
+ (unless (re-search-forward "^<<<<<<< " nil t)
+ ;; The .rej file is obsolete.
+ (condition-case nil (delete-file rej) (error nil))
+ ;; Remove the hook so that it is not called multiple times.
+ (remove-hook 'after-save-hook 'vc-arch-delete-rej-if-obsolete t))))))
+
+(defun vc-arch-find-file-hook ()
+ (let ((rej (concat buffer-file-name ".rej")))
+ (when (and buffer-file-name (file-exists-p rej))
+ (if (vc-arch-diff3-rej-p rej)
+ (save-excursion
+ (goto-char (point-min))
+ (if (not (re-search-forward "^<<<<<<< " nil t))
+ ;; The .rej file is obsolete.
+ (condition-case nil (delete-file rej) (error nil))
+ (smerge-mode 1)
+ (add-hook 'after-save-hook
+ 'vc-arch-delete-rej-if-obsolete nil t)
+ (message "There are unresolved conflicts in this file")))
+ (message "There are unresolved conflicts in %s"
+ (file-name-nondirectory rej))))))
+
+(defun vc-arch-checkin (files rev comment)
+ (if rev (error "Committing to a specific revision is unsupported"))
+ ;; FIXME: This implementation probably only works for singleton filesets
+ (let ((summary (file-relative-name (car files) (vc-arch-root (car files)))))
+ ;; Extract a summary from the comment.
+ (when (or (string-match "\\`Summary:[ \t]*\\(.*[^ \t\n]\\)\\([ \t]*\n\\)*" comment)
+ (string-match "\\`[ \t]*\\(.*[^ \t\n]\\)[ \t]*\\(\n?\\'\\|\n\\([ \t]*\n\\)+\\)" comment))
+ (setq summary (match-string 1 comment))
+ (setq comment (substring comment (match-end 0))))
+ (vc-arch-command nil 0 files "commit" "-s" summary "-L" comment "--"
+ (vc-switches 'Arch 'checkin))))
+
+(defun vc-arch-diff (files &optional oldvers newvers buffer)
+ "Get a difference report using Arch between two versions of FILES."
+ ;; FIXME: This implementation only works for singleton filesets. To make
+ ;; it work for more cases, we have to either call `file-diffs' manually on
+ ;; each and every `file' in the fileset, or use `changes --diffs' (and
+ ;; variants) and maybe filter the output with `filterdiff' to only include
+ ;; the files in which we're interested.
+ (let ((file (car files)))
+ (if (and newvers
+ (vc-up-to-date-p file)
+ (equal newvers (vc-working-revision file)))
+ ;; Newvers is the base revision and the current file is unchanged,
+ ;; so we can diff with the current file.
+ (setq newvers nil))
+ (if newvers
+ (error "Diffing specific revisions not implemented")
+ (let* (process-file-side-effects
+ (async (not vc-disable-async-diff))
+ ;; Run the command from the root dir.
+ (default-directory (vc-arch-root file))
+ (status
+ (vc-arch-command
+ (or buffer "*vc-diff*")
+ (if async 'async 1)
+ nil "file-diffs"
+ (vc-switches 'Arch 'diff)
+ (file-relative-name file)
+ (if (equal oldvers (vc-working-revision file))
+ nil
+ oldvers))))
+ (if async 1 status))))) ; async diff, pessimistic assumption.
+
+(defun vc-arch-delete-file (file)
+ (vc-arch-command nil 0 file "rm"))
+
+(defun vc-arch-rename-file (old new)
+ (vc-arch-command nil 0 new "mv" (file-relative-name old)))
+
+(defalias 'vc-arch-responsible-p 'vc-arch-root)
+
+(defun vc-arch-command (buffer okstatus file &rest flags)
+ "A wrapper around `vc-do-command' for use in vc-arch.el."
+ (apply 'vc-do-command (or buffer "*vc*") okstatus vc-arch-program file flags))
+
+(defun vc-arch-init-revision () nil)
+
+;;; Completion of versions and revisions.
+
+(defun vc-arch--version-completion-table (root string)
+ (delq nil
+ (mapcar
+ (lambda (d)
+ (when (string-match "/\\([^/]+\\)/\\([^/]+\\)\\'" d)
+ (concat (match-string 2 d) "/" (match-string 1 d))))
+ (let ((default-directory root))
+ (file-expand-wildcards
+ (concat "*/*/"
+ (if (string-match "/" string)
+ (concat (substring string (match-end 0))
+ "*/" (substring string 0 (match-beginning 0)))
+ (concat "*/" string))
+ "*"))))))
+
+(defun vc-arch-revision-completion-table (files)
+ (lexical-let ((files files))
+ (lambda (string pred action)
+ ;; FIXME: complete revision patches as well.
+ (let* ((root (expand-file-name "{arch}" (vc-arch-root (car files))))
+ (table (vc-arch--version-completion-table root string)))
+ (complete-with-action action table string pred)))))
+
+;;; Trimming revision libraries.
+
+;; This code is not directly related to VC and there are many variants of
+;; this functionality available as scripts, but I like this version better,
+;; so maybe others will like it too.
+
+(defun vc-arch-trim-find-least-useful-rev (revs)
+ (let* ((first (pop revs))
+ (second (pop revs))
+ (third (pop revs))
+ ;; We try to give more importance to recent revisions. The idea is
+ ;; that it's OK if checking out a revision 1000-patch-old is ten
+ ;; times slower than checking out a revision 100-patch-old. But at
+ ;; the same time a 2-patch-old rev isn't really ten times more
+ ;; important than a 20-patch-old, so we use an arbitrary constant
+ ;; "100" to reduce this effect for recent revisions. Making this
+ ;; constant a float has the side effect of causing the subsequent
+ ;; computations to be done as floats as well.
+ (max (+ 100.0 (car (or (car (last revs)) third))))
+ (cost (lambda () (/ (- (car third) (car first)) (- max (car second)))))
+ (minrev second)
+ (mincost (funcall cost)))
+ (while revs
+ (setq first second)
+ (setq second third)
+ (setq third (pop revs))
+ (when (< (funcall cost) mincost)
+ (setq minrev second)
+ (setq mincost (funcall cost))))
+ minrev))
+
+(defun vc-arch-trim-make-sentinel (revs)
+ (if (null revs) (lambda (proc msg) (message "VC-Arch trimming ... done"))
+ (lexical-let ((revs revs))
+ (lambda (proc msg)
+ (message "VC-Arch trimming %s..." (file-name-nondirectory (car revs)))
+ (rename-file (car revs) (concat (car revs) "*rm*"))
+ (setq proc (start-process "vc-arch-trim" nil
+ "rm" "-rf" (concat (car revs) "*rm*")))
+ (set-process-sentinel proc (vc-arch-trim-make-sentinel (cdr revs)))))))
+
+(defun vc-arch-trim-one-revlib (dir)
+ "Delete half of the revisions in the revision library."
+ (interactive "Ddirectory: ")
+ (let ((garbage (directory-files dir 'full "\\`,," 'nosort)))
+ (when garbage
+ (funcall (vc-arch-trim-make-sentinel garbage) nil nil)))
+ (let ((revs
+ (sort (delq nil
+ (mapcar
+ (lambda (f)
+ (when (string-match "-\\([0-9]+\\)\\'" f)
+ (cons (string-to-number (match-string 1 f)) f)))
+ (directory-files dir nil nil 'nosort)))
+ 'car-less-than-car))
+ (subdirs nil))
+ (when (cddr revs)
+ (dotimes (i (/ (length revs) 2))
+ (let ((minrev (vc-arch-trim-find-least-useful-rev revs)))
+ (setq revs (delq minrev revs))
+ (push minrev subdirs)))
+ (funcall (vc-arch-trim-make-sentinel
+ (mapcar (lambda (x) (expand-file-name (cdr x) dir)) subdirs))
+ nil nil))))
+
+(defun vc-arch-trim-revlib ()
+ "Delete half of the revisions in the revision library."
+ (interactive)
+ (let ((rl-dir (with-output-to-string
+ (call-process vc-arch-program nil standard-output nil
+ "my-revision-library"))))
+ (while (string-match "\\(.*\\)\n" rl-dir)
+ (let ((dir (match-string 1 rl-dir)))
+ (setq rl-dir
+ (if (and (file-directory-p dir) (file-writable-p dir))
+ dir
+ (substring rl-dir (match-end 0))))))
+ (unless (file-writable-p rl-dir)
+ (error "No writable revlib directory found"))
+ (message "Revlib at %s" rl-dir)
+ (let* ((archives (directory-files rl-dir 'full "[^.]\\|..."))
+ (categories
+ (apply 'append
+ (mapcar (lambda (dir)
+ (when (file-directory-p dir)
+ (directory-files dir 'full "[^.]\\|...")))
+ archives)))
+ (branches
+ (apply 'append
+ (mapcar (lambda (dir)
+ (when (file-directory-p dir)
+ (directory-files dir 'full "[^.]\\|...")))
+ categories)))
+ (versions
+ (apply 'append
+ (mapcar (lambda (dir)
+ (when (file-directory-p dir)
+ (directory-files dir 'full "--.*--")))
+ branches))))
+ (mapc 'vc-arch-trim-one-revlib versions))
+ ))
+
+(defvar vc-arch-extra-menu-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [add-tagline]
+ '(menu-item "Add tagline" vc-arch-add-tagline))
+ map))
+
+(defun vc-arch-extra-menu () vc-arch-extra-menu-map)
+
+
+;;; Less obvious implementations.
+
+(defun vc-arch-find-revision (file rev buffer)
+ (let ((out (make-temp-file "vc-out")))
+ (unwind-protect
+ (progn
+ (with-temp-buffer
+ (vc-arch-command (current-buffer) 1 nil "file-diffs" file rev)
+ (call-process-region (point-min) (point-max)
+ "patch" nil nil nil "-R" "-o" out file))
+ (with-current-buffer buffer
+ (insert-file-contents out)))
+ (delete-file out))))
+
+(provide 'vc-arch)
+
+;; arch-tag: a35c7c1c-5237-429d-88ef-3d718fd2e704
+;;; vc-arch.el ends here
--- /dev/null
- ;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;;; 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, 2011 Free Software Foundation, Inc.
+
+;; Author: FSF (see vc.el for full credits)
+;; Maintainer: Andre Spiegel <spiegel@gnu.org>
+;; Package: 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 <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(eval-when-compile (require 'cl) (require 'vc))
+
+;; Clear up the cache to force vc-call to check again and discover
+;; new functions when we reload this file.
+(put 'CVS 'vc-functions nil)
+
+;;; Properties of the backend.
+
+(defun vc-cvs-revision-granularity () 'file)
+
+(defun vc-cvs-checkout-model (files)
+ "CVS-specific version of `vc-checkout-model'."
+ (if (getenv "CVSREAD")
+ 'announce
+ (let* ((file (if (consp files) (car files) files))
+ (attrib (file-attributes file)))
+ (or (vc-file-getprop file 'vc-checkout-model)
+ (vc-file-setprop
+ file 'vc-checkout-model
+ (if (and attrib ;; don't check further if FILE doesn't exist
+ ;; If the file is not writable (despite CVSREAD being
+ ;; undefined), this is probably because the file is being
+ ;; "watched" by other developers.
+ ;; (If vc-mistrust-permissions was t, we actually shouldn't
+ ;; trust this, but there is no other way to learn this from
+ ;; CVS at the moment (version 1.9).)
+ (string-match "r-..-..-." (nth 8 attrib)))
+ 'announce
+ 'implicit))))))
+
+;;;
+;;; Customization options
+;;;
+
+(defcustom vc-cvs-global-switches nil
+ "Global switches to pass to any CVS command."
+ :type '(choice (const :tag "None" nil)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List"
+ :value ("")
+ string))
+ :version "22.1"
+ :group 'vc)
+
+(defcustom vc-cvs-register-switches nil
+ "Switches for registering a file into CVS.
+A string or list of strings passed to the checkin program by
+\\[vc-register]. If nil, use the value of `vc-register-switches'.
+If t, use no switches."
+ :type '(choice (const :tag "Unspecified" nil)
+ (const :tag "None" t)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List" :value ("") string))
+ :version "21.1"
+ :group 'vc)
+
+(defcustom vc-cvs-diff-switches nil
+ "String or list of strings specifying switches for CVS diff under VC.
+If nil, use the value of `vc-diff-switches'. If t, use no switches."
+ :type '(choice (const :tag "Unspecified" nil)
+ (const :tag "None" t)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List" :value ("") string))
+ :version "21.1"
+ :group 'vc)
+
+(defcustom vc-cvs-header '("\$Id\$")
+ "Header keywords to be inserted by `vc-insert-headers'."
+ :version "24.1" ; no longer consult the obsolete vc-header-alist
+ :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)
+ "CVS-specific version of `vc-backend-checkin'."
+ (unless (or (not rev) (vc-cvs-valid-revision-number-p rev))
+ (if (not (vc-cvs-valid-symbolic-tag-name-p rev))
+ (error "%s is not a valid symbolic tag name" rev)
+ ;; If the input revison is a valid symbolic tag name, we create it
+ ;; as a branch, commit and switch to it.
+ (apply 'vc-cvs-command nil 0 files "tag" "-b" (list rev))
+ (apply 'vc-cvs-command nil 0 files "update" "-r" (list rev))
+ (mapc (lambda (file) (vc-file-setprop file 'vc-cvs-sticky-tag rev))
+ files)))
+ (let ((status (apply 'vc-cvs-command nil 1 files
+ "ci" (if rev (concat "-r" rev))
+ (concat "-m" comment)
+ (vc-switches 'CVS 'checkin))))
+ (set-buffer "*vc*")
+ (goto-char (point-min))
+ (when (not (zerop status))
+ ;; Check checkin problem.
+ (cond
+ ((re-search-forward "Up-to-date check failed" nil t)
+ (mapc (lambda (file) (vc-file-setprop file 'vc-state 'needs-merge))
+ files)
+ (error "%s" (substitute-command-keys
+ (concat "Up-to-date check failed: "
+ "type \\[vc-next-action] to merge in changes"))))
+ (t
+ (pop-to-buffer (current-buffer))
+ (goto-char (point-min))
+ (shrink-window-if-larger-than-buffer)
+ (error "Check-in failed"))))
+ ;; Single-file commit? Then update the revision by parsing the buffer.
+ ;; Otherwise we can't necessarily tell what goes with what; clear
+ ;; its properties so they have to be refetched.
+ (if (= (length files) 1)
+ (vc-file-setprop
+ (car files) 'vc-working-revision
+ (vc-parse-buffer "^\\(new\\|initial\\) revision: \\([0-9.]+\\)" 2))
+ (mapc 'vc-file-clearprops files))
+ ;; Anyway, forget the checkout model of the file, because we might have
+ ;; guessed wrong when we found the file. After commit, we can
+ ;; tell it from the permissions of the file (see
+ ;; vc-cvs-checkout-model).
+ (mapc (lambda (file) (vc-file-setprop file 'vc-checkout-model nil))
+ files)
+
+ ;; if this was an explicit check-in (does not include creation of
+ ;; a branch), remove the sticky tag.
+ (if (and rev (not (vc-cvs-valid-symbolic-tag-name-p rev)))
+ (vc-cvs-command nil 0 files "update" "-A"))))
+
+(defun vc-cvs-find-revision (file rev buffer)
+ (apply 'vc-cvs-command
+ buffer 0 file
+ "-Q" ; suppress diagnostic output
+ "update"
+ (and rev (not (string= rev ""))
+ (concat "-r" rev))
+ "-p"
+ (vc-switches 'CVS 'checkout)))
+
+(defun vc-cvs-checkout (file &optional editable rev)
+ "Checkout a revision of FILE into the working area.
+EDITABLE non-nil means that the file should be writable.
+REV is the revision to check out."
+ (message "Checking out %s..." file)
+ ;; Change buffers to get local value of vc-checkout-switches.
+ (with-current-buffer (or (get-file-buffer file) (current-buffer))
+ (if (and (file-exists-p file) (not rev))
+ ;; If no revision was specified, just make the file writable
+ ;; if necessary (using `cvs-edit' if requested).
+ (and editable (not (eq (vc-cvs-checkout-model (list file)) 'implicit))
+ (if vc-cvs-use-edit
+ (vc-cvs-command nil 0 file "edit")
+ (set-file-modes file (logior (file-modes file) 128))
+ (if (equal file buffer-file-name) (toggle-read-only -1))))
+ ;; Check out a particular revision (or recreate the file).
+ (vc-file-setprop file 'vc-working-revision nil)
+ (apply 'vc-cvs-command nil 0 file
+ (and editable "-w")
+ "update"
+ (when rev
+ (unless (eq rev t)
+ ;; default for verbose checkout: clear the
+ ;; sticky tag so that the actual update will
+ ;; get the head of the trunk
+ (if (string= rev "")
+ "-A"
+ (concat "-r" rev))))
+ (vc-switches 'CVS 'checkout)))
+ (vc-mode-line file 'CVS))
+ (message "Checking out %s...done" file))
+
+(defun vc-cvs-delete-file (file)
+ (vc-cvs-command nil 0 file "remove" "-f"))
+
+(defun vc-cvs-revert (file &optional contents-done)
+ "Revert FILE to the working revision on which it was based."
+ (vc-default-revert 'CVS file contents-done)
+ (unless (eq (vc-cvs-checkout-model (list file)) 'implicit)
+ (if vc-cvs-use-edit
+ (vc-cvs-command nil 0 file "unedit")
+ ;; Make the file read-only by switching off all w-bits
+ (set-file-modes file (logand (file-modes file) 3950)))))
+
+(defun vc-cvs-merge (file first-revision &optional second-revision)
+ "Merge changes into current working copy of FILE.
+The changes are between FIRST-REVISION and SECOND-REVISION."
+ (vc-cvs-command nil 0 file
+ "update" "-kk"
+ (concat "-j" first-revision)
+ (concat "-j" second-revision))
+ (vc-file-setprop file 'vc-state 'edited)
+ (with-current-buffer (get-buffer "*vc*")
+ (goto-char (point-min))
+ (if (re-search-forward "conflicts during merge" nil t)
+ (progn
+ (vc-file-setprop file 'vc-state 'conflict)
+ ;; signal error
+ 1)
+ (vc-file-setprop file 'vc-state 'edited)
+ ;; signal success
+ 0)))
+
+(defun vc-cvs-merge-news (file)
+ "Merge in any new changes made to FILE."
+ (message "Merging changes into %s..." file)
+ ;; (vc-file-setprop file 'vc-working-revision nil)
+ (vc-file-setprop file 'vc-checkout-time 0)
+ (vc-cvs-command nil nil file "update")
+ ;; Analyze the merge result reported by CVS, and set
+ ;; file properties accordingly.
+ (with-current-buffer (get-buffer "*vc*")
+ (goto-char (point-min))
+ ;; get new working revision
+ (if (re-search-forward
+ "^Merging differences between [0-9.]* and \\([0-9.]*\\) into" nil t)
+ (vc-file-setprop file 'vc-working-revision (match-string 1))
+ (vc-file-setprop file 'vc-working-revision nil))
+ ;; get file status
+ (prog1
+ (if (eq (buffer-size) 0)
+ 0 ;; there were no news; indicate success
+ (if (re-search-forward
+ (concat "^\\([CMUP] \\)?"
+ (regexp-quote
+ (substring file (1+ (length (expand-file-name
+ "." default-directory)))))
+ "\\( already contains the differences between \\)?")
+ nil t)
+ (cond
+ ;; Merge successful, we are in sync with repository now
+ ((or (match-string 2)
+ (string= (match-string 1) "U ")
+ (string= (match-string 1) "P "))
+ (vc-file-setprop file 'vc-state 'up-to-date)
+ (vc-file-setprop file 'vc-checkout-time
+ (nth 5 (file-attributes file)))
+ 0);; indicate success to the caller
+ ;; Merge successful, but our own changes are still in the file
+ ((string= (match-string 1) "M ")
+ (vc-file-setprop file 'vc-state 'edited)
+ 0);; indicate success to the caller
+ ;; Conflicts detected!
+ (t
+ (vc-file-setprop file 'vc-state 'conflict)
+ 1);; signal the error to the caller
+ )
+ (pop-to-buffer "*vc*")
+ (error "Couldn't analyze cvs update result")))
+ (message "Merging changes into %s...done" file))))
+
+(defun vc-cvs-modify-change-comment (files rev comment)
+ "Modify the change comments for FILES on a specified REV.
+Will fail unless you have administrative privileges on the repo."
+ (vc-cvs-command nil 0 files "admin" (concat "-m" rev ":" comment)))
+
+;;;
+;;; History functions
+;;;
+
+(declare-function vc-rcs-print-log-cleanup "vc-rcs" ())
+
+(defun vc-cvs-print-log (files buffer &optional shortlog start-revision-ignored limit)
+ "Get change logs associated with FILES."
+ (require 'vc-rcs)
+ ;; It's just the catenation of the individual logs.
+ (vc-cvs-command
+ buffer
+ (if (vc-stay-local-p files 'CVS) 'async 0)
+ files "log")
+ (with-current-buffer buffer
+ (vc-exec-after (vc-rcs-print-log-cleanup)))
+ (when limit 'limit-unsupported))
+
+(defun vc-cvs-comment-history (file)
+ "Get comment history of a file."
+ (vc-call-backend 'RCS 'comment-history file))
+
+(defun vc-cvs-diff (files &optional oldvers newvers buffer)
+ "Get a difference report using CVS between two revisions of FILE."
+ (let* (process-file-side-effects
+ (async (and (not vc-disable-async-diff)
+ (vc-stay-local-p files 'CVS)))
+ (invoke-cvs-diff-list nil)
+ status)
+ ;; Look through the file list and see if any files have backups
+ ;; that can be used to do a plain "diff" instead of "cvs diff".
+ (dolist (file files)
+ (let ((ov oldvers)
+ (nv newvers))
+ (when (or (not ov) (string-equal ov ""))
+ (setq ov (vc-working-revision file)))
+ (when (string-equal nv "")
+ (setq nv nil))
+ (let ((file-oldvers (vc-version-backup-file file ov))
+ (file-newvers (if (not nv)
+ file
+ (vc-version-backup-file file nv)))
+ (coding-system-for-read (vc-coding-system-for-diff file)))
+ (if (and file-oldvers file-newvers)
+ (progn
+ ;; This used to append diff-switches and vc-diff-switches,
+ ;; which was consistent with the vc-diff-switches doc at that
+ ;; time, but not with the actual behavior of any other VC diff.
+ (apply 'vc-do-command (or buffer "*vc-diff*") 1 "diff" nil
+ ;; Not a CVS diff, does not use vc-cvs-diff-switches.
+ (append (vc-switches nil 'diff)
+ (list (file-relative-name file-oldvers)
+ (file-relative-name file-newvers))))
+ (setq status 0))
+ (push file invoke-cvs-diff-list)))))
+ (when invoke-cvs-diff-list
+ (setq status (apply 'vc-cvs-command (or buffer "*vc-diff*")
+ (if async 'async 1)
+ invoke-cvs-diff-list "diff"
+ (and oldvers (concat "-r" oldvers))
+ (and newvers (concat "-r" newvers))
+ (vc-switches 'CVS 'diff))))
+ (if async 1 status))) ; async diff, pessimistic assumption
+
+(defconst vc-cvs-annotate-first-line-re "^[0-9]")
+
+(defun vc-cvs-annotate-process-filter (process string)
+ (setq string (concat (process-get process 'output) string))
+ (if (not (string-match vc-cvs-annotate-first-line-re string))
+ ;; Still waiting for the first real line.
+ (process-put process 'output string)
+ (let ((vc-filter (process-get process 'vc-filter)))
+ (set-process-filter process vc-filter)
+ (funcall vc-filter process (substring string (match-beginning 0))))))
+
+(defun vc-cvs-annotate-command (file buffer &optional revision)
+ "Execute \"cvs annotate\" on FILE, inserting the contents in BUFFER.
+Optional arg REVISION is a revision to annotate from."
+ (vc-cvs-command buffer
+ (if (vc-stay-local-p file 'CVS)
+ 'async 0)
+ file "annotate"
+ (if revision (concat "-r" revision)))
+ ;; Strip the leading few lines.
+ (let ((proc (get-buffer-process buffer)))
+ (if proc
+ ;; If running asynchronously, use a process filter.
+ (progn
+ (process-put proc 'vc-filter (process-filter proc))
+ (set-process-filter proc 'vc-cvs-annotate-process-filter))
+ (with-current-buffer buffer
+ (goto-char (point-min))
+ (re-search-forward vc-cvs-annotate-first-line-re)
+ (delete-region (point-min) (1- (point)))))))
+
+(declare-function vc-annotate-convert-time "vc-annotate" (time))
+
+(defun vc-cvs-annotate-current-time ()
+ "Return the current time, based at midnight of the current day, and
+encoded as fractional days."
+ (vc-annotate-convert-time
+ (apply 'encode-time 0 0 0 (nthcdr 3 (decode-time (current-time))))))
+
+(defun vc-cvs-annotate-time ()
+ "Return the time of the next annotation (as fraction of days)
+systime, or nil if there is none."
+ (let* ((bol (point))
+ (cache (get-text-property bol 'vc-cvs-annotate-time))
+ (inhibit-read-only t)
+ (inhibit-modification-hooks t))
+ (cond
+ (cache)
+ ((looking-at
+ "^\\S-+\\s-+\\S-+\\s-+\\([0-9]+\\)-\\(\\sw+\\)-\\([0-9]+\\)): ")
+ (let ((day (string-to-number (match-string 1)))
+ (month (cdr (assq (intern (match-string 2))
+ '((Jan . 1) (Feb . 2) (Mar . 3)
+ (Apr . 4) (May . 5) (Jun . 6)
+ (Jul . 7) (Aug . 8) (Sep . 9)
+ (Oct . 10) (Nov . 11) (Dec . 12)))))
+ (year (let ((tmp (string-to-number (match-string 3))))
+ ;; Years 0..68 are 2000..2068.
+ ;; Years 69..99 are 1969..1999.
+ (+ (cond ((> 69 tmp) 2000)
+ ((> 100 tmp) 1900)
+ (t 0))
+ tmp))))
+ (put-text-property
+ bol (1+ bol) 'vc-cvs-annotate-time
+ (setq cache (cons
+ ;; Position at end makes for nicer overlay result.
+ ;; Don't put actual buffer pos here, but only relative
+ ;; distance, so we don't ever move backward in the
+ ;; goto-char below, even if the text is moved.
+ (- (match-end 0) (match-beginning 0))
+ (vc-annotate-convert-time
+ (encode-time 0 0 0 day month year))))))))
+ (when cache
+ (goto-char (+ bol (car cache))) ; Fontify from here to eol.
+ (cdr cache)))) ; days (float)
+
+(defun vc-cvs-annotate-extract-revision-at-line ()
+ (save-excursion
+ (beginning-of-line)
+ (if (re-search-forward "^\\([0-9]+\\.[0-9]+\\(\\.[0-9]+\\)*\\) +("
+ (line-end-position) t)
+ (match-string-no-properties 1)
+ nil)))
+
+(defun vc-cvs-previous-revision (file rev)
+ (vc-call-backend 'RCS 'previous-revision file rev))
+
+(defun vc-cvs-next-revision (file rev)
+ (vc-call-backend 'RCS 'next-revision file rev))
+
+;; FIXME: This should probably be replaced by code using cvs2cl.
+(defun vc-cvs-update-changelog (files)
+ (vc-call-backend 'RCS 'update-changelog files))
+
+;;;
+;;; Tag system
+;;;
+
+(defun vc-cvs-create-tag (dir name branchp)
+ "Assign to DIR's current revision a given NAME.
+If BRANCHP is non-nil, the name is created as a branch (and the current
+workspace is immediately moved to that new branch)."
+ (vc-cvs-command nil 0 dir "tag" "-c" (if branchp "-b") name)
+ (when branchp (vc-cvs-command nil 0 dir "update" "-r" name)))
+
+(defun vc-cvs-retrieve-tag (dir name update)
+ "Retrieve a tag at and below DIR.
+NAME is the name of the tag; if it is empty, do a `cvs update'.
+If UPDATE is non-nil, then update (resynch) any affected buffers."
+ (with-current-buffer (get-buffer-create "*vc*")
+ (let ((default-directory dir)
+ (sticky-tag))
+ (erase-buffer)
+ (if (or (not name) (string= name ""))
+ (vc-cvs-command t 0 nil "update")
+ (vc-cvs-command t 0 nil "update" "-r" name)
+ (setq sticky-tag name))
+ (when update
+ (goto-char (point-min))
+ (while (not (eobp))
+ (if (looking-at "\\([CMUP]\\) \\(.*\\)")
+ (let* ((file (expand-file-name (match-string 2) dir))
+ (state (match-string 1))
+ (buffer (find-buffer-visiting file)))
+ (when buffer
+ (cond
+ ((or (string= state "U")
+ (string= state "P"))
+ (vc-file-setprop file 'vc-state 'up-to-date)
+ (vc-file-setprop file 'vc-working-revision nil)
+ (vc-file-setprop file 'vc-checkout-time
+ (nth 5 (file-attributes file))))
+ ((or (string= state "M")
+ (string= state "C"))
+ (vc-file-setprop file 'vc-state 'edited)
+ (vc-file-setprop file 'vc-working-revision nil)
+ (vc-file-setprop file 'vc-checkout-time 0)))
+ (vc-file-setprop file 'vc-cvs-sticky-tag sticky-tag)
+ (vc-resynch-buffer file t t))))
+ (forward-line 1))))))
+
+
+;;;
+;;; Miscellaneous
+;;;
+
+(defun vc-cvs-make-version-backups-p (file)
+ "Return non-nil if version backups should be made for FILE."
+ (vc-stay-local-p file 'CVS))
+
+(defun vc-cvs-check-headers ()
+ "Check if the current file has any headers in it."
+ (save-excursion
+ (goto-char (point-min))
+ (re-search-forward "\\$[A-Za-z\300-\326\330-\366\370-\377]+\
+\\(: [\t -#%-\176\240-\377]*\\)?\\$" nil t)))
+
+
+;;;
+;;; Internal functions
+;;;
+
+(defun vc-cvs-command (buffer okstatus files &rest flags)
+ "A wrapper around `vc-do-command' for use in vc-cvs.el.
+The difference to vc-do-command is that this function always invokes `cvs',
+and that it passes `vc-cvs-global-switches' to it before FLAGS."
+ (apply 'vc-do-command (or buffer "*vc*") okstatus "cvs" files
+ (if (stringp vc-cvs-global-switches)
+ (cons vc-cvs-global-switches flags)
+ (append vc-cvs-global-switches
+ flags))))
+
+(defun vc-cvs-stay-local-p (file) ;Back-compatibility.
+ (vc-stay-local-p file 'CVS))
+
+(defun vc-cvs-repository-hostname (dirname)
+ "Hostname of the CVS server associated to workarea DIRNAME."
+ (let ((rootname (expand-file-name "CVS/Root" dirname)))
+ (when (file-readable-p rootname)
+ (with-temp-buffer
+ (let ((coding-system-for-read
+ (or file-name-coding-system
+ default-file-name-coding-system)))
+ (vc-insert-file rootname))
+ (goto-char (point-min))
+ (nth 2 (vc-cvs-parse-root
+ (buffer-substring (point)
+ (line-end-position))))))))
+
+(defun vc-cvs-parse-uhp (path)
+ "parse user@host/path into (user@host /path)"
+ (if (string-match "\\([^/]+\\)\\(/.*\\)" path)
+ (list (match-string 1 path) (match-string 2 path))
+ (list nil path)))
+
+(defun vc-cvs-parse-root (root)
+ "Split CVS ROOT specification string into a list of fields.
+A CVS root specification of the form
+ [:METHOD:][[USER@]HOSTNAME]:?/path/to/repository
+is converted to a normalized record with the following structure:
+ \(METHOD USER HOSTNAME CVS-ROOT).
+The default METHOD for a CVS root of the form
+ /path/to/repository
+is `local'.
+The default METHOD for a CVS root of the form
+ [USER@]HOSTNAME:/path/to/repository
+is `ext'.
+For an empty string, nil is returned (invalid CVS root)."
+ ;; Split CVS root into colon separated fields (0-4).
+ ;; The `x:' makes sure, that leading colons are not lost;
+ ;; `HOST:/PATH' is then different from `:METHOD:/PATH'.
+ (let* ((root-list (cdr (split-string (concat "x:" root) ":")))
+ (len (length root-list))
+ ;; All syntactic varieties will get a proper METHOD.
+ (root-list
+ (cond
+ ((= len 0)
+ ;; Invalid CVS root
+ nil)
+ ((= len 1)
+ (let ((uhp (vc-cvs-parse-uhp (car root-list))))
+ (cons (if (car uhp) "ext" "local") uhp)))
+ ((= len 2)
+ ;; [USER@]HOST:PATH => method `ext'
+ (and (not (equal (car root-list) ""))
+ (cons "ext" root-list)))
+ ((= len 3)
+ ;; :METHOD:PATH or :METHOD:USER@HOSTNAME/PATH
+ (cons (cadr root-list)
+ (vc-cvs-parse-uhp (caddr root-list))))
+ (t
+ ;; :METHOD:[USER@]HOST:PATH
+ (cdr root-list)))))
+ (if root-list
+ (let ((method (car root-list))
+ (uhost (or (cadr root-list) ""))
+ (root (nth 2 root-list))
+ user host)
+ ;; Split USER@HOST
+ (if (string-match "\\(.*\\)@\\(.*\\)" uhost)
+ (setq user (match-string 1 uhost)
+ host (match-string 2 uhost))
+ (setq host uhost))
+ ;; Remove empty HOST
+ (and (equal host "")
+ (setq host))
+ ;; Fix windows style CVS root `:local:C:\\project\\cvs\\some\\dir'
+ (and host
+ (equal method "local")
+ (setq root (concat host ":" root) host))
+ ;; Normalize CVS root record
+ (list method user host root)))))
+
+;; XXX: This does not work correctly for subdirectories. "cvs status"
+;; information is context sensitive, it contains lines like:
+;; cvs status: Examining DIRNAME
+;; and the file entries after that don't show the full path.
+;; Because of this VC directory listings only show changed files
+;; at the top level for CVS.
+(defun vc-cvs-parse-status (&optional full)
+ "Parse output of \"cvs status\" command in the current buffer.
+Set file properties accordingly. Unless FULL is t, parse only
+essential information. Note that this can never set the 'ignored
+state."
+ (let (file status missing)
+ (goto-char (point-min))
+ (while (looking-at "? \\(.*\\)")
+ (setq file (expand-file-name (match-string 1)))
+ (vc-file-setprop file 'vc-state 'unregistered)
+ (forward-line 1))
+ (when (re-search-forward "^File: " nil t)
+ (when (setq missing (looking-at "no file "))
+ (goto-char (match-end 0)))
+ (cond
+ ((re-search-forward "\\=\\([^ \t]+\\)" nil t)
+ (setq file (expand-file-name (match-string 1)))
+ (setq status(if (re-search-forward "\\=[ \t]+Status: \\(.*\\)" nil t)
+ (match-string 1) "Unknown"))
+ (when (and full
+ (re-search-forward
+ "\\(RCS Version\\|RCS Revision\\|Repository revision\\):\
+\[\t ]+\\([0-9.]+\\)"
+ nil t))
+ (vc-file-setprop file 'vc-latest-revision (match-string 2)))
+ (vc-file-setprop
+ file 'vc-state
+ (cond
+ ((string-match "Up-to-date" status)
+ (vc-file-setprop file 'vc-checkout-time
+ (nth 5 (file-attributes file)))
+ 'up-to-date)
+ ((string-match "Locally Modified" status) 'edited)
+ ((string-match "Needs Merge" status) 'needs-merge)
+ ((string-match "Needs \\(Checkout\\|Patch\\)" status)
+ (if missing 'missing 'needs-update))
+ ((string-match "Locally Added" status) 'added)
+ ((string-match "Locally Removed" status) 'removed)
+ ((string-match "File had conflicts " status) 'conflict)
+ ((string-match "Unknown" status) 'unregistered)
+ (t 'edited))))))))
+
+(defun vc-cvs-after-dir-status (update-function)
+ ;; Heavily inspired by vc-cvs-parse-status. AKA a quick hack.
+ ;; This needs a lot of testing.
+ (let ((status nil)
+ (status-str nil)
+ (file nil)
+ (result nil)
+ (missing nil)
+ (ignore-next nil)
+ (subdir default-directory))
+ (goto-char (point-min))
+ (while
+ ;; Look for either a file entry, an unregistered file, or a
+ ;; directory change.
+ (re-search-forward
+ "\\(^=+\n\\([^=c?\n].*\n\\|\n\\)+\\)\\|\\(\\(^?? .*\n\\)+\\)\\|\\(^cvs status: \\(Examining\\|nothing\\) .*\n\\)"
+ nil t)
+ ;; FIXME: get rid of narrowing here.
+ (narrow-to-region (match-beginning 0) (match-end 0))
+ (goto-char (point-min))
+ ;; The subdir
+ (when (looking-at "cvs status: Examining \\(.+\\)")
+ (setq subdir (expand-file-name (match-string 1))))
+ ;; Unregistered files
+ (while (looking-at "? \\(.*\\)")
+ (setq file (file-relative-name
+ (expand-file-name (match-string 1) subdir)))
+ (push (list file 'unregistered) result)
+ (forward-line 1))
+ (when (looking-at "cvs status: nothing known about")
+ ;; We asked about a non existent file. The output looks like this:
+
+ ;; cvs status: nothing known about `lisp/v.diff'
+ ;; ===================================================================
+ ;; File: no file v.diff Status: Unknown
+ ;;
+ ;; Working revision: No entry for v.diff
+ ;; Repository revision: No revision control file
+ ;;
+
+ ;; Due to narrowing in this iteration we only see the "cvs
+ ;; status:" line, so just set a flag so that we can ignore the
+ ;; file in the next iteration.
+ (setq ignore-next t))
+ ;; A file entry.
+ (when (re-search-forward "^File: \\(no file \\)?\\(.*[^ \t]\\)[ \t]+Status: \\(.*\\)" nil t)
+ (setq missing (match-string 1))
+ (setq file (file-relative-name
+ (expand-file-name (match-string 2) subdir)))
+ (setq status-str (match-string 3))
+ (setq status
+ (cond
+ ((string-match "Up-to-date" status-str) 'up-to-date)
+ ((string-match "Locally Modified" status-str) 'edited)
+ ((string-match "Needs Merge" status-str) 'needs-merge)
+ ((string-match "Needs \\(Checkout\\|Patch\\)" status-str)
+ (if missing 'missing 'needs-update))
+ ((string-match "Locally Added" status-str) 'added)
+ ((string-match "Locally Removed" status-str) 'removed)
+ ((string-match "File had conflicts " status-str) 'conflict)
+ ((string-match "Unknown" status-str) 'unregistered)
+ (t 'edited)))
+ (if ignore-next
+ (setq ignore-next nil)
+ (unless (eq status 'up-to-date)
+ (push (list file status) result))))
+ (goto-char (point-max))
+ (widen))
+ (funcall update-function result))
+ ;; Alternative implementation: use the "update" command instead of
+ ;; the "status" command.
+ ;; (let ((result nil)
+ ;; (translation '((?? . unregistered)
+ ;; (?A . added)
+ ;; (?C . conflict)
+ ;; (?M . edited)
+ ;; (?P . needs-merge)
+ ;; (?R . removed)
+ ;; (?U . needs-update))))
+ ;; (goto-char (point-min))
+ ;; (while (not (eobp))
+ ;; (if (looking-at "^[ACMPRU?] \\(.*\\)$")
+ ;; (push (list (match-string 1)
+ ;; (cdr (assoc (char-after) translation)))
+ ;; result)
+ ;; (cond
+ ;; ((looking-at "cvs update: warning: \\(.*\\) was lost")
+ ;; ;; Format is:
+ ;; ;; cvs update: warning: FILENAME was lost
+ ;; ;; U FILENAME
+ ;; (push (list (match-string 1) 'missing) result)
+ ;; ;; Skip the "U" line
+ ;; (forward-line 1))
+ ;; ((looking-at "cvs update: New directory `\\(.*\\)' -- ignored")
+ ;; (push (list (match-string 1) 'unregistered) result))))
+ ;; (forward-line 1))
+ ;; (funcall update-function result)))
+ )
+
+;; Based on vc-cvs-dir-state-heuristic from Emacs 22.
+;; FIXME does not mention unregistered files.
+(defun vc-cvs-dir-status-heuristic (dir update-function &optional basedir)
+ "Find the CVS state of all files in DIR, using only local information."
+ (let (file basename status result dirlist)
+ (with-temp-buffer
+ (vc-cvs-get-entries dir)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (if (looking-at "D/\\([^/]*\\)////")
+ (push (expand-file-name (match-string 1) dir) dirlist)
+ ;; CVS-removed files are not taken under VC control.
+ (when (looking-at "/\\([^/]*\\)/[^/-]")
+ (setq basename (match-string 1)
+ file (expand-file-name basename dir)
+ status (or (vc-file-getprop file 'vc-state)
+ (vc-cvs-parse-entry file t)))
+ (unless (eq status 'up-to-date)
+ (push (list (if basedir
+ (file-relative-name file basedir)
+ basename)
+ status) result))))
+ (forward-line 1)))
+ (dolist (subdir dirlist)
+ (setq result (append result
+ (vc-cvs-dir-status-heuristic subdir nil
+ (or basedir dir)))))
+ (if basedir result
+ (funcall update-function result))))
+
+(defun vc-cvs-dir-status (dir update-function)
+ "Create a list of conses (file . state) for DIR."
+ ;; FIXME check all files in DIR instead?
+ (let ((local (vc-stay-local-p dir 'CVS)))
+ (if (and local (not (eq local 'only-file)))
+ (vc-cvs-dir-status-heuristic dir update-function)
+ (vc-cvs-command (current-buffer) 'async dir "-f" "status")
+ ;; Alternative implementation: use the "update" command instead of
+ ;; the "status" command.
+ ;; (vc-cvs-command (current-buffer) 'async
+ ;; (file-relative-name dir)
+ ;; "-f" "-n" "update" "-d" "-P")
+ (vc-exec-after
+ `(vc-cvs-after-dir-status (quote ,update-function))))))
+
+(defun vc-cvs-dir-status-files (dir files default-state update-function)
+ "Create a list of conses (file . state) for DIR."
+ (apply 'vc-cvs-command (current-buffer) 'async dir "-f" "status" files)
+ (vc-exec-after
+ `(vc-cvs-after-dir-status (quote ,update-function))))
+
+(defun vc-cvs-file-to-string (file)
+ "Read the content of FILE and return it as a string."
+ (condition-case nil
+ (with-temp-buffer
+ (insert-file-contents file)
+ (goto-char (point-min))
+ (buffer-substring (point) (point-max)))
+ (file-error nil)))
+
+(defun vc-cvs-dir-extra-headers (dir)
+ "Extract and represent per-directory properties of a CVS working copy."
+ (let ((repo
+ (condition-case nil
+ (with-temp-buffer
+ (insert-file-contents "CVS/Root")
+ (goto-char (point-min))
+ (and (looking-at ":ext:") (delete-char 5))
+ (concat (buffer-substring (point) (1- (point-max))) "\n"))
+ (file-error nil)))
+ (module
+ (condition-case nil
+ (with-temp-buffer
+ (insert-file-contents "CVS/Repository")
+ (goto-char (point-min))
+ (skip-chars-forward "^\n")
+ (concat (buffer-substring (point-min) (point)) "\n"))
+ (file-error nil))))
+ (concat
+ (cond (repo
+ (concat (propertize "Repository : " 'face 'font-lock-type-face)
+ (propertize repo 'face 'font-lock-variable-name-face)))
+ (t ""))
+ (cond (module
+ (concat (propertize "Module : " 'face 'font-lock-type-face)
+ (propertize module 'face 'font-lock-variable-name-face)))
+ (t ""))
+ (if (file-readable-p "CVS/Tag")
+ (let ((tag (vc-cvs-file-to-string "CVS/Tag")))
+ (cond
+ ((string-match "\\`T" tag)
+ (concat (propertize "Tag : " 'face 'font-lock-type-face)
+ (propertize (substring tag 1)
+ 'face 'font-lock-variable-name-face)))
+ ((string-match "\\`D" tag)
+ (concat (propertize "Date : " 'face 'font-lock-type-face)
+ (propertize (substring tag 1)
+ 'face 'font-lock-variable-name-face)))
+ (t ""))))
+
+ ;; In CVS, branch is a per-file property, not a per-directory property.
+ ;; We can't really do this here without making dangerous assumptions.
+ ;;(propertize "Branch: " 'face 'font-lock-type-face)
+ ;;(propertize "ADD CODE TO PRINT THE BRANCH NAME\n"
+ ;; 'face 'font-lock-warning-face)
+ )))
+
+(defun vc-cvs-get-entries (dir)
+ "Insert the CVS/Entries file from below DIR into the current buffer.
+This function ensures that the correct coding system is used for that,
+which may not be the one that is used for the files' contents.
+CVS/Entries should only be accessed through this function."
+ (let ((coding-system-for-read (or file-name-coding-system
+ default-file-name-coding-system)))
+ (vc-insert-file (expand-file-name "CVS/Entries" dir))))
+
+(defun vc-cvs-valid-symbolic-tag-name-p (tag)
+ "Return non-nil if TAG is a valid symbolic tag name."
+ ;; According to the CVS manual, a valid symbolic tag must start with
+ ;; an uppercase or lowercase letter and can contain uppercase and
+ ;; lowercase letters, digits, `-', and `_'.
+ (and (string-match "^[a-zA-Z]" tag)
+ (not (string-match "[^a-z0-9A-Z-_]" tag))))
+
+(defun vc-cvs-valid-revision-number-p (tag)
+ "Return non-nil if TAG is a valid revision number."
+ (and (string-match "^[0-9]" tag)
+ (not (string-match "[^0-9.]" tag))))
+
+(defun vc-cvs-parse-sticky-tag (match-type match-tag)
+ "Parse and return the sticky tag as a string.
+`match-data' is protected."
+ (let ((data (match-data))
+ (tag)
+ (type (cond ((string= match-type "D") 'date)
+ ((string= match-type "T")
+ (if (vc-cvs-valid-symbolic-tag-name-p match-tag)
+ 'symbolic-name
+ 'revision-number))
+ (t nil))))
+ (unwind-protect
+ (progn
+ (cond
+ ;; Sticky Date tag. Convert to a proper date value (`encode-time')
+ ((eq type 'date)
+ (string-match
+ "\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)"
+ match-tag)
+ (let* ((year-tmp (string-to-number (match-string 1 match-tag)))
+ (month (string-to-number (match-string 2 match-tag)))
+ (day (string-to-number (match-string 3 match-tag)))
+ (hour (string-to-number (match-string 4 match-tag)))
+ (min (string-to-number (match-string 5 match-tag)))
+ (sec (string-to-number (match-string 6 match-tag)))
+ ;; Years 0..68 are 2000..2068.
+ ;; Years 69..99 are 1969..1999.
+ (year (+ (cond ((> 69 year-tmp) 2000)
+ ((> 100 year-tmp) 1900)
+ (t 0))
+ year-tmp)))
+ (setq tag (encode-time sec min hour day month year))))
+ ;; Sticky Tag name or revision number
+ ((eq type 'symbolic-name) (setq tag match-tag))
+ ((eq type 'revision-number) (setq tag match-tag))
+ ;; Default is no sticky tag at all
+ (t nil))
+ (cond ((eq vc-cvs-sticky-tag-display nil) nil)
+ ((eq vc-cvs-sticky-tag-display t)
+ (cond ((eq type 'date) (format-time-string
+ vc-cvs-sticky-date-format-string
+ tag))
+ ((eq type 'symbolic-name) tag)
+ ((eq type 'revision-number) tag)
+ (t nil)))
+ ((functionp vc-cvs-sticky-tag-display)
+ (funcall vc-cvs-sticky-tag-display tag type))
+ (t nil)))
+
+ (set-match-data data))))
+
+(defun vc-cvs-parse-entry (file &optional set-state)
+ "Parse a line from CVS/Entries.
+Compare modification time to that of the FILE, set file properties
+accordingly. However, `vc-state' is set only if optional arg SET-STATE
+is non-nil."
+ (cond
+ ;; entry for a "locally added" file (not yet committed)
+ ((looking-at "/[^/]+/0/")
+ (vc-file-setprop file 'vc-checkout-time 0)
+ (vc-file-setprop file 'vc-working-revision "0")
+ (if set-state (vc-file-setprop file 'vc-state 'added)))
+ ;; normal entry
+ ((looking-at
+ (concat "/[^/]+"
+ ;; revision
+ "/\\([^/]*\\)"
+ ;; timestamp and optional conflict field
+ "/\\([^/]*\\)/"
+ ;; options
+ "\\([^/]*\\)/"
+ ;; sticky tag
+ "\\(.\\|\\)" ;Sticky tag type (date or tag name, could be empty)
+ "\\(.*\\)")) ;Sticky tag
+ (vc-file-setprop file 'vc-working-revision (match-string 1))
+ (vc-file-setprop file 'vc-cvs-sticky-tag
+ (vc-cvs-parse-sticky-tag (match-string 4)
+ (match-string 5)))
+ ;; Compare checkout time and modification time.
+ ;; This is intentionally different from the algorithm that CVS uses
+ ;; (which is based on textual comparison), because there can be problems
+ ;; generating a time string that looks exactly like the one from CVS.
+ (let* ((time (match-string 2))
+ (mtime (nth 5 (file-attributes file)))
+ (parsed-time (progn (require 'parse-time)
+ (parse-time-string (concat time " +0000")))))
+ (cond ((and (not (string-match "\\+" time))
+ (car parsed-time)
+ (equal mtime (apply 'encode-time parsed-time)))
+ (vc-file-setprop file 'vc-checkout-time mtime)
+ (if set-state (vc-file-setprop file 'vc-state 'up-to-date)))
+ (t
+ (vc-file-setprop file 'vc-checkout-time 0)
+ (if set-state (vc-file-setprop file 'vc-state 'edited))))))))
+
+;; Completion of revision names.
+;; Just so I don't feel like I'm duplicating code from pcl-cvs, I'll use
+;; `cvs log' so I can list all the revision numbers rather than only
+;; tag names.
+
+(defun vc-cvs-revision-table (file)
+ (let (process-file-side-effects
+ (default-directory (file-name-directory file))
+ (res nil))
+ (with-temp-buffer
+ (vc-cvs-command t nil file "log")
+ (goto-char (point-min))
+ (when (re-search-forward "^symbolic names:\n" nil t)
+ (while (looking-at "^ \\(.*\\): \\(.*\\)")
+ (push (cons (match-string 1) (match-string 2)) res)
+ (forward-line 1)))
+ (while (re-search-forward "^revision \\([0-9.]+\\)" nil t)
+ (push (match-string 1) res))
+ res)))
+
+(defun vc-cvs-revision-completion-table (files)
+ (lexical-let ((files files)
+ table)
+ (setq table (lazy-completion-table
+ table (lambda () (vc-cvs-revision-table (car files)))))
+ table))
+
+
+(provide 'vc-cvs)
+
+;; arch-tag: 60e1402a-aa53-4607-927a-cf74f144b432
+;;; vc-cvs.el ends here
--- /dev/null
- ;; Copyright (C) 2001, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;;; vc-dav.el --- vc.el support for WebDAV
+
++;; Copyright (C) 2001, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+
+;; Author: Bill Perry <wmperry@gnu.org>
+;; Maintainer: Bill Perry <wmperry@gnu.org>
+;; Keywords: url, vc
+;; Package: vc
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+
+;;; Commentary:
+
+;;; Todo:
+;;
+;; - Some methods need to be updated to match the current vc.el.
+;; - rename "version" -> "revision"
+;; - some methods need to take a fileset as a parameter instead of a
+;; single file.
+
+;;; Code:
+
+(require 'url)
+(require 'url-dav)
+
+;;; Required functions for a vc backend
+(defun vc-dav-registered (url)
+ "Return t if URL is registered with a DAV aware server."
+ (url-dav-vc-registered url))
+
+(defun vc-dav-state (url)
+ "Return the current version control state of URL.
+For a list of possible values, see `vc-state'."
+ ;; Things we can support for WebDAV
+ ;;
+ ;; up-to-date - use lockdiscovery
+ ;; edited - check for an active lock by us
+ ;; USER - use lockdiscovery + owner
+ ;;
+ ;; These don't make sense for WebDAV
+ ;; needs-patch
+ ;; needs-merge
+ ;; unlocked-changes
+ (let ((locks (url-dav-active-locks url)))
+ (cond
+ ((null locks) 'up-to-date)
+ ((assoc url locks)
+ ;; SOMEBODY has a lock... let's find out who.
+ (setq locks (cdr (assoc url locks)))
+ (if (rassoc url-dav-lock-identifier locks)
+ ;; _WE_ have a lock
+ 'edited
+ (cdr (car locks)))))))
+
+(defun vc-dav-checkout-model (url)
+ "Indicate whether URL needs to be \"checked out\" before it can be edited.
+See `vc-checkout-model' for a list of possible values."
+ ;; The only thing we can support with webdav is 'locking
+ 'locking)
+
+;; This should figure out the version # of the file somehow. What is
+;; the most appropriate property in WebDAV to look at for this?
+(defun vc-dav-workfile-version (url)
+ "Return the current workfile version of URL."
+ "Unknown")
+
+(defun vc-dav-register (url &optional rev comment)
+ "Register URL in the DAV backend."
+ ;; Do we need to do anything here? FIXME?
+ )
+
+(defun vc-dav-checkin (url rev comment)
+ "Commit changes in URL to WebDAV.
+If REV is non-nil, that should become the new revision number.
+COMMENT is used as a check-in comment."
+ ;; This should PUT the resource and release any locks that we hold.
+ )
+
+(defun vc-dav-checkout (url &optional editable rev destfile)
+ "Check out revision REV of URL into the working area.
+
+If EDITABLE is non-nil URL should be writable by the user and if
+locking is used for URL, a lock should also be set.
+
+If REV is non-nil, that is the revision to check out. If REV is the
+empty string, that means to check ou tht ehead of the trunk.
+
+If optional arg DESTFILE is given, it is an alternate filename to
+write the contents to.
+"
+ ;; This should LOCK the resource.
+ )
+
+(defun vc-dav-revert (url &optional contents-done)
+ "Revert URL back to the current workfile version.
+
+If optional arg CONTENTS-DONE is non-nil, then the contents of FILE
+have already been reverted from a version backup, and this function
+only needs to update the status of URL within the backend.
+"
+ ;; Should do a GET if !contents_done
+ ;; Should UNLOCK the file.
+ )
+
+(defun vc-dav-print-log (url)
+ "Insert the revision log of URL into the *vc* buffer."
+ )
+
+(defun vc-dav-diff (url &optional rev1 rev2)
+ "Insert the diff for URL into the *vc-diff* buffer.
+If REV1 and REV2 are non-nil report differences from REV1 to REV2.
+If REV1 is nil, use the current workfile version as the older version.
+If REV2 is nil, use the current workfile contents as the nwer version.
+
+It should return a status of either 0 (no differences found), or
+1 (either non-empty diff or the diff is run asynchronously).
+"
+ ;; We should do this asynchronously...
+ ;; How would we do it at all, that is the question!
+ )
+
+
+
+;;; Optional functions
+;; Should be faster than vc-dav-state - but how?
+(defun vc-dav-state-heuristic (url)
+ "Estimate the version control state of URL at visiting time."
+ (vc-dav-state url))
+
+;; This should use url-dav-get-properties with a depth of `1' to get
+;; all the properties.
+(defun vc-dav-dir-state (url)
+ "find the version control state of all files in DIR in a fast way."
+ )
+
+(defun vc-dav-workfile-unchanged-p (url)
+ "Return non-nil if URL is unchanged from its current workfile version."
+ ;; Probably impossible with webdav
+ )
+
+(defun vc-dav-responsible-p (url)
+ "Return non-nil if DAV considers itself `responsible' for URL."
+ ;; Check for DAV support on the web server.
+ t)
+
+(defun vc-dav-could-register (url)
+ "Return non-nil if URL could be registered under this backend."
+ ;; Check for DAV support on the web server.
+ t)
+
+;;; Unimplemented functions
+;;
+;; vc-dav-latest-on-branch-p(URL)
+;; Return non-nil if the current workfile version of FILE is the
+;; latest on its branch. There are no branches in webdav yet.
+;;
+;; vc-dav-mode-line-string(url)
+;; Return a dav-specific mode line string for URL. Are there any
+;; specific states that we want exposed?
+;;
+;; vc-dav-dired-state-info(url)
+;; Translate the `vc-state' property of URL into a string that can
+;; be used in a vc-dired buffer. Are there any extra states that
+;; we want exposed?
+;;
+;; vc-dav-receive-file(url rev)
+;; Let this backend `receive' a file that is already registered
+;; under another backend. The default just calls `register', which
+;; should be sufficient for WebDAV.
+;;
+;; vc-dav-unregister(url)
+;; Unregister URL. Not possible with WebDAV, other than by
+;; deleting the resource.
+
+(provide 'vc-dav)
+
+;; arch-tag: 0a0fb9fe-8190-4c0a-a179-5c291d3a467e
+;;; vc-dav.el ends here
--- /dev/null
- ;; Copyright (C) 2007, 2008, 2009, 2010
+;;; vc-dir.el --- Directory status display under VC
+
++;; Copyright (C) 2007, 2008, 2009, 2010, 2011
+;; Free Software Foundation, Inc.
+
+;; Author: Dan Nicolaescu <dann@ics.uci.edu>
+;; Keywords: vc tools
+;; Package: 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 <http://www.gnu.org/licenses/>.
+
+;;; Credits:
+
+;; The original VC directory status implementation was based on dired.
+;; This implementation was inspired by PCL-CVS.
+;; Many people contributed comments, ideas and code to this
+;; implementation. These include:
+;;
+;; Alexandre Julliard <julliard@winehq.org>
+;; Stefan Monnier <monnier@iro.umontreal.ca>
+;; Tom Tromey <tromey@redhat.com>
+
+;;; Commentary:
+;;
+
+;;; Todo: see vc.el.
+
+(require 'vc-hooks)
+(require 'vc)
+(require 'tool-bar)
+(require 'ewoc)
+
+;;; Code:
+(eval-when-compile
+ (require 'cl))
+
+(defcustom vc-dir-mode-hook nil
+ "Normal hook run by `vc-dir-mode'.
+See `run-hooks'."
+ :type 'hook
+ :group 'vc)
+
+;; Used to store information for the files displayed in the directory buffer.
+;; Each item displayed corresponds to one of these defstructs.
+(defstruct (vc-dir-fileinfo
+ (:copier nil)
+ (:type list) ;So we can use `member' on lists of FIs.
+ (:constructor
+ ;; We could define it as an alias for `list'.
+ vc-dir-create-fileinfo (name state &optional extra marked directory))
+ (:conc-name vc-dir-fileinfo->))
+ name ;Keep it as first, for `member'.
+ state
+ ;; For storing backend specific information.
+ extra
+ marked
+ ;; To keep track of not updated files during a global refresh
+ needs-update
+ ;; To distinguish files and directories.
+ directory)
+
+(defvar vc-ewoc nil)
+
+(defvar vc-dir-process-buffer nil
+ "The buffer used for the asynchronous call that computes status.")
+
+(defvar vc-dir-backend nil
+ "The backend used by the current *vc-dir* buffer.")
+
+(defun vc-dir-move-to-goal-column ()
+ ;; Used to keep the cursor on the file name column.
+ (beginning-of-line)
+ (unless (eolp)
+ ;; Must be in sync with vc-default-dir-printer.
+ (forward-char 25)))
+
+(defun vc-dir-prepare-status-buffer (bname dir backend &optional create-new)
+ "Find a buffer named BNAME showing DIR, or create a new one."
+ (setq dir (file-name-as-directory (expand-file-name dir)))
+ (let* ;; Look for another buffer name BNAME visiting the same directory.
+ ((buf (save-excursion
+ (unless create-new
+ (dolist (buffer vc-dir-buffers)
+ (when (buffer-live-p buffer)
+ (set-buffer buffer)
+ (when (and (derived-mode-p 'vc-dir-mode)
+ (eq vc-dir-backend backend)
+ (string= default-directory dir))
+ (return buffer))))))))
+ (or buf
+ ;; Create a new buffer named BNAME.
+ ;; We pass a filename to create-file-buffer because it is what
+ ;; the function expects, and also what uniquify needs (if active)
+ (with-current-buffer (create-file-buffer (expand-file-name bname dir))
+ (cd dir)
+ (vc-setup-buffer (current-buffer))
+ ;; Reset the vc-parent-buffer-name so that it does not appear
+ ;; in the mode-line.
+ (setq vc-parent-buffer-name nil)
+ (current-buffer)))))
+
+(defvar vc-dir-menu-map
+ (let ((map (make-sparse-keymap "VC-dir")))
+ (define-key map [quit]
+ '(menu-item "Quit" quit-window
+ :help "Quit"))
+ (define-key map [kill]
+ '(menu-item "Kill Update Command" vc-dir-kill-dir-status-process
+ :enable (vc-dir-busy)
+ :help "Kill the command that updates the directory buffer"))
+ (define-key map [refresh]
+ '(menu-item "Refresh" revert-buffer
+ :enable (not (vc-dir-busy))
+ :help "Refresh the contents of the directory buffer"))
+ (define-key map [remup]
+ '(menu-item "Hide up-to-date" vc-dir-hide-up-to-date
+ :help "Hide up-to-date items from display"))
+ ;; Movement.
+ (define-key map [sepmv] '("--"))
+ (define-key map [next-line]
+ '(menu-item "Next line" vc-dir-next-line
+ :help "Go to the next line" :keys "n"))
+ (define-key map [previous-line]
+ '(menu-item "Previous line" vc-dir-previous-line
+ :help "Go to the previous line"))
+ ;; Marking.
+ (define-key map [sepmrk] '("--"))
+ (define-key map [unmark-all]
+ '(menu-item "Unmark All" vc-dir-unmark-all-files
+ :help "Unmark all files that are in the same state as the current file\
+\nWith prefix argument unmark all files"))
+ (define-key map [unmark-previous]
+ '(menu-item "Unmark previous " vc-dir-unmark-file-up
+ :help "Move to the previous line and unmark the file"))
+
+ (define-key map [mark-all]
+ '(menu-item "Mark All" vc-dir-mark-all-files
+ :help "Mark all files that are in the same state as the current file\
+\nWith prefix argument mark all files"))
+ (define-key map [unmark]
+ '(menu-item "Unmark" vc-dir-unmark
+ :help "Unmark the current file or all files in the region"))
+
+ (define-key map [mark]
+ '(menu-item "Mark" vc-dir-mark
+ :help "Mark the current file or all files in the region"))
+
+ (define-key map [sepopn] '("--"))
+ (define-key map [qr]
+ '(menu-item "Query Replace in Files..." vc-dir-query-replace-regexp
+ :help "Replace a string in the marked files"))
+ (define-key map [se]
+ '(menu-item "Search Files..." vc-dir-search
+ :help "Search a regexp in the marked files"))
+ (define-key map [ires]
+ '(menu-item "Isearch Regexp Files..." vc-dir-isearch-regexp
+ :help "Incremental search a regexp in the marked files"))
+ (define-key map [ise]
+ '(menu-item "Isearch Files..." vc-dir-isearch
+ :help "Incremental search a string in the marked files"))
+ (define-key map [open-other]
+ '(menu-item "Open in other window" vc-dir-find-file-other-window
+ :help "Find the file on the current line, in another window"))
+ (define-key map [open]
+ '(menu-item "Open file" vc-dir-find-file
+ :help "Find the file on the current line"))
+ (define-key map [sepvcdet] '("--"))
+ ;; FIXME: This needs a key binding. And maybe a better name
+ ;; ("Insert" like PCL-CVS uses does not sound that great either)...
+ (define-key map [ins]
+ '(menu-item "Show File" vc-dir-show-fileentry
+ :help "Show a file in the VC status listing even though it might be up to date"))
+ (define-key map [annotate]
+ '(menu-item "Annotate" vc-annotate
+ :help "Display the edit history of the current file using colors"))
+ (define-key map [diff]
+ '(menu-item "Compare with Base Version" vc-diff
+ :help "Compare file set with the base version"))
+ (define-key map [logo]
+ '(menu-item "Show Outgoing Log" vc-log-outgoing
+ :help "Show a log of changes that will be sent with a push operation"))
+ (define-key map [logi]
+ '(menu-item "Show Incoming Log" vc-log-incoming
+ :help "Show a log of changes that will be received with a pull operation"))
+ (define-key map [log]
+ '(menu-item "Show History" vc-print-log
+ :help "List the change log of the current file set in a window"))
+ (define-key map [rlog]
+ '(menu-item "Show Top of the Tree History " vc-print-root-log
+ :help "List the change log for the current tree in a window"))
+ ;; VC commands.
+ (define-key map [sepvccmd] '("--"))
+ (define-key map [update]
+ '(menu-item "Update to latest version" vc-update
+ :help "Update the current fileset's files to their tip revisions"))
+ (define-key map [revert]
+ '(menu-item "Revert to base version" vc-revert
+ :help "Revert working copies of the selected fileset to their repository contents."))
+ (define-key map [next-action]
+ ;; FIXME: This really really really needs a better name!
+ ;; And a key binding too.
+ '(menu-item "Check In/Out" vc-next-action
+ :help "Do the next logical version control operation on the current fileset"))
+ (define-key map [register]
+ '(menu-item "Register" vc-register
+ :help "Register file set into the version control system"))
+ map)
+ "Menu for VC dir.")
+
+;; VC backends can use this to add mode-specific menu items to
+;; vc-dir-menu-map.
+(defun vc-dir-menu-map-filter (orig-binding)
+ (when (and (symbolp orig-binding) (fboundp orig-binding))
+ (setq orig-binding (indirect-function orig-binding)))
+ (let ((ext-binding
+ (when (derived-mode-p 'vc-dir-mode)
+ (vc-call-backend vc-dir-backend 'extra-status-menu))))
+ (if (null ext-binding)
+ orig-binding
+ (append orig-binding
+ '("----")
+ ext-binding))))
+
+(defvar vc-dir-mode-map
+ (let ((map (make-sparse-keymap)))
+ ;; VC commands
+ (define-key map "v" 'vc-next-action) ;; C-x v v
+ (define-key map "=" 'vc-diff) ;; C-x v =
+ (define-key map "i" 'vc-register) ;; C-x v i
+ (define-key map "+" 'vc-update) ;; C-x v +
+ (define-key map "l" 'vc-print-log) ;; C-x v l
+ ;; More confusing than helpful, probably
+ ;;(define-key map "R" 'vc-revert) ;; u is taken by vc-dir-unmark.
+ ;;(define-key map "A" 'vc-annotate) ;; g is taken by revert-buffer
+ ;; bound by `special-mode'.
+ ;; Marking.
+ (define-key map "m" 'vc-dir-mark)
+ (define-key map "M" 'vc-dir-mark-all-files)
+ (define-key map "u" 'vc-dir-unmark)
+ (define-key map "U" 'vc-dir-unmark-all-files)
+ (define-key map "\C-?" 'vc-dir-unmark-file-up)
+ (define-key map "\M-\C-?" 'vc-dir-unmark-all-files)
+ ;; Movement.
+ (define-key map "n" 'vc-dir-next-line)
+ (define-key map " " 'vc-dir-next-line)
+ (define-key map "\t" 'vc-dir-next-directory)
+ (define-key map "p" 'vc-dir-previous-line)
+ (define-key map [backtab] 'vc-dir-previous-directory)
+ ;;; Rebind paragraph-movement commands.
+ (define-key map "\M-}" 'vc-dir-next-directory)
+ (define-key map "\M-{" 'vc-dir-previous-directory)
+ (define-key map [C-down] 'vc-dir-next-directory)
+ (define-key map [C-up] 'vc-dir-previous-directory)
+ ;; The remainder.
+ (define-key map "f" 'vc-dir-find-file)
+ (define-key map "\C-m" 'vc-dir-find-file)
+ (define-key map "o" 'vc-dir-find-file-other-window)
+ (define-key map "\C-c\C-c" 'vc-dir-kill-dir-status-process)
+ (define-key map [down-mouse-3] 'vc-dir-menu)
+ (define-key map [mouse-2] 'vc-dir-toggle-mark)
+ (define-key map [follow-link] 'mouse-face)
+ (define-key map "x" 'vc-dir-hide-up-to-date)
+ (define-key map [?\C-k] 'vc-dir-kill-line)
+ (define-key map "S" 'vc-dir-search) ;; FIXME: Maybe use A like dired?
+ (define-key map "Q" 'vc-dir-query-replace-regexp)
+ (define-key map (kbd "M-s a C-s") 'vc-dir-isearch)
+ (define-key map (kbd "M-s a M-C-s") 'vc-dir-isearch-regexp)
+
+ ;; Hook up the menu.
+ (define-key map [menu-bar vc-dir-mode]
+ `(menu-item
+ ;; VC backends can use this to add mode-specific menu items to
+ ;; vc-dir-menu-map.
+ "VC-dir" ,vc-dir-menu-map :filter vc-dir-menu-map-filter))
+ map)
+ "Keymap for directory buffer.")
+
+(defmacro vc-dir-at-event (event &rest body)
+ "Evaluate BODY with point located at event-start of EVENT.
+If BODY uses EVENT, it should be a variable,
+ otherwise it will be evaluated twice."
+ (let ((posn (make-symbol "vc-dir-at-event-posn")))
+ `(save-excursion
+ (unless (equal ,event '(tool-bar))
+ (let ((,posn (event-start ,event)))
+ (set-buffer (window-buffer (posn-window ,posn)))
+ (goto-char (posn-point ,posn))))
+ ,@body)))
+
+(defun vc-dir-menu (e)
+ "Popup the VC dir menu."
+ (interactive "e")
+ (vc-dir-at-event e (popup-menu vc-dir-menu-map e)))
+
+(defvar vc-dir-tool-bar-map
+ (let ((map (make-sparse-keymap)))
+ (tool-bar-local-item-from-menu 'find-file "new" map nil
+ :label "New File" :vert-only t)
+ (tool-bar-local-item-from-menu 'menu-find-file-existing "open" map nil
+ :label "Open" :vert-only t)
+ (tool-bar-local-item-from-menu 'dired "diropen" map nil
+ :vert-only t)
+ (tool-bar-local-item-from-menu 'quit-window "close" map vc-dir-mode-map
+ :vert-only t)
+ (tool-bar-local-item-from-menu 'vc-next-action "saveas" map
+ vc-dir-mode-map :label "Commit")
+ (tool-bar-local-item-from-menu 'vc-print-log "info"
+ map vc-dir-mode-map
+ :label "Log")
+ (define-key-after map [separator-1] menu-bar-separator)
+ (tool-bar-local-item-from-menu 'vc-dir-kill-dir-status-process "cancel"
+ map vc-dir-mode-map
+ :label "Stop" :vert-only t)
+ (tool-bar-local-item-from-menu 'revert-buffer "refresh"
+ map vc-dir-mode-map :vert-only t)
+ (define-key-after map [separator-2] menu-bar-separator)
+ (tool-bar-local-item-from-menu (lookup-key menu-bar-edit-menu [cut])
+ "cut" map nil :vert-only t)
+ (tool-bar-local-item-from-menu (lookup-key menu-bar-edit-menu [copy])
+ "copy" map nil :vert-only t)
+ (tool-bar-local-item-from-menu (lookup-key menu-bar-edit-menu [paste])
+ "paste" map nil :vert-only t)
+ (define-key-after map [separator-3] menu-bar-separator)
+ (tool-bar-local-item-from-menu 'isearch-forward
+ "search" map nil
+ :label "Search" :vert-only t)
+ 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
+ (unless noinsert
+ (ewoc-enter-before vc-ewoc node
+ (apply 'vc-dir-create-fileinfo entry)))
+ (setq entries (cdr entries))
+ (setq entry (car entries))))))
+ (t
+ (unless noinsert
+ ;; 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.
+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-query-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* ((complete-state (vc-dir-recompute-file-state file ddir))
+ (state (cadr complete-state)))
+ (vc-dir-update
+ (list complete-state)
+ status-buf (or (not state)
+ (eq state 'up-to-date)))))))))))
+ ;; Remove out-of-date entries from vc-dir-buffers.
+ (dolist (b drop) (setq vc-dir-buffers (delq b vc-dir-buffers)))))
+
+(defvar use-vc-backend) ;; dynamically bound
+
+(define-derived-mode vc-dir-mode special-mode "VC dir"
+ "Major mode for VC directory buffers.
+Marking/Unmarking key bindings and actions:
+m - mark a file/directory
+ - if the region is active, mark all the files in region.
+ Restrictions: - a file cannot be marked if any parent directory is marked
+ - a directory cannot be marked if any child file or
+ directory is marked
+u - unmark a file/directory
+ - if the region is active, unmark all the files in region.
+M - if the cursor is on a file: mark all the files with the same state as
+ the current file
+ - if the cursor is on a directory: mark all child files
+ - with a prefix argument: mark all files
+U - if the cursor is on a file: unmark all the files with the same state
+ as the current file
+ - if the cursor is on a directory: unmark all child files
+ - with a prefix argument: unmark all files
+mouse-2 - toggles the mark state
+
+VC commands
+VC commands in the `C-x v' prefix can be used.
+VC commands act on the marked entries. If nothing is marked, VC
+commands act on the current entry.
+
+Search & Replace
+S - searches the marked files
+Q - does a query replace on the marked files
+M-s a C-s - does an isearch on the marked files
+M-s a C-M-s - does a regexp isearch on the marked files
+If nothing is marked, these commands act on the current entry.
+When a directory is current or marked, the Search & Replace
+commands act on the child files of that directory that are displayed in
+the *vc-dir* buffer.
+
+\\{vc-dir-mode-map}"
+ (set (make-local-variable 'vc-dir-backend) use-vc-backend)
+ (setq buffer-read-only t)
+ (when (boundp 'tool-bar-map)
+ (set (make-local-variable 'tool-bar-map) vc-dir-tool-bar-map))
+ (let ((buffer-read-only nil))
+ (erase-buffer)
+ (set (make-local-variable 'vc-dir-process-buffer) nil)
+ (set (make-local-variable 'vc-ewoc) (ewoc-create #'vc-dir-printer))
+ (set (make-local-variable 'revert-buffer-function)
+ 'vc-dir-revert-buffer-function)
+ (setq list-buffers-directory (expand-file-name "*vc-dir*" default-directory))
+ (add-to-list 'vc-dir-buffers (current-buffer))
+ ;; Make sure that if the directory buffer is killed, the update
+ ;; process running in the background is also killed.
+ (add-hook 'kill-buffer-query-functions 'vc-dir-kill-query nil t)
+ (hack-dir-local-variables-non-file-buffer)
+ (vc-dir-refresh)))
+
+(defun vc-dir-headers (backend dir)
+ "Display the headers in the *VC dir* buffer.
+It calls the `dir-extra-headers' backend method to display backend
+specific headers."
+ (concat
+ ;; First layout the common headers.
+ (propertize "VC backend : " 'face 'font-lock-type-face)
+ (propertize (format "%s\n" backend) 'face 'font-lock-variable-name-face)
+ (propertize "Working dir: " 'face 'font-lock-type-face)
+ (propertize (format "%s\n" (abbreviate-file-name dir))
+ 'face 'font-lock-variable-name-face)
+ ;; Then the backend specific ones.
+ (vc-call-backend backend 'dir-extra-headers dir)
+ "\n"))
+
+(defun vc-dir-refresh-files (files default-state)
+ "Refresh some files in the *VC-dir* buffer."
+ (let ((def-dir default-directory)
+ (backend vc-dir-backend))
+ (vc-set-mode-line-busy-indicator)
+ ;; Call the `dir-status-file' backend function.
+ ;; `dir-status-file' is supposed to be asynchronous.
+ ;; It should compute the results, and then call the function
+ ;; passed as an argument in order to update the vc-dir buffer
+ ;; with the results.
+ (unless (buffer-live-p vc-dir-process-buffer)
+ (setq vc-dir-process-buffer
+ (generate-new-buffer (format " *VC-%s* tmp status" backend))))
+ (lexical-let ((buffer (current-buffer)))
+ (with-current-buffer vc-dir-process-buffer
+ (cd def-dir)
+ (erase-buffer)
+ (vc-call-backend
+ backend 'dir-status-files def-dir files default-state
+ (lambda (entries &optional more-to-come)
+ ;; ENTRIES is a list of (FILE VC_STATE EXTRA) items.
+ ;; If MORE-TO-COME is true, then more updates will come from
+ ;; the asynchronous process.
+ (with-current-buffer buffer
+ (vc-dir-update entries buffer)
+ (unless more-to-come
+ (setq mode-line-process nil)
+ ;; Remove the ones that haven't been updated at all.
+ ;; Those not-updated are those whose state is nil because the
+ ;; file/dir doesn't exist and isn't versioned.
+ (ewoc-filter vc-ewoc
+ (lambda (info)
+ ;; The state for directory entries might
+ ;; have been changed to 'up-to-date,
+ ;; reset it, othewise it will be removed when doing 'x'
+ ;; next time.
+ ;; FIXME: There should be a more elegant way to do this.
+ (when (and (vc-dir-fileinfo->directory info)
+ (eq (vc-dir-fileinfo->state info)
+ 'up-to-date))
+ (setf (vc-dir-fileinfo->state info) nil))
+
+ (not (vc-dir-fileinfo->needs-update info))))))))))))
+
+(defun vc-dir-revert-buffer-function (&optional ignore-auto noconfirm)
+ (vc-dir-refresh))
+
+(defun vc-dir-refresh ()
+ "Refresh the contents of the *VC-dir* buffer.
+Throw an error if another update process is in progress."
+ (interactive)
+ (if (vc-dir-busy)
+ (error "Another update process is in progress, cannot run two at a time")
+ (let ((def-dir default-directory)
+ (backend vc-dir-backend))
+ (vc-set-mode-line-busy-indicator)
+ ;; Call the `dir-status' backend function.
+ ;; `dir-status' is supposed to be asynchronous.
+ ;; It should compute the results, and then call the function
+ ;; passed as an argument in order to update the vc-dir buffer
+ ;; with the results.
+
+ ;; Create a buffer that can be used by `dir-status' and call
+ ;; `dir-status' with this buffer as the current buffer. Use
+ ;; `vc-dir-process-buffer' to remember this buffer, so that
+ ;; it can be used later to kill the update process in case it
+ ;; takes too long.
+ (unless (buffer-live-p vc-dir-process-buffer)
+ (setq vc-dir-process-buffer
+ (generate-new-buffer (format " *VC-%s* tmp status" backend))))
+ ;; set the needs-update flag on all non-directory entries
+ (ewoc-map (lambda (info)
+ (unless (vc-dir-fileinfo->directory info)
+ (setf (vc-dir-fileinfo->needs-update info) t) nil))
+ vc-ewoc)
+ (lexical-let ((buffer (current-buffer)))
+ (with-current-buffer vc-dir-process-buffer
+ (cd def-dir)
+ (erase-buffer)
+ (vc-call-backend
+ backend 'dir-status def-dir
+ (lambda (entries &optional more-to-come)
+ ;; ENTRIES is a list of (FILE VC_STATE EXTRA) items.
+ ;; If MORE-TO-COME is true, then more updates will come from
+ ;; the asynchronous process.
+ (with-current-buffer buffer
+ (vc-dir-update entries buffer)
+ (unless more-to-come
+ (let ((remaining
+ (ewoc-collect
+ vc-ewoc 'vc-dir-fileinfo->needs-update)))
+ (if remaining
+ (vc-dir-refresh-files
+ (mapcar 'vc-dir-fileinfo->name remaining)
+ 'up-to-date)
+ (setq mode-line-process nil)))))))))
+ (ewoc-set-hf vc-ewoc (vc-dir-headers backend def-dir) ""))))
+
+(defun vc-dir-show-fileentry (file)
+ "Insert an entry for a specific file into the current *VC-dir* listing.
+This is typically used if the file is up-to-date (or has been added
+outside of VC) and one wants to do some operation on it."
+ (interactive "fShow file: ")
+ (vc-dir-update (list (list (file-relative-name file) (vc-state file))) (current-buffer)))
+
+(defun vc-dir-hide-up-to-date ()
+ "Hide up-to-date items from display."
+ (interactive)
+ (let ((crt (ewoc-nth vc-ewoc -1))
+ (first (ewoc-nth vc-ewoc 0)))
+ ;; Go over from the last item to the first and remove the
+ ;; up-to-date files and directories with no child files.
+ (while (not (eq crt first))
+ (let* ((data (ewoc-data crt))
+ (dir (vc-dir-fileinfo->directory data))
+ (next (ewoc-next vc-ewoc crt))
+ (prev (ewoc-prev vc-ewoc crt))
+ ;; ewoc-delete does not work without this...
+ (inhibit-read-only t))
+ (when (or
+ ;; Remove directories with no child files.
+ (and dir
+ (or
+ ;; Nothing follows this directory.
+ (not next)
+ ;; Next item is a directory.
+ (vc-dir-fileinfo->directory (ewoc-data next))))
+ ;; Remove files in the up-to-date state.
+ (eq (vc-dir-fileinfo->state data) 'up-to-date))
+ (ewoc-delete vc-ewoc crt))
+ (setq crt prev)))))
+
+(defun vc-dir-kill-line ()
+ "Remove the current line from display."
+ (interactive)
+ (let ((crt (ewoc-locate vc-ewoc))
+ (inhibit-read-only t))
+ (ewoc-delete vc-ewoc crt)))
+
+(defun vc-dir-printer (fileentry)
+ (vc-call-backend vc-dir-backend 'dir-printer fileentry))
+
+(defun vc-dir-deduce-fileset (&optional state-model-only-files)
+ (let ((marked (vc-dir-marked-files))
+ files
+ only-files-list
+ state
+ model)
+ (if marked
+ (progn
+ (setq files marked)
+ (when state-model-only-files
+ (setq only-files-list (vc-dir-marked-only-files-and-states))))
+ (let ((crt (vc-dir-current-file)))
+ (setq files (list crt))
+ (when state-model-only-files
+ (setq only-files-list (vc-dir-child-files-and-states)))))
+
+ (when state-model-only-files
+ (setq state (cdar only-files-list))
+ ;; Check that all files are in a consistent state, since we use that
+ ;; state to decide which operation to perform.
+ (dolist (crt (cdr only-files-list))
+ (unless (vc-compatible-state (cdr crt) state)
+ (error "When applying VC operations to multiple files, the files are required\nto be in similar VC states.\n%s in state %s clashes with %s in state %s"
+ (car crt) (cdr crt) (caar only-files-list) state)))
+ (setq only-files-list (mapcar 'car only-files-list))
+ (when (and state (not (eq state 'unregistered)))
+ (setq model (vc-checkout-model vc-dir-backend only-files-list))))
+ (list vc-dir-backend files only-files-list state model)))
+
+;;;###autoload
+(defun vc-dir (dir &optional backend)
+ "Show the VC status for \"interesting\" files in and below DIR.
+This allows you to mark files and perform VC operations on them.
+The list omits files which are up to date, with no changes in your copy
+or the repository, if there is nothing in particular to say about them.
+
+Preparing the list of file status takes time; when the buffer
+first appears, it has only the first few lines of summary information.
+The file lines appear later.
+
+Optional second argument BACKEND specifies the VC backend to use.
+Interactively, a prefix argument means to ask for the backend.
+
+These are the commands available for use in the file status buffer:
+
+\\{vc-dir-mode-map}"
+
+ (interactive
+ (list
+ ;; When you hit C-x v d in a visited VC file,
+ ;; the *vc-dir* buffer visits the directory under its truename;
+ ;; therefore it makes sense to always do that.
+ ;; Otherwise if you do C-x v d -> C-x C-f -> C-c v d
+ ;; you may get a new *vc-dir* buffer, different from the original
+ (file-truename (read-file-name "VC status for directory: "
+ default-directory default-directory t
+ nil #'file-directory-p))
+ (if current-prefix-arg
+ (intern
+ (completing-read
+ "Use VC backend: "
+ (mapcar (lambda (b) (list (symbol-name b)))
+ vc-handled-backends)
+ nil t nil nil)))))
+ (unless backend
+ (setq backend (vc-responsible-backend dir)))
+ (let (pop-up-windows) ; based on cvs-examine; bug#6204
+ (pop-to-buffer (vc-dir-prepare-status-buffer "*vc-dir*" dir backend)))
+ (if (derived-mode-p 'vc-dir-mode)
+ (vc-dir-refresh)
+ ;; FIXME: find a better way to pass the backend to `vc-dir-mode'.
+ (let ((use-vc-backend backend))
+ (vc-dir-mode))))
+
+(defun vc-default-dir-extra-headers (backend dir)
+ ;; Be loud by default to remind people to add code to display
+ ;; backend specific headers.
+ ;; XXX: change this to return nil before the release.
+ (concat
+ (propertize "Extra : " 'face 'font-lock-type-face)
+ (propertize "Please add backend specific headers here. It's easy!"
+ 'face 'font-lock-warning-face)))
+
+(defvar vc-dir-filename-mouse-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [mouse-2] 'vc-dir-find-file-other-window)
+ map)
+ "Local keymap for visiting a file.")
+
+(defun vc-default-dir-printer (backend fileentry)
+ "Pretty print FILEENTRY."
+ ;; If you change the layout here, change vc-dir-move-to-goal-column.
+ ;; VC backends can implement backend specific versions of this
+ ;; function. Changes here might need to be reflected in the
+ ;; vc-BACKEND-dir-printer functions.
+ (let* ((isdir (vc-dir-fileinfo->directory fileentry))
+ (state (if isdir "" (vc-dir-fileinfo->state fileentry)))
+ (filename (vc-dir-fileinfo->name fileentry)))
+ (insert
+ (propertize
+ (format "%c" (if (vc-dir-fileinfo->marked fileentry) ?* ? ))
+ 'face 'font-lock-type-face)
+ " "
+ (propertize
+ (format "%-20s" state)
+ 'face (cond ((eq state 'up-to-date) 'font-lock-builtin-face)
+ ((memq state '(missing conflict)) 'font-lock-warning-face)
+ (t 'font-lock-variable-name-face))
+ 'mouse-face 'highlight)
+ " "
+ (propertize
+ (format "%s" filename)
+ 'face
+ (if isdir 'font-lock-comment-delimiter-face 'font-lock-function-name-face)
+ 'help-echo
+ (if isdir
+ "Directory\nVC operations can be applied to it\nmouse-3: Pop-up menu"
+ "File\nmouse-3: Pop-up menu")
+ 'mouse-face 'highlight
+ 'keymap vc-dir-filename-mouse-map))))
+
+(defun vc-default-extra-status-menu (backend)
+ nil)
+
+(defun vc-default-status-fileinfo-extra (backend file)
+ "Default absence of extra information returned for a file."
+ nil)
+
+(provide 'vc-dir)
+
+;; arch-tag: 0274a2e3-e8e9-4b1a-a73c-e8b9129d5d15
+;;; vc-dir.el ends here
--- /dev/null
- ;; Copyright (C) 2008, 2009, 2010
+;;; vc-dispatcher.el -- generic command-dispatcher facility.
+
++;; Copyright (C) 2008, 2009, 2010, 2011
+;; Free Software Foundation, Inc.
+
+;; Author: FSF (see below for full credits)
+;; Maintainer: Eric S. Raymond <esr@thyrsus.com>
+;; Keywords: vc tools
+;; Package: 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 <http://www.gnu.org/licenses/>.
+
+;;; Credits:
+
+;; Designed and implemented by Eric S. Raymond, originally as part of VC mode.
+;; Stefan Monnier and Dan Nicolaescu contributed substantial work on the
+;; vc-dir front end.
+
+;;; Commentary:
+
+;; Goals:
+;;
+;; There is a class of front-ending problems that Emacs might be used
+;; to address that involves selecting sets of files, or possibly
+;; directories, and passing the selection set to slave commands. The
+;; prototypical example, from which this code is derived, is talking
+;; to version-control systems.
+;;
+;; vc-dispatcher.el is written to decouple the UI issues in such front
+;; ends from their application-specific logic. It also provides a
+;; service layer for running the slave commands either synchronously
+;; or asynchronously and managing the message/error logs from the
+;; command runs.
+;;
+;; Similar UI problems can be expected to come up in applications
+;; areas other than VCSes; IDEs and document search are two obvious ones.
+;; This mode is intended to ensure that the Emacs interfaces for all such
+;; beasts are consistent and carefully designed. But even if nothing
+;; but VC ever uses it, getting the layer separation right will be
+;; a valuable thing.
+
+;; Dispatcher's universe:
+;;
+;; The universe consists of the file tree rooted at the current
+;; directory. The dispatcher's upper layer deduces some subset
+;; of the file tree from the state of the currently visited buffer
+;; and returns that subset, presumably to a client mode.
+;;
+;; The user may be looking at either of two different views; a buffer
+;; visiting a file, or a directory buffer generated by vc-dispatcher.
+;;
+;; The lower layer of this mode runs commands in subprocesses, either
+;; synchronously or asynchronously. Commands may be launched in one
+;; of two ways: they may be run immediately, or the calling mode can
+;; create a closure associated with a text-entry buffer, to be
+;; executed when the user types C-c to ship the buffer contents. In
+;; either case the command messages and error (if any) will remain
+;; available in a status buffer.
+
+;; Special behavior of dispatcher directory buffers:
+;;
+;; In dispatcher directory buffers, facilities to perform basic
+;; navigation and selection operations are provided by keymap and menu
+;; entries that dispatcher sets up itself, so they'll be uniform
+;; across all dispatcher-using client modes. Client modes are
+;; expected to append to these to provide mode-specific bindings.
+;;
+;; The standard map associates a 'state' slot (that the client mode
+;; may set) with each directory entry. The dispatcher knows nothing
+;; about the semantics of individual states, but mark and unmark commands
+;; treat all entries with the same state as the currently selected one as
+;; a unit.
+
+;; The interface:
+;;
+;; The main interface to the lower level is vc-do-command. This launches a
+;; command, synchronously or asynchronously, making the output available
+;; in a command log buffer. Two other functions, (vc-start-logentry) and
+;; (vc-finish-logentry), allow you to associate a command closure with an
+;; annotation buffer so that when the user confirms the comment the closure
+;; is run (with the comment as part of its context).
+;;
+;; The interface to the upper level has the two main entry points (vc-dir)
+;; and (vc-dispatcher-selection-set) and a couple of convenience functions.
+;; (vc-dir) sets up a dispatcher browsing buffer; (vc-dispatcher-selection-set)
+;; returns a selection set of files, either the marked files in a browsing
+;; buffer or the singleton set consisting of the file visited by the current
+;; buffer (when that is appropriate). It also does what is needed to ensure
+;; that on-disk files and the contents of their visiting Emacs buffers
+;; coincide.
+;;
+;; When the client mode adds a local vc-mode-line-hook to a buffer, it
+;; will be called with the buffer file name as argument whenever the
+;; dispatcher resynchs the buffer.
+
+;; To do:
+;;
+;; - log buffers need font-locking.
+;;
+
+;; General customization
+(defcustom vc-logentry-check-hook nil
+ "Normal hook run by `vc-finish-logentry'.
+Use this to impose your own rules on the entry in addition to any the
+dispatcher client mode imposes itself."
+ :type 'hook
+ :group 'vc)
+
+(defcustom vc-delete-logbuf-window t
+ "If non-nil, delete the log buffer and window after each logical action.
+If nil, bury that buffer instead.
+This is most useful if you have multiple windows on a frame and would like to
+preserve the setting."
+ :type 'boolean
+ :group 'vc)
+
+(defcustom vc-command-messages nil
+ "If non-nil, display run messages from back-end commands."
+ :type 'boolean
+ :group 'vc)
+
+(defcustom vc-suppress-confirm nil
+ "If non-nil, treat user as expert; suppress yes-no prompts on some things."
+ :type 'boolean
+ :group 'vc)
+
+;; Variables the user doesn't need to know about.
+
+(defvar vc-log-operation nil)
+(defvar vc-log-after-operation-hook nil)
+(defvar vc-log-fileset)
+
+;; In a log entry buffer, this is a local variable
+;; that points to the buffer for which it was made
+;; (either a file, or a directory buffer).
+(defvar vc-parent-buffer nil)
+(put 'vc-parent-buffer 'permanent-local t)
+(defvar vc-parent-buffer-name nil)
+(put 'vc-parent-buffer-name 'permanent-local t)
+
+;; Common command execution logic
+
+(defun vc-process-filter (p s)
+ "An alternative output filter for async process P.
+One difference with the default filter is that this inserts S after markers.
+Another is that undo information is not kept."
+ (let ((buffer (process-buffer p)))
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (save-excursion
+ (let ((buffer-undo-list t)
+ (inhibit-read-only t))
+ (goto-char (process-mark p))
+ (insert s)
+ (set-marker (process-mark p) (point))))))))
+
+(defun vc-setup-buffer (buf)
+ "Prepare BUF for executing a slave command and make it current."
+ (let ((camefrom (current-buffer))
+ (olddir default-directory))
+ (set-buffer (get-buffer-create buf))
+ (kill-all-local-variables)
+ (set (make-local-variable 'vc-parent-buffer) camefrom)
+ (set (make-local-variable 'vc-parent-buffer-name)
+ (concat " from " (buffer-name camefrom)))
+ (setq default-directory olddir)
+ (let ((buffer-undo-list t)
+ (inhibit-read-only t))
+ (erase-buffer))))
+
+(defvar vc-sentinel-movepoint) ;Dynamically scoped.
+
+(defun vc-process-sentinel (p s)
+ (let ((previous (process-get p 'vc-previous-sentinel))
+ (buf (process-buffer p)))
+ ;; Impatient users sometime kill "slow" buffers; check liveness
+ ;; to avoid "error in process sentinel: Selecting deleted buffer".
+ (when (buffer-live-p buf)
+ (when previous (funcall previous p s))
+ (with-current-buffer buf
+ (setq mode-line-process
+ (let ((status (process-status p)))
+ ;; Leave mode-line uncluttered, normally.
+ (unless (eq 'exit status)
+ (format " (%s)" status))))
+ (let (vc-sentinel-movepoint)
+ ;; Normally, we want async code such as sentinels to not move point.
+ (save-excursion
+ (goto-char (process-mark p))
+ (let ((cmds (process-get p 'vc-sentinel-commands)))
+ (process-put p 'vc-sentinel-commands nil)
+ (dolist (cmd cmds)
+ ;; Each sentinel may move point and the next one should be run
+ ;; at that new point. We could get the same result by having
+ ;; each sentinel read&set process-mark, but since `cmd' needs
+ ;; to work both for async and sync processes, this would be
+ ;; difficult to achieve.
+ (vc-exec-after cmd))))
+ ;; But sometimes the sentinels really want to move point.
+ (when vc-sentinel-movepoint
+ (let ((win (get-buffer-window (current-buffer) 0)))
+ (if (not win)
+ (goto-char vc-sentinel-movepoint)
+ (with-selected-window win
+ (goto-char vc-sentinel-movepoint))))))))))
+
+(defun vc-set-mode-line-busy-indicator ()
+ (setq mode-line-process
+ (concat " " (propertize "[waiting...]"
+ 'face 'mode-line-emphasis
+ 'help-echo
+ "A command is in progress in this buffer"))))
+
+(defun vc-exec-after (code)
+ "Eval CODE when the current buffer's process is done.
+If the current buffer has no process, just evaluate CODE.
+Else, add CODE to the process' sentinel."
+ (let ((proc (get-buffer-process (current-buffer))))
+ (cond
+ ;; If there's no background process, just execute the code.
+ ;; We used to explicitly call delete-process on exited processes,
+ ;; but this led to timing problems causing process output to be
+ ;; lost. Terminated processes get deleted automatically
+ ;; anyway. -- cyd
+ ((or (null proc) (eq (process-status proc) 'exit))
+ ;; Make sure we've read the process's output before going further.
+ (when proc (accept-process-output proc))
+ (eval code))
+ ;; If a process is running, add CODE to the sentinel
+ ((eq (process-status proc) 'run)
+ (vc-set-mode-line-busy-indicator)
+ (let ((previous (process-sentinel proc)))
+ (unless (eq previous 'vc-process-sentinel)
+ (process-put proc 'vc-previous-sentinel previous))
+ (set-process-sentinel proc 'vc-process-sentinel))
+ (process-put proc 'vc-sentinel-commands
+ ;; We keep the code fragments in the order given
+ ;; so that vc-diff-finish's message shows up in
+ ;; the presence of non-nil vc-command-messages.
+ (append (process-get proc 'vc-sentinel-commands)
+ (list code))))
+ (t (error "Unexpected process state"))))
+ nil)
+
+(defvar vc-post-command-functions nil
+ "Hook run at the end of `vc-do-command'.
+Each function is called inside the buffer in which the command was run
+and is passed 3 arguments: the COMMAND, the FILES and the FLAGS.")
+
+(defvar w32-quote-process-args)
+
+(defun vc-delistify (filelist)
+ "Smash a FILELIST into a file list string suitable for info messages."
+ ;; FIXME what about file names with spaces?
+ (if (not filelist) "." (mapconcat 'identity filelist " ")))
+
+;;;###autoload
+(defun vc-do-command (buffer okstatus command file-or-list &rest flags)
+ "Execute a slave command, notifying user and checking for errors.
+Output from COMMAND goes to BUFFER, or the current buffer if
+BUFFER is t. If the destination buffer is not already current,
+set it up properly and erase it. The command is considered
+successful if its exit status does not exceed OKSTATUS (if
+OKSTATUS is nil, that means to ignore error status, if it is
+`async', that means not to wait for termination of the
+subprocess; if it is t it means to ignore all execution errors).
+FILE-OR-LIST is the name of a working file; it may be a list of
+files or be nil (to execute commands that don't expect a file
+name or set of files). If an optional list of FLAGS is present,
+that is inserted into the command line before the filename.
+Return the return value of the slave command in the synchronous
+case, and the process object in the asynchronous case."
+ ;; FIXME: file-relative-name can return a bogus result because
+ ;; it doesn't look at the actual file-system to see if symlinks
+ ;; come into play.
+ (let* ((files
+ (mapcar (lambda (f) (file-relative-name (expand-file-name f)))
+ (if (listp file-or-list) file-or-list (list file-or-list))))
+ (full-command
+ ;; What we're doing here is preparing a version of the command
+ ;; for display in a debug-progress message. If it's fewer than
+ ;; 20 characters display the entire command (without trailing
+ ;; newline). Otherwise display the first 20 followed by an ellipsis.
+ (concat (if (string= (substring command -1) "\n")
+ (substring command 0 -1)
+ command)
+ " "
+ (vc-delistify (mapcar (lambda (s) (if (> (length s) 20) (concat (substring s 0 2) "...") s)) flags))
+ " " (vc-delistify files))))
+ (save-current-buffer
+ (unless (or (eq buffer t)
+ (and (stringp buffer)
+ (string= (buffer-name) buffer))
+ (eq buffer (current-buffer)))
+ (vc-setup-buffer buffer))
+ ;; If there's some previous async process still running, just kill it.
+ (let ((oldproc (get-buffer-process (current-buffer))))
+ ;; If we wanted to wait for oldproc to finish before doing
+ ;; something, we'd have used vc-eval-after.
+ ;; Use `delete-process' rather than `kill-process' because we don't
+ ;; want any of its output to appear from now on.
+ (when oldproc (delete-process oldproc)))
+ (let ((squeezed (remq nil flags))
+ (inhibit-read-only t)
+ (status 0))
+ (when files
+ (setq squeezed (nconc squeezed files)))
+ (let (;; Since some functions need to parse the output
+ ;; from external commands, set LC_MESSAGES to C.
+ (process-environment (cons "LC_MESSAGES=C" process-environment))
+ (w32-quote-process-args t))
+ (if (eq okstatus 'async)
+ ;; Run asynchronously.
+ (let ((proc
+ (let ((process-connection-type nil))
+ (apply 'start-file-process command (current-buffer)
+ command squeezed))))
+ (when vc-command-messages
+ (message "Running %s in background..." full-command))
+ ;;(set-process-sentinel proc (lambda (p msg) (delete-process p)))
+ (set-process-filter proc 'vc-process-filter)
+ (setq status proc)
+ (when vc-command-messages
+ (vc-exec-after
+ `(message "Running %s in background... done" ',full-command))))
+ ;; Run synchronously
+ (when vc-command-messages
+ (message "Running %s in foreground..." full-command))
+ (let ((buffer-undo-list t))
+ (setq status (apply 'process-file command nil t nil squeezed)))
+ (when (and (not (eq t okstatus))
+ (or (not (integerp status))
+ (and okstatus (< okstatus status))))
+ (unless (eq ?\s (aref (buffer-name (current-buffer)) 0))
+ (pop-to-buffer (current-buffer))
+ (goto-char (point-min))
+ (shrink-window-if-larger-than-buffer))
+ (error "Running %s...FAILED (%s)" full-command
+ (if (integerp status) (format "status %d" status) status)))
+ (when vc-command-messages
+ (message "Running %s...OK = %d" full-command status))))
+ (vc-exec-after
+ `(run-hook-with-args 'vc-post-command-functions
+ ',command ',file-or-list ',flags))
+ status))))
+
+;; These functions are used to ensure that the view the user sees is up to date
+;; even if the dispatcher client mode has messed with file contents (as in,
+;; for example, VCS keyword expansion).
+
+(declare-function view-mode-exit "view" (&optional return-to-alist exit-action all-win))
+
+(defun vc-position-context (posn)
+ "Save a bit of the text around POSN in the current buffer.
+Used to help us find the corresponding position again later
+if markers are destroyed or corrupted."
+ ;; A lot of this was shamelessly lifted from Sebastian Kremer's
+ ;; rcs.el mode.
+ (list posn
+ (buffer-size)
+ (buffer-substring posn
+ (min (point-max) (+ posn 100)))))
+
+(defun vc-find-position-by-context (context)
+ "Return the position of CONTEXT in the current buffer.
+If CONTEXT cannot be found, return nil."
+ (let ((context-string (nth 2 context)))
+ (if (equal "" context-string)
+ (point-max)
+ (save-excursion
+ (let ((diff (- (nth 1 context) (buffer-size))))
+ (when (< diff 0) (setq diff (- diff)))
+ (goto-char (nth 0 context))
+ (if (or (search-forward context-string nil t)
+ ;; Can't use search-backward since the match may continue
+ ;; after point.
+ (progn (goto-char (- (point) diff (length context-string)))
+ ;; goto-char doesn't signal an error at
+ ;; beginning of buffer like backward-char would
+ (search-forward context-string nil t)))
+ ;; to beginning of OSTRING
+ (- (point) (length context-string))))))))
+
+(defun vc-context-matches-p (posn context)
+ "Return t if POSN matches CONTEXT, nil otherwise."
+ (let* ((context-string (nth 2 context))
+ (len (length context-string))
+ (end (+ posn len)))
+ (if (> end (1+ (buffer-size)))
+ nil
+ (string= context-string (buffer-substring posn end)))))
+
+(defun vc-buffer-context ()
+ "Return a list (POINT-CONTEXT MARK-CONTEXT REPARSE).
+Used by `vc-restore-buffer-context' to later restore the context."
+ (let ((point-context (vc-position-context (point)))
+ ;; Use mark-marker to avoid confusion in transient-mark-mode.
+ (mark-context (when (eq (marker-buffer (mark-marker)) (current-buffer))
+ (vc-position-context (mark-marker))))
+ ;; Make the right thing happen in transient-mark-mode.
+ (mark-active nil))
+ (list point-context mark-context nil)))
+
+(defun vc-restore-buffer-context (context)
+ "Restore point/mark, and reparse any affected compilation buffers.
+CONTEXT is that which `vc-buffer-context' returns."
+ (let ((point-context (nth 0 context))
+ (mark-context (nth 1 context)))
+ ;; if necessary, restore point and mark
+ (if (not (vc-context-matches-p (point) point-context))
+ (let ((new-point (vc-find-position-by-context point-context)))
+ (when new-point (goto-char new-point))))
+ (and mark-active
+ mark-context
+ (not (vc-context-matches-p (mark) mark-context))
+ (let ((new-mark (vc-find-position-by-context mark-context)))
+ (when new-mark (set-mark new-mark))))))
+
+(defun vc-revert-buffer-internal (&optional arg no-confirm)
+ "Revert buffer, keeping point and mark where user expects them.
+Try to be clever in the face of changes due to expanded version-control
+key words. This is important for typeahead to work as expected.
+ARG and NO-CONFIRM are passed on to `revert-buffer'."
+ (interactive "P")
+ (widen)
+ (let ((context (vc-buffer-context)))
+ ;; Use save-excursion here, because it may be able to restore point
+ ;; and mark properly even in cases where vc-restore-buffer-context
+ ;; would fail. However, save-excursion might also get it wrong --
+ ;; in this case, vc-restore-buffer-context gives it a second try.
+ (save-excursion
+ ;; t means don't call normal-mode;
+ ;; that's to preserve various minor modes.
+ (revert-buffer arg no-confirm t))
+ (vc-restore-buffer-context context)))
+
+(defvar vc-mode-line-hook nil)
+(make-variable-buffer-local 'vc-mode-line-hook)
+(put 'vc-mode-line-hook 'permanent-local t)
+
+(defun vc-resynch-window (file &optional keep noquery reset-vc-info)
+ "If FILE is in the current buffer, either revert or unvisit it.
+The choice between revert (to see expanded keywords) and unvisit
+depends on KEEP. NOQUERY if non-nil inhibits confirmation for
+reverting. NOQUERY should be t *only* if it is known the only
+difference between the buffer and the file is due to
+modifications by the dispatcher client code, rather than user
+editing!"
+ (and (string= buffer-file-name file)
+ (if keep
+ (when (file-exists-p file)
+ (when reset-vc-info
+ (vc-file-clearprops file))
+ (vc-revert-buffer-internal t noquery)
+
+ ;; VC operations might toggle the read-only state. In
+ ;; that case we need to adjust the `view-mode' status
+ ;; when `view-read-only' is non-nil.
+ (and view-read-only
+ (if (file-writable-p file)
+ (and view-mode
+ (let ((view-old-buffer-read-only nil))
+ (view-mode-exit)))
+ (and (not view-mode)
+ (not (eq (get major-mode 'mode-class) 'special))
+ (view-mode-enter))))
+
+ ;; FIXME: Why use a hook? Why pass it buffer-file-name?
+ (run-hook-with-args 'vc-mode-line-hook buffer-file-name))
+ (kill-buffer (current-buffer)))))
+
+(declare-function vc-dir-resynch-file "vc-dir" (&optional fname))
+(declare-function vc-string-prefix-p "vc" (prefix string))
+
+(defun vc-resynch-buffers-in-directory (directory &optional keep noquery reset-vc-info)
+ "Resync all buffers that visit files in DIRECTORY."
+ (dolist (buffer (buffer-list))
+ (let ((fname (buffer-file-name buffer)))
+ (when (and fname (vc-string-prefix-p directory fname))
+ (with-current-buffer buffer
+ (vc-resynch-buffer fname keep noquery reset-vc-info))))))
+
+(defun vc-resynch-buffer (file &optional keep noquery reset-vc-info)
+ "If FILE is currently visited, resynch its buffer."
+ (if (string= buffer-file-name file)
+ (vc-resynch-window file keep noquery reset-vc-info)
+ (if (file-directory-p file)
+ (vc-resynch-buffers-in-directory file keep noquery reset-vc-info)
+ (let ((buffer (get-file-buffer file)))
+ (when buffer
+ (with-current-buffer buffer
+ (vc-resynch-window file keep noquery reset-vc-info))))))
+ ;; Try to avoid unnecessary work, a *vc-dir* buffer is only present
+ ;; if this is true.
+ (when vc-dir-buffers
+ (vc-dir-resynch-file file)))
+
+(defun vc-buffer-sync (&optional not-urgent)
+ "Make sure the current buffer and its working file are in sync.
+NOT-URGENT means it is ok to continue if the user says not to save."
+ (when (buffer-modified-p)
+ (if (or vc-suppress-confirm
+ (y-or-n-p (format "Buffer %s modified; save it? " (buffer-name))))
+ (save-buffer)
+ (unless not-urgent
+ (error "Aborted")))))
+
+;; Command closures
+
+;; Set up key bindings for use while editing log messages
+
+(defun vc-log-edit (fileset mode)
+ "Set up `log-edit' for use on FILE."
+ (setq default-directory
+ (with-current-buffer vc-parent-buffer default-directory))
+ (log-edit 'vc-finish-logentry
+ nil
+ `((log-edit-listfun . (lambda ()
+ ;; FIXME: Should expand the list
+ ;; for directories.
+ (mapcar 'file-relative-name
+ ',fileset)))
+ (log-edit-diff-function . (lambda () (vc-diff nil))))
+ nil
+ mode)
+ (set (make-local-variable 'vc-log-fileset) fileset)
+ (set-buffer-modified-p nil)
+ (setq buffer-file-name nil))
+
+(defun vc-start-logentry (files comment initial-contents msg logbuf mode action &optional after-hook)
+ "Accept a comment for an operation on FILES.
+If COMMENT is nil, pop up a LOGBUF buffer, emit MSG, and set the
+action on close to ACTION. If COMMENT is a string and
+INITIAL-CONTENTS is non-nil, then COMMENT is used as the initial
+contents of the log entry buffer. If COMMENT is a string and
+INITIAL-CONTENTS is nil, do action immediately as if the user had
+entered COMMENT. If COMMENT is t, also do action immediately with an
+empty comment. Remember the file's buffer in `vc-parent-buffer'
+\(current one if no file). Puts the log-entry buffer in major-mode
+MODE, defaulting to `log-edit-mode' if MODE is nil.
+AFTER-HOOK specifies the local value for `vc-log-after-operation-hook'."
+ (let ((parent
+ (if (vc-dispatcher-browsing)
+ ;; If we are called from a directory browser, the parent buffer is
+ ;; the current buffer.
+ (current-buffer)
+ (if (and files (equal (length files) 1))
+ (get-file-buffer (car files))
+ (current-buffer)))))
+ (if (and comment (not initial-contents))
+ (set-buffer (get-buffer-create logbuf))
+ (pop-to-buffer (get-buffer-create logbuf)))
+ (set (make-local-variable 'vc-parent-buffer) parent)
+ (set (make-local-variable 'vc-parent-buffer-name)
+ (concat " from " (buffer-name vc-parent-buffer)))
+ (vc-log-edit files mode)
+ (make-local-variable 'vc-log-after-operation-hook)
+ (when after-hook
+ (setq vc-log-after-operation-hook after-hook))
+ (setq vc-log-operation action)
+ (when comment
+ (erase-buffer)
+ (when (stringp comment) (insert comment)))
+ (if (or (not comment) initial-contents)
+ (message "%s Type C-c C-c when done" msg)
+ (vc-finish-logentry (eq comment t)))))
+
+(declare-function vc-dir-move-to-goal-column "vc-dir" ())
+;; vc-finish-logentry is typically called from a log-edit buffer (see
+;; vc-start-logentry).
+(defun vc-finish-logentry (&optional nocomment)
+ "Complete the operation implied by the current log entry.
+Use the contents of the current buffer as a check-in or registration
+comment. If the optional arg NOCOMMENT is non-nil, then don't check
+the buffer contents as a comment."
+ (interactive)
+ ;; Check and record the comment, if any.
+ (unless nocomment
+ (run-hooks 'vc-logentry-check-hook))
+ ;; Sync parent buffer in case the user modified it while editing the comment.
+ ;; But not if it is a vc-dir buffer.
+ (with-current-buffer vc-parent-buffer
+ (or (vc-dispatcher-browsing) (vc-buffer-sync)))
+ (unless vc-log-operation
+ (error "No log operation is pending"))
+
+ ;; save the parameters held in buffer-local variables
+ (let ((logbuf (current-buffer))
+ (log-operation vc-log-operation)
+ ;; FIXME: When coming from VC-Dir, we should check that the
+ ;; set of selected files is still equal to vc-log-fileset,
+ ;; to avoid surprises.
+ (log-fileset vc-log-fileset)
+ (log-entry (buffer-string))
+ (after-hook vc-log-after-operation-hook))
+ (pop-to-buffer vc-parent-buffer)
+ ;; OK, do it to it
+ (save-excursion
+ (funcall log-operation
+ log-fileset
+ log-entry))
+ ;; Remove checkin window (after the checkin so that if that fails
+ ;; we don't zap the log buffer and the typing therein).
+ ;; -- IMO this should be replaced with quit-window
+ (cond ((and logbuf vc-delete-logbuf-window)
+ (delete-windows-on logbuf (selected-frame))
+ ;; Kill buffer and delete any other dedicated windows/frames.
+ (kill-buffer logbuf))
+ (logbuf
+ (with-selected-window (or (get-buffer-window logbuf 0)
+ (selected-window))
+ (with-current-buffer logbuf
+ (bury-buffer)))))
+ ;; Now make sure we see the expanded headers
+ (when log-fileset
+ (mapc
+ (lambda (file) (vc-resynch-buffer file vc-keep-workfiles t))
+ log-fileset))
+ (when (vc-dispatcher-browsing)
+ (vc-dir-move-to-goal-column))
+ (run-hooks after-hook 'vc-finish-logentry-hook)))
+
+(defun vc-dispatcher-browsing ()
+ "Are we in a directory browser buffer?"
+ (derived-mode-p 'vc-dir-mode))
+
+;; These are unused.
+;; (defun vc-dispatcher-in-fileset-p (fileset)
+;; (let ((member nil))
+;; (while (and (not member) fileset)
+;; (let ((elem (pop fileset)))
+;; (if (if (file-directory-p elem)
+;; (eq t (compare-strings buffer-file-name nil (length elem)
+;; elem nil nil))
+;; (eq (current-buffer) (get-file-buffer elem)))
+;; (setq member t))))
+;; member))
+
+;; (defun vc-dispatcher-selection-set (&optional observer)
+;; "Deduce a set of files to which to apply an operation. Return a cons
+;; cell (SELECTION . FILESET), where SELECTION is what the user chose
+;; and FILES is the flist with any directories replaced by the listed files
+;; within them.
+
+;; If we're in a directory display, the fileset is the list of marked files (if
+;; there is one) else the file on the current line. If not in a directory
+;; display, but the current buffer visits a file, the fileset is a singleton
+;; containing that file. Otherwise, throw an error."
+;; (let ((selection
+;; (cond
+;; ;; Browsing with vc-dir
+;; ((vc-dispatcher-browsing)
+;; ;; If no files are marked, temporarily mark current file
+;; ;; and choose on that basis (so we get subordinate files)
+;; (if (not (vc-dir-marked-files))
+;; (prog2
+;; (vc-dir-mark-file)
+;; (cons (vc-dir-marked-files) (vc-dir-marked-only-files))
+;; (vc-dir-unmark-all-files t))
+;; (cons (vc-dir-marked-files) (vc-dir-marked-only-files))))
+;; ;; Visiting an eligible file
+;; ((buffer-file-name)
+;; (cons (list buffer-file-name) (list buffer-file-name)))
+;; ;; No eligible file -- if there's a parent buffer, deduce from there
+;; ((and vc-parent-buffer (or (buffer-file-name vc-parent-buffer)
+;; (with-current-buffer vc-parent-buffer
+;; (vc-dispatcher-browsing))))
+;; (with-current-buffer vc-parent-buffer
+;; (vc-dispatcher-selection-set)))
+;; ;; No good set here, throw error
+;; (t (error "No fileset is available here")))))
+;; ;; We assume, in order to avoid unpleasant surprises to the user,
+;; ;; that a fileset is not in good shape to be handed to the user if the
+;; ;; buffers visiting the fileset don't match the on-disk contents.
+;; (unless observer
+;; (save-some-buffers
+;; nil (lambda () (vc-dispatcher-in-fileset-p (cdr selection)))))
+;; selection))
+
+(provide 'vc-dispatcher)
+
+;; arch-tag: 7d08b17f-5470-4799-914b-bfb9fcf6a246
+;;; vc-dispatcher.el ends here
--- /dev/null
- ;; Copyright (C) 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;;; vc-git.el --- VC backend for the git version control system
+
++;; Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+
+;; Author: Alexandre Julliard <julliard@winehq.org>
+;; Keywords: vc tools
+;; Package: 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 <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file contains a VC backend for the git version control
+;; system.
+;;
+
+;;; Installation:
+
+;; To install: put this file on the load-path and add Git to the list
+;; of supported backends in `vc-handled-backends'; the following line,
+;; placed in your ~/.emacs, will accomplish this:
+;;
+;; (add-to-list 'vc-handled-backends 'Git)
+
+;;; Todo:
+;; - check if more functions could use vc-git-command instead
+;; of start-process.
+;; - changelog generation
+
+;; Implement the rest of the vc interface. See the comment at the
+;; beginning of vc.el. The current status is:
+;; ("??" means: "figure out what to do about it")
+;;
+;; FUNCTION NAME STATUS
+;; BACKEND PROPERTIES
+;; * revision-granularity OK
+;; STATE-QUERYING FUNCTIONS
+;; * registered (file) OK
+;; * state (file) OK
+;; - state-heuristic (file) NOT NEEDED
+;; * working-revision (file) OK
+;; - latest-on-branch-p (file) NOT NEEDED
+;; * checkout-model (files) OK
+;; - workfile-unchanged-p (file) OK
+;; - mode-line-string (file) OK
+;; STATE-CHANGING FUNCTIONS
+;; * create-repo () OK
+;; * register (files &optional rev comment) OK
+;; - init-revision (file) NOT NEEDED
+;; - responsible-p (file) OK
+;; - could-register (file) NOT NEEDED, DEFAULT IS GOOD
+;; - receive-file (file rev) NOT NEEDED
+;; - unregister (file) OK
+;; * checkin (files rev comment) OK
+;; * find-revision (file rev buffer) OK
+;; * checkout (file &optional editable rev) OK
+;; * revert (file &optional contents-done) OK
+;; - rollback (files) COULD BE SUPPORTED
+;; - merge (file rev1 rev2) It would be possible to merge
+;; changes into a single file, but
+;; when committing they wouldn't
+;; be identified as a merge
+;; by git, so it's probably
+;; not a good idea.
+;; - merge-news (file) see `merge'
+;; - steal-lock (file &optional revision) NOT NEEDED
+;; HISTORY FUNCTIONS
+;; * print-log (files buffer &optional shortlog start-revision limit) OK
+;; - log-view-mode () OK
+;; - show-log-entry (revision) OK
+;; - comment-history (file) ??
+;; - update-changelog (files) COULD BE SUPPORTED
+;; * diff (file &optional rev1 rev2 buffer) OK
+;; - revision-completion-table (files) OK
+;; - annotate-command (file buf &optional rev) OK
+;; - annotate-time () OK
+;; - annotate-current-time () NOT NEEDED
+;; - annotate-extract-revision-at-line () OK
+;; TAG SYSTEM
+;; - create-tag (dir name branchp) OK
+;; - retrieve-tag (dir name update) OK
+;; MISCELLANEOUS
+;; - make-version-backups-p (file) NOT NEEDED
+;; - repository-hostname (dirname) NOT NEEDED
+;; - previous-revision (file rev) OK
+;; - next-revision (file rev) OK
+;; - check-headers () COULD BE SUPPORTED
+;; - clear-headers () NOT NEEDED
+;; - delete-file (file) OK
+;; - rename-file (old new) OK
+;; - find-file-hook () NOT NEEDED
+
+(eval-when-compile
+ (require 'cl)
+ (require 'vc)
+ (require 'vc-dir)
+ (require 'grep))
+
+(defcustom vc-git-diff-switches t
+ "String or list of strings specifying switches for Git diff under VC.
+If nil, use the value of `vc-diff-switches'. If t, use no switches."
+ :type '(choice (const :tag "Unspecified" nil)
+ (const :tag "None" t)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List" :value ("") string))
+ :version "23.1"
+ :group 'vc)
+
+(defvar vc-git-commits-coding-system 'utf-8
+ "Default coding system for git commits.")
+
+;;; BACKEND PROPERTIES
+
+(defun vc-git-revision-granularity () 'repository)
+(defun vc-git-checkout-model (files) 'implicit)
+
+;;; STATE-QUERYING FUNCTIONS
+
+;;;###autoload (defun vc-git-registered (file)
+;;;###autoload "Return non-nil if FILE is registered with git."
+;;;###autoload (if (vc-find-root file ".git") ; Short cut.
+;;;###autoload (progn
+;;;###autoload (load "vc-git")
+;;;###autoload (vc-git-registered file))))
+
+(defun vc-git-registered (file)
+ "Check whether FILE is registered with git."
+ (let ((dir (vc-git-root file)))
+ (when dir
+ (with-temp-buffer
+ (let* (process-file-side-effects
+ ;; Do not use the `file-name-directory' here: git-ls-files
+ ;; sometimes fails to return the correct status for relative
+ ;; path specs.
+ ;; See also: http://marc.info/?l=git&m=125787684318129&w=2
+ (name (file-relative-name file dir))
+ (str (ignore-errors
+ (cd dir)
+ (vc-git--out-ok "ls-files" "-c" "-z" "--" name)
+ ;; If result is empty, use ls-tree to check for deleted
+ ;; file.
+ (when (eq (point-min) (point-max))
+ (vc-git--out-ok "ls-tree" "--name-only" "-z" "HEAD"
+ "--" name))
+ (buffer-string))))
+ (and str
+ (> (length str) (length name))
+ (string= (substring str 0 (1+ (length name)))
+ (concat name "\0"))))))))
+
+(defun vc-git--state-code (code)
+ "Convert from a string to a added/deleted/modified state."
+ (case (string-to-char code)
+ (?M 'edited)
+ (?A 'added)
+ (?D 'removed)
+ (?U 'edited) ;; FIXME
+ (?T 'edited))) ;; FIXME
+
+(defun vc-git-state (file)
+ "Git-specific version of `vc-state'."
+ ;; FIXME: This can't set 'ignored or 'conflict yet
+ ;; The 'ignored state could be detected with `git ls-files -i -o
+ ;; --exclude-standard` It also can't set 'needs-update or
+ ;; 'needs-merge. The rough equivalent would be that upstream branch
+ ;; for current branch is in fast-forward state i.e. current branch
+ ;; is direct ancestor of corresponding upstream branch, and the file
+ ;; was modified upstream. But we can't check that without a network
+ ;; operation.
+ (if (not (vc-git-registered file))
+ 'unregistered
+ (vc-git--call nil "add" "--refresh" "--" (file-relative-name file))
+ (let ((diff (vc-git--run-command-string
+ file "diff-index" "-z" "HEAD" "--")))
+ (if (and diff (string-match ":[0-7]\\{6\\} [0-7]\\{6\\} [0-9a-f]\\{40\\} [0-9a-f]\\{40\\} \\([ADMUT]\\)\0[^\0]+\0"
+ diff))
+ (vc-git--state-code (match-string 1 diff))
+ (if (vc-git--empty-db-p) 'added 'up-to-date)))))
+
+(defun vc-git-working-revision (file)
+ "Git-specific version of `vc-working-revision'."
+ (let* (process-file-side-effects
+ (str (with-output-to-string
+ (with-current-buffer standard-output
+ (vc-git--out-ok "symbolic-ref" "HEAD")))))
+ (if (string-match "^\\(refs/heads/\\)?\\(.+\\)$" str)
+ (match-string 2 str)
+ str)))
+
+(defun vc-git-workfile-unchanged-p (file)
+ (eq 'up-to-date (vc-git-state file)))
+
+(defun vc-git-mode-line-string (file)
+ "Return string for placement into the modeline for FILE."
+ (let* ((branch (vc-git-working-revision file))
+ (def-ml (vc-default-mode-line-string 'Git file))
+ (help-echo (get-text-property 0 'help-echo def-ml)))
+ (if (zerop (length branch))
+ (propertize
+ (concat def-ml "!")
+ 'help-echo (concat help-echo "\nNo current branch (detached HEAD)"))
+ (propertize def-ml
+ 'help-echo (concat help-echo "\nCurrent branch: " branch)))))
+
+(defstruct (vc-git-extra-fileinfo
+ (:copier nil)
+ (:constructor vc-git-create-extra-fileinfo
+ (old-perm new-perm &optional rename-state orig-name))
+ (:conc-name vc-git-extra-fileinfo->))
+ old-perm new-perm ;; Permission flags.
+ rename-state ;; Rename or copy state.
+ orig-name) ;; Original name for renames or copies.
+
+(defun vc-git-escape-file-name (name)
+ "Escape a file name if necessary."
+ (if (string-match "[\n\t\"\\]" name)
+ (concat "\""
+ (mapconcat (lambda (c)
+ (case c
+ (?\n "\\n")
+ (?\t "\\t")
+ (?\\ "\\\\")
+ (?\" "\\\"")
+ (t (char-to-string c))))
+ name "")
+ "\"")
+ name))
+
+(defun vc-git-file-type-as-string (old-perm new-perm)
+ "Return a string describing the file type based on its permissions."
+ (let* ((old-type (lsh (or old-perm 0) -9))
+ (new-type (lsh (or new-perm 0) -9))
+ (str (case new-type
+ (?\100 ;; File.
+ (case old-type
+ (?\100 nil)
+ (?\120 " (type change symlink -> file)")
+ (?\160 " (type change subproject -> file)")))
+ (?\120 ;; Symlink.
+ (case old-type
+ (?\100 " (type change file -> symlink)")
+ (?\160 " (type change subproject -> symlink)")
+ (t " (symlink)")))
+ (?\160 ;; Subproject.
+ (case old-type
+ (?\100 " (type change file -> subproject)")
+ (?\120 " (type change symlink -> subproject)")
+ (t " (subproject)")))
+ (?\110 nil) ;; Directory (internal, not a real git state).
+ (?\000 ;; Deleted or unknown.
+ (case old-type
+ (?\120 " (symlink)")
+ (?\160 " (subproject)")))
+ (t (format " (unknown type %o)" new-type)))))
+ (cond (str (propertize str 'face 'font-lock-comment-face))
+ ((eq new-type ?\110) "/")
+ (t ""))))
+
+(defun vc-git-rename-as-string (state extra)
+ "Return a string describing the copy or rename associated with INFO,
+or an empty string if none."
+ (let ((rename-state (when extra
+ (vc-git-extra-fileinfo->rename-state extra))))
+ (if rename-state
+ (propertize
+ (concat " ("
+ (if (eq rename-state 'copy) "copied from "
+ (if (eq state 'added) "renamed from "
+ "renamed to "))
+ (vc-git-escape-file-name
+ (vc-git-extra-fileinfo->orig-name extra))
+ ")")
+ 'face 'font-lock-comment-face)
+ "")))
+
+(defun vc-git-permissions-as-string (old-perm new-perm)
+ "Format a permission change as string."
+ (propertize
+ (if (or (not old-perm)
+ (not new-perm)
+ (eq 0 (logand ?\111 (logxor old-perm new-perm))))
+ " "
+ (if (eq 0 (logand ?\111 old-perm)) "+x" "-x"))
+ 'face 'font-lock-type-face))
+
+(defun vc-git-dir-printer (info)
+ "Pretty-printer for the vc-dir-fileinfo structure."
+ (let* ((isdir (vc-dir-fileinfo->directory info))
+ (state (if isdir "" (vc-dir-fileinfo->state info)))
+ (extra (vc-dir-fileinfo->extra info))
+ (old-perm (when extra (vc-git-extra-fileinfo->old-perm extra)))
+ (new-perm (when extra (vc-git-extra-fileinfo->new-perm extra))))
+ (insert
+ " "
+ (propertize (format "%c" (if (vc-dir-fileinfo->marked info) ?* ? ))
+ 'face 'font-lock-type-face)
+ " "
+ (propertize
+ (format "%-12s" state)
+ 'face (cond ((eq state 'up-to-date) 'font-lock-builtin-face)
+ ((eq state 'missing) 'font-lock-warning-face)
+ (t 'font-lock-variable-name-face))
+ 'mouse-face 'highlight)
+ " " (vc-git-permissions-as-string old-perm new-perm)
+ " "
+ (propertize (vc-git-escape-file-name (vc-dir-fileinfo->name info))
+ 'face (if isdir 'font-lock-comment-delimiter-face
+ 'font-lock-function-name-face)
+ 'help-echo
+ (if isdir
+ "Directory\nVC operations can be applied to it\nmouse-3: Pop-up menu"
+ "File\nmouse-3: Pop-up menu")
+ 'keymap vc-dir-filename-mouse-map
+ 'mouse-face 'highlight)
+ (vc-git-file-type-as-string old-perm new-perm)
+ (vc-git-rename-as-string state extra))))
+
+(defun vc-git-after-dir-status-stage (stage files update-function)
+ "Process sentinel for the various dir-status stages."
+ (let (next-stage result)
+ (goto-char (point-min))
+ (case stage
+ (update-index
+ (setq next-stage (if (vc-git--empty-db-p) 'ls-files-added
+ (if files 'ls-files-up-to-date 'diff-index))))
+ (ls-files-added
+ (setq next-stage 'ls-files-unknown)
+ (while (re-search-forward "\\([0-7]\\{6\\}\\) [0-9a-f]\\{40\\} 0\t\\([^\0]+\\)\0" nil t)
+ (let ((new-perm (string-to-number (match-string 1) 8))
+ (name (match-string 2)))
+ (push (list name 'added (vc-git-create-extra-fileinfo 0 new-perm))
+ result))))
+ (ls-files-up-to-date
+ (setq next-stage 'diff-index)
+ (while (re-search-forward "\\([0-7]\\{6\\}\\) [0-9a-f]\\{40\\} 0\t\\([^\0]+\\)\0" nil t)
+ (let ((perm (string-to-number (match-string 1) 8))
+ (name (match-string 2)))
+ (push (list name 'up-to-date
+ (vc-git-create-extra-fileinfo perm perm))
+ result))))
+ (ls-files-unknown
+ (when files (setq next-stage 'ls-files-ignored))
+ (while (re-search-forward "\\([^\0]*?\\)\0" nil t 1)
+ (push (list (match-string 1) 'unregistered
+ (vc-git-create-extra-fileinfo 0 0))
+ result)))
+ (ls-files-ignored
+ (while (re-search-forward "\\([^\0]*?\\)\0" nil t 1)
+ (push (list (match-string 1) 'ignored
+ (vc-git-create-extra-fileinfo 0 0))
+ result)))
+ (diff-index
+ (setq next-stage 'ls-files-unknown)
+ (while (re-search-forward
+ ":\\([0-7]\\{6\\}\\) \\([0-7]\\{6\\}\\) [0-9a-f]\\{40\\} [0-9a-f]\\{40\\} \\(\\([ADMUT]\\)\0\\([^\0]+\\)\\|\\([CR]\\)[0-9]*\0\\([^\0]+\\)\0\\([^\0]+\\)\\)\0"
+ nil t 1)
+ (let ((old-perm (string-to-number (match-string 1) 8))
+ (new-perm (string-to-number (match-string 2) 8))
+ (state (or (match-string 4) (match-string 6)))
+ (name (or (match-string 5) (match-string 7)))
+ (new-name (match-string 8)))
+ (if new-name ; Copy or rename.
+ (if (eq ?C (string-to-char state))
+ (push (list new-name 'added
+ (vc-git-create-extra-fileinfo old-perm new-perm
+ 'copy name))
+ result)
+ (push (list name 'removed
+ (vc-git-create-extra-fileinfo 0 0
+ 'rename new-name))
+ result)
+ (push (list new-name 'added
+ (vc-git-create-extra-fileinfo old-perm new-perm
+ 'rename name))
+ result))
+ (push (list name (vc-git--state-code state)
+ (vc-git-create-extra-fileinfo old-perm new-perm))
+ result))))))
+ (when result
+ (setq result (nreverse result))
+ (when files
+ (dolist (entry result) (setq files (delete (car entry) files)))
+ (unless files (setq next-stage nil))))
+ (when (or result (not next-stage))
+ (funcall update-function result next-stage))
+ (when next-stage
+ (vc-git-dir-status-goto-stage next-stage files update-function))))
+
+(defun vc-git-dir-status-goto-stage (stage files update-function)
+ (erase-buffer)
+ (case stage
+ (update-index
+ (if files
+ (vc-git-command (current-buffer) 'async files "add" "--refresh" "--")
+ (vc-git-command (current-buffer) 'async nil
+ "update-index" "--refresh")))
+ (ls-files-added
+ (vc-git-command (current-buffer) 'async files
+ "ls-files" "-z" "-c" "-s" "--"))
+ (ls-files-up-to-date
+ (vc-git-command (current-buffer) 'async files
+ "ls-files" "-z" "-c" "-s" "--"))
+ (ls-files-unknown
+ (vc-git-command (current-buffer) 'async files
+ "ls-files" "-z" "-o" "--directory"
+ "--no-empty-directory" "--exclude-standard" "--"))
+ (ls-files-ignored
+ (vc-git-command (current-buffer) 'async files
+ "ls-files" "-z" "-o" "-i" "--directory"
+ "--no-empty-directory" "--exclude-standard" "--"))
+ ;; --relative added in Git 1.5.5.
+ (diff-index
+ (vc-git-command (current-buffer) 'async files
+ "diff-index" "--relative" "-z" "-M" "HEAD" "--")))
+ (vc-exec-after
+ `(vc-git-after-dir-status-stage ',stage ',files ',update-function)))
+
+(defun vc-git-dir-status (dir update-function)
+ "Return a list of (FILE STATE EXTRA) entries for DIR."
+ ;; Further things that would have to be fixed later:
+ ;; - how to handle unregistered directories
+ ;; - how to support vc-dir on a subdir of the project tree
+ (vc-git-dir-status-goto-stage 'update-index nil update-function))
+
+(defun vc-git-dir-status-files (dir files default-state update-function)
+ "Return a list of (FILE STATE EXTRA) entries for FILES in DIR."
+ (vc-git-dir-status-goto-stage 'update-index files update-function))
+
+(defvar vc-git-stash-map
+ (let ((map (make-sparse-keymap)))
+ ;; Turn off vc-dir marking
+ (define-key map [mouse-2] 'ignore)
+
+ (define-key map [down-mouse-3] 'vc-git-stash-menu)
+ (define-key map "\C-k" 'vc-git-stash-delete-at-point)
+ (define-key map "=" 'vc-git-stash-show-at-point)
+ (define-key map "\C-m" 'vc-git-stash-show-at-point)
+ (define-key map "A" 'vc-git-stash-apply-at-point)
+ (define-key map "P" 'vc-git-stash-pop-at-point)
+ (define-key map "S" 'vc-git-stash-snapshot)
+ map))
+
+(defvar vc-git-stash-menu-map
+ (let ((map (make-sparse-keymap "Git Stash")))
+ (define-key map [de]
+ '(menu-item "Delete stash" vc-git-stash-delete-at-point
+ :help "Delete the current stash"))
+ (define-key map [ap]
+ '(menu-item "Apply stash" vc-git-stash-apply-at-point
+ :help "Apply the current stash and keep it in the stash list"))
+ (define-key map [po]
+ '(menu-item "Apply and remove stash (pop)" vc-git-stash-pop-at-point
+ :help "Apply the current stash and remove it"))
+ (define-key map [sh]
+ '(menu-item "Show stash" vc-git-stash-show-at-point
+ :help "Show the contents of the current stash"))
+ map))
+
+(defun vc-git-dir-extra-headers (dir)
+ (let ((str (with-output-to-string
+ (with-current-buffer standard-output
+ (vc-git--out-ok "symbolic-ref" "HEAD"))))
+ (stash (vc-git-stash-list))
+ (stash-help-echo "Use M-x vc-git-stash to create stashes.")
+ branch remote remote-url)
+ (if (string-match "^\\(refs/heads/\\)?\\(.+\\)$" str)
+ (progn
+ (setq branch (match-string 2 str))
+ (setq remote
+ (with-output-to-string
+ (with-current-buffer standard-output
+ (vc-git--out-ok "config"
+ (concat "branch." branch ".remote")))))
+ (when (string-match "\\([^\n]+\\)" remote)
+ (setq remote (match-string 1 remote)))
+ (when remote
+ (setq remote-url
+ (with-output-to-string
+ (with-current-buffer standard-output
+ (vc-git--out-ok "config"
+ (concat "remote." remote ".url"))))))
+ (when (string-match "\\([^\n]+\\)" remote-url)
+ (setq remote-url (match-string 1 remote-url))))
+ (setq branch "not (detached HEAD)"))
+ ;; FIXME: maybe use a different face when nothing is stashed.
+ (concat
+ (propertize "Branch : " 'face 'font-lock-type-face)
+ (propertize branch
+ 'face 'font-lock-variable-name-face)
+ (when remote
+ (concat
+ "\n"
+ (propertize "Remote : " 'face 'font-lock-type-face)
+ (propertize remote-url
+ 'face 'font-lock-variable-name-face)))
+ "\n"
+ (if stash
+ (concat
+ (propertize "Stash :\n" 'face 'font-lock-type-face
+ 'help-echo stash-help-echo)
+ (mapconcat
+ (lambda (x)
+ (propertize x
+ 'face 'font-lock-variable-name-face
+ 'mouse-face 'highlight
+ 'help-echo "mouse-3: Show stash menu\nRET: Show stash\nA: Apply stash\nP: Apply and remove stash (pop)\nC-k: Delete stash"
+ 'keymap vc-git-stash-map))
+ stash "\n"))
+ (concat
+ (propertize "Stash : " 'face 'font-lock-type-face
+ 'help-echo stash-help-echo)
+ (propertize "Nothing stashed"
+ 'help-echo stash-help-echo
+ 'face 'font-lock-variable-name-face))))))
+
+;;; STATE-CHANGING FUNCTIONS
+
+(defun vc-git-create-repo ()
+ "Create a new Git repository."
+ (vc-git-command nil 0 nil "init"))
+
+(defun vc-git-register (files &optional rev comment)
+ "Register FILES into the git version-control system."
+ (let (flist dlist)
+ (dolist (crt files)
+ (if (file-directory-p crt)
+ (push crt dlist)
+ (push crt flist)))
+ (when flist
+ (vc-git-command nil 0 flist "update-index" "--add" "--"))
+ (when dlist
+ (vc-git-command nil 0 dlist "add"))))
+
+(defalias 'vc-git-responsible-p 'vc-git-root)
+
+(defun vc-git-unregister (file)
+ (vc-git-command nil 0 file "rm" "-f" "--cached" "--"))
+
+(declare-function log-edit-extract-headers "log-edit" (headers string))
+
+(defun vc-git-checkin (files rev comment)
+ (let ((coding-system-for-write vc-git-commits-coding-system))
+ (apply 'vc-git-command nil 0 files
+ (nconc (list "commit" "-m")
+ (log-edit-extract-headers '(("Author" . "--author")
+ ("Date" . "--date"))
+ comment)
+ (list "--only" "--")))))
+
+(defun vc-git-find-revision (file rev buffer)
+ (let* (process-file-side-effects
+ (coding-system-for-read 'binary)
+ (coding-system-for-write 'binary)
+ (fullname
+ (let ((fn (vc-git--run-command-string
+ file "ls-files" "-z" "--full-name" "--")))
+ ;; ls-files does not return anything when looking for a
+ ;; revision of a file that has been renamed or removed.
+ (if (string= fn "")
+ (file-relative-name file (vc-git-root default-directory))
+ (substring fn 0 -1)))))
+ (vc-git-command
+ buffer 0
+ nil
+ "cat-file" "blob" (concat (if rev rev "HEAD") ":" fullname))))
+
+(defun vc-git-checkout (file &optional editable rev)
+ (vc-git-command nil 0 file "checkout" (or rev "HEAD")))
+
+(defun vc-git-revert (file &optional contents-done)
+ "Revert FILE to the version stored in the git repository."
+ (if contents-done
+ (vc-git-command nil 0 file "update-index" "--")
+ (vc-git-command nil 0 file "reset" "-q" "--")
+ (vc-git-command nil nil file "checkout" "-q" "--")))
+
+;;; HISTORY FUNCTIONS
+
+(defun vc-git-print-log (files buffer &optional shortlog start-revision limit)
+ "Get change log associated with FILES.
+Note that using SHORTLOG requires at least Git version 1.5.6,
+for the --graph option."
+ (let ((coding-system-for-read vc-git-commits-coding-system))
+ ;; `vc-do-command' creates the buffer, but we need it before running
+ ;; the command.
+ (vc-setup-buffer buffer)
+ ;; If the buffer exists from a previous invocation it might be
+ ;; read-only.
+ (let ((inhibit-read-only t))
+ (with-current-buffer
+ buffer
+ (apply 'vc-git-command buffer
+ 'async files
+ (append
+ '("log" "--no-color")
+ (when shortlog
+ '("--graph" "--decorate" "--date=short"
+ "--pretty=tformat:%d%h %ad %s" "--abbrev-commit"))
+ (when limit (list "-n" (format "%s" limit)))
+ (when start-revision (list start-revision))
+ '("--")))))))
+
+(defun vc-git-log-outgoing (buffer remote-location)
+ (interactive)
+ (vc-git-command
+ buffer 0 nil
+ "log"
+ "--no-color" "--graph" "--decorate" "--date=short"
+ "--pretty=tformat:%d%h %ad %s" "--abbrev-commit"
+ (concat (if (string= remote-location "")
+ "@{upstream}"
+ remote-location)
+ "..HEAD")))
+
+(defun vc-git-log-incoming (buffer remote-location)
+ (interactive)
+ (vc-git-command nil 0 nil "fetch")
+ (vc-git-command
+ buffer 0 nil
+ "log"
+ "--no-color" "--graph" "--decorate" "--date=short"
+ "--pretty=tformat:%d%h %ad %s" "--abbrev-commit"
+ (concat "HEAD.." (if (string= remote-location "")
+ "@{upstream}"
+ remote-location))))
+
+(defvar log-view-message-re)
+(defvar log-view-file-re)
+(defvar log-view-font-lock-keywords)
+(defvar log-view-per-file-logs)
+
+(define-derived-mode vc-git-log-view-mode log-view-mode "Git-Log-View"
+ (require 'add-log) ;; We need the faces add-log.
+ ;; Don't have file markers, so use impossible regexp.
+ (set (make-local-variable 'log-view-file-re) "\\`a\\`")
+ (set (make-local-variable 'log-view-per-file-logs) nil)
+ (set (make-local-variable 'log-view-message-re)
+ (if (not (eq vc-log-view-type 'long))
+ "^\\(?:[*/\\| ]+ \\)?\\(?: ([^)]+)\\)?\\([0-9a-z]+\\) \\([-a-z0-9]+\\) \\(.*\\)"
+ "^commit *\\([0-9a-z]+\\)"))
+ (set (make-local-variable 'log-view-font-lock-keywords)
+ (if (not (eq vc-log-view-type 'long))
+ '(
+ ;; Same as log-view-message-re, except that we don't
+ ;; want the shy group for the tag name.
+ ("^\\(?:[*/\\| ]+ \\)?\\( ([^)]+)\\)?\\([0-9a-z]+\\) \\([-a-z0-9]+\\) \\(.*\\)"
+ (1 'highlight nil lax)
+ (2 'change-log-acknowledgement)
+ (3 'change-log-date)))
+ (append
+ `((,log-view-message-re (1 'change-log-acknowledgement)))
+ ;; Handle the case:
+ ;; user: foo@bar
+ '(("^Author:[ \t]+\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)"
+ (1 'change-log-email))
+ ;; Handle the case:
+ ;; user: FirstName LastName <foo@bar>
+ ("^Author:[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]"
+ (1 'change-log-name)
+ (2 'change-log-email))
+ ("^ +\\(?:\\(?:[Aa]cked\\|[Ss]igned-[Oo]ff\\)-[Bb]y:\\)[ \t]+\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)"
+ (1 'change-log-name))
+ ("^ +\\(?:\\(?:[Aa]cked\\|[Ss]igned-[Oo]ff\\)-[Bb]y:\\)[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]"
+ (1 'change-log-name)
+ (2 'change-log-email))
+ ("^Merge: \\([0-9a-z]+\\) \\([0-9a-z]+\\)"
+ (1 'change-log-acknowledgement)
+ (2 'change-log-acknowledgement))
+ ("^Date: \\(.+\\)" (1 'change-log-date))
+ ("^summary:[ \t]+\\(.+\\)" (1 'log-view-message)))))))
+
+
+(defun vc-git-show-log-entry (revision)
+ "Move to the log entry for REVISION.
+REVISION may have the form BRANCH, BRANCH~N,
+or BRANCH^ (where \"^\" can be repeated)."
+ (goto-char (point-min))
+ (prog1
+ (when revision
+ (search-forward
+ (format "\ncommit %s" revision) nil t
+ (cond ((string-match "~\\([0-9]\\)\\'" revision)
+ (1+ (string-to-number (match-string 1 revision))))
+ ((string-match "\\^+\\'" revision)
+ (1+ (length (match-string 0 revision))))
+ (t nil))))
+ (beginning-of-line)))
+
+(defun vc-git-diff (files &optional rev1 rev2 buffer)
+ "Get a difference report using Git between two revisions of FILES."
+ (let (process-file-side-effects)
+ (apply #'vc-git-command (or buffer "*vc-diff*") 1 files
+ (if (and rev1 rev2) "diff-tree" "diff-index")
+ "--exit-code"
+ (append (vc-switches 'git 'diff)
+ (list "-p" (or rev1 "HEAD") rev2 "--")))))
+
+(defun vc-git-revision-table (files)
+ ;; What about `files'?!? --Stef
+ (let (process-file-side-effects
+ (table (list "HEAD")))
+ (with-temp-buffer
+ (vc-git-command t nil nil "for-each-ref" "--format=%(refname)")
+ (goto-char (point-min))
+ (while (re-search-forward "^refs/\\(heads\\|tags\\|remotes\\)/\\(.*\\)$"
+ nil t)
+ (push (match-string 2) table)))
+ table))
+
+(defun vc-git-revision-completion-table (files)
+ (lexical-let ((files files)
+ table)
+ (setq table (lazy-completion-table
+ table (lambda () (vc-git-revision-table files))))
+ table))
+
+(defun vc-git-annotate-command (file buf &optional rev)
+ (let ((name (file-relative-name file)))
+ (vc-git-command buf 'async nil "blame" "--date=iso" "-C" "-C" rev "--" name)))
+
+(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)
+ (let ((fname (match-string-no-properties 3)))
+ ;; Remove trailing whitespace from the file name.
+ (when (string-match " +\\'" fname)
+ (setq fname (substring fname 0 (match-beginning 0))))
+ (cons revision
+ (expand-file-name fname (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* ((fname (file-relative-name file))
+ (prev-rev (with-temp-buffer
+ (and
+ (vc-git--out-ok "rev-list" "-2" rev "--" fname)
+ (goto-char (point-max))
+ (bolp)
+ (zerop (forward-line -1))
+ (not (bobp))
+ (buffer-substring-no-properties
+ (point)
+ (1- (point-max)))))))
+ (or (vc-git-symbolic-commit prev-rev) prev-rev))
+ (with-temp-buffer
+ (and
+ (vc-git--out-ok "rev-parse" (concat rev "^"))
+ (buffer-substring-no-properties (point-min) (+ (point-min) 40))))))
+
+(defun vc-git-next-revision (file rev)
+ "Git-specific version of `vc-next-revision'."
+ (let* ((default-directory (file-name-directory
+ (expand-file-name file)))
+ (file (file-name-nondirectory file))
+ (current-rev
+ (with-temp-buffer
+ (and
+ (vc-git--out-ok "rev-list" "-1" rev "--" file)
+ (goto-char (point-max))
+ (bolp)
+ (zerop (forward-line -1))
+ (bobp)
+ (buffer-substring-no-properties
+ (point)
+ (1- (point-max))))))
+ (next-rev
+ (and current-rev
+ (with-temp-buffer
+ (and
+ (vc-git--out-ok "rev-list" "HEAD" "--" file)
+ (goto-char (point-min))
+ (search-forward current-rev nil t)
+ (zerop (forward-line -1))
+ (buffer-substring-no-properties
+ (point)
+ (progn (forward-line 1) (1- (point)))))))))
+ (or (vc-git-symbolic-commit next-rev) next-rev)))
+
+(defun vc-git-delete-file (file)
+ (vc-git-command nil 0 file "rm" "-f" "--"))
+
+(defun vc-git-rename-file (old new)
+ (vc-git-command nil 0 (list old new) "mv" "-f" "--"))
+
+(defvar vc-git-extra-menu-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [git-grep]
+ '(menu-item "Git grep..." vc-git-grep
+ :help "Run the `git grep' command"))
+ (define-key map [git-sn]
+ '(menu-item "Stash a snapshot" vc-git-stash-snapshot
+ :help "Stash the current state of the tree and keep the current state"))
+ (define-key map [git-st]
+ '(menu-item "Create Stash..." vc-git-stash
+ :help "Stash away changes"))
+ (define-key map [git-ss]
+ '(menu-item "Show Stash..." vc-git-stash-show
+ :help "Show stash contents"))
+ map))
+
+(defun vc-git-extra-menu () vc-git-extra-menu-map)
+
+(defun vc-git-extra-status-menu () vc-git-extra-menu-map)
+
+(defun vc-git-root (file)
+ (vc-find-root file ".git"))
+
+;; Derived from `lgrep'.
+(defun vc-git-grep (regexp &optional files dir)
+ "Run git grep, searching for REGEXP in FILES in directory DIR.
+The search is limited to file names matching shell pattern FILES.
+FILES may use abbreviations defined in `grep-files-aliases', e.g.
+entering `ch' is equivalent to `*.[ch]'.
+
+With \\[universal-argument] prefix, you can edit the constructed shell command line
+before it is executed.
+With two \\[universal-argument] prefixes, directly edit and run `grep-command'.
+
+Collect output in a buffer. While git grep runs asynchronously, you
+can use \\[next-error] (M-x next-error), or \\<grep-mode-map>\\[compile-goto-error] \
+in the grep output buffer,
+to go to the lines where grep found matches.
+
+This command shares argument histories with \\[rgrep] and \\[grep]."
+ (interactive
+ (progn
+ (grep-compute-defaults)
+ (cond
+ ((equal current-prefix-arg '(16))
+ (list (read-from-minibuffer "Run: " "git grep"
+ nil nil 'grep-history)
+ nil))
+ (t (let* ((regexp (grep-read-regexp))
+ (files (grep-read-files regexp))
+ (dir (read-directory-name "In directory: "
+ nil default-directory t)))
+ (list regexp files dir))))))
+ (require 'grep)
+ (when (and (stringp regexp) (> (length regexp) 0))
+ (let ((command regexp))
+ (if (null files)
+ (if (string= command "git grep")
+ (setq command nil))
+ (setq dir (file-name-as-directory (expand-file-name dir)))
+ (setq command
+ (grep-expand-template "git grep -n -e <R> -- <F>" regexp files))
+ (when command
+ (if (equal current-prefix-arg '(4))
+ (setq command
+ (read-from-minibuffer "Confirm: "
+ command nil nil 'grep-history))
+ (add-to-history 'grep-history command))))
+ (when command
+ (let ((default-directory dir)
+ (compilation-environment '("PAGER=")))
+ ;; Setting process-setup-function makes exit-message-function work
+ ;; even when async processes aren't supported.
+ (compilation-start command 'grep-mode))
+ (if (eq next-error-last-buffer (current-buffer))
+ (setq default-directory dir))))))
+
+(defun vc-git-stash (name)
+ "Create a stash."
+ (interactive "sStash name: ")
+ (let ((root (vc-git-root default-directory)))
+ (when root
+ (vc-git--call nil "stash" "save" name)
+ (vc-resynch-buffer root t t))))
+
+(defun vc-git-stash-show (name)
+ "Show the contents of stash NAME."
+ (interactive "sStash name: ")
+ (vc-setup-buffer "*vc-git-stash*")
+ (vc-git-command "*vc-git-stash*" 'async nil "stash" "show" "-p" name)
+ (set-buffer "*vc-git-stash*")
+ (diff-mode)
+ (setq buffer-read-only t)
+ (pop-to-buffer (current-buffer)))
+
+(defun vc-git-stash-apply (name)
+ "Apply stash NAME."
+ (interactive "sApply stash: ")
+ (vc-git-command "*vc-git-stash*" 0 nil "stash" "apply" "-q" name)
+ (vc-resynch-buffer (vc-git-root default-directory) t t))
+
+(defun vc-git-stash-pop (name)
+ "Pop stash NAME."
+ (interactive "sPop stash: ")
+ (vc-git-command "*vc-git-stash*" 0 nil "stash" "pop" "-q" name)
+ (vc-resynch-buffer (vc-git-root default-directory) t t))
+
+(defun vc-git-stash-snapshot ()
+ "Create a stash with the current tree state."
+ (interactive)
+ (vc-git--call nil "stash" "save"
+ (let ((ct (current-time)))
+ (concat
+ (format-time-string "Snapshot on %Y-%m-%d" ct)
+ (format-time-string " at %H:%M" ct))))
+ (vc-git-command "*vc-git-stash*" 0 nil "stash" "apply" "-q" "stash@{0}")
+ (vc-resynch-buffer (vc-git-root default-directory) t t))
+
+(defun vc-git-stash-list ()
+ (delete
+ ""
+ (split-string
+ (replace-regexp-in-string
+ "^stash@" " " (vc-git--run-command-string nil "stash" "list"))
+ "\n")))
+
+(defun vc-git-stash-get-at-point (point)
+ (save-excursion
+ (goto-char point)
+ (beginning-of-line)
+ (if (looking-at "^ +\\({[0-9]+}\\):")
+ (match-string 1)
+ (error "Cannot find stash at point"))))
+
+(defun vc-git-stash-delete-at-point ()
+ (interactive)
+ (let ((stash (vc-git-stash-get-at-point (point))))
+ (when (y-or-n-p (format "Remove stash %s ? " stash))
+ (vc-git--run-command-string nil "stash" "drop" (format "stash@%s" stash))
+ (vc-dir-refresh))))
+
+(defun vc-git-stash-show-at-point ()
+ (interactive)
+ (vc-git-stash-show (format "stash@%s" (vc-git-stash-get-at-point (point)))))
+
+(defun vc-git-stash-apply-at-point ()
+ (interactive)
+ (vc-git-stash-apply (format "stash@%s" (vc-git-stash-get-at-point (point)))))
+
+(defun vc-git-stash-pop-at-point ()
+ (interactive)
+ (vc-git-stash-pop (format "stash@%s" (vc-git-stash-get-at-point (point)))))
+
+(defun vc-git-stash-menu (e)
+ (interactive "e")
+ (vc-dir-at-event e (popup-menu vc-git-stash-menu-map e)))
+
+\f
+;;; Internal commands
+
+(defun vc-git-command (buffer okstatus file-or-list &rest flags)
+ "A wrapper around `vc-do-command' for use in vc-git.el.
+The difference to vc-do-command is that this function always invokes `git'."
+ (apply 'vc-do-command (or buffer "*vc*") okstatus "git" file-or-list flags))
+
+(defun vc-git--empty-db-p ()
+ "Check if the git db is empty (no commit done yet)."
+ (let (process-file-side-effects)
+ (not (eq 0 (vc-git--call nil "rev-parse" "--verify" "HEAD")))))
+
+(defun vc-git--call (buffer command &rest args)
+ ;; We don't need to care the arguments. If there is a file name, it
+ ;; is always a relative one. This works also for remote
+ ;; directories.
+ (apply 'process-file "git" nil buffer nil command args))
+
+(defun vc-git--out-ok (command &rest args)
+ (zerop (apply 'vc-git--call '(t nil) command args)))
+
+(defun vc-git--run-command-string (file &rest args)
+ "Run a git command on FILE and return its output as string.
+FILE can be nil."
+ (let* ((ok t)
+ (str (with-output-to-string
+ (with-current-buffer standard-output
+ (unless (apply 'vc-git--out-ok
+ (if file
+ (append args (list (file-relative-name
+ file)))
+ args))
+ (setq ok nil))))))
+ (and ok str)))
+
+(defun vc-git-symbolic-commit (commit)
+ "Translate COMMIT string into symbolic form.
+Returns nil if not possible."
+ (and commit
+ (let ((name (with-temp-buffer
+ (and
+ (vc-git--out-ok "name-rev" "--name-only" commit)
+ (goto-char (point-min))
+ (= (forward-line 2) 1)
+ (bolp)
+ (buffer-substring-no-properties (point-min)
+ (1- (point-max)))))))
+ (and name (not (string= name "undefined")) name))))
+
+(provide 'vc-git)
+
+;; arch-tag: bd10664a-0e5b-48f5-a877-6c17b135be12
+;;; vc-git.el ends here
--- /dev/null
- ;; Copyright (C) 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;;; vc-hg.el --- VC backend for the mercurial version control system
+
++;; Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+
+;; Author: Ivan Kanis
+;; Keywords: vc tools
+;; Package: 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 <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This is a mercurial version control backend
+
+;;; Thanks:
+
+;;; Bugs:
+
+;;; Installation:
+
+;;; Todo:
+
+;; 1) Implement the rest of the vc interface. See the comment at the
+;; beginning of vc.el. The current status is:
+
+;; FUNCTION NAME STATUS
+;; BACKEND PROPERTIES
+;; * revision-granularity OK
+;; STATE-QUERYING FUNCTIONS
+;; * registered (file) OK
+;; * state (file) OK
+;; - state-heuristic (file) NOT NEEDED
+;; - dir-status (dir update-function) OK
+;; - dir-status-files (dir files ds uf) OK
+;; - dir-extra-headers (dir) OK
+;; - dir-printer (fileinfo) OK
+;; * working-revision (file) OK
+;; - latest-on-branch-p (file) ??
+;; * checkout-model (files) OK
+;; - workfile-unchanged-p (file) OK
+;; - mode-line-string (file) NOT NEEDED
+;; STATE-CHANGING FUNCTIONS
+;; * register (files &optional rev comment) OK
+;; * create-repo () OK
+;; - init-revision () NOT NEEDED
+;; - responsible-p (file) OK
+;; - could-register (file) OK
+;; - receive-file (file rev) ?? PROBABLY NOT NEEDED
+;; - unregister (file) COMMENTED OUT, MAY BE INCORRECT
+;; * checkin (files rev comment) OK
+;; * find-revision (file rev buffer) OK
+;; * checkout (file &optional editable rev) OK
+;; * revert (file &optional contents-done) OK
+;; - rollback (files) ?? PROBABLY NOT NEEDED
+;; - merge (file rev1 rev2) NEEDED
+;; - merge-news (file) NEEDED
+;; - steal-lock (file &optional revision) NOT NEEDED
+;; HISTORY FUNCTIONS
+;; * print-log (files buffer &optional shortlog start-revision limit) OK
+;; - log-view-mode () OK
+;; - show-log-entry (revision) NOT NEEDED, DEFAULT IS GOOD
+;; - comment-history (file) NOT NEEDED
+;; - update-changelog (files) NOT NEEDED
+;; * diff (files &optional rev1 rev2 buffer) OK
+;; - revision-completion-table (files) OK?
+;; - annotate-command (file buf &optional rev) OK
+;; - annotate-time () OK
+;; - annotate-current-time () NOT NEEDED
+;; - annotate-extract-revision-at-line () OK
+;; TAG SYSTEM
+;; - create-tag (dir name branchp) NEEDED
+;; - retrieve-tag (dir name update) NEEDED
+;; MISCELLANEOUS
+;; - make-version-backups-p (file) ??
+;; - repository-hostname (dirname) ??
+;; - previous-revision (file rev) OK
+;; - next-revision (file rev) OK
+;; - check-headers () ??
+;; - clear-headers () ??
+;; - delete-file (file) TEST IT
+;; - rename-file (old new) OK
+;; - find-file-hook () PROBABLY NOT NEEDED
+
+;; 2) Implement Stefan Monnier's advice:
+;; vc-hg-registered and vc-hg-state
+;; Both of those functions should be super extra careful to fail gracefully in
+;; unexpected circumstances. The reason this is important is that any error
+;; there will prevent the user from even looking at the file :-(
+;; Ideally, just like in vc-arch and vc-cvs, checking that the file is under
+;; mercurial's control and extracting the current revision should be done
+;; without even using `hg' (this way even if you don't have `hg' installed,
+;; Emacs is able to tell you this file is under mercurial's control).
+
+;;; History:
+;;
+
+;;; Code:
+
+(eval-when-compile
+ (require 'cl)
+ (require 'vc)
+ (require 'vc-dir))
+
+;;; Customization options
+
+(defcustom vc-hg-global-switches nil
+ "Global switches to pass to any Hg command."
+ :type '(choice (const :tag "None" nil)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List" :value ("") string))
+ :version "22.2"
+ :group 'vc)
+
+(defcustom vc-hg-diff-switches t ; Hg doesn't support common args like -u
+ "String or list of strings specifying switches for Hg diff under VC.
+If nil, use the value of `vc-diff-switches'. If t, use no switches."
+ :type '(choice (const :tag "Unspecified" nil)
+ (const :tag "None" t)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List" :value ("") string))
+ :version "23.1"
+ :group 'vc)
+
+(defcustom vc-hg-program "hg"
+ "Name of the Mercurial executable (excluding any arguments)."
+ :type 'string
+ :group 'vc)
+\f
+;;; Properties of the backend
+
+(defun vc-hg-revision-granularity () 'repository)
+(defun vc-hg-checkout-model (files) 'implicit)
+
+;;; State querying functions
+
+;;;###autoload (defun vc-hg-registered (file)
+;;;###autoload "Return non-nil if FILE is registered with hg."
+;;;###autoload (if (vc-find-root file ".hg") ; short cut
+;;;###autoload (progn
+;;;###autoload (load "vc-hg")
+;;;###autoload (vc-hg-registered file))))
+
+;; Modeled after the similar function in vc-bzr.el
+(defun vc-hg-registered (file)
+ "Return non-nil if FILE is registered with hg."
+ (when (vc-hg-root file) ; short cut
+ (let ((state (vc-hg-state file))) ; expensive
+ (and state (not (memq state '(ignored unregistered)))))))
+
+(defun vc-hg-state (file)
+ "Hg-specific version of `vc-state'."
+ (let*
+ ((status nil)
+ (default-directory (file-name-directory file))
+ (out
+ (with-output-to-string
+ (with-current-buffer
+ standard-output
+ (setq status
+ (condition-case nil
+ ;; Ignore all errors.
+ (let ((process-environment
+ ;; Avoid localization of messages so we
+ ;; can parse the output.
+ (append (list "TERM=dumb" "LANGUAGE=C")
+ process-environment)))
+ (process-file
+ vc-hg-program nil t nil
+ "--config" "alias.status=status"
+ "--config" "defaults.status="
+ "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")
+ 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
+ vc-hg-program nil t nil
+ "--config" "alias.parents=parents"
+ "--config" "defaults.parents="
+ "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
+ vc-hg-program nil nil nil
+ ;; We use "log" here, if there's a faster command
+ ;; that returns true for an 'added file and false
+ ;; for an 'unregistered one, we could use that.
+ "log" "-l1" (file-relative-name file)))
+ ;; Some problem happened. E.g. We can't find an `hg'
+ ;; executable.
+ (error nil)))
+ (when (eq 0 status) "0"))))
+
+;;; History functions
+
+(defcustom vc-hg-log-switches nil
+ "String or list of strings specifying switches for hg log under VC."
+ :type '(choice (const :tag "None" nil)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List" :value ("") string))
+ :group 'vc-hg)
+
+(defun vc-hg-print-log (files buffer &optional shortlog start-revision limit)
+ "Get change log associated with FILES."
+ ;; `vc-do-command' creates the buffer, but we need it before running
+ ;; the command.
+ (vc-setup-buffer buffer)
+ ;; If the buffer exists from a previous invocation it might be
+ ;; read-only.
+ (let ((inhibit-read-only t))
+ (with-current-buffer
+ buffer
+ (apply 'vc-hg-command buffer 0 files "log"
+ (nconc
+ (when start-revision (list (format "-r%s:" start-revision)))
+ (when limit (list "-l" (format "%s" limit)))
+ (when shortlog (list "--style" "compact"))
+ vc-hg-log-switches)))))
+
+(defvar log-view-message-re)
+(defvar log-view-file-re)
+(defvar log-view-font-lock-keywords)
+(defvar log-view-per-file-logs)
+
+(define-derived-mode vc-hg-log-view-mode log-view-mode "Hg-Log-View"
+ (require 'add-log) ;; we need the add-log faces
+ (set (make-local-variable 'log-view-file-re) "\\`a\\`")
+ (set (make-local-variable 'log-view-per-file-logs) nil)
+ (set (make-local-variable 'log-view-message-re)
+ (if (eq vc-log-view-type 'short)
+ "^\\([0-9]+\\)\\(\\[.*\\]\\)? +\\([0-9a-z]\\{12\\}\\) +\\(\\(?:[0-9]+\\)-\\(?:[0-9]+\\)-\\(?:[0-9]+\\) \\(?:[0-9]+\\):\\(?:[0-9]+\\) \\(?:[-+0-9]+\\)\\) +\\(.*\\)$"
+ "^changeset:[ \t]*\\([0-9]+\\):\\(.+\\)"))
+ (set (make-local-variable 'log-view-font-lock-keywords)
+ (if (eq vc-log-view-type 'short)
+ (append `((,log-view-message-re
+ (1 'log-view-message-face)
+ (2 'highlight nil lax)
+ (3 'log-view-message-face)
+ (4 'change-log-date)
+ (5 'change-log-name))))
+ (append
+ log-view-font-lock-keywords
+ '(
+ ;; Handle the case:
+ ;; user: FirstName LastName <foo@bar>
+ ("^user:[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]"
+ (1 'change-log-name)
+ (2 'change-log-email))
+ ;; Handle the cases:
+ ;; user: foo@bar
+ ;; and
+ ;; user: foo
+ ("^user:[ \t]+\\([A-Za-z0-9_.+-]+\\(?:@[A-Za-z0-9_.-]+\\)?\\)"
+ (1 'change-log-email))
+ ("^date: \\(.+\\)" (1 'change-log-date))
+ ("^tag: +\\([^ ]+\\)$" (1 'highlight))
+ ("^summary:[ \t]+\\(.+\\)" (1 'log-view-message)))))))
+
+(defun vc-hg-diff (files &optional oldvers newvers buffer)
+ "Get a difference report using hg between two revisions of FILES."
+ (let* ((firstfile (car files))
+ (working (and firstfile (vc-working-revision firstfile))))
+ (when (and (equal oldvers working) (not newvers))
+ (setq oldvers nil))
+ (when (and (not oldvers) newvers)
+ (setq oldvers working))
+ (apply #'vc-hg-command (or buffer "*vc-diff*") nil files "diff"
+ (append
+ (vc-switches 'hg 'diff)
+ (when oldvers
+ (if newvers
+ (list "-r" oldvers "-r" newvers)
+ (list "-r" oldvers)))))))
+
+(defun vc-hg-revision-table (files)
+ (let ((default-directory (file-name-directory (car files))))
+ (with-temp-buffer
+ (vc-hg-command t nil files "log" "--template" "{rev} ")
+ (split-string
+ (buffer-substring-no-properties (point-min) (point-max))))))
+
+;; Modeled after the similar function in vc-cvs.el
+(defun vc-hg-revision-completion-table (files)
+ (lexical-let ((files files)
+ table)
+ (setq table (lazy-completion-table
+ table (lambda () (vc-hg-revision-table files))))
+ table))
+
+(defun vc-hg-annotate-command (file buffer &optional revision)
+ "Execute \"hg annotate\" on FILE, inserting the contents in BUFFER.
+Optional arg REVISION is a revision to annotate from."
+ (vc-hg-command buffer 0 file "annotate" "-d" "-n" "--follow"
+ (when revision (concat "-r" revision))))
+
+(declare-function vc-annotate-convert-time "vc-annotate" (time))
+
+;; The format for one line output by "hg annotate -d -n" looks like this:
+;;215 Wed Jun 20 21:22:58 2007 -0700: CONTENTS
+;; i.e: VERSION_NUMBER DATE: CONTENTS
+;; If the user has set the "--follow" option, the output looks like:
+;;215 Wed Jun 20 21:22:58 2007 -0700 foo.c: CONTENTS
+;; i.e. VERSION_NUMBER DATE FILENAME: CONTENTS
+(defconst vc-hg-annotate-re
+ "^[ \t]*\\([0-9]+\\) \\(.\\{30\\}\\)\\(?:\\(: \\)\\|\\(?: +\\(.+\\): \\)\\)")
+
+(defun vc-hg-annotate-time ()
+ (when (looking-at vc-hg-annotate-re)
+ (goto-char (match-end 0))
+ (vc-annotate-convert-time
+ (date-to-time (match-string-no-properties 2)))))
+
+(defun vc-hg-annotate-extract-revision-at-line ()
+ (save-excursion
+ (beginning-of-line)
+ (when (looking-at vc-hg-annotate-re)
+ (if (match-beginning 3)
+ (match-string-no-properties 1)
+ (cons (match-string-no-properties 1)
+ (expand-file-name (match-string-no-properties 4)
+ (vc-hg-root default-directory)))))))
+
+(defun vc-hg-previous-revision (file rev)
+ (let ((newrev (1- (string-to-number rev))))
+ (when (>= newrev 0)
+ (number-to-string newrev))))
+
+(defun vc-hg-next-revision (file rev)
+ (let ((newrev (1+ (string-to-number rev)))
+ (tip-revision
+ (with-temp-buffer
+ (vc-hg-command t 0 nil "tip")
+ (goto-char (point-min))
+ (re-search-forward "^changeset:[ \t]*\\([0-9]+\\):")
+ (string-to-number (match-string-no-properties 1)))))
+ ;; We don't want to exceed the maximum possible revision number, ie
+ ;; the tip revision.
+ (when (<= newrev tip-revision)
+ (number-to-string newrev))))
+
+;; Modeled after the similar function in vc-bzr.el
+(defun vc-hg-delete-file (file)
+ "Delete FILE and delete it in the hg repository."
+ (condition-case ()
+ (delete-file file)
+ (file-error nil))
+ (vc-hg-command nil 0 file "remove" "--after" "--force"))
+
+;; Modeled after the similar function in vc-bzr.el
+(defun vc-hg-rename-file (old new)
+ "Rename file from OLD to NEW using `hg mv'."
+ (vc-hg-command nil 0 new "mv" old))
+
+(defun vc-hg-register (files &optional rev comment)
+ "Register FILES under hg.
+REV is ignored.
+COMMENT is ignored."
+ (vc-hg-command nil 0 files "add"))
+
+(defun vc-hg-create-repo ()
+ "Create a new Mercurial repository."
+ (vc-hg-command nil 0 nil "init"))
+
+(defalias 'vc-hg-responsible-p 'vc-hg-root)
+
+;; Modeled after the similar function in vc-bzr.el
+(defun vc-hg-could-register (file)
+ "Return non-nil if FILE could be registered under hg."
+ (and (vc-hg-responsible-p file) ; shortcut
+ (condition-case ()
+ (with-temp-buffer
+ (vc-hg-command t nil file "add" "--dry-run"))
+ ;; The command succeeds with no output if file is
+ ;; registered.
+ (error))))
+
+;; FIXME: This would remove the file. Is that correct?
+;; (defun vc-hg-unregister (file)
+;; "Unregister FILE from hg."
+;; (vc-hg-command nil nil file "remove"))
+
+(declare-function log-edit-extract-headers "log-edit" (headers string))
+
+(defun vc-hg-checkin (files rev comment)
+ "Hg-specific version of `vc-backend-checkin'.
+REV is ignored."
+ (apply 'vc-hg-command nil 0 files
+ (nconc (list "commit" "-m")
+ (log-edit-extract-headers '(("Author" . "--user")
+ ("Date" . "--date"))
+ comment))))
+
+(defun vc-hg-find-revision (file rev buffer)
+ (let ((coding-system-for-read 'binary)
+ (coding-system-for-write 'binary))
+ (if rev
+ (vc-hg-command buffer 0 file "cat" "-r" rev)
+ (vc-hg-command buffer 0 file "cat"))))
+
+;; Modeled after the similar function in vc-bzr.el
+(defun vc-hg-checkout (file &optional editable rev)
+ "Retrieve a revision of FILE.
+EDITABLE is ignored.
+REV is the revision to check out into WORKFILE."
+ (let ((coding-system-for-read 'binary)
+ (coding-system-for-write 'binary))
+ (with-current-buffer (or (get-file-buffer file) (current-buffer))
+ (if rev
+ (vc-hg-command t 0 file "cat" "-r" rev)
+ (vc-hg-command t 0 file "cat")))))
+
+;; Modeled after the similar function in vc-bzr.el
+(defun vc-hg-workfile-unchanged-p (file)
+ (eq 'up-to-date (vc-hg-state file)))
+
+;; Modeled after the similar function in vc-bzr.el
+(defun vc-hg-revert (file &optional contents-done)
+ (unless contents-done
+ (with-temp-buffer (vc-hg-command t 0 file "revert"))))
+
+;;; Hg specific functionality.
+
+(defvar vc-hg-extra-menu-map
+ (let ((map (make-sparse-keymap)))
+ map))
+
+(defun vc-hg-extra-menu () vc-hg-extra-menu-map)
+
+(defun vc-hg-extra-status-menu () vc-hg-extra-menu-map)
+
+(defvar log-view-vc-backend)
+
+(defstruct (vc-hg-extra-fileinfo
+ (:copier nil)
+ (:constructor vc-hg-create-extra-fileinfo (rename-state extra-name))
+ (:conc-name vc-hg-extra-fileinfo->))
+ rename-state ;; rename or copy state
+ extra-name) ;; original name for copies and rename targets, new name for
+
+(declare-function vc-default-dir-printer "vc-dir" (backend fileentry))
+
+(defun vc-hg-dir-printer (info)
+ "Pretty-printer for the vc-dir-fileinfo structure."
+ (let ((extra (vc-dir-fileinfo->extra info)))
+ (vc-default-dir-printer 'Hg info)
+ (when extra
+ (insert (propertize
+ (format " (%s %s)"
+ (case (vc-hg-extra-fileinfo->rename-state extra)
+ ('copied "copied from")
+ ('renamed-from "renamed from")
+ ('renamed-to "renamed to"))
+ (vc-hg-extra-fileinfo->extra-name extra))
+ 'face 'font-lock-comment-face)))))
+
+(defun vc-hg-after-dir-status (update-function)
+ (let ((status-char nil)
+ (file nil)
+ (translation '((?= . up-to-date)
+ (?C . up-to-date)
+ (?A . added)
+ (?R . removed)
+ (?M . edited)
+ (?I . ignored)
+ (?! . missing)
+ (? . copy-rename-line)
+ (?? . unregistered)))
+ (translated nil)
+ (result nil)
+ (last-added nil)
+ (last-line-copy nil))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (setq translated (cdr (assoc (char-after) translation)))
+ (setq file
+ (buffer-substring-no-properties (+ (point) 2)
+ (line-end-position)))
+ (cond ((not translated)
+ (setq last-line-copy nil))
+ ((eq translated 'up-to-date)
+ (setq last-line-copy nil))
+ ((eq translated 'copy-rename-line)
+ ;; For copied files the output looks like this:
+ ;; A COPIED_FILE_NAME
+ ;; ORIGINAL_FILE_NAME
+ (setf (nth 2 last-added)
+ (vc-hg-create-extra-fileinfo 'copied file))
+ (setq last-line-copy t))
+ ((and last-line-copy (eq translated 'removed))
+ ;; For renamed files the output looks like this:
+ ;; A NEW_FILE_NAME
+ ;; ORIGINAL_FILE_NAME
+ ;; R ORIGINAL_FILE_NAME
+ ;; We need to adjust the previous entry to not think it is a copy.
+ (setf (vc-hg-extra-fileinfo->rename-state (nth 2 last-added))
+ 'renamed-from)
+ (push (list file translated
+ (vc-hg-create-extra-fileinfo
+ 'renamed-to (nth 0 last-added))) result)
+ (setq last-line-copy nil))
+ (t
+ (setq last-added (list file translated nil))
+ (push last-added result)
+ (setq last-line-copy nil)))
+ (forward-line))
+ (funcall update-function result)))
+
+(defun vc-hg-dir-status (dir update-function)
+ (vc-hg-command (current-buffer) 'async dir "status" "-C")
+ (vc-exec-after
+ `(vc-hg-after-dir-status (quote ,update-function))))
+
+(defun vc-hg-dir-status-files (dir files default-state update-function)
+ (apply 'vc-hg-command (current-buffer) 'async dir "status" "-C" files)
+ (vc-exec-after
+ `(vc-hg-after-dir-status (quote ,update-function))))
+
+(defun vc-hg-dir-extra-header (name &rest commands)
+ (concat (propertize name 'face 'font-lock-type-face)
+ (propertize
+ (with-temp-buffer
+ (apply 'vc-hg-command (current-buffer) 0 nil commands)
+ (buffer-substring-no-properties (point-min) (1- (point-max))))
+ 'face 'font-lock-variable-name-face)))
+
+(defun vc-hg-dir-extra-headers (dir)
+ "Generate extra status headers for a Mercurial tree."
+ (let ((default-directory dir))
+ (concat
+ (vc-hg-dir-extra-header "Root : " "root") "\n"
+ (vc-hg-dir-extra-header "Branch : " "id" "-b") "\n"
+ (vc-hg-dir-extra-header "Tags : " "id" "-t") ; "\n"
+ ;; these change after each commit
+ ;; (vc-hg-dir-extra-header "Local num : " "id" "-n") "\n"
+ ;; (vc-hg-dir-extra-header "Global id : " "id" "-i")
+ )))
+
+(defun vc-hg-log-incoming (buffer remote-location)
+ (vc-hg-command buffer 1 nil "incoming" "-n" (unless (string= remote-location "")
+ remote-location)))
+
+(defun vc-hg-log-outgoing (buffer remote-location)
+ (vc-hg-command buffer 1 nil "outgoing" "-n" (unless (string= remote-location "")
+ remote-location)))
+
+(declare-function log-view-get-marked "log-view" ())
+
+;; XXX maybe also add key bindings for these functions.
+(defun vc-hg-push ()
+ (interactive)
+ (let ((marked-list (log-view-get-marked)))
+ (if marked-list
+ (apply #'vc-hg-command
+ nil 0 nil
+ "push"
+ (apply 'nconc
+ (mapcar (lambda (arg) (list "-r" arg)) marked-list)))
+ (error "No log entries selected for push"))))
+
+(defun vc-hg-pull ()
+ (interactive)
+ (let ((marked-list (log-view-get-marked)))
+ (if marked-list
+ (apply #'vc-hg-command
+ nil 0 nil
+ "pull"
+ (apply 'nconc
+ (mapcar (lambda (arg) (list "-r" arg)) marked-list)))
+ (error "No log entries selected for pull"))))
+
+;;; Internal functions
+
+(defun vc-hg-command (buffer okstatus file-or-list &rest flags)
+ "A wrapper around `vc-do-command' for use in vc-hg.el.
+The difference to vc-do-command is that this function always invokes `hg',
+and that it passes `vc-hg-global-switches' to it before FLAGS."
+ (apply 'vc-do-command (or buffer "*vc*") okstatus vc-hg-program file-or-list
+ (if (stringp vc-hg-global-switches)
+ (cons vc-hg-global-switches flags)
+ (append vc-hg-global-switches
+ flags))))
+
+(defun vc-hg-root (file)
+ (vc-find-root file ".hg"))
+
+(provide 'vc-hg)
+
+;; arch-tag: bd094dc5-715a-434f-a331-37b9fb7cd954
+;;; vc-hg.el ends here
--- /dev/null
- ;; 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;;; 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, 2011
+;; Free Software Foundation, Inc.
+
+;; Author: FSF (see vc.el for full credits)
+;; Maintainer: Andre Spiegel <spiegel@gnu.org>
+;; Package: 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 <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This is the always-loaded portion of VC. It takes care of
+;; VC-related activities that are done when you visit a file, so that
+;; vc.el itself is loaded only when you use a VC command. See the
+;; commentary of vc.el.
+
+;;; Code:
+
+(eval-when-compile
+ (require 'cl))
+
+;; Customization Variables (the rest is in vc.el)
+
+(defvar vc-ignore-vc-files nil)
+(make-obsolete-variable 'vc-ignore-vc-files
+ "set `vc-handled-backends' to nil to disable VC."
+ "21.1")
+
+(defvar vc-master-templates ())
+(make-obsolete-variable 'vc-master-templates
+ "to define master templates for a given BACKEND, use
+vc-BACKEND-master-templates. To enable or disable VC for a given
+BACKEND, use `vc-handled-backends'."
+ "21.1")
+
+(defcustom vc-ignore-dir-regexp
+ ;; Stop SMB, automounter, AFS, and DFS host lookups.
+ locate-dominating-stop-dir-regexp
+ "Regexp matching directory names that are not under VC's control.
+The default regexp prevents fruitless and time-consuming attempts
+to determine the VC status in directories in which filenames are
+interpreted as hostnames."
+ :type 'regexp
+ :group 'vc)
+
+(defcustom vc-handled-backends '(RCS CVS SVN SCCS Bzr Git Hg Mtn Arch)
+ ;; RCS, CVS, SVN and SCCS come first because they are per-dir
+ ;; rather than per-tree. RCS comes first because of the multibackend
+ ;; support intended to use RCS for local commits (with a remote CVS server).
+ "List of version control backends for which VC will be used.
+Entries in this list will be tried in order to determine whether a
+file is under that sort of version control.
+Removing an entry from the list prevents VC from being activated
+when visiting a file managed by that backend.
+An empty list disables VC altogether."
+ :type '(repeat symbol)
+ :version "23.1"
+ :group 'vc)
+
+;; Note: we don't actually have a darcs back end yet.
+;; Also, Meta-CVS (corresponsding to MCVS) is unsupported.
+(defcustom vc-directory-exclusion-list (purecopy '("SCCS" "RCS" "CVS" "MCVS"
+ ".svn" ".git" ".hg" ".bzr"
+ "_MTN" "_darcs" "{arch}"))
+ "List of directory names to be ignored when walking directory trees."
+ :type '(repeat string)
+ :group 'vc)
+
+(defcustom vc-make-backup-files nil
+ "If non-nil, backups of registered files are made as with other files.
+If nil (the default), files covered by version control don't get backups."
+ :type 'boolean
+ :group 'vc
+ :group 'backup)
+
+(defcustom vc-follow-symlinks 'ask
+ "What to do if visiting a symbolic link to a file under version control.
+Editing such a file through the link bypasses the version control system,
+which is dangerous and probably not what you want.
+
+If this variable is t, VC follows the link and visits the real file,
+telling you about it in the echo area. If it is `ask', VC asks for
+confirmation whether it should follow the link. If nil, the link is
+visited and a warning displayed."
+ :type '(choice (const :tag "Ask for confirmation" ask)
+ (const :tag "Visit link and warn" nil)
+ (const :tag "Follow link" t))
+ :group 'vc)
+
+(defcustom vc-display-status t
+ "If non-nil, display revision number and lock status in modeline.
+Otherwise, not displayed."
+ :type 'boolean
+ :group 'vc)
+
+
+(defcustom vc-consult-headers t
+ "If non-nil, identify work files by searching for version headers."
+ :type 'boolean
+ :group 'vc)
+
+(defcustom vc-keep-workfiles t
+ "If non-nil, don't delete working files after registering changes.
+If the back-end is CVS, workfiles are always kept, regardless of the
+value of this flag."
+ :type 'boolean
+ :group 'vc)
+
+(defcustom vc-mistrust-permissions nil
+ "If non-nil, don't assume permissions/ownership track version-control status.
+If nil, do rely on the permissions.
+See also variable `vc-consult-headers'."
+ :type 'boolean
+ :group 'vc)
+
+(defun vc-mistrust-permissions (file)
+ "Internal access function to variable `vc-mistrust-permissions' for FILE."
+ (or (eq vc-mistrust-permissions 't)
+ (and vc-mistrust-permissions
+ (funcall vc-mistrust-permissions
+ (vc-backend-subdirectory-name file)))))
+
+(defcustom vc-stay-local 'only-file
+ "Non-nil means use local operations when possible for remote repositories.
+This avoids slow queries over the network and instead uses heuristics
+and past information to determine the current status of a file.
+
+If value is the symbol `only-file' `vc-dir' will connect to the
+server, but heuristics will be used to determine the status for
+all other VC operations.
+
+The value can also be a regular expression or list of regular
+expressions to match against the host name of a repository; then VC
+only stays local for hosts that match it. Alternatively, the value
+can be a list of regular expressions where the first element is the
+symbol `except'; then VC always stays local except for hosts matched
+by these regular expressions."
+ :type '(choice
+ (const :tag "Always stay local" t)
+ (const :tag "Only for file operations" only-file)
+ (const :tag "Don't stay local" nil)
+ (list :format "\nExamine hostname and %v" :tag "Examine hostname ..."
+ (set :format "%v" :inline t (const :format "%t" :tag "don't" except))
+ (regexp :format " stay local,\n%t: %v" :tag "if it matches")
+ (repeat :format "%v%i\n" :inline t (regexp :tag "or"))))
+ :version "23.1"
+ :group 'vc)
+
+(defun vc-stay-local-p (file &optional backend)
+ "Return non-nil if VC should stay local when handling FILE.
+This uses the `repository-hostname' backend operation.
+If FILE is a list of files, return non-nil if any of them
+individually should stay local."
+ (if (listp file)
+ (delq nil (mapcar (lambda (arg) (vc-stay-local-p arg backend)) file))
+ (setq backend (or backend (vc-backend file)))
+ (let* ((sym (vc-make-backend-sym backend 'stay-local))
+ (stay-local (if (boundp sym) (symbol-value sym) vc-stay-local)))
+ (if (symbolp stay-local) stay-local
+ (let ((dirname (if (file-directory-p file)
+ (directory-file-name file)
+ (file-name-directory file))))
+ (eq 'yes
+ (or (vc-file-getprop dirname 'vc-stay-local-p)
+ (vc-file-setprop
+ dirname 'vc-stay-local-p
+ (let ((hostname (vc-call-backend
+ backend 'repository-hostname dirname)))
+ (if (not hostname)
+ 'no
+ (let ((default t))
+ (if (eq (car-safe stay-local) 'except)
+ (setq default nil stay-local (cdr stay-local)))
+ (when (consp stay-local)
+ (setq stay-local
+ (mapconcat 'identity stay-local "\\|")))
+ (if (if (string-match stay-local hostname)
+ default (not default))
+ 'yes 'no))))))))))))
+
+;;; This is handled specially now.
+;; Tell Emacs about this new kind of minor mode
+;; (add-to-list 'minor-mode-alist '(vc-mode vc-mode))
+
+;;;###autoload
+(put 'vc-mode 'risky-local-variable t)
+(make-variable-buffer-local 'vc-mode)
+(put 'vc-mode 'permanent-local t)
+
+(defun vc-mode (&optional arg)
+ ;; Dummy function for C-h m
+ "Version Control minor mode.
+This minor mode is automatically activated whenever you visit a file under
+control of one of the revision control systems in `vc-handled-backends'.
+VC commands are globally reachable under the prefix `\\[vc-prefix-map]':
+\\{vc-prefix-map}")
+
+(defmacro vc-error-occurred (&rest body)
+ `(condition-case nil (progn ,@body nil) (error t)))
+
+;; We need a notion of per-file properties because the version
+;; control state of a file is expensive to derive --- we compute
+;; them when the file is initially found, keep them up to date
+;; during any subsequent VC operations, and forget them when
+;; the buffer is killed.
+
+(defvar vc-file-prop-obarray (make-vector 17 0)
+ "Obarray for per-file properties.")
+
+(defvar vc-touched-properties nil)
+
+(defun vc-file-setprop (file property value)
+ "Set per-file VC PROPERTY for FILE to VALUE."
+ (if (and vc-touched-properties
+ (not (memq property vc-touched-properties)))
+ (setq vc-touched-properties (append (list property)
+ vc-touched-properties)))
+ (put (intern file vc-file-prop-obarray) property value))
+
+(defun vc-file-getprop (file property)
+ "Get per-file VC PROPERTY for FILE."
+ (get (intern file vc-file-prop-obarray) property))
+
+(defun vc-file-clearprops (file)
+ "Clear all VC properties of FILE."
+ (setplist (intern file vc-file-prop-obarray) nil))
+
+\f
+;; We keep properties on each symbol naming a backend as follows:
+;; * `vc-functions': an alist mapping vc-FUNCTION to vc-BACKEND-FUNCTION.
+
+(defun vc-make-backend-sym (backend sym)
+ "Return BACKEND-specific version of VC symbol SYM."
+ (intern (concat "vc-" (downcase (symbol-name backend))
+ "-" (symbol-name sym))))
+
+(defun vc-find-backend-function (backend fun)
+ "Return BACKEND-specific implementation of FUN.
+If there is no such implementation, return the default implementation;
+if that doesn't exist either, return nil."
+ (let ((f (vc-make-backend-sym backend fun)))
+ (if (fboundp f) f
+ ;; Load vc-BACKEND.el if needed.
+ (require (intern (concat "vc-" (downcase (symbol-name backend)))))
+ (if (fboundp f) f
+ (let ((def (vc-make-backend-sym 'default fun)))
+ (if (fboundp def) (cons def backend) nil))))))
+
+(defun vc-call-backend (backend function-name &rest args)
+ "Call for BACKEND the implementation of FUNCTION-NAME with the given ARGS.
+Calls
+
+ (apply 'vc-BACKEND-FUN ARGS)
+
+if vc-BACKEND-FUN exists (after trying to find it in vc-BACKEND.el)
+and else calls
+
+ (apply 'vc-default-FUN BACKEND ARGS)
+
+It is usually called via the `vc-call' macro."
+ (let ((f (assoc function-name (get backend 'vc-functions))))
+ (if f (setq f (cdr f))
+ (setq f (vc-find-backend-function backend function-name))
+ (push (cons function-name f) (get backend 'vc-functions)))
+ (cond
+ ((null f)
+ (error "Sorry, %s is not implemented for %s" function-name backend))
+ ((consp f) (apply (car f) (cdr f) args))
+ (t (apply f args)))))
+
+(defmacro vc-call (fun file &rest args)
+ "A convenience macro for calling VC backend functions.
+Functions called by this macro must accept FILE as the first argument.
+ARGS specifies any additional arguments. FUN should be unquoted.
+BEWARE!! FILE is evaluated twice!!"
+ `(vc-call-backend (vc-backend ,file) ',fun ,file ,@args))
+\f
+(defsubst vc-parse-buffer (pattern i)
+ "Find PATTERN in the current buffer and return its Ith submatch."
+ (goto-char (point-min))
+ (if (re-search-forward pattern nil t)
+ (match-string i)))
+
+(defun vc-insert-file (file &optional limit blocksize)
+ "Insert the contents of FILE into the current buffer.
+
+Optional argument LIMIT is a regexp. If present, the file is inserted
+in chunks of size BLOCKSIZE (default 8 kByte), until the first
+occurrence of LIMIT is found. Anything from the start of that occurrence
+to the end of the buffer is then deleted. The function returns
+non-nil if FILE exists and its contents were successfully inserted."
+ (erase-buffer)
+ (when (file-exists-p file)
+ (if (not limit)
+ (insert-file-contents file)
+ (unless blocksize (setq blocksize 8192))
+ (let ((filepos 0))
+ (while
+ (and (< 0 (cadr (insert-file-contents
+ file nil filepos (incf filepos blocksize))))
+ (progn (beginning-of-line)
+ (let ((pos (re-search-forward limit nil 'move)))
+ (when pos (delete-region (match-beginning 0)
+ (point-max)))
+ (not pos)))))))
+ (set-buffer-modified-p nil)
+ t))
+
+(defun vc-find-root (file witness)
+ "Find the root of a checked out project.
+The function walks up the directory tree from FILE looking for WITNESS.
+If WITNESS if not found, return nil, otherwise return the root."
+ (let ((locate-dominating-stop-dir-regexp
+ (or vc-ignore-dir-regexp locate-dominating-stop-dir-regexp)))
+ (locate-dominating-file file witness)))
+
+;; Access functions to file properties
+;; (Properties should be _set_ using vc-file-setprop, but
+;; _retrieved_ only through these functions, which decide
+;; if the property is already known or not. A property should
+;; only be retrieved by vc-file-getprop if there is no
+;; access function.)
+
+;; properties indicating the backend being used for FILE
+
+(defun vc-registered (file)
+ "Return non-nil if FILE is registered in a version control system.
+
+This function performs the check each time it is called. To rely
+on the result of a previous call, use `vc-backend' instead. If the
+file was previously registered under a certain backend, then that
+backend is tried first."
+ (let (handler)
+ (cond
+ ((and (file-name-directory file)
+ (string-match vc-ignore-dir-regexp (file-name-directory file)))
+ nil)
+ ((and (boundp 'file-name-handler-alist)
+ (setq handler (find-file-name-handler file 'vc-registered)))
+ ;; handler should set vc-backend and return t if registered
+ (funcall handler 'vc-registered file))
+ (t
+ ;; There is no file name handler.
+ ;; Try vc-BACKEND-registered for each handled BACKEND.
+ (catch 'found
+ (let ((backend (vc-file-getprop file 'vc-backend)))
+ (mapc
+ (lambda (b)
+ (and (vc-call-backend b 'registered file)
+ (vc-file-setprop file 'vc-backend b)
+ (throw 'found t)))
+ (if (or (not backend) (eq backend 'none))
+ vc-handled-backends
+ (cons backend vc-handled-backends))))
+ ;; File is not registered.
+ (vc-file-setprop file 'vc-backend 'none)
+ nil)))))
+
+(defun vc-backend (file-or-list)
+ "Return the version control type of FILE-OR-LIST, nil if it's not registered.
+If the argument is a list, the files must all have the same back end."
+ ;; `file' can be nil in several places (typically due to the use of
+ ;; code like (vc-backend buffer-file-name)).
+ (cond ((stringp file-or-list)
+ (let ((property (vc-file-getprop file-or-list 'vc-backend)))
+ ;; Note that internally, Emacs remembers unregistered
+ ;; files by setting the property to `none'.
+ (cond ((eq property 'none) nil)
+ (property)
+ ;; vc-registered sets the vc-backend property
+ (t (if (vc-registered file-or-list)
+ (vc-file-getprop file-or-list 'vc-backend)
+ nil)))))
+ ((and file-or-list (listp file-or-list))
+ (vc-backend (car file-or-list)))
+ (t
+ nil)))
+
+
+(defun vc-backend-subdirectory-name (file)
+ "Return where the repository for the current directory is kept."
+ (symbol-name (vc-backend file)))
+
+(defun vc-name (file)
+ "Return the master name of FILE.
+If the file is not registered, or the master name is not known, return nil."
+ ;; TODO: This should ultimately become obsolete, at least up here
+ ;; in vc-hooks.
+ (or (vc-file-getprop file 'vc-name)
+ ;; force computation of the property by calling
+ ;; vc-BACKEND-registered explicitly
+ (let ((backend (vc-backend file)))
+ (if (and backend
+ (vc-call-backend backend 'registered file))
+ (vc-file-getprop file 'vc-name)))))
+
+(defun vc-checkout-model (backend files)
+ "Indicate how FILES are checked out.
+
+If FILES are not registered, this function always returns nil.
+For registered files, the possible values are:
+
+ 'implicit FILES are always writable, and checked out `implicitly'
+ when the user saves the first changes to the file.
+
+ 'locking FILES are read-only if up-to-date; user must type
+ \\[vc-next-action] before editing. Strict locking
+ is assumed.
+
+ 'announce FILES are read-only if up-to-date; user must type
+ \\[vc-next-action] before editing. But other users
+ may be editing at the same time."
+ (vc-call-backend backend 'checkout-model files))
+
+(defun vc-user-login-name (file)
+ "Return the name under which the user accesses the given FILE."
+ (or (and (eq (string-match tramp-file-name-regexp file) 0)
+ ;; tramp case: execute "whoami" via tramp
+ (let ((default-directory (file-name-directory file))
+ process-file-side-effects)
+ (with-temp-buffer
+ (if (not (zerop (process-file "whoami" nil t)))
+ ;; fall through if "whoami" didn't work
+ nil
+ ;; remove trailing newline
+ (delete-region (1- (point-max)) (point-max))
+ (buffer-string)))))
+ ;; normal case
+ (user-login-name)
+ ;; if user-login-name is nil, return the UID as a string
+ (number-to-string (user-uid))))
+
+(defun vc-state (file &optional backend)
+ "Return the version control state of FILE.
+
+If FILE is not registered, this function always returns nil.
+For registered files, the value returned is one of:
+
+ 'up-to-date The working file is unmodified with respect to the
+ latest version on the current branch, and not locked.
+
+ 'edited The working file has been edited by the user. If
+ locking is used for the file, this state means that
+ the current version is locked by the calling user.
+ This status should *not* be reported for files
+ which have a changed mtime but the same content
+ as the repo copy.
+
+ USER The current version of the working file is locked by
+ some other USER (a string).
+
+ 'needs-update The file has not been edited by the user, but there is
+ a more recent version on the current branch stored
+ in the repository.
+
+ 'needs-merge The file has been edited by the user, and there is also
+ a more recent version on the current branch stored in
+ the repository. This state can only occur if locking
+ is not used for the file.
+
+ 'unlocked-changes The working version of the file is not locked,
+ but the working file has been changed with respect
+ to that version. This state can only occur for files
+ with locking; it represents an erroneous condition that
+ should be resolved by the user (vc-next-action will
+ prompt the user to do it).
+
+ 'added Scheduled to go into the repository on the next commit.
+ Often represented by vc-working-revision = \"0\" in VCSes
+ with monotonic IDs like Subversion and Mercurial.
+
+ 'removed Scheduled to be deleted from the repository on next commit.
+
+ 'conflict The file contains conflicts as the result of a merge.
+ For now the conflicts are text conflicts. In the
+ future this might be extended to deal with metadata
+ conflicts too.
+
+ 'missing The file is not present in the file system, but the VC
+ system still tracks it.
+
+ 'ignored The file showed up in a dir-status listing with a flag
+ indicating the version-control system is ignoring it,
+ Note: This property is not set reliably (some VCSes
+ don't have useful directory-status commands) so assume
+ that any file with vc-state nil might be ignorable
+ without VC knowing it.
+
+ 'unregistered The file is not under version control.
+
+A return of nil from this function means we have no information on the
+status of this file."
+ ;; Note: in Emacs 22 and older, return of nil meant the file was
+ ;; unregistered. This is potentially a source of
+ ;; backward-compatibility bugs.
+
+ ;; FIXME: New (sub)states needed (?):
+ ;; - `copied' and `moved' (might be handled by `removed' and `added')
+ (or (vc-file-getprop file 'vc-state)
+ (when (> (length file) 0) ;Why?? --Stef
+ (setq backend (or backend (vc-backend file)))
+ (when backend
+ (vc-state-refresh file backend)))))
+
+(defun vc-state-refresh (file backend)
+ "Quickly recompute the `state' of FILE."
+ (vc-file-setprop
+ file 'vc-state
+ (vc-call-backend backend 'state-heuristic file)))
+
+(defsubst vc-up-to-date-p (file)
+ "Convenience function that checks whether `vc-state' of FILE is `up-to-date'."
+ (eq (vc-state file) 'up-to-date))
+
+(defun vc-default-state-heuristic (backend file)
+ "Default implementation of vc-BACKEND-state-heuristic.
+It simply calls the real state computation function `vc-BACKEND-state'
+and does not employ any heuristic at all."
+ (vc-call-backend backend 'state file))
+
+(defun vc-workfile-unchanged-p (file)
+ "Return non-nil if FILE has not changed since the last checkout."
+ (let ((checkout-time (vc-file-getprop file 'vc-checkout-time))
+ (lastmod (nth 5 (file-attributes file))))
+ ;; This is a shortcut for determining when the workfile is
+ ;; unchanged. It can fail under some circumstances; see the
+ ;; discussion in bug#694.
+ (if (and checkout-time
+ ;; Tramp and Ange-FTP return this when they don't know the time.
+ (not (equal lastmod '(0 0))))
+ (equal checkout-time lastmod)
+ (let ((unchanged (vc-call workfile-unchanged-p file)))
+ (vc-file-setprop file 'vc-checkout-time (if unchanged lastmod 0))
+ unchanged))))
+
+(defun vc-default-workfile-unchanged-p (backend file)
+ "Check if FILE is unchanged by diffing against the repository version.
+Return non-nil if FILE is unchanged."
+ (zerop (condition-case err
+ ;; If the implementation supports it, let the output
+ ;; go to *vc*, not *vc-diff*, since this is an internal call.
+ (vc-call-backend backend 'diff (list file) nil nil "*vc*")
+ (wrong-number-of-arguments
+ ;; If this error came from the above call to vc-BACKEND-diff,
+ ;; try again without the optional buffer argument (for
+ ;; backward compatibility). Otherwise, resignal.
+ (if (or (not (eq (cadr err)
+ (indirect-function
+ (vc-find-backend-function backend 'diff))))
+ (not (eq (caddr err) 4)))
+ (signal (car err) (cdr err))
+ (vc-call-backend backend 'diff (list file)))))))
+
+(defun vc-working-revision (file &optional backend)
+ "Return the repository version from which FILE was checked out.
+If FILE is not registered, this function always returns nil."
+ (or (vc-file-getprop file 'vc-working-revision)
+ (progn
+ (setq backend (or backend (vc-backend file)))
+ (when backend
+ (vc-file-setprop file 'vc-working-revision
+ (vc-call-backend backend 'working-revision file))))))
+
+;; Backward compatibility.
+(define-obsolete-function-alias
+ 'vc-workfile-version 'vc-working-revision "23.1")
+(defun vc-default-working-revision (backend file)
+ (message
+ "`working-revision' not found: using the old `workfile-version' instead")
+ (vc-call-backend backend 'workfile-version file))
+
+(defun vc-default-registered (backend file)
+ "Check if FILE is registered in BACKEND using vc-BACKEND-master-templates."
+ (let ((sym (vc-make-backend-sym backend 'master-templates)))
+ (unless (get backend 'vc-templates-grabbed)
+ (put backend 'vc-templates-grabbed t)
+ (set sym (append (delq nil
+ (mapcar
+ (lambda (template)
+ (and (consp template)
+ (eq (cdr template) backend)
+ (car template)))
+ (with-no-warnings
+ vc-master-templates)))
+ (symbol-value sym))))
+ (let ((result (vc-check-master-templates file (symbol-value sym))))
+ (if (stringp result)
+ (vc-file-setprop file 'vc-name result)
+ nil)))) ; Not registered
+
+(defun vc-possible-master (s dirname basename)
+ (cond
+ ((stringp s) (format s dirname basename))
+ ((functionp s)
+ ;; The template is a function to invoke. If the
+ ;; function returns non-nil, that means it has found a
+ ;; master. For backward compatibility, we also handle
+ ;; the case that the function throws a 'found atom
+ ;; and a pair (cons MASTER-FILE BACKEND).
+ (let ((result (catch 'found (funcall s dirname basename))))
+ (if (consp result) (car result) result)))))
+
+(defun vc-check-master-templates (file templates)
+ "Return non-nil if there is a master corresponding to FILE.
+
+TEMPLATES is a list of strings or functions. If an element is a
+string, it must be a control string as required by `format', with two
+string placeholders, such as \"%sRCS/%s,v\". The directory part of
+FILE is substituted for the first placeholder, the basename of FILE
+for the second. If a file with the resulting name exists, it is taken
+as the master of FILE, and returned.
+
+If an element of TEMPLATES is a function, it is called with the
+directory part and the basename of FILE as arguments. It should
+return non-nil if it finds a master; that value is then returned by
+this function."
+ (let ((dirname (or (file-name-directory file) ""))
+ (basename (file-name-nondirectory file)))
+ (catch 'found
+ (mapcar
+ (lambda (s)
+ (let ((trial (vc-possible-master s dirname basename)))
+ (when (and trial (file-exists-p trial)
+ ;; Make sure the file we found with name
+ ;; TRIAL is not the source file itself.
+ ;; That can happen with RCS-style names if
+ ;; the file name is truncated (e.g. to 14
+ ;; chars). See if either directory or
+ ;; attributes differ.
+ (or (not (string= dirname
+ (file-name-directory trial)))
+ (not (equal (file-attributes file)
+ (file-attributes trial)))))
+ (throw 'found trial))))
+ templates))))
+
+(defun vc-toggle-read-only (&optional verbose)
+ "Change read-only status of current buffer, perhaps via version control.
+
+If the buffer is visiting a file registered with version control,
+throw an error, because this is not a safe or really meaningful operation
+on any version-control system newer than RCS.
+
+Otherwise, just change the read-only flag of the buffer.
+
+If you bind this function to \\[toggle-read-only], then Emacs
+will properly intercept all attempts to toggle the read-only flag
+on version-controlled buffer."
+ (interactive "P")
+ (if (vc-backend buffer-file-name)
+ (error "Toggling the readability of a version controlled file is likely to wreak havoc")
+ (toggle-read-only)))
+
+(defun vc-default-make-version-backups-p (backend file)
+ "Return non-nil if unmodified versions should be backed up locally.
+The default is to switch off this feature."
+ nil)
+
+(defun vc-version-backup-file-name (file &optional rev manual regexp)
+ "Return a backup file name for REV or the current version of FILE.
+If MANUAL is non-nil it means that a name for backups created by
+the user should be returned; if REGEXP is non-nil that means to return
+a regexp for matching all such backup files, regardless of the version."
+ (if regexp
+ (concat (regexp-quote (file-name-nondirectory file))
+ "\\.~.+" (unless manual "\\.") "~")
+ (expand-file-name (concat (file-name-nondirectory file)
+ ".~" (subst-char-in-string
+ ?/ ?_ (or rev (vc-working-revision file)))
+ (unless manual ".") "~")
+ (file-name-directory file))))
+
+(defun vc-delete-automatic-version-backups (file)
+ "Delete all existing automatic version backups for FILE."
+ (condition-case nil
+ (mapc
+ 'delete-file
+ (directory-files (or (file-name-directory file) default-directory) t
+ (vc-version-backup-file-name file nil nil t)))
+ ;; Don't fail when the directory doesn't exist.
+ (file-error nil)))
+
+(defun vc-make-version-backup (file)
+ "Make a backup copy of FILE, which is assumed in sync with the repository.
+Before doing that, check if there are any old backups and get rid of them."
+ (unless (and (fboundp 'msdos-long-file-names)
+ (not (with-no-warnings (msdos-long-file-names))))
+ (vc-delete-automatic-version-backups file)
+ (condition-case nil
+ (copy-file file (vc-version-backup-file-name file)
+ nil 'keep-date)
+ ;; It's ok if it doesn't work (e.g. directory not writable),
+ ;; since this is just for efficiency.
+ (file-error
+ (message
+ (concat "Warning: Cannot make version backup; "
+ "diff/revert therefore not local"))))))
+
+(defun vc-before-save ()
+ "Function to be called by `basic-save-buffer' (in files.el)."
+ ;; If the file on disk is still in sync with the repository,
+ ;; and version backups should be made, copy the file to
+ ;; another name. This enables local diffs and local reverting.
+ (let ((file buffer-file-name)
+ backend)
+ (ignore-errors ;Be careful not to prevent saving the file.
+ (and (setq backend (vc-backend file))
+ (vc-up-to-date-p file)
+ (eq (vc-checkout-model backend (list file)) 'implicit)
+ (vc-call-backend backend 'make-version-backups-p file)
+ (vc-make-version-backup file)))))
+
+(declare-function vc-dir-resynch-file "vc-dir" (&optional fname))
+
+(defvar vc-dir-buffers nil "List of vc-dir buffers.")
+
+(defun vc-after-save ()
+ "Function to be called by `basic-save-buffer' (in files.el)."
+ ;; If the file in the current buffer is under version control,
+ ;; up-to-date, and locking is not used for the file, set
+ ;; the state to 'edited and redisplay the mode line.
+ (let* ((file buffer-file-name)
+ (backend (vc-backend file)))
+ (and backend
+ (or (and (equal (vc-file-getprop file 'vc-checkout-time)
+ (nth 5 (file-attributes file)))
+ ;; File has been saved in the same second in which
+ ;; it was checked out. Clear the checkout-time
+ ;; to avoid confusion.
+ (vc-file-setprop file 'vc-checkout-time nil))
+ t)
+ (eq (vc-checkout-model backend (list file)) 'implicit)
+ (vc-state-refresh file backend)
+ (vc-mode-line file backend))
+ ;; Try to avoid unnecessary work, a *vc-dir* buffer is
+ ;; present if this is true.
+ (when vc-dir-buffers
+ (vc-dir-resynch-file file))))
+
+(defvar vc-menu-entry
+ `(menu-item ,(purecopy "Version Control") vc-menu-map
+ :filter vc-menu-map-filter))
+
+(when (boundp 'menu-bar-tools-menu)
+ ;; We do not need to worry here about the placement of this entry
+ ;; because menu-bar.el has already created the proper spot for us
+ ;; and this will simply use it.
+ (define-key menu-bar-tools-menu [vc] vc-menu-entry))
+
+(defconst vc-mode-line-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [mode-line down-mouse-1] vc-menu-entry)
+ map))
+
+(defun vc-mode-line (file &optional backend)
+ "Set `vc-mode' to display type of version control for FILE.
+The value is set in the current buffer, which should be the buffer
+visiting FILE.
+If BACKEND is passed use it as the VC backend when computing the result."
+ (interactive (list buffer-file-name))
+ (setq backend (or backend (vc-backend file)))
+ (if (not backend)
+ (setq vc-mode nil)
+ (let* ((ml-string (vc-call-backend backend 'mode-line-string file))
+ (ml-echo (get-text-property 0 'help-echo ml-string)))
+ (setq vc-mode
+ (concat
+ " "
+ (if (null vc-display-status)
+ (symbol-name backend)
+ (propertize
+ ml-string
+ 'mouse-face 'mode-line-highlight
+ 'help-echo
+ (concat (or ml-echo
+ (format "File under the %s version control system"
+ backend))
+ "\nmouse-1: Version Control menu")
+ 'local-map vc-mode-line-map)))))
+ ;; If the user is root, and the file is not owner-writable,
+ ;; then pretend that we can't write it
+ ;; even though we can (because root can write anything).
+ ;; This way, even root cannot modify a file that isn't locked.
+ (and (equal file buffer-file-name)
+ (not buffer-read-only)
+ (zerop (user-real-uid))
+ (zerop (logand (file-modes buffer-file-name) 128))
+ (setq buffer-read-only t)))
+ (force-mode-line-update)
+ backend)
+
+(defun vc-default-mode-line-string (backend file)
+ "Return string for placement in modeline by `vc-mode-line' for FILE.
+Format:
+
+ \"BACKEND-REV\" if the file is up-to-date
+ \"BACKEND:REV\" if the file is edited (or locked by the calling user)
+ \"BACKEND:LOCKER:REV\" if the file is locked by somebody else
+ \"BACKEND@REV\" if the file was locally added
+ \"BACKEND!REV\" if the file contains conflicts or was removed
+ \"BACKEND?REV\" if the file is under VC, but is missing
+
+This function assumes that the file is registered."
+ (let* ((backend-name (symbol-name backend))
+ (state (vc-state file backend))
+ (state-echo nil)
+ (rev (vc-working-revision file backend)))
+ (propertize
+ (cond ((or (eq state 'up-to-date)
+ (eq state 'needs-update))
+ (setq state-echo "Up to date file")
+ (concat backend-name "-" rev))
+ ((stringp state)
+ (setq state-echo (concat "File locked by" state))
+ (concat backend-name ":" state ":" rev))
+ ((eq state 'added)
+ (setq state-echo "Locally added file")
+ (concat backend-name "@" rev))
+ ((eq state 'conflict)
+ (setq state-echo "File contains conflicts after the last merge")
+ (concat backend-name "!" rev))
+ ((eq state 'removed)
+ (setq state-echo "File removed from the VC system")
+ (concat backend-name "!" rev))
+ ((eq state 'missing)
+ (setq state-echo "File tracked by the VC system, but missing from the file system")
+ (concat backend-name "?" rev))
+ (t
+ ;; Not just for the 'edited state, but also a fallback
+ ;; for all other states. Think about different symbols
+ ;; for 'needs-update and 'needs-merge.
+ (setq state-echo "Locally modified file")
+ (concat backend-name ":" rev)))
+ 'help-echo (concat state-echo " under the " backend-name
+ " version control system"))))
+
+(defun vc-follow-link ()
+ "If current buffer visits a symbolic link, visit the real file.
+If the real file is already visited in another buffer, make that buffer
+current, and kill the buffer that visits the link."
+ (let* ((true-buffer (find-buffer-visiting buffer-file-truename))
+ (this-buffer (current-buffer)))
+ (if (eq true-buffer this-buffer)
+ (let ((truename buffer-file-truename))
+ (kill-buffer this-buffer)
+ ;; In principle, we could do something like set-visited-file-name.
+ ;; However, it can't be exactly the same as set-visited-file-name.
+ ;; I'm not going to work out the details right now. -- rms.
+ (set-buffer (find-file-noselect truename)))
+ (set-buffer true-buffer)
+ (kill-buffer this-buffer))))
+
+(defun vc-default-find-file-hook (backend)
+ nil)
+
+(defun vc-find-file-hook ()
+ "Function for `find-file-hook' activating VC mode if appropriate."
+ ;; Recompute whether file is version controlled,
+ ;; if user has killed the buffer and revisited.
+ (when vc-mode
+ (setq vc-mode nil))
+ (when buffer-file-name
+ (vc-file-clearprops buffer-file-name)
+ ;; FIXME: Why use a hook? Why pass it buffer-file-name?
+ (add-hook 'vc-mode-line-hook 'vc-mode-line nil t)
+ (let (backend)
+ (cond
+ ((setq backend (with-demoted-errors (vc-backend buffer-file-name)))
+ ;; Compute the state and put it in the modeline.
+ (vc-mode-line buffer-file-name backend)
+ (unless vc-make-backup-files
+ ;; Use this variable, not make-backup-files,
+ ;; because this is for things that depend on the file name.
+ (set (make-local-variable 'backup-inhibited) t))
+ ;; Let the backend setup any buffer-local things he needs.
+ (vc-call-backend backend 'find-file-hook))
+ ((let ((link-type (and (not (equal buffer-file-name buffer-file-truename))
+ (vc-backend buffer-file-truename))))
+ (cond ((not link-type) nil) ;Nothing to do.
+ ((eq vc-follow-symlinks nil)
+ (message
+ "Warning: symbolic link to %s-controlled source file" link-type))
+ ((or (not (eq vc-follow-symlinks 'ask))
+ ;; If we already visited this file by following
+ ;; the link, don't ask again if we try to visit
+ ;; it again. GUD does that, and repeated questions
+ ;; are painful.
+ (get-file-buffer
+ (abbreviate-file-name
+ (file-chase-links buffer-file-name))))
+
+ (vc-follow-link)
+ (message "Followed link to %s" buffer-file-name)
+ (vc-find-file-hook))
+ (t
+ (if (yes-or-no-p (format
+ "Symbolic link to %s-controlled source file; follow link? " link-type))
+ (progn (vc-follow-link)
+ (message "Followed link to %s" buffer-file-name)
+ (vc-find-file-hook))
+ (message
+ "Warning: editing through the link bypasses version control")
+ )))))))))
+
+(add-hook 'find-file-hook 'vc-find-file-hook)
+
+(defun vc-kill-buffer-hook ()
+ "Discard VC info about a file when we kill its buffer."
+ (when buffer-file-name (vc-file-clearprops buffer-file-name)))
+
+(add-hook 'kill-buffer-hook 'vc-kill-buffer-hook)
+
+;; Now arrange for (autoloaded) bindings of the main package.
+;; Bindings for this have to go in the global map, as we'll often
+;; want to call them from random buffers.
+
+;; Autoloading works fine, but it prevents shortcuts from appearing
+;; in the menu because they don't exist yet when the menu is built.
+;; (autoload 'vc-prefix-map "vc" nil nil 'keymap)
+(defvar vc-prefix-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "a" 'vc-update-change-log)
+ (define-key map "b" 'vc-switch-backend)
+ (define-key map "c" 'vc-rollback)
+ (define-key map "d" 'vc-dir)
+ (define-key map "g" 'vc-annotate)
+ (define-key map "h" 'vc-insert-headers)
+ (define-key map "i" 'vc-register)
+ (define-key map "l" 'vc-print-log)
+ (define-key map "L" 'vc-print-root-log)
+ (define-key map "I" 'vc-log-incoming)
+ (define-key map "O" 'vc-log-outgoing)
+ (define-key map "m" 'vc-merge)
+ (define-key map "r" 'vc-retrieve-tag)
+ (define-key map "s" 'vc-create-tag)
+ (define-key map "u" 'vc-revert)
+ (define-key map "v" 'vc-next-action)
+ (define-key map "+" 'vc-update)
+ (define-key map "=" 'vc-diff)
+ (define-key map "D" 'vc-root-diff)
+ (define-key map "~" 'vc-revision-other-window)
+ map))
+(fset 'vc-prefix-map vc-prefix-map)
+(define-key global-map "\C-xv" 'vc-prefix-map)
+
+(defvar vc-menu-map
+ (let ((map (make-sparse-keymap "Version Control")))
+ ;;(define-key map [show-files]
+ ;; '("Show Files under VC" . (vc-directory t)))
+ (define-key map [vc-retrieve-tag]
+ `(menu-item ,(purecopy "Retrieve Tag") vc-retrieve-tag
+ :help ,(purecopy "Retrieve tagged version or branch")))
+ (define-key map [vc-create-tag]
+ `(menu-item ,(purecopy "Create Tag") vc-create-tag
+ :help ,(purecopy "Create version tag")))
+ (define-key map [separator1] menu-bar-separator)
+ (define-key map [vc-annotate]
+ `(menu-item ,(purecopy "Annotate") vc-annotate
+ :help ,(purecopy "Display the edit history of the current file using colors")))
+ (define-key map [vc-rename-file]
+ `(menu-item ,(purecopy "Rename File") vc-rename-file
+ :help ,(purecopy "Rename file")))
+ (define-key map [vc-revision-other-window]
+ `(menu-item ,(purecopy "Show Other Version") vc-revision-other-window
+ :help ,(purecopy "Visit another version of the current file in another window")))
+ (define-key map [vc-diff]
+ `(menu-item ,(purecopy "Compare with Base Version") vc-diff
+ :help ,(purecopy "Compare file set with the base version")))
+ (define-key map [vc-root-diff]
+ `(menu-item ,(purecopy "Compare Tree with Base Version") vc-root-diff
+ :help ,(purecopy "Compare current tree with the base version")))
+ (define-key map [vc-update-change-log]
+ `(menu-item ,(purecopy "Update ChangeLog") vc-update-change-log
+ :help ,(purecopy "Find change log file and add entries from recent version control logs")))
+ (define-key map [vc-log-out]
+ `(menu-item ,(purecopy "Show Outgoing Log") vc-log-outgoing
+ :help ,(purecopy "Show a log of changes that will be sent with a push operation")))
+ (define-key map [vc-log-in]
+ `(menu-item ,(purecopy "Show Incoming Log") vc-log-incoming
+ :help ,(purecopy "Show a log of changes that will be received with a pull operation")))
+ (define-key map [vc-print-log]
+ `(menu-item ,(purecopy "Show History") vc-print-log
+ :help ,(purecopy "List the change log of the current file set in a window")))
+ (define-key map [vc-print-root-log]
+ `(menu-item ,(purecopy "Show Top of the Tree History ") vc-print-root-log
+ :help ,(purecopy "List the change log for the current tree in a window")))
+ (define-key map [separator2] menu-bar-separator)
+ (define-key map [vc-insert-header]
+ `(menu-item ,(purecopy "Insert Header") vc-insert-headers
+ :help ,(purecopy "Insert headers into a file for use with a version control system.
+")))
+ (define-key map [undo]
+ `(menu-item ,(purecopy "Undo Last Check-In") vc-rollback
+ :help ,(purecopy "Remove the most recent changeset committed to the repository")))
+ (define-key map [vc-revert]
+ `(menu-item ,(purecopy "Revert to Base Version") vc-revert
+ :help ,(purecopy "Revert working copies of the selected file set to their repository contents")))
+ (define-key map [vc-update]
+ `(menu-item ,(purecopy "Update to Latest Version") vc-update
+ :help ,(purecopy "Update the current fileset's files to their tip revisions")))
+ (define-key map [vc-next-action]
+ `(menu-item ,(purecopy "Check In/Out") vc-next-action
+ :help ,(purecopy "Do the next logical version control operation on the current fileset")))
+ (define-key map [vc-register]
+ `(menu-item ,(purecopy "Register") vc-register
+ :help ,(purecopy "Register file set into a version control system")))
+ (define-key map [vc-dir]
+ `(menu-item ,(purecopy "VC Dir") vc-dir
+ :help ,(purecopy "Show the VC status of files in a directory")))
+ map))
+
+(defalias 'vc-menu-map vc-menu-map)
+
+(declare-function vc-responsible-backend "vc" (file))
+
+(defun vc-menu-map-filter (orig-binding)
+ (if (and (symbolp orig-binding) (fboundp orig-binding))
+ (setq orig-binding (indirect-function orig-binding)))
+ (let ((ext-binding
+ (when vc-mode
+ (vc-call-backend
+ (if buffer-file-name
+ (vc-backend buffer-file-name)
+ (vc-responsible-backend default-directory))
+ 'extra-menu))))
+ ;; Give the VC backend a chance to add menu entries
+ ;; specific for that backend.
+ (if (null ext-binding)
+ orig-binding
+ (append orig-binding
+ '((ext-menu-separator "--"))
+ ext-binding))))
+
+(defun vc-default-extra-menu (backend)
+ nil)
+
+(provide 'vc-hooks)
+
+;; arch-tag: 2e5a6fa7-1d30-48e2-8bd0-e3d335f04f32
+;;; vc-hooks.el ends here
--- /dev/null
- ;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;;; vc-mtn.el --- VC backend for Monotone
+
++;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; Keywords: vc
+;; Package: 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 <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;
+
+;;; TODO:
+
+;; - The `previous-version' VC method needs to be supported, 'D' in
+;; log-view-mode uses it.
+
+;;; Code:
+
+(eval-when-compile (require 'cl) (require 'vc))
+
+(defcustom vc-mtn-diff-switches t
+ "String or list of strings specifying switches for monotone diff under VC.
+If nil, use the value of `vc-diff-switches'. If t, use no switches."
+ :type '(choice (const :tag "Unspecified" nil)
+ (const :tag "None" t)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List" :value ("") string))
+ :version "23.1"
+ :group 'vc)
+
+(define-obsolete-variable-alias 'vc-mtn-command 'vc-mtn-program "23.1")
+(defcustom vc-mtn-program "mtn"
+ "Name of the monotone executable."
+ :type 'string
+ :group 'vc)
+
+;; Clear up the cache to force vc-call to check again and discover
+;; new functions when we reload this file.
+(put 'Mtn 'vc-functions nil)
+
+(unless (executable-find vc-mtn-program)
+ ;; vc-mtn.el is 100% non-functional without the `mtn' executable.
+ (setq vc-handled-backends (delq 'Mtn vc-handled-backends)))
+
+;;;###autoload
+(defconst vc-mtn-admin-dir "_MTN")
+;;;###autoload
+(defconst vc-mtn-admin-format (concat vc-mtn-admin-dir "/format"))
+
+;;;###autoload (defun vc-mtn-registered (file)
+;;;###autoload (if (vc-find-root file vc-mtn-admin-format)
+;;;###autoload (progn
+;;;###autoload (load "vc-mtn")
+;;;###autoload (vc-mtn-registered file))))
+
+(defun vc-mtn-revision-granularity () 'repository)
+(defun vc-mtn-checkout-model (files) 'implicit)
+
+(defun vc-mtn-root (file)
+ (setq file (if (file-directory-p file)
+ (file-name-as-directory file)
+ (file-name-directory file)))
+ (or (vc-file-getprop file 'vc-mtn-root)
+ (vc-file-setprop file 'vc-mtn-root
+ (vc-find-root file vc-mtn-admin-format))))
+
+
+(defun vc-mtn-registered (file)
+ (let ((root (vc-mtn-root file)))
+ (when root
+ (vc-mtn-state file))))
+
+(defun vc-mtn-command (buffer okstatus files &rest flags)
+ "A wrapper around `vc-do-command' for use in vc-mtn.el."
+ (let ((process-environment
+ ;; Avoid localization of messages so we can parse the output.
+ (cons "LC_MESSAGES=C" process-environment)))
+ (apply 'vc-do-command (or buffer "*vc*") okstatus vc-mtn-program
+ files flags)))
+
+(defun vc-mtn-state (file)
+ ;; If `mtn' fails or returns status>0, or if the search files, just
+ ;; return nil.
+ (ignore-errors
+ (with-temp-buffer
+ (vc-mtn-command t 0 file "status")
+ (goto-char (point-min))
+ (re-search-forward
+ "^ \\(?:\\(patched\\)\\|\\(added\\) \\(?:.*\\)\\)\\|no changes$")
+ (cond ((match-end 1) 'edited)
+ ((match-end 2) 'added)
+ (t 'up-to-date)))))
+
+(defun vc-mtn-after-dir-status (update-function)
+ (let (result)
+ (goto-char (point-min))
+ (re-search-forward "\\(?:Current b\\|B\\)ranch: *\\(.*\\)\n?\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 b\\|B\\)ranch: *\\(.*\\)\n?\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 b\\|B\\)ranch: *\\(.*\\)\n?\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)
+ (apply 'vc-mtn-command nil 0 files
+ (nconc (list "commit" "-m")
+ (log-edit-extract-headers '(("Author" . "--author")
+ ("Date" . "--date"))
+ comment))))
+
+(defun vc-mtn-find-revision (file rev buffer)
+ (vc-mtn-command buffer 0 file "cat" "-r" rev))
+
+;; (defun vc-mtn-checkout (file &optional editable rev)
+;; )
+
+(defun vc-mtn-revert (file &optional contents-done)
+ (unless contents-done
+ (vc-mtn-command nil 0 file "revert")))
+
+;; (defun vc-mtn-roolback (files)
+;; )
+
+(defun vc-mtn-print-log (files buffer &optional shortlog start-revision limit)
+ (apply 'vc-mtn-command buffer 0 files "log"
+ (append
+ (when start-revision (list "--from" (format "%s" start-revision)))
+ (when limit (list "--last" (format "%s" limit))))))
+
+(defvar log-view-message-re)
+(defvar log-view-file-re)
+(defvar log-view-font-lock-keywords)
+(defvar log-view-per-file-logs)
+
+(define-derived-mode vc-mtn-log-view-mode log-view-mode "Mtn-Log-View"
+ ;; Don't match anything.
+ (set (make-local-variable 'log-view-file-re) "\\`a\\`")
+ (set (make-local-variable 'log-view-per-file-logs) nil)
+ ;; TODO: Use a more precise regexp than "[ |/]+" to avoid false positives
+ ;; in the ChangeLog text.
+ (set (make-local-variable 'log-view-message-re)
+ "^[ |/]+Revision: \\([0-9a-f]+\\)")
+ (require 'add-log) ;For change-log faces.
+ (set (make-local-variable 'log-view-font-lock-keywords)
+ (append log-view-font-lock-keywords
+ '(("^[ |]+Author: \\(.*\\)" (1 'change-log-email))
+ ("^[ |]+Date: \\(.*\\)" (1 'change-log-date-face))))))
+
+;; (defun vc-mtn-show-log-entry (revision)
+;; )
+
+(defun vc-mtn-diff (files &optional rev1 rev2 buffer)
+ "Get a difference report using monotone between two revisions of FILES."
+ (apply 'vc-mtn-command (or buffer "*vc-diff*") 1 files "diff"
+ (append
+ (vc-switches 'mtn 'diff)
+ (if rev1 (list "-r" rev1)) (if rev2 (list "-r" rev2)))))
+
+(defun vc-mtn-annotate-command (file buf &optional rev)
+ (apply 'vc-mtn-command buf 'async file "annotate"
+ (if rev (list "-r" rev))))
+
+(declare-function vc-annotate-convert-time "vc-annotate" (time))
+
+(defconst vc-mtn-annotate-full-re
+ "^ *\\([0-9a-f]+\\)\\.* by [^ ]+ \\([0-9]+\\)-\\([0-9]+\\)-\\([0-9]+\\): ")
+(defconst vc-mtn-annotate-any-re
+ (concat "^\\(?: +: \\|" vc-mtn-annotate-full-re "\\)"))
+
+(defun vc-mtn-annotate-time ()
+ (when (looking-at vc-mtn-annotate-any-re)
+ (goto-char (match-end 0))
+ (let ((year (match-string 2)))
+ (if (not year)
+ ;; Look for the date on a previous line.
+ (save-excursion
+ (get-text-property (1- (previous-single-property-change
+ (point) 'vc-mtn-time nil (point-min)))
+ 'vc-mtn-time))
+ (let ((time (vc-annotate-convert-time
+ (encode-time 0 0 0
+ (string-to-number (match-string 4))
+ (string-to-number (match-string 3))
+ (string-to-number year)
+ t))))
+ (let ((inhibit-read-only t)
+ (inhibit-modification-hooks t))
+ (put-text-property (match-beginning 0) (match-end 0)
+ 'vc-mtn-time time))
+ time)))))
+
+(defun vc-mtn-annotate-extract-revision-at-line ()
+ (save-excursion
+ (when (or (looking-at vc-mtn-annotate-full-re)
+ (re-search-backward vc-mtn-annotate-full-re nil t))
+ (match-string 1))))
+
+;;; Revision completion.
+
+(defun vc-mtn-list-tags ()
+ (with-temp-buffer
+ (vc-mtn-command t 0 nil "list" "tags")
+ (goto-char (point-min))
+ (let ((tags ()))
+ (while (re-search-forward "^[^ ]+" nil t)
+ (push (match-string 0) tags))
+ tags)))
+
+(defun vc-mtn-list-branches ()
+ (with-temp-buffer
+ (vc-mtn-command t 0 nil "list" "branches")
+ (goto-char (point-min))
+ (let ((branches ()))
+ (while (re-search-forward "^.+" nil t)
+ (push (match-string 0) branches))
+ branches)))
+
+(defun vc-mtn-list-revision-ids (prefix)
+ (with-temp-buffer
+ (vc-mtn-command t 0 nil "complete" "revision" prefix)
+ (goto-char (point-min))
+ (let ((ids ()))
+ (while (re-search-forward "^.+" nil t)
+ (push (match-string 0) ids))
+ ids)))
+
+(defun vc-mtn-revision-completion-table (files)
+ ;; TODO: Implement completion for for selectors
+ ;; TODO: Implement completion for composite selectors.
+ (lexical-let ((files files))
+ ;; What about using `files'?!? --Stef
+ (lambda (string pred action)
+ (cond
+ ;; "Tag" selectors.
+ ((string-match "\\`t:" string)
+ (complete-with-action action
+ (mapcar (lambda (tag) (concat "t:" tag))
+ (vc-mtn-list-tags))
+ string pred))
+ ;; "Branch" selectors.
+ ((string-match "\\`b:" string)
+ (complete-with-action action
+ (mapcar (lambda (tag) (concat "b:" tag))
+ (vc-mtn-list-branches))
+ string pred))
+ ;; "Head" selectors. Not sure how they differ from "branch" selectors.
+ ((string-match "\\`h:" string)
+ (complete-with-action action
+ (mapcar (lambda (tag) (concat "h:" tag))
+ (vc-mtn-list-branches))
+ string pred))
+ ;; "ID" selectors.
+ ((string-match "\\`i:" string)
+ (complete-with-action action
+ (mapcar (lambda (tag) (concat "i:" tag))
+ (vc-mtn-list-revision-ids
+ (substring string (match-end 0))))
+ string pred))
+ (t
+ (complete-with-action action
+ '("t:" "b:" "h:" "i:"
+ ;; Completion not implemented for these.
+ "a:" "c:" "d:" "e:" "l:")
+ string pred))))))
+
+
+
+(provide 'vc-mtn)
+
+;; arch-tag: 2b89ffbc-cbb8-405a-9080-2eafd4becb70
+;;; vc-mtn.el ends here
--- /dev/null
- ;; 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;;; 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, 2011
+;; Free Software Foundation, Inc.
+
+;; Author: FSF (see vc.el for full credits)
+;; Maintainer: Andre Spiegel <spiegel@gnu.org>
+;; Package: 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 <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; See vc.el
+
+;; Some features will not work with old RCS versions. Where
+;; appropriate, VC finds out which version you have, and allows or
+;; disallows those features (stealing locks, for example, works only
+;; from 5.6.2 onwards).
+;; Even initial checkins will fail if your RCS version is so old that ci
+;; doesn't understand -t-; this has been known to happen to people running
+;; NExTSTEP 3.0.
+;;
+;; You can support the RCS -x option by customizing vc-rcs-master-templates.
+
+;;; Code:
+
+;;;
+;;; Customization options
+;;;
+
+(eval-when-compile
+ (require 'cl)
+ (require 'vc))
+
+(defcustom vc-rcs-release nil
+ "The release number of your RCS installation, as a string.
+If nil, VC itself computes this value when it is first needed."
+ :type '(choice (const :tag "Auto" nil)
+ (string :tag "Specified")
+ (const :tag "Unknown" unknown))
+ :group 'vc)
+
+(defcustom vc-rcs-register-switches nil
+ "Switches for registering a file in RCS.
+A string or list of strings passed to the checkin program by
+\\[vc-register]. If nil, use the value of `vc-register-switches'.
+If t, use no switches."
+ :type '(choice (const :tag "Unspecified" nil)
+ (const :tag "None" t)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List" :value ("") string))
+ :version "21.1"
+ :group 'vc)
+
+(defcustom vc-rcs-diff-switches nil
+ "String or list of strings specifying switches for RCS diff under VC.
+If nil, use the value of `vc-diff-switches'. If t, use no switches."
+ :type '(choice (const :tag "Unspecified" nil)
+ (const :tag "None" t)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List" :value ("") string))
+ :version "21.1"
+ :group 'vc)
+
+(defcustom vc-rcs-header '("\$Id\$")
+ "Header keywords to be inserted by `vc-insert-headers'."
+ :type '(repeat string)
+ :version "24.1" ; no longer consult the obsolete vc-header-alist
+ :group 'vc)
+
+(defcustom vc-rcsdiff-knows-brief nil
+ "Indicates whether rcsdiff understands the --brief option.
+The value is either `yes', `no', or nil. If it is nil, VC tries
+to use --brief and sets this variable to remember whether it worked."
+ :type '(choice (const :tag "Work out" nil) (const yes) (const no))
+ :group 'vc)
+
+;;;###autoload
+(defcustom vc-rcs-master-templates
+ (purecopy '("%sRCS/%s,v" "%s%s,v" "%sRCS/%s"))
+ "Where to look for RCS master files.
+For a description of possible values, see `vc-check-master-templates'."
+ :type '(choice (const :tag "Use standard RCS file names"
+ '("%sRCS/%s,v" "%s%s,v" "%sRCS/%s"))
+ (repeat :tag "User-specified"
+ (choice string
+ function)))
+ :version "21.1"
+ :group 'vc)
+
+\f
+;;; Properties of the backend
+
+(defun vc-rcs-revision-granularity () 'file)
+
+(defun vc-rcs-checkout-model (files)
+ "RCS-specific version of `vc-checkout-model'."
+ (let ((file (if (consp files) (car files) files))
+ result)
+ (when vc-consult-headers
+ (vc-file-setprop file 'vc-checkout-model nil)
+ (vc-rcs-consult-headers file)
+ (setq result (vc-file-getprop file 'vc-checkout-model)))
+ (or result
+ (progn (vc-rcs-fetch-master-state file)
+ (vc-file-getprop file 'vc-checkout-model)))))
+
+;;;
+;;; State-querying functions
+;;;
+
+;; The autoload cookie below places vc-rcs-registered directly into
+;; loaddefs.el, so that vc-rcs.el does not need to be loaded for
+;; every file that is visited.
+;;;###autoload
+(progn
+(defun vc-rcs-registered (f) (vc-default-registered 'RCS f)))
+
+(defun vc-rcs-state (file)
+ "Implementation of `vc-state' for RCS."
+ (if (not (vc-rcs-registered file))
+ 'unregistered
+ (or (boundp 'vc-rcs-headers-result)
+ (and vc-consult-headers
+ (vc-rcs-consult-headers file)))
+ (let ((state
+ ;; vc-working-revision might not be known; in that case the
+ ;; property is nil. vc-rcs-fetch-master-state knows how to
+ ;; handle that.
+ (vc-rcs-fetch-master-state file
+ (vc-file-getprop file
+ 'vc-working-revision))))
+ (if (not (eq state 'up-to-date))
+ state
+ (if (vc-workfile-unchanged-p file)
+ 'up-to-date
+ (if (eq (vc-rcs-checkout-model (list file)) 'locking)
+ 'unlocked-changes
+ 'edited))))))
+
+(defun vc-rcs-state-heuristic (file)
+ "State heuristic for RCS."
+ (let (vc-rcs-headers-result)
+ (if (and vc-consult-headers
+ (setq vc-rcs-headers-result
+ (vc-rcs-consult-headers file))
+ (eq vc-rcs-headers-result 'rev-and-lock))
+ (let ((state (vc-file-getprop file 'vc-state)))
+ ;; If the headers say that the file is not locked, the
+ ;; permissions can tell us whether locking is used for
+ ;; the file or not.
+ (if (and (eq state 'up-to-date)
+ (not (vc-mistrust-permissions file))
+ (file-exists-p file))
+ (cond
+ ((string-match ".rw..-..-." (nth 8 (file-attributes file)))
+ (vc-file-setprop file 'vc-checkout-model 'implicit)
+ (setq state
+ (if (vc-rcs-workfile-is-newer file)
+ 'edited
+ 'up-to-date)))
+ ((string-match ".r-..-..-." (nth 8 (file-attributes file)))
+ (vc-file-setprop file 'vc-checkout-model 'locking))))
+ state)
+ (if (not (vc-mistrust-permissions file))
+ (let* ((attributes (file-attributes file 'string))
+ (owner-name (nth 2 attributes))
+ (permissions (nth 8 attributes)))
+ (cond ((and permissions (string-match ".r-..-..-." permissions))
+ (vc-file-setprop file 'vc-checkout-model 'locking)
+ 'up-to-date)
+ ((and permissions (string-match ".rw..-..-." permissions))
+ (if (eq (vc-rcs-checkout-model file) 'locking)
+ (if (file-ownership-preserved-p file)
+ 'edited
+ owner-name)
+ (if (vc-rcs-workfile-is-newer file)
+ 'edited
+ 'up-to-date)))
+ (t
+ ;; Strange permissions. Fall through to
+ ;; expensive state computation.
+ (vc-rcs-state file))))
+ (vc-rcs-state file)))))
+
+(defun vc-rcs-dir-status (dir update-function)
+ ;; FIXME: this function should be rewritten or `vc-expand-dirs'
+ ;; should be changed to take a backend parameter. Using
+ ;; `vc-expand-dirs' is not TRTD because it returns files from
+ ;; multiple backends. It should also return 'unregistered files.
+
+ ;; Doing individual vc-state calls is painful but there
+ ;; is no better way in RCS-land.
+ (let ((flist (vc-expand-dirs (list dir)))
+ (result nil))
+ (dolist (file flist)
+ (let ((state (vc-state file))
+ (frel (file-relative-name file)))
+ (when (and (eq (vc-backend file) 'RCS)
+ (not (eq state 'up-to-date)))
+ (push (list frel state) result))))
+ (funcall update-function result)))
+
+(defun vc-rcs-working-revision (file)
+ "RCS-specific version of `vc-working-revision'."
+ (or (and vc-consult-headers
+ (vc-rcs-consult-headers file)
+ (vc-file-getprop file 'vc-working-revision))
+ (progn
+ (vc-rcs-fetch-master-state file)
+ (vc-file-getprop file 'vc-working-revision))))
+
+(defun vc-rcs-latest-on-branch-p (file &optional version)
+ "Return non-nil if workfile version of FILE is the latest on its branch.
+When VERSION is given, perform check for that version."
+ (unless version (setq version (vc-working-revision file)))
+ (with-temp-buffer
+ (string= version
+ (if (vc-rcs-trunk-p version)
+ (progn
+ ;; Compare VERSION to the head version number.
+ (vc-insert-file (vc-name file) "^[0-9]")
+ (vc-parse-buffer "^head[ \t\n]+\\([^;]+\\);" 1))
+ ;; If we are not on the trunk, we need to examine the
+ ;; whole current branch.
+ (vc-insert-file (vc-name file) "^desc")
+ (vc-rcs-find-most-recent-rev (vc-branch-part version))))))
+
+(defun vc-rcs-workfile-unchanged-p (file)
+ "RCS-specific implementation of `vc-workfile-unchanged-p'."
+ ;; Try to use rcsdiff --brief. If rcsdiff does not understand that,
+ ;; do a double take and remember the fact for the future
+ (let* ((version (concat "-r" (vc-working-revision file)))
+ (status (if (eq vc-rcsdiff-knows-brief 'no)
+ (vc-do-command "*vc*" 1 "rcsdiff" file version)
+ (vc-do-command "*vc*" 2 "rcsdiff" file "--brief" version))))
+ (if (eq status 2)
+ (if (not vc-rcsdiff-knows-brief)
+ (setq vc-rcsdiff-knows-brief 'no
+ status (vc-do-command "*vc*" 1 "rcsdiff" file version))
+ (error "rcsdiff failed"))
+ (if (not vc-rcsdiff-knows-brief) (setq vc-rcsdiff-knows-brief 'yes)))
+ ;; The workfile is unchanged if rcsdiff found no differences.
+ (zerop status)))
+
+\f
+;;;
+;;; State-changing functions
+;;;
+
+(defun vc-rcs-create-repo ()
+ "Create a new RCS repository."
+ ;; RCS is totally file-oriented, so all we have to do is make the directory.
+ (make-directory "RCS"))
+
+(defun vc-rcs-register (files &optional rev comment)
+ "Register FILES into the RCS version-control system.
+REV is the optional revision number for the files. COMMENT can be used
+to provide an initial description for each FILES.
+Passes either `vc-rcs-register-switches' or `vc-register-switches'
+to the RCS command.
+
+Automatically retrieve a read-only version of the file with keywords
+expanded if `vc-keep-workfiles' is non-nil, otherwise, delete the workfile."
+ (let (subdir name)
+ ;; When REV is specified, we need to force using "-t-".
+ (when rev (unless comment (setq comment "")))
+ (dolist (file files)
+ (and (not (file-exists-p
+ (setq subdir (expand-file-name "RCS"
+ (file-name-directory file)))))
+ (not (directory-files (file-name-directory file)
+ nil ".*,v$" t))
+ (yes-or-no-p "Create RCS subdirectory? ")
+ (make-directory subdir))
+ (apply 'vc-do-command "*vc*" 0 "ci" file
+ ;; if available, use the secure registering option
+ (and (vc-rcs-release-p "5.6.4") "-i")
+ (concat (if vc-keep-workfiles "-u" "-r") rev)
+ (and comment (concat "-t-" comment))
+ (vc-switches 'RCS 'register))
+ ;; parse output to find master file name and workfile version
+ (with-current-buffer "*vc*"
+ (goto-char (point-min))
+ (if (not (setq name
+ (if (looking-at (concat "^\\(.*\\) <-- "
+ (file-name-nondirectory file)))
+ (match-string 1))))
+ ;; if we couldn't find the master name,
+ ;; run vc-rcs-registered to get it
+ ;; (will be stored into the vc-name property)
+ (vc-rcs-registered file)
+ (vc-file-setprop file 'vc-name
+ (if (file-name-absolute-p name)
+ name
+ (expand-file-name
+ name
+ (file-name-directory file))))))
+ (vc-file-setprop file 'vc-working-revision
+ (if (re-search-forward
+ "^initial revision: \\([0-9.]+\\).*\n"
+ nil t)
+ (match-string 1))))))
+
+(defun vc-rcs-responsible-p (file)
+ "Return non-nil if RCS thinks it would be responsible for registering FILE."
+ ;; TODO: check for all the patterns in vc-rcs-master-templates
+ (file-directory-p (expand-file-name "RCS" (file-name-directory file))))
+
+(defun vc-rcs-receive-file (file rev)
+ "Implementation of receive-file for RCS."
+ (let ((checkout-model (vc-rcs-checkout-model (list file))))
+ (vc-rcs-register file rev "")
+ (when (eq checkout-model 'implicit)
+ (vc-rcs-set-non-strict-locking file))
+ (vc-rcs-set-default-branch file (concat rev ".1"))))
+
+(defun vc-rcs-unregister (file)
+ "Unregister FILE from RCS.
+If this leaves the RCS subdirectory empty, ask the user
+whether to remove it."
+ (let* ((master (vc-name file))
+ (dir (file-name-directory master))
+ (backup-info (find-backup-file-name master)))
+ (if (not backup-info)
+ (delete-file master)
+ (rename-file master (car backup-info) 'ok-if-already-exists)
+ (dolist (f (cdr backup-info)) (ignore-errors (delete-file f))))
+ (and (string= (file-name-nondirectory (directory-file-name dir)) "RCS")
+ ;; check whether RCS dir is empty, i.e. it does not
+ ;; contain any files except "." and ".."
+ (not (directory-files dir nil
+ "^\\([^.]\\|\\.[^.]\\|\\.\\.[^.]\\).*"))
+ (yes-or-no-p (format "Directory %s is empty; remove it? " dir))
+ (delete-directory dir))))
+
+(defun vc-rcs-checkin (files rev comment)
+ "RCS-specific version of `vc-backend-checkin'."
+ (let ((switches (vc-switches 'RCS 'checkin)))
+ ;; Now operate on the files
+ (dolist (file (vc-expand-dirs files))
+ (let ((old-version (vc-working-revision file)) new-version
+ (default-branch (vc-file-getprop file 'vc-rcs-default-branch)))
+ ;; Force branch creation if an appropriate
+ ;; default branch has been set.
+ (and (not rev)
+ default-branch
+ (string-match (concat "^" (regexp-quote old-version) "\\.")
+ default-branch)
+ (setq rev default-branch)
+ (setq switches (cons "-f" switches)))
+ (if (and (not rev) old-version)
+ (setq rev (vc-branch-part old-version)))
+ (apply 'vc-do-command "*vc*" 0 "ci" (vc-name file)
+ ;; if available, use the secure check-in option
+ (and (vc-rcs-release-p "5.6.4") "-j")
+ (concat (if vc-keep-workfiles "-u" "-r") rev)
+ (concat "-m" comment)
+ switches)
+ (vc-file-setprop file 'vc-working-revision nil)
+
+ ;; determine the new workfile version
+ (set-buffer "*vc*")
+ (goto-char (point-min))
+ (when (or (re-search-forward
+ "new revision: \\([0-9.]+\\);" nil t)
+ (re-search-forward
+ "reverting to previous revision \\([0-9.]+\\)" nil t))
+ (setq new-version (match-string 1))
+ (vc-file-setprop file 'vc-working-revision new-version))
+
+ ;; if we got to a different branch, adjust the default
+ ;; branch accordingly
+ (cond
+ ((and old-version new-version
+ (not (string= (vc-branch-part old-version)
+ (vc-branch-part new-version))))
+ (vc-rcs-set-default-branch file
+ (if (vc-rcs-trunk-p new-version) nil
+ (vc-branch-part new-version)))
+ ;; If this is an old RCS release, we might have
+ ;; to remove a remaining lock.
+ (if (not (vc-rcs-release-p "5.6.2"))
+ ;; exit status of 1 is also accepted.
+ ;; It means that the lock was removed before.
+ (vc-do-command "*vc*" 1 "rcs" (vc-name file)
+ (concat "-u" old-version)))))))))
+
+(defun vc-rcs-find-revision (file rev buffer)
+ (apply 'vc-do-command
+ (or buffer "*vc*") 0 "co" (vc-name file)
+ "-q" ;; suppress diagnostic output
+ (concat "-p" rev)
+ (vc-switches 'RCS 'checkout)))
+
+(defun vc-rcs-checkout (file &optional editable rev)
+ "Retrieve a copy of a saved version of FILE. If FILE is a directory,
+attempt the checkout for all registered files beneath it."
+ (if (file-directory-p file)
+ (mapc 'vc-rcs-checkout (vc-expand-dirs (list file)))
+ (let ((file-buffer (get-file-buffer file))
+ switches)
+ (message "Checking out %s..." file)
+ (save-excursion
+ ;; Change buffers to get local value of vc-checkout-switches.
+ (if file-buffer (set-buffer file-buffer))
+ (setq switches (vc-switches 'RCS 'checkout))
+ ;; Save this buffer's default-directory
+ ;; and use save-excursion to make sure it is restored
+ ;; in the same buffer it was saved in.
+ (let ((default-directory default-directory))
+ (save-excursion
+ ;; Adjust the default-directory so that the check-out creates
+ ;; the file in the right place.
+ (setq default-directory (file-name-directory file))
+ (let (new-version)
+ ;; if we should go to the head of the trunk,
+ ;; clear the default branch first
+ (and rev (string= rev "")
+ (vc-rcs-set-default-branch file nil))
+ ;; now do the checkout
+ (apply 'vc-do-command
+ "*vc*" 0 "co" (vc-name file)
+ ;; If locking is not strict, force to overwrite
+ ;; the writable workfile.
+ (if (eq (vc-rcs-checkout-model (list file)) 'implicit) "-f")
+ (if editable "-l")
+ (if (stringp rev)
+ ;; a literal revision was specified
+ (concat "-r" rev)
+ (let ((workrev (vc-working-revision file)))
+ (if workrev
+ (concat "-r"
+ (if (not rev)
+ ;; no revision specified:
+ ;; use current workfile version
+ workrev
+ ;; REV is t ...
+ (if (not (vc-rcs-trunk-p workrev))
+ ;; ... go to head of current branch
+ (vc-branch-part workrev)
+ ;; ... go to head of trunk
+ (vc-rcs-set-default-branch file
+ nil)
+ ""))))))
+ switches)
+ ;; determine the new workfile version
+ (with-current-buffer "*vc*"
+ (setq new-version
+ (vc-parse-buffer "^revision \\([0-9.]+\\).*\n" 1)))
+ (vc-file-setprop file 'vc-working-revision new-version)
+ ;; if necessary, adjust the default branch
+ (and rev (not (string= rev ""))
+ (vc-rcs-set-default-branch
+ file
+ (if (vc-rcs-latest-on-branch-p file new-version)
+ (if (vc-rcs-trunk-p new-version) nil
+ (vc-branch-part new-version))
+ new-version)))))
+ (message "Checking out %s...done" file))))))
+
+(defun vc-rcs-rollback (files)
+ "Roll back, undoing the most recent checkins of FILES. Directories are
+expanded to all registered subfiles in them."
+ (if (not files)
+ (error "RCS backend doesn't support directory-level rollback"))
+ (dolist (file (vc-expand-dirs files))
+ (let* ((discard (vc-working-revision file))
+ (previous (if (vc-rcs-trunk-p discard) "" (vc-branch-part discard)))
+ (config (current-window-configuration))
+ (done nil))
+ (if (null (yes-or-no-p (format "Remove version %s from %s history? "
+ discard file)))
+ (error "Aborted"))
+ (message "Removing revision %s from %s." discard file)
+ (vc-do-command "*vc*" 0 "rcs" (vc-name file) (concat "-o" discard))
+ ;; Check out the most recent remaining version. If it
+ ;; fails, because the whole branch got deleted, do a
+ ;; double-take and check out the version where the branch
+ ;; started.
+ (while (not done)
+ (condition-case err
+ (progn
+ (vc-do-command "*vc*" 0 "co" (vc-name file) "-f"
+ (concat "-u" previous))
+ (setq done t))
+ (error (set-buffer "*vc*")
+ (goto-char (point-min))
+ (if (search-forward "no side branches present for" nil t)
+ (progn (setq previous (vc-branch-part previous))
+ (vc-rcs-set-default-branch file previous)
+ ;; vc-do-command popped up a window with
+ ;; the error message. Get rid of it, by
+ ;; restoring the old window configuration.
+ (set-window-configuration config))
+ ;; No, it was some other error: re-signal it.
+ (signal (car err) (cdr err)))))))))
+
+(defun vc-rcs-revert (file &optional contents-done)
+ "Revert FILE to the version it was based on. If FILE is a directory,
+revert all registered files beneath it."
+ (if (file-directory-p file)
+ (mapc 'vc-rcs-revert (vc-expand-dirs (list file)))
+ (vc-do-command "*vc*" 0 "co" (vc-name file) "-f"
+ (concat (if (eq (vc-state file) 'edited) "-u" "-r")
+ (vc-working-revision file)))))
+
+(defun vc-rcs-merge (file first-version &optional second-version)
+ "Merge changes into current working copy of FILE.
+The changes are between FIRST-VERSION and SECOND-VERSION."
+ (vc-do-command "*vc*" 1 "rcsmerge" (vc-name file)
+ "-kk" ; ignore keyword conflicts
+ (concat "-r" first-version)
+ (if second-version (concat "-r" second-version))))
+
+(defun vc-rcs-steal-lock (file &optional rev)
+ "Steal the lock on the current workfile for FILE and revision REV.
+If FILE is a directory, steal the lock on all registered files beneath it.
+Needs RCS 5.6.2 or later for -M."
+ (if (file-directory-p file)
+ (mapc 'vc-rcs-steal-lock (vc-expand-dirs (list file)))
+ (vc-do-command "*vc*" 0 "rcs" (vc-name file) "-M" (concat "-u" rev))
+ ;; Do a real checkout after stealing the lock, so that we see
+ ;; expanded headers.
+ (vc-do-command "*vc*" 0 "co" (vc-name file) "-f" (concat "-l" rev))))
+
+(defun vc-rcs-modify-change-comment (files rev comment)
+ "Modify the change comments change on FILES on a specified REV. If FILE is a
+directory the operation is applied to all registered files beneath it."
+ (dolist (file (vc-expand-dirs files))
+ (vc-do-command "*vc*" 0 "rcs" (vc-name file)
+ (concat "-m" rev ":" comment))))
+
+\f
+;;;
+;;; History functions
+;;;
+
+(defun vc-rcs-print-log-cleanup ()
+ (let ((inhibit-read-only t))
+ (goto-char (point-max))
+ (forward-line -1)
+ (while (looking-at "=*\n")
+ (delete-char (- (match-end 0) (match-beginning 0)))
+ (forward-line -1))
+ (goto-char (point-min))
+ (when (looking-at "[\b\t\n\v\f\r ]+")
+ (delete-char (- (match-end 0) (match-beginning 0))))))
+
+(defun vc-rcs-print-log (files buffer &optional shortlog start-revision-ignored limit)
+ "Get change log associated with FILE. If FILE is a
+directory the operation is applied to all registered files beneath it."
+ (vc-do-command (or buffer "*vc*") 0 "rlog" (mapcar 'vc-name (vc-expand-dirs files)))
+ (with-current-buffer (or buffer "*vc*")
+ (vc-rcs-print-log-cleanup))
+ (when limit 'limit-unsupported))
+
+(defun vc-rcs-diff (files &optional oldvers newvers buffer)
+ "Get a difference report using RCS between two sets of files."
+ (apply 'vc-do-command (or buffer "*vc-diff*")
+ 1 ;; Always go synchronous, the repo is local
+ "rcsdiff" (vc-expand-dirs files)
+ (append (list "-q"
+ (and oldvers (concat "-r" oldvers))
+ (and newvers (concat "-r" newvers)))
+ (vc-switches 'RCS 'diff))))
+
+(defun vc-rcs-comment-history (file)
+ "Return a string with all log entries stored in BACKEND for FILE."
+ (with-current-buffer "*vc*"
+ ;; Has to be written this way, this function is used by the CVS backend too
+ (vc-call-backend (vc-backend file) 'print-log (list file))
+ ;; Remove cruft
+ (let ((separator (concat "^-+\nrevision [0-9.]+\ndate: .*\n"
+ "\\(branches: .*;\n\\)?"
+ "\\(\\*\\*\\* empty log message \\*\\*\\*\n\\)?")))
+ (goto-char (point-max)) (forward-line -1)
+ (while (looking-at "=*\n")
+ (delete-char (- (match-end 0) (match-beginning 0)))
+ (forward-line -1))
+ (goto-char (point-min))
+ (if (looking-at "[\b\t\n\v\f\r ]+")
+ (delete-char (- (match-end 0) (match-beginning 0))))
+ (goto-char (point-min))
+ (re-search-forward separator nil t)
+ (delete-region (point-min) (point))
+ (while (re-search-forward separator nil t)
+ (delete-region (match-beginning 0) (match-end 0))))
+ ;; Return the de-crufted comment list
+ (buffer-string)))
+
+(defun vc-rcs-annotate-command (file buffer &optional revision)
+ "Annotate FILE, inserting the results in BUFFER.
+Optional arg REVISION is a revision to annotate from."
+ (vc-setup-buffer buffer)
+ ;; Aside from the "head revision on the trunk", the instructions for
+ ;; each revision on the trunk are an ordered list of kill and insert
+ ;; commands necessary to go from the chronologically-following
+ ;; revision to this one. That is, associated with revision N are
+ ;; edits that applied to revision N+1 would result in revision N.
+ ;;
+ ;; On a branch, however, (some) things are inverted: the commands
+ ;; listed are those necessary to go from the chronologically-preceding
+ ;; revision to this one. That is, associated with revision N are
+ ;; edits that applied to revision N-1 would result in revision N.
+ ;;
+ ;; So, to get per-line history info, we apply reverse-chronological
+ ;; edits, starting with the head revision on the trunk, all the way
+ ;; back through the initial revision (typically "1.1" or similar),
+ ;; then apply forward-chronological edits -- keeping track of which
+ ;; revision is associated with each inserted line -- until we reach
+ ;; the desired revision for display (which may be either on the trunk
+ ;; or on a branch).
+ (let* ((tree (with-temp-buffer
+ (insert-file-contents (vc-rcs-registered file))
+ (vc-rcs-parse)))
+ (revisions (cdr (assq 'revisions tree)))
+ ;; The revision N whose instructions we currently are processing.
+ (cur (cdr (assq 'head (cdr (assq 'headers tree)))))
+ ;; Alist from the parse tree for N.
+ (meta (cdr (assoc cur revisions)))
+ ;; Point and temporary string, respectively.
+ p s
+ ;; "Next-branch list". Nil means the desired revision to
+ ;; display lives on the trunk. Non-nil means it lives on a
+ ;; branch, in which case the value is a list of revision pairs
+ ;; (PARENT . CHILD), the first PARENT being on the trunk, that
+ ;; links each series of revisions in the path from the initial
+ ;; revision to the desired revision to display.
+ nbls
+ ;; "Path-accumulate-predicate plus revision/date/author".
+ ;; Until set, forward-chronological edits are not accumulated.
+ ;; Once set, its value (updated every revision) is used for
+ ;; the text property `:vc-rcs-r/d/a' for inserts during
+ ;; processing of forward-chronological instructions for N.
+ ;; See internal func `r/d/a'.
+ prda
+ ;; List of forward-chronological instructions, each of the
+ ;; form: (POS . ACTION), where POS is a buffer position. If
+ ;; ACTION is a string, it is inserted, otherwise it is taken as
+ ;; the number of characters to be deleted.
+ path
+ ;; N+1. When `cur' is "", this is the initial revision.
+ pre)
+ (unless revision
+ (setq revision cur))
+ (unless (assoc revision revisions)
+ (error "No such revision: %s" revision))
+ ;; Find which branches (if any) must be included in the edits.
+ (let ((par revision)
+ bpt kids)
+ (while (setq bpt (vc-branch-part par)
+ par (vc-branch-part bpt))
+ (setq kids (cdr (assq 'branches (cdr (assoc par revisions)))))
+ ;; A branchpoint may have multiple children. Find the right one.
+ (while (not (string= bpt (vc-branch-part (car kids))))
+ (setq kids (cdr kids)))
+ (push (cons par (car kids)) nbls)))
+ ;; Start with the full text.
+ (set-buffer buffer)
+ (insert (cdr (assq 'text meta)))
+ ;; Apply reverse-chronological edits on the trunk, computing and
+ ;; accumulating forward-chronological edits after some point, for
+ ;; later.
+ (flet ((r/d/a () (vector pre
+ (cdr (assq 'date meta))
+ (cdr (assq 'author meta)))))
+ (while (when (setq pre cur cur (cdr (assq 'next meta)))
+ (not (string= "" cur)))
+ (setq
+ ;; Start accumulating the forward-chronological edits when N+1
+ ;; on the trunk is either the desired revision to display, or
+ ;; the appropriate branchpoint for it. Do this before
+ ;; updating `meta' since `r/d/a' uses N+1's `meta' value.
+ prda (when (or prda (string= (if nbls (caar nbls) revision) pre))
+ (r/d/a))
+ meta (cdr (assoc cur revisions)))
+ ;; Edits in the parse tree specify a line number (in the buffer
+ ;; *BEFORE* editing occurs) to start from, but line numbers
+ ;; change as a result of edits. To DTRT, we apply edits in
+ ;; order of descending buffer position so that edits further
+ ;; down in the buffer occur first w/o corrupting specified
+ ;; buffer positions of edits occurring towards the beginning of
+ ;; the buffer. In this way we avoid using markers. A pleasant
+ ;; property of this approach is ability to push instructions
+ ;; onto `path' directly, w/o need to maintain rev boundaries.
+ (dolist (insn (cdr (assq :insn meta)))
+ (goto-char (point-min))
+ (forward-line (1- (pop insn)))
+ (setq p (point))
+ (case (pop insn)
+ (k (setq s (buffer-substring-no-properties
+ p (progn (forward-line (car insn))
+ (point))))
+ (when prda
+ (push `(,p . ,(propertize s :vc-rcs-r/d/a prda)) path))
+ (delete-region p (point)))
+ (i (setq s (car insn))
+ (when prda
+ (push `(,p . ,(length s)) path))
+ (insert s)))))
+ ;; For the initial revision, setting `:vc-rcs-r/d/a' directly is
+ ;; equivalent to pushing an insert instruction (of the entire buffer
+ ;; contents) onto `path' then erasing the buffer, but less wasteful.
+ (put-text-property (point-min) (point-max) :vc-rcs-r/d/a (r/d/a))
+ ;; Now apply the forward-chronological edits for the trunk.
+ (dolist (insn path)
+ (goto-char (pop insn))
+ (if (stringp insn)
+ (insert insn)
+ (delete-char insn)))
+ ;; Now apply the forward-chronological edits (directly from the
+ ;; parse-tree) for the branch(es), if necessary. We re-use vars
+ ;; `pre' and `meta' for the sake of internal func `r/d/a'.
+ (while nbls
+ (setq pre (cdr (pop nbls)))
+ (while (progn
+ (setq meta (cdr (assoc pre revisions))
+ prda nil)
+ (dolist (insn (cdr (assq :insn meta)))
+ (goto-char (point-min))
+ (forward-line (1- (pop insn)))
+ (case (pop insn)
+ (k (delete-region
+ (point) (progn (forward-line (car insn))
+ (point))))
+ (i (insert (propertize
+ (car insn)
+ :vc-rcs-r/d/a
+ (or prda (setq prda (r/d/a))))))))
+ (prog1 (not (string= (if nbls (caar nbls) revision) pre))
+ (setq pre (cdr (assq 'next meta)))))))))
+ ;; Lastly, for each line, insert at bol nicely-formatted history info.
+ ;; We do two passes to collect summary information used to minimize
+ ;; the annotation's usage of screen real-estate: (1) Consider rendered
+ ;; width of revision plus author together as a unit; and (2) Omit
+ ;; author entirely if all authors are the same as the user.
+ (let ((ht (make-hash-table :test 'eq))
+ (me (user-login-name))
+ (maxw 0)
+ (all-me t)
+ rda w a)
+ (goto-char (point-max))
+ (while (not (bobp))
+ (forward-line -1)
+ (setq rda (get-text-property (point) :vc-rcs-r/d/a))
+ (unless (gethash rda ht)
+ (setq a (aref rda 2)
+ all-me (and all-me (string= a me)))
+ (puthash rda (setq w (+ (length (aref rda 0))
+ (length a)))
+ ht)
+ (setq maxw (max w maxw))))
+ (let ((padding (make-string maxw 32)))
+ (flet ((pad (w) (substring-no-properties padding w))
+ (render (rda &rest ls)
+ (propertize
+ (apply 'concat
+ (format-time-string "%Y-%m-%d" (aref rda 1))
+ " "
+ (aref rda 0)
+ ls)
+ :vc-annotate-prefix t
+ :vc-rcs-r/d/a rda)))
+ (maphash
+ (if all-me
+ (lambda (rda w)
+ (puthash rda (render rda (pad w) ": ") ht))
+ (lambda (rda w)
+ (puthash rda (render rda " " (pad w) " " (aref rda 2) ": ") ht)))
+ ht)))
+ (while (not (eobp))
+ (insert (gethash (get-text-property (point) :vc-rcs-r/d/a) ht))
+ (forward-line 1))))
+
+(declare-function vc-annotate-convert-time "vc-annotate" (time))
+
+(defun vc-rcs-annotate-current-time ()
+ "Return the current time, based at midnight of the current day, and
+encoded as fractional days."
+ (vc-annotate-convert-time
+ (apply 'encode-time 0 0 0 (nthcdr 3 (decode-time (current-time))))))
+
+(defun vc-rcs-annotate-time ()
+ "Return the time of the next annotation (as fraction of days)
+systime, or nil if there is none. Also, reposition point."
+ (unless (eobp)
+ (prog1 (vc-annotate-convert-time
+ (aref (get-text-property (point) :vc-rcs-r/d/a) 1))
+ (goto-char (next-single-property-change (point) :vc-annotate-prefix)))))
+
+(defun vc-rcs-annotate-extract-revision-at-line ()
+ (aref (get-text-property (point) :vc-rcs-r/d/a) 0))
+
+\f
+;;;
+;;; Tag system
+;;;
+
+(defun vc-rcs-create-tag (backend dir name branchp)
+ (when branchp
+ (error "RCS backend %s does not support module branches" backend))
+ (let ((result (vc-tag-precondition dir)))
+ (if (stringp result)
+ (error "File %s is not up-to-date" result)
+ (vc-file-tree-walk
+ dir
+ (lambda (f)
+ (vc-do-command "*vc*" 0 "rcs" (vc-name f) (concat "-n" name ":")))))))
+
+\f
+;;;
+;;; Miscellaneous
+;;;
+
+(defun vc-rcs-trunk-p (rev)
+ "Return t if REV is a revision on the trunk."
+ (not (eq nil (string-match "\\`[0-9]+\\.[0-9]+\\'" rev))))
+
+(defun vc-rcs-minor-part (rev)
+ "Return the minor revision number of a revision number REV."
+ (string-match "[0-9]+\\'" rev)
+ (substring rev (match-beginning 0) (match-end 0)))
+
+(defun vc-rcs-previous-revision (file rev)
+ "Return the revision number immediately preceding REV for FILE,
+or nil if there is no previous revision. This default
+implementation works for MAJOR.MINOR-style revision numbers as
+used by RCS and CVS."
+ (let ((branch (vc-branch-part rev))
+ (minor-num (string-to-number (vc-rcs-minor-part rev))))
+ (when branch
+ (if (> minor-num 1)
+ ;; revision does probably not start a branch or release
+ (concat branch "." (number-to-string (1- minor-num)))
+ (if (vc-rcs-trunk-p rev)
+ ;; we are at the beginning of the trunk --
+ ;; don't know anything to return here
+ nil
+ ;; we are at the beginning of a branch --
+ ;; return revision of starting point
+ (vc-branch-part branch))))))
+
+(defun vc-rcs-next-revision (file rev)
+ "Return the revision number immediately following REV for FILE,
+or nil if there is no next revision. This default implementation
+works for MAJOR.MINOR-style revision numbers as used by RCS
+and CVS."
+ (when (not (string= rev (vc-working-revision file)))
+ (let ((branch (vc-branch-part rev))
+ (minor-num (string-to-number (vc-rcs-minor-part rev))))
+ (concat branch "." (number-to-string (1+ minor-num))))))
+
+(defun vc-rcs-update-changelog (files)
+ "Default implementation of update-changelog.
+Uses `rcs2log' which only works for RCS and CVS."
+ ;; FIXME: We (c|sh)ould add support for cvs2cl
+ (let ((odefault default-directory)
+ (changelog (find-change-log))
+ ;; Presumably not portable to non-Unixy systems, along with rcs2log:
+ (tempfile (make-temp-file
+ (expand-file-name "vc"
+ (or small-temporary-file-directory
+ temporary-file-directory))))
+ (login-name (or user-login-name
+ (format "uid%d" (number-to-string (user-uid)))))
+ (full-name (or add-log-full-name
+ (user-full-name)
+ (user-login-name)
+ (format "uid%d" (number-to-string (user-uid)))))
+ (mailing-address (or add-log-mailing-address
+ user-mail-address)))
+ (find-file-other-window changelog)
+ (barf-if-buffer-read-only)
+ (vc-buffer-sync)
+ (undo-boundary)
+ (goto-char (point-min))
+ (push-mark)
+ (message "Computing change log entries...")
+ (message "Computing change log entries... %s"
+ (unwind-protect
+ (progn
+ (setq default-directory odefault)
+ (if (eq 0 (apply 'call-process
+ (expand-file-name "rcs2log"
+ exec-directory)
+ nil (list t tempfile) nil
+ "-c" changelog
+ "-u" (concat login-name
+ "\t" full-name
+ "\t" mailing-address)
+ (mapcar
+ (lambda (f)
+ (file-relative-name
+ (expand-file-name f odefault)))
+ files)))
+ "done"
+ (pop-to-buffer (get-buffer-create "*vc*"))
+ (erase-buffer)
+ (insert-file-contents tempfile)
+ "failed"))
+ (setq default-directory (file-name-directory changelog))
+ (delete-file tempfile)))))
+
+(defun vc-rcs-check-headers ()
+ "Check if the current file has any headers in it."
+ (save-excursion
+ (goto-char (point-min))
+ (re-search-forward "\\$[A-Za-z\300-\326\330-\366\370-\377]+\
+\\(: [\t -#%-\176\240-\377]*\\)?\\$" nil t)))
+
+(defun vc-rcs-clear-headers ()
+ "Implementation of vc-clear-headers for RCS."
+ (let ((case-fold-search nil))
+ (goto-char (point-min))
+ (while (re-search-forward
+ (concat "\\$\\(Author\\|Date\\|Header\\|Id\\|Locker\\|Name\\|"
+ "RCSfile\\|Revision\\|Source\\|State\\): [^$\n]+\\$")
+ nil t)
+ (replace-match "$\\1$"))))
+
+(defun vc-rcs-rename-file (old new)
+ ;; Just move the master file (using vc-rcs-master-templates).
+ (vc-rename-master (vc-name old) new vc-rcs-master-templates))
+
+(defun vc-rcs-find-file-hook ()
+ ;; If the file is locked by some other user, make
+ ;; the buffer read-only. Like this, even root
+ ;; cannot modify a file that someone else has locked.
+ (and (stringp (vc-state buffer-file-name 'RCS))
+ (setq buffer-read-only t)))
+
+\f
+;;;
+;;; Internal functions
+;;;
+
+(defun vc-rcs-workfile-is-newer (file)
+ "Return non-nil if FILE is newer than its RCS master.
+This likely means that FILE has been changed with respect
+to its master version."
+ (let ((file-time (nth 5 (file-attributes file)))
+ (master-time (nth 5 (file-attributes (vc-name file)))))
+ (or (> (nth 0 file-time) (nth 0 master-time))
+ (and (= (nth 0 file-time) (nth 0 master-time))
+ (> (nth 1 file-time) (nth 1 master-time))))))
+
+(defun vc-rcs-find-most-recent-rev (branch)
+ "Find most recent revision on BRANCH."
+ (goto-char (point-min))
+ (let ((latest-rev -1) value)
+ (while (re-search-forward (concat "^\\(" (regexp-quote branch)
+ "\\.\\([0-9]+\\)\\)\ndate[ \t]+[0-9.]+;")
+ nil t)
+ (let ((rev (string-to-number (match-string 2))))
+ (when (< latest-rev rev)
+ (setq latest-rev rev)
+ (setq value (match-string 1)))))
+ (or value
+ (vc-branch-part branch))))
+
+(defun vc-rcs-fetch-master-state (file &optional working-revision)
+ "Compute the master file's idea of the state of FILE.
+If a WORKING-REVISION is given, compute the state of that version,
+otherwise determine the workfile version based on the master file.
+This function sets the properties `vc-working-revision' and
+`vc-checkout-model' to their correct values, based on the master
+file."
+ (with-temp-buffer
+ (if (or (not (vc-insert-file (vc-name file) "^[0-9]"))
+ (progn (goto-char (point-min))
+ (not (looking-at "^head[ \t\n]+[^;]+;$"))))
+ (error "File %s is not an RCS master file" (vc-name file)))
+ (let ((workfile-is-latest nil)
+ (default-branch (vc-parse-buffer "^branch[ \t\n]+\\([^;]*\\);" 1)))
+ (vc-file-setprop file 'vc-rcs-default-branch default-branch)
+ (unless working-revision
+ ;; Workfile version not known yet. Determine that first. It
+ ;; is either the head of the trunk, the head of the default
+ ;; branch, or the "default branch" itself, if that is a full
+ ;; revision number.
+ (cond
+ ;; no default branch
+ ((or (not default-branch) (string= "" default-branch))
+ (setq working-revision
+ (vc-parse-buffer "^head[ \t\n]+\\([^;]+\\);" 1))
+ (setq workfile-is-latest t))
+ ;; default branch is actually a revision
+ ((string-match "^[0-9]+\\.[0-9]+\\(\\.[0-9]+\\.[0-9]+\\)*$"
+ default-branch)
+ (setq working-revision default-branch))
+ ;; else, search for the head of the default branch
+ (t (vc-insert-file (vc-name file) "^desc")
+ (setq working-revision
+ (vc-rcs-find-most-recent-rev default-branch))
+ (setq workfile-is-latest t)))
+ (vc-file-setprop file 'vc-working-revision working-revision))
+ ;; Check strict locking
+ (goto-char (point-min))
+ (vc-file-setprop file 'vc-checkout-model
+ (if (re-search-forward ";[ \t\n]*strict;" nil t)
+ 'locking 'implicit))
+ ;; Compute state of workfile version
+ (goto-char (point-min))
+ (let ((locking-user
+ (vc-parse-buffer (concat "^locks[ \t\n]+[^;]*[ \t\n]+\\([^:]+\\):"
+ (regexp-quote working-revision)
+ "[^0-9.]")
+ 1)))
+ (cond
+ ;; not locked
+ ((not locking-user)
+ (if (or workfile-is-latest
+ (vc-rcs-latest-on-branch-p file working-revision))
+ ;; workfile version is latest on branch
+ 'up-to-date
+ ;; workfile version is not latest on branch
+ 'needs-update))
+ ;; locked by the calling user
+ ((and (stringp locking-user)
+ (string= locking-user (vc-user-login-name file)))
+ ;; Don't call `vc-rcs-checkout-model' to avoid inf-looping.
+ (if (or (eq (vc-file-getprop file 'vc-checkout-model) 'locking)
+ workfile-is-latest
+ (vc-rcs-latest-on-branch-p file working-revision))
+ 'edited
+ ;; Locking is not used for the file, but the owner does
+ ;; have a lock, and there is a higher version on the current
+ ;; branch. Not sure if this can occur, and if it is right
+ ;; to use `needs-merge' in this case.
+ 'needs-merge))
+ ;; locked by somebody else
+ ((stringp locking-user)
+ locking-user)
+ (t
+ (error "Error getting state of RCS file")))))))
+
+(defun vc-rcs-consult-headers (file)
+ "Search for RCS headers in FILE, and set properties accordingly.
+
+Returns: nil if no headers were found
+ 'rev if a workfile revision was found
+ 'rev-and-lock if revision and lock info was found"
+ (cond
+ ((not (get-file-buffer file)) nil)
+ ((let (status version locking-user)
+ (with-current-buffer (get-file-buffer file)
+ (save-excursion
+ (goto-char (point-min))
+ (cond
+ ;; search for $Id or $Header
+ ;; -------------------------
+ ;; The `\ 's below avoid an RCS 5.7 bug when checking in this file.
+ ((or (and (search-forward "$Id\ : " nil t)
+ (looking-at "[^ ]+ \\([0-9.]+\\) "))
+ (and (progn (goto-char (point-min))
+ (search-forward "$Header\ : " nil t))
+ (looking-at "[^ ]+ \\([0-9.]+\\) ")))
+ (goto-char (match-end 0))
+ ;; if found, store the revision number ...
+ (setq version (match-string-no-properties 1))
+ ;; ... and check for the locking state
+ (cond
+ ((looking-at
+ (concat "[0-9]+[/-][01][0-9][/-][0-3][0-9] " ; date
+ "[0-2][0-9]:[0-5][0-9]+:[0-6][0-9]+\\([+-][0-9:]+\\)? " ; time
+ "[^ ]+ [^ ]+ ")) ; author & state
+ (goto-char (match-end 0)) ; [0-6] in regexp handles leap seconds
+ (cond
+ ;; unlocked revision
+ ((looking-at "\\$")
+ (setq locking-user 'none)
+ (setq status 'rev-and-lock))
+ ;; revision is locked by some user
+ ((looking-at "\\([^ ]+\\) \\$")
+ (setq locking-user (match-string-no-properties 1))
+ (setq status 'rev-and-lock))
+ ;; everything else: false
+ (nil)))
+ ;; unexpected information in
+ ;; keyword string --> quit
+ (nil)))
+ ;; search for $Revision
+ ;; --------------------
+ ((re-search-forward (concat "\\$"
+ "Revision: \\([0-9.]+\\) \\$")
+ nil t)
+ ;; if found, store the revision number ...
+ (setq version (match-string-no-properties 1))
+ ;; and see if there's any lock information
+ (goto-char (point-min))
+ (if (re-search-forward (concat "\\$" "Locker:") nil t)
+ (cond ((looking-at " \\([^ ]+\\) \\$")
+ (setq locking-user (match-string-no-properties 1))
+ (setq status 'rev-and-lock))
+ ((looking-at " *\\$")
+ (setq locking-user 'none)
+ (setq status 'rev-and-lock))
+ (t
+ (setq locking-user 'none)
+ (setq status 'rev-and-lock)))
+ (setq status 'rev)))
+ ;; else: nothing found
+ ;; -------------------
+ (t nil))))
+ (if status (vc-file-setprop file 'vc-working-revision version))
+ (and (eq status 'rev-and-lock)
+ (vc-file-setprop file 'vc-state
+ (cond
+ ((eq locking-user 'none) 'up-to-date)
+ ((string= locking-user (vc-user-login-name file))
+ 'edited)
+ (t locking-user)))
+ ;; If the file has headers, we don't want to query the
+ ;; master file, because that would eliminate all the
+ ;; performance gain the headers brought us. We therefore
+ ;; use a heuristic now to find out whether locking is used
+ ;; for this file. If we trust the file permissions, and the
+ ;; file is not locked, then if the file is read-only we
+ ;; assume that locking is used for the file, otherwise
+ ;; locking is not used.
+ (not (vc-mistrust-permissions file))
+ (vc-up-to-date-p file)
+ (if (string-match ".r-..-..-." (nth 8 (file-attributes file)))
+ (vc-file-setprop file 'vc-checkout-model 'locking)
+ (vc-file-setprop file 'vc-checkout-model 'implicit)))
+ status))))
+
+(defun vc-release-greater-or-equal (r1 r2)
+ "Compare release numbers, represented as strings.
+Release components are assumed cardinal numbers, not decimal fractions
+\(5.10 is a higher release than 5.9\). Omitted fields are considered
+lower \(5.6.7 is earlier than 5.6.7.1\). Comparison runs till the end
+of the string is found, or a non-numeric component shows up \(5.6.7 is
+earlier than \"5.6.7 beta\", which is probably not what you want in
+some cases\). This code is suitable for existing RCS release numbers.
+CVS releases are handled reasonably, too \(1.3 < 1.4* < 1.5\)."
+ (let (v1 v2 i1 i2)
+ (catch 'done
+ (or (and (string-match "^\\.?\\([0-9]+\\)" r1)
+ (setq i1 (match-end 0))
+ (setq v1 (string-to-number (match-string 1 r1)))
+ (or (and (string-match "^\\.?\\([0-9]+\\)" r2)
+ (setq i2 (match-end 0))
+ (setq v2 (string-to-number (match-string 1 r2)))
+ (if (> v1 v2) (throw 'done t)
+ (if (< v1 v2) (throw 'done nil)
+ (throw 'done
+ (vc-release-greater-or-equal
+ (substring r1 i1)
+ (substring r2 i2)))))))
+ (throw 'done t)))
+ (or (and (string-match "^\\.?\\([0-9]+\\)" r2)
+ (throw 'done nil))
+ (throw 'done t)))))
+
+(defun vc-rcs-release-p (release)
+ "Return t if we have RELEASE or better."
+ (let ((installation (vc-rcs-system-release)))
+ (if (and installation
+ (not (eq installation 'unknown)))
+ (vc-release-greater-or-equal installation release))))
+
+(defun vc-rcs-system-release ()
+ "Return the RCS release installed on this system, as a string.
+Return symbol `unknown' if the release cannot be deducted. The user can
+override this using variable `vc-rcs-release'.
+
+If the user has not set variable `vc-rcs-release' and it is nil,
+variable `vc-rcs-release' is set to the returned value."
+ (or vc-rcs-release
+ (setq vc-rcs-release
+ (or (and (zerop (vc-do-command "*vc*" nil "rcs" nil "-V"))
+ (with-current-buffer (get-buffer "*vc*")
+ (vc-parse-buffer "^RCS version \\([0-9.]+ *.*\\)" 1)))
+ 'unknown))))
+
+(defun vc-rcs-set-non-strict-locking (file)
+ (vc-do-command "*vc*" 0 "rcs" file "-U")
+ (vc-file-setprop file 'vc-checkout-model 'implicit)
+ (set-file-modes file (logior (file-modes file) 128)))
+
+(defun vc-rcs-set-default-branch (file branch)
+ (vc-do-command "*vc*" 0 "rcs" (vc-name file) (concat "-b" branch))
+ (vc-file-setprop file 'vc-rcs-default-branch branch))
+
+(defun vc-rcs-parse (&optional buffer)
+ "Parse current buffer, presumed to be in RCS-style masterfile format.
+Optional arg BUFFER specifies another buffer to parse. Return an alist
+of two elements, w/ keys `headers' and `revisions' and values in turn
+sub-alists. For `headers', the values unless otherwise specified are
+strings and the keys are:
+
+ desc -- description
+ head -- latest revision
+ branch -- the branch the \"head revision\" lies on;
+ absent if the head revision lies on the trunk
+ access -- ???
+ symbols -- sub-alist of (SYMBOL . REVISION) elements
+ locks -- if file is checked out, something like \"ttn:1.7\"
+ strict -- t if \"strict locking\" is in effect, otherwise nil
+ comment -- may be absent; typically something like \"# \" or \"; \"
+ expand -- may be absent; ???
+
+For `revisions', the car is REVISION (string), the cdr a sub-alist,
+with string values (unless otherwise specified) and keys:
+
+ date -- a time value (like that returned by `encode-time'); as a
+ special case, a year value less than 100 is augmented by 1900
+ author -- username
+ state -- typically \"Exp\" or \"Rel\"
+ branches -- list of revisions that begin branches from this revision
+ next -- on the trunk: the chronologically-preceding revision, or \"\";
+ on a branch: the chronologically-following revision, or \"\"
+ log -- change log entry
+ text -- for the head revision on the trunk, the body of the file;
+ other revisions have `:insn' instead
+ :insn -- for non-head revisions, a list of parsed instructions
+ in one of two forms, in both cases START meaning \"first
+ go to line START\":
+ - `(START k COUNT)' -- kill COUNT lines
+ - `(START i TEXT)' -- insert TEXT (a string)
+ The list is in descending order by START.
+
+The `:insn' key is a keyword to distinguish it as a vc-rcs.el extension."
+ (setq buffer (get-buffer (or buffer (current-buffer))))
+ (set-buffer buffer)
+ ;; An RCS masterfile can be viewed as containing four regular (for the
+ ;; most part) sections: (a) the "headers", (b) the "rev headers", (c)
+ ;; the "description" and (d) the "rev bodies", in that order. In the
+ ;; returned alist (see docstring), elements from (b) and (d) are
+ ;; combined pairwise to form the "revisions", while those from (a) and
+ ;; (c) are simply combined to form the "headers".
+ ;;
+ ;; Loosely speaking, each section contains a series of alternating
+ ;; "tags" and "printed representations". In the (b) and (d), many
+ ;; such series can appear, and a revision number on a line by itself
+ ;; precedes the series of tags and printed representations associated
+ ;; with it.
+ ;;
+ ;; In (a) and (b), the printed representations (with the exception of
+ ;; the `comment' tag in the headers) terminate with a semicolon, which
+ ;; is NOT part of the "value" finally associated with the tag. All
+ ;; other printed representations are in "@@-format"; there is an "@",
+ ;; the middle part (to be translated into the value), another "@" and
+ ;; a newline. Each "@@" in the middle part indicates the position of
+ ;; a single "@" (and consequently the requirement of an additional
+ ;; initial step when translating to the value).
+ ;;
+ ;; Parser state includes vars that collect parts of the return value...
+ (let ((desc nil) (headers nil) (revs nil)
+ ;; ... as well as vars that support a single-pass, tag-assisted,
+ ;; minimal-data-copying scan. Basically -- skirting around the
+ ;; grouping by revision required in (b) and (d) -- we repeatedly
+ ;; and context-sensitively read a tag (that MUST be present),
+ ;; determine the bounds of the printed representation, translate
+ ;; it into a value, and push the tag plus value onto one of the
+ ;; collection vars. Finally, we return the parse tree
+ ;; incorporating the values of the collection vars (see "rv").
+ ;;
+ ;; A symbol or string to keep track of context (for error messages).
+ context
+ ;; A symbol, the current tag.
+ tok
+ ;; Region (begin and end buffer positions) of the printed
+ ;; representation for the current tag.
+ b e
+ ;; A list of buffer positions where "@@" can be found within the
+ ;; printed representation region. For each location, we push two
+ ;; elements onto the list, 1+ and 2+ the location, respectively,
+ ;; with the 2+ appearing at the head. In this way, the expression
+ ;; `(,e ,@@-holes ,b)
+ ;; describes regions that can be concatenated (in reverse order)
+ ;; to "de-@@-format" the printed representation as the first step
+ ;; to translating it into some value. See internal func `gather'.
+ @-holes)
+ (flet ((sw () (skip-chars-forward " \t\n")) ; i.e., `[:space:]'
+ (at (tag) (save-excursion (eq tag (read buffer))))
+ (to-eol () (buffer-substring-no-properties
+ (point) (progn (forward-line 1)
+ (1- (point)))))
+ (to-semi () (setq b (point)
+ e (progn (search-forward ";")
+ (1- (point)))))
+ (to-one@ () (setq @-holes nil
+ b (progn (search-forward "@") (point))
+ e (progn (while (and (search-forward "@")
+ (= ?@ (char-after))
+ (progn
+ (push (point) @-holes)
+ (forward-char 1)
+ (push (point) @-holes))))
+ (1- (point)))))
+ (tok+val (set-b+e name &optional proc)
+ (unless (eq name (setq tok (read buffer)))
+ (error "Missing `%s' while parsing %s" name context))
+ (sw)
+ (funcall set-b+e)
+ (cons tok (if proc
+ (funcall proc)
+ (buffer-substring-no-properties b e))))
+ (k-semi (name &optional proc) (tok+val 'to-semi name proc))
+ (gather () (let ((pairs `(,e ,@@-holes ,b))
+ acc)
+ (while pairs
+ (push (buffer-substring-no-properties
+ (cadr pairs) (car pairs))
+ acc)
+ (setq pairs (cddr pairs)))
+ (apply 'concat acc)))
+ (k-one@ (name &optional later) (tok+val 'to-one@ name
+ (if later
+ (lambda () t)
+ 'gather))))
+ (save-excursion
+ (goto-char (point-min))
+ ;; headers
+ (setq context 'headers)
+ (flet ((hpush (name &optional proc)
+ (push (k-semi name proc) headers)))
+ (hpush 'head)
+ (when (at 'branch)
+ (hpush 'branch))
+ (hpush 'access)
+ (hpush 'symbols
+ (lambda ()
+ (mapcar (lambda (together)
+ (let ((two (split-string together ":")))
+ (setcar two (intern (car two)))
+ (setcdr two (cadr two))
+ two))
+ (split-string
+ (buffer-substring-no-properties b e)))))
+ (hpush 'locks))
+ (push `(strict . ,(when (at 'strict)
+ (search-forward ";")
+ t))
+ headers)
+ (when (at 'comment)
+ (push (k-one@ 'comment) headers)
+ (search-forward ";"))
+ (when (at 'expand)
+ (push (k-one@ 'expand) headers)
+ (search-forward ";"))
+ (setq headers (nreverse headers))
+ ;; rev headers
+ (sw) (setq context 'rev-headers)
+ (while (looking-at "[0-9]")
+ (push `(,(to-eol)
+ ,(k-semi 'date
+ (lambda ()
+ (let ((ls (mapcar 'string-to-number
+ (split-string
+ (buffer-substring-no-properties
+ b e)
+ "\\."))))
+ ;; Hack the year -- verified to be the
+ ;; same algorithm used in RCS 5.7.
+ (when (< (car ls) 100)
+ (setcar ls (+ 1900 (car ls))))
+ (apply 'encode-time (nreverse ls)))))
+ ,@(mapcar 'k-semi '(author state))
+ ,(k-semi 'branches
+ (lambda ()
+ (split-string
+ (buffer-substring-no-properties b e))))
+ ,(k-semi 'next))
+ revs)
+ (sw))
+ (setq revs (nreverse revs))
+ ;; desc
+ (sw) (setq context 'desc
+ desc (k-one@ 'desc))
+ ;; rev bodies
+ (let (acc
+ ;; Element of `revs' that initially holds only header info.
+ ;; "Pairwise combination" occurs when we add body info.
+ rev
+ ;; Components of the editing commands (aside from the actual
+ ;; text) that comprise the `text' printed representations
+ ;; (not including the "head" revision).
+ cmd start act
+ ;; Ascending (reversed) `@-holes' which the internal func
+ ;; `incg' pops to effect incremental gathering.
+ asc
+ ;; Function to extract text (for the `a' command), either
+ ;; `incg' or `buffer-substring-no-properties'. (This is
+ ;; for speed; strictly speaking, it is sufficient to use
+ ;; only the former since it behaves identically to the
+ ;; latter in the absense of "@@".)
+ sub)
+ (flet ((incg (beg end) (let ((b beg) (e end) @-holes)
+ (while (and asc (< (car asc) e))
+ (push (pop asc) @-holes))
+ ;; Self-deprecate when work is done.
+ ;; Folding many dimensions into one.
+ ;; Thanks B.Mandelbrot, for complex sum.
+ ;; O beauteous math! --the Unvexed Bum
+ (unless asc
+ (setq sub 'buffer-substring-no-properties))
+ (gather))))
+ (while (and (sw)
+ (not (eobp))
+ (setq context (to-eol)
+ rev (or (assoc context revs)
+ (error "Rev `%s' has body but no head"
+ context))))
+ (push (k-one@ 'log) (cdr rev))
+ ;; For rev body `text' tags, delay translation slightly...
+ (push (k-one@ 'text t) (cdr rev))
+ ;; ... until we decide which tag and value is appropriate to
+ ;; collect. For the "head" revision, compute the value of the
+ ;; `text' printed representation by simple `gather'. For all
+ ;; other revisions, replace the `text' tag+value with `:insn'
+ ;; plus value, always scanning in-place.
+ (if (string= context (cdr (assq 'head headers)))
+ (setcdr (cadr rev) (gather))
+ (if @-holes
+ (setq asc (nreverse @-holes)
+ sub 'incg)
+ (setq sub 'buffer-substring-no-properties))
+ (goto-char b)
+ (setq acc nil)
+ (while (< (point) e)
+ (forward-char 1)
+ (setq cmd (char-before)
+ start (read (current-buffer))
+ act (read (current-buffer)))
+ (forward-char 1)
+ (push (case cmd
+ (?d
+ ;; `d' means "delete lines".
+ ;; For Emacs spirit, we use `k' for "kill".
+ `(,start k ,act))
+ (?a
+ ;; `a' means "append after this line" but
+ ;; internally we normalize it so that START
+ ;; specifies the actual line for insert, thus
+ ;; requiring less hair in the realization algs.
+ ;; For Emacs spirit, we use `i' for "insert".
+ `(,(1+ start) i
+ ,(funcall sub (point) (progn (forward-line act)
+ (point)))))
+ (t (error "Bad command `%c' in `text' for rev `%s'"
+ cmd context)))
+ acc))
+ (goto-char (1+ e))
+ (setcar (cdr rev) (cons :insn acc)))))))
+ ;; rv
+ `((headers ,desc ,@headers)
+ (revisions ,@revs)))))
+
+(provide 'vc-rcs)
+
+;; arch-tag: 759b4916-5b0d-431d-b647-b185b8c652cf
+;;; vc-rcs.el ends here
--- /dev/null
- ;; 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;;; 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, 2011
+;; Free Software Foundation, Inc.
+
+;; Author: FSF (see vc.el for full credits)
+;; Maintainer: Andre Spiegel <spiegel@gnu.org>
+;; Package: 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 <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Proper function of the SCCS diff commands requires the shellscript vcdiff
+;; to be installed somewhere on Emacs's path for executables.
+;;
+
+;;; Code:
+
+(eval-when-compile
+ (require 'vc))
+
+;;;
+;;; Customization options
+;;;
+
+;; ;; Maybe a better solution is to not use "get" but "sccs get".
+;; (defcustom vc-sccs-path
+;; (let ((path ()))
+;; (dolist (dir '("/usr/sccs" "/usr/lib/sccs" "/usr/libexec/sccs"))
+;; (if (file-directory-p dir)
+;; (push dir path)))
+;; path)
+;; "List of extra directories to search for SCCS commands."
+;; :type '(repeat directory)
+;; :group 'vc)
+
+(defcustom vc-sccs-register-switches nil
+ "Switches for registering a file in SCCS.
+A string or list of strings passed to the checkin program by
+\\[vc-register]. If nil, use the value of `vc-register-switches'.
+If t, use no switches."
+ :type '(choice (const :tag "Unspecified" nil)
+ (const :tag "None" t)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List" :value ("") string))
+ :version "21.1"
+ :group 'vc)
+
+(defcustom vc-sccs-diff-switches nil
+ "String or list of strings specifying switches for SCCS diff under VC.
+If nil, use the value of `vc-diff-switches'. If t, use no switches."
+ :type '(choice (const :tag "Unspecified" nil)
+ (const :tag "None" t)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List" :value ("") string))
+ :version "21.1"
+ :group 'vc)
+
+(defcustom vc-sccs-header '("%W%")
+ "Header keywords to be inserted by `vc-insert-headers'."
+ :type '(repeat string)
+ :version "24.1" ; no longer consult the obsolete vc-header-alist
+ :group 'vc)
+
+;;;###autoload
+(defcustom vc-sccs-master-templates
+ (purecopy '("%sSCCS/s.%s" "%ss.%s" vc-sccs-search-project-dir))
+ "Where to look for SCCS master files.
+For a description of possible values, see `vc-check-master-templates'."
+ :type '(choice (const :tag "Use standard SCCS file names"
+ ("%sSCCS/s.%s" "%ss.%s" vc-sccs-search-project-dir))
+ (repeat :tag "User-specified"
+ (choice string
+ function)))
+ :version "21.1"
+ :group 'vc)
+
+\f
+;;;
+;;; Internal variables
+;;;
+
+(defconst vc-sccs-name-assoc-file "VC-names")
+
+\f
+;;; Properties of the backend
+
+(defun vc-sccs-revision-granularity () 'file)
+(defun vc-sccs-checkout-model (files) 'locking)
+
+;;;
+;;; State-querying functions
+;;;
+
+;; The autoload cookie below places vc-sccs-registered directly into
+;; loaddefs.el, so that vc-sccs.el does not need to be loaded for
+;; every file that is visited. The definition is repeated below
+;; so that Help and etags can find it.
+
+;;;###autoload (defun vc-sccs-registered(f) (vc-default-registered 'SCCS f))
+(defun vc-sccs-registered (f) (vc-default-registered 'SCCS f))
+
+(defun vc-sccs-state (file)
+ "SCCS-specific function to compute the version control state."
+ (if (not (vc-sccs-registered file))
+ 'unregistered
+ (with-temp-buffer
+ (if (vc-insert-file (vc-sccs-lock-file file))
+ (let* ((locks (vc-sccs-parse-locks))
+ (working-revision (vc-working-revision file))
+ (locking-user (cdr (assoc working-revision locks))))
+ (if (not locking-user)
+ (if (vc-workfile-unchanged-p file)
+ 'up-to-date
+ 'unlocked-changes)
+ (if (string= locking-user (vc-user-login-name file))
+ 'edited
+ locking-user)))
+ 'up-to-date))))
+
+(defun vc-sccs-state-heuristic (file)
+ "SCCS-specific state heuristic."
+ (if (not (vc-mistrust-permissions file))
+ ;; This implementation assumes that any file which is under version
+ ;; control and has -rw-r--r-- is locked by its owner. This is true
+ ;; for both RCS and SCCS, which keep unlocked files at -r--r--r--.
+ ;; We have to be careful not to exclude files with execute bits on;
+ ;; scripts can be under version control too. Also, we must ignore the
+ ;; group-read and other-read bits, since paranoid users turn them off.
+ (let* ((attributes (file-attributes file 'string))
+ (owner-name (nth 2 attributes))
+ (permissions (nth 8 attributes)))
+ (if (string-match ".r-..-..-." permissions)
+ 'up-to-date
+ (if (string-match ".rw..-..-." permissions)
+ (if (file-ownership-preserved-p file)
+ 'edited
+ owner-name)
+ ;; Strange permissions.
+ ;; Fall through to real state computation.
+ (vc-sccs-state file))))
+ (vc-sccs-state file)))
+
+(defun vc-sccs-dir-status (dir update-function)
+ ;; FIXME: this function should be rewritten, using `vc-expand-dirs'
+ ;; is not TRTD because it returns files from multiple backends.
+ ;; It should also return 'unregistered files.
+
+ ;; Doing lots of individual VC-state calls is painful, but
+ ;; there is no better option in SCCS-land.
+ (let ((flist (vc-expand-dirs (list dir)))
+ (result nil))
+ (dolist (file flist)
+ (let ((state (vc-state file))
+ (frel (file-relative-name file)))
+ (when (and (eq (vc-backend file) 'SCCS)
+ (not (eq state 'up-to-date)))
+ (push (list frel state) result))))
+ (funcall update-function result)))
+
+(defun vc-sccs-working-revision (file)
+ "SCCS-specific version of `vc-working-revision'."
+ (with-temp-buffer
+ ;; The working revision is always the latest revision number.
+ ;; To find this number, search the entire delta table,
+ ;; rather than just the first entry, because the
+ ;; first entry might be a deleted ("R") revision.
+ (vc-insert-file (vc-name file) "^\001e\n\001[^s]")
+ (vc-parse-buffer "^\001d D \\([^ ]+\\)" 1)))
+
+(defun vc-sccs-workfile-unchanged-p (file)
+ "SCCS-specific implementation of `vc-workfile-unchanged-p'."
+ (zerop (apply 'vc-do-command "*vc*" 1 "vcdiff" (vc-name file)
+ (list "--brief" "-q"
+ (concat "-r" (vc-working-revision file))))))
+
+\f
+;;;
+;;; State-changing functions
+;;;
+
+(defun vc-sccs-do-command (buffer okstatus command file-or-list &rest flags)
+ ;; (let ((load-path (append vc-sccs-path load-path)))
+ ;; (apply 'vc-do-command buffer okstatus command file-or-list flags))
+ (apply 'vc-do-command (or buffer "*vc*") okstatus "sccs" file-or-list command flags))
+
+(defun vc-sccs-create-repo ()
+ "Create a new SCCS repository."
+ ;; SCCS is totally file-oriented, so all we have to do is make the directory
+ (make-directory "SCCS"))
+
+(defun vc-sccs-register (files &optional rev comment)
+ "Register FILES into the SCCS version-control system.
+REV is the optional revision number for the file. COMMENT can be used
+to provide an initial description of FILES.
+Passes either `vc-sccs-register-switches' or `vc-register-switches'
+to the SCCS command.
+
+Automatically retrieve a read-only version of the files with keywords
+expanded if `vc-keep-workfiles' is non-nil, otherwise, delete the workfile."
+ (dolist (file files)
+ (let* ((dirname (or (file-name-directory file) ""))
+ (basename (file-name-nondirectory file))
+ (project-file (vc-sccs-search-project-dir dirname basename)))
+ (let ((vc-name
+ (or project-file
+ (format (car vc-sccs-master-templates) dirname basename))))
+ (apply 'vc-sccs-do-command nil 0 "admin" vc-name
+ (and rev (not (string= rev "")) (concat "-r" rev))
+ "-fb"
+ (concat "-i" (file-relative-name file))
+ (and comment (concat "-y" comment))
+ (vc-switches 'SCCS 'register)))
+ (delete-file file)
+ (if vc-keep-workfiles
+ (vc-sccs-do-command nil 0 "get" (vc-name file))))))
+
+(defun vc-sccs-responsible-p (file)
+ "Return non-nil if SCCS thinks it would be responsible for registering FILE."
+ ;; TODO: check for all the patterns in vc-sccs-master-templates
+ (or (file-directory-p (expand-file-name "SCCS" (file-name-directory file)))
+ (stringp (vc-sccs-search-project-dir (or (file-name-directory file) "")
+ (file-name-nondirectory file)))))
+
+(defun vc-sccs-checkin (files rev comment)
+ "SCCS-specific version of `vc-backend-checkin'."
+ (dolist (file (vc-expand-dirs files))
+ (apply 'vc-sccs-do-command nil 0 "delta" (vc-name file)
+ (if rev (concat "-r" rev))
+ (concat "-y" comment)
+ (vc-switches 'SCCS 'checkin))
+ (if vc-keep-workfiles
+ (vc-sccs-do-command nil 0 "get" (vc-name file)))))
+
+(defun vc-sccs-find-revision (file rev buffer)
+ (apply 'vc-sccs-do-command
+ buffer 0 "get" (vc-name file)
+ "-s" ;; suppress diagnostic output
+ "-p"
+ (and rev
+ (concat "-r"
+ (vc-sccs-lookup-triple file rev)))
+ (vc-switches 'SCCS 'checkout)))
+
+(defun vc-sccs-checkout (file &optional editable rev)
+ "Retrieve a copy of a saved revision of SCCS controlled FILE.
+If FILE is a directory, all version-controlled files beneath are checked out.
+EDITABLE non-nil means that the file should be writable and
+locked. REV is the revision to check out."
+ (if (file-directory-p file)
+ (mapc 'vc-sccs-checkout (vc-expand-dirs (list file)))
+ (let ((file-buffer (get-file-buffer file))
+ switches)
+ (message "Checking out %s..." file)
+ (save-excursion
+ ;; Change buffers to get local value of vc-checkout-switches.
+ (if file-buffer (set-buffer file-buffer))
+ (setq switches (vc-switches 'SCCS 'checkout))
+ ;; Save this buffer's default-directory
+ ;; and use save-excursion to make sure it is restored
+ ;; in the same buffer it was saved in.
+ (let ((default-directory default-directory))
+ (save-excursion
+ ;; Adjust the default-directory so that the check-out creates
+ ;; the file in the right place.
+ (setq default-directory (file-name-directory file))
+
+ (and rev (or (string= rev "")
+ (not (stringp rev)))
+ (setq rev nil))
+ (apply 'vc-sccs-do-command nil 0 "get" (vc-name file)
+ (if editable "-e")
+ (and rev (concat "-r" (vc-sccs-lookup-triple file rev)))
+ switches))))
+ (message "Checking out %s...done" file))))
+
+(defun vc-sccs-rollback (files)
+ "Roll back, undoing the most recent checkins of FILES. Directories
+are expanded to all version-controlled subfiles."
+ (setq files (vc-expand-dirs files))
+ (if (not files)
+ (error "SCCS backend doesn't support directory-level rollback"))
+ (dolist (file files)
+ (let ((discard (vc-working-revision file)))
+ (if (null (yes-or-no-p (format "Remove version %s from %s history? "
+ discard file)))
+ (error "Aborted"))
+ (message "Removing revision %s from %s..." discard file)
+ (vc-sccs-do-command nil 0 "rmdel"
+ (vc-name file) (concat "-r" discard))
+ (vc-sccs-do-command nil 0 "get" (vc-name file) nil))))
+
+(defun vc-sccs-revert (file &optional contents-done)
+ "Revert FILE to the version it was based on. If FILE is a directory,
+revert all subfiles."
+ (if (file-directory-p file)
+ (mapc 'vc-sccs-revert (vc-expand-dirs (list file)))
+ (vc-sccs-do-command nil 0 "unget" (vc-name file))
+ (vc-sccs-do-command nil 0 "get" (vc-name file))
+ ;; Checking out explicit revisions is not supported under SCCS, yet.
+ ;; We always "revert" to the latest revision; therefore
+ ;; vc-working-revision is cleared here so that it gets recomputed.
+ (vc-file-setprop file 'vc-working-revision nil)))
+
+(defun vc-sccs-steal-lock (file &optional rev)
+ "Steal the lock on the current workfile for FILE and revision REV."
+ (if (file-directory-p file)
+ (mapc 'vc-sccs-steal-lock (vc-expand-dirs (list file)))
+ (vc-sccs-do-command nil 0 "unget"
+ (vc-name file) "-n" (if rev (concat "-r" rev)))
+ (vc-sccs-do-command nil 0 "get"
+ (vc-name file) "-g" (if rev (concat "-r" rev)))))
+
+(defun vc-sccs-modify-change-comment (files rev comment)
+ "Modify (actually, append to) the change comments for FILES on a specified REV."
+ (dolist (file (vc-expand-dirs files))
+ (vc-sccs-do-command nil 0 "cdc" (vc-name file)
+ (concat "-y" comment) (concat "-r" rev))))
+
+\f
+;;;
+;;; History functions
+;;;
+
+(defun vc-sccs-print-log (files buffer &optional shortlog start-revision-ignored limit)
+ "Get change log associated with FILES."
+ (setq files (vc-expand-dirs files))
+ (vc-sccs-do-command buffer 0 "prs" (mapcar 'vc-name files))
+ (when limit 'limit-unsupported))
+
+(defun vc-sccs-diff (files &optional oldvers newvers buffer)
+ "Get a difference report using SCCS between two filesets."
+ (setq files (vc-expand-dirs files))
+ (setq oldvers (vc-sccs-lookup-triple (car files) oldvers))
+ (setq newvers (vc-sccs-lookup-triple (car files) newvers))
+ (apply 'vc-do-command (or buffer "*vc-diff*")
+ 1 "vcdiff" (mapcar 'vc-name (vc-expand-dirs files))
+ (append (list "-q"
+ (and oldvers (concat "-r" oldvers))
+ (and newvers (concat "-r" newvers)))
+ (vc-switches 'SCCS 'diff))))
+
+\f
+;;;
+;;; Tag system. SCCS doesn't have tags, so we simulate them by maintaining
+;;; our own set of name-to-revision mappings.
+;;;
+
+(defun vc-sccs-create-tag (backend dir name branchp)
+ (when branchp
+ (error "SCCS backend %s does not support module branches" backend))
+ (let ((result (vc-tag-precondition dir)))
+ (if (stringp result)
+ (error "File %s is not up-to-date" result)
+ (vc-file-tree-walk
+ dir
+ (lambda (f)
+ (vc-sccs-add-triple name f (vc-working-revision f)))))))
+
+\f
+;;;
+;;; Miscellaneous
+;;;
+
+(defun vc-sccs-previous-revision (file rev)
+ (vc-call-backend 'RCS 'previous-revision file rev))
+
+(defun vc-sccs-next-revision (file rev)
+ (vc-call-backend 'RCS 'next-revision file rev))
+
+(defun vc-sccs-check-headers ()
+ "Check if the current file has any headers in it."
+ (save-excursion
+ (goto-char (point-min))
+ (re-search-forward "%[A-Z]%" nil t)))
+
+(defun vc-sccs-rename-file (old new)
+ ;; Move the master file (using vc-rcs-master-templates).
+ (vc-rename-master (vc-name old) new vc-sccs-master-templates)
+ ;; Update the tag file.
+ (with-current-buffer
+ (find-file-noselect
+ (expand-file-name vc-sccs-name-assoc-file
+ (file-name-directory (vc-name old))))
+ (goto-char (point-min))
+ ;; (replace-regexp (concat ":" (regexp-quote old) "$") (concat ":" new))
+ (while (re-search-forward (concat ":" (regexp-quote old) "$") nil t)
+ (replace-match (concat ":" new) nil nil))
+ (basic-save-buffer)
+ (kill-buffer (current-buffer))))
+
+(defun vc-sccs-find-file-hook ()
+ ;; If the file is locked by some other user, make
+ ;; the buffer read-only. Like this, even root
+ ;; cannot modify a file that someone else has locked.
+ (and (stringp (vc-state buffer-file-name 'SCCS))
+ (setq buffer-read-only t)))
+
+\f
+;;;
+;;; Internal functions
+;;;
+
+;; This function is wrapped with `progn' so that the autoload cookie
+;; copies the whole function itself into loaddefs.el rather than just placing
+;; a (autoload 'vc-sccs-search-project-dir "vc-sccs") which would not
+;; help us avoid loading vc-sccs.
+;;;###autoload
+(progn (defun vc-sccs-search-project-dir (dirname basename)
+ "Return the name of a master file in the SCCS project directory.
+Does not check whether the file exists but returns nil if it does not
+find any project directory."
+ (let ((project-dir (getenv "PROJECTDIR")) dirs dir)
+ (when project-dir
+ (if (file-name-absolute-p project-dir)
+ (setq dirs '("SCCS" ""))
+ (setq dirs '("src/SCCS" "src" "source/SCCS" "source"))
+ (setq project-dir (expand-file-name (concat "~" project-dir))))
+ (while (and (not dir) dirs)
+ (setq dir (expand-file-name (car dirs) project-dir))
+ (unless (file-directory-p dir)
+ (setq dir nil)
+ (setq dirs (cdr dirs))))
+ (and dir (expand-file-name (concat "s." basename) dir))))))
+
+(defun vc-sccs-lock-file (file)
+ "Generate lock file name corresponding to FILE."
+ (let ((master (vc-name file)))
+ (and
+ master
+ (string-match "\\(.*/\\)\\(s\\.\\)\\(.*\\)" master)
+ (replace-match "p." t t master 2))))
+
+(defun vc-sccs-parse-locks ()
+ "Parse SCCS locks in current buffer.
+The result is a list of the form ((REVISION . USER) (REVISION . USER) ...)."
+ (let (master-locks)
+ (goto-char (point-min))
+ (while (re-search-forward "^\\([0-9.]+\\) [0-9.]+ \\([^ ]+\\) .*\n?"
+ nil t)
+ (setq master-locks
+ (cons (cons (match-string 1) (match-string 2)) master-locks)))
+ ;; FIXME: is it really necessary to reverse ?
+ (nreverse master-locks)))
+
+(defun vc-sccs-add-triple (name file rev)
+ (with-current-buffer
+ (find-file-noselect
+ (expand-file-name vc-sccs-name-assoc-file
+ (file-name-directory (vc-name file))))
+ (goto-char (point-max))
+ (insert name "\t:\t" file "\t" rev "\n")
+ (basic-save-buffer)
+ (kill-buffer (current-buffer))))
+
+(defun vc-sccs-lookup-triple (file name)
+ "Return the numeric revision corresponding to a named tag of FILE.
+If NAME is nil or a revision number string it's just passed through."
+ (if (or (null name)
+ (let ((firstchar (aref name 0)))
+ (and (>= firstchar ?0) (<= firstchar ?9))))
+ name
+ (with-temp-buffer
+ (vc-insert-file
+ (expand-file-name vc-sccs-name-assoc-file
+ (file-name-directory (vc-name file))))
+ (vc-parse-buffer (concat name "\t:\t" file "\t\\(.+\\)") 1))))
+
+(provide 'vc-sccs)
+
+;; arch-tag: d751dee3-d7b3-47e1-95e3-7ae98c052041
+;;; vc-sccs.el ends here
--- /dev/null
- ;; Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;;; vc-svn.el --- non-resident support for Subversion version-control
+
++;; Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
+;; Free Software Foundation, Inc.
+
+;; Author: FSF (see vc.el for full credits)
+;; Maintainer: Stefan Monnier <monnier@gnu.org>
+;; Package: 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 <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Sync'd with Subversion's vc-svn.el as of revision 5801. but this version
+;; has been extensively modified since to handle filesets.
+
+;;; Code:
+
+(eval-when-compile
+ (require 'vc))
+
+;; Clear up the cache to force vc-call to check again and discover
+;; new functions when we reload this file.
+(put 'SVN 'vc-functions nil)
+
+;;;
+;;; Customization options
+;;;
+
+;; FIXME there is also svnadmin.
+(defcustom vc-svn-program "svn"
+ "Name of the SVN executable."
+ :type 'string
+ :group 'vc)
+
+(defcustom vc-svn-global-switches nil
+ "Global switches to pass to any SVN command."
+ :type '(choice (const :tag "None" nil)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List"
+ :value ("")
+ string))
+ :version "22.1"
+ :group 'vc)
+
+(defcustom vc-svn-register-switches nil
+ "Switches for registering a file into SVN.
+A string or list of strings passed to the checkin program by
+\\[vc-register]. If nil, use the value of `vc-register-switches'.
+If t, use no switches."
+ :type '(choice (const :tag "Unspecified" nil)
+ (const :tag "None" t)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List" :value ("") string))
+ :version "22.1"
+ :group 'vc)
+
+(defcustom vc-svn-diff-switches
+ t ;`svn' doesn't support common args like -c or -b.
+ "String or list of strings specifying extra switches for svn diff under VC.
+If nil, use the value of `vc-diff-switches' (or `diff-switches'),
+together with \"-x --diff-cmd=diff\" (since svn diff does not
+support the default \"-c\" value of `diff-switches'). If you
+want to force an empty list of arguments, use t."
+ :type '(choice (const :tag "Unspecified" nil)
+ (const :tag "None" t)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List"
+ :value ("")
+ string))
+ :version "22.1"
+ :group 'vc)
+
+(defcustom vc-svn-header '("\$Id\$")
+ "Header keywords to be inserted by `vc-insert-headers'."
+ :version "24.1" ; no longer consult the obsolete vc-header-alist
+ :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 "--non-interactive" "update") ; see bug#7152
+ ;; Analyze the merge result reported by SVN, and set
+ ;; file properties accordingly.
+ (with-current-buffer (get-buffer "*vc*")
+ (goto-char (point-min))
+ ;; get new working revision
+ (if (re-search-forward
+ "^\\(Updated to\\|At\\) revision \\([0-9]+\\)" nil t)
+ (vc-file-setprop file 'vc-working-revision (match-string 2))
+ (vc-file-setprop file 'vc-working-revision nil))
+ ;; get file status
+ (goto-char (point-min))
+ (prog1
+ (if (looking-at "At revision")
+ 0 ;; there were no news; indicate success
+ (if (re-search-forward
+ ;; Newer SVN clients have 3 columns of chars (one for the
+ ;; file's contents, then second for its properties, and the
+ ;; third for lock-grabbing info), before the 2 spaces.
+ ;; We also used to match the filename in column 0 without any
+ ;; meta-info before it, but I believe this can never happen.
+ (concat "^\\(\\([ACGDU]\\)\\(.[B ]\\)? \\)"
+ (regexp-quote (file-name-nondirectory file)))
+ nil t)
+ (cond
+ ;; Merge successful, we are in sync with repository now
+ ((string= (match-string 2) "U")
+ (vc-file-setprop file 'vc-state 'up-to-date)
+ (vc-file-setprop file 'vc-checkout-time
+ (nth 5 (file-attributes file)))
+ 0);; indicate success to the caller
+ ;; Merge successful, but our own changes are still in the file
+ ((string= (match-string 2) "G")
+ (vc-file-setprop file 'vc-state 'edited)
+ 0);; indicate success to the caller
+ ;; Conflicts detected!
+ (t
+ (vc-file-setprop file 'vc-state 'edited)
+ 1);; signal the error to the caller
+ )
+ (pop-to-buffer "*vc*")
+ (error "Couldn't analyze svn update result")))
+ (message "Merging changes into %s...done" file))))
+
+(defun vc-svn-modify-change-comment (files rev comment)
+ "Modify the change comments for a specified REV.
+You must have ssh access to the repository host, and the directory Emacs
+uses locally for temp files must also be writable by you on that host.
+This is only supported if the repository access method is either file://
+or svn+ssh://."
+ (let (tempfile host remotefile directory fileurl-p)
+ (with-temp-buffer
+ (vc-do-command (current-buffer) 0 vc-svn-program nil "info")
+ (goto-char (point-min))
+ (unless (re-search-forward "Repository Root: \\(file://\\(/.*\\)\\)\\|\\(svn\\+ssh://\\([^/]+\\)\\(/.*\\)\\)" nil t)
+ (error "Repository information is unavailable"))
+ (if (match-string 1)
+ (progn
+ (setq fileurl-p t)
+ (setq directory (match-string 2)))
+ (setq host (match-string 4))
+ (setq directory (match-string 5))
+ (setq remotefile (concat host ":" tempfile))))
+ (with-temp-file (setq tempfile (make-temp-file user-mail-address))
+ (insert comment))
+ (if fileurl-p
+ ;; Repository Root is a local file.
+ (progn
+ (unless (vc-do-command
+ "*vc*" 0 "svnadmin" nil
+ "setlog" "--bypass-hooks" directory
+ "-r" rev (format "%s" tempfile))
+ (error "Log edit failed"))
+ (delete-file tempfile))
+
+ ;; Remote repository, using svn+ssh.
+ (unless (vc-do-command "*vc*" 0 "scp" nil "-q" tempfile remotefile)
+ (error "Copy of comment to %s failed" remotefile))
+ (unless (vc-do-command
+ "*vc*" 0 "ssh" nil "-q" host
+ (format "svnadmin setlog --bypass-hooks %s -r %s %s; rm %s"
+ directory rev tempfile tempfile))
+ (error "Log edit failed")))))
+
+;;;
+;;; History functions
+;;;
+
+(defvar log-view-per-file-logs)
+
+(define-derived-mode vc-svn-log-view-mode log-view-mode "SVN-Log-View"
+ (require 'add-log)
+ (set (make-local-variable 'log-view-per-file-logs) nil))
+
+(defun vc-svn-print-log (files buffer &optional shortlog start-revision limit)
+ "Get change log(s) associated with FILES."
+ (save-current-buffer
+ (vc-setup-buffer buffer)
+ (let ((inhibit-read-only t))
+ (goto-char (point-min))
+ (if files
+ (dolist (file files)
+ (insert "Working file: " file "\n")
+ (apply
+ 'vc-svn-command
+ buffer
+ 'async
+ ;; (if (and (= (length files) 1) (vc-stay-local-p file 'SVN)) 'async 0)
+ (list file)
+ "log"
+ (append
+ (list
+ (if start-revision
+ (format "-r%s" start-revision)
+ ;; By default Subversion only shows the log up to the
+ ;; working revision, whereas we also want the log of the
+ ;; subsequent commits. At least that's what the
+ ;; vc-cvs.el code does.
+ "-rHEAD:0"))
+ (when limit (list "--limit" (format "%s" limit))))))
+ ;; Dump log for the entire directory.
+ (apply 'vc-svn-command buffer 0 nil "log"
+ (append
+ (list
+ (if start-revision (format "-r%s" start-revision) "-rHEAD:0"))
+ (when limit (list "--limit" (format "%s" limit)))))))))
+
+(defun vc-svn-diff (files &optional oldvers newvers buffer)
+ "Get a difference report using SVN between two revisions of fileset FILES."
+ (and oldvers
+ (not newvers)
+ files
+ (catch 'no
+ (dolist (f files)
+ (or (equal oldvers (vc-working-revision f))
+ (throw 'no nil)))
+ t)
+ ;; Use nil rather than the current revision because svn handles
+ ;; it better (i.e. locally). Note that if _any_ of the files
+ ;; has a different revision, we fetch the lot, which is
+ ;; obviously sub-optimal.
+ (setq oldvers nil))
+ (let* ((switches
+ (if vc-svn-diff-switches
+ (vc-switches 'SVN 'diff)
+ (list "--diff-cmd=diff" "-x"
+ (mapconcat 'identity (vc-switches nil 'diff) " "))))
+ (async (and (not vc-disable-async-diff)
+ (vc-stay-local-p files 'SVN)
+ (or oldvers newvers)))) ; Svn diffs those locally.
+ (apply 'vc-svn-command buffer
+ (if async 'async 0)
+ files "diff"
+ (append
+ switches
+ (when oldvers
+ (list "-r" (if newvers (concat oldvers ":" newvers)
+ oldvers)))))
+ (if async 1 ; async diff => pessimistic assumption
+ ;; For some reason `svn diff' does not return a useful
+ ;; status w.r.t whether the diff was empty or not.
+ (buffer-size (get-buffer buffer)))))
+
+;;;
+;;; Tag system
+;;;
+
+(defun vc-svn-create-tag (dir name branchp)
+ "Assign to DIR's current revision a given NAME.
+If BRANCHP is non-nil, the name is created as a branch (and the current
+workspace is immediately moved to that new branch).
+NAME is assumed to be a URL."
+ (vc-svn-command nil 0 dir "copy" name)
+ (when branchp (vc-svn-retrieve-tag dir name nil)))
+
+(defun vc-svn-retrieve-tag (dir name update)
+ "Retrieve a tag at and below DIR.
+NAME is the name of the tag; if it is empty, do a `svn update'.
+If UPDATE is non-nil, then update (resynch) any affected buffers.
+NAME is assumed to be a URL."
+ (vc-svn-command nil 0 dir "switch" name)
+ ;; FIXME: parse the output and obey `update'.
+ )
+
+;;;
+;;; Miscellaneous
+;;;
+
+;; Subversion makes backups for us, so don't bother.
+;; (defun vc-svn-make-version-backups-p (file)
+;; "Return non-nil if version backups should be made for FILE."
+;; (vc-stay-local-p file 'SVN))
+
+(defun vc-svn-check-headers ()
+ "Check if the current file has any headers in it."
+ (save-excursion
+ (goto-char (point-min))
+ (re-search-forward "\\$[A-Za-z\300-\326\330-\366\370-\377]+\
+\\(: [\t -#%-\176\240-\377]*\\)?\\$" nil t)))
+
+
+;;;
+;;; Internal functions
+;;;
+
+(defun vc-svn-command (buffer okstatus file-or-list &rest flags)
+ "A wrapper around `vc-do-command' for use in vc-svn.el.
+The difference to vc-do-command is that this function always invokes `svn',
+and that it passes `vc-svn-global-switches' to it before FLAGS."
+ (apply 'vc-do-command (or buffer "*vc*") okstatus vc-svn-program file-or-list
+ (if (stringp vc-svn-global-switches)
+ (cons vc-svn-global-switches flags)
+ (append vc-svn-global-switches
+ flags))))
+
+(defun vc-svn-repository-hostname (dirname)
+ (with-temp-buffer
+ (let ((coding-system-for-read
+ (or file-name-coding-system
+ default-file-name-coding-system)))
+ (vc-insert-file (expand-file-name (concat vc-svn-admin-directory
+ "/entries")
+ dirname)))
+ (goto-char (point-min))
+ (when (re-search-forward
+ ;; Old `svn' used name="svn:this_dir", newer use just name="".
+ (concat "name=\"\\(?:svn:this_dir\\)?\"[\n\t ]*"
+ "\\(?:[-a-z]+=\"[^\"]*\"[\n\t ]*\\)*?"
+ "url=\"\\(?1:[^\"]+\\)\""
+ ;; Yet newer ones don't use XML any more.
+ "\\|^\ndir\n[0-9]+\n\\(?1:.*\\)") nil t)
+ ;; This is not a hostname but a URL. This may actually be considered
+ ;; as a feature since it allows vc-svn-stay-local to specify different
+ ;; behavior for different modules on the same server.
+ (match-string 1))))
+
+(defun vc-svn-resolve-when-done ()
+ "Call \"svn resolved\" if the conflict markers have been removed."
+ (save-excursion
+ (goto-char (point-min))
+ (unless (re-search-forward "^<<<<<<< " nil t)
+ (vc-svn-command nil 0 buffer-file-name "resolved")
+ ;; Remove the hook so that it is not called multiple times.
+ (remove-hook 'after-save-hook 'vc-svn-resolve-when-done t))))
+
+;; Inspired by vc-arch-find-file-hook.
+(defun vc-svn-find-file-hook ()
+ (when (eq ?C (vc-file-getprop buffer-file-name 'vc-svn-status))
+ ;; If the file is marked as "conflicted", then we should try and call
+ ;; "svn resolved" when applicable.
+ (if (save-excursion
+ (goto-char (point-min))
+ (re-search-forward "^<<<<<<< " nil t))
+ ;; There are conflict markers.
+ (progn
+ (smerge-start-session)
+ (add-hook 'after-save-hook 'vc-svn-resolve-when-done nil t))
+ ;; There are no conflict markers. This is problematic: maybe it means
+ ;; the conflict has been resolved and we should immediately call "svn
+ ;; resolved", or it means that the file's type does not allow Svn to
+ ;; use conflict markers in which case we don't really know what to do.
+ ;; So let's just punt for now.
+ nil)
+ (message "There are unresolved conflicts in this file")))
+
+(defun vc-svn-parse-status (&optional filename)
+ "Parse output of \"svn status\" command in the current buffer.
+Set file properties accordingly. Unless FILENAME is non-nil, parse only
+information about FILENAME and return its status."
+ (let (file status)
+ (goto-char (point-min))
+ (while (re-search-forward
+ ;; Ignore the files with status X.
+ "^\\(?:\\?\\|[ ACDGIMR!~][ MC][ L][ +][ S]..\\([ *]\\) +\\([-0-9]+\\) +\\([0-9?]+\\) +\\([^ ]+\\)\\) +" nil t)
+ ;; If the username contains spaces, the output format is ambiguous,
+ ;; so don't trust the output's filename unless we have to.
+ (setq file (or filename
+ (expand-file-name
+ (buffer-substring (point) (line-end-position)))))
+ (setq status (char-after (line-beginning-position)))
+ (if (eq status ??)
+ (vc-file-setprop file 'vc-state 'unregistered)
+ ;; Use the last-modified revision, so that searching in vc-print-log
+ ;; output works.
+ (vc-file-setprop file 'vc-working-revision (match-string 3))
+ ;; Remember Svn's own status.
+ (vc-file-setprop file 'vc-svn-status status)
+ (vc-file-setprop
+ file 'vc-state
+ (cond
+ ((eq status ?\ )
+ (if (eq (char-after (match-beginning 1)) ?*)
+ 'needs-update
+ (vc-file-setprop file 'vc-checkout-time
+ (nth 5 (file-attributes file)))
+ 'up-to-date))
+ ((eq status ?A)
+ ;; If the file was actually copied, (match-string 2) is "-".
+ (vc-file-setprop file 'vc-working-revision "0")
+ (vc-file-setprop file 'vc-checkout-time 0)
+ 'added)
+ ((eq status ?C)
+ (vc-file-setprop file 'vc-state 'conflict))
+ ((eq status '?M)
+ (if (eq (char-after (match-beginning 1)) ?*)
+ 'needs-merge
+ 'edited))
+ ((eq status ?I)
+ (vc-file-setprop file 'vc-state 'ignored))
+ ((memq status '(?D ?R))
+ (vc-file-setprop file 'vc-state 'removed))
+ (t 'edited)))))
+ (when filename (vc-file-getprop filename 'vc-state))))
+
+(defun vc-svn-valid-symbolic-tag-name-p (tag)
+ "Return non-nil if TAG is a valid symbolic tag name."
+ ;; According to the SVN manual, a valid symbolic tag must start with
+ ;; an uppercase or lowercase letter and can contain uppercase and
+ ;; lowercase letters, digits, `-', and `_'.
+ (and (string-match "^[a-zA-Z]" tag)
+ (not (string-match "[^a-z0-9A-Z-_]" tag))))
+
+(defun vc-svn-valid-revision-number-p (tag)
+ "Return non-nil if TAG is a valid revision number."
+ (and (string-match "^[0-9]" tag)
+ (not (string-match "[^0-9]" tag))))
+
+;; Support for `svn annotate'
+
+(defun vc-svn-annotate-command (file buf &optional rev)
+ (vc-svn-command buf 'async file "annotate" (if rev (concat "-r" rev))))
+
+(defun vc-svn-annotate-time-of-rev (rev)
+ ;; Arbitrarily assume 10 commmits per day.
+ (/ (string-to-number rev) 10.0))
+
+(defvar vc-annotate-parent-rev)
+
+(defun vc-svn-annotate-current-time ()
+ (vc-svn-annotate-time-of-rev vc-annotate-parent-rev))
+
+(defconst vc-svn-annotate-re "[ \t]*\\([0-9]+\\)[ \t]+[^\t ]+ ")
+
+(defun vc-svn-annotate-time ()
+ (when (looking-at vc-svn-annotate-re)
+ (goto-char (match-end 0))
+ (vc-svn-annotate-time-of-rev (match-string 1))))
+
+(defun vc-svn-annotate-extract-revision-at-line ()
+ (save-excursion
+ (beginning-of-line)
+ (if (looking-at vc-svn-annotate-re) (match-string 1))))
+
+(defun vc-svn-revision-table (files)
+ (let ((vc-svn-revisions '()))
+ (with-current-buffer "*vc*"
+ (vc-svn-command nil 0 files "log" "-q")
+ (goto-char (point-min))
+ (forward-line)
+ (let ((start (point-min))
+ (loglines (buffer-substring-no-properties (point-min)
+ (point-max))))
+ (while (string-match "^r\\([0-9]+\\) " loglines)
+ (push (match-string 1 loglines) vc-svn-revisions)
+ (setq start (+ start (match-end 0)))
+ (setq loglines (buffer-substring-no-properties start (point-max)))))
+ vc-svn-revisions)))
+
+(provide 'vc-svn)
+
+;; arch-tag: 02f10c68-2b4d-453a-90fc-1eee6cfb268d
+;;; vc-svn.el ends here
--- /dev/null
- ;; 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;;; 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, 2011
+;; Free Software Foundation, Inc.
+
+;; Author: FSF (see below for full credits)
+;; Maintainer: Andre Spiegel <spiegel@gnu.org>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; Credits:
+
+;; VC was initially designed and implemented by Eric S. Raymond
+;; <esr@thyrsus.com> in 1992. Over the years, many other people have
+;; contributed substantial amounts of work to VC. These include:
+;;
+;; Per Cederqvist <ceder@lysator.liu.se>
+;; Paul Eggert <eggert@twinsun.com>
+;; Sebastian Kremer <sk@thp.uni-koeln.de>
+;; Martin Lorentzson <martinl@gnu.org>
+;; Dave Love <fx@gnu.org>
+;; Stefan Monnier <monnier@cs.yale.edu>
+;; Thien-Thi Nguyen <ttn@gnu.org>
+;; Dan Nicolaescu <dann@ics.uci.edu>
+;; J.D. Smith <jdsmith@alum.mit.edu>
+;; Andre Spiegel <spiegel@gnu.org>
+;; Richard Stallman <rms@gnu.org>
+;;
+;; In July 2007 ESR returned and redesigned the mode to cope better
+;; with modern version-control systems that do commits by fileset
+;; rather than per individual file.
+;;
+;; If you maintain a client of the mode or customize it in your .emacs,
+;; note that some backend functions which formerly took single file arguments
+;; now take a list of files. These include: register, checkin, print-log,
+;; rollback, and diff.
+
+;;; Commentary:
+
+;; This mode is fully documented in the Emacs user's manual.
+;;
+;; Supported version-control systems presently include CVS, RCS, GNU
+;; Arch, Subversion, Bzr, Git, Mercurial, Monotone and SCCS
+;; (or its free replacement, CSSC).
+;;
+;; If your site uses the ChangeLog convention supported by Emacs, the
+;; function `log-edit-comment-to-change-log' could prove a useful checkin hook,
+;; although you might prefer to use C-c C-a (i.e. `log-edit-insert-changelog')
+;; from the commit buffer instead or to set `log-edit-setup-invert'.
+;;
+;; When using SCCS, RCS, CVS: be careful not to do repo surgery, or
+;; operations like registrations and deletions and renames, outside VC
+;; while VC is running. The support for these systems was designed
+;; when disks were much slower, and the code maintains a lot of
+;; internal state in order to reduce expensive operations to a
+;; minimum. Thus, if you mess with the repo while VC's back is turned,
+;; VC may get seriously confused.
+;;
+;; When using Subversion or a later system, anything you do outside VC
+;; *through the VCS tools* should safely interlock with VC
+;; operations. Under these VC does little state caching, because local
+;; operations are assumed to be fast. The dividing line is
+;;
+;; ADDING SUPPORT FOR OTHER BACKENDS
+;;
+;; VC can use arbitrary version control systems as a backend. To add
+;; support for a new backend named SYS, write a library vc-sys.el that
+;; contains functions of the form `vc-sys-...' (note that SYS is in lower
+;; case for the function and library names). VC will use that library if
+;; you put the symbol SYS somewhere into the list of
+;; `vc-handled-backends'. Then, for example, if `vc-sys-registered'
+;; returns non-nil for a file, all SYS-specific versions of VC commands
+;; will be available for that file.
+;;
+;; VC keeps some per-file information in the form of properties (see
+;; vc-file-set/getprop in vc-hooks.el). The backend-specific functions
+;; do not generally need to be aware of these properties. For example,
+;; `vc-sys-working-revision' should compute the working revision and
+;; return it; it should not look it up in the property, and it needn't
+;; store it there either. However, if a backend-specific function does
+;; store a value in a property, that value takes precedence over any
+;; value that the generic code might want to set (check for uses of
+;; the macro `with-vc-properties' in vc.el).
+;;
+;; In the list of functions below, each identifier needs to be prepended
+;; with `vc-sys-'. Some of the functions are mandatory (marked with a
+;; `*'), others are optional (`-').
+
+;; BACKEND PROPERTIES
+;;
+;; * revision-granularity
+;;
+;; Takes no arguments. Returns either 'file or 'repository. Backends
+;; that return 'file have per-file revision numbering; backends
+;; that return 'repository have per-repository revision numbering,
+;; so a revision level implicitly identifies a changeset
+
+;; STATE-QUERYING FUNCTIONS
+;;
+;; * registered (file)
+;;
+;; Return non-nil if FILE is registered in this backend. Both this
+;; function as well as `state' should be careful to fail gracefully
+;; in the event that the backend executable is absent. It is
+;; preferable that this function's body is autoloaded, that way only
+;; calling vc-registered does not cause the backend to be loaded
+;; (all the vc-FOO-registered functions are called to try to find
+;; the controlling backend for FILE.
+;;
+;; * state (file)
+;;
+;; Return the current version control state of FILE. For a list of
+;; possible values, see `vc-state'. This function should do a full and
+;; reliable state computation; it is usually called immediately after
+;; C-x v v. If you want to use a faster heuristic when visiting a
+;; file, put that into `state-heuristic' below. Note that under most
+;; VCSes this won't be called at all, dir-status is used instead.
+;;
+;; - state-heuristic (file)
+;;
+;; If provided, this function is used to estimate the version control
+;; state of FILE at visiting time. It should be considerably faster
+;; than the implementation of `state'. For a list of possible values,
+;; see the doc string of `vc-state'.
+;;
+;; - dir-status (dir update-function)
+;;
+;; Produce RESULT: a list of lists of the form (FILE VC-STATE EXTRA)
+;; for the files in DIR.
+;; EXTRA can be used for backend specific information about FILE.
+;; If a command needs to be run to compute this list, it should be
+;; run asynchronously using (current-buffer) as the buffer for the
+;; command. When RESULT is computed, it should be passed back by
+;; doing: (funcall UPDATE-FUNCTION RESULT nil).
+;; If the backend uses a process filter, hence it produces partial results,
+;; they can be passed back by doing:
+;; (funcall UPDATE-FUNCTION RESULT t)
+;; and then do a (funcall UPDATE-FUNCTION RESULT nil)
+;; when all the results have been computed.
+;; To provide more backend specific functionality for `vc-dir'
+;; the following functions might be needed: `dir-extra-headers',
+;; `dir-printer', `extra-dir-menu' and `dir-status-files'.
+;;
+;; - dir-status-files (dir files default-state update-function)
+;;
+;; This function is identical to dir-status except that it should
+;; only report status for the specified FILES. Also it needs to
+;; report on all requested files, including up-to-date or ignored
+;; files. If not provided, the default is to consider that the files
+;; are in DEFAULT-STATE.
+;;
+;; - dir-extra-headers (dir)
+;;
+;; Return a string that will be added to the *vc-dir* buffer header.
+;;
+;; - dir-printer (fileinfo)
+;;
+;; Pretty print the `vc-dir-fileinfo' FILEINFO.
+;; If a backend needs to show more information than the default FILE
+;; and STATE in the vc-dir listing, it can store that extra
+;; information in `vc-dir-fileinfo->extra'. This function can be
+;; used to display that extra information in the *vc-dir* buffer.
+;;
+;; - status-fileinfo-extra (file)
+;;
+;; Compute `vc-dir-fileinfo->extra' for FILE.
+;;
+;; * working-revision (file)
+;;
+;; Return the working revision of FILE. This is the revision fetched
+;; by the last checkout or upate, not necessarily the same thing as the
+;; head or tip revision. Should return "0" for a file added but not yet
+;; committed.
+;;
+;; - latest-on-branch-p (file)
+;;
+;; Return non-nil if the working revision of FILE is the latest revision
+;; on its branch (many VCSes call this the 'tip' or 'head' revision).
+;; The default implementation always returns t, which means that
+;; working with non-current revisions is not supported by default.
+;;
+;; * checkout-model (files)
+;;
+;; Indicate whether FILES need to be "checked out" before they can be
+;; edited. See `vc-checkout-model' for a list of possible values.
+;;
+;; - workfile-unchanged-p (file)
+;;
+;; Return non-nil if FILE is unchanged from the working revision.
+;; This function should do a brief comparison of FILE's contents
+;; with those of the repository copy of the working revision. If
+;; the backend does not have such a brief-comparison feature, the
+;; default implementation of this function can be used, which
+;; delegates to a full vc-BACKEND-diff. (Note that vc-BACKEND-diff
+;; must not run asynchronously in this case, see variable
+;; `vc-disable-async-diff'.)
+;;
+;; - mode-line-string (file)
+;;
+;; If provided, this function should return the VC-specific mode
+;; line string for FILE. The returned string should have a
+;; `help-echo' property which is the text to be displayed as a
+;; tooltip when the mouse hovers over the VC entry on the mode-line.
+;; The default implementation deals well with all states that
+;; `vc-state' can return.
+;;
+;; STATE-CHANGING FUNCTIONS
+;;
+;; * create-repo (backend)
+;;
+;; Create an empty repository in the current directory and initialize
+;; it so VC mode can add files to it. For file-oriented systems, this
+;; need do no more than create a subdirectory with the right name.
+;;
+;; * register (files &optional rev comment)
+;;
+;; Register FILES in this backend. Optionally, an initial revision REV
+;; and an initial description of the file, COMMENT, may be specified,
+;; but it is not guaranteed that the backend will do anything with this.
+;; The implementation should pass the value of vc-register-switches
+;; to the backend command. (Note: in older versions of VC, this
+;; command took a single file argument and not a list.)
+;;
+;; - init-revision (file)
+;;
+;; The initial revision to use when registering FILE if one is not
+;; specified by the user. If not provided, the variable
+;; vc-default-init-revision is used instead.
+;;
+;; - responsible-p (file)
+;;
+;; Return non-nil if this backend considers itself "responsible" for
+;; FILE, which can also be a directory. This function is used to find
+;; out what backend to use for registration of new files and for things
+;; like change log generation. The default implementation always
+;; returns nil.
+;;
+;; - could-register (file)
+;;
+;; Return non-nil if FILE could be registered under this backend. The
+;; default implementation always returns t.
+;;
+;; - receive-file (file rev)
+;;
+;; Let this backend "receive" a file that is already registered under
+;; another backend. The default implementation simply calls `register'
+;; for FILE, but it can be overridden to do something more specific,
+;; e.g. keep revision numbers consistent or choose editing modes for
+;; FILE that resemble those of the other backend.
+;;
+;; - unregister (file)
+;;
+;; Unregister FILE from this backend. This is only needed if this
+;; backend may be used as a "more local" backend for temporary editing.
+;;
+;; * checkin (files rev comment)
+;;
+;; Commit changes in FILES to this backend. REV is a historical artifact
+;; and should be ignored. COMMENT is used as a check-in comment.
+;; The implementation should pass the value of vc-checkin-switches to
+;; the backend command.
+;;
+;; * find-revision (file rev buffer)
+;;
+;; Fetch revision REV of file FILE and put it into BUFFER.
+;; If REV is the empty string, fetch the head of the trunk.
+;; The implementation should pass the value of vc-checkout-switches
+;; to the backend command.
+;;
+;; * checkout (file &optional editable rev)
+;;
+;; Check out revision REV of FILE into the working area. If EDITABLE
+;; is non-nil, FILE should be writable by the user and if locking is
+;; used for FILE, a lock should also be set. If REV is non-nil, that
+;; is the revision to check out (default is the working revision).
+;; If REV is t, that means to check out the head of the current branch;
+;; if it is the empty string, check out the head of the trunk.
+;; The implementation should pass the value of vc-checkout-switches
+;; to the backend command.
+;;
+;; * revert (file &optional contents-done)
+;;
+;; Revert FILE back to the working revision. If optional
+;; arg CONTENTS-DONE is non-nil, then the contents of FILE have
+;; already been reverted from a version backup, and this function
+;; only needs to update the status of FILE within the backend.
+;; If FILE is in the `added' state it should be returned to the
+;; `unregistered' state.
+;;
+;; - rollback (files)
+;;
+;; Remove the tip revision of each of FILES from the repository. If
+;; this function is not provided, trying to cancel a revision is
+;; caught as an error. (Most backends don't provide it.) (Also
+;; note that older versions of this backend command were called
+;; 'cancel-version' and took a single file arg, not a list of
+;; files.)
+;;
+;; - merge (file rev1 rev2)
+;;
+;; Merge the changes between REV1 and REV2 into the current working file
+;; (for non-distributed VCS).
+;;
+;; - merge-branch ()
+;;
+;; Merge another branch into the current one, prompting for a
+;; location to merge from.
+;;
+;; - merge-news (file)
+;;
+;; Merge recent changes from the current branch into FILE.
+;; (for non-distributed VCS).
+;;
+;; - pull (prompt)
+;;
+;; Pull "upstream" changes into the current branch (for distributed
+;; VCS). If PROMPT is non-nil, or if necessary, prompt for a
+;; location to pull from.
+;;
+;; - 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-BACKEND-header'."
+ :type '(repeat (cons :format "%v"
+ (regexp :tag "File Type")
+ (string :tag "Header String")))
+ :group 'vc)
+
+(defcustom vc-comment-alist
+ '((nroff-mode ".\\\"" ""))
+ "Special comment delimiters for generating VC headers.
+Add an entry in this list if you need to override the normal `comment-start'
+and `comment-end' variables. This will only be necessary if the mode language
+is sensitive to blank lines."
+ :type '(repeat (list :format "%v"
+ (symbol :tag "Mode")
+ (string :tag "Comment Start")
+ (string :tag "Comment End")))
+ :group 'vc)
+
+(defcustom vc-checkout-carefully (= (user-uid) 0)
+ "Non-nil means be extra-careful in checkout.
+Verify that the file really is not locked
+and that its contents match what the repository version says."
+ :type 'boolean
+ :group 'vc)
+(make-obsolete-variable 'vc-checkout-carefully
+ "the corresponding checks are always done now."
+ "21.1")
+
+\f
+;; Variables users don't need to see
+
+(defvar vc-disable-async-diff nil
+ "VC sets this to t locally to disable some async diff operations.
+Backends that offer asynchronous diffs should respect this variable
+in their implementation of vc-BACKEND-diff.")
+
+;; File property caching
+
+(defun vc-clear-context ()
+ "Clear all cached file properties."
+ (interactive)
+ (fillarray vc-file-prop-obarray 0))
+
+(defmacro with-vc-properties (files form settings)
+ "Execute FORM, then maybe set per-file properties for FILES.
+If any of FILES is actually a directory, then do the same for all
+buffers for files in that directory.
+SETTINGS is an association list of property/value pairs. After
+executing FORM, set those properties from SETTINGS that have not yet
+been updated to their corresponding values."
+ (declare (debug t))
+ `(let ((vc-touched-properties (list t))
+ (flist nil))
+ (dolist (file ,files)
+ (if (file-directory-p file)
+ (dolist (buffer (buffer-list))
+ (let ((fname (buffer-file-name buffer)))
+ (when (and fname (vc-string-prefix-p file fname))
+ (push fname flist))))
+ (push file flist)))
+ ,form
+ (dolist (file flist)
+ (dolist (setting ,settings)
+ (let ((property (car setting)))
+ (unless (memq property vc-touched-properties)
+ (put (intern file vc-file-prop-obarray)
+ property (cdr setting))))))))
+
+;;; Code for deducing what fileset and backend to assume
+
+(defun vc-backend-for-registration (file)
+ "Return a backend that can be used for registering FILE.
+
+If no backend declares itself responsible for FILE, then FILE
+must not be in a version controlled directory, so try to create a
+repository, prompting for the directory and the VC backend to
+use."
+ (catch 'found
+ ;; First try: find a responsible backend, it must be a backend
+ ;; under which FILE is not yet registered.
+ (dolist (backend vc-handled-backends)
+ (and (not (vc-call-backend backend 'registered file))
+ (vc-call-backend backend 'responsible-p file)
+ (throw 'found backend)))
+ ;; no responsible backend
+ (let* ((possible-backends
+ (let (pos)
+ (dolist (crt vc-handled-backends)
+ (when (vc-find-backend-function crt 'create-repo)
+ (push crt pos)))
+ pos))
+ (bk
+ (intern
+ ;; Read the VC backend from the user, only
+ ;; complete with the backends that have the
+ ;; 'create-repo method.
+ (completing-read
+ (format "%s is not in a version controlled directory.\nUse VC backend: " file)
+ (mapcar 'symbol-name possible-backends) nil t)))
+ (repo-dir
+ (let ((def-dir (file-name-directory file)))
+ ;; read the directory where to create the
+ ;; repository, make sure it's a parent of
+ ;; file.
+ (read-file-name
+ (format "create %s repository in: " bk)
+ default-directory def-dir t nil
+ (lambda (arg)
+ (message "arg %s" arg)
+ (and (file-directory-p arg)
+ (vc-string-prefix-p (expand-file-name arg) def-dir)))))))
+ (let ((default-directory repo-dir))
+ (vc-call-backend bk 'create-repo))
+ (throw 'found bk))))
+
+(defun vc-responsible-backend (file)
+ "Return the name of a backend system that is responsible for FILE.
+
+If FILE is already registered, return the
+backend of FILE. If FILE is not registered, then the
+first backend in `vc-handled-backends' that declares itself
+responsible for FILE is returned."
+ (or (and (not (file-directory-p file)) (vc-backend file))
+ (catch 'found
+ ;; First try: find a responsible backend. If this is for registration,
+ ;; it must be a backend under which FILE is not yet registered.
+ (dolist (backend vc-handled-backends)
+ (and (vc-call-backend backend 'responsible-p file)
+ (throw 'found backend))))
+ (error "No VC backend is responsible for %s" file)))
+
+(defun vc-expand-dirs (file-or-dir-list)
+ "Expands directories in a file list specification.
+Within directories, only files already under version control are noticed."
+ (let ((flattened '()))
+ (dolist (node file-or-dir-list)
+ (when (file-directory-p node)
+ (vc-file-tree-walk
+ node (lambda (f) (when (vc-backend f) (push f flattened)))))
+ (unless (file-directory-p node) (push node flattened)))
+ (nreverse flattened)))
+
+(defvar vc-dir-backend)
+(defvar log-view-vc-backend)
+(defvar diff-vc-backend)
+
+(defun vc-deduce-backend ()
+ (cond ((derived-mode-p 'vc-dir-mode) vc-dir-backend)
+ ((derived-mode-p 'log-view-mode) log-view-vc-backend)
+ ((derived-mode-p 'diff-mode) diff-vc-backend)
+ ;; Maybe we could even use comint-mode rather than shell-mode?
+ ((derived-mode-p 'dired-mode 'shell-mode 'compilation-mode)
+ (vc-responsible-backend default-directory))
+ (vc-mode (vc-backend buffer-file-name))))
+
+(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))))))
+
+(defvar vc-coding-system-inherit-eol t
+ "When non-nil, inherit the EOL format for reading Diff output from the file.
+
+Used in `vc-coding-system-for-diff' to determine the EOL format to use
+for reading Diff output for a file. If non-nil, the EOL format is
+inherited from the file itself.
+Set this variable to nil if your Diff tool might use a different
+EOL. Then Emacs will auto-detect the EOL format in Diff output, which
+gives better results.") ;; Cf. bug#4451.
+
+(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
+ (if vc-coding-system-inherit-eol
+ buffer-file-coding-system
+ ;; Don't inherit the EOL part of the coding-system,
+ ;; because some Diff tools may choose to use
+ ;; a different one. bug#4451.
+ (coding-system-base 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)
+ (set (make-local-variable 'diff-vc-backend) (car vc-fileset))
+ (set (make-local-variable 'revert-buffer-function)
+ `(lambda (ignore-auto noconfirm)
+ (vc-diff-internal ,async ',vc-fileset ,rev1 ,rev2 ,verbose)))
+ ;; 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 (vc-deduce-backend))
+ 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 &optional backend)
+ "Read REVISION of FILE into a buffer and return the buffer.
+Use BACKEND as the VC backend if specified."
+ (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
+ (if backend
+ (vc-call-backend backend 'find-revision file revision outbuf)
+ (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 ()
+ "Perform a version control merge operation.
+On a distributed version control system, this runs a \"merge\"
+operation to incorporate changes from another branch onto the
+current branch, prompting for an argument list.
+
+On a non-distributed version control system, this merges changes
+between two revisions into the current fileset. 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 the most recent
+changes from the current branch."
+ (interactive)
+ (let* ((vc-fileset (vc-deduce-fileset t))
+ (backend (car vc-fileset))
+ (files (cadr vc-fileset)))
+ (cond
+ ;; If a branch-merge operation is defined, use it.
+ ((vc-find-backend-function backend 'merge-branch)
+ (vc-call-backend backend 'merge-branch))
+ ;; Otherwise, do a per-file merge.
+ ((vc-find-backend-function backend 'merge)
+ (vc-buffer-sync)
+ (dolist (file files)
+ (let* ((state (vc-state file))
+ first-revision second-revision status)
+ (cond
+ ((stringp state) ;; Locking VCses only
+ (error "File %s is locked by %s" file state))
+ ((not (vc-editable-p file))
+ (vc-checkout file t)))
+ (setq first-revision
+ (vc-read-revision
+ (concat "Merge " file
+ "from branch or revision "
+ "(default news on current branch): ")
+ (list file)
+ backend))
+ (cond
+ ((string= first-revision "")
+ (setq status (vc-call-backend backend 'merge-news file)))
+ (t
+ (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"))))
+ (t
+ (error "Sorry, merging is not implemented for %s" backend)))))
+
+
+(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-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)
+ (backend backend)
+ (limit limit)
+ (shortlog vc-short-log)
+ (files files)
+ (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))
+ (lambda (ignore-auto noconfirm)
+ (vc-print-log-internal backend files working-revision is-start-revision limit))))))
+
+(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
+ rev-buff-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)
+ (set (make-local-variable 'revert-buffer-function)
+ rev-buff-func))
+ (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)))
+ (lexical-let
+ ((backend backend)
+ (remote-location remote-location)
+ (buffer-name buffer-name)
+ (type type))
+ (lambda (ignore-auto noconfirm)
+ (vc-incoming-outgoing-internal backend remote-location buffer-name type)))))
+
+;;;###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 (vc-deduce-backend))
+ 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.
+When called interactively with a prefix argument, prompt for REMOTE-LOCATION.."
+ (interactive
+ (when current-prefix-arg
+ (list (read-string "Remote location (empty for default): "))))
+ (let ((backend (vc-deduce-backend))
+ 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.
+When called interactively with a prefix argument, prompt for REMOTE-LOCATION."
+ (interactive
+ (when current-prefix-arg
+ (list (read-string "Remote location (empty for default): "))))
+ (let ((backend (vc-deduce-backend))
+ 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 (&optional arg)
+ "Update the current fileset or branch.
+On a distributed version control system, this runs a \"pull\"
+operation to update the current branch, prompting for an argument
+list if required. Optional prefix ARG forces a prompt.
+
+On a non-distributed version control system, update the current
+fileset to the tip revisions. For each unchanged and unlocked
+file, this simply replaces the work file with the latest revision
+on its branch. If the file contains changes, any changes in the
+tip revision are merged into the working file."
+ (interactive "P")
+ (let* ((vc-fileset (vc-deduce-fileset t))
+ (backend (car vc-fileset))
+ (files (cadr vc-fileset)))
+ (cond
+ ;; If a pull operation is defined, use it.
+ ((vc-find-backend-function backend 'pull)
+ (vc-call-backend backend 'pull arg))
+ ;; If VCS has `merge-news' functionality (CVS and SVN), use it.
+ ((vc-find-backend-function backend 'merge-news)
+ (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)
+ (vc-maybe-resolve-conflicts
+ file (vc-call-backend backend 'merge-news file)))))
+ ;; For a locking VCS, check out each file.
+ ((eq (vc-checkout-model backend files) 'locking)
+ (dolist (file files)
+ (if (vc-up-to-date-p file)
+ (vc-checkout file nil t))))
+ (t
+ (error "VC update is unsupported for `%s'" backend)))))
+
+;;;###autoload
+(defalias 'vc-pull 'vc-update)
+
+(defun vc-version-backup-file (file &optional rev)
+ "Return name of backup file for revision REV of FILE.
+If version backups should be used for FILE, and there exists
+such a backup for REV or the working revision of file, return
+its name; otherwise return nil."
+ (when (vc-call make-version-backups-p file)
+ (let ((backup-file (vc-version-backup-file-name file rev)))
+ (if (file-exists-p backup-file)
+ backup-file
+ ;; there is no automatic backup, but maybe the user made one manually
+ (setq backup-file (vc-version-backup-file-name file rev 'manual))
+ (when (file-exists-p backup-file)
+ backup-file)))))
+
+(defun vc-revert-file (file)
+ "Revert FILE back to the repository working revision it was based on."
+ (with-vc-properties
+ (list file)
+ (let ((backup-file (vc-version-backup-file file)))
+ (when backup-file
+ (copy-file backup-file file 'ok-if-already-exists 'keep-date)
+ (vc-delete-automatic-version-backups file))
+ (vc-call revert file backup-file))
+ `((vc-state . up-to-date)
+ (vc-checkout-time . ,(nth 5 (file-attributes file)))))
+ (vc-resynch-buffer file t t))
+
+;;;###autoload
+(defun vc-switch-backend (file backend)
+ "Make BACKEND the current version control system for FILE.
+FILE must already be registered in BACKEND. The change is not
+permanent, only for the current session. This function only changes
+VC's perspective on FILE, it does not register or unregister it.
+By default, this command cycles through the registered backends.
+To get a prompt, use a prefix argument."
+ (interactive
+ (list
+ (or buffer-file-name
+ (error "There is no version-controlled file in this buffer"))
+ (let ((crt-bk (vc-backend buffer-file-name))
+ (backends nil))
+ (unless crt-bk
+ (error "File %s is not under version control" buffer-file-name))
+ ;; Find the registered backends.
+ (dolist (crt vc-handled-backends)
+ (when (and (vc-call-backend crt 'registered buffer-file-name)
+ (not (eq crt-bk crt)))
+ (push crt backends)))
+ ;; Find the next backend.
+ (let ((def (car backends))
+ (others backends))
+ (cond
+ ((null others) (error "No other backend to switch to"))
+ (current-prefix-arg
+ (intern
+ (upcase
+ (completing-read
+ (format "Switch to backend [%s]: " def)
+ (mapcar (lambda (b) (list (downcase (symbol-name b)))) backends)
+ nil t nil nil (downcase (symbol-name def))))))
+ (t def))))))
+ (unless (eq backend (vc-backend file))
+ (vc-file-clearprops file)
+ (vc-file-setprop file 'vc-backend backend)
+ ;; Force recomputation of the state
+ (unless (vc-call-backend backend 'registered file)
+ (vc-file-clearprops file)
+ (error "%s is not registered in %s" file backend))
+ (vc-mode-line file)))
+
+;;;###autoload
+(defun vc-transfer-file (file new-backend)
+ "Transfer FILE to another version control system NEW-BACKEND.
+If NEW-BACKEND has a higher precedence than FILE's current backend
+\(i.e. it comes earlier in `vc-handled-backends'), then register FILE in
+NEW-BACKEND, using the revision number from the current backend as the
+base level. If NEW-BACKEND has a lower precedence than the current
+backend, then commit all changes that were made under the current
+backend to NEW-BACKEND, and unregister FILE from the current backend.
+\(If FILE is not yet registered under NEW-BACKEND, register it.)"
+ (let* ((old-backend (vc-backend file))
+ (edited (memq (vc-state file) '(edited needs-merge)))
+ (registered (vc-call-backend new-backend 'registered file))
+ (move
+ (and registered ; Never move if not registered in new-backend yet.
+ ;; move if new-backend comes later in vc-handled-backends
+ (or (memq new-backend (memq old-backend vc-handled-backends))
+ (y-or-n-p "Final transfer? "))))
+ (comment nil))
+ (when (eq old-backend new-backend)
+ (error "%s is the current backend of %s" new-backend file))
+ (if registered
+ (set-file-modes file (logior (file-modes file) 128))
+ ;; `registered' might have switched under us.
+ (vc-switch-backend file old-backend)
+ (let* ((rev (vc-working-revision file))
+ (modified-file (and edited (make-temp-file file)))
+ (unmodified-file (and modified-file (vc-version-backup-file file))))
+ ;; Go back to the base unmodified file.
+ (unwind-protect
+ (progn
+ (when modified-file
+ (copy-file file modified-file 'ok-if-already-exists)
+ ;; If we have a local copy of the unmodified file, handle that
+ ;; here and not in vc-revert-file because we don't want to
+ ;; delete that copy -- it is still useful for OLD-BACKEND.
+ (if unmodified-file
+ (copy-file unmodified-file file
+ 'ok-if-already-exists 'keep-date)
+ (when (y-or-n-p "Get base revision from repository? ")
+ (vc-revert-file file))))
+ (vc-call-backend new-backend 'receive-file file rev))
+ (when modified-file
+ (vc-switch-backend file new-backend)
+ (unless (eq (vc-checkout-model new-backend (list file)) 'implicit)
+ (vc-checkout file t nil))
+ (rename-file modified-file file 'ok-if-already-exists)
+ (vc-file-setprop file 'vc-checkout-time nil)))))
+ (when move
+ (vc-switch-backend file old-backend)
+ (setq comment (vc-call-backend old-backend 'comment-history file))
+ (vc-call-backend old-backend 'unregister file))
+ (vc-switch-backend file new-backend)
+ (when (or move edited)
+ (vc-file-setprop file 'vc-state 'edited)
+ (vc-mode-line file new-backend)
+ (vc-checkin file new-backend nil comment (stringp comment)))))
+
+(defun vc-rename-master (oldmaster newfile templates)
+ "Rename OLDMASTER to be the master file for NEWFILE based on TEMPLATES."
+ (let* ((dir (file-name-directory (expand-file-name oldmaster)))
+ (newdir (or (file-name-directory newfile) ""))
+ (newbase (file-name-nondirectory newfile))
+ (masters
+ ;; List of potential master files for `newfile'
+ (mapcar
+ (lambda (s) (vc-possible-master s newdir newbase))
+ templates)))
+ (when (or (file-symlink-p oldmaster)
+ (file-symlink-p (file-name-directory oldmaster)))
+ (error "This is unsafe in the presence of symbolic links"))
+ (rename-file
+ oldmaster
+ (catch 'found
+ ;; If possible, keep the master file in the same directory.
+ (dolist (f masters)
+ (when (and f (string= (file-name-directory (expand-file-name f)) dir))
+ (throw 'found f)))
+ ;; If not, just use the first possible place.
+ (dolist (f masters)
+ (and f (or (not (setq dir (file-name-directory f)))
+ (file-directory-p dir))
+ (throw 'found f)))
+ (error "New file lacks a version control directory")))))
+
+;;;###autoload
+(defun vc-delete-file (file)
+ "Delete file and mark it as such in the version control system."
+ (interactive "fVC delete file: ")
+ (setq file (expand-file-name file))
+ (let ((buf (get-file-buffer file))
+ (backend (vc-backend file)))
+ (unless backend
+ (error "File %s is not under version control"
+ (file-name-nondirectory file)))
+ (unless (vc-find-backend-function backend 'delete-file)
+ (error "Deleting files under %s is not supported in VC" backend))
+ (when (and buf (buffer-modified-p buf))
+ (error "Please save or undo your changes before deleting %s" file))
+ (let ((state (vc-state file)))
+ (when (eq state 'edited)
+ (error "Please commit or undo your changes before deleting %s" file))
+ (when (eq state 'conflict)
+ (error "Please resolve the conflicts before deleting %s" file)))
+ (unless (y-or-n-p (format "Really want to delete %s? "
+ (file-name-nondirectory file)))
+ (error "Abort!"))
+ (unless (or (file-directory-p file) (null make-backup-files)
+ (not (file-exists-p file)))
+ (with-current-buffer (or buf (find-file-noselect file))
+ (let ((backup-inhibited nil))
+ (backup-buffer))))
+ ;; Bind `default-directory' so that the command that the backend
+ ;; runs to remove the file is invoked in the correct context.
+ (let ((default-directory (file-name-directory file)))
+ (vc-call-backend backend 'delete-file file))
+ ;; If the backend hasn't deleted the file itself, let's do it for him.
+ (when (file-exists-p file) (delete-file file))
+ ;; Forget what VC knew about the file.
+ (vc-file-clearprops file)
+ ;; Make sure the buffer is deleted and the *vc-dir* buffers are
+ ;; updated after this.
+ (vc-resynch-buffer file nil t)))
+
+;;;###autoload
+(defun vc-rename-file (old new)
+ "Rename file OLD to NEW in both work area and repository."
+ (interactive "fVC rename file: \nFRename to: ")
+ ;; in CL I would have said (setq new (merge-pathnames new old))
+ (let ((old-base (file-name-nondirectory old)))
+ (when (and (not (string= "" old-base))
+ (string= "" (file-name-nondirectory new)))
+ (setq new (concat new old-base))))
+ (let ((oldbuf (get-file-buffer old)))
+ (when (and oldbuf (buffer-modified-p oldbuf))
+ (error "Please save files before moving them"))
+ (when (get-file-buffer new)
+ (error "Already editing new file name"))
+ (when (file-exists-p new)
+ (error "New file already exists"))
+ (let ((state (vc-state old)))
+ (unless (memq state '(up-to-date edited))
+ (error "Please %s files before moving them"
+ (if (stringp state) "check in" "update"))))
+ (vc-call rename-file old new)
+ (vc-file-clearprops old)
+ ;; Move the actual file (unless the backend did it already)
+ (when (file-exists-p old) (rename-file old new))
+ ;; ?? Renaming a file might change its contents due to keyword expansion.
+ ;; We should really check out a new copy if the old copy was precisely equal
+ ;; to some checked-in revision. However, testing for this is tricky....
+ (when oldbuf
+ (with-current-buffer oldbuf
+ (let ((buffer-read-only buffer-read-only))
+ (set-visited-file-name new))
+ (vc-mode-line new (vc-backend new))
+ (set-buffer-modified-p nil)))))
+
+;;;###autoload
+(defun vc-update-change-log (&rest args)
+ "Find change log file and add entries from recent version control logs.
+Normally, find log entries for all registered files in the default
+directory.
+
+With prefix arg of \\[universal-argument], only find log entries for the current buffer's file.
+
+With any numeric prefix arg, find log entries for all currently visited
+files that are under version control. This puts all the entries in the
+log for the default directory, which may not be appropriate.
+
+From a program, any ARGS are assumed to be filenames for which
+log entries should be gathered."
+ (interactive
+ (cond ((consp current-prefix-arg) ;C-u
+ (list buffer-file-name))
+ (current-prefix-arg ;Numeric argument.
+ (let ((files nil)
+ (buffers (buffer-list))
+ file)
+ (while buffers
+ (setq file (buffer-file-name (car buffers)))
+ (and file (vc-backend file)
+ (setq files (cons file files)))
+ (setq buffers (cdr buffers)))
+ files))
+ (t
+ ;; Don't supply any filenames to backend; this means
+ ;; it should find all relevant files relative to
+ ;; the default-directory.
+ nil)))
+ (vc-call-backend (vc-responsible-backend default-directory)
+ 'update-changelog args))
+
+;; functions that operate on RCS revision numbers. This code should
+;; also be moved into the backends. It stays for now, however, since
+;; it is used in code below.
+(defun vc-branch-p (rev)
+ "Return t if REV is a branch revision."
+ (not (eq nil (string-match "\\`[0-9]+\\(\\.[0-9]+\\.[0-9]+\\)*\\'" rev))))
+
+;;;###autoload
+(defun vc-branch-part (rev)
+ "Return the branch part of a revision number REV."
+ (let ((index (string-match "\\.[0-9]+\\'" rev)))
+ (when index
+ (substring rev 0 index))))
+
+(define-obsolete-function-alias
+ 'vc-default-previous-version 'vc-default-previous-revision "23.1")
+
+(defun vc-default-responsible-p (backend file)
+ "Indicate whether BACKEND is reponsible for FILE.
+The default is to return nil always."
+ nil)
+
+(defun vc-default-could-register (backend file)
+ "Return non-nil if BACKEND could be used to register FILE.
+The default implementation returns t for all files."
+ t)
+
+(defun vc-default-latest-on-branch-p (backend file)
+ "Return non-nil if FILE is the latest on its branch.
+This default implementation always returns non-nil, which means that
+editing non-current revisions is not supported by default."
+ t)
+
+(defun vc-default-init-revision (backend) vc-default-init-revision)
+
+(defun vc-default-find-revision (backend file rev buffer)
+ "Provide the new `find-revision' op based on the old `checkout' op.
+This is only for compatibility with old backends. They should be updated
+to provide the `find-revision' operation instead."
+ (let ((tmpfile (make-temp-file (expand-file-name file))))
+ (unwind-protect
+ (progn
+ (vc-call-backend backend 'checkout file nil rev tmpfile)
+ (with-current-buffer buffer
+ (insert-file-contents-literally tmpfile)))
+ (delete-file tmpfile))))
+
+(defun vc-default-rename-file (backend old new)
+ (condition-case nil
+ (add-name-to-file old new)
+ (error (rename-file old new)))
+ (vc-delete-file old)
+ (with-current-buffer (find-file-noselect new)
+ (vc-register)))
+
+(defalias 'vc-default-check-headers 'ignore)
+
+(declare-function log-edit-mode "log-edit" ())
+
+(defun vc-default-log-edit-mode (backend) (log-edit-mode))
+
+(defun vc-default-log-view-mode (backend) (log-view-mode))
+
+(defun vc-default-show-log-entry (backend rev)
+ (with-no-warnings
+ (log-view-goto-rev rev)))
+
+(defun vc-default-comment-history (backend file)
+ "Return a string with all log entries stored in BACKEND for FILE."
+ (when (vc-find-backend-function backend 'print-log)
+ (with-current-buffer "*vc*"
+ (vc-call-backend backend 'print-log (list file))
+ (buffer-string))))
+
+(defun vc-default-receive-file (backend file rev)
+ "Let BACKEND receive FILE from another version control system."
+ (vc-call-backend backend 'register (list file) rev ""))
+
+(defun vc-default-retrieve-tag (backend dir name update)
+ (if (string= name "")
+ (progn
+ (vc-file-tree-walk
+ dir
+ (lambda (f) (and
+ (vc-up-to-date-p f)
+ (vc-error-occurred
+ (vc-call-backend backend 'checkout f nil "")
+ (when update (vc-resynch-buffer f t t)))))))
+ (let ((result (vc-tag-precondition dir)))
+ (if (stringp result)
+ (error "File %s is locked" result)
+ (setq update (and (eq result 'visited) update))
+ (vc-file-tree-walk
+ dir
+ (lambda (f) (vc-error-occurred
+ (vc-call-backend backend 'checkout f nil name)
+ (when update (vc-resynch-buffer f t t)))))))))
+
+(defun vc-default-revert (backend file contents-done)
+ (unless contents-done
+ (let ((rev (vc-working-revision file))
+ (file-buffer (or (get-file-buffer file) (current-buffer))))
+ (message "Checking out %s..." file)
+ (let ((failed t)
+ (backup-name (car (find-backup-file-name file))))
+ (when backup-name
+ (copy-file file backup-name 'ok-if-already-exists 'keep-date)
+ (unless (file-writable-p file)
+ (set-file-modes file (logior (file-modes file) 128))))
+ (unwind-protect
+ (let ((coding-system-for-read 'no-conversion)
+ (coding-system-for-write 'no-conversion))
+ (with-temp-file file
+ (let ((outbuf (current-buffer)))
+ ;; Change buffer to get local value of vc-checkout-switches.
+ (with-current-buffer file-buffer
+ (let ((default-directory (file-name-directory file)))
+ (vc-call-backend backend 'find-revision
+ file rev outbuf)))))
+ (setq failed nil))
+ (when backup-name
+ (if failed
+ (rename-file backup-name file 'ok-if-already-exists)
+ (and (not vc-make-backup-files) (delete-file backup-name))))))
+ (message "Checking out %s...done" file))))
+
+(defalias 'vc-default-revision-completion-table 'ignore)
+(defalias 'vc-default-mark-resolved 'ignore)
+
+(defun vc-default-dir-status-files (backend dir files default-state update-function)
+ (funcall update-function
+ (mapcar (lambda (file) (list file default-state)) files)))
+
+(defun vc-check-headers ()
+ "Check if the current file has any headers in it."
+ (interactive)
+ (vc-call-backend (vc-backend buffer-file-name) 'check-headers))
+
+\f
+
+;; These things should probably be generally available
+
+(defun vc-string-prefix-p (prefix string)
+ (let ((lpref (length prefix)))
+ (and (>= (length string) lpref)
+ (eq t (compare-strings prefix nil nil string nil lpref)))))
+
+(defun vc-file-tree-walk (dirname func &rest args)
+ "Walk recursively through DIRNAME.
+Invoke FUNC f ARGS on each VC-managed file f underneath it."
+ (vc-file-tree-walk-internal (expand-file-name dirname) func args)
+ (message "Traversing directory %s...done" dirname))
+
+(defun vc-file-tree-walk-internal (file func args)
+ (if (not (file-directory-p file))
+ (when (vc-backend file) (apply func file args))
+ (message "Traversing directory %s..." (abbreviate-file-name file))
+ (let ((dir (file-name-as-directory file)))
+ (mapcar
+ (lambda (f) (or
+ (string-equal f ".")
+ (string-equal f "..")
+ (member f vc-directory-exclusion-list)
+ (let ((dirf (expand-file-name f dir)))
+ (or
+ (file-symlink-p dirf) ;; Avoid possible loops.
+ (vc-file-tree-walk-internal dirf func args)))))
+ (directory-files dir)))))
+
+(provide 'vc)
+
+;; arch-tag: ca82c1de-3091-4e26-af92-460abc6213a6
+;;; vc.el ends here
#!/bin/sh
+### make-dist: create an Emacs distribution tar file from current srcdir
-#### make-dist: create an Emacs distribution tar file from the current
-#### source tree. This basically creates a duplicate directory
-#### structure, and then hard links into it only those files that should
-#### be distributed. This means that if you add a file with an odd name,
-#### you should make sure that this script will include it.
+## Copyright (C) 1995, 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2005,
- ## 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
++## 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
-# Copyright (C) 1995, 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2005,
-# 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+## This file is part of GNU Emacs.
-# 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 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.
+## GNU Emacs is distributed in the hope that it will be useful,
+## but WITHOUT ANY WARRANTY; without even the implied warranty of
+## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+## GNU General Public License for more details.
-# You should have received a copy of the GNU General Public License
-# along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+## You should have received a copy of the GNU General Public License
+## along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+### Commentary:
+
+## This basically creates a duplicate directory structure, and then
+## hard links into it only those files that should be distributed.
+## This means that if you add a file with an odd name, you should make
+## sure that this script will include it.
+
+### Code:
progname="$0"
;; Local Variables:
;; coding: utf-8
-;; add-log-time-zone-rule: t
;; End:
- Copyright (C) 2008, 2009, 2010 Free Software Foundation, Inc.
+ Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
- Building and Installing Emacs
- on Windows NT/2K/XP and Windows 95/98/ME
+ Building and Installing Emacs on Windows
+ (from 95 to 7 and beyond)
- Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+ Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
Free Software Foundation, Inc.
See the end of the file for license conditions.
--- /dev/null
- Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
- 2010 Free Software Foundation, Inc.
++Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
++ Free Software Foundation, Inc.
+See the end of the file for license conditions.
+
+ Emacs for Windows
+
+ This README file describes how to set up and run a precompiled
+ version of GNU Emacs for Windows. This distribution can be found on
+ the ftp.gnu.org server and its mirrors:
+
+ ftp://ftp.gnu.org/gnu/emacs/windows/
+
+ This server contains other distributions, including the full Emacs
+ source distribution and a barebin distribution which can be installed
+ over it, as well as older releases of Emacs for Windows.
+
+ Answers to frequently asked questions, and further information about
+ this port of GNU Emacs and related software packages can be found via
+ http:
+
+ http://www.gnu.org/software/emacs/windows/
+
+* Preliminaries
+
+ Along with this file should be six subdirectories (bin, etc, info,
+ lisp, leim, site-lisp). If you have downloaded the barebin
+ distribution, then it will contain only the bin directory and the
+ built in documentation in etc/DOC-X, the rest of the subdirectories
+ are in the src distribution, which the barebin distribution is
+ designed to be used with.
+
+* Setting up Emacs
+
+ To install Emacs, simply unpack all the files into a directory of
+ your choice, but note that you might encounter minor problems if
+ there is a space anywhere in the directory name. To complete the
+ installation process, you can optionally run the program addpm.exe
+ in the bin subdirectory. This will put an icon for Emacs in the
+ Start Menu under "Start -> Programs -> Gnu Emacs".
+
+ Some users have reported that the Start Menu item is not created for
+ them. If this happens, just create your own shortcut to runemacs.exe,
+ eg. by dragging it on to the desktop or the Start button.
+
+ Note that running addpm is now an optional step; Emacs is able to
+ locate all of its files without needing any information to be set in
+ the environment or the registry, although such settings will still
+ be obeyed if present. This is convenient for running Emacs on a
+ machine which disallows registry changes, or on which software
+ should not be installed. For instance, you can now run Emacs
+ directly from a CD or USB flash drive without copying or installing
+ anything on the machine itself.
+
+* Starting Emacs
+
+ To run Emacs, simply select Emacs from the Start Menu, or invoke
+ runemacs.exe directly from Explorer or from a command prompt. This
+ will start Emacs in its default GUI mode, ready to use. If you have
+ never used Emacs before, you should follow the tutorial at this
+ point (select Emacs Tutorial from the Help menu), since Emacs is
+ quite different from ordinary Windows applications in many respects.
+
+ If you want to use Emacs in tty or character mode within a command
+ window, you can start it by typing "emacs -nw" at the command prompt.
+ (Obviously, you need to ensure that the Emacs bin subdirectory is in
+ your PATH first, or specify the path to emacs.exe.) The -nw
+ (non-windowed) mode of operation is most useful if you have a telnet
+ server on your machine, allowing you to run Emacs remotely.
+
+* EXE files included
+
+ Emacs comes with the following executable files in the bin directory.
+
+ + emacs.exe - The main Emacs executable. As this is designed to run
+ as both a text-mode application (emacs -nw) and as a GUI application,
+ it will pop up a command prompt window if run directly from Explorer.
+
+ + runemacs.exe - A wrapper for running Emacs as a GUI application
+ without popping up a command prompt window.
+
+ + emacsclient.exe - A command-line client program that can
+ communicate with a running Emacs process. See the `Emacs Server'
+ node of the Emacs manual.
+
+ + emacsclientw.exe - A version of emacsclient that does not open
+ a command-line window.
+
+ + addpm.exe - A basic installer that creates Start Menu icons for Emacs.
+ Running this is optional.
+
+ + cmdproxy.exe - Used internally by Emacs to work around problems with
+ the native shells in various versions of Windows.
+
+ + ctags.exe, etags.exe - Tools for generating tag files. See the
+ `Tags' node of the Emacs manual.
+
+ + ebrowse.exe - A tool for generating C++ browse information. See the
+ `Ebrowse' manual.
+
+ + ddeclient.exe - A tool for interacting with DDE servers.
+
+ + hexl.exe - A tool for converting files to hex dumps. See the
+ `Editing Binary Files' node of the Emacs manual.
+
+ + movemail.exe - A helper application for safely moving mail from
+ a mail spool or POP server to a local user mailbox. See the
+ `Movemail' node of the Emacs manual.
+
+* Image support
+
+ Emacs has built in support for XBM and PPM/PGM/PBM images, and the
+ libXpm library is bundled, providing XPM support (required for color
+ toolbar icons and splash screen). Source for libXpm should be available
+ on the same place as you got this binary distribution from. The version
+ of libXpm bundled with this version of Emacs is 3.5.7, based on x.org's
+ libXpm library from X11R7.3.
+
+ Emacs can also support some other image formats with appropriate
+ libraries. These libraries are all available as part of GTK
+ download for Windows (http://www.gtk.org/download-windows.html), or
+ from the GnuWin32 project. Emacs will find them if the directory
+ they are installed in is on the PATH.
+
+ PNG: requires the PNG reference library 1.4 or later, which will
+ be named libpng14.dll or libpng14-14.dll. LibPNG requires zlib,
+ which should come from the same source as you got libpng.
+ Starting with Emacs 23.3, the precompiled Emacs binaries are
+ built with libpng 1.4.x and later, and are incompatible with
+ earlier versions of libpng DLLs. So if you have libpng 1.2.x,
+ the PNG support will not work, and you will have to download
+ newer versions.
+
+ JPEG: requires the Independant JPEG Group's libjpeg 6b or later,
+ which will be called jpeg62.dll, libjpeg.dll, jpeg-62.dll or jpeg.dll.
+
+ TIFF: requires libTIFF 3.0 or later, which will be called libtiff3.dll
+ or libtiff.dll.
+
+ GIF: requires libungif or giflib 4.1 or later, which will be
+ called giflib4.dll, libungif4.dll or libungif.dll.
+
+ If you have image support DLLs under different names, customize the
+ value of `dynamic-library-alist'.
+
+ In addition, Emacs can be compiled to support SVG. This precompiled
+ distribution has not been compiled that way, since the SVG library
+ or one or more of its extensive dependencies appear to be
+ unreliable under Windows. See nt/INSTALL in the src distribution if
+ you wish to compile Emacs with SVG support.
+
+* Uninstalling Emacs
+
+ If you should need to uninstall Emacs, simply delete all the files
+ and subdirectories from the directory where it was unpacked (Emacs
+ does not install or update any files in system directories or
+ anywhere else). If you ran the addpm.exe program to create the
+ registry entries and the Start menu icon, then you can remove the
+ registry entries using regedit. All of the settings are written
+ under the Software\GNU\Emacs key in HKEY_LOCAL_MACHINE, or if you
+ didn't have administrator privileges when you installed, the same
+ key in HKEY_CURRENT_USER. Just delete the whole Software\GNU\Emacs
+ key.
+
+ The Start menu entry can be removed by right-clicking on the Task bar
+ and selecting Properties, then using the Remove option on the Start
+ Menu Programs page. (If you installed under an account with
+ administrator privileges, then you need to click the Advanced button
+ and look for the Gnu Emacs menu item under All Users.)
+
+* Troubleshooting
+
+ Unpacking the distributions
+
+ If you encounter trouble trying to run Emacs, there are a number of
+ possible causes. Check the following for indications that the
+ distribution was not corrupted by the tools used to unpack it:
+
+ * Be sure to disable CR/LF translation or the executables will
+ be unusable. Older versions of WinZipNT would enable this
+ translation by default. If you are using WinZipNT, disable it.
+ (I don't have WinZipNT myself, and I do not know the specific
+ commands necessary to disable it.)
+
+ * Check that filenames were not truncated to 8.3. For example,
+ there should be a file lisp\abbrevlist.elc; if this has been
+ truncated to abbrevli.elc, your distribution has been corrupted
+ while unpacking and Emacs will not start.
+
+ If you believe you have unpacked the distributions correctly and are
+ still encountering problems, see the section on Further Information
+ below.
+
+ Virus scanners
+
+ Some virus scanners interfere with Emacs' use of subprocesses. If you
+ are unable to use subprocesses and you use Dr. Solomon's WinGuard or
+ McAfee's Vshield, turn off "Scan all files" (WinGuard) or "boot sector
+ scanning" (McAfee exclusion properties).
+
+* Further information
+
+ If you have access to the World Wide Web, I would recommend pointing
+ your favorite web browser to the following document (if you haven't
+ already):
+
+ http://www.gnu.org/software/emacs/windows/
+
+ This document serves as an FAQ and a source for further information
+ about the Windows port and related software packages.
+
+ In addition to the FAQ, there is a mailing list for discussing issues
+ related to the Windows port of Emacs. For information about the
+ list, see this Web page:
+
+ http://lists.gnu.org/mailman/listinfo/help-emacs-windows
+
+ To ask questions on the mailing list, send email to
+ help-emacs-windows@gnu.org. (You don't need to subscribe for that.)
+ To subscribe to the list or unsubscribe from it, fill the form you
+ find at http://lists.gnu.org/mailman/listinfo/help-emacs-windows as
+ explained there.
+
+ Another valuable source of information and help which should not be
+ overlooked is the various Usenet news groups dedicated to Emacs.
+ These are particularly good for help with general issues which aren't
+ specific to the Windows port of Emacs. The main news groups to use
+ for seeking help are:
+
+ gnu.emacs.help
+ comp.emacs
+
+ There are also fairly regular postings and announcements of new or
+ updated Emacs packages on this group:
+
+ gnu.emacs.sources
+
+* Reporting bugs
+
+ If you encounter a bug in this port of Emacs, we would like to hear
+ about it. First check the FAQ on the web page above to see if the bug
+ is already known and if there are any workarounds. Then check whether
+ the bug has something to do with code in your .emacs file, e.g. by
+ invoking Emacs with the "-Q" option.
+
+ If you decide that it is a bug in Emacs, use the built in bug
+ reporting facility to report it (from the menu; Help -> Send Bug Report).
+ If you have not yet configured Emacs for mail, then when you press
+ C-c C-c to send the report, it will ask you to paste the text of the
+ report into your mail client. If the bug is related to subprocesses,
+ also specify which shell you are using (e.g., include the values of
+ `shell-file-name' and `explicit-shell-file-name' in your message).
+
+ Enjoy!
+
+\f
+This file is part of GNU Emacs.
+
+GNU Emacs is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
/* GNU Emacs site configuration template file. -*- C -*-
- Copyright (C) 1988, 1993, 1994, 2001, 2002, 2003, 2004, 2005, 2006,
+
+Copyright (C) 1988, 1993, 1994, 2001, 2002, 2003, 2004, 2005, 2006,
- 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+ 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
@echo off\r
rem ----------------------------------------------------------------------\r
-rem Configuration script for MS Windows 95/98/Me and NT/2000/XP\r
+rem Configuration script for MS Windows operating systems\r
rem Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005,\r
- rem 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.\r
+ rem 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.\r
\r
rem This file is part of GNU Emacs.\r
\r
BEGIN
VALUE "CompanyName", "Free Software Foundation\0"
VALUE "FileDescription", "GNU Emacs: The extensible self-documenting text editor\0"
- VALUE "FileVersion", "23, 2, 91, 0\0"
+ VALUE "FileVersion", "24, 0, 50, 0\0"
VALUE "InternalName", "Emacs\0"
- VALUE "LegalCopyright", "Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010\0"
+ VALUE "LegalCopyright", "Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011\0"
VALUE "OriginalFilename", "emacs.exe"
VALUE "ProductName", "Emacs\0"
- VALUE "ProductVersion", "23, 2, 91, 0\0"
+ VALUE "ProductVersion", "24, 0, 50, 0\0"
VALUE "OLESelfRegister", "\0"
END
END
BEGIN
VALUE "CompanyName", "Free Software Foundation\0"
VALUE "FileDescription", "GNU EmacsClient: Client for the extensible self-documenting text editor\0"
- VALUE "FileVersion", "23, 2, 91, 0\0"
+ VALUE "FileVersion", "24, 0, 50, 0\0"
VALUE "InternalName", "EmacsClient\0"
- VALUE "LegalCopyright", "Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010\0"
+ VALUE "LegalCopyright", "Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011\0"
VALUE "OriginalFilename", "emacsclientw.exe"
VALUE "ProductName", "EmacsClient\0"
- VALUE "ProductVersion", "23, 2, 91, 0\0"
+ VALUE "ProductVersion", "24, 0, 50, 0\0"
VALUE "OLESelfRegister", "\0"
END
END
-/* Pro-process emacs.exe for profiling by MSVC.
+/* Pre-process emacs.exe for profiling by MSVC.
Copyright (C) 1999, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
- 2008, 2009, 2010 Free Software Foundation, Inc.
+ 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
++2011-01-14 Eli Zaretskii <eliz@gnu.org>
++
++ * image.c (png_jmpbuf): Remove definition.
++ (my_png_error, png_load): Don't use png_jmpbuf.
++
++2011-01-14 Eli Zaretskii <eliz@gnu.org>
+2011-01-11 Tassilo Horn <tassilo@member.fsf.org>
+
+ * image.c (imagemagick_load_image, Finit_image_library): Free
+ intermediate image after creating a MagickWand from it. Terminate
+ MagickWand environment after image loading.
+
+2011-01-10 Michael Albinus <michael.albinus@gmx.de>
+
+ * dbusbind.c (Fdbus_register_service): Raise an error in case of
+ unexpected return values.
+ (Fdbus_register_method): Remove connection initialization.
+
+2011-01-10 Jan Moringen <jan.moringen@uni-bielefeld.de>
+
+ * dbusbind.c (QCdbus_request_name_allow_replacement): New symbol;
+ used by Fdbus_register_service.
+ (QCdbus_request_name_replace_existing): Likewise.
+ (QCdbus_request_name_do_not_queue): Likewise.
+ (QCdbus_request_name_reply_primary_owner): Likewise.
+ (QCdbus_request_name_reply_in_queue): Likewise.
+ (QCdbus_request_name_reply_exists): Likewise.
+ (QCdbus_request_name_reply_already_owner): Likewise.
+ (Fdbus_register_service): New function.
+ (Fdbus_register_method): Use Fdbus_register_service to do the name
+ registration.
+ (syms_of_dbusbind): Add symbols dbus-register-service,
+ :allow-replacement, :replace-existing, :do-not-queue,
+ :primary-owner, :existing, :in-queue and :already-owner.
+
+2011-01-09 Chong Yidong <cyd@stupidchicken.com>
+
+ * gtkutil.c (update_frame_tool_bar): Don't advance tool-bar index
+ when removing extra buttons.
+
+2011-01-08 Chong Yidong <cyd@stupidchicken.com>
+
+ * fns.c (Fyes_or_no_p): Doc fix.
+
+2011-01-08 Andreas Schwab <schwab@linux-m68k.org>
+
+ * fns.c (Fyes_or_no_p): Add usage.
+
+2011-01-08 Glenn Morris <rgm@gnu.org>
+
+ * makefile.w32-in ($(EMACS)):
+ * Makefile.in (emacs$(EXEEXT)): -batch implies -q.
+
+ * xdisp.c (syms_of_xdisp) <Qrisky_local_variable>: Move from here...
+ * emacs.c (syms_of_emacs) <Qrisky_local_variable>: ...to here.
+
+2011-01-07 Andreas Schwab <schwab@linux-m68k.org>
+
+ * image.c (imagemagick_load_image): Fix some resource leaks and
+ error handling.
+
+2011-01-07 Chong Yidong <cyd@stupidchicken.com>
+
+ * fns.c (Fyes_or_no_p): Accept format string args.
+
+2011-01-07 Glenn Morris <rgm@gnu.org>
+
+ * emacs.c (no_site_lisp): New int.
+ (USAGE1): Add --no-site-lisp, mention -Q uses it.
+ (main): Set no_site_lisp.
+ (standard_args): Add --no-site-lisp.
+ * lisp.h (no_site_lisp): New int.
+ * lread.c (init_lread): If no_site_lisp, don't re-add site-lisp
+ directories to Vload_path.
+
+2011-01-05 Andreas Schwab <schwab@linux-m68k.org>
+
+ * alloc.c (mark_stack): Use __builtin_unwind_init if available.
+
+2011-01-04 Jan Moringen <jan.moringen@uni-bielefeld.de>
+
+ * dbusbind.c (Fdbus_register_method): Added optional parameter
+ dont_register_service. Updated docstring accordingly.
+
+2011-01-04 Glenn Morris <rgm@gnu.org>
+
+ * emacs.c (emacs_copyright): Update short copyright year to 2011.
+
2011-01-03 Eli Zaretskii <eliz@gnu.org>
* image.c (png_jmpbuf): Remove definition.
;; Local Variables:
;; coding: utf-8
-;; add-log-time-zone-rule: t
;; End:
- Copyright (C) 2007, 2008, 2009, 2010, 2011
- Free Software Foundation, Inc.
+ Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
-# Makefile for GNU Emacs.
+# src/Makefile for GNU Emacs.
+
# Copyright (C) 1985, 1987, 1988, 1993, 1994, 1995, 1999, 2000, 2001, 2002,
- # 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
- # Free Software Foundation, Inc.
+ # 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
+ # Free Software Foundation, Inc.
# This file is part of GNU Emacs.
/* Machine description file for the alpha chip.
- Copyright (C) 1994, 1997, 1999, 2001, 2002, 2003, 2004, 2005, 2006,
+
+Copyright (C) 1994, 1997, 1999, 2001, 2002, 2003, 2004, 2005, 2006,
- 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+ 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
Author: Rainer Schoepf
(according to authors.el)
-/* machine description file template.
- Copyright (C) 1985, 1986, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
+/* Machine description file for IBM S390 in 32-bit mode
+
+Copyright (C) 1985, 1986, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
- 2008, 2009, 2010 Free Software Foundation, Inc.
+ 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
-/* machine description file for IBM S390 in 64-bit mode
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
- Free Software Foundation, Inc.
+/* Machine description file for IBM S390 in 64-bit mode
+
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
++Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
+ Free Software Foundation, Inc.
This file is part of GNU Emacs.
/* Machine description file for generic Motorola 68k.
- Copyright (C) 1985, 1995, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
+
+Copyright (C) 1985, 1995, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
- 2008, 2009, 2010 Free Software Foundation, Inc.
+ 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
/* machine description file template.
- Copyright (C) 1985, 1986, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
+
+Copyright (C) 1985, 1986, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
- 2008, 2009, 2010 Free Software Foundation, Inc.
+ 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
/* machine description file for vax.
- Copyright (C) 1985, 1986, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
+
+Copyright (C) 1985, 1986, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
- 2008, 2009, 2010 Free Software Foundation, Inc.
+ 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
/* System description header file for Cygwin.
- Copyright (C) 1985, 1986, 1992, 1999, 2002, 2003, 2004, 2005, 2006,
+
+Copyright (C) 1985, 1986, 1992, 1999, 2002, 2003, 2004, 2005, 2006,
- 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+ 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
/* System description header for FreeBSD systems.
- This file describes the parameters that system description files
- should define or not.
- Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
+
+Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
- 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
- Free Software Foundation, Inc.
+ 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
+ Free Software Foundation, Inc.
Author: Shawn M. Carey
(according to authors.el)
/* This file is the configuration file for Linux-based GNU systems
- Copyright (C) 1985, 1986, 1992, 1994, 1996, 1999, 2001, 2002, 2003, 2004,
+
+Copyright (C) 1985, 1986, 1992, 1994, 1996, 1999, 2001, 2002, 2003, 2004,
- 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+ 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+This file was put together by Michael K. Johnson and Rik Faith.
+
This file is part of GNU Emacs.
GNU Emacs is free software: you can redistribute it and/or modify
/* System description file for Windows NT.
- Copyright (C) 1993, 1994, 1995, 2001, 2002, 2003, 2004, 2005, 2006,
+
+Copyright (C) 1993, 1994, 1995, 2001, 2002, 2003, 2004, 2005, 2006,
- 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+ 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
/* System description file for MS-DOS
- Copyright (C) 1993, 1996, 1997, 2001, 2002, 2003, 2004, 2005, 2006,
+Copyright (C) 1993, 1996, 1997, 2001, 2002, 2003, 2004, 2005, 2006,
- 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+ 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
/* Template for system description header files.
This file describes the parameters that system description files
should define or not.
- Copyright (C) 1985, 1986, 1992, 1999, 2001, 2002, 2003, 2004, 2005,
+
+Copyright (C) 1985, 1986, 1992, 1999, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+ 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
--- /dev/null
- 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+/* Definitions file for GNU Emacs running on AT&T's System V Release 4
+
+Copyright (C) 1987, 1990, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
++ 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+
+Written by James Van Artsdalen of Dell Computer Corp. james@bigtex.cactus.org.
+Subsequently improved for Dell 2.2 by Eric S. Raymond <esr@snark.thyrsus.com>.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
+
+/* Use the SysVr3 file for at least base configuration. */
+#define USG /* System III, System V, etc */
+
+#define USG5
+#define USG5_4
+
+/* SYSTEM_TYPE should indicate the kind of system you are using.
+ It sets the Lisp variable system-type. */
+#define SYSTEM_TYPE "usg-unix-v"
+
+/* The file containing the kernel's symbol table is called /unix. */
+#define KERNEL_FILE "/unix"
+
+/* The kernel symbol where the load average is found is named avenrun. */
+#define LDAV_SYMBOL "avenrun"
+
+/* setjmp and longjmp can safely replace _setjmp and _longjmp,
+ but they will run slower. */
+#define _setjmp setjmp
+#define _longjmp longjmp
+
+/* The docs for system V/386 suggest v.3 has sigpause, so let's try it. */
+#define HAVE_SYSV_SIGPAUSE
+
+/* On USG systems signal handlers return void. */
+#define SIGTYPE void
+
+/* Get FIONREAD from <sys/filio.h>. Get <sys/ttold.h> to get struct tchars.
+ But get <termio.h> first to make sure ttold.h doesn't interfere.
+ And don't try to use SIGIO yet. */
+#include <sys/wait.h>
+
+#ifdef emacs
+#include <sys/filio.h>
+#include <termio.h>
+#include <sys/ttold.h>
+#include <signal.h>
+#include <sys/stream.h>
+#include <sys/stropts.h>
+#include <sys/termios.h>
+#define BROKEN_SIGIO
+#endif
+
+/* Some SVr4s don't define NSIG in sys/signal.h for ANSI environments;
+ instead, there's a system variable _sys_nsig. Unfortunately, we need the
+ constant to dimension an array. So wire in the appropriate value here. */
+#define NSIG_MINIMUM 32
+
+/* We can support this. */
+#define CLASH_DETECTION
+
+/* Define HAVE_PTYS if the system supports pty devices. */
+#define HAVE_PTYS
+
+/* It is possible to receive SIGCHLD when there are no children
+ waiting, because a previous waitsys(2) cleaned up the carcass of child
+ without clearing the SIGCHLD pending info. So, use a non-blocking
+ wait3 instead, which maps to waitpid(2) in SysVr4. */
+#define wait3(status, options, rusage) \
+ waitpid ((pid_t) -1, (status), (options))
+#define WRETCODE(w) (w >> 8)
+
+/* TIOCGPGRP is broken in SysVr4, so we can't send signals to PTY
+ subprocesses the usual way. But TIOCSIGNAL does work for PTYs, and
+ this is all we need. */
+#define TIOCSIGSEND TIOCSIGNAL
+
+/* This change means that we don't loop through allocate_pty too many
+ times in the (rare) event of a failure. */
+#define FIRST_PTY_LETTER 'z'
+
+/* This sets the name of the master side of the PTY. */
+#define PTY_NAME_SPRINTF strcpy (pty_name, "/dev/ptmx");
+
+/* Push various streams modules onto a PTY channel. */
+#define SETUP_SLAVE_PTY \
+ if (ioctl (xforkin, I_PUSH, "ptem") == -1) \
+ fatal ("ioctl I_PUSH ptem", errno); \
+ if (ioctl (xforkin, I_PUSH, "ldterm") == -1) \
+ fatal ("ioctl I_PUSH ldterm", errno); \
+ if (ioctl (xforkin, I_PUSH, "ttcompat") == -1) \
+ fatal ("ioctl I_PUSH ttcompat", errno);
+
+/* This definition was suggested for next release. So give it a try. */
+#define HAVE_SOCKETS
+
+/* arch-tag: 1a0ed909-5faa-434b-b7c3-9d86c63d53a6
+ (do not change this comment) */
--- /dev/null
- 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1985, 1986, 1987, 1988, 1992, 1993, 1994, 2001, 2002, 2003,
++ 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 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 <http://www.gnu.org/licenses/>. */
+
+
+/*
+ * unexcoff.c - Convert a running program into an a.out or COFF file.
+ *
+ * ==================================================================
+ * Note: This file is currently used only by the MSDOS (a.k.a. DJGPP)
+ * build of Emacs. If you are not interested in the MSDOS build, you
+ * are looking at the wrong version of unexec!
+ * ==================================================================
+ *
+ * Author: Spencer W. Thomas
+ * Computer Science Dept.
+ * University of Utah
+ * Date: Tue Mar 2 1982
+ * Originally under the name unexec.c.
+ * Modified heavily since then.
+ *
+ * Synopsis:
+ * unexec (const char *new_name, const char *old_name);
+ *
+ * Takes a snapshot of the program and makes an a.out format file in the
+ * file named by the string argument new_name.
+ * If a_name is non-NULL, the symbol table will be taken from the given file.
+ * On some machines, an existing a_name file is required.
+ *
+ * If you make improvements I'd like to get them too.
+ * harpo!utah-cs!thomas, thomas@Utah-20
+ *
+ */
+
+/* Modified to support SysVr3 shared libraries by James Van Artsdalen
+ * of Dell Computer Corporation. james@bigtex.cactus.org.
+ */
+
+#include <config.h>
+#define PERROR(file) report_error (file, new)
+
+#ifndef CANNOT_DUMP /* all rest of file! */
+
+#ifdef HAVE_COFF_H
+#include <coff.h>
+#ifdef MSDOS
+#include <fcntl.h> /* for O_RDONLY, O_RDWR */
+#include <crt0.h> /* for _crt0_startup_flags and its bits */
+#include <sys/exceptn.h>
+static int save_djgpp_startup_flags;
+#define filehdr external_filehdr
+#define scnhdr external_scnhdr
+#define syment external_syment
+#define auxent external_auxent
+#define n_numaux e_numaux
+#define n_type e_type
+struct aouthdr
+{
+ unsigned short magic; /* type of file */
+ unsigned short vstamp; /* version stamp */
+ unsigned long tsize; /* text size in bytes, padded to FW bdry*/
+ unsigned long dsize; /* initialized data " " */
+ unsigned long bsize; /* uninitialized data " " */
+ unsigned long entry; /* entry pt. */
+ unsigned long text_start;/* base of text used for this file */
+ unsigned long data_start;/* base of data used for this file */
+};
+#endif /* not MSDOS */
+#else /* not HAVE_COFF_H */
+#include <a.out.h>
+#endif /* not HAVE_COFF_H */
+
+/* Define getpagesize if the system does not.
+ Note that this may depend on symbols defined in a.out.h. */
+#include "getpagesize.h"
+
+#ifndef makedev /* Try to detect types.h already loaded */
+#include <sys/types.h>
+#endif /* makedev */
+#include <stdio.h>
+#include <sys/stat.h>
+#include <errno.h>
+
+#include <sys/file.h>
+
+extern char *start_of_data (void); /* Start of initialized data */
+
+static long block_copy_start; /* Old executable start point */
+static struct filehdr f_hdr; /* File header */
+static struct aouthdr f_ohdr; /* Optional file header (a.out) */
+long bias; /* Bias to add for growth */
+long lnnoptr; /* Pointer to line-number info within file */
+#define SYMS_START block_copy_start
+
+static long text_scnptr;
+static long data_scnptr;
+
+static long coff_offset;
+
+static int pagemask;
+
+/* Correct an int which is the bit pattern of a pointer to a byte
+ into an int which is the number of a byte.
+ This is a no-op on ordinary machines, but not on all. */
+
+#define ADDR_CORRECT(x) ((char *)(x) - (char*)0)
+
+#include <setjmp.h>
+#include "lisp.h"
+
+static void
+report_error (const char *file, int fd)
+{
+ if (fd)
+ close (fd);
+ report_file_error ("Cannot unexec", Fcons (build_string (file), Qnil));
+}
+
+#define ERROR0(msg) report_error_1 (new, msg, 0, 0); return -1
+#define ERROR1(msg,x) report_error_1 (new, msg, x, 0); return -1
+#define ERROR2(msg,x,y) report_error_1 (new, msg, x, y); return -1
+
+static void
+report_error_1 (int fd, const char *msg, int a1, int a2)
+{
+ close (fd);
+ error (msg, a1, a2);
+}
+\f
+static int make_hdr (int, int, const char *, const char *);
+static int copy_text_and_data (int, int);
+static int copy_sym (int, int, const char *, const char *);
+static void mark_x (const char *);
+
+/* ****************************************************************
+ * make_hdr
+ *
+ * Make the header in the new a.out from the header in core.
+ * Modify the text and data sizes.
+ */
+static int
+make_hdr (int new, int a_out,
+ const char *a_name, const char *new_name)
+{
+ auto struct scnhdr f_thdr; /* Text section header */
+ auto struct scnhdr f_dhdr; /* Data section header */
+ auto struct scnhdr f_bhdr; /* Bss section header */
+ auto struct scnhdr scntemp; /* Temporary section header */
+ register int scns;
+ unsigned int bss_start;
+ unsigned int data_start;
+
+ pagemask = getpagesize () - 1;
+
+ /* Adjust text/data boundary. */
+ data_start = (int) start_of_data ();
+ data_start = ADDR_CORRECT (data_start);
+ data_start = data_start & ~pagemask; /* (Down) to page boundary. */
+
+ bss_start = ADDR_CORRECT (sbrk (0)) + pagemask;
+ bss_start &= ~ pagemask;
+
+ if (data_start > bss_start) /* Can't have negative data size. */
+ {
+ ERROR2 ("unexec: data_start (%u) can't be greater than bss_start (%u)",
+ data_start, bss_start);
+ }
+
+ coff_offset = 0L; /* stays zero, except in DJGPP */
+
+ /* Salvage as much info from the existing file as possible */
+ if (a_out >= 0)
+ {
+#ifdef MSDOS
+ /* Support the coff-go32-exe format with a prepended stub, since
+ this is what GCC 2.8.0 and later generates by default in DJGPP. */
+ unsigned short mz_header[3];
+
+ if (read (a_out, &mz_header, sizeof (mz_header)) != sizeof (mz_header))
+ {
+ PERROR (a_name);
+ }
+ if (mz_header[0] == 0x5a4d || mz_header[0] == 0x4d5a) /* "MZ" or "ZM" */
+ {
+ coff_offset = (long)mz_header[2] * 512L;
+ if (mz_header[1])
+ coff_offset += (long)mz_header[1] - 512L;
+ lseek (a_out, coff_offset, 0);
+ }
+ else
+ lseek (a_out, 0L, 0);
+#endif /* MSDOS */
+ if (read (a_out, &f_hdr, sizeof (f_hdr)) != sizeof (f_hdr))
+ {
+ PERROR (a_name);
+ }
+ block_copy_start += sizeof (f_hdr);
+ if (f_hdr.f_opthdr > 0)
+ {
+ if (read (a_out, &f_ohdr, sizeof (f_ohdr)) != sizeof (f_ohdr))
+ {
+ PERROR (a_name);
+ }
+ block_copy_start += sizeof (f_ohdr);
+ }
+ /* Loop through section headers, copying them in */
+ lseek (a_out, coff_offset + sizeof (f_hdr) + f_hdr.f_opthdr, 0);
+ for (scns = f_hdr.f_nscns; scns > 0; scns--) {
+ if (read (a_out, &scntemp, sizeof (scntemp)) != sizeof (scntemp))
+ {
+ PERROR (a_name);
+ }
+ if (scntemp.s_scnptr > 0L)
+ {
+ if (block_copy_start < scntemp.s_scnptr + scntemp.s_size)
+ block_copy_start = scntemp.s_scnptr + scntemp.s_size;
+ }
+ if (strcmp (scntemp.s_name, ".text") == 0)
+ {
+ f_thdr = scntemp;
+ }
+ else if (strcmp (scntemp.s_name, ".data") == 0)
+ {
+ f_dhdr = scntemp;
+ }
+ else if (strcmp (scntemp.s_name, ".bss") == 0)
+ {
+ f_bhdr = scntemp;
+ }
+ }
+ }
+ else
+ {
+ ERROR0 ("can't build a COFF file from scratch yet");
+ }
+
+ /* Now we alter the contents of all the f_*hdr variables
+ to correspond to what we want to dump. */
+
+ f_hdr.f_flags |= (F_RELFLG | F_EXEC);
+ f_ohdr.dsize = bss_start - f_ohdr.data_start;
+ f_ohdr.bsize = 0;
+ f_thdr.s_size = f_ohdr.tsize;
+ f_thdr.s_scnptr = sizeof (f_hdr) + sizeof (f_ohdr);
+ f_thdr.s_scnptr += (f_hdr.f_nscns) * (sizeof (f_thdr));
+ lnnoptr = f_thdr.s_lnnoptr;
+ text_scnptr = f_thdr.s_scnptr;
+ f_dhdr.s_paddr = f_ohdr.data_start;
+ f_dhdr.s_vaddr = f_ohdr.data_start;
+ f_dhdr.s_size = f_ohdr.dsize;
+ f_dhdr.s_scnptr = f_thdr.s_scnptr + f_thdr.s_size;
+ data_scnptr = f_dhdr.s_scnptr;
+ f_bhdr.s_paddr = f_ohdr.data_start + f_ohdr.dsize;
+ f_bhdr.s_vaddr = f_ohdr.data_start + f_ohdr.dsize;
+ f_bhdr.s_size = f_ohdr.bsize;
+ f_bhdr.s_scnptr = 0L;
+ bias = f_dhdr.s_scnptr + f_dhdr.s_size - block_copy_start;
+
+ if (f_hdr.f_symptr > 0L)
+ {
+ f_hdr.f_symptr += bias;
+ }
+
+ if (f_thdr.s_lnnoptr > 0L)
+ {
+ f_thdr.s_lnnoptr += bias;
+ }
+
+ if (write (new, &f_hdr, sizeof (f_hdr)) != sizeof (f_hdr))
+ {
+ PERROR (new_name);
+ }
+
+ if (write (new, &f_ohdr, sizeof (f_ohdr)) != sizeof (f_ohdr))
+ {
+ PERROR (new_name);
+ }
+
+ if (write (new, &f_thdr, sizeof (f_thdr)) != sizeof (f_thdr))
+ {
+ PERROR (new_name);
+ }
+
+ if (write (new, &f_dhdr, sizeof (f_dhdr)) != sizeof (f_dhdr))
+ {
+ PERROR (new_name);
+ }
+
+ if (write (new, &f_bhdr, sizeof (f_bhdr)) != sizeof (f_bhdr))
+ {
+ PERROR (new_name);
+ }
+
+ return (0);
+
+}
+\f
+void
+write_segment (int new, const char *ptr, const char *end)
+{
+ register int i, nwrite, ret;
+ /* This is the normal amount to write at once.
+ It is the size of block that NFS uses. */
+ int writesize = 1 << 13;
+ int pagesize = getpagesize ();
+ char zeros[1 << 13];
+
+ memset (zeros, 0, sizeof (zeros));
+
+ for (i = 0; ptr < end;)
+ {
+ /* Distance to next multiple of writesize. */
+ nwrite = (((int) ptr + writesize) & -writesize) - (int) ptr;
+ /* But not beyond specified end. */
+ if (nwrite > end - ptr) nwrite = end - ptr;
+ ret = write (new, ptr, nwrite);
+ /* If write gets a page fault, it means we reached
+ a gap between the old text segment and the old data segment.
+ This gap has probably been remapped into part of the text segment.
+ So write zeros for it. */
+ if (ret == -1
+#ifdef EFAULT
+ && errno == EFAULT
+#endif
+ )
+ {
+ /* Write only a page of zeros at once,
+ so that we don't overshoot the start
+ of the valid memory in the old data segment. */
+ if (nwrite > pagesize)
+ nwrite = pagesize;
+ write (new, zeros, nwrite);
+ }
+ i += nwrite;
+ ptr += nwrite;
+ }
+}
+/* ****************************************************************
+ * copy_text_and_data
+ *
+ * Copy the text and data segments from memory to the new a.out
+ */
+static int
+copy_text_and_data (int new, int a_out)
+{
+ register char *end;
+ register char *ptr;
+
+#ifdef MSDOS
+ /* Dump the original table of exception handlers, not the one
+ where our exception hooks are registered. */
+ __djgpp_exception_toggle ();
+
+ /* Switch off startup flags that might have been set at runtime
+ and which might change the way that dumped Emacs works. */
+ save_djgpp_startup_flags = _crt0_startup_flags;
+ _crt0_startup_flags &= ~(_CRT0_FLAG_NO_LFN | _CRT0_FLAG_NEARPTR);
+#endif
+
+ lseek (new, (long) text_scnptr, 0);
+ ptr = (char *) f_ohdr.text_start;
+ end = ptr + f_ohdr.tsize;
+ write_segment (new, ptr, end);
+
+ lseek (new, (long) data_scnptr, 0);
+ ptr = (char *) f_ohdr.data_start;
+ end = ptr + f_ohdr.dsize;
+ write_segment (new, ptr, end);
+
+#ifdef MSDOS
+ /* Restore our exception hooks. */
+ __djgpp_exception_toggle ();
+
+ /* Restore the startup flags. */
+ _crt0_startup_flags = save_djgpp_startup_flags;
+#endif
+
+
+ return 0;
+}
+\f
+/* ****************************************************************
+ * copy_sym
+ *
+ * Copy the relocation information and symbol table from the a.out to the new
+ */
+static int
+copy_sym (int new, int a_out, const char *a_name, const char *new_name)
+{
+ char page[1024];
+ int n;
+
+ if (a_out < 0)
+ return 0;
+
+ if (SYMS_START == 0L)
+ return 0;
+
+ if (lnnoptr) /* if there is line number info */
+ lseek (a_out, coff_offset + lnnoptr, 0); /* start copying from there */
+ else
+ lseek (a_out, coff_offset + SYMS_START, 0); /* Position a.out to symtab. */
+
+ while ((n = read (a_out, page, sizeof page)) > 0)
+ {
+ if (write (new, page, n) != n)
+ {
+ PERROR (new_name);
+ }
+ }
+ if (n < 0)
+ {
+ PERROR (a_name);
+ }
+ return 0;
+}
+\f
+/* ****************************************************************
+ * mark_x
+ *
+ * After successfully building the new a.out, mark it executable
+ */
+static void
+mark_x (const char *name)
+{
+ struct stat sbuf;
+ int um;
+ int new = 0; /* for PERROR */
+
+ um = umask (777);
+ umask (um);
+ if (stat (name, &sbuf) == -1)
+ {
+ PERROR (name);
+ }
+ sbuf.st_mode |= 0111 & ~um;
+ if (chmod (name, sbuf.st_mode) == -1)
+ PERROR (name);
+}
+\f
+
+/*
+ * If the COFF file contains a symbol table and a line number section,
+ * then any auxiliary entries that have values for x_lnnoptr must
+ * be adjusted by the amount that the line number section has moved
+ * in the file (bias computed in make_hdr). The #@$%&* designers of
+ * the auxiliary entry structures used the absolute file offsets for
+ * the line number entry rather than an offset from the start of the
+ * line number section!
+ *
+ * When I figure out how to scan through the symbol table and pick out
+ * the auxiliary entries that need adjustment, this routine will
+ * be fixed. As it is now, all such entries are wrong and sdb
+ * will complain. Fred Fish, UniSoft Systems Inc.
+ */
+
+/* This function is probably very slow. Instead of reopening the new
+ file for input and output it should copy from the old to the new
+ using the two descriptors already open (WRITEDESC and READDESC).
+ Instead of reading one small structure at a time it should use
+ a reasonable size buffer. But I don't have time to work on such
+ things, so I am installing it as submitted to me. -- RMS. */
+
+int
+adjust_lnnoptrs (int writedesc, int readdesc, const char *new_name)
+{
+ register int nsyms;
+ register int new;
+ struct syment symentry;
+ union auxent auxentry;
+
+ if (!lnnoptr || !f_hdr.f_symptr)
+ return 0;
+
+#ifdef MSDOS
+ if ((new = writedesc) < 0)
+#else
+ if ((new = open (new_name, O_RDWR)) < 0)
+#endif
+ {
+ PERROR (new_name);
+ return -1;
+ }
+
+ lseek (new, f_hdr.f_symptr, 0);
+ for (nsyms = 0; nsyms < f_hdr.f_nsyms; nsyms++)
+ {
+ read (new, &symentry, SYMESZ);
+ if (symentry.n_numaux)
+ {
+ read (new, &auxentry, AUXESZ);
+ nsyms++;
+ if (ISFCN (symentry.n_type) || symentry.n_type == 0x2400)
+ {
+ auxentry.x_sym.x_fcnary.x_fcn.x_lnnoptr += bias;
+ lseek (new, -AUXESZ, 1);
+ write (new, &auxentry, AUXESZ);
+ }
+ }
+ }
+#ifndef MSDOS
+ close (new);
+#endif
+ return 0;
+}
+
+/* ****************************************************************
+ * unexec
+ *
+ * driving logic.
+ */
+int
+unexec (const char *new_name, const char *a_name)
+{
+ int new = -1, a_out = -1;
+
+ if (a_name && (a_out = open (a_name, O_RDONLY)) < 0)
+ {
+ PERROR (a_name);
+ }
+ if ((new = creat (new_name, 0666)) < 0)
+ {
+ PERROR (new_name);
+ }
+
+ if (make_hdr (new, a_out, a_name, new_name) < 0
+ || copy_text_and_data (new, a_out) < 0
+ || copy_sym (new, a_out, a_name, new_name) < 0
+ || adjust_lnnoptrs (new, a_out, new_name) < 0
+ )
+ {
+ close (new);
+ return -1;
+ }
+
+ close (new);
+ if (a_out >= 0)
+ close (a_out);
+ mark_x (new_name);
+ return 0;
+}
+
+#endif /* not CANNOT_DUMP */
+
+/* arch-tag: 62409b69-e27a-4a7c-9413-0210d6b54e7f
+ (do not change this comment) */
/* Graphical user interface functions for the Microsoft W32 API.
- Copyright (C) 1989, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
+
+Copyright (C) 1989, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
- 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
- Free Software Foundation, Inc.
+ 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
+ Free Software Foundation, Inc.
This file is part of GNU Emacs.
-/* Functions for handle font changes dynamically.
+/* Functions for handle font and other changes dynamically.
- Copyright (C) 2009, 2010
+ Copyright (C) 2009, 2010, 2011
Free Software Foundation, Inc.
This file is part of GNU Emacs.
projects / emacs.git / commitdiff