public/elisp-vcs
2
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Remove local packages, use package.el instead

Browse Source
This commit is contained in:
Kai Tetzlaff (mokal.tetzco.de) 2018-10-03 19:42:46 +02:00
parent 0d548f92fb
commit f7e79ab403
132 changed files with 11 additions and 52809 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
Makefile
View File

@ -6,7 +6,7 @@ endif
all: elisp-all
elisp-all: org-mode auctex sunrise-commander
elisp-all: org-mode sunrise-commander
#elisp-all: ess
#apel flim semi wanderlust
@ -27,8 +27,8 @@ post_clone_cmd-emacswiki :=\
GIT_DIRS += use-package
URL-use-package := https://github.com/jwiegley/use-package.git
GIT_DIRS += yaml-mode
URL-yaml-mode := https://github.com/yoshiki/yaml-mode.git
# GIT_DIRS += yaml-mode
# URL-yaml-mode := https://github.com/yoshiki/yaml-mode.git
#GIT_DIRS += apel
#URL-apel := http://github.com/wanderlust/apel.git
@ -56,20 +56,20 @@ endif
#GIT_DIRS += w3
#URL-w3 := http://git.savannah.gnu.org/r/w3.git
GIT_DIRS += bbdb
URL-bbdb := http://git.savannah.gnu.org/r/bbdb.git
# GIT_DIRS += bbdb
# URL-bbdb := http://git.savannah.gnu.org/r/bbdb.git
GIT_DIRS += auctex
URL-auctex := http://git.savannah.gnu.org/r/auctex.git
# git_DIRS += auctex
# URL-auctex := http://git.savannah.gnu.org/r/auctex.git
GIT_DIRS += emacs-jabber
URL-emacs-jabber := http://git.code.sf.net/p/emacs-jabber/git
# GIT_DIRS += emacs-jabber
# URL-emacs-jabber := http://git.code.sf.net/p/emacs-jabber/git
GIT_DIRS += doxymacs
URL-doxymacs := git://doxymacs.git.sourceforge.net/gitroot/doxymacs/doxymacs
GIT_DIRS += htmlize
URL-htmlize := http://github.com/emacsmirror/htmlize.git
# GIT_DIRS += htmlize
# URL-htmlize := http://github.com/emacsmirror/htmlize.git
#GIT_DIRS += ess
#URL-ess := https://github.com/emacs-ess/ESS.git

340
dvc/COPYING
View File

@ -1,340 +0,0 @@
GNU GENERAL PUBLIC LICENSE
Version 2, June 1991
Copyright (C) 1989, 1991 Free Software Foundation, Inc.
51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
Preamble
The licenses for most software are designed to take away your
freedom to share and change it. By contrast, the GNU General Public
License is intended to guarantee your freedom to share and change free
software--to make sure the software is free for all its users. This
General Public License applies to most of the Free Software
Foundation's software and to any other program whose authors commit to
using it. (Some other Free Software Foundation software is covered by
the GNU Library General Public License instead.) You can apply it to
your programs, too.
When we speak of free software, we are referring to freedom, not
price. Our General Public Licenses are designed to make sure that you
have the freedom to distribute copies of free software (and charge for
this service if you wish), that you receive source code or can get it
if you want it, that you can change the software or use pieces of it
in new free programs; and that you know you can do these things.
To protect your rights, we need to make restrictions that forbid
anyone to deny you these rights or to ask you to surrender the rights.
These restrictions translate to certain responsibilities for you if you
distribute copies of the software, or if you modify it.
For example, if you distribute copies of such a program, whether
gratis or for a fee, you must give the recipients all the rights that
you have. You must make sure that they, too, receive or can get the
source code. And you must show them these terms so they know their
rights.
We protect your rights with two steps: (1) copyright the software, and
(2) offer you this license which gives you legal permission to copy,
distribute and/or modify the software.
Also, for each author's protection and ours, we want to make certain
that everyone understands that there is no warranty for this free
software. If the software is modified by someone else and passed on, we
want its recipients to know that what they have is not the original, so
that any problems introduced by others will not reflect on the original
authors' reputations.
Finally, any free program is threatened constantly by software
patents. We wish to avoid the danger that redistributors of a free
program will individually obtain patent licenses, in effect making the
program proprietary. To prevent this, we have made it clear that any
patent must be licensed for everyone's free use or not licensed at all.
The precise terms and conditions for copying, distribution and
modification follow.
GNU GENERAL PUBLIC LICENSE
TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
0. This License applies to any program or other work which contains
a notice placed by the copyright holder saying it may be distributed
under the terms of this General Public License. The "Program", below,
refers to any such program or work, and a "work based on the Program"
means either the Program or any derivative work under copyright law:
that is to say, a work containing the Program or a portion of it,
either verbatim or with modifications and/or translated into another
language. (Hereinafter, translation is included without limitation in
the term "modification".) Each licensee is addressed as "you".
Activities other than copying, distribution and modification are not
covered by this License; they are outside its scope. The act of
running the Program is not restricted, and the output from the Program
is covered only if its contents constitute a work based on the
Program (independent of having been made by running the Program).
Whether that is true depends on what the Program does.
1. You may copy and distribute verbatim copies of the Program's
source code as you receive it, in any medium, provided that you
conspicuously and appropriately publish on each copy an appropriate
copyright notice and disclaimer of warranty; keep intact all the
notices that refer to this License and to the absence of any warranty;
and give any other recipients of the Program a copy of this License
along with the Program.
You may charge a fee for the physical act of transferring a copy, and
you may at your option offer warranty protection in exchange for a fee.
2. You may modify your copy or copies of the Program or any portion
of it, thus forming a work based on the Program, and copy and
distribute such modifications or work under the terms of Section 1
above, provided that you also meet all of these conditions:
a) You must cause the modified files to carry prominent notices
stating that you changed the files and the date of any change.
b) You must cause any work that you distribute or publish, that in
whole or in part contains or is derived from the Program or any
part thereof, to be licensed as a whole at no charge to all third
parties under the terms of this License.
c) If the modified program normally reads commands interactively
when run, you must cause it, when started running for such
interactive use in the most ordinary way, to print or display an
announcement including an appropriate copyright notice and a
notice that there is no warranty (or else, saying that you provide
a warranty) and that users may redistribute the program under
these conditions, and telling the user how to view a copy of this
License. (Exception: if the Program itself is interactive but
does not normally print such an announcement, your work based on
the Program is not required to print an announcement.)
These requirements apply to the modified work as a whole. If
identifiable sections of that work are not derived from the Program,
and can be reasonably considered independent and separate works in
themselves, then this License, and its terms, do not apply to those
sections when you distribute them as separate works. But when you
distribute the same sections as part of a whole which is a work based
on the Program, the distribution of the whole must be on the terms of
this License, whose permissions for other licensees extend to the
entire whole, and thus to each and every part regardless of who wrote it.
Thus, it is not the intent of this section to claim rights or contest
your rights to work written entirely by you; rather, the intent is to
exercise the right to control the distribution of derivative or
collective works based on the Program.
In addition, mere aggregation of another work not based on the Program
with the Program (or with a work based on the Program) on a volume of
a storage or distribution medium does not bring the other work under
the scope of this License.
3. You may copy and distribute the Program (or a work based on it,
under Section 2) in object code or executable form under the terms of
Sections 1 and 2 above provided that you also do one of the following:
a) Accompany it with the complete corresponding machine-readable
source code, which must be distributed under the terms of Sections
1 and 2 above on a medium customarily used for software interchange; or,
b) Accompany it with a written offer, valid for at least three
years, to give any third party, for a charge no more than your
cost of physically performing source distribution, a complete
machine-readable copy of the corresponding source code, to be
distributed under the terms of Sections 1 and 2 above on a medium
customarily used for software interchange; or,
c) Accompany it with the information you received as to the offer
to distribute corresponding source code. (This alternative is
allowed only for noncommercial distribution and only if you
received the program in object code or executable form with such
an offer, in accord with Subsection b above.)
The source code for a work means the preferred form of the work for
making modifications to it. For an executable work, complete source
code means all the source code for all modules it contains, plus any
associated interface definition files, plus the scripts used to
control compilation and installation of the executable. However, as a
special exception, the source code distributed need not include
anything that is normally distributed (in either source or binary
form) with the major components (compiler, kernel, and so on) of the
operating system on which the executable runs, unless that component
itself accompanies the executable.
If distribution of executable or object code is made by offering
access to copy from a designated place, then offering equivalent
access to copy the source code from the same place counts as
distribution of the source code, even though third parties are not
compelled to copy the source along with the object code.
4. You may not copy, modify, sublicense, or distribute the Program
except as expressly provided under this License. Any attempt
otherwise to copy, modify, sublicense or distribute the Program is
void, and will automatically terminate your rights under this License.
However, parties who have received copies, or rights, from you under
this License will not have their licenses terminated so long as such
parties remain in full compliance.
5. You are not required to accept this License, since you have not
signed it. However, nothing else grants you permission to modify or
distribute the Program or its derivative works. These actions are
prohibited by law if you do not accept this License. Therefore, by
modifying or distributing the Program (or any work based on the
Program), you indicate your acceptance of this License to do so, and
all its terms and conditions for copying, distributing or modifying
the Program or works based on it.
6. Each time you redistribute the Program (or any work based on the
Program), the recipient automatically receives a license from the
original licensor to copy, distribute or modify the Program subject to
these terms and conditions. You may not impose any further
restrictions on the recipients' exercise of the rights granted herein.
You are not responsible for enforcing compliance by third parties to
this License.
7. If, as a consequence of a court judgment or allegation of patent
infringement or for any other reason (not limited to patent issues),
conditions are imposed on you (whether by court order, agreement or
otherwise) that contradict the conditions of this License, they do not
excuse you from the conditions of this License. If you cannot
distribute so as to satisfy simultaneously your obligations under this
License and any other pertinent obligations, then as a consequence you
may not distribute the Program at all. For example, if a patent
license would not permit royalty-free redistribution of the Program by
all those who receive copies directly or indirectly through you, then
the only way you could satisfy both it and this License would be to
refrain entirely from distribution of the Program.
If any portion of this section is held invalid or unenforceable under
any particular circumstance, the balance of the section is intended to
apply and the section as a whole is intended to apply in other
circumstances.
It is not the purpose of this section to induce you to infringe any
patents or other property right claims or to contest validity of any
such claims; this section has the sole purpose of protecting the
integrity of the free software distribution system, which is
implemented by public license practices. Many people have made
generous contributions to the wide range of software distributed
through that system in reliance on consistent application of that
system; it is up to the author/donor to decide if he or she is willing
to distribute software through any other system and a licensee cannot
impose that choice.
This section is intended to make thoroughly clear what is believed to
be a consequence of the rest of this License.
8. If the distribution and/or use of the Program is restricted in
certain countries either by patents or by copyrighted interfaces, the
original copyright holder who places the Program under this License
may add an explicit geographical distribution limitation excluding
those countries, so that distribution is permitted only in or among
countries not thus excluded. In such case, this License incorporates
the limitation as if written in the body of this License.
9. The Free Software Foundation may publish revised and/or new versions
of the General Public License from time to time. Such new versions will
be similar in spirit to the present version, but may differ in detail to
address new problems or concerns.
Each version is given a distinguishing version number. If the Program
specifies a version number of this License which applies to it and "any
later version", you have the option of following the terms and conditions
either of that version or of any later version published by the Free
Software Foundation. If the Program does not specify a version number of
this License, you may choose any version ever published by the Free Software
Foundation.
10. If you wish to incorporate parts of the Program into other free
programs whose distribution conditions are different, write to the author
to ask for permission. For software which is copyrighted by the Free
Software Foundation, write to the Free Software Foundation; we sometimes
make exceptions for this. Our decision will be guided by the two goals
of preserving the free status of all derivatives of our free software and
of promoting the sharing and reuse of software generally.
NO WARRANTY
11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
REPAIR OR CORRECTION.
12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
POSSIBILITY OF SUCH DAMAGES.
END OF TERMS AND CONDITIONS
How to Apply These Terms to Your New Programs
If you develop a new program, and you want it to be of the greatest
possible use to the public, the best way to achieve this is to make it
free software which everyone can redistribute and change under these terms.
To do so, attach the following notices to the program. It is safest
to attach them to the start of each source file to most effectively
convey the exclusion of warranty; and each file should have at least
the "copyright" line and a pointer to where the full notice is found.
<one line to give the program's name and a brief idea of what it does.>
Copyright (C) <year> <name of author>
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
Also add information on how to contact you by electronic and paper mail.
If the program is interactive, make it output a short notice like this
when it starts in an interactive mode:
Gnomovision version 69, Copyright (C) year name of author
Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
This is free software, and you are welcome to redistribute it
under certain conditions; type `show c' for details.
The hypothetical commands `show w' and `show c' should show the appropriate
parts of the General Public License. Of course, the commands you use may
be called something other than `show w' and `show c'; they could even be
mouse-clicks or menu items--whatever suits your program.
You should also get your employer (if you work as a programmer) or your
school, if any, to sign a "copyright disclaimer" for the program, if
necessary. Here is a sample; alter the names:
Yoyodyne, Inc., hereby disclaims all copyright interest in the program
`Gnomovision' (which makes passes at compilers) written by James Hacker.
<signature of Ty Coon>, 1 April 1989
Ty Coon, President of Vice
This General Public License does not permit incorporating your program into
proprietary programs. If your program is a subroutine library, you may
consider it more useful to permit linking proprietary applications with the
library. If this is what you want to do, use the GNU Library General
Public License instead of this License.

136
dvc/INSTALL
View File

@ -1,136 +0,0 @@
THE VERY QUICK INSTALLATION GUIDE
=================================
Since nobody reads long documentation, here's a very short
installation guide:
$ autoconf # only needed when the configure script is not present
$ cd dvc/
$ mkdir ++build/
$ cd ++build/
$ ../configure
$ make
[ possibly make install ]
And add
(load-file "/path/to/dvc/++build/dvc-load.el")
to your ~/.emacs.el
For the details, see below.
USING CONFIGURE
===============
0) If you get DVC from the revision control, the ./configure script is
not included. You have to run "autoreconf" or "autoconf" to recreate it.
1) Select your emacs flavor, this is the option --with-emacs and its
default is emacs (GNU Emacs). Choose a prefix for the installation
with --prefix, by default /usr/local.
The default locations are as follows:
a) GNU Emacs: lisp files goto ${prefix}/share/emacs/site-lisp and
info files to ${prefix}/info (overridable with --with-lispdir=...
and --infodir=...)
b) XEmacs: lisp files goto ${prefix}/lib/xemacs/site-packages/lisp/xtla and info
files to ${prefix}/lib/xemacs/site-packages/info, (overridable
with --with-infodir=... and --infodir=...)
ATTENTION: Files byte-compiled with GNU Emacs are NOT COMPATIBLE with the
XEmacs and you may experience strange problems during startup when doing
so. Thus ensure you are configuring with --with-emacs=xemacs when
installing DVC for XEmacs!
a) GNU Emacs users run:
./configure
b) XEmacs users run:
./configure --with-emacs=xemacs
It is possible to build DVC in a separate directory. For instance, type
mkdir emacs_build; cd emacs_build;
../configure --with-emacs=emacs
2) Compile the lisp files and info by running:
make
3) Installing the files
Run the following command:
make install
a) The easy way
The files dvc.el generated in the build directory and in
the install directory do everything for you: Manually, you can
run
M-x load-file RET /path/to/install/share/emacs/site-lisp/dvc/dvc-load.el RET
(usefull when you want to load DVC after starting "emacs -q"!),
or add
(load-file "/path/to/install/share/emacs/site-lisp/dvc/dvc-load.el")
to your ~/.emacs.el
The manual way
GNU Emacs: Put the lisp/info path as chosen above into your load-path,
i.e. add the following to your ~/.emacs.el (if you don't already have an
equivalent)
(add-to-list 'load-path "/path/to/install/share/emacs/site-lisp/dvc/lisp/")
(add-to-list 'Info-default-directory-list "/path/to/install/share/info/"))
Now, GNU Emacs knows where to find DVC, tell it to load it, by adding
(require 'dvc-autoloads)
to your ~/.emacs.el.
b) XEmacs: You are lucky nothing to do for you!
That's it! Restart Emacs and read the info or start using DVC. For
example, look at the DVC submenu in the Tools menu.
If you would prefer to run DVC from its source directory rather
than installing it, then add the following to your .xemacs/init.el
file.
(load-file "/path/to/dvc/dvc-load.el")
4) Integration of Xtla with Gnus
If you use Gnus and Xtla (support for tla and baz in DVC), you
probably want to add
(tla-insinuate-gnus)
to your ~/.gnus.el
INSTALLING BY HAND (for GNU Emacs)
==================
Basically you need to copy all the *.el files into a directory that is listed
in your `load-path' and the info file into a directory listed in your
`Info-directory-list'.
Then perform the steps from 3a) in the last section.
NOTES
=====
- XEmacs users will require the file ewoc.el which is also installed in the
package dir. It's provided in the contrib/ directory of DVC.
- xtla-browse.el is an add-on package for xtla.el. xtla-browse.el requires
tree-widget.el 2.0 or higher written by David Ponce. XEmacs users should
install the "jde" package. GNU Emacs in subversions.gnu.org CVS repository
contains tree-widget.el. If you are using older GNU Emacs or XEmacs, you can
get it from http://sourceforge.net/projects/emhacks/. xtla.el doesn't
require xtla-browse.el. xtla-browse.el is an option.

26
dvc/INSTALL.windows
View File

@ -1,26 +0,0 @@
* A poor mans installation guide
- The following files are generated by linux build scripts:
dvc-version.el
dvc-site.el
dvc-autoloads.el
- Copy these files from a working linux version to the dvc/lisp directory
- DVC.el needs a sh executable. Using cygwin should be a working option
If sh is not in the search PATH, set it via:
(setq dvc-sh-executable "c:/cygwin/bin/sh.exe")
- Add the following to your .emacs:
(add-to-list 'load-path "c:/emacs/site-lisp/dvc/lisp")
(require 'dvc-autoloads)
- The following tip shows how to configure the windows keys as super/hyper
Put these lines before the (require 'dvc-autoloads) in your .emacs
(setq w32-pass-lwindow-to-system nil
w32-pass-rwindow-to-system nil)
(setq w32-lwindow-modifier 'super) ; lwindow acts as super
(setq w32-rwindow-modifier 'hyper) ; rwindow acts as hyper
(defvar dvc-prefix-key '[(super t)])

123
dvc/Makefile.in
View File

@ -1,123 +0,0 @@
@SET_MAKE@
PACKAGE_TARNAME = @PACKAGE_TARNAME@
PACKAGE_VERSION = @PACKAGE_VERSION@
# location of required programms
AUTOCONF = autoconf
TAR = tar
RM = @RM@
prefix = @prefix@
datarootdir= @datarootdir@
info_dir = @info_dir@
srcdir = @srcdir@
lispdir= @lispdir@
SUBDIRS = lisp texinfo
MKDIR_P = @MKDIR_P@
##############################################################################
all: dvc info dvc-load.el
Makefile: config.status $(srcdir)/Makefile.in
./config.status $@
dvc-load.el: config.status $(srcdir)/dvc-load.el.in
./config.status $@
$(srcdir)/configure: $(srcdir)/configure.ac
cd $(srcdir) ; $(AUTOCONF)
./config.status --recheck
config.status: $(srcdir)/configure
./config.status --recheck
info pdf dvi html:
cd texinfo; $(MAKE) $@
dvc:
cd lisp; $(MAKE)
dvc-verbose:
cd lisp; $(MAKE) all-verbose
dvc-pkg.el: $(srcdir)/config.status
@echo Creating $@
@( echo ';;; $@ (ELPA generated installer file -- do not edit!)' ; \
echo '(define-package "dvc" "$(PACKAGE_VERSION)"' \
' "The Emacs interface to Distributed Version Control Systems")' ) \
> $@
lisp/dvc-version.el:
cd lisp; $(MAKE) dvc-version.el
%-recursive:
@for dir in $(SUBDIRS) ; do ( cd $$dir; $(MAKE) $* ) ; done
install: dvc-load.el install-recursive
sed -e 's|@''lispdir''@|'"$(lispdir)"'|' \
-e 's|@''info_dir''@|'"$(info_dir)"'|' \
$(srcdir)/dvc-load-install.el.in \
> $(lispdir)/dvc-load.el
uninstall: uninstall-recursive
rmdir $(lispdir) || true
clean: clean-recursive
rm -f dvc-load.el dvc-load-install.el
distclean: clean distclean-recursive
rm -rf configure config.status config.log autom4te.cache/ Makefile $(distdir) $(distdir).tar*
maintainer-clean: maintainer-clean-recursive
##############################################################################
distdir = $(PACKAGE_TARNAME)-$(PACKAGE_VERSION)
lispfiles = lisp/Makefile.in lisp/dvc-site.el.in \
lisp/contrib/*.el lisp/tests/*.el lisp/*.el
docfiles = texinfo/Makefile.in texinfo/dvc.texinfo texinfo/dvc.info
miscfiles = Makefile.in COPYING INSTALL* install-sh \
dvc-load.el.in dvc-load-install.el.in \
lisp/dvc-version.el \
texinfo/dvc-version.texinfo \
texinfo/dvc-intro.texinfo \
texinfo/fdl.texinfo \
configure.ac configure
extradist =
distfiles = $(lispfiles) $(docfiles) $(miscfiles) $(extradist)
dist:
rm -rf $(distdir) $(distdir).tar.gz
mkdir $(distdir)
build=`pwd` ; dd=$$build/$(distdir) ; cd $(srcdir) ; \
for f in $(distfiles) ; do d='.' ; \
if [ -f $$build/$$f ] ; then d=$$build ; fi ; \
e=`dirname $$f` ; f=`basename $$f` ; \
test -d $$dd/$$e || $(MKDIR_P) $$dd/$$e ; \
cp -p $$d/$$e/$$f $$dd/$$e/$$f ; done
$(TAR) cf - $(distdir) | gzip --best > $(distdir).tar.gz
rm -rf $(distdir)
tarball:
$(MAKE) dist \
distdir=$(PACKAGE_TARNAME)-snapshot \
extradist='debian/* docs/* scripts/*'
package: dvc-pkg.el info lisp/dvc-version.el
rm -rf $(distdir) $(distdir).tar
mkdir $(distdir)
cp -r docs $(distdir)
cp COPYING $(distdir)
cp dvc-pkg.el lisp/*el texinfo/dvc.info $(distdir)
install-info --info-dir=$(distdir) $(distdir)/dvc.info
$(TAR) cf $(distdir).tar $(distdir)
.INTERMEDIATE: dvc-pkg.el
.PHONY: all info pdf dvi html dvc dvc-verbose \
install uninstall \
clean distclean maintainer-clean \
dist tarball package

185
dvc/configure.ac
View File

@ -1,185 +0,0 @@
# configure.ac --- configuration setup for DVC
# Copyright (C) 2004-2007 by all contributors
# Author: Robert Widhopf-Fenk <hack@robf.de>
# DVC is free software; you can redistribute it and/or modify
# it under the terms of the GNU Library General Public License as published
# by the Free Software Foundation; either version 2 of the License, or (at
# your option) any later version.
# DVC is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU Library General Public License for more details.
# You should have received a copy of the GNU Library General Public License
# along with this program; if not, write to the Free Software Foundation,
# Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
# Process this file with autoconf to produce a new configure script
# Find a program. A failure is not fatal, just issue a warning
AC_DEFUN([DVC_PROG_WARN],
[ AC_SUBST([$1])
AC_ARG_WITH([$2],
[AS_HELP_STRING([--with-][$2]=PROG, [$3])],
[ [$1]=${withval} ],
[
AC_CHECK_PROG([$1], [$2], [$2])
if test "x${$1}" = "x" ; then
AC_MSG_WARN([*** No $2 program found.])
fi
])
])
# Find a program. A failure is not fatal.
AC_DEFUN([DVC_PROG],
[ AC_SUBST([$1])
AC_ARG_WITH([$2],
[AS_HELP_STRING([--with-][$2]=PROG, [$3])],
[ [$1]=${withval} ],
[
AC_CHECK_PROG([$1], [$2], [$2])
])
])
##############################################################################
AC_INIT([DVC], [0], [dvc-dev@gna.org])
AC_COPYRIGHT([Copyright (C) 2004-2007 Robert Widhopf-Fenk <hack@robf.de> and the DVC team])
AC_CONFIG_SRCDIR([configure.ac])
AC_CONFIG_FILES([Makefile lisp/Makefile texinfo/Makefile dvc-load.el lisp/dvc-site.el])
# Common system utilities checking:
AC_PROG_MAKE_SET
AC_PROG_INSTALL
AC_PROG_MKDIR_P
# External programs checking:
# Choose an Emacs flavor according to the --with-emacs user option, or
# try "emacs" and "xemacs". We use EMACS_PROG instead of EMACS to
# avoid colliding with Emacs' own internal environment.
AC_ARG_WITH([emacs],
[AS_HELP_STRING([--with-emacs=PROG], [choose which flavor of Emacs to use])],
[ EMACS_PROG="${withval}" ],
[ AC_CHECK_PROGS(EMACS_PROG, emacs xemacs) ])
if test "x${EMACS_PROG}" = "x" ; then
AC_MSG_ERROR([*** No Emacs program found.])
fi
AC_MSG_CHECKING([emacs-type of ${EMACS_PROG}])
if ${EMACS_PROG} --no-site-file --batch --eval \
'(kill-emacs (if (featurep (quote xemacs)) 0 1))'
then EMACS_FLAVOR=xemacs ; FLAGS='-no-site-file -no-autoloads'
else EMACS_FLAVOR=emacs ; FLAGS=--no-site-file
fi
AC_MSG_RESULT([${EMACS_FLAVOR}])
# Copied from gnus aclocal.m4
AC_ARG_WITH([lispdir],
[AS_HELP_STRING([--with-lispdir=DIR], [where to install lisp files])],
[lispdir=${withval}])
AC_MSG_CHECKING([where .elc files should go])
if test -z "$lispdir"; then
theprefix=$prefix
if test "x$theprefix" = "xNONE"; then
theprefix=$ac_default_prefix
fi
datadir="\$(prefix)/share"
if test "$EMACS_FLAVOR" = "xemacs"; then
datadir="\$(prefix)/lib"
lispdir="${datadir}/${EMACS_FLAVOR}/site-packages/lisp/dvc"
if test ! -d "${lispdir}"; then
if test -d "${theprefix}/share/${EMACS_FLAVOR}/site-lisp"; then
lispdir="\$(prefix)/lib/${EMACS_FLAVOR}/site-packages/lisp/dvc"
fi
fi
else
lispdir="${datadir}/${EMACS_FLAVOR}/site-lisp/dvc"
fi
fi
AC_MSG_RESULT([$lispdir])
AC_SUBST([lispdir])
AC_SUBST([EMACS_PROG])
AC_SUBST([FLAGS])
# Copied from gnus aclocal.m4 (AC_PATH_INFO_DIR)
AC_MSG_CHECKING([where the TeXinfo docs should go])
dnl Set default value. This must be an absolute path.
if test "$infodir" = "\${prefix}/info"; then
if test "$EMACS_FLAVOR" = "xemacs"; then
info_dir="\$(prefix)/${thedir}/${EMACS_FLAVOR}/site-packages/info"
else
info_dir="\$(prefix)/share/info"
fi
else
info_dir=$infodir
fi
AC_MSG_RESULT([$info_dir])
AC_SUBST([info_dir])
DVC_PROG([TLA], [tla], [tla program to use])
DVC_PROG([BAZ], [baz], [baz program to use])
AC_MSG_CHECKING([arch branch to use])
AC_ARG_WITH([arch],
[AS_HELP_STRING([--with-arch=BRANCH],
[which arch branch (one of: tla, baz, none) to use by default
(default is none)])],
[ARCH_BRANCH=$withval],
[ARCH_BRANCH=none])
case $ARCH_BRANCH in
tla|baz|none) blurb= ;;
*) blurb=" (ignored invalid --with-arch=$ARCH_BRANCH)"
ARCH_BRANCH=none ;;
esac
AC_MSG_RESULT([$ARCH_BRANCH$blurb])
AC_SUBST([ARCH_BRANCH])
DVC_PROG_WARN([DIFF], [diff], [diff program to use])
DVC_PROG_WARN([PATCH], [patch], [patch program to use])
AC_ARG_WITH([other-dirs],
[AS_HELP_STRING([--with-other-dirs=DIRS],
[push DIRS (list of space- or colon-separated paths)
onto `load-path' during build])],
[OTHERDIRS=`echo "$withval" | sed 'y/:/ /'`])
AC_SUBST([OTHERDIRS])
# tree widget
AC_MSG_CHECKING([whether tree-widget is in the load-path])
if ${EMACS_PROG} ${FLAGS} --batch --eval \
'(kill-emacs
(if (locate-library "tree-widget" nil
(append command-line-args-left load-path))
0 1))' \
$OTHERDIRS
then HAS_TREE_WIDGET=yes
else HAS_TREE_WIDGET=no
fi
AC_MSG_RESULT([${HAS_TREE_WIDGET}])
if test "x${HAS_TREE_WIDGET}" = "xno" ; then
AC_MSG_WARN([*** tree-widget.el not found in 'load-path.])
AC_MSG_WARN([*** tla-browse.el won't be available unless you install it.])
AC_MSG_WARN([*** See http://sourceforge.net/projects/emhacks/])
AC_MSG_WARN([*** Provide the path to tree-widget with --with-other-dirs])
AC_MSG_WARN([*** if tree-widget.el is already present on your system])
fi
AC_MSG_CHECKING([for the date utility flavor])
if date --version 2>/dev/null | grep GNU ; then
DATE_FLAVOR="GNU"
else
DATE_FLAVOR="BSD"
fi
AC_MSG_RESULT([${DATE_FLAVOR}])
AC_SUBST([DATE_FLAVOR])
AC_OUTPUT
# configure.ac ends here

6
dvc/debian/README.Debian
View File

@ -1,6 +0,0 @@
This package is a rework of Milan Zamazal's packaging based on
Matthieu Moy <Matthieu.Moy@imag.fr>.
This package use cdbs.
-- Daniel Dehennin <dad@hati.baby-gnu.org>, Fri, 22 Aug 2008 07:04:29 +0200

7
dvc/debian/changelog
View File

@ -1,7 +0,0 @@
dvc (0r20100420-1) unstable; urgency=low
* New snapshot.
* Add dvc.texinfo license to debian/copyright.
* Julien Danjou is the sponsor for DVC (Closes: #496930).
-- Daniel Dehennin <daniel.dehennin@baby-gnu.org> Tue, 20 Apr 2010 09:43:34 +0200

1
dvc/debian/compat
View File

@ -1 +0,0 @@
7

30
dvc/debian/control
View File

@ -1,30 +0,0 @@
Source: dvc
Section: devel
Priority: optional
Maintainer: Daniel Dehennin <daniel.dehennin@baby-gnu.org>
Build-Depends: cdbs (>= 0.4.50), debhelper (>= 7)
Build-Depends-Indep: autoconf, emacs23 | emacs22 | emacs21 | xemacs21 | emacs-snapshot, texinfo
Standards-Version: 3.8.4
Vcs-Bzr: http://bzr.xsteve.at/dvc/
Homepage: http://download.gna.org/dvc/
Package: dvc
Architecture: all
Depends: emacs23 | emacs22 | emacs21 | xemacs21 | emacs-snapshot, dpkg (>= 1.15.4) | install-info, ${misc:Depends}
Recommends: tla | bazaar | bzr | git | mercurial | darcs | monotone
Description: Emacs front-end to distributed version control systems
DVC is an attempt to build a common infrastructure for various
distributed revision control systems. Actually supported are tla,
bazaar, bzr, git, mercurial, darcs and monotone.
.
DVC main features are:
* dvc-status: Intuitive interface for status viewing.
* dvc-log: Log viewer.
* dvc-diff: View uncommitted changes in your working directory.
* dvc-bookmarks: Bookmark manager with partner support.
* Integration with ediff, Emacs's graphical diff tool.
* dvc-missing: Interface to view missing patches from all your
partners with a single command.
* Send/receive/apply patches via the Gnus email client.
* Run many version control commands from Emacs (such as init and
pull).

70
dvc/debian/copyright
View File

@ -1,70 +0,0 @@
This package was debianized by Matthieu Moy <Matthieu.Moy@imag.fr> on
Sun, 17 Oct 2004 17:15:25 +0200. Small additional changes were made by
Milan Zamazal <pdm@debian.org> and Daniel Dehennin
<daniel.dehennin@baby-gnu.org> completely repackage it.
It was downloaded from http://download.gna.org/dvc.
Copyright (C) 2004, 2005, 2006, 2007, 2008 DVC team
Upstream authors:
Alan Shutko <ats@acm.org>
Andrea Russo <rastandy@inventati.org>
Andre Kuehne <andre.kuehne@gmx.net>
Bojan Nikolic <bojan@bnikolic.co.uk>
Chris Gray <christopher.grayb@mail.mcgill.ca>
Christian Ohler <ohler+mtn@fastmail.net>
Daniel Dehennin <daniel.dehennin@baby-gnu.org>
Mark Triggs <mark@dishevelled.net>
Martin Brett Pool
Masatake YAMATO <jet@gyve.org>
Matthieu MOY <matthieu.moy@imag.fr>
Michael Olson <mwolson@gnu.org>
Milan Zamazal <pdm@zamazal.org>
Miles Bader <miles@gnu.org>
Robert Widhopf-Fenk <hack@robf.de>
Sam Steingold <sds@gnu.org>
Sascha Wilde <wilde@sha-bang.de>
Stefan Reichoer <stefan@xsteve.at>
Stephen Leake <stephen_leake@stephe-leake.org>
Steve Youngs <steve@sxemacs.org>
Takuzo O'hara <takuzo.ohara@gmail.com>
Vincent LADEUIL
License:
This package is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; version 2 dated June, 1991, or
(at your option) any later version.
This package is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this package; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA.
On Debian systems, the complete text of the GNU General
Public License can be found in `/usr/share/common-licenses/GPL'.
License for dvc.texinfo:
Permission is granted to make and distribute verbatim copies of this
manual provided the copyright notice and this permission notice are
preserved on all copies.
Permission is granted to copy and distribute modified versions of
this manual under the conditions for verbatim copying, provided that
the entire resulting derived work is distributed under the terms of a
permission notice identical to this one.
Permission is granted to copy and distribute translations of this
manual into another language, under the above conditions for modified
versions, except that this permission notice may be stated in a
translation approved by the author.

5
dvc/debian/dvc.dirs
View File

@ -1,5 +0,0 @@
usr/share/doc/dvc
usr/share/emacs/site-lisp/dvc
usr/share/emacs/site-lisp/dvc/lisp
usr/share/emacs/site-lisp/dvc/lisp/contrib

10
dvc/debian/dvc.docs
View File

@ -1,10 +0,0 @@
debian/copyright
docs/ANNOUNCEMENTS
docs/ARCHIVES
docs/BINDINGS
docs/CONTRIBUTORS
docs/DVC-API
docs/FEATURES
docs/HACKING
docs/TODO
docs/xmtn-readme.txt

81
dvc/debian/dvc.emacsen-install
View File

@ -1,81 +0,0 @@
#! /bin/sh -e
# /usr/lib/emacsen-common/packages/install/dvc
# Written by Jim Van Zandt <jrv@vanzandt.mv.com>, borrowing heavily
# from the install scripts for gettext by Santiago Vila
# <sanvila@ctv.es> and octave by Dirk Eddelbuettel <edd@debian.org>.
set -e
FLAVOR=$1
PACKAGE=dvc
if [ "x$FLAVOR" = "x" ]; then
echo Need argument to determin FLAVOR of emacs;
exit 1
fi
if [ "x$PACKAGE" = "x" ]; then
echo Internal error: need package name;
exit 1;
fi
ELDIR=/usr/share/emacs/site-lisp/${PACKAGE}
ELCDIR=/usr/share/${FLAVOR}/site-lisp/${PACKAGE}
case "$FLAVOR" in
emacs |emacs20)
echo "Ignoring flavor ${FLAVOR}"
;;
*)
echo -n "install/${PACKAGE}: Handling install for emacsen flavor ${FLAVOR}... "
# if ! which $FLAVOR 2>&1 > /dev/null; then
# echo "Could not find $FLAVOR. Exiting"
# exit 0;
# fi
if [ -d "$ELCDIR" ]; then
rm -rf $ELCDIR || true;
fi
install -m 755 -d ${ELCDIR}
cd ${ELDIR}/lisp
LOG=`tempfile`;
trap "test ! -f $LOG || mv -f $LOG $ELCDIR/install.log > /dev/null 2>&1" EXIT
make EMACS_PROG=/usr/bin/$FLAVOR > $LOG 2>&1
COMPILED=$(ls -1 *.elc)
if [ "x$COMPILED" = "x" ]; then
echo >&2 "No compiled files exist!!"
echo >&2 "Aborting!!"
echo "No compiled files exist!!" >> $LOG;
echo "Aborting!!" >> $LOG;
mv -f $LOG $ELCDIR/install.log
exit 1
fi
for file in *.elc; do
echo "Installing $file in $ELCDIR" >> $LOG
install -m 644 $file $ELCDIR;
done
# Include files in contrib/ if any
if ls contrib/*.elc > /dev/null 2>&1; then
for file in contrib/*.elc; do
echo "Installing $file in $ELCDIR" >> $LOG
install -m 644 $file $ELCDIR;
done
fi
rm -f dvc-version.el *autoloads.el custom-load.el *.elc contrib/*.elc|| true;
mv -f $LOG $ELCDIR/install.log;
chmod 644 $ELCDIR/install.log;
echo "done."
;;
esac
exit 0

29
dvc/debian/dvc.emacsen-remove
View File

@ -1,29 +0,0 @@
#!/bin/sh -e
# /usr/lib/emacsen-common/packages/remove/dvc
FLAVOR=$1
PACKAGE=dvc
if [ "x$FLAVOR" = "x" ]; then
echo Need argument to determin FLAVOR of emacs;
exit 1
fi
if [ "x$PACKAGE" = "x" ]; then
echo Internal error: need package name;
exit 1;
fi
case "$FLAVOR" in
emacs | emacs20)
echo "Ignoring flavour ${FLAVOR}"
;;
*)
echo "remove/${PACKAGE}: purging byte-compiled files for ${FLAVOR}"
rm -rf /usr/share/${FLAVOR}/site-lisp/${PACKAGE}
;;
esac
exit 0

36
dvc/debian/dvc.emacsen-startup
View File

@ -1,36 +0,0 @@
;; -*-emacs-lisp-*-
;;
;; Emacs startup file for the Debian dvc package
;;
;; Originally contributed by Nils Naumann <naumann@unileoben.ac.at>
;; Modified by Dirk Eddelbuettel <edd@debian.org>
;; Adapted for dh-make by Jim Van Zandt <jrv@vanzandt.mv.com>
;; The dvc package follows the Debian/GNU Linux 'emacsen' policy and
;; byte-compiles its elisp files for each 'emacs flavor' (emacs19,
;; xemacs19, emacs20, xemacs20...). The compiled code is then
;; installed in a subdirectory of the respective site-lisp directory.
;; We have to add this to the load-path:
(let ((list (append '((lisp . "dvc") (source . "dvc/lisp")))))
(while list
(let ((elt (car list)))
(cond
((equal 'lisp (car elt))
(let ((dir (concat "/usr/share/"
(symbol-name debian-emacs-flavor)
"/site-lisp/" (cdr elt))))
(when (file-directory-p dir)
(if (fboundp 'debian-pkg-add-load-path-item)
(debian-pkg-add-load-path-item dir)
(add-to-list 'load-path dir 'append)))))
((equal 'source (car elt))
(let ((dir (concat "/usr/share/emacs/site-lisp/" (cdr elt))))
(when (file-directory-p dir)
(add-to-list 'load-path dir 'append))))))
(setq list (cdr list))))
(if (featurep 'xemacs)
(require 'auto-autoloads)
(require 'dvc-autoloads))

1
dvc/debian/dvc.info
View File

@ -1 +0,0 @@
texinfo/dvc.info

7
dvc/debian/dvc.install
View File

@ -1,7 +0,0 @@
config.status /usr/share/emacs/site-lisp/dvc
Makefile* /usr/share/emacs/site-lisp/dvc
lisp/Makefile* /usr/share/emacs/site-lisp/dvc/lisp/
lisp/Makefile* /usr/share/emacs/site-lisp/dvc/lisp/
lisp/*.el /usr/share/emacs/site-lisp/dvc/lisp/
lisp/dvc-site.el.in /usr/share/emacs/site-lisp/dvc/lisp/
lisp/contrib/*.el /usr/share/emacs/site-lisp/dvc/lisp/contrib/

17
dvc/debian/rules
View File

@ -1,17 +0,0 @@
#!/usr/bin/make -f
# Uncomment this to turn on verbose mode.
export DH_VERBOSE=0
PREFIX := /usr
LISPDIR := /usr/share/emacs/site-lisp/dvc
include /usr/share/cdbs/1/rules/debhelper.mk
clean::
[ ! -f Makefile ] || $(MAKE) distclean
configure/dvc::
autoconf -f -i
./configure PACKAGE_VERSION=$(DEB_VERSION) --prefix=$(PREFIX) --with-lispdir=$(LISPDIR)
$(MAKE) info

1
dvc/debian/source/format
View File

@ -1 +0,0 @@
3.0 (quilt)

99
dvc/docs/ANNOUNCEMENTS
View File

@ -1,99 +0,0 @@
; -*- mode: text -*-
Subject: Xtla 1.2 is out!!
The Xtla development team is proud to announce the release of Xtla,
version 1.2.
Xtla is the Emacs front-end to GNU Arch client (either tla or bazaar
branch, at your option). It mainly provides user-friendly wrappers for
native commands.
The 1.2 version of Xtla will most probably be the last version of Xtla
to contain new features. We are currently moving to a more generic
architecture, that we called DVC, which will support other RCS as
back-ends. We already have preliminary support for Mercurial and
Bazaar 2.
The main features are:
* PCL-CVS like interface for tla inventory and tla changes
* Archive browser - navigate painlessly through archives, categories,
branches, versions, etc.
* Good integration in Emacs - almost everything can be done from
within the editor
* Bookmark manager - keep the most frequently used arch locations in
your bookmark buffer
* Integration with ediff, Emacs's graphical diff tool
- to view changes made in a local tree.
- to view and resolve conflicts after a merge.
* Interface to view missing patches from all your partners with a
single command
* An Emacs mode for arch-related files (log files, =tagging-method,
"build-config" files)
* Support for baz, and for baz added commands like "switch",
"annotate", "status", "resolved"
* Integraton with Gnus.
The main new features for the 1.2 version are:
* M-x baz-update RET can use either merge, replay, or update
* changelog buffer, cat-log-mode buffers, and *Article* buffers (in
Gnus) show clickable buttons for revision names (and other Arch
names).
* A mail notification is available from the Changelog buffer (bound
to "M")
* Several bazaaz 1.5 compatibility issues solved
* Many bugfixes
Information about Xtla can be found here:
http://wiki.gnuarch.org/xtla
We also have a project page on http://gna.org (savannah.gnu.org-like),
where you can find information about the mailing list, the online
manual, the download area, and the bug tracker (also used for feature
requests):
https://gna.org/projects/xtla-el
You can install Xtla is from the archive found here:
https://www-verimag.imag.fr/~moy/arch/public
The version is
Matthieu.Moy@imag.fr--public/xtla--main--1.2
Xtla can also be downloaded as a tarball from here
http://download.gna.org/xtla-el/
Or installed as a Debian package. The package is now in Debian
unstable. You can also get it by adding
deb http://download.gna.org/xtla-el/apt/ unstable/
to your sources.list file if you use another .deb-based distribution.
Many thanks to all contributors and testers, in particular, for this
version:
Stefan Reichör, Original author of Xtla and integrator
Masatake Yamato, GNU Emacs hacker
; Robert Widhopf-Fenk, XEmacs integration and testing
Milan Zamazal, Debian developer
Mark Triggs

36
dvc/docs/ARCHIVES
View File

@ -1,36 +0,0 @@
To test DVC backends quickly here I enumerate some
interesting(completely my subjective view - Masatake) archives or repositories:
Add archives(or repository) you are interested in.
* tla/baz
** dvc itself
$ bzr get http://bzr.xsteve.at/dvc/
* bzr
** bless binary editor
$ bzr branch http://download.gna.org/bless/bless.dev
* cg
** linux kernel
$ cg-clone git://git.kernel.org/pub/scm/linux/kernel/git/torvalds/linux-2.6.git
* hg
** Xen and linux related codes
$ hg clone http://xenbits.xensource.com/linux-2.6-xen.hg
$ hg clone http://xenbits.xensource.com/xen-3.0-testing.hg
* darcs
** Ion-3 window manager
$ darcs get --partial http://modeemi.fi/~tuomov/repos/ion-3

210
dvc/docs/BINDINGS
View File

@ -1,210 +0,0 @@
Some possible keybindings:
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Bookmarks key bindings
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(when (not tla-bookmarks-mode-map)
(setq tla-bookmarks-mode-map (make-sparse-keymap))
;;; Commands for merging (M)
(define-key tla-bookmarks-mode-map [?M ?s] 'tla-bookmarks-star-merge)
(define-key tla-bookmarks-mode-map [?M ?m] 'tla-bookmarks-missing)
(define-key tla-bookmarks-mode-map [?M ?r] 'tla-bookmarks-replay)
;;; Commands for marking (*)
(define-key tla-bookmarks-mode-map "\M-\C-?" 'tla-bookmarks-unmark-all)
(define-key tla-bookmarks-mode-map [?* ?!] 'tla-bookmarks-unmark-all)
(define-key tla-bookmarks-mode-map [?* ?u] 'tla-bookmarks-unmark)
(define-key tla-bookmarks-mode-map [?* ?m] 'tla-bookmarks-mark)
;;; Navigation
(define-key tla-bookmarks-mode-map [?n] 'tla-bookmarks-next)
(define-key tla-bookmarks-mode-map [?p] 'tla-bookmarks-previous)
;;; Bookmark specific commands
(define-key tla-bookmarks-mode-map "\C-m" 'tla-bookmarks-goto)
(define-key tla-bookmarks-mode-map [?a] 'tla-bookmarks-add)
(define-key tla-bookmarks-mode-map [?e] 'tla-bookmarks-edit)
(define-key tla-bookmarks-mode-map [?d] 'tla-bookmarks-delete)
(define-key tla-bookmarks-mode-map [?o] 'tla-bookmarks-open-tree)
(define-key tla-bookmarks-mode-map [?i] 'tla-bookmarks-inventory)
(define-key tla-bookmarks-mode-map [?q] 'tla-buffer-quit)
(define-key tla-bookmarks-mode-map [?+ ?b] 'tla-bookmarks-add)
(define-key tla-bookmarks-mode-map [?+ ?t] 'tla-bookmarks-add-tree-interactive)
(define-key tla-bookmarks-mode-map [?- ?t] 'tla-bookmarks-delete-tree-interactive)
(define-key tla-bookmarks-mode-map [?+ ?p] 'tla-bookmarks-add-partner-interactive)
(define-key tla-bookmarks-mode-map [?- ?p] 'tla-bookmarks-delete-partner-interactive)
(define-key tla-bookmarks-mode-map [?+ ?g] 'tla-bookmarks-add-group-interactive)
(define-key tla-bookmarks-mode-map [?- ?g] 'tla-bookmarks-delete-group-interactive)
(define-key tla-bookmarks-mode-map [?* ?g] 'tla-bookmarks-select-by-group)
(define-key tla-bookmarks-mode-map [?N] 'tla-bookmarks-move-down)
(define-key tla-bookmarks-mode-map [?P] 'tla-bookmarks-move-up)
;;; Archive commands (A)
(define-key tla-bookmarks-mode-map [?>] 'tla-bookmarks-get)
(define-key tla-bookmarks-mode-map [?A ?g] 'tla-bookmarks-get)
;;; Toggle commands (T)
(define-key tla-bookmarks-mode-map [?T t] 'tla-bookmarks-toggle-details)
;;; Debugging commands (D)
(define-key tla-bookmarks-mode-map [?D p] 'tla-show-process-buffer)
;; Add me!
;; (define-key tla-bookmarks-mode-map [?D l] 'tla-show-tla-log)
;;; Misc
(define-key tla-bookmarks-mode-map [??] 'describe-mode)
(define-key tla-bookmarks-mode-map [(meta p)]
'tla-bookmarks-marked-are-partners)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Inventory key bindings
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(when (not tla-inventory-mode-map)
(setq tla-inventory-mode-map (make-sparse-keymap))
;;; Commands for merging (M)
(define-key tla-inventory-mode-map [?M ?s] 'tla-inventory-star-merge)
(define-key tla-inventory-mode-map [?M ?r] 'tla-inventory-replay)
;;; Commands for marking (*)
(define-key tla-inventory-mode-map "\M-\C-?" 'tla-inventory-unmark-all)
(define-key tla-inventory-mode-map [?* ?m] 'tla-inventory-mark-file)
(define-key tla-inventory-mode-map [?* ?u] 'tla-inventory-unmark-file)
(define-key tla-inventory-mode-map [?* ?!] 'tla-inventory-unmark-all)
;;; Navigation
(define-key tla-inventory-mode-map [?n] 'tla-inventory-next)
(define-key tla-inventory-mode-map [?p] 'tla-inventory-previous)
(define-key tla-inventory-mode-map [?^] 'tla-inventory-parent-directory)
(define-key tla-inventory-mode-map [left] 'tla-inventory-parent-directory)
;;; Inventory specific commands
(define-key tla-inventory-mode-map [?+ ?f] 'tla-inventory-add)
(define-key tla-inventory-mode-map [?- ?f] 'tla-inventory-remove)
(define-key tla-inventory-mode-map [?R] 'tla-inventory-move)
(define-key tla-inventory-mode-map [?e] 'tla-inventory-file-ediff)
(define-key tla-inventory-mode-map [?c] 'tla-inventory-edit-log) ;; mnemonic for commit
(define-key tla-inventory-mode-map [?f] 'tla-inventory-find-file)
(define-key tla-inventory-mode-map [return] 'tla-inventory-find-file)
(define-key tla-inventory-mode-map [right] 'tla-inventory-find-file)
(define-key tla-inventory-mode-map "\C-m" 'tla-inventory-find-file)
(define-key tla-inventory-mode-map [?o] 'tla-inventory-find-file-other-window)
(define-key tla-inventory-mode-map [?v] 'tla-inventory-view-file)
;; (define-key tla-inventory-mode-map [?d ?e] 'tla-inventory-file-ediff)
(define-key tla-inventory-mode-map [?d ?m] 'tla-inventory-missing)
(define-key tla-inventory-mode-map [?=] 'tla-changes)
(define-key tla-inventory-mode-map [?l] 'tla-changelog)
(define-key tla-inventory-mode-map [?L] 'tla-logs)
;;; Archive commands (A)
(define-key tla-inventory-mode-map [?A ?m] 'tla-inventory-mirror)
;;; Toggle commands (T)
(dolist (type-arg tla-inventory-file-types-manipulators)
(define-key tla-inventory-mode-map `[?T ,(cadddr type-arg)] (caddr type-arg)))
(define-key tla-inventory-mode-map [?T ?+] 'tla-inventory-set-all-toggle-variables)
(define-key tla-inventory-mode-map [?T ?-] 'tla-inventory-reset-all-toggle-variables)
(define-key tla-inventory-mode-map [?T ?~] 'tla-inventory-toggle-all-toggle-variables)
;;; Debugging commands (D)
(define-key tla-inventory-mode-map [?D p] 'tla-show-process-buffer)
;; Add me!
;; (define-key tla-inventory-mode-map [?D l] 'tla-show-tla-log)
;;; Misc
(define-key tla-inventory-mode-map [??] 'describe-mode)
(define-key tla-inventory-mode-map [?g] 'tla-generic-refresh)
(define-key tla-inventory-mode-map [?q] 'tla-buffer-quit)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Revision key bindings
;;;;;;;;;;;;;;;;;;;;;;;;;;;
(when (not tla-revision-list-mode-map)
(setq tla-revision-list-mode-map (make-sparse-keymap))
;;; Commands for merging/branching (M)
(define-key tla-revision-list-mode-map [?M ?s] 'tla-revision-star-merge)
(define-key tla-revision-list-mode-map [?M ?t] 'tla-revision-tag)
(define-key tla-revision-list-mode-map [?M ?r] 'tla-revision-replay)
;;; Commands for marking (*)
(define-key tla-revision-list-mode-map [?* ?m] 'tla-revision-mark-revision)
;; Add me!
;; (define-key tla-revision-list-mode-map [?* ?u]
;; 'tla-revision-unmark-revision)
;;; Navigation
(define-key tla-revision-list-mode-map [?^]
'tla-revision-list-parent-version)
(define-key tla-revision-list-mode-map [left]
'tla-revision-list-parent-version)
(define-key tla-revision-list-mode-map [down] 'tla-bookmarks-missing-next)
(define-key tla-revision-list-mode-map [up] 'tla-bookmarks-missing-prev)
(define-key tla-revision-list-mode-map [?n] 'tla-bookmarks-missing-next)
(define-key tla-revision-list-mode-map [?p] 'tla-bookmarks-missing-prev)
;;; Archive commands (A)
(define-key tla-revision-list-mode-map [?> ?g] 'tla-revision-get-revision)
(define-key tla-revision-list-mode-map [?> ?C] 'tla-revision-cache-revision)
(define-key tla-revision-list-mode-map [?> ?L] 'tla-revision-add-to-library)
(define-key tla-revision-list-mode-map [?A ?g] 'tla-revision-get-revision)
(define-key tla-revision-list-mode-map [?A ?c] 'tla-revision-cache-revision)
(define-key tla-revision-list-mode-map [?A ?l] 'tla-revision-add-to-library)
;;; Toggle commands (T)
(define-key tla-revision-list-mode-map [?T ?d] 'tla-revision-toggle-date)
(define-key tla-revision-list-mode-map [?T ?c] 'tla-revision-toggle-creator)
(define-key tla-revision-list-mode-map [?T ?s] 'tla-revision-toggle-summary)
(define-key tla-revision-list-mode-map [?T ?r] 'tla-revision-toggle-reverse)
;; ?t ?? is reserved. Not implemented yet.
(define-key tla-revision-list-mode-map [?T ??] 'tla-revision-list-toggles)
;;; Debugging commands (D)
(define-key tla-revision-list-mode-map [?D p] 'tla-show-process-buffer)
;; Add me!
;; (define-key tla-revision-mode-map [?D l] 'tla-show-tla-log)
;;; Revision specific commands
(define-key tla-revision-list-mode-map [?l] 'tla-revision-cat-log)
(define-key tla-revision-list-mode-map [?u] 'tla-revision-update)
(define-key tla-revision-list-mode-map "\C-m" 'tla-revision-return)
(define-key tla-revision-list-mode-map [return] 'tla-revision-return)
(define-key tla-revision-list-mode-map [right] 'tla-revision-return)
(define-key tla-revision-list-mode-map [?d] 'tla-revision-delta)
(define-key tla-revision-list-mode-map [?=] 'tla-revision-changeset)
(define-key tla-revision-list-mode-map [?i] 'tla-pop-to-inventory)
(define-key tla-revision-list-mode-map [?.] 'tla-revision-bookmarks-add)
;;; Misc
(define-key tla-revision-list-mode-map [?g] 'tla-generic-refresh)
(define-key tla-revision-list-mode-map [?q] 'tla-buffer-quit)
)

165
dvc/docs/CONTRIBUTORS
View File

@ -1,165 +0,0 @@
#!/bin/sh
#| -*- scheme -*- |#
:; exec gosh -- $0 "$@"
;;
;; We want to merge dvc tree to GNU Emacs. Thus, every contributor
;; must assign copyright for this changes to the FSF. This file
;; tracks contributors and their copyright assignment status.
;;
;; Before reporting your patch for merging DVC official source tree,
;; add your name to this file. The entry format is as follows:
;;
;; (contributor :name "yourname"
;; :signed done--or--not-yet--or--tiny-change
;; :mail-addresses "addr1@example1.com")
;;
;; or
;;
;; (contributor :name "yourname"
;; :signed done--or--not-yet--or--tiny-change
;; :mail-addresses ("addr1@example1.com" "addr2@example2.com" ...))
;;
;; You can use # instead of @ for circumventing the email-gathering
;; web spiders that spammers use. If you use a list for the
;; :mail-addresses field, the car is used for contacting the FSF.
;;
;; The first time :signed field may be `not-yet'. Then we will contact
;; you via email and send a copyright assignment templalte, which is
;; to be emailed to the FSF (at this point, :signed is changed to
;; `in-progress'). They will then send you the papers to sign. After
;; completing a paper work for it and getting the notification from
;; FSF, the :signed field will be changed to `done'.
;;
;; *The order is not meaningful.*
;;
(define contributors
'(
(contributor :name "Stefan Reichoer"
:signed done
:mail-addresses ("stefan#xsteve.at"
"stefan#pyramide"
"xsteve#nit.at"))
(contributor :name "Matthieu MOY"
:signed done
:mail-addresses ("Matthieu.Moy#imag.fr"
"matthieu.moy#imag.fr"
"moy#ecrins"
"moy#moy"))
(contributor :name "Miles Bader"
:signed done
:mail-addresses "miles#gnu.org")
(contributor :name "Andre Kuehne"
:signed done
:mail-addresses "andre.kuehne#gmx.net")
(contributor :name "Vincent LADEUIL"
:signed done)
(contributor :name "Stephen Leake"
:signed done
:mail-addresses ("stephen_leake#stephe-leake.org"
"stephe#ACS1100007992"
"stephe#LM000850872"))
(contributor :name "Takuzo O'hara"
:signed done
:mail-addresses "takuzo.ohara#gmail.com")
(contributor :name "Michael Olson"
:signed done
:mail-addresses ("mwolson#member.fsf.org"
"mwolson#gnu.org"
"mwolson#exabyte"))
(contributor :name "Martin Brett Pool"
:signed done)
(contributor :name "Andrea Russo"
:signed done
:mail-addresses ("rastandy#inventati.org"
"rast4ndy#gmail.com"))
(contributor :name "Alan Shutko"
:signed done-emacs-only
:mail-addresses "ats#acm.org")
(contributor :name "Sam Steingold"
:signed done
:mail-addresses "sds#gnu.org")
(contributor :name "Mark Triggs"
:signed done
:mail-addresses "mark#dishevelled.net")
(contributor :name "Robert Widhopf-Fenk"
:signed done
:mail-addresses "hack#robf.de")
(contributor :name "Sascha Wilde"
:signed done-emacs-only
:mail-addresses "wilde#sha-bang.de")
(contributor :name "Masatake YAMATO"
:signed done
:mail-addresses ("jet#gyve.org"
"jet#gps06"))
(contributor :name "Steve Youngs"
:signed done-emacs-only
:mail-addresses "steve#sxemacs.org")
(contributor :name "Milan Zamazal"
:signed done
:mail-addresses ("pdm#zamazal.org" "pdm#debian.org"))
;;
;; Assignment in progress
;;
;;
;; Does not need assignment yet
;;
(contributor :name "Daniel Dehennin"
:contacted yes
:changed-elisp no
:signed not-yet
:mail-addresses "daniel.dehennin@baby-gnu.org")
;;
;; Needs assignment (or investigation into changes made)
;;
(contributor :name "Christian Ohler"
:signed not-yet
:contacted yes
:mail-addresses "ohler+mtn#fastmail.net")
(contributor :signed "Chris Gray"
:signed not-yet
:contacted email-invalid
:mail-addresses "christopher.grayb#mail.mcgill.ca")
(contributor :signed "Bojan Nikolic"
:signed in-progress
:contacted yes
:mail-addresses "bojan#bnikolic.co.uk")
(contributor :name "James LewisMoss"
:signed tiny-change
:mail-addresses "jim@lewismoss.org")
;;
;; ADD YOUR NAME HERE.
;;
))
;;
;; This is a program to pick something like mail addresses from the output of
;; tla and bzr. The contributors mail address listed above are removed from the
;; picked addresses.
;;
;; tla changelog | docs/CONTRIBUTORS | sort | uniq
;; bzr log | docs/CONTRIBUTORS | sort | uniq
;;
(use srfi-1)
(let* ((droplist '("dvc-dev#gna.org"))
(addresses (map
(cute regexp-replace #/#/ <> "@")
(apply append droplist
(map (lambda (c)
(let1 addrs (get-keyword :mail-addresses (cdr c) (list))
(if (string? addrs) (list addrs) addrs)))
contributors))))
(registered? (lambda (line)
(any (lambda (a)
(string-scan line a))
addresses))))
(let loop ((line (read-line)))
(unless (eof-object? line)
(when (string-scan line "@")
(unless (registered? line)
(print line)))
(loop (read-line)))))

179
dvc/docs/DVC-API
View File

@ -1,179 +0,0 @@
That file contains the documentation to build support for a different dvc,
using the dvc layer:
Conventions used in the document:
* <dvc> is used as placeholder for the dvc backend to implement
--------------------------------------------------------------------------------
* Base functions that are required for every supported dvc system
* That functions should be located in the <dvc>-dvc.el file
--------------------------------------------------------------------------------
When no function is provided, dvc-dvc-<postfix> is used instead.
- <dvc>-dvc-tree-root
(defun <dvc>-dvc-tree-root (&optional location no-error)
"Return the tree root for LOCATION, nil if not in a local tree.
If NO-ERROR is non-nil, don't raise an error if LOCATION is not a
<dvc> managed tree (but return nil)."
- <dvc>-dvc-log-edit-done
(defun <dvc>-dvc-log-edit-done ()
"Finish a commit for <dvc>."
- <dvc>-dvc-diff
(defun <dvc>-dvc-diff ()
"Shows the changes in the current <dvc> tree."
- <dvc>-dvc-log
(defun <dvc>-dvc-log ()
"Shows the changelog in the current <dvc> tree."
- <dvc>-dvc-command-version
(defun <dvc>-dvc-command-version ()
"Returns and/or shows the version identity string of backend command."
- <dvc>-dvc-file-has-conflict-p
(defun <dvc>-dvc-file-has-conflict-p (filename)
"Return non-nil if FILENAME is marked as having conflicts")
- <dvc>-dvc-resolved
(defun <dvc>-dvc-resolved (filename)
"Mark FILENAME as not having conflict anymore")
To handle the case of a workspace that is controlled by more than one
back-end, all dispatching interactive front-end functions dvc-foo
should have a corresponding function <dvc>-foo, that specifies which
back-end to use.
A simple way to provide <dvc>-foo is to put dvc-foo in
dvc-back-end-wrappers (in dvc-unified.el); then <dvc>-foo is
automatically generated by dvc-register-dvc. This defines
<dvc>-foo as (see dvc-register.el for the actual code):
(defun <dvc>-foo (<args>)
(interactive)
(let ((dvc-temp-current-active-dvc <dvc>))
(call-interactively 'dvc-foo)))
This means that back-ends may _not_ define a function <dvc>-foo.
Note that functions defined by dvc-define-unified-command dispatch
to <dvc>-dvc-foo. Calling <dvc>-dvc-foo is _not_ the same as
calling <dvc>-foo, since dvc-temp-current-active-dvc is not bound,
the interactive argument processing may be different, and
<dvc>-dvc-foo may not even exist (if the default dvc-dvc-foo is
sufficient).
-----------------------------------------------------------------------------
* Revision API
-----------------------------------------------------------------------------
Definition
==========
DVC deals with several RCS, with different ways to designate a
revision. We define a unified way to designate a revision in lisp,
which we call revision identifiers, or rev-id:
REVISION-ID :: (<dvc> BACK-END-ID)
;; <dvc> is one of 'tla, 'bzr, 'xhg, ...
BACK-END-ID :: (revision BACK-END-REVISION)
;; An already commited revision
;; The way to specify it depends on the back-end.
| (local-tree PATH)
;; Uncommited revision in the local tree PATH
| (last-revision PATH NUM)
;; Last commited revision in tree PATH if NUM = 1
;; Last but NUM-1 revision in tree PATH if NUM > 1
| (previous-revision BACK-END-REVISION NUM)
;; Nth Ancestor of BACK-END-ID.
(probably we'll need a (head REMOTE-BRANCH) too)
PATH :: string
;; must be a tree root directory
NUM :: number
REV-STRING :: string
For Xtla (tla and baz):
BACK-END-REVISION :: ("archive" "category" "branch" "version" "revision")
;; archive/category--branch--version--revision
For bzr:
BACK-END-REVISION :: (local "path" NUM)
| (remote "url" NUM)
| (tag REV-STRING)
For xhg:
TODO
For xgit:
BACK-END-REVISION :: (revision "sha1")
| (index)
;; content of the index (aka staging area).
Example
=======
(bzr (revision (local "/path/to/archive" 3)))
(baz (last-revision "/path/to/project" 1))
(baz (revision ("archive" "category" "branch" "version" "revision")))
(xgit (revision "c576304d512df18fa30b91bb3ac15478d5d4dfb1"))
Functions
=========
Based upon that, we define the functions:
dvc-revision-get-file-in-buffer: get the particular revision of a file
in a buffer.
-----------------------------------------------------------------------------
* Back-end specific features Vs Unification
-----------------------------------------------------------------------------
DVC provides the user an interface for multiple revision control
system, and does it using as much back-end independant code as
possible. This has several benefits :
* For the user:
- Similar user-interface, keybindings, ... for different back-ends.
- Unified interface for most operations : one menu, one set of
keybindings, and DVC detects which back-end to use automatically.
* For the developers:
- much less code to write than individual, independant interfaces.
However, some back-end features do not fit well in the DVC common
interface. For example, git differs from other common version control
systems in several regards (the index, for example, is something
probably unique to git, and it leads to a different flow to prepare a
commit).
In this case, there's nothing wrong providing additional functions,
which might not have a dvc-* dispatching command. The user can call
them with M-x <back-end>-command RET explicitly. Additionaly, one can
extend some DVC modes with additional keybindings and menus. See
`dvc-diff-mode' and `xgit-diff-mode' for an example.
-----------------------------------------------------------------------------
* External tools
-----------------------------------------------------------------------------
* 'sh' is required for dvc-run-sync and dvc-run-async.
In practice, that is not a problem for Unix users, but requires
cygwin or mingw for Windows users. 'sh' is used to separate stdout
from stderr; the Emacs function 'call-process' merges them. It may
be possible to do this with native Windows tools, if someone wants
to investigate.

204
dvc/docs/FEATURES
View File

@ -1,204 +0,0 @@
This file is a annotated version of the output of tla help.
It should help us to identify the missing features of xtla regarding
tla itself. Don't forget that xtla is more than a "wrapper" around
tla, so, xtla should also have features not listed here to have a real
added value (the bookmarks feature is probably the best example).
There are currently 3 sections :
* TODO : Nothing was done for that
* DONE : Something was already done for that command. Probably it's
still not perfect yet.
* NOT NEEDED : Nothing was done, and nothing will be done for this
feature since it's meaningless in xtla.
After some time, there should be a fourth section :
* FINISHED : We consider this feature is fully implemented. At least
we mean that, additions to this feature are lowest
priority.
Moving an item from DONE to FINISHED or from TODO to NOT NEEDED should
be discussed on the mailing list.
tla sub-commands
----------------
* help
[DONE] help : provide help with arch
* User Commands
[DONE] my-id : print or change your id
[DONE] my-default-archive : print or change your default archive
[DONE] register-archive : change an archive location registration
[DONE] whereis-archive : print an archive location registration
[DONE] archives : Report registered archives and their locations.
* Project Tree Commands
[DONE] init-tree : initialize a new project tree
[DONE] tree-root : find and print the root of a project tree
[DONE] tree-version : print the default version for a project tree
[DONE] set-tree-version : set the default version for a project tree
[DONE] undo : undo and save changes in a project tree
[DONE] redo : redo changes in project tree
[DONE] changes : report about local changes in a project tree
[DONE] file-diffs : show local changes to a file
* Project Tree Inventory Commands
[DONE] inventory : inventory a source tree
[DONE] tree-lint : audit a source tree
[DONE] id : report the inventory id for a file
[DONE] id-tagging-method : print or change a project tree id tagging method
[DONE] add-id : add an explicit inventory id
[DONE] delete-id : remove an explicit inventory id
[DONE] rm : remove a file (or dir, or symlink) and its explicit inventory tag (if any)
[DONE] move-id : move an explicit inventory id
[DONE] mv : move a file (or dir, or symlink) and it's explicit inventory tag (if any)
[TODO] explicit-default : print or modify default ids
[TODO] id-tagging-defaults : print the default =tagging-method contents
* Patch Set Commands
[TODO] changeset : compute a whole-tree changeset
[DONE] apply-changeset : apply a whole-tree changeset
[DONE] show-changeset : generate a report from a changeset
* Archive Transaction Commands
[DONE] make-archive : create a new archive directory
[NOT NEEDED] archive-setup : create new categories, branches and versions
[DONE] make-category : create a new archive category
[DONE] make-branch : create a new archive branch
[DONE] make-version : create a new archive version
[DONE] import : archive a full-source base-0 revision
[DONE] commit : archive a changeset-based revision
[DONE] get : construct a project tree for a revision
[DONE] get-changeset : retrieve a changeset from an archive
[TODO] lock-revision : lock (or unlock) an archive revision
[DONE] archive-mirror : update an archive mirror
* Archive Commands
[DONE] abrowse : print an outline describing archive contents
[DONE] rbrowse : print an outline describing an archive's contents
[DONE] categories : list the categories in an archive
[DONE] branches : list the branches in an archive category
[DONE] versions : list the versions in an archive branch
[DONE] revisions : list the revisions in an archive version
[TODO] ancestry : display the ancestory of a revision
[TODO] ancestry-graph : display the ancestory of a revision
[DONE] cat-archive-log : print the contents of an archived log entry
[DONE] cacherev : cache a full source tree in an archive
[TODO] cachedrevs : list cached revisions in an archive
[TODO] uncacherev : remove a cached full source tree from an archive
[TODO] archive-meta-info : report meta-info from an archive
[TODO] archive-snapshot : update an archive snapshot
[TODO] archive-version : list the archive-version in an archive
[DONE] archive-fixup : fix ancillary files (e.g. .listing files) in an archive
* Patch Log Commands
[DONE] make-log : initialize a new log file entry
[TODO] log-versions : list patch log versions in a project tree
[TODO] add-log-version : add a patch log version to a project tree
[TODO] remove-log-version : remove a version's patch log from a project tree
[DONE] logs : list patch logs for a version in a project tree
[DONE] cat-log : print the contents of a project tree log entry
[DONE] changelog : generate a ChangeLog from a patch log
[DONE] log-for-merge : generate a log entry body for a merge
[TODO] merges : report where two branches have been merged
[TODO] new-merges : list tree patches new to a version
* Multi-project Configuration Commands
[DONE] build-config : instantiate a multi-project config
[DONE] cat-config : output information about a multi-project config
* Commands for Branching and Merging
[DONE] tag : create a continuation revision (aka tag or branch)
[DONE] update : update a project tree to reflect recent archived changes
[DONE] replay : apply revision changesets to a project tree
[DONE] star-merge : merge mutually merged branches
[TODO] apply-delta : Compute a changeset between any two trees or revisions and apply it to a project tree
[DONE] missing : print patches missing from a project tree
[TODO] join-branch : construct a project tree for a version
[DONE] sync-tree : unify a project tree's patch-log with a given revision
[DONE] delta : Compute a changeset (or diff) between any two trees or revisions
* Local Cache Commands
[DONE] changes : report about local changes in a project tree
[DONE] file-diffs : show local changes to a file
[DONE] file-find : find given version of file
[DONE] pristines : list pristine trees in a project tree
[TODO] lock-pristine : lock (or unlock) a pristine tree
[TODO] add-pristine : ensure that a project tree has a particular pristine revision
[TODO] find-pristine : find and print the path to a pristine revision
* Revision Library Commands
[DONE] my-revision-library : print or change your revision library path
[DONE] library-config : configure parameters of a revision library
[DONE] library-find : find and print the location of a revision in the revision library
[DONE] library-add : add a revision to the revision library
[TODO] library-remove : remove a revision from the revision library
[DONE] library-archives : list the archives in your revision library
[DONE] library-categories : list the categories in your revision library
[DONE] library-branches : list the branches in a library category
[DONE] library-versions : list the versions in a library branch
[DONE] library-revisions : list the revisions in a library version
[TODO] library-log : output a log message from the revision library
[TODO] library-file : find a file in a revision library
* Published Revisions Commands
[TODO] grab : grab a published revision
* Miscellaneous Scripting Support
[NOT NEEDED] parse-package-name : parse a package name
[NOT NEEDED] valid-package-name : test a package name for validity

263
dvc/docs/HACKING
View File

@ -1,263 +0,0 @@
-*- mode: text -*-
Developers
==========
DVC will be merged to GNU Emacs(we hope).
So the developers should be able to sign to FSF about
copyright assignment. In other words, we can accept
only patches whose author agrees to sign to FSF.
CONTRIBUTORS file is for tracking the contributors
and their copyright assignments.
CONTRIBUTORS file is maintained by Michael Olson.
GNU Emacs, XEmacs and its version
=================================
We will support both Emacs and XEmacs. The developers are using:
Stefan Reichoer <stefan at xsteve . at>: GNU Emacs 21.3.1, GNU Emacs in CVS repository
Matthieu Moy <Matthieu.Moy at imag . fr>: GNU Emacs 21.2 (Solaris and Linux)
Masatake YAMATO <jet at gyve . org>: GNU Emacs in CVS repository
Milan Zamazal <pdm at zamazal . org>: GNU Emacs 21.3, GNU Emacs CVS
Martin Pool <mbp at sourcefrog . net>: ???
Robert Widhopf-Fenk <hack at robf . de>: XEmacs 21.4.5
Mark Triggs <mst at dishevelled . net>: GNU Emacs in CVS repository
gnuarch version
===============
gnuarch version which xtla's developers are using:
Stefan Reichoer <stefan at xsteve . at>:
Matthieu Moy <Matthieu.Moy at imag . fr>:
tla 1.2, tla 1.2.2rc2
Masatake YAMATO <jet at gyve . org>:
tla lord@emf.net--2004/dists--devo--1.0--patch-9(configs/emf.net-tla/devo.tla-1.2) from regexps.com
Milan Zamazal <pdm at zamazal . org>: tla, from Debian/testing.
Martin Pool <mbp at sourcefrog . net>:
Robert Widhopf-Fenk <hack at robf . de>:
Mark Triggs <mst at dishevelled . net>:
Key bind conventions
====================
See xtla-defs.el.
Symbol name conventions
=======================
- Face: Do not use a `-face' suffix for face names.
(About the reason, see
http://mail.gnu.org/archive/html/emacs-devel/2004-03/msg00077.html)
- Functions and variables internal to xtla should be named tla--XXX
Functions and variables used by the user should be named tla-XXX
Menu item conventions
=====================
See xtla-defs.el.
Mail conversions
================
Matthieu MOY <Matthieu.Moy at imag dot fr> wrote
in Message-ID: <1084790609.40a8975194dcd@webmail.imag.fr>
I usually send a mail for a merge request only when the change
involves a big portion of the file, to tell everybody to make sure
they merge before doing any changes.
However, when you send a mail, your suggestion of [MERGE REQUEST] flag
is good.
Coding style
============
Robert Widhopf-Fenk <hack at robf dot de> wrote
in Message-ID: <16552.35294.211101.658893@gargle.gargle.HOWL>
I really would like to see no lines longer than 80 chars in xtla.el.
Please, strip trailing whitespaces from your source files.
;; remove trailing whitespaces when saving.
(add-hook 'write-file-hooks 'delete-trailing-whitespace)
in your ~/.emacs.el can help.
Also, don't include any tabs in your source code. You should use
(setq indent-tabs-mode nil)
If you do not want to enable it in general, use something like the following
in your ~/.emacs:
(defun rf-dvc-find-file-hook ()
(when (and (buffer-file-name)
(string-match "xtla\\|dvc" (buffer-file-name)))
(message "Enabled Xtla/DVC settings for buffer %s" (buffer-name))
(make-local-hook 'write-file-hooks)
(add-hook 'write-file-hooks 'delete-trailing-whitespace nil t)
(setq indent-tabs-mode nil)))
(add-hook 'find-file-hooks 'rf-dvc-find-file-hook)
Non-trivial macros should include the form:
(declare (indent INDENT-SPEC) (debug DEBUG-SPEC))
The INDENT-SPEC tells Emacs' indentation commands how to indent the form,
whereas DEBUG-SPEC tells Edebug how to instrument the form for debugging.
See: (info "(elisp) Indenting Macros") and
(info "(elisp) Edebug and Macros") for more info.
Indentation is not (completely) arbitrary. There are three steps,
the first of which need be done only once per editing session.
- Make sure you evaluate *all* `defmacro' forms so that Emacs knows
about each form's indentation spec (if any).
- Use C-M-q at top-level open-paren to canonicalize indentation.
- Apply stylistic exceptions (manual override). Common cases:
- `flet', `labels', `macrolet' -- Emacs does a poor job here, indenting
too much, so overriding it is almost a requirement (many examples);
- deliberate flush-left (to column 0) so that C-M-x "continues to work"
on an inner form (eg: dvc-capturing-lambda);
- end-of-line ";;"-comment alignment (eg: defstruct dvc-fileinfo-file).
Process management
==================
The function dvc--run-arch now creates two buffer each time it is
called: a process buffer, and an error buffer. If the process is ran
synchronously, then the buffers are scheduled for deletion. If not,
the scheduling for deletion occurs in the process sentinel.
This means you will need to clone the buffer if you need to run arch
again while parsing the output buffers. (This was already necessary
with the old mechanism)
The variables tla--last-process-buffer and tla--last-error-buffer are
set each time a new process or error buffer is created. The value is
therefore meaningfull only until a new process is started. Avoid using
them when you're not sure the piece of code you're writting will not
one day be made asynchronous: This become meaningless in a process
sentinel.
I (Mark) have thrown in my two cents on the process management
stuff. I've added two functions: one for running tla synchronously
(tla--run-tla-sync), and one for running it asynchronously
(tla--run-tla-async). Their syntax is pretty much identical, which is as
follows:
(tla--run-tla-(a)sync '("tla-arg1" "tla-arg2" .. "tla-argn")
:finished (lambda (output-buffer error-buffer status)
..)
:killed (lambda (output-buffer error-buffer status)
..)
:error (lambda (output-buffer error-buffer status)
..)
:output-buffer some-buffer
:error-buffer some-buffer
:related-buffer some-buffer)
The keywords :FINISHED, :KILLED and :ERROR supply callbacks, which are
functions that take four arguments:
* the buffer containing the process output
* the buffer containing the process error output; and
* some indicator of the processes status (which can either be a
return code or a string).
* the argument list that the command was run with (e.g. ("undo"))
The :FINISHED callback is called in the case where the program finishes
successfully. The :KILLED callback is called when the program was
unexpectedly killed while running, and the :ERROR callback is called
when the program fails for some reason.
If :OUTPUT-BUFFER or :ERROR-BUFFER are supplied, the process will write
its standard/error output to these instead of generating buffers
automatically. Where these keywords are not given, new buffers will be
created, filled with program output and passed to the callback
functions.
Although it shouldn't ordinarily matter, it is worth noting that if
:OUTPUT-BUFFER or :ERROR-BUFFER are not given, the temporary buffers
that are created will be killed immediately after the callback
exits. This just means that if you plan on keeping those buffers around
for longer than just the scope of the callback, you'll need to clone
them first.
As a quick example, here is how you could asynchronously run a "tla
abrowse -s" and send the output to a printer (I'm not sure why you would
want to do this, but that's the great thing about contrived examples!):
(defun print-archive (archive &optional postscript-output-file)
"Run an abrowse on ARCHIVE and send the result to the printer."
(tla--run-tla-async (list "abrowse" "-s" "-A" archive)
:finished `(lambda (output-buffer error-buffer
status arguments)
(with-current-buffer output-buffer
(ps-print-buffer ,postscript-output-file)
(message "Printed abrowse to %s."
(or ,postscript-output-file
"printer"))))))
The only really noteworthy thing is the use of the backquoted
lambda. This is kind of like a poor man's lexical scoping, but it's a
useful way of capturing variables from the containing environment.
Name manipulator
================
See xtla-core.el.
Release & distribution process
==============================
* Development version
---------------------
The prefered way to get a development version is to use either
Bazaar or Git to clone the latest repo.
Programs for maintainers:
(required) autoconf, tar, gzip, makeinfo
(optional) texi2dvi, etags
With the exception of gzip (which is invoked simply as "gzip"),
the invocation of each of these programs is influenced by a
makefile variable of the same name, but all upcased. For example,
you can choose a different tar for "make dist" using the command:
make dist TAR=/path/to/my/tar
The default values for these variables is simply the program name.
Historical note: We used to AC_PATH_PROG them in configure.ac, but
that did not benefit the end user (./configure && make all install),
so we stopped mid-2008.
* Official releases
-------------------
Official releases will be made by the release manager, after
discussion on the mailing list.
The release manager will modify configure.ac to set the second
arg of AC_INIT to 1.1, for example, and then type the commands
autoreconf
./configure (or ./config.status --recheck)
make
make dist

285
dvc/docs/TODO
View File

@ -1,285 +0,0 @@
-*- mode: text -*-
TODO/Wish list for xtla.el
==========================
Mostly DONE section:
====================
* Some like file-diff-rev from the aba which gives you the changes to a
file between two specified revisions using the following:
diff -u $(tla file-find file.cpp $(tla tree-version)--patch-X)
$(tla file-find file.cpp $(tla tree-version)--patch-Y)
=> This is the function tla-file-ediff-rev. There should also be a
version without ediff, just showing the diff output with
diff-mode.
* Integration with ediff, which I usually prefer to diff-mode.
- This is done for M-x tla-ediff-buffer, `e' in *tla-changes*, 'd
e' in *tla-inventory*
- There is more to do from the *tla-revisions* buffer for example
(retrieve any two revisions and ediff them)
- a 3 way merge with ediff3 would be perfect. (Actually, ediff3
isn't sufficient because it shows you the differences even in the
absence of conflict.). smerge-mode, integrated in Emacs 21,
already does a very good job for this
* En entry "Branch from version" to create a symbolic tag from the
*tla-versions* buffer.
- Done for *tla-revisions*.
* Code cleaning. There are a lot of duplicates.
=> Some big code cleaning have been carried out, but such item can
never go to the "completely DONE" section ;-)
DONE section:
=============
* One line log from minibuffer to commit.
=> This should be handled in vc-arch.el?
* Add good doc strings for the functions
=> Most functions have one now.
* Recursive commands for projects using configurations.
=> implemented for tla-changes and tla-update
* Name reader should support complete location notation like:
Location: Matthieu.Moy@imag.fr--public/xtla--main--0.1
Current partial and incremental location reading is supported
like:
Archive: Matthieu.Moy@imag.fr--public
Category: xtla
Branch: main
Version: 0.1
=> The engine is implemented. Apply it to interactive functions.
* Add a texinfo file
- What should be the structure of this file?
=> Very short. Just a starting point for the users, but xtla should
be self-documented. Menus and docstrings should be sufficient
most of the time.
A demo with screenshots would be nice too. (to let people get
an idea of what xtla is in less than a minute.)
- Should we guide through the tla tutorial?
(Be carefull. I don't like people to learn a tool from the
front-end. I prefer let them understand the concepts with the
command line, and learn the front-end after. It takes a bit more
time but is much more pedagogical)
* M-x xtla should provide the buttons to jump tla-inventory,
tla-bookmarks and so on. This should be integrated with the command central?
* Optimize tla-archive-tree manipulator when it is updated.
I think using rbrowse and/or abrowse output is better than current
implementation.[Masatake] Not so much, because browsing a small
branch in a big archive would be slow (discussed on the ML)
[Matthieu]
* tla log font-lock (like ChangeLog)
* A "revert file" feature. Most of the code is already in
tla-file-ediff. (done in tla-file-revert)
* Archive mirroring.
[Matthieu Moy: I'm taking care of this]
* Prompt for saving buffer visiting files of the current tree for most
operations: commit, update, changes, ... (Which other ones ?)
* M-x xtla-update. Possibility to update from the bookmarks buffer.
* Merge xtla-fully-qualified-revision and xtla-name-construct.
[Masatake YAMATO]
* M-x tla-missing RET should be merged with tla-bookmarks-missing
* Bridge between smerge-mode and xtla.el.
[Masatake YAMATO
(Should completely replace my code -- Matthieu)
(No, I shouldn't. Each function has each necessity.)
* When there are no changes anymore, the `g' command in the
*tla-changes* buffer just prints a message in the echo area, and
doesn't update the buffer, which can be confusing; it would be
better to erase the buffer and perhaps insert the "No changes"
description to make it clear what's going on (so work slightly
differently than `M-x tla-changes' invoked from another buffer -- in
that case, just a message is good).
=> tla-changes now clears the *tla-changes* buffer before doing
anything else.
* More diff-mode commands should be bound in the *tla-changes* buffer,
e.g., `P', and `N'; maybe it can just inherit from the diff-mode
keymap?
=> We are already inheriting from diff-mode. However, the way the keymap
is managed in diff-mode is really strange, and you're right,
we're not inheriting `N' and `P'. But still, diff-file-next is
available with M-N for example. Strange ...
=> initializing tla-changes-mode-map from diff-mode-shared-map
did it.
* It would be nice if the `g' command in a *tla-changes* buffer would
would retain any existing marks (I often want to check the changes
just one last time before committing).
* Perhaps when `tla-make-log-function' is non-nil, `tla-make-log' should
check the return value, and if nil, make a normal log file. That way
the user's special version can only worry about special cases.
=> I (Matthieu MOY) did something a bit different.
tla-make-log-function now defaults to
tla-default-make-log-function, which calls "tla make-log". The
user can just write a wrapper around this function.
* Wrapper for tla import.
- From the working directory, M-x tla-start-project RET should run
. tla init-tree
. tla import --setup
. call tla-edit-log
[Mark Triggs: This is pretty much what I have done, except I have
used tla-inventory instead of tla-edit-log.]
- From the archive browser, there should be an option to offer the
user to create a new project, as you can already create new empty
categories, branches, and versions.
* There could be a menu to navigate buffers based on the variable
tla--buffers-tree. This could also be included in tla-browse.el
using tree-widget.
=> pulldown/popup menu is implemented. Maybe enough -- Masatake.
* undo modifications in local copy at tla-inventory buffer
Matthieu gave hit in the mailing list:
What I meant by "undo" was
cp `tla file-find foo.c` .
* Run missing, replay and star-merge against specified version.
* Eliminate all occurence of tla--run-arch.
* If not in a project tree, `tla-changes' should prompt for the tree
name similar to tla-inventory -- often I'd rather start out with
`changes' and skip `inventory' entirely.
* Modeline : I'd like to see something like the "compiling" item in
the modeline while compiling with M-x compile RET.
* An interface to tla help, giving the list of commands, and running
"tla <command> -H" on demand.
* Create archives with --listing and/or --signed
* make tla-inventory-toggle-* customizable
M-x customize-variable RET tla-inventory-display-* RET
* After committing from a *tla-changes* buffer, it would be good to
automatically update the buffer, so there's a clear indication
what's changed.
* Better management of buffers. xtla buffers should have a unique name
based on the directory or archive to which it refers. It should be
possible to run several tla-{change|inventory|revisions|...} in
different trees. We should keep a list of xtla related buffer to be
able to delete them afterwards. (The current regexp-based algorithm
is not satisfying in my opinion)
=> The function is there : tla--get-buffer-create, and used for
tla-changes and tla-inventory. It's used by default by
tla--show-last-process-buffer and tla--show-error-buffer.
* Tree widget based archive browser. [see tla-browse.el. -- Masatake]
- Libraries should be handled here.
* C-u C-c C-m generates buggy summary line patch numbers.
* Allow cherry picking by marking a set of revisions in a *tla-revisions*
buffer and the run replay with all of the marked revisions as argument. I
(Robert) just had a case where I would need this, i.e. I have a hacking
branch with related revisions (but they are interleaved by others) which I
want to combine into a single change set for the main branch. "tla delta"
does not help here.
* tla-browse should be stronger against errors.
Currently, when an error occur, a tree becomes broken.
[Masatake]
* Should we do something for revision libraries ?
Yes [Masatake].
- Revisions should be marked in *tla-revisions*(done)
- Adding(done)
- tla-library-tree is needed(done).
* Interface to store a changeset to a file(tla changeset?) in revisions buffer.
[?> ?=] or [?d ?>]
* Interface to apply a changeset directory to a local copy in inventory buffer.
[?M ?=] or [?< ?=] but ?< is serverd for mirror.
* M-x tla-review-last-patch RET. See my recent post "Improving
tla-changes and related commands." on xtla-el-dev@gna.org.
(Matthieu)
=> finally, I've called it tla-changes-last-revision
* I (Matthieu) have added a variable tla-buffer-refresh-function and
a function tla-generic-refresh calling it. This could be used in
all xtla modes.
* Define xtla own faces. These faces should be
derived from font-lock's standard face set.
* Don't use a string to refer xtla's buffer. Instead use symbol.
e.g.
Don't use: (get-buffer-create "*tla-missing*")
Use: (cdr (assoc 'missing tla--buffer-type-alist))
* Handle file renaming in changes buffer. Here is the example output:
[jet@localhost symresolver]$ tla changes
* looking for jet@gyve.org--inspector/symresolver--prototype--0.0--patch-9 to compare with
* comparing to jet@gyve.org--inspector/symresolver--prototype--0.0--patch-9
M Makefile.am
=> .arch-ids/symresolver.c.id .arch-ids/lib.c.id
=> symresolver.c lib.c
`=>' should be parsed.
* Interface to add entries to .arch-inventory
* Switching "default tree version " in inventory buffer
* Don't do (concat file "/"). Do (file-name-as-directory file) instead.
** Check the faces on non X, terminal environment
=> [Matthieu] I use xtla most of the time in text mode, but I have
a rather much customized Emacs. I've just checked with emacs -q,
both in dark and light background.
* We should definitely switch to ewoc.el to manage lists. This is what
pcl-cvs, dired and so are using. We would get a lot of feature (in
particular, mouse reactivity) almost for free. The code for marking
revisions could also be really improved by this. I already did this
for the *tla-bookmarks* buffer (Matthieu MOY) and for
*tla-bookmarks-missing* and *tla-revisions*, it's fairly easy to
use.
* Name read engine
-- Integrate with other parts of xtla
--- Get completion from bookmarks
* Run lint under a dedicated mode, so the user can jump to the position
where the lint reports the problem is.
=> There is now a tla tree-lint mode. It's almost finished by now,
but still not well tested and incomplete (no context menu[done], ...)
** (Again) Check `cd' usage. Its changes the default-directory of current buffer.
Sometimes it will cause bugs. (let ((default-directory ...))) may be
enough in many cases. [Matthieu] Should be OK now.

348
dvc/docs/xmtn-readme.txt
View File

@ -1,348 +0,0 @@
* General
xmtn is an Emacs Lisp package that provides a DVC backend for monotone
(the distributed version control system) as well as general facilities
for interacting with monotone from Emacs Lisp.
For more information about monotone, see http://monotone.ca/ .
xmtn's facilities for interacting with monotone are meant to be
reusable by code that is unrelated to DVC, even though they currently
depend on the subprocess handling utilities that DVC provides.
xmtn should work on GNU Emacs 21 or newer. Work on supporting XEmacs
has started but is unfinished; patches welcome. On XEmacs, xmtn
requires MULE.
* Download and installation
Follow the download and installation instructions for DVC. xmtn is
part of DVC.
In addition, the variable `xmtn-executable' needs to point to the
monotone executable. It defaults to "mtn", which will be sufficient
if mtn is in your PATH. Depending on your configuration, the PATH
that Emacs sees can differ from the PATH that you see in your shell.
Try M-x getenv RET PATH RET if in doubt.
You may wish to set `dvc-debug' to nil; DVC tends to be a bit chatty.
* Brief tutorial
(DVC's tutorial does not apply to xmtn, it seems to be specific to
tla.)
Start Emacs. Visit a file that is under version control by monotone.
Modify the file. While in the file's buffer, press C-x V d to see the
diff for this file.
Pressing C-x V = will bring up the tree diff buffer. (What monotone
calls a "workspace" is called a "tree" in DVC.) This buffer shows the
list of all modified files in the tree as well as the diffs for those
files. Use j to jump back and forth between the name of a file in the
list and the diffs for that file. Use RET with point inside a diff
hunk to go to the corresponding file at the corresponding position.
Like many other DVC buffers, the contents of the tree diff buffer can
be refreshed using g.
In the tree diff buffer, files to commit can be marked and unmarked
with m and u. Pressing c lets you commit the selected files; it will
bring up a log edit buffer where you can enter a commit message.
In the log edit buffer, the commit can be executed by pressing C-c
C-c. To abort the commit, simply don't press C-c C-c -- just switch
away from the buffer or kill it. The log edit buffer edits the file
_MTN/log.
To bring up the log edit buffer without going through the tree diff
buffer, use C-x V c.
To view the revision history, use C-x V l or C-x V L. The former
shows the full commit message for each revision, while the latter only
shows the first line. The resulting buffer is a so-called revlist
buffer. In revlist buffers, use cursor up/down to move between
revisions, RET to show details on the revision at point, = to show its
diff from its parent. Revisions can be marked and unmarked with m and
u.
M-x xmtn-view-heads-revlist shows a revlist buffer with just the heads
of the default branch of your tree. To update your tree to one of the
revisions in a revlist buffer, move point to it and use M-x
xmtn-revlist-update. To merge two head revisions, mark them and use
M-x xmtn-revlist-explicit-merge.
M-x xmtn-view-revlist-for-selector prompts for a monotone selector and
shows a revlist buffer with all matching revisions.
C-x V u performs mtn update. C-x V m shows a revlist buffer with the
revisions that mtn update would apply to your tree.
C-x V f a performs mtn add. M-x dvc-ignore-files and M-x
dvc-ignore-file-extensions can be used to add entries to .mt-ignore.
These commands can also be used from dired buffers.
C-x V s shows the status buffer. This currently shows modified,
renamed and unknown files. It's supposed to allow operations like
diff, commit, revert etc. (like pcl-cvs), but that's not implemented
yet. C-x V = is preferable at the moment, although it doesn't show
unknown files.
C-x V a can be used to add a ChangeLog entry to _MTN/log.
There are other useful operations, but these should be enough to get
started.
* Known limitations
xmtn currently just bails out when it needs to operate on a head of a
branch and notices that the branch is unmerged. It should prompt the
user to select a head instead. To update to a head of an unmerged
revision graph, use M-x xmtn-view-heads-revlist and M-x
xmtn-revlist-update.
`xmtn-dvc-diff' breaks when called in a workspace that has no base
revision (e.g. a newly created project). mtn diff works in this case.
Building a revlist buffer is currently a bit slow (or maybe very slow
for long histories?), and the revlist display is not very pretty.
For `dvc-ignore-files' and `dvc-ignore-file-extensions', xmtn operates
on the file .mtn-ignore. This may fail to have the intended effect if
the user has customized monotone's ignore_file hook in a way that
changes the meaning of this file.
The ability to perform operations such as diff and commit from the
status buffer is missing. For now, use the tree diff buffer for this.
xmtn doesn't define any key bindings for monotone-specific commands.
Only the backend-independent key bindings defined by DVC are available.
For now, I don't see the point of checking automate interface_version:
Many of xmtn's operations rely on non-automate commands, so a
compatible automate interface_version doesn't guarantee actual
compatibility; we have to check for a compatible command version
anyway, and that check subsumes the check of interface_version. And
declaring incompatibility whenever we see an automate
interface_version that is too high for us yields false positives too
easily to be useful.
xmtn currently uses mtn automate get_revision in places where it
should be using mtn automate inventory. This is because I was trying
to avoid having to implement a parser for mtn automate inventory, and
get_revision seemed to return almost the same information. However,
get_revision fails if there are missing files -- I discovered this too
late. This is part of the reason why many operations first check
whether files are missing from the tree, and abort if this is the
case.
DVC REVISION-IDs that refer to the "Nth ancestor" such as `(xmtn
(last-revision ...))' or `(xmtn (previous-revision ...))' are
ill-defined for non-linear history in monotone. xmtn currently
throws an error when it encounters a node that has multiple parents
while trying to resolve such IDs.
The support for international character sets/coding systems is partly
based on guesswork but works for my tests.
xmtn does not entirely follow DVC's philosophy: It only implements
DVC's protocols, but doesn't provide its own UI that parallels DVC's.
Hence, much of xmtn's functionality is only available through DVC.
This is because xmtn currently provides only few features beyond what
DVC requires, and implementing a redundant UI was not a high priority
for me.
Currently, the following parts of the DVC protocol are not implemented
by xmtn:
* xmtn-dvc-send-commit-notification, xmtn-dvc-submit-patch: These
commands send an e-mail. Probably useful to people who use a
certain work flow, but not to me right now. These will have to
wait until someone comes along who actually has a use for them.
* xmtn-insinuate-gnus: Need to find out what, precisely, this is
supposed to do. I don't use Gnus myself.
* xmtn-dvc-save-diff: xhg seems to be the only backend that
implements this. It really seems this could be moved into the
common part of DVC anyway. Won't bother implementing it right
now.
* xmtn-dvc-pull: Should be easy. But syncing via command line is
acceptable to me at the moment. The docstring looks like this
needs to do both mtn pull and mtn update -- but I doubt that this
is a good idea for monotone.
* Internals
This section describes some of the internals of xmtn and some of the
design decisions behind it.
** Conventions
monotone.el (from montone's contrib/ directory) already uses the
prefix mtn-. monotone- is already taken by Wim Oudshoorn's e-monotone
package. So this package is named xmtn. xhg, xcg, xdarcs seem to be
in similar situations.
The prefix xmtn- is for definitions exported for the user or for DVC,
the prefix xmtn-- is for internal definitions. Similarly,
xmtn-automate uses xmtn-automate- and xmtn-automate--, etc.
It seems like "monotone" is usually written in small letters. The
manual capitalizes it at the beginnings of sentences, but e.g. the web
page or mtn --version never capitalize it at all -- then again, the
web page doesn't capitalize much at all. In xmtn, we capitalize it
like a noun. xmtn and mtn (as a command name) are always in lower
case.
Monotone uses the term "workspace", DVC uses the term "tree". In our
UI, we use "tree" for consistency with DVC. The idea behind this
decision was that consistency with DVC (and other aspects of Emacs'
UI) is more important than consistency with other monotone front-ends.
But I'm not so sure about this any more; the term "workspace" is so
much more clear... But I guess it makes little sense for version
control systems that don't distinguish between workspaces and
branches.
** Architecture
This section is unlikely to stay fully up-to-date as xmtn's
implementation evolves, but should remain useful as a general
introduction to xmtn's architecture.
xmtn consists of several modules. One way of understanding their
relationship is to group them into layers.
User-visible functionality: xmtn-dvc.el, xmtn-revlist.el
Domain-specific utilities: xmtn-ids.el
High-level interface to mtn: xmtn-automate.el, xmtn-basic-io.el
Low-level interface to mtn: xmtn-run.el
Monotone-related definitions: xmtn-base.el
Support libraries: xmtn-compat.el
Language extensions: xmtn-match.el
Each module should only depend on modules at layers beneath it. (At
least, that's the idea; the code might not satisfy this perfectly.)
xmtn-dvc.el implements the protocols required by DVC, except for
functionality related to interactive display and manipulation of
revision history, which is in xmtn-revlist.el.
xmtn-ids.el contains code to resolve symbolic revision ids in a
certain syntax to explicit hash ids. DVC needs this, but xmtn
provides some useful extensions. For example, a symbolic id `(xmtn
(previous-revision (previous-revision (revision
"75da2575dfc565f6976ed5dd1997bc7afc0ce908"))))' resolves to `(revision
"721c3ab9b5099d3ed7d8b807e08382f3c95badec")'; i.e. the parent of the
parent of revision 75da2575dfc565f6976ed5dd1997bc7afc0ce908 is
revision 721c3ab9b5099d3ed7d8b807e08382f3c95badec.
xmtn-automate.el and xmtn-basic-io.el implement an interface to
monotone's automate functionality and a parser for monotone's basic_io
output format. These modules aren't specific to DVC and should be
reusable by other Emacs Lisp code that wants to use monotone.
xmtn-run.el provides functions for running individual (non-automate)
monotone commands and checking the version of the monotone executable.
The functionality of xmtn-run.el isn't specific to DVC, either, but
its current implementation depends on DVC's process handling
functions, so it's fairly heavyweight.
xmtn-base.el was supposed to contain definitions related to monotone
that are common to xmtn-run.el, xmtn-automate.el and/or
xmtn-basic-io.el, to avoid having to have dependencies on xmtn-run.el
in xmtn-automate.el or xmtn-basic-io.el. This refactoring is not
complete (yet?), though.
xmtn-compat.el contains compatibility wrappers for some Emacs Lisp
functions that are not fully portable across Emacs versions.
xmtn-match.el provides a pattern-matching facility for Emacs Lisp that
is very useful for destructuring DVC REVISION-IDs and processing
basic_io stanzas the way xmtn-basic-io.el parses them. But it is
rather generic and could also be useful for code entirely unrelated to
montone and DVC.
There are a few automated regression tests in
lisp/tests/xmtn-tests.el.
** Implementation details
*** Futures
For some subprocess interactions, xmtn uses a concept called
"futures". In this context, a future is a concurrent computation
represented by a zero-argument anonymous function that, when called,
blocks until the concurrent computation finishes, and returns its
result.
For example, the function `xmtn--unknown-files-future' returns a
future for the list of unknown files instead of returning the list of
unknown files directly. This allows Emacs Lisp code to ask monotone
for the list of unknown files, but then do something different while
monotone computes the list. Only when Emacs actually needs the list
in order to continue, it calls the future and waits for monotone to
finish (if it hasn't finished already).
If a future is called a second time or more often, it will just keep
returning the same result. (What a future does if the concurrent
computation terminates unsuccessfully isn't currently very
well-defined. It should probably signal an error when it is called.)
Spawning computations in parallel has yielded tremendous speed-ups for
certain parts of xmtn (at least in some versions -- I haven't profiled
it recently). Futures make this type of parallelism simple to deal
with.
*** Notes on variable names and dynamic bindings
In higher-order functions (functions that take functions as
arguments), xmtn attempts to avoid introducing spurious dynamic
bindings because they might shadow bindings that the caller wants to
provide to the argument function. xmtn uses `lexical-let' for this
purpose. Unfortunately, function arguments are always dynamic
bindings in Emacs Lisp. That's why the argument names of higher-order
functions in xmtn always have the prefix xmtn-- and are immediately
re-bound to (pseudo-)lexical variables using `lexical-let'. This
makes it unlikely that the arguments will collide with the caller's
variables.
The alternative would be to always use `lexical-let' for bindings that
should be passed through higher-order functions to closures. This is
the most reliable approach, and xmtn also follows it. But errors
resulting from accidental violations of this convention can be very
hard to debug, so the above is still useful for additional safety.
LocalWords: DVC minibuffer UI montone xmtn revlist unmerged docstring backend
LocalWords: backends destructuring mtn

24
dvc/dvc-load-install.el.in
View File

@ -1,24 +0,0 @@
; -*- mode: emacs-lisp -*-
;;
;; Load DVC easily ...
;;
;; Manually, you can run
;;
;; M-x load-file RET /path/to/dvc-load.el RET
;;
;; (usefull when you want to load DVC after starting "emacs -q"!), or
;; add
;;
;; (load-file "/path/to/this/file/in/installdir/dvc-load.el")
;;
;; to your ~/.emacs.el
(add-to-list 'load-path "@lispdir@/")
(add-to-list 'Info-default-directory-list "@info_dir@")
(if (featurep 'dvc-core)
(dvc-reload)
(if (featurep 'xemacs)
(require 'auto-autoloads)
(require 'dvc-autoloads)))

26
dvc/dvc-load.el.in
View File

@ -1,26 +0,0 @@
; -*- mode: emacs-lisp -*-
;;
;; Load DVC easily ...
;;
;; Manually, you can run
;;
;; M-x load-file RET /path/to/dvc-load.el RET
;;
;; (usefull when you want to load DVC after starting "emacs -q"!), or
;; add
;;
;; (load-file "/path/to/this/file/in/builddir/dvc-load.el")
;;
;; to your ~/.emacs.el
(add-to-list 'load-path "@abs_top_builddir@/lisp")
(unless (locate-library "ewoc")
(add-to-list 'load-path "@abs_top_builddir@/lisp/contrib"))
(add-to-list 'Info-default-directory-list "@abs_top_builddir@/texinfo")
(if (featurep 'dvc-core)
(dvc-reload)
(if (featurep 'xemacs)
(require 'dvc-autoloads "@abs_top_builddir@/lisp/auto-autoloads.elc")
(require 'dvc-autoloads)))

251
dvc/install-sh
View File

@ -1,251 +0,0 @@
#!/bin/sh
#
# install - install a program, script, or datafile
# This comes from X11R5 (mit/util/scripts/install.sh).
#
# Copyright 1991 by the Massachusetts Institute of Technology
#
# Permission to use, copy, modify, distribute, and sell this software and its
# documentation for any purpose is hereby granted without fee, provided that
# the above copyright notice appear in all copies and that both that
# copyright notice and this permission notice appear in supporting
# documentation, and that the name of M.I.T. not be used in advertising or
# publicity pertaining to distribution of the software without specific,
# written prior permission. M.I.T. makes no representations about the
# suitability of this software for any purpose. It is provided "as is"
# without express or implied warranty.
#
# Calling this script install-sh is preferred over install.sh, to prevent
# `make' implicit rules from creating a file called install from it
# when there is no Makefile.
#
# This script is compatible with the BSD install script, but was written
# from scratch. It can only install one file at a time, a restriction
# shared with many OS's install programs.
# set DOITPROG to echo to test this script
# Don't use :- since 4.3BSD and earlier shells don't like it.
doit="${DOITPROG-}"
# put in absolute paths if you don't have them in your path; or use env. vars.
mvprog="${MVPROG-mv}"
cpprog="${CPPROG-cp}"
chmodprog="${CHMODPROG-chmod}"
chownprog="${CHOWNPROG-chown}"
chgrpprog="${CHGRPPROG-chgrp}"
stripprog="${STRIPPROG-strip}"
rmprog="${RMPROG-rm}"
mkdirprog="${MKDIRPROG-mkdir}"
transformbasename=""
transform_arg=""
instcmd="$mvprog"
chmodcmd="$chmodprog 0755"
chowncmd=""
chgrpcmd=""
stripcmd=""
rmcmd="$rmprog -f"
mvcmd="$mvprog"
src=""
dst=""
dir_arg=""
while [ x"$1" != x ]; do
case $1 in
-c) instcmd="$cpprog"
shift
continue;;
-d) dir_arg=true
shift
continue;;
-m) chmodcmd="$chmodprog $2"
shift
shift
continue;;
-o) chowncmd="$chownprog $2"
shift
shift
continue;;
-g) chgrpcmd="$chgrpprog $2"
shift
shift
continue;;
-s) stripcmd="$stripprog"
shift
continue;;
-t=*) transformarg=`echo $1 | sed 's/-t=//'`
shift
continue;;
-b=*) transformbasename=`echo $1 | sed 's/-b=//'`
shift
continue;;
*) if [ x"$src" = x ]
then
src=$1
else
# this colon is to work around a 386BSD /bin/sh bug
:
dst=$1
fi
shift
continue;;
esac
done
if [ x"$src" = x ]
then
echo "install: no input file specified"
exit 1
else
true
fi
if [ x"$dir_arg" != x ]; then
dst=$src
src=""
if [ -d $dst ]; then
instcmd=:
chmodcmd=""
else
instcmd=mkdir
fi
else
# Waiting for this to be detected by the "$instcmd $src $dsttmp" command
# might cause directories to be created, which would be especially bad
# if $src (and thus $dsttmp) contains '*'.
if [ -f $src -o -d $src ]
then
true
else
echo "install: $src does not exist"
exit 1
fi
if [ x"$dst" = x ]
then
echo "install: no destination specified"
exit 1
else
true
fi
# If destination is a directory, append the input filename; if your system
# does not like double slashes in filenames, you may need to add some logic
if [ -d $dst ]
then
dst="$dst"/`basename $src`
else
true
fi
fi
## this sed command emulates the dirname command
dstdir=`echo $dst | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'`
# Make sure that the destination directory exists.
# this part is taken from Noah Friedman's mkinstalldirs script
# Skip lots of stat calls in the usual case.
if [ ! -d "$dstdir" ]; then
defaultIFS='
'
IFS="${IFS-${defaultIFS}}"
oIFS="${IFS}"
# Some sh's can't handle IFS=/ for some reason.
IFS='%'
set - `echo ${dstdir} | sed -e 's@/@%@g' -e 's@^%@/@'`
IFS="${oIFS}"
pathcomp=''
while [ $# -ne 0 ] ; do
pathcomp="${pathcomp}${1}"
shift
if [ ! -d "${pathcomp}" ] ;
then
$mkdirprog "${pathcomp}"
else
true
fi
pathcomp="${pathcomp}/"
done
fi
if [ x"$dir_arg" != x ]
then
$doit $instcmd $dst &&
if [ x"$chowncmd" != x ]; then $doit $chowncmd $dst; else true ; fi &&
if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dst; else true ; fi &&
if [ x"$stripcmd" != x ]; then $doit $stripcmd $dst; else true ; fi &&
if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dst; else true ; fi
else
# If we're going to rename the final executable, determine the name now.
if [ x"$transformarg" = x ]
then
dstfile=`basename $dst`
else
dstfile=`basename $dst $transformbasename |
sed $transformarg`$transformbasename
fi
# don't allow the sed command to completely eliminate the filename
if [ x"$dstfile" = x ]
then
dstfile=`basename $dst`
else
true
fi
# Make a temp file name in the proper directory.
dsttmp=$dstdir/#inst.$$#
# Move or copy the file name to the temp name
$doit $instcmd $src $dsttmp &&
trap "rm -f ${dsttmp}" 0 &&
# and set any options; do chmod last to preserve setuid bits
# If any of these fail, we abort the whole thing. If we want to
# ignore errors from any of these, just make sure not to ignore
# errors from the above "$doit $instcmd $src $dsttmp" command.
if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; else true;fi &&
if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; else true;fi &&
if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; else true;fi &&
if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; else true;fi &&
# Now rename the file to the real destination.
$doit $rmcmd -f $dstdir/$dstfile &&
$doit $mvcmd $dsttmp $dstdir/$dstfile
fi &&
exit 0

97
dvc/lisp/Makefile.in
View File

@ -1,97 +0,0 @@
@SET_MAKE@
PACKAGE_VERSION = @PACKAGE_VERSION@
PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@
##############################################################################
# location of required programms
prefix = @prefix@
RM = @RM@
ETAGS = etags
MKDIR_P = @MKDIR_P@
INSTALL = @INSTALL@
INSTALL_DATA = @INSTALL_DATA@
top_srcdir = @top_srcdir@
srcdir = @srcdir@
datarootdir= @datarootdir@
lispdir = @lispdir@
EMACS_PROG = @EMACS_PROG@
FLAGS = @FLAGS@
# Other settings
OTHERDIRS = @OTHERDIRS@
ebatch = srcdir=$(srcdir) otherdirs="$(OTHERDIRS)" \
$(EMACS_PROG) -batch -q $(FLAGS) -l $(srcdir)/dvc-build.el -f
alldeps = dvc-version.el dvc-site.el
all: $(alldeps)
$(ebatch) dvc-build-all
all-verbose: $(alldeps)
$(ebatch) dvc-build-all verbose
# We install foo.el only if there is also foo.elc.
install: all
$(MKDIR_P) -m 0755 "$(lispdir)"
@dlist='$(srcdir) $(srcdir)/contrib' ; \
test '$(srcdir)' = '.' || dlist=". $$dlist" ; \
for elc in *.elc ; do \
el=`echo $$elc | sed 's/.$$//'` ; orig= ; \
for d in $$dlist ; do \
if [ -r "$$d/$$el" ] ; then \
orig="$$d/$$el" ; break ; fi ; done ; \
test "$$orig" || continue ; \
echo Installing $$el ; \
$(INSTALL_DATA) "$$orig" "$(lispdir)" ; \
echo Installing $$elc ; \
$(INSTALL_DATA) $$elc "$(lispdir)" ; \
done
$(INSTALL_DATA) $(srcdir)/xmtn-hooks.lua $(lispdir)
clean:
rm -f *.elc dvc-site.el \
dvc-autoloads.el auto-autoloads.el custom-load.el
Makefile: $(srcdir)/Makefile.in ../config.status
cd ..; ./config.status
distclean: clean
rm -f Makefile
maintainer-clean:
rm -f dvc-version.el
TAGS: $(SRCS)
@if test "x$(ETAGS)" = "x" ; then \
echo "Sorry, no \`etags' program available." ; \
else \
$(ETAGS) */*.el ; \
fi
##############################################################################
autoloads:
$(ebatch) dvc-build-autoloads $(srcdir)
##############################################################################
dvc-version.el: ../config.status
@echo Creating $@
@( echo ';;; $@ (generated file -- do not edit!)' ; \
echo '(defconst dvc-version "$(PACKAGE_VERSION)"' ; \
echo ' "Version of DVC loaded.' ; \
echo 'Please send bug reports to <$(PACKAGE_BUGREPORT)>.")' ; \
echo "(provide 'dvc-version)" ) \
> $@
dvc-site.el: ../config.status $(srcdir)/dvc-site.el.in
(cd .. ; ./config.status lisp/$@)
.PHONY: all all-verbose install \
clean distclean maintainer-clean

54
dvc/lisp/baz-dvc.el
View File

@ -1,54 +0,0 @@
;;; baz-dvc.el --- The dvc layer for baz
;; Copyright (C) 2005, 2007 by all contributors
;; Author: Stefan Reichoer, <stefan@xsteve.at>
;; Contributors: Matthieu Moy, <Matthieu.Moy@imag.fr>
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; This file provides the common dvc layer for baz support
(require 'baz)
(eval-and-compile (require 'dvc-unified))
;;;###autoload
(dvc-register-dvc 'baz "Bazaar 1")
(defalias 'baz-dvc-tree-root 'baz-tree-root)
(defun baz-dvc-diff (base-rev path dont-switch)
(baz-changes nil base-rev))
(defalias 'baz-dvc-file-diff 'baz-file-diff)
(defalias 'baz-dvc-log-edit 'tla-dvc-log-edit)
(defun baz-dvc-add (file)
(baz-add nil file))
(defun baz-dvc-log (arg last-n)
"Shows the changelog in the current Arch tree."
(baz-logs))
(defun baz-dvc-search-file-in-diff (file)
(re-search-forward (concat "^\\+\\+\\+ mod/" file "$")))
(defalias 'baz-dvc-name-construct 'baz--name-construct)
(defun baz-dvc-revision-direct-ancestor (revision)
`(baz (revision ,(baz-revision-direct-ancestor (cadr (cadr revision))))))
(defun baz-dvc-log-edit-file-name-func ()
(baz-make-log))
;;;###autoload
(defalias 'baz-dvc-command-version 'baz-command-version)
(provide 'baz-dvc)
;;; baz-dvc.el ends here

337
dvc/lisp/baz.el
View File

@ -1,337 +0,0 @@
;;; baz.el --- baz related code for dvc
;; Copyright (C) 2005-2007 Free Software Foundation, Inc.
;; Author: Matthieu Moy <Matthieu.Moy@imag.fr>
;; Keywords:
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;
;;; Code:
;;;###autoload
(progn
(defvar baz-tla-only-commands '(tla-tag)
"List of commands available only with tla.")
(defun baz-make-alias-for-tla-commands ()
"Creates baz- aliases for tla- commands.
For each commands beginning with \"tla-\", except the ones in
`baz-tla-only-list', create the corresponding \"baz-\" alias.
Most functions in tla*.el are prefixed with tla-, but this allows you to
type M-x baz-whatever RET instead. Some functions are available only
with baz. They're prefixed with baz- and have no alias."
(interactive)
(dolist (tla-cmd (apropos-internal "^tla-" 'commandp))
(unless (member tla-cmd baz-tla-only-commands)
(let* ((tla-cmd-post (substring (symbol-name tla-cmd) 4))
(baz-cmd (intern (concat "baz-" tla-cmd-post))))
(unless (or (fboundp baz-cmd)
(string-match "^dvc" tla-cmd-post))
(defalias baz-cmd tla-cmd))))))
(baz-make-alias-for-tla-commands)
;; baz--name-construct is used in baz-dvc.el
(eval-after-load "tla"
'(progn (defalias 'baz--name-construct 'tla--name-construct) (baz-make-alias-for-tla-commands))))
(require 'tla)
;;;###autoload
(defun baz-branch (source-revision tag-version &optional cacherev synchronously)
"Create a tag from SOURCE-REVISION to TAG-VERSION.
Run baz branch.
If SYNCHRONOUSLY is non-nil, the process for tagging runs synchronously.
Else it runs asynchronously."
(interactive
(list (unless (y-or-n-p "Branch from local tree? ")
(tla--name-construct
(tla-name-read "Source revision (or version): "
'prompt 'prompt 'prompt 'prompt 'maybe)))
(tla--name-construct
(tla-name-read "New branch: "
'prompt 'prompt 'prompt 'prompt))
(tla--tag-does-cacherev)
nil))
(funcall (if synchronously 'tla--run-tla-sync 'tla--run-tla-async)
(list "branch"
(when (not cacherev) "--no-cacherev")
source-revision tag-version)))
;;;###autoload
(defun baz-status-goto (&optional root against)
"Switch to status buffer or run `baz-dvc-status'."
(interactive (list (dvc-read-project-tree-maybe
(format "Run %s in: "
(tla--changes-command)))
current-prefix-arg))
(unless (tla-has-status-command)
(error "status not available with this arch branch"))
(let* ((default-directory root)
(buffer (dvc-get-buffer 'status default-directory)))
(if buffer
(dvc-switch-to-buffer buffer)
(baz-dvc-status))))
(defun baz-dvc-status ()
"Run \"baz status\" in `default-directory', which must be a tree root.
Doesn't work with tla. Use `tla-changes' or `tla-tree-lint'
instead."
(unless (tla-has-status-command)
(error "status not available with this arch branch"))
(let* ((root default-directory)
(buffer (dvc-prepare-changes-buffer
(list 'last-revision root)
(list 'local-tree root)
'status
default-directory 'baz)))
(when dvc-switch-to-buffer-first
(dvc-switch-to-buffer buffer))
(with-current-buffer buffer
(let ((inhibit-read-only t))
(ewoc-enter-first
dvc-fileinfo-ewoc
(make-dvc-fileinfo-message
:text (concat "* Running baz status in tree " root
"...\n\n")))
(ewoc-enter-last dvc-fileinfo-ewoc
(make-dvc-fileinfo-legacy :data (list 'searching-subtrees)))
(ewoc-refresh dvc-fileinfo-ewoc)))
(dvc-save-some-buffers)
(baz--status-internal root buffer nil)
(tla--run-tla-async
'("inventory" "--nested" "--trees")
:related-buffer buffer
:finished
(lexical-let ((buffer-lex buffer))
(lambda (output error status arguments)
(let ((subtrees (delete ""
(split-string
(with-current-buffer
output (buffer-string)) "\n"))))
(with-current-buffer buffer-lex
(let ((subtree-message (car (tla--changes-find-subtree-message))))
(dolist (subtree subtrees)
(let ((buffer-sub (dvc-get-buffer-create
'status subtree)))
(with-current-buffer buffer-sub
(let ((inhibit-read-only t))
(erase-buffer))
(dvc-diff-mode)
(set (make-local-variable
'tla--changes-buffer-master-buffer)
buffer-lex))
(ewoc-enter-after dvc-fileinfo-ewoc
subtree-message
(make-dvc-fileinfo-legacy
:data (list 'subtree buffer-sub subtree
nil)))
(baz--status-internal
subtree
buffer-sub
buffer-lex)))
(dvc-ewoc-delete dvc-fileinfo-ewoc subtree-message))
(recenter))))))))
(defun baz--status-error-handle (output error status arguments root
buffer master-buffer)
"Handler for error in \"baz status\"."
(if (with-current-buffer error
(goto-char (point-min))
(looking-at "^Tree is not lint clean"))
(let ((buffer (tla--tree-lint-prepare-buffer
root
(lexical-let ((root-lex root) (buffer-lex buffer) (master-buffer-lex
master-buffer))
(lambda ()
(baz--status-internal root-lex buffer-lex
master-buffer-lex)
(switch-to-buffer buffer-lex))))))
(message "Tree is not lint clean")
(save-excursion
(tla--tree-lint-parse-buffer output buffer))
(with-current-buffer buffer
(tla--tree-lint-cursor-goto
(ewoc-nth tla--tree-lint-cookie 0)))
(switch-to-buffer buffer))
(dvc-show-changes-buffer output 'tla--parse-baz-status buffer
master-buffer "^[^*\\.]")
(with-current-buffer buffer
(setq dvc-buffer-refresh-function 'baz-dvc-status))
(when master-buffer
(with-current-buffer master-buffer
(ewoc-map (lambda (fi)
(let ((x (dvc-fileinfo-legacy-data fi)))
(when (and (eq (car x) 'subtree)
(eq (cadr x) buffer))
(setcar (cdddr x) 'changes)))
)
dvc-fileinfo-ewoc)))))
(defun baz--status-internal (root buffer master-buffer)
"Internal function to run \"baz status\".
Run the command in directory ROOT.
The output will be displayed in buffer BUFFER.
BUFFER must already be in changes mode, but mustn't contain any change
information. Only roots of subprojects are already in the ewoc.
If MASTER-BUFFER is non-nil, this run of tla changes is done in a
nested project of a bigger one. MASTER-BUFFER is the buffer in which
the root of the projects is displayed."
(with-current-buffer buffer
(tla--run-tla-async
`("status")
:finished
(lexical-let ((root-lex root) (buffer-lex buffer) (master-buffer-lex
master-buffer)
(-current-buffer--lex (current-buffer)))
(lambda (output error status arguments)
(if (with-current-buffer output
(goto-char (point-min))
(re-search-forward
tla--files-conflicted-regexp nil t))
(baz--status-error-handle
output error status arguments root-lex buffer-lex
master-buffer-lex)
(if master-buffer-lex
(message "No changes in subtree %s" root-lex)
(message "No changes in %s" root-lex))
(with-current-buffer -current-buffer--lex
(let ((inhibit-read-only t))
(dvc-fileinfo-delete-messages)
(ewoc-enter-last
dvc-fileinfo-ewoc
(make-dvc-fileinfo-message
:text (concat "* No changes in "
root-lex ".\n\n")))
(when master-buffer-lex
(with-current-buffer master-buffer-lex
(ewoc-map (lambda (fi)
(let ((x (dvc-fileinfo-legacy-data fi)))
(when (and (eq (car x) 'subtree)
(eq (cadr x) buffer-lex))
(setcar (cdddr x) 'no-changes)))
)
dvc-fileinfo-ewoc)))
(ewoc-refresh dvc-fileinfo-ewoc))))))
:error
(lexical-let ((root-lex root) (buffer-lex buffer) (master-buffer-lex
master-buffer))
(lambda (output error status arguments)
(baz--status-error-handle
output error status arguments root-lex buffer-lex master-buffer-lex)))
)))
;;;###autoload
(defalias 'baz-merge 'tla-star-merge)
;;;###autoload
(defun baz-annotate (file)
"Run \"baz annotate\" on FILE.
Shows the result in a buffer, and create an annotation table for the
annotated file's buffer. This allows you to run `baz-trace-line' and
`baz-trace-line-show-log'."
(interactive (list (read-file-name "Annotate file: "
nil nil t
(file-name-nondirectory
(or (buffer-file-name) "")))))
(let ((file (expand-file-name file))
(buffer (get-file-buffer file)))
(with-current-buffer buffer
(when (or (not (buffer-modified-p))
(y-or-n-p (concat "Save buffer "
(buffer-name buffer)
"? ")))
(save-buffer buffer))
(find-file-noselect file)
(let* ((default-directory (tla-tree-root file))
(buffer (dvc-get-buffer-create tla-arch-branch 'annotate)))
(when dvc-switch-to-buffer-first
(dvc-switch-to-buffer buffer))
(tla--run-tla-async
`("annotate"
,(tla-file-name-relative-to-root file))
:finished (lexical-let ((buffer-lex buffer) (file-lex file))
(lambda (output error status arguments)
(with-current-buffer buffer-lex
(erase-buffer)
(insert-buffer-substring output))
(tla-annotate-mode)
(baz-parse-annotate
output
(find-buffer-visiting file-lex))))
:error
(lambda (output error status arguments)
(dvc-show-error-buffer error)
(dvc-show-last-process-buffer)))))))
(defvar tla-annotation-table nil
"table line-number -> revision built by `baz-parse-annotate'.")
(defun baz-parse-annotate (annotate-buffer buffer)
"Builds a table line-number -> revision from ANNOTATE-BUFFER.
ANNOTATE-BUFFER must be the output of \"baz annotate\", and BUFFER is
the corresponding source buffer."
(set-buffer annotate-buffer)
(goto-char (point-min))
(re-search-forward "^[^ ]*:")
(beginning-of-line)
(let* ((nb-lines (1+ (count-lines (point)
(point-max))))
(table (make-vector nb-lines ""))
(n 0))
(while (looking-at "^\\([^ ]*\\):")
(aset table n (match-string 1))
(setq n (1+ n))
(forward-line 1))
(with-current-buffer buffer
(set (make-local-variable 'tla-annotation-table)
table))
))
(defun baz-trace-line (line buffer)
"Returns the changeset that lead to LINE in FILE."
(interactive (list (count-lines (point-min) (point))
(current-buffer)))
(unless tla-annotation-table
(error "No annotate table in buffer. Run baz-annotate first."))
(with-current-buffer buffer
(let ((changeset (aref tla-annotation-table line)))
(when (interactive-p)
(message changeset))
changeset)))
(defun baz-trace-line-show-log (line buffer)
"Show the log of the changeset that lead to LINE in FILE."
(interactive (list (count-lines (point-min) (point))
(current-buffer)))
(tla-cat-log (baz-trace-line line buffer)))
(provide 'baz)
;;; baz.el ends here

98
dvc/lisp/bzr-core.el
View File

@ -1,98 +0,0 @@
;;; bzr-core.el --- Core of support for Bazaar 2 in DVC
;; Copyright (C) 2005-2008 by all contributors
;; Author: Matthieu Moy <Matthieu.Moy@imag.fr>
;; Contributions from:
;; Stefan Reichoer, <stefan@xsteve.at>
;; Keywords: tools, vc
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;
;;; Code:
;; TODO autoconf stuff.
(defvar bzr-executable (if (eq system-type 'windows-nt) "bzr.bat" "bzr")
"The executable used for the bzr command line client")
;;;###autoload
(defun bzr-tree-root (&optional location no-error interactive)
"Return the tree root for LOCATION, nil if not in a local tree.
Computation is done from withing Emacs, by looking at a .bzr/
directory in a parent buffer of LOCATION. This is therefore very
fast.
If NO-ERROR is non-nil, don't raise an error if LOCATION is not a
bzr-managed tree (but return nil)."
(interactive)
(dvc-tree-root-helper ".bzr/checkout/" (or interactive
(interactive-p))
"%S is not a bzr-managed tree"
location no-error))
;;;###autoload
(defun bzr-branch-root (&optional location no-error interactive)
"Return the branch root for LOCATION, nil if not in a branch.
This function allows DVC relevant functions (e.g., log) to work
on bzr branches with no tree."
(interactive)
(dvc-tree-root-helper ".bzr/branch/" (or interactive
(interactive-p))
"%S is not a bzr-managed branch"
location no-error))
;;;###autoload
(defun bzr-tree-id ()
"Call \"bzr log -r 1\" to get the tree-id.
Does anyone know of a better way to get this info?"
(interactive)
(let ((tree-id nil))
(dvc-run-dvc-sync
'bzr (list "log" "-r" "1")
:finished (lambda (output error status arguments)
(set-buffer output)
(goto-char (point-min))
(if (re-search-forward "^branch nick:\\s-*\\(.+\\)$" nil t)
(setq tree-id (match-string 1))
(setq tree-id "<unknown>")))
:error (lambda (output error status arguments)
(setq tree-id "<unknown>")))
(when (interactive-p)
(message "tree-id for %s: %s" default-directory tree-id))
tree-id))
;;;###autoload
(defun bzr-prepare-environment (env)
"Prepare the environment to run bzr."
(cons "BZR_PROGRESS_BAR=none" env))
;;;###autoload
(defun bzr-default-global-argument ()
"Disable aliases."
'("--no-aliases"))
(defun bzr-read-revision (prompt)
"Read a revision for the actual bzr working copy."
(read-string prompt (bzr-get-revision-at-point)))
(provide 'bzr-core)
;;; bzr-core.el ends here

135
dvc/lisp/bzr-dvc.el
View File

@ -1,135 +0,0 @@
;;; bzr-dvc.el --- Support for Bazaar 2 in DVC's unification layer
;; Copyright (C) 2005-2008 by all contributors
;; Author: Matthieu Moy <Matthieu.Moy@imag.fr>
;; Contributions from:
;; Stefan Reichoer, <stefan@xsteve.at>
;; Keywords: tools
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;
;;; Code:
(eval-and-compile (require 'dvc-unified))
(require 'bzr)
;;;###autoload
(dvc-register-dvc 'bzr "Bazaar 2")
;;;###autoload
(defalias 'bzr-dvc-init 'bzr-init)
;;;###autoload
(defalias 'bzr-dvc-inventory 'bzr-inventory)
;;;###autoload
(defalias 'bzr-dvc-pull 'bzr-pull)
;;;###autoload
(defalias 'bzr-dvc-push 'bzr-push)
;;;###autoload
(defalias 'bzr-dvc-merge 'bzr-merge)
;;;###autoload
(defalias 'bzr-dvc-submit-patch 'bzr-submit-patch)
;;;###autoload
(defalias 'bzr-dvc-add 'bzr-add)
;;;###autoload
(defalias 'bzr-dvc-log-edit-done 'bzr-log-edit-done)
;;;###autoload
(defun bzr-dvc-search-file-in-diff (file)
(re-search-forward (concat "^=== .* '" file "'$")))
;;;###autoload
(defun bzr-dvc-name-construct (back-end-revision)
(nth 1 back-end-revision))
;;;###autoload
(defvar bzr-log-edit-file-name ".tmp-bzr-log-edit.txt"
"The filename, used to store the log message before commiting.
Usually that file is placed in the tree-root of the working tree.")
(add-to-list 'auto-mode-alist `(,(concat "^" (regexp-quote bzr-log-edit-file-name)
"$") . bzr-log-edit-mode))
;;;###autoload
(defalias 'bzr-dvc-command-version 'bzr-command-version)
(defalias 'bzr-dvc-revision-nth-ancestor 'bzr-revision-nth-ancestor)
(defalias 'bzr-dvc-log 'bzr-log)
;;;###autoload
(defalias 'bzr-dvc-save-diff 'bzr-save-diff)
(defalias 'bzr-dvc-changelog 'bzr-changelog)
(defun bzr-dvc-update ()
(interactive)
(bzr-update nil))
(defun bzr-dvc-edit-ignore-files ()
(interactive)
(find-file-other-window (concat (bzr-tree-root) ".bzrignore")))
(defun bzr-dvc-ignore-files (file-list)
(interactive (list (dvc-current-file-list)))
(when (y-or-n-p (format "Ignore %S for %s? " file-list (bzr-tree-root)))
(dolist (f-name file-list)
(bzr-ignore (format "./%s" f-name)))))
(defun bzr-dvc-backend-ignore-file-extensions (extension-list)
(dolist (ext-name extension-list)
(bzr-ignore (format "*.%s" ext-name))))
(autoload 'bzr-revlog-get-revision "bzr-revlog")
(defalias 'bzr-dvc-revlog-get-revision
'bzr-revlog-get-revision)
(defalias 'bzr-dvc-delta 'bzr-delta)
(defalias 'bzr-dvc-send-commit-notification 'bzr-send-commit-notification)
(defalias 'bzr-dvc-prepare-environment 'bzr-prepare-environment)
(defalias 'bzr-dvc-file-has-conflict-p 'bzr-file-has-conflict-p)
(defalias 'bzr-dvc-resolved 'bzr-resolved)
(defalias 'bzr-dvc-annotate-time 'bzr-annotate-time)
(defalias 'bzr-dvc-clone 'bzr-checkout)
(defalias 'bzr-dvc-export-via-email 'bzr-export-via-email)
(defun bzr-dvc-diff-against-url (path)
(let ((buffer (dvc-prepare-changes-buffer
nil
path
'diff default-directory 'bzr)))
(dvc-switch-to-buffer-maybe buffer)
(message "Running bzr merge --preview %s" path)
(dvc-run-dvc-async 'bzr (list "merge" "--preview" "--force" path)
:finished
(dvc-capturing-lambda (output error status arguments)
(dvc-show-changes-buffer output 'bzr-parse-diff
(capture buffer))))))
(provide 'bzr-dvc)
;;; bzr-dvc.el ends here

158
dvc/lisp/bzr-gnus.el
View File

@ -1,158 +0,0 @@
;;; bzr-gnus.el --- bzr dvc integration to gnus
;; Copyright (C) 2008 by all contributors
;; Author: Stefan Reichoer <stefan@xsteve.at>
;; DVC is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; DVC is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; gnus is optional. Load it at compile-time to avoid warnings.
(eval-when-compile
(condition-case nil
(progn
(require 'gnus)
(require 'gnus-art)
(require 'gnus-sum))
(error nil)))
;;;###autoload
(defun bzr-insinuate-gnus ()
"Integrate bzr into Gnus."
(interactive)
;; there is nothing special to do yet...
)
(defun bzr-gnus-article-view-patch (n)
"View MIME part N in a gnus article, as a bzr changeset.
The patch can be embedded or external. If external, the
parameter N is ignored."
(interactive)
(let ((num-of-mime-parts
(save-window-excursion
(gnus-summary-select-article-buffer)
(gnus-article-mime-total-parts))))
(if (> num-of-mime-parts 1)
(bzr-gnus-article-view-attached-patch 2)
(bzr-gnus-article-view-external-patch))))
(defun bzr-gnus-article-view-attached-patch (n)
"View MIME part N, as bzr patchset."
(interactive "p")
(error "bzr-gnus-article-view-attached-patch not yet implemented"))
(defun bzr-gnus-article-view-external-patch ()
"View an external patch that is referenced in this mail.
The mail must contain a line starting with 'Committed revision ' and ending
with the branch location."
(interactive)
(let ((revnr)
(archive-location)
(diff-buffer)
(window-conf (current-window-configuration)))
(gnus-summary-select-article-buffer)
(split-window-vertically)
(goto-char (point-min))
;; Committed revision 129 to http://my-arch.org/branch1
(when (re-search-forward "Committed revision \\([0-9]+\\) to \\(.+\\)$" nil t)
(setq revnr (match-string-no-properties 1))
(setq archive-location (match-string-no-properties 2)))
(gnus-article-show-summary)
(if (and revnr archive-location)
(progn
(message "Viewing bzr revison: %s, location: %s" revnr archive-location)
;; bzr diff -r128..129 http://my-arch.org/branch1
;; Note: this command needs at least bzr v1.1
(setq diff-buffer
(bzr-delta `(bzr (revision (local "" ,(- (string-to-number revnr) 1))))
`(bzr (revision (local "" ,(string-to-number revnr))))
nil
archive-location))
(save-excursion
(set-buffer diff-buffer)
(dvc-buffer-push-previous-window-config window-conf)))
(message "No external bzr patch found in this article.")
(set-window-configuration window-conf))))
(defun bzr-gnus-article-merge-bundle (n)
"Merge MIME part N, as bzr merge bundle."
(interactive "p")
(unless current-prefix-arg
(setq n 2))
(gnus-article-part-wrapper n 'bzr-gnus-merge-bundle))
(defvar bzr-merge-bundle-mapping nil
"*Project in which bzr bundles should be applied.
An alist of rules to map email addresses to target directories.
This is used by the `bzr-gnus-merge-bundle' function.
Example setting: '((\"dvc-dev@gna.org\" \"~/work/bzr/dvc\"))"
)
;; e.g.: (setq bzr-merge-bundle-mapping '(("dvc-dev@gna.org" "~/work/bzr/dvc")))
(defun bzr-gnus-merge-bundle (handle)
"Merge a bzr merge bundle via gnus. HANDLE should be the handle of the part."
(let ((patch-file-name (concat (dvc-make-temp-name "gnus-bzr-merge-") ".patch"))
(window-conf (current-window-configuration))
(to-addr (message-fetch-field "To"))
(import-dir))
(gnus-summary-select-article-buffer)
(dvc-gnus-article-extract-log-message)
(mm-save-part-to-file handle patch-file-name)
(dolist (m bzr-merge-bundle-mapping)
(when (string-match (regexp-quote (car m)) to-addr)
(setq import-dir (dvc-uniquify-file-name (cadr m)))))
(delete-other-windows)
(dvc-buffer-push-previous-window-config)
(find-file patch-file-name)
(setq import-dir (dvc-read-directory-name "Merge bzr bundle to: " nil nil t import-dir))
(when import-dir
(let ((default-directory import-dir))
(bzr-merge-bundle patch-file-name)))
(delete-file patch-file-name)
(kill-buffer (current-buffer)) ;; the patch file
(set-window-configuration window-conf)
(when (and import-dir (y-or-n-p "Run bzr status in merged tree? "))
(let ((default-directory import-dir))
(bzr-status)
(delete-other-windows)))))
(defun bzr-gnus-article-pull-bundle-in-branch (n)
"Merge MIME part N, as bzr merge bundle."
(interactive "p")
(unless current-prefix-arg
(setq n 2))
(gnus-article-part-wrapper n 'bzr-gnus-pull-bundle-in-branch))
(defun bzr-gnus-pull-bundle-in-branch (handle)
"Merge a bzr merge bundle via gnus. HANDLE should be the handle of the part."
(let ((patch-file-name (concat (dvc-make-temp-name "gnus-bzr-pull-bundle-") ".patch"))
(window-conf (current-window-configuration))
(to-addr (message-fetch-field "To"))
(import-dir))
(gnus-summary-select-article-buffer)
(dvc-gnus-article-extract-log-message)
(mm-save-part-to-file handle patch-file-name)
(message "bzr-gnus-pull-bundle-in-branch: implementation not finished (saved patch to %s)" patch-file-name)))
(provide 'bzr-gnus)
;;; bzr-gnus.el ends here

221
dvc/lisp/bzr-revision.el
View File

@ -1,221 +0,0 @@
;;; bzr-revision.el --- Management of revision lists in bzr
;; Copyright (C) 2006 - 2008 by all contributors
;; Author: Matthieu Moy <Matthieu.Moy@imag.fr>
;; Contributions from:
;; Stefan Reichoer, <stefan@xsteve.at>
;; Keywords:
;; DVC is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; DVC is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;
;;; Code:
(require 'dvc-revlist)
(eval-when-compile (require 'cl))
(defstruct (bzr-revision-st)
revno
message
creator
branch-nick
date
merges
)
;; bzr revision list
(defun bzr-revision-list-entry-patch-printer (elem)
"TODO"
(insert (if (dvc-revlist-entry-patch-marked elem)
(concat " " dvc-mark " ") " "))
(let ((struct (dvc-revlist-entry-patch-struct elem)))
(insert (dvc-face-add "revno: " 'dvc-header)
(dvc-face-add (int-to-string (or (bzr-revision-st-revno struct) -99))
'dvc-revision-name)
"\n")
(when dvc-revisions-shows-creator
(insert " " (dvc-face-add "committer: " 'dvc-header)
(or (bzr-revision-st-creator struct) "?") "\n"))
(when dvc-revisions-shows-date
(insert " " (dvc-face-add "timestamp: " 'dvc-header)
(or (bzr-revision-st-date struct) "?") "\n"))
(insert " " (dvc-face-add "branch nick: " 'dvc-header)
(or (bzr-revision-st-branch-nick struct) "?") "\n")
(when dvc-revisions-shows-summary
(insert " " (dvc-face-add "message: " 'dvc-header)
(or (bzr-revision-st-message struct) "?") "\n"))
))
;;; bzr log
(defun bzr-log-parse-remote (log-buffer location)
(bzr-log-parse log-buffer location t))
(defun bzr-missing-parse (log-buffer location)
"Parse the output of bzr missing."
(bzr-log-parse log-buffer location nil t))
(defun bzr-log-parse (log-buffer location &optional remote missing)
"Parse the output of bzr log."
;;(dvc-trace "location=%S" location)
(goto-char (point-min))
(let ((root location)
(intro-string)
(brief (with-current-buffer log-buffer dvc-revlist-brief)))
(when missing ;; skip the first status output
(unless (re-search-forward "^------------------------------------------------------------$" nil t)
(message "No missing revisions: Branches are up to date.")
(goto-char (point-max)))
(setq intro-string (buffer-substring-no-properties (point-min) (point)))
(with-current-buffer log-buffer
(let ((buffer-read-only nil))
(insert intro-string))))
(while (> (point-max) (point))
(forward-line 1)
(let ((start (point))
(message-start-pos)
(message-end-pos)
(elem (make-bzr-revision-st)))
(or (and (re-search-forward
"^------------------------------------------------------------$"
nil t)
(progn (beginning-of-line)
t))
(goto-char (point-max)))
(save-restriction
(save-excursion
(narrow-to-region start (- (point) 1))
;;(dvc-trace "parsing %S" (buffer-string))
(goto-char (point-min))
(while (re-search-forward "^\\([a-z][a-z ]*[a-z]\\):\\( \\|\n\\)" nil t)
;;(dvc-trace "match-string=%S" (match-string 1))
(cond ((string= (match-string 1) "revno")
(setf (bzr-revision-st-revno elem)
(string-to-number
(buffer-substring-no-properties
(point) (line-end-position)))))
((string= (match-string 1) "committer")
(setf (bzr-revision-st-creator elem)
(buffer-substring-no-properties
(point) (line-end-position))))
((string= (match-string 1) "branch nick")
(setf (bzr-revision-st-branch-nick elem)
(buffer-substring-no-properties
(point) (line-end-position))))
((string= (match-string 1) "timestamp")
(setf (bzr-revision-st-date elem)
(buffer-substring-no-properties
(point) (line-end-position))))
((string= (match-string 1) "message")
;;(dvc-trace "found message")
(re-search-forward "^[ \t]*")
(setq message-start-pos (point))
(setq message-end-pos
(if brief
(line-end-position)
(if (re-search-forward "^--------" nil t) (point) (point-max))))
(setf (bzr-revision-st-message elem)
(buffer-substring-no-properties
message-start-pos message-end-pos))
(goto-char (point-max)))
(t (dvc-trace "unmanaged field %S" (match-string 1))))
(forward-line 1)
(beginning-of-line))))
(forward-line 1)
(with-current-buffer log-buffer
(ewoc-enter-last
dvc-revlist-cookie
`(entry-patch
,(make-dvc-revlist-entry-patch
:dvc 'bzr
:struct elem
:rev-id `(bzr (revision
,(list (if remote 'remote 'local)
root (bzr-revision-st-revno
elem)))))))
(goto-char (point-min))
(dvc-revision-prev))))))
(defun bzr-log-refresh ()
"Refresh a log buffer."
(let ((cmd (remove
nil
(append
(list "log")
(if dvc-revlist-last-n
(list "-r" (format "last:%d.." dvc-revlist-last-n)))
(list dvc-revlist-path)))))
(dvc-build-revision-list
'bzr 'alog default-directory cmd 'bzr-log-parse
dvc-revlist-brief dvc-revlist-last-n dvc-revlist-path
'bzr-log-refresh))
(goto-char (point-min)))
;;;###autoload
(defun bzr-log (path last-n)
"Run bzr log for PATH and show only the first line of the log message.
LAST-N revisions are shown (default dvc-log-last-n). Note that the
LAST-N restriction is applied first, so if both PATH and LAST-N are
specified, fewer than LAST-N revisions may be shown."
(interactive (list default-directory (if current-prefix-arg (prefix-numeric-value current-prefix-arg) dvc-log-last-n)))
(let ((default-directory (bzr-branch-root (or path default-directory)))
(dvc-revlist-path path)
(dvc-revlist-brief t)
(dvc-revlist-last-n last-n))
(bzr-log-refresh)))
;;;###autoload
(defun bzr-log-remote (location)
"Run bzr log against a remote location."
(interactive (list (read-string "Location of the branch: ")))
(dvc-build-revision-list 'bzr 'remote-log location `("log" ,location)
'bzr-log-parse-remote t nil nil
(dvc-capturing-lambda ()
(bzr-log-remote (capture location))))
(goto-char (point-min)))
;;;###autoload
(defun bzr-changelog (&optional path)
"Run bzr log and show the full log message."
(interactive (list default-directory))
(let ((default-directory (bzr-branch-root (or path default-directory))))
(dvc-build-revision-list 'bzr 'alog default-directory '("log") 'bzr-log-parse nil nil path
(dvc-capturing-lambda ()
(bzr-changelog (capture path))))
(goto-char (point-min))))
;;;###autoload
(defun bzr-dvc-missing (&optional other)
"Run bzr missing."
(interactive "sBzr missing against other: ")
(when (string= other "")
(setq other nil))
;;(message "bzr-dvc-missing %S" other)
(dvc-build-revision-list 'bzr 'missing (bzr-tree-root)
`("missing" ,other)
'bzr-missing-parse
nil nil nil
(dvc-capturing-lambda ()
(bzr-dvc-missing (capture other))))
(goto-char (point-min)))
(provide 'bzr-revision)
;;; bzr-revision.el ends here

69
dvc/lisp/bzr-revlog.el
View File

@ -1,69 +0,0 @@
;;; bzr-revlog.el --- Show a log entry for a bzr branch
;; Copyright (C) 2006 by all contributors
;; Author: Matthieu Moy <Matthieu.Moy@imag.fr>
;; Keywords:
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;
;;; Code:
(require 'dvc-core)
(require 'dvc-revlog)
(defun bzr-revlog-local (revno &optional path)
"Quick and dirty prototype of function using dvc-revlog-mode."
(interactive "MRevno: ")
(let ((default-directory (or path default-directory)))
(dvc-run-dvc-async 'bzr `("log"
"-r"
,revno)
:finished
(dvc-capturing-lambda (output error status
arguments)
(dvc-switch-to-buffer
(dvc-revlog-show-revision 'bzr output
(capture revno)))))))
(defun bzr-revlog-get-revision (rev-id)
(let ((data (car (dvc-revision-get-data rev-id))))
(dvc-trace "dd=%S" default-directory)
(dvc-trace "data=%S" data)
(cond ((eq (car data) 'local)
(let ((default-directory (nth 1 data)))
(dvc-run-dvc-sync 'bzr
`("log" "--revision"
,(int-to-string (nth 2 data)))
:finished 'dvc-output-buffer-handler)))
((eq (car data) 'remote)
(dvc-run-dvc-sync 'bzr
`("log" "--revision"
,(concat "revno:"
(int-to-string (nth 2 data))
":"
(nth 1 data)))
:finished 'dvc-output-buffer-handler))
(t (error (format "Revision ID %S not implemented" rev-id))))))
(provide 'bzr-revlog)
;;; bzr-revlog.el ends here

272
dvc/lisp/bzr-submit.el
View File

@ -1,272 +0,0 @@
;;; bzr-submit.el --- Patch submission support for Bazaar 2 in DVC
;; Copyright (C) 2006 by all contributors
;; Author: Michael Olson <mwolson@gnu.org>
;; Keywords: tools, vc
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;
;;; Code:
(require 'bzr-core)
(require 'bzr)
(require 'diff-mode)
(defgroup dvc-bzr-submit nil
"Submitting and applying patches via email for bzr."
:group 'dvc
:prefix "bzr-submit-")
(defcustom bzr-apply-patch-mapping nil
"*Project in which patches should be applied.
An alist of rules to map branch nicknames to target directories.
This is used by the `bzr-gnus-apply-patch' function.
Example setting: '((\"dvc-dev-bzr\" \"~/work/bzr/dvc\"))"
:type '(repeat (list :tag "Rule"
(string :tag "Branch nickname")
(string :tag "Target directory")))
:group 'dvc-bzr-submit)
(defcustom bzr-submit-patch-mapping
'(("dvc-dev-bzr" ("dvc-dev@gna.org" "dvc")))
"*Email addresses that should be used to send patches.
An alist of rules to map branch nicknames to target email
addresses and the base name to use in the attached patch.
This is used by the `bzr-submit-patch' function."
:type '(repeat (list :tag "Rule"
(string :tag "Branch nickname")
(list :tag "Target"
(string :tag "Email address")
(string :tag "Base name of patch"))))
:group 'dvc-bzr-submit)
(defcustom bzr-patch-sent-action 'keep-both
"*What shall be done, after sending a patch via mail.
The possible values are 'keep-patch, 'keep-changes, 'keep-both, 'keep-none."
:type '(choice (const keep-patch)
(const keep-changes)
(const keep-both)
(const keep-none))
:group 'dvc-bzr-submit)
(defvar bzr-patch-data nil)
(defun bzr-changed-files (&optional include-added)
"Retrieve a list of files in the current repo that have changed.
If INCLUDE-ADDED is specified, include files that are newly-added."
(let ((default-directory (bzr-tree-root))
(files nil))
(dvc-run-dvc-sync
'bzr (list "status")
:finished (dvc-capturing-lambda
(output error status arguments)
(set-buffer output)
(goto-char (point-min))
(when (and include-added
(re-search-forward "^added:" nil t))
(forward-line 1)
(while (looking-at "^ \\([^ ].*\\)$")
(setq files (cons (match-string 1) files))
(forward-line 1)))
(goto-char (point-min))
(when (re-search-forward "^modified:" nil t)
(forward-line 1)
(while (looking-at "^ \\([^ ].*\\)$")
(setq files (cons (match-string 1) files))
(forward-line 1))))
:error (lambda (output error status arguments)
(error "An error occurred")))
files))
(defun dvc-read-several-from-list (prompt items)
"Read several string ITEMS from list, using PROMPT."
(let ((chosen nil)
(table (mapcar #'list items))
item)
(while (progn
(and table
(setq item (dvc-completing-read prompt table nil t))
(stringp item)
(not (string= item ""))))
(setq chosen (cons item chosen))
(setq table (delete (list item) table)))
chosen))
(defun bzr-show-diff-from-file (file)
"Display the diff contained in FILE with DVC font-locking."
(with-temp-buffer
(insert-file-contents-literally file)
(let ((buffer (dvc-prepare-changes-buffer nil nil 'diff nil 'bzr))
(output (current-buffer)))
(when dvc-switch-to-buffer-first
(dvc-switch-to-buffer buffer))
;; Since we did not search for a tree root, some things may not work from the diff buffer.
(dvc-show-changes-buffer output 'bzr-parse-diff buffer))))
(defun bzr-changes-save-as-patch (file-name
&optional included-files prompt-files)
"Run \"bzr diff\" to create a .diff file.
The changes are stored in the patch file 'FILE-NAME.diff'.
INCLUDED-FILES lists the files whose changes will be included. If
this is nil, include changes to all files.
PROMPT-FILES indicates whether to prompt for the files to include in
the patch. This is only heeded when the function is not called
interactively."
(interactive
(list (read-file-name (concat "File to store the patch in "
"(without an extension): ")
nil "")
(dvc-read-several-from-list
"Files to include (all by default, RET ends): "
(bzr-changed-files t))))
(when (and (not (interactive-p)) prompt-files)
(setq included-files (dvc-read-several-from-list
"Files to include (all by default, RET ends): "
(bzr-changed-files t))))
(let ((patch-file-name (concat (expand-file-name file-name) ".diff"))
(default-directory (bzr-tree-root))
(continue t))
(dvc-run-dvc-sync
'bzr (nconc (list "diff") included-files)
:finished (lambda (output error status arguments)
(message "No changes occurred"))
:error (dvc-capturing-lambda
(output error status arguments)
(set-buffer output)
(write-file patch-file-name)))))
(defun bzr-undo-diff-from-file (file root-dir)
"Undo the changes contained in FILE to the bzr project whose
root is ROOT-DIR."
(with-temp-buffer
(insert-file-contents-literally file)
(diff-mode)
(goto-char (point-min))
(let ((default-directory root-dir)
(diff-advance-after-apply-hunk nil))
(while (re-search-forward diff-file-header-re nil t)
(condition-case nil
(while (progn (diff-apply-hunk t)
(re-search-forward diff-hunk-header-re nil t)))
(error nil))))))
;;;###autoload
(defun bzr-prepare-patch-submission (bzr-tree-root
patch-base-name email version-string
&optional description subject
prompt-files)
"Submit a patch to a bzr working copy (at BZR-TREE-ROOT) via email.
With this feature it is not necessary to branch a bzr archive.
You simply edit your checked out copy from your project and call this function.
The function will create a patch as a .diff file (based on PATCH-BASE-NAME)
and send it to the given email address EMAIL.
VERSION-STRING should indicate the version of bzr that the patch applies to.
DESCRIPTION is a brief descsription of the patch.
SUBJECT is the subject for the email message.
PROMPT-FILES indicates whether to prompt for the files to include in
the patch.
For an example, how to use this function see: `bzr-submit-patch'."
(interactive)
;; create the patch
(let* ((default-directory bzr-tree-root)
(patch-directory (expand-file-name ".tmp-dvc/" bzr-tree-root))
(patch-full-base-name (expand-file-name patch-base-name
patch-directory))
(patch-full-name (concat patch-full-base-name ".diff")))
(unless (file-exists-p patch-directory)
(make-directory patch-directory))
(bzr-changes-save-as-patch patch-full-base-name nil prompt-files)
(require 'reporter)
(delete-other-windows)
(reporter-submit-bug-report email nil nil nil nil description)
(set (make-local-variable 'bzr-patch-data)
(list patch-full-name bzr-tree-root patch-full-name))
(insert "[VERSION] " version-string "\n\n")
(insert bzr-command-version)
(goto-char (point-max))
(mml-attach-file patch-full-name "text/x-patch")
(bzr-show-diff-from-file patch-full-name)
(other-window 1)
(goto-char (point-min))
(mail-position-on-field "Subject")
(insert (or subject "[PATCH] "))))
(defun bzr-submit-patch-done ()
"Clean up after sending a patch via mail.
That function is usually called via `message-sent-hook'. Its
purpose is to revert the sent changes or to delete sent changeset
patch \(see: `bzr-patch-sent-action')."
(when bzr-patch-data
(when (memq bzr-patch-sent-action '(keep-patch keep-none))
(message "Reverting the sent changes in %s" (car bzr-patch-data))
(bzr-undo-diff-from-file (car bzr-patch-data) (cadr bzr-patch-data)))
(when (memq bzr-patch-sent-action '(keep-changes keep-none))
(message "Deleting the sent patch %s" (car (cddr bzr-patch-data)))
(delete-file (car (cddr bzr-patch-data))))
(when (memq bzr-patch-sent-action '(keep-both))
(message "Keeping the sent changes and the sent patch %s"
(car (cddr bzr-patch-data))))))
(add-hook 'message-sent-hook 'bzr-submit-patch-done)
;;;###autoload
(defun bzr-submit-patch ()
"Submit a patch for the current bzr project.
With this feature it is not necessary to tag an arch archive.
You simply edit your checked out copy and call this function.
The function will create a patch as *.tar.gz file and prepare a buffer to
send the patch via email.
The variable `bzr-submit-patch-mapping' allows to specify the
target email address and the base name of the sent tarball.
After the user has sent the message, `bzr-submit-patch-done' is called."
(interactive)
(if (string= (dvc-run-dvc-sync 'bzr '("status" "-V")
:finished 'dvc-output-buffer-handler)
"")
(message "No changes in this bzr working copy - please apply your patch locally and submit it.")
(bzr-command-version)
(let* ((tree-id (bzr-tree-id))
(submit-patch-info (cadr (assoc tree-id
bzr-submit-patch-mapping)))
(mail-address (or (nth 0 submit-patch-info) ""))
(patch-base-file-name (or (nth 1 submit-patch-info) "bzr")))
(bzr-prepare-patch-submission
(dvc-uniquify-file-name (bzr-tree-root))
(concat patch-base-file-name "-patch-"
(format-time-string "%Y-%m-%d_%H-%M-%S" (current-time)))
mail-address
tree-id
dvc-patch-email-message-body-template
nil
(interactive-p)))))
(provide 'bzr-submit)
;;; bzr-submit.el ends here

1363
dvc/lisp/bzr.el
View File

File diff suppressed because it is too large Load Diff

167
dvc/lisp/contrib/elunit.el
View File

@ -1,167 +0,0 @@
;;; elunit.el --- Emacs Lisp Unit Testing framework
;; Copyright (C) 2006 Phil Hagelberg
;; Adapted-By: Christian M. Ohler
;; Inspired by regress.el by Wayne Mesard and Tom Breton, Test::Unit
;; by Nathaniel Talbott, and xUnit by Kent Beck
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; A copy of the GNU General Public License can be obtained from the
;; Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;; See http://dev.technomancy.us/phil/wiki/ElUnit for usage details.
(require 'cl)
(require 'compile)
(defvar *elunit-suites*
'()
"A list of unit test suites")
(defvar *elunit-default-suite* nil
"Choice to use for default suite to run (gets updated to last suite run)")
(defun elunit-suite (name)
(cdr (assoc name *elunit-suites*)))
(defun elunit-get-test (name suite)
(when (symbolp suite) (setq suite (elunit-suite suite)))
(assoc name suite))
;;; Defining tests
(defmacro defsuite (suite-name &rest tests)
"This is what you use to set things up."
(dolist (test tests)
(elunit-add-to-suite (make-test test) suite-name)))
(defun make-test (body)
(let ((name (pop body)))
(list name body buffer-file-name
(save-excursion
(condition-case var
(progn (search-backward (symbol-name name))
(if (fboundp 'line-number-at-pos)
(line-number-at-pos)
'unknown)) ; not a foolproof heuristic to get line number, but good enough.
(error 'unknown))))))
(defun elunit-add-to-suite (test suite)
(unless (elunit-suite suite) (elunit-make-suite suite))
(elunit-delete-test (car test) suite)
(push test (cdr (assoc suite *elunit-suites*))))
(defun elunit-make-suite (suite)
(push (list suite) *elunit-suites*))
(defun elunit-delete-test (name suite)
(when (elunit-get-test name suite)
(setf (cdr (assoc suite *elunit-suites*)) (assq-delete-all name (elunit-suite suite)))))
(defun elunit-clear-suites ()
(setq *elunit-suites* '((default-suite ()))))
;;; Running the unit tests
(defun elunit (suite &optional force-prompt)
"Run all tests in SUITE (a string), and display the results.
Prompt for a suite if FORCE-PROMPT is non-nil, or if both SUITE
and `*elunit-default-suite*' are nil."
(interactive "i\nP")
(unless suite (setq suite *elunit-default-suite*))
(cond ((null suite)
(setq suite
(completing-read
"Run test suite: "
(mapcar (lambda (suite) (cons (symbol-name (car suite))
(symbol-name (car suite))))
*elunit-suites*)
nil t)))
(force-prompt
(setq suite
(completing-read
(format "Run test suite (default %s): " suite)
(mapcar (lambda (suite) (cons (symbol-name (car suite))
(symbol-name (car suite))))
*elunit-suites*)
nil t nil nil suite)))
(t (progn)))
(setq *elunit-default-suite* suite)
(setq *elunit-fail-count* 0)
(run-hooks (intern (concat suite "-setup-hook")))
(with-output-to-temp-buffer "*elunit*"
(princ (concat "Loaded suite: " suite "\n\n"))
(let* ((tests (elunit-suite (intern suite)))
(start-time (cadr (current-time)))
(total (length tests)))
(let ((results (loop for test-id from 1
for test in (reverse tests)
;; This used to be `with-temp-message', but
;; writing the boundaries between test cases
;; into the *Messages* buffer can be
;; helpful.
do (message "Running test \"%s\" (%s of %s)..."
(first test) test-id total)
collect (apply #'elunit-run-test test))))
(message "Ran %s tests; %s failed" total *elunit-fail-count*)
(elunit-report-results results))
(princ (format " in %d seconds." (- (cadr (current-time)) start-time)))))
(run-hooks (intern (concat suite "-teardown-hook"))))
(defun elunit-run-test (name body file-name line-number)
(let* ((passed nil)
(docstring (if (stringp (car body)) (pop body) ""))
(result (condition-case err
(save-excursion (eval (cons 'progn body)) (setq passed t))
(error err))))
(elunit-status passed)
(if passed t
(list name docstring result body file-name line-number *elunit-fail-count*))))
;;; Showing the results
(defun elunit-status (pass)
"Output status while the tests are running"
(princ (if pass "." "F"))
(unless pass (incf *elunit-fail-count*)
(switch-to-buffer "*elunit*")
;; This doesn't work in XEmacs.
;; (overlay-put (make-overlay (point) (- (point) 1)) 'face '(foreground-color . "red"))
(switch-to-buffer nil)))
(defun elunit-report-results (tests)
"For when the tests are finished and we want details"
(dolist (test tests)
(unless (eq t test)
(apply 'elunit-report-result test)))
(princ (format "\n\n\n%d tests total, %d failures" (length tests) *elunit-fail-count*)))
(defun elunit-report-result (name docstring result body file-name line-number index)
"Report a single test failure"
(princ (format "\n\n%d) Failure: %s [%s:%s]
%s
Result: %s
Form: %s" index name file-name line-number docstring result (car body))))
;(add-hook 'temp-buffer-show-hook 'compilation-minor-mode)
;(add-to-list 'compilation-error-regexp-alist '("\\[\\([^:]*\\):\\([0-9]+\\)" 1 2))
;;(add-to-list 'compilation-error-regexp-alist '("\\[\\([^\]]*\\):\\([0-9]+\\)\\]" 1 2))
(provide 'elunit)
;; end of file

609
dvc/lisp/contrib/ewoc.el
View File

@ -1,609 +0,0 @@
;;; ewoc.el --- utility to maintain a view of a list of objects in a buffer
;; Copyright (C) 1991, 92, 93, 94, 95, 96, 97, 98, 99, 2000 Free Software Foundation
;; Author: Per Cederqvist <ceder@lysator.liu.se>
;; Inge Wallin <inge@lysator.liu.se>
;; Maintainer: monnier@gnu.org
;; Created: 3 Aug 1992
;; Keywords: extensions, lisp
;; 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 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; Ewoc Was Once Cookie
;; But now it's Emacs' Widget for Object Collections
;; As the name implies this derives from the `cookie' package (part
;; of Elib). The changes are pervasive though mostly superficial:
;; - uses CL (and its `defstruct')
;; - separate from Elib.
;; - uses its own version of a doubly-linked list which allows us
;; to merge the elib-wrapper and the elib-node structures into ewoc-node
;; - dropping functions not used by PCL-CVS (the only client of ewoc at the
;; time of writing)
;; - removing unused arguments
;; - renaming:
;; elib-node ==> ewoc--node
;; collection ==> ewoc
;; tin ==> ewoc--node
;; cookie ==> data or element or elem
;; Introduction
;; ============
;;
;; Ewoc is a package that implements a connection between an
;; dll (a doubly linked list) and the contents of a buffer.
;; Possible uses are dired (have all files in a list, and show them),
;; buffer-list, kom-prioritize (in the LysKOM elisp client) and
;; others. pcl-cvs.el uses ewoc.el.
;;
;; Ewoc can be considered as the `view' part of a model-view-controller.
;;
;; A `element' can be any lisp object. When you use the ewoc
;; package you specify a pretty-printer, a function that inserts
;; a printable representation of the element in the buffer. (The
;; pretty-printer should use "insert" and not
;; "insert-before-markers").
;;
;; A `ewoc' consists of a doubly linked list of elements, a
;; header, a footer and a pretty-printer. It is displayed at a
;; certain point in a certain buffer. (The buffer and point are
;; fixed when the ewoc is created). The header and the footer
;; are constant strings. They appear before and after the elements.
;;
;; Ewoc does not affect the mode of the buffer in any way. It
;; merely makes it easy to connect an underlying data representation
;; to the buffer contents.
;;
;; A `ewoc--node' is an object that contains one element. There are
;; functions in this package that given an ewoc--node extract the data, or
;; give the next or previous ewoc--node. (All ewoc--nodes are linked together
;; in a doubly linked list. The `previous' ewoc--node is the one that appears
;; before the other in the buffer.) You should not do anything with
;; an ewoc--node except pass it to the functions in this package.
;;
;; An ewoc is a very dynamic thing. You can easily add or delete elements.
;; You can apply a function to all elements in an ewoc, etc, etc.
;;
;; Remember that an element can be anything. Your imagination is the
;; limit! It is even possible to have another ewoc as an
;; element. In that way some kind of tree hierarchy can be created.
;;
;; Full documentation will, God willing, soon be available in a
;; Texinfo manual.
;; In the mean time `grep '^(.*ewoc-[^-]' emacs-lisp/ewoc.el' can help
;; you find all the exported functions:
;;
;; (defun ewoc-create (pretty-printer &optional header footer)
;; (defalias 'ewoc-data 'ewoc--node-data)
;; (defun ewoc-location (node)
;; (defun ewoc-enter-first (ewoc data)
;; (defun ewoc-enter-last (ewoc data)
;; (defun ewoc-enter-after (ewoc node data)
;; (defun ewoc-enter-before (ewoc node data)
;; (defun ewoc-next (ewoc node)
;; (defun ewoc-prev (ewoc node)
;; (defun ewoc-nth (ewoc n)
;; (defun ewoc-map (map-function ewoc &rest args)
;; (defun ewoc-filter (ewoc predicate &rest args)
;; (defun ewoc-locate (ewoc &optional pos guess)
;; (defun ewoc-invalidate (ewoc &rest nodes)
;; (defun ewoc-goto-prev (ewoc arg)
;; (defun ewoc-goto-next (ewoc arg)
;; (defun ewoc-goto-node (ewoc node)
;; (defun ewoc-refresh (ewoc)
;; (defun ewoc-collect (ewoc predicate &rest args)
;; (defun ewoc-buffer (ewoc)
;; (defun ewoc-get-hf (ewoc)
;; (defun ewoc-set-hf (ewoc header footer)
;; Coding conventions
;; ==================
;;
;; All functions of course start with `ewoc'. Functions and macros
;; starting with the prefix `ewoc--' are meant for internal use,
;; while those starting with `ewoc-' are exported for public use.
;; There are currently no global or buffer-local variables used.
;;; Code:
(eval-when-compile (require 'cl)) ;because of CL compiler macros
;; The doubly linked list is implemented as a circular list
;; with a dummy node first and last. The dummy node is used as
;; "the dll" (or rather is the dll handle passed around).
(defstruct (ewoc--node
(:type vector) ;required for ewoc--node-branch hack
(:constructor ewoc--node-create (start-marker data)))
left right data start-marker)
(defalias 'ewoc--node-branch 'aref)
(defun ewoc--dll-create ()
"Create an empty doubly linked list."
(let ((dummy-node (ewoc--node-create 'DL-LIST 'DL-LIST)))
(setf (ewoc--node-right dummy-node) dummy-node)
(setf (ewoc--node-left dummy-node) dummy-node)
dummy-node))
(defun ewoc--node-enter-before (node elemnode)
"Insert ELEMNODE before NODE in a DLL."
(assert (and (null (ewoc--node-left elemnode)) (null (ewoc--node-right elemnode))))
(setf (ewoc--node-left elemnode) (ewoc--node-left node))
(setf (ewoc--node-right elemnode) node)
(setf (ewoc--node-right (ewoc--node-left node)) elemnode)
(setf (ewoc--node-left node) elemnode))
(defun ewoc--node-enter-first (dll node)
"Add a free floating NODE first in DLL."
(ewoc--node-enter-before (ewoc--node-right dll) node))
(defun ewoc--node-enter-last (dll node)
"Add a free floating NODE last in DLL."
(ewoc--node-enter-before dll node))
(defun ewoc--node-next (dll node)
"Return the node after NODE, or nil if NODE is the last node."
(unless (eq (ewoc--node-right node) dll) (ewoc--node-right node)))
(defun ewoc--node-prev (dll node)
"Return the node before NODE, or nil if NODE is the first node."
(unless (eq (ewoc--node-left node) dll) (ewoc--node-left node)))
(defun ewoc--node-delete (node)
"Unbind NODE from its doubly linked list and return it."
;; This is a no-op when applied to the dummy node. This will return
;; nil if applied to the dummy node since it always contains nil.
(setf (ewoc--node-right (ewoc--node-left node)) (ewoc--node-right node))
(setf (ewoc--node-left (ewoc--node-right node)) (ewoc--node-left node))
(setf (ewoc--node-left node) nil)
(setf (ewoc--node-right node) nil)
node)
(defun ewoc--node-nth (dll n)
"Return the Nth node from the doubly linked list DLL.
N counts from zero. If DLL is not that long, nil is returned.
If N is negative, return the -(N+1)th last element.
Thus, (ewoc--node-nth dll 0) returns the first node,
and (ewoc--node-nth dll -1) returns the last node."
;; Branch 0 ("follow left pointer") is used when n is negative.
;; Branch 1 ("follow right pointer") is used otherwise.
(let* ((branch (if (< n 0) 0 1))
(node (ewoc--node-branch dll branch)))
(if (< n 0) (setq n (- -1 n)))
(while (and (not (eq dll node)) (> n 0))
(setq node (ewoc--node-branch node branch))
(setq n (1- n)))
(unless (eq dll node) node)))
(defun ewoc-location (node)
"Return the start location of NODE."
(ewoc--node-start-marker node))
;;; The ewoc data type
(defstruct (ewoc
(:constructor nil)
(:constructor ewoc--create
(buffer pretty-printer header footer dll))
(:conc-name ewoc--))
buffer pretty-printer header footer dll last-node)
(defmacro ewoc--set-buffer-bind-dll-let* (ewoc varlist &rest forms)
"Execute FORMS with ewoc--buffer selected as current buffer,
dll bound to ewoc--dll, and VARLIST bound as in a let*.
dll will be bound when VARLIST is initialized, but the current
buffer will *not* have been changed.
Return value of last form in FORMS."
(let ((old-buffer (make-symbol "old-buffer"))
(hnd (make-symbol "ewoc")))
(` (let* (((, old-buffer) (current-buffer))
((, hnd) (, ewoc))
(dll (ewoc--dll (, hnd)))
(,@ varlist))
(set-buffer (ewoc--buffer (, hnd)))
(unwind-protect
(progn (,@ forms))
(set-buffer (, old-buffer)))))))
(defmacro ewoc--set-buffer-bind-dll (ewoc &rest forms)
`(ewoc--set-buffer-bind-dll-let* ,ewoc nil ,@forms))
(defsubst ewoc--filter-hf-nodes (ewoc node)
"Evaluate NODE once and return it.
BUT if it is the header or the footer in EWOC return nil instead."
(unless (or (eq node (ewoc--header ewoc))
(eq node (ewoc--footer ewoc)))
node))
(defun ewoc--create-node (data pretty-printer pos)
"Call PRETTY-PRINTER with point set at POS in current buffer.
Remember the start position. Create a wrapper containing that
start position and the element DATA."
(save-excursion
;; Remember the position as a number so that it doesn't move
;; when we insert the string.
(when (markerp pos) (setq pos (marker-position pos)))
(goto-char pos)
(let ((inhibit-read-only t))
;; Insert the trailing newline using insert-before-markers
;; so that the start position for the next element is updated.
(insert-before-markers ?\n)
;; Move back, and call the pretty-printer.
(backward-char 1)
(funcall pretty-printer data)
(ewoc--node-create (copy-marker pos) data))))
(defun ewoc--delete-node-internal (ewoc node)
"Delete a data string from EWOC.
Can not be used on the footer. Returns the wrapper that is deleted.
The start-marker in the wrapper is set to nil, so that it doesn't
consume any more resources."
(let ((dll (ewoc--dll ewoc))
(inhibit-read-only t))
;; If we are about to delete the node pointed at by last-node,
;; set last-node to nil.
(if (eq (ewoc--last-node ewoc) node)
(setf (ewoc--last-node ewoc) nil))
(delete-region (ewoc--node-start-marker node)
(ewoc--node-start-marker (ewoc--node-next dll node)))
(set-marker (ewoc--node-start-marker node) nil)
;; Delete the node, and return the wrapper.
(ewoc--node-delete node)))
(defun ewoc--refresh-node (pp node)
"Redisplay the element represented by NODE using the pretty-printer PP."
(let ((inhibit-read-only t))
(save-excursion
;; First, remove the string from the buffer:
(delete-region (ewoc--node-start-marker node)
(1- (marker-position
(ewoc--node-start-marker (ewoc--node-right node)))))
;; Calculate and insert the string.
(goto-char (ewoc--node-start-marker node))
(funcall pp (ewoc--node-data node)))))
;;; ===========================================================================
;;; Public members of the Ewoc package
(defun ewoc-create (pretty-printer &optional header footer)
"Create an empty ewoc.
The ewoc will be inserted in the current buffer at the current position.
PRETTY-PRINTER should be a function that takes one argument, an
element, and inserts a string representing it in the buffer (at
point). The string PRETTY-PRINTER inserts may be empty or span
several linse. A trailing newline will always be inserted
automatically. The PRETTY-PRINTER should use insert, and not
insert-before-markers.
Optional third argument HEADER is a string that will always be
present at the top of the ewoc. HEADER should end with a
newline. Optionaly fourth argument FOOTER is similar, and will
be inserted at the bottom of the ewoc."
(let ((new-ewoc
(ewoc--create (current-buffer)
pretty-printer nil nil (ewoc--dll-create)))
(pos (point)))
(ewoc--set-buffer-bind-dll new-ewoc
;; Set default values
(unless header (setq header ""))
(unless footer (setq footer ""))
(setf (ewoc--node-start-marker dll) (copy-marker pos))
(let ((foot (ewoc--create-node footer (lambda (x) (insert footer)) pos))
(head (ewoc--create-node header (lambda (x) (insert header)) pos)))
(ewoc--node-enter-first dll head)
(ewoc--node-enter-last dll foot)
(setf (ewoc--header new-ewoc) head)
(setf (ewoc--footer new-ewoc) foot)))
;; Return the ewoc
new-ewoc))
(defalias 'ewoc-data 'ewoc--node-data)
(defun ewoc-enter-first (ewoc data)
"Enter DATA first in EWOC."
(ewoc--set-buffer-bind-dll ewoc
(ewoc-enter-after ewoc (ewoc--node-nth dll 0) data)))
(defun ewoc-enter-last (ewoc data)
"Enter DATA last in EWOC."
(ewoc--set-buffer-bind-dll ewoc
(ewoc-enter-before ewoc (ewoc--node-nth dll -1) data)))
(defun ewoc-enter-after (ewoc node data)
"Enter a new element DATA after NODE in EWOC.
Returns the new NODE."
(ewoc--set-buffer-bind-dll ewoc
(ewoc-enter-before ewoc (ewoc--node-next dll node) data)))
(defun ewoc-enter-before (ewoc node data)
"Enter a new element DATA before NODE in EWOC.
Returns the new NODE."
(ewoc--set-buffer-bind-dll ewoc
(ewoc--node-enter-before
node
(ewoc--create-node
data
(ewoc--pretty-printer ewoc)
(ewoc--node-start-marker node)))))
(defun ewoc-next (ewoc node)
"Get the next node.
Returns nil if NODE is nil or the last element."
(when node
(ewoc--filter-hf-nodes
ewoc (ewoc--node-next (ewoc--dll ewoc) node))))
(defun ewoc-prev (ewoc node)
"Get the previous node.
Returns nil if NODE is nil or the first element."
(when node
(ewoc--filter-hf-nodes
ewoc
(ewoc--node-prev (ewoc--dll ewoc) node))))
(defun ewoc-nth (ewoc n)
"Return the Nth node.
N counts from zero. Nil is returned if there is less than N elements.
If N is negative, return the -(N+1)th last element.
Thus, (ewoc-nth dll 0) returns the first node,
and (ewoc-nth dll -1) returns the last node.
Use `ewoc--node-data' to extract the data from the node."
;; Skip the header (or footer, if n is negative).
(setq n (if (< n 0) (1- n) (1+ n)))
(ewoc--filter-hf-nodes ewoc
(ewoc--node-nth (ewoc--dll ewoc) n)))
(defun ewoc-map (map-function ewoc &rest args)
"Apply MAP-FUNCTION to all elements in EWOC.
MAP-FUNCTION is applied to the first element first.
If MAP-FUNCTION returns non-nil the element will be refreshed (its
pretty-printer will be called once again).
Note that the buffer for EWOC will be current buffer when MAP-FUNCTION
is called. MAP-FUNCTION must restore the current buffer to BUFFER before
it returns, if it changes it.
If more than two arguments are given, the remaining
arguments will be passed to MAP-FUNCTION."
(ewoc--set-buffer-bind-dll-let* ewoc
((footer (ewoc--footer ewoc))
(node (ewoc--node-nth dll 1)))
(while (not (eq node footer))
(if (apply map-function (ewoc--node-data node) args)
(ewoc--refresh-node (ewoc--pretty-printer ewoc) node))
(setq node (ewoc--node-next dll node)))))
(defun ewoc-filter (ewoc predicate &rest args)
"Remove all elements in EWOC for which PREDICATE returns nil.
Note that the buffer for EWOC will be current-buffer when PREDICATE
is called. PREDICATE must restore the current buffer before it returns
if it changes it.
The PREDICATE is called with the element as its first argument. If any
ARGS are given they will be passed to the PREDICATE."
(ewoc--set-buffer-bind-dll-let* ewoc
((node (ewoc--node-nth dll 1))
(footer (ewoc--footer ewoc))
(next nil))
(while (not (eq node footer))
(setq next (ewoc--node-next dll node))
(unless (apply predicate (ewoc--node-data node) args)
(ewoc--delete-node-internal ewoc node))
(setq node next))))
(defun ewoc-locate (ewoc &optional pos guess)
"Return the node that POS (a buffer position) is within.
POS may be a marker or an integer. It defaults to point.
GUESS should be a node that it is likely that POS is near.
If POS points before the first element, the first node is returned.
If POS points after the last element, the last node is returned.
If the EWOC is empty, nil is returned."
(unless pos (setq pos (point)))
(ewoc--set-buffer-bind-dll-let* ewoc
()
(cond
;; Nothing present?
((eq (ewoc--node-nth dll 1) (ewoc--node-nth dll -1))
nil)
;; Before second elem?
((< pos (ewoc--node-start-marker (ewoc--node-nth dll 2)))
(ewoc--node-nth dll 1))
;; After one-before-last elem?
((>= pos (ewoc--node-start-marker (ewoc--node-nth dll -2)))
(ewoc--node-nth dll -2))
;; We now know that pos is within a elem.
(t
;; Make an educated guess about which of the three known
;; node'es (the first, the last, or GUESS) is nearest.
(let* ((best-guess (ewoc--node-nth dll 1))
(distance (abs (- pos (ewoc--node-start-marker best-guess)))))
(when guess
(let ((d (abs (- pos (ewoc--node-start-marker guess)))))
(when (< d distance)
(setq distance d)
(setq best-guess guess))))
(let* ((g (ewoc--node-nth dll -1)) ;Check the last elem
(d (abs (- pos (ewoc--node-start-marker g)))))
(when (< d distance)
(setq distance d)
(setq best-guess g)))
(when (ewoc--last-node ewoc) ;Check "previous".
(let* ((g (ewoc--last-node ewoc))
(d (abs (- pos (ewoc--node-start-marker g)))))
(when (< d distance)
(setq distance d)
(setq best-guess g))))
;; best-guess is now a "best guess".
;; Find the correct node. First determine in which direction
;; it lies, and then move in that direction until it is found.
(cond
;; Is pos after the guess?
((>= pos
(ewoc--node-start-marker best-guess))
;; Loop until we are exactly one node too far down...
(while (>= pos (ewoc--node-start-marker best-guess))
(setq best-guess (ewoc--node-next dll best-guess)))
;; ...and return the previous node.
(ewoc--node-prev dll best-guess))
;; Pos is before best-guess
(t
(while (< pos (ewoc--node-start-marker best-guess))
(setq best-guess (ewoc--node-prev dll best-guess)))
best-guess)))))))
(defun ewoc-invalidate (ewoc &rest nodes)
"Refresh some elements.
The pretty-printer that for EWOC will be called for all NODES."
(ewoc--set-buffer-bind-dll ewoc
(dolist (node nodes)
(ewoc--refresh-node (ewoc--pretty-printer ewoc) node))))
(defun ewoc-goto-prev (ewoc arg)
"Move point to the ARGth previous element.
Don't move if we are at the first element, or if EWOC is empty.
Returns the node we moved to."
(ewoc--set-buffer-bind-dll-let* ewoc
((node (ewoc-locate ewoc (point))))
(when node
;; If we were past the last element, first jump to it.
(when (>= (point) (ewoc--node-start-marker (ewoc--node-right node)))
(setq arg (1- arg)))
(while (and node (> arg 0))
(setq arg (1- arg))
(setq node (ewoc--node-prev dll node)))
;; Never step above the first element.
(unless (ewoc--filter-hf-nodes ewoc node)
(setq node (ewoc--node-nth dll 1)))
(ewoc-goto-node ewoc node))))
(defun ewoc-goto-next (ewoc arg)
"Move point to the ARGth next element.
Returns the node (or nil if we just passed the last node)."
(ewoc--set-buffer-bind-dll-let* ewoc
((node (ewoc-locate ewoc (point))))
(while (and node (> arg 0))
(setq arg (1- arg))
(setq node (ewoc--node-next dll node)))
;; Never step below the first element.
;; (unless (ewoc--filter-hf-nodes ewoc node)
;; (setq node (ewoc--node-nth dll -2)))
(ewoc-goto-node ewoc node)))
(defun ewoc-goto-node (ewoc node)
"Move point to NODE."
(ewoc--set-buffer-bind-dll ewoc
(goto-char (ewoc--node-start-marker node))
(if goal-column (move-to-column goal-column))
(setf (ewoc--last-node ewoc) node)))
(defun ewoc-refresh (ewoc)
"Refresh all data in EWOC.
The pretty-printer that was specified when the EWOC was created
will be called for all elements in EWOC.
Note that `ewoc-invalidate' is more efficient if only a small
number of elements needs to be refreshed."
(ewoc--set-buffer-bind-dll-let* ewoc
((footer (ewoc--footer ewoc)))
(let ((inhibit-read-only t))
(delete-region (ewoc--node-start-marker (ewoc--node-nth dll 1))
(ewoc--node-start-marker footer))
(goto-char (ewoc--node-start-marker footer))
(let ((node (ewoc--node-nth dll 1)))
(while (not (eq node footer))
(set-marker (ewoc--node-start-marker node) (point))
(funcall (ewoc--pretty-printer ewoc)
(ewoc--node-data node))
(insert "\n")
(setq node (ewoc--node-next dll node)))))
(set-marker (ewoc--node-start-marker footer) (point))))
(defun ewoc-collect (ewoc predicate &rest args)
"Select elements from EWOC using PREDICATE.
Return a list of all selected data elements.
PREDICATE is a function that takes a data element as its first argument.
The elements on the returned list will appear in the same order as in
the buffer. You should not rely on in which order PREDICATE is
called.
Note that the buffer the EWOC is displayed in is current-buffer
when PREDICATE is called. If PREDICATE must restore current-buffer if
it changes it.
If more than two arguments are given the
remaining arguments will be passed to PREDICATE."
(ewoc--set-buffer-bind-dll-let* ewoc
((header (ewoc--header ewoc))
(node (ewoc--node-nth dll -2))
result)
(while (not (eq node header))
(if (apply predicate (ewoc--node-data node) args)
(push (ewoc--node-data node) result))
(setq node (ewoc--node-prev dll node)))
(nreverse result)))
(defun ewoc-buffer (ewoc)
"Return the buffer that is associated with EWOC.
Returns nil if the buffer has been deleted."
(let ((buf (ewoc--buffer ewoc)))
(when (buffer-name buf) buf)))
(defun ewoc-get-hf (ewoc)
"Return a cons cell containing the (HEADER . FOOTER) of EWOC."
(cons (ewoc--node-data (ewoc--header ewoc))
(ewoc--node-data (ewoc--footer ewoc))))
(defun ewoc-set-hf (ewoc header footer)
"Set the HEADER and FOOTER of EWOC."
(setf (ewoc--node-data (ewoc--header ewoc)) header)
(setf (ewoc--node-data (ewoc--footer ewoc)) footer)
(ewoc--refresh-node (lambda (x) (insert header)) (ewoc--header ewoc))
(ewoc--refresh-node (lambda (x) (insert footer)) (ewoc--footer ewoc)))
(provide 'ewoc)
;;; Local Variables:
;;; eval: (put 'ewoc--set-buffer-bind-dll 'lisp-indent-hook 1)
;;; eval: (put 'ewoc--set-buffer-bind-dll-let* 'lisp-indent-hook 2)
;;; End:
;;; ewoc.el ends here

165
dvc/lisp/dvc-about.el
View File

@ -1,165 +0,0 @@
;;; dvc-about.el --- "About DVC" message
;; Copyright (C) 2006 by all contributors
;; This file is part of DVC.
;;
;; DVC is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; DVC is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; Eye cather displaying about DVC
;;; Code:
(eval-when-compile (require 'cl))
(require 'dvc-buffers)
(require 'dvc-version)
;; Test cases
;; (dvc-about-message-with-bouncing
;; (concat "Author: Stefan Reichoer <stefan@xsteve.at>, "
;; "Contributions from: "
;; "Matthieu Moy <Matthieu.Moy@imag.fr>, "
;; "Masatake YAMATO <jet@gyve.org>, "
;; "Milan Zamazal <pdm@zamazal.org>, "
;; "Martin Pool <mbp@sourcefrog.net>, "
;; "Robert Widhopf-Fenk <hack@robf.de>, "
;; "Mark Triggs <mst@dishevelled.net>"))
;; (dvc-about-message-with-rolling
;; (concat "Author: Stefan Reichoer <stefan@xsteve.at>, "
;; "Contributions from: "
;; "Matthieu Moy <Matthieu.Moy@imag.fr>, "
;; "Masatake YAMATO <jet@gyve.org>, "
;; "Milan Zamazal <pdm@zamazal.org>, "
;; "Martin Pool <mbp@sourcefrog.net>, "
;; "Robert Widhopf-Fenk <hack@robf.de>, "
;; "Mark Triggs <mst@dishevelled.net>"))
(defvar dvc-about-message-long-default-interval 0.2
"Default animation step interval.
Used in `dvc-about-message-with-bouncing' and `dvc-about-message-with-rolling'")
(defvar dvc-about-message-long-border-interval 1.0
"Animation step interval when bouncing in `dvc-about-message-with-bouncing'.")
(defun* dvc-about-message-with-bouncing (&rest msg)
"Similar to `message' but display the message in bouncing animation to show long line."
(setq msg (apply 'format msg))
(let* ((width (- (window-width (minibuffer-window))
(+ 1 (length "[<] ") (length " [>]"))))
(msglen (length msg))
submsg
(steps (- msglen width))
j)
(if (< msglen width)
(message "%s" msg)
(while t
;; Go forward
(dotimes (i steps)
(setq submsg (substring msg i (+ i width)))
(message "[<] %s [ ]" submsg)
(unless (sit-for (cond
((eq i 0) dvc-about-message-long-border-interval)
(t dvc-about-message-long-default-interval)))
(return-from dvc-about-message-with-bouncing)))
;; Go back
(dotimes (i steps)
(setq j (- steps i))
(setq submsg (substring msg j (+ j width)))
(message "[ ] %s [>]" submsg)
(unless (sit-for (cond
((eq i 0) dvc-about-message-long-border-interval)
(t dvc-about-message-long-default-interval)))
(return-from dvc-about-message-with-bouncing)))
(garbage-collect)))))
(defun* dvc-about-message-with-rolling (&rest msg)
"Similar to `message' but display the message in rolling animation to show long line."
(setq msg (concat " <MESSAGE>: "
(apply 'format msg)
" "))
(let* ((width (- (window-width (minibuffer-window))
(+ 1 (length "[<] "))))
(msglen (length msg))
submsg
(normal-range (- msglen width)))
(if (< msglen width)
(message "%s" msg)
(while t
(dotimes (i msglen)
(setq submsg (if (< i normal-range)
(substring msg i (+ i width))
;; Rolling is needed.
(concat (substring msg i)
(substring msg 0 (- (+ i width) msglen)))))
(message "[<] %s" submsg)
(unless (sit-for (cond
((eq i 0) dvc-about-message-long-border-interval)
(t dvc-about-message-long-default-interval)))
(return-from dvc-about-message-with-rolling)))
(garbage-collect)))))
;;;###autoload
(defun dvc-about ()
"Displays a welcome message."
(interactive)
(let* ((name "*dvc-welcome*")
(buffer (get-buffer name)))
(if buffer (dvc-switch-to-buffer buffer)
(dvc-switch-to-buffer
(setq buffer (get-buffer-create name)))
(insert " *** Welcome to DVC ! *** \n")
(insert "\n")
(insert (format "DVC version: %s" dvc-version))
(insert "\n")
(insert
"\n"
""
"[" (dvc-about-insert-button "About" 'dvc-about)
"]"
"\n")
(toggle-read-only t)
(local-set-key [?q] (lambda () (interactive)
(kill-buffer (current-buffer)))))
;; TODO: Use CONTRIBUTORS file.
(dvc-about-message-with-bouncing
(concat "Author: Stefan Reichoer <stefan@xsteve.at>, "
"Contributions from: "
"Matthieu Moy <Matthieu.Moy@imag.fr>, "
"Masatake YAMATO <jet@gyve.org>, "
"Milan Zamazal <pdm@zamazal.org>, "
"Martin Pool <mbp@sourcefrog.net>, "
"Robert Widhopf-Fenk <hack@robf.de>, "
"Mark Triggs <mst@dishevelled.net>"
"WE MUST UPDATE THIS LIST"))))
(defun dvc-about-insert-button (label function)
"Insert a button labeled with LABEL and launching FUNCTION.
Helper function for `dvc-about'."
(dvc-face-add label 'bold
(let ((map (make-sparse-keymap)))
(define-key map [return] function)
(define-key map "\C-m" function)
(define-key map [mouse-2] function)
map)
nil))
(provide 'dvc-about)
;; Local Variables:
;; End:
;;; dvc-about.el ends here

279
dvc/lisp/dvc-annotate.el
View File

@ -1,279 +0,0 @@
;; dvc-annotate.el
;; (Copyed from 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 Free Software Foundation, Inc.
;; Author: FSF (see below for full credits)
;; Maintainer: Andre Spiegel <spiegel@gnu.org>
;; Keywords: tools
;; $Id$
;; 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 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Credits:
;; VC was initially designed and implemented by Eric S. Raymond
;; <esr@snark.thyrsus.com>. Over the years, many people have
;; contributed substantial amounts of work to VC. These include:
;; Per Cederqvist <ceder@lysator.liu.se>
;; Paul Eggert <eggert@twinsun.com>
;; Sebastian Kremer <sk@thp.uni-koeln.de>
;; Martin Lorentzson <martinl@gnu.org>
;; Dave Love <fx@gnu.org>
;; Stefan Monnier <monnier@cs.yale.edu>
;; J.D. Smith <jdsmith@alum.mit.edu>
;; Andre Spiegel <spiegel@gnu.org>
;; Richard Stallman <rms@gnu.org>
;; Thien-Thi Nguyen <ttn@gnu.org>
;; Changes made to vc.el by Takuzo O'hara, <takuzo.ohara@gmail.com>
;;
;; -. Removed parts not required in annotation.
;; -. Modified names with vc.. -> dvc.. to not to conflict with
;; vc.el.
;; -. Changed (vc-call-backend ...) to use static values defined
;; in below.
(defalias 'dvc-annotate-current-time 'dvc-default-annotate-current-time)
;;
;; -------------------------------------------------
;;
(defmacro dvc-annotate-8color-tty-p ()
"Determine whether we are on a tty that uses 8 or less colors."
(cond ((fboundp 'tty-display-color-p)
`(and (tty-display-color-p)
(<= (display-color-cells) 8)))
((and (fboundp 'display-color-p) (fboundp 'device-or-frame-type))
;; XEmacs 21
`(and (display-color-p)
(eq (device-or-frame-type (frame-device)) 'tty)))))
(defmacro dvc-annotate-tty-color-alist ()
"Return a list of colors, each element of which is a list."
(cond ((fboundp 'tty-color-alist)
`(tty-color-alist))
((fboundp 'tty-color-list)
`(mapcar #'list (tty-color-list)))))
;; Annotate customization
(defcustom dvc-annotate-color-map
(if (dvc-annotate-8color-tty-p)
;; 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)))
(dvc-annotate-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 \\[dvc-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 'dvc)
(defcustom dvc-annotate-very-old-color "#3F3FFF"
"Color for lines older than the current color range in \\[dvc-annotate]]."
:type 'string
:group 'dvc)
(defcustom dvc-annotate-background "black"
"Background color for \\[dvc-annotate].
Default color is used if nil."
:type 'string
:group 'dvc)
(defcustom dvc-annotate-face-misc-attribute '((:weight . bold))
"Other face attribute for faces used in dvc annotation.
Specify them as alist of (attribute . value) or nil to ignore."
:type 'string
:group 'dvc)
;;
;; -------------------------------------------------
;;
(defun dvc-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 dvc-annotate-display-autoscale (&optional full)
"Highlight the output of \\[dvc-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 (dvc-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 (setq date (prog1 (dvc-annotate-time)
(forward-line 1)))
(if (> date newest)
(setq newest date))
(if (< date oldest)
(setq oldest date))))
(dvc-annotate-display
(/ (- (if full newest current) oldest)
(dvc-annotate-oldest-in-map dvc-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))))))
;;
;; -------------------------------------------------
;;
(defun dvc-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 dvc-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 dvc-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 (dvc-annotate-time)))
(if next-time
(- (or offset
(dvc-annotate-current-time))
next-time))))
(defun dvc-default-annotate-current-time ()
"Return the current time, encoded as fractional days."
(dvc-annotate-convert-time (current-time)))
(defvar dvc-annotate-offset nil)
(defun dvc-annotate-display (ratio &optional offset)
"Highlight `dvc-annotate' output in the current buffer.
RATIO, is the expansion that should be applied to `dvc-annotate-color-map'.
The annotations are relative to the current time, unless overridden by OFFSET."
(if (/= ratio 1.0)
(set (make-local-variable 'dvc-annotate-color-map)
(mapcar (lambda (elem) (cons (* (car elem) ratio) (cdr elem)))
dvc-annotate-color-map)))
(set (make-local-variable 'dvc-annotate-offset) offset)
(font-lock-mode 1))
(defun dvc-annotate-lines (limit)
(let (difference)
(while (and (< (point) limit)
(setq difference (dvc-annotate-difference dvc-annotate-offset)))
(let* ((color (or (dvc-annotate-compcar difference dvc-annotate-color-map)
(cons nil dvc-annotate-very-old-color)))
;; substring from index 1 to remove any leading `#' in the name
(face-name (concat "dvc-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))
(if dvc-annotate-background
(set-face-background tmp-face
dvc-annotate-background))
(if (and (not (featurep 'xemacs))
dvc-annotate-face-misc-attribute)
(dolist (attr dvc-annotate-face-misc-attribute)
(set-face-attribute tmp-face nil
(car attr) (cdr attr))))
tmp-face))) ; Return the face
(point (point)))
(forward-line 1)
(put-text-property point (point) 'face face)))
;; Pretend to font-lock there were no matches.
nil))
(defun dvc-annotate-time ()
(dvc-call "dvc-annotate-time"))
(provide 'dvc-annotate)

70
dvc/lisp/dvc-be.el
View File

@ -1,70 +0,0 @@
;;; dvc-be.el --- dvc integration for bugs everywhere
;; Copyright (C) 2006 by all contributors
;; Author: Stefan Reichoer, <stefan@xsteve.at>
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; For more information on bugs everywhere see:
;; http://panoramicfeedback.com/opensource/
;; dvc-be should be an interface to bugs everywhere
;; at the moment be exists as standalone tool for arch/bzr
;; or as extension for hg
;; dvc-be should work with both:
;; be commands:
;; be assign Assign an individual or group to fix a bug
;; be close Close a bug
;; be comment Add a comment to a bug
;; be diff Compare bug reports with older tree
;; be inprogress Bug fixing in progress
;; be list List bugs
;; be new Create a new bug
;; be open Re-open a bug
;; be set Change tree settings
;; be set-root Assign the root directory for bug tracking
;; be severity Show or change a bug's severity level
;; be show Show a particular bug
;; be target Show or change a bug's target for fixing
;; be upgrade Upgrade the bugs to the latest format
;; hg be extension commands:
;; bassign assign a person to fix a bug
;; bclose close a given bug
;; bcomment add a comment to a given bug
;; binit initialize the bug repository
;; binprogress mark a bug as 'in-progress'
;; blist list bugs
;; bnew create a new bug
;; bopen re-open a given bug
;; bset show or change per-tree settings
;; bseverity Show or change a bug's severity level.
;; bshow show all information about a given bug
;; btarget Show or change a bug's target for fixing.
;; bversion print the version number
;; the xhg-be extension is in xhg-be.el
;; the standalone support for be will be in this file
;; The UI for listing/changing bugs will be in this file
(provide 'dvc-be)
;;; dvc-be.el ends here

1607
dvc/lisp/dvc-bookmarks.el
View File

File diff suppressed because it is too large Load Diff

759
dvc/lisp/dvc-buffers.el
View File

@ -1,759 +0,0 @@
;;; dvc-buffers.el --- Buffer management for DVC
;; Copyright (C) 2005-2011 by all contributors
;; Author: Matthieu Moy <Matthieu.Moy@imag.fr>
;; Contributions from:
;; Stefan Reichoer, <stefan@xsteve.at>
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;
(eval-when-compile (require 'cl))
(eval-and-compile (require 'dvc-utils))
(require 'dvc-ui)
(require 'dvc-defs)
(require 'dvc-register)
(defvar dvc-buffers-tree nil
"Tree containing all dvc buffers.
Must be of the form
((tla
(type1 (\"path1\" buffer \"original name of buffer\")
(\"path2\" buffer2 \"original name of buffer2\"))
(type2 (\"path1\" buffer3 \"original name of buffer3\")
(\"path3\" buffer4 \"original name of buffer4\")))
(bzr
(type1 (\"path4\" buffer5 \"original name of buffer5\")))
(xhg
(type3 (...))))
Used to keep track of all the dvc related buffers.")
(defvar dvc-buffer-type-alist
'(
(alog "log*" path)
;; alog for "absolute log", i.e., assume path supplied is already
;; the root path
(add-patch "add-patch*" path)
(annotate "annotate*" path)
(archives "archives*" single)
(bookmark "bookmarks*" single)
(branches "branches(%s)*" string)
(browse "browse*" single)
(categories "categories(%s)*" string)
(changelog "changelog*" root)
(changeset "changeset(%s)*" string)
(commit "commit*" root)
(conflicts "conflicts*" root)
(diff "diff*" root)
(errors "error*" multiple)
(file-diff "file-diff*" path)
(generic "process*" multiple)
(info "info*" root)
(inventory "inventory*" path)
(log "log*" root)
(log-edit "log-edit*" root)
(manifest "manifest*" root)
(missing "missing*" root)
(patch-queue "patch-queue*" root)
(pull "pull*" root)
(remote-log "log(%s)*" string)
(revision-diff "diff(%s)*" string)
(revisions "revisions(%s)*" string)
(revlog "revlog(%s)*" string-multiple)
(status "status*" root)
(tips "tips*" single)
(tla-missing "missing*" single)
(tree-lint "tree-lint*" root)
(unknowns "unknowns*" root)
(versions "versions(%s)*" string)
)
"List of (type name mode) used to generate a name for a buffer.
TYPE is the type of buffer to create, passed as the first argument to
`dvc-get-buffer-create'.
NAME is a string, used as a name for the returned buffer.
MODE is a symbol defining the way to manage (value of
`default-directory' in the created buffer) paths for this type of
buffers. It can have the following values:
* 'root: `default-directory' will be the tree-root of the specified
directory.
* 'path: `default-directory' will be the path specified. Can also be
a file.
For 'root and 'path, `dvc-get-buffer-create' will return the existing
buffer for this type and this path if it exists, or create a new one
otherwise.
* 'single: There is only one buffer of this type for each Emacs
instance. If a path is provided, `default-directory' is set to that
path. Otherwise, the path is left unchanged when a buffer is
reused, and set to the current directory on buffer creation.
* 'multiple: `default-directory' is set to the path specified. A new
buffer is returned anyway. (No buffer reuse).
* 'string: The path specified is actually a string. It won't be used
to set `default-directory'. The name of the created buffer will be
(format name string).
* 'string-multiple: combination of 'string and 'multiple.")
(defun dvc-buffers-tree-remove (buffer)
"Remove BUFFER from the buffers tree."
(dolist (dvc-cons dvc-buffers-tree)
(dolist (type-cons (cdr dvc-cons))
(dolist (path-buffer (cdr type-cons))
(when (eq (cadr path-buffer) buffer)
(setcdr type-cons (delete path-buffer (cdr type-cons))))))))
(defun dvc-buffers-tree-add (dvc type path buffer)
"Add a buffer for back-end DVC, of TYPE visiting PATH to the buffers tree.
BUFFER should be the buffer to add."
(let* ((to-add (list path buffer (buffer-name buffer)))
(dvc-assoc (assoc dvc dvc-buffers-tree))
(tree-assoc (assoc type dvc-assoc)))
(if dvc-assoc
(if tree-assoc
(push to-add
(cdr tree-assoc))
(push (list type to-add)
(cdr dvc-assoc)))
(push (list dvc (list type to-add))
dvc-buffers-tree))))
(defun dvc-create-buffer (name)
"Create a buffer for a dvc-mode.
`create-file-buffer' is used to allow uniquify to modify the name."
(with-current-buffer (create-file-buffer name)
(setq list-buffers-directory (concat default-directory name))
(current-buffer)))
(defun dvc-get-buffer-create (dvc type &optional path)
"Get a buffer of type TYPE for the path PATH (default `default-directory').
Maybe reuse one if it exists, according to the value of
`dvc-buffer-type-alist' (see its docstring), or, call
`generate-new-buffer' to create the buffer.
See also `dvc-get-buffer'"
;; Inspired from `cvs-get-buffer-create'
;;
;; For 'root buffers, make sure we don't create two buffers to the
;; same absolute path, even in the presence of symlinks.
(let ((return-buffer
(let* ((elem (assoc type dvc-buffer-type-alist))
(mode (car (cddr elem)))
(path (if (eq mode 'root)
(dvc-tree-root (dvc-uniquify-file-name (or path default-directory) t))
(or path default-directory))))
(or (dvc-get-buffer dvc type path mode)
;; Buffer couldn't be reused. Create one
(let ((name (concat "*" (symbol-name dvc) "-"
(cadr (assoc type dvc-buffer-type-alist)))))
(let ((buffer
(if (or (eq mode 'string)
(eq mode 'string-multiple))
(generate-new-buffer (format name path))
(let ((default-directory
(if (file-name-directory path)
(expand-file-name (file-name-directory path))
default-directory)))
(dvc-create-buffer name)))))
(with-current-buffer buffer
(if (featurep 'xemacs)
(dvc-install-buffer-menu))
(dvc-buffers-tree-add dvc type path buffer)
buffer)))))))
(with-current-buffer return-buffer
;; We do not set dvc-buffer-current-active-dvc here, because any
;; subsequent mode function will call kill-all-local-variables.
(dvc-trace "create buffer %S with back-end %S in %S"
return-buffer dvc default-directory)
return-buffer)))
(defun dvc-get-matching-buffers (dvc type path)
"Return the list of all dvc-buffers-tree entries matching DVC, TYPE, PATH.
If DVC is nil, it matches any back-end. TYPE must match exactly.
PATH matches if the entry in dvc-buffers-tree is a prefix of
PATH."
(let ((result nil)
(true-path (dvc-uniquify-file-name path))
tree)
(if dvc
(setq tree (cdr (assoc type (cdr (assoc dvc dvc-buffers-tree)))))
;; flatten tree to cover all back-ends
(let ((temp dvc-buffers-tree)
buffers)
(while temp
(setq buffers (cdr (assoc type (cdar temp))))
(setq tree (append tree buffers))
(setq temp (cdr temp)))))
;; Filter for path
(while tree
(let* ((root (caar tree))
(index (string-match (regexp-quote root) true-path)))
(if (and index (= 0 index))
(setq result (cons (car tree) result)))
(setq tree (cdr tree))))
result))
(defun dvc-get-buffer (dvc type &optional path mode)
"Get a buffer of type TYPE for the path PATH.
Maybe reuse one if it exists, depending on the value of MODE (see
`dvc-buffer-type-alist' 's third element), otherwise, return nil. See
also `dvc-get-buffer-create'."
(let ((mode (or mode (car (cddr (assoc type dvc-buffer-type-alist)))))
(path (or path default-directory))
(subtree (cdr (assoc dvc dvc-buffers-tree))))
(if (eq mode 'single)
;; nothing to do about PATH. Reuse anyway
(let* ((dvc-path subtree)
(list-path (cdr (assoc type dvc-path)))
(first-elem (car list-path)))
(if list-path
(if (string= (buffer-name (cadr first-elem))
(car (cddr first-elem)))
(cadr first-elem)
(setcdr (assoc type subtree) nil)
nil)
nil))
;; not 'single
(let ((path (and path
(cond
((eq mode 'root)
(dvc-uniquify-file-name
(dvc-tree-root path)))
((or (eq mode 'string)
(eq mode 'string-multiple))
path)
(t (dvc-uniquify-file-name path))))))
(if (or (eq mode 'multiple)
(eq mode 'string-multiple))
;; no need to search an existing buffer
nil
(let* ((list-path (assoc type subtree))
(elem (assoc path (cdr list-path)))
(buffer (cadr elem)))
(when buffer
(if (buffer-live-p buffer)
;; This used to check for buffer not renamed, but
;; that conflicts with uniquify.
buffer
;; remove the buffer and try again
(setcdr list-path
(delq (assoc path (cdr list-path))
(cdr list-path)))
(dvc-get-buffer type path mode)))))))))
(defun dvc-add-buffer-type (type name)
"Define a new TYPE of buffer whose buffer will be named NAME."
(unless (assoc type dvc-buffer-type-alist)
(push (list type name) dvc-buffer-type-alist)))
;; ----------------------------------------------------------------------------
;; Process buffers
;; ----------------------------------------------------------------------------
;; TODO unify with above alist.
(defcustom dvc-process-buffer " *%s-process*"
"*Name of the process buffer."
:type 'string
:group 'dvc-internal)
(defcustom dvc-error-buffer " *%s-errors*"
"*Name of the buffer to which the process's stderr is redirected."
:type 'string
:group 'dvc-internal)
(defcustom dvc-number-of-dead-process-buffer 0
"*Number of process buffers to keep after process termination.
When the number of process buffers exceeds this number, the most ancient
is killed. This includes both the process buffer and the error
buffer (to which stderr is redirected).
A nil value here means \"Never kill any process buffer\". Useful for
debugging, but this will eat the memory of your computer ;-)"
:type 'integer
:group 'dvc-internal)
(defcustom dvc-show-internal-buffers-on-menu nil
"Toggle display of dead process buffers in the buffer menu."
:type 'boolean
:group 'dvc-internal)
(defcustom dvc-other-frame-width 80
"Width of frame created by `dvc-switch-to-buffer' when `other-frame' arg is non-nil."
:type 'integer
:group 'dvc)
(defcustom dvc-other-frame-height 20
"Height of frame created by `dvc-switch-to-buffer' when `other-frame' arg is non-nil."
:type 'integer
:group 'dvc)
(defvar dvc-dead-process-buffer-queue nil
"List of process buffers belonging to terminated processes.
When the list is greater than `dvc-number-of-dead-process-buffer', the last
ones are killed.")
(defun dvc-kill-process-buffer (buffer)
"Don't actually kill BUFFER, but add it to `dvc-dead-process-buffer-queue'.
It will eventually be killed when the number of buffers in
`dvc-dead-process-buffer-queue'exceeds `dvc-number-of-dead-process-buffer'."
(dvc-add-to-list 'dvc-dead-process-buffer-queue buffer t)
(when dvc-number-of-dead-process-buffer
(while (> (length dvc-dead-process-buffer-queue)
(max 2 dvc-number-of-dead-process-buffer))
(let ((buf (car dvc-dead-process-buffer-queue)))
(when (buffer-live-p buf) (kill-buffer buf)))
(setq dvc-dead-process-buffer-queue
(cdr dvc-dead-process-buffer-queue)))))
(defvar dvc-last-process-buffer nil
"The last created process buffer.")
(defvar dvc-last-error-buffer nil
"The last created process buffer.")
(defun dvc-new-process-buffer (to-be-deleted back-end)
"Create a new process buffer.
If TO-BE-DELETED is non-nil, make this buffer a candidate for eventually
being deleted."
(let ((buffer (generate-new-buffer
(format dvc-process-buffer
back-end))))
(setq dvc-last-process-buffer buffer)
(when to-be-deleted (dvc-kill-process-buffer buffer))
buffer))
(defun dvc-new-error-buffer (to-be-deleted back-end)
"Create a new error buffer.
If TO-BE-DELETED is non-nil, make this buffer a candidate for eventually
being deleted."
(let ((buffer (generate-new-buffer
(format dvc-error-buffer
back-end))))
(setq dvc-last-error-buffer buffer)
(when to-be-deleted (dvc-kill-process-buffer buffer))
buffer))
;;
;; Process buffer mode section
;;
(defvar dvc-process-buffer-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (dvc-prefix-buffer ?L) 'dvc-open-internal-log-buffer)
(define-key map dvc-keyvec-quit 'dvc-buffer-quit)
map)
"Keymap used in dvc's log buffer.")
(define-derived-mode dvc-process-buffer-mode fundamental-mode
"DVC Process"
"Major mode for process buffers. Mainly defines \\[bury-buffer]
to quit the buffer"
(dvc-install-buffer-menu)
(toggle-read-only 1))
(defvar dvc-switched-buffer nil)
(defvar dvc-switched-from-buffer nil)
(defun dvc-switch-to-buffer (buffer &optional other-frame)
"Switch to BUFFER using the user's preferred method.
See `dvc-switch-to-buffer-mode' for possible settings."
(setq dvc-switched-from-buffer (current-buffer))
(cond
(other-frame
(let ((display-reuse-frames t)
(pop-up-frames t)
(pop-up-frame-alist `((width . ,dvc-other-frame-width)
(height . ,dvc-other-frame-height)
(minibuffer . nil))))
(pop-to-buffer buffer)))
((eq dvc-switch-to-buffer-mode 'pop-to-buffer)
(pop-to-buffer buffer))
((eq dvc-switch-to-buffer-mode 'single-window)
(switch-to-buffer buffer))
((eq dvc-switch-to-buffer-mode 'show-in-other-window)
(pop-to-buffer buffer)
(setq dvc-switched-buffer (current-buffer))
(pop-to-buffer dvc-switched-from-buffer))
(t
(error "Switch mode %s not implemented" dvc-switch-to-buffer-mode))))
(defun dvc-switch-to-buffer-maybe (buffer &optional setup-as-partner)
"Either switch to buffer BUFFER or just set-buffer.
Depends on the value of `dvc-switch-to-buffer-first'.
When SETUP-AS-PARTNER, set the `dvc-partner-buffer' variable in BUFFER to current-buffer and vice versa."
;; (message "dvc-switch-to-buffer-maybe, curr-buff: %s switch-to: %s" (current-buffer) buffer)
(when setup-as-partner
(setq dvc-partner-buffer buffer)
(let ((cur-buff (current-buffer)))
(with-current-buffer buffer
(setq dvc-partner-buffer cur-buff))))
(if dvc-switch-to-buffer-first
(dvc-switch-to-buffer buffer)
(set-buffer buffer)))
(defun dvc-post-switch-to-buffer ()
"Executed when showing a changeset.
If `dvc-switched-buffer' is non-nil, show this buffer, but keep
cursor position in previous buffer."
(when dvc-switched-buffer
(pop-to-buffer dvc-switched-buffer)
(setq dvc-switched-buffer nil)
(goto-char (point-min))
(pop-to-buffer dvc-switched-from-buffer)))
(defun dvc-show-process-buffer ()
"Show the process buffer of the last started DVC command."
(interactive)
(dvc-switch-to-buffer dvc-last-process-buffer)
(unless (member dvc-last-process-buffer
(mapcar (lambda (p)
(process-buffer (car p)))
dvc-process-running))
(dvc-process-buffer-mode)))
(defun dvc-show-last-error-buffer ()
"Show the error buffer of the last started DVC command."
(interactive)
(dvc-switch-to-buffer dvc-last-error-buffer)
(dvc-process-buffer-mode))
(defun dvc-show-last-process-buffer (&optional type mode path)
"Switch to the last used process buffer in a new buffer of TYPE.
If MODE is specified, it is a function that will be run in the
new buffer. Otherwise, the buffer will remain in fundamental mode, in
read-only.
If PATH is specified, it will be passed to `dvc-get-buffer-create'."
(when (buffer-live-p dvc-last-process-buffer)
(let ((content (with-current-buffer dvc-last-process-buffer
(buffer-string))))
(dvc-switch-to-buffer (dvc-get-buffer-create
'dvc (or type 'generic) path))
(let ((inhibit-read-only t))
(erase-buffer)
(insert content)))
(if mode
(funcall mode)
(dvc-process-buffer-mode))))
(defun dvc-show-error-buffer (buffer &optional type mode)
"Pops up a new buffer displaying contents of BUFFER.
New buffer has type TYPE (default 'errors), mode MODE (default
`dvc-process-buffer-mode')."
(when (buffer-live-p buffer)
(let ((content (with-current-buffer buffer
(buffer-string))))
(dvc-switch-to-buffer (dvc-get-buffer-create
'dvc (or type 'errors)))
(let ((inhibit-read-only t))
(erase-buffer)
(insert content)))
(if mode
(funcall mode)
(dvc-process-buffer-mode))))
;; ----------------------------------------------------------------------------
;; Buffers menu
;; ----------------------------------------------------------------------------
(defun dvc-buffers-menu ()
"Return menus for buffers managed in DVC."
(let ((menu (make-sparse-keymap (concat "DVC-Buffers")))
(submenu (make-sparse-keymap "Queue"))
(i dvc-number-of-dead-process-buffer))
;; Debug QUEUE
(mapcar
(lambda (buffer)
(when (buffer-live-p buffer)
(define-key submenu (vector (make-symbol (buffer-name buffer)))
`(menu-item ,(format "%d: %s%s"
i
(if (zerop (buffer-size buffer)) "[empty] " "")
(buffer-name buffer))
(lambda () (interactive) (switch-to-buffer ,buffer))
:enable t)))
(setq i (1- i)))
dvc-dead-process-buffer-queue)
(define-key menu [queue]
`(menu-item "Queue(DEBUG)"
,submenu
:enable dvc-show-internal-buffers-on-menu))
(mapcar
(lambda (item)
(let* ((dvc (car item))
(type-list (cdr item))
(dvc-label (capitalize (symbol-name dvc)))
(submenu (make-sparse-keymap dvc-label)))
(mapcar
(lambda (type-list)
(let* ((type-label
(concat dvc-label "-"
(capitalize (symbol-name (car type-list)))))
(type-submenu (make-sparse-keymap type-label)))
(mapcar
(lambda (subitem)
(let ((path (car subitem))
(buffer (cadr subitem)))
(when (buffer-live-p buffer)
(unless path
(setq path (buffer-name buffer)))
(define-key type-submenu (vector (make-symbol path))
`(menu-item ,path
(lambda () (interactive)
(switch-to-buffer ,buffer))
:enable t)))))
(cdr type-list))
(define-key submenu (vector (car type-list))
`(menu-item ,type-label
,type-submenu
:enable t))))
type-list)
(when type-list
(define-key menu (vector dvc)
`(menu-item ,dvc-label
,submenu
:enable t))
)))
dvc-buffers-tree)
(define-key menu [list-separator]
'(menu-item "--"))
(define-key menu [process-buffer]
'(menu-item "Show Process Bufffer" dvc-show-process-buffer))
(define-key menu [error-buffer]
'(menu-item "Show Error Bufffer" dvc-show-last-error-buffer))
(define-key menu [log-buffer]
'(menu-item "Open Log Bufffer" dvc-open-internal-log-buffer))
menu))
(eval-when-compile
(unless (functionp 'add-submenu)
(defun add-submenu (&rest arg)
"Avoids a byte-compiler warning for GNU Emacs")))
(defun dvc-install-buffer-menu ()
"Install the buffer menu."
(if (featurep 'xemacs)
;; See dvc-xemacs-buffers-menu in dvc-xemacs.el
(dvc-do-in-xemacs
(add-submenu nil (list "DVC-Buffers"
:filter 'dvc-xemacs-buffers-menu) nil))
;; GNU Emacs
(dvc-do-in-gnu-emacs
(let ((dvc-menu (or (lookup-key global-map [menu-bar tools dvc])
(lookup-key global-map [menu-bar tools DVC]))))
(when (and dvc-menu (not (integerp dvc-menu)))
(define-key-after
dvc-menu
[dvc-buffers]
(cons "DVC-Buffers"
(dvc-buffers-menu)))))
(let ((map (and
(current-local-map)
(or (lookup-key (current-local-map) [menu-bar])
(define-key (current-local-map) [menu-bar]
(make-keymap))))))
(when map
(apply (if (functionp 'define-key-after)
'define-key-after
'define-key)
map
[dvc-buffers]
(cons "DVC-Buffers"
(dvc-buffers-menu))
nil)))
(add-hook 'menu-bar-update-hook 'dvc-install-buffer-menu nil t))))
(defvar dvc-buffer-previous-window-config nil
"Window-configuration to return to on buffer quit.
If nil, nothing is done special. Otherwise, must be a
window-configuration. `dvc-buffer-quit' will restore this
window-configuration.")
(make-variable-buffer-local 'dvc-buffer-previous-window-config)
;; TODO: eventually implement dvc-buffer-previous-window-config as list
;; That does not work at the moment, because it is buffer local.
;; I (Stefan) will play a bit with a global list
(defun dvc-buffer-push-previous-window-config (&optional window-config)
"Store WINDOW-CONFIG in `dvc-buffer-previous-window-config'.
When WINDOW-CONFIG is nil, store `current-window-configuration' instead."
(setq dvc-buffer-previous-window-config (or window-config (current-window-configuration))))
(defun dvc-buffer-quit ()
"Quit the current buffer.
If `dvc-buffer-quit-mode' is 'kill, then kill the buffer. Otherwise,
just bury it."
(interactive)
;; Value is buffer local => keep it before killing the buffer!
(let ((prev-wind-conf dvc-buffer-previous-window-config))
(if (eq dvc-buffer-quit-mode 'kill)
(kill-buffer (current-buffer))
(bury-buffer))
(when prev-wind-conf
(set-window-configuration prev-wind-conf))))
(defun dvc-kill-all-buffers ()
"Kill all dvc buffers."
(interactive)
(let ((number 0))
(dolist (dvc-kind dvc-buffers-tree)
(dolist (type-cons (cdr dvc-kind))
(dolist (path-buffer (cdr type-cons))
(setq number (1+ number))
(kill-buffer (cadr path-buffer)))))
(message "Killed %d buffer%s" number
(if (> number 1) "s" "")))
(setq dvc-buffers-tree nil))
(defun dvc-kill-all-type (type)
"Kill all buffers of type TYPE."
(let ((number 0))
(dolist (dvc-kind dvc-buffers-tree)
(dolist (type-cons (cdr dvc-kind))
(if (equal type (car type-cons))
(dolist (path-buffer (cdr type-cons))
(setq number (1+ number))
(kill-buffer (cadr path-buffer))))))
(message "Killed %d buffer%s" number
(if (> number 1) "s" ""))))
(defun dvc-kill-all-review ()
"Kill all buffers used in reviews; showing previous revisions."
(interactive)
(dvc-kill-all-type 'revision)
(dvc-kill-all-type 'last-revision))
(defun dvc-kill-all-workspace (workspace)
"Kill all buffers whose files are in the WORKSPACE tree."
(interactive "Dkill buffers in workspace: ")
(let ((workspace (expand-file-name workspace))
(count 0))
(dolist (buffer (buffer-list))
(let ((file-name (buffer-file-name buffer)))
(and file-name ;; some buffers don't have a file name
(string= workspace (substring file-name 0 (min (length file-name) (length workspace))))
(kill-buffer buffer)
(setq count (+ 1 count)))))
(message "killed %d buffers" count)))
(defvar dvc-save-some-buffers-ignored-modes '(dvc-log-edit-mode))
(defun dvc-save-some-buffers (&optional tree)
"Save all buffers visiting a file in TREE."
(interactive)
(let ((ok t)
(tree (or (dvc-tree-root tree t)
tree)))
(unless tree
(error "Not in a project tree"))
(dolist (buffer (buffer-list))
(with-current-buffer buffer
(when (and (buffer-modified-p) (not (member major-mode dvc-save-some-buffers-ignored-modes)))
(let ((file (buffer-file-name)))
(when file
(let ((root (dvc-uniquify-file-name
(dvc-tree-root (file-name-directory file) t)))
(tree-exp (dvc-uniquify-file-name tree)))
(when (and root
(string= root tree-exp)
;; buffer is modified and in the tree TREE.
(or dvc-do-not-prompt-for-save
(y-or-n-p (concat "Save buffer "
(buffer-name)
"? "))
(setq ok nil)))
(save-buffer))))))))
ok))
(defun dvc-revert-some-buffers (&optional tree)
"Reverts all buffers visiting a file in TREE that aren't modified.
To be run after an update or a merge."
(interactive)
(let ((tree (dvc-tree-root tree)))
(dolist (buffer (buffer-list))
(with-current-buffer buffer
(when (not (buffer-modified-p))
(let ((file (buffer-file-name)))
(when file
(let ((root (dvc-uniquify-file-name
(dvc-tree-root (file-name-directory file) t)))
(tree-exp (dvc-uniquify-file-name
(expand-file-name tree))))
(when (and (string= root tree-exp)
;; buffer is not modified and in the tree TREE.
dvc-automatically-revert-buffers)
;; Keep the buffer if the file doesn't exist
(if (file-exists-p file)
(revert-buffer t t t)))))))))))
(defun dvc-buffer-visible-p (buffer)
"Return non-nil if BUFFER is visible in frame."
(save-window-excursion
(let ((buf (current-buffer))
(window-conf (current-window-configuration)))
(pop-to-buffer buffer)
(pop-to-buffer buf)
(dvc-do-in-xemacs
(and (setq window-conf (get-buffer-window buffer))
window-conf ;; we use window-conf only to get rid of warnings
(equal (window-frame (get-buffer-window buffer))
(selected-frame))))
(dvc-do-in-gnu-emacs
(compare-window-configurations window-conf
(current-window-configuration))))))
(defun dvc-buffer-show-or-scroll (buffer &optional down)
"If BUFFER is visible, scroll it. Otherwise, show it.
if DOWN is non-nil, scroll down, otherwise, scroll up."
(if (dvc-buffer-visible-p buffer)
(progn
(pop-to-buffer buffer)
(condition-case nil
(if down
(scroll-down 2)
(save-excursion
(move-to-window-line -1)
(if (> (point-max) (point))
(scroll-up 2)
(message "end of buffer"))))
(error (message "Can't scroll anymore."))
))
(dvc-switch-to-buffer buffer)))
(provide 'dvc-buffers)
;;; dvc-buffers.el ends here

87
dvc/lisp/dvc-bug.el
View File

@ -1,87 +0,0 @@
;;; dvc-bug.el --- Reporting bugs to Xtla-el-dev list
;; Copyright (C) 2006-2007 by all contributors
;; This file is part of DVC.
;;
;; DVC is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; DVC is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;; Code:
(require 'dvc-version)
(require 'dvc-register)
;;;###autoload
(defun dvc-submit-bug-report ()
"Submit a bug report, with pertinent information to the dvc-dev list."
(interactive)
(require 'reporter)
(delete-other-windows)
;; (dvc-version)
(dvc-command-version)
(reporter-submit-bug-report
"dvc-dev@gna.org"
(concat "Dvc " dvc-version)
(append
;; non user variables
'(emacs-version
dvc-version
dvc-command-version
)
;; user variables
(sort (apropos-internal (concat "^\\("
(mapconcat (lambda (name)
(concat (regexp-quote (symbol-name name)) "-"))
dvc-registered-backends
"\\|")
"\\)")
'user-variable-p)
(lambda (v1 v2) (string-lessp (format "%s" v1) (format "%s" v2))))
;; see what the user had loaded
(list 'features)
)
nil
nil
(concat
"Please change the Subject header to a concise bug description or feature request.\n"
"In this report, remember to cover the basics, that is, what you \n"
"expected to happen and what in fact did happen.\n"
"Please remove these instructions from your message."))
;; insert the backtrace buffer content if present
(let ((backtrace (get-buffer "*Backtrace*")))
(when backtrace
(goto-char (point-max))
(insert "\n\n")
(insert-buffer-substring backtrace)))
(goto-char (point-min))
(mail-position-on-field "Subject")
(insert "[BUG/FEATURE] "))
;; For people used to Debian's reportbug
(defalias 'dvc-report-bug 'vc-submit-bug-report)
;; For people used to Gnus M-x gnus-bug RET
(defalias 'dvc-bug 'dvc-submit-bug-report)
;; (reporting bugs should be easy ;-)
(provide 'dvc-bug)
;; Local Variables:
;; End:
;;; dvc-bug.el ends here

414
dvc/lisp/dvc-build.el
View File

@ -1,414 +0,0 @@
;;; dvc-build.el --- compile-time helper.
;; Copyright (C) 2004-2008 by all contributors
;; Author: Matthieu Moy <Matthieu.Moy@imag.fr>
;; Thien-Thi Nguyen <ttn@gnuvola.org>
;; Inspired from the work of Steve Youngs <steve@youngs.au.com>
;; This file is part of DVC.
;;
;; DVC is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; DVC is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; This file provides various functions for $(ebatch); see Makefile.in.
;; It is neither compiled nor installed.
;;; Code:
(unless noninteractive
(error "This file is not intended for interactive use (see Makefile.in)"))
;; Expect a small set of env vars to be set by caller.
(defvar srcdir (or (getenv "srcdir")
(error "Env var `srcdir' not set")))
(defvar otherdirs (or (getenv "otherdirs")
;; We used to `error' as for `srcdir' here, but on some
;; systems, if the value is "", `getenv' returns nil, so
;; we can't be too strict. Reported by Stephen Leake.
""))
;; Take control of exit(3).
(fset 'bye-bye (symbol-function 'kill-emacs))
(defun kill-emacs (&optional arg)
(when (and arg (not (equal 0 arg)))
(bye-bye)))
;; Standard
(defun zonk-file (filename)
(when (file-exists-p filename)
(delete-file filename)))
(require 'cl)
(require 'loadhist)
(require 'bytecomp)
(defun f-set-difference (a b) (set-difference a b :test 'string=))
(defun f-intersection (a b) (intersection a b :test 'string=))
(defun srcdir/ (filename)
(expand-file-name filename srcdir))
;; Increase the max-specpdl-size size to avoid an error on some platforms
(setq max-specpdl-size (max 1000 max-specpdl-size))
;; Munge `load-path': contrib at end, everything else in front.
(add-to-list 'load-path (srcdir/ "contrib") t)
(dolist (dir
;;+ (split-string otherdirs " " t)
;; Three-arg `split-string' is supported as of Emacs 22 and XEmacs
;; 21.4.16. We will switch to it eventually. For now, this works:
(delete "" (split-string otherdirs " ")))
(add-to-list 'load-path dir))
(add-to-list 'load-path (unless (equal "." srcdir) srcdir))
(add-to-list 'load-path nil)
;; Avoid interference from Emacs' VC.
(setq vc-handled-backends nil)
;; Internal vars are named --foo.
;; Platform-specific filenames.
(defvar --autoloads-filename (if (featurep 'xemacs)
"auto-autoloads.el"
"dvc-autoloads.el"))
(defvar --custom-autoloads-filename (if (featurep 'xemacs)
"custom-load.el"
"cus-load.el"))
;; List of files to compile.
(defvar --to-compile
(f-set-difference
;; plus
(append
;; generated files
(unless (string= "." srcdir)
(mapcar 'expand-file-name '("dvc-version.el"
"dvc-site.el")))
;; contrib libraries
(when (string= (file-name-directory (locate-library "ewoc"))
(srcdir/ "contrib/"))
'("contrib/ewoc.el"))
;; $(srcdir)/*.el
(directory-files srcdir nil "^[^=].*\\.el$"))
;; minus
(append
;; static
`("dvc-build.el"
,--autoloads-filename
,--custom-autoloads-filename
,(if (featurep 'xemacs)
"dvc-emacs.el"
"dvc-xemacs.el"))
;; dynamic: if invalid, use nil
(unless (locate-library "tree-widget")
'("tla-browse.el")))))
;; Warnings we care about.
(defvar --warnings '(unresolved callargs redefine))
;; Autoload forms for XEmacs.
(when (featurep 'xemacs)
(autoload 'setenv (if (emacs-version>= 21 5) "process" "env") nil t)
;; DVC things
(autoload 'replace-regexp-in-string "dvc-xemacs.el")
(autoload 'line-number-at-pos "dvc-xemacs.el")
(autoload 'line-beginning-position "dvc-xemacs.el")
(autoload 'line-end-position "dvc-xemacs.el")
(autoload 'match-string-no-properties "dvc-xemacs.el")
(autoload 'tla--run-tla-sync "tla-core.el")
(autoload 'dvc-switch-to-buffer "dvc-buffers.el")
(autoload 'dvc-trace "dvc-utils.el")
(autoload 'dvc-flash-line "tla")
(autoload 'tla-tree-root "tla")
(autoload 'tla--name-construct "tla-core")
(defalias 'dvc-cmenu-mouse-avoidance-point-position
'mouse-avoidance-point-position)
;; External things
(autoload 'debug "debug")
(autoload 'tree-widget-action "tree-widget")
(autoload 'ad-add-advice "advice")
(autoload 'customize-group "cus-edit" nil t)
(autoload 'dired "dired" nil t)
(autoload 'dired-other-window "dired" nil t)
(autoload 'dolist "cl-macs" nil nil 'macro)
(autoload 'easy-mmode-define-keymap "easy-mmode")
(autoload 'minibuffer-prompt-end "completer")
(autoload 'mouse-avoidance-point-position "avoid")
(autoload 'read-passwd "passwd")
(autoload 'read-kbd-macro "edmacro" nil t)
(autoload 'regexp-opt "regexp-opt")
(autoload 'reporter-submit-bug-report "reporter")
(autoload 'view-file-other-window "view-less" nil t)
(autoload 'view-mode "view-less" nil t)
(autoload 'with-electric-help "ehelp")
(autoload 'read-kbd-macro "edmacro")
(autoload 'pp-to-string "pp"))
(unless (fboundp 'defadvice)
(autoload 'defadvice "advice" nil nil 'macro))
(defalias 'facep 'ignore) ; ???
(defun byte-compile-dest-file (source)
"Convert an Emacs Lisp source file name to a compiled file name.
In addition, remove directory name part from SOURCE."
(concat (file-name-nondirectory (file-name-sans-versions source)) "c"))
;; Fix some Emacs byte-compiler problems.
(unless (featurep 'xemacs)
(when (and (= emacs-major-version 21)
(>= emacs-minor-version 3)
(condition-case code
(let ((byte-compile-error-on-warn t))
(byte-optimize-form (quote (pop x)) t)
nil)
(error (string-match "called for effect"
(error-message-string code)))))
(defadvice byte-optimize-form-code-walker (around silence-warn-for-pop
(form for-effect)
activate)
"Silence the warning \"...called for effect\" for the `pop' form.
It is effective only when the `pop' macro is defined by cl.el rather
than subr.el."
(let (tmp)
(if (and (eq (car-safe form) 'car)
for-effect
(setq tmp (get 'car 'side-effect-free))
(not byte-compile-delete-errors)
(not (eq tmp 'error-free))
(eq (car-safe (cadr form)) 'prog1)
(let ((var (cadr (cadr form)))
(last (nth 2 (cadr form))))
(and (symbolp var)
(null (nthcdr 3 (cadr form)))
(eq (car-safe last) 'setq)
(eq (cadr last) var)
(eq (car-safe (nth 2 last)) 'cdr)
(eq (cadr (nth 2 last)) var))))
(progn
(put 'car 'side-effect-free 'error-free)
(unwind-protect
ad-do-it
(put 'car 'side-effect-free tmp)))
ad-do-it))))
(when (byte-optimize-form '(and (> 0 1) foo) t)
(defadvice byte-optimize-form-code-walker
(around fix-bug-in-and/or-forms (form for-effect) activate)
"Optimize the rest of the and/or forms.
It has been fixed in XEmacs before releasing 21.4 and also has been
fixed in Emacs after 21.3."
(if (and for-effect (memq (car-safe form) '(and or)))
(let ((fn (car form))
(backwards (reverse (cdr form))))
(while (and backwards
(null (setcar backwards
(byte-optimize-form (car backwards) t))))
(setq backwards (cdr backwards)))
(if (and (cdr form) (null backwards))
(byte-compile-log
" all subforms of %s called for effect; deleted" form))
(when backwards
(setcdr backwards
(mapcar 'byte-optimize-form (cdr backwards))))
(setq ad-return-value (cons fn (nreverse backwards))))
ad-do-it))))
;; Work around for an incompatibility (XEmacs 21.4 vs. 21.5), see the
;; following threads:
;;
;; http://thread.gmane.org/gmane.emacs.gnus.general/56414
;; Subject: attachment problems found but not fixed
;;
;; http://thread.gmane.org/gmane.emacs.gnus.general/56459
;; Subject: Splitting mail -- XEmacs 21.4 vs 21.5
;;
;; http://thread.gmane.org/gmane.emacs.xemacs.beta/20519
;; Subject: XEmacs 21.5 and Gnus fancy splitting.
(when (and (featurep 'xemacs)
(let ((table (copy-syntax-table emacs-lisp-mode-syntax-table)))
(modify-syntax-entry ?= " " table)
(with-temp-buffer
(with-syntax-table table
(insert "foo=bar")
(goto-char (point-min))
(forward-sexp 1)
(eolp)))))
;; The original `with-syntax-table' uses `copy-syntax-table' which
;; doesn't seem to copy modified syntax entries in XEmacs 21.5.
(defmacro with-syntax-table (syntab &rest body)
"Evaluate BODY with the SYNTAB as the current syntax table."
`(let ((stab (syntax-table)))
(unwind-protect
(progn
;;(set-syntax-table (copy-syntax-table ,syntab))
(set-syntax-table ,syntab)
,@body)
(set-syntax-table stab)))))
(defun missing-or-old-elc ()
"Return the list of .el files newer than their .elc."
(remove-if-not (lambda (file)
(let ((source (srcdir/ file))
(elc (byte-compile-dest-file file)))
(or (not (file-exists-p elc))
(file-newer-than-file-p source elc))))
--to-compile))
;; Teach make-autoload how to handle define-dvc-unified-command.
(require 'autoload)
(require 'dvc-unified)
(defadvice make-autoload (before handle-define-dvc-unified-command activate)
(if (eq (car-safe (ad-get-arg 0)) 'define-dvc-unified-command)
(ad-set-arg 0 (macroexpand (ad-get-arg 0)))))
;; Teach `make-autoload' how to handle `define-derived-mode'.
(unless (make-autoload '(define-derived-mode child parent name
"docstring" body)
"file")
(defadvice make-autoload (around handle-define-derived-mode activate)
"Handle `define-derived-mode'."
(if (eq (car-safe (ad-get-arg 0)) 'define-derived-mode)
(setq ad-return-value
(list 'autoload
(list 'quote (nth 1 (ad-get-arg 0)))
(ad-get-arg 1)
(nth 4 (ad-get-arg 0))
t nil))
ad-do-it))
(put 'define-derived-mode 'doc-string-elt 3))
;; Update custom-autoloads and autoloads (merging them for GNU Emacs),
;; and compile everything that needs compiling.
(defun dvc-build-all ()
;; The default warnings don't look so bad to me!
;;(unless command-line-args-left
;; (setq byte-compile-warnings --warnings))
(setq command-line-args-left nil)
(let ((fake-c-l-a-l (list srcdir))
(changed (missing-or-old-elc)))
;; Make `--custom-autoloads-filename'.
(when changed
(load "cus-dep")
(let ((cusload-base-file --custom-autoloads-filename)
(command-line-args-left fake-c-l-a-l))
(if (fboundp 'custom-make-dependencies)
(custom-make-dependencies)
(Custom-make-dependencies))
(when (featurep 'xemacs)
(message "Compiling %s..." --custom-autoloads-filename)
(byte-compile-file --custom-autoloads-filename))))
;; Make `--autoloads-filename'.
(unless (and (file-exists-p --autoloads-filename)
(null changed))
(let ((generated-autoload-file (expand-file-name --autoloads-filename))
(command-line-args-left fake-c-l-a-l)
(make-backup-files nil)
(autoload-package-name "dvc"))
(if (featurep 'xemacs)
(zonk-file generated-autoload-file)
(with-temp-file generated-autoload-file
(insert ?\014)))
(batch-update-autoloads)))
;; Insert some preload forms into the autoload file.
(with-temp-file --autoloads-filename
(insert-file-contents --autoloads-filename)
;; Prevent "changed on disk query"
(if (not (null (find-buffer-visiting --autoloads-filename)))
(kill-buffer (find-buffer-visiting --autoloads-filename)))
(let ((blurb ";;; DVC PRELOAD\n"))
(unless (save-excursion
;; The preload forms are not guaranteed to be at beginning
;; of buffer; they might be prefixed by cus-load munging.
;; So search for them. (Previously, we used `looking-at'.)
(search-forward blurb nil t))
(insert blurb)
(dolist (form '((require 'dvc-core)
(eval-when-compile
(require 'dvc-unified)
(require 'dvc-utils))))
(pp form (current-buffer))))))
;; Merge custom load and autoloads for GNU Emacs and compile the result.
(let ((tail-blurb (concat "\n\n"
"(provide 'dvc-autoloads)\n\n"
";;; Local Variables:\n"
";;; version-control: never\n"
";;; no-update-autoloads: t\n"
";;; End:\n"
";;; dvc-autoloads.el ends here\n")))
(when (or (not (file-exists-p --autoloads-filename))
changed)
(unless (featurep 'xemacs)
(message "Merging %s into %s ..."
--custom-autoloads-filename
--autoloads-filename)
(with-temp-file --autoloads-filename
(insert-file-contents --custom-autoloads-filename)
(delete-file --custom-autoloads-filename)
(search-forward ";;; Code:\n")
(delete-region (point-min) (point))
(insert ";;; dvc-autoloads.el\n\n"
";;; Code:\n")
(goto-char (point-max))
;; ??? What do we have against this innocent var? --ttn
(when (search-backward "custom-versions-load-alist" nil t)
(forward-line -1))
(delete-region (point) (point-max))
(insert-file-contents --autoloads-filename)
(goto-char (point-max))
(when (search-backward "\n(provide " nil t)
(delete-region (1- (point)) (point-max)))
(insert tail-blurb)))
(message "Compiling %s..." --autoloads-filename)
(byte-compile-file --autoloads-filename)
(when (featurep 'xemacs)
(message (concat "Creating dummy dvc-autoloads.el..."))
(with-temp-file "dvc-autoloads.el"
(insert tail-blurb)))))
;; Compile `--to-compile' files.
(when changed
(dolist (file --to-compile)
(load (srcdir/ file) nil nil t))
;; We compute full fanout, not just root-set one-level-downstream.
;; In this way we err on the safe side.
(let (todo)
(while changed
(nconc changed (f-set-difference
(f-intersection
(mapcar 'file-name-nondirectory
(file-dependents
(srcdir/ (car changed))))
--to-compile)
todo))
(pushnew (pop changed) todo :test 'string=))
(mapc 'zonk-file (mapcar 'byte-compile-dest-file todo))
(mapc 'byte-compile-file (mapcar 'srcdir/ todo)))))
;; All done. TODO: Summarize.
(bye-bye))
;;; dvc-build.el ends here

121
dvc/lisp/dvc-cmenu.el
View File

@ -1,121 +0,0 @@
;;; dvc-cmenu.el --- code implementing a context menu with keyboard
;; Copyright (C) 2006 by all contributors
;; This file is part of DVC.
;;
;; DVC is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; DVC is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; Generally context menu is supported only mouse pressing(or clicking).
;; In Xtla, I proposed a context menu supporting operation by keyboard:
;; an user can type C-j to pop the context menu under the point up.
;; I think it is quite useful, so I decide to separate the code from
;; xtla.el.
;; In addition dvc-cmenu supports target item highlighting during popup.
;; So during popup, a user can recognize the context of menu popup now.
;;; Code:
(eval-when-compile (require 'dvc-utils))
(defvar dvc-cmenu 'dvc-cmenu
"Name of property for embedding a context menu to text.")
(defun dvc-cmenu-beginning (point)
"Search backward the position where `dvc-cmenu' property is changed."
(previous-single-property-change point dvc-cmenu))
(defun dvc-cmenu-end (point)
"Search forward the position where `dvc-cmenu' property is changed."
(next-single-property-change point dvc-cmenu))
(defun dvc-cmenu-popup-by-mouse (event prefix)
"Generic function to popup a menu.
The menu is defined in the text property under the point which is
given by mouse. EVENT is the mouse event that called the function.
PREFIX is passed to `dvc-cmenu-popup'."
(interactive "e\nP")
(mouse-set-point event)
(dvc-cmenu-popup prefix))
;; Copied from avoid.el.
(defun dvc-cmenu-mouse-avoidance-point-position (point)
"Return the position of POINT as (FRAME X . Y).
Analogous to `mouse-position'. Copied from avoid.el."
(dvc-do-in-gnu-emacs
(let* ((w (selected-window))
(edges (window-edges w))
(list
(compute-motion (max (window-start w) (point-min)) ; start pos
;; window-start can be < point-min if the
;; latter has changed since the last redisplay
'(0 . 0) ; start XY
point ; stop pos
(cons (window-width) (window-height)) ; stop XY: none
(1- (window-width)) ; width
(cons (window-hscroll w) 0) ; 0 may not be right?
(selected-window))))
;; compute-motion returns (pos HPOS VPOS prevhpos contin)
;; we want: (frame hpos . vpos)
(cons (selected-frame)
(cons (+ (car edges) (car (cdr list)))
(+ (car (cdr edges)) (car (cdr (cdr list)))))))))
(defun dvc-cmenu-popup (prefix)
"Popup a menu defined in the text property under the point.
PREFIX is passed to `popup-menu'."
(interactive "P")
(if (get-text-property (point) dvc-cmenu)
(let* ((menu (get-text-property (point) dvc-cmenu))
(p (previous-single-property-change (point) dvc-cmenu nil
(line-beginning-position)))
(n (next-single-property-change (point) dvc-cmenu nil
(line-end-position)))
(b (if (and p (get-text-property p dvc-cmenu)) p (point)))
(e (if n n (point))))
(if (and (not (featurep 'xemacs)) (interactive-p))
(let* ((pos (dvc-cmenu-mouse-avoidance-point-position e))
(object (car pos))
(x (cadr pos))
(y (cddr pos)))
(set-mouse-position object x y)))
(dvc-cmenu-popup-with-highlight 'dvc-highlight
b e
menu
prefix))
(error "No context-menu under the point")))
(defun dvc-cmenu-popup-with-highlight (face begin end menu &optional prefix)
"Put FACE on BEGIN and END in the buffer during Popup MENU.
PREFIX is passed to `popup-menu'."
(let (o)
(unwind-protect
(progn
(setq o (make-overlay begin end))
(overlay-put o 'face face)
(sit-for 0)
(popup-menu menu prefix))
(delete-overlay o))))
(provide 'dvc-cmenu)
;; Local Variables:
;; End:
;;; dvc-cmenu.el ends here

54
dvc/lisp/dvc-config.el
View File

@ -1,54 +0,0 @@
;;; dvc-config.el --- dvc configuration directory
;; Copyright (C) 2006 by all contributors
;; This file is part of DVC.
;;
;; DVC is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; DVC is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;; Code:
(require 'dvc-utils)
(require 'dvc-defs)
(defcustom dvc-config-directory "~/.dvc/"
"*Directory in which the DVC config files will be stored."
:type 'directory
:group 'dvc)
(defun dvc-config-file-full-path (file &optional create-config-dir)
"Return the full path for the config file FILE.
FILE will be stored in the `dvc-config-directory'.
If CREATE-CONFIG-DIR is non nil, ensure that the `dvc-config-directory'
does exist."
(let ((full-name (dvc-uniquify-file-name
(concat dvc-config-directory file))))
(unless (file-exists-p dvc-config-directory)
(when create-config-dir
(make-directory dvc-config-directory t)
(message "The config files of DVC will be stored in %s!"
dvc-config-directory)
(sit-for 5)))
;; return full-name
full-name))
(provide 'dvc-config)
;; Local Variables:
;; End:
;;; dvc-config.el ends here

1208
dvc/lisp/dvc-core.el
View File

File diff suppressed because it is too large Load Diff

630
dvc/lisp/dvc-defs.el
View File

@ -1,630 +0,0 @@
;;; dvc-defs.el --- Common definitions for DVC
;; Copyright (C) 2005-2009 by all contributors
;; Author: Stefan Reichoer, <stefan@xsteve.at>
;; Contributors: Matthieu Moy, <Matthieu.Moy@imag.fr>
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; This file provides the low-level functions used by the DVC interfaces
;; to distributed revison control systems.
;;; Commands:
;;
;; Below is a complete command list:
;;
;;
;;; Customizable Options:
;;
;; Below is a customizable option list:
;;
;; `dvc-select-priority'
;; A list that defines the priority of the available dvc's.
;; default = (quote nil)
;; `dvc-prompt-active-dvc'
;; If non-nil, prompt for the active dvc when more than one is
;; default = nil
;; `dvc-highlight'
;; *Use highlighting for DVC buffers.
;; default = t
;; `dvc-confirm-add'
;; *If non-nil, prompt for confirmation in dvc-add-files.
;; default = t
;; `dvc-confirm-ignore'
;; *If non-nil, prompt for confirmation in dvc-ignore-files.
;; default = t
;; `dvc-confirm-update'
;; *If non-nil, prompt for confirmation in dvc-update.
;; default = t
;; `dvc-log-last-n'
;; *If non-nil, limit log listings to last n entries.
;; default = nil
;; `dvc-status-display-known'
;; If non-nil, display files with 'known' status in dvc-status buffer.
;; default = nil
;; `dvc-status-display-ignored'
;; If non-nil, display files with 'ignored' status in dvc-status buffer.
;; default = nil
;; `dvc-fileinfo-printer-interface'
;; How to display info about the working tree in DVC diff and status buffers.
;; default = (quote full)
;; `dvc-completing-read-function'
;; Function to call when prompting user to choose between a list of options.
;; default = (quote auto)
;; `dvc-bookmarks-face-tree'
;; DVC face used in bookmarks to highlight main tree entry's
;; default = (quote dvc-keyword)
;; `dvc-bookmarks-face-subtree'
;; DVC face used in bookmarks to highlight subtree entry's
;; default = (quote dvc-comment)
;; `dvc-bookmarks-face-partner'
;; DVC face used in bookmarks to highlight partner entry's
;; default = (quote dvc-revision-name)
;; `dvc-button-face'
;; DVC face used to highlight buttons.
;; default = (quote bold)
;; `dvc-mouse-face'
;; DVC face used to highlight buttons.
;; default = (quote highlight)
;; `dvc-switch-to-buffer-mode'
;; *Mode for switching to DVC buffers.
;; default = (quote pop-to-buffer)
;; `dvc-do-not-prompt-for-save'
;; *Whether or not DVC will prompt before saving.
;; default = nil
;; `dvc-automatically-revert-buffers'
;; *Whether or not DVC will automatically revert buffers.
;; default = t
;; `dvc-log-commands'
;; *Non nil means log all DVC commands in the buffer *dvc-log*.
;; default = t
;; `dvc-log-buffer'
;; *Name of the buffer in which DVC logs main events.
;; default = " *dvc-log*"
;; `dvc-read-project-tree-mode'
;; *Mode for prompting for project tree directories. Possible values are:
;; default = (quote sometimes)
;; `dvc-read-directory-mode'
;; *How prompting project directories should be done.
;; default = (quote sometimes)
;; `dvc-switch-to-buffer-first'
;; *Switch to newly created buffer on creation of buffers?
;; default = t
;; `dvc-buffer-quit-mode'
;; *How *dvc-...* buffer should be killed.
;; default = (quote kill)
;; `dvc-log-insert-last'
;; *If non-nil, insert changelog entries at the end of the log file.
;; default = t
;; `dvc-diff-executable'
;; *The name of the diff executable.
;; default = (dvc-first-set dvc-site-diff-executable "diff")
;; `dvc-patch-executable'
;; *The name of the patch executable.
;; default = (dvc-first-set dvc-site-patch-executable "patch")
;; `dvc-tips-enabled'
;; *Set this to nil to disable tips.
;; default = t
;;; History:
;; This file holds general useful functions, previously only used for DVC.
;;; Code:
(eval-and-compile
(require 'font-lock))
(require 'dvc-site)
(defmacro dvc-first-set (arg1 arg2)
"Returns ARG1 if set, non-nil, and not the empty string.
Otherwise, return ARG2. ARG1 must be a variable."
(declare (indent 1) (debug (symbolp form)))
`(or (and ,(boundp arg1) (when (not (string= ,arg1 ""))
,arg1))
,arg2))
(unless (fboundp 'executable-find)
(autoload 'executable-find "executable"))
;;;###autoload
(defvar dvc-registered-backends nil "The list of registered dvc backends.")
(defgroup dvc nil
"Decentralized Version Control interface for Emacs."
:group 'tools
:prefix "dvc-")
;; Common settings for all dvc's
(defcustom dvc-select-priority '()
"A list that defines the priority of the available dvc's.
If a project uses more than one dvc, use this list to select the primary dvc.
Possible values include: 'tla, 'baz, 'xhg, 'xgit, 'bzr, 'xmtn"
:type '(repeat (choice (const :tag "tla" tla)
(const :tag "baz" baz)
(const :tag "xhg" xhg)
(const :tag "xgit" xgit)
(const :tag "bzr" bzr)
(const :tag "xmtn" xmtn)
(symbol :tag "Other")))
:group 'dvc)
(defcustom dvc-prompt-active-dvc nil
"If non-nil, prompt for the active dvc when more than one is
found for the current directory. The back-ends considered are
given in dvc-select-priority (it must be non-nil - it should be
restricted it to only those back-ends actually used). Otherwise,
use the first one found; dvc-select-priority sets the search
order."
:type 'boolean
:group 'dvc)
(defcustom dvc-highlight t
"*Use highlighting for DVC buffers."
:type 'boolean
:group 'dvc)
(defcustom dvc-confirm-add t
"*If non-nil, prompt for confirmation in dvc-add-files."
:type 'boolean
:group 'dvc)
(defcustom dvc-confirm-ignore t
"*If non-nil, prompt for confirmation in dvc-ignore-files."
:type 'boolean
:group 'dvc)
(defcustom dvc-confirm-update t
"*If non-nil, prompt for confirmation in dvc-update."
:type 'boolean
:group 'dvc)
(defcustom dvc-log-last-n nil
"*If non-nil, limit log listings to last n entries."
:type '(choice boolean integer)
:group 'dvc)
(defcustom dvc-status-display-known nil
"If non-nil, display files with 'known' status in dvc-status buffer."
:type 'boolean
:group 'dvc)
(defcustom dvc-status-display-ignored nil
"If non-nil, display files with 'ignored' status in dvc-status buffer."
:type 'boolean
:group 'dvc)
(defcustom dvc-fileinfo-printer-interface 'full
"How to display info about the working tree in DVC diff and status buffers.
The default is 'full, which uses explanatory text when listing
the status of the tree.
Another option is 'terse, which uses a single letter to indicate
the status of each file.
Alternatively, you may set this to the name of a custom function
which, given a fileinfo argument, produces the status list in the
current buffer."
:group 'dvc
:type '(choice (const :tag "Full" full)
(const :tag "Terse" terse)
(symbol :tag "Other")))
(defcustom dvc-completing-read-function 'auto
"Function to call when prompting user to choose between a list of options.
This should take the same arguments as `completing-read'.
Possible values are `completing-read' and `ido-completing-read'.
Note that you must set `ido-mode' if using`ido-completing-read'.
When set to 'auto, use `ido-completing-read' when ido-mode is enabled,
otherwise `completing-read'."
:type 'function
:group 'dvc)
;; --------------------------------------------------------------------------------
;; Keybindings
;; --------------------------------------------------------------------------------
;; --------------------------------------------------------------------------------
;; Faces
;; --------------------------------------------------------------------------------
(defgroup dvc-faces nil
"This group contains faces defined for DVC."
:group 'dvc)
(defface dvc-revision-name
'((((type tty) (class color)) (:foreground "lightblue" :weight light))
(((class color) (background light)) (:foreground "blue4"))
(((class color) (background dark)) (:foreground "lightskyblue1"))
(t (:weight bold)))
"Face to highlight DVC revision names."
:group 'dvc-faces)
(defface dvc-repository-name
'((t (:inherit dvc-revision-name)))
"Face to highlight DVC repository name."
:group 'dvc-faces)
(defface dvc-local-directory
'((t (:inherit dvc-repository-name)))
"Face to highlight DVC local directory."
:group 'dvc-faces)
(defface dvc-buffer
'((t (:inherit dvc-repository-name)))
"Face to highlight buffer names printed in DVC's buffer."
:group 'dvc-faces)
(defface dvc-marked
'((((type tty) (class color)) (:foreground "magenta" :weight light))
(((class color) (background light)) (:foreground "magenta"))
(((class color) (background dark)) (:foreground "yellow"))
(t (:weight bold)))
"Face to highlight a marked entry in DVC buffers"
:group 'dvc-faces)
(defface dvc-excluded
'((((type tty) (class color)) (:foreground "orchid" :weight light))
(((class color) (background light)) (:foreground "orchid"))
(((class color) (background dark)) (:foreground "gold")))
"Face to highlight an excluded entry in DVC buffers"
:group 'dvc-faces)
(defface dvc-bookmark-name
'((t (:inherit dvc-repository-name)))
"Face to highlight DVC revision names."
:group 'dvc-faces)
(defface dvc-id
'((t (:inherit dvc-keyword)))
"Face to highlight an arch id."
:group 'dvc-faces)
(defface dvc-separator
'((((type tty)) (:underline t :weight bold))
;;(((background light)) (:strike-through t :weight bold))
;;(((background dark)) (:strike-through t :weight bold)))
(((background light)) (:underline t :weight bold))
(((background dark)) (:underline t :weight bold)))
"Face to highlight separators."
:group 'dvc-faces)
(defface dvc-keyword
'((t (:inherit font-lock-keyword-face)))
"Face to highlight keywords."
:group 'dvc-faces)
(defface dvc-comment
'((t (:inherit font-lock-comment-face)))
"Face to highlight comments."
:group 'dvc-faces)
(defface dvc-ignored
'((t (:inherit font-lock-comment-face)))
"Face to highlight precious entries."
:group 'dvc-faces)
(defface dvc-unrecognized
'((t (:inherit font-lock-warning-face)))
"Face to highlight unrecognized entries."
:group 'dvc-faces)
(defface dvc-duplicate
'((t (:inherit font-lock-warning-face)))
"Face to highlight files with duplicate IDs."
:group 'dvc-faces)
(defface dvc-source
'((t (:inherit font-lock-string-face)))
"Face to highlight source code entries."
:group 'dvc-faces)
(defface dvc-nested-tree
'((t (:inherit font-lock-type-face)))
"Face to highlight nested trees."
:group 'dvc-faces)
(defface dvc-to-add
'((t (:inherit font-lock-comment-face)))
"Face to highlight a file that should probably be added to the archive."
:group 'dvc-faces)
(defface dvc-broken-link
'((t (:inherit font-lock-warning-face)))
"Face to highlight a broken link."
:group 'dvc-faces)
(defface dvc-unmerged
'((t (:inherit font-lock-keyword-face)))
"Face to highlight unmerged patches."
:group 'dvc-faces)
(defface dvc-header
'((t (:inherit font-lock-function-name-face)))
"Face to highlight header in log mode for example."
:group 'dvc-faces)
(defface dvc-conflict
'((t (:inherit font-lock-warning-face)))
"Face to highlight conflicts."
:group 'dvc-faces)
(defface dvc-unknown
'((t (:inherit font-lock-variable-name-face)))
"Face to highlight unknown status modification."
:group 'dvc-faces)
(defface dvc-modified
'((t (:inherit font-lock-function-name-face)))
"Face to highlight modified files."
:group 'dvc-faces)
(defface dvc-copy
'((t (:inherit font-lock-function-name-face)))
"Face to highlight copied files/directories."
:group 'dvc-faces)
(defface dvc-move
'((t (:inherit font-lock-constant-face)))
;; Same font as dvc-added, different from dvc-modified, so it stands out in a typical list.
"Face to highlight moved files/directory."
:group 'dvc-faces)
(defface dvc-deleted
'((t (:inherit font-lock-warning-face)))
"Face to highlight deleted files."
:group 'dvc-faces)
(defface dvc-added
'((t (:inherit font-lock-constant-face)))
"Face to highlight added files."
:group 'dvc-faces)
(defface dvc-meta-info
'((t (:inherit font-lock-comment-face)))
"Face to highlight files with meta-info changes."
:group 'dvc-faces)
(defface dvc-messages
'((t (:inherit font-lock-function-name-face)))
"Face to highlight messages in DVC buffers."
:group 'dvc-faces)
(defface dvc-highlight
'((((class color) (background dark)) (:background "darkblue"))
(((class color) (background light)) (:background "gold")))
"Face to use as an alternative to `highlight' face.
If there could be more than two highlighted things, the user will confuse.
In such case use this face."
:group 'dvc-faces)
(defface dvc-mark
'((((class color) (background dark))
(:foreground "green" :bold t))
(((class color) (background light))
(:foreground "green3" :bold t))
(t (:bold t)))
"DVC face used to highlight marked file indicator."
:group 'dvc-faces)
(defcustom dvc-bookmarks-face-tree 'dvc-keyword
"DVC face used in bookmarks to highlight main tree entry's"
:type 'face
:group 'dvc-faces)
(defcustom dvc-bookmarks-face-subtree 'dvc-comment
"DVC face used in bookmarks to highlight subtree entry's"
:type 'face
:group 'dvc-faces)
(defcustom dvc-bookmarks-face-partner 'dvc-revision-name
"DVC face used in bookmarks to highlight partner entry's"
:type 'face
:group 'dvc-faces)
(defcustom dvc-button-face 'bold
"DVC face used to highlight buttons.
An button is a piece of text that you can activate by pressing
`RET' or `mouse-2' above it."
:type 'face
:group 'dvc-faces)
(defcustom dvc-mouse-face 'highlight
"DVC face used to highlight buttons.
Buttons will be displayed in this face when the cursor is above
them."
:type 'face
:group 'dvc-faces)
(defcustom dvc-switch-to-buffer-mode 'pop-to-buffer
"*Mode for switching to DVC buffers.
Recommended settings are: 'pop-to-buffer, and 'show-in-other-window
and 'single-window"
:type '(choice (const pop-to-buffer)
(const single-window)
(const dedicated-frame)
(const show-in-other-window))
:group 'dvc)
(defgroup dvc-file-actions nil
"This group contains items manipulating finding, saving and
reverting files."
:group 'dvc)
(defcustom dvc-do-not-prompt-for-save nil
"*Whether or not DVC will prompt before saving.
If non nil, DVC will not prompt you before saving buffers of the
working local tree."
:type 'boolean
:group 'dvc-file-actions)
(defcustom dvc-automatically-revert-buffers t
"*Whether or not DVC will automatically revert buffers.
If non nil, DVC will automatically revert unmodified buffers after an
arch operation modifying the file."
:type 'boolean
:group 'dvc-file-actions)
(defgroup dvc-internal nil
"This group contains items used mainly for debugging."
:group 'dvc)
(defcustom dvc-log-commands t
"*Non nil means log all DVC commands in the buffer *dvc-log*."
:type 'boolean
:group 'dvc-internal)
(defcustom dvc-log-buffer " *dvc-log*"
"*Name of the buffer in which DVC logs main events."
:type 'string
:group 'dvc-internal)
(defcustom dvc-read-project-tree-mode 'sometimes
"*Mode for prompting for project tree directories. Possible values are:
- always: always prompt.
- unless-specified: If a valid tree directory is given as an
argument, use it; otherwise prompt. Some commands modify this
to use the current project tree without prompt; then a user arg
forces a prompt.
- sometimes: If a command is run inside a project tree, the tree
root is used. Otherwise, prompt.
- never: If a command is run inside a project tree, use the tree
root. Otherwise, raise an error."
:type '(choice (const always)
(const unless-specified)
(const sometimes)
(const never))
:group 'dvc)
(defcustom dvc-read-directory-mode 'sometimes
"*How prompting project directories should be done.
Works similarly to `dvc-read-project-tree-mode', but this one is used
for commands like `tla-inventory' for which a subdirectory of a
project tree is accepted."
:type '(choice (const always)
(const sometimes)
(const never))
:group 'dvc)
(defcustom dvc-switch-to-buffer-first t
"*Switch to newly created buffer on creation of buffers?
If non-nil, DVC commands implementing this feature will switch to the
newly created buffer when the command is called. Further (potentially
asynchronous) processes are run without modifying your
window-configuration. Otherwise, DVC will switch to the new buffer on
command completion."
:type 'boolean
:group 'dvc)
(defcustom dvc-buffer-quit-mode 'kill
"*How *dvc-...* buffer should be killed.
If the value is 'kill, buffers are actually killed. Otherwise, just
bury them."
:type '(choice (const kill)
(const bury))
:group 'dvc)
(defcustom dvc-log-insert-last t
"*If non-nil, insert changelog entries at the end of the log file."
:type 'boolean
:group 'dvc)
(defvar dvc-test-mode nil
"Set non-nil in unit tests; bypasses confirmation prompts.")
(defvar dvc-buffer-marked-file-list nil
"List of marked and not hidden files in the current buffer.
This variable is buffer-local.")
(make-variable-buffer-local 'dvc-buffer-marked-file-list)
(defvar dvc-buffer-all-marked-file-list nil
"List of marked files, including hidden ones, in the current buffer.
`dvc-buffer-marked-file-list' is a subset of this one.
This variable is buffer-local.")
(make-variable-buffer-local 'dvc-buffer-all-marked-file-list)
;; FIXME: dvc-buffer-all-marked-file-list is only used by tla, and it
;; never actually differs from dvc-buffer-marked-file-list
(defvar dvc-patch-email-message-body-template
(concat
"Please change the Subject header to a concise description of your patch.\n"
"Please describe your patch between the LOG-START and LOG-END markers:\n"
"<<LOG-START>>\n"
"\n"
"<<LOG-END>>\n"
"\n")
"A template that is used for functions to send patches via email.
It should contain a <<LOG-START>> and a <<LOG-END>> marker to allow
automatic log message extraction.")
;;
;; Executable location
;;
(defcustom dvc-diff-executable (dvc-first-set
dvc-site-diff-executable
"diff")
"*The name of the diff executable."
:type 'string
:group 'dvc)
(defcustom dvc-patch-executable (dvc-first-set
dvc-site-patch-executable
"patch")
"*The name of the patch executable."
:type 'string
:group 'dvc)
;; end executable
;;
;; DVC tips
;;
;;
;; Tips
;;
(defgroup dvc-tips nil
"\"Tip of the day\" feature for DVC"
:group 'dvc)
(defcustom dvc-tips-enabled t
"*Set this to nil to disable tips."
:type 'boolean
:group 'dvc-tips)
;; end tips mode
(provide 'dvc-defs)
;;; dvc-defs.el ends here

898
dvc/lisp/dvc-diff.el
View File

@ -1,898 +0,0 @@
;;; dvc-diff.el --- A generic diff mode for DVC
;; Copyright (C) 2005-2010 by all contributors
;; Author: Matthieu Moy <Matthieu.Moy@imag.fr>
;; Contributions from:
;; Stefan Reichoer, <stefan@xsteve.at>
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;
;;; Code:
(require 'diff-mode)
(require 'dvc-ui)
(require 'dvc-unified)
(require 'dvc-defs)
(require 'dvc-core)
(require 'dvc-fileinfo)
(eval-when-compile
(require 'cl))
(defvar dvc-diff-base nil
"BASE revision-id for the changes currently displayed.")
(make-variable-buffer-local 'dvc-diff-base)
(defvar dvc-diff-modified nil
"MODIFIED revision-id for the changes currently displayed.")
(make-variable-buffer-local 'dvc-diff-modified)
(defun dvc-dvc-search-file-in-diff (file)
"Default for \"dvc-search-file-in-diff\". Place point on diff hunk for FILE."
(re-search-forward (concat "^\\+\\+\\+ \\(b\\|mod\\|new-[^/\n]+\\)/" file "\\(.+[0-9][0-9][0-9][0-9]\\)?$")))
(defun dvc-prepare-changes-buffer (base modified type path dvc)
"Create and return a buffer to run command showing diffs.
Sets `dvc-diff-base' and `dvc-diff-modified' to BASE and
MODIFIED.
TYPE must be found in `dvc-buffer-type-alist'.
PATH must match mode in `dvc-buffer-type-alist' for TYPE.
DVC is the backend in effect.
TYPE and PATH are passed to `dvc-get-buffer-create'."
(with-current-buffer
(dvc-get-buffer-create dvc type path)
(let ((inhibit-read-only t)) (erase-buffer))
(let ((dvc-temp-current-active-dvc dvc))
(funcall (dvc-function dvc "diff-mode")))
(setq dvc-diff-base base)
(setq dvc-diff-modified modified)
(current-buffer)))
(defun dvc-diff-chose-face (status modif)
"Return a face appropriate for STATUS or MODIF."
(cond
((string= "A" status) 'dvc-added)
((string= "?" status) 'dvc-unknown)
((string= "M" modif) 'dvc-modified)
((string= "M" status) 'dvc-modified)
((string= "-" modif) 'dvc-modified)
((string= "P" status) 'dvc-modified)
((string= "C" status) 'dvc-conflict)
((string= "D" status) 'dvc-conflict)
((string= "R" status) 'dvc-move)
((string= " " status) 'default)
(t
(dvc-trace "unknown status=%S or modif=%S" status modif)
'default)))
;; ----------------------------------------------------------------------------
;; dvc-diff-mode
;; ----------------------------------------------------------------------------
(defun dvc-diff-printer (elem)
"Ewoc pretty-printer for `dvc-fileinfo-legacy'.
Pretty-print ELEM."
(cond
((eq (car elem) 'file)
(let* ((empty-mark " ")
(mark (when (member (cadr elem) dvc-buffer-marked-file-list)
dvc-mark))
(file (nth 1 elem))
(status (nth 2 elem))
(modif (nth 3 elem))
(dir (nth 4 elem))
(origname (nth 5 elem))
(line (concat status modif " "
(when origname (concat origname dir "\t => "))
file dir))
(face (if mark
'dvc-marked
(dvc-diff-chose-face status modif))))
(if mark
(insert mark)
(insert empty-mark))
(insert (dvc-face-add line
face
'dvc-diff-file-map
dvc-diff-file-menu))))
((eq (car elem) 'subtree)
(insert (dvc-face-add
(concat " T" (cond ((not (cadddr elem)) "?")
((eq (cadddr elem) 'changes) "M")
((eq (cadddr elem) 'updated) "U")
((eq (cadddr elem) 'no-changes) "-"))
" " (car (cddr elem)))
'dvc-nested-tree)))
((eq (car elem) 'message)
(insert (cadr elem)))
((eq (car elem) 'searching-subtrees)
(insert (dvc-face-add " T Searching for subtrees ..."
'dvc-nested-tree))))
)
(defvar dvc-diff-mode-map
(let ((map (copy-keymap diff-mode-shared-map)))
(define-key map dvc-keyvec-help 'describe-mode)
(define-key map "\C-m" 'dvc-diff-jump-to-change)
(define-key map [return] 'dvc-diff-jump-to-change)
(define-key map [(control x) (control j)] 'dvc-dired-jump)
(define-key map "\M-=" 'dvc-diff-scroll-up-or-diff)
(define-key map [(meta return)] 'dvc-diff-scroll-down-or-diff)
(define-key map "\M-\C-m" 'dvc-diff-scroll-down-or-diff)
(define-key map [?=] 'dvc-diff-diff)
(define-key map dvc-keyvec-add 'dvc-fileinfo-add-files)
(define-key map "\M-d" 'dvc-diff-dtrt)
(define-key map "E" 'dvc-fileinfo-toggle-exclude)
(define-key map "\M-e" 'dvc-edit-exclude)
(define-key map [?h] 'dvc-buffer-pop-to-partner-buffer)
(define-key map dvc-keyvec-logs 'dvc-diff-log-tree)
(define-key map "l" 'dvc-diff-log-single)
(define-key map dvc-keyvec-ediff 'dvc-diff-ediff)
(define-key map dvc-keyvec-refresh 'dvc-generic-refresh)
(define-key map "R" 'dvc-fileinfo-rename)
(define-key map dvc-keyvec-commit 'dvc-log-edit)
(define-key map "t" 'dvc-diff-add-log-entry)
(define-key map dvc-keyvec-next 'dvc-diff-next)
(define-key map dvc-keyvec-previous 'dvc-diff-prev)
(define-key map dvc-keyvec-revert 'dvc-fileinfo-revert-files)
(define-key map dvc-keyvec-quit 'dvc-buffer-quit)
(define-key map dvc-keyvec-remove 'dvc-fileinfo-remove-files)
(define-key map [?d] 'dvc-fileinfo-remove-files) ; as in dired
(define-key map dvc-keyvec-mark 'dvc-diff-mark-file)
(define-key map dvc-keyvec-mark-all 'dvc-fileinfo-mark-all)
(define-key map dvc-keyvec-unmark 'dvc-diff-unmark-file)
(define-key map [backspace] 'dvc-diff-unmark-file-up)
(define-key map dvc-keyvec-unmark-all 'dvc-fileinfo-unmark-all)
(define-key map [?v] 'dvc-diff-view-source)
(define-key map dvc-keyvec-parent 'dvc-diff-master-buffer)
(define-key map [?j] 'dvc-diff-diff-or-list)
(define-key map (dvc-prefix-kill-ring ?d) 'dvc-diff-save-current-defun-as-kill)
;; Buffers group
(define-key map (dvc-prefix-buffer ?p) 'dvc-show-process-buffer)
(define-key map (dvc-prefix-buffer ?e) 'dvc-show-last-error-buffer)
(define-key map (dvc-prefix-buffer ?L) 'dvc-open-internal-log-buffer)
(define-key map (dvc-prefix-buffer dvc-key-show-bookmark) 'dvc-bookmarks)
;; Ignore file handling
(define-key map (dvc-prefix-tagging-method ?i) 'dvc-fileinfo-ignore-files)
(define-key map (dvc-prefix-tagging-method ?I) 'dvc-ignore-file-extensions)
(define-key map (dvc-prefix-tagging-method ?e) 'dvc-edit-ignore-files)
(define-key map [?i] 'dvc-fileinfo-ignore-files)
(define-key map [?I] 'dvc-ignore-file-extensions-in-dir)
(define-key map "\M-I" 'dvc-ignore-file-extensions)
;; working copy bindings
(define-key map (vector dvc-key-working-copy) nil) ;; unbind ?W, before it can be used
(define-key map (dvc-prefix-working-copy ?s) 'dvc-save-diff)
;; the merge group
(define-key map (dvc-prefix-merge ?u) 'dvc-update)
(define-key map (dvc-prefix-merge ?f) 'dvc-pull) ;; hint: fetch, p is reserved for push
(define-key map (dvc-prefix-merge ?m) '(lambda () (interactive) (dvc-missing nil default-directory)))
(define-key map (dvc-prefix-merge ?M) 'dvc-merge)
map)
"Keymap used in `dvc-diff-mode'.")
;;
;; Menu
;;
(defconst dvc-diff-file-menu-list
'("File Changes"
["Jump to File" dvc-diff-jump-to-change t]
["Jump to Diffs" dvc-diff-diff-or-list t]
["View Diff in Separate Buffer" dvc-diff-diff t]
["View Diff with Ediff" dvc-diff-ediff t]
["Log (full tree)" dvc-diff-log-tree t]
["Log (single file)" dvc-diff-log-single t]
"--"
["Delete File" dvc-fileinfo-remove-files t]
["Revert File" dvc-fileinfo-revert-files t]
["Add File" dvc-fileinfo-add-files t]
)
"Used both in the global and the context menu of `dvc-diff-mode'.")
(easy-menu-define dvc-diff-file-menu nil
"Menu used on a `dvc-diff' file"
dvc-diff-file-menu-list)
(defconst dvc-diff-mode-menu-list
`(["Refresh Buffer" dvc-generic-refresh t]
["Edit log before commit" dvc-log-edit t]
["Add log entry" dvc-add-log-entry t]
("Merge"
["Update" dvc-update t]
["Pull" dvc-pull t]
["Show missing" (lambda () (interactive) (dvc-missing nil default-directory)) t]
["Merge" dvc-merge t]
)
("Mark"
["Mark File" dvc-diff-mark-file t]
["Mark all" dvc-fileinfo-mark-all t]
["Unmark File" dvc-diff-unmark-file t]
["Unmark all" dvc-fileinfo-unmark-all t]
)
("Ignore"
["Ignore Files" dvc-fileinfo-ignore-files t]
["Ignore File Extensions" dvc-ignore-file-extensions t]
["Edit Ignore File" dvc-edit-ignore-files t]
)
("Exclude"
["Exclude File" dvc-fileinfo-toggle-exclude t]
["Edit Exclude File" dvc-edit-exclude t]
)
,dvc-diff-file-menu-list
))
(easy-menu-define dvc-diff-mode-menu dvc-diff-mode-map
"`dvc-changes' menu"
`("DVC-Diff"
,@dvc-diff-mode-menu-list))
(defvar dvc-diff-file-map
(let ((map (copy-keymap dvc-cmenu-map-template)))
(define-key map dvc-mouse-2 'dvc-diff-jump-to-change-by-mouse)
map)
"Keymap used on files in `dvc-diff-mode' buffers.")
;; dvc-prepare-changes-buffer will call "<back-end>-diff-mode", if
;; defined, instead of this one. If so, it should be derived from
;; dvc-diff-mode (via `define-derived-mode'), and rely on it for as
;; many features as possible (one can, for example, extend the menu
;; and keymap). See `xgit-diff-mode' in xgit.el for a good example.
;;
;; Remember to add the new mode to
;; `uniquify-list-buffers-directory-modes' using
;; `dvc-add-uniquify-directory-mode'.
(define-derived-mode dvc-diff-mode fundamental-mode "dvc-diff"
"Major mode to display changesets. Derives from `diff-mode'.
Use '\\<dvc-diff-mode-map>\\[dvc-diff-mark-file]' to mark files, and '\\[dvc-diff-unmark-file]' to unmark.
If you commit from this buffer (with '\\<dvc-diff-mode-map>\\[dvc-log-edit]'), then,
the list of selected files (in this buffer) will be commited (with the text you
entered as a comment) at the time you actually commit with \\<dvc-log-edit-mode-map>\\[dvc-log-edit-done].
Commands:
\\{dvc-diff-mode-map}
"
(let ((diff-mode-shared-map (copy-keymap dvc-diff-mode-map))
major-mode mode-name)
(diff-mode))
(setq dvc-buffer-current-active-dvc (dvc-current-active-dvc))
(setq font-lock-defaults (list 'diff-font-lock-keywords t nil nil))
(set (make-local-variable 'dvc-get-file-info-at-point-function)
'dvc-diff-get-file-at-point)
(setq dvc-buffer-refresh-function 'dvc-diff-generic-refresh)
(setq dvc-fileinfo-ewoc (ewoc-create 'dvc-fileinfo-printer))
(setq dvc-buffer-marked-file-list nil)
(dvc-install-buffer-menu)
(setq buffer-read-only t)
(set-buffer-modified-p nil))
(dvc-add-uniquify-directory-mode 'dvc-diff-mode)
(defun dvc-diff-generic-refresh ()
"Refresh the diff buffer."
(interactive)
(if (eq (dvc-revision-get-type dvc-diff-modified) 'local-tree)
;; Don't specify dvc-diff-base here; it may have changed due to an update
(dvc-diff)
(error "Don't know how to refresh buffer")))
(defun dvc-diff-in-ewoc-p ()
"Return non-nil if in ewoc section of diff buffer."
(let ((elem (ewoc-locate dvc-fileinfo-ewoc)))
(when elem
(>= (ewoc-location elem) (line-beginning-position)))))
(defun dvc-diff-jump-to-change (&optional other-file)
"Jump to the corresponding file and location of the change at point.
OTHER-FILE (default prefix) if non-nil means visit the original
file; otherwise visit the modified file."
(interactive "P")
(let ((dvc-temp-current-active-dvc (dvc-current-active-dvc)))
(if (dvc-diff-in-ewoc-p)
(let ((fileinfo (dvc-fileinfo-current-fileinfo)))
(etypecase fileinfo
(dvc-fileinfo-file ; also matches dvc-fileinfo-dir
;; FIXME: support OTHER-FILE here
(find-file (dvc-fileinfo-current-file)))
(dvc-fileinfo-legacy
(let ((data (dvc-fileinfo-legacy-data fileinfo)))
(cond
((eq (car data) 'file)
(find-file (cadr data)))
((eq (car data) 'subtree)
(dvc-switch-to-buffer (cadr data)))
(t (error "Not on a recognized location")))))))
;; not in the ewoc part
(diff-goto-source other-file))))
(defun dvc-diff-scroll-or-diff (up-or-down)
"If file-diff buffer is visible, call UP-OR-DOWN. Otherwise, show it."
(let ((file (dvc-get-file-info-at-point)))
(unless file
(error "No file at point."))
(let ((buffer (dvc-get-buffer dvc-buffer-current-active-dvc 'file-diff file)))
(unless (dvc-scroll-maybe buffer up-or-down)
(dvc-file-diff file dvc-diff-base dvc-diff-modified t)))))
(defun dvc-diff-scroll-up-or-diff ()
(interactive)
(dvc-diff-scroll-or-diff 'scroll-up))
(defun dvc-diff-scroll-down-or-diff ()
(interactive)
(dvc-diff-scroll-or-diff 'scroll-down))
(defun dvc-diff-diff-or-list ()
"Jump between list entry and corresponding diff hunk.
When in the list, jump to the corresponding
diff. When on a diff, jump to the corresponding entry in the list."
(interactive)
(if (dvc-diff-in-ewoc-p)
(let ((fileinfo (dvc-fileinfo-current-fileinfo)))
(etypecase fileinfo
(dvc-fileinfo-file
(dvc-call "dvc-search-file-in-diff" (dvc-fileinfo-current-file))
(diff-hunk-next))
(dvc-fileinfo-legacy
(let ((data (dvc-fileinfo-legacy-data fileinfo)))
(cond
((eq (car data) 'file)
(dvc-call "dvc-search-file-in-diff" (cadr data))
(diff-hunk-next))
((eq (car data) 'subtree)
(dvc-switch-to-buffer (cadr data)))
(t (error "Not on a recognized location")))))))
;; not in list
(goto-char (ewoc-location (dvc-fileinfo-find-file (dvc-diff-get-file-at-point))))))
(defun dvc-diff-mark-file ()
"Mark the file under point, and move to next file.
If on a message, mark the group to the next message."
(interactive)
(if (not (dvc-diff-in-ewoc-p))
(error "not in file list"))
(let ((fileinfo (dvc-fileinfo-current-fileinfo)))
(etypecase fileinfo
(dvc-fileinfo-file
(dvc-fileinfo-mark-file))
(dvc-fileinfo-message
(dvc-diff-mark-group))
(dvc-fileinfo-legacy
(let ((current (ewoc-locate dvc-fileinfo-ewoc))
(file (dvc-get-file-info-at-point)))
(add-to-list 'dvc-buffer-marked-file-list file)
(ewoc-invalidate dvc-fileinfo-ewoc current)
(dvc-fileinfo-next))))))
(defun dvc-diff-mark-group (&optional unmark)
"Mark (or UNMARK) a group of files.
Must be called with the cursor on a 'message ewoc entry. Marks all
files until the end of the ewoc, or the next ewoc entry which is not
a 'file."
(if (not (dvc-diff-in-ewoc-p))
(error "not in file list"))
(if (not (dvc-fileinfo-message-p (dvc-fileinfo-current-fileinfo)))
(error "not on a message"))
(dvc-fileinfo-next)
(if (not (dvc-fileinfo-file-or-legacy-file-p (dvc-fileinfo-current-fileinfo)))
(error "next in list is not on a file"))
(let ((ewoc-elem (ewoc-locate dvc-fileinfo-ewoc)))
(while (and ewoc-elem
(ewoc-data ewoc-elem)
(dvc-fileinfo-file-or-legacy-file-p (ewoc-data ewoc-elem)))
(let* ((fileinfo (ewoc-data ewoc-elem))
(file (dvc-fileinfo-path fileinfo)))
(dvc-trace "mark/unmark %S" file)
(if (dvc-fileinfo-file-p fileinfo)
(if unmark
(dvc-fileinfo-unmark-file)
(dvc-fileinfo-mark-file))
;; legacy
(if unmark
(setq dvc-buffer-marked-file-list
(delete file dvc-buffer-marked-file-list))
(add-to-list 'dvc-buffer-marked-file-list file))))
(setq ewoc-elem (ewoc-next dvc-fileinfo-ewoc ewoc-elem)))
(ewoc-refresh dvc-fileinfo-ewoc)
(if ewoc-elem
(goto-char (ewoc-location ewoc-elem))
(goto-char (point-max)))))
(defun dvc-diff-unmark-file (&optional up)
"Unmark the file under point.
If on a message, unmark the group to the next message. If
optional UP, move to previous file first; otherwise move to next
file after."
(interactive)
(if (not (dvc-diff-in-ewoc-p))
(error "not in file list"))
(if up (dvc-fileinfo-prev t))
(let ((fileinfo (dvc-fileinfo-current-fileinfo)))
(etypecase fileinfo
(dvc-fileinfo-file
(dvc-fileinfo-mark-file-1 nil))
(dvc-fileinfo-message
(dvc-diff-mark-group t))
(dvc-fileinfo-legacy
(let ((current (ewoc-locate dvc-fileinfo-ewoc))
(file (dvc-get-file-info-at-point)))
(setq dvc-buffer-marked-file-list (delete file dvc-buffer-marked-file-list))
(ewoc-invalidate dvc-fileinfo-ewoc current)))))
(unless up (dvc-fileinfo-next)))
(defun dvc-diff-unmark-file-up ()
"Unmark the file under point and move up."
(interactive)
(dvc-diff-unmark-file t))
(defun dvc-diff-diff ()
"Show diff for file at point."
(interactive)
(let ((on-modified-file (dvc-get-file-info-at-point)))
(if on-modified-file
(let ((buf (current-buffer)))
(dvc-file-diff on-modified-file dvc-diff-base
dvc-diff-modified t)
(pop-to-buffer buf))
(error "Not on a modified file"))))
(defun dvc-diff-next ()
"Move to the next list line or diff hunk."
(interactive)
(if (dvc-diff-in-ewoc-p)
(dvc-fileinfo-next)
(diff-hunk-next)))
(defun dvc-diff-prev ()
"Move to the previous list line or diff hunk."
(interactive)
(if (dvc-diff-in-ewoc-p)
(dvc-fileinfo-prev)
(diff-hunk-prev)))
(defun dvc-diff-ediff ()
"Run ediff on the current changes."
(interactive)
(unless (and (car dvc-diff-base)
(car dvc-diff-modified))
(error "No revision information to base ediff on"))
(let ((modified-file (dvc-get-file-info-at-point))
(loc (point)))
(if (and modified-file
(dvc-diff-in-ewoc-p))
;; on ewoc item; just ediff
(dvc-file-ediff-revisions modified-file
dvc-diff-base
dvc-diff-modified
(dvc-fileinfo-base-file))
;; in diff section; find hunk index, so we can jump to it in the ediff.
(end-of-line)
(dvc-trace "loc=%S" loc)
(let ((hunk 1))
(re-search-backward "^--- ")
(re-search-forward "^--- ")
(diff-hunk-next)
(while (<= (re-search-forward "\\(^[\\+-].*\n\\)+" nil t) loc)
(dvc-trace "hunk=%S" hunk)
(setq hunk (1+ hunk)))
(goto-char loc)
(with-current-buffer
(dvc-file-ediff-revisions modified-file
dvc-diff-base
dvc-diff-modified)
(ediff-jump-to-difference hunk))))))
(defun dvc-diff-log-single (&optional last-n)
"Show log for current file, LAST-N entries. (default
`dvc-log-last-n'; all if nil). LAST-N may be specified
interactively."
(interactive (list (if current-prefix-arg (prefix-numeric-value current-prefix-arg) dvc-log-last-n)))
(dvc-log (dvc-get-file-info-at-point) last-n))
(defun dvc-diff-log-tree (&optional last-n)
"Show log for current tree, LAST-N entries (default
`dvc-log-last-n'; all if nil). LAST-N may be specified
interactively."
(interactive (list (if current-prefix-arg (prefix-numeric-value current-prefix-arg) dvc-log-last-n)))
(dvc-log nil last-n))
(defun dvc-diff-find-file-name ()
"Same as `diff-find-file-name', but works in more cases."
(cond ((re-search-backward "^\\+\\+\\+ \\(mod/\\|b/\\|new-[^/\n]+/\\)?\\([^\n]*?\\)\\([ \t].*\\)?$" nil t)
(match-string-no-properties 2))
((not (ewoc-locate dvc-fileinfo-ewoc (point))) ;; the buffer contains no diff
"")
(t
(diff-find-file-name))))
(defun dvc-diff-get-file-at-point ()
"Return filename for file at point.
Throw an error when not on a file. If file is renamed, this is
the modified name."
(if (dvc-diff-in-ewoc-p)
(dvc-fileinfo-current-file)
(save-excursion
(expand-file-name (concat (file-name-as-directory
default-directory)
(dvc-diff-find-file-name))))))
(defun dvc-diff-add-log-entry (&optional other-frame)
"Add a log entry for file or diff hunk at point."
(interactive "P")
(if (dvc-diff-in-ewoc-p)
(dvc-fileinfo-add-log-entry other-frame)
(dvc-add-log-entry other-frame)))
(defvar dvc-header nil
"Free variable used to pass info from the parser to
`dvc-show-changes-buffer' (defined with a (let ...) in
dvc-show-changes-buffer, and altered by called functions).
This is just a lint trap.")
(defun dvc-show-changes-buffer (buffer parser &optional
output-buffer no-switch
header-end-regexp cmd)
"Show the *{dvc}-diff* buffer built from the *{dvc}-process* BUFFER.
default-directory of process buffer must be a tree root.
PARSER is a function to parse the diff and fill in the
dvc-fileinfo-ewoc list; it will be called with one arg,
OUTPUT-BUFFER. Data to be parsed will be in current buffer.
dvc-header will have been set as described below. After PARSER is
called, dvc-header is set as the dvc-fileinfo-ewoc header, and
OUTPUT-BUFFER contents are set as the dvc-fileinfo-ewoc footer.
Display changes in OUTPUT-BUFFER (must be non-nil; create with
dvc-prepare-changes-buffer).
If NO-SWITCH is nil, don't switch to the created buffer.
If non-nil, HEADER-END-REGEXP is a regexp matching the first line
which is not part of the diff header. Lines preceding
HEADER-END-REGEXP are copied into dvc-header.
CMD, if non-nil, is prepended to dvc-header."
;; We assume default-directory is correct, rather than calling
;; dvc-tree-root, because dvc-tree-root might prompt if there is
;; more than one back-end present. Similarly, we assume
;; output-buffer is created, to avoid calling dvc-current-active-dvc
;; for dvc-get-buffer-create.
(let* ((root (with-current-buffer buffer default-directory))
(dvc (dvc-current-active-dvc))
(changes-buffer output-buffer)
(dvc-header ""))
(if (or no-switch dvc-switch-to-buffer-first)
(set-buffer changes-buffer)
(dvc-switch-to-buffer changes-buffer))
(let (buffer-read-only)
(dvc-fileinfo-delete-messages)
(with-current-buffer buffer
(goto-char (point-min))
(when cmd
(setq dvc-header
(concat (dvc-face-add cmd 'dvc-header) "\n"
(dvc-face-add (make-string 72 ?\ ) 'dvc-separator))))
(when header-end-regexp
(setq dvc-header
(concat dvc-header
(buffer-substring-no-properties
(goto-char (point-min))
(progn (re-search-forward header-end-regexp nil t) ;; "^[^*\\.]"
(beginning-of-line)
(point))))))
(beginning-of-line)
(funcall parser changes-buffer)
;; Footer is back-end output from point to end-of-buffer; should be the diff output.
(let ((footer (concat
(dvc-face-add (make-string 72 ?\ ) 'dvc-separator)
"\n\n"
(buffer-substring-no-properties
(point) (point-max)))))
(with-current-buffer changes-buffer
(ewoc-set-hf dvc-fileinfo-ewoc dvc-header footer)
(if root (cd root)))))))
(setq buffer-read-only t)
(if (progn (goto-char (point-min))
(re-search-forward "^---" nil t))
(when (or global-font-lock-mode font-lock-mode)
(let ((font-lock-verbose nil))
(font-lock-fontify-buffer)))
;; Disabling font-lock mode (it's useless and it removes other
;; faces with Emacs 21)
(setq font-lock-keywords nil)
(font-lock-mode -1)
(ewoc-refresh dvc-fileinfo-ewoc))
(if (ewoc-nth dvc-fileinfo-ewoc 0)
(goto-char (ewoc-location (ewoc-nth dvc-fileinfo-ewoc 0)))))
(defun dvc-diff-no-changes (diff-buffer msg dir)
"Function to call from diff parser when there are no changes in a tree.
Inserts a message in the changes buffer, and in the minibuffer.
DIFF-BUFFER is the buffer prepared by dvc-prepare-changes-buffer.
MSG is a format string for a message to the user.
DIR is a string, passed to `format' with MSG."
(with-current-buffer diff-buffer
(let ((inhibit-read-only t))
(dvc-fileinfo-delete-messages)
(ewoc-enter-last dvc-fileinfo-ewoc
(make-dvc-fileinfo-message
:text (concat "* " (format msg dir) ".\n\n")))
(ewoc-refresh dvc-fileinfo-ewoc)
(recenter '(4))))
(message msg dir))
(defun dvc-diff-error-in-process (diff-buffer msg output error)
"Enter a message in DIFF-BUFFER (created by
dvc-prepare-changes-buffer), consisting of MSG and the contents of
OUTPUT and ERROR. Should be called by the error handler in the
diff parser."
(with-current-buffer diff-buffer
(let ((inhibit-read-only t))
(dvc-fileinfo-delete-messages)
(ewoc-enter-last dvc-fileinfo-ewoc
(make-dvc-fileinfo-message
:text (concat "* " msg ":\n"
(dvc-buffer-content output)
(dvc-buffer-content error))))
(ewoc-refresh dvc-fileinfo-ewoc)
(recenter)))
(message msg))
(defun dvc-diff-clear-buffers (dvc root msg &optional header)
"Clears all DVC diff and status buffers with root ROOT, insert MSG and optional HEADER.
Useful to clear diff buffers after a commit."
(dvc-trace "dvc-diff-clear-buffers (%S %S)" root msg)
;; Don't need to clear 'revision-diff; that is not changed by a commit
(dolist (buffer (list (dvc-get-buffer dvc 'diff root)
(dvc-get-buffer dvc 'status root)))
(when buffer
(dvc-trace "buffer=%S" buffer)
(with-current-buffer buffer
(let ((inhibit-read-only t))
(ewoc-filter
dvc-fileinfo-ewoc
(lambda (fileinfo)
(and (dvc-fileinfo-legacy-p fileinfo)
(eq (car (dvc-fileinfo-legacy-data fileinfo)) 'subtree))))
(if header
(ewoc-set-hf dvc-fileinfo-ewoc header "")
(ewoc-set-hf dvc-fileinfo-ewoc "" ""))
(ewoc-enter-first dvc-fileinfo-ewoc (make-dvc-fileinfo-message :text msg))
(ewoc-refresh dvc-fileinfo-ewoc))))))
(defun dvc-diff-dtrt (prefix)
"Do The Right Thing in a dvc-diff buffer."
(interactive "P")
(let* ((marked-elems (dvc-fileinfo-marked-elems))
(length-marked-elems (length marked-elems))
(fileinfo
(if (< 1 length-marked-elems)
(ewoc-data (car marked-elems))
(save-excursion
(unless (dvc-diff-in-ewoc-p) (dvc-diff-diff-or-list))
(dvc-fileinfo-current-fileinfo))))
(status (dvc-fileinfo-file-status fileinfo)))
(ecase status
(added
(if (< 1 length-marked-elems)
(error "cannot Do The Right Thing on more than one 'added' file"))
(dvc-fileinfo-add-log-entry-1 fileinfo prefix))
(deleted
;; typically nothing to do; just need commit
(ding)
(dvc-fileinfo-next))
(missing
;; File is in database, but not in workspace
(cond
((dvc-fileinfo-rename-possible marked-elems)
(dvc-fileinfo-rename))
(t
(dvc-fileinfo-same-status marked-elems)
(ding)
(dvc-offer-choices (concat (dvc-fileinfo-current-file) " does not exist in working directory")
'((dvc-fileinfo-revert-files "revert")
(dvc-fileinfo-remove-files "remove")
(dvc-fileinfo-rename "rename"))))))
(modified
;; Don't offer undo here; not a common action
(if (dvc-diff-in-ewoc-p)
(if (< 1 length-marked-elems)
(error "cannot ediff more than one file")
(dvc-diff-ediff))
(if (< 1 length-marked-elems)
(error "cannot add a log entry for more than one file")
(dvc-diff-add-log-entry))))
((copy-source copy-target rename-source rename-target)
;; typically nothing to do; just need commit
(ding)
(dvc-fileinfo-next))
(unknown
(cond
((dvc-fileinfo-rename-possible marked-elems)
(dvc-fileinfo-rename))
(t
(dvc-fileinfo-same-status marked-elems)
(dvc-offer-choices nil
'((dvc-fileinfo-add-files "add")
(dvc-fileinfo-ignore-files "ignore")
(dvc-fileinfo-remove-files "remove")
(dvc-fileinfo-rename "rename"))))))
)))
;;;###autoload
(defun dvc-file-ediff (file)
"Run ediff of FILE (default current buffer file) against last revision."
(interactive (list (buffer-file-name)))
;; Setting `enable-local-variables' nil here is something of a
;; trade-off. In some buffers (Makefiles), the local variables may
;; include expressions that parse project files, which can take a
;; long time and confuse Emacs, so we don't want to process them. On
;; the other hand, they may set fontification style, which we do
;; want in ediff. The only general solution is to define a subset of
;; local variables that are desireable for ediff; we can't do that
;; just in DVC.
(let ((enable-local-variables nil))
(let ((file-buffer (find-file-noselect file))
(pristine-buffer
(dvc-revision-get-file-in-buffer
file `(,(dvc-current-active-dvc)
(last-revision
,(dvc-tree-root file t)
1)))))
(with-current-buffer pristine-buffer
(set-buffer-modified-p nil)
(setq buffer-read-only t)
(let ((buffer-file-name file))
(set-auto-mode t)))
(dvc-ediff-buffers pristine-buffer file-buffer))))
(defun dvc-file-ediff-revisions (file base-rev modified-rev &optional base-file)
"View changes in FILE between BASE-REV and MODIFIED-REV using ediff.
Optional BASE-FILE is filename in BASE-REV if different from FILE."
(dvc-ediff-buffers
(dvc-revision-get-file-in-buffer (or base-file file) base-rev)
(dvc-revision-get-file-in-buffer file modified-rev)))
;;;###autoload
(defun dvc-dvc-file-diff (file &optional base modified dont-switch)
"Default for back-end-specific file diff. View changes in FILE
between BASE (default last-revision) and MODIFIED (default
workspace version)."
(let* ((dvc (or (car base) (dvc-current-active-dvc)))
(base (or base `(,dvc (last-revision ,file 1))))
(modified (or modified `(,dvc (local-tree ,file))))
(diff-buffer (dvc-prepare-changes-buffer
base
modified
'file-diff file dvc))
(base-buffer
(dvc-revision-get-file-in-buffer file base))
(modified-buffer
(dvc-revision-get-file-in-buffer file modified))
(base-file (make-temp-file "DVC-file-diff-base"))
(modified-file (make-temp-file "DVC-file-diff-mod")))
(with-temp-file base-file
(insert (with-current-buffer base-buffer (buffer-string)))
(setq buffer-file-coding-system (with-current-buffer base-buffer
buffer-file-coding-system)))
(with-temp-file modified-file
(insert (with-current-buffer modified-buffer (buffer-string)))
(setq buffer-file-coding-system (with-current-buffer modified-buffer
buffer-file-coding-system)))
(dvc-switch-to-buffer diff-buffer)
(let ((inhibit-read-only t)
(slash (unless (file-name-absolute-p file) "/")))
(erase-buffer)
(call-process dvc-diff-executable nil diff-buffer nil
"-u"
;; FIXME: If the file has been renamed between
;; BASE and MODIFIED, the file names as
;; displayed here may be incorrect. The
;; protocol needs to be extended to allow the
;; backend to supply the correct file names.
(concat "-La" slash file)
(concat "-Lb" slash file)
base-file modified-file))
(delete-file base-file)
(delete-file modified-file)
(message "")
(goto-char (point-min))
(setq buffer-read-only t)))
(defun dvc-ediff-startup-hook ()
"Passed as a startup hook for ediff.
Programs ediff to return to the current window configuration after
quitting."
;; ediff-after-quit-hook-internal is local to an ediff session.
(add-hook 'ediff-after-quit-hook-internal
(dvc-capturing-lambda ()
(set-window-configuration (capture dvc-window-config)))
nil 'local)
;; Set dvc-buffer-current-active-dvc for dvc-ediff-add-log-entry.
;; When this hook is called, current buffer is the ediff control
;; buffer, default-directory is the tree root.
(setq dvc-buffer-current-active-dvc (dvc-current-active-dvc)))
(defvar dvc-window-config nil
"Keep byte-compiler happy; declare let-bound variable used by dvc-ediff-startup-hook.")
(defun dvc-ediff-buffers (bufferA bufferB)
"Wrapper around `ediff-buffers'.
Calls `ediff-buffers' on BUFFERA and BUFFERB."
(let ((dvc-window-config (current-window-configuration))
(dvc-temp-current-active-dvc (dvc-current-active-dvc)))
(ediff-buffers bufferA bufferB
'(dvc-ediff-startup-hook) 'dvc-ediff)))
(provide 'dvc-diff)
;;; dvc-diff.el ends here

186
dvc/lisp/dvc-emacs.el
View File

@ -1,186 +0,0 @@
;;; dvc-emacs.el --- Compatibility stuff for old versions of GNU Emacs
;;; and for XEmacs.
;;;
;;; This file should be loaded when using Gnu Emacs; load
;;; dvc-xemacs.el when using XEmacs.
;; Copyright (C) 2004, 2007 - 2008 by all contributors
;; This file is part of DVC.
;;
;; DVC is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; DVC is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Policy:
;;
;; The DVC baseline environment is the current release of Gnu Emacs.
;; However, we also support at least one previous release of Gnu
;; Emacs, and the current release of XEmacs.
;;
;; There is current Gnu Emacs code used in DVC that is not present in
;; XEmacs or previous releases of Gnu Emacs.
;;
;; This file provides versions of that code that work with previous
;; versions of Gnu Emacs. dvc-xemacs.el provides versions of that code
;; that work with XEmacs.
;;
;; There are also functions in Gnu Emacs code used in DVC that have
;; different names in XEmacs. This file and dvc-xemacs.el provide
;; common names for those functions.
;;
;; There may also be functions in Gnu Emacs that have the same name as
;; functions in XEmacs, in which case this file provides a common name
;; to sort things out.
;;
;; In all cases, the code provided here should use names prefixed with
;; `dvc-'. This is to allow for the possibility that other packages
;; also provide the same function, but the code is broken in some way.
;; Our version will work with DVC; theirs will work with their
;; package. DVC code must use the dvc- prefixed name.
;;
;; It might be that some code is truly _not_ broken, but it's much
;; easier to just use the dvc- prefix than to prove that.
;;
;; Some implementations will be duplicated here and in dvc-xemacs.el.
;; That is ok; they may need to diverge if bugs are discovered, and
;; they will most likely be reduced to aliases at different times.
;; DVC developers should normally use Gnu Emacs 22 or XEmacs. In
;; addition, they should occasionally compile with Gnu Emacs 21, or
;; earlier versions of XEmacs, to verify compatibility.
;;
;; As the current release of Gnu Emacs ages, it may be that there are
;; features in the development head of Emacs that would be useful in
;; DVC. Such features can also be provided here.
;; In the future, when we drop support for Gnu Emacs 21, some of the
;; functions provided here can be deleted, and the DVC code that uses
;; it changed to use the Gnu Emacs release name. That will make that
;; code somewhat clearer.
;;; Code:
(unless (fboundp 'minibufferp)
(defun minibufferp ()
"Return non-nil if within a minibuffer."
(equal (selected-window)
(active-minibuffer-window))))
;; These have different names in Gnu Emacs and XEmacs; see dvc-xemacs.el
(defalias 'dvc-make-overlay 'make-overlay)
(defalias 'dvc-delete-overlay 'delete-overlay)
(defalias 'dvc-overlay-put 'overlay-put)
(defalias 'dvc-move-overlay 'move-overlay)
(defalias 'dvc-overlay-buffer 'overlay-buffer)
(defalias 'dvc-overlay-start 'overlay-start)
(defalias 'dvc-overlay-end 'overlay-end)
(defalias 'dvc-extent-detached-p 'ignore)
(defalias 'dvc-extent-start-open 'ignore)
(defalias 'dvc-mail-strip-quoted-names 'mail-strip-quoted-names)
(defalias 'dvc-character-to-event 'identity)
(defalias 'dvc-assq-delete-all 'assq-delete-all)
(defalias 'dvc-add-text-properties 'add-text-properties)
(defalias 'dvc-put-text-property 'put-text-property)
(defconst dvc-mouse-face-prop 'mouse-face)
;; Provide features from Emacs 22 for Emacs 21
;; alphabetical by symbol name
(if (fboundp 'derived-mode-p)
(defalias 'dvc-derived-mode-p 'derived-mode-p)
(defun dvc-derived-mode-p (&rest modes)
"Non-nil if the current major mode is derived from one of MODES.
Uses the `derived-mode-parent' property of the symbol to trace backwards."
(let ((parent major-mode))
(while (and (not (memq parent modes))
(setq parent (get parent 'derived-mode-parent))))
parent)))
(if (fboundp 'ewoc-delete)
(defalias 'dvc-ewoc-delete 'ewoc-delete)
(defun dvc-ewoc-delete (ewoc &rest nodes)
"Delete NODES from EWOC."
(ewoc--set-buffer-bind-dll-let* ewoc
((L nil) (R nil) (last (ewoc--last-node ewoc)))
(dolist (node nodes)
;; If we are about to delete the node pointed at by last-node,
;; set last-node to nil.
(when (eq last node)
(setf last nil (ewoc--last-node ewoc) nil))
(delete-region (ewoc--node-start-marker node)
(ewoc--node-start-marker (ewoc--node-next dll node)))
(set-marker (ewoc--node-start-marker node) nil)
(setf L (ewoc--node-left node)
R (ewoc--node-right node)
;; Link neighbors to each other.
(ewoc--node-right L) R
(ewoc--node-left R) L
;; Forget neighbors.
(ewoc--node-left node) nil
(ewoc--node-right node) nil)))))
;; In Emacs 22, (expand-file-name "c:/..") returns "c:/". But in Emacs
;; 21, it returns "c:/..". So fix that here. We don't use
;; dvc-expand-file-name everywhere in DVC, to simplify deleting it
;; later. We only use it when this case is likely to be encountered.
(if (and (memq system-type '(ms-dos windows-nt))
(< emacs-major-version 22))
(defun dvc-expand-file-name (name &optional default-directory)
(let ((result (expand-file-name name default-directory)))
(if (equal (substring result -2 (length result)) "..")
(setq result (substring result 0 -2)))
result))
(defalias 'dvc-expand-file-name 'expand-file-name))
(if (fboundp 'line-number-at-pos)
(defalias 'dvc-line-number-at-pos 'line-number-at-pos)
(defun dvc-line-number-at-pos (&optional pos)
"Return (narrowed) buffer line number at position POS.
If POS is nil, use current buffer location."
(let ((opoint (or pos (point))) start)
(save-excursion
(goto-char (point-min))
(setq start (point))
(goto-char opoint)
(forward-line 0)
(1+ (count-lines start (point)))))))
(if (fboundp 'redisplay)
(defalias 'dvc-redisplay 'redisplay)
(defun dvc-redisplay (&optional force)
(if force
(let ((redisplay-dont-pause t))
(sit-for 0))
(sit-for 0))))
(if (fboundp 'window-body-height)
(defalias 'dvc-window-body-height 'window-body-height)
(defalias 'dvc-window-body-height 'window-height))
;; FIXME: move to dvc-utils?
(defun dvc-emacs-make-temp-dir (prefix)
"Make a temporary directory using PREFIX.
Return the name of the directory."
(let ((dir (make-temp-name
(expand-file-name prefix temporary-file-directory))))
(make-directory dir)
dir))
(defalias 'dvc-make-temp-dir 'dvc-emacs-make-temp-dir)
(provide 'dvc-emacs)
;;; dvc-emacs.el ends here

831
dvc/lisp/dvc-fileinfo.el
View File

@ -1,831 +0,0 @@
;;; dvc-fileinfo.el --- An ewoc structure for displaying file information
;;; for DVC
;; Copyright (C) 2007 - 2011 by all contributors
;; Author: Stephen Leake, <stephen_leake@stephe-leake.org>
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;
;;; Code:
(require 'dvc-defs)
(require 'dvc-core)
(require 'ewoc)
(eval-when-compile (require 'cl))
(defstruct (dvc-fileinfo-root
(:constructor nil)
(:copier nil))
;; no slots; root of class for ewoc entries.
)
(defvar dvc-fileinfo-ewoc nil
"Buffer-local ewoc for displaying workspace file status.
All dvc-fileinfo functions operate on this ewoc.
The elements must all be of class dvc-fileinfo-root.")
;; We could have each mode that uses fileinfo declare their own
;; buffer-local ewoc variable (ie dvc-diff-cookie). However, then the
;; interactive functions declared here (like dvc-fileinfo-next) would
;; take an ewoc argument, making them harder to bind directly to keys.
;;
;; We assume there will only be one ewoc structure of interest in a
;; given buffer.
(make-variable-buffer-local 'dvc-fileinfo-ewoc)
(defstruct (dvc-fileinfo-file
(:include dvc-fileinfo-root)
(:copier nil))
mark ;; t/nil.
exclude ;; t/nil. If t, don't commit unless also mark = t.
dir ;; Directory the file resides in, relative to dvc-root.
file ;; File name sans directory.
;; (concat dir file) gives a valid path.
status ;; Symbol; see dvc-fileinfo-status-image-full for list
(indexed t) ;; Whether changes made to the file have been recorded
;; in the index. Use t if the back-end does not
;; support an index.
more-status ;; String. If status is rename-*, this is the other name.
;; Otherwise whatever else the backend has to say
)
(defun dvc-fileinfo-status-image-full (status)
"String image of STATUS.
This is used by `dvc-fileinfo-printer-full'."
(ecase status
(added "added ")
(conflict "conflict ")
(deleted "deleted ")
(ignored "ignored ")
(invalid "invalid ")
(known "known ")
(missing "missing ")
(modified "modified ")
(copy-source "copy ")
(copy-target " ==> ")
(rename-source "rename-source")
(rename-target "rename-target")
(unknown "unknown ")))
(defun dvc-fileinfo-status-image-terse (status)
"String image of STATUS.
This is used by `dvc-fileinfo-printer-terse'."
(ecase status
(added "A")
(conflict "X")
(deleted "D")
(ignored "G")
(invalid "I")
(known "-")
(missing "D")
(modified "M")
(copy-source "C")
(copy-target 'target)
(rename-source "R")
(rename-target 'target)
(unknown "?")))
(defun dvc-fileinfo-choose-face-full (status)
"Return a face appropriate for STATUS.
This is used by `dvc-fileinfo-printer-full'."
(ecase status
(added 'dvc-added)
(conflict 'dvc-conflict)
(deleted 'dvc-deleted)
(ignored 'dvc-ignored)
(invalid 'dvc-unrecognized)
(known 'dvc-source)
(missing 'dvc-move)
(modified 'dvc-modified)
(copy-source 'dvc-copy)
(copy-target 'dvc-copy)
(rename-source 'dvc-move)
(rename-target 'dvc-move)
(unknown 'dvc-unknown)))
(defalias 'dvc-fileinfo-choose-face-terse 'dvc-fileinfo-choose-face-full)
(defstruct (dvc-fileinfo-dir
(:include dvc-fileinfo-file)
(:copier nil))
;; no extra slots
)
(defstruct (dvc-fileinfo-message
(:include dvc-fileinfo-root)
(:copier nil))
text ;; String
)
(defstruct (dvc-fileinfo-legacy
(:include dvc-fileinfo-root)
(:copier nil))
;; This type has the same form as the old dvc-diff-cookie ewoc
;; element. It is provided to ease the transition to the new
;; structure; current parsing code needs very few changes to use
;; this, and can be more gradually changed to use a dvc-fileinfo
;; struct.
data
;; one of:
;; (file \"filename\" \"[CRADP?]\" \"M\" \"/\" \"origname\")
;; (subtree \"name\" related-buffer changes?)
;; (searching-subtree \"<message>\" )
)
(defun dvc-fileinfo-printer (fileinfo)
"Ewoc pretty-printer for dvc-fileinfo types. Actual pretty-printer
is specified by `dvc-fileinfo-printer-interface'."
(let* ((interface (or dvc-fileinfo-printer-interface 'full))
(fun (intern (concat "dvc-fileinfo-printer-"
(symbol-name interface)))))
;; Allow people to use a complete function name if they like
(when (and (not (fboundp fun))
(fboundp interface))
(setq fun interface))
(funcall fun fileinfo)))
(defun dvc-fileinfo-printer-full (fileinfo)
"Ewoc pretty-printer for dvc-fileinfo types which uses full text to
indicate statuses."
(etypecase fileinfo
(dvc-fileinfo-file ;; also matches dvc-fileinfo-dir
(let ((line (concat
(dvc-fileinfo-status-image-full
(dvc-fileinfo-file-status fileinfo))
" "
(dvc-fileinfo-file-dir fileinfo)
(dvc-fileinfo-file-file fileinfo)))
(face (cond
((dvc-fileinfo-file-mark fileinfo) 'dvc-marked)
((dvc-fileinfo-file-exclude fileinfo) 'dvc-excluded)
(t (dvc-fileinfo-choose-face-full
(dvc-fileinfo-file-status fileinfo))))))
(insert " ")
(cond
((dvc-fileinfo-file-mark fileinfo) (insert dvc-mark))
((dvc-fileinfo-file-exclude fileinfo) (insert dvc-exclude))
(t (insert " ")))
(insert " ")
(insert (dvc-face-add line face))
(if (> (length (dvc-fileinfo-file-more-status fileinfo)) 0)
(progn
(newline)
(insert " ")
(case (dvc-fileinfo-file-status fileinfo)
(rename-source
(insert "to "))
(rename-target
(insert "from "))
(t nil))
(insert (dvc-fileinfo-file-more-status fileinfo))))))
(dvc-fileinfo-legacy
(dvc-diff-printer (dvc-fileinfo-legacy-data fileinfo)) )
(dvc-fileinfo-message
(insert (dvc-fileinfo-message-text fileinfo)))))
(defun dvc-fileinfo-printer-terse (fileinfo)
"Ewoc pretty-printer for dvc-fileinfo types which uses a single letter
to indicate statuses."
(let ((inhibit-read-only t))
(etypecase fileinfo
(dvc-fileinfo-file ;; also matches dvc-fileinfo-dir
(let* ((image (dvc-fileinfo-status-image-terse
(dvc-fileinfo-file-status fileinfo)))
(indexed (if (or (dvc-fileinfo-file-indexed fileinfo)
(eq (dvc-fileinfo-file-status fileinfo)
'unknown))
" " "?"))
(line (if (stringp image)
(concat image indexed " "
(dvc-fileinfo-file-dir fileinfo)
(dvc-fileinfo-file-file fileinfo))
(concat " ==> "
(dvc-fileinfo-file-dir fileinfo)
(dvc-fileinfo-file-file fileinfo))))
(face (cond
((dvc-fileinfo-file-mark fileinfo) 'dvc-marked)
((dvc-fileinfo-file-exclude fileinfo) 'dvc-excluded)
(t (dvc-fileinfo-choose-face-terse
(dvc-fileinfo-file-status fileinfo))))))
(cond
((dvc-fileinfo-file-mark fileinfo) (insert dvc-mark))
((dvc-fileinfo-file-exclude fileinfo) (insert dvc-exclude))
(t (insert " ")))
(insert " ")
(insert (dvc-face-add line face))
(if (> (length (dvc-fileinfo-file-more-status fileinfo)) 0)
(progn
(newline)
(insert " ")
(insert (dvc-fileinfo-file-more-status fileinfo))))))
(dvc-fileinfo-legacy
(dvc-diff-printer (dvc-fileinfo-legacy-data fileinfo)) )
(dvc-fileinfo-message
(insert (dvc-fileinfo-message-text fileinfo))))))
(defun dvc-fileinfo-current-fileinfo ()
"Return the fileinfo (a dvc-fileinfo-file, or
dvc-fileinfo-legacy) for the ewoc element at point. Throws an
error if point is not on a file or directory."
(let ((ewoc-entry (ewoc-locate dvc-fileinfo-ewoc)))
(if (not ewoc-entry)
;; ewoc is empty
(error "not on a file or directory"))
(let ((fileinfo (ewoc-data ewoc-entry)))
(etypecase fileinfo
(dvc-fileinfo-file ; also matches dvc-fileinfo-dir
fileinfo)
(dvc-fileinfo-legacy
(let ((data (dvc-fileinfo-legacy-data fileinfo)))
(cond
((eq (car data) 'file)
fileinfo)
(t
(error "not on a file or directory")))))
(dvc-fileinfo-message
(error "not on a file or directory"))))))
(defun dvc-fileinfo-file-or-legacy-file-p (fileinfo)
"Return t if FILEINFO is a dvc-fileinfo-file, or a dvc-fileinfo-legacy
containing a 'file."
(or (dvc-fileinfo-file-p fileinfo)
(and (dvc-fileinfo-legacy-p fileinfo)
(eq 'file (car (dvc-fileinfo-legacy-data fileinfo))))))
(defun dvc-fileinfo-path (fileinfo)
"Return directory and file from fileinfo, as a string."
(etypecase fileinfo
(dvc-fileinfo-file
(concat (dvc-fileinfo-file-dir fileinfo)
(dvc-fileinfo-file-file fileinfo)))
(dvc-fileinfo-legacy
(let ((data (dvc-fileinfo-legacy-data fileinfo)))
(if (eq 'file (car data))
(cadr data)
(error "Not on a file entry"))))))
(defun dvc-fileinfo-current-file ()
"Return a string giving the filename (including path from root)
of the file element on the line at point. Throws an error if
point is not on a file element line. If file status is
`rename-*', this is the modified (or target) name."
(let ((fileinfo (dvc-fileinfo-current-fileinfo)))
(etypecase fileinfo
(dvc-fileinfo-file ; also matches dvc-fileinfo-dir
(case (dvc-fileinfo-file-status fileinfo)
(rename-source
;; target name is in more-status
(dvc-fileinfo-file-more-status fileinfo))
(t
(concat (dvc-fileinfo-file-dir fileinfo)
(dvc-fileinfo-file-file fileinfo)))))
(dvc-fileinfo-legacy
(cadr (dvc-fileinfo-legacy-data fileinfo))))))
(defun dvc-fileinfo-base-file ()
"Return a string giving the filename in the base revision.
Includes path from root). Different from
dvc-fileinfo-current-file only for renamed files."
(let ((fileinfo (dvc-fileinfo-current-fileinfo)))
(etypecase fileinfo ; also matches dvc-fileinfo-dir
(dvc-fileinfo-file
(case (dvc-fileinfo-file-status fileinfo)
(rename-target
;; source name is in more-status, and it includes the path
(dvc-fileinfo-file-more-status fileinfo))
(t
;; see if there is a rename for this file in the ewoc
(let ((found-data
(ewoc-collect
dvc-fileinfo-ewoc
(lambda (data)
(etypecase data
(dvc-fileinfo-file
(and (eq 'rename-target (dvc-fileinfo-file-status data))
(string= (dvc-fileinfo-file-dir fileinfo)
(dvc-fileinfo-file-dir data))
(string= (dvc-fileinfo-file-file fileinfo)
(dvc-fileinfo-file-file data))))
(t nil))))))
(if found-data
(dvc-fileinfo-file-more-status (car found-data))
(concat (dvc-fileinfo-file-dir fileinfo)
(dvc-fileinfo-file-file fileinfo)))))))
(dvc-fileinfo-legacy
(cadr (dvc-fileinfo-legacy-data fileinfo))))))
(defun dvc-fileinfo-all-files ()
"Return list of all files (as strings) in file list"
(let (result)
(ewoc-map
(lambda (fileinfo)
(when (dvc-fileinfo-file-or-legacy-file-p fileinfo)
;; we use 'add-to-list', because some back-ends put files in
;; the ewoc more than once
(add-to-list 'result (dvc-fileinfo-path fileinfo)))
nil)
dvc-fileinfo-ewoc)
result))
(defun dvc-fileinfo-delete-messages ()
"Remove all message elements from the ewoc."
(ewoc-filter dvc-fileinfo-ewoc
(lambda (fileinfo)
(not (dvc-fileinfo-message-p fileinfo)))))
(defun dvc-fileinfo-kill ()
"Remove the current element(s) from the ewoc. Does nothing for
marked legacy fileinfos."
(interactive)
(if (and (= 0 (length (dvc-fileinfo-marked-files)))
(= 0 (length dvc-buffer-marked-file-list)))
;; no marked files
(progn
;; binding inhibit-read-only doesn't seem to work here
(toggle-read-only 0)
(dvc-ewoc-delete dvc-fileinfo-ewoc (ewoc-locate dvc-fileinfo-ewoc))
(toggle-read-only 1))
;; marked files
(if (= 0 (length dvc-buffer-marked-file-list))
;; non-legacy files
(ewoc-filter dvc-fileinfo-ewoc
(lambda (fileinfo)
(not (dvc-fileinfo-file-mark fileinfo)))
)
;; legacy files
nil)))
(defun dvc-fileinfo-mark-dir-1 (fileinfo mark dir-compare)
;; Note that fileinfo will only be fileinfo-file or fileinfo-dir
(if (string-equal dir-compare (dvc-fileinfo-file-dir fileinfo))
(let ((file (dvc-fileinfo-path fileinfo)))
(etypecase fileinfo
(dvc-fileinfo-dir
(if (dvc-fileinfo-file-exclude fileinfo)
(if mark
(message "not marking %s; excluded" file))
(dvc-fileinfo-mark-dir file mark))
;; return non-nil so this element is refreshed
t)
(dvc-fileinfo-file
(if (dvc-fileinfo-file-exclude fileinfo)
(if mark
(message "not marking %s; excluded" file))
(setf (dvc-fileinfo-file-mark fileinfo) mark))
;; return non-nil so this element is refreshed
t)
))))
(defun dvc-fileinfo-mark-dir (dir mark)
"Set the mark for all files in DIR to MARK, recursively."
(ewoc-map (lambda (fileinfo dir-compare)
(etypecase fileinfo
(dvc-fileinfo-file ; also matches dvc-fileinfo-dir
(dvc-fileinfo-mark-dir-1 fileinfo mark dir-compare))
(dvc-fileinfo-message nil)
(dvc-fileinfo-legacy
(error "dvc-fileinfo-mark-dir not implemented for legacy back-ends"))))
dvc-fileinfo-ewoc
(file-name-as-directory dir)))
(defun dvc-fileinfo-mark-file-1 (mark)
"Set the mark for file under point to MARK. If a directory, mark all files
in that directory."
(let* ((current (ewoc-locate dvc-fileinfo-ewoc))
(fileinfo (ewoc-data current)))
(etypecase fileinfo
(dvc-fileinfo-dir
(let ((file (dvc-fileinfo-path fileinfo)))
(if (dvc-fileinfo-file-exclude fileinfo)
(if mark
(progn
;; we don't throw an error here, because we might
;; be marking a higher-level directory, and we
;; don't want to skip the rest of it.
(ding)
(message "not marking %s; excluded" file)))
;; not excluded
(setf (dvc-fileinfo-file-mark fileinfo) mark)
(ewoc-invalidate dvc-fileinfo-ewoc current)
(dvc-fileinfo-mark-dir file mark))))
(dvc-fileinfo-file
(let ((file (dvc-fileinfo-path fileinfo)))
(if (dvc-fileinfo-file-exclude fileinfo)
(if mark
(progn
;; we don't throw an error here, because we might
;; be marking a higher-level directory, and we
;; don't want to skip the rest of it.
(ding)
(message "not marking %s; excluded" file)))
;; not excluded
(setf (dvc-fileinfo-file-mark fileinfo) mark)
(ewoc-invalidate dvc-fileinfo-ewoc current))))
(dvc-fileinfo-legacy
(error "mark not supported for legacy systems"))
(dvc-fileinfo-message
(error "not on a file or directory")))))
(defun dvc-fileinfo-mark-file ()
"Mark the file under point. If a directory, mark all files in
that directory. Then move to next ewoc entry."
(interactive)
(dvc-fileinfo-mark-file-1 t)
(dvc-fileinfo-next))
(defun dvc-fileinfo-unmark-file (&optional prev)
"Unmark the file under point. If a directory, unmark all files
in that directory. If PREV non-nil, move to previous ewoc entry;
otherwise move to next."
(interactive)
(dvc-fileinfo-mark-file-1 nil)
(if prev
(dvc-fileinfo-prev)
(dvc-fileinfo-next)))
(defun dvc-fileinfo-unmark-file-up ()
"Unmark the file under point. If a directory, unmark all files
in that directory. Then move to previous ewoc entry."
(interactive)
(dvc-fileinfo-unmark-file t))
(defun dvc-fileinfo-mark-all ()
"Mark all files and directories."
(interactive)
(ewoc-map (lambda (fileinfo)
(etypecase fileinfo
(dvc-fileinfo-file ; also matches dvc-fileinfo-dir
(if (dvc-fileinfo-file-exclude fileinfo)
(progn
(message "not marking %s; excluded" (dvc-fileinfo-path fileinfo))
;; don't need to refresh
nil)
(setf (dvc-fileinfo-file-mark fileinfo) t)
;; return non-nil so this element is refreshed
t))
(dvc-fileinfo-legacy
(error "mark not supported for legacy backends"))
(dvc-fileinfo-message
nil)))
dvc-fileinfo-ewoc))
(defun dvc-fileinfo-unmark-all ()
"Unmark all files and directories."
(interactive)
(ewoc-map (lambda (fileinfo)
(etypecase fileinfo
(dvc-fileinfo-file ; also matches dvc-fileinfo-dir
(if (dvc-fileinfo-file-mark fileinfo)
(progn
(setf (dvc-fileinfo-file-mark fileinfo) nil)
;; return non-nil so this element is refreshed
t)))
(dvc-fileinfo-legacy
(error "mark not supported for legacy backends"))
(dvc-fileinfo-message
nil)))
dvc-fileinfo-ewoc))
(defun dvc-fileinfo-toggle-exclude ()
"Toggle exclude for file under point. Does not edit default exclude file."
(interactive)
(let* ((current (ewoc-locate dvc-fileinfo-ewoc))
(fileinfo (ewoc-data current)))
(typecase fileinfo
(dvc-fileinfo-file
(if (dvc-fileinfo-file-mark fileinfo)
(error "Cannot exclude marked file"))
(setf (dvc-fileinfo-file-exclude fileinfo)
(not (dvc-fileinfo-file-exclude fileinfo)))
(ewoc-invalidate dvc-fileinfo-ewoc current))
(otherwise
(error "not on a file or directory")))))
(dvc-make-ewoc-next dvc-fileinfo-next dvc-fileinfo-ewoc)
(dvc-make-ewoc-prev dvc-fileinfo-prev dvc-fileinfo-ewoc)
(defun dvc-fileinfo-find-file (file)
"Return ewoc element for FILE (full path)."
(let ((elem (ewoc-nth dvc-fileinfo-ewoc 0)))
(while
(and elem
(let ((fileinfo (ewoc-data elem)))
(not (and
(dvc-fileinfo-file-or-legacy-file-p fileinfo)
(string= (expand-file-name (dvc-fileinfo-path fileinfo))
file)))))
;; not found yet
(setq elem (ewoc-next dvc-fileinfo-ewoc elem)))
(if elem
elem
(error "Can't find file %s in list" file))))
(defun dvc-fileinfo-marked-elems ()
"Return list of ewoc elements that are marked files."
;; This does _not_ include legacy fileinfo structs; they do not
;; contain a mark field. We are planning to eventually eliminate
;; dvc-buffer-marked-file-list and legacy fileinfos.
(let ((elem (ewoc-nth dvc-fileinfo-ewoc 0))
result)
(while elem
(let ((fi (ewoc-data elem)))
(if (and (dvc-fileinfo-file-p fi)
(dvc-fileinfo-file-mark fi))
(setq result (append result (list elem))))
(setq elem (ewoc-next dvc-fileinfo-ewoc elem))))
result))
(defun dvc-fileinfo-marked-files ()
"Return list of files that are marked."
;; This does _not_ include legacy fileinfo structs; they do not
;; contain a mark field. We are planning to eventually eliminate
;; dvc-buffer-marked-file-list and legacy fileinfos.
(let ((elem (ewoc-nth dvc-fileinfo-ewoc 0))
result)
(while elem
(let ((fi (ewoc-data elem)))
(if (and (dvc-fileinfo-file-p fi)
(dvc-fileinfo-file-mark fi))
(setq result (append result (list (dvc-fileinfo-path fi)))))
(setq elem (ewoc-next dvc-fileinfo-ewoc elem))))
result))
(defun dvc-fileinfo-excluded-files ()
"Return list of filenames that are excluded files."
;; This does _not_ include legacy fileinfo structs; they do not
;; contain an excluded field.
(let ((elem (ewoc-nth dvc-fileinfo-ewoc 0))
result)
(while elem
(let ((fi (ewoc-data elem)))
(if (and (dvc-fileinfo-file-p fi)
(dvc-fileinfo-file-exclude fi))
(setq result (append result (list (dvc-fileinfo-path fi)))))
(setq elem (ewoc-next dvc-fileinfo-ewoc elem))))
result))
(defun dvc-fileinfo-same-status (elems)
"If all ELEMS (list of ewoc elements with data of class
dvc-fileinfo-file) have same status, return t. Otherwise
throw an error."
(if (null elems)
t
(let (status)
(dolist (elem elems)
(let ((fileinfo (ewoc-data elem)))
(if status
(if (not (equal status (dvc-fileinfo-file-status fileinfo)))
(error (concat "cannot Do The Right Thing on files with"
" different status")))
(setq status (dvc-fileinfo-file-status fileinfo)))))
status)))
;;; actions
(defun dvc-fileinfo-set-status (status)
"Set status of current file(s) to STATUS. This avoids the need
to run the backend again. Does nothing for legacy fileinfos."
(if (= 0 (length (dvc-fileinfo-marked-files)))
(if dvc-buffer-marked-file-list
;; marked legacy fileinfos
nil
;; no marked files
(let ((fileinfo (dvc-fileinfo-current-fileinfo)))
(etypecase fileinfo
(dvc-fileinfo-message
nil)
(dvc-fileinfo-file ; also matches dvc-fileinfo-dir
(setf (dvc-fileinfo-file-status fileinfo) status))
(dvc-fileinfo-legacy
nil))
(ewoc-invalidate dvc-fileinfo-ewoc (ewoc-locate dvc-fileinfo-ewoc))))
;; marked files
(ewoc-map (lambda (fileinfo)
(etypecase fileinfo
(dvc-fileinfo-message
nil)
(dvc-fileinfo-file ; also matches dvc-fileinfo-dir
(if (dvc-fileinfo-file-mark fileinfo) (setf (dvc-fileinfo-file-status fileinfo) status)))))
dvc-fileinfo-ewoc)))
(defun dvc-fileinfo-add-files ()
"Add current file(s) to the database. Directories are also added,
but not recursively."
(interactive)
(apply 'dvc-add-files (dvc-current-file-list))
(dvc-fileinfo-set-status 'added))
(defun dvc-fileinfo-add-log-entry-1 (fileinfo other-frame)
"Add an entry in the current log-edit buffer for FILEINFO.
If OTHER-FRAME (default prefix) xor `dvc-log-edit-other-frame' is
non-nil, show log-edit buffer in other frame."
(dvc-log-edit other-frame t)
(undo-boundary)
(goto-char (point-max))
(newline 2)
(insert "* ")
(insert (dvc-fileinfo-path fileinfo))
(insert ": ")
(if (typep fileinfo 'dvc-fileinfo-file)
(ecase (dvc-fileinfo-file-status fileinfo)
(added
(insert "New file.")
(newline))
((copy-source copy-target)
(insert "copied")
(newline))
((rename-source rename-target)
(insert "renamed")
(newline))
((conflict
deleted
ignored
invalid
known
missing
modified
unknown)
nil))))
(defun dvc-fileinfo-add-log-entry (&optional other-frame)
"Add an entry in the current log-edit buffer for the current file.
If OTHER-FRAME (default prefix) xor `dvc-log-edit-other-frame' is
non-nil, show log-edit buffer in other frame."
(interactive "P")
(dvc-fileinfo-add-log-entry-1 (dvc-fileinfo-current-fileinfo) other-frame))
(defun dvc-fileinfo-ignore-files ()
"Ignore current files."
(interactive)
(dvc-ignore-files (dvc-current-file-list))
(dvc-fileinfo-kill))
(defun dvc-fileinfo-remove-files ()
"Remove current files. If status `unknown', delete from
workspace. Otherwise, call `dvc-remove-files'. For marked legacy
fileinfos, just call `dvc-remove-files'."
(interactive)
(if dvc-buffer-marked-file-list
(dvc-remove-files)
;; not legacy
(let ((elems (or (dvc-fileinfo-marked-elems)
(list (ewoc-locate dvc-fileinfo-ewoc))))
(inhibit-read-only t)
known-files unknown-files)
(while elems
(let ((fileinfo (ewoc-data (car elems))))
(typecase fileinfo
(dvc-fileinfo-file
(if (equal 'unknown (dvc-fileinfo-file-status fileinfo))
(progn
(push (car elems) unknown-files))
;; `add-to-list' gets a stack overflow here
(setq known-files (cons (car elems) known-files))))
(dvc-fileinfo-legacy
;; Assume files are known
(add-to-list 'known-files (car elems)))
(otherwise
;; just ignore
nil))
(setq elems (cdr elems))))
(if known-files
(progn
(apply 'dvc-remove-files
(mapcar (lambda (elem)
(dvc-fileinfo-path (ewoc-data elem)))
known-files))
(mapc
(lambda (elem)
(let ((fileinfo (ewoc-data elem)))
(etypecase fileinfo
(dvc-fileinfo-file
(setf (dvc-fileinfo-file-status fileinfo) 'deleted)
(ewoc-invalidate dvc-fileinfo-ewoc elem))
(dvc-fileinfo-legacy
;; Don't have enough info to update this
nil))))
known-files)))
(when unknown-files
(let ((names (mapcar (lambda (x) (dvc-fileinfo-path (ewoc-data x)))
unknown-files)))
(when (dvc-confirm-file-op "remove unknown" names t)
(mapcar 'delete-file names)
(apply 'ewoc-delete dvc-fileinfo-ewoc unknown-files)))))))
(defun dvc-fileinfo-revert-files ()
"Revert current files."
(interactive)
(apply 'dvc-revert-files (dvc-current-file-list))
(dvc-fileinfo-kill))
(defun dvc-fileinfo--do-rename (fi-source fi-target elems)
(dvc-rename (dvc-fileinfo-path fi-source)
(dvc-fileinfo-path fi-target))
(setf (dvc-fileinfo-file-status fi-source) 'rename-source)
(setf (dvc-fileinfo-file-status fi-target) 'rename-target)
(setf (dvc-fileinfo-file-mark fi-source) nil)
(setf (dvc-fileinfo-file-mark fi-target) nil)
(apply 'ewoc-invalidate dvc-fileinfo-ewoc elems))
(defun dvc-fileinfo-rename ()
"Record a rename for two currently marked files.
One file must have status `missing', the other `unknown'."
(interactive)
(let* ((elems (dvc-fileinfo-marked-elems))
(fis (mapcar 'ewoc-data elems))
(stati (mapcar 'dvc-fileinfo-file-status fis)))
(if (not (= 2 (length stati)))
(error "rename requires exactly 2 marked files"))
(cond
((and (eq 'missing (nth 0 stati))
(eq 'unknown (nth 1 stati)))
(dvc-fileinfo--do-rename (nth 0 fis) (nth 1 fis) elems))
((and (eq 'missing (nth 1 stati))
(eq 'unknown (nth 0 stati)))
(dvc-fileinfo--do-rename (nth 1 fis) (nth 0 fis) elems))
(t
(error (concat "must rename from a file with status `missing' to a"
" file with status `unknown'"))))))
(defun dvc-fileinfo-rename-possible (marked-elems)
"Return nil if `dvc-fileinfo-rename' will throw an error for
MARKED-ELEMS, non-nil otherwise."
(and
marked-elems
(= 2 (length marked-elems))
(let* ((fis (mapcar 'ewoc-data marked-elems))
(stati (mapcar 'dvc-fileinfo-file-status fis)))
(or
(and (eq 'missing (nth 0 stati))
(eq 'unknown (nth 1 stati)))
(and (eq 'missing (nth 1 stati))
(eq 'unknown (nth 0 stati)))))))
(provide 'dvc-fileinfo)
;;; end of file

334
dvc/lisp/dvc-gnus.el
View File

@ -1,334 +0,0 @@
;;; dvc-gnus.el --- dvc integration to gnus
;; Copyright (C) 2003-2009 by all contributors
;; Author: Matthieu Moy <Matthieu.Moy@imag.fr>
;; Contributions from:
;; Stefan Reichoer <stefan@xsteve.at>
;; DVC is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; DVC is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
(require 'tla-core)
;; gnus is optional. Load it at compile-time to avoid warnings.
(eval-when-compile
(condition-case nil
(progn
(require 'gnus)
(require 'gnus-art)
(require 'gnus-sum))
(error nil)))
(defvar gnus-summary-dvc-submap nil
"DVC Key mapping added to gnus summary.")
(defun dvc-gnus-initialize-keymap ()
"Initialize the keymap for DVC in `gnus-summary-mode-map'.
Prefix key is 'K t'."
(unless gnus-summary-dvc-submap
(require 'gnus)
(require 'gnus-sum)
(require 'gnus-art)
(setq gnus-summary-dvc-submap (make-sparse-keymap))
(define-key gnus-summary-mode-map [?K ?t] gnus-summary-dvc-submap)))
;;;###autoload
(defun dvc-insinuate-gnus ()
"Insinuate Gnus for each registered DVC back-end.
Runs (<backend>-insinuate-gnus) for each registered back-end having
this function.
Additionally the following key binding is defined for the gnus summary mode map:
K t l `dvc-gnus-article-extract-log-message'
K t v `dvc-gnus-article-view-patch'
K t m `dvc-gnus-article-view-missing'
K t a `dvc-gnus-article-apply-patch'
K t p `dvc-gnus-article-apply-patch-with-selected-destination'"
(interactive)
(dvc-gnus-initialize-keymap)
(define-key gnus-summary-dvc-submap [?a] 'dvc-gnus-article-apply-patch)
(define-key gnus-summary-dvc-submap [?p] 'dvc-gnus-article-apply-patch-with-selected-destination)
(define-key gnus-summary-dvc-submap [?l] 'dvc-gnus-article-extract-log-message)
(define-key gnus-summary-dvc-submap [?v] 'dvc-gnus-article-view-patch)
(define-key gnus-summary-dvc-submap [?m] 'dvc-gnus-article-view-missing)
(mapcar (lambda (x)
(let ((fn (dvc-function x "insinuate-gnus" t)))
(when (fboundp fn)
(dvc-trace "Insinuating Gnus for %S" x)
(funcall fn))))
dvc-registered-backends))
(defun dvc-gnus-article-extract-log-message ()
"Parse the mail and extract the log information.
Save it to `dvc-memorized-log-header', `dvc-memorized-patch-sender',
`dvc-memorized-log-message' and `dvc-memorized-version'."
(interactive)
(gnus-summary-select-article-buffer)
(save-excursion
(goto-char (point-min))
(let* ((start-pos (or (search-forward "[PATCH] " nil t) (search-forward "Subject: ")))
(end-pos (line-end-position))
(log-header (buffer-substring-no-properties start-pos end-pos)))
(setq dvc-memorized-log-header log-header))
(goto-char (point-min))
(let* ((start-pos (re-search-forward "From: +" nil t))
(end-pos (line-end-position))
(sender (when start-pos (buffer-substring-no-properties start-pos end-pos))))
(setq dvc-memorized-patch-sender (and start-pos sender)))
(goto-char (point-min))
(let* ((start-pos (search-forward "[VERSION] " nil t))
(end-pos (line-end-position))
(version (when start-pos (buffer-substring-no-properties start-pos end-pos))))
(setq dvc-memorized-version (and start-pos version)))
(dolist (delim-pair '(("^<<LOG-START>>" "^<<LOG-END>>") ("^\\[\\[\\[" "^\\]\\]\\]")))
(goto-char (point-min))
(when (and (re-search-forward (car delim-pair) nil t)
(re-search-forward (cadr delim-pair) nil t))
(goto-char (point-min))
(let* ((start-pos (+ (re-search-forward (car delim-pair)) 1))
(end-pos (- (progn (re-search-forward (cadr delim-pair)) (line-beginning-position)) 1))
(log-message (buffer-substring-no-properties start-pos end-pos)))
(setq dvc-memorized-log-message log-message)
(message "Extracted the patch log message from '%s'" dvc-memorized-log-header)))))
(gnus-article-show-summary))
(defvar dvc-gnus-article-apply-patch-deciders nil
"A list of functions that can be used to determine the patch type in a given mail.
The function is called when the article buffer is active. It should return nil if
the patch type could not be determined, otherwise one of the following:
'tla, 'xhg, 'bzr-merge-or-pull-url, 'bzr-merge-bundle, 'xgit")
(defvar dvc-gnus-override-window-config nil)
(defun dvc-gnus-article-apply-patch (n)
"Apply MIME part N, as patchset.
When called with no prefix arg, set N := 2.
DVC will try to figure out which VCS to use when applying the patch.
First we check to see if it is a tla changeset created with DVC.
If that is the case, `tla-gnus-apply-patch' is called.
The next check is whether it is a patch suitable for xhg. In that case
`xhg-gnus-article-import-patch' is called.
Then we check to see whether the patch was prepared with git
format-patch. If so, then call `xgit-gnus-article-apply-patch'.
Otherwise `dvc-gnus-apply-patch' is called."
(interactive "p")
(unless current-prefix-arg
(setq n 2))
(let ((patch-type)
(bzr-merge-or-pull-url)
(patch-decider-list dvc-gnus-article-apply-patch-deciders))
(save-window-excursion
(gnus-summary-select-article-buffer)
(goto-char (point-min))
(while (and (not patch-type) patch-decider-list)
(setq patch-type (funcall (car patch-decider-list)))
(setq patch-decider-list (cdr patch-decider-list)))
(unless patch-type
(cond ((re-search-forward (concat "\\[VERSION\\] "
(tla-make-name-regexp 4 t t))
nil t)
(setq patch-type 'tla))
((progn (goto-char (point-min))
(re-search-forward "^# Bazaar merge directive format" nil t))
(setq patch-type 'bzr-merge-bundle))
((progn (goto-char (point-min))
(or
(re-search-forward "^changeset: +[0-9]+:[0-9a-f]+$" nil t)
(re-search-forward "^Merge of all patches applied from revision" nil t)))
(setq patch-type 'xhg))
((progn (goto-char (point-min))
(or (re-search-forward "^New revision in \\(.+\\)$" nil t)
(re-search-forward "^Committed revision [0-9]+ to \\(.+\\)$" nil t)))
(setq patch-type 'bzr-merge-or-pull
bzr-merge-or-pull-url (match-string-no-properties 1)))
((progn (goto-char (point-min))
(and (re-search-forward "^---$" nil t)
(re-search-forward "^diff --git" nil t)))
(setq patch-type 'xgit))
(t (setq patch-type 'dvc)))))
(message "patch-type: %S" patch-type)
(cond ((eq patch-type 'tla)
(tla-gnus-article-apply-patch n))
((eq patch-type 'xhg)
(xhg-gnus-article-import-patch n))
((eq patch-type 'xgit)
(xgit-gnus-article-apply-patch n))
((eq patch-type 'bzr-merge-or-pull)
(bzr-merge-or-pull-from-url bzr-merge-or-pull-url))
((eq patch-type 'bzr-merge-bundle)
(bzr-gnus-article-merge-bundle n))
((eq patch-type 'bzr-pull-bundle-in-branch)
(bzr-gnus-article-pull-bundle-in-branch n))
((eq patch-type nil)
(let ((dvc-gnus-override-window-config))
(gnus-article-part-wrapper n 'dvc-gnus-apply-patch)
(when dvc-gnus-override-window-config
(set-window-configuration dvc-gnus-override-window-config))))
(t
(error "Unknown patch type %S" patch-type)))))
(defvar dvc-gnus-select-patch-dir-function nil)
(defun dvc-gnus-article-apply-patch-with-selected-destination (n)
"Apply a patch via the emacs diff-mode.
Allow to select the target directory from one of
`dvc-gnus-patch-desitination-candidates'."
(interactive "p")
(unless current-prefix-arg
(setq n 2))
(let ((dvc-gnus-override-window-config)
(dvc-gnus-select-patch-dir-function 'dvc-gnus-select-patch-destination))
(gnus-article-part-wrapper n 'dvc-gnus-apply-patch)
(when dvc-gnus-override-window-config
(set-window-configuration dvc-gnus-override-window-config))))
(defvar dvc-gnus-patch-desitination-candidates nil)
(defun dvc-gnus-select-patch-destination ()
(expand-file-name (dvc-completing-read "Patch destination: " dvc-gnus-patch-desitination-candidates)))
(defun dvc-gnus-article-view-missing ()
"Apply MIME part N, as patchset.
When called with no prefix arg, set N := 2.
First is checked, if it is a tla changeset created with DVC.
If that is the case, `tla-gnus-apply-patch' is called.
The next check is whether it is a patch suitable for xhg. In that case
`xhg-gnus-article-import-patch' is called.
Otherwise `dvc-gnus-apply-patch' is called."
(interactive)
(save-window-excursion
(gnus-summary-select-article-buffer)
(goto-char (point-min))
(goto-char (point-min))
(if (or (re-search-forward "^New revision in \\(.+\\)$" nil t)
(re-search-forward "^Committed revision [0-9]+ to \\(.+\\)$" nil t))
(let* ((bzr-missing-url (match-string-no-properties 1))
(dest (cdr (assoc bzr-missing-url bzr-merge-or-pull-from-url-rules)))
(path (cadr dest))
(doit t))
(when path
(setq doit (y-or-n-p (format "Run missing from %s in %s? " bzr-missing-url path))))
(when doit
(unless path
(setq path (dvc-read-directory-name (format "Run missing from %s in: " bzr-missing-url))))
(let ((default-directory path))
(message "Running bzr missing from %s in %s" bzr-missing-url path)
(bzr-missing bzr-missing-url)))))))
(defun dvc-gnus-article-view-patch (n)
"View MIME part N, as patchset.
When called with no prefix arg, set N := 2.
First is checked, if it is a tla changeset created with DVC.
If that is the case, `tla-gnus-article-view-patch' is called.
The next check looks at commit notification mails for bzr, when
such a message is detected, `bzr-gnus-article-view-patch' is called.
Otherwise `dvc-gnus-view-patch' is called."
(interactive "p")
(unless current-prefix-arg
(setq n 2))
(let ((patch-type))
(save-window-excursion
(gnus-summary-select-article-buffer)
(goto-char (point-min))
(if (or (re-search-forward (concat "\\[VERSION\\] " (tla-make-name-regexp 4 t t)) nil t)
(progn (goto-char (point-min))
(and (search-forward "Revision: " nil t)
(search-forward "Archive: " nil t))))
(setq patch-type 'tla)
(goto-char (point-min))
;; Committed revision 129 to http://my-arch.org/branch1
(if (re-search-forward "^Committed revision [0-9]+ to " nil t)
(setq patch-type 'bzr)
(setq patch-type 'dvc))))
(cond ((eq patch-type 'tla)
(tla-gnus-article-view-patch n))
((eq patch-type 'bzr)
(bzr-gnus-article-view-patch n))
(t
(let ((dvc-gnus-override-window-config))
(gnus-article-part-wrapper n 'dvc-gnus-view-patch)
(when dvc-gnus-override-window-config
(set-window-configuration dvc-gnus-override-window-config)))))))
(defvar dvc-apply-patch-mapping nil)
;;e.g.: (add-to-list 'dvc-apply-patch-mapping '("psvn" "~/work/myprg/psvn"))
(defun dvc-gnus-suggest-apply-patch-directory ()
"Use `dvc-apply-patch-mapping' to suggest a directory where
the patch sould be applied."
(if dvc-gnus-select-patch-dir-function
(funcall dvc-gnus-select-patch-dir-function)
(save-window-excursion
(gnus-summary-select-article-buffer)
(let ((patch-directory "~/")
(m dvc-apply-patch-mapping))
(save-excursion
(goto-char (point-min))
(when (search-forward "text/x-patch; " nil t)
(while m
(if (looking-at (caar m))
(progn
(setq patch-directory (cadar m))
(setq m nil))
(setq m (cdr m))))))
(gnus-article-show-summary)
(expand-file-name patch-directory)))))
(defun dvc-gnus-apply-patch (handle)
"Apply the patch corresponding to HANDLE."
(dvc-gnus-article-extract-log-message)
(let ((dvc-patch-name (concat (dvc-make-temp-name "dvc-patch") ".diff"))
(window-conf (current-window-configuration))
(patch-buff))
(dvc-buffer-push-previous-window-config window-conf)
(mm-save-part-to-file handle dvc-patch-name)
(find-file dvc-patch-name)
(diff-mode)
(toggle-read-only 1)
(setq patch-buff (current-buffer))
(delete-other-windows)
(setq default-directory (dvc-gnus-suggest-apply-patch-directory))
;; 07.07.2008: applying with ediff only works well when only one file is given.
;; (flet ((ediff-get-default-file-name (&optional default) (if default default default-directory)))
;; (ediff-patch-file 2 patch-buff))
(diff-hunk-next)
(message "You can apply the patch hunks now by using C-c C-a.")
(setq dvc-gnus-override-window-config (current-window-configuration))))
(defun dvc-gnus-view-patch (handle)
"View the patch corresponding to HANDLE."
(let ((dvc-patch-name (concat (dvc-make-temp-name "dvc-patch") ".diff"))
(cur-buf (current-buffer))
(window-conf (current-window-configuration))
(patch-buff))
(mm-save-part-to-file handle dvc-patch-name)
(gnus-summary-select-article-buffer)
(split-window-vertically)
(find-file-other-window dvc-patch-name)
(diff-mode)
(setq dvc-gnus-override-window-config (current-window-configuration))
(dvc-buffer-push-previous-window-config window-conf)
(toggle-read-only 1)
(other-window -1)
(gnus-article-show-summary)))
(provide 'dvc-gnus)
;;; dvc-gnus.el ends here

214
dvc/lisp/dvc-lisp.el
View File

@ -1,214 +0,0 @@
;;; dvc-lisp.el --- DVC lisp helper functions
;; Copyright (C) 2003-2007 by all contributors
;; Author: Stefan Reichoer, <stefan@xsteve.at>
;; Contributions from:
;; Matthieu Moy <Matthieu.Moy@imag.fr>
;; Masatake YAMATO <jet@gyve.org>
;; Milan Zamazal <pdm@zamazal.org>
;; Martin Pool <mbp@sourcefrog.net>
;; Robert Widhopf-Fenk <hack@robf.de>
;; Mark Triggs <mst@dishevelled.net>
;; Michael Olson <mwolson@gnu.org>
;; DVC is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; DVC is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; Helper functions unrelated from GNU Arch.
;;; History:
;;
;; Created in May 2005 by Matthieu Moy
;;
;; Overhauled in Aug 2007 by Michael Olson
(autoload 'edebug-unwrap "edebug")
(defvar dvc-gensym-counter 0)
(defun dvc-gensym (&optional prefix)
"Generate a new uninterned symbol.
If PREFIX is a string, then the name is made by appending a
number to PREFIX. The default is to use \"dvc\".
If PREFIX is a number, then use that number at the end of the
symbol name."
(let* ((prefix (if (stringp prefix) prefix "dvc-gensym-uniq-"))
(num (if (integerp prefix) prefix
(prog1
dvc-gensym-counter
(setq dvc-gensym-counter (1+ dvc-gensym-counter)))))
(symbol (make-symbol (format "%s%d" prefix num))))
(eval `(defvar ,symbol nil "lint trap"))
symbol))
(defun dvc-capturing-lambda-helper (l)
"Traverse list L, replacing captured symbols with newly generated
symbols.
A pair is added to `captured-values' for each new symbol,
containing the name of the new symbol and the name of the old
symbol.
This is used by `dvc-capturing-lambda'."
(cond ((atom l) l)
((eq (car l) 'capture)
(let ((sym (edebug-unwrap (cadr l))))
(unless (symbolp sym)
(error "Expected a symbol in capture statement: %S" sym))
(let ((g (car (rassq sym captured-values))))
(unless g
(setq g (dvc-gensym))
(push (cons g sym) captured-values))
g)))
(t (mapcar 'dvc-capturing-lambda-helper l))))
(eval-and-compile
;; NOTE: We keep the contents of this block flush against the left
;; margin, so that C-M-x continues to work.
(defmacro dvc-capturing-lambda (args &rest body)
"Return a `lambda' form with ARGS, containing BODY, after capturing
symbol values in BODY from the defining context.
Symbols to be captured should be surrounded by (capture ...).
The remainder of BODY's forms are left as-is.
For development on DVC, using either `dvc-capturing-lambda' or
`lexical-let' is acceptable, with the condition that you must use
one consistently within a particular source file.
A practical example:
;; Using dvc-capturing-lambda
(defun sort-by-nearness-1 (values middle)
\"Sort VALUES in order of how close they are to MIDDLE.\"
(sort values (dvc-capturing-lambda (a b)
(< (abs (- a (capture middle)))
(abs (- b (capture middle)))))))
(sort-by-nearness-1 '(1 2 3 4 8 5 9) 6)
=> (5 4 8 3 9 2 1)
;; Using backquote
(defun sort-by-nearness-2 (values middle)
\"Sort VALUES in order of how close they are to MIDDLE.\"
(sort values `(lambda (a b)
(< (abs (- a ,middle))
(abs (- b ,middle))))))
(sort-by-nearness-2 '(1 2 3 4 8 5 9) 6)
=> (5 4 8 3 9 2 1)
;; Using lexical-let
(defun sort-by-nearness-3 (values middle)
\"Sort VALUES in order of how close they are to MIDDLE.\"
(lexical-let ((middle middle))
(sort values (lambda (a b)
(< (abs (- a middle))
(abs (- b middle)))))))
(sort-by-nearness-3 '(1 2 3 4 8 5 9) 6)
=> (5 4 8 3 9 2 1)
An example for the well-read Lisp fan:
(let* ((x 'lexical-x)
(y 'lexical-y)
(l (dvc-capturing-lambda (arg)
(list x (capture y) arg))))
(let ((y 'dynamic-y)
(x 'dynamic-x))
(funcall l 'dummy-arg)))
=> (dynamic-x lexical-y dummy-arg)"
(declare (indent 1)
(debug (sexp body)))
(let* ((captured-values nil)
(body (dvc-capturing-lambda-helper body)))
`(list 'lambda ',args
(list 'apply
(lambda ,(append args (mapcar #'car captured-values))
. ,body)
,@(mapcar #'(lambda (arg) (list 'quote arg)) args)
(list 'quote (list ,@(mapcar #'cdr captured-values))))))))
(defun dvc-lexical-let-perform-replacement-in-source ()
"Replace instances of quoted lambda forms with `lexical-let'
in the current buffer."
(interactive)
(goto-char (point-min))
(while (search-forward "`(lambda" nil t)
(search-backward "(")
(save-excursion (forward-sexp 1) (insert ")"))
(backward-delete-char 1)
(insert "(lexical-let ")
(search-backward "(lex")
(let ((beginning (point))
(letlist "")
(namelist nil))
(forward-sexp 1)
(save-restriction
(narrow-to-region beginning (point))
(goto-char (point-min))
(while (search-forward "," nil t)
(backward-delete-char 1)
(let* ((beg (point))
(end (progn (forward-sexp 1) (point)))
(name (buffer-substring-no-properties beg end))
(var (concat (replace-regexp-in-string "[^a-zA-Z\\-]" "-"
name) "-lex")))
(when (not (member name namelist))
(push name namelist)
(setq letlist (concat
letlist (when (not (string= letlist ""))
" ")
"(" var " "
name
")")))
(delete-region beg end)
(goto-char beg)
(insert var)
))
(goto-char (point-min))
(search-forward "(lexical-let ")
(insert "(" letlist ")")
(newline-and-indent)))))
(defun dvc-capturing-lambda-perform-replacement-in-source ()
"Replace instances of quoted lambda forms with `dvc-capturing-lambda'
in the current buffer."
(interactive)
(goto-char (point-min))
(while (search-forward "`(lambda" nil t)
(delete-region (match-beginning 0) (match-end 0))
(insert "(dvc-capturing-lambda")
(search-backward "(")
(let ((beginning (point)))
(forward-sexp 1)
(save-restriction
(narrow-to-region beginning (point))
(goto-char (point-min))
(while (search-forward "," nil t)
(backward-delete-char 1)
(insert "(capture ")
(forward-sexp 1)
(insert ")"))))))
(provide 'dvc-lisp)
;;; dvc-lisp.el ends here

409
dvc/lisp/dvc-log.el
View File

@ -1,409 +0,0 @@
;;; dvc-log.el --- Manipulation of the log before committing
;; Copyright (C) 2005-2008, 2010 by all contributors
;; Author: Matthieu Moy <Matthieu.Moy@imag.fr>
;; Contributions from:
;; Stefan Reichoer, <stefan@xsteve.at>
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;
;;; Code:
(require 'dvc-unified)
(require 'ediff)
(require 'vc)
(defcustom dvc-log-edit-other-frame nil
"If non-nil, dvc-log-edit defaults to other-frame."
:type 'boolean
:group 'dvc)
;;
;; Log edit mode
;;
(defvar dvc-log-edit-font-lock-keywords
`(("^\t?\\* \\([^ ,:([\n]+\\)"
(1 'change-log-file-face)
("\\=, \\([^ ,:([\n]+\\)" nil nil
(1 'change-log-file-face))
("\\= (\\([^) ,:\n]+\\)" nil nil
(1 'change-log-list-face))
("\\=, *\\([^) ,:\n]+\\)" nil nil
(1 'change-log-list-face)))
;; (,(concat "^" (regexp-quote dvc-log-edit-file-list-marker) "$")
;; . 'dvc-header)
)
"Keywords in dvc-log-edit mode.")
(defvar dvc-log-edit-flush-prefix "## ")
(defvar dvc-log-edit-file-list-marker
"--This line, and those below, will be ignored--"
"A marker separating the actual log message from the list of files to commit.")
(defvar dvc-log-edit-init-functions (make-hash-table :test 'equal)
"A hash table that holds the mapping from work directory roots to
functions that provide the initial content for a commit.")
;; --------------------------------------------------------------------------------
;; Menus
;; --------------------------------------------------------------------------------
;;;###autoload
(define-derived-mode dvc-log-edit-mode text-mode "dvc-log-edit"
"Major Mode to edit DVC log messages.
Commands:
\\{dvc-log-edit-mode-map}
"
(setq dvc-buffer-current-active-dvc (dvc-current-active-dvc))
(use-local-map dvc-log-edit-mode-map)
(easy-menu-add dvc-log-edit-mode-menu)
(dvc-install-buffer-menu)
(set (make-local-variable 'font-lock-defaults)
'(dvc-log-edit-font-lock-keywords t))
(set (make-local-variable 'fill-paragraph-function)
'dvc-log-fill-paragraph)
(setq fill-column 73)
(when (eq (point-min) (point-max))
(dvc-log-edit-insert-initial-commit-message))
(run-hooks 'dvc-log-edit-mode-hook))
(define-key dvc-log-edit-mode-map [(control ?c) (control ?c)] 'dvc-log-edit-done)
(define-key dvc-log-edit-mode-map [(control ?c) (control ?d)] 'dvc-diff)
(define-key dvc-log-edit-mode-map [(control ?c) (control ?l)] 'dvc-log)
(define-key dvc-log-edit-mode-map [(control ?c) (control ?f)] 'dvc-log-insert-commit-file-list)
(define-key dvc-log-edit-mode-map [(control ?c) (control ?p)] 'dvc-buffer-pop-to-partner-buffer)
(define-key dvc-log-edit-mode-map [(control ?c) (control ?m)] 'dvc-log-edit-insert-memorized-log)
(define-key dvc-log-edit-mode-map [(control ?c) (control ?i)] 'dvc-log-edit-insert-initial-commit-message)
(easy-menu-define dvc-log-edit-mode-menu dvc-log-edit-mode-map
"`dvc-log-edit-mode' menu"
'("Log Edit"
["Show changes" dvc-diff t]
["Commit" dvc-log-edit-done t]
["Show Changelog" dvc-log t]
["Pop to partner buffer" dvc-buffer-pop-to-partner-buffer t]
["Insert/Flush commit file list" dvc-log-insert-commit-file-list t]
["Insert memorized log" dvc-log-edit-insert-memorized-log t]
"--"
["Abort" dvc-log-edit-abort t]))
;; Internal variables
(defvar dvc-pre-commit-window-configuration nil)
;;;###autoload
(defun dvc-dvc-log-edit (root other-frame no-init)
"Edit the log file for tree ROOT before a commit.
OTHER_FRAME if non-nil puts log edit buffer in a separate frame.
NO-INIT if non-nil suppresses initialization of the buffer if one
is reused."
(setq dvc-pre-commit-window-configuration
(current-window-configuration))
(let ((start-buffer (current-buffer)))
(dvc-switch-to-buffer
(dvc-get-buffer-create (dvc-current-active-dvc) 'log-edit root)
other-frame)
;; `no-init' is somewhat misleading here. It is set to t in
;; dvc-add-log-entry, and nil in dvc-log-edit. That prevents
;; changing dvc-partner-buffer when we shouldn't. But the user
;; might call dvc-log-edit multiple times from the same diff or
;; status buffer, and expect edits in the log-edit buffer to be
;; preserved.
(unless no-init
(let ((buffer-name (buffer-name))
(file-name (dvc-log-edit-file-name)))
(set-visited-file-name file-name t t)
;; `set-visited-file-name' modifies default-directory
(setq default-directory root)
;; Read in the current log file, unless the user has already
;; edited the buffer.
(when (and (= (point-min) (point-max)) (file-readable-p file-name))
(insert-file-contents file-name)
(set-buffer-modified-p nil))
(rename-buffer buffer-name)
(setq dvc-partner-buffer start-buffer)
(dvc-call "log-edit-mode")))))
(defun dvc-log-edit-abort ()
"Abort the current log edit."
(interactive)
(bury-buffer)
(set-window-configuration dvc-pre-commit-window-configuration))
(defun dvc-log-close (buffer)
"Close the log buffer, and delete the file."
(if vc-delete-logbuf-window
(kill-buffer buffer)
(quit-window))
(delete-file (dvc-log-edit-file-name)))
(defun dvc-log-flush-commit-file-list ()
"Remove the list of the files to commit.
All lines starting with `dvc-log-edit-flush-prefix' are deleted."
(interactive)
(save-excursion
(goto-char (point-min))
(flush-lines (concat "^" dvc-log-edit-flush-prefix))))
(defun dvc-log-fill-paragraph (&optional justify)
"Fill the paragraph, but preserve open parentheses at beginning of lines.
Prefix arg means justify as well."
(interactive "P")
(let ((end (progn (forward-paragraph) (point)))
(beg (progn (backward-paragraph) (point)))
(paragraph-start (concat paragraph-start "\\|\\s *\\s(")))
(fill-region beg end justify)
t))
(defun dvc-log-insert-commit-file-list (arg)
"Insert the file list that will be committed.
With a negative prefix argument just remove the file list
by calling `dvc-log-flush-commit-file-list'."
(interactive "p")
(if (< arg 0)
(dvc-log-flush-commit-file-list)
(let ((file-list (funcall (dvc-function (dvc-current-active-dvc) "dvc-files-to-commit")))
(mark))
(dvc-trace "Files to commit: %S" file-list)
(save-excursion
(goto-char (point-min))
(dvc-log-flush-commit-file-list)
(insert dvc-log-edit-flush-prefix)
(insert (format "Lines beginning with '%s' will be deleted from this buffer before committing\n" dvc-log-edit-flush-prefix))
(insert dvc-log-edit-flush-prefix)
(insert "Files to commit:\n")
(dolist (f file-list)
(setq mark (cdr (assoc (car f) '( (dvc-modified . "M ") (dvc-added . "A ") (dvc-deleted . "R ") ))))
(insert dvc-log-edit-flush-prefix)
(insert (dvc-face-add (concat mark (cdr f)) (car f)))
(newline))))))
(defun dvc-log-edit-insert-memorized-log ()
"Insert a memorized log message."
(interactive)
(when dvc-memorized-log-header
(goto-char (point-min))
(delete-region (point) (line-end-position))
(insert dvc-memorized-log-header))
(when dvc-memorized-log-message
(goto-char (point-min))
(end-of-line)
(newline)
(newline)
(when dvc-memorized-patch-sender
(if (looking-at "Patch from ")
(forward-line 1)
(progn
(undo-boundary)
(insert (format "Patch from %s\n" dvc-memorized-patch-sender)))))
(when (looking-at "\* .+: ") ;; e.g.: "* lisp/dvc.el: "
(end-of-line)
(newline))
(insert dvc-memorized-log-message)))
;;;###autoload
(defun dvc-add-log-entry (&optional other-frame)
"Add new ChangeLog style entry to the current DVC log-edit buffer.
If OTHER-FRAME xor `dvc-log-edit-other-frame' is non-nil,
show log-edit buffer in other frame."
(interactive "P")
(save-restriction
(dvc-add-log-entry-internal other-frame)))
(defun dvc-add-log-file-name (buffer-file)
"Return a file name for a log entry for BUFFER-FILE; including path from tree root.
For use as add-log-file-name-function."
;; This is better than the default algorithm in add-log-file-name,
;; when the log file is not in the workspace root (as is true for
;; monotone)
(if (string-match
(concat "^" (regexp-quote (dvc-tree-root)))
buffer-file)
(substring buffer-file (match-end 0))
(file-name-nondirectory buffer-file)))
(defun dvc-ediff-add-log-entry (&optional other-frame)
"Add new DVC log ChangeLog style entry; intended to be invoked
from the ediff control buffer."
(interactive "P")
(let ((dvc-temp-current-active-dvc dvc-buffer-current-active-dvc))
(set-buffer ediff-buffer-B) ; DVC puts workspace version here
(dvc-add-log-entry-internal other-frame)))
(defun dvc-ediff-setup ()
(define-key 'ediff-mode-map "t" 'dvc-ediff-add-log-entry)) ; matches dvc-diff-mode-map
;; ediff hooks that run after ediff-mode-map is created:
;; ediff-prepare-buffer-hook, ediff-startup-hook
(add-hook 'ediff-startup-hook 'dvc-ediff-setup)
(defun dvc-add-log-entry-internal (other-frame)
"Similar to `add-change-log-entry'.
Inserts the entry in the dvc log-edit buffer instead of the ChangeLog."
;; This is mostly copied from add-log.el. Perhaps it would be better to
;; split add-change-log-entry into several functions and then use them, but
;; that wouldn't work with older versions of Emacs.
;;
;; We don't set add-log-file-name-function globally because
;; dvc-diff-mode needs a different one.
(if (not (featurep 'add-log)) (require 'add-log))
(let* ((dvc-temp-current-active-dvc (dvc-current-active-dvc))
(add-log-file-name-function 'dvc-add-log-file-name)
(defun (add-log-current-defun))
(buf-file-name (if (and (boundp 'add-log-buffer-file-name-function)
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 (dvc-log-edit-file-name))
;; Set ENTRY to the file name to use in the new entry.
(entry (add-log-file-name buffer-file file-name))
beg
bound
narrowing)
(dvc-log-edit other-frame t)
(undo-boundary)
(goto-char (point-min))
(when (re-search-forward (regexp-opt
(list "^Patches applied:"
(regexp-quote
;; TODO
dvc-log-edit-file-list-marker)))
nil t)
(narrow-to-region (point-min) (match-beginning 0))
(setq narrowing t)
(goto-char (point-min)))
(re-search-forward "\n\n\\|\\'")
(setq beg (point))
(if (looking-at "\n*[^\n* \t]")
(progn
(skip-chars-forward "\n")
(setq bound (point)))
(goto-char (point-max))
(setq bound (point))
(unless (and (boundp 'add-log-keep-changes-together)
add-log-keep-changes-together)
(backward-paragraph) ; paragraph delimits entries for file
(forward-line 1)
(setq beg (point))))
(goto-char beg)
(forward-line -1)
;; Now insert the new line for this entry.
(cond ((re-search-forward "^\\s *\\*\\s *$" bound t)
;; Put this file name into the existing empty entry.
(if entry
(insert entry)))
((let (case-fold-search)
(re-search-forward
(concat (regexp-quote (concat "* " entry))
;; Don't accept `foo.bar' when
;; looking for `foo':
"\\(\\s \\|[(),:]\\)")
bound t))
;; Add to the existing entry for the same file.
(if (re-search-forward "^\\s *$\\|^\\s \\*" nil t)
(goto-char (match-beginning 0))
(goto-char (point-max))
(insert-char ?\n 1))
;; Delete excess empty lines; make just 2.
(while (and (not (eobp)) (looking-at "^\\s *$"))
(delete-region (point) (line-beginning-position 2)))
(insert-char ?\n 2)
(forward-line -2)
(indent-relative))
(t
;; Make a new entry.
(if dvc-log-insert-last
(progn
(goto-char (point-max))
(re-search-backward "^." nil t)
(end-of-line)
(insert "\n\n* ")
)
(forward-line 1)
(while (looking-at "\\sW")
(forward-line 1))
(while (and (not (eobp)) (looking-at "^\\s *$"))
(delete-region (point) (line-beginning-position 2)))
(insert-char ?\n 3)
(forward-line -2)
(indent-to left-margin)
(insert "* "))
(if entry (insert entry))))
(if narrowing (widen))
;; Now insert the function name, if we have one.
;; Point is at the entry for this file,
;; either at the end of the line or at the first blank line.
(if defun
(progn
;; Make it easy to get rid of the function name.
(undo-boundary)
(unless (save-excursion
(beginning-of-line 1)
(looking-at "\\s *$"))
(insert ?\ ))
;; See if the prev function name has a message yet or not
;; If not, merge the two entries.
(let ((pos (point-marker)))
(if (and (skip-syntax-backward " ")
(skip-chars-backward "):")
(looking-at "):")
(progn (delete-region (+ 1 (point)) (+ 2 (point))) t)
(> fill-column (+ (current-column) (length defun) 3)))
(progn (delete-region (point) pos)
(insert ", "))
(goto-char pos)
(insert "("))
(set-marker pos nil))
;; Check for previous function name using re-search-backward
;; instead of looking-back, because looking-back is not
;; implemented in all variants of (X)Emacs. We could create
;; a compatibility function for it, but nobody else seems to
;; use it yet, so there is no point.
(when (re-search-backward (concat (regexp-quote defun) ",\\s *\\=") nil t)
(replace-match ""))
(insert 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 ": ")))))
(defun dvc-log-edit-register-initial-content-function (working-copy-root the-function)
"Register a mapping from a work directory root to a function that provide the initial content for a commit."
(puthash (dvc-uniquify-file-name working-copy-root) the-function dvc-log-edit-init-functions))
(defun dvc-log-edit-insert-initial-commit-message ()
"Insert the initial commit message at point.
See `dvc-log-edit-register-initial-content-function' to register functions that provide the message text."
(interactive)
(let ((initial-content-function (gethash (dvc-uniquify-file-name (dvc-tree-root)) dvc-log-edit-init-functions)))
(when initial-content-function
(insert (funcall initial-content-function)))))
(provide 'dvc-log)
;;; dvc-log.el ends here

301
dvc/lisp/dvc-register.el
View File

@ -1,301 +0,0 @@
;;; dvc-register.el --- Registration of DVC back-ends
;; Copyright (C) 2005-2008 by all contributors
;; Author: Stefan Reichoer, <stefan@xsteve.at>
;; Contributions from: Matthieu Moy <Matthieu.Moy@imag.fr>
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; DVC Back-end registration
(require 'dvc-defs)
(require 'dvc-utils)
(defvar dvc-registered-backends nil
"List of registered back-ends.")
(defun dvc-intern-symbol-name (dvc postfix)
"Intern a symbol for DVC, add POSTFIX to the name.
A '-' is put between DVC and the POSTFIX.
Example: (dvc-intern-symbol-name 'xhg \"tree-root\") => xhg-tree-root"
(intern (concat (symbol-name dvc) "-" postfix)))
(defmacro dvc-register-dvc (dvc name)
"Register DVC, NAME is displayed for user interaction.
It's a macro, so it can be called without loading dvc-unified. The
build system inserts a (eval-when-compile (require 'dvc-unified))
at the beginning of the autoload file, so, the macro is available in
the autoloads."
;; make sure dvc-back-end-wrappers is defined.
(require 'dvc-unified)
(let ((wrappers-defs
(mapcar (lambda (wrapper)
(let* ((dvc-noquote (cadr dvc))
(name (nth 0 wrapper))
(symb (intern (concat (symbol-name
dvc-noquote)
"-"
name)))
(symb-dvc (intern (concat "dvc-"
name)))
(args (nth 1 wrapper))
(call-args (remove '&rest (remove '&optional args)))
(docstring (concat "Wrapper for dvc-" name
", for back-end "
(symbol-name dvc-noquote)
".")))
`(defun ,symb ,args
,docstring
(interactive)
(let ((dvc-temp-current-active-dvc ,dvc))
,(if call-args
`(if (interactive-p)
(call-interactively (quote ,symb-dvc))
(funcall (quote ,symb-dvc) ,@call-args))
`(call-interactively (quote ,symb-dvc)))))))
dvc-back-end-wrappers
)))
`(progn
(defvar dvc-registered-backends nil)
(add-to-list 'dvc-registered-backends ,dvc)
(defvar ,(intern (concat (symbol-name (cadr dvc))
"-backend-name"))
,name
,(concat "Human friendly name used for the dvc backend '"
(symbol-name (cadr dvc))
".\nThis variable was created by `dvc-register-dvc'"))
;; the hard thing is to make sure all back-ends define all
;; functions.
;; some dvc-register-dvc will be called before processing DVC
;; core's autoloads (_b_az, _b_zr, ...), some after (_x_hg,
;; _x_git, ...), since it's done in alphabetical order. here,
;; we make sure all functions are declared, and since
;; dvc-register-dvc is called for each back-end, we've got it.
,@wrappers-defs)))
(defvar dvc-backend-name "Unknown")
(defun dvc-function (dvc postfix &optional nodefault)
"Return the function for DVC backend concatenated with POSTFIX.
To be used with `apply' or `funcall'. If NODEFAULT is nil and no
function is available for this backend, use dvc-<postfix>
instead.
POSTFIX is a string."
(let ((res (dvc-intern-symbol-name dvc postfix)))
(if (or nodefault (fboundp res)) res
(let ((dvc-register-sym (intern (concat (symbol-name dvc) "-dvc"))))
(unless (featurep dvc-register-sym)
(dvc-trace "require %S" dvc-register-sym)
(if (featurep 'xemacs)
(require dvc-register-sym nil)
(require dvc-register-sym nil t))))
(let ((second-try (dvc-function dvc postfix t)))
(if (fboundp second-try) second-try
(let ((fall-back (dvc-intern-symbol-name 'dvc postfix)))
(if (not fall-back) second-try
(let ((result (dvc-intern-symbol-name 'dvc postfix)))
(if (fboundp result) result
(error "No definition and no fallback for %s-\"%s\""
(symbol-name dvc) postfix))))))))))
(defun dvc-variable (dvc postfix &optional nodefault)
"Get the value of a variable in a DVC backend.
If NODEFAULT is nil and no variable is available for this
backend, use dvc-<prefix> instead."
(let ((res (dvc-intern-symbol-name dvc postfix)))
(if (or nodefault (boundp res)) (eval res)
(let ((dvc-register-sym (intern (concat (symbol-name dvc) "-dvc"))))
(unless (featurep dvc-register-sym)
(dvc-trace "require %S" dvc-register-sym)
(if (featurep 'xemacs)
(require dvc-register-sym nil)
(require dvc-register-sym nil t))))
(let ((second-try (dvc-variable dvc postfix t)))
second-try))))
;;;###autoload
(defun dvc-apply (postfix &rest args)
"Apply ARGS to the `dvc-current-active-dvc' concated with POSTFIX."
;; dvc-current-active-dvc does not prompt for the local tree
(let ((current-dvc (dvc-current-active-dvc)))
(if current-dvc
;; We bind dvc-temp-current-active-dvc here so functions that
;; create new buffers and then call dvc-current-active-dvc
;; get the right back-end.
(let ((dvc-temp-current-active-dvc current-dvc))
(apply 'apply (dvc-function current-dvc postfix) args))
;; no current dvc found; prompt for tree
(let ((default-directory
(dvc-read-directory-name "Local tree: ")))
(if (dvc-current-active-dvc t)
(apply 'dvc-apply postfix args)
;; user thinks this directory is a DVC directory; don't just
;; keep prompting.
(error "%s is not a DVC managed directory" default-directory))))))
;;;###autoload
(defun dvc-call (postfix &rest args)
"Call the function specified by concatenating `dvc-current-active-dvc' and
POSTFIX, with arguments ARGS."
;; The &rest argument turns ARGS into a list for us
(dvc-apply postfix args))
(defvar dvc-current-active-dvc-cache (make-hash-table :test 'equal)
"A cache that contains directories as keys and the DVC symbol as value.
That value is considered first in `dvc-current-active-dvc'.")
(defvar dvc-buffer-current-active-dvc nil
"Tell DVC which back-end to use in some buffers.
Overrides the search for a control directory in `dvc-current-active-dvc'.")
(make-variable-buffer-local 'dvc-buffer-current-active-dvc)
(defvar dvc-temp-current-active-dvc nil
"Tell DVC which back-end to use temporarily.
Overrides the search for a control directory in
`dvc-current-active-dvc'. This is meant to be set in a let statement.")
(defun dvc-current-active-dvc (&optional nocache)
"Get the currently active dvc for the current `default-directory'.
Currently supported dvc's can be found in
`dvc-registered-backends'. If `dvc-prompt-active-dvc' is nil,
`dvc-select-priority' specifies the priority, if more than one
back-end is in use for `default-directory'.
If `dvc-prompt-active-dvc' is non-nil, `dvc-registered-backends'
specifies the list of back-ends to test for, and the user is
prompted when more than one is found. Note that
`dvc-registered-backends' defaults to all backends that DVC
supports; it may be customized to only those used.
The value found for each directory is cached in `dvc-current-active-dvc-cache'.
If NOCACHE is non-nil, ignore the cache for this call, but still
cache the result (useful for correcting an incorrect cache entry).
If either `dvc-temp-current-active-dvc' (a let-bound value)
or `dvc-buffer-current-active-dvc' (a buffer-local value) is non-nil,
then use that value instead of the cache or searching."
(interactive "P")
(or dvc-temp-current-active-dvc
dvc-buffer-current-active-dvc
(let (root
(dvc (unless nocache
(gethash (dvc-uniquify-file-name default-directory)
dvc-current-active-dvc-cache))))
(unless dvc
(if dvc-prompt-active-dvc
(let ((dvc-list dvc-registered-backends)
(options)
(tree-root-func))
(while dvc-list
(setq tree-root-func (dvc-function (car dvc-list) "tree-root" t))
(when (fboundp tree-root-func)
(let ((current-root (funcall tree-root-func nil t)))
(when current-root
;; WORKAROUND: ido-completing-read requires
;; strings, not symbols, in the options list.
(setq options (cons (list (symbol-name (car dvc-list)) current-root) options)))))
(setq dvc-list (cdr dvc-list)))
(case (length options)
(0
;; FIXME: In most situations we'd like to abort
;; with a nice error message here, but in others
;; (ie dvc-find-file-hook) we need to silently
;; return nil if there is no back-end found. Need
;; another arg.
(setq dvc nil))
(1
(setq dvc (intern (caar options))))
(t
;; We should use (dvc-variable (car option)
;; "backend-name") in the prompt and completion
;; list, but we can't go from that name back to the
;; dvc symbol; dvc-register-dvc needs to build an
;; alist. On the other hand, users use the symbol
;; name in setting `dvc-select-priority', so
;; perhaps this is better.
(let ((selection
(dvc-completing-read
(concat "back-end ("
(mapconcat (lambda (option) (car option)) options ", ")
"): ")
options nil t)))
(setq dvc (intern selection))
(setq root (cadr (assoc dvc options)))))))
;; not prompting
(let ((dvc-list (append dvc-select-priority dvc-registered-backends))
(tree-root-func))
(setq root "/")
(while dvc-list
(setq tree-root-func (dvc-function (car dvc-list) "tree-root" t))
(when (fboundp tree-root-func)
(let ((current-root (funcall tree-root-func nil t)))
(when (and current-root (> (length current-root) (length root)))
(setq root current-root)
(setq dvc (car dvc-list)))))
(setq dvc-list (cdr dvc-list)))))
(if dvc
;; cache the found dvc, for both default-directory and root,
;; since a previous call may have cached a different dvc for
;; the root.
(puthash (dvc-uniquify-file-name default-directory)
dvc dvc-current-active-dvc-cache)
(unless (string= root default-directory)
(puthash (dvc-uniquify-file-name root)
dvc dvc-current-active-dvc-cache))
(when (interactive-p)
(message "DVC: using %s for %s" dvc default-directory))))
dvc)))
(defun dvc-select-dvc (directory dvc)
"Select the DVC to use for DIRECTORY.
The given value is stored in `dvc-current-active-dvc-cache'."
(interactive (list (dvc-uniquify-file-name
(dvc-read-directory-name "Set dvc for path: " nil nil t))
(intern (dvc-completing-read
"dvc: "
(map t 'symbol-name
(append '(None) dvc-registered-backends))))))
(when (eq dvc 'None)
(message "Removing %s from dvc-current-active-dvc-cache" directory)
(setq dvc nil))
(puthash directory dvc dvc-current-active-dvc-cache))
(defun dvc-clear-dvc-cache ()
"Clear the dvc cache. Useful when changing to an alternate back-end."
(interactive)
(clrhash dvc-current-active-dvc-cache))
(provide 'dvc-register)
;;; dvc-register.el ends here

477
dvc/lisp/dvc-revlist.el
View File

@ -1,477 +0,0 @@
;;; dvc-revlist.el --- Revision list in DVC
;; Copyright (C) 2005-2009 by all contributors
;; Author: Matthieu Moy <Matthieu.Moy@imag.fr>
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; Generic stuff to display revision lists.
;; Revision lists are the core of the "decentralized" aspect of DVC.
;;; Code:
(eval-when-compile (require 'cl))
(eval-and-compile
(require 'dvc-lisp)
(require 'dvc-utils)
(require 'dvc-core)
)
(require 'dvc-ui)
;; Display parameters
(defvar dvc-revlist-brief nil)
(make-variable-buffer-local 'dvc-revlist-brief)
(defvar dvc-revlist-last-n nil
"Buffer-local value of dvc-log-last-n.")
(make-variable-buffer-local 'dvc-revlist-last-n)
(defvar dvc-revlist-path nil)
(make-variable-buffer-local 'dvc-revlist-path)
(defstruct (dvc-revlist-entry-patch)
dvc ;; the back-end
marked
struct ;; back-end struct
rev-id ;; DVC revision ID.
merged-by
log-buffer
diff-buffer)
(defvar dvc-revlist-cookie nil
"Ewoc cookie for dvc-revlist.")
;; elem of dvc-revlist-cookie should be one of:
;; ('separator "string" kind)
;; `kind' is: one of
;; partner: ???
;; bookmark: ???
;;
;; ('entry-patch struct)
;; `struct' is a dvc-revlist-entry-patch struct type.
;;
;; ('entry-change "changes")
;;
;; ('message "message")
;;
;; The second element tells if the element is marked or not.
(defun dvc-revlist-printer (elem)
"Print an element ELEM of the revision list."
(let ()
(case (car elem)
(entry-patch
(funcall
(dvc-function (dvc-revlist-entry-patch-dvc (nth 1 elem))
"revision-list-entry-patch-printer" t) (nth 1 elem)))
(entry-change (insert (cadr elem)))
(message (insert (dvc-face-add (cadr elem)
'dvc-messages)))
(separator
(case (car (cddr elem))
(partner (insert "\n" (dvc-face-add (cadr elem)
'dvc-separator)))
(bookmark (insert "\n" (dvc-face-add
(concat "*** "
(cadr elem)
" ***")
'dvc-separator) "\n")))))))
(dvc-make-move-fn ewoc-next dvc-revision-next
dvc-revlist-cookie)
(dvc-make-move-fn ewoc-prev dvc-revision-prev
dvc-revlist-cookie)
(dvc-make-move-fn ewoc-next dvc-revision-next-unmerged
dvc-revlist-cookie t)
(dvc-make-move-fn ewoc-prev dvc-revision-prev-unmerged
dvc-revlist-cookie t)
(defun dvc-revlist-current-patch ()
"Get the dvc-revlist-entry-patch at point."
(nth 1 (ewoc-data (ewoc-locate dvc-revlist-cookie))))
(defun dvc-revlist-current-patch-struct ()
"Get the dvc-revlist-entry-patch-struct at point."
(dvc-revlist-entry-patch-struct (dvc-revlist-current-patch)))
(defun dvc-revision-mark-revision ()
"Mark revision at point."
(interactive)
(let* ((pos (point))
(current (ewoc-locate
dvc-revlist-cookie))
(data (ewoc-data current)))
(setf (dvc-revlist-entry-patch-marked (nth 1 data)) t)
(ewoc-invalidate dvc-revlist-cookie current)
(goto-char pos)
(dvc-revision-next)))
(defun dvc-revision-marked-revisions ()
"Return the revisions that are currently marked."
(let ((acc '()))
(ewoc-map (lambda (x) (when (and (eq (car x) 'entry-patch)
(dvc-revlist-entry-patch-marked
(cadr x)))
(push (dvc-revlist-entry-patch-struct
(nth 1 x)) acc)))
dvc-revlist-cookie)
(nreverse acc)))
(defun dvc-revision-unmark-revision ()
"Unmark the revision at point."
(interactive)
(let* ((pos (point))
(current (ewoc-locate
dvc-revlist-cookie))
(data (ewoc-data current)))
(setf (dvc-revlist-entry-patch-marked (nth 1 data)) nil)
(ewoc-invalidate dvc-revlist-cookie current)
(goto-char pos)
(dvc-revision-next)))
;; TODO bind this to something
(defun dvc-revision-unmark-all ()
"Unmark all revisions."
(interactive)
(let ((pos (point)))
(ewoc-map (lambda (x) (when (and (eq (car x) 'entry-patch)
(nth 2 x))
(setcar (cddr x) nil)))
dvc-revlist-cookie)
(ewoc-refresh dvc-revlist-cookie)
(goto-char pos)))
(defcustom dvc-revisions-shows-summary t
"*Whether summary should be displayed for `dvc-revisions'."
:type 'boolean
:group 'tla-revisions)
(defcustom dvc-revisions-shows-creator t
"*Whether creator should be displayed for `dvc-revisions'."
:type 'boolean
:group 'tla-revisions)
(defcustom dvc-revisions-shows-date t
"*Whether date should be displayed for `dvc-revisions'."
:type 'boolean
:group 'tla-revisions)
(defun dvc-revision-refresh-maybe ()
(let ((refresh-fn
(dvc-function (dvc-current-active-dvc)
"revision-refresh-maybe" t)))
(when (fboundp refresh-fn)
(funcall refresh-fn))))
(defun dvc-revlist-toggle-date ()
"Toggle display of the date in the revision list."
(interactive)
(setq dvc-revisions-shows-date (not dvc-revisions-shows-date))
(dvc-revision-refresh-maybe)
(ewoc-refresh dvc-revlist-cookie))
(defun dvc-revlist-toggle-summary ()
"Toggle display of the summary information in the revision list."
(interactive)
(setq dvc-revisions-shows-summary (not dvc-revisions-shows-summary))
(dvc-revision-refresh-maybe)
(ewoc-refresh dvc-revlist-cookie))
(defun dvc-revlist-toggle-creator ()
"Toggle display of the creator in the revision list."
(interactive)
(setq dvc-revisions-shows-creator (not dvc-revisions-shows-creator))
(dvc-revision-refresh-maybe)
(ewoc-refresh dvc-revlist-cookie))
(defun dvc-revlist-more (&optional delta)
"If revision list was limited by `dvc-log-last-n', show more revisions.
Increment DELTA may be specified interactively; default 10."
(interactive (list (if current-prefix-arg (prefix-numeric-value current-prefix-arg) 10)))
(if dvc-revlist-last-n
(progn
(setq dvc-revlist-last-n (+ dvc-revlist-last-n delta))
(dvc-generic-refresh))))
(defun dvc-revlist-toggle-brief ()
"Toggle between brief and full revisions."
(interactive)
(setq dvc-revlist-brief (not dvc-revlist-brief))
(dvc-generic-refresh))
(defvar dvc-get-revision-info-at-point-function nil
"Variable should be local to each buffer.
Function used to get the revision info at point")
(defun dvc-get-info-at-point ()
"Get the version information that point is on."
(when (fboundp dvc-get-revision-info-at-point-function)
(funcall dvc-get-revision-info-at-point-function)))
(defun dvc-revlist-get-revision-at-point ()
"Retrieve the revision structure at point in a DVC revlist mode buffer."
(let* ((entry (dvc-revlist-entry-patch-rev-id
(nth 1 (ewoc-data (ewoc-locate dvc-revlist-cookie)))))
(type (dvc-revision-get-type entry))
(data (dvc-revision-get-data entry)))
(case type
(revision (nth 0 data))
(t (error "No revision at point")))))
(autoload 'dvc-revlog-revision "dvc-revlog")
(defun dvc-revlist-show-item (&optional scroll-down)
"Show a changeset for the current revision."
(interactive)
(let ((elem (ewoc-data (ewoc-locate
dvc-revlist-cookie)))
(dvc-temp-current-active-dvc (dvc-current-active-dvc)))
(case (car elem)
(entry-patch
;; reuse existing buffer if possible
(let ((buffer (dvc-revlist-entry-patch-log-buffer
(nth 1 elem)))
(log-buf (current-buffer)))
(if (and buffer (buffer-live-p buffer))
(dvc-buffer-show-or-scroll buffer scroll-down)
(setq buffer (setf (dvc-revlist-entry-patch-log-buffer
(nth 1 elem))
(dvc-revlog-revision
(dvc-revlist-entry-patch-rev-id (nth 1 elem)))))
(with-current-buffer buffer
;; goto the beginning of the shown buffer
(goto-char (point-min))))
(pop-to-buffer log-buf)))
;; TODO: untested.
(entry-change (let ((default-directory (car (cddr elem))))
(dvc-diff))))))
(defun dvc-revlist-show-item-scroll-down ()
(interactive)
(dvc-revlist-show-item t))
(dvc-make-bymouse-function dvc-revlist-show-item)
(defun dvc-revlist-diff (&optional scroll-down)
"Show the diff for the current revision."
(interactive)
(let ((elem (ewoc-data (ewoc-locate dvc-revlist-cookie))))
(unless (eq (car elem) 'entry-patch)
(error "Cursor is not on a revision."))
;; get the buffer from the ewoc structure.
(let ((buffer (dvc-revlist-entry-patch-diff-buffer
(nth 1 elem)))
(log-buf (current-buffer)))
(dvc-trace "buffer1=%S" buffer)
(if (and buffer (buffer-live-p buffer))
(dvc-buffer-show-or-scroll buffer scroll-down)
(setf (dvc-revlist-entry-patch-diff-buffer
(nth 1 elem))
(let* ((rev-id (dvc-revlist-entry-patch-rev-id (nth 1 elem)))
(rev-type (dvc-revision-get-type rev-id))
(rev-data (dvc-revision-get-data rev-id)))
(unless (eq rev-type 'revision)
(error "Only 'revision type is supported here. Got %S" rev-type))
(let* ((prev-rev-id `(,(car rev-id) (previous-revision
,(cadr rev-id) 1))))
;;(dvc-trace "prev-rev-id=%S" prev-rev-id)
;;(dvc-trace "rev-id=%S" rev-id)
(dvc-delta prev-rev-id rev-id))))
(setq buffer (dvc-revlist-entry-patch-diff-buffer
(nth 1 elem)))
(dvc-trace "buffer2=%S" buffer))
(with-current-buffer buffer
(setq dvc-partner-buffer log-buf))
(pop-to-buffer log-buf)
(setq dvc-partner-buffer buffer))))
(defun dvc-revlist-diff-to-current-tree (&optional scroll-down)
"Show the diff between the revision at point and the local tree."
(interactive)
(let ((elem (ewoc-data (ewoc-locate dvc-revlist-cookie))))
(unless (eq (car elem) 'entry-patch)
(error "Cursor is not on a revision."))
(dvc-diff (dvc-revlist-entry-patch-rev-id (nth 1 elem)) (dvc-tree-root) nil)))
(defun dvc-revlist-diff-scroll-down ()
(interactive)
(dvc-revlist-diff t))
(defvar dvc-revlist-mode-map
(let ((map (make-sparse-keymap)))
(define-key map [?g] 'dvc-generic-refresh)
(define-key map [tab] 'dvc-revision-next)
(define-key map [(control ?i)] 'dvc-revision-next)
(define-key map [(shift tab)] 'dvc-revision-prev)
(unless (featurep 'xemacs)
(define-key map [(shift iso-lefttab)] 'dvc-revision-prev)
(define-key map [(shift control ?i)] 'dvc-revision-prev))
(define-key map [?+] 'dvc-revlist-more)
(define-key map [?b] 'dvc-revlist-toggle-brief)
(define-key map [?n] 'dvc-revision-next)
(define-key map [?p] 'dvc-revision-prev)
(define-key map [?N] 'dvc-revision-next-unmerged)
(define-key map [?P] 'dvc-revision-prev-unmerged)
(define-key map [?A] 'dvc-send-commit-notification) ;; Mnemonic: announce
(define-key map [?E] 'dvc-export-via-email)
(define-key map "\C-m" 'dvc-revlist-show-item)
(define-key map [return] 'dvc-revlist-show-item)
(define-key map [(meta return)] 'dvc-revlist-show-item-scroll-down)
(define-key map [?=] 'dvc-revlist-diff)
(define-key map [(control ?=)] 'dvc-revlist-diff-to-current-tree)
(define-key map [(meta ?=)] 'dvc-revlist-diff-scroll-down)
(define-key map (dvc-prefix-toggle ?d) 'dvc-revlist-toggle-date)
(define-key map (dvc-prefix-toggle ?c) 'dvc-revlist-toggle-creator)
(define-key map (dvc-prefix-toggle ?s) 'dvc-revlist-toggle-summary)
(define-key map dvc-keyvec-mark 'dvc-revision-mark-revision)
(define-key map dvc-keyvec-unmark 'dvc-revision-unmark-revision)
(define-key map dvc-keyvec-quit 'dvc-buffer-quit)
(define-key map (dvc-prefix-buffer ?p) 'dvc-show-process-buffer)
(define-key map (dvc-prefix-buffer ?L) 'dvc-open-internal-log-buffer)
(define-key map (dvc-prefix-buffer dvc-key-show-bookmark) 'dvc-bookmarks)
(define-key map (dvc-prefix-merge ?u) 'dvc-revlist-update)
(define-key map (dvc-prefix-merge ?U) 'dvc-update)
(define-key map (dvc-prefix-merge ?m) '(lambda () (interactive) (dvc-missing nil default-directory)))
(define-key map (dvc-prefix-merge ?M) 'dvc-merge)
(define-key map dvc-keyvec-inventory 'dvc-pop-to-inventory)
(define-key map [?h] 'dvc-buffer-pop-to-partner-buffer)
(define-key map dvc-keyvec-help 'describe-mode)
(define-key map dvc-keyvec-kill-ring nil)
(define-key map (dvc-prefix-kill-ring ?l) 'dvc-revision-save-log-message-as-kill)
map))
(easy-menu-define dvc-revlist-mode-menu dvc-revlist-mode-map
"`dvc-revlist' menu"
'("DVC-Revlist"
["Diff single rev" dvc-revlist-diff t]
["Diff with workspace" dvc-revlist-diff-to-current-tree t]
["Update to rev at point" dvc-revlist-update t]
["Update to head" dvc-update t]
["Merge" dvc-merge t]
["Show missing" (lambda () (interactive) (dvc-missing nil default-directory)) t]
))
;; dvc-revlist-create-buffer will use "<back-end>-revlist-mode", if
;; defined, instead of this one. If so, it should be derived from
;; dvc-revlist-mode (via `define-derived-mode'), and rely on it for as
;; many features as possible (one can, for example, extend the menu
;; and keymap). See `xmtn-revlist-mode' in xmtn-revlist.el for a good
;; example.
;;
;; Remember to add the new mode to
;; `uniquify-list-buffers-directory-modes' using
;; `dvc-add-uniquify-directory-mode'.
(define-derived-mode dvc-revlist-mode fundamental-mode
"dvc-revlist"
"Major mode to show revision list.
Commands are:
\\{dvc-revlist-mode-map}"
(setq dvc-buffer-current-active-dvc (dvc-current-active-dvc))
(dvc-install-buffer-menu)
(let ((inhibit-read-only t))
(erase-buffer))
(set (make-local-variable 'dvc-revlist-cookie)
(ewoc-create (dvc-ewoc-create-api-select
#'dvc-revlist-printer)))
(toggle-read-only 1)
(buffer-disable-undo)
(setq truncate-lines t)
(set-buffer-modified-p nil)
(set (make-local-variable 'dvc-get-revision-info-at-point-function)
'dvc-revlist-get-rev-at-point))
(dvc-add-uniquify-directory-mode 'dvc-revlist-mode)
(defun dvc-revlist-create-buffer (back-end type location refresh-fn brief last-n)
"Create (or reuse) and return a buffer to display a revision list.
BACK-END is the the back-end.
TYPE must be in dvc-buffer-type-alist.
LOCATION is root or a buffer name, depending on TYPE."
(let ((dvc-temp-current-active-dvc back-end)
(buffer (dvc-get-buffer-create back-end type location)))
(with-current-buffer buffer
(funcall (dvc-function back-end "revlist-mode"))
(setq dvc-buffer-refresh-function refresh-fn)
(setq dvc-revlist-brief brief)
(setq dvc-revlist-last-n last-n))
buffer))
(defun dvc-build-revision-list (back-end type location arglist parser
brief last-n path refresh-fn)
"Runs the back-end BACK-END to build a revision list.
A buffer of type TYPE with location LOCATION is created or reused.
The back-end is launched with the arguments ARGLIST, and the
caller has to provide the function PARSER which will actually
build the revision list.
BRIEF, if non-nil, means show a brief entry for each revision;
nil means show full entry.
LAST-N limits the number of revisions to display; all if nil.
PATH, if non-nil, restricts the log to that file.
REFRESH-FN specifies the function to call when the user wants to
refresh the revision list buffer. It must take no arguments."
(let ((buffer (dvc-revlist-create-buffer back-end type location refresh-fn brief last-n)))
(with-current-buffer buffer
(setq dvc-revlist-path path)
(setq dvc-revlist-brief brief)
(setq dvc-revlist-last-n last-n))
(dvc-switch-to-buffer-maybe buffer t)
(dvc-run-dvc-async
back-end arglist
:finished
(dvc-capturing-lambda (output error status arguments)
(with-current-buffer output
(funcall (capture parser) (capture buffer) (capture location))))
:error
;; TODO handle error messages, only treat the bzr missing command
;; like this (errorcode=1)
(dvc-capturing-lambda (output error status arguments)
(with-current-buffer output
(funcall (capture parser) (capture buffer) (capture location)))))))
(defun dvc-revision-log-message-at-point ()
(dvc-call "revision-st-message" (dvc-revlist-current-patch-struct)))
(defun dvc-revision-save-log-message-as-kill ()
"Save the log message for the actual patch."
(interactive)
(kill-new (dvc-revision-log-message-at-point)))
;; TODO: (message "Copied log message for %s" (tla-changelog-revision-at-point)))
(defun dvc-revlist-update ()
"Update current workspace to revision at point"
(interactive)
(dvc-update (dvc-revlist-entry-patch-rev-id (dvc-revlist-current-patch))))
(provide 'dvc-revlist)
;;; dvc-revlist.el ends here

98
dvc/lisp/dvc-revlog.el
View File

@ -1,98 +0,0 @@
;;; dvc-revlog.el --- View a single log entry in DVC
;; Copyright (C) 2005-2008 by all contributors
;; Author: Matthieu Moy <Matthieu.Moy@imag.fr>
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;
;;; Code:
(require 'dvc-ui)
(defvar dvc-revlog-mode-map
(let ((map (make-sparse-keymap)))
(define-key map [?g] 'dvc-generic-refresh)
(define-key map dvc-keyvec-quit 'dvc-buffer-quit)
map))
(define-derived-mode dvc-revlog-mode fundamental-mode
"dvc-revlog"
"Major mode to show a single log entry.
This mode is the DVC common denominator of the back-ends, and is
therefore pretty trivial, but each back-end will have to derive
it to something more specific.
Commands are:
\\{dvc-revlog-mode-map}"
(setq dvc-buffer-current-active-dvc (dvc-current-active-dvc))
(dvc-install-buffer-menu)
(toggle-read-only 1))
(dvc-add-uniquify-directory-mode 'dvc-revlog-mode)
(defun dvc-revlog-show-revision (back-end source-buffer buffer-name)
"Use the content of SOURCE-BUFFER to display a revlog.
Create a new buffer named from BUFFER-NAME."
(let ((buffer (dvc-get-buffer-create
back-end 'revlog buffer-name)))
(dvc-switch-to-buffer buffer)
(insert-buffer-substring source-buffer)
(funcall (dvc-function back-end "revlog-mode"))
buffer))
(defun dvc-revlog-revision (rev-id)
"Show the log for REV-ID.
Call `dvc-revlog-revision-in-buffer' to get the content, and display
it in revlog-mode."
(with-temp-buffer
(insert (dvc-revlog-revision-in-buffer rev-id))
(dvc-revlog-show-revision (dvc-revision-get-dvc rev-id)
(current-buffer)
(dvc-revision-to-string rev-id))))
(defun dvc-revlog-revision-in-buffer (rev-id)
"Get the log message for revision REV-ID.
Return the log message as a string.
REV-ID is as defined in docs/DVC-API. The behavior is similar to the
one of `dvc-revision-get-file-in-buffer', but for log entries instead
of file contents.
Currently, only 'revision type is supported."
(dvc-trace "dd-ib=%S" default-directory)
(dvc-trace "rev-id=%S" rev-id)
(let ((type (dvc-revision-get-type rev-id)))
(unless (eq type 'revision)
(error "rev-id %S not supported by dvc-revision-revlog"
type))
(funcall (dvc-function (dvc-revision-get-dvc rev-id)
"dvc-revlog-get-revision")
rev-id)))
(provide 'dvc-revlog)
;;; dvc-revlog.el ends here

39
dvc/lisp/dvc-site.el.in
View File

@ -1,39 +0,0 @@
;;; dvc-site.el.in --- Site-specific configuration for DVC (generated by ./configure)
;; Copyright (C) 2005 Matthieu Moy
;; Author: Matthieu Moy <Matthieu.Moy@imag.fr>
;; Keywords: convenience
;; DVC is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; DVC file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; Variables tla-*** of dvc-defs.el and other *-defs.el for which the
;; configure script can provide a value have their tla-site-*** dual
;; here. It is set by configure, and will be used as default value in
;; dvc-defs.el
;;; Code:
(defvar dvc-site-tla-executable "@TLA@")
(defvar dvc-site-baz-executable "@BAZ@")
(defvar dvc-site-diff-executable "@DIFF@")
(defvar dvc-site-patch-executable "@PATCH@")
(defvar dvc-site-arch-branch '@ARCH_BRANCH@)
(provide 'dvc-site)
;;; dvc-site.el ends here

95
dvc/lisp/dvc-state.el
View File

@ -1,95 +0,0 @@
;;; dvc-state.el --- saving and loading state variables between Emacs sessions
;; Copyright (C) 2006-2008 by all contributors
;; This file is part of DVC.
;;
;; DVC is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; DVC is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; `dvc-save-state' is for saving to a state file.
;; `dvc-load-state' is for loading from a state file.
;;; Code:
(require 'dvc-utils)
(require 'dvc-defs)
(require 'dvc-config)
(defgroup dvc-state nil
"Saving DVC's state between Emacs sessions."
:group 'dvc)
(defcustom dvc-state-file-name "state.el"
"*File in which DVC saves state variables between Emacs sessions.
The file is stored in the `dvc-config-directory'"
:type 'file
:group 'dvc-state)
(defcustom dvc-state-variables-list '(dvc-tips-number)
"*List of variables to store in the state file `dvc-state-file-name'."
:type '(repeat (symbol))
:group 'dvc-state)
;;;###autoload
(defun dvc-save-state (&optional vars state-file pp)
"Save variables from VARS list to file STATE-FILE.
The default for VARS is `dvc-state-variables-list'
The default for STATE-FILE is `dvc-state-file-name'.
If PP is non-nil use `dvc-pp-to-string' to format object.
The file will contain a setq setting the vars during loading by
`dvc-load-state'."
(let ((state-file (or state-file
(expand-file-name dvc-state-file-name
dvc-config-directory)))
(vars (or vars dvc-state-variables-list))
v)
(if (not (file-exists-p (file-name-directory state-file)))
(make-directory (file-name-directory state-file) t))
(save-excursion
(set-buffer (get-buffer-create " *dvc-state*"))
(erase-buffer)
(insert ";; Generated file. Do not edit!!!\n(setq\n")
(if pp
(while vars
(setq v (car vars) vars (cdr vars))
(insert (format "%s\n'%s"
(symbol-name v)
(dvc-pp-to-string (symbol-value v)))))
(while vars
(setq v (car vars) vars (cdr vars))
(insert (format " %s '%S\n"
(symbol-name v)
(symbol-value v)))))
(insert " )")
(write-region (point-min) (point-max) state-file))))
;;;###autoload
(defun dvc-load-state (&optional state-file)
"Load STATE-FILE (default `dvc-state-file-name`), i.e. evaluate its content."
(let ((state-file (or state-file
(expand-file-name dvc-state-file-name
dvc-config-directory))))
(if (file-exists-p state-file)
(load state-file nil t t))))
(provide 'dvc-state)
;; Local Variables:
;; End:
;;; dvc-state.el ends here

249
dvc/lisp/dvc-status.el
View File

@ -1,249 +0,0 @@
;;; dvc-status.el --- A generic status mode for DVC
;; Copyright (C) 2007 - 2009, 2011 by all contributors
;; Author: Stephen Leake, <stephen_leake@stephe-leake.org>
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;
;;; Code:
(require 'dvc-ui)
(require 'dvc-defs)
(require 'dvc-core)
(require 'dvc-fileinfo)
(require 'uniquify)
(defcustom dvc-status-display-known nil
"If non-nil, display files with 'known' status in dvc-status buffer."
:type 'boolean
:group 'dvc)
(defcustom dvc-status-display-ignored nil
"If non-nil, display files with 'ignored' status in dvc-status buffer."
:type 'boolean
:group 'dvc)
(defvar dvc-status-mode-map
(let ((map (make-sparse-keymap)))
;; grouped by major function, then alphabetical by dvc-keyvec name
;; workspace operations
(define-key map dvc-keyvec-add 'dvc-fileinfo-add-files)
(define-key map dvc-keyvec-commit 'dvc-log-edit)
(define-key map [?=] 'dvc-diff-diff)
(define-key map "E" 'dvc-fileinfo-toggle-exclude)
(define-key map "\M-e" 'dvc-edit-exclude)
(define-key map dvc-keyvec-ediff 'dvc-status-ediff)
(define-key map dvc-keyvec-help 'describe-mode)
(define-key map dvc-keyvec-logs 'dvc-log)
(define-key map "l" 'dvc-diff-log-single)
(define-key map "R" 'dvc-fileinfo-rename)
(define-key map "t" 'dvc-fileinfo-add-log-entry)
(define-key map dvc-keyvec-mark 'dvc-fileinfo-mark-file)
(define-key map dvc-keyvec-mark-all 'dvc-fileinfo-mark-all)
(define-key map dvc-keyvec-next 'dvc-fileinfo-next)
(define-key map dvc-keyvec-previous 'dvc-fileinfo-prev)
(define-key map dvc-keyvec-quit 'dvc-buffer-quit)
(define-key map dvc-keyvec-refresh 'dvc-generic-refresh)
(define-key map dvc-keyvec-revert 'dvc-fileinfo-revert-files)
(define-key map dvc-keyvec-unmark 'dvc-fileinfo-unmark-file)
(define-key map dvc-keyvec-unmark-all 'dvc-fileinfo-unmark-all)
(define-key map [?i] 'dvc-fileinfo-ignore-files)
(define-key map [?I] 'dvc-ignore-file-extensions-in-dir)
(define-key map "\M-I" 'dvc-ignore-file-extensions)
(define-key map (dvc-prefix-tagging-method ?e) 'dvc-edit-ignore-files)
(define-key map [?k] 'dvc-fileinfo-kill)
(define-key map dvc-keyvec-remove 'dvc-fileinfo-remove-files)
(define-key map "\r" 'dvc-find-file-other-window)
(define-key map "\M-d" 'dvc-status-dtrt)
;; database operations
(define-key map (dvc-prefix-merge ?u) 'dvc-update)
(define-key map (dvc-prefix-merge ?m) 'dvc-missing)
(define-key map (dvc-prefix-merge ?M) 'dvc-merge)
map)
"Keymap used in `dvc-status-mode'.")
(easy-menu-define dvc-status-mode-menu dvc-status-mode-map
"`dvc-status' menu"
`("DVC"
["Refresh Buffer" dvc-generic-refresh t]
["Edit log before commit" dvc-log-edit t]
["Quit" dvc-buffer-quit t]
("Merge/Update"
["Update" dvc-update t]
["Show missing" dvc-missing t]
["Merge" dvc-merge t]
)
("Mark"
["Mark File" dvc-fileinfo-mark-file t]
["Mark all" dvc-fileinfo-mark-all t]
["Unmark File" dvc-fileinfo-unmark-file t]
["Unmark all" dvc-fileinfo-unmark-all t]
)
("Ignore"
["Ignore Files" dvc-fileinfo-ignore-files t]
["Ignore Extensions in dir" dvc-ignore-file-extensions-in-dir t]
["Ignore Extensions globally" dvc-ignore-file-extensions t]
["Edit Ignore File" dvc-edit-ignore-files t]
)
("Exclude"
["Exclude File" dvc-fileinfo-toggle-exclude t]
["Edit Exclude File" dvc-edit-exclude t]
)
["Do the Right Thing" dvc-status-dtrt t]
["Add File" dvc-fileinfo-add-files t]
["Ediff File" dvc-status-ediff t]
["diff File" dvc-diff-diff t]
["Delete File" dvc-fileinfo-remove-files t]
["Kill File" dvc-fileinfo-kill t]
["Rename File" dvc-fileinfo-rename t]
["Revert File" dvc-fileinfo-revert-files t]
["Edit File" dvc-find-file-other-window t]
["Add log entry" dvc-fileinfo-add-log-entry t]
["Log (single file)" dvc-diff-log-single t]
["Log (full tree)" dvc-log t]
))
;; "<back-end>-status-mode", if defined, will be used instead of this
;; one. If so, it should be derived from dvc-status-mode (via
;; `define-derived-mode'), and rely on it for as many features as
;; possible (one can, for example, extend the menu and keymap).
;; Remember to add the new mode to uniquify-list-buffers-directory-modes
(define-derived-mode dvc-status-mode fundamental-mode "dvc-status"
"Major mode to display workspace status."
(setq dvc-buffer-current-active-dvc (dvc-current-active-dvc))
(setq dvc-fileinfo-ewoc (ewoc-create 'dvc-fileinfo-printer))
(set (make-local-variable 'dvc-get-file-info-at-point-function) 'dvc-fileinfo-current-file)
(use-local-map dvc-status-mode-map)
(easy-menu-add dvc-status-mode-menu)
(dvc-install-buffer-menu)
(setq buffer-read-only t)
(buffer-disable-undo)
(set-buffer-modified-p nil))
(when (boundp 'uniquify-list-buffers-directory-modes)
(add-to-list 'uniquify-list-buffers-directory-modes 'dvc-status-mode))
(defun dvc-status-prepare-buffer (dvc root base-revision branch header-more refresh)
"Prepare and return a status buffer. Should be called by <back-end>-dvc-status.
Calls <back-end>-status-mode.
DVC is back-end.
ROOT is absolute path to workspace.
BASE-REVISION is a string identifying the workspace's base revision.
BRANCH is a string identifying the workspace's branch.
HEADER-MORE is a function called to add other text to the ewoc header;
it should return a string.
REFRESH is a function that refreshes the status; see `dvc-buffer-refresh-function'."
(let ((status-buffer (dvc-get-buffer-create dvc 'status root)))
(dvc-kill-process-maybe status-buffer)
(with-current-buffer status-buffer
(let ((inhibit-read-only t)) (erase-buffer))
(let ((dvc-temp-current-active-dvc dvc))
(funcall (dvc-function dvc "status-mode")))
(let ((header (concat
(format "Status for %s:\n" root)
(format " base revision : %s\n" base-revision)
(format " branch : %s\n" branch)
(if (functionp header-more) (funcall header-more))))
(footer ""))
(set (make-local-variable 'dvc-buffer-refresh-function) refresh)
(ewoc-filter dvc-fileinfo-ewoc (lambda (elem) nil))
(ewoc-set-hf dvc-fileinfo-ewoc header footer)
(ewoc-enter-last dvc-fileinfo-ewoc (make-dvc-fileinfo-message :text (format "Running %s..." dvc)))
(ewoc-refresh dvc-fileinfo-ewoc)))
(dvc-switch-to-buffer-maybe status-buffer)))
(defun dvc-status-dtrt (prefix)
"Do The Right Thing in a status buffer; update, commit, resolve
conflicts, and/or ediff current files."
(interactive "P")
(let (status)
;; Note that message elements cannot be marked. Make sure all
;; selected files need the same action.
(if (< 1 (length (dvc-fileinfo-marked-files)))
(ewoc-map (lambda (fileinfo)
(etypecase fileinfo
(dvc-fileinfo-message
nil)
(dvc-fileinfo-file ; also matches dvc-fileinfo-dir
(if (dvc-fileinfo-file-mark fileinfo)
(if status
(if (not (equal status (dvc-fileinfo-file-status fileinfo)))
(error "cannot Do The Right Thing on files with different status"))
(setq status (dvc-fileinfo-file-status fileinfo))))
;; don't redisplay the element
nil)))
dvc-fileinfo-ewoc)
(setq status (dvc-fileinfo-file-status (dvc-fileinfo-current-fileinfo))))
(ecase status
(added
(dvc-fileinfo-add-log-entry prefix))
((deleted rename-source rename-target)
(dvc-status-ediff))
(missing
;; File is in database, but not in workspace
(ding)
(dvc-offer-choices (concat (dvc-fileinfo-current-file) " does not exist in working directory")
'((dvc-fileinfo-revert-files "revert")
(dvc-fileinfo-remove-files "remove")
(dvc-fileinfo-rename "rename"))))
(modified
;; Don't offer undo here; not a common action
;; Assume user has started the commit log frame
(if (< 1 (length (dvc-fileinfo-marked-files)))
(error "cannot diff more than one file"))
(dvc-status-ediff))
(unknown
(dvc-offer-choices nil
'((dvc-fileinfo-add-files "add")
(dvc-fileinfo-ignore-files "ignore")
(dvc-fileinfo-remove-files "remove")
(dvc-fileinfo-rename "rename"))))
)))
(defun dvc-status-inventory-done (status-buffer)
(with-current-buffer status-buffer
(ewoc-enter-last dvc-fileinfo-ewoc (make-dvc-fileinfo-message :text "Parsing inventory..."))
(ewoc-refresh dvc-fileinfo-ewoc)
(dvc-redisplay)
;; delete "running", "parsing" from the ewoc now, but don't
;; refresh until the status is displayed
(dvc-fileinfo-delete-messages)))
(defun dvc-status-ediff ()
"Run ediff on the current workspace file, against the database version."
(interactive)
;; FIXME: need user interface to specify other revision to diff
;; against. At least BASE and HEAD.
(let ((dvc-temp-current-active-dvc dvc-buffer-current-active-dvc))
(dvc-file-ediff (dvc-fileinfo-current-file))))
(provide 'dvc-status)
;;; end of file

290
dvc/lisp/dvc-tips.el
View File

@ -1,290 +0,0 @@
;;; dvc-tips.el --- "Tip of the day" feature for DVC.
;; Copyright (C) 2004-2008 by all contributors
;; Author: Matthieu Moy <Matthieu.Moy@imag.fr>
;; Keywords: convenience
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; To raise the learning curve for DVC users. Some commands can
;; (optionaly) pop-up a buffer with a tip. Currently, `dvc-commit'
;; does this.
;;; History:
;;
;; Created on October 2004 by Matthieu MOY
;;; Code:
(defconst dvc-tips-array
[
"Welcome to DVC. I'm the tip buffer. I will appear from time to time
to show you interesting features that you may have missed! Disable me
by setting the variable `dvc-tips-enabled' to nil.
Press q to exit, n to view next tip, p to view previous tip."
"DVC.el provides high level interfaces to various distributed revision
control systems. It currently supports:
* bzr: bzr
* tla: tla (Gnu Arch)
* xhg: hg (Mercurial)
* xmtn: Monotone
* xgit: git
* xdarcs: darcs"
"The following functions are the main entry points:
M-x dvc-status
M-x dvc-diff
M-x dvc-changelog
"
"Most interesting commands are available through a global keyboard
shortcut. Try \"C-x V C-h\" to get a list"
"DVC.el provides several major modes for different buffers. Each mode
has its own keybindings. Get help with \"C-h m\""
"When DVC.el is loaded, C-M-h in a minibuffer prompt gives you help
about the command being run."
"Report bugs using M-x dvc-submit-bug-report RET"
"Submitting a patch is very easy:
Just make the needed changes to your checked out copy and do
M-x dvc-submit-patch RET"
"You can add changelog style comments to your commit log by \"C-x V a\"."
"Currently the tips are mostly tailored towards tla since Xtla was
the starting point for DVC.el
We accept new tips and like to integrate them to the tips list.
Please send your tip to dvc-dev@gna.org."
"For the available tla commands Xtla provides a corresponding interactive
function.
Some examples:
M-x tla-inventory ... runs tla inventory
M-x tla-undo ... runs tla undo
M-x tla-changes ... runs tla changes
Xtla prompts for the needed parameters."
"When you are prompted for an archive, category, branch, version or
revision name, lots of keybindings are available. Get a list with \"C-h\"."
"Xtla allows you to manage a list of bookmarks. Try \"C-x V b\" and add
bookmarks from the menu. You may also add bookmarks from an archives,
category, version or revision buffer as well as from the tla-browse
buffer."
"From the bookmark buffer, you can select some bookmarks and make
them partners with M-p. Afterwards, pressing 'M m' on a bookmark will
show you the missing patches from his partners."
"You can enable ispell, flyspell or other useful mode for editing
log files by \"M-x customize-variable RET tla-log-edit-mode-hook RET\"."
"By default, Xtla caches any log file you retrieve with
`tla-revlog' or `tla-cat-archive-log' in ~/.arch-log-library. This
speeds up many Xtla operations.
You can disable this by setting `tla-log-library-greedy' to nil."
"Xtla can use both tla and bazaar implementations of GNU Arch.
\"M-x customize-variable RET tla-arch-branch RET\" to choose.
\"M-x tla-use-tla RET\" and \"M-x tla-use-baz RET\" to switch.
See bazaar homepage for more info on bazaar:
http://bazaar.canonical.com/"
"Xtla is highly customizable.
Start it by \"M-x customize-group RET xtla RET\"."
"In a *tla-changes* buffer you can quickly jump to the source file by
\"RET\", or view the source file in another window by \"v\", or start
an ediff session by \"e\" to inspect/reject parts of the changes."
"In a *tla-changes* buffer, you can quickly jump from the list of
files to the corresponding patch hunk, and come back with \"j\""
"From a revision list buffer or a *tla-changes* buffer, \"=\" will
show the diffs for the thing at point. M-= and M-RET allows you to
navigate in this diff while keeping your cursor in the same buffer."
"After committing, you can review the last committed patch with
\"M-x tla-changes-last-revision RET\".
Usefull to review and fix a patch you've just merged without mixing
manual modifications and merge in the same patch."
"After a merge, typing \"C-c m\" in the log buffer will generate
for you a summary line, keyword and body. This is highly
customizable."
"You've got a nice, graphical, archive browser one M-x tla-browse
RET away."
"In the bookmark buffer, pressing \"C-x C-f\" starts with the local
tree of the bookmark at point for the default directory."
"SMerge mode is an Emacs minor mode usefull to resolve conflicts
after a --three-way merge. Xtla will enter this mode automatically
when you open a file with conflicts. Type M-x tla-conflicts-finish RET
to exit smerge mode and delete the corresponding .rej file."
"\"C-x V e\" in a source file will open an ediff session with the
unmodified version of the file. From here, you can undo patch hunks
one by one with the key \"b\""
"In the *tree-lint* buffer, with your cursor on a message, most
commands will apply to all the files listed under this message."
"M-x baz-annotate RET will show you an annotated version of your
source file to track the origin of each line of code."
"After running M-x baz-annotate RET, you cat run
M-x baz-trace-line RET => Gives you the revision in which the line was
last modified in the minibuffer.
M-x baz-trace-line-show-log RET => Displays the log file of this
revision."
"Xtla is well integrated with Gnus. Revision names are buttonized,
you can apply a changeset sent to you as attachment easily, ...
Add
(tla-insinuate-gnus)
to your ~/.gnus.el or your ~/.emacs.el."
]
"List of tips. Add more !")
(defvar dvc-tips-number 0
"Number of the last tip viewed.
Will be saved in state.el")
(defun dvc-tips-message-number (number)
"Return the message number NUMBER, as a string."
(let ((number (mod number (length dvc-tips-array))))
(aref dvc-tips-array number)))
;;
;; Tips mode
;;
(defvar dvc-tips-mode-map
(let ((map (make-sparse-keymap)))
(define-key map dvc-keyvec-quit 'dvc-buffer-quit)
(define-key map dvc-keyvec-next 'dvc-tips-next-tip)
(define-key map dvc-keyvec-previous 'dvc-tips-previous-tip)
(define-key map [?c] 'dvc-tips-customize)
map))
(define-derived-mode dvc-tips-mode fundamental-mode "dvc-tips"
"Major mode for buffers displaying tip of the day.
Commands:
\\{dvc-tips-mode-map}"
(toggle-read-only 1))
(defun dvc-tips-popup-number (number &optional noswitch)
"Pops up tip number NUMBER."
(let ((message (dvc-tips-message-number number)))
(switch-to-buffer (dvc-get-buffer-create 'dvc 'tips))
(dvc-tips-mode)
(let ((inhibit-read-only t))
(erase-buffer)
(insert (dvc-face-add
"************************* Did you know? *************************"
'dvc-messages)
"\n\n")
(insert message)
(newline 2)
(insert (dvc-face-add
"*********************************************************************"
'dvc-messages))
(goto-char (point-min))
)
(when (and (not noswitch) (eq dvc-switch-to-buffer-mode 'single-window))
;; If mode is single-window, switch to another window (and if
;; necessary, split the frame) anyway.
(when (= (length (window-list)) 1)
(split-window-vertically))
(other-window 1))))
(defun dvc-tips-popup-maybe ()
"Pop up a buffer with a tip if tips are enabled.
see `dvc-tips-enabled'."
(when dvc-tips-enabled
(dvc-tips-popup)))
(defcustom dvc-tips-function nil
"*Alternate function to show a tip.
Must insert the text in the current buffer"
:type 'function
:group 'dvc-tips)
(defun dvc-tips-make-function-from-exec (shell-command header footer)
"Make a lisp function from a shell command.
SHELL-COMMAND is the name of a shell command, return a function
suitable for `dvc-tips-function'."
`(lambda ()
"Function to display a message."
(interactive)
(insert ,header
(shell-command-to-string ,shell-command)
,footer)))
(defun dvc-tips-make-fortune-from-exec (shell-command)
"Wrapper for `dvc-tips-make-function-from-exec'.
Shows a nice header and footer in addition.
Try
\(setq dvc-tips-function (dvc-tips-make-fortune-from-exec \"fortune\"))
"
(dvc-tips-make-function-from-exec
shell-command
(concat (dvc-face-add
"**************************** Fortune ****************************"
'dvc-messages) "\n\n")
(concat "\n"
(dvc-face-add
"*********************************************************************"
'dvc-messages))))
;;;###autoload
(defun dvc-tips-popup (&optional direction noswitch)
"Pop up a buffer with a tip message.
Don't use this function from Xtla. Use `dvc-tips-popup-maybe'
instead."
(interactive)
(let ((work-dir default-directory))
(if dvc-tips-function
(progn
(switch-to-buffer (dvc-get-buffer-create 'dvc 'tips))
(let ((inhibit-read-only t))
(erase-buffer)
(funcall dvc-tips-function))
(dvc-tips-mode))
(dvc-load-state)
(dvc-tips-popup-number dvc-tips-number noswitch)
(setq dvc-tips-number
(mod (+ dvc-tips-number (or direction 1)) (length dvc-tips-array)))
(dvc-save-state))
(setq default-directory work-dir))) ;; set the default-directory in the tips buffer to the current working dir
(defun dvc-tips-next-tip ()
"Show next tip."
(interactive)
(dvc-tips-popup 1 t))
(defun dvc-tips-previous-tip ()
"Show previous tip."
(interactive)
(dvc-tips-popup -1 t))
(defun dvc-tips-customize ()
"Run customize group for dvc-tips."
(interactive)
(customize-group 'dvc-tips))
(provide 'dvc-tips)
;;; dvc-tips.el ends here

506
dvc/lisp/dvc-ui.el
View File

@ -1,506 +0,0 @@
;;; dvc-ui.el --- User interface (keybinding, menus) for DVC
;; Copyright (C) 2005-2009 by all contributors
;; Author: Matthieu Moy <Matthieu.Moy@imag.fr>
;; Contributions from:
;; Stefan Reichoer, <stefan@xsteve.at>
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;
;;; Code:
(eval-and-compile
(require 'dvc-utils))
(require 'dvc-register)
;;;###autoload
(eval-and-compile
(require 'easymenu))
(require 'dvc-register)
;; ----------------------------------------------------------------------------
;; Key bindings
;; ----------------------------------------------------------------------------
;;
;; Conventions
;;
;; - Meta Rules:
;; 0. If you feel a binding odd more than 3 times, report it to dvc dev mailing
;; list. Especially about some danger functions like undo, merge; and functions
;; taking longer time to be executed.
;;
;; 1. Our key binding should not surprise "general users" even if the
;; binding is convenience. Instead, provide hooks for customization.
;; We know it is difficult to define "general users".
;;
;; 2. Write the result of discussion here.
;;
;; 3. See http://mail.gnu.org/archive/html/emacs-devel/2004-03/msg00608.html
;;
;;
;; - Generic Rules:
;;
;; 1. dvc-status should have similar key bindings to pcl-cvs.
;; If a pcl-cvs's binding is too odd, talk it in dvc dev mailing list.
;;
;; 2. Define common prefix for command groups like '>'.
;; So a key binding for a grouped command has following structure:
;;
;; ?{prefix} ?{suffix}
;;
;; e.g. `get something commands' should have `>' as prefix.
;;
;; About suffix part, ? should show the help for the groups.
;;
;; e.g. `help for `get something commands'' is >?.
;;
;; BTW, The prefix ? is for help related command.
;; So `? >' can stand for "show the help for get-something related
;; command". In other word, prefix and suffix is swappable if
;; prefix or suffix is `?'.
;;
;; 3. Upper case for commands taking longer time to be executed.
;; 4. Lower case for commands taking shorter time to be executed.
;; 5. dired's binding is also helpful.
;;
;;
;; - Concrete Rules:
;;
;; t ? list all toggles
;; c dvc-edit-log
;; RET Open the thing at point
;;
;;
;; Definitions for key concrete rules
;;
;; common keys
;;;###autoload
(defvar dvc-key-help ??) ; help
(defvar dvc-key-mark-prefix ?*) ; other mark related command prefix
(defvar dvc-key-add-bookmark ?b) ; add this to bookmark
(defvar dvc-key-get ?>) ; prefix for getting something
(defvar dvc-key-reflect ?<) ; mirror, apply, install...
(defvar dvc-key-parent ?^) ; visit uppper XXX. e.g. directory
;;;###autoload
(defvar dvc-key-diff ?=) ; one shot
;;;###autoload
(defvar dvc-key-status ?s) ; one shot
(defvar dvc-key-add ?a) ; prefix for adding something
;;;###autoload
(defvar dvc-key-show-bookmark ?b) ; show bookmark
(defvar dvc-key-diff-prefix ?d)
;;;###autoload
(defvar dvc-key-file-diff ?d)
;;;###autoload
(defvar dvc-key-tree-lint ?l)
;;;###autoload
(defvar dvc-key-logs ?L)
;;;###autoload
(defvar dvc-key-ediff ?e)
;;;###autoload
(defvar dvc-key-log-entry ?a)
(defvar dvc-key-refresh ?g) ; refresh buffer
;;;###autoload
(defvar dvc-key-inventory ?i) ; inventory
(defvar dvc-key-mark ?m) ; mark
(defvar dvc-key-next ?n) ; next item
(defvar dvc-key-previous ?p) ; previous item
(defvar dvc-key-quit ?q) ; quit
(defvar dvc-key-remove ?r) ; prefix for remove something
(defvar dvc-key-move ?R) ; prefix for move/rename something
(defvar dvc-key-toggle ?t) ; prefix for toggle
(defvar dvc-key-unmark ?u) ; unmark
(defvar dvc-key-popup-menu ?\C-j)
;;;###autoload
(defvar dvc-key-kill-ring-prefix ?w)
;;;###autoload
(defvar dvc-key-commit ?c) ; actually edit-log, but
; that's what you do when you
; want to commit.
;;;###autoload
(defvar dvc-key-update ?u) ; to run dvc update
(defvar dvc-key-replay ?r) ; to run dvc replay
(defvar dvc-key-star-merge ?s) ; to run dvc star-merge
;;;###autoload
(defvar dvc-key-missing ?m) ; to run dvc missing
;;;###autoload
(defvar dvc-key-buffer-prefix ?B) ; prefix to switch to XXX buffer
(defvar dvc-key-view-buffer-prefix ?v) ; prefix to view XXX buffer
(defvar dvc-key-directory-prefix ?D)
;;;###autoload
(defvar dvc-key-file-prefix ?f) ; file specific functions
(defvar dvc-key-branch-prefix ?o) ; branch specific functions
(defvar dvc-key-merge-prefix ?M)
(defvar dvc-key-tag ?T)
(defvar dvc-key-revert ?U)
(defvar dvc-key-working-copy ?W) ; Affecting on working copy
(defvar dvc-key-partner-file-prefix ?f) ; Only used in the bookmarks buffer
(defvar dvc-key-tagging-method-prefix ?#)
(defvar dvc-key-id ?t) ; `t' for `t'ag.
;; functions for creating key groups
;;;###autoload
(progn
(defun dvc-key-group (prefix &rest keys)
(apply 'vector prefix keys)))
(defun dvc-prefix-toggle (&rest keys)
(dvc-key-group dvc-key-toggle keys))
(defun dvc-prefix-add (&rest keys)
(dvc-key-group dvc-key-add keys))
(defun dvc-prefix-remove (&rest keys)
(dvc-key-group dvc-key-remove keys))
(defun dvc-prefix-move (&rest keys)
(dvc-key-group dvc-key-move keys))
(defun dvc-prefix-mark (&rest keys)
(dvc-key-group dvc-key-mark-prefix keys))
(defun dvc-prefix-diff (&rest keys)
(dvc-key-group dvc-key-diff-prefix keys))
(defun dvc-prefix-merge (&rest keys)
(dvc-key-group dvc-key-merge-prefix keys))
(defun dvc-prefix-directory (&rest keys)
(dvc-key-group dvc-key-directory-prefix keys))
;;;###autoload
(progn
(defun dvc-prefix-file (&rest keys)
(dvc-key-group dvc-key-file-prefix keys)))
;;;###autoload
(progn
(defun dvc-prefix-branch (&rest keys)
(dvc-key-group dvc-key-branch-prefix keys)))
;;;###autoload
(progn
(defun dvc-prefix-kill-ring (&rest keys)
(dvc-key-group dvc-key-kill-ring-prefix keys)))
;;;###autoload
(progn
(defun dvc-prefix-view-buffer (&rest keys)
(dvc-key-group dvc-key-view-buffer-prefix keys)))
;;;###autoload
(progn
(defun dvc-prefix-buffer (&rest keys)
(dvc-key-group dvc-key-buffer-prefix keys)))
(defun dvc-prefix-working-copy (&rest keys)
(dvc-key-group dvc-key-working-copy keys))
(defun dvc-prefix-partner-file (&rest keys)
(dvc-key-group dvc-key-partner-file-prefix keys))
(defun dvc-prefix-tag (&rest keys)
(dvc-key-group dvc-key-tag keys))
(defun dvc-prefix-tagging-method (&rest keys)
(dvc-key-group dvc-key-tagging-method-prefix keys))
;; predefined key vectors
(defvar dvc-keyvec-toggle-set (dvc-prefix-toggle ?+))
(defvar dvc-keyvec-toggle-reset (dvc-prefix-toggle ?-))
(defvar dvc-keyvec-toggle-invert (dvc-prefix-toggle ?~))
;;;###autoload
(defvar dvc-keyvec-help (vector dvc-key-help))
(defvar dvc-keyvec-parent (vector dvc-key-parent))
(defvar dvc-keyvec-add (vector dvc-key-add))
(defvar dvc-keyvec-remove (vector dvc-key-remove))
(defvar dvc-keyvec-get (vector dvc-key-get))
(defvar dvc-keyvec-refresh (vector dvc-key-refresh))
(defvar dvc-keyvec-next (vector dvc-key-next))
(defvar dvc-keyvec-previous (vector dvc-key-previous))
(defvar dvc-keyvec-mark (vector dvc-key-mark))
(defvar dvc-keyvec-unmark (vector dvc-key-unmark))
(defvar dvc-keyvec-mark-all (dvc-prefix-mark ?*))
(defvar dvc-keyvec-unmark-all (dvc-prefix-mark ?!))
(defvar dvc-keyvec-quit (vector dvc-key-quit))
(defvar dvc-keyvec-popup-menu (vector dvc-key-popup-menu))
;;;###autoload
(defvar dvc-keyvec-ediff (vector dvc-key-ediff))
;;;###autoload
(defvar dvc-keyvec-tree-lint (vector dvc-key-tree-lint))
;;;###autoload
(defvar dvc-keyvec-logs (vector dvc-key-logs))
;;;###autoload
(defvar dvc-keyvec-log-entry (vector dvc-key-log-entry))
;;;###autoload
(defvar dvc-keyvec-diff (vector dvc-key-diff))
;;;###autoload
(defvar dvc-keyvec-status (vector dvc-key-status))
;;;###autoload
(defvar dvc-keyvec-file-diff (vector dvc-key-file-diff))
;;;###autoload
(defvar dvc-keyvec-file-diff (vector dvc-key-file-diff))
;;;###autoload
(defvar dvc-keyvec-commit (vector dvc-key-commit))
;;;###autoload
(defvar dvc-keyvec-update (vector dvc-key-update))
;;;###autoload
(defvar dvc-keyvec-missing (vector dvc-key-missing))
(defvar dvc-keyvec-replay (vector dvc-key-replay))
(defvar dvc-keyvec-star-merge (vector dvc-key-star-merge))
(defvar dvc-keyvec-reflect (vector dvc-key-reflect))
(defvar dvc-keyvec-revert (vector dvc-key-revert))
;;;###autoload
(defvar dvc-keyvec-inventory (vector dvc-key-inventory))
;;;###autoload
(defvar dvc-keyvec-show-bookmark (vector dvc-key-show-bookmark))
(defvar dvc-keyvec-add-bookmark (vector dvc-key-add-bookmark))
(defvar dvc-keyvec-tag (vector dvc-key-tag))
(defvar dvc-keyvec-kill-ring (vector dvc-key-kill-ring-prefix))
(defvar dvc-keyvec-id (vector dvc-key-id))
(defvar dvc-keyvec-toggle (vector dvc-key-toggle))
;;
;; Global
;;
;; FIXME: replace all those tla-... by dvc-... !!!
;;;###autoload
(defvar dvc-global-keymap
(let ((map (make-sparse-keymap)))
(define-key map [?U] 'tla-undo)
(define-key map [?R] 'tla-redo)
(define-key map [?t] 'tla-tag-insert)
(define-key map [?r] 'tla-tree-revisions)
(define-key map [(meta ?l)] 'tla-tree-lint)
;;(define-key map [(meta ?o)] 'tla-file-view-original)
(define-key map [?p] 'dvc-submit-patch)
(define-key map dvc-keyvec-log-entry 'dvc-add-log-entry)
(define-key map [?A] 'tla-archives)
(define-key map dvc-keyvec-file-diff 'dvc-file-diff)
(define-key map dvc-keyvec-ediff 'dvc-file-ediff)
(define-key map dvc-keyvec-diff 'dvc-diff)
(define-key map dvc-keyvec-status 'dvc-status)
(define-key map dvc-keyvec-commit 'dvc-log-edit)
(define-key map dvc-keyvec-inventory 'dvc-inventory)
(define-key map dvc-keyvec-logs 'dvc-log)
;; dvc: l runs changelog, M-l runs tree-lint for Arch
(define-key map [?l] 'dvc-changelog)
(define-key map [?I] 'dvc-init)
(define-key map [?C] 'dvc-clone)
(define-key map [?F] 'dvc-pull)
(define-key map [?P] 'dvc-push)
(define-key map dvc-keyvec-update 'dvc-update)
(define-key map [?m] 'dvc-missing)
(define-key map [?M] 'dvc-merge)
(define-key map dvc-keyvec-show-bookmark 'dvc-bookmarks)
(define-key map dvc-keyvec-help 'tla-help)
;; branch handling
(define-key map (dvc-prefix-branch ?c) 'dvc-create-branch)
(define-key map (dvc-prefix-branch ?s) 'dvc-select-branch)
(define-key map (dvc-prefix-branch ?l) 'dvc-list-branches)
;; file specific functionality
(define-key map (dvc-prefix-file ?a) 'dvc-add-files)
(define-key map (dvc-prefix-file ?D) 'dvc-remove-files)
(define-key map (dvc-prefix-file ?R) 'dvc-revert-files)
(define-key map (dvc-prefix-file ?M) 'dvc-rename)
(define-key map (dvc-prefix-file ?X) 'dvc-purge-files)
(define-key map (dvc-prefix-file ?=) 'dvc-file-diff)
(define-key map (dvc-prefix-view-buffer
?p) 'dvc-show-process-buffer)
(define-key map (dvc-prefix-view-buffer
?e) 'dvc-show-last-error-buffer)
(define-key map (dvc-prefix-view-buffer
?l) 'dvc-open-internal-log-buffer)
(define-key map (dvc-prefix-view-buffer
dvc-key-diff) 'tla-changes-goto)
(define-key map (dvc-prefix-view-buffer
dvc-key-status) 'baz-status-goto)
(define-key map (dvc-prefix-view-buffer
dvc-key-inventory) 'tla-inventory-goto)
(define-key map (dvc-prefix-view-buffer
?L) 'tla-tree-lint-goto)
(define-key map (dvc-prefix-view-buffer ?r) 'tla-tree-revisions-goto)
(define-key map (dvc-prefix-kill-ring ?a) 'tla-save-archive-to-kill-ring)
(define-key map (dvc-prefix-kill-ring ?v) 'tla-save-version-to-kill-ring)
(define-key map (dvc-prefix-kill-ring ?r) 'tla-save-revision-to-kill-ring)
map)
"Global keymap used by DVC.")
;;;###autoload
(defcustom dvc-prefix-key [(control x) ?V]
"Prefix key for the DVC commands in the global keymap.
If you wish to disable the prefix key, set this variable to nil."
:type '(choice (const [(control x) ?V])
(const [(control x) ?T])
(const [(control x) ?t])
(const [(control x) ?v ?t])
(const [(super v)])
(const [(hyper v)])
(const [(super t)])
(const [(hyper t)])
(const :tag "None" nil)
(sexp))
:group 'tla-bindings
:set (lambda (var value)
(if (boundp var)
(global-unset-key (symbol-value var)))
(set var value)
(global-set-key (symbol-value var) dvc-global-keymap)))
;;;###autoload
(defun dvc-enable-prefix-key ()
"Install the DVC prefix key globally."
(interactive)
(when dvc-prefix-key
(global-set-key dvc-prefix-key dvc-global-keymap)))
;;;###autoload
(dvc-enable-prefix-key)
;; It is important that DVC has this key, so steal it from other
;; programs, but give the user a chance to override this.
;;;###autoload
(add-hook 'after-init-hook 'dvc-enable-prefix-key t)
;;;###autoload
(define-key ctl-x-4-map [?T] 'dvc-add-log-entry)
(defvar dvc-cmenu-map-template
(let ((map (make-sparse-keymap)))
;; TODO: [return], "\C-m" => tla--generic-context-action
(define-key map dvc-keyvec-help 'describe-mode)
(define-key map [down-mouse-3] 'dvc-cmenu-popup-by-mouse)
(define-key map dvc-keyvec-popup-menu 'dvc-cmenu-popup)
map)
"Template for keymaps used in items, files, changes, etc.")
;;
;; Global
;;
;;;###autoload
(easy-menu-add-item
(and (boundp 'menu-bar-tools-menu) (dvc-do-in-gnu-emacs menu-bar-tools-menu))
(dvc-do-in-xemacs '("Tools"))
'("DVC"
["Show Bookmarks" dvc-bookmarks t]
"---"
"Tree Commands:"
["View Diff" dvc-diff t]
["View Status" dvc-status t]
["View Missing" dvc-missing t]
["View Log" dvc-log t]
["View ChangeLog" dvc-changelog t]
["Edit Commit Log" dvc-log-edit t]
"---"
"File Commands:"
["Add Files" dvc-add-files t]
["Revert Files" dvc-revert-files t]
["Remove Files" dvc-remove-files t]
["Add Log Entry" dvc-add-log-entry t]
;; ["Insert Arch Tag" tla-tag-insert t]
;; ["View File Diff" tla-file-diff t]
;; ["View File Ediff" tla-file-ediff t]
;; ["View Original" tla-file-view-original t]
;; ["View Conflicts" tla-view-conflicts t]
"---"
["Initialize repository" dvc-init t]
)
"PCL-CVS")
;; Show the selected DVC in the modeline: M-x dvc-show-active-dvc
(defvar dvc-show-active-dvc nil)
(defvar dvc-show-active-dvc-string "")
(make-variable-buffer-local 'dvc-show-active-dvc-string)
(add-to-list 'minor-mode-alist '(dvc-show-active-dvc dvc-show-active-dvc-string))
(add-hook 'find-file-hooks 'dvc-find-file-hook)
(add-hook 'dired-mode-hook 'dvc-dired-hook)
(defun dvc-show-active-dvc (arg)
"Toggle displaying a DVC string in the modeline.
If ARG is null, toggle displaying
If ARG is a number and is greater than zero, turn on visualization; otherwise,
turn off visualization."
(interactive "P")
(setq dvc-show-active-dvc (if arg
(> (prefix-numeric-value arg) 0)
(not dvc-show-active-dvc)))
(when dvc-show-active-dvc
(dvc-actualize-modeline)))
(defun dvc-dvc-file-has-conflict-p (filename)
nil)
(defun dvc-find-file-hook ()
"Set dvc-show-active-dvc-string, after loading a file. Enter
smerge mode if the file has conflicts (detected by
<dvc>-dvc-file-has-conflict-p)."
(when (dvc-current-active-dvc)
(dvc-actualize-modeline)
(when (dvc-call "dvc-file-has-conflict-p" (buffer-file-name))
(dvc-funcall-if-exists smerge-mode 1)
(message
"Conflicts in file%s. Use M-x dvc-resolved RET when done."
(if (boundp 'smerge-mode) ", entering SMerge mode" "")))))
(defun dvc-dired-hook ()
"Set dvc-show-active-dvc-string for dired buffers."
(dvc-actualize-modeline))
(defun dvc-actualize-modeline ()
(let ((dvc (dvc-current-active-dvc)))
;;(when dvc-show-active-dvc (dvc-trace "dvc-actualize-modeline: %S %S" default-directory dvc))
(setq dvc-show-active-dvc-string (if dvc (concat " DVC:" (symbol-name dvc))
""))))
(provide 'dvc-ui)
;;; dvc-ui.el ends here

677
dvc/lisp/dvc-unified.el
View File

@ -1,677 +0,0 @@
;;; dvc-unified.el --- The unification layer for dvc
;; Copyright (C) 2005-2010 by all contributors
;; Author: Stefan Reichoer, <stefan@xsteve.at>
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; This file provides the functionality that unifies the various dvc layers
;;; Commands:
;;
;; Below is a complete command list:
;;
;; `dvc-init'
;; Initialize a new repository.
;; `dvc-add-files'
;; Add FILES to the currently active dvc. FILES is a list of
;; `dvc-revert-files'
;; Revert FILES for the currently active dvc.
;; `dvc-remove-files'
;; Remove FILES for the currently active dvc.
;; `dvc-clone'
;; Ask for the DVC to use and clone SOURCE-PATH.
;; `dvc-diff'
;; Display the changes from BASE-REV to the local tree in PATH.
;; `dvc-diff-against-url'
;; Show the diff from the current tree against a remote url
;; `dvc-status'
;; Display the status in optional PATH tree.
;; `dvc-log'
;; Display the brief log for PATH (a file-name; default current
;; `dvc-apply-patch'
;; Apply patch `patch-name' on current-tree.
;; `dvc-rename'
;; Rename file FROM-NAME to TO-NAME; TO-NAME may be a directory.
;; `dvc-command-version'
;; Returns and/or shows the version identity string of backend command.
;; `dvc-tree-root'
;; Get the tree root for PATH or the current `default-directory'.
;; `dvc-log-edit'
;; Edit the log before commiting. Optional OTHER_FRAME (default
;; `dvc-ignore-file-extensions'
;; Ignore the file extensions of the marked files, in all
;; `dvc-ignore-file-extensions-in-dir'
;; Ignore the file extensions of the marked files, only in the
;; `dvc-missing'
;; Show revisions missing from PATH (default prompt),
;; `dvc-push'
;; Push changes to a remote location.
;; `dvc-create-branch'
;; Create a new branch.
;; `dvc-select-branch'
;; Select a branch.
;; `dvc-list-branches'
;; List available branches.
;;
;;; History:
;;
;;; Code:
(condition-case nil
(require 'dired-x)
(error nil))
(require 'ffap)
(require 'dvc-register)
(require 'dvc-core)
(require 'dvc-defs)
(require 'dvc-tips)
(require 'dvc-utils)
;; --------------------------------------------------------------------------------
;; unified functions
;; --------------------------------------------------------------------------------
;;;###autoload
(defun dvc-init ()
"Initialize a new repository.
It currently supports the initialization for bzr, xhg, xgit, tla.
Note: this function is only useful when called interactively."
(interactive)
(when (interactive-p)
(let ((supported-variants (map t 'symbol-name dvc-registered-backends))
(working-dir (dvc-uniquify-file-name default-directory))
(dvc))
;; hide backends that don't provide an init function
(mapc '(lambda (elem)
(setq supported-variants (delete elem supported-variants)))
'("xdarcs" "xmtn" "baz"))
(add-to-list 'supported-variants "bzr-repo")
(setq dvc (intern (dvc-completing-read
(format "Init a repository for '%s', using dvc: " working-dir)
(sort supported-variants 'string-lessp))))
(cond ((string= dvc "bzr-repo")
(call-interactively 'bzr-init-repository))
(t
(funcall (dvc-function dvc "dvc-init") working-dir))))))
;;;###autoload
(defun dvc-add-files (&rest files)
"Add FILES to the currently active dvc. FILES is a list of
strings including path from root; interactive defaults
to (dvc-current-file-list)."
(interactive (dvc-current-file-list))
(when (setq files (dvc-confirm-file-op "add" files dvc-confirm-add))
(dvc-apply "dvc-add-files" files)))
;;;###autoload
(defun dvc-revert-files (&rest files)
"Revert FILES for the currently active dvc."
(interactive (dvc-current-file-list))
(when (setq files (dvc-confirm-file-op "revert" files t))
(dvc-apply "dvc-revert-files" files)))
;;;###autoload
(defun dvc-remove-files (&rest files)
"Remove FILES for the currently active dvc.
Return t if files removed, nil if not (due to user confirm or error)."
(interactive (dvc-current-file-list))
(when (setq files (dvc-confirm-file-op "remove" files t))
(dvc-apply "dvc-remove-files" files)))
(defun dvc-remove-optional-args (spec &rest args)
"Process ARGS, removing those that come after the &optional keyword
in SPEC if they are nil, returning the result."
(let ((orig args)
new)
(if (not (catch 'found
(while (and spec args)
(if (eq (car spec) '&optional)
(throw 'found t)
(setq new (cons (car args) new)
args (cdr args)
spec (cdr spec))))
nil))
orig
;; an &optional keyword was found: process it
(let ((acc (reverse args)))
(while (and acc (null (car acc)))
(setq acc (cdr acc)))
(when acc
(setq new (nconc acc new)))
(nreverse new)))))
;;;###autoload
(defmacro define-dvc-unified-command (name args comment &optional interactive)
"Define a DVC unified command. &optional arguments are permitted, but
not &rest."
(declare (indent 2)
(debug (&define name lambda-list stringp
[&optional interactive])))
`(defun ,name ,args
,comment
,@(when interactive (list interactive))
(dvc-apply ,(symbol-name name)
(dvc-remove-optional-args ',args
,@(remove '&optional args)))))
;;;###autoload
(defun dvc-clone (&optional dvc source-path dest-path rev)
"Ask for the DVC to use and clone SOURCE-PATH."
(interactive "P")
(when (interactive-p)
(let* ((ffap-url-regexp
(concat
"\\`\\("
"\\(ftp\\|https?\\|git\\|www\\)://" ; needs host
"\\)." ; require one more character
))
(url-at-point (ffap-url-at-point))
(all-candidates (map t 'symbol-name dvc-registered-backends))
(git-is-candidate (re-search-backward "git clone .+" (line-beginning-position) t))
(hg-is-candidate (re-search-backward "hg clone .+" (line-beginning-position) t))
(bzr-is-candidate (re-search-backward "bzr get .+" (line-beginning-position) t)))
(setq dvc (intern (dvc-completing-read
"Clone, using dvc: "
all-candidates
nil t
(cond (git-is-candidate "xgit")
(bzr-is-candidate "bzr")
(hg-is-candidate "xhg")
(t nil)))))
(setq source-path (read-string (format "%S-clone from path: " dvc) url-at-point))
(setq dest-path (expand-file-name (dvc-read-directory-name
(format "Destination Directory for %S-clone: " dvc)
nil nil nil "<default>")))
(if current-prefix-arg
(unless (not (eq dvc 'xhg))
(setq rev (read-string "FromRevision: ")))
nil)))
(let ((default-directory (or (file-name-directory dest-path) default-directory)))
(when (string= (file-name-nondirectory dest-path) "<default>")
(setq dest-path nil))
(if rev
(funcall (dvc-function dvc "dvc-clone") source-path dest-path rev)
(funcall (dvc-function dvc "dvc-clone") source-path dest-path))))
;;;###autoload
(defun dvc-diff (&optional base-rev path dont-switch)
"Display the changes from BASE-REV to the local tree in PATH.
BASE-REV (a revision-id) defaults to base revision of the
tree. Use `dvc-delta' for differencing two revisions.
PATH defaults to `default-directory', that is, the whole working tree.
See also `dvc-file-diff', which defaults to the current buffer file.
The new buffer is always displayed; if DONT-SWITCH is nil, select it."
(interactive)
(let ((default-directory
(dvc-read-project-tree-maybe "DVC diff (directory): "
(when path (expand-file-name path)))))
(setq base-rev (or base-rev
;; Allow back-ends to override this for e.g. git,
;; which can return either the index or the last
;; revision.
(dvc-call "dvc-last-revision" (dvc-tree-root path))))
(dvc-save-some-buffers default-directory)
(dvc-call "dvc-diff" base-rev default-directory dont-switch)))
;;;###autoload
(defun dvc-diff-against-url (path)
"Show the diff from the current tree against a remote url"
(interactive)
(dvc-save-some-buffers default-directory)
(dvc-call "dvc-diff-against-url" path))
(defun dvc-dvc-last-revision (path)
(list (dvc-current-active-dvc)
(list 'last-revision path 1)))
;;;###autoload
(define-dvc-unified-command dvc-delta (base modified &optional dont-switch)
"Display diff from revision BASE to MODIFIED.
BASE and MODIFIED must be full revision IDs, or strings. If
strings, the meaning is back-end specific; it should be some sort
of revision specifier.
The new buffer is always displayed; if DONT-SWITCH is nil, select it."
(interactive "Mbase revision: \nMmodified revision: "))
;;;###autoload
(define-dvc-unified-command dvc-file-diff (file &optional base modified dont-switch)
"Display the changes in FILE (default current buffer file)
between BASE (default last-revision) and MODIFIED (default
workspace version).
If DONT-SWITCH is non-nil, just show the diff buffer, don't select it."
;; use dvc-diff-diff to default file to dvc-get-file-info-at-point
(interactive (list buffer-file-name)))
;;;###autoload
(defun dvc-status (&optional path)
"Display the status in optional PATH tree."
(interactive)
(let ((default-directory
(dvc-read-project-tree-maybe "DVC status (directory): "
(when path (expand-file-name path)) (not current-prefix-arg))))
;; Since we have bound default-directory, we don't need to pass
;; `path' to the back-end.
(dvc-save-some-buffers default-directory)
(dvc-call "dvc-status"))
nil)
(define-dvc-unified-command dvc-name-construct (back-end-revision)
"Returns a string representation of BACK-END-REVISION.")
;;;###autoload
(defun dvc-log (&optional path last-n)
"Display the brief log for PATH (a file-name; default current
buffer file name; nil means entire tree; negative prefix arg
means prompt for tree depending on value of
dvc-read-project-tree-mode), LAST-N entries (default
`dvc-log-last-n'; all if nil, prefix value means that
many entries (absolute value)). Use `dvc-changelog' for the full log."
(interactive "i\nP")
(let* ((path (if (and last-n (< (prefix-numeric-value last-n) 0))
nil (buffer-file-name)))
(last-n (if last-n
(abs (prefix-numeric-value last-n))
dvc-log-last-n))
(default-directory
(dvc-read-project-tree-maybe "DVC tree root (directory): "
(when path (expand-file-name path))
path)))
;; Since we have bound default-directory, we don't need to pass
;; 'root' to the back-end.
(dvc-call "dvc-log" path last-n))
nil)
(defun dvc-apply-patch (patch-name)
"Apply patch `patch-name' on current-tree."
(interactive (list (read-from-minibuffer "Patch: "
nil nil nil nil
(dired-filename-at-point))))
(let ((current-dvc (dvc-current-active-dvc)))
(case current-dvc
('xgit (xgit-apply-patch patch-name))
('xhg (xhg-import patch-name))
;; TODO ==>Please add here appropriate commands for your backend
(t
(if (y-or-n-p (format "[%s] don't know how to apply patch, do you want to run a generic command instead?"
current-dvc))
(shell-command (format "cat %s | patch -p1" patch-name))
(message "I don't known yet how to patch on %s" current-dvc))))))
;;;###autoload
(define-dvc-unified-command dvc-changelog (&optional arg)
"Display the full changelog in this tree for the actual dvc.
Use `dvc-log' for the brief log."
(interactive))
;;;###autoload
(define-dvc-unified-command dvc-add (file)
"Adds FILE to the repository."
(interactive "fFile: "))
(define-dvc-unified-command dvc-revision-direct-ancestor (revision)
"Computes the direct ancestor of a revision.")
(define-dvc-unified-command dvc-revision-nth-ancestor (revision n)
"Computes the direct ancestor of a revision.")
(define-dvc-unified-command dvc-resolved (file)
"Mark FILE as resolved"
(interactive (list (buffer-file-name))))
;; Look at `xhg-ediff-file-at-rev' and `xhg-dvc-ediff-file-revisions'
;; to build backend functions.
(define-dvc-unified-command dvc-ediff-file-revisions ()
"Ediff rev1 of file against rev2."
(interactive))
(defun dvc-rename (from-name to-name)
"Rename file FROM-NAME to TO-NAME; TO-NAME may be a directory.
When called non-interactively, if from-file-name does not exist,
but to-file-name does, just record the rename in the back-end"
;; back-end function <dvc>-dvc-rename (from-name to-name bookkeep-only)
;; If bookkeep-only nil, rename file in filesystem and back-end
;; If non-nil, rename file in back-end only.
(interactive
(let* ((from-name (dvc-confirm-read-file-name "Rename: " t))
(to-name (dvc-confirm-read-file-name
(format "Rename %s to: " from-name)
nil "" from-name)))
(list from-name to-name)))
(if (file-exists-p from-name)
(progn
;; rename the file in the filesystem and back-end
(if (and (file-exists-p to-name)
(not (file-directory-p to-name)))
(error "%s exists and is not a directory" to-name))
(when (file-directory-p to-name)
(setq to-name (file-name-as-directory to-name)))
(dvc-call "dvc-rename" from-name to-name nil))
;; rename the file in the back-end only
(progn
;; rename the file in the filesystem and back-end
(if (not (file-exists-p to-name))
(error "%s does not exist" to-name))
(when (file-directory-p to-name)
(setq to-name (file-name-as-directory to-name)))
(dvc-call "dvc-rename" from-name to-name t))))
(defvar dvc-command-version nil)
;;;###autoload
(defun dvc-command-version ()
"Returns and/or shows the version identity string of backend command."
(interactive)
(setq dvc-command-version (dvc-call "dvc-command-version"))
(when (interactive-p)
(message "%s" dvc-command-version))
dvc-command-version)
;;;###autoload
(defun dvc-tree-root (&optional path no-error)
"Get the tree root for PATH or the current `default-directory'.
When called interactively, print a message including the tree root and
the current active back-end."
(interactive)
(let ((dvc-list (or
(when dvc-temp-current-active-dvc (list dvc-temp-current-active-dvc))
(when dvc-buffer-current-active-dvc (list dvc-buffer-current-active-dvc))
(append dvc-select-priority dvc-registered-backends)))
(root "/")
(dvc)
(tree-root-func)
(path (or path default-directory)))
(while dvc-list
(setq tree-root-func (dvc-function (car dvc-list) "tree-root" t))
(when (fboundp tree-root-func)
(let ((current-root (funcall tree-root-func path t)))
(when (and current-root (> (length current-root) (length root)))
(setq root current-root)
(setq dvc (car dvc-list)))))
(setq dvc-list (cdr dvc-list)))
(when (string= root "/")
(unless no-error (error "Tree %s is not under version control"
path))
(setq root nil))
(when (interactive-p)
(message "Root: %s (managed by %s)"
root (dvc-variable dvc "backend-name")))
root))
;;;###autoload
(defun dvc-log-edit (&optional other-frame no-init)
"Edit the log before commiting. Optional OTHER_FRAME (default
user prefix) puts log edit buffer in a separate frame (or in the
same frame if `dvc-log-edit-other-frame' is non-nil). Optional
NO-INIT if non-nil suppresses initialization of buffer if one is
reused. `default-directory' must be the tree root."
(interactive "P")
(setq other-frame (dvc-xor other-frame dvc-log-edit-other-frame))
;; Reuse an existing log-edit buffer if possible.
;;
;; If this is invoked from a status or diff buffer,
;; dvc-buffer-current-active-dvc is set. If invoked from another
;; buffer (ie a source file, either directly or via
;; dvc-add-log-entry), dvc-buffer-current-active-dvc is nil, there
;; might be two back-ends to choose from, and dvc-current-active-dvc
;; might prompt. So we look for an existing log-edit buffer for the
;; current tree first, and assume the user wants the back-end
;; associated with that buffer (ie, it was the result of a previous
;; prompt).
(let ((log-edit-buffers (dvc-get-matching-buffers dvc-buffer-current-active-dvc 'log-edit default-directory)))
(case (length log-edit-buffers)
(0 ;; Need to create a new log-edit buffer. In the log-edit
;; buffer, dvc-partner-buffer must be set to a buffer with a
;; mode that dvc-current-file-list supports.
;; dvc-buffer-current-active-dvc could be nil here, so we have
;; to use dvc-current-active-dvc, and let it prompt.
(let* ((dvc-temp-current-active-dvc (dvc-current-active-dvc))
(diff-status-buffers
(append (dvc-get-matching-buffers dvc-temp-current-active-dvc 'diff default-directory)
(dvc-get-matching-buffers dvc-temp-current-active-dvc 'status default-directory)
(dvc-get-matching-buffers dvc-temp-current-active-dvc 'conflicts default-directory)))
(activated-from-bookmark-buffer (eq major-mode 'dvc-bookmarks-mode)))
(case (length diff-status-buffers)
(0 (if (not activated-from-bookmark-buffer)
(error "Must have a DVC diff, status, or conflict buffer before calling dvc-log-edit")
(dvc-call "dvc-log-edit" (dvc-tree-root) other-frame nil)))
(1
(set-buffer (nth 1 (car diff-status-buffers)))
(dvc-call "dvc-log-edit" (dvc-tree-root) other-frame nil))
(t ;; multiple: choose current buffer
(if (memq (current-buffer)
(mapcar #'(lambda (item) (nth 1 item))
diff-status-buffers))
(dvc-call "dvc-log-edit" (dvc-tree-root) other-frame nil)
;; give up. IMPROVEME: could prompt
(if dvc-buffer-current-active-dvc
(error "More than one diff, status, or conflict buffer for %s in %s; can't tell which to use. Please close some."
dvc-buffer-current-active-dvc default-directory)
(error "More than one diff, status, or conflict buffer for %s; can't tell which to use. Please close some."
default-directory)))))))
(1 ;; Just reuse the buffer. In this call, we can't use
;; dvc-buffer-current-active-dvc from the current buffer,
;; because it might be nil (if we are in a source buffer). We
;; want to use dvc-buffer-current-active-dvc from that buffer
;; for this dvc-call, but we can't switch to it first,
;; because dvc-log-edit needs the current buffer to set
;; dvc-partner-buffer.
(let ((dvc-temp-current-active-dvc
(with-current-buffer (nth 1 (car log-edit-buffers)) dvc-buffer-current-active-dvc)))
(dvc-call "dvc-log-edit" (dvc-tree-root) other-frame no-init)))
(t ;; multiple matching buffers
(if dvc-buffer-current-active-dvc
(error "More than one log-edit buffer for %s in %s; can't tell which to use. Please close some."
dvc-buffer-current-active-dvc default-directory)
(error "More than one log-edit buffer for %s; can't tell which to use. Please close some."
default-directory))))))
(defvar dvc-back-end-wrappers
'(("add-log-entry" (&optional other-frame))
("add-files" (&rest files))
("diff" (&optional base-rev path dont-switch))
("ignore-file-extensions" (file-list))
("ignore-file-extensions-in-dir" (file-list))
("log-edit" (&optional OTHER-FRAME))
("missing" (&optional other path force-prompt))
("rename" (from-name to-name))
("remove-files" (&rest files))
("revert-files" (&rest files))
("status" (&optional path)))
"Alist of descriptions of back-end wrappers to define.
A back-end wrapper is a fuction called <back-end>-<something>, whose
body is a simple wrapper around dvc-<something>. This is usefull for
functions which are totally generic, but will use some back-end
specific stuff in their body.
At this point in the file, we don't have the list of back-ends, which
is why we don't do the (defun ...) here, but leave a description for
use by `dvc-register-dvc'.")
;;;###autoload
(define-dvc-unified-command dvc-log-edit-done (&optional arg)
"Commit and close the log buffer. Optional ARG is back-end specific."
(interactive (list current-prefix-arg)))
;;;###autoload
(define-dvc-unified-command dvc-edit-ignore-files ()
"Edit the ignored file list."
(interactive))
;;;###autoload
(define-dvc-unified-command dvc-ignore-files (file-list)
"Ignore the marked files."
(interactive (list (dvc-current-file-list))))
;;;###autoload
(defun dvc-ignore-file-extensions (file-list)
"Ignore the file extensions of the marked files, in all
directories of the workspace."
(interactive (list (dvc-current-file-list)))
(let* ((extensions (delete nil (mapcar 'file-name-extension file-list)))
;; FIXME: should also filter duplicates. use delete-duplicates
(root (dvc-tree-root))
(msg (case (length extensions)
(1 (format "extension *.%s" (first extensions)))
(t (format "%d extensions" (length extensions))))))
(if extensions
(when (y-or-n-p (format "Ignore %s in workspace %s? " msg root))
(dvc-call "dvc-backend-ignore-file-extensions" extensions))
(error "No files with an extension selected"))))
;;;###autoload
(defun dvc-ignore-file-extensions-in-dir (file-list)
"Ignore the file extensions of the marked files, only in the
directories containing the files, and recursively below them."
(interactive (list (dvc-current-file-list)))
;; We have to match the extensions to the directories, so reject
;; command if either is nil.
(let* ((extensions (mapcar 'file-name-extension file-list))
(dirs (mapcar 'file-name-directory file-list))
(msg (case (length extensions)
(1 (format "extension *.%s in directory `%s'" (first extensions) (first dirs)))
(t (format "%d extensions in directories" (length extensions))))))
(dolist (extension extensions)
(if (not extension)
(error "A file with no extension selected")))
(dolist (dir dirs)
(if (not dir)
(error "A file with no directory selected")))
(when (y-or-n-p (format "Ignore %s? " msg))
(dvc-call "dvc-backend-ignore-file-extensions-in-dir" file-list))))
;;;###autoload
(defun dvc-missing (&optional other path use-current)
"Show revisions missing from PATH (default prompt),
relative to OTHER. OTHER defaults to the head revision of the
current branch; for some back-ends, it may also be a remote
repository.
If USE-CURRENT non-nil (default user prefix arg), PATH defaults to current tree."
(interactive `(nil nil ,current-prefix-arg))
(let ((default-directory
(dvc-read-project-tree-maybe "DVC missing (directory): "
(when path (expand-file-name path))
use-current)))
;; Since we have bound default-directory, we don't need to pass
;; `path' to the back-end.
(dvc-save-some-buffers default-directory)
(dvc-call "dvc-missing" other))
nil)
;;;###autoload
(define-dvc-unified-command dvc-inventory ()
"Show the inventory for this working copy."
(interactive))
;;;###autoload
(define-dvc-unified-command dvc-save-diff (file)
"Store the diff from the working copy against the repository in a file."
(interactive (list (read-file-name "Save the diff to: "))))
;;;###autoload
(define-dvc-unified-command dvc-update (&optional revision-id)
"Update this working copy to REVISION-ID (default head of current branch)."
(interactive))
;;;###autoload
(define-dvc-unified-command dvc-pull (&optional other)
"Pull changes from a remote location.
If OTHER is nil, pull from a default or remembered location as
determined by the back-end. If OTHER is a string, it identifies
a (local or remote) database or branch to pull into the current
database, branch or workspace."
(interactive))
;;;###autoload
(defun dvc-push ()
"Push changes to a remote location."
(interactive)
(let ((bookmarked-locations (dvc-bookmarks-current-push-locations)))
(when bookmarked-locations
(dolist (location bookmarked-locations)
(message "pushing to: %s" location)
(dvc-call "dvc-push" location)))))
;;;###autoload
(define-dvc-unified-command dvc-merge (&optional other)
"Merge with OTHER.
If OTHER is nil, merge heads in current database, or merge from
remembered database.
If OTHER is a string, it identifies a (local or remote) database or
branch to merge into the current database, branch, or workspace."
(interactive))
;;;###autoload
(define-dvc-unified-command dvc-submit-patch ()
"Submit a patch for the current project under DVC control."
(interactive))
;;;###autoload
(define-dvc-unified-command dvc-send-commit-notification (&optional to)
"Send a commit notification for the changeset at point.
If TO is provided, send it to that email address. If a prefix
argument is given, modify the behavior of this command as
specified by the VCS backend."
(interactive (list current-prefix-arg)))
;;;###autoload
(define-dvc-unified-command dvc-export-via-email ()
"Send the changeset at point via email."
(interactive))
;;;###autoload
(defun dvc-create-branch ()
"Create a new branch."
(interactive)
(call-interactively (dvc-function (dvc-current-active-dvc) "dvc-create-branch")))
;;;###autoload
(defun dvc-select-branch ()
"Select a branch."
(interactive)
(call-interactively (dvc-function (dvc-current-active-dvc) "dvc-select-branch")))
;;;###autoload
(defun dvc-list-branches ()
"List available branches."
(interactive)
(call-interactively (dvc-function (dvc-current-active-dvc) "dvc-list-branches")))
(provide 'dvc-unified)
;;; dvc-unified.el ends here

826
dvc/lisp/dvc-utils.el
View File

@ -1,826 +0,0 @@
;;; dvc-utils.el --- Utility functions for DVC
;; Copyright (C) 2005 - 2010 by all contributors
;; Author: Matthieu Moy <Matthieu.Moy@imag.fr>
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; This file provides some functions used in DVC, but not particularly
;; linked to revision control systems.
(require 'dvc-defs)
(require 'ewoc)
;; Load compatibility code
(if (featurep 'xemacs)
(require 'dvc-xemacs)
(require 'dvc-emacs))
;; Macros to generate correct code for different emacs variants
;; (progn ...) is here to have autoload generation actually insert the
;; code in the autoload file.
;;;###autoload
(progn
(defmacro dvc-do-in-gnu-emacs (&rest body)
"Execute BODY if in GNU/Emacs."
(declare (indent defun) (debug (body)))
(unless (featurep 'xemacs) `(progn ,@body))))
;;;###autoload
(progn
(defmacro dvc-do-in-xemacs (&rest body)
"Execute BODY if in XEmacs."
(declare (indent defun) (debug (body)))
(when (featurep 'xemacs) `(progn ,@body))))
(defconst dvc-mouse-2
(if (featurep 'xemacs)
[down-mouse-2]
[mouse-2]))
(dvc-do-in-xemacs
(unless (functionp 'clone-process)
(defun clone-process (process &optional newname)
"Create a twin copy of PROCESS.
If NEWNAME is nil, it defaults to PROCESS' name;
NEWNAME is modified by adding or incrementing <N> at the end as necessary.
If PROCESS is associated with a buffer, the new process will be associated
with the current buffer instead.
Returns nil if PROCESS has already terminated."
(setq newname (or newname (process-name process)))
(if (string-match "<[0-9]+>\\'" newname)
(setq newname (substring newname 0 (match-beginning 0))))
(when (memq (process-status process) '(run stop open))
(let* ((process-connection-type (process-tty-name process))
(old-kwoq (process-kill-without-query process nil))
(new-process
(if (memq (process-status process) '(open))
(apply 'open-network-stream newname
(if (process-buffer process) (current-buffer)))
(apply 'start-process newname
(if (process-buffer process) (current-buffer))
(process-command process)))))
(process-kill-without-query new-process old-kwoq)
(process-kill-without-query process old-kwoq)
(set-process-filter new-process (process-filter process))
(set-process-sentinel new-process (process-sentinel process))
new-process)))))
(defmacro dvc-funcall-if-exists (function &rest args)
"Call FUNCTION with ARGS as parameters if it exists."
(if (fboundp function)
`(funcall ',function ,@args)))
(defun dvc-strip-final-newline (string)
"Strip the final newline from STRING if there's one."
(if (eq (aref string (- (length string) 1)) ?\n)
(substring string 0 (- (length string) 1))
string))
(defun dvc-add-to-list (list-var element &optional append)
"Same behavior as GNU Emacs's `add-to-list', but also works on XEmacs.
LIST-VAR is a symbol representing the list to be modified.
ELEMENT is the element to be added to the list.
If APPEND is non-nil, add the item to the end of the list instead of the
front."
(if (featurep 'xemacs)
(if append
(when (not (member element (eval list-var)))
(set list-var (append (eval list-var) (list element))))
(add-to-list list-var element))
(add-to-list list-var element append)))
;; copied from Emacs22, only needed when omit-nulls is needed,
;; otherwise split-string can be used
(defun dvc-split-string (string &optional separators omit-nulls)
"Split STRING into substrings bounded by matches for SEPARATORS.
The beginning and end of STRING, and each match for SEPARATORS, are
splitting points. The substrings matching SEPARATORS are removed, and
the substrings between the splitting points are collected as a list,
which is returned.
If SEPARATORS is non-nil, it should be a regular expression matching text
which separates, but is not part of, the substrings. If nil it defaults to
`split-string-default-separators', normally \"[ \\f\\t\\n\\r\\v]+\", and
OMIT-NULLS is forced to t.
If OMIT-NULLS is t, zero-length substrings are omitted from the list \(so
that for the default value of SEPARATORS leading and trailing whitespace
are effectively trimmed). If nil, all zero-length substrings are retained,
which correctly parses CSV format, for example.
Note that the effect of `(split-string STRING)' is the same as
`(split-string STRING split-string-default-separators t)'). In the rare
case that you wish to retain zero-length substrings when splitting on
whitespace, use `(split-string STRING split-string-default-separators)'.
Modifies the match data; use `save-match-data' if necessary."
(let ((keep-nulls (not (if separators omit-nulls t)))
(rexp (or separators split-string-default-separators))
(start 0)
notfirst
(list nil))
(while (and (string-match rexp string
(if (and notfirst
(= start (match-beginning 0))
(< start (length string)))
(1+ start) start))
(< start (length string)))
(setq notfirst t)
(if (or keep-nulls (< start (match-beginning 0)))
(setq list
(cons (substring string start (match-beginning 0))
list)))
(setq start (match-end 0)))
(if (or keep-nulls (< start (length string)))
(setq list
(cons (substring string start)
list)))
(nreverse list)))
(eval-and-compile
(unless (fboundp 'dired-delete-file)
;; NOTE: Cut-and-past from CVS Emacs
;;
(defvar dired-re-no-dot "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*")
(defun dired-make-relative (file &optional dir ignore)
"Convert FILE (an absolute file name) to a name relative to DIR.
If this is impossible, return FILE unchanged.
DIR must be a directory name, not a file name."
(or dir (setq dir default-directory))
;; This case comes into play if default-directory is set to
;; use ~.
(if (and (> (length dir) 0) (= (aref dir 0) ?~))
(setq dir (expand-file-name dir)))
(if (string-match (concat "^" (regexp-quote dir)) file)
(substring file (match-end 0))
;; (or no-error
;; (error "%s: not in directory tree growing at %s" file dir))
file))
;; Delete file, possibly delete a directory and all its files.
;; This function is useful outside of dired. One could change it's name
;; to e.g. recursive-delete-file and put it somewhere else.
(defun dired-delete-file (file &optional recursive) "\
Delete FILE or directory (possibly recursively if optional RECURSIVE is true.)
RECURSIVE determines what to do with a non-empty directory. If RECURSIVE is:
Nil, do not delete.
`always', delete recursively without asking.
`top', ask for each directory at top level.
Anything else, ask for each sub-directory."
(let (files)
;; This test is equivalent to
;; (and (file-directory-p fn) (not (file-symlink-p fn)))
;; but more efficient
(if (not (eq t (car (file-attributes file))))
(delete-file file)
(when (and recursive
(setq files
(directory-files file t dired-re-no-dot)) ; Not empty.
(or (eq recursive 'always)
(yes-or-no-p (format "Recursive delete of %s "
(dired-make-relative file)))))
(if (eq recursive 'top) (setq recursive 'always)) ; Don't ask again.
(while files ; Recursively delete (possibly asking).
(dired-delete-file (car files) recursive)
(setq files (cdr files))))
(delete-directory file))))))
(defun dvc-sethome (dir)
"Sets $HOME to DIR, safely.
`setenv' is not sufficient because `abbreviated-home-dir' would then
be incorrectly set, breaking a lot of Emacs function."
(setenv "HOME" dir)
(setq abbreviated-home-dir nil))
(defun dvc-read-directory-name (prompt &optional dir default-dirname
mustmatch initial)
"Read directory name, prompting with PROMPT and completing in directory DIR.
Value is not expanded---you must call `expand-file-name' yourself.
Default name to DEFAULT-DIRNAME if user exits with the same
non-empty string that was inserted by this function.
(If DEFAULT-DIRNAME is omitted, the current buffer's directory is used,
except that if INITIAL is specified, that combined with DIR is used.)
If the user exits with an empty minibuffer, this function returns
an empty string. (This can only happen if the user erased the
pre-inserted contents or if `insert-default-directory' is nil.)
Fourth arg MUSTMATCH non-nil means require existing directory's name.
Non-nil and non-t means also require confirmation after completion.
Fifth arg INITIAL specifies text to start with.
DIR should be an absolute directory name. It defaults to
the value of `default-directory'."
(if (fboundp 'read-directory-name)
(read-directory-name prompt dir default-dirname mustmatch initial)
;; The same as the definition of `read-directory-name'
;; in GNU Emacs in CVS.
(unless dir
(setq dir default-directory))
(unless default-dirname
(setq default-dirname
(if initial (concat dir initial) dir)))
(read-file-name prompt dir default-dirname mustmatch initial)))
(defun dvc-create-tarball-from-intermediate-directory (dir tgz-file-name)
"Create a tarball with the content of DIR.
If DIR does not yet exist, wait until it does exist.
Then create the tarball TGZ-FILE-NAME and remove the contents of DIR."
;;create the archive: tar cfz ,,cset.tar.gz ,,cset
(while (not (file-exists-p dir)) ;;somewhat dirty, but seems to work...
(sit-for 0.01))
;;(message "Calling tar cfz %s -C %s %s" tgz-file-name (file-name-directory dir) (file-name-nondirectory dir))
(call-process "tar" nil nil nil "cfz" tgz-file-name "-C" (file-name-directory dir) (file-name-nondirectory dir))
(call-process "rm" nil nil nil "-rf" dir)
(message "Created tarball %s" tgz-file-name))
(defvar dvc-digits (string-to-list "0123456789"))
(defun dvc-digit-char-p (character)
"Returns non-nil if CHARACTER is a digit."
(member character dvc-digits))
(defun dvc-position (item seq &optional comp-func)
"Position of ITEM in list, or nil if not found.
Return 0 if ITEM is the first element of SEQ.
If an optional argument COMP-FUNC is given, COMP-FUNC
is used to compare ITEM with an item of SEQ; returning t
means the two items are the same."
(let ((pos 0)
(seq-int seq))
(unless comp-func
(setq comp-func 'eq))
(while (and seq-int
(not (funcall comp-func item (car seq-int))))
(setq seq-int (cdr seq-int))
(setq pos (1+ pos)))
(when seq-int pos)))
(defun dvc-uniquify-file-name (path &optional resolve-symlinks)
"Return a string containing an absolute path to PATH, which is relative to `default-directory'.
If PATH is a directory,the returned contains one and exactly one trailing
slash. If PATH is nil, then nil is returned.
If RESOLVE-SYMLINKS is non-nil (default nil), resolve symlinks in path."
;; We normally _don'_ want 'file-truename' here, since that
;; eliminates symlinks. We assume the user has configured symlinks
;; the way they want within the workspace, so the view from the
;; current default directory is correct.
;;
;; This may cause problems with the path to the workspace root;
;; `call-process' spawns the backend process with symlinks in the
;; working directory expanded. Most backends get the workspace root
;; from the working directory; if DVC passes the workspace root
;; explicitly to the backend explicitly, it must resolve symlinks at
;; that point.
;;
;; Another case is DVC status buffers (and similar buffers); we
;; don't want to create two buffers to the same workspace with
;; different paths.
;;
;; In these cases, set resolve-symlinks t at the call point.
(and path
(let ((expanded (expand-file-name
(if (file-directory-p path)
(file-name-as-directory path)
path))))
(if resolve-symlinks
(setq expanded (file-truename expanded)))
(if (featurep 'xemacs)
(replace-regexp-in-string "/+$" "/" expanded)
expanded))))
(defun dvc-add-uniquify-directory-mode (mode)
"Add MODE to `uniquify-list-buffers-directory-modes'."
(require 'uniquify)
(when (boundp 'uniquify-list-buffers-directory-modes)
(add-to-list 'uniquify-list-buffers-directory-modes mode)))
(defvar dvc-temp-directory "/tmp"
"Temporary directory for some DVC operations.")
(defun dvc-make-temp-name (file)
"Generate a temporary file name based on FILE.
The path for the file name can be set via `dvc-temp-directory'."
(make-temp-name (concat (dvc-uniquify-file-name dvc-temp-directory) file)))
(defun dvc-buffer-content (buffer)
"Return the content of BUFFER as a string.
Strips the final newline if there is one."
(with-current-buffer buffer
(buffer-substring-no-properties
(point-min)
(progn (goto-char (point-max))
(if (eq (char-before) ?\n)
(- (point) 1)
(point))))))
;; this is no longer needed, because ewoc-create takes now the argument nosep:
;; (defun ewoc-create (pretty-printer &optional header footer nosep)
;; If you need that behaviour: set dvc-ewoc-create-needs-newline to t
(defvar dvc-ewoc-create-needs-newline nil)
(defun dvc-ewoc-create-api-select (pretty-printer)
"Possibly insert a trailing newline after PRETTY-PRINTER call.
Work around `ewoc-create' interface change: oldest versions automatically
added a trailing newline, whereas newest versions do not."
(if dvc-ewoc-create-needs-newline
;; if `ewoc-set-data' is defined, the pretty printer should insert a
;; trailing newline (new `ewoc-create' interface; there is no
;; `ewoc-version', therefore we test on `ewoc-set-data')
`(lambda (elem) (,pretty-printer elem) (insert "\n"))
pretty-printer))
;; ----------------------------------------------------------------------------
;; Face manipulators
;; ----------------------------------------------------------------------------
(defsubst dvc-face-add (str face &optional keymap menu help)
"Add to string STR the face FACE.
Optionally, also add the text properties KEYMAP, MENU and HELP.
If KEYMAP is a symbol, (symbol-value KEYMAP) is used
as a keymap; and `substitute-command-keys' result
against (format \"\\{%s}\" (symbol-name keymap)) is appended to HELP.
If HELP is nil and if MENU is non nil, the MENU title is used as HELP."
(if dvc-highlight
(let* ((strcpy (copy-sequence str))
(key-help (when (symbolp keymap)
(substitute-command-keys (format "\\{%s}" (symbol-name keymap)))))
(prefix-help (if help help (when (and menu (stringp (cadr menu))) (cadr menu))))
(long-help (if key-help
(if prefix-help (concat prefix-help "\n"
;; Sigh. Font used on tooltips in GNU Emacs with Gtk+
;; is a proportional.
;; (make-string (length help) ?=) "\n"
"================" "\n"
key-help) key-help)
help))
(keymap (if (symbolp keymap) (symbol-value keymap) keymap)))
(add-text-properties 0 (length strcpy)
`(face ,face
;;; Even if we define a face in a buffer, it seems that
;;; font-lock mode just ignore it or remove the face property.
;;; I don't know the detail but in tla-inventory buffer,
;;; I cannot make both font-lock keywords and faces put by dvc-face-add
;;; highlight at once. When font-lock-face is defined, I can do.
;;; See "Special Properties" subsection in the emacs lisp reference manual.
;;; `font-lock-face' property is new in Emacs 21.4. However, I guess there is
;;; no wrong side effect if I define font-lock-face property here.
font-lock-face ,face
,@(when keymap
`(mouse-face highlight
keymap ,keymap
help-echo ,long-help))
,@(when menu
`(dvc-cmenu ,menu))
)
strcpy)
strcpy)
str))
(defun dvc-face-add-with-condition (condition text face1 face2)
"If CONDITION then add TEXT the face FACE1, else add FACE2."
(if condition
(dvc-face-add text face1)
(dvc-face-add text face2)))
(defun dvc-flash-line-on ()
"Turn on highline mode or equivalent."
(or (dvc-funcall-if-exists hl-line-mode)
(dvc-funcall-if-exists highline-on)))
(defun dvc-flash-line-off ()
"Turn off highline mode or equivalent."
(or (dvc-funcall-if-exists hl-line-mode)
(dvc-funcall-if-exists highline-off)))
(defun dvc-flash-line ()
"Flash the current line."
(let ((buffer (current-buffer)))
(dvc-flash-line-on)
(sit-for 1000)
;; Avoid to switching buffer by asynchronously running
;; processes.
;; TODO: This is adhoc solution. Something guard-mechanism to avoid
;; buffer switching may be needed.
(set-buffer buffer)
(dvc-flash-line-off)))
;; ----------------------------------------------------------------------------
;; Debugging facilities
;; ----------------------------------------------------------------------------
(defvar dvc-debug nil
"*Indicate whether debugging messages should be printed by `dvc-trace'.")
;;;###autoload
(defun dvc-trace (&rest msg)
"Display the trace message MSG.
Same as `message' if `dvc-debug' is non-nil.
Does nothing otherwise. Please use it for your debug messages."
(when dvc-debug
(apply 'message (concat "dvc: " (car msg)) (cdr msg))))
(defun dvc-trace-current-line ()
"Display the line the cursor is in."
(dvc-trace "Current-line(%s)=%s[_]%s"
(save-restriction (widen) (dvc-line-number-at-pos))
(buffer-substring-no-properties
(line-beginning-position)
(point))
(buffer-substring-no-properties
(point)
(line-end-position))))
(defmacro dvc-features-list ()
"Topological sort of the dependancy graph. Root comes last.
It's a macro so that it remains available after (unload-feature ...)."
(quote '(
;; DVC
dvc-site
dvc-version
dvc-tips
dvc-buffers
dvc-core
dvc-defs
dvc-diff
dvc-emacs
dvc-lisp
dvc-revlog
dvc-revlist
dvc-log
dvc-register
dvc-ui
dvc-unified
dvc-utils
dvc-xemacs
;; xhg
xhg-core
xhg-dvc
xhg-gnus
xhg
;; tla
tla-dvc
tla-bconfig
tla-browse
tla-tests
tla
tla-core
tla-autoconf
tla-defs
tla-gnus
;; baz
baz-dvc
baz
;; bzr
bzr-core
bzr-dvc
bzr-revlist
bzr-revision
bzr
;; xgit
xgit-annotate
xgit-dvc
xgit-gnus
xgit-log
xgit-revision
xgit-core
xgit
)))
(defun dvc-unload ()
"Unloads DVC.
run `unload-feature' for each DVC feature.
TODO: should also remove the hooks setup by DVC
\(`file-find-hook', ...)."
(interactive)
(dolist (feature (dvc-features-list))
(when (featurep feature) (unload-feature feature t)))
(when (featurep 'dvc-autoloads)
(unload-feature 'dvc-autoloads t)))
;;;###autoload
(defun dvc-reload (&optional directory)
"Reload DVC (usually for debugging purpose).
With prefix arg, prompts for the DIRECTORY in which DVC should be
loaded. Useful to switch from one branch to the other.
If a Makefile is present in the directory where DVC is to be loaded,
run \"make\"."
(interactive
(list (when current-prefix-arg
(let* ((other (dvc-read-directory-name
"Load DVC from: "))
(lispdir (concat (file-name-as-directory other)
"lisp")))
(if (file-directory-p lispdir)
lispdir
other)))))
(when directory
(let ((current-path (file-name-directory (locate-library
"dvc-core"))))
(setq load-path
(cons directory (remove current-path load-path)))))
(let ((default-directory (file-name-directory (locate-library "dvc-core"))))
(when (file-exists-p
"Makefile")
(shell-command "make")))
(dvc-unload)
(require 'dvc-autoloads))
(defun dvc-regexp-quote (string)
"Return a regexp string which matches exactly STRING and nothing else.
Special characters are escaped to leave STRING in a suitable form for
Arch."
(let ((quoted (regexp-quote string)))
(replace-regexp-in-string
"\\([{}()|]\\)"
(concat "\\\\" ; leading slash
"\\1") ; quoted character
quoted)))
(defun dvc-pp-to-string (sexp)
"Return sexp pretty printed by `pp-to-string'."
(let ((print-readably t)
print-level print-length)
(pp-to-string sexp)))
(defvar dvc-buffer-refresh-function nil
"Variable should be local to each buffer.
Function used to refresh the current buffer")
(make-variable-buffer-local 'dvc-buffer-refresh-function)
(defun dvc-read-project-tree-maybe (&optional prompt directory prefer-current)
"Return a directory name which is the root of some project tree.
Either prompt from the user or use the current directory.
The behavior can be changed according to the value of
`dvc-read-project-tree-mode'.
PROMPT is used as a user prompt, and DIRECTORY is the starting point
of the project search.
When `dvc-read-project-tree-mode' is `unless-specified',
PREFER-CURRENT non-nil means use current `default-directory' if
it is a valid project tree."
(let* ((root (dvc-tree-root (or directory default-directory) t))
(default-directory (or root
directory
default-directory))
(prompt (or prompt "Use directory: ")))
(case dvc-read-project-tree-mode
(always (dvc-tree-root (dvc-read-directory-name prompt)))
(unless-specified
(if (or directory (and prefer-current root))
(if root
root
(dvc-read-directory-name prompt))
(dvc-read-directory-name prompt)))
(sometimes (or root
(dvc-tree-root (dvc-read-directory-name prompt))))
(never (or root
(error "%s directory is not a DVC managed directory" directory)))
(t (error "`%s': wrong value for dvc-read-project-tree-mode" dvc-read-project-tree-mode)))))
(defun dvc-generic-refresh ()
"Call the function specified by `dvc-buffer-refresh-function'."
(interactive)
(let ((dvc-read-directory-mode 'never)
(dvc-read-project-tree-mode 'never))
(if dvc-buffer-refresh-function
(let ((dvc-temp-current-active-dvc dvc-buffer-current-active-dvc))
(funcall dvc-buffer-refresh-function))
(message "I don't know how to refresh this buffer"))))
(defmacro dvc-make-move-fn (ewoc-direction function cookie
&optional only-unmerged)
"Create function to move up or down in `dvc-revlist-cookie'.
EWOC-DIRECTION is either `ewoc-next' or `ewoc-prev'.
FUNCTION is the name of the function to declare.
COOKIE is the ewoc to navigate in.
if ONLY-UNMERGED is non-nil, then, navigate only through revisions not
merged by another revision in the same list."
(declare (indent 2) (debug (&define functionp name symbolp booleanp)))
`(defun ,function ()
(interactive)
(let* ((elem (ewoc-locate ,cookie))
(next (or (,ewoc-direction ,cookie elem) elem)))
(while (and next
(if ,only-unmerged
(not (and (eq (car (ewoc-data next))
'entry-patch)
(eq (nth 4 (ewoc-data next))
'nobody)))
(eq (car (ewoc-data next)) 'separator))
(,ewoc-direction ,cookie next))
(setq next (,ewoc-direction ,cookie next)))
(while (and next
(if ,only-unmerged
(not (and (eq (car (ewoc-data next))
'entry-patch)
(eq (nth 4 (ewoc-data next))
'nobody)))
(eq (car (ewoc-data next)) 'separator)))
(setq next (,(if (eq ewoc-direction 'ewoc-next)
'ewoc-prev
'ewoc-next) ,cookie next)))
(when next (goto-char (ewoc-location next))))))
(defun dvc-ewoc-maybe-scroll (ewoc node)
"If display of NODE goes off the bottom of the window, recenter."
(let* ((next-node (ewoc-next ewoc node))
(next-loc (if next-node
(ewoc-location next-node)
(ewoc-location (ewoc--footer ewoc)))))
(if (> next-loc (window-end))
;; we tried scroll-up here, but it screws up sometimes
(recenter))
))
(defmacro dvc-make-ewoc-next (function-name ewoc)
"Declare a function FUNCTION-NAME to move to the next EWOC entry."
(declare (indent 2) (debug (&define functionp function-name symbolp)))
`(defun ,function-name (&optional filter no-ding)
(interactive)
"Move to the next ewoc entry.
If optional FILTER is non-nil, skip elements for which FILTER
returns non-nil. FILTER is called with one argument, the ewoc
element. If optional NO-DING, don't ding if there is no next."
(let ((current (ewoc-locate ,ewoc)))
(if current
(let ((cur-location (ewoc-location current))
(next (ewoc-next ,ewoc current)))
(cond
((> cur-location (point))
;; not exactly at an element; move there
(goto-char cur-location)
(dvc-ewoc-maybe-scroll ,ewoc current))
(next
(if filter
(progn
(while (and next
(funcall filter next))
(setq next (ewoc-next ,ewoc next)))
(if next
(goto-char (ewoc-location next))
(unless no-ding (ding))))
(goto-char (ewoc-location next))
(dvc-ewoc-maybe-scroll ,ewoc next)))
(t
;; at last element
(unless no-ding (ding)))))
;; no elements
(unless no-ding (ding))))))
(defmacro dvc-make-ewoc-prev (function-name ewoc)
"Declare a function FUNCTION-NAME to move to the previous EWOC entry."
(declare (indent 2) (debug (&define functionp function-name symbolp)))
`(defun ,function-name (&optional filter no-ding)
"Move to the previous ewoc entry.
If optional FILTER is non-nil, skip elements for which FILTER
returns non-nil. FILTER is called with one argument, the ewoc
element. If optional NO-DING, don't ding if there is no next."
(interactive)
(let ((current (ewoc-locate ,ewoc)))
(if current
(let ((cur-location (ewoc-location current))
(prev (ewoc-prev ,ewoc current)))
(cond
((> (point) cur-location)
(goto-char cur-location))
(prev
(if filter
(progn
(while (and prev
(funcall filter prev))
(setq prev (ewoc-prev ,ewoc prev)))
(if prev
(goto-char (ewoc-location prev))
(unless no-ding (ding))))
(goto-char (ewoc-location prev))))
(t
;; at first element
(unless no-ding (ding)))))
;; no elements
(unless no-ding (ding))))))
(defun dvc-scroll-maybe (buffer up-or-down)
"If BUFFER exists, show it, scroll and return non-nil.
Otherwise, return nil."
(interactive)
(when (buffer-live-p buffer)
(let ((visible (dvc-buffer-visible-p buffer))
(buf (current-buffer)))
(pop-to-buffer buffer)
(when visible
(condition-case nil
(funcall up-or-down 2)
(error (message "Can't scroll anymore."))))
(pop-to-buffer buf))))
(defun dvc-offer-choices (comment choices)
"Present user with a choice of actions, labeled by COMMENT. CHOICES is a list of pairs
containing (symbol description)."
;; Could use "keyboard menu"; see elisp info 22.17.3 Menus and the Keyboard
(let ((msg "use ")
choice)
(dolist (choice choices)
(setq msg (concat msg
(key-description (car (where-is-internal (car choice))))
" (" (cadr choice) ") ")))
(error (if comment
(concat comment "; " msg)
msg))))
(defun dvc-completing-read (&rest args)
"Read a string in the minibuffer, with completion.
Set `dvc-completing-read-function' to determine which function to use.
See `completing-read' for a description of ARGS."
;; Initialize dvc-completing-read-function on the first invocation of dvc-completing-read
;; This allows to enable ido-mode after loading DVC
(when (eq dvc-completing-read-function 'auto)
(setq dvc-completing-read-function (if (and (boundp 'ido-mode) ido-mode)
'ido-completing-read
'completing-read)))
(apply dvc-completing-read-function args))
(defun dvc-default-excluded-files ()
"Return a list of strings (normally file names relative to tree
root) from the file \".dvc-exclude\" in `default-directory'.
Shell wildcards are converted to regexp, for use with
`dvc-match-excluded'."
(if (file-readable-p ".dvc-exclude")
(with-temp-buffer
(insert-file-contents ".dvc-exclude")
(let (result)
(while (< (point) (point-max))
(setq result (append result (list (wildcard-to-regexp (buffer-substring (point) (point-at-eol))))))
(forward-line 1))
result))))
(defun dvc-match-excluded (excluded-files file)
"Non-nil if any element of EXCLUDED-FILES matches FILE,
according to `string-match'."
(let (matched)
(dolist (file-regexp excluded-files matched)
(setq matched
(or matched
(string-match file-regexp file))))
(not (null matched))))
(defun dvc-edit-exclude ()
"Edit the file \".dvc-exclude\" in `default-directory'."
(interactive)
(find-file ".dvc-exclude"))
(defsubst dvc-xor (a b)
(or (and a (not b)) (and (not a) b)))
(defun dvc-message-replace-header (header new-value &optional after force)
"Remove HEADER and insert the NEW-VALUE.
If AFTER, insert after this header. If FORCE, insert new field
even if NEW-VALUE is empty."
;; Similar to `nnheader-replace-header' but for message buffers.
(require 'message)
(save-excursion
(save-restriction
(message-narrow-to-headers)
(message-remove-header header))
(when (or force (> (length new-value) 0))
(if after
(message-position-on-field header after)
(message-position-on-field header))
(insert new-value))))
(provide 'dvc-utils)
;;; dvc-utils.el ends here

426
dvc/lisp/dvc-xemacs.el
View File

@ -1,426 +0,0 @@
;;; dvc-xemacs.el --- Compatibility stuff for XEmacs
;;;
;;; This file should be loaded when using XEmacs; load
;;; dvc-emacs.el when using Gnu Emacs.
;; Copyright (C) 2004-2006, 2008 by all contributors
;; Author: Robert Widhopf-Fenk <hack@robf.de>
;; This file is part of DVC.
;;
;; DVC is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; DVC is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Policy: see dvc-emacs.el for policy on what goes in this file.
;;; Code:
(eval-when-compile
(require 'cl))
(eval-and-compile
(require 'overlay)
(require 'wid-edit)
;; The following require causes a infinite recursion as the (provide ...) is at
;; the file end. Thus we live with the warnings about unknown variables etc.
;;(require 'dvc-core)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; fixes warnings about undefined variables
(unless (boundp 'add-log-buffer-file-name-function)
(defvar add-log-buffer-file-name-function nil))
(unless (boundp 'add-log-file-name-function)
(defvar add-log-file-name-function nil))
(unless (boundp 'add-log-keep-changes-together)
(defvar add-log-keep-changes-together nil))
(unless (boundp 'global-font-lock-mode)
(defvar global-font-lock-mode nil))
(unless (boundp 'vc-ignore-vc-files)
(defvar vc-ignore-vc-files nil))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(unless (functionp 'add-log-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
(if (string-match
(concat "^" (regexp-quote (file-name-directory log-file)))
buffer-file)
(substring buffer-file (match-end 0))
(file-name-nondirectory buffer-file)))
;; If we have a backup file, it's presumably because we're
;; comparing old and new versions (e.g. for deleted
;; functions) and we'll want to use the original name.
(if (backup-file-name-p buffer-file)
(file-name-sans-versions buffer-file)
buffer-file)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; the unless check seems to fail
;;(unless (functionp 'replace-regexp-in-string)
(defun replace-regexp-in-string (regexp rep string
&optional fixedcase literal)
(replace-in-string string regexp rep literal))
;;)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(unless (functionp 'line-end-position)
(defun line-end-position ()
(save-excursion (end-of-line) (point))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(unless (functionp 'line-beginning-position)
(defun line-beginning-position (&optional n)
(save-excursion
(if n (forward-line n))
(beginning-of-line)
(point))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(unless (functionp 'mouse-set-point)
(defun mouse-set-point (event)
(goto-char (event-point event))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(unless (functionp 'match-string-no-properties)
(defun match-string-no-properties (arg &optional string)
(match-string arg string)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(unless (functionp 'clone-buffer)
(defun clone-buffer (&optional newname display-flag)
"Create a twin copy of the current buffer.
If NEWNAME is nil, it defaults to the current buffer's name;
NEWNAME is modified by adding or incrementing <N> at the end as necessary.
If DISPLAY-FLAG is non-nil, the new buffer is shown with `pop-to-buffer'.
This runs the normal hook `clone-buffer-hook' in the new buffer
after it has been set up properly in other respects."
(interactive (list (if current-prefix-arg (read-string "Name: "))
t))
(if buffer-file-name
(error "Cannot clone a file-visiting buffer"))
(if (get major-mode 'no-clone)
(error "Cannot clone a buffer in %s mode" mode-name))
(setq newname (or newname (buffer-name)))
(if (string-match "<[0-9]+>\\'" newname)
(setq newname (substring newname 0 (match-beginning 0))))
(let ((buf (current-buffer))
(ptmin (point-min))
(ptmax (point-max))
(pt (point))
(mk (mark t))
(modified (buffer-modified-p))
(mode major-mode)
(lvars (buffer-local-variables))
(process (get-buffer-process (current-buffer)))
(new (generate-new-buffer (or newname (buffer-name)))))
(save-restriction
(widen)
(with-current-buffer new
(insert-buffer-substring buf)))
(with-current-buffer new
(narrow-to-region ptmin ptmax)
(goto-char pt)
(if mk (set-mark mk))
(set-buffer-modified-p modified)
;; Clone the old buffer's process, if any.
(when process (clone-process process))
;; Now set up the major mode.
(funcall mode)
;; Set up other local variables.
(mapcar (lambda (v)
(condition-case () ;in case var is read-only
(if (symbolp v)
(makunbound v)
(set (make-local-variable (car v)) (cdr v)))
(error nil)))
lvars)
;; Run any hooks (typically set up by the major mode
;; for cloning to work properly).
(run-hooks 'clone-buffer-hook))
(if display-flag (pop-to-buffer new))
new)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(unless (functionp 'make-temp-file)
(defun make-temp-file (prefix &optional dir-flag)
"Create a temporary file.
The returned file name (created by `make-temp-name', is guaranteed to point to
a newly created empty file.
You can then use `write-region' to write new data into the file.
If DIR-FLAG is non-nil, create a new empty directory instead of a file."
(let (file)
(while (condition-case ()
(progn
(setq file
(make-temp-name
(expand-file-name prefix)))
(if dir-flag
(make-directory file)
(write-region "" nil file nil 'silent nil))
nil)
(file-already-exists t))
;; the file was somehow created by someone else between
;; `make-temp-name' and `write-region', let's try again.
nil)
file)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; AFAIK easy-menu cannot be used for dynamic menus
(defun dvc-xemacs-dvc-mode-p (buf)
"Helper function for menu-related functions.
Return t if BUF is a dvc-related buffer."
(if (bufferp buf)
(setq buf (format "%s" (symbol-value-in-buffer 'major-mode buf))))
(string-match "^dvc-" buf))
(defvar dvc-dead-process-buffer-queue nil)
(defun dvc-xemacs-buffers-menu (menu)
"Create the markers-menu.
MENU is the menu to which items should be added."
(interactive (list nil))
(let ((bufs (buffer-list))
(queue dvc-dead-process-buffer-queue)
queue-menu
b)
;; the user buffers
(while bufs
(setq b (car bufs)
bufs (cdr bufs))
(if (dvc-xemacs-dvc-mode-p b)
(setq menu (cons (vector (buffer-name b)
(list 'switch-to-buffer b) t)
menu))))
(setq menu (sort menu
(lambda (m1 m2) (string< (aref m1 0) (aref m2 0)))))
;; the queue buffers
(while queue
(setq b (car queue)
queue (cdr queue)
queue-menu (cons (vector (buffer-name b)
(list 'switch-to-buffer b) t)
queue-menu)))
(setq queue-menu (sort queue-menu
(lambda (m1 m2) (string< (aref m1 0) (aref m2 0)))))
;; combine menus
(setq menu (cons (append '("Queue") queue-menu) menu))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun dvc-group-buffers-menu-by-mode-then-alphabetically (buf1 buf2)
"For use as a value of `buffers-menu-grouping-function'.
This groups buffers by major mode. It only really makes sense if
`buffers-menu-sorting-function' is
'dvc-sort-buffers-menu-by-mode-then-alphabetically'.
(setq buffers-menu-grouping-function 'dvc-group-buffers-menu-by-mode-then-alphabetically)
BUF1 and BUF2 are successive members of the sorted buffers list after
being passed through `buffers-menu-sort-function'. It should return
non-nil if the second buffer begins a new group.
This is a modified version of
`group-buffers-menu-by-mode-then-alphabetically'
adding an submenu \"DVC\" containing all dvc buffers."
(cond ((and buf1 buf2
(not (dvc-xemacs-dvc-mode-p buf1))
(dvc-xemacs-dvc-mode-p buf2))
(if (string-match "\\`*" (buffer-name buf1))
"*Misc*"
(symbol-value-in-buffer 'mode-name buf1)))
((and buf1
(dvc-xemacs-dvc-mode-p buf1)
(or (not buf2)
(not (dvc-xemacs-dvc-mode-p buf2))))
"DVC")
((string-match "\\`*" (buffer-name buf1))
(and (null buf2) "*Misc*"))
((or (null buf2)
(string-match "\\`*" (buffer-name buf2))
(not (eq (symbol-value-in-buffer 'major-mode buf1)
(symbol-value-in-buffer 'major-mode buf2))))
(symbol-value-in-buffer 'mode-name buf1))
(t nil)))
(defun dvc-sort-buffers-menu-by-mode-then-alphabetically (buf1 buf2)
"For use as a value of `buffers-menu-sort-function'.
Sorts first by major mode and then alphabetically by name, but puts buffers
beginning with a star at the end of the list.
(setq buffers-menu-sort-function 'dvc-sort-buffers-menu-by-mode-then-alphabetically)
It will be passed two arguments BUF1 and BUF2 (two buffers to compare)
and will return t if the first is \"less\" than the second.
This is a modified version of `sort-buffers-menu-by-mode-then-alphabetically',
causing all *dvc-* buffers to be treated as having the same major mode."
(let* ((nam1 (buffer-name buf1))
(nam2 (buffer-name buf2))
(inv1p (not (null (string-match "\\` " nam1))))
(inv2p (not (null (string-match "\\` " nam2))))
(star1p (not (null (string-match "\\`*" nam1))))
(star2p (not (null (string-match "\\`*" nam2))))
(mode1 (symbol-value-in-buffer 'major-mode buf1))
(mode2 (symbol-value-in-buffer 'major-mode buf2)))
(if (dvc-xemacs-dvc-mode-p mode1)
(setq mode1 "dvc"))
(if (dvc-xemacs-dvc-mode-p mode1)
(setq mode2 "dvc"))
(cond ((not (eq inv1p inv2p))
(not inv1p))
((not (eq star1p star2p))
(not star1p))
((and star1p star2p (string-lessp nam1 nam2)))
((string-lessp mode1 mode2)
t)
((string-lessp mode2 mode1)
nil)
(t
(string-lessp nam1 nam2)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; since the custom.el coming with XEmacs does not know about the :inherit
;; keyword of defface we are dealing with it for our faces ...
(let ((faces (face-list)) face inherit)
(while faces
(setq face (car faces)
faces (cdr faces))
(when (string-match "^dvc-" (format "%s" face))
(setq inherit (assoc :inherit (car (custom-face-get-spec face))))
(if inherit
(set-face-parent face (cadr inherit))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(unless (functionp 'minibuffer-contents)
(defun minibuffer-contents ()
"Return the user input in a minbuffer as a string.
The current buffer must be a minibuffer."
(buffer-substring)))
(unless (functionp 'minibufferp)
(defun minibufferp ()
"Return non-nil if within a minibuffer."
(equal (selected-window)
(active-minibuffer-window))))
(unless (functionp 'diff-hunk-next)
(defalias 'diff-hunk-next 'diff-next-hunk))
(unless (functionp 'diff-hunk-prev)
(defalias 'diff-hunk-prev 'diff-prev-hunk))
(defalias 'dvc-expand-file-name 'expand-file-name)
;; FIXME: move to dvc-utils?
(defun dvc-xmas-make-temp-dir (prefix)
"Make a temporary directory using PREFIX.
Return the name of the directory."
(let ((dir (make-temp-name (expand-file-name prefix (temp-directory)))))
(make-directory dir)
dir))
(defalias 'dvc-make-temp-dir 'dvc-xmas-make-temp-dir)
;; From Gnus.
(defun dvc-xmas-move-overlay (extent start end &optional buffer)
(set-extent-endpoints extent start end buffer))
(defun dvc-xmas-kill-all-overlays ()
"Delete all extents in the current buffer."
(map-extents (lambda (extent ignore)
(delete-extent extent)
nil)))
(defun dvc-xmas-add-text-properties (start end props &optional object)
(add-text-properties start end props object)
(put-text-property start end 'start-closed nil object))
(defun dvc-xmas-put-text-property (start end prop value &optional object)
(put-text-property start end prop value object)
(put-text-property start end 'start-closed nil object))
(defun dvc-xmas-assq-delete-all (key alist)
(let ((elem nil))
(while (setq elem (assq key alist))
(setq alist (delq elem alist)))
alist))
(defalias 'dvc-make-overlay 'make-extent)
(defalias 'dvc-delete-overlay 'delete-extent)
(defalias 'dvc-overlay-put 'set-extent-property)
(defalias 'dvc-move-overlay 'dvc-xmas-move-overlay)
(defalias 'dvc-overlay-buffer 'extent-object)
(defalias 'dvc-overlay-start 'extent-start-position)
(defalias 'dvc-overlay-end 'extent-end-position)
(defalias 'dvc-kill-all-overlays 'dvc-xmas-kill-all-overlays)
(defalias 'dvc-extent-detached-p 'extent-detached-p)
(defalias 'dvc-add-text-properties 'dvc-xmas-add-text-properties)
(defalias 'dvc-put-text-property 'dvc-xmas-put-text-property)
(defalias 'dvc-deactivate-mark 'ignore)
(defalias 'dvc-window-edges 'window-pixel-edges)
(defalias 'dvc-assq-delete-all 'dvc-xmas-assq-delete-all)
(defconst dvc-mouse-face-prop 'highlight)
;; end from Gnus
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defalias 'dvc-line-number-at-pos (if (functionp 'line-number-at-pos)
'line-number-at-pos
'line-number))
(defvar allow-remote-paths nil)
(if (fboundp 'ewoc-delete)
(defalias 'dvc-ewoc-delete 'ewoc-delete)
(defun dvc-ewoc-delete (ewoc &rest nodes)
"Delete NODES from EWOC."
(ewoc--set-buffer-bind-dll-let* ewoc
((L nil) (R nil) (last (ewoc--last-node ewoc)))
(dolist (node nodes)
;; If we are about to delete the node pointed at by last-node,
;; set last-node to nil.
(when (eq last node)
(setf last nil (ewoc--last-node ewoc) nil))
(delete-region (ewoc--node-start-marker node)
(ewoc--node-start-marker (ewoc--node-next dll node)))
(set-marker (ewoc--node-start-marker node) nil)
(setf L (ewoc--node-left node)
R (ewoc--node-right node)
;; Link neighbors to each other.
(ewoc--node-right L) R
(ewoc--node-left R) L
;; Forget neighbors.
(ewoc--node-left node) nil
(ewoc--node-right node) nil)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(provide 'dvc-xemacs)
;; Local Variables:
;; End:
;;; dvc-xemacs.el ends here

136
dvc/lisp/tests/bzr-tests.el
View File

@ -1,136 +0,0 @@
;;; bzr-tests.el --- Automated regression tests for bzr
;; Copyright (C) 2007, 2008 Stephen Leake
;; Author: Stephen Leake
;; adapted from xmtn-tests.el
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2 of the License, or
;; (at your option) any later version.
;;
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this file; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
;; Boston, MA 02110-1301 USA.
;;; Commentary:
;; Automated regression tests for bzr-dvc.
;;; Code:
;; These tests require elunit.el from dvc/lisp/contrib, originally
;; from http://dev.technomancy.us/phil/wiki/ElUnit
(require 'bzr-dvc)
(require 'cl)
(require 'dvc-tests-utils "tests/dvc-tests-utils.el")
(require 'elunit)
;;; This is preferable over separate set-up and tear-down functions
;;; since it allows us to make use of `unwind-protect' and dynamic
;;; bindings.
(defun bzr-tests--call-with-test-environment (bzr--body)
"Initialize a bzr workspace, call BODY"
(lexical-let ((body bzr--body)
(temp-dir nil))
(unwind-protect
(progn
(setq temp-dir (file-name-as-directory (make-temp-file "bzr-tests-" t)))
(let ((default-directory temp-dir))
(dvc-run-dvc-sync 'bzr '("init"))
(funcall body)
(dvc-tests-wait-async)))
(if temp-dir
;; If this delete doesn't succeed, there is a real problem,
;; so we don't try to handle the error.
(dired-delete-file temp-dir 'always)))))
(defun bzr-tests--call-with-test-history (bzr--body)
"Create a test environment with one file with some change
history. Call BODY with one key arg :file-name; the file name of
the test file."
(lexical-let ((body bzr--body))
(bzr-tests--call-with-test-environment
(function*
(lambda ()
(lexical-let ((file-name "file-1"))
(with-temp-file file-name (insert "a\n"))
(bzr-add file-name)
(dvc-run-dvc-sync 'bzr '("commit" "--message" "\"commit 1\""))
(with-temp-file file-name (insert "b\n"))
(dvc-run-dvc-sync 'bzr '("commit" "--message" "\"commit 2\""))
(funcall body
:file-name file-name)))))))
(defmacro* bzr-tests--with-test-environment ((&rest keys) &body body)
(declare (indent 1) (debug sexp body))
`(bzr-tests--call-with-test-environment (function* (lambda (,@keys) ,@body))))
(defmacro* bzr-tests--with-test-history ((&rest keys) &body body)
(declare (indent 1) (debug sexp body))
`(bzr-tests--call-with-test-history (function* (lambda (,@keys) ,@body))))
(defsuite bzr
(log
(save-window-excursion
(bzr-tests--with-test-history (&key &allow-other-keys)
;; The test is simply that this doesn't crash.
(dvc-log)
(dvc-tests-wait-async) ; let log display
(dvc-revlist-show-item))))
(file-diff
;; The test is simply that this doesn't crash.
(save-window-excursion
(bzr-tests--with-test-history (&key file-name &allow-other-keys)
(find-file file-name)
(unwind-protect
(progn
(insert "x")
(save-excursion
(call-interactively #'dvc-file-diff)))
(revert-buffer t t)))))
(diff
;; The test is simply that this doesn't crash.
(save-window-excursion
(bzr-tests--with-test-history (&key file-name &allow-other-keys)
(find-file file-name)
(insert "x")
(write-file file-name)
(call-interactively #'dvc-diff))))
(diff-from-revlog
;; The test is simply that this doesn't crash.
(save-window-excursion
(bzr-tests--with-test-history (&key &allow-other-keys)
(dvc-changelog)
(dvc-tests-wait-async) ; let log display
(dvc-revision-next)
(dvc-revlist-diff))))
)
;;(elunit "bzr")
(defsuite bzr-one
(log
(save-window-excursion
(bzr-tests--with-test-history
(&key &allow-other-keys)
(dvc-diff))))
)
;;(elunit "bzr-one")
(provide 'bzr-tests)
;;; bzr-tests.el ends here

43
dvc/lisp/tests/dvc-tests-utils.el
View File

@ -1,43 +0,0 @@
;;; dvc-tests-utils.el --- Utilities for automated regression tests
;; Copyright (C) 2007 Stephen Leake
;; Author: Stephen Leake
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2 of the License, or
;; (at your option) any later version.
;;
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this file; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
;; Boston, MA 02110-1301 USA.
(eval-and-compile
(require 'cl))
(defun dvc-tests-wait-async ()
"Waits for all asynchronous dvc processes to terminate."
(let* ((delay 0.2)
(seconds-before-message 2)
(iterations-before-message (/ seconds-before-message delay))
(iterations 0))
(while dvc-process-running
(when (>= iterations iterations-before-message)
(setq iterations 0)
(message "Waiting for processes: %S"
(mapcar (lambda (entry)
(dvc-event-command (second entry)))
dvc-process-running)))
(incf iterations-before-message)
(sit-for delay))))
(provide 'dvc-tests-utils)
;; end of file

657
dvc/lisp/tests/xmtn-tests.el
View File

@ -1,657 +0,0 @@
;;; xmtn-tests.el --- Automated regression tests for xmtn
;; Copyright (C) 2006, 2007 Christian M. Ohler
;; Author: Christian M. Ohler
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2 of the License, or
;; (at your option) any later version.
;;
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this file; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
;; Boston, MA 02110-1301 USA.
;;; Commentary:
;; Automated regression tests for xmtn.
;;; Code:
;;; There are some notes on the design of xmtn in
;;; docs/xmtn-readme.txt.
;; These tests require elunit.el from
;; http://dev.technomancy.us/phil/wiki/ElUnit .
(eval-and-compile
(require 'cl)
(require 'elunit)
(require 'elp) ;; elp-elapsed-time is a 'defsubst', so we require elp at load time, not run time.
(require 'xmtn-match)
(require 'xmtn-dvc)
(require 'dvc-tests-utils "tests/dvc-tests-utils.el"))
(defun xmtn-tests--keypair-string ()
"[keypair xmtn-test]
MIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQDFE8/sRvdvN5+F5aFVpXeJpz0eKAzhYdWB
uW3L0C1tWnLk+HzYV13ewKMtFzwkoTeITTX5q372zH2XSIcUR2jBCArQf8Ru40886nLwG7zU
G1cI3B86akQknDUn3t9C1jEHXlBJiPLwaWrcmMFhoA+PnE49gopudw4q6Yhg1YCOqwIDAQAB#
MIICyTBDBgkqhkiG9w0BBQ0wNjAeBgkqhkiG9w0BBQwwEQQIccoCNMR2fIYCAggAAgEYMBQG
CCqGSIb3DQMHBAgjnJz0whELeQSCAoDEzuBbQf7hf43ULUZR7gFBrXilg+KBgItlA0Mz6jmI
0+LzoHhJiU3rnyR1MsXkf7uCBFje5Uqj53vUrnrBbxgGBFHwOw1Kic+lbDtvAKlNLPPPl9h8
W9QrQYhEg9VsmYBUvxZnyw5Kmafpmh1wC/fRSchDmWyhUeJHtkZhnUgcG9OFi6z8JT64/VGw
ZhB46Q2dGLrygjHRArA8FIOX5dlGzyRNfa0w5dVWZED7IcQVCoBLwLiEb9woK+fyEuK12fM+
23U8/sAO74MMOoyvs+OoloPtgniHuRdc/1RV9CS9k64mnzJdOnhR/GxQIL36LZcNrHvnM9Nn
xrK2yDkuk39JcLDJlFPZok7vluEn1GCKKGce3Z2LP6VPTJAqBHgt1fTMBAT5bc7rbVQxzVEU
56anNOMR1T9MRnbX5u5Hpj5mNIqbWX+g3YCIgKIJXbtD57GixPP4s/mP2EcAAeZvWiGeTF6Z
GyNq8USmlEjXpMrIWqLk+f6OzDyvk05sTQByRlKwOGzgbyNnWsetKC97wFfsBExNKhKeFFTV
6HOehUEPHIrikNaLed52czpqaKcQ67uVfdWXs3drwS7V0RRtTdcAzy0u95bERPrRpCY3tq/a
CGp3K4RF00eJQLBa94D9LYIEMBk4evfKCijcId0b4kzIQS1SI1sytnt+P1zPQaV5yAetOOD/
fuHfnYU27Mqis5V23xo1ibjDS1fa3/E6XK2P+Y3rHuyjQ/QbFlcBwj0vjv8yqwRWOe5y6Msd
f6S7jhNd76i/o3K/DmnpnI1N8RODAd77uejpe8K0xthzk2q02VtrBXA7jpY7oSaIaKJPov6v
YPFoLxe1V5oOyoe3ap0H
[end]")
(defun xmtn-tests--default-rc-file ()
;; Monotone versions up to and including 0.33 don't allow empty
;; passphrases.
"function get_passphrase(keypair_id) return \"a\" end")
;;; This is preferable over seperate set-up and tear-down functions
;;; since it allows us to make use of `unwind-protect' and dynamic
;;; bindings.
(defun xmtn-tests--call-with-test-environment (xmtn--body)
(lexical-let ((body xmtn--body))
(lexical-let ((temp-dir nil))
(unwind-protect
(progn
(setq temp-dir (file-name-as-directory
(xmtn--make-temp-file "xmtn-tests-" t)))
(lexical-let ((key-dir (concat temp-dir "keys/"))
(rc-file (concat temp-dir "rc")))
(let* ((default-directory temp-dir)
(dvc-test-mode t)
(xmtn-additional-arguments
`("--db" ,(concat temp-dir "a.mtn")
"--keydir" ,key-dir
"--norc"
"--rcfile" ,rc-file)))
(make-directory key-dir)
(with-temp-file (concat key-dir "xmtn-tests")
(insert (xmtn-tests--keypair-string) ?\n))
(with-temp-file rc-file
(insert (xmtn-tests--default-rc-file) ?\n))
(xmtn--run-command-sync nil '("db" "init"))
(xmtn--run-command-sync nil '("setup"
"--branch" "invalid.xmtn-tests"
"workspace"))
(let ((default-directory (concat temp-dir "workspace/")))
(funcall body
:root default-directory)))))
(when temp-dir
(dired-delete-file temp-dir 'always))))))
(defun xmtn-tests--call-with-test-history (xmtn--body)
(lexical-let ((body xmtn--body))
(xmtn-tests--call-with-test-environment
(function*
(lambda (&key ((:root xmtn--root)))
(lexical-let ((root xmtn--root)
(file-name "file-1")
revision-1
revision-2)
(with-temp-file file-name (insert "a\n"))
(xmtn--add-files root (list file-name))
(xmtn--run-command-sync root `("commit" "--message=commit 1"))
(setq revision-1 (xmtn--get-base-revision-hash-id root))
(with-temp-file file-name (insert "b\n"))
(xmtn--run-command-sync root `("commit" "--message=commit 2"))
(setq revision-2 (xmtn--get-base-revision-hash-id root))
(funcall body
:root root
:file-name file-name
:revision-1 revision-1
:revision-2 revision-2)))))))
(defmacro* xmtn-tests--with-test-environment ((&rest keys) &body body)
(declare (indent 1) (debug (sexp body)))
`(xmtn-tests--call-with-test-environment (function* (lambda (,@keys) ,@body))))
(defmacro* xmtn-tests--with-test-history ((&rest keys) &body body)
(declare (indent 1) (debug (sexp body)))
`(xmtn-tests--call-with-test-history (function* (lambda (,@keys) ,@body))))
(defsuite xmtn
(xmtn--match
(progn
(assert (xmtn-match--match-variable-p '$x ?$))
(assert (xmtn-match--match-variable-p '@x ?@))
(assert (not (xmtn-match--match-variable-p "$x" ?$)))
(assert (not (xmtn-match--match-variable-p 'x ?$)))
(assert (xmtn-match--contains-match-variable-p '$x ?$))
(assert (xmtn-match--contains-match-variable-p '(a b $x c) ?$))
(assert (xmtn-match--contains-match-variable-p '[a $y $z c] ?$))
(assert (xmtn-match--contains-match-variable-p '(nil . $y) ?$))
(assert (xmtn-match--contains-match-variable-p '((() $a)) ?$))
(assert (not (xmtn-match--contains-match-variable-p 'x ?$)))
(assert (not (xmtn-match--contains-match-variable-p '(a . b) ?$)))
(assert (not (xmtn-match--contains-match-variable-p nil ?$)))
(assert (not (xmtn-match--contains-match-variable-p '((() ())) ?$)))
(assert (not (xmtn-match--contains-match-variable-p nil ?$)))
(assert (equal (xmtn-match '(a b)
(($y $y) nil)
($z z))
'(a b)))
(assert (equal (xmtn-match '(a a)
(($y $y) y))
'a))
(assert (equal (xmtn-match '(a b)
($z z)
($z nil))
'(a b)))
(assert (xmtn-match nil ([t $y] y) ($z t)))
(assert (xmtn-match [foo bar] ([foo $y] y)))
(assert (xmtn-match [foo bar] ((a . b) nil) ([foo bar] t)))
(assert (xmtn-match nil (nil t)))))
(xmtn--version-case
(flet ((xmtn--latest-mtn-release () ;flet has dynamic scope in Emacs Lisp
'(2 5 "y")))
(let* ((xmtn-executable 'xmtn-dummy)
(xmtn--*command-version-cached-for-executable* xmtn-executable))
(let ((xmtn--*cached-command-version* '(2 5 "x")))
(assert
(xmtn--version-case
((and (= 2 5) (>= 2 5) (or (= 2 4) (<= 3 0))
(<= 2 6) (/= 1 5) (not (/= 2 5))
(not (>= 2 6))
(not (<= 2 4))
(not (< 2 5))
(not (< 2 4))) t)
(t nil)))
(assert
(not (ignore-errors
(xmtn--version-case
(nil t)))))
(assert (xmtn--version-case ((mainline> 2 4) t) (t nil)))
(assert (xmtn--version-case ((mainline> 2 5) t) (t nil)))
(assert (xmtn--version-case ((mainline> 2 6) nil) (t t))))
(let ((xmtn--*cached-command-version* '(2 5 "y")))
(assert (xmtn--version-case ((mainline> 2 4) t) (t nil)))
(assert (xmtn--version-case ((mainline> 2 5) nil) (t t)))
(assert (xmtn--version-case ((mainline> 2 6) nil) (t t))))
(let ((xmtn--*cached-command-version* '(1 5 "w")))
(assert (xmtn--version-case ((mainline> 2 4) nil) (t t)))
(assert (xmtn--version-case ((mainline> 2 5) nil) (t t)))
(assert (xmtn--version-case ((mainline> 1 4) t) (t nil)))
(assert (xmtn--version-case ((mainline> 1 5) nil) (t t))))
(let ((xmtn--*cached-command-version* '(2 6 "z")))
(assert (xmtn--version-case ((mainline> 2 4) t) (t nil)))
(assert (xmtn--version-case ((mainline> 2 5) t) (t nil)))
(assert (xmtn--version-case ((mainline> 2 6) nil) (t t)))))))
(log
(save-window-excursion
(xmtn-tests--with-test-history (&key &allow-other-keys)
;; The test is simply that this doesn't crash.
(dvc-log)
(dvc-revlist-show-item))))
(file-diff
;; The test is simply that this doesn't crash.
(save-window-excursion
(xmtn-tests--with-test-history (&key file-name &allow-other-keys)
(find-file file-name)
(unwind-protect
(progn
(insert "x")
(save-excursion
(call-interactively #'dvc-file-diff)))
(revert-buffer t t)))))
(diff
;; The test is simply that this doesn't crash.
(save-window-excursion
(xmtn-tests--with-test-history (&key file-name &allow-other-keys)
(find-file file-name)
(let ((buffer (current-buffer)))
(unwind-protect
(progn
(insert "x")
(write-region (point-min) (point-max)
file-name nil 'no-message nil nil)
(set-buffer-modified-p nil)
(call-interactively #'dvc-diff))
(dvc-tests-wait-async)
(with-current-buffer buffer
(set-buffer-modified-p nil)
(kill-buffer buffer)))))))
(automate-buffer-numbering
(xmtn-tests--with-test-history (&key root &allow-other-keys)
(xmtn-automate-with-session (session root)
(xmtn-automate-with-command (handle-1 session '("graph") :may-kill-p t)
(sleep-for 0.5)
(xmtn-automate-terminate-processes-in-root root)
(xmtn-automate-with-command (handle-2 session '("graph")
:may-kill-p nil)
(assert (not (equal (xmtn-automate-command-buffer handle-1)
(xmtn-automate-command-buffer handle-2))))
(xmtn-automate-command-wait-until-finished handle-2))))))
(automate-several-commands
(xmtn-tests--with-test-history (&key root &allow-other-keys)
;; The test is simply that this doesn't crash.
(xmtn-automate-with-session (session root)
(xmtn-automate-with-command (cmd session '("graph") :may-kill-p nil))
(xmtn-automate-with-command (cmd session '("graph") :may-kill-p nil))
(xmtn-automate-with-command (cmd session '("graph") :may-kill-p nil))
(xmtn-automate-with-command (cmd session '("graph") :may-kill-p nil))
(xmtn-automate-with-command (cmd session '("graph") :may-kill-p t))
(xmtn-automate-with-command (cmd session '("graph") :may-kill-p t)
;;(xmtn-automate-command-wait-until-finished cmd)
))
;; Try to delay deletion of our temp workspace until process has
;; terminated.
(sleep-for 1)))
(non-ascii-file-name
(let ((umlaut (string (make-char 'latin-iso8859-1 #xe4)))) ; umlaut a
(xmtn-tests--with-test-environment (&key root)
(let ((file-name umlaut))
(let ((file-name-coding-system 'utf-8)) ; not sure about this...
(with-temp-file file-name ; create empty file
(progn)))
(xmtn--add-files root (list file-name))
(let ((manifest (xmtn--get-manifest root `(local-tree ,root))))
(xmtn-match manifest
(((dir "") (file $file-name-here $hash-id $attributes))
(assert (equal file-name-here file-name) t)
(assert (endp attributes)))))
;; Check whether xmtn-automate encodes the file name
;; correctly when passing it to monotone. The actual command
;; doesn't matter as much as the fact that monotone receives
;; it correctly.
(xmtn--with-automate-command-output-basic-io-parser
(next-stanza root (xmtn--version-case
((mainline> 0 35) `("get_attributes" ,file-name))
(t `("attributes" ,file-name))))
(xmtn-match (funcall next-stanza)
((("format_version" (string "1")))))
(assert (null (funcall next-stanza)) t))))))
(non-ascii-file-contents
(let ((umlaut (string (make-char 'latin-iso8859-1 #xe4)))) ; umlaut a
(xmtn-tests--with-test-environment (&key root)
(let ((file-name "foo")
(contents (concat umlaut "\n"))
(coding-system 'iso-8859-1-unix))
(with-temp-file file-name
(setq buffer-file-coding-system coding-system)
(insert contents))
(xmtn--add-files root (list file-name))
(xmtn--run-command-sync root (list "commit" "--message=commit foo"))
(let ((content-id "77785e6fd883a5e27a62bc6f26365e1b37e1900f"))
(assert (equal (xmtn--file-contents-as-string root content-id)
(encode-coding-string contents coding-system))
t))))))
(non-ascii-cert-value
(let ((umlaut (string (make-char 'latin-iso8859-1 #xe4)))) ; umlaut a
(xmtn-tests--with-test-history (&key root revision-2 &allow-other-keys)
(let ((cert-name "test-cert")
(cert-value umlaut))
(xmtn--run-command-sync root `("cert" "--"
,revision-2
,cert-name ,cert-value))
(let ((certs (xmtn--list-parsed-certs root revision-2)))
(let ((matching-certs (remove* cert-name certs
:key #'third
:test-not #'equal)))
(xmtn-match matching-certs
((($email ok $cert-name-here $cert-value-here t))
(assert (equal cert-name-here cert-name) t)
(assert (equal cert-value-here cert-value) t)))))))))
(dvc-file-diff-with-non-ascii-contents
(save-window-excursion
(let ((umlaut (string (make-char 'latin-iso8859-1 #xe4)))) ; umlaut a
(xmtn-tests--with-test-environment (&key root)
(let ((file-name "foo")
(contents (concat umlaut "\n"))
(coding-system 'utf-8-unix))
(with-temp-file file-name
(setq buffer-file-coding-system coding-system)
(insert contents))
(xmtn--add-files root (list file-name))
(xmtn--run-command-sync root (list "commit" "--message=commit foo"))
(with-temp-buffer
(let ((coding-system-for-read coding-system))
(insert-file-contents file-name t))
(dvc-file-diff file-name)
(assert (eql (point-min) (point-max)))))))))
(buffer-file-coding-system-in-dvc-dvc-file-diff
(save-window-excursion
(let ((umlaut (string (make-char 'latin-iso8859-1 #xe4)))) ; umlaut a
(xmtn-tests--with-test-environment (&key root)
(let ((file-name "foo")
(contents (concat umlaut "\n"))
(coding-system-1 'utf-8-unix)
(coding-system-2 'iso-8859-1-unix))
(with-temp-file file-name
(setq buffer-file-coding-system coding-system-1)
(insert contents))
(xmtn--add-files root (list file-name))
(xmtn--run-command-sync root (list "commit" "--message=commit foo"))
(with-temp-buffer
(insert-file-contents file-name t)
(setq buffer-file-coding-system coding-system-2)
(let ((coding-system-for-read coding-system-1))
(dvc-file-diff file-name))
(assert (not (eql (point-min) (point-max))))))))))
(file-diff-after-rename
(xmtn-tests--with-test-history (&key root ((:file-name file-name-1))
revision-2
&allow-other-keys)
(let ((file-name-2 "bar"))
(xmtn--run-command-sync root
(xmtn--version-case
((>= 0 34)
`("mv" "--" ,file-name-1 ,file-name-2))
(t
`("mv" "-e" "--" ,file-name-1 ,file-name-2))))
(with-temp-buffer
(xmtn--revision-get-file-helper file-name-2 revision-2)
(assert (equal (buffer-substring (point-min) (point-max))
"b\n")
t)))))
(diff-from-revlog
(save-window-excursion
(xmtn-tests--with-test-history (&key &allow-other-keys)
(unwind-protect
(progn
(dvc-changelog)
(dvc-revision-next)
(dvc-revlist-diff))
(dvc-tests-wait-async)))))
(stdio-command-options
(xmtn--version-case
((>= 0 31)
(xmtn-tests--with-test-history (&key root file-name
revision-1 revision-2
&allow-other-keys)
(let ((root default-directory))
(assert
(equal
(xmtn-automate-simple-command-output-lines
root `(("revision" ,revision-1
"revision" ,revision-2)
"content_diff" ,file-name))
'("============================================================"
"--- file-1 3f786850e387550fdab836ed7e6dc881de23001b"
"+++ file-1 89e6c98d92887913cadf06b2adb97f26cde4849b"
"@@ -1 +1 @@"
"-a"
"+b"))
t))))
(t
(xmtn-tests--with-test-history (&key root file-name
revision-1 revision-2)
(assert (not (ignore-errors
(message "%S" (xmtn-automate-simple-command-output-lines
root `(("revision" ,revision-1
"revision" ,revision-2)
"content_diff" ,file-name)))
t)))))))
(xmtn-dvc-command-version
;; Should not error.
(xmtn-dvc-command-version))
(dvc-file-diff-write-file-hooks
(save-window-excursion
(xmtn-tests--with-test-history (&key file-name &allow-other-keys)
(find-file file-name)
(unwind-protect
(progn
(let ((write-file-hooks (list (lambda ()
(assert nil)))))
(insert "x")
(save-excursion
(call-interactively #'dvc-file-diff))))
(revert-buffer t t)))))
(get-content-changed-closure
(save-window-excursion
(xmtn-tests--with-test-history (&key root file-name revision-1 revision-2
&allow-other-keys)
(let ((other-file-name (concat file-name "2"))
(renamed-file-name (concat file-name "x"))
revision-3 revision-4 revision-5)
(progn
(with-temp-file other-file-name (insert "a\n"))
(xmtn--add-files root (list other-file-name))
(xmtn--run-command-sync root `("commit" "--message=commit"))
(setq revision-3 (xmtn--get-base-revision-hash-id root)))
(progn
(xmtn--run-command-sync root
(xmtn--version-case
((>= 0 34)
`("mv" "--" ,file-name ,renamed-file-name))
(t
`("mv" "-e" "--" ,file-name
,renamed-file-name))))
(xmtn--run-command-sync root `("commit" "--message=commit"))
(setq revision-4 (xmtn--get-base-revision-hash-id root)))
(progn
(with-temp-file renamed-file-name (insert "c\n"))
(xmtn--run-command-sync root `("commit" "--message=commit"))
(setq revision-5 (xmtn--get-base-revision-hash-id root)))
(flet ((check (file start-rev expected-results)
(let ((actual (xmtn--get-content-changed-closure
root `(revision ,start-rev) file)))
(unless (null (set-exclusive-or expected-results
actual
:test #'equal))
(error "file=%S start-rev=%s expected=%S actual=%S; revisions=%S"
file start-rev expected-results actual
(list revision-1 revision-2 revision-3 revision-4
revision-5))))))
(check file-name revision-1 `((,revision-1 ,file-name)))
;; Some of these checks fail with mtn 0.30; not
;; investigated further.
;;
;; 0.30 reports ((1 file))
(check file-name revision-2 `((,revision-1 ,file-name)
(,revision-2 ,file-name)))
;; 0.30 reports ((1 file))
(check file-name revision-3 `((,revision-1 ,file-name)
(,revision-2 ,file-name)))
;; 0.30 reports ((1 file) (4 renamed))
(check renamed-file-name revision-4 `((,revision-1 ,file-name)
(,revision-2 ,file-name)))
;; 0.30 reports ((1 file) (4 renamed))
(check renamed-file-name revision-5 `((,revision-1 ,file-name)
(,revision-2 ,file-name)
(,revision-5
,renamed-file-name)))
(check other-file-name revision-3 `((,revision-3 ,other-file-name)))
(check other-file-name revision-4 `((,revision-3 ,other-file-name)))
(check other-file-name revision-5 `((,revision-3 ,other-file-name)))
)))))
(locale
;; The test is simply that this doesn't crash.
(let ((process-environment (list* "LC_MESSAGES=de_DE" process-environment))
(xmtn--*cached-command-version* nil))
;; Unfortunately, in my configuration, I don't seem to be able to
;; get monotone to print non-English messages at all. So, for
;; me, this doesn't actually fail even without the appropriate
;; changes to `xmtn--call-with-environment-for-subprocess'.
(xmtn-check-command-version)))
(xmtn--file-registered-p
(xmtn-tests--with-test-history (&key root file-name &allow-other-keys)
(assert (xmtn--file-registered-p root file-name))
(assert (not (xmtn--file-registered-p root "nonexistent-file")))))
(dvc-status-add
(save-window-excursion
(xmtn-tests--with-test-environment
(&key &allow-other-keys)
;; add and commit an unknown file, using dvc-status keystrokes
(with-temp-file "unknown" (insert "unknown - to be added\n"))
(with-temp-file "unknown-marked" (insert "unknown, marked\n"))
(dvc-status)
(dvc-tests-wait-async)
(assert (looking-at " unknown unknown"))
(execute-kbd-macro (vector dvc-key-add))
(dvc-tests-wait-async)
(assert (looking-at " added unknown"))
(forward-line)
(assert (looking-at " unknown unknown-marked"))
(execute-kbd-macro (vector dvc-key-mark dvc-key-add))
;; FIXME: checking for the mark doesn't work; something about the fontification of the line.
(dvc-tests-wait-async)
(execute-kbd-macro (vector dvc-key-unmark))
(assert (looking-at " added unknown-marked"))
;; FIXME: commit hangs when run from this test, in xmtn--insert-log-edit-hints, which runs stuff asynchronously
;; (execute-kbd-macro (vector dvc-key-commit))
;; (dvc-tests-wait-async)
;; (debug)
;; (execute-kbd-macro (vector "C-c" "C-c"))
;; this works
(dvc-log-edit)
(dvc-tests-wait-async)
(dvc-log-edit-done)
(dvc-tests-wait-async)
;; currently need dvc-status-refresh to see results of the
;; commit; eventually dvc-status will edit the ewoc directly
(dvc-status-refresh)
(dvc-tests-wait-async)
(assert (looking-at "$"))
)))
)
(defvar xmtn-tests--profile-history (list))
(defun xmtn-tests--profile ()
(interactive)
(unless (not xmtn--*enable-assertions*)
(unless (y-or-n-p "Assertions appear to be enabled. Continue anyway? ")
(error "Aborted")))
(let ((command
(read-from-minibuffer "Profile xmtn command: "
nil read-expression-map t
'xmtn-tests--profile-history))
(reps 20))
(elp-instrument-package "xmtn-")
(elp-instrument-package "dvc-")
(elp-instrument-package "process-")
(elp-instrument-package "ewoc-")
(elp-instrument-function 'accept-process-output)
(elp-instrument-function 'buffer-substring-no-properties)
(elp-reset-all)
(setq elp-reset-after-results nil)
;; FIXME: Maybe use benchmark.el.
(let ((gc-cons-threshold (max gc-cons-threshold 100000000))
(run-time 0)
(gc-time 0))
(assert (garbage-collect))
(loop for rep from 1
repeat reps
do
(with-temp-message (format "Profiling, repetition %s of %s..."
rep reps)
(save-excursion
(save-window-excursion
(let ((start-time (current-time)))
(eval command)
(let ((end-time (current-time)))
(incf run-time (elp-elapsed-time start-time
end-time))))))
(assert (let ((start-time (current-time)))
(prog1
(garbage-collect)
(let ((end-time (current-time)))
(incf gc-time (elp-elapsed-time start-time
end-time))))))))
(elp-results)
(setq truncate-lines t)
(goto-char (point-min))
(insert (format "Command: %S\n" command))
(insert (format "Repetitions: %s\n" reps))
(insert "\n")
(insert (format "Wall time (excluding gc): %s\n" run-time))
(insert (format "GC time (bogus): %s\n" gc-time))
(insert "\n"))
(elp-restore-all))
(message "Profiling finished"))
(defun xmtn-tests--time ()
(interactive)
(unless (not xmtn--*enable-assertions*)
(unless (y-or-n-p "Assertions appear to be enabled. Continue anyway? ")
(error "Aborted")))
(let ((command
(read-from-minibuffer "Time xmtn command: "
nil read-expression-map t
'xmtn-tests--profile-history))
(reps 10)) ;; FIXME: dies on rep 30 on Windows MinGW
;; Run command once before starting timing to get everything in cache
(eval command)
(let ((run-time 0))
(assert (garbage-collect))
(loop for rep from 1
repeat reps
do
(with-temp-message (format "Timing, repetition %s of %s..."
rep reps)
(save-excursion
(save-window-excursion
(let ((start-time (current-time)))
(eval command)
(let ((end-time (current-time)))
(incf run-time (elp-elapsed-time start-time
end-time))))))))
(switch-to-buffer-other-window (get-buffer-create
"*xmtn timing results*"))
(erase-buffer)
(setq truncate-lines t)
(goto-char (point-min))
(insert (format "Command: %S\n" command))
(insert (format "Repetitions: %s\n" reps))
(insert "\n")
(insert (format "Wall time (including gc): %s\n" run-time))
(insert "\n")))
(message "Timing finished"))
(defun xmtn-tests--parse-basic-io-inventory-benchmark (mtn-executable tree)
(let ((default-directory tree)
(xmtn-executable mtn-executable)
(xmtn--*cached-command-version* nil))
(xmtn-automate-with-session (session (dvc-tree-root))
(xmtn-automate-with-command (handle session '("inventory"))
(xmtn-automate-command-wait-until-finished handle)
(xmtn-automate-command-check-for-and-report-error handle)
(xmtn-basic-io-with-stanza-parser (parser (xmtn-automate-command-buffer
handle))
(let ((changed 0)
(total 0)
(unknown 0)
(ignored 0))
(loop for stanza = (funcall parser)
while stanza
do (incf total)
do (let ((status (second (assoc "status" stanza))))
(xmtn-match status
((string "known"))
((string "missing"))
((string "unknown") (incf unknown))
((string "ignored") (incf ignored)))
(let ((changes (second (assoc "changes" stanza))))
(unless (null changes)
(incf changed)))))
(message "total=%s changed=%s ignored=%s unknown=%s"
total changed ignored unknown)))))))
(provide 'xmtn-tests)
;;; xmtn-tests.el ends here

226
dvc/lisp/tla-autoconf.el
View File

@ -1,226 +0,0 @@
;;; tla-autoconf.el --- Arch interface for emacs
;; Copyright (C) 2003-2005 by all contributors
;; Author: Stefan Reichoer, <stefan@xsteve.at>
;; Contributions from:
;; Matthieu Moy <Matthieu.Moy@imag.fr>
;; Masatake YAMATO <jet@gyve.org>
;; Milan Zamazal <pdm@zamazal.org>
;; Martin Pool <mbp@sourcefrog.net>
;; Robert Widhopf-Fenk <hack@robf.de>
;; Mark Triggs <mst@dishevelled.net>
;; Xtla is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; Xtla is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;
;; Autoconfiguration of Xtla, depending on the client (different
;; versions of tla and baz)
;;
;; Each autodected feature has a corresponding variable and a
;; corresponding function. The variable's name is
;; tla--autoconf-<feature> and serves *only* as a cache. The possible
;; values are 'yes 'no and nil (for "don't know").
;; The function's name is tla-<feature>, and is the one to use.
;;; History:
;;
;; Created on May 28, 2005 by Matthieu Moy.
;;; Code:
(eval-when-compile
(require 'cl))
;; ----------------------------------------------------------------------------
;; Wether a command exists
;; ----------------------------------------------------------------------------
(defmacro tla--has-foo-command (cmd)
"Create the autodetection function for the command CMDNAME.
Checks if the command CMDNAME exists (appear in the output of the
\"help\" command."
(declare (debug (stringp)))
(let ((var (intern (concat "tla--autoconf-has-" cmd "-command")))
(fun (intern (concat "tla-has-" cmd "-command"))))
`(progn
(defvar ,var nil
,(format "Whether tla|baz has a %s command.
Possible values are nil (don't know), 'yes, or 'no. Don't use this
variable directly. Use `tla-has-%s-command' instead." cmd cmd))
(defun ,fun ()
,(format "Whether tla|baz has a %s command.
Returns 't or nil.
If `tla--autoconf-has-%s-command' is non-nil, use its value.
Otherwise, test if \"%s\" is listed by \"tla|baz help\", and memorize
the result in `tla--autoconf-has-%s-command'." cmd cmd cmd cmd)
(interactive)
(let ((answer
(cond ((eq ,var 'yes) t)
((eq ,var 'no) nil)
(t (tla--run-tla-sync
'("help")
:finished (lambda (output error status
arguments)
(with-current-buffer output
(goto-char (point-min))
(search-forward (concat " " ,cmd " :")
nil t))))))))
(when (interactive-p)
(message (if answer "Yes" "No")))
(setq ,var
(if answer 'yes 'no))
answer)))))
(tla--has-foo-command "escape") ; support for spaces in filename
(tla--has-foo-command "diff")
(tla--has-foo-command "file-diff")
(tla--has-foo-command "tree-id")
(tla--has-foo-command "status")
(tla--has-foo-command "switch")
(tla--has-foo-command "merge")
(tla--has-foo-command "resolved")
(tla--has-foo-command "lint")
(tla--has-foo-command "branch")
(tla--has-foo-command "add-id")
;; ----------------------------------------------------------------------------
;; Wether commands need or support an option
;; ----------------------------------------------------------------------------
(defmacro tla--foo-has-bar-option (cmdname cmd option helpstring)
"Create the autodetection function for the command CMDNAME.
Checks if the command CMDNAME accepts the option OPTION. CMD may be a
lisp expression that returns the actual command to execute (usefull
for commands whose name is not the same for baz and tla. HELPSTRING is
the string to search for in the output of CMD --help."
(declare (debug (stringp form stringp stringp)))
(let ((var (intern (concat "tla--autoconf-" cmdname "-has-" option "-option")))
(fun (intern (concat "tla-" cmdname "-has-" option "-option"))))
`(progn
(defvar ,var nil
,(format "Whether \"tla|baz %s\" needs the --%s option.
Possible values are nil (don't know), 'yes, or 'no. Don't use this
variable directly. Use `tla-%s-has-%s-option' instead." cmdname option
cmdname option))
(defun ,fun ()
,(format "Whether \"tla|baz %s\" needs the --%s option.
Returns 't or nil.
If `tla--autoconf-%s-has-%s-option' is non-nil, use its value. Otherwise, test
if \"--%s\" is listed by \"tla %s --help\", and memorize the result in
`tla--autoconf-%s-has-%s-option'." cmdname option cmdname option option
cmdname cmdname option)
(interactive)
(let ((answer
(cond ((eq ,var 'yes) t)
((eq ,var 'no) nil)
(t (tla--run-tla-sync
(list ,cmd "--help")
:finished (lambda (output error status arguments)
(with-current-buffer output
(goto-char (point-min))
(search-forward ,helpstring
nil t))))))))
(when (interactive-p)
(message (if answer "Yes" "No")))
(setq ,var
(if answer 'yes 'no))
answer)))))
(tla--foo-has-bar-option "tag" (if (tla-has-branch-command)
"branch" "tag")
"setup" " -S, --setup")
(tla--foo-has-bar-option "merge" (if (tla-has-merge-command)
"merge" "star-merge")
"three-way" " -t, --three-way")
(tla--foo-has-bar-option "merge" (if (tla-has-merge-command)
"merge" "star-merge")
"show-ancestor" " --show-ancestor")
(tla--foo-has-bar-option "switch" "switch" "show-ancestor"
" --show-ancestor")
(tla--foo-has-bar-option "merge" (if (tla-has-merge-command)
"merge" "star-merge")
"two-way" " --two-way")
(tla--foo-has-bar-option "import" "import" "setup" " -S, --setup")
(tla--foo-has-bar-option "archives" "archives" "all-locations"
" --all-locations")
(tla--foo-has-bar-option "inventory" "inventory" "no-recursion"
" --no-recursion")
(tla--foo-has-bar-option "revisions" "revisions" "complete-log"
" -l, --complete-log")
(tla--foo-has-bar-option "missing" "missing" "full" " -f, --full")
(tla--foo-has-bar-option "archive-mirror" "archive-mirror" "all-mirrors"
" -a, --all-mirrors")
(defalias 'tla-use-baz-archive-registration 'tla-archive-mirror-has-all-mirrors-option)
;; ----------------------------------------------------------------------------
;; Management of autoconf variables
;; ----------------------------------------------------------------------------
(defun tla-autoconf-reset ()
"Forget the autodetected values about tla or baz capabilities.
Reset all variable whose name start with \"tla--autoconf-\" to nil."
(interactive)
(dolist (var (apropos-internal "^tla--autoconf-"))
(set var nil)))
(defun tla-autoconf-show ()
"Show the autodetected values about tla or baz capabilities.
Reset all variable whose name start with \"tla--autoconf-\" to nil."
(interactive)
(dvc-switch-to-buffer (get-buffer-create "*xtla-config*"))
(erase-buffer)
(dolist (var (apropos-internal "^tla--autoconf-"))
(let ((value (eval var)))
(insert (symbol-name var) ": "
(cond ((eq value 'yes) "Yes")
((eq value 'no) "No")
((eq value nil) "Don't know")
(t (error "incorrect value")))
"\n"))))
(defun tla-autoconf-compute ()
"Autodetect values about tla or baz capabilities."
(interactive)
(dolist (var (apropos-internal "^tla--autoconf-"))
(let* ((name (symbol-name var))
(func-name (replace-regexp-in-string "^tla--autoconf-"
"tla-" name))
(fn (intern func-name))
(value (funcall fn))))
nil))
(defun tla-autoconf-show-compute ()
"Autodetect and show values about tla or baz capabilities."
(interactive)
(tla-autoconf-compute)
(tla-autoconf-show))
(provide 'tla-autoconf)
;;; tla-autoconf.el ends here

151
dvc/lisp/tla-bconfig.el
View File

@ -1,151 +0,0 @@
;;; tla-bconfig.el --- mode for input file of GNU arch's build-config
;; Copyright (C) 2005 Free Software Foundation, Inc.
;; Author: Masatake YAMATO <jet@gyve.org>
;; Keywords:
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;
;;; Code:
(eval-and-compile
(require 'tla)
(require 'easymenu))
(defvar tla-bconfig-font-lock-keywords
'(("#.*$" . 'dvc-comment)
("\\(\\./[^ \n\t]*\\)[ \t]+\\(.*\\)"
(1 'dvc-local-directory) (2 'tla-archive-name)))
"Keywords in tla-bconfig mode.")
(defvar tla-bconfig-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "\t" 'tla-bconfig-insert-contents)
(define-key map " " 'tla-bconfig-insert-contents)
(define-key map "." 'tla-bconfig-insert-contents-dot)
;;
(define-key map "\C-c\t" 'tla-insert-location)
(define-key map "\C-c " 'tla-insert-location)
;;
(define-key map "\C-c/" 'tla-bconfig-insert-directory)
(define-key map "\C-c." 'tla-bconfig-insert-directory)
(define-key map "\C-c\C-c" 'tla-build-config)
(define-key map "\C-c\C-v" 'tla-cat-config)
map)
"Keymap used in `tla-bconfig-mode'.")
(easy-menu-define tla-bconfig-mode-menu tla-bconfig-mode-map
"`tla-bconfig-mode' menu"
`("Build-Config"
["Insert Directory" tla-bconfig-insert-directory t]
["Insert Name" tla-insert-location t]
"--"
["Run cat-config" tla-cat-config t]
["Run build-config" tla-build-config t]))
(defun tla-bconfig-insert-directory ()
"Read a directory relative from tla's tree root, and insert it."
(interactive)
(let* ((base-dir (tla-tree-root))
(dir (dvc-read-directory-name "Directory: " base-dir)))
(when dir
(insert "./"
(directory-file-name
(substring (expand-file-name dir)
(length (expand-file-name base-dir))))))))
(defun tla-bconfig-insert-contents (n)
"Insert a directory or tla name depending on the point position."
(interactive "p")
(cond
;; In comment: Insert self.
((nth 4 (parse-partial-sexp (point) (point-min)))
(self-insert-command n))
;; Beginning of line: Insert a directory.
((bolp)
(tla-bconfig-insert-directory))
;; filename + space + X
;; If X is still empty, insert a tla name at ?.
((save-excursion
(beginning-of-line)
(and (re-search-forward "\\(\\./[^ \t\n]*\\)[ \t]+\\(.*\\)"
(line-end-position)
t)
(match-beginning 2)))
(goto-char (match-beginning 2))
(when (eq 0 (length (match-string 2)))
(tla-insert-location)))
;; filename
;; Insert tab, then insert a tla name.
((save-excursion
(beginning-of-line)
(and (re-search-forward "\\(\\./[^ \t\n]*\\)"
(line-end-position)
t)
(match-end 1)))
(goto-char (match-end 1))
(insert "\t")
(tla-insert-location))
;; In other case insert self.
(t (self-insert-command n))))
(defun tla-bconfig-insert-contents-dot (n)
""
(interactive "p")
(if (bolp)
(tla-bconfig-insert-contents n)
(self-insert-command n)))
(defvar tla-bconfig-mode-syntax-table
(let ((st (make-syntax-table)))
(modify-syntax-entry ?# "<" st)
(modify-syntax-entry ?\n ">" st)
st)
"Syntax table used in tla-bconfig mode.")
;;;###autoload
(defun tla-bconfig-mode ()
"Major mode to edit GNU arch's build config files."
(interactive)
(kill-all-local-variables)
(set-syntax-table tla-bconfig-mode-syntax-table)
(use-local-map tla-bconfig-mode-map)
(set (make-local-variable 'font-lock-defaults)
'(tla-bconfig-font-lock-keywords t))
(set (make-local-variable 'comment-start) "#")
(setq major-mode 'tla-bconfig-mode
mode-name "tla-bconfig")
(run-hooks 'tla-bconfig-mode-hook))
;;;###autoload
(add-to-list 'auto-mode-alist '("\\.arch$" . tla-bconfig-mode))
(provide 'tla-bconfig)
;; Local Variables:
;; End:
;; tla-bconfig.el ends here

1500
dvc/lisp/tla-browse.el
View File

File diff suppressed because it is too large Load Diff

1906
dvc/lisp/tla-core.el
View File

File diff suppressed because it is too large Load Diff

2040
dvc/lisp/tla-defs.el
View File

File diff suppressed because it is too large Load Diff

141
dvc/lisp/tla-dvc.el
View File

@ -1,141 +0,0 @@
;;; tla-dvc.el --- The dvc layer for xtla
;; Copyright (C) 2005-2008 by all contributors
;; Author: Stefan Reichoer, <stefan@xsteve.at>
;; Contributors: Matthieu Moy, <Matthieu.Moy@imag.fr>
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; This file provides the common dvc layer for tla support
;;; History:
;;
;;; Code:
(require 'tla-core)
(eval-and-compile (require 'dvc-unified))
;; ----------------------------------------------------------------------------
;; The dvc functionality
;; ----------------------------------------------------------------------------
;;;###autoload
(dvc-register-dvc 'tla "GNU Arch")
(defalias 'tla-dvc-tree-root 'tla-tree-root)
(defun tla-dvc-diff (base-rev path dont-switch)
;; 09.09.2007: We should use base-rev here, but that
;; does not work for tla. So drop base-rev to make dvc-diff work for tla again...
;;(tla-changes nil base-rev))
(tla-changes nil))
(defun tla-dvc-file-diff (file &optional base modified dont-switch)
;; FIXME: tla-file-diff expects BASE is a string.
;; However, tla-dvc-file-diff receives BASE in a list revision form.
;; To fill the gap, nil is passed to. -- Masatake.
;; FIXME: only tla overrides dvc-dvc-file-diff; perhaps it doesn't need to?
(tla-file-diff file nil modified dont-switch))
(defun tla-dvc-status ()
(tla-changes t nil))
(defalias 'tla-dvc-submit-patch 'tla-submit-patch)
(defun tla-dvc-update ()
(interactive)
(tla-update default-directory))
(defun tla-dvc-log-edit (&optional root other-frame no-init)
(interactive "P")
(tla-edit-log nil (current-buffer) other-frame))
(defun tla-dvc-add (file)
(tla-add nil file))
(defun tla-dvc-remove-files (&rest files)
"Call `tla-remove' to remove a list of files."
(apply 'tla-remove nil files))
(defun tla-dvc-rename (from-name to-name bookkeep-only)
(interactive)
(tla-move from-name to-name bookkeep-only))
(defun tla-dvc-log (arg last-n)
"Show the log for the current Arch tree."
(tla-logs))
(defun tla-dvc-changelog ()
"Show the changelog for the current Arch tree."
(tla-changelog))
(defun tla-dvc-search-file-in-diff (file)
(re-search-forward (concat "^\\+\\+\\+ mod/" file "$")))
(defalias 'tla-dvc-name-construct 'tla--name-construct)
(defun tla-dvc-revision-direct-ancestor (revision)
`(tla (revision ,(tla-revision-direct-ancestor (cadr (cadr revision))))))
(defun tla-dvc-log-edit-file-name-func ()
(tla-make-log))
(defun tla-dvc-inventory ()
(interactive)
(tla-inventory))
(defun tla-dvc-missing (&optional other)
(interactive)
;; eventually move the user input logic from tla-missing-1 to this function...
(tla-missing-1 (tla-tree-root nil t) (tla-tree-version)))
;;;###autoload
(defalias 'tla-dvc-command-version 'tla-command-version)
(defun tla-dvc-delta (base modified &optional dont-switch)
(interactive (error "TODO: interactive not implemented"))
(if (and (eq (dvc-revision-get-type base) 'previous-revision)
(eq (dvc-revision-get-type modified) 'revision)
(equal (car (dvc-revision-get-data
(car (dvc-revision-get-data base))))
(car (dvc-revision-get-data modified))))
;; base is the ancestor of modified. Optimization possible
(tla-get-changeset (car (dvc-revision-get-data
(car (dvc-revision-get-data base))))
t)
(tla-delta (tla--name-construct (tla-revision-id-to-list base))
(tla--name-construct (tla-revision-id-to-list modified))
nil dont-switch)))
;; TODO: This should be an alias for tla-revert-files in the future.
(defun tla-dvc-revert-files (&rest files)
"See `tla-inventory-revert-file'"
(mapcar 'tla-inventory-revert-file files))
;;;###autoload
(defalias 'tla-dvc-file-has-conflict-p 'tla-file-has-conflict-p)
(defalias 'tla-dvc-resolved 'tla-resolved)
(defalias 'tla-dvc-init 'tla-start-project)
(provide 'tla-dvc)
;;; tla-dvc.el ends here

168
dvc/lisp/tla-gnus.el
View File

@ -1,168 +0,0 @@
;;; tla-gnus.el --- dvc integration to gnus
;; Copyright (C) 2003-2006 by all contributors
;; Author: Stefan Reichoer, <stefan@xsteve.at>
;; Xtla is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; Xtla is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
(require 'tla-core)
(require 'dvc-gnus)
;; gnus is optional. Load it at compile-time to avoid warnings.
(eval-when-compile
(condition-case nil
(progn
(require 'gnus)
(require 'gnus-art)
(require 'gnus-sum))
(error nil)))
;; Integration into gnus
(autoload 'tla-categories-string "tla")
(autoload 'tla-branches-string "tla")
(autoload 'tla-versions-string "tla")
(autoload 'tla-revisions-string "tla")
(autoload 'tla--button-revision-fn "tla")
(defun tla-gnus-setup-buttons ()
"Make archive@host.com/something clickable in Gnus Article buffer."
(interactive)
(add-to-list 'gnus-button-alist
'((tla-make-name-regexp 0 t t) 1 t
tla-categories-string 1))
(add-to-list 'gnus-button-alist
'((tla-make-name-regexp 1 t t) 1 t
tla-branches-string 1))
(add-to-list 'gnus-button-alist
'((tla-make-name-regexp 2 t t) 1 t
tla-versions-string 1))
(add-to-list 'gnus-button-alist
'((tla-make-name-regexp 3 t t) 1 t
tla-revisions-string 1))
(add-to-list 'gnus-button-alist
'((tla-make-name-regexp 4 t t) 1 t
tla--button-revision-fn 1)))
;;;###autoload
(defun tla-insinuate-gnus ()
"Integrate the tla backend of DVC into Gnus.
Add the `tla-submit-patch-done' function to the
`message-sent-hook'.
The archives/categories/branches/version/revision names are buttonized
in the *Article* buffers."
(interactive)
(add-hook 'message-sent-hook 'tla-submit-patch-done)
(tla-gnus-setup-buttons))
(defun tla-gnus-article-view-patch (n)
"View MIME part N in a gnus article, as a tla changeset.
The patch can be embedded or external. If external, the
parameter N is ignored."
(interactive)
(gnus-summary-select-article-buffer)
(if (> (gnus-article-mime-total-parts) 1)
(tla-gnus-article-view-attached-patch 2)
(tla-gnus-article-view-external-patch)))
(defun tla-gnus-article-view-attached-patch (n)
"View MIME part N, as tla patchset."
(interactive "p")
(gnus-article-part-wrapper n 'tla-gnus-view-patch))
(defun tla-gnus-article-view-external-patch ()
"View an external patch that is referenced in this mail.
The mail must either contain a line starting with 'Committed ' and ending
with the fully qualified revision name.
The second supported format contains an extra line for Revision and Archive."
(interactive)
(let ((revision)
(archive)
(version)
(window-conf (current-window-configuration)))
(gnus-summary-select-article-buffer)
(split-window-vertically)
(goto-char (point-min))
(cond ((re-search-forward (concat "Committed " (tla-make-name-regexp 4 nil t)) nil t)
(setq version (buffer-substring-no-properties
(+ (match-beginning 0) 10) (- (match-end 0) 1))))
(t
(when (search-forward "Revision: " nil t)
(setq revision (buffer-substring-no-properties (point) (line-end-position))))
(when (search-forward "Archive: " nil t)
(setq archive (buffer-substring-no-properties (point) (line-end-position))))
(when (and archive revision)
(setq version (concat archive "/" revision)))))
(gnus-article-show-summary)
(if version
(progn
(tla-get-changeset version t)
(save-excursion
(set-buffer (dvc-get-buffer tla-arch-branch 'changeset version))
(dvc-buffer-push-previous-window-config window-conf)))
(message "No external arch patch found in this article.")
(set-window-configuration window-conf))))
(defun tla-gnus-view-patch (handle)
"View a patch within gnus. HANDLE should be the handle of the part."
(let ((archive-name (dvc-make-temp-name "gnus-patch-tgz"))
(window-conf (current-window-configuration)))
(mm-save-part-to-file handle archive-name)
(gnus-summary-select-article-buffer)
(split-window-vertically)
(tla-show-changeset-from-tgz archive-name)
(dvc-buffer-push-previous-window-config window-conf)
(delete-file archive-name)))
(defun tla-gnus-article-apply-patch (n)
"Apply MIME part N, as tla patchset.
When called with no prefix arg, set N := 2."
(interactive "p")
(unless current-prefix-arg
(setq n 2))
(gnus-article-part-wrapper n 'tla-gnus-apply-patch))
(defun tla-gnus-apply-patch (handle)
"Apply the patch corresponding to HANDLE."
(dvc-gnus-article-extract-log-message)
(let ((archive-name (dvc-make-temp-name "gnus-patch-tgz"))
(tree-dir (tla--name-match-from-list
(when dvc-memorized-version
(tla--name-split dvc-memorized-version))
tla-apply-patch-mapping))
(tree)
(window-conf (current-window-configuration)))
(mm-save-part-to-file handle archive-name)
(gnus-summary-select-article-buffer)
(split-window-vertically)
(tla-show-changeset-from-tgz archive-name)
(dvc-buffer-push-previous-window-config window-conf)
(setq tree (dvc-read-directory-name "Apply to tree: "
tree-dir tree-dir))
(tla-apply-changeset-from-tgz archive-name tree nil)
(delete-file archive-name)
(when (eq major-mode 'tla-inventory-mode)
(delete-other-windows))))
(provide 'tla-gnus)
;;; tla-gnus.el ends here

537
dvc/lisp/tla-tests.el
View File

@ -1,537 +0,0 @@
;;; tla-tests.el --- unit tests for tla.el
;; Copyright (C) 2004 Free Software Foundation, Inc.
;; Author: Matthieu Moy <Matthieu.Moy@imag.fr>
;; Modified by: Mark Triggs <mst@dishevelled.net>
;; Keywords: lisp
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; This is a test framework and a set of testcase for xtla.
;; Any user is welcome to run M-x tla-tests-batch RET, and send the
;; output in case a test fails. One can also run a particular testcase
;; with M-x tla-tests-run RET
;; xtla developers are strongly encourraged to write new testcases.
;; Doing so is rather simple :
;;
;; 1) write a function, and name it `tla-test-...'. The function must
;; raise an error when the test fails. A few functions are provided to
;; the test writers. Please refer to their docstrings for details:
;; `tla-tests-log' => write a message to the log buffer
;; `tla-tests-buffer-nonreg' => compares a buffer with the previous
;; execution of the test.
;;
;; 2) Add the parameters of the testcases to the alists
;; `tla-tests-command-alist' and `tla-tests-init-alist'. The first one
;; gives the expected list of tla commands to be ran. The second one
;; says how the testcase should be ran.
;;; History:
;;
;; Created in September 2004 after a discussion on IRC
;;; Code:
(eval-when-compile (require 'cl))
(require 'tla)
(require 'tla-autoconf)
;;
;; xtla-tests parameters
;;
(defvar tla-tests-scratch-dir (expand-file-name "~/tmp/arch-test")
"Directory where the test can write.
WARNING: This directory will be deleted before each test.")
(defvar tla-tests-archive-location
(concat tla-tests-scratch-dir "/archive")
"Location of the archive used for xtla testing.
Must be a subdir of `tla-tests-scratch-dir'.")
(defvar tla-tests-wd-location
(concat tla-tests-scratch-dir "/wd")
"Location of a possible working directory used for xtla testing.
Must be a subdir of `tla-tests-scratch-dir'.")
(defvar tla-tests-log-buffer nil
"Buffer where the tests will output messages.")
(defvar tla-tests-archive-name "foo@bar.com--2004"
"The name of the test archive to use.")
(defvar tla-tests-project-name "xtla--test--1.0"
"The name of the test project to use.")
;;
;; Testcase parameters
;;
(defconst tla-tests-command-alist
`((tla-test-my-id "my-id" "my-id"
"my-id John\\ Smith\\ \\<john\\@smith.com\\>"
"my-id")
(tla-test-make-archive
,(concat "make-archive foo\\@bar.com--2004 "
tla-tests-archive-location)
"archives --all-locations" "my-default-archive")
(tla-test-changes-what-changed-original-file)
(tla-test-changes "inventory --nested --trees"
"inventory --nested --trees"
"changes --diffs" "changes --diffs")
(tla-test-changes-baz "diff" "inventory --nested --trees" "inventory --nested --trees" "diff"))
"List of tla/baz commands that should be executed by each test."
)
(defconst tla-tests-init-alist
'((tla-test-my-id noid noarch noproject)
(tla-test-make-archive noarch noproject)
(tla-test-changes-what-changed-original-file noid noarch noproject)
(tla-test-changes)
(tla-test-revision-lessp noid noarch noproject)
(tla-test-recursive-update noproject nocmdcheck)
(tla-test--position)
(tla-test--digit-char-p)
)
"Alist used by the initialization phase of each test.
Each element must be of the form (testcase list-of-features). The list
of feature can contain the symbols
* noid: Don't fix tla my-id
* noarch: Don't create an archive
* noproject: Otherwise, create a project in the archive with a base-0
and a patch-1
* nocmdcheck: Don't check which tla commands are run
* get: Runs tla get on the project in the archive TODO
* changes: do some modifications in the working directory after tla
get TODO")
;;
;; Functions to run tests
;;
;;;###autoload
(defun tla-tests-batch ()
"Run all the available test-cases in batch mode."
(interactive)
(tla-tests-log "***************************")
(tla-tests-log "* Starting new batch test *")
(tla-tests-log "***************************")
(let ((failed 0)
(ok 0)
(list-tests (apropos-internal "^tla-test-" 'fboundp)))
(while list-tests
(if (tla-tests-run (car list-tests))
(setq ok (1+ ok))
(setq failed (1+ failed)))
(setq list-tests (cdr list-tests)))
(tla-tests-log "**********************")
(tla-tests-log "* Batch test report: *")
(tla-tests-log "* Passed: %3d *" ok)
(tla-tests-log "* Failed: %3d *" failed)
(tla-tests-log "**********************")
))
(defun tla-tests-log (message &rest format-params)
"Logs the message (format MESSAGE FORMAT-PARAMS).
Log messages are written to the tests log buffer."
(unless (buffer-live-p tla-tests-log-buffer)
(setq tla-tests-log-buffer (get-buffer-create "*tla-tests*")))
(let ((message (apply 'format message format-params)))
(with-current-buffer tla-tests-log-buffer
(goto-char (point-max))
(insert message)
(newline)
(message message))))
(defmacro tla-write-to-file (filename &rest forms)
"In buffer visiting FILENAME, evaluate FORMS, save and kill the buffer."
(declare (indent 1) (debug (form body)))
(let ((buf (dvc-gensym)))
`(let ((,buf (find-file-noselect ,filename)))
(unwind-protect
(with-current-buffer ,buf
,@forms
(save-buffer))
(kill-buffer ,buf)))))
(defun tla-tests-make-dummy-project ()
"Create a dummy project, import and commit it to the archive."
(with-temp-buffer
(cd tla-tests-scratch-dir)
(make-directory tla-tests-project-name)
(cd tla-tests-project-name)
(tla--run-tla-sync (list "init-tree"
(format "%s/%s"
tla-tests-archive-name
tla-tests-project-name)))
(tla--run-tla-sync (list "import" (when (tla-import-has-setup-option) "--setup")))
(tla-write-to-file "hello" (insert (concat "Current time is "
(current-time-string))))
(tla-add nil "hello")
(tla--run-tla-sync (list "commit" "-L" "Test commit"))
(expand-file-name default-directory)))
(defvar tla-tests-real-home (getenv "HOME"))
(defun tla-tests-initialize (tfeatures)
"Initialization function called before launching a testcase.
FEATURES is the list of features got from `tla-tests-init-alist'."
(dvc-sethome tla-tests-scratch-dir)
(shell-command (concat "rm -rf " tla-tests-scratch-dir))
(shell-command (concat "mkdir -p " tla-tests-scratch-dir))
(condition-case err
(progn
(unless (member 'noid tfeatures)
(tla-my-id 1 "Xtla tester <bogus@email.org>"))
(unless (member 'noarch tfeatures)
(tla--make-archive tla-tests-archive-name tla-tests-archive-location)
(tla-my-default-archive tla-tests-archive-name))
(unless (member 'noproject tfeatures)
(cd (tla-tests-make-dummy-project)))
(dvc-clear-log-buffer))
(error
(tla-tests-terminate)
(error (cadr err)))))
(defun tla-tests-terminate ()
"Terminates the execution of a testcase and restores HOME."
(interactive)
(dvc-sethome tla-tests-real-home))
(defun tla-tests-wait-end-of-process ()
"Waits for all asynchronous tla processes to terminate."
(while dvc-process-running
(message "Processes: %s" dvc-process-running)
(sit-for 0.2)))
;;;###autoload
(defun tla-tests-run (test)
"Run the testcase TEST.
Switch HOME to the test directory, clear the log buffer, call the
function TEST, and check that the list of tla commands ran by calling
TEST is the same as the one expected, stored in
`tla-tests-command-alist'"
(interactive
(list (intern (dvc-completing-read
"Test to run: "
(mapcar (lambda (x) (list (symbol-name x)))
(apropos-internal "^tla-test-"))))))
(tla-autoconf-compute)
(let ((default-directory tla-tests-scratch-dir)
(init-features (cdr (assoc test tla-tests-init-alist))))
(with-temp-buffer
(tla-tests-initialize init-features)
(tla-tests-log "\n*** running test %s\n" (symbol-name test))
(let ((commands-ok t)
(errors nil))
(unwind-protect
(condition-case condition-error
(progn
(funcall test)
(tla-tests-wait-end-of-process)
(unless (member 'nocmdcheck init-features)
(let ((list-cmds (tla-tests-get-list-cmds))
(expected (mapcar
(lambda (x)
(concat (tla-arch-branch-name) " " x))
(cdr (or (assoc (intern
(concat
(symbol-name test) "-"
(tla-arch-branch-name)))
tla-tests-command-alist)
(assoc test tla-tests-command-alist))))))
(unless (equal list-cmds expected)
(tla-tests-log "Different list of commands")
(tla-tests-log "Expected: %S" expected)
(tla-tests-log "Got: %S" list-cmds)
(setq commands-ok nil)))))
(error (progn (tla-tests-log "Error running tests")
(setq errors (or condition-error t)))))
(tla-tests-terminate))
(dvc-switch-to-buffer tla-tests-log-buffer)
(tla-tests-log "*** Report for test %s:" (symbol-name test))
(tla-tests-log "Commands: %s\nErrors: %s"
(if commands-ok "OK" "ERROR")
(if errors (format "ERROR - %s" errors) "OK"))
;; return value
(and commands-ok (not errors))))))
(defun tla-tests-get-list-cmds ()
"Get the list of commands ran since the log buffer was cleared.
Returns a list of strings"
(set-buffer (get-buffer-create dvc-log-buffer))
(goto-char (point-max))
(let ((list-cmds '()))
(while (re-search-backward "^Command: " nil t)
(re-search-forward "^Command: ")
(setq list-cmds (cons (buffer-substring-no-properties (point)
(line-end-position))
list-cmds))
(forward-line -1))
list-cmds
))
(defvar tla-tests-nonreg-dir
(expand-file-name
(concat (file-name-directory (locate-library "tla"))
"../tests"))
"Directory where non-regression tests should be stored.")
(defun tla-tests-buffer-nonreg (buffer id)
"Perform a non-regression script on BUFFER.
When called for the first time, stores the content of BUFFER in
`tla-tests-nonreg-dir'/ID.txt. Afterwards, compares the content of
BUFFER with the previously archived one. Raise an error when there is
a difference."
(make-directory tla-tests-nonreg-dir t)
(let ((filename (concat (file-name-as-directory
tla-tests-nonreg-dir)
id ".txt")))
(with-current-buffer buffer
(if (file-exists-p filename)
(progn
(let ((old (concat
(dvc-strip-final-newline
(with-current-buffer (find-file-noselect
filename)
(buffer-string)))
"\n"))
(new (concat
(dvc-strip-final-newline
(replace-regexp-in-string
(regexp-quote (getenv "HOME")) "$HOME"
(buffer-string)))
"\n")))
(if (string= old new)
(progn (tla-tests-log "non-reg %s OK" id))
(tla-tests-log "Non regression failed for %s failed" id)
(tla-tests-log "Expected:\n\"%s\"\n" old)
(tla-tests-log "Got:\n\"%s\"\n" new)
(error "Non regression failed"))))
(let ((content (buffer-string)))
(with-current-buffer (get-buffer-create " *tla-tmp*")
(erase-buffer)
(insert content)
(goto-char (point-min))
(while (search-forward (getenv "HOME") nil t)
(replace-match "$HOME" nil t))
(tla-tests-log "Archiving %s for non-regression." id)
(tla-tests-log "please check %s for errors." filename)
(write-file filename)
(kill-buffer (current-buffer))
t))))))
;;
;; Testcases
;;
(defun tla-test-my-id ()
"Test that my-id works correctly."
(ignore-errors (tla-my-id))
(flet ((read-string (prompt x y z)
"John Smith <john@smith.com>"))
(tla-my-id t))
(unless (string= (tla-my-id)
"John Smith <john@smith.com>")
(error "Wrong id"))
)
(defun tla-test-make-archive ()
"Test that make-archive works correctly."
(tla--make-archive "foo@bar.com--2004" tla-tests-archive-location)
(unless (file-directory-p tla-tests-archive-location)
(error "Archive not created"))
(tla-archives)
(tla-tests-log "archive created. Testing tla-archives.")
(tla-tests-buffer-nonreg (current-buffer) "make-archive-archives"))
(defun tla-test-changes-what-changed-original-file ()
"Test that changes-what-changed-original-file correctly."
(let ((what-changed
"/home/jet/projects/pook/,,what-changed.pookx--prototype--0.1--base-0--jet@gyve.org--test/new-files-archive/./pook.h"))
(unless (equal (expand-file-name "/home/jet/projects/pook/pook.h")
(expand-file-name (tla--changes-what-changed-original-file
what-changed)))
(error "Unexpected file name is returned"))))
(defun tla-test-changes ()
"Test that tla-changes runs correctly."
(tla-changes)
(tla-tests-wait-end-of-process)
(tla-tests-buffer-nonreg (current-buffer) "changes-nochange"))
(defun tla-test-name-split-construct ()
"Check that `tla--name-split' and `tla--name-construct' works."
(let ((name-alist
'(("archive@name--year"
("archive@name--year" nil nil nil nil))
("archive@name--year/category"
("archive@name--year" "category" nil nil nil))
("archive@name--year/category--branch"
("archive@name--year" "category" "branch" nil nil))
("archive@name--year/category--1"
("archive@name--year" "category" "" "1" nil))
("archive@name--year/category--1.0--patch-42"
("archive@name--year" "category" "" "1.0" "patch-42"))
("archive@name--year/category--branch"
("archive@name--year" "category" "branch" nil nil))
("archive@name--year/category--branch--1.0"
("archive@name--year" "category" "branch" "1.0" nil))
("archive@name--year/category--branch--1.0--version-0"
("archive@name--year" "category" "branch" "1.0"
"version-0")))))
(dolist (pair name-alist)
(unless (equal (car pair) (tla--name-construct (cadr pair)))
(error "Bug in tla--name-construct"))
(unless (equal (tla--name-split (car pair)) (cadr pair))
(error "Bug in tla--name-construct")))))
(defun tla-test-revision-lessp ()
"Checks that `tla-revision-lessp' works."
(let ((rev-alist
'(("archive@name--year/cat--br--0--patch-3"
"archive@name--year/cat--br--0--patch-12")
("archive@name--year/cat--br--0--patch-3"
"archive@name--year/cat--br--1--patch-1")
("base-0" "patch-1")
("patch-1" "version-0")
("patch-1" "version-1")
("version-1" "version-2")
("12" "13")
("12x" "12y")
("a1y" "a2y")
("a12x" "ax")
("aa" "aaa")
("babbb" "bb"))))
(dolist (pair rev-alist)
(unless (tla-revision-lessp (car pair) (cadr pair))
(error "Bug in (tla-revision-lessp %S %S)" (car pair) (cadr pair)))
(when (tla-revision-lessp (cadr pair) (car pair))
(error "Bug in (tla-revision-lessp %S %S)" (cadr pair) (car pair))))))
(defun tla-test-recursive-update ()
"Test that update can be applied recursively"
(cd tla-tests-scratch-dir)
(let ((mainproject
(let ((tla-tests-project-name "mainproject--test--1.0"))
(tla-tests-make-dummy-project)))
(subprojects
(mapcar (lambda (tla-tests-project-name)
(let ((dir (tla-tests-make-dummy-project)))
(tla--run-tla-sync
(list "commit" "-L" "Test commit" "-d" dir))
dir))
'("subproject--test--1.0" "subproject--test--2.0"))))
;; Add a build-config to the main project
(cd mainproject)
(tla-write-to-file "config"
(insert "subproject-1 subproject--test--1.0--patch-1\n")
(insert "subproject-2 subproject--test--2.0--patch-1\n"))
(tla--run-tla-sync (list "add" "config"))
(tla--run-tla-sync (list "commit" "-L" "new build config")))
(let ((dist-directory (expand-file-name "~/dist")))
(make-directory dist-directory)
(cd dist-directory)
(let ((project-dir (concat dist-directory "/mainproject")))
(tla--run-tla-sync (list "get" "mainproject--test--1.0" project-dir))
(cd project-dir)
(tla--run-tla-sync (list "build-config" "config"))
(let ((dirs (split-string (shell-command-to-string
"tla inventory -t") "\n")))
(mapc (lambda (dir)
(dvc-trace "default=%S dir=%S" default-directory dir)
(let ((default-directory
(concat (file-name-as-directory
default-directory) dir)))
(tla--run-tla-sync '("missing")
:finished
(lambda (output error status arguments)
(when (string= ""
(dvc-buffer-content output))
(error "There should have been missing patches"))))))
dirs)
(flet ((tla--run-tla-async (&rest args)
(apply 'tla--run-tla-sync args)))
(tla-update project-dir nil t))
(mapc (lambda (dir)
(dvc-trace "default=%S dir=%S" default-directory dir)
(let ((default-directory
(concat (file-name-as-directory
default-directory) dir)))
(tla--run-tla-sync '("missing")
:finished
(lambda (output error status arguments)
(unless (string= ""
(dvc-buffer-content output))
(error "There should have been no missing patches"))))))
dirs)))))
(defun tla-test--position ()
"Test `dvc-position'."
(let ((list '(0.0 1.0 2.0 3.0)))
(unless
(eq 0 (dvc-position 0.0 list (lambda (x y) (= x y))))
(error "Wrong position"))
(unless
(eq 1 (dvc-position 1.0 list (lambda (x y) (= x y))))
(error "Wrong position"))
(unless
(eq nil (dvc-position 4.0 list (lambda (x y) (= x y))))
(error "Wrong position"))))
(defun tla-test--digit-char-p ()
"Test `dvc-digit-char-p'."
(when (member nil
(list
(dvc-digit-char-p ?5)
(dvc-digit-char-p ?9)
(dvc-digit-char-p ?0)
(dvc-digit-char-p ?1)
(not (dvc-digit-char-p ?a))
(not (dvc-digit-char-p ?A))
(not (dvc-digit-char-p ?!))
(not (dvc-digit-char-p ?Y))))
(error "Failed")))
(provide 'tla-tests)
;;; tla-tests.el ends here

9790
dvc/lisp/tla.el
View File

File diff suppressed because it is too large Load Diff

61
dvc/lisp/xdarcs-core.el
View File

@ -1,61 +0,0 @@
;;; xdarcs-core.el --- Common definitions for darcs support in DVC
;; Copyright (C) 2006 by all contributors
;; Author: Stefan Reichoer, <stefan@xsteve.at>
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; This file provides the low-level functions used by the darcs interface
;; from DVC.
;;; History:
;;
;;; Code:
(require 'dvc-core)
;; Settings for darcs
(defvar xdarcs-executable
"darcs"
"The executable used for the darcs commandline client.")
(defvar xdarcs-log-edit-file-name
"++xdarcs-log-edit"
"The filename, used to store the log message before commiting.
Usually that file is placed in the tree-root of the working tree.")
;;;###autoload
(defun xdarcs-tree-root (&optional location no-error interactive)
"Return the tree root for LOCATION, nil if not in a local tree.
Computation is done from withing Emacs, by looking at an _darcs/
directory in a parent buffer of LOCATION. This is therefore very
fast.
If NO-ERROR is non-nil, don't raise an error if LOCATION is not a
git managed tree (but return nil)."
(dvc-tree-root-helper "_darcs/" (or interactive (interactive-p))
"%S is not in a darcs tree!"
location no-error))
(provide 'xdarcs-core)
;;; xdarcs-core.el ends here

80
dvc/lisp/xdarcs-dvc.el
View File

@ -1,80 +0,0 @@
;;; xdarcs-dvc.el --- The dvc layer for darcs
;; Copyright (C) 2006, 2007, 2008 by all contributors
;; Author: Stefan Reichoer, <stefan@xsteve.at>
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; This file provides the common dvc layer for darcs
;;; History:
;;
;;; Code:
(require 'xdarcs)
(eval-and-compile (require 'dvc-unified))
;;;###autoload
(dvc-register-dvc 'xdarcs "Darcs")
;;;###autoload
(defalias 'xdarcs-dvc-tree-root 'xdarcs-tree-root)
;;;###autoload
(defalias 'xdarcs-dvc-log-edit-done 'xdarcs-log-edit-done)
;;;###autoload
(defalias 'xdarcs-dvc-command-version 'xdarcs-command-version)
;;;###autoload
(defalias 'xdarcs-dvc-status 'xdarcs-whatsnew)
;;;###autoload
(defalias 'xdarcs-dvc-pull 'xdarcs-pull)
(defvar xdarcs-ignore-file "_darcs/prefs/boring"
"Relative path of the darcs boring file within the xdarcs-tree-root.")
(defun xdarcs-dvc-edit-ignore-files ()
(interactive)
(find-file-other-window (concat (xdarcs-tree-root) xdarcs-ignore-file)))
(defun xdarcs-dvc-ignore-files (file-list)
(interactive (list (dvc-current-file-list)))
(when (y-or-n-p (format "Ignore %S for %s? " file-list (xdarcs-tree-root)))
(with-current-buffer
(find-file-noselect (concat (xdarcs-tree-root) xdarcs-ignore-file))
(goto-char (point-max))
(dolist (f-name file-list)
(insert (format "^%s$\n" (regexp-quote f-name))))
(save-buffer))))
(defun xdarcs-dvc-backend-ignore-file-extensions (extension-list)
(with-current-buffer
(find-file-noselect (concat (xdarcs-tree-root) xdarcs-ignore-file))
(goto-char (point-max))
(dolist (ext-name extension-list)
(insert (format "\\.%s$\n" (regexp-quote ext-name))))
(save-buffer)))
(provide 'xdarcs-dvc)
;;; xdarcs-dvc.el ends here

383
dvc/lisp/xdarcs.el
View File

@ -1,383 +0,0 @@
;;; xdarcs.el --- darcs interface for dvc
;; Copyright (C) 2006, 2007, 2008 by all contributors
;; Author: Stefan Reichoer, <stefan@xsteve.at>
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; The darcs interface for dvc
;;; History:
;;
;;; Code:
(require 'dvc-core)
(require 'dvc-utils)
(require 'dvc-diff)
(require 'xdarcs-core)
(defun xdarcs-initialize (&optional dir)
"Run darcs initialize."
(interactive
(list (expand-file-name (dvc-read-directory-name "Directory for darcs initialize: "
(or default-directory
(getenv "HOME"))))))
(let ((default-directory dir))
(dvc-run-dvc-sync 'xdarcs (list "initialize")
:finished (dvc-capturing-lambda
(output error status arguments)
(message "darcs initialize finished")))))
;;;###autoload
(defun xdarcs-dvc-add-files (&rest files)
"Run darcs add."
(dvc-trace "xdarcs-add-files: %s" files)
(dvc-run-dvc-sync 'xdarcs (append '("add") files)
:finished (dvc-capturing-lambda
(output error status arguments)
(message "darcs add finished"))))
(defun xdarcs-command-version ()
"Run darcs --version."
(interactive)
(let ((version (dvc-run-dvc-sync 'xdarcs '("--version")
:finished 'dvc-output-buffer-handler)))
(when (interactive-p)
(message "darcs version: %s" version))
version))
;; --------------------------------------------------------------------------------
;; whatsnew
;; --------------------------------------------------------------------------------
;;
;; (defun xdarcs-whatsnew ()
;; "Run darcs whatsnew.
;; When called with a prefix argument, specify the --look-for-adds parameter."
;; (interactive)
;; (let ((param-list '("whatsnew")))
;; (when current-prefix-arg
;; (add-to-list 'param-list "--look-for-adds" t))
;; (dvc-run-dvc-display-as-info 'xdarcs param-list)))
(defun xdarcs-parse-whatsnew (changes-buffer)
(dvc-trace "xdarcs-parse-whatsnew (dolist)")
(let ((status-list
(split-string (dvc-buffer-content (current-buffer)) "\n")))
(with-current-buffer changes-buffer
(setq dvc-header (format "darcs whatsnew --look-for-adds for %s\n" default-directory))
(let ((buffer-read-only)
status modif modif-char)
(dolist (elem status-list)
(unless (string= "" elem)
(setq modif-char (aref elem 0))
(cond ((eq modif-char ?M)
(setq status "M"
modif "M")
(when (or (string-match "\\(.+\\) -[0-9]+ \\+[0-9]+$"
elem)
(string-match "\\(.+\\) [+-][0-9]+$"
elem))
(setq elem (match-string 1 elem))))
;; ???a
((eq modif-char ?a)
(setq status "?"))
((eq modif-char ?A)
(setq status "A"
modif " "))
((eq modif-char ?R)
(setq status "D"))
((eq modif-char ??)
(setq status "?"))
(t
(setq modif nil
status nil)))
(when (or modif status)
(ewoc-enter-last
dvc-fileinfo-ewoc
(make-dvc-fileinfo-legacy
:data (list 'file
;; Skip the status and "./" in the filename
(substring elem 4)
status
modif))))))))))
;;;###autoload
(defun xdarcs-whatsnew (&optional path)
"Run darcs whatsnew."
(interactive (list default-directory))
(let* ((dir (or path default-directory))
(root (xdarcs-tree-root dir))
(buffer (dvc-prepare-changes-buffer
`(xdarcs (last-revision ,root 1))
`(xdarcs (local-tree ,root))
'status root 'xdarcs)))
(dvc-switch-to-buffer-maybe buffer)
(setq dvc-buffer-refresh-function 'xdarcs-whatsnew)
(dvc-save-some-buffers root)
(dvc-run-dvc-sync
'xdarcs '("whatsnew" "--look-for-adds")
:finished
(dvc-capturing-lambda (output error status arguments)
(with-current-buffer (capture buffer)
(if (> (point-max) (point-min))
(dvc-show-changes-buffer output 'xdarcs-parse-whatsnew
(capture buffer))
(dvc-diff-no-changes (capture buffer)
"No changes in %s"
(capture root))))
:error
(dvc-capturing-lambda (output error status arguments)
(dvc-diff-error-in-process (capture buffer)
"Error in diff process"
output error))))))
;;;###autoload
(defun xdarcs-dvc-missing (&optional other)
"Run 'darcs pull --dry-run -s -v' to see what's missing"
(interactive)
(let ((buffer (dvc-get-buffer-create 'xdarcs 'missing)))
(dvc-run-dvc-async
'xdarcs '("pull" "--dry-run" "-s" "-v")
:finished
(dvc-capturing-lambda (output error status arguments)
(progn
(with-current-buffer (capture buffer)
(let ((inhibit-read-only t))
(erase-buffer)
(insert-buffer-substring output)
(goto-char (point-min))
(re-search-forward "^Would pull the following changes:" nil t)
(xdarcs-missing-next 1)
(xdarcs-missing-mode)))
(goto-char (point-min))
(dvc-switch-to-buffer (capture buffer)))))))
(defvar xdarcs-review-recenter-position-on-next-diff 5)
(defvar xdarcs-missing-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (dvc-prefix-buffer ?L) 'dvc-open-internal-log-buffer)
(define-key map dvc-keyvec-quit 'dvc-buffer-quit)
(define-key map [?n] 'xdarcs-missing-next)
(define-key map [?p] 'xdarcs-missing-previous)
(define-key map [?\ ] 'xdarcs-missing-dwim-next)
(define-key map (dvc-prefix-merge ?f) 'dvc-pull) ;; hint: fetch, p is reserved for push
map)
"Keymap used in a xdarcs missing buffer.")
(defvar xdarcs-missing-patch-start-regexp
"^\\(Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\|Sun\\).+$")
(defvar xdarcs-missing-font-lock-keywords
`((,xdarcs-missing-patch-start-regexp . font-lock-function-name-face)
("^hunk.+" . font-lock-variable-name-face))
"Keywords in `xdarcs-missing-mode'.")
(define-derived-mode xdarcs-missing-mode fundamental-mode
"xdarcs missing mode"
"Major mode to show the output of a call to `xdarcs-missing'."
(dvc-install-buffer-menu)
(set (make-local-variable 'font-lock-defaults)
(list 'xdarcs-missing-font-lock-keywords t nil nil))
(toggle-read-only 1))
(defun xdarcs-missing-next (n)
(interactive "p")
(end-of-line)
(re-search-forward xdarcs-missing-patch-start-regexp nil t n)
(beginning-of-line)
(when xdarcs-review-recenter-position-on-next-diff
(recenter xdarcs-review-recenter-position-on-next-diff)))
(defun xdarcs-missing-previous (n)
(interactive "p")
(end-of-line)
(re-search-backward xdarcs-missing-patch-start-regexp)
(re-search-backward xdarcs-missing-patch-start-regexp nil t n)
(when xdarcs-review-recenter-position-on-next-diff
(recenter xdarcs-review-recenter-position-on-next-diff)))
(defun xdarcs-missing-dwim-next ()
"Either move to the next changeset via `xdarcs-missing-next' or call `scroll-up'.
When the beginning of the next changeset is already visible, call `xdarcs-missing-next',
otherwise call `scroll-up'."
(interactive)
(let* ((start-pos (point))
(window-line (count-lines (window-start) start-pos))
(window-height (dvc-window-body-height))
(distance-to-next-changeset (save-window-excursion (xdarcs-missing-next 1) (count-lines start-pos (point)))))
(goto-char start-pos)
(when (eq distance-to-next-changeset 0) ; last changeset
(setq distance-to-next-changeset (count-lines start-pos (point-max))))
(if (< (- window-height window-line) distance-to-next-changeset)
(scroll-up)
(xdarcs-missing-next 1))))
(defun xdarcs-pull-finish-function (output error status arguments)
(let ((buffer (dvc-get-buffer-create 'xdarcs 'pull)))
(with-current-buffer buffer
(let ((inhibit-read-only t))
(erase-buffer)
(insert-buffer-substring output)
(toggle-read-only 1)))
(let ((dvc-switch-to-buffer-mode 'show-in-other-window))
(dvc-switch-to-buffer buffer))))
;;;###autoload
(defun xdarcs-pull (&optional other)
"Run darcs pull --all.
If OTHER is nil, pull from the repository most recently pulled
from or pushed to. If OTHER is a string, pull from that
repository."
(interactive)
(dvc-run-dvc-async 'xdarcs (list "pull" "--all" other)
:error 'xdarcs-pull-finish-function
:finished 'xdarcs-pull-finish-function))
;; --------------------------------------------------------------------------------
;; diff
;; --------------------------------------------------------------------------------
(defun xdarcs-parse-diff (changes-buffer)
(save-excursion
(while (re-search-forward
"^diff\\( -[^ ]*\\)* old-[^ ]* new-[^/]*/\\(.*\\)$" nil t)
(let* ((name (match-string-no-properties 2))
; Darcs does not appear to provide any of this information via
; "darcs diff". But maybe that won't always be the case?
; Also, going forwards might help all the diffs to appear...
(added (progn (forward-line 1)
(looking-at "^--- /dev/null")))
(removed (progn (forward-line 1)
(looking-at "^\\+\\+\\+ /dev/null"))))
; Darcs 2.30, at least, is not putting any blank lines between diffs...
(save-excursion
(forward-line -2)
(if (not (or (looking-back "^$")
(= (point) (point-min))))
(insert "\n")))
(with-current-buffer changes-buffer
(ewoc-enter-last
dvc-fileinfo-ewoc
(make-dvc-fileinfo-legacy
:data (list 'file
name
(cond (added "A")
(removed "D")
(t " "))
(cond ((or added removed) " ")
(t "M"))
" " ; dir. directories are not
; tracked in git
nil))))))))
;;;###autoload
(defun xdarcs-dvc-diff (&optional against path dont-switch)
(interactive (list nil nil current-prefix-arg))
(let* ((cur-dir (or path default-directory))
(orig-buffer (current-buffer))
(root (dvc-tree-root cur-dir))
(buffer (dvc-prepare-changes-buffer
`(xdarcs (last-revision ,root 1))
`(xdarcs (local-tree ,root))
'diff root 'xdarcs))
(command-list '("diff" "--unified")))
(dvc-switch-to-buffer-maybe buffer)
(when dont-switch (pop-to-buffer orig-buffer))
(dvc-save-some-buffers root)
(dvc-run-dvc-sync 'xdarcs command-list
:finished
(dvc-capturing-lambda (output error status arguments)
(dvc-show-changes-buffer output 'xdarcs-parse-diff
(capture buffer))))))
;; --------------------------------------------------------------------------------
;; dvc revision support
;; --------------------------------------------------------------------------------
;;
;; It seems that there if no subcommand in darcs to get specified
;; revision of a file. So I use following trick:
;; 1. Make a diff between the file in local copy and the last revision
;; of file. Then
;; 2. Apply the diff as patch reversely(-R) to the file in the local
;; copy with patch command. With -o option, patch command doesn't
;; modify the file in local copy; patch command create the applied
;; file at /tmp. Finally
;; 3. Do insert-file-contents to the current buffer.
;;
;; Darcs experts, if you know better way, please, let us know.
;;
;; - Masatake
;;
;;;###autoload
(defun xdarcs-revision-get-last-revision (file last-revision)
"Insert the content of FILE in LAST-REVISION, in current buffer.
LAST-REVISION looks like
\(\"path\" NUM)"
(dvc-trace "xdarcs-revision-get-last-revision file:%S last-revision:%S" file last-revision)
(let* (;;(xdarcs-rev (int-to-string (nth 1 last-revision)))
(default-directory (car last-revision))
;; TODO: support the last-revision parameter??
(patch (dvc-run-dvc-sync
'xdarcs (list "diff" "--unified" file)
:finished 'dvc-output-buffer-handler))
(output-buffer (current-buffer))
(output-file (dvc-make-temp-name "xdarcs-file-find"))
(patch-cmdline (format "cd \"%s\"; patch -R -o \"%s\""
default-directory
output-file))
;; TODO: Use dvc's process/buffer management facility.
(status (with-temp-buffer
(insert patch)
(shell-command-on-region (point-min)
(point-max)
patch-cmdline
output-buffer))))
(when (zerop status)
(with-current-buffer output-buffer
(insert-file-contents output-file)
;; TODO: remove output-file
))))
;;;###autoload
(defun xdarcs-dvc-revert-files (&rest files)
"Run darcs revert."
(dvc-trace "xdarcs-revert-files: %s" files)
(let ((default-directory (xdarcs-tree-root)))
(dvc-run-dvc-sync 'xdarcs (append '("revert" "-a") (mapcar #'file-relative-name files))
:finished (dvc-capturing-lambda
(output error status arguments)
(message "xdarcs revert finished")))))
;;;###autoload
(defun xdarcs-dvc-remove-files (&rest files)
"Run darcs remove."
(dvc-trace "xdarcs-remove-files: %s" files)
(dvc-run-dvc-sync 'xdarcs (append '("remove" "-a") files)
:finished (dvc-capturing-lambda
(output error status arguments)
(message "xdarcs remove finished"))))
(provide 'xdarcs)
;;; xdarcs.el ends here

138
dvc/lisp/xgit-annotate.el
View File

@ -1,138 +0,0 @@
;;; xgit-annotate.el --- Git interface for dvc: mode for git-annotate style output
;; Copyright (C) 2007-2009 by all contributors
;; Author: Takuzo O'hara, <takuzo.ohara@gmail.com>
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; The git interface for dvc: a mode to handle git-annotate style output
;;; Code:
(require 'dvc-annotate)
(require 'rect)
(defvar xgit-annotate-mode-map
(let ((map (make-sparse-keymap)))
(define-key map dvc-keyvec-help 'describe-mode)
(define-key map [return] 'xgit-annotate-show-rev)
(define-key map dvc-keyvec-quit 'dvc-buffer-quit)
map)
"Keymap used in `xgit-annotate-mode'.")
(define-derived-mode xgit-annotate-mode fundamental-mode "xgit-annotate"
"Major mode to display git annotate output.
Commands:
\\{xgit-annotate-mode-map}
"
(dvc-annotate-display-autoscale t)
(dvc-annotate-lines (point-max))
(xgit-annotate-hide-revinfo)
(toggle-read-only 1))
;; Matches to
;; e.g.
;; normal commit:
;; "ee6e815b (Takuzo Ohara 2007-02-23 12:24:57 +0900 1) ..."
;; or initial commit:
;; "^de398cf (Takuzo Ohara 2007-02-21 21:28:35 +0900 366) ..."
;; or not yet commited:
;; "00000000 (Not Committed Yet 2007-02-24 15:31:42 +0900 37) ..."
(defconst xgit-annotate-info-regexp "^\\(\\(\\^?\\([[:xdigit:]]+\\)\\)[[:blank:]]+.*(\\(.*?\\)[[:blank:]]+\\([0-9]\\{4\\}\\)-\\([0-9]\\{2\\}\\)-\\([0-9]\\{2\\}\\) \\([0-9]\\{2\\}\\):\\([0-9]\\{2\\}\\):\\([0-9]\\{2\\}\\) \\([+-][0-9]\\{2\\}\\)\\([0-9]\\{2\\}\\)[[:blank:]]+\\)\\([0-9]+\\))")
(defun xgit-info-to-allbutlinenum () (match-string-no-properties 1))
(defun xgit-info-to-rev () (match-string-no-properties 2))
(defun xgit-info-to-initrev () (match-string-no-properties 3))
(defun xgit-info-to-name () (match-string-no-properties 4))
(defun xgit-info-to-year () (string-to-number (match-string-no-properties 5)))
(defun xgit-info-to-month () (string-to-number (match-string-no-properties 6)))
(defun xgit-info-to-day () (string-to-number (match-string-no-properties 7)))
(defun xgit-info-to-hour () (string-to-number (match-string-no-properties 8)))
(defun xgit-info-to-min () (string-to-number (match-string-no-properties 9)))
(defun xgit-info-to-sec () (string-to-number (match-string-no-properties 10)))
(defun xgit-info-to-zone-hour () (string-to-number (match-string-no-properties 11)))
(defun xgit-info-to-zone-min () (string-to-number (match-string-no-properties 12)))
(defun xgit-info-to-linenum () (string-to-number (match-string-no-properties 13)))
(defconst xgit-annotate-revision-regexp "^^?\\([[:xdigit:]]+\\)")
(defun xgit-annotate-get-rev ()
"Returns git revision at point in annotate buffer."
(if (< (point) (point-max))
(save-excursion
(beginning-of-line)
(if (looking-at xgit-annotate-info-regexp)
(xgit-info-to-rev)))))
(defun xgit-annotate-show-rev ()
"Show the information at the point."
(interactive)
(let ((rev (xgit-annotate-get-rev)))
(if (string-match xgit-annotate-revision-regexp rev)
;; initial version might result too large for git-show, so use
;; git-log.
(xgit-log default-directory nil :rev (match-string-no-properties 1 rev))
(xgit-show default-directory rev))
(xgit-describe default-directory rev)))
(defun _xgit-annotate-hide-revinfo ()
(let ((p_rev (xgit-annotate-get-rev))
(width (- (match-end 12) (line-beginning-position))))
(forward-line 1)
;; When revision of two subsequent lines are same:
(if (string= p_rev (xgit-annotate-get-rev))
(let ((start (line-beginning-position)))
;; forward until revision changes,
(while (string= p_rev (xgit-annotate-get-rev))
(forward-line 1))
;; point is at new revision so move back a line,
(unless (= (point) (point-max))
(previous-line 1))
;; match again to get position of right-bottom corner,
(xgit-annotate-get-rev)
;; rectangular replace by white space, from start to end.
(string-rectangle start (match-end 12) (make-string width ? ))))
))
(defun xgit-annotate-hide-revinfo ()
"Hide revision information when it is same as previous line's info."
(save-excursion
(goto-char (point-min))
(while (< (point) (point-max))
(_xgit-annotate-hide-revinfo))))
(defun xgit-annotate-time ()
(when (< (point) (point-max))
(beginning-of-line)
(if (re-search-forward xgit-annotate-info-regexp nil t)
(let* ((year (xgit-info-to-year))
(month (xgit-info-to-month))
(day (xgit-info-to-day))
(hour (xgit-info-to-hour))
(min (xgit-info-to-min))
(sec (xgit-info-to-sec))
(zone-hour (xgit-info-to-zone-hour))
(zone-min (xgit-info-to-zone-min))
(zone-sec (* 60 (+ (* 60 zone-hour) zone-min))))
(dvc-annotate-convert-time
(encode-time sec min hour day month year zone-sec))
))))
(provide 'xgit-annotate)
;;; xgit-annotate.el ends here

127
dvc/lisp/xgit-core.el
View File

@ -1,127 +0,0 @@
;;; xgit-core.el --- Common definitions for git support in DVC
;; Copyright (C) 2006-2007 by all contributors
;; Author: Stefan Reichoer, <stefan@xsteve.at>
;; Contributions from:
;; Takuzo O'hara <takuzo.ohara@gmail.com>
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; This file provides the low-level functions used by the git interface
;; from DVC.
;;; History:
;;
;;; Code:
(require 'dvc-core)
(defgroup dvc-xgit nil
"Git support in dvc"
:group 'dvc)
;; Settings for git
(defcustom xgit-executable "git"
"The executable used for the git commandline client."
:type 'string
:group 'dvc-xgit)
(defcustom xgit-git-dir-mapping nil
"A mapping from the root of a directory tree to the desired
git metadata directory."
:type '(repeat (list :tag "Rule"
(regexp :tag "Root dir")
(directory :tag "Git dir")))
:group 'dvc-xgit)
(defvar xgit-log-edit-file-name
"DVC_EDITMSG"
"The filename used to store the log message before commiting.
Usually that file is placed in the .git directory of the working tree.")
(defun xgit-lookup-external-git-dir (&optional location root)
"Check to see whether the user has specified a custom git metadata
directory in `xgit-git-dir-mapping'.
If root is non-nil, return the tree root, which is guaranteed to
end with a trailing slash. Otherwise, return the git metadata
directory.
If no rule from `xgit-git-dir-mapping' matches, return nil."
(setq location (file-name-as-directory (or location default-directory)))
(save-match-data
(catch 'found
(dolist (rule xgit-git-dir-mapping)
(when (string-match (concat "^" (directory-file-name (car rule)) "/")
location)
(throw 'found (if root (match-string 0 location)
(cadr rule)))))
nil)))
;;;###autoload
(defun xgit-tree-root (&optional location no-error interactive)
"Return the tree root for LOCATION, nil if not in a local tree.
Computation is done from withing Emacs, by looking at an .git/
directory in a parent buffer of LOCATION. This is therefore very
fast.
If NO-ERROR is non-nil, don't raise an error if LOCATION is not a
git managed tree (but return nil)."
(or (xgit-lookup-external-git-dir location t)
(dvc-tree-root-helper ".git/" (or interactive (interactive-p))
"%S is not in a git tree!"
location no-error)))
;; Stefan: 17.05.2007: not sure, if xgit-tree-has-head is still needed/valid
(defun xgit-tree-has-head ()
"Return t, if the git repository has a valid HEAD entry.
It will be nil before the initial commit."
(file-readable-p (concat (xgit-tree-root) ".git/HEAD")))
(defun xgit-git-dir (&optional location)
"Return directory name name for .git git metadata directory for LOCATION."
(let ((git-dir (xgit-lookup-external-git-dir location)))
(concat (file-relative-name
(or git-dir (xgit-tree-root location))
(file-name-as-directory (or location default-directory)))
(if git-dir "" ".git"))))
(defun xgit-git-dir-option (&optional location)
"Utility function to add --git-dir option to git command."
;; git barfs when "~/" is in the --git-dir argument, so we cannot
;; just concat the result of xgit-tree-root as-is
(concat "--git-dir=" (xgit-git-dir location)))
(defconst xgit-hash-regexp "[0-9a-f]\\{40\\}")
;;;###autoload
(defun xgit-prepare-environment (env)
"Prepare the environment to run git."
;; git pipes the result of "git log" to the PAGER, so set
;; GIT_PAGER=cat to work around that feature
(let ((git-dir (xgit-lookup-external-git-dir)))
(nconc (when git-dir (list (concat "GIT_DIR=" git-dir)))
(list "GIT_PAGER=cat")
env)))
(provide 'xgit-core)
;;; xgit-core.el ends here

167
dvc/lisp/xgit-dvc.el
View File

@ -1,167 +0,0 @@
;;; xgit-dvc.el --- The dvc layer for git
;; Copyright (C) 2006-2009 by all contributors
;; Author: Stefan Reichoer, <stefan@xsteve.at>
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; This file provides the common dvc layer for git
;;; History:
;;
;;; Code:
(require 'xgit)
(eval-and-compile (require 'dvc-unified))
;;;###autoload
(dvc-register-dvc 'xgit "git")
;;;###autoload
(defalias 'xgit-dvc-tree-root 'xgit-tree-root)
;;;###autoload
(defalias 'xgit-dvc-command-version 'xgit-command-version)
(defalias 'xgit-dvc-delta 'xgit-delta)
(defun xgit-dvc-log-edit-file-name-func ()
(concat (file-name-as-directory (xgit-git-dir))
xgit-log-edit-file-name))
(defun xgit-dvc-log-edit-done (&optional invert-normal)
"Finish a commit for git, using git commit.
If the partner buffer has files marked, then the index will
always be used. Otherwise, the `xgit-use-index' option
determines whether the index will be used in this commit.
If INVERT-NORMAL is non-nil, the behavior opposite of that
specified by `xgit-use-index' will be used in this commit."
(let ((buffer (find-file-noselect (dvc-log-edit-file-name)))
(files-to-commit (when (buffer-live-p dvc-partner-buffer)
(with-current-buffer dvc-partner-buffer
(dvc-current-file-list 'nil-if-none-marked))))
(use-index (if (or (eq xgit-use-index 'ask)
(not invert-normal))
(xgit-use-index-p)
(not (xgit-use-index-p)))))
(dvc-log-flush-commit-file-list)
(save-buffer buffer)
(message "committing %S in %s" (or files-to-commit "all files")
(dvc-tree-root))
(dvc-run-dvc-sync
'xgit (append (list "commit"
(unless (or files-to-commit use-index) "-a")
"-F" (dvc-log-edit-file-name))
files-to-commit)
:finished (dvc-capturing-lambda
(output error status arguments)
(dvc-show-error-buffer output 'commit)
(let ((inhibit-read-only t))
(goto-char (point-max))
(insert (with-current-buffer error
(buffer-string))))
(dvc-log-close (capture buffer))
;; doesn't work at the moment (Stefan, 10.02.2006)
;; (dvc-diff-clear-buffers 'xgit (capture default-directory)
;; "* Just committed! Please refresh buffer\n")
(message "git commit finished")))
(dvc-tips-popup-maybe)))
;;;###autoload
(defun xgit-dvc-log (arg last-n)
"Shows the changelog in the current git tree.
ARG is passed as prefix argument"
(call-interactively 'xgit-log))
(defalias 'xgit-dvc-revlog-get-revision 'xgit-revlog-get-revision)
(defalias 'xgit-dvc-name-construct 'xgit-name-construct)
(defun xgit-dvc-changelog (&optional arg)
"Shows the changelog in the current git tree.
ARG is passed as prefix argument"
(call-interactively 'xgit-log))
(defalias 'xgit-dvc-prepare-environment 'xgit-prepare-environment)
(defalias 'xgit-dvc-revision-get-last-revision 'xgit-revision-get-last-revision)
(defalias 'xgit-dvc-last-revision 'xgit-last-revision)
(defalias 'xgit-dvc-annotate-time 'xgit-annotate-time)
(defun xgit-dvc-missing (&optional other)
"Run 'git fetch origin; git log HEAD..origin'"
(interactive)
(xgit-fetch "origin")
(xgit-changelog "HEAD" "origin" t))
(defun xgit-dvc-pull ()
"Run 'git pull origin'"
(interactive)
(xgit-pull "origin"))
(defun* xgit-dvc-push (url &optional (branch "master"))
"Run 'git push url'.
with prefix arg ask for branch, default to master."
(interactive "sGit push to: ")
(xgit-push url branch))
(defalias 'xgit-dvc-clone 'xgit-clone)
(defalias 'xgit-dvc-create-branch 'xgit-branch)
(defalias 'xgit-dvc-select-branch 'xgit-checkout)
(defalias 'xgit-dvc-list-branches 'xgit-branch-list)
(defalias 'xgit-dvc-send-commit-notification 'xgit-gnus-send-commit-notification)
(defalias 'xgit-dvc-init 'xgit-init)
;;;###autoload
(defalias 'xgit-dvc-add 'xgit-add)
(defun xgit-dvc-edit-ignore-files ()
"Edit git's ignore file.
TODO: Support per directory ignore file.
This only supports exclude file now."
(interactive)
(find-file-other-window (xgit-get-root-exclude-file)))
(defun xgit-dvc-ignore-files (file-list)
"Added FILE-LIST to git's ignore file.
TODO: Support per directory ignore file.
This only supports exclude file now."
(interactive (list (dvc-current-file-list)))
(when (y-or-n-p (format "Ignore %S for %s? "
file-list
(xgit-git-dir)))
(with-current-buffer
(find-file-noselect (xgit-get-root-exclude-file))
(goto-char (point-max))
(dolist (f-name file-list)
(insert (format "%s\n" f-name)))
(save-buffer))))
(provide 'xgit-dvc)
;;; xgit-dvc.el ends here

294
dvc/lisp/xgit-gnus.el
View File

@ -1,294 +0,0 @@
;;; xgit-gnus.el --- dvc integration to gnus
;; Copyright (C) 2003-2007 by all contributors
;; Author: Michael Olson <mwolson@gnu.org>,
;; Stefan Reichoer <stefan@xsteve.at>
;; Contributions from:
;; Matthieu Moy <Matthieu.Moy@imag.fr>
;; DVC is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; DVC is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; gnus is optional. Load it at compile-time to avoid warnings.
(eval-when-compile
(condition-case nil
(progn
(require 'gnus)
(require 'gnus-art)
(require 'gnus-sum))
(error nil)))
;;;###autoload
(defun xgit-insinuate-gnus ()
"Integrate Xgit into Gnus."
(interactive)
;; bindings are set up by dvc-insinuate-gnus
)
;;; Applying patches from email messages
(defcustom xgit-apply-patch-mapping nil
"*Working directories in which patches should be applied.
An alist of rules to map a regexp matching an email address to a
working directory.
This is used by the `xgit-gnus-apply-patch' function.
Example setting: '((\".*erc-discuss@gnu.org\" \"~/proj/emacs/erc/master\"))"
:type '(repeat (list :tag "Rule"
(string :tag "Email address regexp")
(string :tag "Working directory")))
:group 'dvc-xgit)
(defvar xgit-gnus-patch-from-user nil)
(defun xgit-gnus-article-apply-patch (n)
"Apply the current article as a git patch.
N is the mime part given to us by DVC.
If N is negative, then force applying of the patch by doing a
3-way merge.
We ignore the use of N as a mime part, since git can extract
patches from the entire message."
(interactive "p")
(let ((force nil))
(when (and (numberp n) (< n 0))
(setq force t))
(xgit-gnus-apply-patch force)))
(defun xgit-gnus-apply-patch (force)
"Apply a git patch via gnus. HANDLE should be the handle of the part."
(let ((patch-file-name (concat (dvc-make-temp-name "gnus-xgit-apply-")
".patch"))
(window-conf (current-window-configuration))
(err-occurred nil)
(trigger-commit nil)
working-dir patch-buffer)
(gnus-summary-show-article 'raw)
(gnus-summary-select-article-buffer)
(save-excursion
(let ((require-final-newline nil)
(coding-system-for-write mm-text-coding-system))
(gnus-write-buffer patch-file-name))
(goto-char (point-min))
(re-search-forward "^To: " nil t)
(catch 'found
(dolist (m xgit-apply-patch-mapping)
(when (looking-at (car m))
(setq working-dir (dvc-uniquify-file-name (cadr m)))
(throw 'found t)))))
(gnus-summary-show-article)
(delete-other-windows)
(dvc-buffer-push-previous-window-config)
(find-file patch-file-name)
(setq patch-buffer (current-buffer))
(setq working-dir (dvc-read-directory-name "Apply git patch to: "
nil nil t working-dir))
(when working-dir
(setq working-dir (file-name-as-directory working-dir)))
(unwind-protect
(progn
(when working-dir
(let ((default-directory working-dir))
(if (or (xgit-lookup-external-git-dir)
(file-exists-p ".git/"))
;; apply the patch and commit if it applies cleanly
(xgit-apply-mbox patch-file-name force)
;; just apply the patch, since we might not be in a
;; git repo
(xgit-apply-patch patch-file-name)
(setq trigger-commit t))))
(set-window-configuration window-conf)
(when working-dir
(if trigger-commit
(xgit-gnus-stage-patch-for-commit working-dir patch-buffer)
(when (y-or-n-p "Run git log in working directory? ")
(xgit-log working-dir nil)
(delete-other-windows)))))
;; clean up temporary file
(delete-file patch-file-name)
(kill-buffer patch-buffer))))
(defun xgit-gnus-stage-patch-for-commit (working-dir patch-buffer)
"Switch to directory WORKING-DIR and set up a commit based on the patch
contained in PATCH-BUFFER."
(let ((default-directory working-dir))
(destructuring-bind (subject body)
(with-current-buffer patch-buffer
(let (subject body)
(goto-char (point-min))
(when (re-search-forward "^Subject: *\\(.+\\)$" nil t)
(setq subject (match-string 1)))
(goto-char (point-min))
(when (re-search-forward "^$" nil t)
(forward-line 1)
(let ((beg (point)))
(when (re-search-forward "^---$" nil t)
(setq body (buffer-substring beg (match-beginning 0))))))
(list subject body)))
;; strip "[COMMIT]" prefix
(when (and subject
(string-match "\\`\\[[^]]+\\] *" subject))
(setq subject (substring subject (match-end 0))))
(message "Staging patch for commit ...")
(dvc-diff)
(dvc-log-edit)
(erase-buffer)
(insert subject "\n\n" body))))
(defvar xgit-gnus-status-window-configuration nil)
(defun xgit-gnus-article-view-status-for-apply-patch (n)
"View the status for the repository, where MIME part N would be applied
as a git patch.
Use the same logic as in `xgit-gnus-article-apply-patch' to
guess the repository path via `xgit-apply-patch-mapping'."
(interactive "p")
(xgit-gnus-view-status-for-apply-patch)
(set-window-configuration xgit-gnus-status-window-configuration))
(defun xgit-gnus-view-status-for-apply-patch ()
"View the status for a repository before applying a git patch via gnus."
(let ((window-conf (current-window-configuration))
(working-dir))
(gnus-summary-select-article-buffer)
(save-excursion
(goto-char (point-min))
(re-search-forward "^To: " nil t)
(dolist (m xgit-apply-patch-mapping)
(when (looking-at (car m))
(setq working-dir (dvc-uniquify-file-name (cadr m))))))
(unless working-dir
;; when we find the directory in xgit-apply-patch-mapping don't
;; ask for confirmation
(setq working-dir (dvc-read-directory-name
"View git repository status for: "
nil nil t working-dir)))
(when working-dir
(setq working-dir (file-name-as-directory working-dir)))
(let ((default-directory working-dir))
(xgit-dvc-status)
(delete-other-windows)
(setq xgit-gnus-status-window-configuration
(current-window-configuration))
(dvc-buffer-push-previous-window-config window-conf))))
(defun xgit-gnus-article-view-patch (n)
"View the currently looked-at patch.
All this does is switch to the article and move to where the
patch begins."
(interactive "p")
(gnus-summary-select-article-buffer)
(goto-char (point-min))
(re-search-forward "^---$" nil t)
(forward-line 1))
;;; Sending commit notifications
(defcustom xgit-mail-notification-destination nil
"An alist of rules which map working directories to both target
email addresses and the prefix string for the subject line.
This is used by the `xgit-send-commit-notification' function."
:type '(repeat (list :tag "Rule"
(string :tag "Working directory")
(string :tag "Email subject prefix")
(string :tag "Email address")
(string :tag "Repo location (optional)")))
:group 'dvc-xgit)
(defcustom xgit-mail-notification-sign-off-p nil
"If non-nil, add a Signed-Off-By header to any mail commit notifications."
:type 'boolean
:group 'dvc-xgit)
(defun xgit-gnus-send-commit-notification (&optional to)
"Send a commit notification email for the changelog entry at point.
The option `xgit-mail-notification-destination' can be used to
specify a prefix for the subject line, the destination email
address, and an optional repo location. The rest of the subject
line contains the summary line of the commit.
If the optional argument TO is provided, send an email to that
address instead of consulting
`xgit-mail-notification-destination'. If the prefix
argument (C-u) is given, then prompt for this value."
(interactive (list current-prefix-arg))
(let (dest-specs)
(when (equal to '(4))
(setq to (read-string "Destination email address: ")))
(if to
(setq dest-specs (list nil to nil))
(catch 'found
(dolist (m xgit-mail-notification-destination)
(when (string= default-directory (file-name-as-directory (car m)))
(setq dest-specs (cdr m))
(throw 'found t)))))
(let* ((rev (dvc-revlist-get-revision-at-point))
(repo-location (nth 2 dest-specs)))
(destructuring-bind (from subject body)
(dvc-run-dvc-sync
'xgit (delq nil (list "format-patch" "--stdout" "-k" "-1"
(when xgit-mail-notification-sign-off-p "-s")
rev))
:finished
(lambda (output error status args)
(with-current-buffer output
(let (from subject body)
(goto-char (point-min))
(when (re-search-forward "^From: *\\(.+\\)$" nil t)
(setq from (match-string 1)))
(goto-char (point-min))
(when (re-search-forward "^Subject: *\\(.+\\)$" nil t)
(setq subject (match-string 1)))
(goto-char (point-min))
(when (re-search-forward "^$" nil t)
(forward-line 1)
(setq body (buffer-substring (point) (point-max))))
(list from subject body)))))
(message "Preparing commit email for revision %s" rev)
(let ((gnus-newsgroup-name nil))
(compose-mail (if dest-specs (cadr dest-specs) "")
(concat (if dest-specs (car dest-specs) "")
subject)))
(when from
(dvc-message-replace-header "From" from))
(message-goto-body)
;; do not PGP sign the message as per git convention
(when (looking-at "<#part[^>]*>")
(let ((beg (point)))
(forward-line 1)
(delete-region beg (point))))
(save-excursion
(when body
(insert body))
(when repo-location
(message-goto-body)
(when (re-search-forward "^---$" nil t)
(insert "\nCommitted revision " rev "\n"
"to <" repo-location ">.\n")))
(goto-char (point-max))
(unless (and (bolp) (looking-at "^$"))
(insert "\n"))
(message-goto-body))))))
(provide 'xgit-gnus)
;;; xgit-gnus.el ends here

72
dvc/lisp/xgit-log-edit.el
View File

@ -1,72 +0,0 @@
;;; xgit-log-edit.el --- Major mode to edit commit messages for git
;; Copyright (C) 2009 Matthieu Moy
;; Author: Matthieu Moy <Matthieu.Moy@imag.fr>
;; Keywords: git
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;;; Code:
;;;###autoload
(add-to-list 'auto-mode-alist '("/COMMIT_EDITMSG$" . xgit-log-edit-mode))
(defvar xgit-log-edit-mode-map
(let ((map (make-sparse-keymap)))
(define-key map [(control ?c) (control ?s)] 'xgit-log-edit-insert-sob)
map)
"Keymap used in `xgit-log-edit-mode' buffers.")
(easy-menu-define xgit-log-edit-mode-menu xgit-log-edit-mode-map
"`xgit-log-edit-mode' menu"
'("Log"
["Insert Signed-off-by:" xgit-log-edit-insert-sob t]
))
(defvar xgit-log-edit-font-lock-keywords
`(("^Signed-off-by: " . 'dvc-header)
("^#.*$" . 'dvc-comment))
"Keywords in xgit-log-edit mode.")
(defun xgit-log-edit-insert-sob ()
(interactive)
(goto-char (point-max))
(re-search-backward "^[^#\n]")
(end-of-line)
(newline 2)
(insert "Signed-off-by: " user-full-name " <" user-mail-address ">"))
;;;###autoload
(define-derived-mode xgit-log-edit-mode dvc-log-edit-mode "xgit-log-edit"
"Major Mode to edit xgit log messages.
Commands:
\\{xgit-log-edit-mode-map}
"
(use-local-map xgit-log-edit-mode-map)
(easy-menu-add xgit-log-edit-mode-menu)
(dvc-install-buffer-menu)
(set (make-local-variable 'font-lock-defaults)
'(xgit-log-edit-font-lock-keywords t))
(set (make-local-variable 'comment-start) "#")
(set (make-local-variable 'comment-end) "")
(setq fill-column 73)
(run-hooks 'xgit-log-edit-mode-hook))
(provide 'xgit-log-edit)
;;; xgit-log-edit.el ends here

390
dvc/lisp/xgit-log.el
View File

@ -1,390 +0,0 @@
;;; xgit-log.el --- git interface for dvc: mode for git log style output
;; Copyright (C) 2006-2009 by all contributors
;; Author: Stefan Reichoer, <stefan@xsteve.at>
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; The git interface for dvc: a mode to handle git log style output
;;; History:
;;
;;; Code:
(eval-when-compile (require 'cl))
(require 'dvc-revlist)
(defstruct (xgit-revision-st)
hash
message
author
commit
author-date
commit-date
merge
)
;; copied and adapted from bzr-log-parse
(defun xgit-log-parse (log-buffer location &optional remote missing)
"Parse the output of git log."
(dvc-trace "xgit-log-parse. location=%S" location)
(goto-char (point-min))
(let ((root location)
(intro-string)) ;; not used currently, but who knows
(when missing ;; skip the first status output
(re-search-forward (concat "^commit " xgit-hash-regexp "\n"))
(beginning-of-line)
(setq intro-string (buffer-substring-no-properties (point-min) (point)))
(with-current-buffer log-buffer
(let ((buffer-read-only nil))
(insert intro-string))))
(dvc-trace-current-line)
(while (> (point-max) (point))
(dvc-trace "while")
(dvc-trace-current-line)
(let ((elem (make-xgit-revision-st)))
;; As comments, with ";; |" as prefix is an example of output
;; of git log --pretty=fuller, with the corresponding parser
;; code below.
;; |commit c576304d512df18fa30b91bb3ac15478d5d4dfb1
(re-search-forward (concat "^commit \\(" xgit-hash-regexp
"\\)\n"))
(setf (xgit-revision-st-hash elem) (match-string 1))
(dvc-trace "commit %S" (xgit-revision-st-hash elem))
;; |Merge: f34f2b0... b13ef49...
;; |Author: Junio C Hamano <gitster@pobox.com>
;; |AuthorDate: Wed Aug 15 21:38:38 2007 -0700
;; |Commit: Junio C Hamano <gitster@pobox.com>
;; |CommitDate: Wed Aug 15 21:38:38 2007 -0700
(while (looking-at "^\\([^ \t\n]+\\): +\\([^ ].*\\)$")
(cond ((string= (match-string 1) "Author")
(setf (xgit-revision-st-author elem)
(match-string-no-properties 2)))
((string= (match-string 1) "Commit")
(setf (xgit-revision-st-commit elem)
(match-string-no-properties 2)))
((string= (match-string 1) "AuthorDate")
(setf (xgit-revision-st-author-date elem)
(match-string-no-properties 2)))
((string= (match-string 1) "CommitDate")
(setf (xgit-revision-st-commit-date elem)
(match-string-no-properties 2)))
((string= (match-string 1) "Merge")
(setf (xgit-revision-st-merge elem)
(match-string-no-properties 2))))
(forward-line 1))
;; |
;; | Merge branch 'maint' to sync with 1.5.2.5
;; |
;; | * maint:
;; | GIT 1.5.2.5
;; | git-add -u paths... now works from subdirectory
;; | Fix "git add -u" data corruption.
;; |
;; |
(forward-line 1)
(let ((start-point (point)))
(re-search-forward "^$")
;; final blank line, or end of buffer.
(beginning-of-line)
(setf (xgit-revision-st-message elem)
(buffer-substring-no-properties
start-point (point))))
(forward-line 1)
;; elem now contains the revision structure.
(with-current-buffer log-buffer
(ewoc-enter-last
dvc-revlist-cookie
`(entry-patch
,(make-dvc-revlist-entry-patch
:dvc 'xgit
:struct elem
:rev-id `(xgit (revision ,(xgit-revision-st-hash
elem))))))
(goto-char (point-min))
(dvc-revision-prev))))))
(defun xgit-revision-list-entry-patch-printer (elem)
(insert (if (dvc-revlist-entry-patch-marked elem)
(concat " " dvc-mark " ") " "))
(let* ((struct (dvc-revlist-entry-patch-struct elem))
(hash (xgit-revision-st-hash struct))
(commit (or (xgit-revision-st-commit struct) "?"))
(author (or (xgit-revision-st-author struct) "?"))
(commit-date (or (xgit-revision-st-commit-date struct) "?"))
(author-date (or (xgit-revision-st-author-date struct) "?")))
(insert (dvc-face-add "commit" 'dvc-header) " " hash "\n")
(when dvc-revisions-shows-creator
(insert " " (dvc-face-add "Commit:" 'dvc-header) " " commit "\n")
(unless (string= commit author)
(insert " " (dvc-face-add "Author:" 'dvc-header) " " author "\n")))
(when dvc-revisions-shows-date
(insert " " (dvc-face-add "CommitDate:" 'dvc-header) " "
commit-date "\n")
(unless (string= commit-date author-date)
(insert " " (dvc-face-add "AuthorDate:" 'dvc-header) " "
author-date "\n")))
(when dvc-revisions-shows-summary
(newline)
(insert (replace-regexp-in-string
"^" " " ;; indent by 4 already in git output, plus 3
;; to leave room for mark.
(or (xgit-revision-st-message struct) "?")))
(newline)
))
)
(defun xgit-revlog-get-revision (rev-id)
(let ((rev (car (dvc-revision-get-data rev-id))))
(dvc-run-dvc-sync 'xgit `("show" ,rev)
:finished 'dvc-output-buffer-handler)))
(defun xgit-revlog-mode ()
(interactive)
(xgit-diff-mode))
(defun xgit-name-construct (revision)
revision)
(defcustom xgit-log-max-count 400
"Number of logs to print. Specify negative value for all logs.
Limiting this to low number will shorten time for log retrieval
for large projects like Linux kernel on slow machines (Linux
kernel has >50000 logs).
See also `xgit-log-since'."
:type 'integer
:group 'dvc-xgit)
(defcustom xgit-log-since nil
"Time duration for which the log should be displayed.
For example, \"1.month.ago\", \"last.week\", ...
Use nil if you don't want a limit.
See also `xgit-log-max-count'."
:type '(choice (string :tag "Duration")
(const :tag "No limit" nil))
:group 'dvc-xgit)
(defun xgit-log-grep (regexp)
"Limit the log output to ones with log message that matches the specified pattern."
(interactive "MGrep pattern for Commit Log: ")
(xgit-log default-directory nil :log-regexp regexp))
(defun xgit-log-file (filename)
"Limit the log output to ones that changes the specified file."
(interactive "FFile name: ")
(xgit-log default-directory nil :file filename))
(defun xgit-log-diff-grep (string)
"Limit the logs that contain the change in given string."
(interactive "MGrep pattern for Commit Diff: ")
(xgit-log default-directory nil :diff-match string))
(defun xgit-log-revision (rev)
"Show log for a given hash id."
(interactive "MID: ")
(xgit-log default-directory 1 :rev rev))
;; copied and adapted from bzr-log
;;;###autoload
(defun* xgit-log (dir &optional cnt &key log-regexp diff-match rev file since)
"Run git log for DIR.
DIR is a directory controlled by Git.
CNT is max number of log to print. If not specified, uses xgit-log-max-count.
LOG-REGEXP is regexp to filter logs by matching commit logs.
DIFF-MATCH is string to filter logs by matching commit diffs.
REV is revision to show.
FILE is filename in repostory to filter logs by matching filename."
(interactive (list default-directory nil))
(let* ((count (format "--max-count=%s" (or cnt xgit-log-max-count)))
(since-date (or since xgit-log-since))
(since (when since-date (format "--since=%s" since-date)))
(grep (when log-regexp (format "--grep=%s" log-regexp)))
(diff (when diff-match (format "-S%s" diff-match)))
(fname (when file (file-relative-name file (xgit-tree-root dir))))
(args (list "log" "--pretty=fuller" count
since grep diff rev "--" fname)))
(dvc-build-revision-list 'xgit 'log (or dir default-directory) args
'xgit-log-parse t nil nil
(dvc-capturing-lambda ()
(xgit-log (capture dir)
(capture cnt)
:log-regexp (capture log-regexp)
:diff-match (capture diff-match)
:rev (capture rev)
:file (capture file)
:since (capture since))))
(goto-char (point-min))))
;; An alternative xgit-log implementation, showing diffs inline, based on xhg-log
(require 'diff-mode)
(defvar xgit-changelog-mode-map
(let ((map (copy-keymap diff-mode-shared-map)))
(define-key map dvc-keyvec-help 'describe-mode)
(define-key map [?g] 'xgit-changelog)
(define-key map [?h] 'dvc-buffer-pop-to-partner-buffer)
(define-key map [?s] 'xgit-status)
(define-key map dvc-keyvec-next 'xgit-changelog-next)
(define-key map dvc-keyvec-previous 'xgit-changelog-previous)
(define-key map [?\ ] 'xgit-changelog-dwim-next)
(define-key map dvc-keyvec-quit 'dvc-buffer-quit)
;; the merge group
(define-key map (dvc-prefix-merge ?f) 'dvc-pull) ;; hint: fetch, p is reserved for push
(define-key map (dvc-prefix-merge ?m) '(lambda () (interactive) (dvc-missing nil default-directory)))
map)
"Keymap used in `xgit-changelog-mode'.")
;;(easy-menu-define xgit-changelog-mode-menu xgit-changelog-mode-map
;; "`xgit-changelog-mode' menu"
;; `("hg-log"
;; ["Show status" dvc-status t]
;; ))
(defvar xgit-changelog-font-lock-keywords
(append
'(("^commit " . font-lock-function-name-face)
("^Merge:" . font-lock-function-name-face)
("^Author:" . font-lock-function-name-face)
("^Date:" . font-lock-function-name-face))
diff-font-lock-keywords)
"Keywords in `xgit-changelog-mode' mode.")
(defvar xgit-changelog-review-current-diff-revision nil)
(defvar xgit-changelog-review-recenter-position-on-next-diff 5)
(define-derived-mode xgit-changelog-mode fundamental-mode "xgit-changelog"
"Major mode to display hg log output with embedded diffs. Derives from `diff-mode'.
Commands:
\\{xgit-changelog-mode-map}
"
(let ((diff-mode-shared-map (copy-keymap xgit-changelog-mode-map))
major-mode mode-name)
(diff-mode))
(set (make-local-variable 'font-lock-defaults)
(list 'xgit-changelog-font-lock-keywords t nil nil))
(set (make-local-variable 'xgit-changelog-review-current-diff-revision) nil))
(defun xgit-changelog (&optional r1 r2 show-patch file)
"Run git log.
When run interactively, the prefix argument decides, which parameters are queried from the user.
C-u : Show patches also, use all revisions
C-u C-u : Show patches also, ask for revisions
positive : Don't show patches, ask for revisions.
negative : Don't show patches, limit to n revisions."
(interactive "P")
(when (interactive-p)
(cond ((equal current-prefix-arg '(4))
(setq show-patch t)
(setq r1 nil))
((equal current-prefix-arg '(16))
(setq show-patch t)
(setq r1 1)))
(when (and (numberp r1) (> r1 0))
(setq r1 (read-string "git log, R1:"))
(setq r2 (read-string "git log, R2:"))))
(let ((buffer (dvc-get-buffer-create 'xgit 'log))
(command-list '("log" "--reverse"))
(cur-dir default-directory))
(when r1
(when (numberp r1)
(setq r1 (number-to-string r1))))
(when r2
(when (numberp r2)
(setq r2 (number-to-string r2))))
(if (and (> (length r2) 0) (> (length r1) 0))
(setq command-list (append command-list (list (concat r1 ".." r2))))
(when (> (length r1) 0)
(let ((r1-num (string-to-number r1)))
(if (> r1-num 0)
(setq command-list (append command-list (list r1)))
(setq command-list
(append command-list
(list (format "--max-count=%d" (abs r1-num)))))))))
(when show-patch
(setq command-list (append command-list (list "-p"))))
(dvc-switch-to-buffer-maybe buffer)
(let ((inhibit-read-only t))
(erase-buffer))
(xgit-changelog-mode)
(dvc-run-dvc-sync 'xgit command-list
:finished
(dvc-capturing-lambda (output error status arguments)
(progn
(with-current-buffer (capture buffer)
(let ((inhibit-read-only t))
(erase-buffer)
(insert-buffer-substring output)
(goto-char (point-min))
(insert (format "xgit log for %s\n\n" default-directory))
(toggle-read-only 1))))))))
(defconst xgit-changelog-start-regexp "^commit \\([0-9a-f]+\\)$")
(defun xgit-changelog-next (n)
"Move to the next changeset header of the next diff hunk"
(interactive "p")
(end-of-line)
(re-search-forward xgit-changelog-start-regexp nil t n)
(beginning-of-line)
(when xgit-changelog-review-recenter-position-on-next-diff
(recenter xgit-changelog-review-recenter-position-on-next-diff)))
(defun xgit-changelog-previous (n)
"Move to the previous changeset header of the previous diff hunk"
(interactive "p")
(end-of-line)
(when (save-excursion
(beginning-of-line)
(looking-at xgit-changelog-start-regexp))
(re-search-backward xgit-changelog-start-regexp))
(re-search-backward xgit-changelog-start-regexp nil t n)
(when xgit-changelog-review-recenter-position-on-next-diff
(recenter xgit-changelog-review-recenter-position-on-next-diff)))
(defun xgit-changelog-dwim-next ()
"Either move to the next changeset via `xgit-changelog-next' or call `scroll-up'.
When the beginning of the next changeset is already visible, call `xgit-changelog-next',
otherwise call `scroll-up'."
(interactive)
(let* ((start-pos (point))
(window-line (count-lines (window-start) start-pos))
(window-height (dvc-window-body-height))
(distance-to-next-changeset (save-window-excursion (xgit-changelog-next 1) (count-lines start-pos (point)))))
(goto-char start-pos)
(when (eq distance-to-next-changeset 0) ; last changeset
(setq distance-to-next-changeset (count-lines start-pos (point-max))))
(if (< (- window-height window-line) distance-to-next-changeset)
(scroll-up)
(xgit-changelog-next 1))))
(provide 'xgit-log)
;;; xgit-log.el ends here

91
dvc/lisp/xgit-rebase-todo.el
View File

@ -1,91 +0,0 @@
;;; xgit-rebase-todo.el --- Major mode for editting git-rebase-todo files.
;; Copyright (C) 2009 Matthieu Moy
;; Author: Matthieu Moy <Matthieu.Moy@imag.fr>
;; Keywords:
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;;; Code:
;;;###autoload
(add-to-list 'auto-mode-alist '("/git-rebase-todo$" . xgit-rebase-todo-mode))
(defvar xgit-rebase-todo-mode-map
(let ((map (make-sparse-keymap)))
(define-key map [(meta ?n)] 'xgit-rebase-todo-move-down)
(define-key map [(meta ?p)] 'xgit-rebase-todo-move-up)
map)
"Keymap used in `xgit-rebase-todo-mode' buffers.")
(defun xgit-rebase-todo-move-down ()
(interactive)
(beginning-of-line)
(let* ((next (+ 1 (line-end-position)))
(line (buffer-substring (point) next)))
(delete-region (point) next)
(forward-line 1)
(insert line)
(forward-line -1)))
(defun xgit-rebase-todo-move-up ()
(interactive)
(beginning-of-line)
(let* ((next (+ 1 (line-end-position)))
(line (buffer-substring (point) next)))
(delete-region (point) next)
(forward-line -1)
(insert line)
(forward-line -1)))
;; (easy-menu-define xgit-rebase-todo-mode-menu xgit-rebase-todo-mode-map
;; "`xgit-rebase-todo-mode' menu"
;; '("Rebase-todo"
;; ["Action" xgit-rebase-todo-function t]
;; ))
(defvar xgit-rebase-todo-font-lock-keywords
'(("^\\([a-z]+\\) \\([0-9a-f]+\\) \\(.*\\)$"
(1 'dvc-keyword)
(2 'dvc-revision-name))
("^#.*$" . 'dvc-comment))
"Keywords in xgit-rebase-todo mode.")
;;;###autoload
(define-derived-mode xgit-rebase-todo-mode fundamental-mode "xgit-rebase-todo"
"Major Mode to edit xgit rebase-todo files.
These files are the ones on which git launches the editor for
'git rebase --interactive' commands.
Commands:
\\{xgit-rebase-todo-mode-map}
"
(use-local-map xgit-rebase-todo-mode-map)
;;(easy-menu-add xgit-rebase-todo-mode-menu)
(dvc-install-buffer-menu)
(set (make-local-variable 'font-lock-defaults)
'(xgit-rebase-todo-font-lock-keywords t))
(set (make-local-variable 'comment-start) "#")
(set (make-local-variable 'comment-end) "")
(run-hooks 'xgit-rebase-todo-mode-hook))
(provide 'xgit-rebase-todo)
;;; xgit-rebase-todo.el ends here

116
dvc/lisp/xgit-revision.el
View File

@ -1,116 +0,0 @@
;;; xgit-revision.el --- Management of revision lists for git
;; Copyright (C) 2006-2007 by all contributors
;; Author: Stefan Reichoer, <stefan@xsteve.at>
;; Keywords:
;; DVC is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; DVC is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;
;;; Code:
(eval-when-compile (require 'cl))
(defstruct (xgit-revision-st)
commit
tree
parent
author
committer
date
message)
;; cg dvc revision list
(defun xgit-revision-list-entry-patch-printer (elem)
(insert (if (dvc-revlist-entry-patch-marked elem)
(concat " " dvc-mark " ") " "))
(let ((struct (dvc-revlist-entry-patch-struct elem)))
(insert (dvc-face-add "commit: " 'dvc-header)
(dvc-face-add (xgit-revision-st-commit struct) 'dvc-revision-name)
"\n")
(when (xgit-revision-st-tree struct)
(insert " " (dvc-face-add "tree: " 'dvc-header)
(dvc-face-add (xgit-revision-st-tree struct) 'dvc-revision-name)
"\n"))
(when (xgit-revision-st-parent struct)
(insert " " (dvc-face-add "parent: " 'dvc-header)
(dvc-face-add (xgit-revision-st-parent struct) 'dvc-revision-name)
"\n"))
(when dvc-revisions-shows-creator
(insert " " (dvc-face-add "author: " 'dvc-header)
(or (xgit-revision-st-author struct) "?") "\n")
(insert " " (dvc-face-add "committer: " 'dvc-header)
(or (xgit-revision-st-committer struct) "?") "\n"))
(when dvc-revisions-shows-date
(insert " " (dvc-face-add "timestamp: " 'dvc-header)
(or (xgit-revision-st-date struct) "?") "\n"))
(when dvc-revisions-shows-summary
(insert " " (dvc-face-add "summary: " 'dvc-header)
(or (xgit-revision-st-message struct) "?") "\n"))))
;;; cg dvc log
(defun xgit-dvc-log-parse (log-buffer)
(goto-char (point-min))
(let ((root (xgit-tree-root))
(elem (make-xgit-revision-st))
(field)
(field-value))
(while (> (point-max) (point))
(beginning-of-line)
(when (looking-at "^\\([a-z]+\\) +\\(.+\\)$")
(setq field (match-string-no-properties 1))
(setq field-value (match-string-no-properties 2))
;; (dvc-trace "field: %s, field-value: %s" field field-value)
(cond ((string= field "commit")
(setf (xgit-revision-st-commit elem) field-value))
((string= field "tree")
(setf (xgit-revision-st-tree elem) field-value))
((string= field "parent")
(setf (xgit-revision-st-parent elem) field-value))
((string= field "author")
(setf (xgit-revision-st-author elem) field-value))
((string= field "committer")
(setf (xgit-revision-st-committer elem) field-value))
(t (dvc-trace "xgit-dvc-log-parse: unmanaged field %S" field)))
(forward-line 1))
(when (looking-at "^$")
;; (dvc-trace "empty line")
(unless (re-search-forward "^commit" nil t)
(goto-char (point-max)))
(with-current-buffer log-buffer
(ewoc-enter-last
dvc-revlist-cookie
`(entry-patch
,(make-dvc-revlist-entry-patch
:dvc 'xgit
:struct elem
:rev-id `(xgit (revision
(local ,root ,
(xgit-revision-st-commit elem))))))))
(setq elem (make-xgit-revision-st)))))
(with-current-buffer log-buffer
(goto-char (point-min))))
(provide 'xgit-revision)
;;; xgit-revision.el ends here

1004
dvc/lisp/xgit.el
View File

File diff suppressed because it is too large Load Diff

143
dvc/lisp/xhg-annotate.el
View File

@ -1,143 +0,0 @@
;;; xhg-annotate.el ---
;; Copyright (C) 2009 Thierry Volpiatto.
;; Author: Thierry Volpiatto <thierry.volpiatto@gmail.com>
;; Maintainer: Thierry Volpiatto
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 3, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth
;; Floor, Boston, MA 02110-1301, USA.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;;; ==========
;;; Commands:
;;
;; Below are complete command list:
;;
;; `xhg-annotate-show-rev-number-log'
;; Show xhg-log output corresponding to line at point in
;; `xhg-annotate-show-prec-rev-number-log'
;; Go to precedent line in xhg-annotate buffer and display
;; `xhg-annotate-show-next-rev-number-log'
;; Go to next line in xhg-annotate buffer and display
;; `xhg-annotate'
;; Run hg annotate and display xhg-log in other-window.
;; `xhg-annotate-quit'
;; Quit and restore precedent window config.
;; hg annotate:
;;
;; List changes in files, showing the revision id responsible for each line
;; This command is useful to discover who did a change or when a change took
;; place.
;; Without the -a option, annotate will avoid processing files it
;; detects as binary. With -a, annotate will generate an annotation
;; anyway, probably with undesirable results.
;; From current file under hg control, run xhg-annotate in one buffer
;; and xhg-log in the other buffer at the revision corresponding to current line
;; of current file.
;; once in the xhg-annotate buffer you can navigate to the different line
;; showing at each movement the xhg-log output corresponding to revision.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Code:
(require 'derived)
(eval-when-compile (require 'cl))
;;;###autoload
(defvar xhg-annotate-mode-map
(let ((map (make-sparse-keymap)))
(define-key map [(shift down)] 'xhg-annotate-show-next-rev-number-log)
(define-key map [(shift up)] 'xhg-annotate-show-prec-rev-number-log)
(define-key map (kbd "<return>") 'xhg-annotate-show-rev-number-log)
(define-key map [?q] 'xhg-annotate-quit)
map)
"Keymap used for xhg-annotate-mode commands.")
(define-derived-mode xhg-annotate-mode dvc-info-buffer-mode "xhg-annotate"
"Major mode to show revision number log.
Special commands:
\\{xhg-annotate-mode-map}")
(defvar xhg-annotate-current-buffer nil)
(defun xhg-annotate-get-rev-num-on-line ()
"Extract revision number on line in `xhg-annotate' buffer."
(let ((cur-line (buffer-substring (point-at-bol) (point-at-eol)))
(rev-num))
(when (string-match "^ *[0-9]*" cur-line)
(setq rev-num (match-string 0 cur-line))
(setq rev-num (replace-regexp-in-string " " "" rev-num)))))
;;;###autoload
(defun xhg-annotate-show-rev-number-log ()
"Show `xhg-log' corresponding to current line in `xhg-annotate' buffer."
(interactive)
(let ((rev-number (xhg-annotate-get-rev-num-on-line))
(fname (buffer-file-name xhg-annotate-current-buffer)))
(save-excursion
(xhg-log rev-number rev-number t fname)
(other-window 1))))
;;;###autoload
(defun xhg-annotate-show-prec-rev-number-log ()
"Go to precedent line in xhg-annotate buffer and display
corresponding xhg-log output."
(interactive)
(forward-line -1)
(xhg-annotate-show-rev-number-log))
;;;###autoload
(defun xhg-annotate-show-next-rev-number-log ()
"Go to next line in xhg-annotate buffer and display
corresponding xhg-log output."
(interactive)
(forward-line)
(xhg-annotate-show-rev-number-log))
;;;###autoload
(defun xhg-annotate ()
"Run hg annotate and display xhg-log in other-window."
(interactive)
(setq xhg-annotate-current-buffer (current-buffer))
(let ((line-num (line-number-at-pos)))
(dvc-run-dvc-display-as-info 'xhg (append '("annotate") (dvc-current-file-list)))
(switch-to-buffer "*xhg-info*")
(goto-line line-num)
(xhg-annotate-mode)
(xhg-annotate-show-rev-number-log)))
;;;###autoload
(defun xhg-annotate-quit ()
"Quit and restore precedent window config."
(interactive)
(dvc-buffer-quit)
(other-window 1)
(dvc-buffer-quit)
(switch-to-buffer xhg-annotate-current-buffer)
(setq xhg-annotate-current-buffer nil)
(delete-other-windows))
(provide 'xhg-annotate)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; xhg-annotate.el ends here

57
dvc/lisp/xhg-be.el
View File

@ -1,57 +0,0 @@
;;; xhg-be.el --- dvc integration for the mercurial bugs everywhere plugin
;; Copyright (C) 2006 by all contributors
;; Author: Stefan Reichoer, <stefan@xsteve.at>
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; For more information on bugs everywhere see:
;; http://panoramicfeedback.com/opensource/
;; hg be extension commands:
;; bassign assign a person to fix a bug
;; bclose close a given bug
;; bcomment add a comment to a given bug
;; binit initialize the bug repository
;; binprogress mark a bug as 'in-progress'
;; blist list bugs
;; bnew create a new bug
;; bopen re-open a given bug
;; bset show or change per-tree settings
;; bseverity Show or change a bug's severity level.
;; bshow show all information about a given bug
;; btarget Show or change a bug's target for fixing.
;; bversion print the version number
(require 'dvc-be)
(defun xhg-binit (&optional dir)
"Run hg binit."
(interactive
(list (expand-file-name (dvc-read-directory-name "Directory for hg binit: "
(or default-directory
(getenv "HOME"))))))
(let ((default-directory dir))
(dvc-run-dvc-sync 'xhg (list "binit")
:finished (dvc-capturing-lambda
(output error status arguments)
(message "hg binit finished")))))
(provide 'xhg-be)
;;; xhg-be.el ends here

70
dvc/lisp/xhg-core.el
View File

@ -1,70 +0,0 @@
;;; xhg-core.el --- Common definitions for mercurial support in DVC
;; Copyright (C) 2005-2012 by all contributors
;; Author: Stefan Reichoer, <stefan@xsteve.at>
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; This file provides the low-level functions used by the Xtla interfaces
;; to distributed revison control systems.
;;; History:
;;
;;; Code:
(require 'dvc-core)
;; Settings for Mercurial/hg
(defvar xhg-executable
"hg"
"The executable used for the hg commandline client.")
(defvar xhg-log-edit-file-name
"++xhg-log-edit"
"The filename, used to store the log message before commiting.
Usually that file is placed in the tree-root of the working tree.")
;;;###autoload
(defun xhg-tree-root (&optional location no-error interactive)
"Return the tree root for LOCATION, nil if not in a local tree.
Computation is done from withing Emacs, by looking at an .hg/
directory in a parent buffer of LOCATION. This is therefore very
fast.
If NO-ERROR is non-nil, don't raise an error if LOCATION is not a
mercurial managed tree (but return nil)."
(dvc-tree-root-helper ".hg/" (or interactive (interactive-p))
"%S is not in a mercurial-managed tree!"
location no-error))
(defun xhg-read-revision (prompt)
"Read a revision for the actual mercurial working copy."
(read-string prompt (xhg-log-revision-at-point)))
(defun xhg-prepare-environment (env)
"Prepare the environment to run hg."
;; DVC expects hg messages in the C locale
(cons "LC_MESSAGES=C" env))
(provide 'xhg-core)
;;; xhg-core.el ends here

220
dvc/lisp/xhg-dvc.el
View File

@ -1,220 +0,0 @@
;;; xhg-dvc.el --- The dvc layer for xhg
;; Copyright (C) 2005-2012 by all contributors
;; Author: Stefan Reichoer, <stefan@xsteve.at>
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; This file provides the common dvc layer for xhg
;;; Commands:
;;
;; Below is a complete command list:
;;
;; `xhg-select-committer-for-next-commit'
;; Select the committer for the next hg commit.
;; `xhg-dvc-missing'
;; Run hg incoming to show the missing patches for this tree.
;; `xhg-dvc-pull'
;; Run hg pull, when `xhg-dvc-pull-runs-update' is t, use the --update flag.
;; `xhg-dvc-create-branch'
;; Run xhg-branch.
;; `xhg-dvc-select-branch'
;; Switch to a named branch.
;;
;;; History:
;;
;;; Code:
(require 'xhg)
(eval-and-compile (require 'dvc-unified))
;;;###autoload
(dvc-register-dvc 'xhg "Mercurial")
;;;###autoload
(defalias 'xhg-dvc-tree-root 'xhg-tree-root)
;;;###autoload
(defalias 'xhg-dvc-merge 'xhg-merge)
;;;###autoload
(defun xhg-dvc-export-via-email ()
(interactive)
(call-interactively 'xhg-export-via-mail))
(defvar xhg-dvc-commit-extra-parameters nil "A list of extra parameters for the next hg commit.")
(defvar xhg-commit-done-hook '()
"*Hooks run after a successful commit via `xhg-dvc-log-edit-done'.")
(defun xhg-select-committer-for-next-commit (committer)
"Select the committer for the next hg commit.
This is done via setting `xhg-dvc-commit-extra-parameters'."
(interactive (list (read-string "Committer for next hg commit: " xhg-gnus-patch-from-user)))
(setq xhg-dvc-commit-extra-parameters `("--user" ,committer)))
;; Base functions that are required for every supported dvc system
(defun xhg-dvc-log-edit-done ()
"Finish a commit for Mercurial."
(let ((buffer (find-file-noselect (dvc-log-edit-file-name)))
(files-to-commit (with-current-buffer dvc-partner-buffer (dvc-current-file-list 'nil-if-none-marked))))
(dvc-log-flush-commit-file-list)
(save-buffer buffer)
(message "committing %S in %s" (or files-to-commit "all files") (dvc-tree-root))
(dvc-run-dvc-sync
'xhg (append (list "commit" "-l" (dvc-log-edit-file-name))
xhg-dvc-commit-extra-parameters files-to-commit)
:finished (dvc-capturing-lambda
(output error status arguments)
(dvc-show-error-buffer output 'commit)
(let ((inhibit-read-only t))
(goto-char (point-max))
(insert (with-current-buffer error
(buffer-string))))
(dvc-log-close (capture buffer))
;; doesn't work at the moment (Stefan, 10.02.2006)
;; (dvc-diff-clear-buffers 'xhg (capture default-directory)
;; "* Just committed! Please refresh buffer\n")
(setq xhg-dvc-commit-extra-parameters nil)
(message "Mercurial commit finished")
(dvc-tips-popup-maybe)
(run-hooks 'xhg-commit-done-hook)))))
;;;###autoload
(defalias 'xhg-dvc-save-diff 'xhg-save-diff)
;;;###autoload
(defalias 'xhg-dvc-command-version 'xhg-command-version)
(defun xhg-dvc-changelog (&optional arg)
"Shows the changelog in the current Mercurial tree.
ARG is passed as prefix argument"
(call-interactively 'xhg-log))
(defalias 'xhg-dvc-prepare-environment 'xhg-prepare-environment)
;; deactivated at them moment, use dvc-dvc-files-to-commit to allow selecting files to commit
;; (defun xhg-dvc-files-to-commit ()
;; ;; -mar: modified+added+removed
;; (dvc-run-dvc-sync 'xhg (list "status" "-mar")
;; :finished (dvc-capturing-lambda
;; (output error status arguments)
;; (let ((file-list)
;; (modif)
;; (file-name))
;; (set-buffer output)
;; (goto-char (point-min))
;; (while (> (point-max) (point))
;; (cond ((looking-at "M ")
;; (setq modif 'dvc-modified))
;; ((looking-at "A ")
;; (setq modif 'dvc-added))
;; ((looking-at "R ")
;; (setq modif 'dvc-move))
;; (t
;; (setq modif nil)))
;; (setq file-name (buffer-substring-no-properties (+ (point) 2) (line-end-position)))
;; (add-to-list 'file-list (cons modif file-name))
;; (forward-line 1))
;; file-list))))
(defun xhg-dvc-edit-ignore-files ()
(interactive)
(find-file-other-window (concat (xhg-tree-root) ".hgignore")))
(defun xhg-dvc-ignore-files (file-list)
(interactive (list (dvc-current-file-list)))
(when (y-or-n-p (format "Ignore %S for %s? " file-list (xhg-tree-root)))
(with-current-buffer
(find-file-noselect (concat (xhg-tree-root) ".hgignore"))
(goto-char (point-max))
(dolist (f-name file-list)
(insert (format "^%s$\n" (regexp-quote f-name))))
(save-buffer))))
(defun xhg-dvc-backend-ignore-file-extensions (extension-list)
(with-current-buffer
(find-file-noselect (concat (xhg-tree-root) ".hgignore"))
(goto-char (point-max))
(dolist (ext-name extension-list)
(insert (format "\\.%s$\n" (regexp-quote ext-name))))
(save-buffer)))
(defun xhg-dvc-missing (&optional other)
"Run hg incoming to show the missing patches for this tree.
When `last-command' was `dvc-pull', run `xhg-missing'."
(interactive)
(if (eq last-command 'dvc-pull)
(xhg-missing-1)
(xhg-incoming other t)))
(defun xhg-dvc-update ()
(interactive)
(xhg-update))
(defvar xhg-dvc-pull-runs-update t
"Whether `xhg-dvc-pull' should call hg pull with the --update flag.")
(defun xhg-dvc-pull (&optional other)
"Run hg pull, when `xhg-dvc-pull-runs-update' is t, use the --update flag."
(interactive)
(let ((source-path
(or other
(let* ((completions (xhg-paths 'both))
(initial-input (car (member "default" completions))))
(if (string= initial-input "default") initial-input
(dvc-completing-read
"Pull from hg repository: "
completions nil nil initial-input))))))
(xhg-pull source-path xhg-dvc-pull-runs-update)))
(defun xhg-dvc-create-branch (new-name)
"Run xhg-branch."
(interactive "sNewBranchName: ")
(xhg-branch new-name))
(defun xhg-dvc-select-branch ()
"Switch to a named branch."
(interactive)
(xhg-update nil t))
(defun xhg-dvc-ediff-file-revisions ()
"Layer function for `xhg-ediff-file-at-rev'."
(interactive)
(call-interactively #'xhg-ediff-file-at-rev))
(defalias 'xhg-dvc-revlog-get-revision 'xhg-revlog-get-revision)
(defalias 'xhg-dvc-name-construct 'xhg-name-construct)
(defalias 'xhg-dvc-delta 'xhg-delta)
(defalias 'xhg-dvc-clone 'xhg-clone)
(defalias 'xhg-dvc-init 'xhg-init)
(defalias 'xhg-dvc-push 'xhg-push)
(provide 'xhg-dvc)
;;; xhg-dvc.el ends here

Some files were not shown because too many files have changed in this diff Show More