From: Stefan Monnier Date: Fri, 14 Jan 2011 17:18:41 +0000 (-0500) Subject: Merge from emacs-23 X-Git-Tag: emacs-pretest-24.0.90~104^2~618^2~1322^2~233^2~2 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=77ab81d0545e980c57c0a35510ade29a9e43b4cd;p=emacs.git Merge from emacs-23 --- 77ab81d0545e980c57c0a35510ade29a9e43b4cd diff --cc admin/ChangeLog index e0059664aba,33b091ba0b9..5edbbdac653 --- a/admin/ChangeLog +++ b/admin/ChangeLog @@@ -1,21 -1,8 +1,26 @@@ -2011-01-03 Glenn Morris ++2011-01-14 Glenn Morris + + * admin.el (set-copyright): Also handle \year in refcards/*.tex. + -2010-12-31 Eli Zaretskii ++2011-01-14 Eli Zaretskii +2011-01-14 Glenn Morris + + * bzrmerge.el: Require cl when compiling. + (bzrmerge-merges): Doc fix. + +2011-01-07 Paul Eggert + + * 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 + + * 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 * nt/README.W32: Update the information about PNG support libraries. (Bug#7716) diff --cc admin/admin.el index 7cd2c02fb58,b792287596b..4387aecdde7 --- a/admin/admin.el +++ b/admin/admin.el @@@ -172,18 -183,18 +171,18 @@@ Root must be the root of an Emacs sourc (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. diff --cc doc/emacs/regs.texi index d50bb087462,5eada94a0ab..731e03cde0b --- a/doc/emacs/regs.texi +++ b/doc/emacs/regs.texi @@@ -1,8 -1,8 +1,8 @@@ @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 diff --cc doc/lispintro/ChangeLog index d75bb003279,b77431f3313..1b7b803b39c --- a/doc/lispintro/ChangeLog +++ b/doc/lispintro/ChangeLog @@@ -447,10 -389,11 +447,10 @@@ ;; 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. diff --cc doc/misc/ChangeLog index 7fc944e523c,652322adca5..92b61e75688 --- a/doc/misc/ChangeLog +++ b/doc/misc/ChangeLog @@@ -1,70 -1,8 +1,75 @@@ -2011-01-03 Eduard Wiebe ++2011-01-14 Eduard Wiebe + + * nxml-mode.texi (Introduction): Fix file name typos. + -2010-12-02 Glenn Morris ++2011-01-14 Glenn Morris +2011-01-13 Christian Ohler + + * ert.texi: New file. + + * Makefile.in: + * makefile.w32-in: Add ert.texi. + +2011-01-10 Jan Moringen + + * dbus.texi (Receiving Method Calls): New function + dbus-register-service. Rearrange node. + +2011-01-07 Paul Eggert + + * 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 + + * dbus.texi (Receiving Method Calls): Describe new optional + parameter dont-register-service of dbus-register-{method,property}. + +2010-12-17 Daiki Ueno + + * epa.texi (Encrypting/decrypting *.gpg files): Mention + epa-file-select-keys. + +2010-12-16 Lars Magne Ingebrigtsen + + * gnus.texi (Archived Messages): Remove outdated text. + +2010-12-16 Teodor Zlatanov + + * gnus.texi (Foreign Groups): Added clarification of foreign groups. + +2010-12-15 Andrew Cohen + + * gnus.texi (The hyrex Engine): Say that this engine is obsolete. + +2010-12-14 Andrew Cohen + + * gnus.texi (The swish++ Engine): Add customizable parameters + descriptions. + (The swish-e Engine): Ditto. + +2010-12-14 Michael Albinus + + * tramp.texi (Inline methods): Add "ksu" method. + (Remote processes): Add example with remote `default-directory'. + +2010-12-14 Glenn Morris + + * faq.texi (Expanding aliases when sending mail): + Now build-mail-aliases is interactive. + +2010-12-13 Andrew Cohen + + * gnus.texi: First pass at adding (rough) nnir documentation. + +2010-12-13 Lars Magne Ingebrigtsen + + * 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 * cl.texi (For Clauses): Small fixes for frames and windows. diff --cc doc/misc/gnus-faq.texi index d9df9c8db18,d224d36fcda..bc0327df60c --- a/doc/misc/gnus-faq.texi +++ b/doc/misc/gnus-faq.texi @@@ -2,8 -2,11 +2,8 @@@ @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 . -@c @setfilename gnus-faq.info @settitle Frequently Asked Questions @c %**end of header diff --cc doc/misc/org.texi index 5a676786fdd,b20e1c6ce03..330e68603ca --- a/doc/misc/org.texi +++ b/doc/misc/org.texi @@@ -265,8 -45,7 +265,8 @@@ @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 diff --cc etc/ChangeLog index d8dd5aa0ae0,112f4ff60d0..5e8b164ce05 --- a/etc/ChangeLog +++ b/etc/ChangeLog @@@ -1,54 -1,22 +1,73 @@@ -2011-01-03 Glenn Morris ++2011-01-14 Glenn Morris + + * 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 ++2011-01-14 Kenichi Handa + + * NEWS: Describe the changes for rmail's MIME handling. + -2010-12-04 W. Martin Borgert (tiny change) ++2011-01-14 W. Martin Borgert (tiny change) +2011-01-13 Christian Ohler + + * NEWS: Mention ERT. + +2011-01-10 Jan Moringen + + * NEWS: Add new function dbus-register-service. + +2011-01-09 Chong Yidong + + * 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 + + * compilation.txt: Add column to gcc-include sample. + +2011-01-08 Glenn Morris + + * PROBLEMS: -batch implies -q. + +2011-01-07 Tassilo Horn + + * 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 + + * 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 + + * NEWS: Extended behaviour of dbus-register-{method,property}. + +2011-01-02 Kenichi Handa + + * NEWS.23: Describe the changes for rmail's MIME handling. + +2010-12-18 Chong Yidong + + * images/separator.xpm: Tweak colors. + +2010-12-14 Michael Albinus + + * NEWS: Mention new Tramp method "ksu". + +2010-12-13 W. Martin Borgert (tiny change) * schema/schemas.xml: Add DocBook (Bug#7491). diff --cc etc/NEWS.23 index 3b10a6d2815,00000000000..fd47f89699b mode 100644,000000..100644 --- a/etc/NEWS.23 +++ b/etc/NEWS.23 @@@ -1,2517 -1,0 +1,2517 @@@ +GNU Emacs NEWS -- history of user-visible changes. + - Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ++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. + + +* Installation Changes in Emacs 23.3 + +* Startup Changes in Emacs 23.3 + +* Changes in Emacs 23.3 + + +* Editing Changes in Emacs 23.3 + + +* 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 + 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. + + +* 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. + + +* 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. + + +* 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. + + +* 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. + + +* 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). + + +* 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. + + +* 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. + + +* 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. + + +* 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'. + + +* 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. + + +* 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. + + +* 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. + +* 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. + + +* 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.) + +* 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. + + +* 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'. + +* 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. + + +* 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. + + +* 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. + + +* 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. + + +* 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 \(?:\) 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. + + +* 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. + + +---------------------------------------------------------------------- +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 . + + +Local variables: +mode: outline +paragraph-separate: "[ ]*$" +end: + +arch-tag: e759449d-88b3-4de4-9900-3a6c3dfa23e2 diff --cc etc/images/README index 7adb3c7eb85,30ef4ec89e7..080c7d24028 --- a/etc/images/README +++ b/etc/images/README @@@ -33,12 -33,8 +33,12 @@@ Files: splash.pbm, splash.xpm, gnus.pb Files: splash.png, splash.svg Author: Francesc Rocher - 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 + 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 diff --cc etc/refcards/orgcard.tex index c55c55dcf99,28fb565dc84..d4704484905 --- a/etc/refcards/orgcard.tex +++ b/etc/refcards/orgcard.tex @@@ -1,7 -1,7 +1,7 @@@ % 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 diff --cc lisp/ChangeLog index 95b99750e3e,504ebf59708..813746ca6df --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@@ -1,396 -1,42 +1,432 @@@ -2011-01-03 Brent Goodrick (tiny change) ++2011-01-14 Brent Goodrick (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 ++2011-01-14 Stefan Monnier + + * progmodes/python.el (python-mode): Don't impose font-lock (bug#3628). + -2011-01-02 Stefan Monnier ++2011-01-14 Stefan Monnier + + * files.el (file-local-variables-alist): + Make permanent-local (bug#7767). + -2011-01-02 Glenn Morris ++2011-01-14 Glenn Morris + + * version.el (emacs-copyright): Set short copyright year to 2011. + -2011-01-02 Mark Lillibridge (tiny change) ++2011-01-14 Mark Lillibridge (tiny change) + + * mail/mail-utils.el (mail-strip-quoted-names): Avoid clobbering + an existing temp buffer. (Bug#7746) + -2011-01-02 Glenn Morris ++2011-01-14 Glenn Morris + + * mail/mail-utils.el (mail-mbox-from): Handle From: headers with + multiple addresses. (Bug#7760) + -2010-12-31 Michael Albinus ++2011-01-14 Michael Albinus + + * net/tramp.el (tramp-methods): Add recursive options to "scpc", + "scpx", "pscp" and "psftp". + -2010-12-31 Eli Zaretskii ++2011-01-14 Eli Zaretskii + + * term/w32-win.el (image-library-alist): Set up correctly for +2011-01-14 Kim F. Storm + + * emulation/cua-base.el (cua--init-keymaps): + Remap exchange-point-and-mark in cua-global-keymap. + +2011-01-14 Tassilo Horn + + * progmodes/sh-script.el (sh-other-keywords): Add ZSH's foreach + loop keyword. + +2011-01-14 Stefan Monnier + + * 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 + + 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 + + * 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 + + * 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 + + * dired-x.el (dired-omit-verbose): New defcustom that allows + disabling the omit messages. + (dired-omit-expunge): Use it. + +2011-01-13 Christian Ohler + + * emacs-lisp/ert.el, emacs-lisp/ert-x.el: New files. + +2011-01-13 Chong Yidong + + * font-lock.el (font-lock-verbose): Default to nil. + +2011-01-13 Chong Yidong + + * 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 + + * 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 + + * emacs-lisp/unsafep.el (unsafep): Handle backquoted forms. + +2011-01-11 Stefan Monnier + + * 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 + + * progmodes/prolog.el: Replace by a whole new file. + +2011-01-11 Stefan Monnier + + * 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 + + * calendar/diary-lib.el (diary-mode): Refresh *Calendar* after + refreshing the diary buffer. + +2011-01-10 Ken Manheimer + + * 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 + + * 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 + + * 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 + + * 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 + + * net/ldap.el (ldap-search-internal): Don't use eval. + +2011-01-09 Chong Yidong + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * makefile.w32-in (EMACSOPT): Add --no-site-lisp. + + * makefile.w32-in (EMACSOPT): -batch implies --no-init-file. + +2011-01-07 Sam Steingold + + * 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 + + * subr.el (y-or-n-p): Accept format string args. + +2011-01-07 Glenn Morris + + * Makefile.in (EMACSOPT): Add --no-site-lisp. + +2011-01-06 Ken Manheimer + + * 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 + + * 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 + + * 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 + + * emacs-lisp/rx.el (rx-repeat): Replace CL function. + +2011-01-04 Ken Manheimer + + * 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 + + * textmodes/rst.el (rst-compile-toolsets): + Add pdf and s5 to option alist. + +2011-01-04 Jan Moringen + + * net/dbus.el (dbus-register-property): Add optional parameter + dont-register-service. Updated docstring accordingly. + +2011-01-04 Andreas Schwab + + * textmodes/rst.el (rst-compile-pdf-preview) + (rst-compile-slides-preview): Remove extra line. + +2011-01-04 Glenn Morris + + * 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 + + * 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 +2011-01-02 Eli Zaretskii * time.el (display-time-mode): Mention display-time-interval in the doc string. (Bug#7713) diff --cc lisp/cedet/cedet-cscope.el index 211c7fb4b01,90b2277012a..afb06044f22 --- a/lisp/cedet/cedet-cscope.el +++ b/lisp/cedet/cedet-cscope.el @@@ -1,9 -1,8 +1,9 @@@ ;;; 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 +;; Package: cedet ;; This file is part of GNU Emacs. diff --cc lisp/cedet/cedet-files.el index bb7137ddad2,65112bdab92..b20cb3a172a --- a/lisp/cedet/cedet-files.el +++ b/lisp/cedet/cedet-files.el @@@ -1,9 -1,8 +1,9 @@@ ;;; 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 +;; Package: cedet ;; This file is part of GNU Emacs. diff --cc lisp/cedet/cedet-global.el index da4e618a749,9b270415dc1..8ac4ba1d0ba --- a/lisp/cedet/cedet-global.el +++ b/lisp/cedet/cedet-global.el @@@ -1,9 -1,8 +1,9 @@@ ;;; 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 +;; Package: cedet ;; This file is part of GNU Emacs. diff --cc lisp/cedet/ede/pmake.el index b8e7c5f61a6,45660566234..a9575b69249 --- a/lisp/cedet/ede/pmake.el +++ b/lisp/cedet/ede/pmake.el @@@ -1,7 -1,7 +1,7 @@@ ;;; 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 ;; Keywords: project, make diff --cc lisp/cedet/ede/speedbar.el index 8658a654b16,11c3bd8b7e5..c7ea005e6cb --- a/lisp/cedet/ede/speedbar.el +++ b/lisp/cedet/ede/speedbar.el @@@ -1,7 -1,7 +1,7 @@@ ;;; 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 ;; Keywords: project, make, tags diff --cc lisp/cedet/semantic/ede-grammar.el index 90c72990ca9,8623998cc30..a3d901a6146 --- a/lisp/cedet/semantic/ede-grammar.el +++ b/lisp/cedet/semantic/ede-grammar.el @@@ -1,7 -1,6 +1,6 @@@ ;;; 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 ;; Keywords: project, make diff --cc lisp/dframe.el index 9ca0a260f6d,ffcffc22c10..c2744d00252 --- a/lisp/dframe.el +++ b/lisp/dframe.el @@@ -1,8 -1,7 +1,8 @@@ ;;; 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 ;; Keywords: file, tags, tools diff --cc lisp/dynamic-setting.el index cfa1053c44d,00000000000..3597e8338ed mode 100644,000000..100644 --- a/lisp/dynamic-setting.el +++ b/lisp/dynamic-setting.el @@@ -1,110 -1,0 +1,110 @@@ +;;; dynamic-setting.el --- Support dynamic changes + - ;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. ++;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc. + +;; Author: Jan Djärv +;; 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 . + +;;; 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 diff --cc lisp/emacs-lisp/cl-specs.el index 776ce5e9ca1,c21fbb1a17c..9dab72fae48 --- a/lisp/emacs-lisp/cl-specs.el +++ b/lisp/emacs-lisp/cl-specs.el @@@ -1,10 -1,9 +1,10 @@@ ;;; 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 ;; Keywords: lisp, tools, maint +;; Package: emacs ;; LCD Archive Entry: ;; cl-specs.el|Daniel LaLiberte|liberte@holonexus.org diff --cc lisp/emacs-lisp/timer.el index b12d9068676,16d1af331fa..130b1ae23eb --- a/lisp/emacs-lisp/timer.el +++ b/lisp/emacs-lisp/timer.el @@@ -1,10 -1,9 +1,10 @@@ ;;; 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. diff --cc lisp/emulation/edt.el index bfed09e0df3,3e746cb0346..52b083da6a1 --- a/lisp/emulation/edt.el +++ b/lisp/emulation/edt.el @@@ -1,8 -1,7 +1,7 @@@ -;;; 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 ;; Maintainer: Kevin Gallagher diff --cc lisp/emulation/viper-cmd.el index 4e90889ddd0,317b5760caa..a4df2941b1c --- a/lisp/emulation/viper-cmd.el +++ b/lisp/emulation/viper-cmd.el @@@ -1,10 -1,9 +1,10 @@@ ;;; 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 +;; Package: viper ;; This file is part of GNU Emacs. diff --cc lisp/emulation/viper-ex.el index be387d7724b,b068bd5ca25..e4cfbe88572 --- a/lisp/emulation/viper-ex.el +++ b/lisp/emulation/viper-ex.el @@@ -1,10 -1,9 +1,10 @@@ ;;; 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 +;; Package: viper ;; This file is part of GNU Emacs. diff --cc lisp/emulation/viper-init.el index 5af96922171,1ecff657d2a..f18cd55d7f8 --- a/lisp/emulation/viper-init.el +++ b/lisp/emulation/viper-init.el @@@ -1,10 -1,9 +1,10 @@@ ;;; 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 +;; Package: viper ;; This file is part of GNU Emacs. diff --cc lisp/emulation/viper-keym.el index d75573673d7,a3dda4e0ceb..79d7505f512 --- a/lisp/emulation/viper-keym.el +++ b/lisp/emulation/viper-keym.el @@@ -1,10 -1,9 +1,10 @@@ ;;; 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 +;; Package: viper ;; This file is part of GNU Emacs. diff --cc lisp/emulation/viper-macs.el index 71d565632eb,d39589f44d7..3af24a46f9b --- a/lisp/emulation/viper-macs.el +++ b/lisp/emulation/viper-macs.el @@@ -1,10 -1,9 +1,10 @@@ ;;; 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 +;; Package: viper ;; This file is part of GNU Emacs. diff --cc lisp/emulation/viper-mous.el index 9bea921e167,31acf40028a..69ad062fc28 --- a/lisp/emulation/viper-mous.el +++ b/lisp/emulation/viper-mous.el @@@ -1,10 -1,9 +1,10 @@@ ;;; 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 +;; Package: viper ;; This file is part of GNU Emacs. diff --cc lisp/emulation/viper-util.el index 6868a960087,81485a0390d..70e5466346d --- a/lisp/emulation/viper-util.el +++ b/lisp/emulation/viper-util.el @@@ -1,11 -1,9 +1,10 @@@ ;;; 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 +;; Package: viper ;; This file is part of GNU Emacs. diff --cc lisp/face-remap.el index f7f469b0ccc,6bb84acb16c..3420eea29e0 --- a/lisp/face-remap.el +++ b/lisp/face-remap.el @@@ -1,9 -1,9 +1,9 @@@ ;;; 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 -;; Keywords: faces face remapping display user commands +;; Keywords: faces, face remapping, display, user commands ;; ;; This file is part of GNU Emacs. ;; diff --cc lisp/format.el index b4277ef6df0,f9b00414c99..59cb1a2b139 --- a/lisp/format.el +++ b/lisp/format.el @@@ -1,10 -1,9 +1,10 @@@ ;;; 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 +;; Package: emacs ;; This file is part of GNU Emacs. diff --cc lisp/indent.el index e57d6068ef5,8adb5a9bd6a..6d0100489d1 --- a/lisp/indent.el +++ b/lisp/indent.el @@@ -1,10 -1,9 +1,10 @@@ ;;; 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. diff --cc lisp/language/hebrew.el index bcc3d625d68,3ff2538469d..ad079c2d70b --- a/lisp/language/hebrew.el +++ b/lisp/language/hebrew.el @@@ -1,9 -1,9 +1,9 @@@ -;;; 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 diff --cc lisp/midnight.el index 5ff1ecc9b07,ef4d0dd1136..b4b0528677f --- a/lisp/midnight.el +++ b/lisp/midnight.el @@@ -1,10 -1,10 +1,10 @@@ ;;; 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 -;; Maintainer: Sam Steingold +;; Author: Sam Steingold +;; Maintainer: Sam Steingold ;; Created: 1998-05-18 ;; Keywords: utilities diff --cc lisp/minibuffer.el index 8d09d5d3f6d,338ab4e281e..284cbdc2182 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@@ -1,9 -1,8 +1,9 @@@ ;;; 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 +;; Package: emacs ;; This file is part of GNU Emacs. diff --cc lisp/mwheel.el index 2fc84c06245,03aefcaf441..d16c20cd585 --- a/lisp/mwheel.el +++ b/lisp/mwheel.el @@@ -1,10 -1,9 +1,10 @@@ ;;; 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 ;; Keywords: mouse +;; Package: emacs ;; This file is part of GNU Emacs. diff --cc lisp/net/hmac-def.el index c16fffc8de4,459d0b81779..a7a408e853b --- a/lisp/net/hmac-def.el +++ b/lisp/net/hmac-def.el @@@ -1,9 -1,9 +1,9 @@@ ;;; 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 -;; Keywords: HMAC, RFC-2104 +;; Keywords: HMAC, RFC2104 ;; This file is part of GNU Emacs. diff --cc lisp/net/hmac-md5.el index a0bfd36ea69,c433d7004d8..e61ea80456f --- a/lisp/net/hmac-md5.el +++ b/lisp/net/hmac-md5.el @@@ -1,9 -1,9 +1,9 @@@ ;;; 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 -;; 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. diff --cc lisp/net/tramp-sh.el index 9950709bd7a,00000000000..ae7deeeb953 mode 100644,000000..100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@@ -1,5061 -1,0 +1,5061 @@@ +;;; tramp-sh.el --- Tramp access functions for (s)sh-like connections + +;; 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 +;; Michael Albinus +;; 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 . + +;;; 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 . - # 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. +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 = ) { + 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 . +# 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 = ) { + 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 +(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 ' + ;; 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 ) + (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 + ;; . + (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 " 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 diff --cc lisp/net/tramp.el index c198d9e082d,0ac5048ef3b..cd9ef314acc --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@@ -1,8 -1,10 +1,8 @@@ ;;; 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 ;; Michael Albinus ;; Keywords: comm, processes diff --cc lisp/obsolete/complete.el index b7e94743802,00000000000..faf8d8336e8 mode 100644,000000..100644 --- a/lisp/obsolete/complete.el +++ b/lisp/obsolete/complete.el @@@ -1,1124 -1,0 +1,1124 @@@ +;;; 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 Free Software Foundation, Inc. ++;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. + +;; Author: Dave Gillespie +;; 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 . + +;;; 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 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.") + + +(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] 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)))) + + +(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))) + + +(provide 'complete) + +;; arch-tag: fc7e2768-ff44-4e22-b579-4d825b968458 +;;; complete.el ends here diff --cc lisp/obsolete/pgg-def.el index 0d602fda617,00000000000..93dbf3c1abc mode 100644,000000..100644 --- a/lisp/obsolete/pgg-def.el +++ b/lisp/obsolete/pgg-def.el @@@ -1,99 -1,0 +1,99 @@@ +;;; pgg-def.el --- functions/macros for defining PGG functions + +;; Copyright (C) 1999, 2002, 2003, 2004, 2005, - ;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ++;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. + +;; Author: Daiki Ueno +;; 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 . + +;;; 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 diff --cc lisp/obsolete/pgg-gpg.el index 7e67790a4ce,00000000000..35d80656871 mode 100644,000000..100644 --- a/lisp/obsolete/pgg-gpg.el +++ b/lisp/obsolete/pgg-gpg.el @@@ -1,411 -1,0 +1,411 @@@ +;;; pgg-gpg.el --- GnuPG support for PGG. + +;; Copyright (C) 1999, 2000, 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: Daiki Ueno +;; Symmetric encryption and gpg-agent support added by: +;; Sascha Wilde +;; 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 . + +;;; 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 diff --cc lisp/obsolete/pgg-parse.el index 640d0b3ce0f,00000000000..6dea3668e7b mode 100644,000000..100644 --- a/lisp/obsolete/pgg-parse.el +++ b/lisp/obsolete/pgg-parse.el @@@ -1,524 -1,0 +1,524 @@@ +;;; pgg-parse.el --- OpenPGP packet parsing + +;; Copyright (C) 1999, 2002, 2003, 2004, 2005, - ;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ++;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. + +;; Author: Daiki Ueno +;; 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 . + +;;; Commentary: + +;; This module is based on + +;; [OpenPGP] RFC 2440: "OpenPGP Message Format" +;; by John W. Noerenberg, II , +;; Jon Callas , Lutz Donnerhacke , +;; Hal Finney and Rodney Thayer +;; (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 diff --cc lisp/obsolete/pgg-pgp.el index 9d1d8ef1c04,00000000000..7883e3785ce mode 100644,000000..100644 --- a/lisp/obsolete/pgg-pgp.el +++ b/lisp/obsolete/pgg-pgp.el @@@ -1,258 -1,0 +1,258 @@@ +;;; pgg-pgp.el --- PGP 2.* and 6.* support for PGG. + +;; Copyright (C) 1999, 2000, 2002, 2003, 2004, 2005, 2006, 2007, 2008, - ;; 2009, 2010 Free Software Foundation, Inc. ++;; 2009, 2010, 2011 Free Software Foundation, Inc. + +;; Author: Daiki Ueno +;; 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 . + +;;; 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 diff --cc lisp/obsolete/pgg-pgp5.el index dd662c21d25,00000000000..7f923ee1e99 mode 100644,000000..100644 --- a/lisp/obsolete/pgg-pgp5.el +++ b/lisp/obsolete/pgg-pgp5.el @@@ -1,259 -1,0 +1,259 @@@ +;;; pgg-pgp5.el --- PGP 5.* support for PGG. + +;; Copyright (C) 1999, 2000, 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: Daiki Ueno +;; 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 . + +;;; 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 diff --cc lisp/obsolete/pgg.el index b63dd46c98b,00000000000..93d9a7a094e mode 100644,000000..100644 --- a/lisp/obsolete/pgg.el +++ b/lisp/obsolete/pgg.el @@@ -1,600 -1,0 +1,600 @@@ +;;; pgg.el --- glue for the various PGP implementations. + +;; Copyright (C) 1999, 2000, 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: Daiki Ueno +;; Symmetric encryption added by: Sascha Wilde +;; 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 . + +;;; 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 diff --cc lisp/obsolete/s-region.el index a88d1f37ee7,00000000000..2b8c4a38bf8 mode 100644,000000..100644 --- a/lisp/obsolete/s-region.el +++ b/lisp/obsolete/s-region.el @@@ -1,125 -1,0 +1,125 @@@ +;;; s-region.el --- set region using shift key + +;; Copyright (C) 1994, 1995, 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: Morten Welinder +;; 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 . + +;;; 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 diff --cc lisp/obsolete/sregex.el index ef4700c15f8,00000000000..e6bebc861a5 mode 100644,000000..100644 --- a/lisp/obsolete/sregex.el +++ b/lisp/obsolete/sregex.el @@@ -1,609 -1,0 +1,609 @@@ +;;; sregex.el --- symbolic regular expressions + +;; Copyright (C) 1997, 1998, 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: Bob Glickstein +;; Maintainer: Bob Glickstein +;; 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 . + +;;; 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 diff --cc lisp/pcmpl-cvs.el index 98d1e476669,49522ea9da8..b960ec215e7 --- a/lisp/pcmpl-cvs.el +++ b/lisp/pcmpl-cvs.el @@@ -1,10 -1,9 +1,10 @@@ ;;; 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 +;; Package: pcomplete ;; This file is part of GNU Emacs. diff --cc lisp/pcmpl-gnu.el index df1f055506c,2b4334f89ee..196be69abd5 --- a/lisp/pcmpl-gnu.el +++ b/lisp/pcmpl-gnu.el @@@ -1,10 -1,8 +1,10 @@@ ;;; 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 diff --cc lisp/pcmpl-linux.el index 59c084fffae,7f2d67fc3cd..38e7270482d --- a/lisp/pcmpl-linux.el +++ b/lisp/pcmpl-linux.el @@@ -1,10 -1,8 +1,10 @@@ ;;; 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 diff --cc lisp/pcmpl-rpm.el index 7960141f03e,6d160a68085..cf6158da3fd --- a/lisp/pcmpl-rpm.el +++ b/lisp/pcmpl-rpm.el @@@ -1,10 -1,8 +1,10 @@@ ;;; 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 diff --cc lisp/pcmpl-unix.el index f2c19ca71c4,afa951b184b..b4c79831a59 --- a/lisp/pcmpl-unix.el +++ b/lisp/pcmpl-unix.el @@@ -1,10 -1,8 +1,10 @@@ ;;; 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 diff --cc lisp/progmodes/octave-mod.el index 3e6c2896752,e467ca08929..2911b97db89 --- a/lisp/progmodes/octave-mod.el +++ b/lisp/progmodes/octave-mod.el @@@ -1,10 -1,10 +1,10 @@@ ;;; 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 -;; Author: John Eaton +;; Author: John Eaton ;; Maintainer: Kurt Hornik ;; Keywords: languages diff --cc lisp/select.el index 0f43ce05822,9e7d844ff22..b8bc8ff25ea --- a/lisp/select.el +++ b/lisp/select.el @@@ -1,8 -1,5 +1,8 @@@ ;;; select.el --- lisp portion of standard selection support +;; Copyright (C) 1993, 1994, 2001, 2002, 2003, 2004, 2005, 2006, 2007, - ;; 2008, 2009, 2010 Free Software Foundation, Inc. ++;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc. + ;; Maintainer: FSF ;; Keywords: internal diff --cc lisp/tabify.el index 591a9432fe5,d6731c032fd..0c5ca8413ef --- a/lisp/tabify.el +++ b/lisp/tabify.el @@@ -1,10 -1,9 +1,10 @@@ ;;; 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. diff --cc lisp/tool-bar.el index 51d13fe3920,ddaf16043a3..7339dcecc2b --- a/lisp/tool-bar.el +++ b/lisp/tool-bar.el @@@ -1,11 -1,10 +1,11 @@@ ;;; 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 ;; Keywords: mouse frames +;; Package: emacs ;; This file is part of GNU Emacs. diff --cc lisp/url/ChangeLog index 45b023ffb60,de0f57d073c..dc6fd979231 --- a/lisp/url/ChangeLog +++ b/lisp/url/ChangeLog @@@ -2375,10 -2231,11 +2375,10 @@@ ;; 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. diff --cc lisp/url/url-cookie.el index 37fd6005995,607f4da3d09..c373ef6f66a --- a/lisp/url/url-cookie.el +++ b/lisp/url/url-cookie.el @@@ -1,7 -1,7 +1,7 @@@ -;;; 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 diff --cc lisp/vc/add-log.el index c356dde8226,00000000000..23b7466f8d5 mode 100644,000000..100644 --- a/lisp/vc/add-log.el +++ b/lisp/vc/add-log.el @@@ -1,1371 -1,0 +1,1371 @@@ +;;; 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 ++;; 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 . + +;;; 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))) + +(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 "]")))))) + +(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 diff --cc lisp/vc/compare-w.el index 6e2ab7327de,00000000000..5b680ea4f1e mode 100644,000000..100644 --- a/lisp/vc/compare-w.el +++ b/lisp/vc/compare-w.el @@@ -1,393 -1,0 +1,393 @@@ +;;; 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 Free Software Foundation, Inc. ++;; 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 . + +;;; 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 diff --cc lisp/vc/cvs-status.el index 140f299b610,00000000000..ffcb3a9d53d mode 100644,000000..100644 --- a/lisp/vc/cvs-status.el +++ b/lisp/vc/cvs-status.el @@@ -1,539 -1,0 +1,539 @@@ +;;; cvs-status.el --- major mode for browsing `cvs status' output -*- coding: utf-8 -*- + +;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, - ;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ++;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. + +;; Author: Stefan Monnier +;; Keywords: pcl-cvs cvs status tree vc tools + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Todo: + +;; - Somehow allow cvs-status-tree to work on-the-fly + +;;; Code: + +(eval-when-compile (require 'cl)) +(require 'pcvs-util) + +;;; + +(defgroup cvs-status nil + "Major mode for browsing `cvs status' output." + :group 'pcl-cvs + :prefix "cvs-status-") + +(easy-mmode-defmap cvs-status-mode-map + '(("n" . next-line) + ("p" . previous-line) + ("N" . cvs-status-next) + ("P" . cvs-status-prev) + ("\M-n" . cvs-status-next) + ("\M-p" . cvs-status-prev) + ("t" . cvs-status-cvstrees) + ("T" . cvs-status-trees) + (">" . cvs-mode-checkout)) + "CVS-Status' keymap." + :group 'cvs-status + :inherit 'cvs-mode-map) + +;;(easy-menu-define cvs-status-menu cvs-status-mode-map +;; "Menu for `cvs-status-mode'." +;; '("CVS-Status" +;; ["Show Tag Trees" cvs-status-tree t] +;; )) + +(defvar cvs-status-mode-hook nil + "Hook run at the end of `cvs-status-mode'.") + +(defconst cvs-status-tags-leader-re "^ Existing Tags:$") +(defconst cvs-status-entry-leader-re + "^File:\\s-+\\(?:no file \\)?\\(.*\\S-\\)\\s-+Status: \\(.+\\)$") +(defconst cvs-status-dir-re "^cvs[.ex]* [a-z]+: Examining \\(.+\\)$") +(defconst cvs-status-rev-re "[0-9][.0-9]*\\.[.0-9]*[0-9]") +(defconst cvs-status-tag-re "[ \t]\\([a-zA-Z][^ \t\n.]*\\)") + +(defconst cvs-status-font-lock-keywords + `((,cvs-status-entry-leader-re + (1 'cvs-filename) + (2 'cvs-need-action)) + (,cvs-status-tags-leader-re + (,cvs-status-rev-re + (save-excursion (re-search-forward "^\n" nil 'move) (point)) + (progn (re-search-backward cvs-status-tags-leader-re nil t) + (forward-line 1)) + (0 font-lock-comment-face)) + (,cvs-status-tag-re + (save-excursion (re-search-forward "^\n" nil 'move) (point)) + (progn (re-search-backward cvs-status-tags-leader-re nil t) + (forward-line 1)) + (1 font-lock-function-name-face))))) +(defconst cvs-status-font-lock-defaults + '(cvs-status-font-lock-keywords t nil nil nil (font-lock-multiline . t))) + +(defvar cvs-minor-wrap-function) +(put 'cvs-status-mode 'mode-class 'special) +;;;###autoload +(define-derived-mode cvs-status-mode fundamental-mode "CVS-Status" + "Mode used for cvs status output." + (set (make-local-variable 'font-lock-defaults) cvs-status-font-lock-defaults) + (set (make-local-variable 'cvs-minor-wrap-function) 'cvs-status-minor-wrap)) + +;; Define cvs-status-next and cvs-status-prev +(easy-mmode-define-navigation cvs-status cvs-status-entry-leader-re "entry") + +(defun cvs-status-current-file () + (save-excursion + (forward-line 1) + (or (re-search-backward cvs-status-entry-leader-re nil t) + (re-search-forward cvs-status-entry-leader-re)) + (let* ((file (match-string 1)) + (cvsdir (and (re-search-backward cvs-status-dir-re nil t) + (match-string 1))) + (pcldir (and (if (boundp 'cvs-pcl-cvs-dirchange-re) + (re-search-backward cvs-pcl-cvs-dirchange-re nil t)) + (match-string 1))) + (dir "")) + (let ((default-directory "")) + (when pcldir (setq dir (expand-file-name pcldir dir))) + (when cvsdir (setq dir (expand-file-name cvsdir dir))) + (expand-file-name file dir))))) + +(defun cvs-status-current-tag () + (save-excursion + (let ((pt (point)) + (col (current-column)) + (start (progn (re-search-backward cvs-status-tags-leader-re nil t) (point))) + (end (progn (re-search-forward "^$" nil t) (point)))) + (when (and (< start pt) (> end pt)) + (goto-char pt) + (end-of-line) + (let ((tag nil) (dist pt) (end (point))) + (beginning-of-line) + (while (re-search-forward cvs-status-tag-re end t) + (let* ((cole (current-column)) + (colb (save-excursion + (goto-char (match-beginning 1)) (current-column))) + (ndist (min (abs (- cole col)) (abs (- colb col))))) + (when (< ndist dist) + (setq dist ndist) + (setq tag (match-string 1))))) + tag))))) + +(defun cvs-status-minor-wrap (buf f) + (let ((data (with-current-buffer buf + (cons + (cons (cvs-status-current-file) + (cvs-status-current-tag)) + (when mark-active + (save-excursion + (goto-char (mark)) + (cons (cvs-status-current-file) + (cvs-status-current-tag)))))))) + (let ((cvs-branch-prefix (cdar data)) + (cvs-secondary-branch-prefix (and (cdar data) (cddr data))) + (cvs-minor-current-files + (cons (caar data) + (when (and (cadr data) (not (equal (caar data) (cadr data)))) + (list (cadr data))))) + ;; FIXME: I need to force because the fileinfos are UNKNOWN + (cvs-force-command "/F")) + (funcall f)))) + +;; +;; Tagelt, tag element +;; + +(defstruct (cvs-tag + (:constructor nil) + (:constructor cvs-tag-make + (vlist &optional name type)) + (:conc-name cvs-tag->)) + vlist + name + type) + +(defsubst cvs-status-vl-to-str (vl) (mapconcat 'number-to-string vl ".")) + +(defun cvs-tag->string (tag) + (if (stringp tag) tag + (let ((name (cvs-tag->name tag)) + (vl (cvs-tag->vlist tag))) + (if (null name) (cvs-status-vl-to-str vl) + (let ((rev (if vl (concat " (" (cvs-status-vl-to-str vl) ")") ""))) + (if (consp name) (mapcar (lambda (name) (concat name rev)) name) + (concat name rev))))))) + +(defun cvs-tag-compare-1 (vl1 vl2) + (cond + ((and (null vl1) (null vl2)) 'equal) + ((null vl1) 'more2) + ((null vl2) 'more1) + (t (let ((v1 (car vl1)) + (v2 (car vl2))) + (cond + ((> v1 v2) 'more1) + ((< v1 v2) 'more2) + (t (cvs-tag-compare-1 (cdr vl1) (cdr vl2)))))))) + +(defsubst cvs-tag-compare (tag1 tag2) + (cvs-tag-compare-1 (cvs-tag->vlist tag1) (cvs-tag->vlist tag2))) + +(defun cvs-tag-merge (tag1 tag2) + "Merge TAG1 and TAG2 into one." + (let ((type1 (cvs-tag->type tag1)) + (type2 (cvs-tag->type tag2)) + (name1 (cvs-tag->name tag1)) + (name2 (cvs-tag->name tag2))) + (unless (equal (cvs-tag->vlist tag1) (cvs-tag->vlist tag2)) + (setf (cvs-tag->vlist tag1) nil)) + (if type1 + (unless (or (not type2) (equal type1 type2)) + (setf (cvs-tag->type tag1) nil)) + (setf (cvs-tag->type tag1) type2)) + (if name1 + (setf (cvs-tag->name tag1) (cvs-append name1 name2)) + (setf (cvs-tag->name tag1) name2)) + tag1)) + +(defun cvs-tree-print (tags printer column) + "Print the tree of TAGS where each tag's string is given by PRINTER. +PRINTER should accept both a tag (in which case it should return a string) +or a string (in which case it should simply return its argument). +A tag cannot be a CONS. The return value can also be a list of strings, +if several nodes where merged into one. +The tree will be printed no closer than column COLUMN." + + (let* ((eol (save-excursion (end-of-line) (current-column))) + (column (max (+ eol 2) column))) + (if (null tags) column + (let* ((rev (cvs-car tags)) + (name (funcall printer (cvs-car rev))) + (rest (append (cvs-cdr name) (cvs-cdr tags))) + (prefix + (save-excursion + (or (= (forward-line 1) 0) (insert "\n")) + (cvs-tree-print rest printer column)))) + (assert (>= prefix column)) + (move-to-column prefix t) + (assert (eolp)) + (insert (cvs-car name)) + (dolist (br (cvs-cdr rev)) + (let* ((column (current-column)) + (brrev (funcall printer (cvs-car br))) + (brlength (length (cvs-car brrev))) + (brfill (concat (make-string (/ brlength 2) ? ) "|")) + (prefix + (save-excursion + (insert " -- ") + (cvs-tree-print (cvs-append brrev brfill (cvs-cdr br)) + printer (current-column))))) + (delete-region (save-excursion (move-to-column prefix) (point)) + (point)) + (insert " " (make-string (- prefix column 2) ?-) " ") + (end-of-line))) + prefix)))) + +(defun cvs-tree-merge (tree1 tree2) + "Merge tags trees TREE1 and TREE2 into one. +BEWARE: because of stability issues, this is not a symetric operation." + (assert (and (listp tree1) (listp tree2))) + (cond + ((null tree1) tree2) + ((null tree2) tree1) + (t + (let* ((rev1 (car tree1)) + (tag1 (cvs-car rev1)) + (vl1 (cvs-tag->vlist tag1)) + (l1 (length vl1)) + (rev2 (car tree2)) + (tag2 (cvs-car rev2)) + (vl2 (cvs-tag->vlist tag2)) + (l2 (length vl2))) + (cond + ((= l1 l2) + (case (cvs-tag-compare tag1 tag2) + (more1 (list* rev2 (cvs-tree-merge tree1 (cdr tree2)))) + (more2 (list* rev1 (cvs-tree-merge (cdr tree1) tree2))) + (equal + (cons (cons (cvs-tag-merge tag1 tag2) + (cvs-tree-merge (cvs-cdr rev1) (cvs-cdr rev2))) + (cvs-tree-merge (cdr tree1) (cdr tree2)))))) + ((> l1 l2) + (cvs-tree-merge + (list (cons (cvs-tag-make (butlast vl1)) tree1)) tree2)) + ((< l1 l2) + (cvs-tree-merge + tree1 (list (cons (cvs-tag-make (butlast vl2)) tree2))))))))) + +(defun cvs-tag-make-tag (tag) + (let ((vl (mapcar 'string-to-number (split-string (nth 2 tag) "\\.")))) + (cvs-tag-make vl (nth 0 tag) (intern (nth 1 tag))))) + +(defun cvs-tags->tree (tags) + "Make a tree out of a list of TAGS." + (let ((tags + (mapcar + (lambda (tag) + (let ((tag (cvs-tag-make-tag tag))) + (list (if (not (eq (cvs-tag->type tag) 'branch)) tag + (list (cvs-tag-make (butlast (cvs-tag->vlist tag))) + tag))))) + tags))) + (while (cdr tags) + (let (tl) + (while tags + (push (cvs-tree-merge (pop tags) (pop tags)) tl)) + (setq tags (nreverse tl)))) + (car tags))) + +(defun cvs-status-get-tags () + "Look for a list of tags, read them in and delete them. +Return nil if there was an empty list of tags and t if there wasn't +even a list. Else, return the list of tags where each element of +the list is a three-string list TAG, KIND, REV." + (let ((tags nil)) + (if (not (re-search-forward cvs-status-tags-leader-re nil t)) t + (forward-char 1) + (let ((pt (point)) + (lastrev nil) + (case-fold-search t)) + (or + (looking-at "\\s-+no\\s-+tags") + + (progn ; normal listing + (while (looking-at "^[ \t]+\\([^ \t\n]+\\)[ \t]+(\\([a-z]+\\): \\(.+\\))$") + (push (list (match-string 1) (match-string 2) (match-string 3)) tags) + (forward-line 1)) + (unless (looking-at "^$") (setq tags nil) (goto-char pt)) + tags) + + (progn ; cvstree-style listing + (while (or (looking-at "^ .+\\(.\\) \\([0-9.]+\\): \\([^\n\t .0-9][^\n\t ]*\\)?$") + (and lastrev + (looking-at "^ .+\\(\\) \\(8\\)? \\([^\n\t .0-9][^\n\t ]*\\)$"))) + (setq lastrev (or (match-string 2) lastrev)) + (push (list (match-string 3) + (if (equal (match-string 1) " ") "branch" "revision") + lastrev) tags) + (forward-line 1)) + (unless (looking-at "^$") (setq tags nil) (goto-char pt)) + (setq tags (nreverse tags))) + + (progn ; new tree style listing + (let* ((re-lead "[ \t]*\\(-+\\)?\\(|\n?[ \t]+\\)*") + (re3 (concat re-lead "\\(\\.\\)?\\(" cvs-status-rev-re "\\)")) + (re2 (concat re-lead cvs-status-tag-re "\\(\\)")) + (re1 (concat re-lead cvs-status-tag-re + " (\\(" cvs-status-rev-re "\\))"))) + (while (or (looking-at re1) (looking-at re2) (looking-at re3)) + (push (list (match-string 3) + (if (match-string 1) "branch" "revision") + (match-string 4)) tags) + (goto-char (match-end 0)) + (when (eolp) (forward-char 1)))) + (unless (looking-at "^$") (setq tags nil) (goto-char pt)) + (setq tags (nreverse tags)))) + + (delete-region pt (point))) + tags))) + +(defvar font-lock-mode) +;; (defun cvs-refontify (beg end) +;; (when (and (boundp 'font-lock-mode) +;; font-lock-mode +;; (fboundp 'font-lock-fontify-region)) +;; (font-lock-fontify-region (1- beg) (1+ end)))) + +(defun cvs-status-trees () + "Look for a lists of tags, and replace them with trees." + (interactive) + (save-excursion + (goto-char (point-min)) + (let ((inhibit-read-only t) + (tags nil)) + (while (listp (setq tags (cvs-status-get-tags))) + ;;(let ((pt (save-excursion (forward-line -1) (point)))) + (save-restriction + (narrow-to-region (point) (point)) + ;;(newline) + (combine-after-change-calls + (cvs-tree-print (cvs-tags->tree tags) 'cvs-tag->string 3))) + ;;(cvs-refontify pt (point)) + ;;(sit-for 0) + ;;) + )))) + +;;;; +;;;; CVSTree-style trees +;;;; + +(defvar cvs-tree-use-jisx0208 nil) ;Old compat var. +(defvar cvs-tree-use-charset + (cond + (cvs-tree-use-jisx0208 'jisx0208) + ((char-displayable-p ?━) 'unicode) + ((char-displayable-p (make-char 'japanese-jisx0208 40 44)) 'jisx0208)) + "*Non-nil if we should use the graphical glyphs from `japanese-jisx0208'. +Otherwise, default to ASCII chars like +, - and |.") + +(defconst cvs-tree-char-space + (case cvs-tree-use-charset + (jisx0208 (make-char 'japanese-jisx0208 33 33)) + (unicode " ") + (t " "))) +(defconst cvs-tree-char-hbar + (case cvs-tree-use-charset + (jisx0208 (make-char 'japanese-jisx0208 40 44)) + (unicode "━") + (t "--"))) +(defconst cvs-tree-char-vbar + (case cvs-tree-use-charset + (jisx0208 (make-char 'japanese-jisx0208 40 45)) + (unicode "┃") + (t "| "))) +(defconst cvs-tree-char-branch + (case cvs-tree-use-charset + (jisx0208 (make-char 'japanese-jisx0208 40 50)) + (unicode "┣") + (t "+-"))) +(defconst cvs-tree-char-eob ;end of branch + (case cvs-tree-use-charset + (jisx0208 (make-char 'japanese-jisx0208 40 49)) + (unicode "┗") + (t "`-"))) +(defconst cvs-tree-char-bob ;beginning of branch + (case cvs-tree-use-charset + (jisx0208 (make-char 'japanese-jisx0208 40 51)) + (unicode "┳") + (t "+-"))) + +(defun cvs-tag-lessp (tag1 tag2) + (eq (cvs-tag-compare tag1 tag2) 'more2)) + +(defvar cvs-tree-nomerge nil) + +(defun cvs-status-cvstrees (&optional arg) + "Look for a list of tags, and replace it with a tree. +Optional prefix ARG chooses between two representations." + (interactive "P") + (when (and cvs-tree-use-charset + (not enable-multibyte-characters)) + ;; We need to convert the buffer from unibyte to multibyte + ;; since we'll use multibyte chars for the tree. + (let ((modified (buffer-modified-p)) + (inhibit-read-only t) + (inhibit-modification-hooks t)) + (unwind-protect + (progn + (decode-coding-region (point-min) (point-max) 'undecided) + (set-buffer-multibyte t)) + (restore-buffer-modified-p modified)))) + (save-excursion + (goto-char (point-min)) + (let ((inhibit-read-only t) + (tags nil) + (cvs-tree-nomerge (if arg (not cvs-tree-nomerge) cvs-tree-nomerge))) + (while (listp (setq tags (cvs-status-get-tags))) + (let ((tags (mapcar 'cvs-tag-make-tag tags)) + ;;(pt (save-excursion (forward-line -1) (point))) + ) + (setq tags (sort tags 'cvs-tag-lessp)) + (let* ((first (car tags)) + (prev (if (cvs-tag-p first) + (list (car (cvs-tag->vlist first))) nil))) + (combine-after-change-calls + (cvs-tree-tags-insert tags prev)) + ;;(cvs-refontify pt (point)) + ;;(sit-for 0) + )))))) + +(defun cvs-tree-tags-insert (tags prev) + (when tags + (let* ((tag (car tags)) + (vlist (cvs-tag->vlist tag)) + (nprev ;"next prev" + (let* ((next (cvs-car (cadr tags))) + (nprev (if (and cvs-tree-nomerge next + (equal vlist (cvs-tag->vlist next))) + prev vlist))) + (cvs-map (lambda (v p) v) nprev prev))) + (after (save-excursion + (newline) + (cvs-tree-tags-insert (cdr tags) nprev))) + (pe t) ;"prev equal" + (nas nil)) ;"next afters" to be returned + (insert " ") + (do* ((vs vlist (cdr vs)) + (ps prev (cdr ps)) + (as after (cdr as))) + ((and (null as) (null vs) (null ps)) + (let ((revname (cvs-status-vl-to-str vlist))) + (if (cvs-every 'identity (cvs-map 'equal prev vlist)) + (insert (make-string (+ 4 (length revname)) ? ) + (or (cvs-tag->name tag) "")) + (insert " " revname ": " (or (cvs-tag->name tag) ""))))) + (let* ((eq (and pe (equal (car ps) (car vs)))) + (next-eq (equal (cadr ps) (cadr vs)))) + (let* ((na+char + (if (car as) + (if eq + (if next-eq (cons t cvs-tree-char-vbar) + (cons t cvs-tree-char-branch)) + (cons nil cvs-tree-char-bob)) + (if eq + (if next-eq (cons nil cvs-tree-char-space) + (cons t cvs-tree-char-eob)) + (cons nil (if (and (eq (cvs-tag->type tag) 'branch) + (cvs-every 'null as)) + cvs-tree-char-space + cvs-tree-char-hbar)))))) + (insert (cdr na+char)) + (push (car na+char) nas)) + (setq pe eq))) + (nreverse nas)))) + +;;;; +;;;; Merged trees from different files +;;;; + +(defun cvs-tree-fuzzy-merge-1 (trees tree prev) + ) + +(defun cvs-tree-fuzzy-merge (trees tree) + "Do the impossible: merge TREE into TREES." + ()) + +(defun cvs-tree () + "Get tags from the status output and merge tham all into a big tree." + (save-excursion + (goto-char (point-min)) + (let ((inhibit-read-only t) + (trees (make-vector 31 0)) tree) + (while (listp (setq tree (cvs-tags->tree (cvs-status-get-tags)))) + (cvs-tree-fuzzy-merge trees tree)) + (erase-buffer) + (let ((cvs-tag-print-rev nil)) + (cvs-tree-print tree 'cvs-tag->string 3))))) + + +(provide 'cvs-status) + +;; arch-tag: db8b5094-d02a-473e-a476-544e89ff5ad0 +;;; cvs-status.el ends here diff --cc lisp/vc/diff-mode.el index c16c2460e75,00000000000..e8c79aead64 mode 100644,000000..100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@@ -1,1942 -1,0 +1,1942 @@@ +;;; diff-mode.el --- a mode for viewing/editing context diffs + +;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,2005, 2006, - ;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ++;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. + +;; Author: Stefan Monnier +;; Keywords: convenience patch diff vc + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Provides support for font-lock, outline, navigation +;; commands, editing and various conversions as well as jumping +;; to the corresponding source file. + +;; Inspired by Pavel Machek's patch-mode.el () +;; Some efforts were spent to have it somewhat compatible with XEmacs' +;; diff-mode as well as with compilation-minor-mode + +;; Bugs: + +;; - Reverse doesn't work with normal diffs. + +;; Todo: + +;; - Improve `diff-add-change-log-entries-other-window', +;; it is very simplistic now. +;; +;; - Add a `delete-after-apply' so C-c C-a automatically deletes hunks. +;; Also allow C-c C-a to delete already-applied hunks. +;; +;; - Try `diff ' to try and fuzzily discover the source location +;; of a hunk. Show then the changes between and and make it +;; possible to apply them to , , or . +;; Or maybe just make it into a ".rej to diff3-markers converter". +;; Maybe just use `wiggle' (by Neil Brown) to do it for us. +;; +;; - in diff-apply-hunk, strip context in replace-match to better +;; preserve markers and spacing. +;; - Handle `diff -b' output in context->unified. + +;;; Code: +(eval-when-compile (require 'cl)) + +(defvar add-log-buffer-file-name-function) + + +(defgroup diff-mode () + "Major mode for viewing/editing diffs." + :version "21.1" + :group 'tools + :group 'diff) + +(defcustom diff-default-read-only nil + "If non-nil, `diff-mode' buffers default to being read-only." + :type 'boolean + :group 'diff-mode) + +(defcustom diff-jump-to-old-file nil + "Non-nil means `diff-goto-source' jumps to the old file. +Else, it jumps to the new file." + :type 'boolean + :group 'diff-mode) + +(defcustom diff-update-on-the-fly t + "Non-nil means hunk headers are kept up-to-date on-the-fly. +When editing a diff file, the line numbers in the hunk headers +need to be kept consistent with the actual diff. This can +either be done on the fly (but this sometimes interacts poorly with the +undo mechanism) or whenever the file is written (can be slow +when editing big diffs)." + :type 'boolean + :group 'diff-mode) + +(defcustom diff-advance-after-apply-hunk t + "Non-nil means `diff-apply-hunk' will move to the next hunk after applying." + :type 'boolean + :group 'diff-mode) + +(defcustom diff-mode-hook nil + "Run after setting up the `diff-mode' major mode." + :type 'hook + :options '(diff-delete-empty-files diff-make-unified) + :group 'diff-mode) + +(defvar diff-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]") + "^[ <>!+-]")))) + (save-excursion + (while (re-search-backward re start t) + (replace-match "" t t))))))) + +(defconst diff-hunk-header-re-unified + "^@@ -\\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)? \\+\\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)? @@") +(defconst diff-context-mid-hunk-header-re + "--- \\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)? ----$") + +(defvar diff-font-lock-keywords + `((,(concat "\\(" diff-hunk-header-re-unified "\\)\\(.*\\)$") + (1 diff-hunk-header-face) (6 diff-function-face)) + ("^\\(\\*\\{15\\}\\)\\(.*\\)$" ;context + (1 diff-hunk-header-face) (2 diff-function-face)) + ("^\\*\\*\\* .+ \\*\\*\\*\\*". diff-hunk-header-face) ;context + (,diff-context-mid-hunk-header-re . diff-hunk-header-face) ;context + ("^[0-9,]+[acd][0-9,]+$" . diff-hunk-header-face) ;normal + ("^---$" . diff-hunk-header-face) ;normal + ;; For file headers, accept files with spaces, but be careful to rule + ;; out false-positives when matching hunk headers. + ("^\\(---\\|\\+\\+\\+\\|\\*\\*\\*\\) \\([^\t\n]+?\\)\\(?:\t.*\\| \\(\\*\\*\\*\\*\\|----\\)\\)?\n" + (0 diff-header-face) + (2 (if (not (match-end 3)) diff-file-header-face) prepend)) + ("^\\([-<]\\)\\(.*\n\\)" + (1 diff-indicator-removed-face) (2 diff-removed-face)) + ("^\\([+>]\\)\\(.*\n\\)" + (1 diff-indicator-added-face) (2 diff-added-face)) + ("^\\(!\\)\\(.*\n\\)" + (1 diff-indicator-changed-face) (2 diff-changed-face)) + ("^Index: \\(.+\\).*\n" + (0 diff-header-face) (1 diff-index-face prepend)) + ("^Only in .*\n" . diff-nonexistent-face) + ("^\\(#\\)\\(.*\\)" + (1 font-lock-comment-delimiter-face) + (2 font-lock-comment-face)) + ("^[^-=+*!<>#].*\n" (0 diff-context-face)))) + +(defconst diff-font-lock-defaults + '(diff-font-lock-keywords t nil nil nil (font-lock-multiline . nil))) + +(defvar diff-imenu-generic-expression + ;; Prefer second name as first is most likely to be a backup or + ;; version-control name. The [\t\n] at the end of the unidiff pattern + ;; catches Debian source diff files (which lack the trailing date). + '((nil "\\+\\+\\+\\ \\([^\t\n]+\\)[\t\n]" 1) ; unidiffs + (nil "^--- \\([^\t\n]+\\)\t.*\n\\*" 1))) ; context diffs + +;;;; +;;;; Movement +;;;; + +(defvar diff-valid-unified-empty-line t + "If non-nil, empty lines are valid in unified diffs. +Some versions of diff replace all-blank context lines in unified format with +empty lines. This makes the format less robust, but is tolerated. +See http://lists.gnu.org/archive/html/emacs-devel/2007-11/msg01990.html") + +(defconst diff-hunk-header-re + (concat "^\\(?:" diff-hunk-header-re-unified ".*\\|\\*\\{15\\}.*\n\\*\\*\\* .+ \\*\\*\\*\\*\\|[0-9]+\\(,[0-9]+\\)?[acd][0-9]+\\(,[0-9]+\\)?\\)$")) +(defconst diff-file-header-re (concat "^\\(--- .+\n\\+\\+\\+ \\|\\*\\*\\* .+\n--- \\|[^-+!<>0-9@* \n]\\).+\n" (substring diff-hunk-header-re 1))) +(defvar diff-narrowed-to nil) + +(defun diff-hunk-style (&optional style) + (when (looking-at diff-hunk-header-re) + (setq style (cdr (assq (char-after) '((?@ . unified) (?* . context))))) + (goto-char (match-end 0))) + style) + +(defun diff-end-of-hunk (&optional style donttrustheader) + (let (end) + (when (looking-at diff-hunk-header-re) + ;; Especially important for unified (because headers are ambiguous). + (setq style (diff-hunk-style style)) + (goto-char (match-end 0)) + (when (and (not donttrustheader) (match-end 2)) + (let* ((nold (string-to-number (or (match-string 2) "1"))) + (nnew (string-to-number (or (match-string 4) "1"))) + (endold + (save-excursion + (re-search-forward (if diff-valid-unified-empty-line + "^[- \n]" "^[- ]") + nil t nold) + (line-beginning-position 2))) + (endnew + ;; The hunk may end with a bunch of "+" lines, so the `end' is + ;; then further than computed above. + (save-excursion + (re-search-forward (if diff-valid-unified-empty-line + "^[+ \n]" "^[+ ]") + nil t nnew) + (line-beginning-position 2)))) + (setq end (max endold endnew))))) + ;; We may have a first evaluation of `end' thanks to the hunk header. + (unless end + (setq end (and (re-search-forward + (case style + (unified (concat (if diff-valid-unified-empty-line + "^[^-+# \\\n]\\|" "^[^-+# \\]\\|") + ;; A `unified' header is ambiguous. + diff-file-header-re)) + (context "^[^-+#! \\]") + (normal "^[^<>#\\]") + (t "^[^-+#!<> \\]")) + nil t) + (match-beginning 0))) + (when diff-valid-unified-empty-line + ;; While empty lines may be valid inside hunks, they are also likely + ;; to be unrelated to the hunk. + (goto-char (or end (point-max))) + (while (eq ?\n (char-before (1- (point)))) + (forward-char -1) + (setq end (point))))) + ;; The return value is used by easy-mmode-define-navigation. + (goto-char (or end (point-max))))) + +(defun diff-beginning-of-hunk (&optional try-harder) + "Move back to beginning of hunk. +If TRY-HARDER is non-nil, try to cater to the case where we're not in a hunk +but in the file header instead, in which case move forward to the first hunk." + (beginning-of-line) + (unless (looking-at diff-hunk-header-re) + (forward-line 1) + (condition-case () + (re-search-backward diff-hunk-header-re) + (error + (if (not try-harder) + (error "Can't find the beginning of the hunk") + (diff-beginning-of-file-and-junk) + (diff-hunk-next)))))) + +(defun diff-unified-hunk-p () + (save-excursion + (ignore-errors + (diff-beginning-of-hunk) + (looking-at "^@@")))) + +(defun diff-beginning-of-file () + (beginning-of-line) + (unless (looking-at diff-file-header-re) + (let ((start (point)) + res) + ;; diff-file-header-re may need to match up to 4 lines, so in case + ;; we're inside the header, we need to move up to 3 lines forward. + (forward-line 3) + (if (and (setq res (re-search-backward diff-file-header-re nil t)) + ;; Maybe the 3 lines forward were too much and we matched + ;; a file header after our starting point :-( + (or (<= (point) start) + (setq res (re-search-backward diff-file-header-re nil t)))) + res + (goto-char start) + (error "Can't find the beginning of the file"))))) + + +(defun diff-end-of-file () + (re-search-forward "^[-+#!<>0-9@* \\]" nil t) + (re-search-forward (concat "^[^-+#!<>0-9@* \\]\\|" diff-file-header-re) + nil 'move) + (if (match-beginning 1) + (goto-char (match-beginning 1)) + (beginning-of-line))) + +;; Define diff-{hunk,file}-{prev,next} +(easy-mmode-define-navigation + diff-hunk diff-hunk-header-re "hunk" diff-end-of-hunk diff-restrict-view + (if diff-auto-refine-mode + (condition-case-no-debug nil (diff-refine-hunk) (error nil)))) + +(easy-mmode-define-navigation + diff-file diff-file-header-re "file" diff-end-of-hunk) + +(defun diff-restrict-view (&optional arg) + "Restrict the view to the current hunk. +If the prefix ARG is given, restrict the view to the current file instead." + (interactive "P") + (save-excursion + (if arg (diff-beginning-of-file) (diff-beginning-of-hunk 'try-harder)) + (narrow-to-region (point) + (progn (if arg (diff-end-of-file) (diff-end-of-hunk)) + (point))) + (set (make-local-variable 'diff-narrowed-to) (if arg 'file 'hunk)))) + + +(defun diff-hunk-kill () + "Kill current hunk." + (interactive) + (diff-beginning-of-hunk) + (let* ((start (point)) + ;; Search the second match, since we're looking at the first. + (nexthunk (when (re-search-forward diff-hunk-header-re nil t 2) + (match-beginning 0))) + (firsthunk (ignore-errors + (goto-char start) + (diff-beginning-of-file) (diff-hunk-next) (point))) + (nextfile (ignore-errors (diff-file-next) (point))) + (inhibit-read-only t)) + (goto-char start) + (if (and firsthunk (= firsthunk start) + (or (null nexthunk) + (and nextfile (> nexthunk nextfile)))) + ;; It's the only hunk for this file, so kill the file. + (diff-file-kill) + (diff-end-of-hunk) + (kill-region start (point))))) + +;; "index ", "old mode", "new mode", "new file mode" and +;; "deleted file mode" are output by git-diff. +(defconst diff-file-junk-re + "diff \\|index \\|\\(?:deleted file\\|new\\(?: file\\)?\\|old\\) mode") + +(defun diff-beginning-of-file-and-junk () + "Go to the beginning of file-related diff-info. +This is like `diff-beginning-of-file' except it tries to skip back over leading +data such as \"Index: ...\" and such." + (let* ((orig (point)) + ;; Skip forward over what might be "leading junk" so as to get + ;; closer to the actual diff. + (_ (progn (beginning-of-line) + (while (looking-at diff-file-junk-re) + (forward-line 1)))) + (start (point)) + (prevfile (condition-case err + (save-excursion (diff-beginning-of-file) (point)) + (error err))) + (err (if (consp prevfile) prevfile)) + (nextfile (ignore-errors + (save-excursion + (goto-char start) (diff-file-next) (point)))) + ;; prevhunk is one of the limits. + (prevhunk (save-excursion + (ignore-errors + (if (numberp prevfile) (goto-char prevfile)) + (diff-hunk-prev) (point)))) + (previndex (save-excursion + (forward-line 1) ;In case we're looking at "Index:". + (re-search-backward "^Index: " prevhunk t)))) + ;; If we're in the junk, we should use nextfile instead of prevfile. + (if (and (numberp nextfile) + (or (not (numberp prevfile)) + (and previndex (> previndex prevfile)))) + (setq prevfile nextfile)) + (if (and previndex (numberp prevfile) (< previndex prevfile)) + (setq prevfile previndex)) + (if (and (numberp prevfile) (<= prevfile start)) + (progn + (goto-char prevfile) + ;; Now skip backward over the leading junk we may have before the + ;; diff itself. + (while (save-excursion + (and (zerop (forward-line -1)) + (looking-at diff-file-junk-re))) + (forward-line -1))) + ;; File starts *after* the starting point: we really weren't in + ;; a file diff but elsewhere. + (goto-char orig) + (signal (car err) (cdr err))))) + +(defun diff-file-kill () + "Kill current file's hunks." + (interactive) + (let ((orig (point)) + (start (progn (diff-beginning-of-file-and-junk) (point))) + (inhibit-read-only t)) + (diff-end-of-file) + (if (looking-at "^\n") (forward-char 1)) ;`tla' generates such diffs. + (if (> orig (point)) (error "Not inside a file diff")) + (kill-region start (point)))) + +(defun diff-kill-junk () + "Kill spurious empty diffs." + (interactive) + (save-excursion + (let ((inhibit-read-only t)) + (goto-char (point-min)) + (while (re-search-forward (concat "^\\(Index: .*\n\\)" + "\\([^-+!* <>].*\n\\)*?" + "\\(\\(Index:\\) \\|" + diff-file-header-re "\\)") + nil t) + (delete-region (if (match-end 4) (match-beginning 0) (match-end 1)) + (match-beginning 3)) + (beginning-of-line))))) + +(defun diff-count-matches (re start end) + (save-excursion + (let ((n 0)) + (goto-char start) + (while (re-search-forward re end t) (incf n)) + n))) + +(defun diff-splittable-p () + (save-excursion + (beginning-of-line) + (and (looking-at "^[-+ ]") + (progn (forward-line -1) (looking-at "^[-+ ]")) + (diff-unified-hunk-p)))) + +(defun diff-split-hunk () + "Split the current (unified diff) hunk at point into two hunks." + (interactive) + (beginning-of-line) + (let ((pos (point)) + (start (progn (diff-beginning-of-hunk) (point)))) + (unless (looking-at diff-hunk-header-re-unified) + (error "diff-split-hunk only works on unified context diffs")) + (forward-line 1) + (let* ((start1 (string-to-number (match-string 1))) + (start2 (string-to-number (match-string 3))) + (newstart1 (+ start1 (diff-count-matches "^[- \t]" (point) pos))) + (newstart2 (+ start2 (diff-count-matches "^[+ \t]" (point) pos))) + (inhibit-read-only t)) + (goto-char pos) + ;; Hopefully the after-change-function will not screw us over. + (insert "@@ -" (number-to-string newstart1) ",1 +" + (number-to-string newstart2) ",1 @@\n") + ;; Fix the original hunk-header. + (diff-fixup-modifs start pos)))) + + +;;;; +;;;; jump to other buffers +;;;; + +(defvar diff-remembered-files-alist nil) +(defvar diff-remembered-defdir nil) + +(defun diff-filename-drop-dir (file) + (when (string-match "/" file) (substring file (match-end 0)))) + +(defun diff-merge-strings (ancestor from to) + "Merge the diff between ANCESTOR and FROM into TO. +Returns the merged string if successful or nil otherwise. +The strings are assumed not to contain any \"\\n\" (i.e. end of line). +If ANCESTOR = FROM, returns TO. +If ANCESTOR = TO, returns FROM. +The heuristic is simplistic and only really works for cases +like \(diff-merge-strings \"b/foo\" \"b/bar\" \"/a/c/foo\")." + ;; Ideally, we want: + ;; AMB ANB CMD -> CND + ;; but that's ambiguous if `foo' or `bar' is empty: + ;; a/foo a/foo1 b/foo.c -> b/foo1.c but not 1b/foo.c or b/foo.c1 + (let ((str (concat ancestor "\n" from "\n" to))) + (when (and (string-match (concat + "\\`\\(.*?\\)\\(.*\\)\\(.*\\)\n" + "\\1\\(.*\\)\\3\n" + "\\(.*\\(\\2\\).*\\)\\'") str) + (equal to (match-string 5 str))) + (concat (substring str (match-beginning 5) (match-beginning 6)) + (match-string 4 str) + (substring str (match-end 6) (match-end 5)))))) + +(defun diff-tell-file-name (old name) + "Tell Emacs where the find the source file of the current hunk. +If the OLD prefix arg is passed, tell the file NAME of the old file." + (interactive + (let* ((old current-prefix-arg) + (fs (diff-hunk-file-names current-prefix-arg))) + (unless fs (error "No file name to look for")) + (list old (read-file-name (format "File for %s: " (car fs)) + nil (diff-find-file-name old 'noprompt) t)))) + (let ((fs (diff-hunk-file-names old))) + (unless fs (error "No file name to look for")) + (push (cons fs name) diff-remembered-files-alist))) + +(defun diff-hunk-file-names (&optional old) + "Give the list of file names textually mentioned for the current hunk." + (save-excursion + (unless (looking-at diff-file-header-re) + (or (ignore-errors (diff-beginning-of-file)) + (re-search-forward diff-file-header-re nil t))) + (let ((limit (save-excursion + (condition-case () + (progn (diff-hunk-prev) (point)) + (error (point-min))))) + (header-files + (if (looking-at "[-*][-*][-*] \\(\\S-+\\)\\(\\s-.*\\)?\n[-+][-+][-+] \\(\\S-+\\)") + (list (if old (match-string 1) (match-string 3)) + (if old (match-string 3) (match-string 1))) + (forward-line 1) nil))) + (delq nil + (append + (when (and (not old) + (save-excursion + (re-search-backward "^Index: \\(.+\\)" limit t))) + (list (match-string 1))) + header-files + (when (re-search-backward + "^diff \\(-\\S-+ +\\)*\\(\\S-+\\)\\( +\\(\\S-+\\)\\)?" + nil t) + (list (if old (match-string 2) (match-string 4)) + (if old (match-string 4) (match-string 2))))))))) + +(defun diff-find-file-name (&optional old noprompt prefix) + "Return the file corresponding to the current patch. +Non-nil OLD means that we want the old file. +Non-nil NOPROMPT means to prefer returning nil than to prompt the user. +PREFIX is only used internally: don't use it." + (unless (equal diff-remembered-defdir default-directory) + ;; Flush diff-remembered-files-alist if the default-directory is changed. + (set (make-local-variable 'diff-remembered-defdir) default-directory) + (set (make-local-variable 'diff-remembered-files-alist) nil)) + (save-excursion + (unless (looking-at diff-file-header-re) + (or (ignore-errors (diff-beginning-of-file)) + (re-search-forward diff-file-header-re nil t))) + (let ((fs (diff-hunk-file-names old))) + (if prefix (setq fs (mapcar (lambda (f) (concat prefix f)) fs))) + (or + ;; use any previously used preference + (cdr (assoc fs diff-remembered-files-alist)) + ;; try to be clever and use previous choices as an inspiration + (dolist (rf diff-remembered-files-alist) + (let ((newfile (diff-merge-strings (caar rf) (car fs) (cdr rf)))) + (if (and newfile (file-exists-p newfile)) (return newfile)))) + ;; look for each file in turn. If none found, try again but + ;; ignoring the first level of directory, ... + (do* ((files fs (delq nil (mapcar 'diff-filename-drop-dir files))) + (file nil nil)) + ((or (null files) + (setq file (do* ((files files (cdr files)) + (file (car files) (car files))) + ;; Use file-regular-p to avoid + ;; /dev/null, directories, etc. + ((or (null file) (file-regular-p file)) + file)))) + file)) + ;; .rej patches implicitly apply to + (and (string-match "\\.rej\\'" (or buffer-file-name "")) + (let ((file (substring buffer-file-name 0 (match-beginning 0)))) + (when (file-exists-p file) file))) + ;; If we haven't found the file, maybe it's because we haven't paid + ;; attention to the PCL-CVS hint. + (and (not prefix) + (boundp 'cvs-pcl-cvs-dirchange-re) + (save-excursion + (re-search-backward cvs-pcl-cvs-dirchange-re nil t)) + (diff-find-file-name old noprompt (match-string 1))) + ;; if all else fails, ask the user + (unless noprompt + (let ((file (read-file-name (format "Use file %s: " + (or (first fs) "")) + nil (first fs) t (first fs)))) + (set (make-local-variable 'diff-remembered-files-alist) + (cons (cons fs file) diff-remembered-files-alist)) + file)))))) + + +(defun diff-ediff-patch () + "Call `ediff-patch-file' on the current buffer." + (interactive) + (condition-case err + (ediff-patch-file nil (current-buffer)) + (wrong-number-of-arguments (ediff-patch-file)))) + +;;;; +;;;; Conversion functions +;;;; + +;;(defvar diff-inhibit-after-change nil +;; "Non-nil means inhibit `diff-mode's after-change functions.") + +(defun diff-unified->context (start end) + "Convert unified diffs to context diffs. +START and END are either taken from the region (if a prefix arg is given) or +else cover the whole buffer." + (interactive (if (or current-prefix-arg (and transient-mark-mode mark-active)) + (list (region-beginning) (region-end)) + (list (point-min) (point-max)))) + (unless (markerp end) (setq end (copy-marker end t))) + (let (;;(diff-inhibit-after-change t) + (inhibit-read-only t)) + (save-excursion + (goto-char start) + (while (and (re-search-forward + (concat "^\\(\\(---\\) .+\n\\(\\+\\+\\+\\) .+\\|" + diff-hunk-header-re-unified ".*\\)$") + nil t) + (< (point) end)) + (combine-after-change-calls + (if (match-beginning 2) + ;; we matched a file header + (progn + ;; use reverse order to make sure the indices are kept valid + (replace-match "---" t t nil 3) + (replace-match "***" t t nil 2)) + ;; we matched a hunk header + (let ((line1 (match-string 4)) + (lines1 (or (match-string 5) "1")) + (line2 (match-string 6)) + (lines2 (or (match-string 7) "1")) + ;; Variables to use the special undo function. + (old-undo buffer-undo-list) + (old-end (marker-position end)) + (start (match-beginning 0)) + (reversible t)) + (replace-match + (concat "***************\n*** " line1 "," + (number-to-string (+ (string-to-number line1) + (string-to-number lines1) + -1)) + " ****")) + (save-restriction + (narrow-to-region (line-beginning-position 2) + ;; Call diff-end-of-hunk from just before + ;; the hunk header so it can use the hunk + ;; header info. + (progn (diff-end-of-hunk 'unified) (point))) + (let ((hunk (buffer-string))) + (goto-char (point-min)) + (if (not (save-excursion (re-search-forward "^-" nil t))) + (delete-region (point) (point-max)) + (goto-char (point-max)) + (let ((modif nil) last-pt) + (while (progn (setq last-pt (point)) + (= (forward-line -1) 0)) + (case (char-after) + (?\s (insert " ") (setq modif nil) (backward-char 1)) + (?+ (delete-region (point) last-pt) (setq modif t)) + (?- (if (not modif) + (progn (forward-char 1) + (insert " ")) + (delete-char 1) + (insert "! ")) + (backward-char 2)) + (?\\ (when (save-excursion (forward-line -1) + (= (char-after) ?+)) + (delete-region (point) last-pt) (setq modif t))) + ;; diff-valid-unified-empty-line. + (?\n (insert " ") (setq modif nil) (backward-char 2)) + (t (setq modif nil)))))) + (goto-char (point-max)) + (save-excursion + (insert "--- " line2 "," + (number-to-string (+ (string-to-number line2) + (string-to-number lines2) + -1)) + " ----\n" hunk)) + ;;(goto-char (point-min)) + (forward-line 1) + (if (not (save-excursion (re-search-forward "^+" nil t))) + (delete-region (point) (point-max)) + (let ((modif nil) (delete nil)) + (if (save-excursion (re-search-forward "^\\+.*\n-" nil t)) + ;; Normally, lines in a substitution come with + ;; first the removals and then the additions, and + ;; the context->unified function follows this + ;; convention, of course. Yet, other alternatives + ;; are valid as well, but they preclude the use of + ;; context->unified as an undo command. + (setq reversible nil)) + (while (not (eobp)) + (case (char-after) + (?\s (insert " ") (setq modif nil) (backward-char 1)) + (?- (setq delete t) (setq modif t)) + (?+ (if (not modif) + (progn (forward-char 1) + (insert " ")) + (delete-char 1) + (insert "! ")) + (backward-char 2)) + (?\\ (when (save-excursion (forward-line 1) + (not (eobp))) + (setq delete t) (setq modif t))) + ;; diff-valid-unified-empty-line. + (?\n (insert " ") (setq modif nil) (backward-char 2) + (setq reversible nil)) + (t (setq modif nil))) + (let ((last-pt (point))) + (forward-line 1) + (when delete + (delete-region last-pt (point)) + (setq delete nil))))))) + (unless (or (not reversible) (eq buffer-undo-list t)) + ;; Drop the many undo entries and replace them with + ;; a single entry that uses diff-context->unified to do + ;; the work. + (setq buffer-undo-list + (cons (list 'apply (- old-end end) start (point-max) + 'diff-context->unified start (point-max)) + old-undo))))))))))) + +(defun diff-context->unified (start end &optional to-context) + "Convert context diffs to unified diffs. +START and END are either taken from the region +\(when it is highlighted) or else cover the whole buffer. +With a prefix argument, convert unified format to context format." + (interactive (if (and transient-mark-mode mark-active) + (list (region-beginning) (region-end) current-prefix-arg) + (list (point-min) (point-max) current-prefix-arg))) + (if to-context + (diff-unified->context start end) + (unless (markerp end) (setq end (copy-marker end t))) + (let ( ;;(diff-inhibit-after-change t) + (inhibit-read-only t)) + (save-excursion + (goto-char start) + (while (and (re-search-forward "^\\(\\(\\*\\*\\*\\) .+\n\\(---\\) .+\\|\\*\\{15\\}.*\n\\*\\*\\* \\([0-9]+\\),\\(-?[0-9]+\\) \\*\\*\\*\\*\\)$" nil t) + (< (point) end)) + (combine-after-change-calls + (if (match-beginning 2) + ;; we matched a file header + (progn + ;; use reverse order to make sure the indices are kept valid + (replace-match "+++" t t nil 3) + (replace-match "---" t t nil 2)) + ;; we matched a hunk header + (let ((line1s (match-string 4)) + (line1e (match-string 5)) + (pt1 (match-beginning 0)) + ;; Variables to use the special undo function. + (old-undo buffer-undo-list) + (old-end (marker-position end)) + (reversible t)) + (replace-match "") + (unless (re-search-forward + diff-context-mid-hunk-header-re nil t) + (error "Can't find matching `--- n1,n2 ----' line")) + (let ((line2s (match-string 1)) + (line2e (match-string 2)) + (pt2 (progn + (delete-region (progn (beginning-of-line) (point)) + (progn (forward-line 1) (point))) + (point-marker)))) + (goto-char pt1) + (forward-line 1) + (while (< (point) pt2) + (case (char-after) + (?! (delete-char 2) (insert "-") (forward-line 1)) + (?- (forward-char 1) (delete-char 1) (forward-line 1)) + (?\s ;merge with the other half of the chunk + (let* ((endline2 + (save-excursion + (goto-char pt2) (forward-line 1) (point)))) + (case (char-after pt2) + ((?! ?+) + (insert "+" + (prog1 (buffer-substring (+ pt2 2) endline2) + (delete-region pt2 endline2)))) + (?\s + (unless (= (- endline2 pt2) + (- (line-beginning-position 2) (point))) + ;; If the two lines we're merging don't have the + ;; same length (can happen with "diff -b"), then + ;; diff-unified->context will not properly undo + ;; this operation. + (setq reversible nil)) + (delete-region pt2 endline2) + (delete-char 1) + (forward-line 1)) + (?\\ (forward-line 1)) + (t (setq reversible nil) + (delete-char 1) (forward-line 1))))) + (t (setq reversible nil) (forward-line 1)))) + (while (looking-at "[+! ] ") + (if (/= (char-after) ?!) (forward-char 1) + (delete-char 1) (insert "+")) + (delete-char 1) (forward-line 1)) + (save-excursion + (goto-char pt1) + (insert "@@ -" line1s "," + (number-to-string (- (string-to-number line1e) + (string-to-number line1s) + -1)) + " +" line2s "," + (number-to-string (- (string-to-number line2e) + (string-to-number line2s) + -1)) " @@")) + (set-marker pt2 nil) + ;; The whole procedure succeeded, let's replace the myriad + ;; of undo elements with just a single special one. + (unless (or (not reversible) (eq buffer-undo-list t)) + (setq buffer-undo-list + (cons (list 'apply (- old-end end) pt1 (point) + 'diff-unified->context pt1 (point)) + old-undo))) + ))))))))) + +(defun diff-reverse-direction (start end) + "Reverse the direction of the diffs. +START and END are either taken from the region (if a prefix arg is given) or +else cover the whole buffer." + (interactive (if (or current-prefix-arg (and transient-mark-mode mark-active)) + (list (region-beginning) (region-end)) + (list (point-min) (point-max)))) + (unless (markerp end) (setq end (copy-marker end t))) + (let (;;(diff-inhibit-after-change t) + (inhibit-read-only t)) + (save-excursion + (goto-char start) + (while (and (re-search-forward "^\\(\\([-*][-*][-*] \\)\\(.+\\)\n\\([-+][-+][-+] \\)\\(.+\\)\\|\\*\\{15\\}.*\n\\*\\*\\* \\(.+\\) \\*\\*\\*\\*\\|@@ -\\([0-9,]+\\) \\+\\([0-9,]+\\) @@.*\\)$" nil t) + (< (point) end)) + (combine-after-change-calls + (cond + ;; a file header + ((match-beginning 2) (replace-match "\\2\\5\n\\4\\3" nil)) + ;; a context-diff hunk header + ((match-beginning 6) + (let ((pt-lines1 (match-beginning 6)) + (lines1 (match-string 6))) + (replace-match "" nil nil nil 6) + (forward-line 1) + (let ((half1s (point))) + (while (looking-at "[-! \\][ \t]\\|#") + (when (= (char-after) ?-) (delete-char 1) (insert "+")) + (forward-line 1)) + (let ((half1 (delete-and-extract-region half1s (point)))) + (unless (looking-at diff-context-mid-hunk-header-re) + (insert half1) + (error "Can't find matching `--- n1,n2 ----' line")) + (let* ((str1end (or (match-end 2) (match-end 1))) + (str1 (buffer-substring (match-beginning 1) str1end))) + (goto-char str1end) + (insert lines1) + (delete-region (match-beginning 1) str1end) + (forward-line 1) + (let ((half2s (point))) + (while (looking-at "[!+ \\][ \t]\\|#") + (when (= (char-after) ?+) (delete-char 1) (insert "-")) + (forward-line 1)) + (let ((half2 (delete-and-extract-region half2s (point)))) + (insert (or half1 "")) + (goto-char half1s) + (insert (or half2 "")))) + (goto-char pt-lines1) + (insert str1)))))) + ;; a unified-diff hunk header + ((match-beginning 7) + (replace-match "@@ -\\8 +\\7 @@" nil) + (forward-line 1) + (let ((c (char-after)) first last) + (while (case (setq c (char-after)) + (?- (setq first (or first (point))) + (delete-char 1) (insert "+") t) + (?+ (setq last (or last (point))) + (delete-char 1) (insert "-") t) + ((?\\ ?#) t) + (t (when (and first last (< first last)) + (insert (delete-and-extract-region first last))) + (setq first nil last nil) + (memq c (if diff-valid-unified-empty-line + '(?\s ?\n) '(?\s))))) + (forward-line 1)))))))))) + +(defun diff-fixup-modifs (start end) + "Fixup the hunk headers (in case the buffer was modified). +START and END are either taken from the region (if a prefix arg is given) or +else cover the whole buffer." + (interactive (if (or current-prefix-arg (and transient-mark-mode mark-active)) + (list (region-beginning) (region-end)) + (list (point-min) (point-max)))) + (let ((inhibit-read-only t)) + (save-excursion + (goto-char end) (diff-end-of-hunk nil 'donttrustheader) + (let ((plus 0) (minus 0) (space 0) (bang 0)) + (while (and (= (forward-line -1) 0) (<= start (point))) + (if (not (looking-at + (concat diff-hunk-header-re-unified + "\\|[-*][-*][-*] [0-9,]+ [-*][-*][-*][-*]$" + "\\|--- .+\n\\+\\+\\+ "))) + (case (char-after) + (?\s (incf space)) + (?+ (incf plus)) + (?- (incf minus)) + (?! (incf bang)) + ((?\\ ?#) nil) + (t (setq space 0 plus 0 minus 0 bang 0))) + (cond + ((looking-at diff-hunk-header-re-unified) + (let* ((old1 (match-string 2)) + (old2 (match-string 4)) + (new1 (number-to-string (+ space minus))) + (new2 (number-to-string (+ space plus)))) + (if old2 + (unless (string= new2 old2) (replace-match new2 t t nil 4)) + (goto-char (match-end 4)) (insert "," new2)) + (if old1 + (unless (string= new1 old1) (replace-match new1 t t nil 2)) + (goto-char (match-end 2)) (insert "," new1)))) + ((looking-at diff-context-mid-hunk-header-re) + (when (> (+ space bang plus) 0) + (let* ((old1 (match-string 1)) + (old2 (match-string 2)) + (new (number-to-string + (+ space bang plus -1 (string-to-number old1))))) + (unless (string= new old2) (replace-match new t t nil 2))))) + ((looking-at "\\*\\*\\* \\([0-9]+\\),\\(-?[0-9]*\\) \\*\\*\\*\\*$") + (when (> (+ space bang minus) 0) + (let* ((old (match-string 1)) + (new (format + (concat "%0" (number-to-string (length old)) "d") + (+ space bang minus -1 (string-to-number old))))) + (unless (string= new old) (replace-match new t t nil 2)))))) + (setq space 0 plus 0 minus 0 bang 0))))))) + +;;;; +;;;; Hooks +;;;; + +(defun diff-write-contents-hooks () + "Fixup hunk headers if necessary." + (if (buffer-modified-p) (diff-fixup-modifs (point-min) (point-max))) + nil) + +;; It turns out that making changes in the buffer from within an +;; *-change-function is asking for trouble, whereas making them +;; from a post-command-hook doesn't pose much problems +(defvar diff-unhandled-changes nil) +(defun diff-after-change-function (beg end len) + "Remember to fixup the hunk header. +See `after-change-functions' for the meaning of BEG, END and LEN." + ;; Ignoring changes when inhibit-read-only is set is strictly speaking + ;; incorrect, but it turns out that inhibit-read-only is normally not set + ;; inside editing commands, while it tends to be set when the buffer gets + ;; updated by an async process or by a conversion function, both of which + ;; would rather not be uselessly slowed down by this hook. + (when (and (not undo-in-progress) (not inhibit-read-only)) + (if diff-unhandled-changes + (setq diff-unhandled-changes + (cons (min beg (car diff-unhandled-changes)) + (max end (cdr diff-unhandled-changes)))) + (setq diff-unhandled-changes (cons beg end))))) + +(defun diff-post-command-hook () + "Fixup hunk headers if necessary." + (when (consp diff-unhandled-changes) + (ignore-errors + (save-excursion + (goto-char (car diff-unhandled-changes)) + ;; Maybe we've cut the end of the hunk before point. + (if (and (bolp) (not (bobp))) (backward-char 1)) + ;; We used to fixup modifs on all the changes, but it turns out that + ;; it's safer not to do it on big changes, e.g. when yanking a big + ;; diff, or when the user edits the header, since we might then + ;; screw up perfectly correct values. --Stef + (diff-beginning-of-hunk) + (let* ((style (if (looking-at "\\*\\*\\*") 'context)) + (start (line-beginning-position (if (eq style 'context) 3 2))) + (mid (if (eq style 'context) + (save-excursion + (re-search-forward diff-context-mid-hunk-header-re + nil t))))) + (when (and ;; Don't try to fixup changes in the hunk header. + (> (car diff-unhandled-changes) start) + ;; Don't try to fixup changes in the mid-hunk header either. + (or (not mid) + (< (cdr diff-unhandled-changes) (match-beginning 0)) + (> (car diff-unhandled-changes) (match-end 0))) + (save-excursion + (diff-end-of-hunk nil 'donttrustheader) + ;; Don't try to fixup changes past the end of the hunk. + (>= (point) (cdr diff-unhandled-changes)))) + (diff-fixup-modifs (point) (cdr diff-unhandled-changes))))) + (setq diff-unhandled-changes nil)))) + +(defun diff-next-error (arg reset) + ;; Select a window that displays the current buffer so that point + ;; movements are reflected in that window. Otherwise, the user might + ;; never see the hunk corresponding to the source she's jumping to. + (pop-to-buffer (current-buffer)) + (if reset (goto-char (point-min))) + (diff-hunk-next arg) + (diff-goto-source)) + +(defvar whitespace-style) +(defvar whitespace-trailing-regexp) + +;;;###autoload +(define-derived-mode diff-mode fundamental-mode "Diff" + "Major mode for viewing/editing context diffs. +Supports unified and context diffs as well as (to a lesser extent) +normal diffs. + +When the buffer is read-only, the ESC prefix is not necessary. +If you edit the buffer manually, diff-mode will try to update the hunk +headers for you on-the-fly. + +You can also switch between context diff and unified diff with \\[diff-context->unified], +or vice versa with \\[diff-unified->context] and you can also reverse the direction of +a diff with \\[diff-reverse-direction]. + + \\{diff-mode-map}" + + (set (make-local-variable 'font-lock-defaults) diff-font-lock-defaults) + (set (make-local-variable 'outline-regexp) diff-outline-regexp) + (set (make-local-variable 'imenu-generic-expression) + diff-imenu-generic-expression) + ;; These are not perfect. They would be better done separately for + ;; context diffs and unidiffs. + ;; (set (make-local-variable 'paragraph-start) + ;; (concat "@@ " ; unidiff hunk + ;; "\\|\\*\\*\\* " ; context diff hunk or file start + ;; "\\|--- [^\t]+\t")) ; context or unidiff file + ;; ; start (first or second line) + ;; (set (make-local-variable 'paragraph-separate) paragraph-start) + ;; (set (make-local-variable 'page-delimiter) "--- [^\t]+\t") + ;; compile support + (set (make-local-variable 'next-error-function) 'diff-next-error) + + (set (make-local-variable 'beginning-of-defun-function) + 'diff-beginning-of-file-and-junk) + (set (make-local-variable 'end-of-defun-function) + 'diff-end-of-file) + + ;; Set up `whitespace-mode' so that turning it on will show trailing + ;; whitespace problems on the modified lines of the diff. + (set (make-local-variable 'whitespace-style) '(trailing)) + (set (make-local-variable 'whitespace-trailing-regexp) + "^[-\+!<>].*?\\([\t ]+\\)$") + + (setq buffer-read-only diff-default-read-only) + ;; setup change hooks + (if (not diff-update-on-the-fly) + (add-hook 'write-contents-functions 'diff-write-contents-hooks nil t) + (make-local-variable 'diff-unhandled-changes) + (add-hook 'after-change-functions 'diff-after-change-function nil t) + (add-hook 'post-command-hook 'diff-post-command-hook nil t)) + ;; Neat trick from Dave Love to add more bindings in read-only mode: + (lexical-let ((ro-bind (cons 'buffer-read-only diff-mode-shared-map))) + (add-to-list 'minor-mode-overriding-map-alist ro-bind) + ;; Turn off this little trick in case the buffer is put in view-mode. + (add-hook 'view-mode-hook + (lambda () + (setq minor-mode-overriding-map-alist + (delq ro-bind minor-mode-overriding-map-alist))) + nil t)) + ;; add-log support + (set (make-local-variable 'add-log-current-defun-function) + 'diff-current-defun) + (set (make-local-variable 'add-log-buffer-file-name-function) + (lambda () (diff-find-file-name nil 'noprompt))) + (unless (buffer-file-name) + (hack-dir-local-variables-non-file-buffer))) + +;;;###autoload +(define-minor-mode diff-minor-mode + "Minor mode for viewing/editing context diffs. +\\{diff-minor-mode-map}" + :group 'diff-mode :lighter " Diff" + ;; FIXME: setup font-lock + ;; setup change hooks + (if (not diff-update-on-the-fly) + (add-hook 'write-contents-functions 'diff-write-contents-hooks nil t) + (make-local-variable 'diff-unhandled-changes) + (add-hook 'after-change-functions 'diff-after-change-function nil t) + (add-hook 'post-command-hook 'diff-post-command-hook nil t))) + +;;; Handy hook functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun diff-delete-if-empty () + ;; An empty diff file means there's no more diffs to integrate, so we + ;; can just remove the file altogether. Very handy for .rej files if we + ;; remove hunks as we apply them. + (when (and buffer-file-name + (eq 0 (nth 7 (file-attributes buffer-file-name)))) + (delete-file buffer-file-name))) + +(defun diff-delete-empty-files () + "Arrange for empty diff files to be removed." + (add-hook 'after-save-hook 'diff-delete-if-empty nil t)) + +(defun diff-make-unified () + "Turn context diffs into unified diffs if applicable." + (if (save-excursion + (goto-char (point-min)) + (and (looking-at diff-hunk-header-re) (eq (char-after) ?*))) + (let ((mod (buffer-modified-p))) + (unwind-protect + (diff-context->unified (point-min) (point-max)) + (restore-buffer-modified-p mod))))) + +;;; +;;; Misc operations that have proved useful at some point. +;;; + +(defun diff-next-complex-hunk () + "Jump to the next \"complex\" hunk. +\"Complex\" is approximated by \"the hunk changes the number of lines\". +Only works for unified diffs." + (interactive) + (while + (and (re-search-forward diff-hunk-header-re-unified nil t) + (equal (match-string 2) (match-string 4))))) + +(defun diff-sanity-check-context-hunk-half (lines) + (let ((count lines)) + (while + (cond + ((and (memq (char-after) '(?\s ?! ?+ ?-)) + (memq (char-after (1+ (point))) '(?\s ?\t))) + (decf count) t) + ((or (zerop count) (= count lines)) nil) + ((memq (char-after) '(?! ?+ ?-)) + (if (not (and (eq (char-after (1+ (point))) ?\n) + (y-or-n-p "Try to auto-fix whitespace loss damage? "))) + (error "End of hunk ambiguously marked") + (forward-char 1) (insert " ") (forward-line -1) t)) + ((< lines 0) + (error "End of hunk ambiguously marked")) + ((not (y-or-n-p "Try to auto-fix whitespace loss and word-wrap damage? ")) + (error "Abort!")) + ((eolp) (insert " ") (forward-line -1) t) + (t (insert " ") (delete-region (- (point) 2) (- (point) 1)) t)) + (forward-line)))) + +(defun diff-sanity-check-hunk () + (let (;; Every modification is protected by a y-or-n-p, so it's probably + ;; OK to override a read-only setting. + (inhibit-read-only t)) + (save-excursion + (cond + ((not (looking-at diff-hunk-header-re)) + (error "Not recognizable hunk header")) + + ;; A context diff. + ((eq (char-after) ?*) + (if (not (looking-at "\\*\\{15\\}\\(?: .*\\)?\n\\*\\*\\* \\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)? \\*\\*\\*\\*")) + (error "Unrecognized context diff first hunk header format") + (forward-line 2) + (diff-sanity-check-context-hunk-half + (if (match-end 2) + (1+ (- (string-to-number (match-string 2)) + (string-to-number (match-string 1)))) + 1)) + (if (not (looking-at diff-context-mid-hunk-header-re)) + (error "Unrecognized context diff second hunk header format") + (forward-line) + (diff-sanity-check-context-hunk-half + (if (match-end 2) + (1+ (- (string-to-number (match-string 2)) + (string-to-number (match-string 1)))) + 1))))) + + ;; A unified diff. + ((eq (char-after) ?@) + (if (not (looking-at diff-hunk-header-re-unified)) + (error "Unrecognized unified diff hunk header format") + (let ((before (string-to-number (or (match-string 2) "1"))) + (after (string-to-number (or (match-string 4) "1")))) + (forward-line) + (while + (case (char-after) + (?\s (decf before) (decf after) t) + (?- + (if (and (looking-at diff-file-header-re) + (zerop before) (zerop after)) + ;; No need to query: this is a case where two patches + ;; are concatenated and only counting the lines will + ;; give the right result. Let's just add an empty + ;; line so that our code which doesn't count lines + ;; will not get confused. + (progn (save-excursion (insert "\n")) nil) + (decf before) t)) + (?+ (decf after) t) + (t + (cond + ((and diff-valid-unified-empty-line + ;; Not just (eolp) so we don't infloop at eob. + (eq (char-after) ?\n) + (> before 0) (> after 0)) + (decf before) (decf after) t) + ((and (zerop before) (zerop after)) nil) + ((or (< before 0) (< after 0)) + (error (if (or (zerop before) (zerop after)) + "End of hunk ambiguously marked" + "Hunk seriously messed up"))) + ((not (y-or-n-p (concat "Try to auto-fix " (if (eolp) "whitespace loss" "word-wrap damage") "? "))) + (error "Abort!")) + ((eolp) (insert " ") (forward-line -1) t) + (t (insert " ") + (delete-region (- (point) 2) (- (point) 1)) t)))) + (forward-line))))) + + ;; A plain diff. + (t + ;; TODO. + ))))) + +(defun diff-hunk-text (hunk destp char-offset) + "Return the literal source text from HUNK as (TEXT . OFFSET). +If DESTP is nil, TEXT is the source, otherwise the destination text. +CHAR-OFFSET is a char-offset in HUNK, and OFFSET is the corresponding +char-offset in TEXT." + (with-temp-buffer + (insert hunk) + (goto-char (point-min)) + (let ((src-pos nil) + (dst-pos nil) + (divider-pos nil) + (num-pfx-chars 2)) + ;; Set the following variables: + ;; SRC-POS buffer pos of the source part of the hunk or nil if none + ;; DST-POS buffer pos of the destination part of the hunk or nil + ;; DIVIDER-POS buffer pos of any divider line separating the src & dst + ;; NUM-PFX-CHARS number of line-prefix characters used by this format" + (cond ((looking-at "^@@") + ;; unified diff + (setq num-pfx-chars 1) + (forward-line 1) + (setq src-pos (point) dst-pos (point))) + ((looking-at "^\\*\\*") + ;; context diff + (forward-line 2) + (setq src-pos (point)) + (re-search-forward diff-context-mid-hunk-header-re nil t) + (forward-line 0) + (setq divider-pos (point)) + (forward-line 1) + (setq dst-pos (point))) + ((looking-at "^[0-9]+a[0-9,]+$") + ;; normal diff, insert + (forward-line 1) + (setq dst-pos (point))) + ((looking-at "^[0-9,]+d[0-9]+$") + ;; normal diff, delete + (forward-line 1) + (setq src-pos (point))) + ((looking-at "^[0-9,]+c[0-9,]+$") + ;; normal diff, change + (forward-line 1) + (setq src-pos (point)) + (re-search-forward "^---$" nil t) + (forward-line 0) + (setq divider-pos (point)) + (forward-line 1) + (setq dst-pos (point))) + (t + (error "Unknown diff hunk type"))) + + (if (if destp (null dst-pos) (null src-pos)) + ;; Implied empty text + (if char-offset '("" . 0) "") + + ;; For context diffs, either side can be empty, (if there's only + ;; added or only removed text). We should then use the other side. + (cond ((equal src-pos divider-pos) (setq src-pos dst-pos)) + ((equal dst-pos (point-max)) (setq dst-pos src-pos))) + + (when char-offset (goto-char (+ (point-min) char-offset))) + + ;; Get rid of anything except the desired text. + (save-excursion + ;; Delete unused text region + (let ((keep (if destp dst-pos src-pos))) + (when (and divider-pos (> divider-pos keep)) + (delete-region divider-pos (point-max))) + (delete-region (point-min) keep)) + ;; Remove line-prefix characters, and unneeded lines (unified diffs). + (let ((kill-char (if destp ?- ?+))) + (goto-char (point-min)) + (while (not (eobp)) + (if (eq (char-after) kill-char) + (delete-region (point) (progn (forward-line 1) (point))) + (delete-char num-pfx-chars) + (forward-line 1))))) + + (let ((text (buffer-substring-no-properties (point-min) (point-max)))) + (if char-offset (cons text (- (point) (point-min))) text)))))) + + +(defun diff-find-text (text) + "Return the buffer position (BEG . END) of the nearest occurrence of TEXT. +If TEXT isn't found, nil is returned." + (let* ((orig (point)) + (forw (and (search-forward text nil t) + (cons (match-beginning 0) (match-end 0)))) + (back (and (goto-char (+ orig (length text))) + (search-backward text nil t) + (cons (match-beginning 0) (match-end 0))))) + ;; Choose the closest match. + (if (and forw back) + (if (> (- (car forw) orig) (- orig (car back))) back forw) + (or back forw)))) + +(defun diff-find-approx-text (text) + "Return the buffer position (BEG . END) of the nearest occurrence of TEXT. +Whitespace differences are ignored." + (let* ((orig (point)) + (re (concat "^[ \t\n ]*" + (mapconcat 'regexp-quote (split-string text) "[ \t\n ]+") + "[ \t\n ]*\n")) + (forw (and (re-search-forward re nil t) + (cons (match-beginning 0) (match-end 0)))) + (back (and (goto-char (+ orig (length text))) + (re-search-backward re nil t) + (cons (match-beginning 0) (match-end 0))))) + ;; Choose the closest match. + (if (and forw back) + (if (> (- (car forw) orig) (- orig (car back))) back forw) + (or back forw)))) + +(defsubst diff-xor (a b) (if a (if (not b) a) b)) + +(defun diff-find-source-location (&optional other-file reverse noprompt) + "Find out (BUF LINE-OFFSET POS SRC DST SWITCHED). +BUF is the buffer corresponding to the source file. +LINE-OFFSET is the offset between the expected and actual positions + of the text of the hunk or nil if the text was not found. +POS is a pair (BEG . END) indicating the position of the text in the buffer. +SRC and DST are the two variants of text as returned by `diff-hunk-text'. + SRC is the variant that was found in the buffer. +SWITCHED is non-nil if the patch is already applied. +NOPROMPT, if non-nil, means not to prompt the user." + (save-excursion + (let* ((other (diff-xor other-file diff-jump-to-old-file)) + (char-offset (- (point) (progn (diff-beginning-of-hunk 'try-harder) + (point)))) + ;; Check that the hunk is well-formed. Otherwise diff-mode and + ;; the user may disagree on what constitutes the hunk + ;; (e.g. because an empty line truncates the hunk mid-course), + ;; leading to potentially nasty surprises for the user. + ;; + ;; Suppress check when NOPROMPT is non-nil (Bug#3033). + (_ (unless noprompt (diff-sanity-check-hunk))) + (hunk (buffer-substring + (point) (save-excursion (diff-end-of-hunk) (point)))) + (old (diff-hunk-text hunk reverse char-offset)) + (new (diff-hunk-text hunk (not reverse) char-offset)) + ;; Find the location specification. + (line (if (not (looking-at "\\(?:\\*\\{15\\}.*\n\\)?[-@* ]*\\([0-9,]+\\)\\([ acd+]+\\([0-9,]+\\)\\)?")) + (error "Can't find the hunk header") + (if other (match-string 1) + (if (match-end 3) (match-string 3) + (unless (re-search-forward + diff-context-mid-hunk-header-re nil t) + (error "Can't find the hunk separator")) + (match-string 1))))) + (file (or (diff-find-file-name other noprompt) + (error "Can't find the file"))) + (buf (find-file-noselect file))) + ;; Update the user preference if he so wished. + (when (> (prefix-numeric-value other-file) 8) + (setq diff-jump-to-old-file other)) + (with-current-buffer buf + (goto-char (point-min)) (forward-line (1- (string-to-number line))) + (let* ((orig-pos (point)) + (switched nil) + ;; FIXME: Check for case where both OLD and NEW are found. + (pos (or (diff-find-text (car old)) + (progn (setq switched t) (diff-find-text (car new))) + (progn (setq switched nil) + (condition-case nil + (diff-find-approx-text (car old)) + (invalid-regexp nil))) ;Regex too big. + (progn (setq switched t) + (condition-case nil + (diff-find-approx-text (car new)) + (invalid-regexp nil))) ;Regex too big. + (progn (setq switched nil) nil)))) + (nconc + (list buf) + (if pos + (list (count-lines orig-pos (car pos)) pos) + (list nil (cons orig-pos (+ orig-pos (length (car old)))))) + (if switched (list new old t) (list old new)))))))) + + +(defun diff-hunk-status-msg (line-offset reversed dry-run) + (let ((msg (if dry-run + (if reversed "already applied" "not yet applied") + (if reversed "undone" "applied")))) + (message (cond ((null line-offset) "Hunk text not found") + ((= line-offset 0) "Hunk %s") + ((= line-offset 1) "Hunk %s at offset %d line") + (t "Hunk %s at offset %d lines")) + msg line-offset))) + +(defvar diff-apply-hunk-to-backup-file nil) + +(defun diff-apply-hunk (&optional reverse) + "Apply the current hunk to the source file and go to the next. +By default, the new source file is patched, but if the variable +`diff-jump-to-old-file' is non-nil, then the old source file is +patched instead (some commands, such as `diff-goto-source' can change +the value of this variable when given an appropriate prefix argument). + +With a prefix argument, REVERSE the hunk." + (interactive "P") + (destructuring-bind (buf line-offset pos old new &optional switched) + ;; Sometimes we'd like to have the following behavior: if REVERSE go + ;; to the new file, otherwise go to the old. But that means that by + ;; default we use the old file, which is the opposite of the default + ;; for diff-goto-source, and is thus confusing. Also when you don't + ;; know about it it's pretty surprising. + ;; TODO: make it possible to ask explicitly for this behavior. + ;; + ;; This is duplicated in diff-test-hunk. + (diff-find-source-location nil reverse) + (cond + ((null line-offset) + (error "Can't find the text to patch")) + ((with-current-buffer buf + (and buffer-file-name + (backup-file-name-p buffer-file-name) + (not diff-apply-hunk-to-backup-file) + (not (set (make-local-variable 'diff-apply-hunk-to-backup-file) + (yes-or-no-p (format "Really apply this hunk to %s? " + (file-name-nondirectory + buffer-file-name))))))) + (error "%s" + (substitute-command-keys + (format "Use %s\\[diff-apply-hunk] to apply it to the other file" + (if (not reverse) "\\[universal-argument] "))))) + ((and switched + ;; A reversed patch was detected, perhaps apply it in reverse. + (not (save-window-excursion + (pop-to-buffer buf) + (goto-char (+ (car pos) (cdr old))) + (y-or-n-p + (if reverse + "Hunk hasn't been applied yet; apply it now? " + "Hunk has already been applied; undo it? "))))) + (message "(Nothing done)")) + (t + ;; Apply the hunk + (with-current-buffer buf + (goto-char (car pos)) + (delete-region (car pos) (cdr pos)) + (insert (car new))) + ;; Display BUF in a window + (set-window-point (display-buffer buf) (+ (car pos) (cdr new))) + (diff-hunk-status-msg line-offset (diff-xor switched reverse) nil) + (when diff-advance-after-apply-hunk + (diff-hunk-next)))))) + + +(defun diff-test-hunk (&optional reverse) + "See whether it's possible to apply the current hunk. +With a prefix argument, try to REVERSE the hunk." + (interactive "P") + (destructuring-bind (buf line-offset pos src dst &optional switched) + (diff-find-source-location nil reverse) + (set-window-point (display-buffer buf) (+ (car pos) (cdr src))) + (diff-hunk-status-msg line-offset (diff-xor reverse switched) t))) + + +(defalias 'diff-mouse-goto-source 'diff-goto-source) + +(defun diff-goto-source (&optional other-file event) + "Jump to the corresponding source line. +`diff-jump-to-old-file' (or its opposite if the OTHER-FILE prefix arg +is given) determines whether to jump to the old or the new file. +If the prefix arg is bigger than 8 (for example with \\[universal-argument] \\[universal-argument]) +then `diff-jump-to-old-file' is also set, for the next invocations." + (interactive (list current-prefix-arg last-input-event)) + ;; When pointing at a removal line, we probably want to jump to + ;; the old location, and else to the new (i.e. as if reverting). + ;; This is a convenient detail when using smerge-diff. + (if event (posn-set-point (event-end event))) + (let ((rev (not (save-excursion (beginning-of-line) (looking-at "[-<]"))))) + (destructuring-bind (buf line-offset pos src dst &optional switched) + (diff-find-source-location other-file rev) + (pop-to-buffer buf) + (goto-char (+ (car pos) (cdr src))) + (diff-hunk-status-msg line-offset (diff-xor rev switched) t)))) + + +(defun diff-current-defun () + "Find the name of function at point. +For use in `add-log-current-defun-function'." + ;; Kill change-log-default-name so it gets recomputed each time, since + ;; each hunk may belong to another file which may belong to another + ;; directory and hence have a different ChangeLog file. + (kill-local-variable 'change-log-default-name) + (save-excursion + (when (looking-at diff-hunk-header-re) + (forward-line 1) + (re-search-forward "^[^ ]" nil t)) + (destructuring-bind (&optional buf line-offset pos src dst switched) + ;; Use `noprompt' since this is used in which-func-mode and such. + (ignore-errors ;Signals errors in place of prompting. + (diff-find-source-location nil nil 'noprompt)) + (when buf + (beginning-of-line) + (or (when (memq (char-after) '(?< ?-)) + ;; Cursor is pointing at removed text. This could be a removed + ;; function, in which case, going to the source buffer will + ;; not help since the function is now removed. Instead, + ;; try to figure out the function name just from the + ;; code-fragment. + (let ((old (if switched dst src))) + (with-temp-buffer + (insert (car old)) + (funcall (buffer-local-value 'major-mode buf)) + (goto-char (+ (point-min) (cdr old))) + (add-log-current-defun)))) + (with-current-buffer buf + (goto-char (+ (car pos) (cdr src))) + (add-log-current-defun))))))) + +(defun diff-ignore-whitespace-hunk () + "Re-diff the current hunk, ignoring whitespace differences." + (interactive) + (let* ((char-offset (- (point) (progn (diff-beginning-of-hunk 'try-harder) + (point)))) + (opts (case (char-after) (?@ "-bu") (?* "-bc") (t "-b"))) + (line-nb (and (or (looking-at "[^0-9]+\\([0-9]+\\)") + (error "Can't find line number")) + (string-to-number (match-string 1)))) + (inhibit-read-only t) + (hunk (delete-and-extract-region + (point) (save-excursion (diff-end-of-hunk) (point)))) + (lead (make-string (1- line-nb) ?\n)) ;Line nums start at 1. + (file1 (make-temp-file "diff1")) + (file2 (make-temp-file "diff2")) + (coding-system-for-read buffer-file-coding-system) + old new) + (unwind-protect + (save-excursion + (setq old (diff-hunk-text hunk nil char-offset)) + (setq new (diff-hunk-text hunk t char-offset)) + (write-region (concat lead (car old)) nil file1 nil 'nomessage) + (write-region (concat lead (car new)) nil file2 nil 'nomessage) + (with-temp-buffer + (let ((status + (call-process diff-command nil t nil + opts file1 file2))) + (case status + (0 nil) ;Nothing to reformat. + (1 (goto-char (point-min)) + ;; Remove the file-header. + (when (re-search-forward diff-hunk-header-re nil t) + (delete-region (point-min) (match-beginning 0)))) + (t (goto-char (point-max)) + (unless (bolp) (insert "\n")) + (insert hunk))) + (setq hunk (buffer-string)) + (unless (memq status '(0 1)) + (error "Diff returned: %s" status))))) + ;; Whatever happens, put back some equivalent text: either the new + ;; one or the original one in case some error happened. + (insert hunk) + (delete-file file1) + (delete-file file2)))) + +;;; Fine change highlighting. + +(defface diff-refine-change + '((((class color) (min-colors 88) (background light)) + :background "grey85") + (((class color) (min-colors 88) (background dark)) + :background "grey60") + (((class color) (background light)) + :background "yellow") + (((class color) (background dark)) + :background "green") + (t :weight bold)) + "Face used for char-based changes shown by `diff-refine-hunk'." + :group 'diff-mode) + +(defun diff-refine-preproc () + (while (re-search-forward "^[+>]" nil t) + ;; Remove spurious changes due to the fact that one side of the hunk is + ;; marked with leading + or > and the other with leading - or <. + ;; We used to replace all the prefix chars with " " but this only worked + ;; when we did char-based refinement (or when using + ;; smerge-refine-weight-hack) since otherwise, the `forward' motion done + ;; in chopup do not necessarily do the same as the ones in highlight + ;; since the "_" is not treated the same as " ". + (replace-match (cdr (assq (char-before) '((?+ . "-") (?> . "<")))))) + ) + +(defun diff-refine-hunk () + "Highlight changes of hunk at point at a finer granularity." + (interactive) + (eval-and-compile (require 'smerge-mode)) + (save-excursion + (diff-beginning-of-hunk 'try-harder) + (let* ((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 diff --cc lisp/vc/diff.el index 1f5f2d764d2,00000000000..0a853c5d902 mode 100644,000000..100644 --- a/lisp/vc/diff.el +++ b/lisp/vc/diff.el @@@ -1,218 -1,0 +1,218 @@@ +;;; diff.el --- run `diff' in compilation-mode + +;; Copyright (C) 1992, 1994, 1996, 2001, 2002, 2003, 2004, 2005, 2006, - ;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ++;; 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 . + +;;; 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 diff --cc lisp/vc/ediff-diff.el index 70352751d8d,00000000000..fbbdc3b7bce mode 100644,000000..100644 --- a/lisp/vc/ediff-diff.el +++ b/lisp/vc/ediff-diff.el @@@ -1,1535 -1,0 +1,1534 @@@ +;;; ediff-diff.el --- diff-related utilities + - ;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, - ;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 - ;; Free Software Foundation, Inc. ++;; 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 +;; 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 . + +;;; 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 diff --cc lisp/vc/ediff-help.el index 06a600f0af4,00000000000..b77f5f2aafa mode 100644,000000..100644 --- a/lisp/vc/ediff-help.el +++ b/lisp/vc/ediff-help.el @@@ -1,322 -1,0 +1,322 @@@ +;;; ediff-help.el --- Code related to the contents of Ediff help buffers + +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, - ;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ++;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. + +;; Author: Michael Kifer +;; 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 . + +;;; Commentary: + +;;; Code: + + +;; Compiler pacifier start +(defvar ediff-multiframe) +;; end pacifier + +(require 'ediff-init) + +;; Help messages + +(defconst ediff-long-help-message-head + " Move around | Toggle features | Manipulate +=====================|===========================|=============================" + "The head of the full help message.") +(defconst ediff-long-help-message-tail + "=====================|===========================|============================= + R -show registry | = -compare regions | M -show session group + D -diff output | E -browse Ediff manual| G -send bug report + i -status info | ? -help off | z/q -suspend/quit +------------------------------------------------------------------------------- +For help on a specific command: Click Button 2 over it; or + Put the cursor over it and type RET." + "The tail of the full-help message.") + +(defconst ediff-long-help-message-compare3 + " +p,DEL -previous diff | | -vert/horiz split | xy -copy buf X's region to Y +n,SPC -next diff | h -hilighting | rx -restore buf X's old diff + j -jump to diff | @ -auto-refinement | * -refine current region + gx -goto X's point| ## -ignore whitespace | ! -update diff regions + C-l -recenter | #c -ignore case | + v/V -scroll up/dn | #f/#h -focus/hide regions | wx -save buf X + -scroll lt/rt | X -read-only in buf X | wd -save diff output + ~ -rotate buffers| m -wide display | +" + "Help message usually used for 3-way comparison. +Normally, not a user option. See `ediff-help-message' for details.") + +(defconst ediff-long-help-message-compare2 + " +p,DEL -previous diff | | -vert/horiz split |a/b -copy A/B's region to B/A +n,SPC -next diff | h -hilighting | rx -restore buf X's old diff + j -jump to diff | @ -auto-refinement | * -refine current region + gx -goto X's point| ## -ignore whitespace | ! -update diff regions + C-l -recenter | #c -ignore case | + v/V -scroll up/dn | #f/#h -focus/hide regions | wx -save buf X + -scroll lt/rt | X -read-only in buf X | wd -save diff output + ~ -swap variants | m -wide display | +" + "Help message usually used for 2-way comparison. +Normally, not a user option. See `ediff-help-message' for details.") + +(defconst ediff-long-help-message-narrow2 + " +p,DEL -previous diff | | -vert/horiz split |a/b -copy A/B's region to B/A +n,SPC -next diff | h -hilighting | rx -restore buf X's old diff + j -jump to diff | @ -auto-refinement | * -refine current region + gx -goto X's point| ## -ignore whitespace | ! -update diff regions + C-l -recenter | #c -ignore case | % -narrow/widen buffs + v/V -scroll up/dn | #f/#h -focus/hide regions | wx -save buf X + -scroll lt/rt | X -read-only in buf X | wd -save diff output + ~ -swap variants | m -wide display | +" + "Help message when comparing windows or regions line-by-line. +Normally, not a user option. See `ediff-help-message' for details.") + +(defconst ediff-long-help-message-word-mode + " +p,DEL -previous diff | | -vert/horiz split | xy -copy buf X's region to Y +n,SPC -next diff | h -hilighting | rx -restore buf X's old diff + j -jump to diff | | + gx -goto X's point| % -narrow/widen buffs | ! -recompute diffs + C-l -recenter | #c -ignore case | + v/V -scroll up/dn | #f/#h -focus/hide regions | wx -save buf X + -scroll lt/rt | X -read-only in buf X | wd -save diff output + ~ -swap variants | m -wide display | +" + "Help message when comparing windows or regions word-by-word. +Normally, not a user option. See `ediff-help-message' for details.") + +(defconst ediff-long-help-message-merge + " +p,DEL -previous diff | | -vert/horiz split | x -copy buf X's region to C +n,SPC -next diff | h -hilighting | r -restore buf C's old diff + j -jump to diff | @ -auto-refinement | * -refine current region + gx -goto X's point| ## -ignore whitespace | ! -update diff regions + C-l -recenter | #f/#h -focus/hide regions | + -combine diff regions + v/V -scroll up/dn | X -read-only in buf X | wx -save buf X + -scroll lt/rt | m -wide display | wd -save diff output + ~ -swap variants | s -shrink window C | / -show ancestor buff + | $$ -show clashes only | & -merge w/new default + | $* -skip changed regions | +" + "Help message for merge sessions. +Normally, not a user option. See `ediff-help-message' for details.") + +;; The actual long help message. +(ediff-defvar-local ediff-long-help-message "" + "Normally, not a user option. See `ediff-help-message' for details.") + +(defconst ediff-brief-message-string + " Type ? for help" + "Contents of the brief help message.") +;; The actual brief help message +(ediff-defvar-local ediff-brief-help-message "" + "Normally, not a user option. See `ediff-help-message' for details.") + +(ediff-defvar-local ediff-brief-help-message-function nil + "The brief help message that the user can customize. +If the user sets this to a parameter-less function, Ediff will use it to +produce the brief help message. This function must return a string.") +(ediff-defvar-local ediff-long-help-message-function nil + "The long help message that the user can customize. +See `ediff-brief-help-message-function' for more.") + +(defcustom ediff-use-long-help-message nil + "If t, Ediff displays a long help message. Short help message otherwise." + :type 'boolean + :group 'ediff-window) + +;; The actual help message. +(ediff-defvar-local ediff-help-message "" + "The actual help message. +Normally, the user shouldn't touch this. However, if you want Ediff to +start up with different help messages for different jobs, you can change +the value of this variable and the variables `ediff-help-message-*' in +`ediff-startup-hook'.") + + +;; the keymap that defines clicks over the quick help regions +(defvar ediff-help-region-map (make-sparse-keymap)) + +(define-key + ediff-help-region-map + (if (featurep 'emacs) [mouse-2] [button2]) + 'ediff-help-for-quick-help) + +;; runs in the control buffer +(defun ediff-set-help-overlays () + (goto-char (point-min)) + (let (overl beg end cmd) + (while (re-search-forward " *\\([^ \t\n|]+\\||\\) +-[^|\n]+" nil 'noerror) + (setq beg (match-beginning 0) + end (match-end 0) + cmd (buffer-substring (match-beginning 1) (match-end 1))) + (setq overl (ediff-make-overlay beg end)) + (if (featurep 'emacs) + (ediff-overlay-put overl 'mouse-face 'highlight) + (ediff-overlay-put overl 'highlight t)) + (ediff-overlay-put overl 'ediff-help-info cmd)))) + + +(defun ediff-help-for-quick-help () + "Explain Ediff commands in more detail." + (interactive) + (ediff-barf-if-not-control-buffer) + (let ((pos (ediff-event-point last-command-event)) + overl cmd) + + (if (featurep 'xemacs) + (setq overl (extent-at pos (current-buffer) 'ediff-help-info) + cmd (ediff-overlay-get overl 'ediff-help-info)) + (setq cmd (car (mapcar (lambda (elt) + (overlay-get elt 'ediff-help-info)) + (overlays-at pos))))) + + (if (not (stringp cmd)) + (error "Hmm... I don't see an Ediff command around here...")) + + (ediff-documentation "Quick Help Commands") + + (let (case-fold-search) + (cond ((string= cmd "?") (re-search-forward "^`\\?'")) + ((string= cmd "G") (re-search-forward "^`G'")) + ((string= cmd "E") (re-search-forward "^`E'")) + ((string= cmd "wd") (re-search-forward "^`wd'")) + ((string= cmd "wx") (re-search-forward "^`wa'")) + ((string= cmd "a/b") (re-search-forward "^`a'")) + ((string= cmd "x") (re-search-forward "^`a'")) + ((string= cmd "xy") (re-search-forward "^`ab'")) + ((string= cmd "p,DEL") (re-search-forward "^`p'")) + ((string= cmd "n,SPC") (re-search-forward "^`n'")) + ((string= cmd "j") (re-search-forward "^`j'")) + ((string= cmd "gx") (re-search-forward "^`ga'")) + ((string= cmd "!") (re-search-forward "^`!'")) + ((string= cmd "*") (re-search-forward "^`\\*'")) + ((string= cmd "m") (re-search-forward "^`m'")) + ((string= cmd "|") (re-search-forward "^`|'")) + ((string= cmd "@") (re-search-forward "^`@'")) + ((string= cmd "h") (re-search-forward "^`h'")) + ((string= cmd "r") (re-search-forward "^`r'")) + ((string= cmd "rx") (re-search-forward "^`ra'")) + ((string= cmd "##") (re-search-forward "^`##'")) + ((string= cmd "#c") (re-search-forward "^`#c'")) + ((string= cmd "#f/#h") (re-search-forward "^`#f'")) + ((string= cmd "X") (re-search-forward "^`A'")) + ((string= cmd "v/V") (re-search-forward "^`v'")) + ((string= cmd "") (re-search-forward "^`<'")) + ((string= cmd "~") (re-search-forward "^`~'")) + ((string= cmd "i") (re-search-forward "^`i'")) + ((string= cmd "D") (re-search-forward "^`D'")) + ((string= cmd "R") (re-search-forward "^`R'")) + ((string= cmd "M") (re-search-forward "^`M'")) + ((string= cmd "z/q") (re-search-forward "^`z'")) + ((string= cmd "%") (re-search-forward "^`%'")) + ((string= cmd "C-l") (re-search-forward "^`C-l'")) + ((string= cmd "$$") (re-search-forward "^`\\$\\$'")) + ((string= cmd "$*") (re-search-forward "^`\\$\\*'")) + ((string= cmd "/") (re-search-forward "^`/'")) + ((string= cmd "&") (re-search-forward "^`&'")) + ((string= cmd "s") (re-search-forward "^`s'")) + ((string= cmd "+") (re-search-forward "^`\\+'")) + ((string= cmd "=") (re-search-forward "^`='")) + (t (error "Undocumented command! Type `G' in Ediff Control Panel to drop a note to the Ediff maintainer"))) + ) ; let case-fold-search + )) + + +;; assuming we are in control window, calculate length of the first line in +;; help message +(defun ediff-help-message-line-length () + (save-excursion + (goto-char (point-min)) + (if ediff-use-long-help-message + (forward-line 1)) + (end-of-line) + (current-column))) + + +(defun ediff-indent-help-message () + (let* ((shift (/ (max 0 (- (window-width (selected-window)) + (ediff-help-message-line-length))) + 2)) + (str (make-string shift ?\ ))) + (save-excursion + (goto-char (point-min)) + (while (< (point) (point-max)) + (insert str) + (beginning-of-line) + (forward-line 1))))) + + +;; compose the help message as a string +(defun ediff-set-help-message () + (setq ediff-long-help-message + (cond ((and ediff-long-help-message-function + (or (symbolp ediff-long-help-message-function) + (consp ediff-long-help-message-function))) + (funcall ediff-long-help-message-function)) + (ediff-word-mode + (concat ediff-long-help-message-head + ediff-long-help-message-word-mode + ediff-long-help-message-tail)) + (ediff-narrow-job + (concat ediff-long-help-message-head + ediff-long-help-message-narrow2 + ediff-long-help-message-tail)) + (ediff-merge-job + (concat ediff-long-help-message-head + ediff-long-help-message-merge + ediff-long-help-message-tail)) + (ediff-diff3-job + (concat ediff-long-help-message-head + ediff-long-help-message-compare3 + ediff-long-help-message-tail)) + (t + (concat ediff-long-help-message-head + ediff-long-help-message-compare2 + ediff-long-help-message-tail)))) + (setq ediff-brief-help-message + (cond ((and ediff-brief-help-message-function + (or (symbolp ediff-brief-help-message-function) + (consp ediff-brief-help-message-function))) + (funcall ediff-brief-help-message-function)) + ((stringp ediff-brief-help-message-function) + ediff-brief-help-message-function) + ((ediff-multiframe-setup-p) ediff-brief-message-string) + (t ; long brief msg, not multiframe --- put in the middle + ediff-brief-message-string) + )) + (setq ediff-help-message (if ediff-use-long-help-message + ediff-long-help-message + ediff-brief-help-message)) + (run-hooks 'ediff-display-help-hook)) + +;;;###autoload +(defun ediff-customize () + (interactive) + (customize-group "ediff")) + + +(provide 'ediff-help) + + +;; arch-tag: 05659813-7fcf-4274-964f-d2f577431a9d +;;; ediff-help.el ends here diff --cc lisp/vc/ediff-hook.el index e917d29a7b4,00000000000..83c807564f9 mode 100644,000000..100644 --- a/lisp/vc/ediff-hook.el +++ b/lisp/vc/ediff-hook.el @@@ -1,264 -1,0 +1,264 @@@ +;;; ediff-hook.el --- setup for Ediff's menus and autoloads + +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, - ;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ++;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. + +;; Author: Michael Kifer +;; 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 . + +;;; Commentary: + +;;; Code: + +;;; These must be placed in menu-bar.el in Emacs +;; +;; (define-key menu-bar-tools-menu [ediff-misc] +;; '("Ediff Miscellanea" . menu-bar-ediff-misc-menu)) +;; (define-key menu-bar-tools-menu [epatch] +;; '("Apply Patch" . menu-bar-epatch-menu)) +;; (define-key menu-bar-tools-menu [ediff-merge] +;; '("Merge" . menu-bar-ediff-merge-menu)) +;; (define-key menu-bar-tools-menu [ediff] +;; '("Compare" . menu-bar-ediff-menu)) + +;; Compiler pacifier +(defvar ediff-menu) +(defvar ediff-merge-menu) +(defvar epatch-menu) +(defvar ediff-misc-menu) +;; end pacifier + +;; allow menus to be set up without ediff-wind.el being loaded +(defvar ediff-window-setup-function) + +;; This autoload is useless in Emacs because ediff-hook.el is dumped with +;; emacs, but it is needed in XEmacs +;;;###autoload +(if (featurep 'xemacs) + (progn + (defun ediff-xemacs-init-menus () + (when (featurep 'menubar) + (add-submenu + '("Tools") ediff-menu "OO-Browser...") + (add-submenu + '("Tools") ediff-merge-menu "OO-Browser...") + (add-submenu + '("Tools") epatch-menu "OO-Browser...") + (add-submenu + '("Tools") ediff-misc-menu "OO-Browser...") + (add-menu-button + '("Tools") "-------" "OO-Browser...") + )) + (defvar ediff-menu + '("Compare" + ["Two Files..." ediff-files t] + ["Two Buffers..." ediff-buffers t] + ["Three Files..." ediff-files3 t] + ["Three Buffers..." ediff-buffers3 t] + "---" + ["Two Directories..." ediff-directories t] + ["Three Directories..." ediff-directories3 t] + "---" + ["File with Revision..." ediff-revision t] + ["Directory Revisions..." ediff-directory-revisions t] + "---" + ["Windows Word-by-word..." ediff-windows-wordwise t] + ["Windows Line-by-line..." ediff-windows-linewise t] + "---" + ["Regions Word-by-word..." ediff-regions-wordwise t] + ["Regions Line-by-line..." ediff-regions-linewise t] + )) + (defvar ediff-merge-menu + '("Merge" + ["Files..." ediff-merge-files t] + ["Files with Ancestor..." ediff-merge-files-with-ancestor t] + ["Buffers..." ediff-merge-buffers t] + ["Buffers with Ancestor..." + ediff-merge-buffers-with-ancestor t] + "---" + ["Directories..." ediff-merge-directories t] + ["Directories with Ancestor..." + ediff-merge-directories-with-ancestor t] + "---" + ["Revisions..." ediff-merge-revisions t] + ["Revisions with Ancestor..." + ediff-merge-revisions-with-ancestor t] + ["Directory Revisions..." ediff-merge-directory-revisions t] + ["Directory Revisions with Ancestor..." + ediff-merge-directory-revisions-with-ancestor t] + )) + (defvar epatch-menu + '("Apply Patch" + ["To a file..." ediff-patch-file t] + ["To a buffer..." ediff-patch-buffer t] + )) + (defvar ediff-misc-menu + '("Ediff Miscellanea" + ["Ediff Manual" ediff-documentation t] + ["Customize Ediff" ediff-customize t] + ["List Ediff Sessions" ediff-show-registry t] + ["Use separate frame for Ediff control buffer" + ediff-toggle-multiframe + :style toggle + :selected (if (and (featurep 'ediff-util) + (boundp 'ediff-window-setup-function)) + (eq ediff-window-setup-function + 'ediff-setup-windows-multiframe))] + ["Use a toolbar with Ediff control buffer" + ediff-toggle-use-toolbar + :style toggle + :selected (if (featurep 'ediff-tbar) + (ediff-use-toolbar-p))])) + + ;; put these menus before Object-Oriented-Browser in Tools menu + (if (and (featurep 'menubar) (not (featurep 'infodock)) + (not (featurep 'ediff-hook))) + (ediff-xemacs-init-menus))) + ;; Emacs + ;; initialize menu bar keymaps + (defvar menu-bar-ediff-misc-menu + (make-sparse-keymap "Ediff Miscellanea")) + (fset 'menu-bar-ediff-misc-menu + (symbol-value 'menu-bar-ediff-misc-menu)) + (defvar menu-bar-epatch-menu (make-sparse-keymap "Apply Patch")) + (fset 'menu-bar-epatch-menu (symbol-value 'menu-bar-epatch-menu)) + (defvar menu-bar-ediff-merge-menu (make-sparse-keymap "Merge")) + (fset 'menu-bar-ediff-merge-menu + (symbol-value 'menu-bar-ediff-merge-menu)) + (defvar menu-bar-ediff-menu (make-sparse-keymap "Compare")) + (fset 'menu-bar-ediff-menu (symbol-value 'menu-bar-ediff-menu)) + + ;; define ediff compare menu + (define-key menu-bar-ediff-menu [ediff-misc] + `(menu-item ,(purecopy "Ediff Miscellanea") menu-bar-ediff-misc-menu)) + (define-key menu-bar-ediff-menu [separator-ediff-misc] menu-bar-separator) + (define-key menu-bar-ediff-menu [window] + `(menu-item ,(purecopy "This Window and Next Window") compare-windows + :help ,(purecopy "Compare the current window and the next window"))) + (define-key menu-bar-ediff-menu [ediff-windows-linewise] + `(menu-item ,(purecopy "Windows Line-by-line...") ediff-windows-linewise + :help ,(purecopy "Compare windows line-wise"))) + (define-key menu-bar-ediff-menu [ediff-windows-wordwise] + `(menu-item ,(purecopy "Windows Word-by-word...") ediff-windows-wordwise + :help ,(purecopy "Compare windows word-wise"))) + (define-key menu-bar-ediff-menu [separator-ediff-windows] menu-bar-separator) + (define-key menu-bar-ediff-menu [ediff-regions-linewise] + `(menu-item ,(purecopy "Regions Line-by-line...") ediff-regions-linewise + :help ,(purecopy "Compare regions line-wise"))) + (define-key menu-bar-ediff-menu [ediff-regions-wordwise] + `(menu-item ,(purecopy "Regions Word-by-word...") ediff-regions-wordwise + :help ,(purecopy "Compare regions word-wise"))) + (define-key menu-bar-ediff-menu [separator-ediff-regions] menu-bar-separator) + (define-key menu-bar-ediff-menu [ediff-dir-revision] + `(menu-item ,(purecopy "Directory Revisions...") ediff-directory-revisions + :help ,(purecopy "Compare directory files with their older versions"))) + (define-key menu-bar-ediff-menu [ediff-revision] + `(menu-item ,(purecopy "File with Revision...") ediff-revision + :help ,(purecopy "Compare file with its older versions"))) + (define-key menu-bar-ediff-menu [separator-ediff-directories] menu-bar-separator) + (define-key menu-bar-ediff-menu [ediff-directories3] + `(menu-item ,(purecopy "Three Directories...") ediff-directories3 + :help ,(purecopy "Compare files common to three directories simultaneously"))) + (define-key menu-bar-ediff-menu [ediff-directories] + `(menu-item ,(purecopy "Two Directories...") ediff-directories + :help ,(purecopy "Compare files common to two directories simultaneously"))) + (define-key menu-bar-ediff-menu [separator-ediff-files] menu-bar-separator) + (define-key menu-bar-ediff-menu [ediff-buffers3] + `(menu-item ,(purecopy "Three Buffers...") ediff-buffers3 + :help ,(purecopy "Compare three buffers simultaneously"))) + (define-key menu-bar-ediff-menu [ediff-files3] + `(menu-item ,(purecopy "Three Files...") ediff-files3 + :help ,(purecopy "Compare three files simultaneously"))) + (define-key menu-bar-ediff-menu [ediff-buffers] + `(menu-item ,(purecopy "Two Buffers...") ediff-buffers + :help ,(purecopy "Compare two buffers simultaneously"))) + (define-key menu-bar-ediff-menu [ediff-files] + `(menu-item ,(purecopy "Two Files...") ediff-files + :help ,(purecopy "Compare two files simultaneously"))) + + ;; define ediff merge menu + (define-key + menu-bar-ediff-merge-menu [ediff-merge-dir-revisions-with-ancestor] + `(menu-item ,(purecopy "Directory Revisions with Ancestor...") + ediff-merge-directory-revisions-with-ancestor + :help ,(purecopy "Merge versions of the files in the same directory by comparing the files with common ancestors"))) + (define-key + menu-bar-ediff-merge-menu [ediff-merge-dir-revisions] + `(menu-item ,(purecopy "Directory Revisions...") ediff-merge-directory-revisions + :help ,(purecopy "Merge versions of the files in the same directory (without using ancestor information)"))) + (define-key + menu-bar-ediff-merge-menu [ediff-merge-revisions-with-ancestor] + `(menu-item ,(purecopy "Revisions with Ancestor...") + ediff-merge-revisions-with-ancestor + :help ,(purecopy "Merge versions of the same file by comparing them with a common ancestor"))) + (define-key menu-bar-ediff-merge-menu [ediff-merge-revisions] + `(menu-item ,(purecopy "Revisions...") ediff-merge-revisions + :help ,(purecopy "Merge versions of the same file (without using ancestor information)"))) + (define-key menu-bar-ediff-merge-menu [separator-ediff-merge] menu-bar-separator) + (define-key + menu-bar-ediff-merge-menu [ediff-merge-directories-with-ancestor] + `(menu-item ,(purecopy "Directories with Ancestor...") + ediff-merge-directories-with-ancestor + :help ,(purecopy "Merge files common to a pair of directories by comparing the files with common ancestors"))) + (define-key menu-bar-ediff-merge-menu [ediff-merge-directories] + `(menu-item ,(purecopy "Directories...") ediff-merge-directories + :help ,(purecopy "Merge files common to a pair of directories"))) + (define-key + menu-bar-ediff-merge-menu [separator-ediff-merge-dirs] menu-bar-separator) + (define-key + menu-bar-ediff-merge-menu [ediff-merge-buffers-with-ancestor] + `(menu-item ,(purecopy "Buffers with Ancestor...") ediff-merge-buffers-with-ancestor + :help ,(purecopy "Merge buffers by comparing their contents with a common ancestor"))) + (define-key menu-bar-ediff-merge-menu [ediff-merge-buffers] + `(menu-item ,(purecopy "Buffers...") ediff-merge-buffers + :help ,(purecopy "Merge buffers (without using ancestor information)"))) + (define-key menu-bar-ediff-merge-menu [ediff-merge-files-with-ancestor] + `(menu-item ,(purecopy "Files with Ancestor...") ediff-merge-files-with-ancestor + :help ,(purecopy "Merge files by comparing them with a common ancestor"))) + (define-key menu-bar-ediff-merge-menu [ediff-merge-files] + `(menu-item ,(purecopy "Files...") ediff-merge-files + :help ,(purecopy "Merge files (without using ancestor information)"))) + + ;; define epatch menu + (define-key menu-bar-epatch-menu [ediff-patch-buffer] + `(menu-item ,(purecopy "To a Buffer...") ediff-patch-buffer + :help ,(purecopy "Apply a patch to the contents of a buffer"))) + (define-key menu-bar-epatch-menu [ediff-patch-file] + `(menu-item ,(purecopy "To a File...") ediff-patch-file + :help ,(purecopy "Apply a patch to a file"))) + + ;; define ediff miscellanea + (define-key menu-bar-ediff-misc-menu [emultiframe] + `(menu-item ,(purecopy "Use separate control buffer frame") + ediff-toggle-multiframe + :help ,(purecopy "Switch between the single-frame presentation mode and the multi-frame mode"))) + (define-key menu-bar-ediff-misc-menu [eregistry] + `(menu-item ,(purecopy "List Ediff Sessions") ediff-show-registry + :help ,(purecopy "List all active Ediff sessions; it is a convenient way to find and resume such a session"))) + (define-key menu-bar-ediff-misc-menu [ediff-cust] + `(menu-item ,(purecopy "Customize Ediff") ediff-customize + :help ,(purecopy "Change some of the parameters that govern the behavior of Ediff"))) + (define-key menu-bar-ediff-misc-menu [ediff-doc] + `(menu-item ,(purecopy "Ediff Manual") ediff-documentation + :help ,(purecopy "Bring up the Ediff manual")))) + +(provide 'ediff-hook) + + +;; arch-tag: 512f8656-8a4b-4789-af5d-5c6144498df3 +;;; ediff-hook.el ends here diff --cc lisp/vc/ediff-init.el index 9665a21cd14,00000000000..56ccc540352 mode 100644,000000..100644 --- a/lisp/vc/ediff-init.el +++ b/lisp/vc/ediff-init.el @@@ -1,1812 -1,0 +1,1812 @@@ +;;; ediff-init.el --- Macros, variables, and defsubsts used by Ediff + +;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, - ;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ++;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. + +;; Author: Michael Kifer +;; 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 . + +;;; 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 diff --cc lisp/vc/ediff-merg.el index 4c6aee15d1d,00000000000..b63bd15f4ea mode 100644,000000..100644 --- a/lisp/vc/ediff-merg.el +++ b/lisp/vc/ediff-merg.el @@@ -1,398 -1,0 +1,398 @@@ +;;; ediff-merg.el --- merging utilities + +;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, - ;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ++;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. + +;; Author: Michael Kifer +;; 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 . + +;;; Commentary: + +;;; Code: + + +;; compiler pacifier +(defvar ediff-window-A) +(defvar ediff-window-B) +(defvar ediff-window-C) +(defvar ediff-merge-window-share) +(defvar ediff-window-config-saved) + +(eval-when-compile + (require 'ediff-util)) +;; end pacifier + +(require 'ediff-init) + +(defcustom ediff-quit-merge-hook 'ediff-maybe-save-and-delete-merge + "Hooks to run before quitting a merge job. +The most common use is to save and delete the merge buffer." + :type 'hook + :group 'ediff-merge) + + +(defcustom ediff-default-variant 'combined + "The variant to be used as a default for buffer C in merging. +Valid values are the symbols `default-A', `default-B', and `combined'." + :type '(radio (const default-A) (const default-B) (const combined)) + :group 'ediff-merge) + +(defcustom ediff-combination-pattern + '("<<<<<<< variant A" A ">>>>>>> variant B" B "####### Ancestor" Ancestor "======= end") + "Pattern to be used for combining difference regions in buffers A and B. +The value must be a list of the form +\(STRING1 bufspec1 STRING2 bufspec2 STRING3 bufspec3 STRING4) +where bufspec is the symbol A, B, or Ancestor. For instance, if the value is +'(STRING1 A STRING2 Ancestor STRING3 B STRING4) then the +combined text will look like this: + +STRING1 +diff region from variant A +STRING2 +diff region from the ancestor +STRING3 +diff region from variant B +STRING4 +" + :type '(choice (list string symbol string symbol string) + (list string symbol string symbol string symbol string)) + :group 'ediff-merge) + +(defcustom ediff-show-clashes-only nil + "If t, show only those diff regions where both buffers disagree with the ancestor. +This means that regions that have status prefer-A or prefer-B will be +skipped over. A value of nil means show all regions." + :type 'boolean + :group 'ediff-merge + ) +(make-variable-buffer-local 'ediff-show-clashes-only) + +(defcustom ediff-skip-merge-regions-that-differ-from-default nil + "If t, show only the regions that have not been changed by the user. +A region is considered to have been changed if it is different from the current +default (`default-A', `default-B', `combined') and it hasn't been marked as +`prefer-A' or `prefer-B'. +A region is considered to have been changed also when it is marked as +as `prefer-A', but is different from the corresponding difference region in +Buffer A or if it is marked as `prefer-B' and is different from the region in +Buffer B." + :type 'boolean + :group 'ediff-merge + ) +(make-variable-buffer-local 'ediff-skip-merge-regions-that-differ-from-default) + +;; check if there is no clash between the ancestor and one of the variants. +;; if it is not a merge job then return true +(defun ediff-merge-region-is-non-clash (n) + (if (ediff-merge-job) + (string-match "prefer" (or (ediff-get-state-of-merge n) "")) + t)) + +;; If ediff-show-clashes-only, check if there is no clash between the ancestor +;; and one of the variants. +(defun ediff-merge-region-is-non-clash-to-skip (n) + (and (ediff-merge-job) + ediff-show-clashes-only + (ediff-merge-region-is-non-clash n))) + +;; If ediff-skip-changed-regions, check if the merge region differs from +;; the current default. If a region is different from the default, it means +;; that the user has made determination as to how to merge for this particular +;; region. +(defun ediff-skip-merge-region-if-changed-from-default-p (n) + (and (ediff-merge-job) + ediff-skip-merge-regions-that-differ-from-default + (ediff-merge-changed-from-default-p n 'prefers-too))) + + +(defun ediff-get-combined-region (n) + (let ((pattern-list ediff-combination-pattern) + (combo-region "") + (err-msg + "ediff-combination-pattern: Invalid format. Please consult the documentation") + region-delim region-spec) + + (if (< (length pattern-list) 5) + (error err-msg)) + + (while (> (length pattern-list) 2) + (setq region-delim (nth 0 pattern-list) + region-spec (nth 1 pattern-list)) + (or (and (stringp region-delim) (memq region-spec '(A B Ancestor))) + (error err-msg)) + + (condition-case nil + (setq combo-region + (concat combo-region + region-delim "\n" + (ediff-get-region-contents + n region-spec ediff-control-buffer))) + (error "")) + (setq pattern-list (cdr (cdr pattern-list))) + ) + + (setq region-delim (nth 0 pattern-list)) + (or (stringp region-delim) + (error err-msg)) + (setq combo-region (concat combo-region region-delim "\n")) + )) + +;;(defsubst ediff-make-combined-diff (regA regB) +;; (concat (nth 0 ediff-combination-pattern) "\n" +;; regA +;; (nth 1 ediff-combination-pattern) "\n" +;; regB +;; (nth 2 ediff-combination-pattern) "\n")) + +(defsubst ediff-set-state-of-all-diffs-in-all-buffers (ctl-buf) + (let ((n 0)) + (while (< n ediff-number-of-differences) + (ediff-set-state-of-diff-in-all-buffers n ctl-buf) + (setq n (1+ n))))) + +(defun ediff-set-state-of-diff-in-all-buffers (n ctl-buf) + (let ((regA (ediff-get-region-contents n 'A ctl-buf)) + (regB (ediff-get-region-contents n 'B ctl-buf)) + (regC (ediff-get-region-contents n 'C ctl-buf))) + (cond ((and (string= regA regB) (string= regA regC)) + (ediff-set-state-of-diff n 'A "=diff(B)") + (ediff-set-state-of-diff n 'B "=diff(C)") + (ediff-set-state-of-diff n 'C "=diff(A)")) + ((string= regA regB) + (ediff-set-state-of-diff n 'A "=diff(B)") + (ediff-set-state-of-diff n 'B "=diff(A)") + (ediff-set-state-of-diff n 'C nil)) + ((string= regA regC) + (ediff-set-state-of-diff n 'A "=diff(C)") + (ediff-set-state-of-diff n 'C "=diff(A)") + (ediff-set-state-of-diff n 'B nil)) + ((string= regB regC) + (ediff-set-state-of-diff n 'C "=diff(B)") + (ediff-set-state-of-diff n 'B "=diff(C)") + (ediff-set-state-of-diff n 'A nil)) + ((string= regC (ediff-get-combined-region n)) + (ediff-set-state-of-diff n 'A nil) + (ediff-set-state-of-diff n 'B nil) + (ediff-set-state-of-diff n 'C "=diff(A+B)")) + (t (ediff-set-state-of-diff n 'A nil) + (ediff-set-state-of-diff n 'B nil) + (ediff-set-state-of-diff n 'C nil))) + )) + +(defun ediff-set-merge-mode () + (normal-mode t) + (remove-hook 'local-write-file-hooks 'ediff-set-merge-mode)) + + +;; Go over all diffs starting with DIFF-NUM and copy regions into buffer C +;; according to the state of the difference. +;; Since ediff-copy-diff refuses to copy identical diff regions, there is +;; no need to optimize ediff-do-merge any further. +;; +;; If re-merging, change state of merge in all diffs starting with +;; DIFF-NUM, except those where the state is prefer-* or where it is +;; `default-*' or `combined' but the buf C region appears to be modified +;; since last set by default. +(defun ediff-do-merge (diff-num &optional remerging) + (if (< diff-num 0) (setq diff-num 0)) + (let ((n diff-num) + ;;(default-state-of-merge (format "%S" ediff-default-variant)) + do-not-copy state-of-merge) + (while (< n ediff-number-of-differences) + (setq do-not-copy nil) ; reset after each cycle + (if (= (mod n 10) 0) + (message "%s buffers A & B into C ... region %d of %d" + (if remerging "Re-merging" "Merging") + n + ediff-number-of-differences)) + + (setq state-of-merge (ediff-get-state-of-merge n)) + + (if remerging + ;;(let ((reg-A (ediff-get-region-contents n 'A ediff-control-buffer)) + ;; (reg-B (ediff-get-region-contents n 'B ediff-control-buffer)) + ;; (reg-C (ediff-get-region-contents n 'C ediff-control-buffer))) + (progn + + ;; if region was edited since it was first set by default + (if (or (ediff-merge-changed-from-default-p n) + ;; was preferred + (string-match "prefer" state-of-merge)) + ;; then ignore + (setq do-not-copy t)) + + ;; change state of merge for this diff, if necessary + (if (and (string-match "\\(default\\|combined\\)" state-of-merge) + (not do-not-copy)) + (ediff-set-state-of-merge + n (format "%S" ediff-default-variant))) + )) + + ;; state-of-merge may have changed via ediff-set-state-of-merge, so + ;; check it once again + (setq state-of-merge (ediff-get-state-of-merge n)) + + (or do-not-copy + (if (string= state-of-merge "combined") + ;; use n+1 because ediff-combine-diffs works via user numbering + ;; of diffs, which is 1+ to what ediff uses internally + (ediff-combine-diffs (1+ n) 'batch) + (ediff-copy-diff + n (if (string-match "-A" state-of-merge) 'A 'B) 'C 'batch))) + (setq n (1+ n))) + (message "Merging buffers A & B into C ... Done") + )) + + +(defun ediff-re-merge () + "Remerge unmodified diff regions using a new default. Start with the current region." + (interactive) + (let* ((default-variant-alist + (list '("default-A") '("default-B") '("combined"))) + (actual-alist + (delete (list (symbol-name ediff-default-variant)) + default-variant-alist))) + (setq ediff-default-variant + (intern + (completing-read + (format "Current merge default is `%S'. New default: " + ediff-default-variant) + actual-alist nil 'must-match))) + (ediff-do-merge ediff-current-difference 'remerge) + (ediff-recenter) + )) + +(defun ediff-shrink-window-C (arg) + "Shrink window C to just one line. +With a prefix argument, returns window C to its normal size. +Used only for merging jobs." + (interactive "P") + (if (not ediff-merge-job) + (error "ediff-shrink-window-C can be used only for merging jobs")) + (cond ((eq arg '-) (setq arg -1)) + ((not (numberp arg)) (setq arg nil))) + (cond ((null arg) + (let ((ediff-merge-window-share + (if (< (window-height ediff-window-C) 3) + ediff-merge-window-share 0))) + (setq ediff-window-config-saved "") ; force redisplay + (ediff-recenter 'no-rehighlight))) + ((and (< arg 0) (> (window-height ediff-window-C) 2)) + (setq ediff-merge-window-share (* ediff-merge-window-share 0.9)) + (setq ediff-window-config-saved "") ; force redisplay + (ediff-recenter 'no-rehighlight)) + ((and (> arg 0) (> (window-height ediff-window-A) 2)) + (setq ediff-merge-window-share (* ediff-merge-window-share 1.1)) + (setq ediff-window-config-saved "") ; force redisplay + (ediff-recenter 'no-rehighlight)))) + + +;; N here is the user's region number. It is 1+ what Ediff uses internally. +(defun ediff-combine-diffs (n &optional batch-invocation) + "Combine Nth diff regions of buffers A and B and place the combination in C. +N is a prefix argument. If nil, combine the current difference regions. +Combining is done according to the specifications in variable +`ediff-combination-pattern'." + (interactive "P") + (setq n (if (numberp n) (1- n) ediff-current-difference)) + + (let (reg-combined) + ;;(setq regA (ediff-get-region-contents n 'A ediff-control-buffer) + ;; regB (ediff-get-region-contents n 'B ediff-control-buffer)) + ;;(setq reg-combined (ediff-make-combined-diff regA regB)) + (setq reg-combined (ediff-get-combined-region n)) + + (ediff-copy-diff n nil 'C batch-invocation reg-combined)) + (or batch-invocation (ediff-jump-to-difference (1+ n)))) + + +;; Checks if the region in buff C looks like a combination of the regions +;; in buffers A and B. Return a list (reg-a-beg reg-a-end reg-b-beg reg-b-end) +;; These refer to where the delimiters for region A, B, Ancestor start and end +;; in buffer C +(defun ediff-looks-like-combined-merge (region-num) + (if ediff-merge-job + (let ((combined (string-match (regexp-quote "(A+B)") + (or (ediff-get-state-of-diff region-num 'C) + ""))) + (mrgreg-beg (ediff-get-diff-posn 'C 'beg region-num)) + (mrgreg-end (ediff-get-diff-posn 'C 'end region-num)) + (pattern-list ediff-combination-pattern) + delim reg-beg reg-end delim-regs-list) + + (if combined + (ediff-with-current-buffer ediff-buffer-C + (while pattern-list + (goto-char mrgreg-beg) + (setq delim (nth 0 pattern-list)) + (search-forward delim mrgreg-end 'noerror) + (setq reg-beg (match-beginning 0)) + (setq reg-end (match-end 0)) + (if (and reg-beg reg-end) + (setq delim-regs-list + ;; in reverse + (cons reg-end (cons reg-beg delim-regs-list)))) + (if (> (length pattern-list) 1) + (setq pattern-list (cdr (cdr pattern-list))) + (setq pattern-list nil)) + ))) + + (reverse delim-regs-list) + ))) + +(defvar state-of-merge) ; dynamic var + +;; Check if the non-preferred merge has been modified since originally set. +;; This affects only the regions that are marked as default-A/B or combined. +;; If PREFERS-TOO is non-nil, then look at the regions marked as prefers-A/B as +;; well. +(defun ediff-merge-changed-from-default-p (diff-num &optional prefers-too) + (let ((reg-A (ediff-get-region-contents diff-num 'A ediff-control-buffer)) + (reg-B (ediff-get-region-contents diff-num 'B ediff-control-buffer)) + (reg-C (ediff-get-region-contents diff-num 'C ediff-control-buffer))) + + (setq state-of-merge (ediff-get-state-of-merge diff-num)) + + ;; if region was edited since it was first set by default + (or (and (string= state-of-merge "default-A") + (not (string= reg-A reg-C))) + (and (string= state-of-merge "default-B") + (not (string= reg-B reg-C))) + (and (string= state-of-merge "combined") + ;;(not (string= (ediff-make-combined-diff reg-A reg-B) reg-C))) + (not (string= (ediff-get-combined-region diff-num) reg-C))) + (and prefers-too + (string= state-of-merge "prefer-A") + (not (string= reg-A reg-C))) + (and prefers-too + (string= state-of-merge "prefer-B") + (not (string= reg-B reg-C))) + ))) + + +(provide 'ediff-merg) + + +;; Local Variables: +;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun) +;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1) +;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body)) +;; End: + +;; arch-tag: 9b798cf9-02ba-487f-a62e-b63aa823dbfb +;;; ediff-merg.el ends here diff --cc lisp/vc/ediff-ptch.el index 393bdcb673c,00000000000..c851439de38 mode 100644,000000..100644 --- a/lisp/vc/ediff-ptch.el +++ b/lisp/vc/ediff-ptch.el @@@ -1,845 -1,0 +1,844 @@@ +;;; ediff-ptch.el --- Ediff's patch support + - ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, - ;; 2005, 2006, 2007, 2008, 2009, 2010 - ;; Free Software Foundation, Inc. ++;; 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 +;; 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 . + +;;; 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 diff --cc lisp/vc/ediff-vers.el index 581aad3e4dc,00000000000..487c5e80786 mode 100644,000000..100644 --- a/lisp/vc/ediff-vers.el +++ b/lisp/vc/ediff-vers.el @@@ -1,240 -1,0 +1,240 @@@ +;;; ediff-vers.el --- version control interface to Ediff + +;; Copyright (C) 1995, 1996, 1997, 2001, 2002, 2003, 2004, - ;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ++;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. + +;; Author: Michael Kifer +;; 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 . + +;;; Commentary: + +;;; Code: + +;; Compiler pacifier +(defvar rcs-default-co-switches) + +(and noninteractive + (eval-when-compile + (condition-case nil + ;; for compatibility with current stable version of xemacs + (progn + ;;(require 'pcvs nil 'noerror) + ;;(require 'rcs nil 'noerror) + (require 'pcvs) + (require 'rcs)) + (error nil)) + (require 'vc) + (require 'ediff-init) + )) +;; end pacifier + +(defcustom ediff-keep-tmp-versions nil + "If t, do not delete temporary previous versions for the files on which +comparison or merge operations are being performed." + :type 'boolean + :group 'ediff-vers + ) + +(defalias 'ediff-vc-revision-other-window + (if (fboundp 'vc-revision-other-window) + 'vc-revision-other-window + 'vc-version-other-window)) + +(defalias 'ediff-vc-working-revision + (if (fboundp 'vc-working-revision) + 'vc-working-revision + 'vc-workfile-version)) + +;; VC.el support + +(eval-when-compile + (require 'vc-hooks)) ;; for vc-call macro + + +(defun ediff-vc-latest-version (file) + "Return the version level of the latest version of FILE in repository." + (if (fboundp 'vc-latest-version) + (vc-latest-version file) + (or (vc-file-getprop file 'vc-latest-revision) + (cond ((vc-backend file) + (vc-call state file) + (vc-file-getprop file 'vc-latest-revision)) + (t (error "File %s is not under version control" file)))) + )) + + +(defun ediff-vc-internal (rev1 rev2 &optional startup-hooks) + ;; Run Ediff on versions of the current buffer. + ;; If REV1 is "", use the latest version of the current buffer's file. + ;; If REV2 is "" then compare current buffer with REV1. + ;; If the current buffer is named `F', the version is named `F.~REV~'. + ;; If `F.~REV~' already exists, it is used instead of being re-created. + (let (file1 file2 rev1buf rev2buf) + (if (string= rev1 "") + (setq rev1 (ediff-vc-latest-version (buffer-file-name)))) + (save-window-excursion + (save-excursion + (ediff-vc-revision-other-window rev1) + (setq rev1buf (current-buffer) + file1 (buffer-file-name))) + (save-excursion + (or (string= rev2 "") ; use current buffer + (ediff-vc-revision-other-window rev2)) + (setq rev2buf (current-buffer) + file2 (buffer-file-name))) + (setq startup-hooks + (cons `(lambda () + (ediff-delete-version-file ,file1) + (or ,(string= rev2 "") (ediff-delete-version-file ,file2))) + startup-hooks))) + (ediff-buffers + rev1buf rev2buf + startup-hooks + 'ediff-revision))) + +;; RCS.el support +(defun rcs-ediff-view-revision (&optional rev) +;; View previous RCS revision of current file. +;; With prefix argument, prompts for a revision name. + (interactive (list (if current-prefix-arg + (read-string "Revision: ")))) + (let* ((filename (buffer-file-name (current-buffer))) + (switches (append '("-p") + (if rev (list (concat "-r" rev)) nil))) + (buff (concat (file-name-nondirectory filename) ".~" rev "~"))) + (message "Working ...") + (setq filename (expand-file-name filename)) + (with-output-to-temp-buffer buff + (ediff-with-current-buffer standard-output + (fundamental-mode)) + (let ((output-buffer (ediff-rcs-get-output-buffer filename buff))) + (delete-windows-on output-buffer) + (with-current-buffer output-buffer + (apply 'call-process "co" nil t nil + ;; -q: quiet (no diagnostics) + (append switches rcs-default-co-switches + (list "-q" filename))))) + (message "") + buff))) + +(defun ediff-rcs-get-output-buffer (file name) + ;; Get a buffer for RCS output for FILE, make it writable and clean it up. + ;; Optional NAME is name to use instead of `*RCS-output*'. + ;; This is a modified version from rcs.el v1.1. I use it here to make + ;; Ediff immune to changes in rcs.el + (let ((buf (get-buffer-create name))) + (with-current-buffer buf + (setq buffer-read-only nil + default-directory (file-name-directory (expand-file-name file))) + (erase-buffer)) + buf)) + +(defun ediff-rcs-internal (rev1 rev2 &optional startup-hooks) +;; Run Ediff on versions of the current buffer. +;; If REV2 is "" then use current buffer. + (let (rev2buf rev1buf) + (save-window-excursion + (setq rev2buf (if (string= rev2 "") + (current-buffer) + (rcs-ediff-view-revision rev2)) + rev1buf (rcs-ediff-view-revision rev1))) + + ;; rcs.el doesn't create temp version files, so we don't have to delete + ;; anything in startup hooks to ediff-buffers + (ediff-buffers rev1buf rev2buf startup-hooks 'ediff-revision) + )) + +;;; Merge with Version Control + +(defun ediff-vc-merge-internal (rev1 rev2 ancestor-rev + &optional startup-hooks merge-buffer-file) +;; If ANCESTOR-REV non-nil, merge with ancestor + (let (buf1 buf2 ancestor-buf) + (save-window-excursion + (save-excursion + (ediff-vc-revision-other-window rev1) + (setq buf1 (current-buffer))) + (save-excursion + (or (string= rev2 "") + (ediff-vc-revision-other-window rev2)) + (setq buf2 (current-buffer))) + (if ancestor-rev + (save-excursion + (if (string= ancestor-rev "") + (setq ancestor-rev (ediff-vc-working-revision buffer-file-name))) + (ediff-vc-revision-other-window ancestor-rev) + (setq ancestor-buf (current-buffer)))) + (setq startup-hooks + (cons + `(lambda () + (ediff-delete-version-file ,(buffer-file-name buf1)) + (or ,(string= rev2 "") + (ediff-delete-version-file ,(buffer-file-name buf2))) + (or ,(string= ancestor-rev "") + ,(not ancestor-rev) + (ediff-delete-version-file ,(buffer-file-name ancestor-buf))) + ) + startup-hooks))) + (if ancestor-rev + (ediff-merge-buffers-with-ancestor + buf1 buf2 ancestor-buf + startup-hooks 'ediff-merge-revisions-with-ancestor merge-buffer-file) + (ediff-merge-buffers + buf1 buf2 startup-hooks 'ediff-merge-revisions merge-buffer-file)) + )) + +(defun ediff-rcs-merge-internal (rev1 rev2 ancestor-rev + &optional + startup-hooks merge-buffer-file) + ;; If ANCESTOR-REV non-nil, merge with ancestor + (let (buf1 buf2 ancestor-buf) + (save-window-excursion + (setq buf1 (rcs-ediff-view-revision rev1) + buf2 (if (string= rev2 "") + (current-buffer) + (rcs-ediff-view-revision rev2)) + ancestor-buf (if ancestor-rev + (if (string= ancestor-rev "") + (current-buffer) + (rcs-ediff-view-revision ancestor-rev))))) + ;; rcs.el doesn't create temp version files, so we don't have to delete + ;; anything in startup hooks to ediff-buffers + (if ancestor-rev + (ediff-merge-buffers-with-ancestor + buf1 buf2 ancestor-buf + startup-hooks 'ediff-merge-revisions-with-ancestor merge-buffer-file) + (ediff-merge-buffers + buf1 buf2 startup-hooks 'ediff-merge-revisions merge-buffer-file)))) + + +;; delete version file on exit unless ediff-keep-tmp-versions is true +(defun ediff-delete-version-file (file) + (or ediff-keep-tmp-versions (delete-file file))) + + +(provide 'ediff-vers) + + +;; Local Variables: +;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun) +;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1) +;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body)) +;; End: + +;; arch-tag: bbb34f0c-2a90-426a-a77a-c75f479ebbbf +;;; ediff-vers.el ends here diff --cc lisp/vc/ediff-wind.el index 4d6666a86f2,00000000000..1057dd4c9aa mode 100644,000000..100644 --- a/lisp/vc/ediff-wind.el +++ b/lisp/vc/ediff-wind.el @@@ -1,1313 -1,0 +1,1312 @@@ +;;; ediff-wind.el --- window manipulation utilities + - ;; Copyright (C) 1994, 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2004, - ;; 2005, 2006, 2007, 2008, 2009, 2010 - ;; Free Software Foundation, Inc. ++;; 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 +;; 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 . + +;;; Commentary: + +;;; Code: + + +;; Compiler pacifier +(defvar icon-title-format) +(defvar top-toolbar-height) +(defvar bottom-toolbar-height) +(defvar left-toolbar-height) +(defvar right-toolbar-height) +(defvar left-toolbar-width) +(defvar right-toolbar-width) +(defvar default-menubar) +(defvar top-gutter) +(defvar frame-icon-title-format) +(defvar ediff-diff-status) + +;; declare-function does not exist in XEmacs +(eval-and-compile + (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) + +(eval-when-compile + (require 'ediff-util) + (require 'ediff-help)) +;; end pacifier + +(require 'ediff-init) + +;; be careful with ediff-tbar +(if (featurep 'xemacs) + (require 'ediff-tbar) + (defun ediff-compute-toolbar-width () 0)) + +(defgroup ediff-window nil + "Ediff window manipulation." + :prefix "ediff-" + :group 'ediff + :group 'frames) + + +;; Determine which window setup function to use based on current window system. +(defun ediff-choose-window-setup-function-automatically () + (if (ediff-window-display-p) + 'ediff-setup-windows-multiframe + 'ediff-setup-windows-plain)) + +(defcustom ediff-window-setup-function (ediff-choose-window-setup-function-automatically) + "Function called to set up windows. +Ediff provides a choice of two functions: `ediff-setup-windows-plain', for +doing everything in one frame and `ediff-setup-windows-multiframe', which sets +the control panel in a separate frame. By default, the appropriate function is +chosen automatically depending on the current window system. +However, `ediff-toggle-multiframe' can be used to toggle between the multiframe +display and the single frame display. +If the multiframe function detects that one of the buffers A/B is seen in some +other frame, it will try to keep that buffer in that frame. + +If you don't like any of the two provided functions, write your own one. +The basic guidelines: + 1. It should leave the control buffer current and the control window + selected. + 2. It should set `ediff-window-A', `ediff-window-B', `ediff-window-C', + and `ediff-control-window' to contain window objects that display + the corresponding buffers. + 3. It should accept the following arguments: + buffer-A, buffer-B, buffer-C, control-buffer + Buffer C may not be used in jobs that compare only two buffers. +If you plan to do something fancy, take a close look at how the two +provided functions are written." + :type '(choice (const :tag "Multi Frame" ediff-setup-windows-multiframe) + (const :tag "Single Frame" ediff-setup-windows-plain) + (function :tag "Other function")) + :group 'ediff-window) + +;; indicates if we are in a multiframe setup +(ediff-defvar-local ediff-multiframe nil "") + +;; Share of the frame occupied by the merge window (buffer C) +(ediff-defvar-local ediff-merge-window-share 0.45 "") + +;; The control window. +(ediff-defvar-local ediff-control-window nil "") +;; Official window for buffer A +(ediff-defvar-local ediff-window-A nil "") +;; Official window for buffer B +(ediff-defvar-local ediff-window-B nil "") +;; Official window for buffer C +(ediff-defvar-local ediff-window-C nil "") +;; Ediff's window configuration. +;; Used to minimize the need to rearrange windows. +(ediff-defvar-local ediff-window-config-saved "" "") + +;; Association between buff-type and ediff-window-* +(defconst ediff-window-alist + '((A . ediff-window-A) + (?A . ediff-window-A) + (B . ediff-window-B) + (?B . ediff-window-B) + (C . ediff-window-C) + (?C . ediff-window-C))) + + +(defcustom ediff-split-window-function 'split-window-vertically + "The function used to split the main window between buffer-A and buffer-B. +You can set it to a horizontal split instead of the default vertical split +by setting this variable to `split-window-horizontally'. +You can also have your own function to do fancy splits. +This variable has no effect when buffer-A/B are shown in different frames. +In this case, Ediff will use those frames to display these buffers." + :type '(choice + (const :tag "Split vertically" split-window-vertically) + (const :tag "Split horizontally" split-window-horizontally) + function) + :group 'ediff-window) + +(defcustom ediff-merge-split-window-function 'split-window-horizontally + "The function used to split the main window between buffer-A and buffer-B. +You can set it to a vertical split instead of the default horizontal split +by setting this variable to `split-window-vertically'. +You can also have your own function to do fancy splits. +This variable has no effect when buffer-A/B/C are shown in different frames. +In this case, Ediff will use those frames to display these buffers." + :type '(choice + (const :tag "Split vertically" split-window-vertically) + (const :tag "Split horizontally" split-window-horizontally) + function) + :group 'ediff-window) + +;; Definitions hidden from the compiler by compat wrappers. +(declare-function ediff-display-pixel-width "ediff-init") +(declare-function ediff-display-pixel-height "ediff-init") + +(defconst ediff-control-frame-parameters + (list + '(name . "Ediff") + ;;'(unsplittable . t) + '(minibuffer . nil) + '(user-position . t) ; Emacs only + '(vertical-scroll-bars . nil) ; Emacs only + '(scrollbar-width . 0) ; XEmacs only + '(scrollbar-height . 0) ; XEmacs only + '(menu-bar-lines . 0) ; Emacs only + '(tool-bar-lines . 0) ; Emacs 21+ only + '(left-fringe . 0) + '(right-fringe . 0) + ;; don't lower but auto-raise + '(auto-lower . nil) + '(auto-raise . t) + '(visibility . nil) + ;; make initial frame small to avoid distraction + '(width . 1) '(height . 1) + ;; this blocks queries from window manager as to where to put + ;; ediff's control frame. we put the frame outside the display, + ;; so the initial frame won't jump all over the screen + (cons 'top (if (fboundp 'ediff-display-pixel-height) + (1+ (ediff-display-pixel-height)) + 3000)) + (cons 'left (if (fboundp 'ediff-display-pixel-width) + (1+ (ediff-display-pixel-width)) + 3000)) + ) + "Frame parameters for displaying Ediff Control Panel. +Used internally---not a user option.") + +;; position of the mouse; used to decide whether to warp the mouse into ctl +;; frame +(ediff-defvar-local ediff-mouse-pixel-position nil "") + +;; not used for now +(defvar ediff-mouse-pixel-threshold 30 + "If the user moves mouse more than this many pixels, Ediff won't warp mouse into control window.") + +(defcustom ediff-grab-mouse t + "If t, Ediff will always grab the mouse and put it in the control frame. +If 'maybe, Ediff will do it sometimes, but not after operations that require +relatively long time. If nil, the mouse will be entirely user's +responsibility." + :type 'boolean + :group 'ediff-window) + +(defcustom ediff-control-frame-position-function 'ediff-make-frame-position + "Function to call to determine the desired location for the control panel. +Expects three parameters: the control buffer, the desired width and height +of the control frame. It returns an association list +of the form \(\(top . \) \(left . \)\)" + :type 'function + :group 'ediff-window) + +(defcustom ediff-control-frame-upward-shift 42 + "The upward shift of control frame from the top of buffer A's frame. +Measured in pixels. +This is used by the default control frame positioning function, +`ediff-make-frame-position'. This variable is provided for easy +customization of the default control frame positioning." + :type 'integer + :group 'ediff-window) + +(defcustom ediff-narrow-control-frame-leftward-shift (if (featurep 'xemacs) 7 3) + "The leftward shift of control frame from the right edge of buf A's frame. +Measured in characters. +This is used by the default control frame positioning function, +`ediff-make-frame-position' to adjust the position of the control frame +when it shows the short menu. This variable is provided for easy +customization of the default." + :type 'integer + :group 'ediff-window) + +(defcustom ediff-wide-control-frame-rightward-shift 7 + "The rightward shift of control frame from the left edge of buf A's frame. +Measured in characters. +This is used by the default control frame positioning function, +`ediff-make-frame-position' to adjust the position of the control frame +when it shows the full menu. This variable is provided for easy +customization of the default." + :type 'integer + :group 'ediff-window) + + +;; Wide frame display + +;; t means Ediff is using wide display +(ediff-defvar-local ediff-wide-display-p nil "") +;; keeps frame config for toggling wide display +(ediff-defvar-local ediff-wide-display-orig-parameters nil + "Frame parameters to be restored when the user wants to toggle the wide +display off.") +(ediff-defvar-local ediff-wide-display-frame nil + "Frame to be used for wide display.") +(ediff-defvar-local ediff-make-wide-display-function 'ediff-make-wide-display + "The value is a function that is called to create a wide display. +The function is called without arguments. It should resize the frame in +which buffers A, B, and C are to be displayed, and it should save the old +frame parameters in `ediff-wide-display-orig-parameters'. +The variable `ediff-wide-display-frame' should be set to contain +the frame used for the wide display.") + +;; Frame used for the control panel in a windowing system. +(ediff-defvar-local ediff-control-frame nil "") + +(defcustom ediff-prefer-iconified-control-frame nil + "If t, keep control panel iconified when help message is off. +This has effect only on a windowing system. +If t, hitting `?' to toggle control panel off iconifies it. + +This is only useful in Emacs and only for certain kinds of window managers, +such as TWM and its derivatives, since the window manager must permit +keyboard input to go into icons. XEmacs completely ignores keyboard input +into icons, regardless of the window manager." + :type 'boolean + :group 'ediff-window) + +;;; Functions + +(defun ediff-get-window-by-clicking (wind prev-wind wind-number) + (let (event) + (message + "Select windows by clicking. Please click on Window %d " wind-number) + (while (not (ediff-mouse-event-p (setq event (ediff-read-event)))) + (if (sit-for 1) ; if sequence of events, wait till the final word + (beep 1)) + (message "Please click on Window %d " wind-number)) + (ediff-read-event) ; discard event + (setq wind (if (featurep 'xemacs) + (event-window event) + (posn-window (event-start event)))))) + + +;; Select the lowest window on the frame. +(defun ediff-select-lowest-window () + (if (featurep 'xemacs) + (select-window (frame-lowest-window)) + (let* ((lowest-window (selected-window)) + (bottom-edge (car (cdr (cdr (cdr (window-edges)))))) + (last-window (save-excursion + (other-window -1) (selected-window))) + (window-search t)) + (while window-search + (let* ((this-window (next-window)) + (next-bottom-edge + (car (cdr (cdr (cdr (window-edges this-window))))))) + (if (< bottom-edge next-bottom-edge) + (setq bottom-edge next-bottom-edge + lowest-window this-window)) + (select-window this-window) + (when (eq last-window this-window) + (select-window lowest-window) + (setq window-search nil))))))) + + +;;; Common window setup routines + +;; Set up the window configuration. If POS is given, set the points to +;; the beginnings of the buffers. +;; When 3way comparison is added, this will have to choose the appropriate +;; setup function based on ediff-job-name +(defun ediff-setup-windows (buffer-A buffer-B buffer-C control-buffer) + ;; Make sure we are not in the minibuffer window when we try to delete + ;; all other windows. + (run-hooks 'ediff-before-setup-windows-hook) + (if (eq (selected-window) (minibuffer-window)) + (other-window 1)) + + ;; in case user did a no-no on a tty + (or (ediff-window-display-p) + (setq ediff-window-setup-function 'ediff-setup-windows-plain)) + + (or (ediff-keep-window-config control-buffer) + (funcall + (ediff-with-current-buffer control-buffer ediff-window-setup-function) + buffer-A buffer-B buffer-C control-buffer)) + (run-hooks 'ediff-after-setup-windows-hook)) + +;; Just set up 3 windows. +;; Usually used without windowing systems +;; With windowing, we want to use dedicated frames. +(defun ediff-setup-windows-plain (buffer-A buffer-B buffer-C control-buffer) + (ediff-with-current-buffer control-buffer + (setq ediff-multiframe nil)) + (if ediff-merge-job + (ediff-setup-windows-plain-merge + buffer-A buffer-B buffer-C control-buffer) + (ediff-setup-windows-plain-compare + buffer-A buffer-B buffer-C control-buffer))) + +(defun ediff-setup-windows-plain-merge (buf-A buf-B buf-C control-buffer) + ;; skip dedicated and unsplittable frames + (ediff-destroy-control-frame control-buffer) + (let ((window-min-height 1) + split-window-function + merge-window-share merge-window-lines + wind-A wind-B wind-C) + (ediff-with-current-buffer control-buffer + (setq merge-window-share ediff-merge-window-share + ;; this lets us have local versions of ediff-split-window-function + split-window-function ediff-split-window-function)) + (delete-other-windows) + (set-window-dedicated-p (selected-window) nil) + (split-window-vertically) + (ediff-select-lowest-window) + (ediff-setup-control-buffer control-buffer) + + ;; go to the upper window and split it betw A, B, and possibly C + (other-window 1) + (setq merge-window-lines + (max 2 (round (* (window-height) merge-window-share)))) + (switch-to-buffer buf-A) + (setq wind-A (selected-window)) + + ;; XEmacs used to have a lot of trouble with display + ;; It did't set things right unless we tell it to sit still + ;; 19.12 seems ok. + ;;(if (featurep 'xemacs) (sit-for 0)) + + (split-window-vertically (max 2 (- (window-height) merge-window-lines))) + (if (eq (selected-window) wind-A) + (other-window 1)) + (setq wind-C (selected-window)) + (switch-to-buffer buf-C) + + (select-window wind-A) + (funcall split-window-function) + + (if (eq (selected-window) wind-A) + (other-window 1)) + (switch-to-buffer buf-B) + (setq wind-B (selected-window)) + + (ediff-with-current-buffer control-buffer + (setq ediff-window-A wind-A + ediff-window-B wind-B + ediff-window-C wind-C)) + + (ediff-select-lowest-window) + (ediff-setup-control-buffer control-buffer) + )) + + +;; This function handles all comparison jobs, including 3way jobs +(defun ediff-setup-windows-plain-compare (buf-A buf-B buf-C control-buffer) + ;; skip dedicated and unsplittable frames + (ediff-destroy-control-frame control-buffer) + (let ((window-min-height 1) + split-window-function wind-width-or-height + three-way-comparison + wind-A-start wind-B-start wind-A wind-B wind-C) + (ediff-with-current-buffer control-buffer + (setq wind-A-start (ediff-overlay-start + (ediff-get-value-according-to-buffer-type + 'A ediff-narrow-bounds)) + wind-B-start (ediff-overlay-start + (ediff-get-value-according-to-buffer-type + 'B ediff-narrow-bounds)) + ;; this lets us have local versions of ediff-split-window-function + split-window-function ediff-split-window-function + three-way-comparison ediff-3way-comparison-job)) + ;; if in minibuffer go somewhere else + (if (save-match-data + (string-match "\*Minibuf-" (buffer-name (window-buffer)))) + (select-window (next-window nil 'ignore-minibuf))) + (delete-other-windows) + (set-window-dedicated-p (selected-window) nil) + (split-window-vertically) + (ediff-select-lowest-window) + (ediff-setup-control-buffer control-buffer) + + ;; go to the upper window and split it betw A, B, and possibly C + (other-window 1) + (switch-to-buffer buf-A) + (setq wind-A (selected-window)) + (if three-way-comparison + (setq wind-width-or-height + (/ (if (eq split-window-function 'split-window-vertically) + (window-height wind-A) + (window-width wind-A)) + 3))) + + ;; XEmacs used to have a lot of trouble with display + ;; It did't set things right unless we told it to sit still + ;; 19.12 seems ok. + ;;(if (featurep 'xemacs) (sit-for 0)) + + (funcall split-window-function wind-width-or-height) + + (if (eq (selected-window) wind-A) + (other-window 1)) + (switch-to-buffer buf-B) + (setq wind-B (selected-window)) + + (if three-way-comparison + (progn + (funcall split-window-function) ; equally + (if (eq (selected-window) wind-B) + (other-window 1)) + (switch-to-buffer buf-C) + (setq wind-C (selected-window)))) + + (ediff-with-current-buffer control-buffer + (setq ediff-window-A wind-A + ediff-window-B wind-B + ediff-window-C wind-C)) + + ;; It is unlikely that we will want to implement 3way window comparison. + ;; So, only buffers A and B are used here. + (if ediff-windows-job + (progn + (set-window-start wind-A wind-A-start) + (set-window-start wind-B wind-B-start))) + + (ediff-select-lowest-window) + (ediff-setup-control-buffer control-buffer) + )) + + +;; dispatch an appropriate window setup function +(defun ediff-setup-windows-multiframe (buf-A buf-B buf-C control-buf) + (ediff-with-current-buffer control-buf + (setq ediff-multiframe t)) + (if ediff-merge-job + (ediff-setup-windows-multiframe-merge buf-A buf-B buf-C control-buf) + (ediff-setup-windows-multiframe-compare buf-A buf-B buf-C control-buf))) + +(defun ediff-setup-windows-multiframe-merge (buf-A buf-B buf-C control-buf) +;;; Algorithm: +;;; 1. Never use frames that have dedicated windows in them---it is bad to +;;; destroy dedicated windows. +;;; 2. If A and B are in the same frame but C's frame is different--- use one +;;; frame for A and B and use a separate frame for C. +;;; 3. If C's frame is non-existent, then: if the first suitable +;;; non-dedicated frame is different from A&B's, then use it for C. +;;; Otherwise, put A,B, and C in one frame. +;;; 4. If buffers A, B, C are is separate frames, use them to display these +;;; buffers. + + ;; Skip dedicated or iconified frames. + ;; Unsplittable frames are taken care of later. + (ediff-skip-unsuitable-frames 'ok-unsplittable) + + (let* ((window-min-height 1) + (wind-A (ediff-get-visible-buffer-window buf-A)) + (wind-B (ediff-get-visible-buffer-window buf-B)) + (wind-C (ediff-get-visible-buffer-window buf-C)) + (frame-A (if wind-A (window-frame wind-A))) + (frame-B (if wind-B (window-frame wind-B))) + (frame-C (if wind-C (window-frame wind-C))) + ;; on wide display, do things in one frame + (force-one-frame + (ediff-with-current-buffer control-buf ediff-wide-display-p)) + ;; this lets us have local versions of ediff-split-window-function + (split-window-function + (ediff-with-current-buffer control-buf ediff-split-window-function)) + (orig-wind (selected-window)) + (orig-frame (selected-frame)) + (use-same-frame (or force-one-frame + ;; A and C must be in one frame + (eq frame-A (or frame-C orig-frame)) + ;; B and C must be in one frame + (eq frame-B (or frame-C orig-frame)) + ;; A or B is not visible + (not (frame-live-p frame-A)) + (not (frame-live-p frame-B)) + ;; A or B is not suitable for display + (not (ediff-window-ok-for-display wind-A)) + (not (ediff-window-ok-for-display wind-B)) + ;; A and B in the same frame, and no good frame + ;; for C + (and (eq frame-A frame-B) + (not (frame-live-p frame-C))) + )) + ;; use-same-frame-for-AB implies wind A and B are ok for display + (use-same-frame-for-AB (and (not use-same-frame) + (eq frame-A frame-B))) + (merge-window-share (ediff-with-current-buffer control-buf + ediff-merge-window-share)) + merge-window-lines + designated-minibuffer-frame + done-A done-B done-C) + + ;; buf-A on its own + (if (and (window-live-p wind-A) + (null use-same-frame) ; implies wind-A is suitable + (null use-same-frame-for-AB)) + (progn ; bug A on its own + ;; buffer buf-A is seen in live wind-A + (select-window wind-A) + (delete-other-windows) + (setq wind-A (selected-window)) + (setq done-A t))) + + ;; buf-B on its own + (if (and (window-live-p wind-B) + (null use-same-frame) ; implies wind-B is suitable + (null use-same-frame-for-AB)) + (progn ; buf B on its own + ;; buffer buf-B is seen in live wind-B + (select-window wind-B) + (delete-other-windows) + (setq wind-B (selected-window)) + (setq done-B t))) + + ;; buf-C on its own + (if (and (window-live-p wind-C) + (ediff-window-ok-for-display wind-C) + (null use-same-frame)) ; buf C on its own + (progn + ;; buffer buf-C is seen in live wind-C + (select-window wind-C) + (delete-other-windows) + (setq wind-C (selected-window)) + (setq done-C t))) + + (if (and use-same-frame-for-AB ; implies wind A and B are suitable + (window-live-p wind-A)) + (progn + ;; wind-A must already be displaying buf-A + (select-window wind-A) + (delete-other-windows) + (setq wind-A (selected-window)) + + (funcall split-window-function) + (if (eq (selected-window) wind-A) + (other-window 1)) + (switch-to-buffer buf-B) + (setq wind-B (selected-window)) + + (setq done-A t + done-B t))) + + (if use-same-frame + (let ((window-min-height 1)) + (if (and (eq frame-A frame-B) + (eq frame-B frame-C) + (frame-live-p frame-A)) + (select-frame frame-A) + ;; avoid dedicated and non-splittable windows + (ediff-skip-unsuitable-frames)) + (delete-other-windows) + (setq merge-window-lines + (max 2 (round (* (window-height) merge-window-share)))) + (switch-to-buffer buf-A) + (setq wind-A (selected-window)) + + (split-window-vertically + (max 2 (- (window-height) merge-window-lines))) + (if (eq (selected-window) wind-A) + (other-window 1)) + (setq wind-C (selected-window)) + (switch-to-buffer buf-C) + + (select-window wind-A) + + (funcall split-window-function) + (if (eq (selected-window) wind-A) + (other-window 1)) + (switch-to-buffer buf-B) + (setq wind-B (selected-window)) + + (setq done-A t + done-B t + done-C t) + )) + + (or done-A ; Buf A to be set in its own frame, + ;;; or it was set before because use-same-frame = 1 + (progn + ;; Buf-A was not set up yet as it wasn't visible, + ;; and use-same-frame = nil, use-same-frame-for-AB = nil + (select-window orig-wind) + (delete-other-windows) + (switch-to-buffer buf-A) + (setq wind-A (selected-window)) + )) + (or done-B ; Buf B to be set in its own frame, + ;;; or it was set before because use-same-frame = 1 + (progn + ;; Buf-B was not set up yet as it wasn't visible + ;; and use-same-frame = nil, use-same-frame-for-AB = nil + (select-window orig-wind) + (delete-other-windows) + (switch-to-buffer buf-B) + (setq wind-B (selected-window)) + )) + + (or done-C ; Buf C to be set in its own frame, + ;;; or it was set before because use-same-frame = 1 + (progn + ;; Buf-C was not set up yet as it wasn't visible + ;; and use-same-frame = nil + (select-window orig-wind) + (delete-other-windows) + (switch-to-buffer buf-C) + (setq wind-C (selected-window)) + )) + + (ediff-with-current-buffer control-buf + (setq ediff-window-A wind-A + ediff-window-B wind-B + ediff-window-C wind-C) + (setq frame-A (window-frame ediff-window-A) + designated-minibuffer-frame + (window-frame (minibuffer-window frame-A)))) + + (ediff-setup-control-frame control-buf designated-minibuffer-frame) + )) + + +;; Window setup for all comparison jobs, including 3way comparisons +(defun ediff-setup-windows-multiframe-compare (buf-A buf-B buf-C control-buf) +;;; Algorithm: +;;; If a buffer is seen in a frame, use that frame for that buffer. +;;; If it is not seen, use the current frame. +;;; If both buffers are not seen, they share the current frame. If one +;;; of the buffers is not seen, it is placed in the current frame (where +;;; ediff started). If that frame is displaying the other buffer, it is +;;; shared between the two buffers. +;;; However, if we decide to put both buffers in one frame +;;; and the selected frame isn't splittable, we create a new frame and +;;; put both buffers there, event if one of this buffers is visible in +;;; another frame. + + ;; Skip dedicated or iconified frames. + ;; Unsplittable frames are taken care of later. + (ediff-skip-unsuitable-frames 'ok-unsplittable) + + (let* ((window-min-height 1) + (wind-A (ediff-get-visible-buffer-window buf-A)) + (wind-B (ediff-get-visible-buffer-window buf-B)) + (wind-C (ediff-get-visible-buffer-window buf-C)) + (frame-A (if wind-A (window-frame wind-A))) + (frame-B (if wind-B (window-frame wind-B))) + (frame-C (if wind-C (window-frame wind-C))) + (ctl-frame-exists-p (ediff-with-current-buffer control-buf + (frame-live-p ediff-control-frame))) + ;; on wide display, do things in one frame + (force-one-frame + (ediff-with-current-buffer control-buf ediff-wide-display-p)) + ;; this lets us have local versions of ediff-split-window-function + (split-window-function + (ediff-with-current-buffer control-buf ediff-split-window-function)) + (three-way-comparison + (ediff-with-current-buffer control-buf ediff-3way-comparison-job)) + (orig-wind (selected-window)) + (use-same-frame (or force-one-frame + (eq frame-A frame-B) + (not (ediff-window-ok-for-display wind-A)) + (not (ediff-window-ok-for-display wind-B)) + (if three-way-comparison + (or (eq frame-A frame-C) + (eq frame-B frame-C) + (not (ediff-window-ok-for-display wind-C)) + (not (frame-live-p frame-A)) + (not (frame-live-p frame-B)) + (not (frame-live-p frame-C)))) + (and (not (frame-live-p frame-B)) + (or ctl-frame-exists-p + (eq frame-A (selected-frame)))) + (and (not (frame-live-p frame-A)) + (or ctl-frame-exists-p + (eq frame-B (selected-frame)))))) + wind-A-start wind-B-start + designated-minibuffer-frame + done-A done-B done-C) + + (ediff-with-current-buffer control-buf + (setq wind-A-start (ediff-overlay-start + (ediff-get-value-according-to-buffer-type + 'A ediff-narrow-bounds)) + wind-B-start (ediff-overlay-start + (ediff-get-value-according-to-buffer-type + 'B ediff-narrow-bounds)))) + + (if (and (window-live-p wind-A) (null use-same-frame)) ; buf-A on its own + (progn + ;; buffer buf-A is seen in live wind-A + (select-window wind-A) ; must be displaying buf-A + (delete-other-windows) + (setq wind-A (selected-window)) + (setq done-A t))) + + (if (and (window-live-p wind-B) (null use-same-frame)) ; buf B on its own + (progn + ;; buffer buf-B is seen in live wind-B + (select-window wind-B) ; must be displaying buf-B + (delete-other-windows) + (setq wind-B (selected-window)) + (setq done-B t))) + + (if (and (window-live-p wind-C) (null use-same-frame)) ; buf C on its own + (progn + ;; buffer buf-C is seen in live wind-C + (select-window wind-C) ; must be displaying buf-C + (delete-other-windows) + (setq wind-C (selected-window)) + (setq done-C t))) + + (if use-same-frame + (let (wind-width-or-height) ; this affects 3way setups only + (if (and (eq frame-A frame-B) (frame-live-p frame-A)) + (select-frame frame-A) + ;; avoid dedicated and non-splittable windows + (ediff-skip-unsuitable-frames)) + (delete-other-windows) + (switch-to-buffer buf-A) + (setq wind-A (selected-window)) + + (if three-way-comparison + (setq wind-width-or-height + (/ + (if (eq split-window-function 'split-window-vertically) + (window-height wind-A) + (window-width wind-A)) + 3))) + + (funcall split-window-function wind-width-or-height) + (if (eq (selected-window) wind-A) + (other-window 1)) + (switch-to-buffer buf-B) + (setq wind-B (selected-window)) + + (if three-way-comparison + (progn + (funcall split-window-function) ; equally + (if (memq (selected-window) (list wind-A wind-B)) + (other-window 1)) + (switch-to-buffer buf-C) + (setq wind-C (selected-window)))) + (setq done-A t + done-B t + done-C t) + )) + + (or done-A ; Buf A to be set in its own frame + ;;; or it was set before because use-same-frame = 1 + (progn + ;; Buf-A was not set up yet as it wasn't visible, + ;; and use-same-frame = nil + (select-window orig-wind) + (delete-other-windows) + (switch-to-buffer buf-A) + (setq wind-A (selected-window)) + )) + (or done-B ; Buf B to be set in its own frame + ;;; or it was set before because use-same-frame = 1 + (progn + ;; Buf-B was not set up yet as it wasn't visible, + ;; and use-same-frame = nil + (select-window orig-wind) + (delete-other-windows) + (switch-to-buffer buf-B) + (setq wind-B (selected-window)) + )) + + (if three-way-comparison + (or done-C ; Buf C to be set in its own frame + ;;; or it was set before because use-same-frame = 1 + (progn + ;; Buf-C was not set up yet as it wasn't visible, + ;; and use-same-frame = nil + (select-window orig-wind) + (delete-other-windows) + (switch-to-buffer buf-C) + (setq wind-C (selected-window)) + ))) + + (ediff-with-current-buffer control-buf + (setq ediff-window-A wind-A + ediff-window-B wind-B + ediff-window-C wind-C) + + (setq frame-A (window-frame ediff-window-A) + designated-minibuffer-frame + (window-frame (minibuffer-window frame-A)))) + + ;; It is unlikely that we'll implement a version of ediff-windows that + ;; would compare 3 windows at once. So, we don't use buffer C here. + (if ediff-windows-job + (progn + (set-window-start wind-A wind-A-start) + (set-window-start wind-B wind-B-start))) + + (ediff-setup-control-frame control-buf designated-minibuffer-frame) + )) + +;; skip unsplittable frames and frames that have dedicated windows. +;; create a new splittable frame if none is found +(defun ediff-skip-unsuitable-frames (&optional ok-unsplittable) + (if (ediff-window-display-p) + (let ((wind-frame (window-frame (selected-window))) + seen-windows) + (while (and (not (memq (selected-window) seen-windows)) + (or + (ediff-frame-has-dedicated-windows wind-frame) + (ediff-frame-iconified-p wind-frame) + ;; skip small windows + (< (frame-height wind-frame) + (* 3 window-min-height)) + (if ok-unsplittable + nil + (ediff-frame-unsplittable-p wind-frame)))) + ;; remember history + (setq seen-windows (cons (selected-window) seen-windows)) + ;; try new window + (other-window 1 t) + (setq wind-frame (window-frame (selected-window))) + ) + (if (memq (selected-window) seen-windows) + ;; fed up, no appropriate frames + (setq wind-frame (make-frame '((unsplittable))))) + + (select-frame wind-frame) + ))) + +(defun ediff-frame-has-dedicated-windows (frame) + (let (ans) + (walk-windows + (lambda (wind) (if (window-dedicated-p wind) + (setq ans t))) + 'ignore-minibuffer + frame) + ans)) + +;; window is ok, if it is only one window on the frame, not counting the +;; minibuffer, or none of the frame's windows is dedicated. +;; The idea is that it is bad to destroy dedicated windows while creating an +;; ediff window setup +(defun ediff-window-ok-for-display (wind) + (and + (window-live-p wind) + (or + ;; only one window + (eq wind (next-window wind 'ignore-minibuffer (window-frame wind))) + ;; none is dedicated (in multiframe setup) + (not (ediff-frame-has-dedicated-windows (window-frame wind))) + ))) + +;; Prepare or refresh control frame +(defun ediff-setup-control-frame (ctl-buffer designated-minibuffer-frame) + (let ((window-min-height 1) + ctl-frame-iconified-p dont-iconify-ctl-frame deiconify-ctl-frame + ctl-frame old-ctl-frame lines + ;; user-grabbed-mouse + fheight fwidth adjusted-parameters) + + (ediff-with-current-buffer ctl-buffer + (if (and (featurep 'xemacs) (featurep 'menubar)) + (set-buffer-menubar nil)) + ;;(setq user-grabbed-mouse (ediff-user-grabbed-mouse)) + (run-hooks 'ediff-before-setup-control-frame-hook)) + + (setq old-ctl-frame (ediff-with-current-buffer ctl-buffer ediff-control-frame)) + (ediff-with-current-buffer ctl-buffer + (setq ctl-frame (if (frame-live-p old-ctl-frame) + old-ctl-frame + (make-frame ediff-control-frame-parameters)) + ediff-control-frame ctl-frame) + ;; protect against undefined face-attribute + (condition-case nil + (if (and (featurep 'emacs) (face-attribute 'mode-line :box)) + (set-face-attribute 'mode-line ctl-frame :box nil)) + (error))) + + (setq ctl-frame-iconified-p (ediff-frame-iconified-p ctl-frame)) + (select-frame ctl-frame) + (if (window-dedicated-p (selected-window)) + () + (delete-other-windows) + (switch-to-buffer ctl-buffer)) + + ;; must be before ediff-setup-control-buffer + ;; just a precaution--we should be in ctl-buffer already + (ediff-with-current-buffer ctl-buffer + (make-local-variable 'frame-title-format) + (make-local-variable 'frame-icon-title-format) ; XEmacs + (make-local-variable 'icon-title-format)) ; Emacs + + (ediff-setup-control-buffer ctl-buffer) + (setq dont-iconify-ctl-frame + (not (string= ediff-help-message ediff-brief-help-message))) + (setq deiconify-ctl-frame + (and (eq this-command 'ediff-toggle-help) + dont-iconify-ctl-frame)) + + ;; 1 more line for the modeline + (setq lines (1+ (count-lines (point-min) (point-max))) + fheight lines + fwidth (max (+ (ediff-help-message-line-length) 2) + (ediff-compute-toolbar-width)) + adjusted-parameters + (list + ;; possibly change surrogate minibuffer + (cons 'minibuffer + (minibuffer-window + designated-minibuffer-frame)) + (cons 'width fwidth) + (cons 'height fheight) + (cons 'user-position t) + )) + + ;; adjust autoraise + (setq adjusted-parameters + (cons (if ediff-use-long-help-message + '(auto-raise . nil) + '(auto-raise . t)) + adjusted-parameters)) + + ;; In XEmacs, buffer menubar needs to be killed before frame parameters + ;; are changed. + (if (ediff-has-toolbar-support-p) + (when (featurep 'xemacs) + (if (ediff-has-gutter-support-p) + (set-specifier top-gutter (list ctl-frame nil))) + (sit-for 0) + (set-specifier top-toolbar-height (list ctl-frame 0)) + ;;(set-specifier bottom-toolbar-height (list ctl-frame 0)) + (set-specifier left-toolbar-width (list ctl-frame 0)) + (set-specifier right-toolbar-width (list ctl-frame 0)))) + + ;; 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 diff --cc lisp/vc/ediff.el index c41a6e4a1af,00000000000..9866f10107f mode 100644,000000..100644 --- a/lisp/vc/ediff.el +++ b/lisp/vc/ediff.el @@@ -1,1566 -1,0 +1,1566 @@@ +;;; ediff.el --- a comprehensive visual interface to diff & patch + +;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, - ;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ++;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. + +;; Author: Michael Kifer +;; Created: February 2, 1994 +;; Keywords: comparing, merging, patching, vc, tools, unix +;; Version: 2.81.4 + +;; Yoni Rabkin contacted the maintainer of this +;; file on 20/3/2008, and the maintainer agreed that when a bug is +;; filed in the Emacs bug reporting system against this file, a copy +;; of the bug report be sent to the maintainer's email address. + +(defconst ediff-version "2.81.4" "The current version of Ediff") +(defconst ediff-date "December 7, 2009" "Date of last update") + + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Never read that diff output again! +;; Apply patch interactively! +;; Merge with ease! + +;; This package provides a convenient way of simultaneous browsing through +;; the differences between a pair (or a triple) of files or buffers. The +;; files being compared, file-A, file-B, and file-C (if applicable) are +;; shown in separate windows (side by side, one above the another, or in +;; separate frames), and the differences are highlighted as you step +;; through them. You can also copy difference regions from one buffer to +;; another (and recover old differences if you change your mind). + +;; Ediff also supports merging operations on files and buffers, including +;; merging using ancestor versions. Both comparison and merging operations can +;; be performed on directories, i.e., by pairwise comparison of files in those +;; directories. + +;; In addition, Ediff can apply a patch to a file and then let you step +;; though both files, the patched and the original one, simultaneously, +;; difference-by-difference. You can even apply a patch right out of a +;; mail buffer, i.e., patches received by mail don't even have to be saved. +;; Since Ediff lets you copy differences between buffers, you can, in +;; effect, apply patches selectively (i.e., you can copy a difference +;; region from file_orig to file, thereby undoing any particular patch that +;; you don't like). + +;; Ediff is aware of version control, which lets the user compare +;; files with their older versions. Ediff can also work with remote and +;; compressed files. Details are given below. + +;; Finally, Ediff supports directory-level comparison, merging and patching. +;; See the on-line manual for details. + +;; This package builds upon the ideas borrowed from emerge.el and several +;; Ediff's functions are adaptations from emerge.el. Much of the functionality +;; Ediff provides is also influenced by emerge.el. + +;; The present version of Ediff supersedes Emerge. It provides a superior user +;; interface and has numerous major features not found in Emerge. In +;; particular, it can do patching, and 2-way and 3-way file comparison, +;; merging, and directory operations. + + + +;;; Bugs: + +;; 1. The undo command doesn't restore deleted regions well. That is, if +;; you delete all characters in a difference region and then invoke +;; `undo', the reinstated text will most likely be inserted outside of +;; what Ediff thinks is the current difference region. (This problem +;; doesn't seem to exist with XEmacs.) +;; +;; If at any point you feel that difference regions are no longer correct, +;; you can hit '!' to recompute the differences. + +;; 2. On a monochrome display, the repertoire of faces with which to +;; highlight fine differences is limited. By default, Ediff is using +;; underlining. However, if the region is already underlined by some other +;; overlays, there is no simple way to temporarily remove that residual +;; underlining. This problem occurs when a buffer is highlighted with +;; hilit19.el or font-lock.el packages. If this residual highlighting gets +;; in the way, you can do the following. Both font-lock.el and hilit19.el +;; provide commands for unhighlighting buffers. You can either place these +;; commands in `ediff-prepare-buffer-hook' (which will unhighlight every +;; buffer used by Ediff) or you can execute them interactively, at any time +;; and on any buffer. + + +;;; Acknowledgements: + +;; Ediff was inspired by Dale R. Worley's emerge.el. +;; Ediff would not have been possible without the help and encouragement of +;; its many users. See Ediff on-line Info for the full list of those who +;; helped. Improved defaults in Ediff file-name reading commands. + +;;; Code: + +(provide 'ediff) + +;; Compiler pacifier +(eval-and-compile + (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) + + +(eval-when-compile + (require 'dired) + (require 'ediff-util) + (require 'ediff-ptch)) +;; end pacifier + +(require 'ediff-init) +(require 'ediff-mult) ; required because of the registry stuff + +(defgroup ediff nil + "A comprehensive visual interface to diff & patch." + :tag "Ediff" + :group 'tools) + + +(defcustom ediff-use-last-dir nil + "If t, Ediff will use previous directory as default when reading file name." + :type 'boolean + :group 'ediff) + +;; Last directory used by an Ediff command for file-A. +(defvar ediff-last-dir-A nil) +;; Last directory used by an Ediff command for file-B. +(defvar ediff-last-dir-B nil) +;; Last directory used by an Ediff command for file-C. +(defvar ediff-last-dir-C nil) +;; Last directory used by an Ediff command for the ancestor file. +(defvar ediff-last-dir-ancestor nil) +;; Last directory used by an Ediff command as the output directory for merge. +(defvar ediff-last-merge-autostore-dir nil) + + +;; Used as a startup hook to set `_orig' patch file read-only. +(defun ediff-set-read-only-in-buf-A () + (ediff-with-current-buffer ediff-buffer-A + (toggle-read-only 1))) + +;; Return a plausible default for ediff's first file: +;; In dired, return the file number FILENO (or 0) in the list +;; (all-selected-files, filename under the cursor), where directories are +;; ignored. Otherwise, return DEFAULT file name, if non-nil. Else, +;; if the buffer is visiting a file, return that file name. +(defun ediff-get-default-file-name (&optional default fileno) + (cond ((eq major-mode 'dired-mode) + (let ((current (dired-get-filename nil 'no-error)) + (marked (condition-case nil + (dired-get-marked-files 'no-dir) + (error nil))) + aux-list choices result) + (or (integerp fileno) (setq fileno 0)) + (if (stringp default) + (setq aux-list (cons default aux-list))) + (if (and (stringp current) (not (file-directory-p current))) + (setq aux-list (cons current aux-list))) + (setq choices (nconc marked aux-list)) + (setq result (elt choices fileno)) + (or result + default))) + ((stringp default) default) + ((buffer-file-name (current-buffer)) + (file-name-nondirectory (buffer-file-name (current-buffer)))) + )) + +;;; Compare files/buffers + +;;;###autoload +(defun ediff-files (file-A file-B &optional startup-hooks) + "Run Ediff on a pair of files, FILE-A and FILE-B." + (interactive + (let ((dir-A (if ediff-use-last-dir + ediff-last-dir-A + default-directory)) + dir-B f) + (list (setq f (ediff-read-file-name + "File A to compare" + dir-A + (ediff-get-default-file-name) + 'no-dirs)) + (ediff-read-file-name "File B to compare" + (setq dir-B + (if ediff-use-last-dir + ediff-last-dir-B + (file-name-directory f))) + (progn + (ediff-add-to-history + 'file-name-history + (ediff-abbreviate-file-name + (expand-file-name + (file-name-nondirectory f) + dir-B))) + (ediff-get-default-file-name f 1))) + ))) + (ediff-files-internal file-A + (if (file-directory-p file-B) + (expand-file-name + (file-name-nondirectory file-A) file-B) + file-B) + nil ; file-C + startup-hooks + 'ediff-files)) + +;;;###autoload +(defun ediff-files3 (file-A file-B file-C &optional startup-hooks) + "Run Ediff on three files, FILE-A, FILE-B, and FILE-C." + (interactive + (let ((dir-A (if ediff-use-last-dir + ediff-last-dir-A + default-directory)) + dir-B dir-C f ff) + (list (setq f (ediff-read-file-name + "File A to compare" + dir-A + (ediff-get-default-file-name) + 'no-dirs)) + (setq ff (ediff-read-file-name "File B to compare" + (setq dir-B + (if ediff-use-last-dir + ediff-last-dir-B + (file-name-directory f))) + (progn + (ediff-add-to-history + 'file-name-history + (ediff-abbreviate-file-name + (expand-file-name + (file-name-nondirectory f) + dir-B))) + (ediff-get-default-file-name f 1)))) + (ediff-read-file-name "File C to compare" + (setq dir-C (if ediff-use-last-dir + ediff-last-dir-C + (file-name-directory ff))) + (progn + (ediff-add-to-history + 'file-name-history + (ediff-abbreviate-file-name + (expand-file-name + (file-name-nondirectory ff) + dir-C))) + (ediff-get-default-file-name ff 2))) + ))) + (ediff-files-internal file-A + (if (file-directory-p file-B) + (expand-file-name + (file-name-nondirectory file-A) file-B) + file-B) + (if (file-directory-p file-C) + (expand-file-name + (file-name-nondirectory file-A) file-C) + file-C) + startup-hooks + 'ediff-files3)) + +;;;###autoload +(defalias 'ediff3 'ediff-files3) + + +(defun ediff-find-file (file-var buffer-name &optional last-dir hooks-var) + "Visit FILE and arrange its buffer to Ediff's liking. +FILE-VAR is actually a variable symbol whose value must contain a true +file name. +BUFFER-NAME is a variable symbol, which will get the buffer object into +which FILE is read. +LAST-DIR is the directory variable symbol where FILE's +directory name should be returned. HOOKS-VAR is a variable symbol that will +be assigned the hook to be executed after `ediff-startup' is finished. +`ediff-find-file' arranges that the temp files it might create will be +deleted." + (let* ((file (symbol-value file-var)) + (file-magic (ediff-filename-magic-p file)) + (temp-file-name-prefix (file-name-nondirectory file))) + (cond ((not (file-readable-p file)) + (error "File `%s' does not exist or is not readable" file)) + ((file-directory-p file) + (error "File `%s' is a directory" file))) + + ;; some of the commands, below, require full file name + (setq file (expand-file-name file)) + + ;; Record the directory of the file + (if last-dir + (set last-dir (expand-file-name (file-name-directory file)))) + + ;; Setup the buffer + (set buffer-name (find-file-noselect file)) + + (ediff-with-current-buffer (symbol-value buffer-name) + (widen) ; Make sure the entire file is seen + (cond (file-magic ; file has a handler, such as jka-compr-handler or + ;;; ange-ftp-hook-function--arrange for temp file + (ediff-verify-file-buffer 'magic) + (setq file + (ediff-make-temp-file + (current-buffer) temp-file-name-prefix)) + (set hooks-var (cons `(lambda () (delete-file ,file)) + (symbol-value hooks-var)))) + ;; file processed via auto-mode-alist, a la uncompress.el + ((not (equal (file-truename file) + (file-truename (buffer-file-name)))) + (setq file + (ediff-make-temp-file + (current-buffer) temp-file-name-prefix)) + (set hooks-var (cons `(lambda () (delete-file ,file)) + (symbol-value hooks-var)))) + (t ;; plain file---just check that the file matches the buffer + (ediff-verify-file-buffer)))) + (set file-var file))) + +;; MERGE-BUFFER-FILE is the file to be associated with the merge buffer +(defun ediff-files-internal (file-A file-B file-C startup-hooks job-name + &optional merge-buffer-file) + (let (buf-A buf-B buf-C) + (if (string= file-A file-B) + (error "Files A and B are the same")) + (if (stringp file-C) + (or (and (string= file-A file-C) (error "Files A and C are the same")) + (and (string= file-B file-C) (error "Files B and C are the same")))) + (message "Reading file %s ... " file-A) + ;;(sit-for 0) + (ediff-find-file 'file-A 'buf-A 'ediff-last-dir-A 'startup-hooks) + (message "Reading file %s ... " file-B) + ;;(sit-for 0) + (ediff-find-file 'file-B 'buf-B 'ediff-last-dir-B 'startup-hooks) + (if (stringp file-C) + (progn + (message "Reading file %s ... " file-C) + ;;(sit-for 0) + (ediff-find-file + 'file-C 'buf-C + (if (eq job-name 'ediff-merge-files-with-ancestor) + 'ediff-last-dir-ancestor 'ediff-last-dir-C) + 'startup-hooks))) + (ediff-setup buf-A file-A + buf-B file-B + buf-C file-C + startup-hooks + (list (cons 'ediff-job-name job-name)) + merge-buffer-file))) + +(declare-function diff-latest-backup-file "diff" (fn)) + +;;;###autoload +(defalias 'ediff 'ediff-files) + +;;;###autoload +(defun ediff-current-file () + "Start ediff between current buffer and its file on disk. +This command can be used instead of `revert-buffer'. If there is +nothing to revert then this command fails." + (interactive) + (unless (or revert-buffer-function + revert-buffer-insert-file-contents-function + (and buffer-file-number + (or (buffer-modified-p) + (not (verify-visited-file-modtime + (current-buffer)))))) + (error "Nothing to revert")) + (let* ((auto-save-p (and (recent-auto-save-p) + buffer-auto-save-file-name + (file-readable-p buffer-auto-save-file-name) + (y-or-n-p + "Buffer has been auto-saved recently. Compare with auto-save file? "))) + (file-name (if auto-save-p + buffer-auto-save-file-name + buffer-file-name)) + (revert-buf-name (concat "FILE=" file-name)) + (revert-buf (get-buffer revert-buf-name)) + (current-major major-mode)) + (unless file-name + (error "Buffer does not seem to be associated with any file")) + (when revert-buf + (kill-buffer revert-buf) + (setq revert-buf nil)) + (setq revert-buf (get-buffer-create revert-buf-name)) + (with-current-buffer revert-buf + (insert-file-contents file-name) + ;; Assume same modes: + (funcall current-major)) + (ediff-buffers revert-buf (current-buffer)))) + + +;;;###autoload +(defun ediff-backup (file) + "Run Ediff on FILE and its backup file. +Uses the latest backup, if there are several numerical backups. +If this file is a backup, `ediff' it with its original." + (interactive (list (read-file-name "Ediff (file with backup): "))) + ;; The code is taken from `diff-backup'. + (require 'diff) + (let (bak ori) + (if (backup-file-name-p file) + (setq bak file + ori (file-name-sans-versions file)) + (setq bak (or (diff-latest-backup-file file) + (error "No backup found for %s" file)) + ori file)) + (ediff-files bak ori))) + +;;;###autoload +(defun ediff-buffers (buffer-A buffer-B &optional startup-hooks job-name) + "Run Ediff on a pair of buffers, BUFFER-A and BUFFER-B." + (interactive + (let (bf) + (list (setq bf (read-buffer "Buffer A to compare: " + (ediff-other-buffer "") t)) + (read-buffer "Buffer B to compare: " + (progn + ;; realign buffers so that two visible bufs will be + ;; at the top + (save-window-excursion (other-window 1)) + (ediff-other-buffer bf)) + t)))) + (or job-name (setq job-name 'ediff-buffers)) + (ediff-buffers-internal buffer-A buffer-B nil startup-hooks job-name)) + +;;;###autoload +(defalias 'ebuffers 'ediff-buffers) + + +;;;###autoload +(defun ediff-buffers3 (buffer-A buffer-B buffer-C + &optional startup-hooks job-name) + "Run Ediff on three buffers, BUFFER-A, BUFFER-B, and BUFFER-C." + (interactive + (let (bf bff) + (list (setq bf (read-buffer "Buffer A to compare: " + (ediff-other-buffer "") t)) + (setq bff (read-buffer "Buffer B to compare: " + (progn + ;; realign buffers so that two visible + ;; bufs will be at the top + (save-window-excursion (other-window 1)) + (ediff-other-buffer bf)) + t)) + (read-buffer "Buffer C to compare: " + (progn + ;; realign buffers so that three visible + ;; bufs will be at the top + (save-window-excursion (other-window 1)) + (ediff-other-buffer (list bf bff))) + t) + ))) + (or job-name (setq job-name 'ediff-buffers3)) + (ediff-buffers-internal buffer-A buffer-B buffer-C startup-hooks job-name)) + +;;;###autoload +(defalias 'ebuffers3 'ediff-buffers3) + + + +;; MERGE-BUFFER-FILE is the file to be associated with the merge buffer +(defun ediff-buffers-internal (buf-A buf-B buf-C startup-hooks job-name + &optional merge-buffer-file) + (let* ((buf-A-file-name (buffer-file-name (get-buffer buf-A))) + (buf-B-file-name (buffer-file-name (get-buffer buf-B))) + (buf-C-is-alive (ediff-buffer-live-p buf-C)) + (buf-C-file-name (if buf-C-is-alive + (buffer-file-name (get-buffer buf-B)))) + file-A file-B file-C) + (unwind-protect + (progn + (if (not (ediff-buffer-live-p buf-A)) + (error "Buffer %S doesn't exist" buf-A)) + (if (not (ediff-buffer-live-p buf-B)) + (error "Buffer %S doesn't exist" buf-B)) + (let ((ediff-job-name job-name)) + (if (and ediff-3way-comparison-job + (not buf-C-is-alive)) + (error "Buffer %S doesn't exist" buf-C))) + (if (stringp buf-A-file-name) + (setq buf-A-file-name (file-name-nondirectory buf-A-file-name))) + (if (stringp buf-B-file-name) + (setq buf-B-file-name (file-name-nondirectory buf-B-file-name))) + (if (stringp buf-C-file-name) + (setq buf-C-file-name (file-name-nondirectory buf-C-file-name))) + + (setq file-A (ediff-make-temp-file buf-A buf-A-file-name) + file-B (ediff-make-temp-file buf-B buf-B-file-name)) + (if buf-C-is-alive + (setq file-C (ediff-make-temp-file buf-C buf-C-file-name))) + + (ediff-setup (get-buffer buf-A) file-A + (get-buffer buf-B) file-B + (if buf-C-is-alive (get-buffer buf-C)) + file-C + (cons `(lambda () + (delete-file ,file-A) + (delete-file ,file-B) + (if (stringp ,file-C) (delete-file ,file-C))) + startup-hooks) + (list (cons 'ediff-job-name job-name)) + merge-buffer-file)) + (if (and (stringp file-A) (file-exists-p file-A)) + (delete-file file-A)) + (if (and (stringp file-B) (file-exists-p file-B)) + (delete-file file-B)) + (if (and (stringp file-C) (file-exists-p file-C)) + (delete-file file-C))))) + + +;;; Directory and file group operations + +;; Get appropriate default name for directory: +;; If ediff-use-last-dir, use ediff-last-dir-A. +;; In dired mode, use the directory that is under the point (if any); +;; otherwise, use default-directory +(defun ediff-get-default-directory-name () + (cond (ediff-use-last-dir ediff-last-dir-A) + ((eq major-mode 'dired-mode) + (let ((f (dired-get-filename nil 'noerror))) + (if (and (stringp f) (file-directory-p f)) + f + default-directory))) + (t default-directory))) + + +;;;###autoload +(defun ediff-directories (dir1 dir2 regexp) + "Run Ediff on a pair of directories, DIR1 and DIR2, comparing files that have +the same name in both. The third argument, REGEXP, is nil or a regular +expression; only file names that match the regexp are considered." + (interactive + (let ((dir-A (ediff-get-default-directory-name)) + (default-regexp (eval ediff-default-filtering-regexp)) + f) + (list (setq f (read-directory-name + "Directory A to compare:" dir-A nil 'must-match)) + (read-directory-name "Directory B to compare:" + (if ediff-use-last-dir + ediff-last-dir-B + (ediff-strip-last-dir f)) + nil 'must-match) + (read-string + (if (stringp default-regexp) + (format "Filter through regular expression (default %s): " + default-regexp) + "Filter through regular expression: ") + nil + 'ediff-filtering-regexp-history + (eval ediff-default-filtering-regexp)) + ))) + (ediff-directories-internal + dir1 dir2 nil regexp 'ediff-files 'ediff-directories + )) + +;;;###autoload +(defalias 'edirs 'ediff-directories) + + +;;;###autoload +(defun ediff-directory-revisions (dir1 regexp) + "Run Ediff on a directory, DIR1, comparing its files with their revisions. +The second argument, REGEXP, is a regular expression that filters the file +names. Only the files that are under revision control are taken into account." + (interactive + (let ((dir-A (ediff-get-default-directory-name)) + (default-regexp (eval ediff-default-filtering-regexp)) + ) + (list (read-directory-name + "Directory to compare with revision:" dir-A nil 'must-match) + (read-string + (if (stringp default-regexp) + (format "Filter through regular expression (default %s): " + default-regexp) + "Filter through regular expression: ") + nil + 'ediff-filtering-regexp-history + (eval ediff-default-filtering-regexp)) + ))) + (ediff-directory-revisions-internal + dir1 regexp 'ediff-revision 'ediff-directory-revisions + )) + +;;;###autoload +(defalias 'edir-revisions 'ediff-directory-revisions) + + +;;;###autoload +(defun ediff-directories3 (dir1 dir2 dir3 regexp) + "Run Ediff on three directories, DIR1, DIR2, and DIR3, comparing files that +have the same name in all three. The last argument, REGEXP, is nil or a +regular expression; only file names that match the regexp are considered." + + (interactive + (let ((dir-A (ediff-get-default-directory-name)) + (default-regexp (eval ediff-default-filtering-regexp)) + f) + (list (setq f (read-directory-name "Directory A to compare:" dir-A nil)) + (setq f (read-directory-name "Directory B to compare:" + (if ediff-use-last-dir + ediff-last-dir-B + (ediff-strip-last-dir f)) + nil 'must-match)) + (read-directory-name "Directory C to compare:" + (if ediff-use-last-dir + ediff-last-dir-C + (ediff-strip-last-dir f)) + nil 'must-match) + (read-string + (if (stringp default-regexp) + (format "Filter through regular expression (default %s): " + default-regexp) + "Filter through regular expression: ") + nil + 'ediff-filtering-regexp-history + (eval ediff-default-filtering-regexp)) + ))) + (ediff-directories-internal + dir1 dir2 dir3 regexp 'ediff-files3 'ediff-directories3 + )) + +;;;###autoload +(defalias 'edirs3 'ediff-directories3) + +;;;###autoload +(defun ediff-merge-directories (dir1 dir2 regexp &optional merge-autostore-dir) + "Run Ediff on a pair of directories, DIR1 and DIR2, merging files that have +the same name in both. The third argument, REGEXP, is nil or a regular +expression; only file names that match the regexp are considered." + (interactive + (let ((dir-A (ediff-get-default-directory-name)) + (default-regexp (eval ediff-default-filtering-regexp)) + f) + (list (setq f (read-directory-name "Directory A to merge:" + dir-A nil 'must-match)) + (read-directory-name "Directory B to merge:" + (if ediff-use-last-dir + ediff-last-dir-B + (ediff-strip-last-dir f)) + nil 'must-match) + (read-string + (if (stringp default-regexp) + (format "Filter through regular expression (default %s): " + default-regexp) + "Filter through regular expression: ") + nil + 'ediff-filtering-regexp-history + (eval ediff-default-filtering-regexp)) + ))) + (ediff-directories-internal + dir1 dir2 nil regexp 'ediff-merge-files 'ediff-merge-directories + nil merge-autostore-dir + )) + +;;;###autoload +(defalias 'edirs-merge 'ediff-merge-directories) + +;;;###autoload +(defun ediff-merge-directories-with-ancestor (dir1 dir2 ancestor-dir regexp + &optional + merge-autostore-dir) + "Merge files in directories DIR1 and DIR2 using files in ANCESTOR-DIR as ancestors. +Ediff merges files that have identical names in DIR1, DIR2. If a pair of files +in DIR1 and DIR2 doesn't have an ancestor in ANCESTOR-DIR, Ediff will merge +without ancestor. The fourth argument, REGEXP, is nil or a regular expression; +only file names that match the regexp are considered." + (interactive + (let ((dir-A (ediff-get-default-directory-name)) + (default-regexp (eval ediff-default-filtering-regexp)) + f) + (list (setq f (read-directory-name "Directory A to merge:" dir-A nil)) + (setq f (read-directory-name "Directory B to merge:" + (if ediff-use-last-dir + ediff-last-dir-B + (ediff-strip-last-dir f)) + nil 'must-match)) + (read-directory-name "Ancestor directory:" + (if ediff-use-last-dir + ediff-last-dir-C + (ediff-strip-last-dir f)) + nil 'must-match) + (read-string + (if (stringp default-regexp) + (format "Filter through regular expression (default %s): " + default-regexp) + "Filter through regular expression: ") + nil + 'ediff-filtering-regexp-history + (eval ediff-default-filtering-regexp)) + ))) + (ediff-directories-internal + dir1 dir2 ancestor-dir regexp + 'ediff-merge-files-with-ancestor 'ediff-merge-directories-with-ancestor + nil merge-autostore-dir + )) + +;;;###autoload +(defun ediff-merge-directory-revisions (dir1 regexp + &optional merge-autostore-dir) + "Run Ediff on a directory, DIR1, merging its files with their revisions. +The second argument, REGEXP, is a regular expression that filters the file +names. Only the files that are under revision control are taken into account." + (interactive + (let ((dir-A (ediff-get-default-directory-name)) + (default-regexp (eval ediff-default-filtering-regexp)) + ) + (list (read-directory-name + "Directory to merge with revisions:" dir-A nil 'must-match) + (read-string + (if (stringp default-regexp) + (format "Filter through regular expression (default %s): " + default-regexp) + "Filter through regular expression: ") + nil + 'ediff-filtering-regexp-history + (eval ediff-default-filtering-regexp)) + ))) + (ediff-directory-revisions-internal + dir1 regexp 'ediff-merge-revisions 'ediff-merge-directory-revisions + nil merge-autostore-dir + )) + +;;;###autoload +(defalias 'edir-merge-revisions 'ediff-merge-directory-revisions) + +;;;###autoload +(defun ediff-merge-directory-revisions-with-ancestor (dir1 regexp + &optional + merge-autostore-dir) + "Run Ediff on a directory, DIR1, merging its files with their revisions and ancestors. +The second argument, REGEXP, is a regular expression that filters the file +names. Only the files that are under revision control are taken into account." + (interactive + (let ((dir-A (ediff-get-default-directory-name)) + (default-regexp (eval ediff-default-filtering-regexp)) + ) + (list (read-directory-name + "Directory to merge with revisions and ancestors:" + dir-A nil 'must-match) + (read-string + (if (stringp default-regexp) + (format "Filter through regular expression (default %s): " + default-regexp) + "Filter through regular expression: ") + nil + 'ediff-filtering-regexp-history + (eval ediff-default-filtering-regexp)) + ))) + (ediff-directory-revisions-internal + dir1 regexp 'ediff-merge-revisions-with-ancestor + 'ediff-merge-directory-revisions-with-ancestor + nil merge-autostore-dir + )) + +;;;###autoload +(defalias + 'edir-merge-revisions-with-ancestor + 'ediff-merge-directory-revisions-with-ancestor) + +;;;###autoload +(defalias 'edirs-merge-with-ancestor 'ediff-merge-directories-with-ancestor) + +;; Run ediff-action (ediff-files, ediff-merge, ediff-merge-with-ancestors) +;; on a pair of directories (three directories, in case of ancestor). +;; The third argument, REGEXP, is nil or a regular expression; +;; only file names that match the regexp are considered. +;; JOBNAME is the symbol indicating the meta-job to be performed. +;; MERGE-AUTOSTORE-DIR is the directory in which to store merged files. +(defun ediff-directories-internal (dir1 dir2 dir3 regexp action jobname + &optional startup-hooks + merge-autostore-dir) + (if (stringp dir3) + (setq dir3 (if (file-directory-p dir3) dir3 (file-name-directory dir3)))) + + (cond ((string= dir1 dir2) + (error "Directories A and B are the same: %s" dir1)) + ((and (eq jobname 'ediff-directories3) + (string= dir1 dir3)) + (error "Directories A and C are the same: %s" dir1)) + ((and (eq jobname 'ediff-directories3) + (string= dir2 dir3)) + (error "Directories B and C are the same: %s" dir1))) + + (if merge-autostore-dir + (or (stringp merge-autostore-dir) + (error "%s: Directory for storing merged files must be a string" + jobname))) + (let (;; dir-diff-struct is of the form (common-list diff-list) + ;; It is a structure where ediff-intersect-directories returns + ;; commonalities and differences among directories + dir-diff-struct + meta-buf) + (if (and ediff-autostore-merges + (ediff-merge-metajob jobname) + (not merge-autostore-dir)) + (setq merge-autostore-dir + (read-directory-name "Save merged files in directory: " + (if ediff-use-last-dir + ediff-last-merge-autostore-dir + (ediff-strip-last-dir dir1)) + nil + 'must-match))) + ;; verify we are not merging into an orig directory + (if merge-autostore-dir + (cond ((and (stringp dir1) (string= merge-autostore-dir dir1)) + (or (y-or-n-p + "Directory for saving merged files = Directory A. Sure? ") + (error "Directory merge aborted"))) + ((and (stringp dir2) (string= merge-autostore-dir dir2)) + (or (y-or-n-p + "Directory for saving merged files = Directory B. Sure? ") + (error "Directory merge aborted"))) + ((and (stringp dir3) (string= merge-autostore-dir dir3)) + (or (y-or-n-p + "Directory for saving merged files = Ancestor Directory. Sure? ") + (error "Directory merge aborted"))))) + + (setq dir-diff-struct (ediff-intersect-directories + jobname + regexp dir1 dir2 dir3 merge-autostore-dir)) + (setq startup-hooks + ;; this sets various vars in the meta buffer inside + ;; ediff-prepare-meta-buffer + (cons `(lambda () + ;; tell what to do if the user clicks on a session record + (setq ediff-session-action-function (quote ,action)) + ;; set ediff-dir-difference-list + (setq ediff-dir-difference-list + (cdr (quote ,dir-diff-struct)))) + startup-hooks)) + (setq meta-buf (ediff-prepare-meta-buffer + 'ediff-filegroup-action + (car dir-diff-struct) + "*Ediff Session Group Panel" + 'ediff-redraw-directory-group-buffer + jobname + startup-hooks)) + (ediff-show-meta-buffer meta-buf) + )) + +;; MERGE-AUTOSTORE-DIR can be given to tell ediff where to store the merged +;; files +(defun ediff-directory-revisions-internal (dir1 regexp action jobname + &optional startup-hooks + merge-autostore-dir) + (setq dir1 (if (file-directory-p dir1) dir1 (file-name-directory dir1))) + + (if merge-autostore-dir + (or (stringp merge-autostore-dir) + (error "%S: Directory for storing merged files must be a string" + jobname))) + (let (file-list meta-buf) + (if (and ediff-autostore-merges + (ediff-merge-metajob jobname) + (not merge-autostore-dir)) + (setq merge-autostore-dir + (read-directory-name "Save merged files in directory: " + (if ediff-use-last-dir + ediff-last-merge-autostore-dir + (ediff-strip-last-dir dir1)) + nil + 'must-match))) + ;; verify merge-autostore-dir != dir1 + (if (and merge-autostore-dir + (stringp dir1) + (string= merge-autostore-dir dir1)) + (or (y-or-n-p + "Directory for saving merged file = directory A. Sure? ") + (error "Merge of directory revisions aborted"))) + + (setq file-list + (ediff-get-directory-files-under-revision + jobname regexp dir1 merge-autostore-dir)) + (setq startup-hooks + ;; this sets various vars in the meta buffer inside + ;; ediff-prepare-meta-buffer + (cons `(lambda () + ;; tell what to do if the user clicks on a session record + (setq ediff-session-action-function (quote ,action))) + startup-hooks)) + (setq meta-buf (ediff-prepare-meta-buffer + 'ediff-filegroup-action + file-list + "*Ediff Session Group Panel" + 'ediff-redraw-directory-group-buffer + jobname + startup-hooks)) + (ediff-show-meta-buffer meta-buf) + )) + + +;;; Compare regions and windows + +;;;###autoload +(defun ediff-windows-wordwise (dumb-mode &optional wind-A wind-B startup-hooks) + "Compare WIND-A and WIND-B, which are selected by clicking, wordwise. +With prefix argument, DUMB-MODE, or on a non-windowing display, works as +follows: +If WIND-A is nil, use selected window. +If WIND-B is nil, use window next to WIND-A." + (interactive "P") + (ediff-windows dumb-mode wind-A wind-B + startup-hooks 'ediff-windows-wordwise 'word-mode)) + +;;;###autoload +(defun ediff-windows-linewise (dumb-mode &optional wind-A wind-B startup-hooks) + "Compare WIND-A and WIND-B, which are selected by clicking, linewise. +With prefix argument, DUMB-MODE, or on a non-windowing display, works as +follows: +If WIND-A is nil, use selected window. +If WIND-B is nil, use window next to WIND-A." + (interactive "P") + (ediff-windows dumb-mode wind-A wind-B + startup-hooks 'ediff-windows-linewise nil)) + +;; Compare WIND-A and WIND-B, which are selected by clicking. +;; With prefix argument, DUMB-MODE, or on a non-windowing display, +;; works as follows: +;; If WIND-A is nil, use selected window. +;; If WIND-B is nil, use window next to WIND-A. +(defun ediff-windows (dumb-mode wind-A wind-B startup-hooks job-name word-mode) + (if (or dumb-mode (not (ediff-window-display-p))) + (setq wind-A (ediff-get-next-window wind-A nil) + wind-B (ediff-get-next-window wind-B wind-A)) + (setq wind-A (ediff-get-window-by-clicking wind-A nil 1) + wind-B (ediff-get-window-by-clicking wind-B wind-A 2))) + + (let ((buffer-A (window-buffer wind-A)) + (buffer-B (window-buffer wind-B)) + beg-A end-A beg-B end-B) + + (save-excursion + (save-window-excursion + (sit-for 0) ; sync before using window-start/end -- a precaution + (select-window wind-A) + (setq beg-A (window-start) + end-A (window-end)) + (select-window wind-B) + (setq beg-B (window-start) + end-B (window-end)))) + (setq buffer-A + (ediff-clone-buffer-for-window-comparison + buffer-A wind-A "-Window.A-") + buffer-B + (ediff-clone-buffer-for-window-comparison + buffer-B wind-B "-Window.B-")) + (ediff-regions-internal + buffer-A beg-A end-A buffer-B beg-B end-B + startup-hooks job-name word-mode nil))) + + +;;;###autoload +(defun ediff-regions-wordwise (buffer-A buffer-B &optional startup-hooks) + "Run Ediff on a pair of regions in specified buffers. +Regions \(i.e., point and mark\) can be set in advance or marked interactively. +This function is effective only for relatively small regions, up to 200 +lines. For large regions, use `ediff-regions-linewise'." + (interactive + (let (bf) + (list (setq bf (read-buffer "Region's A buffer: " + (ediff-other-buffer "") t)) + (read-buffer "Region's B buffer: " + (progn + ;; realign buffers so that two visible bufs will be + ;; at the top + (save-window-excursion (other-window 1)) + (ediff-other-buffer bf)) + t)))) + (if (not (ediff-buffer-live-p buffer-A)) + (error "Buffer %S doesn't exist" buffer-A)) + (if (not (ediff-buffer-live-p buffer-B)) + (error "Buffer %S doesn't exist" buffer-B)) + + + (let ((buffer-A + (ediff-clone-buffer-for-region-comparison buffer-A "-Region.A-")) + (buffer-B + (ediff-clone-buffer-for-region-comparison buffer-B "-Region.B-")) + reg-A-beg reg-A-end reg-B-beg reg-B-end) + (with-current-buffer buffer-A + (setq reg-A-beg (region-beginning) + reg-A-end (region-end)) + (set-buffer buffer-B) + (setq reg-B-beg (region-beginning) + reg-B-end (region-end))) + + (ediff-regions-internal + (get-buffer buffer-A) reg-A-beg reg-A-end + (get-buffer buffer-B) reg-B-beg reg-B-end + startup-hooks 'ediff-regions-wordwise 'word-mode nil))) + +;;;###autoload +(defun ediff-regions-linewise (buffer-A buffer-B &optional startup-hooks) + "Run Ediff on a pair of regions in specified buffers. +Regions \(i.e., point and mark\) can be set in advance or marked interactively. +Each region is enlarged to contain full lines. +This function is effective for large regions, over 100-200 +lines. For small regions, use `ediff-regions-wordwise'." + (interactive + (let (bf) + (list (setq bf (read-buffer "Region A's buffer: " + (ediff-other-buffer "") t)) + (read-buffer "Region B's buffer: " + (progn + ;; realign buffers so that two visible bufs will be + ;; at the top + (save-window-excursion (other-window 1)) + (ediff-other-buffer bf)) + t)))) + (if (not (ediff-buffer-live-p buffer-A)) + (error "Buffer %S doesn't exist" buffer-A)) + (if (not (ediff-buffer-live-p buffer-B)) + (error "Buffer %S doesn't exist" buffer-B)) + + (let ((buffer-A + (ediff-clone-buffer-for-region-comparison buffer-A "-Region.A-")) + (buffer-B + (ediff-clone-buffer-for-region-comparison buffer-B "-Region.B-")) + reg-A-beg reg-A-end reg-B-beg reg-B-end) + (with-current-buffer buffer-A + (setq reg-A-beg (region-beginning) + reg-A-end (region-end)) + ;; enlarge the region to hold full lines + (goto-char reg-A-beg) + (beginning-of-line) + (setq reg-A-beg (point)) + (goto-char reg-A-end) + (end-of-line) + (or (eobp) (forward-char)) ; include the newline char + (setq reg-A-end (point)) + + (set-buffer buffer-B) + (setq reg-B-beg (region-beginning) + reg-B-end (region-end)) + ;; enlarge the region to hold full lines + (goto-char reg-B-beg) + (beginning-of-line) + (setq reg-B-beg (point)) + (goto-char reg-B-end) + (end-of-line) + (or (eobp) (forward-char)) ; include the newline char + (setq reg-B-end (point)) + ) ; save excursion + + (ediff-regions-internal + (get-buffer buffer-A) reg-A-beg reg-A-end + (get-buffer buffer-B) reg-B-beg reg-B-end + startup-hooks 'ediff-regions-linewise nil nil))) ; no word mode + +;; compare region beg-A to end-A of buffer-A +;; to regions beg-B -- end-B in buffer-B. +(defun ediff-regions-internal (buffer-A beg-A end-A buffer-B beg-B end-B + startup-hooks job-name word-mode + setup-parameters) + (let ((tmp-buffer (get-buffer-create ediff-tmp-buffer)) + overl-A overl-B + file-A file-B) + (unwind-protect + (progn + ;; in case beg/end-A/B aren't markers--make them into markers + (ediff-with-current-buffer buffer-A + (setq beg-A (move-marker (make-marker) beg-A) + end-A (move-marker (make-marker) end-A))) + (ediff-with-current-buffer buffer-B + (setq beg-B (move-marker (make-marker) beg-B) + end-B (move-marker (make-marker) end-B))) + + ;; make file-A + (if word-mode + (ediff-wordify beg-A end-A buffer-A tmp-buffer) + (ediff-copy-to-buffer beg-A end-A buffer-A tmp-buffer)) + (setq file-A (ediff-make-temp-file tmp-buffer "regA")) + + ;; make file-B + (if word-mode + (ediff-wordify beg-B end-B buffer-B tmp-buffer) + (ediff-copy-to-buffer beg-B end-B buffer-B tmp-buffer)) + (setq file-B (ediff-make-temp-file tmp-buffer "regB")) + + (setq overl-A (ediff-make-bullet-proof-overlay beg-A end-A buffer-A)) + (setq overl-B (ediff-make-bullet-proof-overlay beg-B end-B buffer-B)) + (ediff-setup buffer-A file-A + buffer-B file-B + nil nil ; buffer & file C + (cons `(lambda () + (delete-file ,file-A) + (delete-file ,file-B)) + startup-hooks) + (append + (list (cons 'ediff-word-mode word-mode) + (cons 'ediff-narrow-bounds (list overl-A overl-B)) + (cons 'ediff-job-name job-name)) + setup-parameters))) + (if (and (stringp file-A) (file-exists-p file-A)) + (delete-file file-A)) + (if (and (stringp file-B) (file-exists-p file-B)) + (delete-file file-B))) + )) + + +;;; Merge files and buffers + +;;;###autoload +(defalias 'ediff-merge 'ediff-merge-files) + +(defsubst ediff-merge-on-startup () + (ediff-do-merge 0) + ;; Can't remember why this is here, but it may cause the automatically merged + ;; buffer to be lost. So, keep the buffer modified. + ;;(ediff-with-current-buffer ediff-buffer-C + ;; (set-buffer-modified-p nil)) + ) + +;;;###autoload +(defun ediff-merge-files (file-A file-B + ;; MERGE-BUFFER-FILE is the file to be + ;; associated with the merge buffer + &optional startup-hooks merge-buffer-file) + "Merge two files without ancestor." + (interactive + (let ((dir-A (if ediff-use-last-dir + ediff-last-dir-A + default-directory)) + dir-B f) + (list (setq f (ediff-read-file-name + "File A to merge" + dir-A + (ediff-get-default-file-name) + 'no-dirs)) + (ediff-read-file-name "File B to merge" + (setq dir-B + (if ediff-use-last-dir + ediff-last-dir-B + (file-name-directory f))) + (progn + (ediff-add-to-history + 'file-name-history + (ediff-abbreviate-file-name + (expand-file-name + (file-name-nondirectory f) + dir-B))) + (ediff-get-default-file-name f 1))) + ))) + (setq startup-hooks (cons 'ediff-merge-on-startup startup-hooks)) + (ediff-files-internal file-A + (if (file-directory-p file-B) + (expand-file-name + (file-name-nondirectory file-A) file-B) + file-B) + nil ; file-C + startup-hooks + 'ediff-merge-files + merge-buffer-file)) + +;;;###autoload +(defun ediff-merge-files-with-ancestor (file-A file-B file-ancestor + &optional + startup-hooks + ;; MERGE-BUFFER-FILE is the file + ;; to be associated with the + ;; merge buffer + merge-buffer-file) + "Merge two files with ancestor." + (interactive + (let ((dir-A (if ediff-use-last-dir + ediff-last-dir-A + default-directory)) + dir-B dir-ancestor f ff) + (list (setq f (ediff-read-file-name + "File A to merge" + dir-A + (ediff-get-default-file-name) + 'no-dirs)) + (setq ff (ediff-read-file-name "File B to merge" + (setq dir-B + (if ediff-use-last-dir + ediff-last-dir-B + (file-name-directory f))) + (progn + (ediff-add-to-history + 'file-name-history + (ediff-abbreviate-file-name + (expand-file-name + (file-name-nondirectory f) + dir-B))) + (ediff-get-default-file-name f 1)))) + (ediff-read-file-name "Ancestor file" + (setq dir-ancestor + (if ediff-use-last-dir + ediff-last-dir-ancestor + (file-name-directory ff))) + (progn + (ediff-add-to-history + 'file-name-history + (ediff-abbreviate-file-name + (expand-file-name + (file-name-nondirectory ff) + dir-ancestor))) + (ediff-get-default-file-name ff 2))) + ))) + (setq startup-hooks (cons 'ediff-merge-on-startup startup-hooks)) + (ediff-files-internal file-A + (if (file-directory-p file-B) + (expand-file-name + (file-name-nondirectory file-A) file-B) + file-B) + file-ancestor + startup-hooks + 'ediff-merge-files-with-ancestor + merge-buffer-file)) + +;;;###autoload +(defalias 'ediff-merge-with-ancestor 'ediff-merge-files-with-ancestor) + +;;;###autoload +(defun ediff-merge-buffers (buffer-A buffer-B + &optional + ;; MERGE-BUFFER-FILE is the file to be + ;; associated with the merge buffer + startup-hooks job-name merge-buffer-file) + "Merge buffers without ancestor." + (interactive + (let (bf) + (list (setq bf (read-buffer "Buffer A to merge: " + (ediff-other-buffer "") t)) + (read-buffer "Buffer B to merge: " + (progn + ;; realign buffers so that two visible bufs will be + ;; at the top + (save-window-excursion (other-window 1)) + (ediff-other-buffer bf)) + t)))) + + (setq startup-hooks (cons 'ediff-merge-on-startup startup-hooks)) + (or job-name (setq job-name 'ediff-merge-buffers)) + (ediff-buffers-internal + buffer-A buffer-B nil startup-hooks job-name merge-buffer-file)) + +;;;###autoload +(defun ediff-merge-buffers-with-ancestor (buffer-A buffer-B buffer-ancestor + &optional + startup-hooks + job-name + ;; MERGE-BUFFER-FILE is the + ;; file to be associated + ;; with the merge buffer + merge-buffer-file) + "Merge buffers with ancestor." + (interactive + (let (bf bff) + (list (setq bf (read-buffer "Buffer A to merge: " + (ediff-other-buffer "") t)) + (setq bff (read-buffer "Buffer B to merge: " + (progn + ;; realign buffers so that two visible + ;; bufs will be at the top + (save-window-excursion (other-window 1)) + (ediff-other-buffer bf)) + t)) + (read-buffer "Ancestor buffer: " + (progn + ;; realign buffers so that three visible + ;; bufs will be at the top + (save-window-excursion (other-window 1)) + (ediff-other-buffer (list bf bff))) + t) + ))) + + (setq startup-hooks (cons 'ediff-merge-on-startup startup-hooks)) + (or job-name (setq job-name 'ediff-merge-buffers-with-ancestor)) + (ediff-buffers-internal + buffer-A buffer-B buffer-ancestor startup-hooks job-name merge-buffer-file)) + + +;;;###autoload +(defun ediff-merge-revisions (&optional file startup-hooks merge-buffer-file) + ;; MERGE-BUFFER-FILE is the file to be associated with the merge buffer + "Run Ediff by merging two revisions of a file. +The file is the optional FILE argument or the file visited by the current +buffer." + (interactive) + (if (stringp file) (find-file file)) + (let (rev1 rev2) + (setq rev1 + (read-string + (format + "Version 1 to merge (default %s's working version): " + (if (stringp file) + (file-name-nondirectory file) "current buffer"))) + rev2 + (read-string + (format + "Version 2 to merge (default %s): " + (if (stringp file) + (file-name-nondirectory file) "current buffer")))) + (ediff-load-version-control) + ;; ancestor-revision=nil + (funcall + (intern (format "ediff-%S-merge-internal" ediff-version-control-package)) + rev1 rev2 nil startup-hooks merge-buffer-file))) + + +;;;###autoload +(defun ediff-merge-revisions-with-ancestor (&optional + file startup-hooks + ;; MERGE-BUFFER-FILE is the file to + ;; be associated with the merge + ;; buffer + merge-buffer-file) + "Run Ediff by merging two revisions of a file with a common ancestor. +The file is the optional FILE argument or the file visited by the current +buffer." + (interactive) + (if (stringp file) (find-file file)) + (let (rev1 rev2 ancestor-rev) + (setq rev1 + (read-string + (format + "Version 1 to merge (default %s's working version): " + (if (stringp file) + (file-name-nondirectory file) "current buffer"))) + rev2 + (read-string + (format + "Version 2 to merge (default %s): " + (if (stringp file) + (file-name-nondirectory file) "current buffer"))) + ancestor-rev + (read-string + (format + "Ancestor version (default %s's base revision): " + (if (stringp file) + (file-name-nondirectory file) "current buffer")))) + (ediff-load-version-control) + (funcall + (intern (format "ediff-%S-merge-internal" ediff-version-control-package)) + rev1 rev2 ancestor-rev startup-hooks merge-buffer-file))) + +;;; Apply patch + +;;;###autoload +(defun ediff-patch-file (&optional arg patch-buf) + "Run Ediff by patching SOURCE-FILENAME. +If optional PATCH-BUF is given, use the patch in that buffer +and don't ask the user. +If prefix argument, then: if even argument, assume that the patch is in a +buffer. If odd -- assume it is in a file." + (interactive "P") + (let (source-dir source-file) + (require 'ediff-ptch) + (setq patch-buf + (ediff-get-patch-buffer + (if arg (prefix-numeric-value arg)) patch-buf)) + (setq source-dir (cond (ediff-use-last-dir ediff-last-dir-patch) + ((and (not ediff-patch-default-directory) + (buffer-file-name patch-buf)) + (file-name-directory + (expand-file-name + (buffer-file-name patch-buf)))) + (t default-directory))) + (setq source-file + (read-file-name + "File to patch (directory, if multifile patch): " + ;; use an explicit initial file + source-dir nil nil (ediff-get-default-file-name))) + (ediff-dispatch-file-patching-job patch-buf source-file))) + +;;;###autoload +(defun ediff-patch-buffer (&optional arg patch-buf) + "Run Ediff by patching the buffer specified at prompt. +Without the optional prefix ARG, asks if the patch is in some buffer and +prompts for the buffer or a file, depending on the answer. +With ARG=1, assumes the patch is in a file and prompts for the file. +With ARG=2, assumes the patch is in a buffer and prompts for the buffer. +PATCH-BUF is an optional argument, which specifies the buffer that contains the +patch. If not given, the user is prompted according to the prefix argument." + (interactive "P") + (require 'ediff-ptch) + (setq patch-buf + (ediff-get-patch-buffer + (if arg (prefix-numeric-value arg)) patch-buf)) + (ediff-patch-buffer-internal + patch-buf + (read-buffer + "Which buffer to patch? " + (ediff-other-buffer patch-buf)))) + + +;;;###autoload +(defalias 'epatch 'ediff-patch-file) +;;;###autoload +(defalias 'epatch-buffer 'ediff-patch-buffer) + + + + +;;; Versions Control functions + +;;;###autoload +(defun ediff-revision (&optional file startup-hooks) + "Run Ediff by comparing versions of a file. +The file is an optional FILE argument or the file entered at the prompt. +Default: the file visited by the current buffer. +Uses `vc.el' or `rcs.el' depending on `ediff-version-control-package'." + ;; if buffer is non-nil, use that buffer instead of the current buffer + (interactive "P") + (if (not (stringp file)) + (setq file + (ediff-read-file-name "Compare revisions for file" + (if ediff-use-last-dir + ediff-last-dir-A + default-directory) + (ediff-get-default-file-name) + 'no-dirs))) + (find-file file) + (if (and (buffer-modified-p) + (y-or-n-p (format "Buffer %s is modified. Save buffer? " + (buffer-name)))) + (save-buffer (current-buffer))) + (let (rev1 rev2) + (setq rev1 + (read-string + (format "Revision 1 to compare (default %s's latest revision): " + (file-name-nondirectory file))) + rev2 + (read-string + (format "Revision 2 to compare (default %s's current state): " + (file-name-nondirectory file)))) + (ediff-load-version-control) + (funcall + (intern (format "ediff-%S-internal" ediff-version-control-package)) + rev1 rev2 startup-hooks) + )) + + +;;;###autoload +(defalias 'erevision 'ediff-revision) + + +;; Test if version control package is loaded and load if not +;; Is SILENT is non-nil, don't report error if package is not found. +(defun ediff-load-version-control (&optional silent) + (require 'ediff-vers) + (or (featurep ediff-version-control-package) + (if (locate-library (symbol-name ediff-version-control-package)) + (progn + (message "") ; kill the message from `locate-library' + (require ediff-version-control-package)) + (or silent + (error "Version control package %S.el not found. Use vc.el instead" + ediff-version-control-package))))) + + +;;;###autoload +(defun ediff-version () + "Return string describing the version of Ediff. +When called interactively, displays the version." + (interactive) + ;; called-interactively-p - not in XEmacs + ;; (if (called-interactively-p 'interactive) + (if (interactive-p) + (message "%s" (ediff-version)) + (format "Ediff %s of %s" ediff-version ediff-date))) + +;; info is run first, and will autoload info.el. +(declare-function Info-goto-node "info" (nodename &optional fork)) + +;;;###autoload +(defun ediff-documentation (&optional node) + "Display Ediff's manual. +With optional NODE, goes to that node." + (interactive) + (let ((ctl-window ediff-control-window) + (ctl-buf ediff-control-buffer)) + + (ediff-skip-unsuitable-frames) + (condition-case nil + (progn + (pop-to-buffer (get-buffer-create "*info*")) + (info (if (featurep 'xemacs) "ediff.info" "ediff")) + (if node + (Info-goto-node node) + (message "Type `i' to search for a specific topic")) + (raise-frame (selected-frame))) + (error (beep 1) + (with-output-to-temp-buffer ediff-msg-buffer + (ediff-with-current-buffer standard-output + (fundamental-mode)) + (princ ediff-BAD-INFO)) + (if (window-live-p ctl-window) + (progn + (select-window ctl-window) + (set-window-buffer ctl-window ctl-buf))))))) + + +(dolist (mess '("^Errors in diff output. Diff output is in " + "^Hmm... I don't see an Ediff command around here...$" + "^Undocumented command! Type `G' in Ediff Control Panel to drop a note to the Ediff maintainer$" + ": This command runs in Ediff Control Buffer only!$" + ": Invalid op in ediff-check-version$" + "^ediff-shrink-window-C can be used only for merging jobs$" + "^Lost difference info on these directories$" + "^This command is inapplicable in the present context$" + "^This session group has no parent$" + "^Can't hide active session, $" + "^Ediff: something wrong--no multiple diffs buffer$" + "^Can't make context diff for Session $" + "^The patch buffer wasn't found$" + "^Aborted$" + "^This Ediff session is not part of a session group$" + "^No active Ediff sessions or corrupted session registry$" + "^No session info in this line$" + "^`.*' is not an ordinary file$" + "^Patch appears to have failed$" + "^Recomputation of differences cancelled$" + "^No fine differences in this mode$" + "^Lost connection to ancestor buffer...sorry$" + "^Not merging with ancestor$" + "^Don't know how to toggle read-only in buffer " + "Emacs is not running as a window application$" + "^This command makes sense only when merging with an ancestor$" + "^At end of the difference list$" + "^At beginning of the difference list$" + "^Nothing saved for diff .* in buffer " + "^Buffer is out of sync for file " + "^Buffer out of sync for file " + "^Output from `diff' not found$" + "^You forgot to specify a region in buffer " + "^All right. Make up your mind and come back...$" + "^Current buffer is not visiting any file$" + "^Failed to retrieve revision: $" + "^Can't determine display width.$" + "^File `.*' does not exist or is not readable$" + "^File `.*' is a directory$" + "^Buffer .* doesn't exist$" + "^Directories . and . are the same: " + "^Directory merge aborted$" + "^Merge of directory revisions aborted$" + "^Buffer .* doesn't exist$" + "^There is no file to merge$" + "^Version control package .*.el not found. Use vc.el instead$")) + (add-to-list 'debug-ignored-errors mess)) + + +(require 'ediff-util) + +(run-hooks 'ediff-load-hook) + + +;; Local Variables: +;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun) +;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1) +;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body)) +;; End: + +;; arch-tag: 97c71396-db02-4f41-8b48-6a51c3348fcc +;;; ediff.el ends here diff --cc lisp/vc/log-edit.el index c7f37c50011,00000000000..94e70ff2b33 mode 100644,000000..100644 --- a/lisp/vc/log-edit.el +++ b/lisp/vc/log-edit.el @@@ -1,879 -1,0 +1,879 @@@ +;;; log-edit.el --- Major mode for editing CVS commit messages + +;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, - ;; 2008, 2009, 2010 Free Software Foundation, Inc. ++;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc. + +;; Author: Stefan Monnier +;; Keywords: pcl-cvs cvs commit log vc + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Todo: + +;; - Move in VC's code +;; - Add compatibility for VC's hook variables + +;;; Code: + +(eval-when-compile (require 'cl)) +(require 'add-log) ; for all the ChangeLog goodies +(require 'pcvs-util) +(require 'ring) + +;;;; +;;;; Global Variables +;;;; + +(defgroup log-edit nil + "Major mode for editing RCS and CVS commit messages." + :group 'pcl-cvs + :group 'vc ; It's used by VC. + :version "21.1" + :prefix "log-edit-") + +;; compiler pacifiers +(defvar cvs-buffer) + + +;; The main keymap + +(easy-mmode-defmap log-edit-mode-map + `(("\C-c\C-c" . log-edit-done) + ("\C-c\C-a" . log-edit-insert-changelog) + ("\C-c\C-d" . log-edit-show-diff) + ("\C-c\C-f" . log-edit-show-files) + ("\M-n" . log-edit-next-comment) + ("\M-p" . log-edit-previous-comment) + ("\M-r" . log-edit-comment-search-backward) + ("\M-s" . log-edit-comment-search-forward) + ("\C-c?" . log-edit-mode-help)) + "Keymap for the `log-edit-mode' (to edit version control log messages)." + :group 'log-edit) + +;; Compatibility with old names. Should we bother ? +(defvar vc-log-mode-map log-edit-mode-map) +(defvar vc-log-entry-mode vc-log-mode-map) + +(easy-menu-define log-edit-menu log-edit-mode-map + "Menu used for `log-edit-mode'." + '("Log-Edit" + ["Done" log-edit-done + :help "Exit log-edit and proceed with the actual action."] + "--" + ["Insert ChangeLog" log-edit-insert-changelog + :help "Insert a log message by looking at the ChangeLog"] + ["Add to ChangeLog" log-edit-add-to-changelog + :help "Insert this log message into the appropriate ChangeLog file"] + "--" + ["Show diff" log-edit-show-diff + :help "Show the diff for the files to be committed."] + ["List files" log-edit-show-files + :help "Show the list of relevant files."] + "--" + ["Previous comment" log-edit-previous-comment + :help "Cycle backwards through comment history"] + ["Next comment" log-edit-next-comment + :help "Cycle forwards through comment history."] + ["Search comment forward" log-edit-comment-search-forward + :help "Search forwards through comment history for a substring match of str"] + ["Search comment backward" log-edit-comment-search-backward + :help "Search backwards through comment history for substring match of str"])) + +(defcustom log-edit-confirm 'changed + "If non-nil, `log-edit-done' will request confirmation. +If 'changed, only request confirmation if the list of files has + changed since the beginning of the log-edit session." + :group 'log-edit + :type '(choice (const changed) (const t) (const nil))) + +(defcustom log-edit-keep-buffer nil + "If non-nil, don't hide the buffer after `log-edit-done'." + :group 'log-edit + :type 'boolean) + +(defvar cvs-commit-buffer-require-final-newline t) +(make-obsolete-variable 'cvs-commit-buffer-require-final-newline + 'log-edit-require-final-newline + "21.1") + +(defcustom log-edit-require-final-newline + cvs-commit-buffer-require-final-newline + "Enforce a newline at the end of commit log messages. +Enforce it silently if t, query if non-nil and don't do anything if nil." + :group 'log-edit + :type '(choice (const ask) (const t) (const nil))) + +(defcustom log-edit-setup-invert nil + "Non-nil means `log-edit' should invert the meaning of its SETUP arg. +If SETUP is 'force, this variable has no effect." + :group 'log-edit + :type 'boolean) + +(defcustom log-edit-hook '(log-edit-insert-cvs-template + log-edit-show-files + log-edit-insert-changelog) + "Hook run at the end of `log-edit'." + :group 'log-edit + :type '(hook :options (log-edit-insert-changelog + log-edit-insert-cvs-rcstemplate + log-edit-insert-cvs-template + log-edit-insert-filenames))) + +(defcustom log-edit-mode-hook (if (boundp 'vc-log-mode-hook) vc-log-mode-hook) + "Hook run when entering `log-edit-mode'." + :group 'log-edit + :type 'hook) + +(defcustom log-edit-done-hook nil + "Hook run before doing the actual commit. +This hook can be used to cleanup the message, enforce various +conventions, or to allow recording the message in some other database, +such as a bug-tracking system. The list of files about to be committed +can be obtained from `log-edit-files'." + :group 'log-edit + :type '(hook :options (log-edit-set-common-indentation + log-edit-add-to-changelog))) + +(defcustom log-edit-strip-single-file-name nil + "If non-nil, remove file name from single-file log entries." + :type 'boolean + :safe 'booleanp + :group 'log-edit + :version "24.1") + +(defvar cvs-changelog-full-paragraphs t) +(make-obsolete-variable 'cvs-changelog-full-paragraphs + 'log-edit-changelog-full-paragraphs + "21.1") + +(defvar log-edit-changelog-full-paragraphs cvs-changelog-full-paragraphs + "*If non-nil, include full ChangeLog paragraphs in the log. +This may be set in the ``local variables'' section of a ChangeLog, to +indicate the policy for that ChangeLog. + +A ChangeLog paragraph is a bunch of log text containing no blank lines; +a paragraph usually describes a set of changes with a single purpose, +but perhaps spanning several functions in several files. Changes in +different paragraphs are unrelated. + +You could argue that the log entry for a file should contain the +full ChangeLog paragraph mentioning the change to the file, even though +it may mention other files, because that gives you the full context you +need to understand the change. This is the behavior you get when this +variable is set to t. + +On the other hand, you could argue that the log entry for a change +should contain only the text for the changes which occurred in that +file, because the log is per-file. This is the behavior you get +when this variable is set to nil.") + +;;;; Internal global or buffer-local vars + +(defconst log-edit-files-buf "*log-edit-files*") +(defvar log-edit-initial-files nil) +(defvar log-edit-callback nil) +(defvar log-edit-diff-function nil) +(defvar log-edit-listfun nil) + +(defvar log-edit-parent-buffer nil) + +;;; Originally taken from VC-Log mode + +(defconst log-edit-maximum-comment-ring-size 32 + "Maximum number of saved comments in the comment ring.") +(defvar log-edit-comment-ring (make-ring log-edit-maximum-comment-ring-size)) +(defvar log-edit-comment-ring-index nil) +(defvar log-edit-last-comment-match "") + +(defun log-edit-new-comment-index (stride len) + "Return the comment index STRIDE elements from the current one. +LEN is the length of `log-edit-comment-ring'." + (mod (cond + (log-edit-comment-ring-index (+ log-edit-comment-ring-index stride)) + ;; Initialize the index on the first use of this command + ;; so that the first M-p gets index 0, and the first M-n gets + ;; index -1. + ((> stride 0) (1- stride)) + (t stride)) + len)) + +(defun log-edit-previous-comment (arg) + "Cycle backwards through comment history. +With a numeric prefix ARG, go back ARG comments." + (interactive "*p") + (let ((len (ring-length log-edit-comment-ring))) + (if (<= len 0) + (progn (message "Empty comment ring") (ding)) + ;; Don't use `erase-buffer' because we don't want to `widen'. + (delete-region (point-min) (point-max)) + (setq log-edit-comment-ring-index (log-edit-new-comment-index arg len)) + (message "Comment %d" (1+ log-edit-comment-ring-index)) + (insert (ring-ref log-edit-comment-ring log-edit-comment-ring-index))))) + +(defun log-edit-next-comment (arg) + "Cycle forwards through comment history. +With a numeric prefix ARG, go forward ARG comments." + (interactive "*p") + (log-edit-previous-comment (- arg))) + +(defun log-edit-comment-search-backward (str &optional stride) + "Search backwards through comment history for substring match of STR. +If the optional argument STRIDE is present, that is a step-width to use +when going through the comment ring." + ;; Why substring rather than regexp ? -sm + (interactive + (list (read-string "Comment substring: " nil nil log-edit-last-comment-match))) + (unless stride (setq stride 1)) + (if (string= str "") + (setq str log-edit-last-comment-match) + (setq log-edit-last-comment-match str)) + (let* ((str (regexp-quote str)) + (len (ring-length log-edit-comment-ring)) + (n (log-edit-new-comment-index stride len))) + (while (progn (when (or (>= n len) (< n 0)) (error "Not found")) + (not (string-match str (ring-ref log-edit-comment-ring n)))) + (setq n (+ n stride))) + (setq log-edit-comment-ring-index n) + (log-edit-previous-comment 0))) + +(defun log-edit-comment-search-forward (str) + "Search forwards through comment history for a substring match of STR." + (interactive + (list (read-string "Comment substring: " nil nil log-edit-last-comment-match))) + (log-edit-comment-search-backward str -1)) + +(defun log-edit-comment-to-change-log (&optional whoami file-name) + "Enter last VC comment into the change log for the current file. +WHOAMI (interactive prefix) non-nil means prompt for user name +and site. FILE-NAME is the name of the change log; if nil, use +`change-log-default-name'. + +This may be useful as a `log-edit-checkin-hook' to update change logs +automatically." + (interactive (if current-prefix-arg + (list current-prefix-arg + (prompt-for-change-log-name)))) + (let (;; Extract the comment first so we get any error before doing anything. + (comment (ring-ref log-edit-comment-ring 0)) + ;; Don't let add-change-log-entry insert a defun name. + (add-log-current-defun-function 'ignore) + end) + ;; Call add-log to do half the work. + (add-change-log-entry whoami file-name t t) + ;; Insert the VC comment, leaving point before it. + (setq end (save-excursion (insert comment) (point-marker))) + (if (looking-at "\\s *\\s(") + ;; It starts with an open-paren, as in "(foo): Frobbed." + ;; So remove the ": " add-log inserted. + (delete-char -2)) + ;; Canonicalize the white space between the file name and comment. + (just-one-space) + ;; Indent rest of the text the same way add-log indented the first line. + (let ((indentation (current-indentation))) + (save-excursion + (while (< (point) end) + (forward-line 1) + (indent-to indentation)) + (setq end (point)))) + ;; Fill the inserted text, preserving open-parens at bol. + (let ((paragraph-start (concat paragraph-start "\\|\\s *\\s("))) + (beginning-of-line) + (fill-region (point) end)) + ;; Canonicalize the white space at the end of the entry so it is + ;; separated from the next entry by a single blank line. + (skip-syntax-forward " " end) + (delete-char (- (skip-syntax-backward " "))) + (or (eobp) (looking-at "\n\n") + (insert "\n")))) + +;; Compatibility with old names. +(define-obsolete-variable-alias 'vc-comment-ring 'log-edit-comment-ring "22.1") +(define-obsolete-variable-alias 'vc-comment-ring-index 'log-edit-comment-ring-index "22.1") +(define-obsolete-function-alias 'vc-previous-comment 'log-edit-previous-comment "22.1") +(define-obsolete-function-alias 'vc-next-comment 'log-edit-next-comment "22.1") +(define-obsolete-function-alias 'vc-comment-search-reverse 'log-edit-comment-search-backward "22.1") +(define-obsolete-function-alias 'vc-comment-search-forward 'log-edit-comment-search-forward "22.1") +(define-obsolete-function-alias 'vc-comment-to-change-log 'log-edit-comment-to-change-log "22.1") + +;;; +;;; Actual code +;;; + +(defface log-edit-summary '((t :inherit font-lock-function-name-face)) + "Face for the summary in `log-edit-mode' buffers.") + +(defface log-edit-header '((t :inherit font-lock-keyword-face)) + "Face for the headers in `log-edit-mode' buffers.") + +(defface log-edit-unknown-header '((t :inherit font-lock-comment-face)) + "Face for unknown headers in `log-edit-mode' buffers.") + +(defvar log-edit-headers-alist '(("Summary" . log-edit-summary) + ("Fixes") ("Author")) + "AList of known headers and the face to use to highlight them.") + +(defconst log-edit-header-contents-regexp + "[ \t]*\\(.*\\(\n[ \t].*\\)*\\)\n?") + +(defun log-edit-match-to-eoh (limit) + ;; FIXME: copied from message-match-to-eoh. + (let ((start (point))) + (rfc822-goto-eoh) + ;; Typical situation: some temporary change causes the header to be + ;; incorrect, so EOH comes earlier than intended: the last lines of the + ;; intended headers are now not considered part of the header any more, + ;; so they don't have the multiline property set. When the change is + ;; completed and the header has its correct shape again, the lack of the + ;; multiline property means we won't rehighlight the last lines of + ;; the header. + (if (< (point) start) + nil ;No header within start..limit. + ;; Here we disregard LIMIT so that we may extend the area again. + (set-match-data (list start (point))) + (point)))) + +(defvar log-edit-font-lock-keywords + ;; Copied/inspired by message-font-lock-keywords. + `((log-edit-match-to-eoh + (,(concat "^\\(\\([a-z]+\\):\\)" log-edit-header-contents-regexp) + (progn (goto-char (match-beginning 0)) (match-end 0)) nil + (1 (if (assoc (match-string 2) log-edit-headers-alist) + 'log-edit-header + 'log-edit-unknown-header) + nil lax) + ;; 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. +\\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 diff --cc lisp/vc/log-view.el index ac32cea6202,00000000000..fbcb88b3f72 mode 100644,000000..100644 --- a/lisp/vc/log-view.el +++ b/lisp/vc/log-view.el @@@ -1,546 -1,0 +1,546 @@@ +;;; log-view.el --- Major mode for browsing RCS/CVS/SCCS log output + +;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, - ;; 2008, 2009, 2010 Free Software Foundation, Inc. ++;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc. + +;; Author: Stefan Monnier +;; Keywords: rcs, sccs, cvs, log, vc, tools + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Major mode to browse revision log histories. +;; Currently supports the format output by: +;; RCS, SCCS, CVS, Subversion, and DaRCS. + +;; Examples of log output: + +;;;; RCS/CVS: + +;; ---------------------------- +;; revision 1.35 locked by: turlutut +;; date: 2005-03-22 18:48:38 +0000; author: monnier; state: Exp; lines: +6 -8 +;; (gnus-display-time-event-handler): +;; Check display-time-timer at runtime rather than only at load time +;; in case display-time-mode is turned off in the mean time. +;; ---------------------------- +;; revision 1.34 +;; date: 2005-02-09 15:50:38 +0000; author: kfstorm; state: Exp; lines: +7 -7 +;; branches: 1.34.2; +;; Change release version from 21.4 to 22.1 throughout. +;; Change development version from 21.3.50 to 22.0.50. + +;;;; SCCS: + +;;;; Subversion: + +;; ------------------------------------------------------------------------ +;; r4622 | ckuethe | 2007-12-23 18:18:01 -0500 (Sun, 23 Dec 2007) | 2 lines +;; +;; uBlox AEK-4T in binary mode. Added to unstable because it breaks gpsfake +;; +;; ------------------------------------------------------------------------ +;; r4621 | ckuethe | 2007-12-23 16:48:11 -0500 (Sun, 23 Dec 2007) | 3 lines +;; +;; Add a note about requiring usbfs to use the garmin gps18 (usb) +;; Mention firmware testing the AC12 with firmware BQ00 and BQ04 +;; +;; ------------------------------------------------------------------------ +;; r4620 | ckuethe | 2007-12-23 15:52:34 -0500 (Sun, 23 Dec 2007) | 1 line +;; +;; add link to latest hardware reference +;; ------------------------------------------------------------------------ +;; r4619 | ckuethe | 2007-12-23 14:37:31 -0500 (Sun, 23 Dec 2007) | 1 line +;; +;; there is now a regression test for AC12 without raw data output + +;;;; Darcs: + +;; Changes to darcsum.el: +;; +;; Mon Nov 28 15:19:38 GMT 2005 Dave Love +;; * Abstract process startup into darcsum-start-process. Use TERM=dumb. +;; TERM=dumb avoids escape characters, at least, for any old darcs that +;; doesn't understand DARCS_DONT_COLOR & al. +;; +;; Thu Nov 24 15:20:45 GMT 2005 Dave Love +;; * darcsum-mode-related changes. +;; Don't call font-lock-mode (unnecessary) or use-local-map (redundant). +;; Use mode-class 'special. Add :group. +;; Add trailing-whitespace option to mode hook and fix +;; darcsum-display-changeset not to use trailing whitespace. + +;;;; Mercurial + +;; changeset: 11:8ff1a4166444 +;; tag: tip +;; user: Eric S. Raymond +;; date: Wed Dec 26 12:18:58 2007 -0500 +;; summary: Explain keywords. Add markup fixes. +;; +;; changeset: 10:20abc7ab09c3 +;; user: Eric S. Raymond +;; date: Wed Dec 26 11:37:28 2007 -0500 +;; summary: Typo fixes. +;; +;; changeset: 9:ada9f4da88aa +;; user: Eric S. Raymond +;; date: Wed Dec 26 11:23:00 2007 -0500 +;; summary: Add RCS example session. + +;;; Todo: + +;; - add ability to modify a log-entry (via cvs-mode-admin ;-) +;; - remove references to cvs-* +;; - make it easier to add support for new backends without changing the code. + +;;; Code: + +(eval-when-compile (require 'cl)) +(require 'pcvs-util) +(autoload 'vc-find-revision "vc") +(autoload 'vc-diff-internal "vc") + +(defvar cvs-minor-wrap-function) + +(defgroup log-view nil + "Major mode for browsing log output of RCS/CVS/SCCS." + :group 'pcl-cvs + :prefix "log-view-") + +;; Needed because log-view-mode-map inherits from widget-keymap. (Bug#5311) +(require 'wid-edit) + +(easy-mmode-defmap log-view-mode-map + '(("z" . kill-this-buffer) + ("q" . quit-window) + ("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 diff --cc lisp/vc/pcvs-defs.el index 7dda4533f6e,00000000000..db153fd29a1 mode 100644,000000..100644 --- a/lisp/vc/pcvs-defs.el +++ b/lisp/vc/pcvs-defs.el @@@ -1,529 -1,0 +1,529 @@@ +;;; 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 ++;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 +;; Free Software Foundation, Inc. + +;; Author: Stefan Monnier +;; 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 . + +;;; Commentary: + + +;;; Code: + +(eval-when-compile (require 'cl)) +(require 'pcvs-util) + +;;;; ------------------------------------------------------- +;;;; START OF THINGS TO CHECK WHEN INSTALLING + +(defvar cvs-program "cvs" + "*Name or full path of the cvs executable.") + +(defvar cvs-version + ;; With the divergence of the CVSNT codebase and version numbers, this is + ;; not really good any more. + (ignore-errors + (with-temp-buffer + (call-process cvs-program nil t nil "-v") + (goto-char (point-min)) + (when (re-search-forward "(CVS\\(NT\\)?) \\([0-9]+\\)\\.\\([0-9]+\\)" + nil t) + (cons (string-to-number (match-string 1)) + (string-to-number (match-string 2)))))) + "*Version of `cvs' installed on your system. +It must be in the (MAJOR . MINOR) format.") + +;; FIXME: this is only used by cvs-mode-diff-backup +(defvar cvs-diff-program (or (and (boundp 'diff-command) diff-command) "diff") + "*Name or full path of the best diff program you've got. +NOTE: there are some nasty bugs in the context diff variants of some vendor +versions, such as the one in SunOS-4.") + +;;;; END OF THINGS TO CHECK WHEN INSTALLING +;;;; -------------------------------------------------------- + +;;;; +;;;; User configuration variables: +;;;; +;;;; NOTE: these should be set in your ~/.emacs (or site-lisp/default.el) file. +;;;; + +(defgroup pcl-cvs nil + "Special support for the CVS versioning system." + :version "21.1" + :group 'tools + :prefix "cvs-") + +;; +;; cvsrc options +;; + +(defcustom cvs-cvsrc-file (convert-standard-filename "~/.cvsrc") + "Path to your cvsrc file." + :group 'pcl-cvs + :type '(file)) + +(defvar cvs-shared-start 4 + "Index of the first shared flag. +If set to 4, for instance, a numeric argument smaller than 4 will +select a non-shared flag, while a numeric argument greater than 3 +will select a shared-flag.") + +(defvar cvs-shared-flags (make-list cvs-shared-start nil) + "List of flags whose settings is shared among several commands.") + +(defvar cvs-cvsroot nil + "*Specifies where the (current) cvs master repository is. +Overrides the environment variable $CVSROOT by sending \" -d dir\" to +all CVS commands. This switch is useful if you have multiple CVS +repositories. It can be set interactively with \\[cvs-change-cvsroot.] +There is no need to set this if $CVSROOT is set to a correct value.") + +(defcustom cvs-auto-remove-handled nil + "If up-to-date files should be acknowledged automatically. +If T, they will be removed from the *cvs* buffer after every command. +If DELAYED, they will be removed from the *cvs* buffer before every command. +If STATUS, they will only be removed after a `cvs-mode-status' command. +Else, they will never be automatically removed from the *cvs* buffer." + :group 'pcl-cvs + :type '(choice (const nil) (const status) (const delayed) (const t))) + +(defcustom cvs-auto-remove-directories 'handled + "If ALL, directory entries will never be shown. +If HANDLED, only non-handled directories will be shown. +If EMPTY, only non-empty directories will be shown." + :group 'pcl-cvs + :type '(choice (const :tag "No" nil) (const all) (const handled) (const empty))) + +(defcustom cvs-auto-revert t + "Non-nil if changed files should automatically be reverted." + :group 'pcl-cvs + :type '(boolean)) + +(defcustom cvs-sort-ignore-file t + "Non-nil if `cvs-mode-ignore' should sort the .cvsignore automatically." + :group 'pcl-cvs + :type '(boolean)) + +(defcustom cvs-force-dir-tag t + "If non-nil, tagging can only be applied to directories. +Tagging should generally be applied a directory at a time, but sometimes it is +useful to be able to tag a single file. The normal way to do that is to use +`cvs-mode-force-command' so as to temporarily override the restrictions," + :group 'pcl-cvs + :type '(boolean)) + +(defcustom cvs-default-ignore-marks nil + "Non-nil if cvs mode commands should ignore any marked files. +Normally they run on the files that are marked (with `cvs-mode-mark'), +or the file under the cursor if no files are marked. If this variable +is set to a non-nil value they will by default run on the file on the +current line. See also `cvs-invert-ignore-marks'" + :group 'pcl-cvs + :type '(boolean)) + +(defvar cvs-diff-ignore-marks t) +(make-obsolete-variable 'cvs-diff-ignore-marks + 'cvs-invert-ignore-marks + "21.1") + +(defcustom cvs-invert-ignore-marks + (let ((l ())) + (unless (equal cvs-diff-ignore-marks cvs-default-ignore-marks) + (push "diff" l)) + (when (and cvs-force-dir-tag (not cvs-default-ignore-marks)) + (push "tag" l)) + l) + "List of cvs commands that invert the default ignore-mark behavior. +Commands in this set will use the opposite default from the one set +in `cvs-default-ignore-marks'." + :group 'pcl-cvs + :type '(set (const "diff") + (const "tag") + (const "ignore"))) + +(defcustom cvs-confirm-removals t + "Ask for confirmation before removing files. +Non-nil means that PCL-CVS will ask confirmation before removing files +except for files whose content can readily be recovered from the repository. +A value of `list' means that the list of files to be deleted will be +displayed when asking for confirmation." + :group 'pcl-cvs + :type '(choice (const list) + (const t) + (const nil))) + +(defcustom cvs-add-default-message nil + "Default message to use when adding files. +If set to nil, `cvs-mode-add' will always prompt for a message." + :group 'pcl-cvs + :type '(choice (const :tag "Prompt" nil) + (string))) + +(defvar cvs-diff-buffer-name "*cvs-diff*") +(make-obsolete-variable 'cvs-diff-buffer-name + 'cvs-buffer-name-alist + "21.1") + +(defcustom cvs-find-file-and-jump nil + "Jump to the modified area when finding a file. +If non-nil, `cvs-mode-file-file' will place the cursor at the beginning of +the modified area. If the file is not locally modified, this will obviously +have no effect." + :group 'pcl-cvs + :type '(boolean)) + +(defcustom cvs-buffer-name-alist + '(("diff" cvs-diff-buffer-name diff-mode) + ("status" "*cvs-info*" cvs-status-mode) + ("tree" "*cvs-info*" cvs-status-mode) + ("message" "*cvs-commit*" nil log-edit) + ("log" "*cvs-info*" log-view-mode)) + "Buffer name and mode to be used for each command. +This is a list of elements of the form + + (CMD BUFNAME MODE &optional POSTPROC) + +CMD is the name of the command. +BUFNAME is an expression that should evaluate to a string used as + a buffer name. It can use the variable CMD if it wants to. +MODE is the command to use to setup the buffer. +POSTPROC is a function that should be executed when the command terminates + +The CMD used for `cvs-mode-commit' is \"message\". For that special + case, POSTPROC is called just after MODE with special arguments." + :group 'pcl-cvs + :type '(repeat + (list (choice (const "diff") + (const "status") + (const "tree") + (const "message") + (const "log") + (string)) + (choice (const "*vc-diff*") + (const "*cvs-info*") + (const "*cvs-commit*") + (const (expand-file-name "*cvs-commit*")) + (const (format "*cvs-%s*" cmd)) + (const (expand-file-name (format "*cvs-%s*" cmd))) + (sexp :value "my-cvs-info-buffer") + (const nil)) + (choice (function-item diff-mode) + (function-item cvs-edit-mode) + (function-item cvs-status-mode) + function + (const nil)) + (set :inline t + (choice (function-item cvs-status-cvstrees) + (function-item cvs-status-trees) + function))))) + +(defvar cvs-buffer-name '(expand-file-name "*cvs*" dir) ;; "*cvs*" + "Name of the cvs buffer. +This expression will be evaluated in an environment where DIR is set to +the directory name of the cvs buffer.") + +(defvar cvs-temp-buffer-name + ;; Was '(expand-file-name " *cvs-tmp*" dir), but that causes them to + ;; become non-hidden if uniquification is done `forward'. + " *cvs-tmp*" + "*Name of the cvs temporary buffer. +Output from cvs is placed here for asynchronous commands.") + +(defcustom cvs-idiff-imerge-handlers + (if (fboundp 'ediff) + '(cvs-ediff-diff . cvs-ediff-merge) + '(cvs-emerge-diff . cvs-emerge-merge)) + "Pair of functions to be used for resp. diff'ing and merg'ing interactively." + :group 'pcl-cvs + :type '(choice (const :tag "Ediff" (cvs-ediff-diff . cvs-ediff-merge)) + (const :tag "Emerge" (cvs-emerge-diff . cvs-emerge-merge)))) + +(defvar cvs-mode-hook nil + "Run after `cvs-mode' was setup.") + + +;;;; +;;;; Internal variables, used in the process buffer. +;;;; + +(defvar cvs-postprocess nil + "(Buffer local) what to do once the process exits.") + +;;;; +;;;; Internal variables for the *cvs* buffer. +;;;; + +(defcustom cvs-reuse-cvs-buffer 'subdir + "When to reuse an existing cvs buffer. +Alternatives are: + CURRENT: just reuse the current buffer if it is a cvs buffer + SAMEDIR: reuse any cvs buffer displaying the same directory + SUBDIR: or reuse any cvs buffer displaying any sub- or super- directory + ALWAYS: reuse any cvs buffer." + :group 'pcl-cvs + :type '(choice (const always) (const subdir) (const samedir) (const current))) + +(defvar cvs-temp-buffer nil + "(Buffer local) The temporary buffer associated with this *cvs* buffer.") + +(defvar cvs-lock-file nil + "Full path to a lock file that CVS is waiting for (or was waiting for). +This variable is buffer local and only used in the *cvs* buffer.") + +(defvar cvs-lock-file-regexp "^#cvs\\.\\([trw]fl\\.[-.a-z0-9]+\\|lock\\)\\'" + "Regexp matching the possible names of locks in the CVS repository.") + +(defconst cvs-cursor-column 22 + "Column to position cursor in in `cvs-mode'.") + +;;;; +;;;; Global internal variables +;;;; + +(defconst cvs-vendor-branch "1.1.1" + "The default branch used by CVS for vendor code.") + +(easy-mmode-defmap cvs-mode-diff-map + '(("E" "imerge" . cvs-mode-imerge) + ("=" . cvs-mode-diff) + ("e" "idiff" . cvs-mode-idiff) + ("2" "other" . cvs-mode-idiff-other) + ("d" "diff" . cvs-mode-diff) + ("b" "backup" . cvs-mode-diff-backup) + ("h" "head" . cvs-mode-diff-head) + ("r" "repository" . cvs-mode-diff-repository) + ("y" "yesterday" . cvs-mode-diff-yesterday) + ("v" "vendor" . cvs-mode-diff-vendor)) + "Keymap for diff-related operations in `cvs-mode'." + :name "Diff") +;; This is necessary to allow correct handling of \\[cvs-mode-diff-map] +;; in substitute-command-keys. +(fset 'cvs-mode-diff-map cvs-mode-diff-map) + +(easy-mmode-defmap cvs-mode-map + ;;(define-prefix-command 'cvs-mode-map-diff-prefix) + ;;(define-prefix-command 'cvs-mode-map-control-c-prefix) + '(;; various + ;; (undo . cvs-mode-undo) + ("?" . cvs-help) + ("h" . cvs-help) + ("q" . cvs-bury-buffer) + ("z" . kill-this-buffer) + ("F" . cvs-mode-set-flags) + ;; ("\M-f" . cvs-mode-force-command) + ("!" . cvs-mode-force-command) + ("\C-c\C-c" . cvs-mode-kill-process) + ;; marking + ("m" . cvs-mode-mark) + ("M" . cvs-mode-mark-all-files) + ("S" . cvs-mode-mark-on-state) + ("u" . cvs-mode-unmark) + ("\C-?". cvs-mode-unmark-up) + ("%" . cvs-mode-mark-matching-files) + ("T" . cvs-mode-toggle-marks) + ("\M-\C-?" . cvs-mode-unmark-all-files) + ;; navigation keys + (" " . cvs-mode-next-line) + ("n" . cvs-mode-next-line) + ("p" . cvs-mode-previous-line) + ("\t" . cvs-mode-next-line) + ([backtab] . cvs-mode-previous-line) + ;; M- keys are usually those that operate on modules + ;;("\M-C". cvs-mode-rcs2log) ; i.e. "Create a ChangeLog" + ;;("\M-t". cvs-rtag) + ;;("\M-l". cvs-rlog) + ("\M-c". cvs-checkout) + ("\M-e". cvs-examine) + ("g" . cvs-mode-revert-buffer) + ("\M-u". cvs-update) + ("\M-s". cvs-status) + ;; diff commands + ("=" . cvs-mode-diff) + ("d" . cvs-mode-diff-map) + ;; keys that operate on individual files + ("\C-k" . cvs-mode-acknowledge) + ("A" . cvs-mode-add-change-log-entry-other-window) + ;;("B" . cvs-mode-byte-compile-files) + ("C" . cvs-mode-commit-setup) + ("O" . cvs-mode-update) + ("U" . cvs-mode-undo) + ("I" . cvs-mode-insert) + ("a" . cvs-mode-add) + ("b" . cvs-set-branch-prefix) + ("B" . cvs-set-secondary-branch-prefix) + ("c" . cvs-mode-commit) + ("e" . cvs-mode-examine) + ("f" . cvs-mode-find-file) + ("\C-m" . cvs-mode-find-file) + ("i" . cvs-mode-ignore) + ("l" . cvs-mode-log) + ("o" . cvs-mode-find-file-other-window) + ("r" . cvs-mode-remove) + ("s" . cvs-mode-status) + ("t" . cvs-mode-tag) + ("v" . cvs-mode-view-file) + ("x" . cvs-mode-remove-handled) + ;; cvstree bindings + ("+" . cvs-mode-tree) + ;; mouse bindings + ([mouse-2] . cvs-mode-find-file) + ([follow-link] . (lambda (pos) + (if (eq (get-char-property pos 'face) 'cvs-filename) t))) + ([(down-mouse-3)] . cvs-menu) + ;; dired-like bindings + ("\C-o" . cvs-mode-display-file) + ;; Emacs-21 toolbar + ;;([tool-bar item1] . (menu-item "Examine" cvs-examine :image (image :file "/usr/share/icons/xpaint.xpm" :type xpm))) + ;;([tool-bar item2] . (menu-item "Update" cvs-update :image (image :file "/usr/share/icons/mail1.xpm" :type xpm))) + ) + "Keymap for `cvs-mode'." + :dense t + :suppress t) + +(fset 'cvs-mode-map cvs-mode-map) + +(easy-menu-define cvs-menu cvs-mode-map "Menu used in `cvs-mode'." + '("CVS" + ["Open file" cvs-mode-find-file t] + ["Open in other window" cvs-mode-find-file-other-window t] + ["Display in other window" cvs-mode-display-file t] + ["Interactive merge" cvs-mode-imerge t] + ("View diff" + ["Interactive diff" cvs-mode-idiff t] + ["Current diff" cvs-mode-diff t] + ["Diff with head" cvs-mode-diff-head t] + ["Diff with vendor" cvs-mode-diff-vendor t] + ["Diff against yesterday" cvs-mode-diff-yesterday t] + ["Diff with backup" cvs-mode-diff-backup t]) + ["View log" cvs-mode-log t] + ["View status" cvs-mode-status t] + ["View tag tree" cvs-mode-tree t] + "----" + ["Insert" cvs-mode-insert] + ["Update" cvs-mode-update (cvs-enabledp 'update)] + ["Re-examine" cvs-mode-examine t] + ["Commit" cvs-mode-commit-setup (cvs-enabledp 'commit)] + ["Tag" cvs-mode-tag (cvs-enabledp (when cvs-force-dir-tag 'tag))] + ["Undo changes" cvs-mode-undo (cvs-enabledp 'undo)] + ["Add" cvs-mode-add (cvs-enabledp 'add)] + ["Remove" cvs-mode-remove (cvs-enabledp 'remove)] + ["Ignore" cvs-mode-ignore (cvs-enabledp 'ignore)] + ["Add ChangeLog" cvs-mode-add-change-log-entry-other-window t] + "----" + ["Mark" cvs-mode-mark t] + ["Mark all" cvs-mode-mark-all-files t] + ["Mark by regexp..." cvs-mode-mark-matching-files t] + ["Mark by state..." cvs-mode-mark-on-state t] + ["Unmark" cvs-mode-unmark t] + ["Unmark all" cvs-mode-unmark-all-files t] + ["Hide handled" cvs-mode-remove-handled t] + "----" + ["PCL-CVS Manual" (lambda () (interactive) + (info "(pcl-cvs)Top")) t] + "----" + ["Quit" cvs-mode-quit t])) + +;;;; +;;;; CVS-Minor mode +;;;; + +(defcustom cvs-minor-mode-prefix "\C-xc" + "Prefix key for the `cvs-mode' bindings in `cvs-minor-mode'." + :group 'pcl-cvs) + +(easy-mmode-defmap cvs-minor-mode-map + `((,cvs-minor-mode-prefix . cvs-mode-map) + ("e" . (menu-item nil cvs-mode-edit-log + :filter (lambda (x) (if (derived-mode-p 'log-view-mode) x))))) + "Keymap for `cvs-minor-mode', used in buffers related to PCL-CVS.") + +(defvar cvs-buffer nil + "(Buffer local) The *cvs* buffer associated with this buffer.") +(put 'cvs-buffer 'permanent-local t) +;;(make-variable-buffer-local 'cvs-buffer) + +(defvar cvs-minor-wrap-function nil + "Function to call when switching to the *cvs* buffer. +Takes two arguments: +- a *cvs* buffer. +- a zero-arg function which is guaranteed not to switch buffer. +It is expected to call the function.") +;;(make-variable-buffer-local 'cvs-minor-wrap-function) + +(defvar cvs-minor-current-files) +;;"Current files in a `cvs-minor-mode' buffer." +;; This should stay `void' because we want to be able to tell the difference +;; between an empty list and no list at all. + +(defconst cvs-pcl-cvs-dirchange-re "^pcl-cvs: descending directory \\(.*\\)$") + +;;;; +;;;; autoload the global menu +;;;; + +;;;###autoload +(defvar cvs-global-menu + (let ((m (make-sparse-keymap "PCL-CVS"))) + (define-key m [status] + `(menu-item ,(purecopy "Directory Status") cvs-status + :help ,(purecopy "A more verbose status of a workarea"))) + (define-key m [checkout] + `(menu-item ,(purecopy "Checkout Module") cvs-checkout + :help ,(purecopy "Check out a module from the repository"))) + (define-key m [update] + `(menu-item ,(purecopy "Update Directory") cvs-update + :help ,(purecopy "Fetch updates from the repository"))) + (define-key m [examine] + `(menu-item ,(purecopy "Examine Directory") cvs-examine + :help ,(purecopy "Examine the current state of a workarea"))) + (fset 'cvs-global-menu m))) + + +;; cvs-1.10 and above can take file arguments in other directories +;; while others need to be executed once per directory +(defvar cvs-execute-single-dir + (if (or (null cvs-version) + (or (>= (cdr cvs-version) 10) (> (car cvs-version) 1))) + ;; Supposedly some recent versions of CVS output some directory info + ;; as they recurse downthe tree, but it's not good enough in the case + ;; where we run "cvs status foo bar/foo". + '("status") + t) + "Whether cvs commands should be executed a directory at a time. +If a list, specifies for which commands the single-dir mode should be used. +If T, single-dir mode should be used for all operations. + +CVS versions before 1.10 did not allow passing them arguments in different +directories, so pcl-cvs checks what version you're using to determine +whether to use the new feature or not. +Sadly, even with a new cvs executable, if you connect to an older cvs server +\(typically a cvs-1.9 on the server), the old restriction applies. In such +a case the sanity check made by pcl-cvs fails and you will have to manually +set this variable to t (until the cvs server is upgraded). +When the above problem occurs, pcl-cvs should (hopefully) catch cvs' error +message and replace it with a message telling you to change this variable.") + +;; +(provide 'pcvs-defs) + +;; arch-tag: c7c701d0-d1d4-4aa9-a302-007bb03aca5e +;;; pcvs-defs.el ends here diff --cc lisp/vc/pcvs-info.el index 1ae924ff177,00000000000..0b570b1085b mode 100644,000000..100644 --- a/lisp/vc/pcvs-info.el +++ b/lisp/vc/pcvs-info.el @@@ -1,490 -1,0 +1,490 @@@ +;;; 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 ++;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 +;; Free Software Foundation, Inc. + +;; Author: Stefan Monnier +;; 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 . + +;;; Commentary: + +;; The cvs-fileinfo data structure: +;; +;; When the `cvs update' is ready we parse the output. Every file +;; that is affected in some way is added to the cookie collection as +;; a "fileinfo" (as defined below in cvs-create-fileinfo). + +;;; Code: + +(eval-when-compile (require 'cl)) +(require 'pcvs-util) +;;(require 'pcvs-defs) + +;;;; +;;;; config variables +;;;; + +(define-obsolete-variable-alias 'cvs-display-full-path + 'cvs-display-full-name "22.1") + +(defcustom cvs-display-full-name t + "Specifies how the filenames should be displayed in the listing. +If non-nil, their full filename name will be displayed, else only the +non-directory part." + :group 'pcl-cvs + :type '(boolean)) + +(defcustom cvs-allow-dir-commit nil + "Allow `cvs-mode-commit' on directories. +If you commit without any marked file and with the cursor positioned +on a directory entry, cvs would commit the whole directory. This seems +to confuse some users sometimes." + :group 'pcl-cvs + :type '(boolean)) + +;;;; +;;;; Faces for fontification +;;;; + +(defface cvs-header + '((((class color) (background dark)) + (:foreground "lightyellow" :weight bold)) + (((class color) (background light)) + (:foreground "blue4" :weight bold)) + (t (:weight bold))) + "PCL-CVS face used to highlight directory changes." + :group 'pcl-cvs) +(define-obsolete-face-alias 'cvs-header-face 'cvs-header "22.1") + +(defface cvs-filename + '((((class color) (background dark)) + (:foreground "lightblue")) + (((class color) (background light)) + (:foreground "blue4")) + (t ())) + "PCL-CVS face used to highlight file names." + :group 'pcl-cvs) +(define-obsolete-face-alias 'cvs-filename-face 'cvs-filename "22.1") + +(defface cvs-unknown + '((((class color) (background dark)) + (:foreground "red1")) + (((class color) (background light)) + (:foreground "red1")) + (t (:slant italic))) + "PCL-CVS face used to highlight unknown file status." + :group 'pcl-cvs) +(define-obsolete-face-alias 'cvs-unknown-face 'cvs-unknown "22.1") + +(defface cvs-handled + '((((class color) (background dark)) + (:foreground "pink")) + (((class color) (background light)) + (:foreground "pink")) + (t ())) + "PCL-CVS face used to highlight handled file status." + :group 'pcl-cvs) +(define-obsolete-face-alias 'cvs-handled-face 'cvs-handled "22.1") + +(defface cvs-need-action + '((((class color) (background dark)) + (:foreground "orange")) + (((class color) (background light)) + (:foreground "orange")) + (t (:slant italic))) + "PCL-CVS face used to highlight status of files needing action." + :group 'pcl-cvs) +(define-obsolete-face-alias 'cvs-need-action-face 'cvs-need-action "22.1") + +(defface cvs-marked + '((((min-colors 88) (class color) (background dark)) + (:foreground "green1" :weight bold)) + (((class color) (background dark)) + (:foreground "green" :weight bold)) + (((class color) (background light)) + (:foreground "green3" :weight bold)) + (t (:weight bold))) + "PCL-CVS face used to highlight marked file indicator." + :group 'pcl-cvs) +(define-obsolete-face-alias 'cvs-marked-face 'cvs-marked "22.1") + +(defface cvs-msg + '((t (:slant italic))) + "PCL-CVS face used to highlight CVS messages." + :group 'pcl-cvs) +(define-obsolete-face-alias 'cvs-msg-face 'cvs-msg "22.1") + +(defvar cvs-fi-up-to-date-face 'cvs-handled) +(defvar cvs-fi-unknown-face 'cvs-unknown) +(defvar cvs-fi-conflict-face 'font-lock-warning-face) + +;; There is normally no need to alter the following variable, but if +;; your site has installed CVS in a non-standard way you might have +;; to change it. + +(defvar cvs-bakprefix ".#" + "The prefix that CVS prepends to files when rcsmerge'ing.") + +(easy-mmode-defmap cvs-status-map + '(([(mouse-2)] . cvs-mode-toggle-mark)) + "Local keymap for text properties of status") + +;; Constructor: + +(defstruct (cvs-fileinfo + (:constructor nil) + (:copier nil) + (:constructor -cvs-create-fileinfo (type dir file full-log + &key marked subtype + merge + base-rev + head-rev)) + (:conc-name cvs-fileinfo->)) + marked ;; t/nil. + type ;; See below + subtype ;; See below + dir ;; Relative directory the file resides in. + ;; (concat dir file) should give a valid path. + file ;; The file name sans the directory. + base-rev ;; During status: This is the revision that the + ;; working file is based on. + head-rev ;; During status: This is the highest revision in + ;; the repository. + merge ;; A cons cell containing the (ancestor . head) revisions + ;; of the merge that resulted in the current file. + ;;removed ;; t if the file no longer exists. + full-log ;; The output from cvs, unparsed. + ;;mod-time ;; Not used. + + ;; In addition to the above, the following values can be extracted: + + ;; handled ;; t if this file doesn't require further action. + ;; full-name ;; The complete relative filename. + ;; pp-name ;; The printed file name + ;; backup-file;; For MERGED and CONFLICT files after a \"cvs update\", + ;; this is a full path to the backup file where the + ;; untouched version resides. + + ;; The meaning of the type field: + + ;; Value ---Used by--- Explanation + ;; update status + ;; NEED-UPDATE x file needs update + ;; MODIFIED x x modified by you, unchanged in repository + ;; MERGED x x successful merge + ;; ADDED x x added by you, not yet committed + ;; MISSING x rm'd, but not yet `cvs remove'd + ;; REMOVED x x removed by you, not yet committed + ;; NEED-MERGE x need merge + ;; CONFLICT x conflict when merging + ;; ;;MOD-CONFLICT x removed locally, changed in repository. + ;; DIRCHANGE x x A change of directory. + ;; UNKNOWN x An unknown file. + ;; UP-TO-DATE x The file is up-to-date. + ;; UPDATED x x file copied from repository + ;; PATCHED x x diff applied from repository + ;; COMMITTED x x cvs commit'd + ;; DEAD An entry that should be removed + ;; MESSAGE x x This is a special fileinfo that is used + ;; to display a text that should be in + ;; full-log." + ;; TEMP A temporary message that should be removed + ) +(defun cvs-create-fileinfo (type dir file msg &rest keys) + (cvs-check-fileinfo (apply #'-cvs-create-fileinfo type dir file msg keys))) + +;; Fake selectors: + +(defun cvs-fileinfo->full-name (fileinfo) + "Return the full path for the file that is described in FILEINFO." + (let ((dir (cvs-fileinfo->dir fileinfo))) + (if (eq (cvs-fileinfo->type fileinfo) 'DIRCHANGE) + (if (string= dir "") "." (directory-file-name dir)) + ;; Here, I use `concat' rather than `expand-file-name' because I want + ;; the resulting path to stay relative if `dir' is relative. + (concat dir (cvs-fileinfo->file fileinfo))))) +(define-obsolete-function-alias 'cvs-fileinfo->full-path + 'cvs-fileinfo->full-name "22.1") + +(defun cvs-fileinfo->pp-name (fi) + "Return the filename of FI as it should be displayed." + (if cvs-display-full-name + (cvs-fileinfo->full-name fi) + (cvs-fileinfo->file fi))) + +(defun cvs-fileinfo->backup-file (fileinfo) + "Construct the file name of the backup file for FILEINFO." + (let* ((dir (cvs-fileinfo->dir fileinfo)) + (file (cvs-fileinfo->file fileinfo)) + (default-directory (file-name-as-directory (expand-file-name dir))) + (files (directory-files "." nil + (concat "\\`" (regexp-quote cvs-bakprefix) + (regexp-quote file) "\\(\\.[0-9]+\\.[0-9]+\\)+\\'"))) + bf) + (dolist (f files) + (when (and (file-readable-p f) + (or (null bf) (file-newer-than-file-p f bf))) + (setq bf f))) + (concat dir bf))) + +;; (defun cvs-fileinfo->handled (fileinfo) +;; "Tell if this requires further action" +;; (memq (cvs-fileinfo->type fileinfo) '(UP-TO-DATE DEAD))) + + +;; Predicate: + +(defun cvs-check-fileinfo (fi) + "Check FI's conformance to some conventions." + (let ((check 'none) + (type (cvs-fileinfo->type fi)) + (subtype (cvs-fileinfo->subtype fi)) + (marked (cvs-fileinfo->marked fi)) + (dir (cvs-fileinfo->dir fi)) + (file (cvs-fileinfo->file fi)) + (base-rev (cvs-fileinfo->base-rev fi)) + (head-rev (cvs-fileinfo->head-rev fi)) + (full-log (cvs-fileinfo->full-log fi))) + (if (and (setq check 'marked) (memq marked '(t nil)) + (setq check 'base-rev) (or (null base-rev) (stringp base-rev)) + (setq check 'head-rev) (or (null head-rev) (stringp head-rev)) + (setq check 'full-log) (stringp full-log) + (setq check 'dir) + (and (stringp dir) + (not (file-name-absolute-p dir)) + (or (string= dir "") + (string= dir (file-name-as-directory dir)))) + (setq check 'file) + (and (stringp file) + (string= file (file-name-nondirectory file))) + (setq check 'type) (symbolp type) + (setq check 'consistency) + (case type + (DIRCHANGE (and (null subtype) (string= "." file))) + ((NEED-UPDATE ADDED MISSING DEAD MODIFIED MESSAGE UP-TO-DATE + REMOVED NEED-MERGE CONFLICT UNKNOWN MESSAGE) + t))) + fi + (error "Invalid :%s in cvs-fileinfo %s" check fi)))) + + +;;;; +;;;; State table to indicate what you can do when. +;;;; + +(defconst cvs-states + `((NEED-UPDATE update diff ignore) + (UP-TO-DATE update nil remove diff safe-rm revert) + (MODIFIED update commit undo remove diff merge diff-base) + (ADDED update commit remove) + (MISSING remove undo update safe-rm revert) + (REMOVED commit add undo safe-rm) + (NEED-MERGE update undo diff diff-base) + (CONFLICT merge remove undo commit diff diff-base) + (DIRCHANGE remove update diff ,(if cvs-allow-dir-commit 'commit) tag) + (UNKNOWN ignore add remove) + (DEAD ) + (MESSAGE)) + "Fileinfo state descriptions for pcl-cvs. +This is an assoc list. Each element consists of (STATE . FUNS) +- STATE (described in `cvs-create-fileinfo') is the key +- FUNS is the list of applicable operations. + The first one (if any) should be the \"default\" action. +Most of the actions have the obvious meaning. +`safe-rm' indicates that the file can be removed without losing + any information.") + +;;;; +;;;; Utility functions +;;;; + +(defun cvs-applicable-p (fi-or-type func) + "Check if FUNC is applicable to FI-OR-TYPE. +If FUNC is nil, always return t. +FI-OR-TYPE can either be a symbol (a fileinfo-type) or a fileinfo." + (let ((type (if (symbolp fi-or-type) fi-or-type + (cvs-fileinfo->type fi-or-type)))) + (and (not (eq type 'MESSAGE)) + (eq (car (memq func (cdr (assq type cvs-states)))) func)))) + +(defun cvs-add-face (str face &optional keymap &rest props) + (when keymap + (when (keymapp keymap) + (setq props (list* 'keymap keymap props))) + (setq props (list* 'mouse-face 'highlight props))) + (add-text-properties 0 (length str) (list* 'font-lock-face face props) str) + str) + +(defun cvs-fileinfo-pp (fileinfo) + "Pretty print FILEINFO. Insert a printed representation in current buffer. +For use by the cookie package." + (cvs-check-fileinfo fileinfo) + (let ((type (cvs-fileinfo->type fileinfo)) + (subtype (cvs-fileinfo->subtype fileinfo))) + (insert + (case type + (DIRCHANGE (concat "In directory " + (cvs-add-face (cvs-fileinfo->full-name fileinfo) + 'cvs-header t 'cvs-goal-column t) + ":")) + (MESSAGE + (cvs-add-face (format "Message: %s" (cvs-fileinfo->full-log fileinfo)) + 'cvs-msg)) + (t + (let* ((status (if (cvs-fileinfo->marked fileinfo) + (cvs-add-face "*" 'cvs-marked) + " ")) + (file (cvs-add-face (cvs-fileinfo->pp-name fileinfo) + 'cvs-filename t 'cvs-goal-column t)) + (base (or (cvs-fileinfo->base-rev fileinfo) "")) + (head (cvs-fileinfo->head-rev fileinfo)) + (type + (let ((str (case type + ;;(MOD-CONFLICT "Not Removed") + (DEAD "") + (t (capitalize (symbol-name type))))) + (face (let ((sym (intern + (concat "cvs-fi-" + (downcase (symbol-name type)) + "-face")))) + (or (and (boundp sym) (symbol-value sym)) + 'cvs-need-action)))) + (cvs-add-face str face cvs-status-map))) + (side (or + ;; maybe a subtype + (when subtype (downcase (symbol-name subtype))) + ;; or the head-rev + (when (and head (not (string= head base))) head) + ;; or nothing + ""))) + (format "%-11s %s %-11s %-11s %s" + side status type base file)))) + "\n"))) + + +(defun cvs-fileinfo-update (fi fi-new) + "Update FI with the information provided in FI-NEW." + (let ((type (cvs-fileinfo->type fi-new)) + (merge (cvs-fileinfo->merge fi-new))) + (setf (cvs-fileinfo->type fi) type) + (setf (cvs-fileinfo->subtype fi) (cvs-fileinfo->subtype fi-new)) + (setf (cvs-fileinfo->full-log fi) (cvs-fileinfo->full-log fi-new)) + (setf (cvs-fileinfo->base-rev fi) (cvs-fileinfo->base-rev fi-new)) + (setf (cvs-fileinfo->head-rev fi) (cvs-fileinfo->head-rev fi-new)) + (cond + (merge (setf (cvs-fileinfo->merge fi) merge)) + ((memq type '(UP-TO-DATE NEED-UPDATE)) + (setf (cvs-fileinfo->merge fi) nil))))) + +(defun cvs-fileinfo< (a b) + "Compare fileinfo A with fileinfo B and return t if A is `less'. +The ordering defined by this function is such that directories are +sorted alphabetically, and inside every directory the DIRCHANGE +fileinfo will appear first, followed by all files (alphabetically)." + (let ((subtypea (cvs-fileinfo->subtype a)) + (subtypeb (cvs-fileinfo->subtype b))) + (cond + ;; Sort according to directories. + ((string< (cvs-fileinfo->dir a) (cvs-fileinfo->dir b)) t) + ((not (string= (cvs-fileinfo->dir a) (cvs-fileinfo->dir b))) nil) + + ;; The DIRCHANGE entry is always first within the directory. + ((eq (cvs-fileinfo->type b) 'DIRCHANGE) nil) + ((eq (cvs-fileinfo->type a) 'DIRCHANGE) t) + + ;; All files are sorted by file name. + ((string< (cvs-fileinfo->file a) (cvs-fileinfo->file b)))))) + +;;; +;;; Look at CVS/Entries to quickly find a first approximation of the status +;;; + +(defun cvs-fileinfo-from-entries (dir &optional all) + "List of fileinfos for DIR, extracted from CVS/Entries. +Unless ALL is optional, returns only the files that are not up-to-date. +DIR can also be a file." + (let* ((singlefile + (cond + ((equal dir "") nil) + ((file-directory-p dir) (setq dir (file-name-as-directory dir)) nil) + (t (prog1 (file-name-nondirectory dir) + (setq dir (or (file-name-directory dir) "")))))) + (file (expand-file-name "CVS/Entries" dir)) + (fis nil)) + (if (not (file-readable-p file)) + (push (cvs-create-fileinfo (if singlefile 'UNKNOWN 'DIRCHANGE) + dir (or singlefile ".") "") fis) + (with-temp-buffer + (insert-file-contents file) + (goto-char (point-min)) + ;; Select the single file entry in case we're only interested in a file. + (cond + ((not singlefile) + (push (cvs-create-fileinfo 'DIRCHANGE dir "." "") fis)) + ((re-search-forward + (concat "^[^/]*/" (regexp-quote singlefile) "/.*") nil t) + (setq all t) + (goto-char (match-beginning 0)) + (narrow-to-region (point) (match-end 0))) + (t + (push (cvs-create-fileinfo 'UNKNOWN dir singlefile "") fis) + (narrow-to-region (point-min) (point-min)))) + (while (looking-at "\\([^/]*\\)/\\([^/]*\\)/\\([^/]*\\)/\\([^/]*\\)/") + (if (/= (match-beginning 1) (match-end 1)) + (setq fis (append (cvs-fileinfo-from-entries + (concat dir (file-name-as-directory + (match-string 2))) + all) + fis)) + (let ((f (match-string 2)) + (rev (match-string 3)) + (date (match-string 4)) + timestamp + (type 'MODIFIED) + (subtype nil)) + (cond + ((equal (substring rev 0 1) "-") + (setq type 'REMOVED rev (substring rev 1))) + ((not (file-exists-p (concat dir f))) (setq type 'MISSING)) + ((equal rev "0") (setq type 'ADDED rev nil)) + ((equal date "Result of merge") (setq subtype 'MERGED)) + ((let ((mtime (nth 5 (file-attributes (concat dir f)))) + (system-time-locale "C")) + (setq timestamp (format-time-string "%c" mtime 'utc)) + ;; Solaris sometimes uses "Wed Sep 05", not "Wed Sep 5". + ;; See "grep '[^a-z_]ctime' cvs/src/*.c" for reference. + (if (= (aref timestamp 8) ?0) + (setq timestamp (concat (substring timestamp 0 8) + " " (substring timestamp 9)))) + (equal timestamp date)) + (setq type (if all 'UP-TO-DATE))) + ((equal date (concat "Result of merge+" timestamp)) + (setq type 'CONFLICT))) + (when type + (push (cvs-create-fileinfo type dir f "" + :base-rev rev :subtype subtype) + fis)))) + (forward-line 1)))) + fis)) + +(provide 'pcvs-info) + +;; arch-tag: d85dde07-bdc2-400a-882f-92f398c7b0ba +;;; pcvs-info.el ends here diff --cc lisp/vc/pcvs-parse.el index 560a270a731,00000000000..a27fe3e61cf mode 100644,000000..100644 --- a/lisp/vc/pcvs-parse.el +++ b/lisp/vc/pcvs-parse.el @@@ -1,539 -1,0 +1,539 @@@ +;;; pcvs-parse.el --- the CVS output parser + +;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - ;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ++;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. + +;; Author: Stefan Monnier +;; 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 . + +;;; Commentary: + +;;; Bugs: + +;; - when merging a modified file, if the merge says that the file already +;; contained in the changes, it marks the file as `up-to-date' although +;; it might still contain further changes. +;; Example: merging a zero-change commit. + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'pcvs-util) +(require 'pcvs-info) + +;; imported from pcvs.el +(defvar cvs-execute-single-dir) + +;; parse vars + +(defcustom cvs-update-prog-output-skip-regexp "$" + "A regexp that matches the end of the output from all cvs update programs. +That is, output from any programs that are run by CVS (by the flag -u +in the `modules' file - see cvs(5)) when `cvs update' is performed should +terminate with a line that this regexp matches. It is enough that +some part of the line is matched. + +The default (a single $) fits programs without output." + :group 'pcl-cvs + :type '(regexp :value "$")) + +(defcustom cvs-parse-ignored-messages + '("Executing ssh-askpass to query the password.*$" + ".*Remote host denied X11 forwarding.*$") + "A list of regexps matching messages that should be ignored by the parser. +Each regexp should match a whole set of lines and should hence be terminated +by `$'." + :group 'pcl-cvs + :type '(repeat regexp)) + +;; a few more defvars just to shut up the compiler +(defvar cvs-start) +(defvar cvs-current-dir) +(defvar cvs-current-subdir) +(defvar dont-change-disc) + +;;;; The parser + +(defconst cvs-parse-known-commands + '("status" "add" "commit" "update" "remove" "checkout" "ci") + "List of CVS commands whose output is understood by the parser.") + +(defun cvs-parse-buffer (parse-spec dont-change-disc &optional subdir) + "Parse current buffer according to PARSE-SPEC. +PARSE-SPEC is a function of no argument advancing the point and returning + either a fileinfo or t (if the matched text should be ignored) or + nil if it didn't match anything. +DONT-CHANGE-DISC just indicates whether the command was changing the disc + or not (useful to tell the difference between `cvs-examine' and `cvs-update' + output. +The path names should be interpreted as relative to SUBDIR (defaults + to the `default-directory'). +Return a list of collected entries, or t if an error occurred." + (goto-char (point-min)) + (let ((fileinfos ()) + (cvs-current-dir "") + (case-fold-search nil) + (cvs-current-subdir (or subdir ""))) + (while (not (or (eobp) (eq fileinfos t))) + (let ((ret (cvs-parse-run-table parse-spec))) + (cond + ;; it matched a known information message + ((cvs-fileinfo-p ret) (push ret fileinfos)) + ;; it didn't match anything at all (impossible) + ((and (consp ret) (cvs-fileinfo-p (car ret))) + (setq fileinfos (append ret fileinfos))) + ((null ret) (setq fileinfos t)) + ;; it matched something that should be ignored + (t nil)))) + (nreverse fileinfos))) + + +;; All those parsing macros/functions should return a success indicator +(defsubst cvs-parse-msg () (buffer-substring cvs-start (1- (point)))) + +;;(defsubst COLLECT (exp) (push exp *result*)) +;;(defsubst PROG (e) t) +;;(defmacro SEQ (&rest seqs) (cons 'and seqs)) + +(defmacro cvs-match (re &rest matches) + "Try to match RE and extract submatches. +If RE matches, advance the point until the line after the match and +then assign the variables as specified in MATCHES (via `setq')." + (cons 'cvs-do-match + (cons re (mapcar (lambda (match) + `(cons ',(first match) ,(second match))) + matches)))) + +(defun cvs-do-match (re &rest matches) + "Internal function for the `cvs-match' macro. +Match RE and if successful, execute MATCHES." + ;; Is it a match? + (when (looking-at re) + (goto-char (match-end 0)) + ;; Skip the newline (unless we already are at the end of the buffer). + (when (and (eolp) (< (point) (point-max))) (forward-char)) + ;; assign the matches + (dolist (match matches t) + (let ((val (cdr match))) + (set (car match) (if (integerp val) (match-string val) val)))))) + +(defmacro cvs-or (&rest alts) + "Try each one of the ALTS alternatives until one matches." + `(let ((-cvs-parse-point (point))) + ,(cons 'or + (mapcar (lambda (es) + `(or ,es (ignore (goto-char -cvs-parse-point)))) + alts)))) +(def-edebug-spec cvs-or t) + +;; This is how parser tables should be executed +(defun cvs-parse-run-table (parse-spec) + "Run PARSE-SPEC and provide sensible default behavior." + (unless (bolp) (forward-line 1)) ;this should never be needed + (let ((cvs-start (point))) + (cvs-or + (funcall parse-spec) + + (dolist (re cvs-parse-ignored-messages) + (when (cvs-match re) (return t))) + + ;; This is a parse error. Create a message-type fileinfo. + (and + (cvs-match ".*$") + (cvs-create-fileinfo 'MESSAGE cvs-current-dir " " + ;; (concat " Unknown msg: '" + (cvs-parse-msg) ;; "'") + :subtype 'ERROR))))) + + +(defun cvs-parsed-fileinfo (type path &optional directory &rest keys) + "Create a fileinfo. +TYPE can either be a type symbol or a cons of the form (TYPE . SUBTYPE). +PATH is the filename. +DIRECTORY influences the way PATH is interpreted: +- if it's a string, it denotes the directory in which PATH (which should then be + a plain file name with no directory component) resides. +- if it's nil, the PATH should not be trusted: if it has a directory + component, use it, else, assume it is relative to the current directory. +- else, the PATH should be trusted to be relative to the root + directory (i.e. if there is no directory component, it means the file + is inside the main directory). +The remaining KEYS are passed directly to `cvs-create-fileinfo'." + (let ((dir directory) + (file path)) + ;; only trust the directory if it's a string + (unless (stringp directory) + ;; else, if the directory is true, the path should be trusted + (setq dir (or (file-name-directory path) (if directory ""))) + (setq file (file-name-nondirectory path))) + + (let ((type (if (consp type) (car type) type)) + (subtype (if (consp type) (cdr type)))) + (when dir (setq cvs-current-dir dir)) + (apply 'cvs-create-fileinfo type + (concat cvs-current-subdir (or dir cvs-current-dir)) + file (cvs-parse-msg) :subtype subtype keys)))) + +;;;; CVS Process Parser Tables: +;;;; +;;;; The table for status and update could actually be merged since they +;;;; don't conflict. But they don't overlap much either. + +(defun cvs-parse-table () + "Table of message objects for `cvs-parse-process'." + (let (c file dir path base-rev subtype) + (cvs-or + + (cvs-parse-status) + (cvs-parse-merge) + (cvs-parse-commit) + + ;; this is not necessary because the fileinfo merging will remove + ;; such duplicate info and luckily the second info is the one we want. + ;; (and (cvs-match "M \\(.*\\)$" (path 1)) + ;; (cvs-parse-merge path)) + + ;; Normal file state indicator. + (and + (cvs-match "\\([MARCUPNJ?]\\) \\(.*\\)$" (c 1) (path 2)) + ;; M: The file is modified by the user, and untouched in the repository. + ;; A: The file is "cvs add"ed, but not "cvs ci"ed. + ;; R: The file is "cvs remove"ed, but not "cvs ci"ed. + ;; C: Conflict + ;; U: The file is copied from the repository. + ;; P: The file was patched from the repository. + ;; ?: Unknown file. + (let ((code (aref c 0))) + (cvs-parsed-fileinfo + (case code + (?M 'MODIFIED) + (?A 'ADDED) + (?R 'REMOVED) + (?? 'UNKNOWN) + (?C + (if (not dont-change-disc) 'CONFLICT + ;; This is ambiguous. We should look for conflict markers in the + ;; file to decide between CONFLICT and NEED-MERGE. With CVS-1.10 + ;; servers, this should not be necessary, because they return + ;; a complete merge output. + (with-temp-buffer + (ignore-errors (insert-file-contents path)) + (goto-char (point-min)) + (if (re-search-forward "^<<<<<<< " nil t) + 'CONFLICT 'NEED-MERGE)))) + (?J 'NEED-MERGE) ;not supported by standard CVS + ((?U ?P) + (if dont-change-disc 'NEED-UPDATE + (cons 'UP-TO-DATE (if (eq code ?U) 'UPDATED 'PATCHED))))) + path 'trust))) + + (and + (cvs-match "pcl-cvs: descending directory \\(.*\\)$" (dir 1)) + (setq cvs-current-subdir dir)) + + ;; A special cvs message + (and + (let ((case-fold-search t)) + (cvs-match "cvs[.a-z]* [a-z]+: ")) + (cvs-or + + ;; CVS is descending a subdirectory + ;; (status says `examining' while update says `updating') + (and + (cvs-match "\\(Examining\\|Updating\\) \\(.*\\)$" (dir 2)) + (let ((dir (if (string= "." dir) "" (file-name-as-directory dir)))) + (cvs-parsed-fileinfo 'DIRCHANGE "." dir))) + + ;; [-n update] A new (or pruned) directory appeared but isn't traversed + (and + (cvs-match "New directory `\\(.*\\)' -- ignored$" (dir 1)) + ;; (cvs-parsed-fileinfo 'MESSAGE " " (file-name-as-directory dir)) + ;; These messages either correspond to a true new directory + ;; that an update will bring in, or to a directory that's empty + ;; on the current branch (either because it only exists in other + ;; branches, or because it's been removed). + (if (ignore-errors + (with-temp-buffer + (ignore-errors + (insert-file-contents + (expand-file-name ".cvsignore" (file-name-directory dir)))) + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote (file-name-nondirectory dir)) "/$") + nil t))) + t ;The user requested to ignore those messages. + (cvs-parsed-fileinfo '(NEED-UPDATE . NEW-DIR) dir t))) + + ;; File removed, since it is removed (by third party) in repository. + (and + (cvs-or + ;; some cvs versions output quotes around these files + (cvs-match "warning: `\\(.*\\)' is not (any longer) pertinent$" (file 1)) + (cvs-match "warning: \\(.*\\) is not (any longer) pertinent$" (file 1)) + (cvs-match "`\\(.*\\)' is no longer in the repository$" (file 1)) + (cvs-match "\\(.*\\) is no longer in the repository$" (file 1))) + (cvs-parsed-fileinfo + (if dont-change-disc '(NEED-UPDATE . REMOVED) 'DEAD) file)) + + ;; [add] + (and + (cvs-or + (cvs-match "scheduling file `\\(.*\\)' for addition.*$" (path 1)) + (cvs-match "re-adding file \\(.*\\) (in place of .*)$" (path 1))) + (cvs-parsed-fileinfo 'ADDED path)) + + ;; [add] this will also show up as a `U ' + (and + (cvs-match "`?\\(.*?\\)'?, version \\(.*\\), resurrected$" + (path 1) (base-rev 2)) + ;; FIXME: resurrection only brings back the original version, + ;; not the latest on the branch, so `up-to-date' is not always + ;; what we want. + (cvs-parsed-fileinfo '(UP-TO-DATE . RESURRECTED) path nil + :base-rev base-rev)) + + ;; [remove] + (and + (cvs-match "removed `\\(.*\\)'$" (path 1)) + (cvs-parsed-fileinfo 'DEAD path)) + + ;; [remove,merge] + (and + (cvs-match "scheduling `\\(.*\\)' for removal$" (file 1)) + (cvs-parsed-fileinfo 'REMOVED file)) + + ;; [update] File removed by you, but not cvs rm'd + (and + (cvs-match "warning: \\(.*\\) was lost$" (path 1)) + (cvs-match (concat "U " (regexp-quote path) "$")) + (cvs-parsed-fileinfo (if dont-change-disc + 'MISSING + '(UP-TO-DATE . UPDATED)) + path)) + + ;; Mode conflicts (rather than contents) + (and + (cvs-match "conflict: ") + (cvs-or + (cvs-match "removed \\(.*\\) was modified by second party$" + (path 1) (subtype 'REMOVED)) + (cvs-match "\\(.*\\) created independently by second party$" + (path 1) (subtype 'ADDED)) + (cvs-match "\\(.*\\) is modified but no longer in the repository$" + (path 1) (subtype 'MODIFIED))) + (cvs-match (concat "C " (regexp-quote path))) + (cvs-parsed-fileinfo (cons 'CONFLICT subtype) path)) + + ;; Messages that should be shown to the user + (and + (cvs-or + (cvs-match "move away \\(.*\\); it is in the way$" (file 1)) + (cvs-match "warning: new-born \\(.*\\) has disappeared$" (file 1)) + (cvs-match "sticky tag .* for file `\\(.*\\)' is not a branch$" + (file 1))) + (cvs-parsed-fileinfo 'MESSAGE file)) + + ;; File unknown. + (and (cvs-match "use `.+ add' to create an entry for \\(.*\\)$" (path 1)) + (cvs-parsed-fileinfo 'UNKNOWN path)) + + ;; [commit] + (and (cvs-match "Up-to-date check failed for `\\(.+\\)'$" (file 1)) + (cvs-parsed-fileinfo 'NEED-MERGE file)) + + ;; We use cvs-execute-multi-dir but cvs can't handle it + ;; Probably because the cvs-client can but the cvs-server can't + (and (cvs-match ".* files with '?/'? in their name.*$") + (not cvs-execute-single-dir) + (setq cvs-execute-single-dir t) + (cvs-create-fileinfo + 'MESSAGE "" " " + "*** Add (setq cvs-execute-single-dir t) to your .emacs *** + See the FAQ file or the variable's documentation for more info.")) + + ;; Cvs waits for a lock. Ignored: already handled by the process filter + (cvs-match "\\[..:..:..\\] \\(waiting for\\|obtained\\) .*lock in .*$") + ;; File you removed still exists. Ignore (will be noted as removed). + (cvs-match ".* should be removed and is still there$") + ;; just a note + (cvs-match "use ['`].+ commit' to \\sw+ th\\sw+ files? permanently$") + ;; [add,status] followed by a more complete status description anyway + (and (cvs-match "nothing known about \\(.*\\)$" (path 1)) + (cvs-parsed-fileinfo 'DEAD path 'trust)) + ;; [update] problem with patch + (cvs-match "checksum failure after patch to .*; will refetch$") + (cvs-match "refetching unpatchable files$") + ;; [commit] + (cvs-match "Rebuilding administrative file database$") + ;; ??? + (cvs-match "--> Using per-directory sticky tag `.*'") + + ;; CVS is running a *info program. + (and + (cvs-match "Executing.*$") + ;; Skip by any output the program may generate to stdout. + ;; Note that pcl-cvs will get seriously confused if the + ;; program prints anything to stderr. + (re-search-forward cvs-update-prog-output-skip-regexp)))) + + (and + (cvs-match "cvs[.ex]* \\[[a-z]+ aborted\\]:.*$") + (cvs-parsed-fileinfo 'MESSAGE "")) + + ;; sadly you can't do much with these since the path is in the repository + (cvs-match "Directory .* added to the repository$") + ))) + + +(defun cvs-parse-merge () + (let (path base-rev head-rev type) + ;; A merge (maybe with a conflict). + (and + (cvs-match "RCS file: .*$") + ;; Squirrel away info about the files that were retrieved for merging + (cvs-match "retrieving revision \\([0-9.]+\\)$" (base-rev 1)) + (cvs-match "retrieving revision \\([0-9.]+\\)$" (head-rev 1)) + (cvs-match "Merging differences between [0-9.]+ and [0-9.]+ into \\(.*\\)$" + (path 1)) + + ;; eat up potential conflict warnings + (cvs-or (cvs-match "\\(rcs\\)?merge:?\\( warning\\)?: \\(overlaps\\|conflicts\\) \\(or other problems \\)?during merge$" (type 'CONFLICT)) t) + (cvs-or + (and + (cvs-match "cvs[.ex]* [a-z]+: ") + (cvs-or + (cvs-match "conflicts found in \\(.*\\)$" (path 1) (type 'CONFLICT)) + (cvs-match "could not merge .*$") + (cvs-match "restoring \\(.*\\) from backup file .*$" (path 1)))) + t) + + ;; Is it a succesful merge? + ;; Figure out result of merging (ie, was there a conflict?) + (let ((qfile (regexp-quote path))) + (cvs-or + ;; Conflict + (and + (cvs-match (concat "C \\(.*" qfile "\\)$") (path 1) (type 'CONFLICT)) + ;; C might be followed by a "suprious" U for non-mergeable files + (cvs-or (cvs-match (concat "U \\(.*" qfile "\\)$")) t)) + ;; Successful merge + (cvs-match (concat "M \\(.*" qfile "\\)$") (path 1)) + ;; The file already contained the modifications + (cvs-match (concat "^\\(.*" qfile + "\\) already contains the differences between .*$") + (path 1) (type '(UP-TO-DATE . MERGED))) + t) + ;; FIXME: PATH might not be set yet. Sometimes the only path + ;; information is in `RCS file: ...' (yuck!!). + (cvs-parsed-fileinfo (if dont-change-disc 'NEED-MERGE + (or type '(MODIFIED . MERGED))) path nil + :merge (cons base-rev head-rev)))))) + +(defun cvs-parse-status () + (let (nofile path base-rev head-rev type) + (and + (cvs-match + "===================================================================$") + (cvs-match "File: \\(no file \\)?\\(.*[^ \t]\\)[ \t]+Status: " + (nofile 1) (path 2)) + (cvs-or + (cvs-match "Needs \\(Checkout\\|Patch\\)$" + (type (if nofile 'MISSING 'NEED-UPDATE))) + (cvs-match "Up-to-date$" + (type (if nofile '(UP-TO-DATE . REMOVED) 'UP-TO-DATE))) + (cvs-match "File had conflicts on merge$" (type 'MODIFIED)) + (cvs-match ".*[Cc]onflict.*$" (type 'CONFLICT)) + (cvs-match "Locally Added$" (type 'ADDED)) + (cvs-match "Locally Removed$" (type 'REMOVED)) + (cvs-match "Locally Modified$" (type 'MODIFIED)) + (cvs-match "Needs Merge$" (type 'NEED-MERGE)) + (cvs-match "Entry Invalid" (type '(NEED-MERGE . REMOVED))) + (cvs-match ".*$" (type 'UNKNOWN))) + (cvs-match "$") + (cvs-or + (cvs-match " *Version:[ \t]*\\([0-9.]+\\).*$" (base-rev 1)) + ;; NOTE: there's no date on the end of the following for server mode... + (cvs-match " *Working revision:[ \t]*-?\\([0-9.]+\\).*$" (base-rev 1)) + ;; Let's not get all worked up if the format changes a bit + (cvs-match " *Working revision:.*$")) + (cvs-or + (cvs-match " *RCS Version:[ \t]*\\([0-9.]+\\)[ \t]*.*$" (head-rev 1)) + (cvs-match " *Repository revision:[ \t]*\\([0-9.]+\\)[ \t]*\\(.*\\)$" + (head-rev 1)) + (cvs-match " *Repository revision:.*")) + (cvs-or (cvs-match " *Expansion option:.*") t) ;Optional CVSNT thingie. + (cvs-or (cvs-match " *Commit Identifier:.*") t) ;Optional CVSNT thingie. + (cvs-or + (and ;; Sometimes those fields are missing. + (cvs-match " *Sticky Tag:[ \t]*\\(.*\\)$") ; FIXME: use it. + (cvs-match " *Sticky Date:[ \t]*\\(.*\\)$") ; FIXME: use it. + (cvs-match " *Sticky Options:[ \t]*\\(.*\\)$")) ; FIXME: use it. + t) + (cvs-or (cvs-match " *Merge From:.*") t) ;Optional CVSNT thingie. + (cvs-match "$") + ;; ignore the tags-listing in the case of `status -v' + (cvs-or (cvs-match " *Existing Tags:\n\\(\t.*\n\\)*$") t) + (cvs-parsed-fileinfo type path nil + :base-rev base-rev + :head-rev head-rev)))) + +(defun cvs-parse-commit () + (let (path file base-rev subtype) + (cvs-or + + (and + (cvs-or + (cvs-match "\\(Checking in\\|Removing\\) \\(.*\\);$" (path 2)) + t) + (cvs-match ".*,v <-- \\(.*\\)$" (file 1)) + (cvs-or + ;; deletion + (cvs-match "new revision: delete; previous revision: \\([0-9.]*\\)$" + (subtype 'REMOVED) (base-rev 1)) + ;; addition + (cvs-match "initial revision: \\([0-9.]*\\)$" + (subtype 'ADDED) (base-rev 1)) + ;; update + (cvs-match "new revision: \\([0-9.]*\\); previous revision: .*$" + (subtype 'COMMITTED) (base-rev 1))) + (cvs-or (cvs-match "done$") t) + ;; In cvs-1.12.9 commit messages have been changed and became + ;; ambiguous. More specifically, the `path' above is not given. + ;; We assume here that in future releases the corresponding info will + ;; be put into `file'. + (progn + ;; Try to remove the temp files used by VC. + (vc-delete-automatic-version-backups (expand-file-name (or path file))) + ;; it's important here not to rely on the default directory management + ;; because `cvs commit' might begin by a series of Examining messages + ;; so the processing of the actual checkin messages might begin with + ;; a `current-dir' set to something different from "" + (cvs-parsed-fileinfo (cons 'UP-TO-DATE subtype) + (or path file) 'trust + :base-rev base-rev))) + + ;; useless message added before the actual addition: ignored + (cvs-match "RCS file: .*\ndone$")))) + + +(provide 'pcvs-parse) + +;; arch-tag: 35418375-1a23-40a0-957d-96b0262f91d6 +;;; pcvs-parse.el ends here diff --cc lisp/vc/pcvs-util.el index 595b762b2fa,00000000000..ebcd3583210 mode 100644,000000..100644 --- a/lisp/vc/pcvs-util.el +++ b/lisp/vc/pcvs-util.el @@@ -1,372 -1,0 +1,372 @@@ +;;; pcvs-util.el --- utility functions for PCL-CVS -*- byte-compile-dynamic: t -*- + +;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - ;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ++;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. + +;; Author: Stefan Monnier +;; 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 . + +;;; Commentary: + + +;;; Code: + +(eval-when-compile (require 'cl)) + +;;;; +;;;; list processing +;;;; + +(defsubst cvs-car (x) (if (consp x) (car x) x)) +(defalias 'cvs-cdr 'cdr-safe) +(defsubst cvs-append (&rest xs) + (apply 'append (mapcar (lambda (x) (if (listp x) x (list x))) xs))) + +(defsubst cvs-every (-cvs-every-f -cvs-every-l) + (while (consp -cvs-every-l) + (unless (funcall -cvs-every-f (pop -cvs-every-l)) + (setq -cvs-every-l t))) + (not -cvs-every-l)) + +(defun cvs-union (xs ys) + (let ((zs ys)) + (dolist (x xs zs) + (unless (member x ys) (push x zs))))) + +(defun cvs-map (-cvs-map-f &rest -cvs-map-ls) + (let ((accum ())) + (while (not (cvs-every 'null -cvs-map-ls)) + (push (apply -cvs-map-f (mapcar 'car -cvs-map-ls)) accum) + (setq -cvs-map-ls (mapcar 'cdr -cvs-map-ls))) + (nreverse accum))) + +(defun cvs-first (l &optional n) + (if (null n) (car l) + (when l + (let* ((nl (list (pop l))) + (ret nl)) + (while (and l (> n 1)) + (setcdr nl (list (pop l))) + (setq nl (cdr nl)) + (decf n)) + ret)))) + +(defun cvs-partition (p l) + "Partition a list L into two lists based on predicate P. +The function returns a `cons' cell where the `car' contains +elements of L for which P is true while the `cdr' contains +the other elements. The ordering among elements is maintained." + (let (car cdr) + (dolist (x l) + (if (funcall p x) (push x car) (push x cdr))) + (cons (nreverse car) (nreverse cdr)))) + +;;; +;;; frame, window, buffer handling +;;; + +(defun cvs-pop-to-buffer-same-frame (buf) + "Pop to BUF like `pop-to-buffer' but staying on the same frame. +If `pop-to-buffer' would have opened a new frame, this function would +try to split a new window instead." + (let ((pop-up-windows (or pop-up-windows pop-up-frames)) + (pop-up-frames nil)) + (or (let ((buf (get-buffer-window buf))) (and buf (select-window buf))) + (and pop-up-windows + (ignore-errors (select-window (split-window-vertically))) + (switch-to-buffer buf)) + (pop-to-buffer (current-buffer))))) + +(defun cvs-bury-buffer (buf &optional mainbuf) + "Hide the buffer BUF that was temporarily popped up. +BUF is assumed to be a temporary buffer used from the buffer MAINBUF." + (interactive (list (current-buffer))) + (save-current-buffer + (let ((win (if (eq buf (window-buffer (selected-window))) (selected-window) + (get-buffer-window buf t)))) + (when win + (if (window-dedicated-p win) + (condition-case () + (delete-window win) + (error (iconify-frame (window-frame win)))) +;;; (if (and mainbuf (get-buffer-window mainbuf)) +;;; ;; FIXME: if the buffer popped into a pre-existing window, +;;; ;; we don't want to delete that window. +;;; t ;;(delete-window win) +;;; ) + ))) + (with-current-buffer buf + (bury-buffer (unless (and (eq buf (window-buffer (selected-window))) + (not (window-dedicated-p (selected-window)))) + buf))) + (when mainbuf + (let ((mainwin (or (get-buffer-window mainbuf) + (get-buffer-window mainbuf 'visible)))) + (when mainwin (select-window mainwin)))))) + +(defun cvs-get-buffer-create (name &optional noreuse) + "Create a buffer NAME unless such a buffer already exists. +If the NAME looks like an absolute file name, the buffer will be created +with `create-file-buffer' and will probably get another name than NAME. +In such a case, the search for another buffer with the same name doesn't +use the buffer name but the buffer's `list-buffers-directory' variable. +If NOREUSE is non-nil, always return a new buffer." + (or (and (not (file-name-absolute-p name)) + (if noreuse (generate-new-buffer name) + (get-buffer-create name))) + (unless noreuse + (dolist (buf (buffer-list)) + (with-current-buffer buf + (when (equal name list-buffers-directory) + (return buf))))) + (with-current-buffer (create-file-buffer name) + (setq list-buffers-directory name) + (current-buffer)))) + +;;;; +;;;; string processing +;;;; + +(defun cvs-insert-strings (strings) + "Insert a list of STRINGS into the current buffer. +Uses columns to keep the listing readable but compact." + (when (consp strings) + (let* ((length (apply 'max (mapcar 'length strings))) + (wwidth (1- (window-width))) + (columns (min + ;; At least 2 columns; at least 2 spaces between columns. + (max 2 (/ wwidth (+ 2 length))) + ;; Don't allocate more columns than we can fill. + ;; Windows can't show less than 3 lines anyway. + (max 1 (/ (length strings) 2)))) + (colwidth (/ wwidth columns))) + ;; Use tab-width rather than indent-to. + (setq tab-width colwidth) + ;; The insertion should be "sensible" no matter what choices were made. + (dolist (str strings) + (unless (bolp) + (insert " \t") + (when (< wwidth (+ (max colwidth (length str)) (current-column))) + (delete-char -2) (insert "\n"))) + (insert str))))) + + +(defun cvs-file-to-string (file &optional oneline args) + "Read the content of FILE and return it as a string. +If ONELINE is t, only the first line (no \\n) will be returned. +If ARGS is non-nil, the file will be executed with ARGS as its +arguments. If ARGS is not a list, no argument will be passed." + (condition-case nil + (with-temp-buffer + (if args + (apply 'call-process + file nil t nil (when (listp args) args)) + (insert-file-contents file)) + (goto-char (point-min)) + (buffer-substring (point) + (if oneline (line-end-position) (point-max)))) + (file-error nil))) + +(defun cvs-string-prefix-p (str1 str2) + "Tell whether STR1 is a prefix of STR2." + (eq t (compare-strings str2 nil (length str1) str1 nil nil))) + +;;;; +;;;; file names +;;;; + +(defsubst cvs-expand-dir-name (d) + (file-name-as-directory (expand-file-name d))) + +;;;; +;;;; (interactive ) support function +;;;; + +(defstruct (cvs-qtypedesc + (:constructor nil) (:copier nil) + (:constructor cvs-qtypedesc-create + (str2obj obj2str &optional complete hist-sym require))) + str2obj + obj2str + hist-sym + complete + require) + + +(defconst cvs-qtypedesc-string1 (cvs-qtypedesc-create 'identity 'identity t)) +(defconst cvs-qtypedesc-string (cvs-qtypedesc-create 'identity 'identity)) +(defconst cvs-qtypedesc-strings + (cvs-qtypedesc-create 'split-string-and-unquote + 'combine-and-quote-strings nil)) + +(defun cvs-query-read (default prompt qtypedesc &optional hist-sym) + (let* ((qtypedesc (or qtypedesc cvs-qtypedesc-strings)) + (hist-sym (or hist-sym (cvs-qtypedesc-hist-sym qtypedesc))) + (complete (cvs-qtypedesc-complete qtypedesc)) + (completions (and (functionp complete) (funcall complete))) + (initval (funcall (cvs-qtypedesc-obj2str qtypedesc) default))) + (funcall (cvs-qtypedesc-str2obj qtypedesc) + (cond + ((null complete) (read-string prompt initval hist-sym)) + ((functionp complete) + (completing-read prompt completions + nil (cvs-qtypedesc-require qtypedesc) + initval hist-sym)) + (t initval))))) + +;;;; +;;;; Flags handling +;;;; + +(defstruct (cvs-flags + (:constructor nil) + (:constructor -cvs-flags-make + (desc defaults &optional qtypedesc hist-sym))) + defaults persist desc qtypedesc hist-sym) + +(defmacro cvs-flags-define (sym defaults + &optional desc qtypedesc hist-sym docstring) + `(defconst ,sym + (let ((bound (boundp ',sym))) + (if (and bound (cvs-flags-p ,sym)) ,sym + (let ((defaults ,defaults)) + (-cvs-flags-make ,desc + (if bound (cons ,sym (cdr defaults)) defaults) + ,qtypedesc ,hist-sym)))) + ,docstring)) + +(defun cvs-flags-query (sym &optional desc arg) + "Query flags based on SYM. +Optional argument DESC will be used for the prompt. +If ARG (or a prefix argument) is nil, just use the 0th default. +If it is a non-negative integer, use the corresponding default. +If it is a negative integer query for a new value of the corresponding + default and return that new value. +If it is \\[universal-argument], just query and return a value without + altering the defaults. +If it is \\[universal-argument] \\[universal-argument], behave just + as if a negative zero was provided." + (let* ((flags (symbol-value sym)) + (desc (or desc (cvs-flags-desc flags))) + (qtypedesc (cvs-flags-qtypedesc flags)) + (hist-sym (cvs-flags-hist-sym flags)) + (arg (if (eq arg 'noquery) 0 (or arg current-prefix-arg 0))) + (numarg (prefix-numeric-value arg)) + (defaults (cvs-flags-defaults flags)) + (permstr (if (< numarg 0) (format " (%sth default)" (- numarg))))) + ;; special case for universal-argument + (when (consp arg) + (setq permstr (if (> numarg 4) " (permanent)" "")) + (setq numarg 0)) + + ;; sanity check + (unless (< (abs numarg) (length defaults)) + (error "There is no %sth default" (abs numarg))) + + (if permstr + (let* ((prompt (format "%s%s: " desc permstr)) + (fs (cvs-query-read (nth (- numarg) (cvs-flags-defaults flags)) + prompt qtypedesc hist-sym))) + (when (not (equal permstr "")) + (setf (nth (- numarg) (cvs-flags-defaults flags)) fs)) + fs) + (nth numarg defaults)))) + +(defsubst cvs-flags-set (sym index value) + "Set SYM's INDEX'th setting to VALUE." + (setf (nth index (cvs-flags-defaults (symbol-value sym))) value)) + +;;;; +;;;; Prefix keys +;;;; + +(defconst cvs-prefix-number 10) + +(defsubst cvs-prefix-sym (sym) (intern (concat (symbol-name sym) "-cps"))) + +(defmacro cvs-prefix-define (sym docstring desc defaults + &optional qtypedesc hist-sym) + (let ((cps (cvs-prefix-sym sym))) + `(progn + (defvar ,sym nil ,(concat (or docstring "") " +See `cvs-prefix-set' for further description of the behavior.")) + (defvar ,cps + (let ((defaults ,defaults)) + ;; sanity ensurance + (unless (>= (length defaults) cvs-prefix-number) + (setq defaults (append defaults + (make-list (1- cvs-prefix-number) + (nth 0 defaults))))) + (-cvs-flags-make ,desc defaults ,qtypedesc ,hist-sym)))))) + +(defun cvs-prefix-make-local (sym) + (let ((cps (cvs-prefix-sym sym))) + (make-local-variable sym) + (set (make-local-variable cps) (copy-cvs-flags (symbol-value cps))))) + +(defun cvs-prefix-set (sym arg) + ;; we could distinguish between numeric and non-numeric prefix args instead of + ;; relying on that magic `4'. + "Set the cvs-prefix contained in SYM. +If ARG is between 0 and 9, it selects the corresponding default. +If ARG is negative (or \\[universal-argument] which corresponds to negative 0), + it queries the user and sets the -ARG'th default. +If ARG is greater than 9 (or \\[universal-argument] \\[universal-argument]), + the (ARG mod 10)'th prefix is made persistent. +If ARG is nil toggle the PREFIX's value between its 0th default and nil + and reset the persistence." + (let* ((prefix (symbol-value (cvs-prefix-sym sym))) + (numarg (if (integerp arg) arg 0)) + ;; (defs (cvs-flags-defaults prefix)) + ) + + ;; set persistence if requested + (when (> (prefix-numeric-value arg) 9) + (setf (cvs-flags-persist prefix) t) + (setq numarg (mod numarg 10))) + + ;; set the value + (set sym + (cond + ((null arg) + (setf (cvs-flags-persist prefix) nil) + (unless (symbol-value sym) (nth 0 (cvs-flags-defaults prefix)))) + + ((or (consp arg) (< numarg 0)) + (setf (nth (- numarg) (cvs-flags-defaults prefix)) + (cvs-query-read (nth (- numarg) (cvs-flags-defaults prefix)) + (format "%s: " (cvs-flags-desc prefix)) + (cvs-flags-qtypedesc prefix) + (cvs-flags-hist-sym prefix)))) + (t (nth numarg (cvs-flags-defaults prefix))))) + (force-mode-line-update))) + +(defun cvs-prefix-get (sym &optional read-only) + "Return the current value of the prefix SYM. +And reset it unless READ-ONLY is non-nil." + (prog1 (symbol-value sym) + (unless (or read-only + (cvs-flags-persist (symbol-value (cvs-prefix-sym sym)))) + (set sym nil) + (force-mode-line-update)))) + +(provide 'pcvs-util) + +;; arch-tag: 3b2588bb-2ae3-4f1f-bf5b-dea91b1f8a59 +;;; pcvs-util.el ends here diff --cc lisp/vc/pcvs.el index 305e109b6d6,00000000000..fbc089afc4c mode 100644,000000..100644 --- a/lisp/vc/pcvs.el +++ b/lisp/vc/pcvs.el @@@ -1,2443 -1,0 +1,2443 @@@ +;;; pcvs.el --- a front-end to CVS + +;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - ;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ++;; 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 . + +;;; Commentary: + +;; PCL-CVS is a front-end to the CVS version control system. For people +;; familiar with VC, it is somewhat like VC-dired: it presents the status of +;; all the files in your working area and allows you to commit/update several +;; of them at a time. Compared to VC-dired, it is considerably better and +;; faster (but only for CVS). + +;; PCL-CVS was originally written by Per Cederqvist many years ago. This +;; version derives from the XEmacs-21 version, itself based on the 2.0b2 +;; version (last release from Per). It is a thorough rework. + +;; Contrary to what you'd expect, PCL-CVS is not a replacement for VC but only +;; for VC-dired. As such, I've tried to make PCL-CVS and VC interoperate +;; seamlessly (I also use VC). + +;; To use PCL-CVS just use `M-x cvs-examine RET RET'. +;; There is a TeXinfo manual, which can be helpful to get started. + +;;; Bugs: + +;; - Extracting an old version seems not to recognize encoding correctly. +;; That's probably because it's done via a process rather than a file. + +;;; Todo: + +;; ******** FIX THE DOCUMENTATION ********* +;; +;; - rework the displaying of error messages. +;; - allow to flush messages only +;; - allow to protect files like ChangeLog from flushing +;; - automatically cvs-mode-insert files from find-file-hook +;; (and don't flush them as long as they are visited) +;; - query the user for cvs-get-marked (for some cmds or if nothing's selected) +;; - don't return the first (resp last) FI if the cursor is before +;; (resp after) it. +;; - allow cvs-confirm-removals to force always confirmation. +;; - cvs-checkout should ask for a revision (with completion). +;; - removal confirmation should allow specifying another file name. +;; +;; - hide fileinfos without getting rid of them (will require ewok work). +;; - add toolbar entries +;; - marking +;; marking directories should jump to just after the dir. +;; allow (un)marking directories at a time with the mouse. +;; allow cvs-cmd-do to either clear the marks or not. +;; add a "marks active" notion, like transient-mark-mode does. +;; - liveness indicator +;; - indicate in docstring if the cmd understands the `b' prefix(es). +;; - call smerge-mode when opening CONFLICT files. +;; - have vc-checkin delegate to cvs-mode-commit when applicable +;; - higher-level CVS operations +;; cvs-mode-rename +;; cvs-mode-branch +;; - module-level commands +;; add support for parsing 'modules' file ("cvs co -c") +;; cvs-mode-rcs2log +;; cvs-rdiff +;; cvs-release +;; cvs-import +;; C-u M-x cvs-checkout should ask for a cvsroot +;; cvs-mode-handle-new-vendor-version +;; - checks out module, or alternately does update join +;; - does "cvs -n tag LAST_VENDOR" to find old files into *cvs* +;; cvs-export +;; (with completion on tag names and hooks to help generate full releases) +;; - display stickiness information. And current CVS/Tag as well. +;; - write 'cvs-mode-admin' to do arbitrary 'cvs admin' commands +;; Most interesting would be version removal and log message replacement. +;; The last one would be neat when called from log-view-mode. +;; - cvs-mode-incorporate +;; It would merge in the status from one *cvs* buffer into another. +;; This would be used to populate such a buffer that had been created with +;; a `cvs {update,status,checkout} -l'. +;; - cvs-mode-(i)diff-other-{file,buffer,cvs-buffer} +;; - offer the choice to kill the process when the user kills the cvs buffer. +;; right now, it's killed without further ado. +;; - make `cvs-mode-ignore' allow manually entering a pattern. +;; to which dir should it apply ? +;; - cvs-mode-ignore should try to remove duplicate entries. +;; - maybe poll/check CVS/Entries files to react to external `cvs' commands ? +;; - some kind of `cvs annotate' support ? +;; but vc-annotate can be used instead. +;; - proper `g' that passes safe args and uses either cvs-status or cvs-examine +;; maybe also use cvs-update depending on I-don't-know-what. +;; - add message-levels so that we can hide some levels of messages + +;;; Code: + +(eval-when-compile (require 'cl)) +(require 'ewoc) ;Ewoc was once cookie +(require 'pcvs-defs) +(require 'pcvs-util) +(require 'pcvs-parse) +(require 'pcvs-info) + + +;;;; +;;;; global vars +;;;; + +(defvar cvs-cookies) ;;nil + ;;"Handle for the cookie structure that is displayed in the *cvs* buffer.") +;;(make-variable-buffer-local 'cvs-cookies) + +;;;; +;;;; Dynamically scoped variables +;;;; + +(defvar cvs-from-vc nil "Bound to t inside VC advice.") + +;;;; +;;;; flags variables +;;;; + +(defun cvs-defaults (&rest defs) + (let ((defs (cvs-first defs cvs-shared-start))) + (append defs + (make-list (- cvs-shared-start (length defs)) (car defs)) + cvs-shared-flags))) + +;; For cvs flags, we need to add "-f" to override the cvsrc settings +;; we also want to evict the annoying -q and -Q options that hide useful +;; information from pcl-cvs. +(cvs-flags-define cvs-cvs-flags '(("-f"))) + +(cvs-flags-define cvs-checkout-flags (cvs-defaults '("-P"))) +(cvs-flags-define cvs-status-flags (cvs-defaults '("-v") nil)) +(cvs-flags-define cvs-log-flags (cvs-defaults nil)) +(cvs-flags-define cvs-diff-flags (cvs-defaults '("-u" "-N") '("-c" "-N") '("-u" "-b"))) +(cvs-flags-define cvs-tag-flags (cvs-defaults nil)) +(cvs-flags-define cvs-add-flags (cvs-defaults nil)) +(cvs-flags-define cvs-commit-flags (cvs-defaults nil)) +(cvs-flags-define cvs-remove-flags (cvs-defaults nil)) +;;(cvs-flags-define cvs-undo-flags (cvs-defaults nil)) +(cvs-flags-define cvs-update-flags (cvs-defaults '("-d" "-P"))) + +(defun cvs-reread-cvsrc () + "Reset the default arguments to those in the `cvs-cvsrc-file'." + (interactive) + (condition-case nil + (with-temp-buffer + (insert-file-contents cvs-cvsrc-file) + ;; fetch the values + (dolist (cmd '("cvs" "checkout" "status" "log" "diff" "tag" + "add" "commit" "remove" "update")) + (goto-char (point-min)) + (when (re-search-forward + (concat "^" cmd "\\(\\s-+\\(.*\\)\\)?$") nil t) + (let* ((sym (intern (concat "cvs-" cmd "-flags"))) + (val (split-string-and-unquote (or (match-string 2) "")))) + (cvs-flags-set sym 0 val)))) + ;; ensure that cvs doesn't have -q or -Q + (cvs-flags-set 'cvs-cvs-flags 0 + (cons "-f" + (cdr (cvs-partition + (lambda (x) (member x '("-q" "-Q" "-f"))) + (cvs-flags-query 'cvs-cvs-flags + nil 'noquery)))))) + (file-error nil))) + +;; initialize to cvsrc's default values +(cvs-reread-cvsrc) + + +;;;; +;;;; Mouse bindings and mode motion +;;;; + +(defvar cvs-minor-current-files) + +(defun cvs-menu (e) + "Popup the CVS menu." + (interactive "e") + (let ((cvs-minor-current-files + (list (ewoc-data (ewoc-locate + cvs-cookies (posn-point (event-end e))))))) + (popup-menu cvs-menu e))) + +(defvar cvs-mode-line-process nil + "Mode-line control for displaying info on cvs process status.") + + +;;;; +;;;; Query-Type-Descriptor for Tags +;;;; + +(autoload 'cvs-status-get-tags "cvs-status") +(defun cvs-tags-list () + "Return a list of acceptable tags, ready for completions." + (assert (cvs-buffer-p)) + (let ((marked (cvs-get-marked))) + (list* '("BASE") '("HEAD") + (when marked + (with-temp-buffer + (process-file cvs-program + nil ;no input + t ;output to current-buffer + nil ;don't update display while running + "status" + "-v" + (cvs-fileinfo->full-name (car marked))) + (goto-char (point-min)) + (let ((tags (cvs-status-get-tags))) + (when (listp tags) tags))))))) + +(defvar cvs-tag-history nil) +(defconst cvs-qtypedesc-tag + (cvs-qtypedesc-create 'identity 'identity 'cvs-tags-list 'cvs-tag-history)) + +;;;; + +(defun cvs-mode! (&optional -cvs-mode!-fun) + "Switch to the *cvs* buffer. +If -CVS-MODE!-FUN is provided, it is executed *cvs* being the current buffer + and with its window selected. Else, the *cvs* buffer is simply selected. +-CVS-MODE!-FUN is called interactively if applicable and else with no argument." + (let* ((-cvs-mode!-buf (current-buffer)) + (cvsbuf (cond ((cvs-buffer-p) (current-buffer)) + ((and cvs-buffer (cvs-buffer-p cvs-buffer)) cvs-buffer) + (t (error "can't find the *cvs* buffer")))) + (-cvs-mode!-wrapper cvs-minor-wrap-function) + (-cvs-mode!-cont (lambda () + (save-current-buffer + (if (commandp -cvs-mode!-fun) + (call-interactively -cvs-mode!-fun) + (funcall -cvs-mode!-fun)))))) + (if (not -cvs-mode!-fun) (set-buffer cvsbuf) + (let ((cvs-mode!-buf (current-buffer)) + (cvs-mode!-owin (selected-window)) + (cvs-mode!-nwin (get-buffer-window cvsbuf 'visible))) + (unwind-protect + (progn + (set-buffer cvsbuf) + (when cvs-mode!-nwin (select-window cvs-mode!-nwin)) + (if -cvs-mode!-wrapper + (funcall -cvs-mode!-wrapper -cvs-mode!-buf -cvs-mode!-cont) + (funcall -cvs-mode!-cont))) + (set-buffer cvs-mode!-buf) + (when (and cvs-mode!-nwin (eq cvs-mode!-nwin (selected-window))) + ;; the selected window has not been changed by FUN + (select-window cvs-mode!-owin))))))) + +;;;; +;;;; Prefixes +;;;; + +(defvar cvs-branches (list cvs-vendor-branch "HEAD" "HEAD")) +(cvs-prefix-define cvs-branch-prefix + "Current selected branch." + "version" + (cons cvs-vendor-branch cvs-branches) + cvs-qtypedesc-tag) + +(defun cvs-set-branch-prefix (arg) + "Set the branch prefix to take action at the next command. +See `cvs-prefix-set' for a further the description of the behavior. +\\[universal-argument] 1 selects the vendor branch +and \\[universal-argument] 2 selects the HEAD." + (interactive "P") + (cvs-mode!) + (cvs-prefix-set 'cvs-branch-prefix arg)) + +(defun cvs-add-branch-prefix (flags &optional arg) + "Add branch selection argument if the branch prefix was set. +The argument is added (or not) to the list of FLAGS and is constructed +by appending the branch to ARG which defaults to \"-r\"." + (let ((branch (cvs-prefix-get 'cvs-branch-prefix))) + ;; deactivate the secondary prefix, even if not used. + (cvs-prefix-get 'cvs-secondary-branch-prefix) + (if branch (cons (concat (or arg "-r") branch) flags) flags))) + +(cvs-prefix-define cvs-secondary-branch-prefix + "Current secondary selected branch." + "version" + (cons cvs-vendor-branch cvs-branches) + cvs-qtypedesc-tag) + +(defun cvs-set-secondary-branch-prefix (arg) + "Set the branch prefix to take action at the next command. +See `cvs-prefix-set' for a further the description of the behavior. +\\[universal-argument] 1 selects the vendor branch +and \\[universal-argument] 2 selects the HEAD." + (interactive "P") + (cvs-mode!) + (cvs-prefix-set 'cvs-secondary-branch-prefix arg)) + +(defun cvs-add-secondary-branch-prefix (flags &optional arg) + "Add branch selection argument if the secondary branch prefix was set. +The argument is added (or not) to the list of FLAGS and is constructed +by appending the branch to ARG which defaults to \"-r\". +Since the `cvs-secondary-branch-prefix' is only active if the primary +prefix is active, it is important to read the secondary prefix before +the primay since reading the primary can deactivate it." + (let ((branch (and (cvs-prefix-get 'cvs-branch-prefix 'read-only) + (cvs-prefix-get 'cvs-secondary-branch-prefix)))) + (if branch (cons (concat (or arg "-r") branch) flags) flags))) + +;;;; + +(define-minor-mode cvs-minor-mode + "This mode is used for buffers related to a main *cvs* buffer. +All the `cvs-mode' buffer operations are simply rebound under +the \\[cvs-mode-map] prefix." + nil " CVS" + :group 'pcl-cvs) +(put 'cvs-minor-mode 'permanent-local t) + + +(defvar cvs-temp-buffers nil) +(defun cvs-temp-buffer (&optional cmd normal nosetup) + "Create a temporary buffer to run CMD in. +If CMD is a string, use it to lookup `cvs-buffer-name-alist' to find +the buffer name to be used and its `major-mode'. + +The selected window will not be changed. The new buffer will not maintain undo +information and will be read-only unless NORMAL is non-nil. It will be emptied +\(unless NOSETUP is non-nil\) and its `default-directory' will be inherited +from the current buffer." + (let* ((cvs-buf (current-buffer)) + (info (cdr (assoc cmd cvs-buffer-name-alist))) + (name (eval (nth 0 info))) + (mode (nth 1 info)) + (dir default-directory) + (buf (cond + (name (cvs-get-buffer-create name)) + ((and (bufferp cvs-temp-buffer) (buffer-live-p cvs-temp-buffer)) + cvs-temp-buffer) + (t + (set (make-local-variable 'cvs-temp-buffer) + (cvs-get-buffer-create + (eval cvs-temp-buffer-name) 'noreuse)))))) + + ;; handle the potential pre-existing process + (let ((proc (get-buffer-process buf))) + (when (and (not normal) (processp proc) + (memq (process-status proc) '(run stop))) + (if cmd + ;; When CMD is specified, the buffer is normally shown to the + ;; user, so interrupting the process is not harmful. + ;; Use `delete-process' rather than `kill-process' otherwise + ;; the pending output of the process will still get inserted + ;; after we erase the buffer. + (delete-process proc) + (error "Can not run two cvs processes simultaneously")))) + + (if (not name) (kill-local-variable 'other-window-scroll-buffer) + ;; Strangely, if no window is created, `display-buffer' ends up + ;; doing a `switch-to-buffer' which does a `set-buffer', hence + ;; the need for `save-excursion'. + (unless nosetup (save-excursion (display-buffer buf))) + ;; FIXME: this doesn't do the right thing if the user later on + ;; does a `find-file-other-window' and `scroll-other-window' + (set (make-local-variable 'other-window-scroll-buffer) buf)) + + (add-to-list 'cvs-temp-buffers buf) + + (with-current-buffer buf + (setq buffer-read-only nil) + (setq default-directory dir) + (unless nosetup + ;; Disable undo before calling erase-buffer since it may generate + ;; a very large and unwanted undo record. + (buffer-disable-undo) + (erase-buffer)) + (set (make-local-variable 'cvs-buffer) cvs-buf) + ;;(cvs-minor-mode 1) + (let ((lbd list-buffers-directory)) + (if (fboundp mode) (funcall mode) (fundamental-mode)) + (when lbd (setq list-buffers-directory lbd))) + (cvs-minor-mode 1) + ;;(set (make-local-variable 'cvs-buffer) cvs-buf) + (if normal + (buffer-enable-undo) + (setq buffer-read-only t) + (buffer-disable-undo)) + buf))) + +(defun cvs-mode-kill-buffers () + "Kill all the \"temporary\" buffers created by the *cvs* buffer." + (interactive) + (dolist (buf cvs-temp-buffers) (ignore-errors (kill-buffer buf)))) + +(defun cvs-make-cvs-buffer (dir &optional new) + "Create the *cvs* buffer for directory DIR. +If non-nil, NEW means to create a new buffer no matter what." + ;; the real cvs-buffer creation + (setq dir (cvs-expand-dir-name dir)) + (let* ((buffer-name (eval cvs-buffer-name)) + (buffer + (or (and (not new) + (eq cvs-reuse-cvs-buffer 'current) + (cvs-buffer-p) ;reuse the current buffer if possible + (current-buffer)) + ;; look for another cvs buffer visiting the same directory + (save-excursion + (unless new + (dolist (buffer (cons (current-buffer) (buffer-list))) + (set-buffer buffer) + (and (cvs-buffer-p) + (case cvs-reuse-cvs-buffer + (always t) + (subdir + (or (cvs-string-prefix-p default-directory dir) + (cvs-string-prefix-p dir default-directory))) + (samedir (string= default-directory dir))) + (return buffer))))) + ;; we really have to create a new buffer: + ;; we temporarily bind cwd to "" to prevent + ;; create-file-buffer from using directory info + ;; unless it is explicitly in the cvs-buffer-name. + (cvs-get-buffer-create buffer-name new)))) + (with-current-buffer buffer + (or + (and (string= dir default-directory) (cvs-buffer-p) + ;; just a refresh + (ignore-errors + (cvs-cleanup-collection cvs-cookies nil nil t) + (current-buffer))) + ;; setup from scratch + (progn + (setq default-directory dir) + (setq buffer-read-only nil) + (erase-buffer) + (insert "Repository : " (directory-file-name (cvs-get-cvsroot)) + "\nModule : " (cvs-get-module) + "\nWorking dir: " (abbreviate-file-name dir) + (if (not (file-readable-p "CVS/Tag")) "\n" + (let ((tag (cvs-file-to-string "CVS/Tag"))) + (cond + ((string-match "\\`T" tag) + (concat "\nTag : " (substring tag 1))) + ((string-match "\\`D" tag) + (concat "\nDate : " (substring tag 1))) + ("\n")))) + "\n") + (setq buffer-read-only t) + (cvs-mode) + (set (make-local-variable 'list-buffers-directory) buffer-name) + ;;(set (make-local-variable 'cvs-temp-buffer) (cvs-temp-buffer)) + (let ((cookies (ewoc-create 'cvs-fileinfo-pp "\n\n" "\n" t))) + (set (make-local-variable 'cvs-cookies) cookies) + (add-hook 'kill-buffer-hook + (lambda () + (ignore-errors (kill-buffer cvs-temp-buffer))) + nil t) + ;;(set-buffer buf) + buffer)))))) + +(defun* cvs-cmd-do (cmd dir flags fis new + &key cvsargs noexist dont-change-disc noshow) + (let* ((dir (file-name-as-directory + (abbreviate-file-name (expand-file-name dir)))) + (cvsbuf (cvs-make-cvs-buffer dir new))) + ;; Check that dir is under CVS control. + (unless (file-directory-p dir) + (error "%s is not a directory" dir)) + (unless (or noexist (file-directory-p (expand-file-name "CVS" dir)) + (file-expand-wildcards (expand-file-name "*/CVS" dir))) + (error "%s does not contain CVS controlled files" dir)) + + (set-buffer cvsbuf) + (cvs-mode-run cmd flags fis + :cvsargs cvsargs :dont-change-disc dont-change-disc) + + (if noshow cvsbuf + (let ((pop-up-windows nil)) (pop-to-buffer cvsbuf))))) +;; (funcall (if (and (boundp 'pop-up-frames) pop-up-frames) +;; 'pop-to-buffer 'switch-to-buffer) +;; cvsbuf)))) + +(defun cvs-run-process (args fis postprocess &optional single-dir) + (assert (cvs-buffer-p cvs-buffer)) + (save-current-buffer + (let ((procbuf (current-buffer)) + (cvsbuf cvs-buffer) + (single-dir (or single-dir (eq cvs-execute-single-dir t)))) + + (set-buffer procbuf) + (goto-char (point-max)) + (unless (bolp) (let ((inhibit-read-only t)) (insert "\n"))) + ;; find the set of files we'll process in this round + (let* ((dir+files+rest + (if (or (null fis) (not single-dir)) + ;; not single-dir mode: just process the whole thing + (list "" (mapcar 'cvs-fileinfo->full-name fis) nil) + ;; single-dir mode: extract the same-dir-elements + (let ((dir (cvs-fileinfo->dir (car fis)))) + ;; output the concerned dir so the parser can translate paths + (let ((inhibit-read-only t)) + (insert "pcl-cvs: descending directory " dir "\n")) + ;; loop to find the same-dir-elems + (do* ((files () (cons (cvs-fileinfo->file fi) files)) + (fis fis (cdr fis)) + (fi (car fis) (car fis))) + ((not (and fis (string= dir (cvs-fileinfo->dir fi)))) + (list dir files fis)))))) + (dir (nth 0 dir+files+rest)) + (files (nth 1 dir+files+rest)) + (rest (nth 2 dir+files+rest))) + + (add-hook 'kill-buffer-hook + (lambda () + (let ((proc (get-buffer-process (current-buffer)))) + (when (processp proc) + (set-process-filter proc nil) + ;; Abort postprocessing but leave the sentinel so it + ;; will update the list of running procs. + (process-put proc 'cvs-postprocess nil) + (interrupt-process proc)))) + nil t) + + ;; create the new process and setup the procbuffer correspondingly + (let* ((msg (cvs-header-msg args fis)) + (args (append (cvs-flags-query 'cvs-cvs-flags nil 'noquery) + (if cvs-cvsroot (list "-d" cvs-cvsroot)) + args + files)) + ;; If process-connection-type is nil and the repository + ;; is accessed via SSH, a bad interaction between libc, + ;; CVS and SSH can lead to garbled output. + ;; It might be a glibc-specific problem (but it can also happens + ;; under Mac OS X, it seems). + ;; It seems that using a pty can help circumvent the problem, + ;; but at the cost of screwing up when the process thinks it + ;; can ask for user input (such as password or host-key + ;; confirmation). A better workaround is to set CVS_RSH to + ;; an appropriate script, or to use a later version of CVS. + (process-connection-type nil) ; Use a pipe, not a pty. + (process + ;; the process will be run in the selected dir + (let ((default-directory (cvs-expand-dir-name dir))) + (apply 'start-file-process "cvs" procbuf cvs-program args)))) + ;; setup the process. + (process-put process 'cvs-buffer cvs-buffer) + (with-current-buffer cvs-buffer (cvs-update-header msg 'add)) + (process-put process 'cvs-header msg) + (process-put + process 'cvs-postprocess + (if (null rest) + ;; this is the last invocation + postprocess + ;; else, we have to register ourselves to be rerun on the rest + `(cvs-run-process ',args ',rest ',postprocess ',single-dir))) + (set-process-sentinel process 'cvs-sentinel) + (set-process-filter process 'cvs-update-filter) + (set-marker (process-mark process) (point-max)) + (ignore-errors (process-send-eof process)) ;close its stdin to avoid hangs + + ;; now finish setting up the cvs-buffer + (set-buffer cvsbuf) + (setq cvs-mode-line-process (symbol-name (process-status process))) + (force-mode-line-update))))) + + ;; The following line is said to improve display updates on some + ;; emacsen. It shouldn't be needed, but it does no harm. + (sit-for 0)) + +(defun cvs-header-msg (args fis) + (let* ((lastarg nil) + (args (mapcar (lambda (arg) + (cond + ;; filter out the largish commit message + ((and (eq lastarg nil) (string= arg "commit")) + (setq lastarg 'commit) arg) + ((and (eq lastarg 'commit) (string= arg "-m")) + (setq lastarg '-m) arg) + ((eq lastarg '-m) + (setq lastarg 'done) "") + ;; filter out the largish `admin -mrev:msg' message + ((and (eq lastarg nil) (string= arg "admin")) + (setq lastarg 'admin) arg) + ((and (eq lastarg 'admin) + (string-match "\\`-m[^:]*:" arg)) + (setq lastarg 'done) + (concat (match-string 0 arg) "")) + ;; Keep the rest as is. + (t arg))) + args))) + (concat cvs-program " " + (combine-and-quote-strings + (append (cvs-flags-query 'cvs-cvs-flags nil 'noquery) + (if cvs-cvsroot (list "-d" cvs-cvsroot)) + args + (mapcar 'cvs-fileinfo->full-name fis)))))) + +(defun cvs-update-header (cmd add) + (let* ((hf (ewoc-get-hf cvs-cookies)) + (str (car hf)) + (done "") + (tin (ewoc-nth cvs-cookies 0))) + ;; look for the first *real* fileinfo (to determine emptyness) + (while + (and tin + (memq (cvs-fileinfo->type (ewoc-data tin)) + '(MESSAGE DIRCHANGE))) + (setq tin (ewoc-next cvs-cookies tin))) + (if add + (progn + ;; Remove the default empty line, if applicable. + (if (not (string-match "." str)) (setq str "\n")) + (setq str (concat "-- Running " cmd " ...\n" str))) + (if (not (string-match + ;; FIXME: If `cmd' is large, this will bump into the + ;; compiled-regexp size limit. We could drop the "^" anchor + ;; and use search-forward to circumvent the problem. + (concat "^-- Running " (regexp-quote cmd) " \\.\\.\\.\n") str)) + (error "Internal PCL-CVS error while removing message") + (setq str (replace-match "" t t str)) + ;; Re-add the default empty line, if applicable. + (if (not (string-match "." str)) (setq str "\n\n")) + (setq done (concat "-- last cmd: " cmd " --\n")))) + ;; set the new header and footer + (ewoc-set-hf cvs-cookies + str (concat "\n--------------------- " + (if tin "End" "Empty") + " ---------------------\n" + done)))) + + +(defun cvs-sentinel (proc msg) + "Sentinel for the cvs update process. +This is responsible for parsing the output from the cvs update when +it is finished." + (when (memq (process-status proc) '(signal exit)) + (let ((cvs-postproc (process-get proc 'cvs-postprocess)) + (cvs-buf (process-get proc 'cvs-buffer)) + (procbuf (process-buffer proc))) + (unless (buffer-live-p cvs-buf) (setq cvs-buf nil)) + (unless (buffer-live-p procbuf) (setq procbuf nil)) + ;; Since the buffer and mode line will show that the + ;; process is dead, we can delete it now. Otherwise it + ;; will stay around until M-x list-processes. + (process-put proc 'postprocess nil) + (delete-process proc) + ;; Don't do anything if the main buffer doesn't exist any more. + (when cvs-buf + (with-current-buffer cvs-buf + (cvs-update-header (process-get proc 'cvs-header) nil) + (setq cvs-mode-line-process (symbol-name (process-status proc))) + (force-mode-line-update) + (when cvs-postproc + (if (null procbuf) + ;;(set-process-buffer proc nil) + (error "cvs' process buffer was killed") + (with-current-buffer procbuf + ;; Do the postprocessing like parsing and such. + (save-excursion (eval cvs-postproc))))))) + ;; Check whether something is left. + (when (and procbuf (not (get-buffer-process procbuf))) + (with-current-buffer procbuf + ;; IIRC, we enable undo again once the process is finished + ;; for cases where the output was inserted in *vc-diff* or + ;; in a file-like buffer. --Stef + (buffer-enable-undo) + (with-current-buffer (or cvs-buf (current-buffer)) + (message "CVS process has completed in %s" + (buffer-name)))))))) + +(defun cvs-parse-process (dcd &optional subdir old-fis) + "Parse the output of a cvs process. +DCD is the `dont-change-disc' flag to use when parsing that output. +SUBDIR is the subdirectory (if any) where this command was run. +OLD-FIS is the list of fileinfos on which the cvs command was applied and + which should be considered up-to-date if they are missing from the output." + (when (eq system-type 'darwin) + ;; Fixup the ^D^H^H inserted at beginning of buffer sometimes on MacOSX + ;; because of the call to `process-send-eof'. + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "^\\^D+" nil t) + (let ((inhibit-read-only t)) + (delete-region (match-beginning 0) (match-end 0)))))) + (let* ((fileinfos (cvs-parse-buffer 'cvs-parse-table dcd subdir)) + last) + (with-current-buffer cvs-buffer + ;; Expand OLD-FIS to actual files. + (let ((fis nil)) + (dolist (fi old-fis) + (setq fis (if (eq (cvs-fileinfo->type fi) 'DIRCHANGE) + (nconc (ewoc-collect cvs-cookies 'cvs-dir-member-p + (cvs-fileinfo->dir fi)) + fis) + (cons fi fis)))) + (setq old-fis fis)) + ;; Drop OLD-FIS which were already up-to-date. + (let ((fis nil)) + (dolist (fi old-fis) + (unless (eq (cvs-fileinfo->type fi) 'UP-TO-DATE) (push fi fis))) + (setq old-fis fis)) + ;; Add the new fileinfos to the ewoc. + (dolist (fi fileinfos) + (setq last (cvs-addto-collection cvs-cookies fi last)) + ;; This FI was in the output, so remove it from OLD-FIS. + (setq old-fis (delq (ewoc-data last) old-fis))) + ;; Process the "silent output" (i.e. absence means up-to-date). + (dolist (fi old-fis) + (setf (cvs-fileinfo->type fi) 'UP-TO-DATE) + (setq last (cvs-addto-collection cvs-cookies fi last))) + (setq fileinfos (nconc old-fis fileinfos)) + ;; Clean up the ewoc as requested by the user. + (cvs-cleanup-collection cvs-cookies + (eq cvs-auto-remove-handled t) + cvs-auto-remove-directories + nil) + ;; Revert buffers if necessary. + (when (and cvs-auto-revert (not dcd) (not cvs-from-vc)) + (cvs-revert-if-needed fileinfos))))) + +(defmacro defun-cvs-mode (fun args docstring interact &rest body) + "Define a function to be used in a *cvs* buffer. +This will look for a *cvs* buffer and execute BODY in it. +Since the interactive arguments might need to be queried after +switching to the *cvs* buffer, the generic code is rather ugly, +but luckily we can often use simpler alternatives. + +FUN can be either a symbol (i.e. STYLE is nil) or a cons (FUN . STYLE). +ARGS and DOCSTRING are the normal argument list. +INTERACT is the interactive specification or nil for non-commands. + +STYLE can be either SIMPLE, NOARGS or DOUBLE. It's an error for it +to have any other value, unless other details of the function make it +clear what alternative to use. +- SIMPLE will get all the interactive arguments from the original buffer. +- NOARGS will get all the arguments from the *cvs* buffer and will + always behave as if called interactively. +- DOUBLE is the generic case." + (declare (debug (&define sexp lambda-list stringp ("interactive" interactive) def-body)) + (doc-string 3)) + (let ((style (cvs-cdr fun)) + (fun (cvs-car fun))) + (cond + ;; a trivial interaction, no need to move it + ((or (eq style 'SIMPLE) + (null (nth 1 interact)) + (stringp (nth 1 interact))) + `(defun ,fun ,args ,docstring ,interact + (cvs-mode! (lambda () ,@body)))) + + ;; fun is only called interactively: move all the args to the inner fun + ((eq style 'NOARGS) + `(defun ,fun () ,docstring (interactive) + (cvs-mode! (lambda ,args ,interact ,@body)))) + + ;; bad case + ((eq style 'DOUBLE) + (string-match ".*" docstring) + (let ((line1 (match-string 0 docstring)) + (fun-1 (intern (concat (symbol-name fun) "-1")))) + `(progn + (defun ,fun-1 ,args + ,(concat docstring "\nThis function only works within a *cvs* buffer. +For interactive use, use `" (symbol-name fun) "' instead.") + ,interact + ,@body) + (put ',fun-1 'definition-name ',fun) + (defun ,fun () + ,(concat line1 "\nWrapper function that switches to a *cvs* buffer +before calling the real function `" (symbol-name fun-1) "'.\n") + (interactive) + (cvs-mode! ',fun-1))))) + + (t (error "Unknown style %s in `defun-cvs-mode'" style))))) + +(defun-cvs-mode cvs-mode-kill-process () + "Kill the temporary buffer and associated process." + (interactive) + (when (and (bufferp cvs-temp-buffer) (buffer-live-p cvs-temp-buffer)) + (let ((proc (get-buffer-process cvs-temp-buffer))) + (when proc (delete-process proc))))) + +;; +;; Maintaining the collection in the face of updates +;; + +(defun cvs-addto-collection (c fi &optional tin) + "Add FI to C and return FI's corresponding tin. +FI is inserted in its proper place or maybe even merged with a preexisting + fileinfo if applicable. +TIN specifies an optional starting point." + (unless tin (setq tin (ewoc-nth c 0))) + (while (and tin (cvs-fileinfo< fi (ewoc-data tin))) + (setq tin (ewoc-prev c tin))) + (if (null tin) (ewoc-enter-first c fi) ;empty collection + (assert (not (cvs-fileinfo< fi (ewoc-data tin)))) + (let ((next-tin (ewoc-next c tin))) + (while (not (or (null next-tin) + (cvs-fileinfo< fi (ewoc-data next-tin)))) + (setq tin next-tin next-tin (ewoc-next c next-tin))) + (if (or (cvs-fileinfo< (ewoc-data tin) fi) + (eq (cvs-fileinfo->type fi) 'MESSAGE)) + ;; tin < fi < next-tin + (ewoc-enter-after c tin fi) + ;; fi == tin + (cvs-fileinfo-update (ewoc-data tin) fi) + (ewoc-invalidate c tin) + ;; Move cursor back to where it belongs. + (when (bolp) (cvs-move-to-goal-column)) + tin)))) + +(defcustom cvs-cleanup-functions nil + "Functions to tweak the cleanup process. +The functions are called with a single argument (a FILEINFO) and should +return a non-nil value if that fileinfo should be removed." + :group 'pcl-cvs + :type '(hook :options (cvs-cleanup-removed))) + +(defun cvs-cleanup-removed (fi) + "Non-nil if FI has been cvs-removed but still exists. +This is intended for use on `cvs-cleanup-functions' when you have cvs-removed +automatically generated files (which should hence not be under CVS control) +but can't commit the removal because the repository's owner doesn't understand +the problem." + (and (or (eq (cvs-fileinfo->type fi) 'REMOVED) + (and (eq (cvs-fileinfo->type fi) 'CONFLICT) + (eq (cvs-fileinfo->subtype fi) 'REMOVED))) + (file-exists-p (cvs-fileinfo->full-name fi)))) + +;; called at the following times: +;; - postparse ((eq cvs-auto-remove-handled t) cvs-auto-remove-directories nil) +;; - pre-run ((eq cvs-auto-remove-handled 'delayed) nil t) +;; - remove-handled (t (or cvs-auto-remove-directories 'handled) t) +;; - cvs-cmd-do (nil nil t) +;; - post-ignore (nil nil nil) +;; - acknowledge (nil nil nil) +;; - remove (nil nil nil) +(defun cvs-cleanup-collection (c rm-handled rm-dirs rm-msgs) + "Remove undesired entries. +C is the collection +RM-HANDLED if non-nil means remove handled entries. +RM-DIRS behaves like `cvs-auto-remove-directories'. +RM-MSGS if non-nil means remove messages." + (let (last-fi first-dir (rerun t)) + (while rerun + (setq rerun nil) + (setq first-dir t) + (setq last-fi (cvs-create-fileinfo 'DEAD "../" "" "")) ;place-holder + (ewoc-filter + c (lambda (fi) + (let* ((type (cvs-fileinfo->type fi)) + (subtype (cvs-fileinfo->subtype fi)) + (keep + (case type + ;; remove temp messages and keep the others + (MESSAGE (not (or rm-msgs (eq subtype 'TEMP)))) + ;; remove entries + (DEAD nil) + ;; handled also? + (UP-TO-DATE (not rm-handled)) + ;; keep the rest + (t (not (run-hook-with-args-until-success + 'cvs-cleanup-functions fi)))))) + + ;; mark dirs for removal + (when (and keep rm-dirs + (eq (cvs-fileinfo->type last-fi) 'DIRCHANGE) + (not (when first-dir (setq first-dir nil) t)) + (or (eq rm-dirs 'all) + (not (cvs-string-prefix-p + (cvs-fileinfo->dir last-fi) + (cvs-fileinfo->dir fi))) + (and (eq type 'DIRCHANGE) (eq rm-dirs 'empty)) + (eq subtype 'FOOTER))) + (setf (cvs-fileinfo->type last-fi) 'DEAD) + (setq rerun t)) + (when keep (setq last-fi fi))))) + ;; remove empty last dir + (when (and rm-dirs + (not first-dir) + (eq (cvs-fileinfo->type last-fi) 'DIRCHANGE)) + (setf (cvs-fileinfo->type last-fi) 'DEAD) + (setq rerun t))))) + +(defun cvs-get-cvsroot () + "Gets the CVSROOT for DIR." + (let ((cvs-cvsroot-file (expand-file-name "Root" "CVS"))) + (or (cvs-file-to-string cvs-cvsroot-file t) + cvs-cvsroot + (getenv "CVSROOT") + "?????"))) + +(defun cvs-get-module () + "Return the current CVS module. +This usually doesn't really work but is a handy initval in a prompt." + (let* ((repfile (expand-file-name "Repository" "CVS")) + (rep (cvs-file-to-string repfile t))) + (cond + ((null rep) "") + ((not (file-name-absolute-p rep)) rep) + (t + (let* ((root (cvs-get-cvsroot)) + (str (concat (file-name-as-directory (or root "/")) " || " rep))) + (if (and root (string-match "\\(.*\\) || \\1\\(.*\\)\\'" str)) + (match-string 2 str) + (file-name-nondirectory rep))))))) + + + +;;;; +;;;; running a "cvs checkout". +;;;; + +;;;###autoload +(defun cvs-checkout (modules dir flags &optional root) + "Run a 'cvs checkout MODULES' in DIR. +Feed the output to a *cvs* buffer, display it in the current window, +and run `cvs-mode' on it. + +With a prefix argument, prompt for cvs FLAGS to use." + (interactive + (let ((root (cvs-get-cvsroot))) + (if (or (null root) current-prefix-arg) + (setq root (read-string "CVS Root: "))) + (list (split-string-and-unquote + (read-string "Module(s): " (cvs-get-module))) + (read-directory-name "CVS Checkout Directory: " + nil default-directory nil) + (cvs-add-branch-prefix + (cvs-flags-query 'cvs-checkout-flags "cvs checkout flags")) + root))) + (when (eq flags t) + (setf flags (cvs-flags-query 'cvs-checkout-flags nil 'noquery))) + (let ((cvs-cvsroot root)) + (cvs-cmd-do "checkout" (or dir default-directory) + (append flags modules) nil 'new + :noexist t))) + +(defun-cvs-mode (cvs-mode-checkout . NOARGS) (dir) + "Run cvs checkout against the current branch. +The files are stored to DIR." + (interactive + (let* ((branch (cvs-prefix-get 'cvs-branch-prefix)) + (prompt (format "CVS Checkout Directory for `%s%s': " + (cvs-get-module) + (if branch (format " (branch: %s)" branch) + "")))) + (list (read-directory-name prompt nil default-directory nil)))) + (let ((modules (split-string-and-unquote (cvs-get-module))) + (flags (cvs-add-branch-prefix + (cvs-flags-query 'cvs-checkout-flags "cvs checkout flags"))) + (cvs-cvsroot (cvs-get-cvsroot))) + (cvs-checkout modules dir flags))) + +;;;; +;;;; The code for running a "cvs update" and friends in various ways. +;;;; + +(defun-cvs-mode (cvs-mode-revert-buffer . SIMPLE) + (&optional ignore-auto noconfirm) + "Rerun `cvs-examine' on the current directory with the default flags." + (interactive) + (cvs-examine default-directory t)) + +(defun cvs-query-directory (prompt) + "Read directory name, prompting with PROMPT. +If in a *cvs* buffer, don't prompt unless a prefix argument is given." + (if (and (cvs-buffer-p) + (not current-prefix-arg)) + default-directory + (read-directory-name prompt nil default-directory nil))) + +;;;###autoload +(defun cvs-quickdir (dir &optional flags noshow) + "Open a *cvs* buffer on DIR without running cvs. +With a prefix argument, prompt for a directory to use. +A prefix arg >8 (ex: \\[universal-argument] \\[universal-argument]), + prevents reuse of an existing *cvs* buffer. +Optional argument NOSHOW if non-nil means not to display the buffer. +FLAGS is ignored." + (interactive (list (cvs-query-directory "CVS quickdir (directory): "))) + ;; FIXME: code duplication with cvs-cmd-do and cvs-parse-process + (let* ((dir (file-name-as-directory + (abbreviate-file-name (expand-file-name dir)))) + (new (> (prefix-numeric-value current-prefix-arg) 8)) + (cvsbuf (cvs-make-cvs-buffer dir new)) + last) + ;; Check that dir is under CVS control. + (unless (file-directory-p dir) + (error "%s is not a directory" dir)) + (unless (file-directory-p (expand-file-name "CVS" dir)) + (error "%s does not contain CVS controlled files" dir)) + (set-buffer cvsbuf) + (dolist (fi (cvs-fileinfo-from-entries "")) + (setq last (cvs-addto-collection cvs-cookies fi last))) + (cvs-cleanup-collection cvs-cookies + (eq cvs-auto-remove-handled t) + cvs-auto-remove-directories + nil) + (if noshow cvsbuf + (let ((pop-up-windows nil)) (pop-to-buffer cvsbuf))))) + +;;;###autoload +(defun cvs-examine (directory flags &optional noshow) + "Run a `cvs -n update' in the specified DIRECTORY. +That is, check what needs to be done, but don't change the disc. +Feed the output to a *cvs* buffer and run `cvs-mode' on it. +With a prefix argument, prompt for a directory and cvs FLAGS to use. +A prefix arg >8 (ex: \\[universal-argument] \\[universal-argument]), + prevents reuse of an existing *cvs* buffer. +Optional argument NOSHOW if non-nil means not to display the buffer." + (interactive (list (cvs-query-directory "CVS Examine (directory): ") + (cvs-flags-query 'cvs-update-flags "cvs -n update flags"))) + (when (eq flags t) + (setf flags (cvs-flags-query 'cvs-update-flags nil 'noquery))) + (when find-file-visit-truename (setq directory (file-truename directory))) + (cvs-cmd-do "update" directory flags nil + (> (prefix-numeric-value current-prefix-arg) 8) + :cvsargs '("-n") + :noshow noshow + :dont-change-disc t)) + + +;;;###autoload +(defun cvs-update (directory flags) + "Run a `cvs update' in the current working DIRECTORY. +Feed the output to a *cvs* buffer and run `cvs-mode' on it. +With a \\[universal-argument] prefix argument, prompt for a directory to use. +A prefix arg >8 (ex: \\[universal-argument] \\[universal-argument]), + prevents reuse of an existing *cvs* buffer. +The prefix is also passed to `cvs-flags-query' to select the FLAGS + passed to cvs." + (interactive (list (cvs-query-directory "CVS Update (directory): ") + (cvs-flags-query 'cvs-update-flags "cvs update flags"))) + (when (eq flags t) + (setf flags (cvs-flags-query 'cvs-update-flags nil 'noquery))) + (cvs-cmd-do "update" directory flags nil + (> (prefix-numeric-value current-prefix-arg) 8))) + + +;;;###autoload +(defun cvs-status (directory flags &optional noshow) + "Run a `cvs status' in the current working DIRECTORY. +Feed the output to a *cvs* buffer and run `cvs-mode' on it. +With a prefix argument, prompt for a directory and cvs FLAGS to use. +A prefix arg >8 (ex: \\[universal-argument] \\[universal-argument]), + prevents reuse of an existing *cvs* buffer. +Optional argument NOSHOW if non-nil means not to display the buffer." + (interactive (list (cvs-query-directory "CVS Status (directory): ") + (cvs-flags-query 'cvs-status-flags "cvs status flags"))) + (when (eq flags t) + (setf flags (cvs-flags-query 'cvs-status-flags nil 'noquery))) + (cvs-cmd-do "status" directory flags nil + (> (prefix-numeric-value current-prefix-arg) 8) + :noshow noshow :dont-change-disc t)) + +(defun cvs-update-filter (proc string) + "Filter function for pcl-cvs. +This function gets the output that CVS sends to stdout. It inserts +the STRING into (process-buffer PROC) but it also checks if CVS is waiting +for a lock file. If so, it inserts a message cookie in the *cvs* buffer." + (save-match-data + (with-current-buffer (process-buffer proc) + (let ((inhibit-read-only t)) + (save-excursion + ;; Insert the text, moving the process-marker. + (goto-char (process-mark proc)) + (insert string) + (set-marker (process-mark proc) (point)) + ;; FIXME: Delete any old lock message + ;;(if (tin-nth cookies 1) + ;; (tin-delete cookies + ;; (tin-nth cookies 1))) + ;; Check if CVS is waiting for a lock. + (beginning-of-line 0) ;Move to beginning of last complete line. + (when (looking-at "^[ a-z]+: \\(.*waiting for .*lock in \\(.*\\)\\)$") + (let ((msg (match-string 1)) + (lock (match-string 2))) + (with-current-buffer cvs-buffer + (set (make-local-variable 'cvs-lock-file) lock) + ;; display the lock situation in the *cvs* buffer: + (ewoc-enter-last + cvs-cookies + (cvs-create-fileinfo + 'MESSAGE "" " " + (concat msg + (when (file-exists-p lock) + (substitute-command-keys + "\n\t(type \\[cvs-mode-delete-lock] to delete it)"))) + :subtype 'TEMP)) + (pop-to-buffer (current-buffer)) + (goto-char (point-max)) + (beep))))))))) + + +;;;; +;;;; The cvs-mode and its associated commands. +;;;; + +(cvs-prefix-define cvs-force-command "" "" '("/F") cvs-qtypedesc-string1) +(defun-cvs-mode cvs-mode-force-command (arg) + "Force the next cvs command to operate on all the selected files. +By default, cvs commands only operate on files on which the command +\"makes sense\". This overrides the safety feature on the next cvs command. +It actually behaves as a toggle. If prefixed by \\[universal-argument] \\[universal-argument], +the override will persist until the next toggle." + (interactive "P") + (cvs-prefix-set 'cvs-force-command arg)) + +(put 'cvs-mode 'mode-class 'special) +(define-derived-mode cvs-mode nil "CVS" + "Mode used for PCL-CVS, a frontend to CVS. +Full documentation is in the Texinfo file." + (setq mode-line-process + '("" cvs-force-command cvs-ignore-marks-modif + ":" (cvs-branch-prefix + ("" cvs-branch-prefix (cvs-secondary-branch-prefix + ("->" cvs-secondary-branch-prefix)))) + " " cvs-mode-line-process)) + (if buffer-file-name + (error "Use M-x cvs-quickdir to get a *cvs* buffer")) + (buffer-disable-undo) + ;;(set (make-local-variable 'goal-column) cvs-cursor-column) + (set (make-local-variable 'revert-buffer-function) 'cvs-mode-revert-buffer) + (setq truncate-lines t) + (cvs-prefix-make-local 'cvs-branch-prefix) + (cvs-prefix-make-local 'cvs-secondary-branch-prefix) + (cvs-prefix-make-local 'cvs-force-command) + (cvs-prefix-make-local 'cvs-ignore-marks-modif) + (make-local-variable 'cvs-mode-line-process) + (make-local-variable 'cvs-temp-buffers)) + + +(defun cvs-buffer-p (&optional buffer) + "Return whether the (by default current) BUFFER is a `cvs-mode' buffer." + (save-excursion + (if buffer (set-buffer buffer)) + (and (eq major-mode 'cvs-mode)))) + +(defun cvs-buffer-check () + "Check that the current buffer follows cvs-buffer's conventions." + (let ((buf (current-buffer)) + (check 'none)) + (or (and (setq check 'collection) + (eq (ewoc-buffer cvs-cookies) buf) + (setq check 'cvs-temp-buffer) + (or (null cvs-temp-buffer) + (null (buffer-live-p cvs-temp-buffer)) + (and (eq (with-current-buffer cvs-temp-buffer cvs-buffer) buf) + (equal (with-current-buffer cvs-temp-buffer + default-directory) + default-directory))) + t) + (error "Inconsistent %s in buffer %s" check (buffer-name buf))))) + + +(defun cvs-mode-quit () + "Quit PCL-CVS, killing the *cvs* buffer." + (interactive) + (and (y-or-n-p "Quit pcl-cvs? ") (kill-buffer (current-buffer)))) + +;; Give help.... + +(defun cvs-help () + "Display help for various PCL-CVS commands." + (interactive) + (if (eq last-command 'cvs-help) + (describe-function 'cvs-mode) ; would need minor-mode for log-edit-mode + (message "%s" + (substitute-command-keys + "`\\[cvs-help]':help `\\[cvs-mode-add]':add `\\[cvs-mode-commit]':commit \ +`\\[cvs-mode-diff-map]':diff* `\\[cvs-mode-log]':log \ +`\\[cvs-mode-remove]':remove `\\[cvs-mode-status]':status \ +`\\[cvs-mode-undo]':undo")))) + +;; Move around in the buffer + +(defun cvs-move-to-goal-column () + (let* ((eol (line-end-position)) + (fpos (next-single-property-change (point) 'cvs-goal-column nil eol))) + (when (< fpos eol) + (goto-char fpos)))) + +(defun-cvs-mode cvs-mode-previous-line (arg) + "Go to the previous line. +If a prefix argument is given, move by that many lines." + (interactive "p") + (ewoc-goto-prev cvs-cookies arg) + (cvs-move-to-goal-column)) + +(defun-cvs-mode cvs-mode-next-line (arg) + "Go to the next line. +If a prefix argument is given, move by that many lines." + (interactive "p") + (ewoc-goto-next cvs-cookies arg) + (cvs-move-to-goal-column)) + +;;;; +;;;; Mark handling +;;;; + +(defun-cvs-mode cvs-mode-mark (&optional arg) + "Mark the fileinfo on the current line. +If the fileinfo is a directory, all the contents of that directory are +marked instead. A directory can never be marked." + (interactive) + (let* ((tin (ewoc-locate cvs-cookies)) + (fi (ewoc-data tin))) + (if (eq (cvs-fileinfo->type fi) 'DIRCHANGE) + ;; it's a directory: let's mark all files inside + (ewoc-map + (lambda (f dir) + (when (cvs-dir-member-p f dir) + (setf (cvs-fileinfo->marked f) + (not (if (eq arg 'toggle) (cvs-fileinfo->marked f) arg))) + t)) ;Tell cookie to redisplay this cookie. + cvs-cookies + (cvs-fileinfo->dir fi)) + ;; not a directory: just do the obvious + (setf (cvs-fileinfo->marked fi) + (not (if (eq arg 'toggle) (cvs-fileinfo->marked fi) arg))) + (ewoc-invalidate cvs-cookies tin) + (cvs-mode-next-line 1)))) + +(defalias 'cvs-mouse-toggle-mark 'cvs-mode-toggle-mark) +(defun cvs-mode-toggle-mark (e) + "Toggle the mark of the entry at point." + (interactive (list last-input-event)) + (save-excursion + (posn-set-point (event-end e)) + (cvs-mode-mark 'toggle))) + +(defun-cvs-mode cvs-mode-unmark () + "Unmark the fileinfo on the current line." + (interactive) + (cvs-mode-mark t)) + +(defun-cvs-mode cvs-mode-mark-all-files () + "Mark all files." + (interactive) + (ewoc-map (lambda (cookie) + (unless (eq (cvs-fileinfo->type cookie) 'DIRCHANGE) + (setf (cvs-fileinfo->marked cookie) t))) + cvs-cookies)) + +(defun-cvs-mode (cvs-mode-mark-on-state . SIMPLE) (state) + "Mark all files in state STATE." + (interactive + (list + (let ((default + (condition-case nil + (downcase + (symbol-name + (cvs-fileinfo->type + (cvs-mode-marked nil nil :read-only t :one t :noquery t)))) + (error nil)))) + (intern + (upcase + (completing-read + (concat + "Mark files in state" (if default (concat " [" default "]")) ": ") + (mapcar (lambda (x) + (list (downcase (symbol-name (car x))))) + cvs-states) + nil t nil nil default)))))) + (ewoc-map (lambda (fi) + (when (eq (cvs-fileinfo->type fi) state) + (setf (cvs-fileinfo->marked fi) t))) + cvs-cookies)) + +(defun-cvs-mode cvs-mode-mark-matching-files (regex) + "Mark all files matching REGEX." + (interactive "sMark files matching: ") + (ewoc-map (lambda (cookie) + (when (and (not (eq (cvs-fileinfo->type cookie) 'DIRCHANGE)) + (string-match regex (cvs-fileinfo->file cookie))) + (setf (cvs-fileinfo->marked cookie) t))) + cvs-cookies)) + +(defun-cvs-mode cvs-mode-unmark-all-files () + "Unmark all files. +Directories are also unmarked, but that doesn't matter, since +they should always be unmarked." + (interactive) + (ewoc-map (lambda (cookie) + (setf (cvs-fileinfo->marked cookie) nil) + t) + cvs-cookies)) + +(defun-cvs-mode cvs-mode-unmark-up () + "Unmark the file on the previous line." + (interactive) + (let ((tin (ewoc-goto-prev cvs-cookies 1))) + (when tin + (setf (cvs-fileinfo->marked (ewoc-data tin)) nil) + (ewoc-invalidate cvs-cookies tin))) + (cvs-move-to-goal-column)) + +(defconst cvs-ignore-marks-alternatives + '(("toggle-marks" . "/TM") + ("force-marks" . "/FM") + ("ignore-marks" . "/IM"))) + +(cvs-prefix-define cvs-ignore-marks-modif + "Prefix to decide whether to ignore marks or not." + "active" + (mapcar 'cdr cvs-ignore-marks-alternatives) + (cvs-qtypedesc-create + (lambda (str) (cdr (assoc str cvs-ignore-marks-alternatives))) + (lambda (obj) (car (rassoc obj cvs-ignore-marks-alternatives))) + (lambda () cvs-ignore-marks-alternatives) + nil t)) + +(defun-cvs-mode cvs-mode-toggle-marks (arg) + "Toggle whether the next CVS command uses marks. +See `cvs-prefix-set' for further description of the behavior. +\\[universal-argument] 1 selects `force-marks', +\\[universal-argument] 2 selects `ignore-marks', +\\[universal-argument] 3 selects `toggle-marks'." + (interactive "P") + (cvs-prefix-set 'cvs-ignore-marks-modif arg)) + +(defun cvs-ignore-marks-p (cmd &optional read-only) + (let ((default (if (member cmd cvs-invert-ignore-marks) + (not cvs-default-ignore-marks) + cvs-default-ignore-marks)) + (modif (cvs-prefix-get 'cvs-ignore-marks-modif read-only))) + (cond + ((equal modif "/IM") t) + ((equal modif "/TM") (not default)) + ((equal modif "/FM") nil) + (t default)))) + +(defun cvs-mode-mark-get-modif (cmd) + (if (cvs-ignore-marks-p cmd 'read-only) "/IM" "/FM")) + +(defun cvs-get-marked (&optional ignore-marks ignore-contents) + "Return a list of all selected fileinfos. +If there are any marked tins, and IGNORE-MARKS is nil, return them. +Otherwise, if the cursor selects a directory, and IGNORE-CONTENTS is +nil, return all files in it, else return just the directory. +Otherwise return (a list containing) the file the cursor points to, or +an empty list if it doesn't point to a file at all." + (let ((fis nil)) + (dolist (fi (if (and (boundp 'cvs-minor-current-files) + (consp cvs-minor-current-files)) + (mapcar + (lambda (f) + (if (cvs-fileinfo-p f) f + (let ((f (file-relative-name f))) + (if (file-directory-p f) + (cvs-create-fileinfo + 'DIRCHANGE (file-name-as-directory f) "." "") + (let ((dir (file-name-directory f)) + (file (file-name-nondirectory f))) + (cvs-create-fileinfo + 'UNKNOWN (or dir "") file "")))))) + cvs-minor-current-files) + (or (and (not ignore-marks) + (ewoc-collect cvs-cookies 'cvs-fileinfo->marked)) + (list (ewoc-data (ewoc-locate cvs-cookies)))))) + + (if (or ignore-contents (not (eq (cvs-fileinfo->type fi) 'DIRCHANGE))) + (push fi fis) + ;; If a directory is selected, return members, if any. + (setq fis + (append (ewoc-collect + cvs-cookies 'cvs-dir-member-p (cvs-fileinfo->dir fi)) + fis)))) + (nreverse fis))) + +(defun* cvs-mode-marked (filter &optional cmd + &key read-only one file noquery) + "Get the list of marked FIS. +CMD is used to determine whether to use the marks or not. +Only files for which FILTER is applicable are returned. +If READ-ONLY is non-nil, the current toggling is left intact. +If ONE is non-nil, marks are ignored and a single FI is returned. +If FILE is non-nil, directory entries won't be selected." + (unless cmd (setq cmd (symbol-name filter))) + (let* ((fis (cvs-get-marked (or one (cvs-ignore-marks-p cmd read-only)) + (and (not file) + (cvs-applicable-p 'DIRCHANGE filter)))) + (force (cvs-prefix-get 'cvs-force-command)) + (fis (car (cvs-partition + (lambda (fi) (cvs-applicable-p fi (and (not force) filter))) + fis)))) + (when (and (or (null fis) (and one (cdr fis))) (not noquery)) + (message (if (null fis) + "`%s' is not applicable to any of the selected files." + "`%s' is only applicable to a single file.") cmd) + (sit-for 1) + (setq fis (list (cvs-insert-file + (read-file-name (format "File to %s: " cmd)))))) + (if one (car fis) fis))) + +(defun cvs-enabledp (filter) + "Determine whether FILTER applies to at least one of the selected files." + (ignore-errors (cvs-mode-marked filter nil :read-only t :noquery t))) + +(defun cvs-mode-files (&rest -cvs-mode-files-args) + (cvs-mode! + (lambda () + (mapcar 'cvs-fileinfo->full-name + (apply 'cvs-mode-marked -cvs-mode-files-args))))) + +;; +;; Interface between Log-Edit and PCL-CVS +;; + +(defun cvs-mode-commit-setup () + "Run `cvs-mode-commit' with setup." + (interactive) + (cvs-mode-commit 'force)) + +(defcustom cvs-mode-commit-hook nil + "Hook run after setting up the commit buffer." + :type 'hook + :options '(cvs-mode-diff) + :group 'pcl-cvs) + +(defun cvs-mode-commit (setup) + "Check in all marked files, or the current file. +The user will be asked for a log message in a buffer. +The buffer's mode and name is determined by the \"message\" setting + of `cvs-buffer-name-alist'. +The POSTPROC specified there (typically `log-edit') is then called, + passing it the SETUP argument." + (interactive "P") + ;; It seems that the save-excursion that happens if I use the better + ;; form of `(cvs-mode! (lambda ...))' screws up a couple things which + ;; end up being rather annoying (like log-edit-mode's message being + ;; displayed in the wrong minibuffer). + (cvs-mode!) + (let ((buf (cvs-temp-buffer "message" 'normal 'nosetup)) + (setupfun (or (nth 2 (cdr (assoc "message" cvs-buffer-name-alist))) + 'log-edit))) + (funcall setupfun 'cvs-do-commit setup + '((log-edit-listfun . cvs-commit-filelist) + (log-edit-diff-function . cvs-mode-diff)) buf) + (set (make-local-variable 'cvs-minor-wrap-function) 'cvs-commit-minor-wrap) + (run-hooks 'cvs-mode-commit-hook))) + +(defun cvs-commit-minor-wrap (buf f) + (let ((cvs-ignore-marks-modif (cvs-mode-mark-get-modif "commit"))) + (funcall f))) + +(defun cvs-commit-filelist () + (cvs-mode-files 'commit nil :read-only t :file t :noquery t)) + +(defun cvs-do-commit (flags) + "Do the actual commit, using the current buffer as the log message." + (interactive (list (cvs-flags-query 'cvs-commit-flags "cvs commit flags"))) + (let ((msg (buffer-substring-no-properties (point-min) (point-max)))) + (cvs-mode!) + ;;(pop-to-buffer cvs-buffer) + (cvs-mode-do "commit" (list* "-m" msg flags) 'commit))) + + +;;;; Editing existing commit log messages. + +(defun cvs-edit-log-text-at-point () + (save-excursion + (end-of-line) + (when (re-search-backward "^revision " nil t) + (forward-line 1) + (if (looking-at "date:") (forward-line 1)) + (if (looking-at "branches:") (forward-line 1)) + (buffer-substring + (point) + (if (re-search-forward + "^\\(-\\{28\\}\\|=\\{77\\}\\|revision [.0-9]+\\)$" + nil t) + (match-beginning 0) + (point)))))) + +(defvar cvs-edit-log-revision) +(defvar cvs-edit-log-files) (put 'cvs-edit-log-files 'permanent-local t) +(defun cvs-mode-edit-log (file rev &optional text) + "Edit the log message at point. +This is best called from a `log-view-mode' buffer." + (interactive + (list + (or (cvs-mode! (lambda () + (car (cvs-mode-files nil nil + :read-only t :file t :noquery t)))) + (read-string "File name: ")) + (or (cvs-mode! (lambda () (cvs-prefix-get 'cvs-branch-prefix))) + (read-string "Revision to edit: ")) + (cvs-edit-log-text-at-point))) + ;; It seems that the save-excursion that happens if I use the better + ;; form of `(cvs-mode! (lambda ...))' screws up a couple things which + ;; end up being rather annoying (like log-edit-mode's message being + ;; displayed in the wrong minibuffer). + (cvs-mode!) + (let ((buf (cvs-temp-buffer "message" 'normal 'nosetup)) + (setupfun (or (nth 2 (cdr (assoc "message" cvs-buffer-name-alist))) + 'log-edit))) + (with-current-buffer buf + ;; Set the filename before, so log-edit can correctly setup its + ;; log-edit-initial-files variable. + (set (make-local-variable 'cvs-edit-log-files) (list file))) + (funcall setupfun 'cvs-do-edit-log nil + '((log-edit-listfun . cvs-edit-log-filelist) + (log-edit-diff-function . cvs-mode-diff)) + buf) + (when text (erase-buffer) (insert text)) + (set (make-local-variable 'cvs-edit-log-revision) rev) + (set (make-local-variable 'cvs-minor-wrap-function) + 'cvs-edit-log-minor-wrap) + ;; (run-hooks 'cvs-mode-commit-hook) + )) + +(defun cvs-edit-log-minor-wrap (buf f) + (let ((cvs-branch-prefix (with-current-buffer buf cvs-edit-log-revision)) + (cvs-minor-current-files + (with-current-buffer buf cvs-edit-log-files)) + ;; FIXME: I need to force because the fileinfos are UNKNOWN + (cvs-force-command "/F")) + (funcall f))) + +(defun cvs-edit-log-filelist () + (if cvs-minor-wrap-function + (cvs-mode-files nil nil :read-only t :file t :noquery t) + cvs-edit-log-files)) + +(defun cvs-do-edit-log (rev) + "Do the actual commit, using the current buffer as the log message." + (interactive (list cvs-edit-log-revision)) + (let ((msg (buffer-substring-no-properties (point-min) (point-max)))) + (cvs-mode! + (lambda () + (cvs-mode-do "admin" (list (concat "-m" rev ":" msg)) nil))))) + + +;;;; +;;;; CVS Mode commands +;;;; + +(defun-cvs-mode (cvs-mode-insert . NOARGS) (file) + "Insert an entry for a specific file into the current listing. +This is typically used if the file is up-to-date (or has been added +outside of PCL-CVS) and one wants to do some operation on it." + (interactive + (list (read-file-name + "File to insert: " + ;; Can't use ignore-errors here because interactive + ;; specs aren't byte-compiled. + (condition-case nil + (file-name-as-directory + (expand-file-name + (cvs-fileinfo->dir + (cvs-mode-marked nil nil :read-only t :one t :noquery t)))) + (error nil))))) + (cvs-insert-file file)) + +(defun cvs-insert-file (file) + "Insert FILE (and its contents if it's a dir) and return its FI." + (let ((file (file-relative-name (directory-file-name file))) last) + (dolist (fi (cvs-fileinfo-from-entries file)) + (setq last (cvs-addto-collection cvs-cookies fi last))) + ;; There should have been at least one entry. + (goto-char (ewoc-location last)) + (ewoc-data last))) + +(defun cvs-mark-fis-dead (fis) + ;; Helper function, introduced because of the need for macro-expansion. + (dolist (fi fis) + (setf (cvs-fileinfo->type fi) 'DEAD))) + +(defun-cvs-mode (cvs-mode-add . SIMPLE) (flags) + "Add marked files to the cvs repository. +With prefix argument, prompt for cvs flags." + (interactive (list (cvs-flags-query 'cvs-add-flags "cvs add flags"))) + (let ((fis (cvs-mode-marked 'add)) + (needdesc nil) (dirs nil)) + ;; find directories and look for fis needing a description + (dolist (fi fis) + (cond + ((file-directory-p (cvs-fileinfo->full-name fi)) (push fi dirs)) + ((eq (cvs-fileinfo->type fi) 'UNKNOWN) (setq needdesc t)))) + ;; prompt for description if necessary + (let* ((msg (if (and needdesc + (or current-prefix-arg (not cvs-add-default-message))) + (read-from-minibuffer "Enter description: ") + (or cvs-add-default-message ""))) + (flags (list* "-m" msg flags)) + (postproc + ;; setup postprocessing for the directory entries + (when dirs + `((cvs-run-process (list "-n" "update") + ',dirs + '(cvs-parse-process t)) + (cvs-mark-fis-dead ',dirs))))) + (cvs-mode-run "add" flags fis :postproc postproc)))) + +(defun-cvs-mode (cvs-mode-diff . DOUBLE) (flags) + "Diff the selected files against the repository. +This command compares the files in your working area against the +revision which they are based upon." + (interactive + (list (cvs-add-branch-prefix + (cvs-add-secondary-branch-prefix + (cvs-flags-query 'cvs-diff-flags "cvs diff flags"))))) + (cvs-mode-do "diff" flags 'diff + :show t)) ;; :ignore-exit t + +(defun-cvs-mode (cvs-mode-diff-head . SIMPLE) (flags) + "Diff the selected files against the head of the current branch. +See ``cvs-mode-diff'' for more info." + (interactive (list (cvs-flags-query 'cvs-diff-flags "cvs diff flags"))) + (cvs-mode-diff-1 (cons "-rHEAD" flags))) + +(defun-cvs-mode (cvs-mode-diff-repository . SIMPLE) (flags) + "Diff the files for changes in the repository since last co/update/commit. +See ``cvs-mode-diff'' for more info." + (interactive (list (cvs-flags-query 'cvs-diff-flags "cvs diff flags"))) + (cvs-mode-diff-1 (cons "-rBASE" (cons "-rHEAD" flags)))) + +(defun-cvs-mode (cvs-mode-diff-yesterday . SIMPLE) (flags) + "Diff the selected files against yesterday's head of the current branch. +See ``cvs-mode-diff'' for more info." + (interactive (list (cvs-flags-query 'cvs-diff-flags "cvs diff flags"))) + (cvs-mode-diff-1 (cons "-Dyesterday" flags))) + +(defun-cvs-mode (cvs-mode-diff-vendor . SIMPLE) (flags) + "Diff the selected files against the head of the vendor branch. +See ``cvs-mode-diff'' for more info." + (interactive (list (cvs-flags-query 'cvs-diff-flags "cvs diff flags"))) + (cvs-mode-diff-1 (cons (concat "-r" cvs-vendor-branch) flags))) + +;; sadly, this is not provided by cvs, so we have to roll our own +(defun-cvs-mode (cvs-mode-diff-backup . SIMPLE) (flags) + "Diff the files against the backup file. +This command can be used on files that are marked with \"Merged\" +or \"Conflict\" in the *cvs* buffer." + (interactive (list (cvs-flags-query 'cvs-diff-flags "diff flags"))) + (unless (listp flags) (error "flags should be a list of strings")) + (save-some-buffers) + (let* ((marked (cvs-get-marked (cvs-ignore-marks-p "diff"))) + (fis (car (cvs-partition 'cvs-fileinfo->backup-file marked)))) + (unless (consp fis) + (error "No files with a backup file selected!")) + ;; let's extract some info into the environment for `buffer-name' + (let* ((dir (cvs-fileinfo->dir (car fis))) + (file (cvs-fileinfo->file (car fis)))) + (set-buffer (cvs-temp-buffer "diff"))) + (message "cvs diff backup...") + (cvs-execute-single-file-list fis 'cvs-diff-backup-extractor + cvs-diff-program flags)) + (message "cvs diff backup... Done.")) + +(defun cvs-diff-backup-extractor (fileinfo) + "Return the filename and the name of the backup file as a list. +Signal an error if there is no backup file." + (let ((backup-file (cvs-fileinfo->backup-file fileinfo))) + (unless backup-file + (error "%s has no backup file" (cvs-fileinfo->full-name fileinfo))) + (list backup-file (cvs-fileinfo->full-name fileinfo)))) + +;; +;; Emerge support +;; +(defun cvs-emerge-diff (b1 b2) (emerge-buffers b1 b2 b1)) +(defun cvs-emerge-merge (b1 b2 base out) + (emerge-buffers-with-ancestor b1 b2 base (find-file-noselect out))) + +;; +;; Ediff support +;; + +(defvar ediff-after-quit-destination-buffer) +(defvar ediff-after-quit-hook-internal) +(defvar cvs-transient-buffers) +(defun cvs-ediff-startup-hook () + (add-hook 'ediff-after-quit-hook-internal + `(lambda () + (cvs-ediff-exit-hook + ',ediff-after-quit-destination-buffer ',cvs-transient-buffers)) + nil 'local)) + +(defun cvs-ediff-exit-hook (cvs-buf tmp-bufs) + ;; kill the temp buffers (and their associated windows) + (dolist (tb tmp-bufs) + (when (and tb (buffer-live-p tb) (not (buffer-modified-p tb))) + (let ((win (get-buffer-window tb t))) + (kill-buffer tb) + (when (window-live-p win) (ignore-errors (delete-window win)))))) + ;; switch back to the *cvs* buffer + (when (and cvs-buf (buffer-live-p cvs-buf) + (not (get-buffer-window cvs-buf t))) + (ignore-errors (switch-to-buffer cvs-buf)))) + +(defun cvs-ediff-diff (b1 b2) + (let ((ediff-after-quit-destination-buffer (current-buffer)) + (startup-hook '(cvs-ediff-startup-hook))) + (ediff-buffers b1 b2 startup-hook 'ediff-revision))) + +(defun cvs-ediff-merge (b1 b2 base out) + (let ((ediff-after-quit-destination-buffer (current-buffer)) + (startup-hook '(cvs-ediff-startup-hook))) + (ediff-merge-buffers-with-ancestor + b1 b2 base startup-hook + 'ediff-merge-revisions-with-ancestor + out))) + +;; +;; Interactive merge/diff support. +;; + +(defun cvs-retrieve-revision (fileinfo rev) + "Retrieve the given REVision of the file in FILEINFO into a new buffer." + (let* ((file (cvs-fileinfo->full-name fileinfo)) + (buffile (concat file "." rev))) + (or (find-buffer-visiting buffile) + (with-current-buffer (create-file-buffer buffile) + (message "Retrieving revision %s..." rev) + ;; Discard stderr output to work around the CVS+SSH+libc + ;; problem when stdout and stderr are the same. + (let ((res + (let ((coding-system-for-read 'binary)) + (apply 'process-file cvs-program nil '(t nil) nil + "-q" "update" "-p" + ;; If `rev' is HEAD, don't pass it at all: + ;; the default behavior is to get the head + ;; of the current branch whereas "-r HEAD" + ;; stupidly gives you the head of the trunk. + (append (unless (equal rev "HEAD") (list "-r" rev)) + (list file)))))) + (when (and res (not (and (equal 0 res)))) + (error "Something went wrong retrieving revision %s: %s" rev res)) + ;; Figure out the encoding used and decode the byte-sequence + ;; into a sequence of chars. + (decode-coding-inserted-region + (point-min) (point-max) file t nil nil t) + ;; Set buffer-file-coding-system. + (after-insert-file-set-coding (buffer-size) t) + (set-buffer-modified-p nil) + (let ((buffer-file-name (expand-file-name file))) + (after-find-file)) + (toggle-read-only 1) + (message "Retrieving revision %s... Done" rev) + (current-buffer)))))) + +;; FIXME: The user should be able to specify ancestor/head/backup and we should +;; provide sensible defaults when merge info is unavailable (rather than rely +;; on smerge-ediff). Also provide sane defaults for need-merge files. +(defun-cvs-mode cvs-mode-imerge () + "Merge interactively appropriate revisions of the selected file." + (interactive) + (let ((fi (cvs-mode-marked 'merge nil :one t :file t))) + (let ((merge (cvs-fileinfo->merge fi)) + (file (cvs-fileinfo->full-name fi)) + (backup-file (cvs-fileinfo->backup-file fi))) + (if (not (and merge backup-file)) + (let ((buf (find-file-noselect file))) + (message "Missing merge info or backup file, using VC.") + (with-current-buffer buf + (smerge-ediff))) + (let* ((ancestor-buf (cvs-retrieve-revision fi (car merge))) + (head-buf (cvs-retrieve-revision fi (cdr merge))) + (backup-buf (let ((auto-mode-alist nil)) + (find-file-noselect backup-file))) + ;; this binding is used by cvs-ediff-startup-hook + (cvs-transient-buffers (list ancestor-buf backup-buf head-buf))) + (with-current-buffer backup-buf + (let ((buffer-file-name (expand-file-name file))) + (after-find-file))) + (funcall (cdr cvs-idiff-imerge-handlers) + backup-buf head-buf ancestor-buf file)))))) + +(cvs-flags-define cvs-idiff-version + (list "BASE" cvs-vendor-branch cvs-vendor-branch "BASE" "BASE") + "version: " cvs-qtypedesc-tag) + +(defun-cvs-mode (cvs-mode-idiff . NOARGS) (&optional rev1 rev2) + "Diff interactively current file to revisions." + (interactive + (let* ((rev1 (cvs-prefix-get 'cvs-branch-prefix)) + (rev2 (and rev1 (cvs-prefix-get 'cvs-secondary-branch-prefix)))) + (list (or rev1 (cvs-flags-query 'cvs-idiff-version)) + rev2))) + (let ((fi (cvs-mode-marked 'diff "idiff" :one t :file t))) + (let* ((file (cvs-fileinfo->full-name fi)) + (rev1-buf (cvs-retrieve-revision fi (or rev1 "BASE"))) + (rev2-buf (if rev2 (cvs-retrieve-revision fi rev2))) + ;; this binding is used by cvs-ediff-startup-hook + (cvs-transient-buffers (list rev1-buf rev2-buf))) + (funcall (car cvs-idiff-imerge-handlers) + rev1-buf (or rev2-buf (find-file-noselect file)))))) + +(defun-cvs-mode (cvs-mode-idiff-other . NOARGS) () + "Diff interactively current file to revisions." + (interactive) + (let* ((rev1 (cvs-prefix-get 'cvs-branch-prefix)) + (rev2 (and rev1 (cvs-prefix-get 'cvs-secondary-branch-prefix))) + (fis (cvs-mode-marked 'diff "idiff" :file t))) + (when (> (length fis) 2) + (error "idiff-other cannot be applied to more than 2 files at a time")) + (let* ((fi1 (car fis)) + (rev1-buf (if rev1 (cvs-retrieve-revision fi1 rev1) + (find-file-noselect (cvs-fileinfo->full-name fi1)))) + rev2-buf) + (if (cdr fis) + (let ((fi2 (nth 1 fis))) + (setq rev2-buf + (if rev2 (cvs-retrieve-revision fi2 rev2) + (find-file-noselect (cvs-fileinfo->full-name fi2))))) + (error "idiff-other doesn't know what other file/buffer to use")) + (let* (;; this binding is used by cvs-ediff-startup-hook + (cvs-transient-buffers (list rev1-buf rev2-buf))) + (funcall (car cvs-idiff-imerge-handlers) + rev1-buf rev2-buf))))) + + +(defun cvs-is-within-p (fis dir) + "Non-nil if buffer is inside one of FIS (in DIR)." + (when (stringp buffer-file-name) + (setq buffer-file-name (expand-file-name buffer-file-name)) + (let (ret) + (dolist (fi (or fis (list (cvs-create-fileinfo 'DIRCHANGE "" "." "")))) + (when (cvs-string-prefix-p + (expand-file-name (cvs-fileinfo->full-name fi) dir) + buffer-file-name) + (setq ret t))) + ret))) + +(defun* cvs-mode-run (cmd flags fis + &key (buf (cvs-temp-buffer)) + dont-change-disc cvsargs postproc) + "Generic cvs-mode- function. +Executes `cvs CVSARGS CMD FLAGS FIS'. +BUF is the buffer to be used for cvs' output. +DONT-CHANGE-DISC non-nil indicates that the command will not change the + contents of files. This is only used by the parser. +POSTPROC is a list of expressions to be evaluated at the very end (after + parsing if applicable). It will be prepended with `progn' if necessary." + (let ((def-dir default-directory)) + ;; Save the relevant buffers + (save-some-buffers nil (lambda () (cvs-is-within-p fis def-dir)))) + (unless (listp flags) (error "flags should be a list of strings")) + ;; Some w32 versions of CVS don't like an explicit . too much. + (when (and (car fis) (null (cdr fis)) + (eq (cvs-fileinfo->type (car fis)) 'DIRCHANGE) + ;; (equal (cvs-fileinfo->file (car fis)) ".") + (equal (cvs-fileinfo->dir (car fis)) "")) + (setq fis nil)) + (let* ((single-dir (or (not (listp cvs-execute-single-dir)) + (member cmd cvs-execute-single-dir))) + (parse (member cmd cvs-parse-known-commands)) + (args (append cvsargs (list cmd) flags)) + (after-mode (nth 2 (cdr (assoc cmd cvs-buffer-name-alist))))) + (cvs-cleanup-collection cvs-cookies ;cleanup remaining messages + (eq cvs-auto-remove-handled 'delayed) nil t) + (when (fboundp after-mode) + (setq postproc (append postproc `((,after-mode))))) + (when parse + (let ((old-fis + (when (member cmd '("status" "update")) ;FIXME: Yuck!! + ;; absence of `cvs update' output has a specific meaning. + (or fis (list (cvs-create-fileinfo 'DIRCHANGE "" "." "")))))) + (push `(cvs-parse-process ',dont-change-disc nil ',old-fis) postproc))) + (setq postproc (if (cdr postproc) (cons 'progn postproc) (car postproc))) + (with-current-buffer buf + (let ((inhibit-read-only t)) (erase-buffer)) + (message "Running cvs %s ..." cmd) + (cvs-run-process args fis postproc single-dir)))) + + +(defun* cvs-mode-do (cmd flags filter + &key show dont-change-disc cvsargs postproc) + "Generic cvs-mode- function. +Executes `cvs CVSARGS CMD FLAGS' on the selected files. +FILTER is passed to `cvs-applicable-p' to only apply the command to + files for which it makes sense. +SHOW indicates that CMD should be not be run in the default temp buffer and + should be shown to the user. The buffer and mode to be used is determined + by `cvs-buffer-name-alist'. +DONT-CHANGE-DISC non-nil indicates that the command will not change the + contents of files. This is only used by the parser." + (cvs-mode-run cmd flags (cvs-mode-marked filter cmd) + :buf (cvs-temp-buffer (when show cmd)) + :dont-change-disc dont-change-disc + :cvsargs cvsargs + :postproc postproc)) + +(defun-cvs-mode (cvs-mode-status . SIMPLE) (flags) + "Show cvs status for all marked files. +With prefix argument, prompt for cvs flags." + (interactive (list (cvs-flags-query 'cvs-status-flags "cvs status flags"))) + (cvs-mode-do "status" flags nil :dont-change-disc t :show t + :postproc (when (eq cvs-auto-remove-handled 'status) + `((with-current-buffer ,(current-buffer) + (cvs-mode-remove-handled)))))) + +(defun-cvs-mode (cvs-mode-tree . SIMPLE) (flags) + "Call cvstree using the file under the point as a keyfile." + (interactive (list (cvs-flags-query 'cvs-status-flags "cvs status flags"))) + (cvs-mode-run "status" (cons "-v" flags) (cvs-mode-marked nil "status") + :buf (cvs-temp-buffer "tree") + :dont-change-disc t + :postproc '((cvs-status-cvstrees)))) + +;; cvs log + +(defun-cvs-mode (cvs-mode-log . NOARGS) (flags) + "Display the cvs log of all selected files. +With prefix argument, prompt for cvs flags." + (interactive (list (cvs-add-branch-prefix + (cvs-flags-query 'cvs-log-flags "cvs log flags")))) + (cvs-mode-do "log" flags nil :show t)) + + +(defun-cvs-mode (cvs-mode-update . NOARGS) (flags) + "Update all marked files. +With a prefix argument, prompt for cvs flags." + (interactive + (list (cvs-add-branch-prefix + (cvs-add-secondary-branch-prefix + (cvs-flags-query 'cvs-update-flags "cvs update flags") + "-j") "-j"))) + (cvs-mode-do "update" flags 'update)) + + +(defun-cvs-mode (cvs-mode-examine . NOARGS) (flags) + "Re-examine all marked files. +With a prefix argument, prompt for cvs flags." + (interactive + (list (cvs-add-branch-prefix + (cvs-add-secondary-branch-prefix + (cvs-flags-query 'cvs-update-flags "cvs -n update flags") + "-j") "-j"))) + (cvs-mode-do "update" flags nil :cvsargs '("-n") :dont-change-disc t)) + + +(defun-cvs-mode cvs-mode-ignore (&optional pattern) + "Arrange so that CVS ignores the selected files. +This command ignores files that are not flagged as `Unknown'." + (interactive) + (dolist (fi (cvs-mode-marked 'ignore)) + (cvs-append-to-ignore (cvs-fileinfo->dir fi) (cvs-fileinfo->file fi) + (eq (cvs-fileinfo->subtype fi) 'NEW-DIR)) + (setf (cvs-fileinfo->type fi) 'DEAD)) + (cvs-cleanup-collection cvs-cookies nil nil nil)) + +(declare-function vc-editable-p "vc" (file)) +(declare-function vc-checkout "vc" (file &optional writable rev)) + +(defun cvs-append-to-ignore (dir str &optional old-dir) + "Add STR to the .cvsignore file in DIR. +If OLD-DIR is non-nil, then this is a directory that we don't want +to hear about anymore." + (with-current-buffer + (find-file-noselect (expand-file-name ".cvsignore" dir)) + (when (ignore-errors + (and buffer-read-only + (eq 'CVS (vc-backend buffer-file-name)) + (not (vc-editable-p buffer-file-name)))) + ;; CVSREAD=on special case + (vc-checkout buffer-file-name t)) + (goto-char (point-max)) + (unless (bolp) (insert "\n")) + (insert str (if old-dir "/\n" "\n")) + (if cvs-sort-ignore-file (sort-lines nil (point-min) (point-max))) + (save-buffer))) + + +(defun cvs-mode-find-file-other-window (e) + "Select a buffer containing the file in another window." + (interactive (list last-input-event)) + (cvs-mode-find-file e t)) + + +(defun cvs-mode-display-file (e) + "Show a buffer containing the file in another window." + (interactive (list last-input-event)) + (cvs-mode-find-file e 'dont-select)) + + +(defun cvs-mode-view-file (e) + "View the file." + (interactive (list last-input-event)) + (cvs-mode-find-file e nil t)) + + +(defun cvs-mode-view-file-other-window (e) + "View the file." + (interactive (list last-input-event)) + (cvs-mode-find-file e t t)) + + +(defun cvs-find-modif (fi) + (with-temp-buffer + (process-file cvs-program nil (current-buffer) nil + "-f" "diff" (cvs-fileinfo->file fi)) + (goto-char (point-min)) + (if (re-search-forward "^\\([0-9]+\\)" nil t) + (string-to-number (match-string 1)) + 1))) + + +(defun cvs-mode-find-file (e &optional other view) + "Select a buffer containing the file. +With a prefix, opens the buffer in an OTHER window." + (interactive (list last-input-event current-prefix-arg)) + ;; If the event moves point, check that it moves it to a valid location. + (when (and (/= (point) (progn (posn-set-point (event-end e)) (point))) + (not (memq (get-text-property (1- (line-end-position)) + 'font-lock-face) + '(cvs-header cvs-filename)))) + (error "Not a file name")) + (cvs-mode! + (lambda (&optional rev) + (interactive (list (cvs-prefix-get 'cvs-branch-prefix))) + (let* ((cvs-buf (current-buffer)) + (fi (cvs-mode-marked nil nil :one t))) + (if (eq (cvs-fileinfo->type fi) 'DIRCHANGE) + (let ((odir default-directory)) + (setq default-directory + (cvs-expand-dir-name (cvs-fileinfo->dir fi))) + (cond ((eq other 'dont-select) + (display-buffer (find-file-noselect default-directory))) + (other (dired-other-window default-directory)) + (t (dired default-directory))) + (set-buffer cvs-buf) + (setq default-directory odir)) + (let ((buf (if rev (cvs-retrieve-revision fi rev) + (find-file-noselect (cvs-fileinfo->full-name fi))))) + (funcall (cond ((eq other 'dont-select) 'display-buffer) + (other + (if view 'view-buffer-other-window + 'switch-to-buffer-other-window)) + (t (if view 'view-buffer 'switch-to-buffer))) + buf) + (when (and cvs-find-file-and-jump (cvs-applicable-p fi 'diff-base)) + (save-restriction + (widen) + (goto-char (point-min)) + (forward-line (1- (cvs-find-modif fi))))) + buf)))))) + + +(defun-cvs-mode (cvs-mode-undo . SIMPLE) (flags) + "Undo local changes to all marked files. +The file is removed and `cvs update FILE' is run." + ;;"With prefix argument, prompt for cvs FLAGS." + (interactive (list nil));; (cvs-flags-query 'cvs-undo-flags "undo flags") + (if current-prefix-arg (call-interactively 'cvs-mode-revert-to-rev) + (let* ((fis (cvs-do-removal 'undo "update" 'all)) + (removedp (lambda (fi) + (or (eq (cvs-fileinfo->type fi) 'REMOVED) + (and (eq (cvs-fileinfo->type fi) 'CONFLICT) + (eq (cvs-fileinfo->subtype fi) 'REMOVED))))) + (fis-split (cvs-partition removedp fis)) + (fis-removed (car fis-split)) + (fis-other (cdr fis-split))) + (if (null fis-other) + (when fis-removed (cvs-mode-run "add" nil fis-removed)) + (cvs-mode-run "update" flags fis-other + :postproc + (when fis-removed + `((with-current-buffer ,(current-buffer) + (cvs-mode-run "add" nil ',fis-removed))))))))) + + +(defun-cvs-mode (cvs-mode-revert-to-rev . NOARGS) (rev) + "Revert the selected files to an old revision." + (interactive + (list (or (cvs-prefix-get 'cvs-branch-prefix) + (let ((current-prefix-arg '(4))) + (cvs-flags-query 'cvs-idiff-version))))) + (let* ((fis (cvs-mode-marked 'revert "revert" :file t)) + (tag (concat "tmp_pcl_tag_" (make-temp-name ""))) + (untag `((with-current-buffer ,(current-buffer) + (cvs-mode-run "tag" (list "-d" ',tag) ',fis)))) + (update `((with-current-buffer ,(current-buffer) + (cvs-mode-run "update" (list "-j" ',tag "-j" ',rev) ',fis + :postproc ',untag))))) + (cvs-mode-run "tag" (list tag) fis :postproc update))) + + +(defun-cvs-mode cvs-mode-delete-lock () + "Delete the lock file that CVS is waiting for. +Note that this can be dangerous. You should only do this +if you are convinced that the process that created the lock is dead." + (interactive) + (let* ((default-directory (cvs-expand-dir-name cvs-lock-file)) + (locks (directory-files default-directory nil cvs-lock-file-regexp))) + (cond + ((not locks) (error "No lock files found")) + ((yes-or-no-p (concat "Really delete locks in " cvs-lock-file "? ")) + (dolist (lock locks) + (cond ((file-directory-p lock) (delete-directory lock)) + ((file-exists-p lock) (delete-file lock)))))))) + + +(defun-cvs-mode cvs-mode-remove-handled () + "Remove all lines that are handled. +Empty directories are removed." + (interactive) + (cvs-cleanup-collection cvs-cookies + t (or cvs-auto-remove-directories 'handled) t)) + + +(defun-cvs-mode cvs-mode-acknowledge () + "Remove all marked files from the buffer." + (interactive) + (dolist (fi (cvs-get-marked (cvs-ignore-marks-p "acknowledge") t)) + (setf (cvs-fileinfo->type fi) 'DEAD)) + (cvs-cleanup-collection cvs-cookies nil nil nil)) + +(defun cvs-do-removal (filter &optional cmd all) + "Remove files. +Returns a list of FIS that should be `cvs remove'd." + (let* ((files (cvs-mode-marked filter cmd :file t :read-only t)) + (fis (cdr (cvs-partition (lambda (fi) + (eq (cvs-fileinfo->type fi) 'UNKNOWN)) + (cvs-mode-marked filter cmd)))) + (silent (or (not cvs-confirm-removals) + (cvs-every (lambda (fi) + (or (not (file-exists-p + (cvs-fileinfo->full-name fi))) + (cvs-applicable-p fi 'safe-rm))) + files))) + (tmpbuf (cvs-temp-buffer))) + (when (and (not silent) (equal cvs-confirm-removals 'list)) + (with-current-buffer tmpbuf + (let ((inhibit-read-only t)) + (cvs-insert-strings (mapcar 'cvs-fileinfo->full-name fis)) + (cvs-pop-to-buffer-same-frame (current-buffer)) + (shrink-window-if-larger-than-buffer)))) + (if (not (or silent + (unwind-protect + (yes-or-no-p + (let ((nfiles (length files)) + (verb (if (eq filter 'undo) "Undo" "Delete"))) + (if (= 1 nfiles) + (format "%s file: \"%s\" ? " + verb + (cvs-fileinfo->file (car files))) + (format "%s %d files? " + verb + nfiles)))) + (cvs-bury-buffer tmpbuf cvs-buffer)))) + (progn (message "Aborting") nil) + (dolist (fi files) + (let* ((type (cvs-fileinfo->type fi)) + (file (cvs-fileinfo->full-name fi))) + (when (or all (eq type 'UNKNOWN)) + (when (file-exists-p file) (delete-file file)) + (unless all (setf (cvs-fileinfo->type fi) 'DEAD) t)))) + fis))) + +(defun-cvs-mode (cvs-mode-remove . SIMPLE) (flags) + "Remove all marked files. +With prefix argument, prompt for cvs flags." + (interactive (list (cvs-flags-query 'cvs-remove-flags "cvs remove flags"))) + (let ((fis (cvs-do-removal 'remove))) + (if fis (cvs-mode-run "remove" (cons "-f" flags) fis) + (cvs-cleanup-collection cvs-cookies nil nil nil)))) + + +(defvar cvs-tag-name "") +(defun-cvs-mode (cvs-mode-tag . SIMPLE) (tag &optional flags) + "Run `cvs tag TAG' on all selected files. +With prefix argument, prompt for cvs flags. +By default this can only be used on directories. +Use \\[cvs-mode-force-command] or change `cvs-force-dir-tag' if you need +to use it on individual files." + (interactive + (list (setq cvs-tag-name + (cvs-query-read cvs-tag-name "Tag name: " cvs-qtypedesc-tag)) + (cvs-flags-query 'cvs-tag-flags "tag flags"))) + (cvs-mode-do "tag" (append flags (list tag)) + (when cvs-force-dir-tag 'tag))) + +(defun-cvs-mode (cvs-mode-untag . SIMPLE) (tag &optional flags) + "Run `cvs tag -d TAG' on all selected files. +With prefix argument, prompt for cvs flags." + (interactive + (list (setq cvs-tag-name + (cvs-query-read cvs-tag-name "Tag to delete: " cvs-qtypedesc-tag)) + (cvs-flags-query 'cvs-tag-flags "tag flags"))) + (cvs-mode-do "tag" (append '("-d") flags (list tag)) + (when cvs-force-dir-tag 'tag))) + + +;; Byte compile files. + +(defun-cvs-mode cvs-mode-byte-compile-files () + "Run byte-compile-file on all selected files that end in '.el'." + (interactive) + (let ((marked (cvs-get-marked (cvs-ignore-marks-p "byte-compile")))) + (dolist (fi marked) + (let ((filename (cvs-fileinfo->full-name fi))) + (when (string-match "\\.el\\'" filename) + (byte-compile-file filename)))))) + +;; ChangeLog support. + +(defun-cvs-mode cvs-mode-add-change-log-entry-other-window () + "Add a ChangeLog entry in the ChangeLog of the current directory." + (interactive) + ;; Require `add-log' explicitly, because if it gets autoloaded when we call + ;; add-change-log-entry-other-window below, the + ;; add-log-buffer-file-name-function ends up unbound when we leave the `let'. + (require 'add-log) + (dolist (fi (cvs-mode-marked nil nil)) + (let* ((default-directory (cvs-expand-dir-name (cvs-fileinfo->dir fi))) + (add-log-buffer-file-name-function + (lambda () + (let ((file (expand-file-name (cvs-fileinfo->file fi)))) + (if (file-directory-p file) + ;; Be careful to use a directory name, otherwise add-log + ;; starts looking for a ChangeLog file in the + ;; parent dir. + (file-name-as-directory file) + file))))) + (kill-local-variable 'change-log-default-name) + (save-excursion (add-change-log-entry-other-window))))) + +;; interactive commands to set optional flags + +(defun cvs-mode-set-flags (flag) + "Ask for new setting of cvs-FLAG-flags." + (interactive + (list (completing-read + "Which flag: " + '("cvs" "diff" "update" "status" "log" "tag" ;"rtag" + "commit" "remove" "undo" "checkout") + nil t))) + (let* ((sym (intern (concat "cvs-" flag "-flags")))) + (let ((current-prefix-arg '(16))) + (cvs-flags-query sym (concat flag " flags"))))) + + +;;;; +;;;; Utilities for the *cvs* buffer +;;;; + +(defun cvs-dir-member-p (fileinfo dir) + "Return true if FILEINFO represents a file in directory DIR." + (and (not (eq (cvs-fileinfo->type fileinfo) 'DIRCHANGE)) + (cvs-string-prefix-p dir (cvs-fileinfo->dir fileinfo)))) + +(defun cvs-execute-single-file (fi extractor program constant-args) + "Internal function for `cvs-execute-single-file-list'." + (let* ((arg-list (funcall extractor fi)) + (inhibit-read-only t)) + + ;; Execute the command unless extractor returned t. + (when (listp arg-list) + (let* ((args (append constant-args arg-list))) + + (insert (format "=== %s %s\n\n" + program (split-string-and-unquote args))) + + ;; FIXME: return the exit status? + (apply 'process-file program nil t t args) + (goto-char (point-max)))))) + +;; FIXME: make this run in the background ala cvs-run-process... +(defun cvs-execute-single-file-list (fis extractor program constant-args) + "Run PROGRAM on all elements on FIS. +CONSTANT-ARGS is a list of strings to pass as arguments to PROGRAM. +The arguments given to the program will be CONSTANT-ARGS followed by +the list that EXTRACTOR returns. + +EXTRACTOR will be called once for each file on FIS. It is given +one argument, the cvs-fileinfo. It can return t, which means ignore +this file, or a list of arguments to send to the program." + (dolist (fi fis) + (cvs-execute-single-file fi extractor program constant-args))) + + +(defun cvs-revert-if-needed (fis) + (dolist (fileinfo fis) + (let* ((file (cvs-fileinfo->full-name fileinfo)) + (buffer (find-buffer-visiting file))) + ;; For a revert to happen the user must be editing the file... + (unless (or (null buffer) + (memq (cvs-fileinfo->type fileinfo) '(MESSAGE UNKNOWN)) + ;; FIXME: check whether revert is really needed. + ;; `(verify-visited-file-modtime buffer)' doesn't cut it + ;; because it only looks at the time stamp (it ignores + ;; read-write changes) which is not changed by `commit'. + (buffer-modified-p buffer)) + (with-current-buffer buffer + (ignore-errors + (revert-buffer 'ignore-auto 'dont-ask 'preserve-modes) + ;; `preserve-modes' avoids changing the (minor) modes. But we + ;; do want to reset the mode for VC, so we do it explicitly. + (vc-find-file-hook) + (when (eq (cvs-fileinfo->type fileinfo) 'CONFLICT) + (smerge-start-session)))))))) + + +(defun cvs-change-cvsroot (newroot) + "Change the cvsroot." + (interactive "DNew repository: ") + (if (or (file-directory-p (expand-file-name "CVSROOT" newroot)) + (y-or-n-p (concat "Warning: no CVSROOT found inside repository." + " Change cvs-cvsroot anyhow? "))) + (setq cvs-cvsroot newroot))) + +;;;; +;;;; useful global settings +;;;; + +;; +;; Hook to allow calling PCL-CVS by visiting the /CVS subdirectory +;; + +;;;###autoload +(defcustom cvs-dired-action 'cvs-quickdir + "The action to be performed when opening a CVS directory. +Sensible values are `cvs-examine', `cvs-status' and `cvs-quickdir'." + :group 'pcl-cvs + :type '(choice (const cvs-examine) (const cvs-status) (const cvs-quickdir))) + +;;;###autoload +(defcustom cvs-dired-use-hook '(4) + "Whether or not opening a CVS directory should run PCL-CVS. +A value of nil means never do it. +ALWAYS means to always do it unless a prefix argument is given to the + command that prompted the opening of the directory. +Anything else means to do it only if the prefix arg is equal to this value." + :group 'pcl-cvs + :type '(choice (const :tag "Never" nil) + (const :tag "Always" always) + (const :tag "Prefix" (4)))) + +;;;###autoload +(progn (defun cvs-dired-noselect (dir) + "Run `cvs-examine' if DIR is a CVS administrative directory. +The exact behavior is determined also by `cvs-dired-use-hook'." + (when (stringp dir) + (setq dir (directory-file-name dir)) + (when (and (string= "CVS" (file-name-nondirectory dir)) + (file-readable-p (expand-file-name "Entries" dir)) + cvs-dired-use-hook + (if (eq cvs-dired-use-hook 'always) + (not current-prefix-arg) + (equal current-prefix-arg cvs-dired-use-hook))) + (save-excursion + (funcall cvs-dired-action (file-name-directory dir) t t)))))) + +;; +;; hook into VC +;; + +(add-hook 'vc-post-command-functions 'cvs-vc-command-advice) + +(defun cvs-vc-command-advice (command files flags) + (when (and (equal command "cvs") + (progn + (while (and (stringp (car flags)) + (string-match "\\`-" (car flags))) + (pop flags)) + ;; don't parse output we don't understand. + (member (car flags) cvs-parse-known-commands)) + ;; Don't parse "update -p" output. + (not (and (member (car flags) '("update" "checkout")) + (let ((found-p nil)) + (dolist (flag flags found-p) + (if (equal flag "-p") (setq found-p t))))))) + (save-current-buffer + (let ((buffer (current-buffer)) + (dir default-directory) + (cvs-from-vc t)) + (dolist (cvs-buf (buffer-list)) + (set-buffer cvs-buf) + ;; look for a corresponding pcl-cvs buffer + (when (and (eq major-mode 'cvs-mode) + (cvs-string-prefix-p default-directory dir)) + (let ((subdir (substring dir (length default-directory)))) + (set-buffer buffer) + (set (make-local-variable 'cvs-buffer) cvs-buf) + ;; `cvs -q add file' produces no useful output :-( + (when (and (equal (car flags) "add") + (goto-char (point-min)) + (looking-at ".*to add this file permanently\n\\'")) + (dolist (file (if (listp files) files (list files))) + (insert "cvs add: scheduling file `" + (file-name-nondirectory file) + "' for addition\n"))) + ;; VC never (?) does `cvs -n update' so dcd=nil + ;; should probably always be the right choice. + (cvs-parse-process nil subdir)))))))) + +;; +;; Hook into write-buffer +;; + +(defun cvs-mark-buffer-changed () + (let* ((file (expand-file-name buffer-file-name)) + (version (and (fboundp 'vc-backend) + (eq (vc-backend file) 'CVS) + (vc-working-revision file)))) + (when version + (save-excursion + (dolist (cvs-buf (buffer-list)) + (set-buffer cvs-buf) + ;; look for a corresponding pcl-cvs buffer + (when (and (eq major-mode 'cvs-mode) + (cvs-string-prefix-p default-directory file)) + (let* ((file (substring file (length default-directory))) + (fi (cvs-create-fileinfo + (if (string= "0" version) + 'ADDED 'MODIFIED) + (or (file-name-directory file) "") + (file-name-nondirectory file) + "cvs-mark-buffer-changed"))) + (cvs-addto-collection cvs-cookies fi)))))))) + +(add-hook 'after-save-hook 'cvs-mark-buffer-changed) + + +(provide 'pcvs) + +;; arch-tag: 8e3a7494-0453-4389-9ab3-a557ce9fab61 +;;; pcvs.el ends here diff --cc lisp/vc/smerge-mode.el index 32f829f814e,00000000000..296ae635d0b mode 100644,000000..100644 --- a/lisp/vc/smerge-mode.el +++ b/lisp/vc/smerge-mode.el @@@ -1,1235 -1,0 +1,1235 @@@ +;;; smerge-mode.el --- Minor mode to resolve diff3 conflicts + +;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, - ;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ++;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. + +;; Author: Stefan Monnier +;; Keywords: vc, tools, revision control, merge, diff3, cvs, conflict + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Provides a lightweight alternative to emerge/ediff. +;; To use it, simply add to your .emacs the following lines: +;; +;; (autoload 'smerge-mode "smerge-mode" nil t) +;; +;; you can even have it turned on automatically with the following +;; piece of code in your .emacs: +;; +;; (defun sm-try-smerge () +;; (save-excursion +;; (goto-char (point-min)) +;; (when (re-search-forward "^<<<<<<< " nil t) +;; (smerge-mode 1)))) +;; (add-hook 'find-file-hook 'sm-try-smerge t) + +;;; Todo: + +;; - if requested, ask the user whether he wants to call ediff right away + +;;; Code: + +(eval-when-compile (require 'cl)) +(require 'diff-mode) ;For diff-auto-refine-mode. + + +;;; The real definition comes later. +(defvar smerge-mode) + +(defgroup smerge () + "Minor mode to highlight and resolve diff3 conflicts." + :group 'tools + :prefix "smerge-") + +(defcustom smerge-diff-buffer-name "*vc-diff*" + "Buffer name to use for displaying diffs." + :group 'smerge + :type '(choice + (const "*vc-diff*") + (const "*cvs-diff*") + (const "*smerge-diff*") + string)) + +(defcustom smerge-diff-switches + (append '("-d" "-b") + (if (listp diff-switches) diff-switches (list diff-switches))) + "A list of strings specifying switches to be passed to diff. +Used in `smerge-diff-base-mine' and related functions." + :group 'smerge + :type '(repeat string)) + +(defcustom smerge-auto-leave t + "Non-nil means to leave `smerge-mode' when the last conflict is resolved." + :group 'smerge + :type 'boolean) + +(defface smerge-mine + '((((min-colors 88) (background light)) + (:foreground "blue1")) + (((background light)) + (:foreground "blue")) + (((min-colors 88) (background dark)) + (:foreground "cyan1")) + (((background dark)) + (:foreground "cyan"))) + "Face for your code." + :group 'smerge) +(define-obsolete-face-alias 'smerge-mine-face 'smerge-mine "22.1") +(defvar smerge-mine-face 'smerge-mine) + +(defface smerge-other + '((((background light)) + (:foreground "darkgreen")) + (((background dark)) + (:foreground "lightgreen"))) + "Face for the other code." + :group 'smerge) +(define-obsolete-face-alias 'smerge-other-face 'smerge-other "22.1") +(defvar smerge-other-face 'smerge-other) + +(defface smerge-base + '((((min-colors 88) (background light)) + (:foreground "red1")) + (((background light)) + (:foreground "red")) + (((background dark)) + (:foreground "orange"))) + "Face for the base code." + :group 'smerge) +(define-obsolete-face-alias 'smerge-base-face 'smerge-base "22.1") +(defvar smerge-base-face 'smerge-base) + +(defface smerge-markers + '((((background light)) + (:background "grey85")) + (((background dark)) + (:background "grey30"))) + "Face for the conflict markers." + :group 'smerge) +(define-obsolete-face-alias 'smerge-markers-face 'smerge-markers "22.1") +(defvar smerge-markers-face 'smerge-markers) + +(defface smerge-refined-change + '((t :background "yellow")) + "Face used for char-based changes shown by `smerge-refine'." + :group 'smerge) + +(easy-mmode-defmap smerge-basic-map + `(("n" . smerge-next) + ("p" . smerge-prev) + ("r" . smerge-resolve) + ("a" . smerge-keep-all) + ("b" . smerge-keep-base) + ("o" . smerge-keep-other) + ("m" . smerge-keep-mine) + ("E" . smerge-ediff) + ("C" . smerge-combine-with-next) + ("R" . smerge-refine) + ("\C-m" . smerge-keep-current) + ("=" . ,(make-sparse-keymap "Diff")) + ("=<" "base-mine" . smerge-diff-base-mine) + ("=>" "base-other" . smerge-diff-base-other) + ("==" "mine-other" . smerge-diff-mine-other)) + "The base keymap for `smerge-mode'.") + +(defcustom smerge-command-prefix "\C-c^" + "Prefix for `smerge-mode' commands." + :group 'smerge + :type '(choice (const :tag "ESC" "\e") + (const :tag "C-c ^" "\C-c^" ) + (const :tag "none" "") + string)) + +(easy-mmode-defmap smerge-mode-map + `((,smerge-command-prefix . ,smerge-basic-map)) + "Keymap for `smerge-mode'.") + +(defvar smerge-check-cache nil) +(make-variable-buffer-local 'smerge-check-cache) +(defun smerge-check (n) + (condition-case nil + (let ((state (cons (point) (buffer-modified-tick)))) + (unless (equal (cdr smerge-check-cache) state) + (smerge-match-conflict) + (setq smerge-check-cache (cons (match-data) state))) + (nth (* 2 n) (car smerge-check-cache))) + (error nil))) + +(easy-menu-define smerge-mode-menu smerge-mode-map + "Menu for `smerge-mode'." + '("SMerge" + ["Next" smerge-next :help "Go to next conflict"] + ["Previous" smerge-prev :help "Go to previous conflict"] + "--" + ["Keep All" smerge-keep-all :help "Keep all three versions" + :active (smerge-check 1)] + ["Keep Current" smerge-keep-current :help "Use current (at point) version" + :active (and (smerge-check 1) (> (smerge-get-current) 0))] + "--" + ["Revert to Base" smerge-keep-base :help "Revert to base version" + :active (smerge-check 2)] + ["Keep Other" smerge-keep-other :help "Keep `other' version" + :active (smerge-check 3)] + ["Keep Yours" smerge-keep-mine :help "Keep your version" + :active (smerge-check 1)] + "--" + ["Diff Base/Mine" smerge-diff-base-mine + :help "Diff `base' and `mine' for current conflict" + :active (smerge-check 2)] + ["Diff Base/Other" smerge-diff-base-other + :help "Diff `base' and `other' for current conflict" + :active (smerge-check 2)] + ["Diff Mine/Other" smerge-diff-mine-other + :help "Diff `mine' and `other' for current conflict" + :active (smerge-check 1)] + "--" + ["Invoke Ediff" smerge-ediff + :help "Use Ediff to resolve the conflicts" + :active (smerge-check 1)] + ["Auto Resolve" smerge-resolve + :help "Try auto-resolution heuristics" + :active (smerge-check 1)] + ["Combine" smerge-combine-with-next + :help "Combine current conflict with next" + :active (smerge-check 1)] + )) + +(easy-menu-define smerge-context-menu nil + "Context menu for mine area in `smerge-mode'." + '(nil + ["Keep Current" smerge-keep-current :help "Use current (at point) version"] + ["Kill Current" smerge-kill-current :help "Remove current (at point) version"] + ["Keep All" smerge-keep-all :help "Keep all three versions"] + "---" + ["More..." (popup-menu smerge-mode-menu) :help "Show full SMerge mode menu"] + )) + +(defconst smerge-font-lock-keywords + '((smerge-find-conflict + (1 smerge-mine-face prepend t) + (2 smerge-base-face prepend t) + (3 smerge-other-face prepend t) + ;; FIXME: `keep' doesn't work right with syntactic fontification. + (0 smerge-markers-face keep) + (4 nil t t) + (5 nil t t))) + "Font lock patterns for `smerge-mode'.") + +(defconst smerge-begin-re "^<<<<<<< \\(.*\\)\n") +(defconst smerge-end-re "^>>>>>>> .*\n") +(defconst smerge-base-re "^||||||| .*\n") +(defconst smerge-other-re "^=======\n") + +(defvar smerge-conflict-style nil + "Keep track of which style of conflict is in use. +Can be nil if the style is undecided, or else: +- `diff3-E' +- `diff3-A'") + +;; Compiler pacifiers +(defvar font-lock-mode) +(defvar font-lock-keywords) + +;;;; +;;;; Actual code +;;;; + +;; Define smerge-next and smerge-prev +(easy-mmode-define-navigation smerge smerge-begin-re "conflict" nil nil + (if diff-auto-refine-mode + (condition-case nil (smerge-refine) (error nil)))) + +(defconst smerge-match-names ["conflict" "mine" "base" "other"]) + +(defun smerge-ensure-match (n) + (unless (match-end n) + (error "No `%s'" (aref smerge-match-names n)))) + +(defun smerge-auto-leave () + (when (and smerge-auto-leave + (save-excursion (goto-char (point-min)) + (not (re-search-forward smerge-begin-re nil t)))) + (when (and (listp buffer-undo-list) smerge-mode) + (push (list 'apply 'smerge-mode 1) buffer-undo-list)) + (smerge-mode -1))) + + +(defun smerge-keep-all () + "Concatenate all versions." + (interactive) + (smerge-match-conflict) + (let ((mb2 (or (match-beginning 2) (point-max))) + (me2 (or (match-end 2) (point-min)))) + (delete-region (match-end 3) (match-end 0)) + (delete-region (max me2 (match-end 1)) (match-beginning 3)) + (if (and (match-end 2) (/= (match-end 1) (match-end 3))) + (delete-region (match-end 1) (match-beginning 2))) + (delete-region (match-beginning 0) (min (match-beginning 1) mb2)) + (smerge-auto-leave))) + +(defun smerge-keep-n (n) + (smerge-remove-props (match-beginning 0) (match-end 0)) + ;; We used to use replace-match, but that did not preserve markers so well. + (delete-region (match-end n) (match-end 0)) + (delete-region (match-beginning 0) (match-beginning n))) + +(defun smerge-combine-with-next () + "Combine the current conflict with the next one." + ;; `smerge-auto-combine' relies on the finish position (at the beginning + ;; of the closing marker). + (interactive) + (smerge-match-conflict) + (let ((ends nil)) + (dolist (i '(3 2 1 0)) + (push (if (match-end i) (copy-marker (match-end i) t)) ends)) + (setq ends (apply 'vector ends)) + (goto-char (aref ends 0)) + (if (not (re-search-forward smerge-begin-re nil t)) + (error "No next conflict") + (smerge-match-conflict) + (let ((match-data (mapcar (lambda (m) (if m (copy-marker m))) + (match-data)))) + ;; First copy the in-between text in each alternative. + (dolist (i '(1 2 3)) + (when (aref ends i) + (goto-char (aref ends i)) + (insert-buffer-substring (current-buffer) + (aref ends 0) (car match-data)))) + (delete-region (aref ends 0) (car match-data)) + ;; Then move the second conflict's alternatives into the first. + (dolist (i '(1 2 3)) + (set-match-data match-data) + (when (and (aref ends i) (match-end i)) + (goto-char (aref ends i)) + (insert-buffer-substring (current-buffer) + (match-beginning i) (match-end i)))) + (delete-region (car match-data) (cadr match-data)) + ;; Free the markers. + (dolist (m match-data) (if m (move-marker m nil))) + (mapc (lambda (m) (if m (move-marker m nil))) ends))))) + +(defvar smerge-auto-combine-max-separation 2 + "Max number of lines between conflicts that should be combined.") + +(defun smerge-auto-combine () + "Automatically combine conflicts that are near each other." + (interactive) + (save-excursion + (goto-char (point-min)) + (while (smerge-find-conflict) + ;; 2 is 1 (default) + 1 (the begin markers). + (while (save-excursion + (smerge-find-conflict + (line-beginning-position + (+ 2 smerge-auto-combine-max-separation)))) + (forward-line -1) ;Go back inside the conflict. + (smerge-combine-with-next) + (forward-line 1) ;Move past the end of the conflict. + )))) + +(defvar smerge-resolve-function + (lambda () (error "Don't know how to resolve")) + "Mode-specific merge function. +The function is called with zero or one argument (non-nil if the resolution +function should only apply safe heuristics) and with the match data set +according to `smerge-match-conflict'.") +(add-to-list 'debug-ignored-errors "Don't know how to resolve") + +(defvar smerge-text-properties + `(help-echo "merge conflict: mouse-3 shows a menu" + ;; mouse-face highlight + keymap (keymap (down-mouse-3 . smerge-popup-context-menu)))) + +(defun smerge-remove-props (beg end) + (remove-overlays beg end 'smerge 'refine) + (remove-overlays beg end 'smerge 'conflict) + ;; Now that we use overlays rather than text-properties, this function + ;; does not cause refontification any more. It can be seen very clearly + ;; in buffers where jit-lock-contextually is not t, in which case deleting + ;; the "<<<<<<< foobar" leading line leaves the rest of the conflict + ;; highlighted as if it were still a valid conflict. Note that in many + ;; important cases (such as the previous example) we're actually called + ;; during font-locking so inhibit-modification-hooks is non-nil, so we + ;; can't just modify the buffer and expect font-lock to be triggered as in: + ;; (put-text-property beg end 'smerge-force-highlighting nil) + (with-silent-modifications + (remove-text-properties beg end '(fontified nil)))) + +(defun smerge-popup-context-menu (event) + "Pop up the Smerge mode context menu under mouse." + (interactive "e") + (if (and smerge-mode + (save-excursion (posn-set-point (event-end event)) (smerge-check 1))) + (progn + (posn-set-point (event-end event)) + (smerge-match-conflict) + (let ((i (smerge-get-current)) + o) + (if (<= i 0) + ;; Out of range + (popup-menu smerge-mode-menu) + ;; Install overlay. + (setq o (make-overlay (match-beginning i) (match-end i))) + (unwind-protect + (progn + (overlay-put o 'face 'highlight) + (sit-for 0) ;Display the new highlighting. + (popup-menu smerge-context-menu)) + ;; Delete overlay. + (delete-overlay o))))) + ;; There's no conflict at point, the text-props are just obsolete. + (save-excursion + (let ((beg (re-search-backward smerge-end-re nil t)) + (end (re-search-forward smerge-begin-re nil t))) + (smerge-remove-props (or beg (point-min)) (or end (point-max))) + (push event unread-command-events))))) + +(defun smerge-apply-resolution-patch (buf m0b m0e m3b m3e &optional m2b) + "Replace the conflict with a bunch of subconflicts. +BUF contains a plain diff between match-1 and match-3." + (let ((line 1) + (textbuf (current-buffer)) + (name1 (progn (goto-char m0b) + (buffer-substring (+ (point) 8) (line-end-position)))) + (name2 (when m2b (goto-char m2b) (forward-line -1) + (buffer-substring (+ (point) 8) (line-end-position)))) + (name3 (progn (goto-char m0e) (forward-line -1) + (buffer-substring (+ (point) 8) (line-end-position))))) + (smerge-remove-props m0b m0e) + (delete-region m3e m0e) + (delete-region m0b m3b) + (setq m3b m0b) + (setq m3e (- m3e (- m3b m0b))) + (goto-char m3b) + (with-current-buffer buf + (goto-char (point-min)) + (while (not (eobp)) + (if (not (looking-at "\\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)?\\([acd]\\)\\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)?$")) + (error "Unexpected patch hunk header: %s" + (buffer-substring (point) (line-end-position))) + (let* ((op (char-after (match-beginning 3))) + (startline (+ (string-to-number (match-string 1)) + ;; No clue why this is the way it is, but line + ;; numbers seem to be off-by-one for `a' ops. + (if (eq op ?a) 1 0))) + (endline (if (eq op ?a) startline + (1+ (if (match-end 2) + (string-to-number (match-string 2)) + startline)))) + (lines (- endline startline)) + (otherlines (cond + ((eq op ?d) nil) + ((null (match-end 5)) 1) + (t (- (string-to-number (match-string 5)) + (string-to-number (match-string 4)) -1)))) + othertext) + (forward-line 1) ;Skip header. + (forward-line lines) ;Skip deleted text. + (if (eq op ?c) (forward-line 1)) ;Skip separator. + (setq othertext + (if (null otherlines) "" + (let ((pos (point))) + (dotimes (i otherlines) (delete-char 2) (forward-line 1)) + (buffer-substring pos (point))))) + (with-current-buffer textbuf + (forward-line (- startline line)) + (insert "<<<<<<< " name1 "\n" othertext + (if name2 (concat "||||||| " name2 "\n") "") + "=======\n") + (forward-line lines) + (insert ">>>>>>> " name3 "\n") + (setq line endline)))))))) + +(defun smerge-resolve (&optional safe) + "Resolve the conflict at point intelligently. +This relies on mode-specific knowledge and thus only works in some +major modes. Uses `smerge-resolve-function' to do the actual work." + (interactive) + (smerge-match-conflict) + (smerge-remove-props (match-beginning 0) (match-end 0)) + (let ((md (match-data)) + (m0b (match-beginning 0)) + (m1b (match-beginning 1)) + (m2b (match-beginning 2)) + (m3b (match-beginning 3)) + (m0e (match-end 0)) + (m1e (match-end 1)) + (m2e (match-end 2)) + (m3e (match-end 3)) + (buf (generate-new-buffer " *smerge*")) + m b o) + (unwind-protect + (progn + (cond + ;; Trivial diff3 -A non-conflicts. + ((and (eq (match-end 1) (match-end 3)) + (eq (match-beginning 1) (match-beginning 3))) + (smerge-keep-n 3)) + ;; Mode-specific conflict resolution. + ((condition-case nil + (atomic-change-group + (if safe + (funcall smerge-resolve-function safe) + (funcall smerge-resolve-function)) + t) + (error nil)) + ;; Nothing to do: the resolution function has done it already. + nil) + ;; Non-conflict. + ((and (eq m1e m3e) (eq m1b m3b)) + (set-match-data md) (smerge-keep-n 3)) + ;; Refine a 2-way conflict using "diff -b". + ;; In case of a 3-way conflict with an empty base + ;; (i.e. 2 conflicting additions), we do the same, presuming + ;; that the 2 additions should be somehow merged rather + ;; than concatenated. + ((let ((lines (count-lines m3b m3e))) + (setq m (make-temp-file "smm")) + (write-region m1b m1e m nil 'silent) + (setq o (make-temp-file "smo")) + (write-region m3b m3e o nil 'silent) + (not (or (eq m1b m1e) (eq m3b m3e) + (and (not (zerop (call-process diff-command + nil buf nil "-b" o m))) + ;; TODO: We don't know how to do the refinement + ;; if there's a non-empty ancestor and m1 and m3 + ;; aren't just plain equal. + m2b (not (eq m2b m2e))) + (with-current-buffer buf + (goto-char (point-min)) + ;; Make sure there's some refinement. + (looking-at + (concat "1," (number-to-string lines) "c")))))) + (smerge-apply-resolution-patch buf m0b m0e m3b m3e m2b)) + ;; "Mere whitespace changes" conflicts. + ((when m2e + (setq b (make-temp-file "smb")) + (write-region m2b m2e b nil 'silent) + (with-current-buffer buf (erase-buffer)) + ;; Only minor whitespace changes made locally. + ;; BEWARE: pass "-c" 'cause the output is reused in the next test. + (zerop (call-process diff-command nil buf nil "-bc" b m))) + (set-match-data md) + (smerge-keep-n 3)) + ;; Try "diff -b BASE MINE | patch OTHER". + ((when (and (not safe) m2e b + ;; If the BASE is empty, this would just concatenate + ;; the two, which is rarely right. + (not (eq m2b m2e))) + ;; BEWARE: we're using here the patch of the previous test. + (with-current-buffer buf + (zerop (call-process-region + (point-min) (point-max) "patch" t nil nil + "-r" "/dev/null" "--no-backup-if-mismatch" + "-fl" o)))) + (save-restriction + (narrow-to-region m0b m0e) + (smerge-remove-props m0b m0e) + (insert-file-contents o nil nil nil t))) + ;; Try "diff -b BASE OTHER | patch MINE". + ((when (and (not safe) m2e b + ;; If the BASE is empty, this would just concatenate + ;; the two, which is rarely right. + (not (eq m2b m2e))) + (write-region m3b m3e o nil 'silent) + (call-process diff-command nil buf nil "-bc" b o) + (with-current-buffer buf + (zerop (call-process-region + (point-min) (point-max) "patch" t nil nil + "-r" "/dev/null" "--no-backup-if-mismatch" + "-fl" m)))) + (save-restriction + (narrow-to-region m0b m0e) + (smerge-remove-props m0b m0e) + (insert-file-contents m nil nil nil t))) + (t + (error "Don't know how to resolve")))) + (if (buffer-name buf) (kill-buffer buf)) + (if m (delete-file m)) + (if b (delete-file b)) + (if o (delete-file o)))) + (smerge-auto-leave)) + +(defun smerge-resolve-all () + "Perform automatic resolution on all conflicts." + (interactive) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward smerge-begin-re nil t) + (condition-case nil + (progn + (smerge-match-conflict) + (smerge-resolve 'safe)) + (error nil))))) + +(defun smerge-batch-resolve () + ;; command-line-args-left is what is left of the command line. + (if (not noninteractive) + (error "`smerge-batch-resolve' is to be used only with -batch")) + (while command-line-args-left + (let ((file (pop command-line-args-left))) + (if (string-match "\\.rej\\'" file) + ;; .rej files should never contain diff3 markers, on the other hand, + ;; in Arch, .rej files are sometimes used to indicate that the + ;; main file has diff3 markers. So you can pass **/*.rej and + ;; it will DTRT. + (setq file (substring file 0 (match-beginning 0)))) + (message "Resolving conflicts in %s..." file) + (when (file-readable-p file) + (with-current-buffer (find-file-noselect file) + (smerge-resolve-all) + (save-buffer) + (kill-buffer (current-buffer))))))) + +(defun smerge-keep-base () + "Revert to the base version." + (interactive) + (smerge-match-conflict) + (smerge-ensure-match 2) + (smerge-keep-n 2) + (smerge-auto-leave)) + +(defun smerge-keep-other () + "Use \"other\" version." + (interactive) + (smerge-match-conflict) + ;;(smerge-ensure-match 3) + (smerge-keep-n 3) + (smerge-auto-leave)) + +(defun smerge-keep-mine () + "Keep your version." + (interactive) + (smerge-match-conflict) + ;;(smerge-ensure-match 1) + (smerge-keep-n 1) + (smerge-auto-leave)) + +(defun smerge-get-current () + (let ((i 3)) + (while (or (not (match-end i)) + (< (point) (match-beginning i)) + (>= (point) (match-end i))) + (decf i)) + i)) + +(defun smerge-keep-current () + "Use the current (under the cursor) version." + (interactive) + (smerge-match-conflict) + (let ((i (smerge-get-current))) + (if (<= i 0) (error "Not inside a version") + (smerge-keep-n i) + (smerge-auto-leave)))) + +(defun smerge-kill-current () + "Remove the current (under the cursor) version." + (interactive) + (smerge-match-conflict) + (let ((i (smerge-get-current))) + (if (<= i 0) (error "Not inside a version") + (let ((left nil)) + (dolist (n '(3 2 1)) + (if (and (match-end n) (/= (match-end n) (match-end i))) + (push n left))) + (if (and (cdr left) + (/= (match-end (car left)) (match-end (cadr left)))) + (ding) ;We don't know how to do that. + (smerge-keep-n (car left)) + (smerge-auto-leave)))))) + +(defun smerge-diff-base-mine () + "Diff 'base' and 'mine' version in current conflict region." + (interactive) + (smerge-diff 2 1)) + +(defun smerge-diff-base-other () + "Diff 'base' and 'other' version in current conflict region." + (interactive) + (smerge-diff 2 3)) + +(defun smerge-diff-mine-other () + "Diff 'mine' and 'other' version in current conflict region." + (interactive) + (smerge-diff 1 3)) + +(defun smerge-match-conflict () + "Get info about the conflict. Puts the info in the `match-data'. +The submatches contain: + 0: the whole conflict. + 1: your code. + 2: the base code. + 3: other code. +An error is raised if not inside a conflict." + (save-excursion + (condition-case nil + (let* ((orig-point (point)) + + (_ (forward-line 1)) + (_ (re-search-backward smerge-begin-re)) + + (start (match-beginning 0)) + (mine-start (match-end 0)) + (filename (or (match-string 1) "")) + + (_ (re-search-forward smerge-end-re)) + (_ (assert (< orig-point (match-end 0)))) + + (other-end (match-beginning 0)) + (end (match-end 0)) + + (_ (re-search-backward smerge-other-re start)) + + (mine-end (match-beginning 0)) + (other-start (match-end 0)) + + base-start base-end) + + ;; handle the various conflict styles + (cond + ((save-excursion + (goto-char mine-start) + (re-search-forward smerge-begin-re end t)) + ;; There's a nested conflict and we're after the beginning + ;; of the outer one but before the beginning of the inner one. + ;; Of course, maybe this is not a nested conflict but in that + ;; case it can only be something nastier that we don't know how + ;; to handle, so may as well arbitrarily decide to treat it as + ;; a nested conflict. --Stef + (error "There is a nested conflict")) + + ((re-search-backward smerge-base-re start t) + ;; a 3-parts conflict + (set (make-local-variable 'smerge-conflict-style) 'diff3-A) + (setq base-end mine-end) + (setq mine-end (match-beginning 0)) + (setq base-start (match-end 0))) + + ((string= filename (file-name-nondirectory + (or buffer-file-name ""))) + ;; a 2-parts conflict + (set (make-local-variable 'smerge-conflict-style) 'diff3-E)) + + ((and (not base-start) + (or (eq smerge-conflict-style 'diff3-A) + (equal filename "ANCESTOR") + (string-match "\\`[.0-9]+\\'" filename))) + ;; a same-diff conflict + (setq base-start mine-start) + (setq base-end mine-end) + (setq mine-start other-start) + (setq mine-end other-end))) + + (store-match-data (list start end + mine-start mine-end + base-start base-end + other-start other-end + (when base-start (1- base-start)) base-start + (1- other-start) other-start)) + t) + (search-failed (error "Point not in conflict region"))))) + +(add-to-list 'debug-ignored-errors "Point not in conflict region") + +(defun smerge-conflict-overlay (pos) + "Return the conflict overlay at POS if any." + (let ((ols (overlays-at pos)) + conflict) + (dolist (ol ols) + (if (and (eq (overlay-get ol 'smerge) 'conflict) + (> (overlay-end ol) pos)) + (setq conflict ol))) + conflict)) + +(defun smerge-find-conflict (&optional limit) + "Find and match a conflict region. Intended as a font-lock MATCHER. +The submatches are the same as in `smerge-match-conflict'. +Returns non-nil if a match is found between point and LIMIT. +Point is moved to the end of the conflict." + (let ((found nil) + (pos (point)) + conflict) + ;; First check to see if point is already inside a conflict, using + ;; the conflict overlays. + (while (and (not found) (setq conflict (smerge-conflict-overlay pos))) + ;; Check the overlay's validity and kill it if it's out of date. + (condition-case nil + (progn + (goto-char (overlay-start conflict)) + (smerge-match-conflict) + (goto-char (match-end 0)) + (if (<= (point) pos) + (error "Matching backward!") + (setq found t))) + (error (smerge-remove-props + (overlay-start conflict) (overlay-end conflict)) + (goto-char pos)))) + ;; If we're not already inside a conflict, look for the next conflict + ;; and add/update its overlay. + (while (and (not found) (re-search-forward smerge-begin-re limit t)) + (condition-case nil + (progn + (smerge-match-conflict) + (goto-char (match-end 0)) + (let ((conflict (smerge-conflict-overlay (1- (point))))) + (if conflict + ;; Update its location, just in case it got messed up. + (move-overlay conflict (match-beginning 0) (match-end 0)) + (setq conflict (make-overlay (match-beginning 0) (match-end 0) + nil 'front-advance nil)) + (overlay-put conflict 'evaporate t) + (overlay-put conflict 'smerge 'conflict) + (let ((props smerge-text-properties)) + (while props + (overlay-put conflict (pop props) (pop props)))))) + (setq found t)) + (error nil))) + found)) + +;;; Refined change highlighting + +(defvar smerge-refine-forward-function 'smerge-refine-forward + "Function used to determine an \"atomic\" element. +You can set it to `forward-char' to get char-level granularity. +Its behavior has mainly two restrictions: +- if this function encounters a newline, it's important that it stops right + after the newline. + This only matters if `smerge-refine-ignore-whitespace' is nil. +- it needs to be unaffected by changes performed by the `preproc' argument + to `smerge-refine-subst'. + This only matters if `smerge-refine-weight-hack' is nil.") + +(defvar smerge-refine-ignore-whitespace t + "If non-nil, indicate that `smerge-refine' should try to ignore change in whitespace.") + +(defvar smerge-refine-weight-hack t + "If non-nil, pass to diff as many lines as there are chars in the region. +I.e. each atomic element (e.g. word) will be copied as many times (on different +lines) as it has chars. This has two advantages: +- if `diff' tries to minimize the number *lines* (rather than chars) + added/removed, this adjust the weights so that adding/removing long + symbols is considered correspondingly more costly. +- `smerge-refine-forward-function' only needs to be called when chopping up + the regions, and `forward-char' can be used afterwards. +It has the following disadvantages: +- cannot use `diff -w' because the weighting causes added spaces in a line + to be represented as added copies of some line, so `diff -w' can't do the + right thing any more. +- may in degenerate cases take a 1KB input region and turn it into a 1MB + file to pass to diff.") + +(defun smerge-refine-forward (n) + (let ((case-fold-search nil) + (re "[[:upper:]]?[[:lower:]]+\\|[[:upper:]]+\\|[[:digit:]]+\\|.\\|\n")) + (when (and smerge-refine-ignore-whitespace + ;; smerge-refine-weight-hack causes additional spaces to + ;; appear as additional lines as well, so even if diff ignore + ;; whitespace changes, it'll report added/removed lines :-( + (not smerge-refine-weight-hack)) + (setq re (concat "[ \t]*\\(?:" re "\\)"))) + (dotimes (i n) + (unless (looking-at re) (error "Smerge refine internal error")) + (goto-char (match-end 0))))) + +(defun smerge-refine-chopup-region (beg end file &optional preproc) + "Chopup the region into small elements, one per line. +Save the result into FILE. +If non-nil, PREPROC is called with no argument in a buffer that contains +a copy of the text, just before chopping it up. It can be used to replace +chars to try and eliminate some spurious differences." + ;; We used to chop up char-by-char rather than word-by-word like ediff + ;; does. It had the benefit of simplicity and very fine results, but it + ;; often suffered from problem that diff would find correlations where + ;; there aren't any, so the resulting "change" didn't make much sense. + ;; You can still get this behavior by setting + ;; `smerge-refine-forward-function' to `forward-char'. + (let ((buf (current-buffer))) + (with-temp-buffer + (insert-buffer-substring buf beg end) + (when preproc (goto-char (point-min)) (funcall preproc)) + (when smerge-refine-ignore-whitespace + ;; It doesn't make much of a difference for diff-fine-highlight + ;; because we still have the _/+//! prefix anyway. Can still be + ;; useful in other circumstances. + (subst-char-in-region (point-min) (point-max) ?\n ?\s)) + (goto-char (point-min)) + (while (not (eobp)) + (funcall smerge-refine-forward-function 1) + (let ((s (if (prog2 (forward-char -1) (bolp) (forward-char 1)) + nil + (buffer-substring (line-beginning-position) (point))))) + ;; We add \n after each char except after \n, so we get + ;; one line per text char, where each line contains + ;; just one char, except for \n chars which are + ;; represented by the empty line. + (unless (eq (char-before) ?\n) (insert ?\n)) + ;; HACK ALERT!! + (if smerge-refine-weight-hack + (dotimes (i (1- (length s))) (insert s "\n"))))) + (unless (bolp) (error "Smerge refine internal error")) + (let ((coding-system-for-write 'emacs-mule)) + (write-region (point-min) (point-max) file nil 'nomessage))))) + +(defun smerge-refine-highlight-change (buf beg match-num1 match-num2 props) + (with-current-buffer buf + (goto-char beg) + (let* ((startline (- (string-to-number match-num1) 1)) + (beg (progn (funcall (if smerge-refine-weight-hack + 'forward-char + smerge-refine-forward-function) + startline) + (point))) + (end (progn (funcall (if smerge-refine-weight-hack + 'forward-char + smerge-refine-forward-function) + (if match-num2 + (- (string-to-number match-num2) + startline) + 1)) + (point)))) + (when smerge-refine-ignore-whitespace + (skip-chars-backward " \t\n" beg) (setq end (point)) + (goto-char beg) + (skip-chars-forward " \t\n" end) (setq beg (point))) + (when (> end beg) + (let ((ol (make-overlay + beg end nil + ;; Make them tend to shrink rather than spread when editing. + 'front-advance nil))) + (overlay-put ol 'evaporate t) + (dolist (x props) (overlay-put ol (car x) (cdr x))) + ol))))) + +(defun smerge-refine-subst (beg1 end1 beg2 end2 props &optional preproc) + "Show fine differences in the two regions BEG1..END1 and BEG2..END2. +PROPS is an alist of properties to put (via overlays) on the changes. +If non-nil, PREPROC is called with no argument in a buffer that contains +a copy of a region, just before preparing it to for `diff'. It can be +used to replace chars to try and eliminate some spurious differences." + (let* ((buf (current-buffer)) + (pos (point)) + (file1 (make-temp-file "diff1")) + (file2 (make-temp-file "diff2"))) + ;; Chop up regions into smaller elements and save into files. + (smerge-refine-chopup-region beg1 end1 file1 preproc) + (smerge-refine-chopup-region beg2 end2 file2 preproc) + + ;; Call diff on those files. + (unwind-protect + (with-temp-buffer + (let ((coding-system-for-read 'emacs-mule)) + (call-process diff-command nil t nil + (if (and smerge-refine-ignore-whitespace + (not smerge-refine-weight-hack)) + ;; Pass -a so diff treats it as a text file even + ;; if it contains \0 and such. + ;; Pass -d so as to get the smallest change, but + ;; also and more importantly because otherwise it + ;; may happen that diff doesn't behave like + ;; smerge-refine-weight-hack expects it to. + ;; See http://thread.gmane.org/gmane.emacs.devel/82685. + "-awd" "-ad") + file1 file2)) + ;; Process diff's output. + (goto-char (point-min)) + (let ((last1 nil) + (last2 nil)) + (while (not (eobp)) + (if (not (looking-at "\\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)?\\([acd]\\)\\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)?$")) + (error "Unexpected patch hunk header: %s" + (buffer-substring (point) (line-end-position)))) + (let ((op (char-after (match-beginning 3))) + (m1 (match-string 1)) + (m2 (match-string 2)) + (m4 (match-string 4)) + (m5 (match-string 5))) + (when (memq op '(?d ?c)) + (setq last1 + (smerge-refine-highlight-change buf beg1 m1 m2 props))) + (when (memq op '(?a ?c)) + (setq last2 + (smerge-refine-highlight-change buf beg2 m4 m5 props)))) + (forward-line 1) ;Skip hunk header. + (and (re-search-forward "^[0-9]" nil 'move) ;Skip hunk body. + (goto-char (match-beginning 0)))) + ;; (assert (or (null last1) (< (overlay-start last1) end1))) + ;; (assert (or (null last2) (< (overlay-start last2) end2))) + (if smerge-refine-weight-hack + (progn + ;; (assert (or (null last1) (<= (overlay-end last1) end1))) + ;; (assert (or (null last2) (<= (overlay-end last2) end2))) + ) + ;; smerge-refine-forward-function when calling in chopup may + ;; have stopped because it bumped into EOB whereas in + ;; smerge-refine-weight-hack it may go a bit further. + (if (and last1 (> (overlay-end last1) end1)) + (move-overlay last1 (overlay-start last1) end1)) + (if (and last2 (> (overlay-end last2) end2)) + (move-overlay last2 (overlay-start last2) end2)) + ))) + (goto-char pos) + (delete-file file1) + (delete-file file2)))) + +(defun smerge-refine (&optional part) + "Highlight the words of the conflict that are different. +For 3-way conflicts, highlights only two of the three parts. +A numeric argument PART can be used to specify which two parts; +repeating the command will highlight other two parts." + (interactive + (if (integerp current-prefix-arg) (list current-prefix-arg) + (smerge-match-conflict) + (let* ((prop (get-text-property (match-beginning 0) 'smerge-refine-part)) + (part (if (and (consp prop) + (eq (buffer-chars-modified-tick) (car prop))) + (cdr prop)))) + ;; If already highlighted, cycle. + (list (if (integerp part) (1+ (mod part 3))))))) + + (if (and (integerp part) (or (< part 1) (> part 3))) + (error "No conflict part nb %s" part)) + (smerge-match-conflict) + (remove-overlays (match-beginning 0) (match-end 0) 'smerge 'refine) + ;; Ignore `part' if not applicable, and default it if not provided. + (setq part (cond ((null (match-end 2)) 2) + ((eq (match-end 1) (match-end 3)) 1) + ((integerp part) part) + ;; 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 diff --cc lisp/vc/vc-annotate.el index 10b88e6f14c,00000000000..edf632f4410 mode 100644,000000..100644 --- a/lisp/vc/vc-annotate.el +++ b/lisp/vc/vc-annotate.el @@@ -1,680 -1,0 +1,680 @@@ +;;; vc-annotate.el --- VC Annotate Support + +;; Copyright (C) 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2006, - ;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ++;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. + +;; Author: Martin Lorentzson +;; 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 . + +;;; 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 diff --cc lisp/vc/vc-arch.el index ba91f7f23c6,00000000000..cbe3a38fcb3 mode 100644,000000..100644 --- a/lisp/vc/vc-arch.el +++ b/lisp/vc/vc-arch.el @@@ -1,642 -1,0 +1,642 @@@ +;;; vc-arch.el --- VC backend for the Arch version-control system + - ;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 ++;; 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 +;; 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 . + +;;; 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 diff --cc lisp/vc/vc-cvs.el index a78b59ffba5,00000000000..3b5766bda62 mode 100644,000000..100644 --- a/lisp/vc/vc-cvs.el +++ b/lisp/vc/vc-cvs.el @@@ -1,1214 -1,0 +1,1214 @@@ +;;; vc-cvs.el --- non-resident support for CVS version-control + +;; Copyright (C) 1995, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - ;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ++;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. + +;; Author: FSF (see vc.el for full credits) +;; Maintainer: Andre Spiegel +;; 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 . + +;;; 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 diff --cc lisp/vc/vc-dav.el index bd495eaf4b7,00000000000..571a2ca8689 mode 100644,000000..100644 --- a/lisp/vc/vc-dav.el +++ b/lisp/vc/vc-dav.el @@@ -1,190 -1,0 +1,190 @@@ +;;; vc-dav.el --- vc.el support for WebDAV + - ;; Copyright (C) 2001, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ++;; Copyright (C) 2001, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. + +;; Author: Bill Perry +;; Maintainer: Bill Perry +;; 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 . + + +;;; Commentary: + +;;; Todo: +;; +;; - Some methods need to be updated to match the current vc.el. +;; - rename "version" -> "revision" +;; - some methods need to take a fileset as a parameter instead of a +;; single file. + +;;; Code: + +(require 'url) +(require 'url-dav) + +;;; Required functions for a vc backend +(defun vc-dav-registered (url) + "Return t if URL is registered with a DAV aware server." + (url-dav-vc-registered url)) + +(defun vc-dav-state (url) + "Return the current version control state of URL. +For a list of possible values, see `vc-state'." + ;; Things we can support for WebDAV + ;; + ;; up-to-date - use lockdiscovery + ;; edited - check for an active lock by us + ;; USER - use lockdiscovery + owner + ;; + ;; These don't make sense for WebDAV + ;; needs-patch + ;; needs-merge + ;; unlocked-changes + (let ((locks (url-dav-active-locks url))) + (cond + ((null locks) 'up-to-date) + ((assoc url locks) + ;; SOMEBODY has a lock... let's find out who. + (setq locks (cdr (assoc url locks))) + (if (rassoc url-dav-lock-identifier locks) + ;; _WE_ have a lock + 'edited + (cdr (car locks))))))) + +(defun vc-dav-checkout-model (url) + "Indicate whether URL needs to be \"checked out\" before it can be edited. +See `vc-checkout-model' for a list of possible values." + ;; The only thing we can support with webdav is 'locking + 'locking) + +;; This should figure out the version # of the file somehow. What is +;; the most appropriate property in WebDAV to look at for this? +(defun vc-dav-workfile-version (url) + "Return the current workfile version of URL." + "Unknown") + +(defun vc-dav-register (url &optional rev comment) + "Register URL in the DAV backend." + ;; Do we need to do anything here? FIXME? + ) + +(defun vc-dav-checkin (url rev comment) + "Commit changes in URL to WebDAV. +If REV is non-nil, that should become the new revision number. +COMMENT is used as a check-in comment." + ;; This should PUT the resource and release any locks that we hold. + ) + +(defun vc-dav-checkout (url &optional editable rev destfile) + "Check out revision REV of URL into the working area. + +If EDITABLE is non-nil URL should be writable by the user and if +locking is used for URL, a lock should also be set. + +If REV is non-nil, that is the revision to check out. If REV is the +empty string, that means to check ou tht ehead of the trunk. + +If optional arg DESTFILE is given, it is an alternate filename to +write the contents to. +" + ;; This should LOCK the resource. + ) + +(defun vc-dav-revert (url &optional contents-done) + "Revert URL back to the current workfile version. + +If optional arg CONTENTS-DONE is non-nil, then the contents of FILE +have already been reverted from a version backup, and this function +only needs to update the status of URL within the backend. +" + ;; Should do a GET if !contents_done + ;; Should UNLOCK the file. + ) + +(defun vc-dav-print-log (url) + "Insert the revision log of URL into the *vc* buffer." + ) + +(defun vc-dav-diff (url &optional rev1 rev2) + "Insert the diff for URL into the *vc-diff* buffer. +If REV1 and REV2 are non-nil report differences from REV1 to REV2. +If REV1 is nil, use the current workfile version as the older version. +If REV2 is nil, use the current workfile contents as the nwer version. + +It should return a status of either 0 (no differences found), or +1 (either non-empty diff or the diff is run asynchronously). +" + ;; We should do this asynchronously... + ;; How would we do it at all, that is the question! + ) + + + +;;; Optional functions +;; Should be faster than vc-dav-state - but how? +(defun vc-dav-state-heuristic (url) + "Estimate the version control state of URL at visiting time." + (vc-dav-state url)) + +;; This should use url-dav-get-properties with a depth of `1' to get +;; all the properties. +(defun vc-dav-dir-state (url) + "find the version control state of all files in DIR in a fast way." + ) + +(defun vc-dav-workfile-unchanged-p (url) + "Return non-nil if URL is unchanged from its current workfile version." + ;; Probably impossible with webdav + ) + +(defun vc-dav-responsible-p (url) + "Return non-nil if DAV considers itself `responsible' for URL." + ;; Check for DAV support on the web server. + t) + +(defun vc-dav-could-register (url) + "Return non-nil if URL could be registered under this backend." + ;; Check for DAV support on the web server. + t) + +;;; Unimplemented functions +;; +;; vc-dav-latest-on-branch-p(URL) +;; Return non-nil if the current workfile version of FILE is the +;; latest on its branch. There are no branches in webdav yet. +;; +;; vc-dav-mode-line-string(url) +;; Return a dav-specific mode line string for URL. Are there any +;; specific states that we want exposed? +;; +;; vc-dav-dired-state-info(url) +;; Translate the `vc-state' property of URL into a string that can +;; be used in a vc-dired buffer. Are there any extra states that +;; we want exposed? +;; +;; vc-dav-receive-file(url rev) +;; Let this backend `receive' a file that is already registered +;; under another backend. The default just calls `register', which +;; should be sufficient for WebDAV. +;; +;; vc-dav-unregister(url) +;; Unregister URL. Not possible with WebDAV, other than by +;; deleting the resource. + +(provide 'vc-dav) + +;; arch-tag: 0a0fb9fe-8190-4c0a-a179-5c291d3a467e +;;; vc-dav.el ends here diff --cc lisp/vc/vc-dir.el index 0335614a6ac,00000000000..36e69677229 mode 100644,000000..100644 --- a/lisp/vc/vc-dir.el +++ b/lisp/vc/vc-dir.el @@@ -1,1263 -1,0 +1,1263 @@@ +;;; vc-dir.el --- Directory status display under VC + - ;; Copyright (C) 2007, 2008, 2009, 2010 ++;; Copyright (C) 2007, 2008, 2009, 2010, 2011 +;; Free Software Foundation, Inc. + +;; Author: Dan Nicolaescu +;; 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 . + +;;; Credits: + +;; The original VC directory status implementation was based on dired. +;; This implementation was inspired by PCL-CVS. +;; Many people contributed comments, ideas and code to this +;; implementation. These include: +;; +;; Alexandre Julliard +;; Stefan Monnier +;; Tom Tromey + +;;; Commentary: +;; + +;;; Todo: see vc.el. + +(require 'vc-hooks) +(require 'vc) +(require 'tool-bar) +(require 'ewoc) + +;;; Code: +(eval-when-compile + (require 'cl)) + +(defcustom vc-dir-mode-hook nil + "Normal hook run by `vc-dir-mode'. +See `run-hooks'." + :type 'hook + :group 'vc) + +;; Used to store information for the files displayed in the directory buffer. +;; Each item displayed corresponds to one of these defstructs. +(defstruct (vc-dir-fileinfo + (:copier nil) + (:type list) ;So we can use `member' on lists of FIs. + (:constructor + ;; We could define it as an alias for `list'. + vc-dir-create-fileinfo (name state &optional extra marked directory)) + (:conc-name vc-dir-fileinfo->)) + name ;Keep it as first, for `member'. + state + ;; For storing backend specific information. + extra + marked + ;; To keep track of not updated files during a global refresh + needs-update + ;; To distinguish files and directories. + directory) + +(defvar vc-ewoc nil) + +(defvar vc-dir-process-buffer nil + "The buffer used for the asynchronous call that computes status.") + +(defvar vc-dir-backend nil + "The backend used by the current *vc-dir* buffer.") + +(defun vc-dir-move-to-goal-column () + ;; Used to keep the cursor on the file name column. + (beginning-of-line) + (unless (eolp) + ;; Must be in sync with vc-default-dir-printer. + (forward-char 25))) + +(defun vc-dir-prepare-status-buffer (bname dir backend &optional create-new) + "Find a buffer named BNAME showing DIR, or create a new one." + (setq dir (file-name-as-directory (expand-file-name dir))) + (let* ;; Look for another buffer name BNAME visiting the same directory. + ((buf (save-excursion + (unless create-new + (dolist (buffer vc-dir-buffers) + (when (buffer-live-p buffer) + (set-buffer buffer) + (when (and (derived-mode-p 'vc-dir-mode) + (eq vc-dir-backend backend) + (string= default-directory dir)) + (return buffer)))))))) + (or buf + ;; Create a new buffer named BNAME. + ;; We pass a filename to create-file-buffer because it is what + ;; the function expects, and also what uniquify needs (if active) + (with-current-buffer (create-file-buffer (expand-file-name bname dir)) + (cd dir) + (vc-setup-buffer (current-buffer)) + ;; Reset the vc-parent-buffer-name so that it does not appear + ;; in the mode-line. + (setq vc-parent-buffer-name nil) + (current-buffer))))) + +(defvar vc-dir-menu-map + (let ((map (make-sparse-keymap "VC-dir"))) + (define-key map [quit] + '(menu-item "Quit" quit-window + :help "Quit")) + (define-key map [kill] + '(menu-item "Kill Update Command" vc-dir-kill-dir-status-process + :enable (vc-dir-busy) + :help "Kill the command that updates the directory buffer")) + (define-key map [refresh] + '(menu-item "Refresh" revert-buffer + :enable (not (vc-dir-busy)) + :help "Refresh the contents of the directory buffer")) + (define-key map [remup] + '(menu-item "Hide up-to-date" vc-dir-hide-up-to-date + :help "Hide up-to-date items from display")) + ;; Movement. + (define-key map [sepmv] '("--")) + (define-key map [next-line] + '(menu-item "Next line" vc-dir-next-line + :help "Go to the next line" :keys "n")) + (define-key map [previous-line] + '(menu-item "Previous line" vc-dir-previous-line + :help "Go to the previous line")) + ;; Marking. + (define-key map [sepmrk] '("--")) + (define-key map [unmark-all] + '(menu-item "Unmark All" vc-dir-unmark-all-files + :help "Unmark all files that are in the same state as the current file\ +\nWith prefix argument unmark all files")) + (define-key map [unmark-previous] + '(menu-item "Unmark previous " vc-dir-unmark-file-up + :help "Move to the previous line and unmark the file")) + + (define-key map [mark-all] + '(menu-item "Mark All" vc-dir-mark-all-files + :help "Mark all files that are in the same state as the current file\ +\nWith prefix argument mark all files")) + (define-key map [unmark] + '(menu-item "Unmark" vc-dir-unmark + :help "Unmark the current file or all files in the region")) + + (define-key map [mark] + '(menu-item "Mark" vc-dir-mark + :help "Mark the current file or all files in the region")) + + (define-key map [sepopn] '("--")) + (define-key map [qr] + '(menu-item "Query Replace in Files..." vc-dir-query-replace-regexp + :help "Replace a string in the marked files")) + (define-key map [se] + '(menu-item "Search Files..." vc-dir-search + :help "Search a regexp in the marked files")) + (define-key map [ires] + '(menu-item "Isearch Regexp Files..." vc-dir-isearch-regexp + :help "Incremental search a regexp in the marked files")) + (define-key map [ise] + '(menu-item "Isearch Files..." vc-dir-isearch + :help "Incremental search a string in the marked files")) + (define-key map [open-other] + '(menu-item "Open in other window" vc-dir-find-file-other-window + :help "Find the file on the current line, in another window")) + (define-key map [open] + '(menu-item "Open file" vc-dir-find-file + :help "Find the file on the current line")) + (define-key map [sepvcdet] '("--")) + ;; FIXME: This needs a key binding. And maybe a better name + ;; ("Insert" like PCL-CVS uses does not sound that great either)... + (define-key map [ins] + '(menu-item "Show File" vc-dir-show-fileentry + :help "Show a file in the VC status listing even though it might be up to date")) + (define-key map [annotate] + '(menu-item "Annotate" vc-annotate + :help "Display the edit history of the current file using colors")) + (define-key map [diff] + '(menu-item "Compare with Base Version" vc-diff + :help "Compare file set with the base version")) + (define-key map [logo] + '(menu-item "Show Outgoing Log" vc-log-outgoing + :help "Show a log of changes that will be sent with a push operation")) + (define-key map [logi] + '(menu-item "Show Incoming Log" vc-log-incoming + :help "Show a log of changes that will be received with a pull operation")) + (define-key map [log] + '(menu-item "Show History" vc-print-log + :help "List the change log of the current file set in a window")) + (define-key map [rlog] + '(menu-item "Show Top of the Tree History " vc-print-root-log + :help "List the change log for the current tree in a window")) + ;; VC commands. + (define-key map [sepvccmd] '("--")) + (define-key map [update] + '(menu-item "Update to latest version" vc-update + :help "Update the current fileset's files to their tip revisions")) + (define-key map [revert] + '(menu-item "Revert to base version" vc-revert + :help "Revert working copies of the selected fileset to their repository contents.")) + (define-key map [next-action] + ;; FIXME: This really really really needs a better name! + ;; And a key binding too. + '(menu-item "Check In/Out" vc-next-action + :help "Do the next logical version control operation on the current fileset")) + (define-key map [register] + '(menu-item "Register" vc-register + :help "Register file set into the version control system")) + map) + "Menu for VC dir.") + +;; VC backends can use this to add mode-specific menu items to +;; vc-dir-menu-map. +(defun vc-dir-menu-map-filter (orig-binding) + (when (and (symbolp orig-binding) (fboundp orig-binding)) + (setq orig-binding (indirect-function orig-binding))) + (let ((ext-binding + (when (derived-mode-p 'vc-dir-mode) + (vc-call-backend vc-dir-backend 'extra-status-menu)))) + (if (null ext-binding) + orig-binding + (append orig-binding + '("----") + ext-binding)))) + +(defvar vc-dir-mode-map + (let ((map (make-sparse-keymap))) + ;; VC commands + (define-key map "v" 'vc-next-action) ;; C-x v v + (define-key map "=" 'vc-diff) ;; C-x v = + (define-key map "i" 'vc-register) ;; C-x v i + (define-key map "+" 'vc-update) ;; C-x v + + (define-key map "l" 'vc-print-log) ;; C-x v l + ;; More confusing than helpful, probably + ;;(define-key map "R" 'vc-revert) ;; u is taken by vc-dir-unmark. + ;;(define-key map "A" 'vc-annotate) ;; g is taken by revert-buffer + ;; bound by `special-mode'. + ;; Marking. + (define-key map "m" 'vc-dir-mark) + (define-key map "M" 'vc-dir-mark-all-files) + (define-key map "u" 'vc-dir-unmark) + (define-key map "U" 'vc-dir-unmark-all-files) + (define-key map "\C-?" 'vc-dir-unmark-file-up) + (define-key map "\M-\C-?" 'vc-dir-unmark-all-files) + ;; Movement. + (define-key map "n" 'vc-dir-next-line) + (define-key map " " 'vc-dir-next-line) + (define-key map "\t" 'vc-dir-next-directory) + (define-key map "p" 'vc-dir-previous-line) + (define-key map [backtab] 'vc-dir-previous-directory) + ;;; Rebind paragraph-movement commands. + (define-key map "\M-}" 'vc-dir-next-directory) + (define-key map "\M-{" 'vc-dir-previous-directory) + (define-key map [C-down] 'vc-dir-next-directory) + (define-key map [C-up] 'vc-dir-previous-directory) + ;; The remainder. + (define-key map "f" 'vc-dir-find-file) + (define-key map "\C-m" 'vc-dir-find-file) + (define-key map "o" 'vc-dir-find-file-other-window) + (define-key map "\C-c\C-c" 'vc-dir-kill-dir-status-process) + (define-key map [down-mouse-3] 'vc-dir-menu) + (define-key map [mouse-2] 'vc-dir-toggle-mark) + (define-key map [follow-link] 'mouse-face) + (define-key map "x" 'vc-dir-hide-up-to-date) + (define-key map [?\C-k] 'vc-dir-kill-line) + (define-key map "S" 'vc-dir-search) ;; FIXME: Maybe use A like dired? + (define-key map "Q" 'vc-dir-query-replace-regexp) + (define-key map (kbd "M-s a C-s") 'vc-dir-isearch) + (define-key map (kbd "M-s a M-C-s") 'vc-dir-isearch-regexp) + + ;; Hook up the menu. + (define-key map [menu-bar vc-dir-mode] + `(menu-item + ;; VC backends can use this to add mode-specific menu items to + ;; vc-dir-menu-map. + "VC-dir" ,vc-dir-menu-map :filter vc-dir-menu-map-filter)) + map) + "Keymap for directory buffer.") + +(defmacro vc-dir-at-event (event &rest body) + "Evaluate BODY with point located at event-start of EVENT. +If BODY uses EVENT, it should be a variable, + otherwise it will be evaluated twice." + (let ((posn (make-symbol "vc-dir-at-event-posn"))) + `(save-excursion + (unless (equal ,event '(tool-bar)) + (let ((,posn (event-start ,event))) + (set-buffer (window-buffer (posn-window ,posn))) + (goto-char (posn-point ,posn)))) + ,@body))) + +(defun vc-dir-menu (e) + "Popup the VC dir menu." + (interactive "e") + (vc-dir-at-event e (popup-menu vc-dir-menu-map e))) + +(defvar vc-dir-tool-bar-map + (let ((map (make-sparse-keymap))) + (tool-bar-local-item-from-menu '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 diff --cc lisp/vc/vc-dispatcher.el index b6ccae1af1b,00000000000..cb5bd0a2c22 mode 100644,000000..100644 --- a/lisp/vc/vc-dispatcher.el +++ b/lisp/vc/vc-dispatcher.el @@@ -1,696 -1,0 +1,696 @@@ +;;; vc-dispatcher.el -- generic command-dispatcher facility. + - ;; Copyright (C) 2008, 2009, 2010 ++;; Copyright (C) 2008, 2009, 2010, 2011 +;; Free Software Foundation, Inc. + +;; Author: FSF (see below for full credits) +;; Maintainer: Eric S. Raymond +;; 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 . + +;;; Credits: + +;; Designed and implemented by Eric S. Raymond, originally as part of VC mode. +;; Stefan Monnier and Dan Nicolaescu contributed substantial work on the +;; vc-dir front end. + +;;; Commentary: + +;; Goals: +;; +;; There is a class of front-ending problems that Emacs might be used +;; to address that involves selecting sets of files, or possibly +;; directories, and passing the selection set to slave commands. The +;; prototypical example, from which this code is derived, is talking +;; to version-control systems. +;; +;; vc-dispatcher.el is written to decouple the UI issues in such front +;; ends from their application-specific logic. It also provides a +;; service layer for running the slave commands either synchronously +;; or asynchronously and managing the message/error logs from the +;; command runs. +;; +;; Similar UI problems can be expected to come up in applications +;; areas other than VCSes; IDEs and document search are two obvious ones. +;; This mode is intended to ensure that the Emacs interfaces for all such +;; beasts are consistent and carefully designed. But even if nothing +;; but VC ever uses it, getting the layer separation right will be +;; a valuable thing. + +;; Dispatcher's universe: +;; +;; The universe consists of the file tree rooted at the current +;; directory. The dispatcher's upper layer deduces some subset +;; of the file tree from the state of the currently visited buffer +;; and returns that subset, presumably to a client mode. +;; +;; The user may be looking at either of two different views; a buffer +;; visiting a file, or a directory buffer generated by vc-dispatcher. +;; +;; The lower layer of this mode runs commands in subprocesses, either +;; synchronously or asynchronously. Commands may be launched in one +;; of two ways: they may be run immediately, or the calling mode can +;; create a closure associated with a text-entry buffer, to be +;; executed when the user types C-c to ship the buffer contents. In +;; either case the command messages and error (if any) will remain +;; available in a status buffer. + +;; Special behavior of dispatcher directory buffers: +;; +;; In dispatcher directory buffers, facilities to perform basic +;; navigation and selection operations are provided by keymap and menu +;; entries that dispatcher sets up itself, so they'll be uniform +;; across all dispatcher-using client modes. Client modes are +;; expected to append to these to provide mode-specific bindings. +;; +;; The standard map associates a 'state' slot (that the client mode +;; may set) with each directory entry. The dispatcher knows nothing +;; about the semantics of individual states, but mark and unmark commands +;; treat all entries with the same state as the currently selected one as +;; a unit. + +;; The interface: +;; +;; The main interface to the lower level is vc-do-command. This launches a +;; command, synchronously or asynchronously, making the output available +;; in a command log buffer. Two other functions, (vc-start-logentry) and +;; (vc-finish-logentry), allow you to associate a command closure with an +;; annotation buffer so that when the user confirms the comment the closure +;; is run (with the comment as part of its context). +;; +;; The interface to the upper level has the two main entry points (vc-dir) +;; and (vc-dispatcher-selection-set) and a couple of convenience functions. +;; (vc-dir) sets up a dispatcher browsing buffer; (vc-dispatcher-selection-set) +;; returns a selection set of files, either the marked files in a browsing +;; buffer or the singleton set consisting of the file visited by the current +;; buffer (when that is appropriate). It also does what is needed to ensure +;; that on-disk files and the contents of their visiting Emacs buffers +;; coincide. +;; +;; When the client mode adds a local vc-mode-line-hook to a buffer, it +;; will be called with the buffer file name as argument whenever the +;; dispatcher resynchs the buffer. + +;; To do: +;; +;; - log buffers need font-locking. +;; + +;; General customization +(defcustom vc-logentry-check-hook nil + "Normal hook run by `vc-finish-logentry'. +Use this to impose your own rules on the entry in addition to any the +dispatcher client mode imposes itself." + :type 'hook + :group 'vc) + +(defcustom vc-delete-logbuf-window t + "If non-nil, delete the log buffer and window after each logical action. +If nil, bury that buffer instead. +This is most useful if you have multiple windows on a frame and would like to +preserve the setting." + :type 'boolean + :group 'vc) + +(defcustom vc-command-messages nil + "If non-nil, display run messages from back-end commands." + :type 'boolean + :group 'vc) + +(defcustom vc-suppress-confirm nil + "If non-nil, treat user as expert; suppress yes-no prompts on some things." + :type 'boolean + :group 'vc) + +;; Variables the user doesn't need to know about. + +(defvar vc-log-operation nil) +(defvar vc-log-after-operation-hook nil) +(defvar vc-log-fileset) + +;; In a log entry buffer, this is a local variable +;; that points to the buffer for which it was made +;; (either a file, or a directory buffer). +(defvar vc-parent-buffer nil) +(put 'vc-parent-buffer 'permanent-local t) +(defvar vc-parent-buffer-name nil) +(put 'vc-parent-buffer-name 'permanent-local t) + +;; Common command execution logic + +(defun vc-process-filter (p s) + "An alternative output filter for async process P. +One difference with the default filter is that this inserts S after markers. +Another is that undo information is not kept." + (let ((buffer (process-buffer p))) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (save-excursion + (let ((buffer-undo-list t) + (inhibit-read-only t)) + (goto-char (process-mark p)) + (insert s) + (set-marker (process-mark p) (point)))))))) + +(defun vc-setup-buffer (buf) + "Prepare BUF for executing a slave command and make it current." + (let ((camefrom (current-buffer)) + (olddir default-directory)) + (set-buffer (get-buffer-create buf)) + (kill-all-local-variables) + (set (make-local-variable 'vc-parent-buffer) camefrom) + (set (make-local-variable 'vc-parent-buffer-name) + (concat " from " (buffer-name camefrom))) + (setq default-directory olddir) + (let ((buffer-undo-list t) + (inhibit-read-only t)) + (erase-buffer)))) + +(defvar vc-sentinel-movepoint) ;Dynamically scoped. + +(defun vc-process-sentinel (p s) + (let ((previous (process-get p 'vc-previous-sentinel)) + (buf (process-buffer p))) + ;; Impatient users sometime kill "slow" buffers; check liveness + ;; to avoid "error in process sentinel: Selecting deleted buffer". + (when (buffer-live-p buf) + (when previous (funcall previous p s)) + (with-current-buffer buf + (setq mode-line-process + (let ((status (process-status p))) + ;; Leave mode-line uncluttered, normally. + (unless (eq 'exit status) + (format " (%s)" status)))) + (let (vc-sentinel-movepoint) + ;; Normally, we want async code such as sentinels to not move point. + (save-excursion + (goto-char (process-mark p)) + (let ((cmds (process-get p 'vc-sentinel-commands))) + (process-put p 'vc-sentinel-commands nil) + (dolist (cmd cmds) + ;; Each sentinel may move point and the next one should be run + ;; at that new point. We could get the same result by having + ;; each sentinel read&set process-mark, but since `cmd' needs + ;; to work both for async and sync processes, this would be + ;; difficult to achieve. + (vc-exec-after cmd)))) + ;; But sometimes the sentinels really want to move point. + (when vc-sentinel-movepoint + (let ((win (get-buffer-window (current-buffer) 0))) + (if (not win) + (goto-char vc-sentinel-movepoint) + (with-selected-window win + (goto-char vc-sentinel-movepoint)))))))))) + +(defun vc-set-mode-line-busy-indicator () + (setq mode-line-process + (concat " " (propertize "[waiting...]" + 'face 'mode-line-emphasis + 'help-echo + "A command is in progress in this buffer")))) + +(defun vc-exec-after (code) + "Eval CODE when the current buffer's process is done. +If the current buffer has no process, just evaluate CODE. +Else, add CODE to the process' sentinel." + (let ((proc (get-buffer-process (current-buffer)))) + (cond + ;; If there's no background process, just execute the code. + ;; We used to explicitly call delete-process on exited processes, + ;; but this led to timing problems causing process output to be + ;; lost. Terminated processes get deleted automatically + ;; anyway. -- cyd + ((or (null proc) (eq (process-status proc) 'exit)) + ;; Make sure we've read the process's output before going further. + (when proc (accept-process-output proc)) + (eval code)) + ;; If a process is running, add CODE to the sentinel + ((eq (process-status proc) 'run) + (vc-set-mode-line-busy-indicator) + (let ((previous (process-sentinel proc))) + (unless (eq previous 'vc-process-sentinel) + (process-put proc 'vc-previous-sentinel previous)) + (set-process-sentinel proc 'vc-process-sentinel)) + (process-put proc 'vc-sentinel-commands + ;; We keep the code fragments in the order given + ;; so that vc-diff-finish's message shows up in + ;; the presence of non-nil vc-command-messages. + (append (process-get proc 'vc-sentinel-commands) + (list code)))) + (t (error "Unexpected process state")))) + nil) + +(defvar vc-post-command-functions nil + "Hook run at the end of `vc-do-command'. +Each function is called inside the buffer in which the command was run +and is passed 3 arguments: the COMMAND, the FILES and the FLAGS.") + +(defvar w32-quote-process-args) + +(defun vc-delistify (filelist) + "Smash a FILELIST into a file list string suitable for info messages." + ;; FIXME what about file names with spaces? + (if (not filelist) "." (mapconcat 'identity filelist " "))) + +;;;###autoload +(defun vc-do-command (buffer okstatus command file-or-list &rest flags) + "Execute a slave command, notifying user and checking for errors. +Output from COMMAND goes to BUFFER, or the current buffer if +BUFFER is t. If the destination buffer is not already current, +set it up properly and erase it. The command is considered +successful if its exit status does not exceed OKSTATUS (if +OKSTATUS is nil, that means to ignore error status, if it is +`async', that means not to wait for termination of the +subprocess; if it is t it means to ignore all execution errors). +FILE-OR-LIST is the name of a working file; it may be a list of +files or be nil (to execute commands that don't expect a file +name or set of files). If an optional list of FLAGS is present, +that is inserted into the command line before the filename. +Return the return value of the slave command in the synchronous +case, and the process object in the asynchronous case." + ;; FIXME: file-relative-name can return a bogus result because + ;; it doesn't look at the actual file-system to see if symlinks + ;; come into play. + (let* ((files + (mapcar (lambda (f) (file-relative-name (expand-file-name f))) + (if (listp file-or-list) file-or-list (list file-or-list)))) + (full-command + ;; What we're doing here is preparing a version of the command + ;; for display in a debug-progress message. If it's fewer than + ;; 20 characters display the entire command (without trailing + ;; newline). Otherwise display the first 20 followed by an ellipsis. + (concat (if (string= (substring command -1) "\n") + (substring command 0 -1) + command) + " " + (vc-delistify (mapcar (lambda (s) (if (> (length s) 20) (concat (substring s 0 2) "...") s)) flags)) + " " (vc-delistify files)))) + (save-current-buffer + (unless (or (eq buffer t) + (and (stringp buffer) + (string= (buffer-name) buffer)) + (eq buffer (current-buffer))) + (vc-setup-buffer buffer)) + ;; If there's some previous async process still running, just kill it. + (let ((oldproc (get-buffer-process (current-buffer)))) + ;; If we wanted to wait for oldproc to finish before doing + ;; something, we'd have used vc-eval-after. + ;; Use `delete-process' rather than `kill-process' because we don't + ;; want any of its output to appear from now on. + (when oldproc (delete-process oldproc))) + (let ((squeezed (remq nil flags)) + (inhibit-read-only t) + (status 0)) + (when files + (setq squeezed (nconc squeezed files))) + (let (;; Since some functions need to parse the output + ;; from external commands, set LC_MESSAGES to C. + (process-environment (cons "LC_MESSAGES=C" process-environment)) + (w32-quote-process-args t)) + (if (eq okstatus 'async) + ;; Run asynchronously. + (let ((proc + (let ((process-connection-type nil)) + (apply 'start-file-process command (current-buffer) + command squeezed)))) + (when vc-command-messages + (message "Running %s in background..." full-command)) + ;;(set-process-sentinel proc (lambda (p msg) (delete-process p))) + (set-process-filter proc 'vc-process-filter) + (setq status proc) + (when vc-command-messages + (vc-exec-after + `(message "Running %s in background... done" ',full-command)))) + ;; Run synchronously + (when vc-command-messages + (message "Running %s in foreground..." full-command)) + (let ((buffer-undo-list t)) + (setq status (apply 'process-file command nil t nil squeezed))) + (when (and (not (eq t okstatus)) + (or (not (integerp status)) + (and okstatus (< okstatus status)))) + (unless (eq ?\s (aref (buffer-name (current-buffer)) 0)) + (pop-to-buffer (current-buffer)) + (goto-char (point-min)) + (shrink-window-if-larger-than-buffer)) + (error "Running %s...FAILED (%s)" full-command + (if (integerp status) (format "status %d" status) status))) + (when vc-command-messages + (message "Running %s...OK = %d" full-command status)))) + (vc-exec-after + `(run-hook-with-args 'vc-post-command-functions + ',command ',file-or-list ',flags)) + status)))) + +;; These functions are used to ensure that the view the user sees is up to date +;; even if the dispatcher client mode has messed with file contents (as in, +;; for example, VCS keyword expansion). + +(declare-function view-mode-exit "view" (&optional return-to-alist exit-action all-win)) + +(defun vc-position-context (posn) + "Save a bit of the text around POSN in the current buffer. +Used to help us find the corresponding position again later +if markers are destroyed or corrupted." + ;; A lot of this was shamelessly lifted from Sebastian Kremer's + ;; rcs.el mode. + (list posn + (buffer-size) + (buffer-substring posn + (min (point-max) (+ posn 100))))) + +(defun vc-find-position-by-context (context) + "Return the position of CONTEXT in the current buffer. +If CONTEXT cannot be found, return nil." + (let ((context-string (nth 2 context))) + (if (equal "" context-string) + (point-max) + (save-excursion + (let ((diff (- (nth 1 context) (buffer-size)))) + (when (< diff 0) (setq diff (- diff))) + (goto-char (nth 0 context)) + (if (or (search-forward context-string nil t) + ;; Can't use search-backward since the match may continue + ;; after point. + (progn (goto-char (- (point) diff (length context-string))) + ;; goto-char doesn't signal an error at + ;; beginning of buffer like backward-char would + (search-forward context-string nil t))) + ;; to beginning of OSTRING + (- (point) (length context-string)))))))) + +(defun vc-context-matches-p (posn context) + "Return t if POSN matches CONTEXT, nil otherwise." + (let* ((context-string (nth 2 context)) + (len (length context-string)) + (end (+ posn len))) + (if (> end (1+ (buffer-size))) + nil + (string= context-string (buffer-substring posn end))))) + +(defun vc-buffer-context () + "Return a list (POINT-CONTEXT MARK-CONTEXT REPARSE). +Used by `vc-restore-buffer-context' to later restore the context." + (let ((point-context (vc-position-context (point))) + ;; Use mark-marker to avoid confusion in transient-mark-mode. + (mark-context (when (eq (marker-buffer (mark-marker)) (current-buffer)) + (vc-position-context (mark-marker)))) + ;; Make the right thing happen in transient-mark-mode. + (mark-active nil)) + (list point-context mark-context nil))) + +(defun vc-restore-buffer-context (context) + "Restore point/mark, and reparse any affected compilation buffers. +CONTEXT is that which `vc-buffer-context' returns." + (let ((point-context (nth 0 context)) + (mark-context (nth 1 context))) + ;; if necessary, restore point and mark + (if (not (vc-context-matches-p (point) point-context)) + (let ((new-point (vc-find-position-by-context point-context))) + (when new-point (goto-char new-point)))) + (and mark-active + mark-context + (not (vc-context-matches-p (mark) mark-context)) + (let ((new-mark (vc-find-position-by-context mark-context))) + (when new-mark (set-mark new-mark)))))) + +(defun vc-revert-buffer-internal (&optional arg no-confirm) + "Revert buffer, keeping point and mark where user expects them. +Try to be clever in the face of changes due to expanded version-control +key words. This is important for typeahead to work as expected. +ARG and NO-CONFIRM are passed on to `revert-buffer'." + (interactive "P") + (widen) + (let ((context (vc-buffer-context))) + ;; Use save-excursion here, because it may be able to restore point + ;; and mark properly even in cases where vc-restore-buffer-context + ;; would fail. However, save-excursion might also get it wrong -- + ;; in this case, vc-restore-buffer-context gives it a second try. + (save-excursion + ;; t means don't call normal-mode; + ;; that's to preserve various minor modes. + (revert-buffer arg no-confirm t)) + (vc-restore-buffer-context context))) + +(defvar vc-mode-line-hook nil) +(make-variable-buffer-local 'vc-mode-line-hook) +(put 'vc-mode-line-hook 'permanent-local t) + +(defun vc-resynch-window (file &optional keep noquery reset-vc-info) + "If FILE is in the current buffer, either revert or unvisit it. +The choice between revert (to see expanded keywords) and unvisit +depends on KEEP. NOQUERY if non-nil inhibits confirmation for +reverting. NOQUERY should be t *only* if it is known the only +difference between the buffer and the file is due to +modifications by the dispatcher client code, rather than user +editing!" + (and (string= buffer-file-name file) + (if keep + (when (file-exists-p file) + (when reset-vc-info + (vc-file-clearprops file)) + (vc-revert-buffer-internal t noquery) + + ;; VC operations might toggle the read-only state. In + ;; that case we need to adjust the `view-mode' status + ;; when `view-read-only' is non-nil. + (and view-read-only + (if (file-writable-p file) + (and view-mode + (let ((view-old-buffer-read-only nil)) + (view-mode-exit))) + (and (not view-mode) + (not (eq (get major-mode 'mode-class) 'special)) + (view-mode-enter)))) + + ;; FIXME: Why use a hook? Why pass it buffer-file-name? + (run-hook-with-args 'vc-mode-line-hook buffer-file-name)) + (kill-buffer (current-buffer))))) + +(declare-function vc-dir-resynch-file "vc-dir" (&optional fname)) +(declare-function vc-string-prefix-p "vc" (prefix string)) + +(defun vc-resynch-buffers-in-directory (directory &optional keep noquery reset-vc-info) + "Resync all buffers that visit files in DIRECTORY." + (dolist (buffer (buffer-list)) + (let ((fname (buffer-file-name buffer))) + (when (and fname (vc-string-prefix-p directory fname)) + (with-current-buffer buffer + (vc-resynch-buffer fname keep noquery reset-vc-info)))))) + +(defun vc-resynch-buffer (file &optional keep noquery reset-vc-info) + "If FILE is currently visited, resynch its buffer." + (if (string= buffer-file-name file) + (vc-resynch-window file keep noquery reset-vc-info) + (if (file-directory-p file) + (vc-resynch-buffers-in-directory file keep noquery reset-vc-info) + (let ((buffer (get-file-buffer file))) + (when buffer + (with-current-buffer buffer + (vc-resynch-window file keep noquery reset-vc-info)))))) + ;; Try to avoid unnecessary work, a *vc-dir* buffer is only present + ;; if this is true. + (when vc-dir-buffers + (vc-dir-resynch-file file))) + +(defun vc-buffer-sync (&optional not-urgent) + "Make sure the current buffer and its working file are in sync. +NOT-URGENT means it is ok to continue if the user says not to save." + (when (buffer-modified-p) + (if (or vc-suppress-confirm + (y-or-n-p (format "Buffer %s modified; save it? " (buffer-name)))) + (save-buffer) + (unless not-urgent + (error "Aborted"))))) + +;; Command closures + +;; Set up key bindings for use while editing log messages + +(defun vc-log-edit (fileset mode) + "Set up `log-edit' for use on FILE." + (setq default-directory + (with-current-buffer vc-parent-buffer default-directory)) + (log-edit 'vc-finish-logentry + nil + `((log-edit-listfun . (lambda () + ;; FIXME: Should expand the list + ;; for directories. + (mapcar 'file-relative-name + ',fileset))) + (log-edit-diff-function . (lambda () (vc-diff nil)))) + nil + mode) + (set (make-local-variable 'vc-log-fileset) fileset) + (set-buffer-modified-p nil) + (setq buffer-file-name nil)) + +(defun vc-start-logentry (files comment initial-contents msg logbuf mode action &optional after-hook) + "Accept a comment for an operation on FILES. +If COMMENT is nil, pop up a LOGBUF buffer, emit MSG, and set the +action on close to ACTION. If COMMENT is a string and +INITIAL-CONTENTS is non-nil, then COMMENT is used as the initial +contents of the log entry buffer. If COMMENT is a string and +INITIAL-CONTENTS is nil, do action immediately as if the user had +entered COMMENT. If COMMENT is t, also do action immediately with an +empty comment. Remember the file's buffer in `vc-parent-buffer' +\(current one if no file). Puts the log-entry buffer in major-mode +MODE, defaulting to `log-edit-mode' if MODE is nil. +AFTER-HOOK specifies the local value for `vc-log-after-operation-hook'." + (let ((parent + (if (vc-dispatcher-browsing) + ;; If we are called from a directory browser, the parent buffer is + ;; the current buffer. + (current-buffer) + (if (and files (equal (length files) 1)) + (get-file-buffer (car files)) + (current-buffer))))) + (if (and comment (not initial-contents)) + (set-buffer (get-buffer-create logbuf)) + (pop-to-buffer (get-buffer-create logbuf))) + (set (make-local-variable 'vc-parent-buffer) parent) + (set (make-local-variable 'vc-parent-buffer-name) + (concat " from " (buffer-name vc-parent-buffer))) + (vc-log-edit files mode) + (make-local-variable 'vc-log-after-operation-hook) + (when after-hook + (setq vc-log-after-operation-hook after-hook)) + (setq vc-log-operation action) + (when comment + (erase-buffer) + (when (stringp comment) (insert comment))) + (if (or (not comment) initial-contents) + (message "%s Type C-c C-c when done" msg) + (vc-finish-logentry (eq comment t))))) + +(declare-function vc-dir-move-to-goal-column "vc-dir" ()) +;; vc-finish-logentry is typically called from a log-edit buffer (see +;; vc-start-logentry). +(defun vc-finish-logentry (&optional nocomment) + "Complete the operation implied by the current log entry. +Use the contents of the current buffer as a check-in or registration +comment. If the optional arg NOCOMMENT is non-nil, then don't check +the buffer contents as a comment." + (interactive) + ;; Check and record the comment, if any. + (unless nocomment + (run-hooks 'vc-logentry-check-hook)) + ;; Sync parent buffer in case the user modified it while editing the comment. + ;; But not if it is a vc-dir buffer. + (with-current-buffer vc-parent-buffer + (or (vc-dispatcher-browsing) (vc-buffer-sync))) + (unless vc-log-operation + (error "No log operation is pending")) + + ;; save the parameters held in buffer-local variables + (let ((logbuf (current-buffer)) + (log-operation vc-log-operation) + ;; FIXME: When coming from VC-Dir, we should check that the + ;; set of selected files is still equal to vc-log-fileset, + ;; to avoid surprises. + (log-fileset vc-log-fileset) + (log-entry (buffer-string)) + (after-hook vc-log-after-operation-hook)) + (pop-to-buffer vc-parent-buffer) + ;; OK, do it to it + (save-excursion + (funcall log-operation + log-fileset + log-entry)) + ;; Remove checkin window (after the checkin so that if that fails + ;; we don't zap the log buffer and the typing therein). + ;; -- IMO this should be replaced with quit-window + (cond ((and logbuf vc-delete-logbuf-window) + (delete-windows-on logbuf (selected-frame)) + ;; Kill buffer and delete any other dedicated windows/frames. + (kill-buffer logbuf)) + (logbuf + (with-selected-window (or (get-buffer-window logbuf 0) + (selected-window)) + (with-current-buffer logbuf + (bury-buffer))))) + ;; Now make sure we see the expanded headers + (when log-fileset + (mapc + (lambda (file) (vc-resynch-buffer file vc-keep-workfiles t)) + log-fileset)) + (when (vc-dispatcher-browsing) + (vc-dir-move-to-goal-column)) + (run-hooks after-hook 'vc-finish-logentry-hook))) + +(defun vc-dispatcher-browsing () + "Are we in a directory browser buffer?" + (derived-mode-p 'vc-dir-mode)) + +;; These are unused. +;; (defun vc-dispatcher-in-fileset-p (fileset) +;; (let ((member nil)) +;; (while (and (not member) fileset) +;; (let ((elem (pop fileset))) +;; (if (if (file-directory-p elem) +;; (eq t (compare-strings buffer-file-name nil (length elem) +;; elem nil nil)) +;; (eq (current-buffer) (get-file-buffer elem))) +;; (setq member t)))) +;; member)) + +;; (defun vc-dispatcher-selection-set (&optional observer) +;; "Deduce a set of files to which to apply an operation. Return a cons +;; cell (SELECTION . FILESET), where SELECTION is what the user chose +;; and FILES is the flist with any directories replaced by the listed files +;; within them. + +;; If we're in a directory display, the fileset is the list of marked files (if +;; there is one) else the file on the current line. If not in a directory +;; display, but the current buffer visits a file, the fileset is a singleton +;; containing that file. Otherwise, throw an error." +;; (let ((selection +;; (cond +;; ;; Browsing with vc-dir +;; ((vc-dispatcher-browsing) +;; ;; If no files are marked, temporarily mark current file +;; ;; and choose on that basis (so we get subordinate files) +;; (if (not (vc-dir-marked-files)) +;; (prog2 +;; (vc-dir-mark-file) +;; (cons (vc-dir-marked-files) (vc-dir-marked-only-files)) +;; (vc-dir-unmark-all-files t)) +;; (cons (vc-dir-marked-files) (vc-dir-marked-only-files)))) +;; ;; Visiting an eligible file +;; ((buffer-file-name) +;; (cons (list buffer-file-name) (list buffer-file-name))) +;; ;; No eligible file -- if there's a parent buffer, deduce from there +;; ((and vc-parent-buffer (or (buffer-file-name vc-parent-buffer) +;; (with-current-buffer vc-parent-buffer +;; (vc-dispatcher-browsing)))) +;; (with-current-buffer vc-parent-buffer +;; (vc-dispatcher-selection-set))) +;; ;; No good set here, throw error +;; (t (error "No fileset is available here"))))) +;; ;; We assume, in order to avoid unpleasant surprises to the user, +;; ;; that a fileset is not in good shape to be handed to the user if the +;; ;; buffers visiting the fileset don't match the on-disk contents. +;; (unless observer +;; (save-some-buffers +;; nil (lambda () (vc-dispatcher-in-fileset-p (cdr selection))))) +;; selection)) + +(provide 'vc-dispatcher) + +;; arch-tag: 7d08b17f-5470-4799-914b-bfb9fcf6a246 +;;; vc-dispatcher.el ends here diff --cc lisp/vc/vc-git.el index 48a86454f74,00000000000..6d3a6991354 mode 100644,000000..100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@@ -1,1040 -1,0 +1,1040 @@@ +;;; vc-git.el --- VC backend for the git version control system + - ;; Copyright (C) 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ++;; Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. + +;; Author: Alexandre Julliard +;; 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 . + +;;; 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 + ("^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 \\\\[compile-goto-error] \ +in the grep output buffer, +to go to the lines where grep found matches. + +This command shares argument histories with \\[rgrep] and \\[grep]." + (interactive + (progn + (grep-compute-defaults) + (cond + ((equal current-prefix-arg '(16)) + (list (read-from-minibuffer "Run: " "git grep" + nil nil 'grep-history) + nil)) + (t (let* ((regexp (grep-read-regexp)) + (files (grep-read-files regexp)) + (dir (read-directory-name "In directory: " + nil default-directory t))) + (list regexp files dir)))))) + (require 'grep) + (when (and (stringp regexp) (> (length regexp) 0)) + (let ((command regexp)) + (if (null files) + (if (string= command "git grep") + (setq command nil)) + (setq dir (file-name-as-directory (expand-file-name dir))) + (setq command + (grep-expand-template "git grep -n -e -- " regexp files)) + (when command + (if (equal current-prefix-arg '(4)) + (setq command + (read-from-minibuffer "Confirm: " + command nil nil 'grep-history)) + (add-to-history 'grep-history command)))) + (when command + (let ((default-directory dir) + (compilation-environment '("PAGER="))) + ;; Setting process-setup-function makes exit-message-function work + ;; even when async processes aren't supported. + (compilation-start command 'grep-mode)) + (if (eq next-error-last-buffer (current-buffer)) + (setq default-directory dir)))))) + +(defun vc-git-stash (name) + "Create a stash." + (interactive "sStash name: ") + (let ((root (vc-git-root default-directory))) + (when root + (vc-git--call nil "stash" "save" name) + (vc-resynch-buffer root t t)))) + +(defun vc-git-stash-show (name) + "Show the contents of stash NAME." + (interactive "sStash name: ") + (vc-setup-buffer "*vc-git-stash*") + (vc-git-command "*vc-git-stash*" 'async nil "stash" "show" "-p" name) + (set-buffer "*vc-git-stash*") + (diff-mode) + (setq buffer-read-only t) + (pop-to-buffer (current-buffer))) + +(defun vc-git-stash-apply (name) + "Apply stash NAME." + (interactive "sApply stash: ") + (vc-git-command "*vc-git-stash*" 0 nil "stash" "apply" "-q" name) + (vc-resynch-buffer (vc-git-root default-directory) t t)) + +(defun vc-git-stash-pop (name) + "Pop stash NAME." + (interactive "sPop stash: ") + (vc-git-command "*vc-git-stash*" 0 nil "stash" "pop" "-q" name) + (vc-resynch-buffer (vc-git-root default-directory) t t)) + +(defun vc-git-stash-snapshot () + "Create a stash with the current tree state." + (interactive) + (vc-git--call nil "stash" "save" + (let ((ct (current-time))) + (concat + (format-time-string "Snapshot on %Y-%m-%d" ct) + (format-time-string " at %H:%M" ct)))) + (vc-git-command "*vc-git-stash*" 0 nil "stash" "apply" "-q" "stash@{0}") + (vc-resynch-buffer (vc-git-root default-directory) t t)) + +(defun vc-git-stash-list () + (delete + "" + (split-string + (replace-regexp-in-string + "^stash@" " " (vc-git--run-command-string nil "stash" "list")) + "\n"))) + +(defun vc-git-stash-get-at-point (point) + (save-excursion + (goto-char point) + (beginning-of-line) + (if (looking-at "^ +\\({[0-9]+}\\):") + (match-string 1) + (error "Cannot find stash at point")))) + +(defun vc-git-stash-delete-at-point () + (interactive) + (let ((stash (vc-git-stash-get-at-point (point)))) + (when (y-or-n-p (format "Remove stash %s ? " stash)) + (vc-git--run-command-string nil "stash" "drop" (format "stash@%s" stash)) + (vc-dir-refresh)))) + +(defun vc-git-stash-show-at-point () + (interactive) + (vc-git-stash-show (format "stash@%s" (vc-git-stash-get-at-point (point))))) + +(defun vc-git-stash-apply-at-point () + (interactive) + (vc-git-stash-apply (format "stash@%s" (vc-git-stash-get-at-point (point))))) + +(defun vc-git-stash-pop-at-point () + (interactive) + (vc-git-stash-pop (format "stash@%s" (vc-git-stash-get-at-point (point))))) + +(defun vc-git-stash-menu (e) + (interactive "e") + (vc-dir-at-event e (popup-menu vc-git-stash-menu-map e))) + + +;;; Internal commands + +(defun vc-git-command (buffer okstatus file-or-list &rest flags) + "A wrapper around `vc-do-command' for use in vc-git.el. +The difference to vc-do-command is that this function always invokes `git'." + (apply 'vc-do-command (or buffer "*vc*") okstatus "git" file-or-list flags)) + +(defun vc-git--empty-db-p () + "Check if the git db is empty (no commit done yet)." + (let (process-file-side-effects) + (not (eq 0 (vc-git--call nil "rev-parse" "--verify" "HEAD"))))) + +(defun vc-git--call (buffer command &rest args) + ;; We don't need to care the arguments. If there is a file name, it + ;; is always a relative one. This works also for remote + ;; directories. + (apply 'process-file "git" nil buffer nil command args)) + +(defun vc-git--out-ok (command &rest args) + (zerop (apply 'vc-git--call '(t nil) command args))) + +(defun vc-git--run-command-string (file &rest args) + "Run a git command on FILE and return its output as string. +FILE can be nil." + (let* ((ok t) + (str (with-output-to-string + (with-current-buffer standard-output + (unless (apply 'vc-git--out-ok + (if file + (append args (list (file-relative-name + file))) + args)) + (setq ok nil)))))) + (and ok str))) + +(defun vc-git-symbolic-commit (commit) + "Translate COMMIT string into symbolic form. +Returns nil if not possible." + (and commit + (let ((name (with-temp-buffer + (and + (vc-git--out-ok "name-rev" "--name-only" commit) + (goto-char (point-min)) + (= (forward-line 2) 1) + (bolp) + (buffer-substring-no-properties (point-min) + (1- (point-max))))))) + (and name (not (string= name "undefined")) name)))) + +(provide 'vc-git) + +;; arch-tag: bd10664a-0e5b-48f5-a877-6c17b135be12 +;;; vc-git.el ends here diff --cc lisp/vc/vc-hg.el index 2a2879aadb8,00000000000..62deb5b0507 mode 100644,000000..100644 --- a/lisp/vc/vc-hg.el +++ b/lisp/vc/vc-hg.el @@@ -1,639 -1,0 +1,639 @@@ +;;; vc-hg.el --- VC backend for the mercurial version control system + - ;; Copyright (C) 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ++;; 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 . + +;;; 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) + +;;; 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 + ("^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 diff --cc lisp/vc/vc-hooks.el index 37426eb25f2,00000000000..38bc121e709 mode 100644,000000..100644 --- a/lisp/vc/vc-hooks.el +++ b/lisp/vc/vc-hooks.el @@@ -1,1056 -1,0 +1,1056 @@@ +;;; 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 ++;; 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 +;; 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 . + +;;; 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)) + + +;; We keep properties on each symbol naming a backend as follows: +;; * `vc-functions': an alist mapping vc-FUNCTION to vc-BACKEND-FUNCTION. + +(defun vc-make-backend-sym (backend sym) + "Return BACKEND-specific version of VC symbol SYM." + (intern (concat "vc-" (downcase (symbol-name backend)) + "-" (symbol-name sym)))) + +(defun vc-find-backend-function (backend fun) + "Return BACKEND-specific implementation of FUN. +If there is no such implementation, return the default implementation; +if that doesn't exist either, return nil." + (let ((f (vc-make-backend-sym backend fun))) + (if (fboundp f) f + ;; Load vc-BACKEND.el if needed. + (require (intern (concat "vc-" (downcase (symbol-name backend))))) + (if (fboundp f) f + (let ((def (vc-make-backend-sym 'default fun))) + (if (fboundp def) (cons def backend) nil)))))) + +(defun vc-call-backend (backend function-name &rest args) + "Call for BACKEND the implementation of FUNCTION-NAME with the given ARGS. +Calls + + (apply 'vc-BACKEND-FUN ARGS) + +if vc-BACKEND-FUN exists (after trying to find it in vc-BACKEND.el) +and else calls + + (apply 'vc-default-FUN BACKEND ARGS) + +It is usually called via the `vc-call' macro." + (let ((f (assoc function-name (get backend 'vc-functions)))) + (if f (setq f (cdr f)) + (setq f (vc-find-backend-function backend function-name)) + (push (cons function-name f) (get backend 'vc-functions))) + (cond + ((null f) + (error "Sorry, %s is not implemented for %s" function-name backend)) + ((consp f) (apply (car f) (cdr f) args)) + (t (apply f args))))) + +(defmacro vc-call (fun file &rest args) + "A convenience macro for calling VC backend functions. +Functions called by this macro must accept FILE as the first argument. +ARGS specifies any additional arguments. FUN should be unquoted. +BEWARE!! FILE is evaluated twice!!" + `(vc-call-backend (vc-backend ,file) ',fun ,file ,@args)) + +(defsubst vc-parse-buffer (pattern i) + "Find PATTERN in the current buffer and return its Ith submatch." + (goto-char (point-min)) + (if (re-search-forward pattern nil t) + (match-string i))) + +(defun vc-insert-file (file &optional limit blocksize) + "Insert the contents of FILE into the current buffer. + +Optional argument LIMIT is a regexp. If present, the file is inserted +in chunks of size BLOCKSIZE (default 8 kByte), until the first +occurrence of LIMIT is found. Anything from the start of that occurrence +to the end of the buffer is then deleted. The function returns +non-nil if FILE exists and its contents were successfully inserted." + (erase-buffer) + (when (file-exists-p file) + (if (not limit) + (insert-file-contents file) + (unless blocksize (setq blocksize 8192)) + (let ((filepos 0)) + (while + (and (< 0 (cadr (insert-file-contents + file nil filepos (incf filepos blocksize)))) + (progn (beginning-of-line) + (let ((pos (re-search-forward limit nil 'move))) + (when pos (delete-region (match-beginning 0) + (point-max))) + (not pos))))))) + (set-buffer-modified-p nil) + t)) + +(defun vc-find-root (file witness) + "Find the root of a checked out project. +The function walks up the directory tree from FILE looking for WITNESS. +If WITNESS if not found, return nil, otherwise return the root." + (let ((locate-dominating-stop-dir-regexp + (or vc-ignore-dir-regexp locate-dominating-stop-dir-regexp))) + (locate-dominating-file file witness))) + +;; Access functions to file properties +;; (Properties should be _set_ using vc-file-setprop, but +;; _retrieved_ only through these functions, which decide +;; if the property is already known or not. A property should +;; only be retrieved by vc-file-getprop if there is no +;; access function.) + +;; properties indicating the backend being used for FILE + +(defun vc-registered (file) + "Return non-nil if FILE is registered in a version control system. + +This function performs the check each time it is called. To rely +on the result of a previous call, use `vc-backend' instead. If the +file was previously registered under a certain backend, then that +backend is tried first." + (let (handler) + (cond + ((and (file-name-directory file) + (string-match vc-ignore-dir-regexp (file-name-directory file))) + nil) + ((and (boundp 'file-name-handler-alist) + (setq handler (find-file-name-handler file 'vc-registered))) + ;; handler should set vc-backend and return t if registered + (funcall handler 'vc-registered file)) + (t + ;; There is no file name handler. + ;; Try vc-BACKEND-registered for each handled BACKEND. + (catch 'found + (let ((backend (vc-file-getprop file 'vc-backend))) + (mapc + (lambda (b) + (and (vc-call-backend b 'registered file) + (vc-file-setprop file 'vc-backend b) + (throw 'found t))) + (if (or (not backend) (eq backend 'none)) + vc-handled-backends + (cons backend vc-handled-backends)))) + ;; File is not registered. + (vc-file-setprop file 'vc-backend 'none) + nil))))) + +(defun vc-backend (file-or-list) + "Return the version control type of FILE-OR-LIST, nil if it's not registered. +If the argument is a list, the files must all have the same back end." + ;; `file' can be nil in several places (typically due to the use of + ;; code like (vc-backend buffer-file-name)). + (cond ((stringp file-or-list) + (let ((property (vc-file-getprop file-or-list 'vc-backend))) + ;; Note that internally, Emacs remembers unregistered + ;; files by setting the property to `none'. + (cond ((eq property 'none) nil) + (property) + ;; vc-registered sets the vc-backend property + (t (if (vc-registered file-or-list) + (vc-file-getprop file-or-list 'vc-backend) + nil))))) + ((and file-or-list (listp file-or-list)) + (vc-backend (car file-or-list))) + (t + nil))) + + +(defun vc-backend-subdirectory-name (file) + "Return where the repository for the current directory is kept." + (symbol-name (vc-backend file))) + +(defun vc-name (file) + "Return the master name of FILE. +If the file is not registered, or the master name is not known, return nil." + ;; TODO: This should ultimately become obsolete, at least up here + ;; in vc-hooks. + (or (vc-file-getprop file 'vc-name) + ;; force computation of the property by calling + ;; vc-BACKEND-registered explicitly + (let ((backend (vc-backend file))) + (if (and backend + (vc-call-backend backend 'registered file)) + (vc-file-getprop file 'vc-name))))) + +(defun vc-checkout-model (backend files) + "Indicate how FILES are checked out. + +If FILES are not registered, this function always returns nil. +For registered files, the possible values are: + + 'implicit FILES are always writable, and checked out `implicitly' + when the user saves the first changes to the file. + + 'locking FILES are read-only if up-to-date; user must type + \\[vc-next-action] before editing. Strict locking + is assumed. + + 'announce FILES are read-only if up-to-date; user must type + \\[vc-next-action] before editing. But other users + may be editing at the same time." + (vc-call-backend backend 'checkout-model files)) + +(defun vc-user-login-name (file) + "Return the name under which the user accesses the given FILE." + (or (and (eq (string-match tramp-file-name-regexp file) 0) + ;; tramp case: execute "whoami" via tramp + (let ((default-directory (file-name-directory file)) + process-file-side-effects) + (with-temp-buffer + (if (not (zerop (process-file "whoami" nil t))) + ;; fall through if "whoami" didn't work + nil + ;; remove trailing newline + (delete-region (1- (point-max)) (point-max)) + (buffer-string))))) + ;; normal case + (user-login-name) + ;; if user-login-name is nil, return the UID as a string + (number-to-string (user-uid)))) + +(defun vc-state (file &optional backend) + "Return the version control state of FILE. + +If FILE is not registered, this function always returns nil. +For registered files, the value returned is one of: + + 'up-to-date The working file is unmodified with respect to the + latest version on the current branch, and not locked. + + 'edited The working file has been edited by the user. If + locking is used for the file, this state means that + the current version is locked by the calling user. + This status should *not* be reported for files + which have a changed mtime but the same content + as the repo copy. + + USER The current version of the working file is locked by + some other USER (a string). + + 'needs-update The file has not been edited by the user, but there is + a more recent version on the current branch stored + in the repository. + + 'needs-merge The file has been edited by the user, and there is also + a more recent version on the current branch stored in + the repository. This state can only occur if locking + is not used for the file. + + 'unlocked-changes The working version of the file is not locked, + but the working file has been changed with respect + to that version. This state can only occur for files + with locking; it represents an erroneous condition that + should be resolved by the user (vc-next-action will + prompt the user to do it). + + 'added Scheduled to go into the repository on the next commit. + Often represented by vc-working-revision = \"0\" in VCSes + with monotonic IDs like Subversion and Mercurial. + + 'removed Scheduled to be deleted from the repository on next commit. + + 'conflict The file contains conflicts as the result of a merge. + For now the conflicts are text conflicts. In the + future this might be extended to deal with metadata + conflicts too. + + 'missing The file is not present in the file system, but the VC + system still tracks it. + + 'ignored The file showed up in a dir-status listing with a flag + indicating the version-control system is ignoring it, + Note: This property is not set reliably (some VCSes + don't have useful directory-status commands) so assume + that any file with vc-state nil might be ignorable + without VC knowing it. + + 'unregistered The file is not under version control. + +A return of nil from this function means we have no information on the +status of this file." + ;; Note: in Emacs 22 and older, return of nil meant the file was + ;; unregistered. This is potentially a source of + ;; backward-compatibility bugs. + + ;; FIXME: New (sub)states needed (?): + ;; - `copied' and `moved' (might be handled by `removed' and `added') + (or (vc-file-getprop file 'vc-state) + (when (> (length file) 0) ;Why?? --Stef + (setq backend (or backend (vc-backend file))) + (when backend + (vc-state-refresh file backend))))) + +(defun vc-state-refresh (file backend) + "Quickly recompute the `state' of FILE." + (vc-file-setprop + file 'vc-state + (vc-call-backend backend 'state-heuristic file))) + +(defsubst vc-up-to-date-p (file) + "Convenience function that checks whether `vc-state' of FILE is `up-to-date'." + (eq (vc-state file) 'up-to-date)) + +(defun vc-default-state-heuristic (backend file) + "Default implementation of vc-BACKEND-state-heuristic. +It simply calls the real state computation function `vc-BACKEND-state' +and does not employ any heuristic at all." + (vc-call-backend backend 'state file)) + +(defun vc-workfile-unchanged-p (file) + "Return non-nil if FILE has not changed since the last checkout." + (let ((checkout-time (vc-file-getprop file 'vc-checkout-time)) + (lastmod (nth 5 (file-attributes file)))) + ;; This is a shortcut for determining when the workfile is + ;; unchanged. It can fail under some circumstances; see the + ;; discussion in bug#694. + (if (and checkout-time + ;; Tramp and Ange-FTP return this when they don't know the time. + (not (equal lastmod '(0 0)))) + (equal checkout-time lastmod) + (let ((unchanged (vc-call workfile-unchanged-p file))) + (vc-file-setprop file 'vc-checkout-time (if unchanged lastmod 0)) + unchanged)))) + +(defun vc-default-workfile-unchanged-p (backend file) + "Check if FILE is unchanged by diffing against the repository version. +Return non-nil if FILE is unchanged." + (zerop (condition-case err + ;; If the implementation supports it, let the output + ;; go to *vc*, not *vc-diff*, since this is an internal call. + (vc-call-backend backend 'diff (list file) nil nil "*vc*") + (wrong-number-of-arguments + ;; If this error came from the above call to vc-BACKEND-diff, + ;; try again without the optional buffer argument (for + ;; backward compatibility). Otherwise, resignal. + (if (or (not (eq (cadr err) + (indirect-function + (vc-find-backend-function backend 'diff)))) + (not (eq (caddr err) 4))) + (signal (car err) (cdr err)) + (vc-call-backend backend 'diff (list file))))))) + +(defun vc-working-revision (file &optional backend) + "Return the repository version from which FILE was checked out. +If FILE is not registered, this function always returns nil." + (or (vc-file-getprop file 'vc-working-revision) + (progn + (setq backend (or backend (vc-backend file))) + (when backend + (vc-file-setprop file 'vc-working-revision + (vc-call-backend backend 'working-revision file)))))) + +;; Backward compatibility. +(define-obsolete-function-alias + 'vc-workfile-version 'vc-working-revision "23.1") +(defun vc-default-working-revision (backend file) + (message + "`working-revision' not found: using the old `workfile-version' instead") + (vc-call-backend backend 'workfile-version file)) + +(defun vc-default-registered (backend file) + "Check if FILE is registered in BACKEND using vc-BACKEND-master-templates." + (let ((sym (vc-make-backend-sym backend 'master-templates))) + (unless (get backend 'vc-templates-grabbed) + (put backend 'vc-templates-grabbed t) + (set sym (append (delq nil + (mapcar + (lambda (template) + (and (consp template) + (eq (cdr template) backend) + (car template))) + (with-no-warnings + vc-master-templates))) + (symbol-value sym)))) + (let ((result (vc-check-master-templates file (symbol-value sym)))) + (if (stringp result) + (vc-file-setprop file 'vc-name result) + nil)))) ; Not registered + +(defun vc-possible-master (s dirname basename) + (cond + ((stringp s) (format s dirname basename)) + ((functionp s) + ;; The template is a function to invoke. If the + ;; function returns non-nil, that means it has found a + ;; master. For backward compatibility, we also handle + ;; the case that the function throws a 'found atom + ;; and a pair (cons MASTER-FILE BACKEND). + (let ((result (catch 'found (funcall s dirname basename)))) + (if (consp result) (car result) result))))) + +(defun vc-check-master-templates (file templates) + "Return non-nil if there is a master corresponding to FILE. + +TEMPLATES is a list of strings or functions. If an element is a +string, it must be a control string as required by `format', with two +string placeholders, such as \"%sRCS/%s,v\". The directory part of +FILE is substituted for the first placeholder, the basename of FILE +for the second. If a file with the resulting name exists, it is taken +as the master of FILE, and returned. + +If an element of TEMPLATES is a function, it is called with the +directory part and the basename of FILE as arguments. It should +return non-nil if it finds a master; that value is then returned by +this function." + (let ((dirname (or (file-name-directory file) "")) + (basename (file-name-nondirectory file))) + (catch 'found + (mapcar + (lambda (s) + (let ((trial (vc-possible-master s dirname basename))) + (when (and trial (file-exists-p trial) + ;; Make sure the file we found with name + ;; TRIAL is not the source file itself. + ;; That can happen with RCS-style names if + ;; the file name is truncated (e.g. to 14 + ;; chars). See if either directory or + ;; attributes differ. + (or (not (string= dirname + (file-name-directory trial))) + (not (equal (file-attributes file) + (file-attributes trial))))) + (throw 'found trial)))) + templates)))) + +(defun vc-toggle-read-only (&optional verbose) + "Change read-only status of current buffer, perhaps via version control. + +If the buffer is visiting a file registered with version control, +throw an error, because this is not a safe or really meaningful operation +on any version-control system newer than RCS. + +Otherwise, just change the read-only flag of the buffer. + +If you bind this function to \\[toggle-read-only], then Emacs +will properly intercept all attempts to toggle the read-only flag +on version-controlled buffer." + (interactive "P") + (if (vc-backend buffer-file-name) + (error "Toggling the readability of a version controlled file is likely to wreak havoc") + (toggle-read-only))) + +(defun vc-default-make-version-backups-p (backend file) + "Return non-nil if unmodified versions should be backed up locally. +The default is to switch off this feature." + nil) + +(defun vc-version-backup-file-name (file &optional rev manual regexp) + "Return a backup file name for REV or the current version of FILE. +If MANUAL is non-nil it means that a name for backups created by +the user should be returned; if REGEXP is non-nil that means to return +a regexp for matching all such backup files, regardless of the version." + (if regexp + (concat (regexp-quote (file-name-nondirectory file)) + "\\.~.+" (unless manual "\\.") "~") + (expand-file-name (concat (file-name-nondirectory file) + ".~" (subst-char-in-string + ?/ ?_ (or rev (vc-working-revision file))) + (unless manual ".") "~") + (file-name-directory file)))) + +(defun vc-delete-automatic-version-backups (file) + "Delete all existing automatic version backups for FILE." + (condition-case nil + (mapc + 'delete-file + (directory-files (or (file-name-directory file) default-directory) t + (vc-version-backup-file-name file nil nil t))) + ;; Don't fail when the directory doesn't exist. + (file-error nil))) + +(defun vc-make-version-backup (file) + "Make a backup copy of FILE, which is assumed in sync with the repository. +Before doing that, check if there are any old backups and get rid of them." + (unless (and (fboundp 'msdos-long-file-names) + (not (with-no-warnings (msdos-long-file-names)))) + (vc-delete-automatic-version-backups file) + (condition-case nil + (copy-file file (vc-version-backup-file-name file) + nil 'keep-date) + ;; It's ok if it doesn't work (e.g. directory not writable), + ;; since this is just for efficiency. + (file-error + (message + (concat "Warning: Cannot make version backup; " + "diff/revert therefore not local")))))) + +(defun vc-before-save () + "Function to be called by `basic-save-buffer' (in files.el)." + ;; If the file on disk is still in sync with the repository, + ;; and version backups should be made, copy the file to + ;; another name. This enables local diffs and local reverting. + (let ((file buffer-file-name) + backend) + (ignore-errors ;Be careful not to prevent saving the file. + (and (setq backend (vc-backend file)) + (vc-up-to-date-p file) + (eq (vc-checkout-model backend (list file)) 'implicit) + (vc-call-backend backend 'make-version-backups-p file) + (vc-make-version-backup file))))) + +(declare-function vc-dir-resynch-file "vc-dir" (&optional fname)) + +(defvar vc-dir-buffers nil "List of vc-dir buffers.") + +(defun vc-after-save () + "Function to be called by `basic-save-buffer' (in files.el)." + ;; If the file in the current buffer is under version control, + ;; up-to-date, and locking is not used for the file, set + ;; the state to 'edited and redisplay the mode line. + (let* ((file buffer-file-name) + (backend (vc-backend file))) + (and backend + (or (and (equal (vc-file-getprop file 'vc-checkout-time) + (nth 5 (file-attributes file))) + ;; File has been saved in the same second in which + ;; it was checked out. Clear the checkout-time + ;; to avoid confusion. + (vc-file-setprop file 'vc-checkout-time nil)) + t) + (eq (vc-checkout-model backend (list file)) 'implicit) + (vc-state-refresh file backend) + (vc-mode-line file backend)) + ;; Try to avoid unnecessary work, a *vc-dir* buffer is + ;; present if this is true. + (when vc-dir-buffers + (vc-dir-resynch-file file)))) + +(defvar vc-menu-entry + `(menu-item ,(purecopy "Version Control") vc-menu-map + :filter vc-menu-map-filter)) + +(when (boundp 'menu-bar-tools-menu) + ;; We do not need to worry here about the placement of this entry + ;; because menu-bar.el has already created the proper spot for us + ;; and this will simply use it. + (define-key menu-bar-tools-menu [vc] vc-menu-entry)) + +(defconst vc-mode-line-map + (let ((map (make-sparse-keymap))) + (define-key map [mode-line down-mouse-1] vc-menu-entry) + map)) + +(defun vc-mode-line (file &optional backend) + "Set `vc-mode' to display type of version control for FILE. +The value is set in the current buffer, which should be the buffer +visiting FILE. +If BACKEND is passed use it as the VC backend when computing the result." + (interactive (list buffer-file-name)) + (setq backend (or backend (vc-backend file))) + (if (not backend) + (setq vc-mode nil) + (let* ((ml-string (vc-call-backend backend 'mode-line-string file)) + (ml-echo (get-text-property 0 'help-echo ml-string))) + (setq vc-mode + (concat + " " + (if (null vc-display-status) + (symbol-name backend) + (propertize + ml-string + 'mouse-face 'mode-line-highlight + 'help-echo + (concat (or ml-echo + (format "File under the %s version control system" + backend)) + "\nmouse-1: Version Control menu") + 'local-map vc-mode-line-map))))) + ;; If the user is root, and the file is not owner-writable, + ;; then pretend that we can't write it + ;; even though we can (because root can write anything). + ;; This way, even root cannot modify a file that isn't locked. + (and (equal file buffer-file-name) + (not buffer-read-only) + (zerop (user-real-uid)) + (zerop (logand (file-modes buffer-file-name) 128)) + (setq buffer-read-only t))) + (force-mode-line-update) + backend) + +(defun vc-default-mode-line-string (backend file) + "Return string for placement in modeline by `vc-mode-line' for FILE. +Format: + + \"BACKEND-REV\" if the file is up-to-date + \"BACKEND:REV\" if the file is edited (or locked by the calling user) + \"BACKEND:LOCKER:REV\" if the file is locked by somebody else + \"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 diff --cc lisp/vc/vc-mtn.el index a1ca6ab4d65,00000000000..0bf30aca6a3 mode 100644,000000..100644 --- a/lisp/vc/vc-mtn.el +++ b/lisp/vc/vc-mtn.el @@@ -1,345 -1,0 +1,345 @@@ +;;; vc-mtn.el --- VC backend for Monotone + - ;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ++;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. + +;; Author: Stefan Monnier +;; 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 . + +;;; 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 diff --cc lisp/vc/vc-rcs.el index f8d5214d776,00000000000..ea0fed7bf0d mode 100644,000000..100644 --- a/lisp/vc/vc-rcs.el +++ b/lisp/vc/vc-rcs.el @@@ -1,1471 -1,0 +1,1471 @@@ +;;; 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 ++;; 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 +;; 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 . + +;;; 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) + + +;;; Properties of the backend + +(defun vc-rcs-revision-granularity () 'file) + +(defun vc-rcs-checkout-model (files) + "RCS-specific version of `vc-checkout-model'." + (let ((file (if (consp files) (car files) files)) + result) + (when vc-consult-headers + (vc-file-setprop file 'vc-checkout-model nil) + (vc-rcs-consult-headers file) + (setq result (vc-file-getprop file 'vc-checkout-model))) + (or result + (progn (vc-rcs-fetch-master-state file) + (vc-file-getprop file 'vc-checkout-model))))) + +;;; +;;; State-querying functions +;;; + +;; The autoload cookie below places vc-rcs-registered directly into +;; loaddefs.el, so that vc-rcs.el does not need to be loaded for +;; every file that is visited. +;;;###autoload +(progn +(defun vc-rcs-registered (f) (vc-default-registered 'RCS f))) + +(defun vc-rcs-state (file) + "Implementation of `vc-state' for RCS." + (if (not (vc-rcs-registered file)) + 'unregistered + (or (boundp 'vc-rcs-headers-result) + (and vc-consult-headers + (vc-rcs-consult-headers file))) + (let ((state + ;; vc-working-revision might not be known; in that case the + ;; property is nil. vc-rcs-fetch-master-state knows how to + ;; handle that. + (vc-rcs-fetch-master-state file + (vc-file-getprop file + 'vc-working-revision)))) + (if (not (eq state 'up-to-date)) + state + (if (vc-workfile-unchanged-p file) + 'up-to-date + (if (eq (vc-rcs-checkout-model (list file)) 'locking) + 'unlocked-changes + 'edited)))))) + +(defun vc-rcs-state-heuristic (file) + "State heuristic for RCS." + (let (vc-rcs-headers-result) + (if (and vc-consult-headers + (setq vc-rcs-headers-result + (vc-rcs-consult-headers file)) + (eq vc-rcs-headers-result 'rev-and-lock)) + (let ((state (vc-file-getprop file 'vc-state))) + ;; If the headers say that the file is not locked, the + ;; permissions can tell us whether locking is used for + ;; the file or not. + (if (and (eq state 'up-to-date) + (not (vc-mistrust-permissions file)) + (file-exists-p file)) + (cond + ((string-match ".rw..-..-." (nth 8 (file-attributes file))) + (vc-file-setprop file 'vc-checkout-model 'implicit) + (setq state + (if (vc-rcs-workfile-is-newer file) + 'edited + 'up-to-date))) + ((string-match ".r-..-..-." (nth 8 (file-attributes file))) + (vc-file-setprop file 'vc-checkout-model 'locking)))) + state) + (if (not (vc-mistrust-permissions file)) + (let* ((attributes (file-attributes file 'string)) + (owner-name (nth 2 attributes)) + (permissions (nth 8 attributes))) + (cond ((and permissions (string-match ".r-..-..-." permissions)) + (vc-file-setprop file 'vc-checkout-model 'locking) + 'up-to-date) + ((and permissions (string-match ".rw..-..-." permissions)) + (if (eq (vc-rcs-checkout-model file) 'locking) + (if (file-ownership-preserved-p file) + 'edited + owner-name) + (if (vc-rcs-workfile-is-newer file) + 'edited + 'up-to-date))) + (t + ;; Strange permissions. Fall through to + ;; expensive state computation. + (vc-rcs-state file)))) + (vc-rcs-state file))))) + +(defun vc-rcs-dir-status (dir update-function) + ;; FIXME: this function should be rewritten or `vc-expand-dirs' + ;; should be changed to take a backend parameter. Using + ;; `vc-expand-dirs' is not TRTD because it returns files from + ;; multiple backends. It should also return 'unregistered files. + + ;; Doing individual vc-state calls is painful but there + ;; is no better way in RCS-land. + (let ((flist (vc-expand-dirs (list dir))) + (result nil)) + (dolist (file flist) + (let ((state (vc-state file)) + (frel (file-relative-name file))) + (when (and (eq (vc-backend file) 'RCS) + (not (eq state 'up-to-date))) + (push (list frel state) result)))) + (funcall update-function result))) + +(defun vc-rcs-working-revision (file) + "RCS-specific version of `vc-working-revision'." + (or (and vc-consult-headers + (vc-rcs-consult-headers file) + (vc-file-getprop file 'vc-working-revision)) + (progn + (vc-rcs-fetch-master-state file) + (vc-file-getprop file 'vc-working-revision)))) + +(defun vc-rcs-latest-on-branch-p (file &optional version) + "Return non-nil if workfile version of FILE is the latest on its branch. +When VERSION is given, perform check for that version." + (unless version (setq version (vc-working-revision file))) + (with-temp-buffer + (string= version + (if (vc-rcs-trunk-p version) + (progn + ;; Compare VERSION to the head version number. + (vc-insert-file (vc-name file) "^[0-9]") + (vc-parse-buffer "^head[ \t\n]+\\([^;]+\\);" 1)) + ;; If we are not on the trunk, we need to examine the + ;; whole current branch. + (vc-insert-file (vc-name file) "^desc") + (vc-rcs-find-most-recent-rev (vc-branch-part version)))))) + +(defun vc-rcs-workfile-unchanged-p (file) + "RCS-specific implementation of `vc-workfile-unchanged-p'." + ;; Try to use rcsdiff --brief. If rcsdiff does not understand that, + ;; do a double take and remember the fact for the future + (let* ((version (concat "-r" (vc-working-revision file))) + (status (if (eq vc-rcsdiff-knows-brief 'no) + (vc-do-command "*vc*" 1 "rcsdiff" file version) + (vc-do-command "*vc*" 2 "rcsdiff" file "--brief" version)))) + (if (eq status 2) + (if (not vc-rcsdiff-knows-brief) + (setq vc-rcsdiff-knows-brief 'no + status (vc-do-command "*vc*" 1 "rcsdiff" file version)) + (error "rcsdiff failed")) + (if (not vc-rcsdiff-knows-brief) (setq vc-rcsdiff-knows-brief 'yes))) + ;; The workfile is unchanged if rcsdiff found no differences. + (zerop status))) + + +;;; +;;; State-changing functions +;;; + +(defun vc-rcs-create-repo () + "Create a new RCS repository." + ;; RCS is totally file-oriented, so all we have to do is make the directory. + (make-directory "RCS")) + +(defun vc-rcs-register (files &optional rev comment) + "Register FILES into the RCS version-control system. +REV is the optional revision number for the files. COMMENT can be used +to provide an initial description for each FILES. +Passes either `vc-rcs-register-switches' or `vc-register-switches' +to the RCS command. + +Automatically retrieve a read-only version of the file with keywords +expanded if `vc-keep-workfiles' is non-nil, otherwise, delete the workfile." + (let (subdir name) + ;; When REV is specified, we need to force using "-t-". + (when rev (unless comment (setq comment ""))) + (dolist (file files) + (and (not (file-exists-p + (setq subdir (expand-file-name "RCS" + (file-name-directory file))))) + (not (directory-files (file-name-directory file) + nil ".*,v$" t)) + (yes-or-no-p "Create RCS subdirectory? ") + (make-directory subdir)) + (apply 'vc-do-command "*vc*" 0 "ci" file + ;; if available, use the secure registering option + (and (vc-rcs-release-p "5.6.4") "-i") + (concat (if vc-keep-workfiles "-u" "-r") rev) + (and comment (concat "-t-" comment)) + (vc-switches 'RCS 'register)) + ;; parse output to find master file name and workfile version + (with-current-buffer "*vc*" + (goto-char (point-min)) + (if (not (setq name + (if (looking-at (concat "^\\(.*\\) <-- " + (file-name-nondirectory file))) + (match-string 1)))) + ;; if we couldn't find the master name, + ;; run vc-rcs-registered to get it + ;; (will be stored into the vc-name property) + (vc-rcs-registered file) + (vc-file-setprop file 'vc-name + (if (file-name-absolute-p name) + name + (expand-file-name + name + (file-name-directory file)))))) + (vc-file-setprop file 'vc-working-revision + (if (re-search-forward + "^initial revision: \\([0-9.]+\\).*\n" + nil t) + (match-string 1)))))) + +(defun vc-rcs-responsible-p (file) + "Return non-nil if RCS thinks it would be responsible for registering FILE." + ;; TODO: check for all the patterns in vc-rcs-master-templates + (file-directory-p (expand-file-name "RCS" (file-name-directory file)))) + +(defun vc-rcs-receive-file (file rev) + "Implementation of receive-file for RCS." + (let ((checkout-model (vc-rcs-checkout-model (list file)))) + (vc-rcs-register file rev "") + (when (eq checkout-model 'implicit) + (vc-rcs-set-non-strict-locking file)) + (vc-rcs-set-default-branch file (concat rev ".1")))) + +(defun vc-rcs-unregister (file) + "Unregister FILE from RCS. +If this leaves the RCS subdirectory empty, ask the user +whether to remove it." + (let* ((master (vc-name file)) + (dir (file-name-directory master)) + (backup-info (find-backup-file-name master))) + (if (not backup-info) + (delete-file master) + (rename-file master (car backup-info) 'ok-if-already-exists) + (dolist (f (cdr backup-info)) (ignore-errors (delete-file f)))) + (and (string= (file-name-nondirectory (directory-file-name dir)) "RCS") + ;; check whether RCS dir is empty, i.e. it does not + ;; contain any files except "." and ".." + (not (directory-files dir nil + "^\\([^.]\\|\\.[^.]\\|\\.\\.[^.]\\).*")) + (yes-or-no-p (format "Directory %s is empty; remove it? " dir)) + (delete-directory dir)))) + +(defun vc-rcs-checkin (files rev comment) + "RCS-specific version of `vc-backend-checkin'." + (let ((switches (vc-switches 'RCS 'checkin))) + ;; Now operate on the files + (dolist (file (vc-expand-dirs files)) + (let ((old-version (vc-working-revision file)) new-version + (default-branch (vc-file-getprop file 'vc-rcs-default-branch))) + ;; Force branch creation if an appropriate + ;; default branch has been set. + (and (not rev) + default-branch + (string-match (concat "^" (regexp-quote old-version) "\\.") + default-branch) + (setq rev default-branch) + (setq switches (cons "-f" switches))) + (if (and (not rev) old-version) + (setq rev (vc-branch-part old-version))) + (apply 'vc-do-command "*vc*" 0 "ci" (vc-name file) + ;; if available, use the secure check-in option + (and (vc-rcs-release-p "5.6.4") "-j") + (concat (if vc-keep-workfiles "-u" "-r") rev) + (concat "-m" comment) + switches) + (vc-file-setprop file 'vc-working-revision nil) + + ;; determine the new workfile version + (set-buffer "*vc*") + (goto-char (point-min)) + (when (or (re-search-forward + "new revision: \\([0-9.]+\\);" nil t) + (re-search-forward + "reverting to previous revision \\([0-9.]+\\)" nil t)) + (setq new-version (match-string 1)) + (vc-file-setprop file 'vc-working-revision new-version)) + + ;; if we got to a different branch, adjust the default + ;; branch accordingly + (cond + ((and old-version new-version + (not (string= (vc-branch-part old-version) + (vc-branch-part new-version)))) + (vc-rcs-set-default-branch file + (if (vc-rcs-trunk-p new-version) nil + (vc-branch-part new-version))) + ;; If this is an old RCS release, we might have + ;; to remove a remaining lock. + (if (not (vc-rcs-release-p "5.6.2")) + ;; exit status of 1 is also accepted. + ;; It means that the lock was removed before. + (vc-do-command "*vc*" 1 "rcs" (vc-name file) + (concat "-u" old-version))))))))) + +(defun vc-rcs-find-revision (file rev buffer) + (apply 'vc-do-command + (or buffer "*vc*") 0 "co" (vc-name file) + "-q" ;; suppress diagnostic output + (concat "-p" rev) + (vc-switches 'RCS 'checkout))) + +(defun vc-rcs-checkout (file &optional editable rev) + "Retrieve a copy of a saved version of FILE. If FILE is a directory, +attempt the checkout for all registered files beneath it." + (if (file-directory-p file) + (mapc 'vc-rcs-checkout (vc-expand-dirs (list file))) + (let ((file-buffer (get-file-buffer file)) + switches) + (message "Checking out %s..." file) + (save-excursion + ;; Change buffers to get local value of vc-checkout-switches. + (if file-buffer (set-buffer file-buffer)) + (setq switches (vc-switches 'RCS 'checkout)) + ;; Save this buffer's default-directory + ;; and use save-excursion to make sure it is restored + ;; in the same buffer it was saved in. + (let ((default-directory default-directory)) + (save-excursion + ;; Adjust the default-directory so that the check-out creates + ;; the file in the right place. + (setq default-directory (file-name-directory file)) + (let (new-version) + ;; if we should go to the head of the trunk, + ;; clear the default branch first + (and rev (string= rev "") + (vc-rcs-set-default-branch file nil)) + ;; now do the checkout + (apply 'vc-do-command + "*vc*" 0 "co" (vc-name file) + ;; If locking is not strict, force to overwrite + ;; the writable workfile. + (if (eq (vc-rcs-checkout-model (list file)) 'implicit) "-f") + (if editable "-l") + (if (stringp rev) + ;; a literal revision was specified + (concat "-r" rev) + (let ((workrev (vc-working-revision file))) + (if workrev + (concat "-r" + (if (not rev) + ;; no revision specified: + ;; use current workfile version + workrev + ;; REV is t ... + (if (not (vc-rcs-trunk-p workrev)) + ;; ... go to head of current branch + (vc-branch-part workrev) + ;; ... go to head of trunk + (vc-rcs-set-default-branch file + nil) + "")))))) + switches) + ;; determine the new workfile version + (with-current-buffer "*vc*" + (setq new-version + (vc-parse-buffer "^revision \\([0-9.]+\\).*\n" 1))) + (vc-file-setprop file 'vc-working-revision new-version) + ;; if necessary, adjust the default branch + (and rev (not (string= rev "")) + (vc-rcs-set-default-branch + file + (if (vc-rcs-latest-on-branch-p file new-version) + (if (vc-rcs-trunk-p new-version) nil + (vc-branch-part new-version)) + new-version))))) + (message "Checking out %s...done" file)))))) + +(defun vc-rcs-rollback (files) + "Roll back, undoing the most recent checkins of FILES. Directories are +expanded to all registered subfiles in them." + (if (not files) + (error "RCS backend doesn't support directory-level rollback")) + (dolist (file (vc-expand-dirs files)) + (let* ((discard (vc-working-revision file)) + (previous (if (vc-rcs-trunk-p discard) "" (vc-branch-part discard))) + (config (current-window-configuration)) + (done nil)) + (if (null (yes-or-no-p (format "Remove version %s from %s history? " + discard file))) + (error "Aborted")) + (message "Removing revision %s from %s." discard file) + (vc-do-command "*vc*" 0 "rcs" (vc-name file) (concat "-o" discard)) + ;; Check out the most recent remaining version. If it + ;; fails, because the whole branch got deleted, do a + ;; double-take and check out the version where the branch + ;; started. + (while (not done) + (condition-case err + (progn + (vc-do-command "*vc*" 0 "co" (vc-name file) "-f" + (concat "-u" previous)) + (setq done t)) + (error (set-buffer "*vc*") + (goto-char (point-min)) + (if (search-forward "no side branches present for" nil t) + (progn (setq previous (vc-branch-part previous)) + (vc-rcs-set-default-branch file previous) + ;; vc-do-command popped up a window with + ;; the error message. Get rid of it, by + ;; restoring the old window configuration. + (set-window-configuration config)) + ;; No, it was some other error: re-signal it. + (signal (car err) (cdr err))))))))) + +(defun vc-rcs-revert (file &optional contents-done) + "Revert FILE to the version it was based on. If FILE is a directory, +revert all registered files beneath it." + (if (file-directory-p file) + (mapc 'vc-rcs-revert (vc-expand-dirs (list file))) + (vc-do-command "*vc*" 0 "co" (vc-name file) "-f" + (concat (if (eq (vc-state file) 'edited) "-u" "-r") + (vc-working-revision file))))) + +(defun vc-rcs-merge (file first-version &optional second-version) + "Merge changes into current working copy of FILE. +The changes are between FIRST-VERSION and SECOND-VERSION." + (vc-do-command "*vc*" 1 "rcsmerge" (vc-name file) + "-kk" ; ignore keyword conflicts + (concat "-r" first-version) + (if second-version (concat "-r" second-version)))) + +(defun vc-rcs-steal-lock (file &optional rev) + "Steal the lock on the current workfile for FILE and revision REV. +If FILE is a directory, steal the lock on all registered files beneath it. +Needs RCS 5.6.2 or later for -M." + (if (file-directory-p file) + (mapc 'vc-rcs-steal-lock (vc-expand-dirs (list file))) + (vc-do-command "*vc*" 0 "rcs" (vc-name file) "-M" (concat "-u" rev)) + ;; Do a real checkout after stealing the lock, so that we see + ;; expanded headers. + (vc-do-command "*vc*" 0 "co" (vc-name file) "-f" (concat "-l" rev)))) + +(defun vc-rcs-modify-change-comment (files rev comment) + "Modify the change comments change on FILES on a specified REV. If FILE is a +directory the operation is applied to all registered files beneath it." + (dolist (file (vc-expand-dirs files)) + (vc-do-command "*vc*" 0 "rcs" (vc-name file) + (concat "-m" rev ":" comment)))) + + +;;; +;;; History functions +;;; + +(defun vc-rcs-print-log-cleanup () + (let ((inhibit-read-only t)) + (goto-char (point-max)) + (forward-line -1) + (while (looking-at "=*\n") + (delete-char (- (match-end 0) (match-beginning 0))) + (forward-line -1)) + (goto-char (point-min)) + (when (looking-at "[\b\t\n\v\f\r ]+") + (delete-char (- (match-end 0) (match-beginning 0)))))) + +(defun vc-rcs-print-log (files buffer &optional shortlog start-revision-ignored limit) + "Get change log associated with FILE. If FILE is a +directory the operation is applied to all registered files beneath it." + (vc-do-command (or buffer "*vc*") 0 "rlog" (mapcar 'vc-name (vc-expand-dirs files))) + (with-current-buffer (or buffer "*vc*") + (vc-rcs-print-log-cleanup)) + (when limit 'limit-unsupported)) + +(defun vc-rcs-diff (files &optional oldvers newvers buffer) + "Get a difference report using RCS between two sets of files." + (apply 'vc-do-command (or buffer "*vc-diff*") + 1 ;; Always go synchronous, the repo is local + "rcsdiff" (vc-expand-dirs files) + (append (list "-q" + (and oldvers (concat "-r" oldvers)) + (and newvers (concat "-r" newvers))) + (vc-switches 'RCS 'diff)))) + +(defun vc-rcs-comment-history (file) + "Return a string with all log entries stored in BACKEND for FILE." + (with-current-buffer "*vc*" + ;; Has to be written this way, this function is used by the CVS backend too + (vc-call-backend (vc-backend file) 'print-log (list file)) + ;; Remove cruft + (let ((separator (concat "^-+\nrevision [0-9.]+\ndate: .*\n" + "\\(branches: .*;\n\\)?" + "\\(\\*\\*\\* empty log message \\*\\*\\*\n\\)?"))) + (goto-char (point-max)) (forward-line -1) + (while (looking-at "=*\n") + (delete-char (- (match-end 0) (match-beginning 0))) + (forward-line -1)) + (goto-char (point-min)) + (if (looking-at "[\b\t\n\v\f\r ]+") + (delete-char (- (match-end 0) (match-beginning 0)))) + (goto-char (point-min)) + (re-search-forward separator nil t) + (delete-region (point-min) (point)) + (while (re-search-forward separator nil t) + (delete-region (match-beginning 0) (match-end 0)))) + ;; Return the de-crufted comment list + (buffer-string))) + +(defun vc-rcs-annotate-command (file buffer &optional revision) + "Annotate FILE, inserting the results in BUFFER. +Optional arg REVISION is a revision to annotate from." + (vc-setup-buffer buffer) + ;; Aside from the "head revision on the trunk", the instructions for + ;; each revision on the trunk are an ordered list of kill and insert + ;; commands necessary to go from the chronologically-following + ;; revision to this one. That is, associated with revision N are + ;; edits that applied to revision N+1 would result in revision N. + ;; + ;; On a branch, however, (some) things are inverted: the commands + ;; listed are those necessary to go from the chronologically-preceding + ;; revision to this one. That is, associated with revision N are + ;; edits that applied to revision N-1 would result in revision N. + ;; + ;; So, to get per-line history info, we apply reverse-chronological + ;; edits, starting with the head revision on the trunk, all the way + ;; back through the initial revision (typically "1.1" or similar), + ;; then apply forward-chronological edits -- keeping track of which + ;; revision is associated with each inserted line -- until we reach + ;; the desired revision for display (which may be either on the trunk + ;; or on a branch). + (let* ((tree (with-temp-buffer + (insert-file-contents (vc-rcs-registered file)) + (vc-rcs-parse))) + (revisions (cdr (assq 'revisions tree))) + ;; The revision N whose instructions we currently are processing. + (cur (cdr (assq 'head (cdr (assq 'headers tree))))) + ;; Alist from the parse tree for N. + (meta (cdr (assoc cur revisions))) + ;; Point and temporary string, respectively. + p s + ;; "Next-branch list". Nil means the desired revision to + ;; display lives on the trunk. Non-nil means it lives on a + ;; branch, in which case the value is a list of revision pairs + ;; (PARENT . CHILD), the first PARENT being on the trunk, that + ;; links each series of revisions in the path from the initial + ;; revision to the desired revision to display. + nbls + ;; "Path-accumulate-predicate plus revision/date/author". + ;; Until set, forward-chronological edits are not accumulated. + ;; Once set, its value (updated every revision) is used for + ;; the text property `:vc-rcs-r/d/a' for inserts during + ;; processing of forward-chronological instructions for N. + ;; See internal func `r/d/a'. + prda + ;; List of forward-chronological instructions, each of the + ;; form: (POS . ACTION), where POS is a buffer position. If + ;; ACTION is a string, it is inserted, otherwise it is taken as + ;; the number of characters to be deleted. + path + ;; N+1. When `cur' is "", this is the initial revision. + pre) + (unless revision + (setq revision cur)) + (unless (assoc revision revisions) + (error "No such revision: %s" revision)) + ;; Find which branches (if any) must be included in the edits. + (let ((par revision) + bpt kids) + (while (setq bpt (vc-branch-part par) + par (vc-branch-part bpt)) + (setq kids (cdr (assq 'branches (cdr (assoc par revisions))))) + ;; A branchpoint may have multiple children. Find the right one. + (while (not (string= bpt (vc-branch-part (car kids)))) + (setq kids (cdr kids))) + (push (cons par (car kids)) nbls))) + ;; Start with the full text. + (set-buffer buffer) + (insert (cdr (assq 'text meta))) + ;; Apply reverse-chronological edits on the trunk, computing and + ;; accumulating forward-chronological edits after some point, for + ;; later. + (flet ((r/d/a () (vector pre + (cdr (assq 'date meta)) + (cdr (assq 'author meta))))) + (while (when (setq pre cur cur (cdr (assq 'next meta))) + (not (string= "" cur))) + (setq + ;; Start accumulating the forward-chronological edits when N+1 + ;; on the trunk is either the desired revision to display, or + ;; the appropriate branchpoint for it. Do this before + ;; updating `meta' since `r/d/a' uses N+1's `meta' value. + prda (when (or prda (string= (if nbls (caar nbls) revision) pre)) + (r/d/a)) + meta (cdr (assoc cur revisions))) + ;; Edits in the parse tree specify a line number (in the buffer + ;; *BEFORE* editing occurs) to start from, but line numbers + ;; change as a result of edits. To DTRT, we apply edits in + ;; order of descending buffer position so that edits further + ;; down in the buffer occur first w/o corrupting specified + ;; buffer positions of edits occurring towards the beginning of + ;; the buffer. In this way we avoid using markers. A pleasant + ;; property of this approach is ability to push instructions + ;; onto `path' directly, w/o need to maintain rev boundaries. + (dolist (insn (cdr (assq :insn meta))) + (goto-char (point-min)) + (forward-line (1- (pop insn))) + (setq p (point)) + (case (pop insn) + (k (setq s (buffer-substring-no-properties + p (progn (forward-line (car insn)) + (point)))) + (when prda + (push `(,p . ,(propertize s :vc-rcs-r/d/a prda)) path)) + (delete-region p (point))) + (i (setq s (car insn)) + (when prda + (push `(,p . ,(length s)) path)) + (insert s))))) + ;; For the initial revision, setting `:vc-rcs-r/d/a' directly is + ;; equivalent to pushing an insert instruction (of the entire buffer + ;; contents) onto `path' then erasing the buffer, but less wasteful. + (put-text-property (point-min) (point-max) :vc-rcs-r/d/a (r/d/a)) + ;; Now apply the forward-chronological edits for the trunk. + (dolist (insn path) + (goto-char (pop insn)) + (if (stringp insn) + (insert insn) + (delete-char insn))) + ;; Now apply the forward-chronological edits (directly from the + ;; parse-tree) for the branch(es), if necessary. We re-use vars + ;; `pre' and `meta' for the sake of internal func `r/d/a'. + (while nbls + (setq pre (cdr (pop nbls))) + (while (progn + (setq meta (cdr (assoc pre revisions)) + prda nil) + (dolist (insn (cdr (assq :insn meta))) + (goto-char (point-min)) + (forward-line (1- (pop insn))) + (case (pop insn) + (k (delete-region + (point) (progn (forward-line (car insn)) + (point)))) + (i (insert (propertize + (car insn) + :vc-rcs-r/d/a + (or prda (setq prda (r/d/a)))))))) + (prog1 (not (string= (if nbls (caar nbls) revision) pre)) + (setq pre (cdr (assq 'next meta))))))))) + ;; Lastly, for each line, insert at bol nicely-formatted history info. + ;; We do two passes to collect summary information used to minimize + ;; the annotation's usage of screen real-estate: (1) Consider rendered + ;; width of revision plus author together as a unit; and (2) Omit + ;; author entirely if all authors are the same as the user. + (let ((ht (make-hash-table :test 'eq)) + (me (user-login-name)) + (maxw 0) + (all-me t) + rda w a) + (goto-char (point-max)) + (while (not (bobp)) + (forward-line -1) + (setq rda (get-text-property (point) :vc-rcs-r/d/a)) + (unless (gethash rda ht) + (setq a (aref rda 2) + all-me (and all-me (string= a me))) + (puthash rda (setq w (+ (length (aref rda 0)) + (length a))) + ht) + (setq maxw (max w maxw)))) + (let ((padding (make-string maxw 32))) + (flet ((pad (w) (substring-no-properties padding w)) + (render (rda &rest ls) + (propertize + (apply 'concat + (format-time-string "%Y-%m-%d" (aref rda 1)) + " " + (aref rda 0) + ls) + :vc-annotate-prefix t + :vc-rcs-r/d/a rda))) + (maphash + (if all-me + (lambda (rda w) + (puthash rda (render rda (pad w) ": ") ht)) + (lambda (rda w) + (puthash rda (render rda " " (pad w) " " (aref rda 2) ": ") ht))) + ht))) + (while (not (eobp)) + (insert (gethash (get-text-property (point) :vc-rcs-r/d/a) ht)) + (forward-line 1)))) + +(declare-function vc-annotate-convert-time "vc-annotate" (time)) + +(defun vc-rcs-annotate-current-time () + "Return the current time, based at midnight of the current day, and +encoded as fractional days." + (vc-annotate-convert-time + (apply 'encode-time 0 0 0 (nthcdr 3 (decode-time (current-time)))))) + +(defun vc-rcs-annotate-time () + "Return the time of the next annotation (as fraction of days) +systime, or nil if there is none. Also, reposition point." + (unless (eobp) + (prog1 (vc-annotate-convert-time + (aref (get-text-property (point) :vc-rcs-r/d/a) 1)) + (goto-char (next-single-property-change (point) :vc-annotate-prefix))))) + +(defun vc-rcs-annotate-extract-revision-at-line () + (aref (get-text-property (point) :vc-rcs-r/d/a) 0)) + + +;;; +;;; Tag system +;;; + +(defun vc-rcs-create-tag (backend dir name branchp) + (when branchp + (error "RCS backend %s does not support module branches" backend)) + (let ((result (vc-tag-precondition dir))) + (if (stringp result) + (error "File %s is not up-to-date" result) + (vc-file-tree-walk + dir + (lambda (f) + (vc-do-command "*vc*" 0 "rcs" (vc-name f) (concat "-n" name ":"))))))) + + +;;; +;;; Miscellaneous +;;; + +(defun vc-rcs-trunk-p (rev) + "Return t if REV is a revision on the trunk." + (not (eq nil (string-match "\\`[0-9]+\\.[0-9]+\\'" rev)))) + +(defun vc-rcs-minor-part (rev) + "Return the minor revision number of a revision number REV." + (string-match "[0-9]+\\'" rev) + (substring rev (match-beginning 0) (match-end 0))) + +(defun vc-rcs-previous-revision (file rev) + "Return the revision number immediately preceding REV for FILE, +or nil if there is no previous revision. This default +implementation works for MAJOR.MINOR-style revision numbers as +used by RCS and CVS." + (let ((branch (vc-branch-part rev)) + (minor-num (string-to-number (vc-rcs-minor-part rev)))) + (when branch + (if (> minor-num 1) + ;; revision does probably not start a branch or release + (concat branch "." (number-to-string (1- minor-num))) + (if (vc-rcs-trunk-p rev) + ;; we are at the beginning of the trunk -- + ;; don't know anything to return here + nil + ;; we are at the beginning of a branch -- + ;; return revision of starting point + (vc-branch-part branch)))))) + +(defun vc-rcs-next-revision (file rev) + "Return the revision number immediately following REV for FILE, +or nil if there is no next revision. This default implementation +works for MAJOR.MINOR-style revision numbers as used by RCS +and CVS." + (when (not (string= rev (vc-working-revision file))) + (let ((branch (vc-branch-part rev)) + (minor-num (string-to-number (vc-rcs-minor-part rev)))) + (concat branch "." (number-to-string (1+ minor-num)))))) + +(defun vc-rcs-update-changelog (files) + "Default implementation of update-changelog. +Uses `rcs2log' which only works for RCS and CVS." + ;; FIXME: We (c|sh)ould add support for cvs2cl + (let ((odefault default-directory) + (changelog (find-change-log)) + ;; Presumably not portable to non-Unixy systems, along with rcs2log: + (tempfile (make-temp-file + (expand-file-name "vc" + (or small-temporary-file-directory + temporary-file-directory)))) + (login-name (or user-login-name + (format "uid%d" (number-to-string (user-uid))))) + (full-name (or add-log-full-name + (user-full-name) + (user-login-name) + (format "uid%d" (number-to-string (user-uid))))) + (mailing-address (or add-log-mailing-address + user-mail-address))) + (find-file-other-window changelog) + (barf-if-buffer-read-only) + (vc-buffer-sync) + (undo-boundary) + (goto-char (point-min)) + (push-mark) + (message "Computing change log entries...") + (message "Computing change log entries... %s" + (unwind-protect + (progn + (setq default-directory odefault) + (if (eq 0 (apply 'call-process + (expand-file-name "rcs2log" + exec-directory) + nil (list t tempfile) nil + "-c" changelog + "-u" (concat login-name + "\t" full-name + "\t" mailing-address) + (mapcar + (lambda (f) + (file-relative-name + (expand-file-name f odefault))) + files))) + "done" + (pop-to-buffer (get-buffer-create "*vc*")) + (erase-buffer) + (insert-file-contents tempfile) + "failed")) + (setq default-directory (file-name-directory changelog)) + (delete-file tempfile))))) + +(defun vc-rcs-check-headers () + "Check if the current file has any headers in it." + (save-excursion + (goto-char (point-min)) + (re-search-forward "\\$[A-Za-z\300-\326\330-\366\370-\377]+\ +\\(: [\t -#%-\176\240-\377]*\\)?\\$" nil t))) + +(defun vc-rcs-clear-headers () + "Implementation of vc-clear-headers for RCS." + (let ((case-fold-search nil)) + (goto-char (point-min)) + (while (re-search-forward + (concat "\\$\\(Author\\|Date\\|Header\\|Id\\|Locker\\|Name\\|" + "RCSfile\\|Revision\\|Source\\|State\\): [^$\n]+\\$") + nil t) + (replace-match "$\\1$")))) + +(defun vc-rcs-rename-file (old new) + ;; Just move the master file (using vc-rcs-master-templates). + (vc-rename-master (vc-name old) new vc-rcs-master-templates)) + +(defun vc-rcs-find-file-hook () + ;; If the file is locked by some other user, make + ;; the buffer read-only. Like this, even root + ;; cannot modify a file that someone else has locked. + (and (stringp (vc-state buffer-file-name 'RCS)) + (setq buffer-read-only t))) + + +;;; +;;; Internal functions +;;; + +(defun vc-rcs-workfile-is-newer (file) + "Return non-nil if FILE is newer than its RCS master. +This likely means that FILE has been changed with respect +to its master version." + (let ((file-time (nth 5 (file-attributes file))) + (master-time (nth 5 (file-attributes (vc-name file))))) + (or (> (nth 0 file-time) (nth 0 master-time)) + (and (= (nth 0 file-time) (nth 0 master-time)) + (> (nth 1 file-time) (nth 1 master-time)))))) + +(defun vc-rcs-find-most-recent-rev (branch) + "Find most recent revision on BRANCH." + (goto-char (point-min)) + (let ((latest-rev -1) value) + (while (re-search-forward (concat "^\\(" (regexp-quote branch) + "\\.\\([0-9]+\\)\\)\ndate[ \t]+[0-9.]+;") + nil t) + (let ((rev (string-to-number (match-string 2)))) + (when (< latest-rev rev) + (setq latest-rev rev) + (setq value (match-string 1))))) + (or value + (vc-branch-part branch)))) + +(defun vc-rcs-fetch-master-state (file &optional working-revision) + "Compute the master file's idea of the state of FILE. +If a WORKING-REVISION is given, compute the state of that version, +otherwise determine the workfile version based on the master file. +This function sets the properties `vc-working-revision' and +`vc-checkout-model' to their correct values, based on the master +file." + (with-temp-buffer + (if (or (not (vc-insert-file (vc-name file) "^[0-9]")) + (progn (goto-char (point-min)) + (not (looking-at "^head[ \t\n]+[^;]+;$")))) + (error "File %s is not an RCS master file" (vc-name file))) + (let ((workfile-is-latest nil) + (default-branch (vc-parse-buffer "^branch[ \t\n]+\\([^;]*\\);" 1))) + (vc-file-setprop file 'vc-rcs-default-branch default-branch) + (unless working-revision + ;; Workfile version not known yet. Determine that first. It + ;; is either the head of the trunk, the head of the default + ;; branch, or the "default branch" itself, if that is a full + ;; revision number. + (cond + ;; no default branch + ((or (not default-branch) (string= "" default-branch)) + (setq working-revision + (vc-parse-buffer "^head[ \t\n]+\\([^;]+\\);" 1)) + (setq workfile-is-latest t)) + ;; default branch is actually a revision + ((string-match "^[0-9]+\\.[0-9]+\\(\\.[0-9]+\\.[0-9]+\\)*$" + default-branch) + (setq working-revision default-branch)) + ;; else, search for the head of the default branch + (t (vc-insert-file (vc-name file) "^desc") + (setq working-revision + (vc-rcs-find-most-recent-rev default-branch)) + (setq workfile-is-latest t))) + (vc-file-setprop file 'vc-working-revision working-revision)) + ;; Check strict locking + (goto-char (point-min)) + (vc-file-setprop file 'vc-checkout-model + (if (re-search-forward ";[ \t\n]*strict;" nil t) + 'locking 'implicit)) + ;; Compute state of workfile version + (goto-char (point-min)) + (let ((locking-user + (vc-parse-buffer (concat "^locks[ \t\n]+[^;]*[ \t\n]+\\([^:]+\\):" + (regexp-quote working-revision) + "[^0-9.]") + 1))) + (cond + ;; not locked + ((not locking-user) + (if (or workfile-is-latest + (vc-rcs-latest-on-branch-p file working-revision)) + ;; workfile version is latest on branch + 'up-to-date + ;; workfile version is not latest on branch + 'needs-update)) + ;; locked by the calling user + ((and (stringp locking-user) + (string= locking-user (vc-user-login-name file))) + ;; Don't call `vc-rcs-checkout-model' to avoid inf-looping. + (if (or (eq (vc-file-getprop file 'vc-checkout-model) 'locking) + workfile-is-latest + (vc-rcs-latest-on-branch-p file working-revision)) + 'edited + ;; Locking is not used for the file, but the owner does + ;; have a lock, and there is a higher version on the current + ;; branch. Not sure if this can occur, and if it is right + ;; to use `needs-merge' in this case. + 'needs-merge)) + ;; locked by somebody else + ((stringp locking-user) + locking-user) + (t + (error "Error getting state of RCS file"))))))) + +(defun vc-rcs-consult-headers (file) + "Search for RCS headers in FILE, and set properties accordingly. + +Returns: nil if no headers were found + 'rev if a workfile revision was found + 'rev-and-lock if revision and lock info was found" + (cond + ((not (get-file-buffer file)) nil) + ((let (status version locking-user) + (with-current-buffer (get-file-buffer file) + (save-excursion + (goto-char (point-min)) + (cond + ;; search for $Id or $Header + ;; ------------------------- + ;; The `\ 's below avoid an RCS 5.7 bug when checking in this file. + ((or (and (search-forward "$Id\ : " nil t) + (looking-at "[^ ]+ \\([0-9.]+\\) ")) + (and (progn (goto-char (point-min)) + (search-forward "$Header\ : " nil t)) + (looking-at "[^ ]+ \\([0-9.]+\\) "))) + (goto-char (match-end 0)) + ;; if found, store the revision number ... + (setq version (match-string-no-properties 1)) + ;; ... and check for the locking state + (cond + ((looking-at + (concat "[0-9]+[/-][01][0-9][/-][0-3][0-9] " ; date + "[0-2][0-9]:[0-5][0-9]+:[0-6][0-9]+\\([+-][0-9:]+\\)? " ; time + "[^ ]+ [^ ]+ ")) ; author & state + (goto-char (match-end 0)) ; [0-6] in regexp handles leap seconds + (cond + ;; unlocked revision + ((looking-at "\\$") + (setq locking-user 'none) + (setq status 'rev-and-lock)) + ;; revision is locked by some user + ((looking-at "\\([^ ]+\\) \\$") + (setq locking-user (match-string-no-properties 1)) + (setq status 'rev-and-lock)) + ;; everything else: false + (nil))) + ;; unexpected information in + ;; keyword string --> quit + (nil))) + ;; search for $Revision + ;; -------------------- + ((re-search-forward (concat "\\$" + "Revision: \\([0-9.]+\\) \\$") + nil t) + ;; if found, store the revision number ... + (setq version (match-string-no-properties 1)) + ;; and see if there's any lock information + (goto-char (point-min)) + (if (re-search-forward (concat "\\$" "Locker:") nil t) + (cond ((looking-at " \\([^ ]+\\) \\$") + (setq locking-user (match-string-no-properties 1)) + (setq status 'rev-and-lock)) + ((looking-at " *\\$") + (setq locking-user 'none) + (setq status 'rev-and-lock)) + (t + (setq locking-user 'none) + (setq status 'rev-and-lock))) + (setq status 'rev))) + ;; else: nothing found + ;; ------------------- + (t nil)))) + (if status (vc-file-setprop file 'vc-working-revision version)) + (and (eq status 'rev-and-lock) + (vc-file-setprop file 'vc-state + (cond + ((eq locking-user 'none) 'up-to-date) + ((string= locking-user (vc-user-login-name file)) + 'edited) + (t locking-user))) + ;; If the file has headers, we don't want to query the + ;; master file, because that would eliminate all the + ;; performance gain the headers brought us. We therefore + ;; use a heuristic now to find out whether locking is used + ;; for this file. If we trust the file permissions, and the + ;; file is not locked, then if the file is read-only we + ;; assume that locking is used for the file, otherwise + ;; locking is not used. + (not (vc-mistrust-permissions file)) + (vc-up-to-date-p file) + (if (string-match ".r-..-..-." (nth 8 (file-attributes file))) + (vc-file-setprop file 'vc-checkout-model 'locking) + (vc-file-setprop file 'vc-checkout-model 'implicit))) + status)))) + +(defun vc-release-greater-or-equal (r1 r2) + "Compare release numbers, represented as strings. +Release components are assumed cardinal numbers, not decimal fractions +\(5.10 is a higher release than 5.9\). Omitted fields are considered +lower \(5.6.7 is earlier than 5.6.7.1\). Comparison runs till the end +of the string is found, or a non-numeric component shows up \(5.6.7 is +earlier than \"5.6.7 beta\", which is probably not what you want in +some cases\). This code is suitable for existing RCS release numbers. +CVS releases are handled reasonably, too \(1.3 < 1.4* < 1.5\)." + (let (v1 v2 i1 i2) + (catch 'done + (or (and (string-match "^\\.?\\([0-9]+\\)" r1) + (setq i1 (match-end 0)) + (setq v1 (string-to-number (match-string 1 r1))) + (or (and (string-match "^\\.?\\([0-9]+\\)" r2) + (setq i2 (match-end 0)) + (setq v2 (string-to-number (match-string 1 r2))) + (if (> v1 v2) (throw 'done t) + (if (< v1 v2) (throw 'done nil) + (throw 'done + (vc-release-greater-or-equal + (substring r1 i1) + (substring r2 i2))))))) + (throw 'done t))) + (or (and (string-match "^\\.?\\([0-9]+\\)" r2) + (throw 'done nil)) + (throw 'done t))))) + +(defun vc-rcs-release-p (release) + "Return t if we have RELEASE or better." + (let ((installation (vc-rcs-system-release))) + (if (and installation + (not (eq installation 'unknown))) + (vc-release-greater-or-equal installation release)))) + +(defun vc-rcs-system-release () + "Return the RCS release installed on this system, as a string. +Return symbol `unknown' if the release cannot be deducted. The user can +override this using variable `vc-rcs-release'. + +If the user has not set variable `vc-rcs-release' and it is nil, +variable `vc-rcs-release' is set to the returned value." + (or vc-rcs-release + (setq vc-rcs-release + (or (and (zerop (vc-do-command "*vc*" nil "rcs" nil "-V")) + (with-current-buffer (get-buffer "*vc*") + (vc-parse-buffer "^RCS version \\([0-9.]+ *.*\\)" 1))) + 'unknown)))) + +(defun vc-rcs-set-non-strict-locking (file) + (vc-do-command "*vc*" 0 "rcs" file "-U") + (vc-file-setprop file 'vc-checkout-model 'implicit) + (set-file-modes file (logior (file-modes file) 128))) + +(defun vc-rcs-set-default-branch (file branch) + (vc-do-command "*vc*" 0 "rcs" (vc-name file) (concat "-b" branch)) + (vc-file-setprop file 'vc-rcs-default-branch branch)) + +(defun vc-rcs-parse (&optional buffer) + "Parse current buffer, presumed to be in RCS-style masterfile format. +Optional arg BUFFER specifies another buffer to parse. Return an alist +of two elements, w/ keys `headers' and `revisions' and values in turn +sub-alists. For `headers', the values unless otherwise specified are +strings and the keys are: + + desc -- description + head -- latest revision + branch -- the branch the \"head revision\" lies on; + absent if the head revision lies on the trunk + access -- ??? + symbols -- sub-alist of (SYMBOL . REVISION) elements + locks -- if file is checked out, something like \"ttn:1.7\" + strict -- t if \"strict locking\" is in effect, otherwise nil + comment -- may be absent; typically something like \"# \" or \"; \" + expand -- may be absent; ??? + +For `revisions', the car is REVISION (string), the cdr a sub-alist, +with string values (unless otherwise specified) and keys: + + date -- a time value (like that returned by `encode-time'); as a + special case, a year value less than 100 is augmented by 1900 + author -- username + state -- typically \"Exp\" or \"Rel\" + branches -- list of revisions that begin branches from this revision + next -- on the trunk: the chronologically-preceding revision, or \"\"; + on a branch: the chronologically-following revision, or \"\" + log -- change log entry + text -- for the head revision on the trunk, the body of the file; + other revisions have `:insn' instead + :insn -- for non-head revisions, a list of parsed instructions + in one of two forms, in both cases START meaning \"first + go to line START\": + - `(START k COUNT)' -- kill COUNT lines + - `(START i TEXT)' -- insert TEXT (a string) + The list is in descending order by START. + +The `:insn' key is a keyword to distinguish it as a vc-rcs.el extension." + (setq buffer (get-buffer (or buffer (current-buffer)))) + (set-buffer buffer) + ;; An RCS masterfile can be viewed as containing four regular (for the + ;; most part) sections: (a) the "headers", (b) the "rev headers", (c) + ;; the "description" and (d) the "rev bodies", in that order. In the + ;; returned alist (see docstring), elements from (b) and (d) are + ;; combined pairwise to form the "revisions", while those from (a) and + ;; (c) are simply combined to form the "headers". + ;; + ;; Loosely speaking, each section contains a series of alternating + ;; "tags" and "printed representations". In the (b) and (d), many + ;; such series can appear, and a revision number on a line by itself + ;; precedes the series of tags and printed representations associated + ;; with it. + ;; + ;; In (a) and (b), the printed representations (with the exception of + ;; the `comment' tag in the headers) terminate with a semicolon, which + ;; is NOT part of the "value" finally associated with the tag. All + ;; other printed representations are in "@@-format"; there is an "@", + ;; the middle part (to be translated into the value), another "@" and + ;; a newline. Each "@@" in the middle part indicates the position of + ;; a single "@" (and consequently the requirement of an additional + ;; initial step when translating to the value). + ;; + ;; Parser state includes vars that collect parts of the return value... + (let ((desc nil) (headers nil) (revs nil) + ;; ... as well as vars that support a single-pass, tag-assisted, + ;; minimal-data-copying scan. Basically -- skirting around the + ;; grouping by revision required in (b) and (d) -- we repeatedly + ;; and context-sensitively read a tag (that MUST be present), + ;; determine the bounds of the printed representation, translate + ;; it into a value, and push the tag plus value onto one of the + ;; collection vars. Finally, we return the parse tree + ;; incorporating the values of the collection vars (see "rv"). + ;; + ;; A symbol or string to keep track of context (for error messages). + context + ;; A symbol, the current tag. + tok + ;; Region (begin and end buffer positions) of the printed + ;; representation for the current tag. + b e + ;; A list of buffer positions where "@@" can be found within the + ;; printed representation region. For each location, we push two + ;; elements onto the list, 1+ and 2+ the location, respectively, + ;; with the 2+ appearing at the head. In this way, the expression + ;; `(,e ,@@-holes ,b) + ;; describes regions that can be concatenated (in reverse order) + ;; to "de-@@-format" the printed representation as the first step + ;; to translating it into some value. See internal func `gather'. + @-holes) + (flet ((sw () (skip-chars-forward " \t\n")) ; i.e., `[:space:]' + (at (tag) (save-excursion (eq tag (read buffer)))) + (to-eol () (buffer-substring-no-properties + (point) (progn (forward-line 1) + (1- (point))))) + (to-semi () (setq b (point) + e (progn (search-forward ";") + (1- (point))))) + (to-one@ () (setq @-holes nil + b (progn (search-forward "@") (point)) + e (progn (while (and (search-forward "@") + (= ?@ (char-after)) + (progn + (push (point) @-holes) + (forward-char 1) + (push (point) @-holes)))) + (1- (point))))) + (tok+val (set-b+e name &optional proc) + (unless (eq name (setq tok (read buffer))) + (error "Missing `%s' while parsing %s" name context)) + (sw) + (funcall set-b+e) + (cons tok (if proc + (funcall proc) + (buffer-substring-no-properties b e)))) + (k-semi (name &optional proc) (tok+val 'to-semi name proc)) + (gather () (let ((pairs `(,e ,@@-holes ,b)) + acc) + (while pairs + (push (buffer-substring-no-properties + (cadr pairs) (car pairs)) + acc) + (setq pairs (cddr pairs))) + (apply 'concat acc))) + (k-one@ (name &optional later) (tok+val 'to-one@ name + (if later + (lambda () t) + 'gather)))) + (save-excursion + (goto-char (point-min)) + ;; headers + (setq context 'headers) + (flet ((hpush (name &optional proc) + (push (k-semi name proc) headers))) + (hpush 'head) + (when (at 'branch) + (hpush 'branch)) + (hpush 'access) + (hpush 'symbols + (lambda () + (mapcar (lambda (together) + (let ((two (split-string together ":"))) + (setcar two (intern (car two))) + (setcdr two (cadr two)) + two)) + (split-string + (buffer-substring-no-properties b e))))) + (hpush 'locks)) + (push `(strict . ,(when (at 'strict) + (search-forward ";") + t)) + headers) + (when (at 'comment) + (push (k-one@ 'comment) headers) + (search-forward ";")) + (when (at 'expand) + (push (k-one@ 'expand) headers) + (search-forward ";")) + (setq headers (nreverse headers)) + ;; rev headers + (sw) (setq context 'rev-headers) + (while (looking-at "[0-9]") + (push `(,(to-eol) + ,(k-semi 'date + (lambda () + (let ((ls (mapcar 'string-to-number + (split-string + (buffer-substring-no-properties + b e) + "\\.")))) + ;; Hack the year -- verified to be the + ;; same algorithm used in RCS 5.7. + (when (< (car ls) 100) + (setcar ls (+ 1900 (car ls)))) + (apply 'encode-time (nreverse ls))))) + ,@(mapcar 'k-semi '(author state)) + ,(k-semi 'branches + (lambda () + (split-string + (buffer-substring-no-properties b e)))) + ,(k-semi 'next)) + revs) + (sw)) + (setq revs (nreverse revs)) + ;; desc + (sw) (setq context 'desc + desc (k-one@ 'desc)) + ;; rev bodies + (let (acc + ;; Element of `revs' that initially holds only header info. + ;; "Pairwise combination" occurs when we add body info. + rev + ;; Components of the editing commands (aside from the actual + ;; text) that comprise the `text' printed representations + ;; (not including the "head" revision). + cmd start act + ;; Ascending (reversed) `@-holes' which the internal func + ;; `incg' pops to effect incremental gathering. + asc + ;; Function to extract text (for the `a' command), either + ;; `incg' or `buffer-substring-no-properties'. (This is + ;; for speed; strictly speaking, it is sufficient to use + ;; only the former since it behaves identically to the + ;; latter in the absense of "@@".) + sub) + (flet ((incg (beg end) (let ((b beg) (e end) @-holes) + (while (and asc (< (car asc) e)) + (push (pop asc) @-holes)) + ;; Self-deprecate when work is done. + ;; Folding many dimensions into one. + ;; Thanks B.Mandelbrot, for complex sum. + ;; O beauteous math! --the Unvexed Bum + (unless asc + (setq sub 'buffer-substring-no-properties)) + (gather)))) + (while (and (sw) + (not (eobp)) + (setq context (to-eol) + rev (or (assoc context revs) + (error "Rev `%s' has body but no head" + context)))) + (push (k-one@ 'log) (cdr rev)) + ;; For rev body `text' tags, delay translation slightly... + (push (k-one@ 'text t) (cdr rev)) + ;; ... until we decide which tag and value is appropriate to + ;; collect. For the "head" revision, compute the value of the + ;; `text' printed representation by simple `gather'. For all + ;; other revisions, replace the `text' tag+value with `:insn' + ;; plus value, always scanning in-place. + (if (string= context (cdr (assq 'head headers))) + (setcdr (cadr rev) (gather)) + (if @-holes + (setq asc (nreverse @-holes) + sub 'incg) + (setq sub 'buffer-substring-no-properties)) + (goto-char b) + (setq acc nil) + (while (< (point) e) + (forward-char 1) + (setq cmd (char-before) + start (read (current-buffer)) + act (read (current-buffer))) + (forward-char 1) + (push (case cmd + (?d + ;; `d' means "delete lines". + ;; For Emacs spirit, we use `k' for "kill". + `(,start k ,act)) + (?a + ;; `a' means "append after this line" but + ;; internally we normalize it so that START + ;; specifies the actual line for insert, thus + ;; requiring less hair in the realization algs. + ;; For Emacs spirit, we use `i' for "insert". + `(,(1+ start) i + ,(funcall sub (point) (progn (forward-line act) + (point))))) + (t (error "Bad command `%c' in `text' for rev `%s'" + cmd context))) + acc)) + (goto-char (1+ e)) + (setcar (cdr rev) (cons :insn acc))))))) + ;; rv + `((headers ,desc ,@headers) + (revisions ,@revs))))) + +(provide 'vc-rcs) + +;; arch-tag: 759b4916-5b0d-431d-b647-b185b8c652cf +;;; vc-rcs.el ends here diff --cc lisp/vc/vc-sccs.el index 2acd778881a,00000000000..f717ed0962b mode 100644,000000..100644 --- a/lisp/vc/vc-sccs.el +++ b/lisp/vc/vc-sccs.el @@@ -1,487 -1,0 +1,487 @@@ +;;; 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 ++;; 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 +;; 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 . + +;;; 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) + + +;;; +;;; Internal variables +;;; + +(defconst vc-sccs-name-assoc-file "VC-names") + + +;;; Properties of the backend + +(defun vc-sccs-revision-granularity () 'file) +(defun vc-sccs-checkout-model (files) 'locking) + +;;; +;;; State-querying functions +;;; + +;; The autoload cookie below places vc-sccs-registered directly into +;; loaddefs.el, so that vc-sccs.el does not need to be loaded for +;; every file that is visited. The definition is repeated below +;; so that Help and etags can find it. + +;;;###autoload (defun vc-sccs-registered(f) (vc-default-registered 'SCCS f)) +(defun vc-sccs-registered (f) (vc-default-registered 'SCCS f)) + +(defun vc-sccs-state (file) + "SCCS-specific function to compute the version control state." + (if (not (vc-sccs-registered file)) + 'unregistered + (with-temp-buffer + (if (vc-insert-file (vc-sccs-lock-file file)) + (let* ((locks (vc-sccs-parse-locks)) + (working-revision (vc-working-revision file)) + (locking-user (cdr (assoc working-revision locks)))) + (if (not locking-user) + (if (vc-workfile-unchanged-p file) + 'up-to-date + 'unlocked-changes) + (if (string= locking-user (vc-user-login-name file)) + 'edited + locking-user))) + 'up-to-date)))) + +(defun vc-sccs-state-heuristic (file) + "SCCS-specific state heuristic." + (if (not (vc-mistrust-permissions file)) + ;; This implementation assumes that any file which is under version + ;; control and has -rw-r--r-- is locked by its owner. This is true + ;; for both RCS and SCCS, which keep unlocked files at -r--r--r--. + ;; We have to be careful not to exclude files with execute bits on; + ;; scripts can be under version control too. Also, we must ignore the + ;; group-read and other-read bits, since paranoid users turn them off. + (let* ((attributes (file-attributes file 'string)) + (owner-name (nth 2 attributes)) + (permissions (nth 8 attributes))) + (if (string-match ".r-..-..-." permissions) + 'up-to-date + (if (string-match ".rw..-..-." permissions) + (if (file-ownership-preserved-p file) + 'edited + owner-name) + ;; Strange permissions. + ;; Fall through to real state computation. + (vc-sccs-state file)))) + (vc-sccs-state file))) + +(defun vc-sccs-dir-status (dir update-function) + ;; FIXME: this function should be rewritten, using `vc-expand-dirs' + ;; is not TRTD because it returns files from multiple backends. + ;; It should also return 'unregistered files. + + ;; Doing lots of individual VC-state calls is painful, but + ;; there is no better option in SCCS-land. + (let ((flist (vc-expand-dirs (list dir))) + (result nil)) + (dolist (file flist) + (let ((state (vc-state file)) + (frel (file-relative-name file))) + (when (and (eq (vc-backend file) 'SCCS) + (not (eq state 'up-to-date))) + (push (list frel state) result)))) + (funcall update-function result))) + +(defun vc-sccs-working-revision (file) + "SCCS-specific version of `vc-working-revision'." + (with-temp-buffer + ;; The working revision is always the latest revision number. + ;; To find this number, search the entire delta table, + ;; rather than just the first entry, because the + ;; first entry might be a deleted ("R") revision. + (vc-insert-file (vc-name file) "^\001e\n\001[^s]") + (vc-parse-buffer "^\001d D \\([^ ]+\\)" 1))) + +(defun vc-sccs-workfile-unchanged-p (file) + "SCCS-specific implementation of `vc-workfile-unchanged-p'." + (zerop (apply 'vc-do-command "*vc*" 1 "vcdiff" (vc-name file) + (list "--brief" "-q" + (concat "-r" (vc-working-revision file)))))) + + +;;; +;;; State-changing functions +;;; + +(defun vc-sccs-do-command (buffer okstatus command file-or-list &rest flags) + ;; (let ((load-path (append vc-sccs-path load-path))) + ;; (apply 'vc-do-command buffer okstatus command file-or-list flags)) + (apply 'vc-do-command (or buffer "*vc*") okstatus "sccs" file-or-list command flags)) + +(defun vc-sccs-create-repo () + "Create a new SCCS repository." + ;; SCCS is totally file-oriented, so all we have to do is make the directory + (make-directory "SCCS")) + +(defun vc-sccs-register (files &optional rev comment) + "Register FILES into the SCCS version-control system. +REV is the optional revision number for the file. COMMENT can be used +to provide an initial description of FILES. +Passes either `vc-sccs-register-switches' or `vc-register-switches' +to the SCCS command. + +Automatically retrieve a read-only version of the files with keywords +expanded if `vc-keep-workfiles' is non-nil, otherwise, delete the workfile." + (dolist (file files) + (let* ((dirname (or (file-name-directory file) "")) + (basename (file-name-nondirectory file)) + (project-file (vc-sccs-search-project-dir dirname basename))) + (let ((vc-name + (or project-file + (format (car vc-sccs-master-templates) dirname basename)))) + (apply 'vc-sccs-do-command nil 0 "admin" vc-name + (and rev (not (string= rev "")) (concat "-r" rev)) + "-fb" + (concat "-i" (file-relative-name file)) + (and comment (concat "-y" comment)) + (vc-switches 'SCCS 'register))) + (delete-file file) + (if vc-keep-workfiles + (vc-sccs-do-command nil 0 "get" (vc-name file)))))) + +(defun vc-sccs-responsible-p (file) + "Return non-nil if SCCS thinks it would be responsible for registering FILE." + ;; TODO: check for all the patterns in vc-sccs-master-templates + (or (file-directory-p (expand-file-name "SCCS" (file-name-directory file))) + (stringp (vc-sccs-search-project-dir (or (file-name-directory file) "") + (file-name-nondirectory file))))) + +(defun vc-sccs-checkin (files rev comment) + "SCCS-specific version of `vc-backend-checkin'." + (dolist (file (vc-expand-dirs files)) + (apply 'vc-sccs-do-command nil 0 "delta" (vc-name file) + (if rev (concat "-r" rev)) + (concat "-y" comment) + (vc-switches 'SCCS 'checkin)) + (if vc-keep-workfiles + (vc-sccs-do-command nil 0 "get" (vc-name file))))) + +(defun vc-sccs-find-revision (file rev buffer) + (apply 'vc-sccs-do-command + buffer 0 "get" (vc-name file) + "-s" ;; suppress diagnostic output + "-p" + (and rev + (concat "-r" + (vc-sccs-lookup-triple file rev))) + (vc-switches 'SCCS 'checkout))) + +(defun vc-sccs-checkout (file &optional editable rev) + "Retrieve a copy of a saved revision of SCCS controlled FILE. +If FILE is a directory, all version-controlled files beneath are checked out. +EDITABLE non-nil means that the file should be writable and +locked. REV is the revision to check out." + (if (file-directory-p file) + (mapc 'vc-sccs-checkout (vc-expand-dirs (list file))) + (let ((file-buffer (get-file-buffer file)) + switches) + (message "Checking out %s..." file) + (save-excursion + ;; Change buffers to get local value of vc-checkout-switches. + (if file-buffer (set-buffer file-buffer)) + (setq switches (vc-switches 'SCCS 'checkout)) + ;; Save this buffer's default-directory + ;; and use save-excursion to make sure it is restored + ;; in the same buffer it was saved in. + (let ((default-directory default-directory)) + (save-excursion + ;; Adjust the default-directory so that the check-out creates + ;; the file in the right place. + (setq default-directory (file-name-directory file)) + + (and rev (or (string= rev "") + (not (stringp rev))) + (setq rev nil)) + (apply 'vc-sccs-do-command nil 0 "get" (vc-name file) + (if editable "-e") + (and rev (concat "-r" (vc-sccs-lookup-triple file rev))) + switches)))) + (message "Checking out %s...done" file)))) + +(defun vc-sccs-rollback (files) + "Roll back, undoing the most recent checkins of FILES. Directories +are expanded to all version-controlled subfiles." + (setq files (vc-expand-dirs files)) + (if (not files) + (error "SCCS backend doesn't support directory-level rollback")) + (dolist (file files) + (let ((discard (vc-working-revision file))) + (if (null (yes-or-no-p (format "Remove version %s from %s history? " + discard file))) + (error "Aborted")) + (message "Removing revision %s from %s..." discard file) + (vc-sccs-do-command nil 0 "rmdel" + (vc-name file) (concat "-r" discard)) + (vc-sccs-do-command nil 0 "get" (vc-name file) nil)))) + +(defun vc-sccs-revert (file &optional contents-done) + "Revert FILE to the version it was based on. If FILE is a directory, +revert all subfiles." + (if (file-directory-p file) + (mapc 'vc-sccs-revert (vc-expand-dirs (list file))) + (vc-sccs-do-command nil 0 "unget" (vc-name file)) + (vc-sccs-do-command nil 0 "get" (vc-name file)) + ;; Checking out explicit revisions is not supported under SCCS, yet. + ;; We always "revert" to the latest revision; therefore + ;; vc-working-revision is cleared here so that it gets recomputed. + (vc-file-setprop file 'vc-working-revision nil))) + +(defun vc-sccs-steal-lock (file &optional rev) + "Steal the lock on the current workfile for FILE and revision REV." + (if (file-directory-p file) + (mapc 'vc-sccs-steal-lock (vc-expand-dirs (list file))) + (vc-sccs-do-command nil 0 "unget" + (vc-name file) "-n" (if rev (concat "-r" rev))) + (vc-sccs-do-command nil 0 "get" + (vc-name file) "-g" (if rev (concat "-r" rev))))) + +(defun vc-sccs-modify-change-comment (files rev comment) + "Modify (actually, append to) the change comments for FILES on a specified REV." + (dolist (file (vc-expand-dirs files)) + (vc-sccs-do-command nil 0 "cdc" (vc-name file) + (concat "-y" comment) (concat "-r" rev)))) + + +;;; +;;; History functions +;;; + +(defun vc-sccs-print-log (files buffer &optional shortlog start-revision-ignored limit) + "Get change log associated with FILES." + (setq files (vc-expand-dirs files)) + (vc-sccs-do-command buffer 0 "prs" (mapcar 'vc-name files)) + (when limit 'limit-unsupported)) + +(defun vc-sccs-diff (files &optional oldvers newvers buffer) + "Get a difference report using SCCS between two filesets." + (setq files (vc-expand-dirs files)) + (setq oldvers (vc-sccs-lookup-triple (car files) oldvers)) + (setq newvers (vc-sccs-lookup-triple (car files) newvers)) + (apply 'vc-do-command (or buffer "*vc-diff*") + 1 "vcdiff" (mapcar 'vc-name (vc-expand-dirs files)) + (append (list "-q" + (and oldvers (concat "-r" oldvers)) + (and newvers (concat "-r" newvers))) + (vc-switches 'SCCS 'diff)))) + + +;;; +;;; Tag system. SCCS doesn't have tags, so we simulate them by maintaining +;;; our own set of name-to-revision mappings. +;;; + +(defun vc-sccs-create-tag (backend dir name branchp) + (when branchp + (error "SCCS backend %s does not support module branches" backend)) + (let ((result (vc-tag-precondition dir))) + (if (stringp result) + (error "File %s is not up-to-date" result) + (vc-file-tree-walk + dir + (lambda (f) + (vc-sccs-add-triple name f (vc-working-revision f))))))) + + +;;; +;;; Miscellaneous +;;; + +(defun vc-sccs-previous-revision (file rev) + (vc-call-backend 'RCS 'previous-revision file rev)) + +(defun vc-sccs-next-revision (file rev) + (vc-call-backend 'RCS 'next-revision file rev)) + +(defun vc-sccs-check-headers () + "Check if the current file has any headers in it." + (save-excursion + (goto-char (point-min)) + (re-search-forward "%[A-Z]%" nil t))) + +(defun vc-sccs-rename-file (old new) + ;; Move the master file (using vc-rcs-master-templates). + (vc-rename-master (vc-name old) new vc-sccs-master-templates) + ;; Update the tag file. + (with-current-buffer + (find-file-noselect + (expand-file-name vc-sccs-name-assoc-file + (file-name-directory (vc-name old)))) + (goto-char (point-min)) + ;; (replace-regexp (concat ":" (regexp-quote old) "$") (concat ":" new)) + (while (re-search-forward (concat ":" (regexp-quote old) "$") nil t) + (replace-match (concat ":" new) nil nil)) + (basic-save-buffer) + (kill-buffer (current-buffer)))) + +(defun vc-sccs-find-file-hook () + ;; If the file is locked by some other user, make + ;; the buffer read-only. Like this, even root + ;; cannot modify a file that someone else has locked. + (and (stringp (vc-state buffer-file-name 'SCCS)) + (setq buffer-read-only t))) + + +;;; +;;; Internal functions +;;; + +;; This function is wrapped with `progn' so that the autoload cookie +;; copies the whole function itself into loaddefs.el rather than just placing +;; a (autoload 'vc-sccs-search-project-dir "vc-sccs") which would not +;; help us avoid loading vc-sccs. +;;;###autoload +(progn (defun vc-sccs-search-project-dir (dirname basename) + "Return the name of a master file in the SCCS project directory. +Does not check whether the file exists but returns nil if it does not +find any project directory." + (let ((project-dir (getenv "PROJECTDIR")) dirs dir) + (when project-dir + (if (file-name-absolute-p project-dir) + (setq dirs '("SCCS" "")) + (setq dirs '("src/SCCS" "src" "source/SCCS" "source")) + (setq project-dir (expand-file-name (concat "~" project-dir)))) + (while (and (not dir) dirs) + (setq dir (expand-file-name (car dirs) project-dir)) + (unless (file-directory-p dir) + (setq dir nil) + (setq dirs (cdr dirs)))) + (and dir (expand-file-name (concat "s." basename) dir)))))) + +(defun vc-sccs-lock-file (file) + "Generate lock file name corresponding to FILE." + (let ((master (vc-name file))) + (and + master + (string-match "\\(.*/\\)\\(s\\.\\)\\(.*\\)" master) + (replace-match "p." t t master 2)))) + +(defun vc-sccs-parse-locks () + "Parse SCCS locks in current buffer. +The result is a list of the form ((REVISION . USER) (REVISION . USER) ...)." + (let (master-locks) + (goto-char (point-min)) + (while (re-search-forward "^\\([0-9.]+\\) [0-9.]+ \\([^ ]+\\) .*\n?" + nil t) + (setq master-locks + (cons (cons (match-string 1) (match-string 2)) master-locks))) + ;; FIXME: is it really necessary to reverse ? + (nreverse master-locks))) + +(defun vc-sccs-add-triple (name file rev) + (with-current-buffer + (find-file-noselect + (expand-file-name vc-sccs-name-assoc-file + (file-name-directory (vc-name file)))) + (goto-char (point-max)) + (insert name "\t:\t" file "\t" rev "\n") + (basic-save-buffer) + (kill-buffer (current-buffer)))) + +(defun vc-sccs-lookup-triple (file name) + "Return the numeric revision corresponding to a named tag of FILE. +If NAME is nil or a revision number string it's just passed through." + (if (or (null name) + (let ((firstchar (aref name 0))) + (and (>= firstchar ?0) (<= firstchar ?9)))) + name + (with-temp-buffer + (vc-insert-file + (expand-file-name vc-sccs-name-assoc-file + (file-name-directory (vc-name file)))) + (vc-parse-buffer (concat name "\t:\t" file "\t\\(.+\\)") 1)))) + +(provide 'vc-sccs) + +;; arch-tag: d751dee3-d7b3-47e1-95e3-7ae98c052041 +;;; vc-sccs.el ends here diff --cc lisp/vc/vc-svn.el index 3e4c299f096,00000000000..635cb14bd8d mode 100644,000000..100644 --- a/lisp/vc/vc-svn.el +++ b/lisp/vc/vc-svn.el @@@ -1,748 -1,0 +1,748 @@@ +;;; vc-svn.el --- non-resident support for Subversion version-control + - ;; Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 ++;; 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 +;; 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 . + +;;; 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 diff --cc lisp/vc/vc.el index 40f91b70757,00000000000..d243cb1ce5b mode 100644,000000..100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@@ -1,2779 -1,0 +1,2779 @@@ +;;; 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 ++;; 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 +;; Keywords: vc tools + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Credits: + +;; VC was initially designed and implemented by Eric S. Raymond +;; in 1992. Over the years, many other people have +;; contributed substantial amounts of work to VC. These include: +;; +;; Per Cederqvist +;; Paul Eggert +;; Sebastian Kremer +;; Martin Lorentzson +;; Dave Love +;; Stefan Monnier +;; Thien-Thi Nguyen +;; Dan Nicolaescu +;; J.D. Smith +;; Andre Spiegel +;; Richard Stallman +;; +;; In July 2007 ESR returned and redesigned the mode to cope better +;; with modern version-control systems that do commits by fileset +;; rather than per individual file. +;; +;; If you maintain a client of the mode or customize it in your .emacs, +;; note that some backend functions which formerly took single file arguments +;; now take a list of files. These include: register, checkin, print-log, +;; rollback, and diff. + +;;; Commentary: + +;; This mode is fully documented in the Emacs user's manual. +;; +;; Supported version-control systems presently include CVS, RCS, GNU +;; Arch, Subversion, Bzr, Git, Mercurial, Monotone and SCCS +;; (or its free replacement, CSSC). +;; +;; If your site uses the ChangeLog convention supported by Emacs, the +;; function `log-edit-comment-to-change-log' could prove a useful checkin hook, +;; although you might prefer to use C-c C-a (i.e. `log-edit-insert-changelog') +;; from the commit buffer instead or to set `log-edit-setup-invert'. +;; +;; When using SCCS, RCS, CVS: be careful not to do repo surgery, or +;; operations like registrations and deletions and renames, outside VC +;; while VC is running. The support for these systems was designed +;; when disks were much slower, and the code maintains a lot of +;; internal state in order to reduce expensive operations to a +;; minimum. Thus, if you mess with the repo while VC's back is turned, +;; VC may get seriously confused. +;; +;; When using Subversion or a later system, anything you do outside VC +;; *through the VCS tools* should safely interlock with VC +;; operations. Under these VC does little state caching, because local +;; operations are assumed to be fast. The dividing line is +;; +;; ADDING SUPPORT FOR OTHER BACKENDS +;; +;; VC can use arbitrary version control systems as a backend. To add +;; support for a new backend named SYS, write a library vc-sys.el that +;; contains functions of the form `vc-sys-...' (note that SYS is in lower +;; case for the function and library names). VC will use that library if +;; you put the symbol SYS somewhere into the list of +;; `vc-handled-backends'. Then, for example, if `vc-sys-registered' +;; returns non-nil for a file, all SYS-specific versions of VC commands +;; will be available for that file. +;; +;; VC keeps some per-file information in the form of properties (see +;; vc-file-set/getprop in vc-hooks.el). The backend-specific functions +;; do not generally need to be aware of these properties. For example, +;; `vc-sys-working-revision' should compute the working revision and +;; return it; it should not look it up in the property, and it needn't +;; store it there either. However, if a backend-specific function does +;; store a value in a property, that value takes precedence over any +;; value that the generic code might want to set (check for uses of +;; the macro `with-vc-properties' in vc.el). +;; +;; In the list of functions below, each identifier needs to be prepended +;; with `vc-sys-'. Some of the functions are mandatory (marked with a +;; `*'), others are optional (`-'). + +;; BACKEND PROPERTIES +;; +;; * revision-granularity +;; +;; Takes no arguments. Returns either 'file or 'repository. Backends +;; that return 'file have per-file revision numbering; backends +;; that return 'repository have per-repository revision numbering, +;; so a revision level implicitly identifies a changeset + +;; STATE-QUERYING FUNCTIONS +;; +;; * registered (file) +;; +;; Return non-nil if FILE is registered in this backend. Both this +;; function as well as `state' should be careful to fail gracefully +;; in the event that the backend executable is absent. It is +;; preferable that this function's body is autoloaded, that way only +;; calling vc-registered does not cause the backend to be loaded +;; (all the vc-FOO-registered functions are called to try to find +;; the controlling backend for FILE. +;; +;; * state (file) +;; +;; Return the current version control state of FILE. For a list of +;; possible values, see `vc-state'. This function should do a full and +;; reliable state computation; it is usually called immediately after +;; C-x v v. If you want to use a faster heuristic when visiting a +;; file, put that into `state-heuristic' below. Note that under most +;; VCSes this won't be called at all, dir-status is used instead. +;; +;; - state-heuristic (file) +;; +;; If provided, this function is used to estimate the version control +;; state of FILE at visiting time. It should be considerably faster +;; than the implementation of `state'. For a list of possible values, +;; see the doc string of `vc-state'. +;; +;; - dir-status (dir update-function) +;; +;; Produce RESULT: a list of lists of the form (FILE VC-STATE EXTRA) +;; for the files in DIR. +;; EXTRA can be used for backend specific information about FILE. +;; If a command needs to be run to compute this list, it should be +;; run asynchronously using (current-buffer) as the buffer for the +;; command. When RESULT is computed, it should be passed back by +;; doing: (funcall UPDATE-FUNCTION RESULT nil). +;; If the backend uses a process filter, hence it produces partial results, +;; they can be passed back by doing: +;; (funcall UPDATE-FUNCTION RESULT t) +;; and then do a (funcall UPDATE-FUNCTION RESULT nil) +;; when all the results have been computed. +;; To provide more backend specific functionality for `vc-dir' +;; the following functions might be needed: `dir-extra-headers', +;; `dir-printer', `extra-dir-menu' and `dir-status-files'. +;; +;; - dir-status-files (dir files default-state update-function) +;; +;; This function is identical to dir-status except that it should +;; only report status for the specified FILES. Also it needs to +;; report on all requested files, including up-to-date or ignored +;; files. If not provided, the default is to consider that the files +;; are in DEFAULT-STATE. +;; +;; - dir-extra-headers (dir) +;; +;; Return a string that will be added to the *vc-dir* buffer header. +;; +;; - dir-printer (fileinfo) +;; +;; Pretty print the `vc-dir-fileinfo' FILEINFO. +;; If a backend needs to show more information than the default FILE +;; and STATE in the vc-dir listing, it can store that extra +;; information in `vc-dir-fileinfo->extra'. This function can be +;; used to display that extra information in the *vc-dir* buffer. +;; +;; - status-fileinfo-extra (file) +;; +;; Compute `vc-dir-fileinfo->extra' for FILE. +;; +;; * working-revision (file) +;; +;; Return the working revision of FILE. This is the revision fetched +;; by the last checkout or upate, not necessarily the same thing as the +;; head or tip revision. Should return "0" for a file added but not yet +;; committed. +;; +;; - latest-on-branch-p (file) +;; +;; Return non-nil if the working revision of FILE is the latest revision +;; on its branch (many VCSes call this the 'tip' or 'head' revision). +;; The default implementation always returns t, which means that +;; working with non-current revisions is not supported by default. +;; +;; * checkout-model (files) +;; +;; Indicate whether FILES need to be "checked out" before they can be +;; edited. See `vc-checkout-model' for a list of possible values. +;; +;; - workfile-unchanged-p (file) +;; +;; Return non-nil if FILE is unchanged from the working revision. +;; This function should do a brief comparison of FILE's contents +;; with those of the repository copy of the working revision. If +;; the backend does not have such a brief-comparison feature, the +;; default implementation of this function can be used, which +;; delegates to a full vc-BACKEND-diff. (Note that vc-BACKEND-diff +;; must not run asynchronously in this case, see variable +;; `vc-disable-async-diff'.) +;; +;; - mode-line-string (file) +;; +;; If provided, this function should return the VC-specific mode +;; line string for FILE. The returned string should have a +;; `help-echo' property which is the text to be displayed as a +;; tooltip when the mouse hovers over the VC entry on the mode-line. +;; The default implementation deals well with all states that +;; `vc-state' can return. +;; +;; STATE-CHANGING FUNCTIONS +;; +;; * create-repo (backend) +;; +;; Create an empty repository in the current directory and initialize +;; it so VC mode can add files to it. For file-oriented systems, this +;; need do no more than create a subdirectory with the right name. +;; +;; * register (files &optional rev comment) +;; +;; Register FILES in this backend. Optionally, an initial revision REV +;; and an initial description of the file, COMMENT, may be specified, +;; but it is not guaranteed that the backend will do anything with this. +;; The implementation should pass the value of vc-register-switches +;; to the backend command. (Note: in older versions of VC, this +;; command took a single file argument and not a list.) +;; +;; - init-revision (file) +;; +;; The initial revision to use when registering FILE if one is not +;; specified by the user. If not provided, the variable +;; vc-default-init-revision is used instead. +;; +;; - responsible-p (file) +;; +;; Return non-nil if this backend considers itself "responsible" for +;; FILE, which can also be a directory. This function is used to find +;; out what backend to use for registration of new files and for things +;; like change log generation. The default implementation always +;; returns nil. +;; +;; - could-register (file) +;; +;; Return non-nil if FILE could be registered under this backend. The +;; default implementation always returns t. +;; +;; - receive-file (file rev) +;; +;; Let this backend "receive" a file that is already registered under +;; another backend. The default implementation simply calls `register' +;; for FILE, but it can be overridden to do something more specific, +;; e.g. keep revision numbers consistent or choose editing modes for +;; FILE that resemble those of the other backend. +;; +;; - unregister (file) +;; +;; Unregister FILE from this backend. This is only needed if this +;; backend may be used as a "more local" backend for temporary editing. +;; +;; * checkin (files rev comment) +;; +;; Commit changes in FILES to this backend. REV is a historical artifact +;; and should be ignored. COMMENT is used as a check-in comment. +;; The implementation should pass the value of vc-checkin-switches to +;; the backend command. +;; +;; * find-revision (file rev buffer) +;; +;; Fetch revision REV of file FILE and put it into BUFFER. +;; If REV is the empty string, fetch the head of the trunk. +;; The implementation should pass the value of vc-checkout-switches +;; to the backend command. +;; +;; * checkout (file &optional editable rev) +;; +;; Check out revision REV of FILE into the working area. If EDITABLE +;; is non-nil, FILE should be writable by the user and if locking is +;; used for FILE, a lock should also be set. If REV is non-nil, that +;; is the revision to check out (default is the working revision). +;; If REV is t, that means to check out the head of the current branch; +;; if it is the empty string, check out the head of the trunk. +;; The implementation should pass the value of vc-checkout-switches +;; to the backend command. +;; +;; * revert (file &optional contents-done) +;; +;; Revert FILE back to the working revision. If optional +;; arg CONTENTS-DONE is non-nil, then the contents of FILE have +;; already been reverted from a version backup, and this function +;; only needs to update the status of FILE within the backend. +;; If FILE is in the `added' state it should be returned to the +;; `unregistered' state. +;; +;; - rollback (files) +;; +;; Remove the tip revision of each of FILES from the repository. If +;; this function is not provided, trying to cancel a revision is +;; caught as an error. (Most backends don't provide it.) (Also +;; note that older versions of this backend command were called +;; 'cancel-version' and took a single file arg, not a list of +;; files.) +;; +;; - merge (file rev1 rev2) +;; +;; Merge the changes between REV1 and REV2 into the current working file +;; (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") + + +;; 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)) + + + +;; These things should probably be generally available + +(defun vc-string-prefix-p (prefix string) + (let ((lpref (length prefix))) + (and (>= (length string) lpref) + (eq t (compare-strings prefix nil nil string nil lpref))))) + +(defun vc-file-tree-walk (dirname func &rest args) + "Walk recursively through DIRNAME. +Invoke FUNC f ARGS on each VC-managed file f underneath it." + (vc-file-tree-walk-internal (expand-file-name dirname) func args) + (message "Traversing directory %s...done" dirname)) + +(defun vc-file-tree-walk-internal (file func args) + (if (not (file-directory-p file)) + (when (vc-backend file) (apply func file args)) + (message "Traversing directory %s..." (abbreviate-file-name file)) + (let ((dir (file-name-as-directory file))) + (mapcar + (lambda (f) (or + (string-equal f ".") + (string-equal f "..") + (member f vc-directory-exclusion-list) + (let ((dirf (expand-file-name f dir))) + (or + (file-symlink-p dirf) ;; Avoid possible loops. + (vc-file-tree-walk-internal dirf func args))))) + (directory-files dir))))) + +(provide 'vc) + +;; arch-tag: ca82c1de-3091-4e26-af92-460abc6213a6 +;;; vc.el ends here diff --cc make-dist index 3d610c1eee6,2fb443dfee6..88a307d7ca1 --- a/make-dist +++ b/make-dist @@@ -1,32 -1,29 +1,32 @@@ #!/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 . +## You should have received a copy of the GNU General Public License +## along with GNU Emacs. If not, see . +### 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" diff --cc nextstep/ChangeLog index 26d22b4c90e,5d2f1fe6f2a..84925209c15 --- a/nextstep/ChangeLog +++ b/nextstep/ChangeLog @@@ -195,9 -178,10 +195,9 @@@ ;; 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. diff --cc nt/INSTALL index ada4b6a8bbe,6de3ad29835..c051e5ca72b --- a/nt/INSTALL +++ b/nt/INSTALL @@@ -1,7 -1,7 +1,7 @@@ - 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. diff --cc nt/README.W32 index ffe9b9ea9f0,00000000000..e9e9d00aea3 mode 100644,000000..100644 --- a/nt/README.W32 +++ b/nt/README.W32 @@@ -1,269 -1,0 +1,269 @@@ - 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! + + +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 . diff --cc nt/config.nt index 92e466d185a,47881cb4267..8a203372936 --- a/nt/config.nt +++ b/nt/config.nt @@@ -1,7 -1,6 +1,7 @@@ /* 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. diff --cc nt/configure.bat index 410087687bd,ff1d84abc51..9dc0e6da5b6 --- a/nt/configure.bat +++ b/nt/configure.bat @@@ -1,8 -1,8 +1,8 @@@ @echo off rem ---------------------------------------------------------------------- -rem Configuration script for MS Windows 95/98/Me and NT/2000/XP +rem Configuration script for MS Windows operating systems rem Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, - rem 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. + rem 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. rem This file is part of GNU Emacs. diff --cc nt/emacs.rc index 253065b47c4,5cb2d3516d9..9a71935f251 --- a/nt/emacs.rc +++ b/nt/emacs.rc @@@ -25,12 -25,12 +25,12 @@@ BEGI 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 diff --cc nt/emacsclient.rc index 98f0bcd4f84,a5dc2d91915..27ee1437989 --- a/nt/emacsclient.rc +++ b/nt/emacsclient.rc @@@ -23,12 -23,12 +23,12 @@@ BEGI 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 diff --cc nt/preprep.c index 220b0e40ce6,142d64dfe57..285ff69b6db --- a/nt/preprep.c +++ b/nt/preprep.c @@@ -1,6 -1,6 +1,6 @@@ -/* 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. diff --cc src/ChangeLog index a8755321a4d,f947b5aeef6..f473da74811 --- a/src/ChangeLog +++ b/src/ChangeLog @@@ -1,85 -1,3 +1,91 @@@ ++2011-01-14 Eli Zaretskii ++ ++ * image.c (png_jmpbuf): Remove definition. ++ (my_png_error, png_load): Don't use png_jmpbuf. ++ ++2011-01-14 Eli Zaretskii +2011-01-11 Tassilo Horn + + * 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 + + * 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 + + * 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 + + * gtkutil.c (update_frame_tool_bar): Don't advance tool-bar index + when removing extra buttons. + +2011-01-08 Chong Yidong + + * fns.c (Fyes_or_no_p): Doc fix. + +2011-01-08 Andreas Schwab + + * fns.c (Fyes_or_no_p): Add usage. + +2011-01-08 Glenn Morris + + * makefile.w32-in ($(EMACS)): + * Makefile.in (emacs$(EXEEXT)): -batch implies -q. + + * xdisp.c (syms_of_xdisp) : Move from here... + * emacs.c (syms_of_emacs) : ...to here. + +2011-01-07 Andreas Schwab + + * image.c (imagemagick_load_image): Fix some resource leaks and + error handling. + +2011-01-07 Chong Yidong + + * fns.c (Fyes_or_no_p): Accept format string args. + +2011-01-07 Glenn Morris + + * 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 + + * alloc.c (mark_stack): Use __builtin_unwind_init if available. + +2011-01-04 Jan Moringen + + * dbusbind.c (Fdbus_register_method): Added optional parameter + dont_register_service. Updated docstring accordingly. + +2011-01-04 Glenn Morris + + * emacs.c (emacs_copyright): Update short copyright year to 2011. + 2011-01-03 Eli Zaretskii * image.c (png_jmpbuf): Remove definition. @@@ -29502,10 -22541,10 +29508,9 @@@ See ChangeLog.10 for earlier changes ;; 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. diff --cc src/Makefile.in index 0f85428b88c,e92f2bb3b85..57d76fc7568 --- a/src/Makefile.in +++ b/src/Makefile.in @@@ -1,8 -1,7 +1,8 @@@ -# 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. diff --cc src/m/alpha.h index 0e7d182fee7,e43d3cbd398..d6d4202cb3b --- a/src/m/alpha.h +++ b/src/m/alpha.h @@@ -1,7 -1,6 +1,7 @@@ /* 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) diff --cc src/m/ibms390.h index 1a19f7233a0,77e463ad318..eef6c75b150 --- a/src/m/ibms390.h +++ b/src/m/ibms390.h @@@ -1,7 -1,6 +1,7 @@@ -/* 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. diff --cc src/m/ibms390x.h index 2ef14a22945,b91b2fe5749..467526fe0c6 --- a/src/m/ibms390x.h +++ b/src/m/ibms390x.h @@@ -1,7 -1,6 +1,7 @@@ -/* 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. diff --cc src/m/m68k.h index df930d511f7,43094f1c399..6a516ca3a50 --- a/src/m/m68k.h +++ b/src/m/m68k.h @@@ -1,7 -1,6 +1,7 @@@ /* 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. diff --cc src/m/template.h index 0d8e78622a6,4eb4fbe5afa..cae95a802b3 --- a/src/m/template.h +++ b/src/m/template.h @@@ -1,7 -1,6 +1,7 @@@ /* 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. diff --cc src/m/vax.h index 16e790a2769,4f70dd1770f..39550a42fe4 --- a/src/m/vax.h +++ b/src/m/vax.h @@@ -1,7 -1,6 +1,7 @@@ /* 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. diff --cc src/s/cygwin.h index 157ef72f550,27ca8813584..774ef3a9ab5 --- a/src/s/cygwin.h +++ b/src/s/cygwin.h @@@ -1,7 -1,6 +1,7 @@@ /* 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. diff --cc src/s/freebsd.h index cfed343d6c5,bbcbaa667fa..99dc050bfae --- a/src/s/freebsd.h +++ b/src/s/freebsd.h @@@ -1,8 -1,9 +1,8 @@@ /* 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) diff --cc src/s/gnu-linux.h index 9327423b42f,c13cb607a95..9c37b8eec03 --- a/src/s/gnu-linux.h +++ b/src/s/gnu-linux.h @@@ -1,10 -1,7 +1,10 @@@ /* 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 diff --cc src/s/ms-w32.h index 826a02bc60f,2b0a60cfab9..6900cbcc45b --- a/src/s/ms-w32.h +++ b/src/s/ms-w32.h @@@ -1,7 -1,6 +1,7 @@@ /* 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. diff --cc src/s/msdos.h index 8dd8e3cf490,5f76dc77f8a..3bb1dfe03e7 --- a/src/s/msdos.h +++ b/src/s/msdos.h @@@ -1,7 -1,7 +1,7 @@@ /* 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. diff --cc src/s/template.h index eb7ca85c5e5,6ca5ebd6b2b..d6aad17d396 --- a/src/s/template.h +++ b/src/s/template.h @@@ -1,9 -1,8 +1,9 @@@ /* 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. diff --cc src/s/usg5-4-common.h index 4dcb8e50200,00000000000..366d92b95a0 mode 100644,000000..100644 --- a/src/s/usg5-4-common.h +++ b/src/s/usg5-4-common.h @@@ -1,111 -1,0 +1,111 @@@ +/* 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 Free Software Foundation, Inc. ++ 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 . + +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 . */ + +/* 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 . Get to get struct tchars. + But get first to make sure ttold.h doesn't interfere. + And don't try to use SIGIO yet. */ +#include + +#ifdef emacs +#include +#include +#include +#include +#include +#include +#include +#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) */ diff --cc src/unexcoff.c index fb221dacda2,00000000000..b7b1801879d mode 100644,000000..100644 --- a/src/unexcoff.c +++ b/src/unexcoff.c @@@ -1,560 -1,0 +1,560 @@@ +/* Copyright (C) 1985, 1986, 1987, 1988, 1992, 1993, 1994, 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. + +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 . */ + + +/* + * 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 +#define PERROR(file) report_error (file, new) + +#ifndef CANNOT_DUMP /* all rest of file! */ + +#ifdef HAVE_COFF_H +#include +#ifdef MSDOS +#include /* for O_RDONLY, O_RDWR */ +#include /* for _crt0_startup_flags and its bits */ +#include +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 +#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 +#endif /* makedev */ +#include +#include +#include + +#include + +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 +#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); +} + +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); + +} + +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; +} + +/* **************************************************************** + * 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; +} + +/* **************************************************************** + * 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); +} + + +/* + * 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) */ diff --cc src/w32fns.c index 31feadc2d70,daea5120a4f..e1081d2e912 --- a/src/w32fns.c +++ b/src/w32fns.c @@@ -1,8 -1,7 +1,8 @@@ /* 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. diff --cc src/xsettings.c index 83ca87ed0bd,632a74d0d9a..16c4603f592 --- a/src/xsettings.c +++ b/src/xsettings.c @@@ -1,5 -1,5 +1,5 @@@ -/* 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.