diff --git a/dvc/COPYING b/dvc/COPYING new file mode 100644 index 0000000..b7b5f53 --- /dev/null +++ b/dvc/COPYING @@ -0,0 +1,340 @@ + 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. + + + Copyright (C) + + 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. + + , 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. diff --git a/dvc/INSTALL b/dvc/INSTALL new file mode 100644 index 0000000..c6e25c6 --- /dev/null +++ b/dvc/INSTALL @@ -0,0 +1,136 @@ +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. diff --git a/dvc/INSTALL.windows b/dvc/INSTALL.windows new file mode 100644 index 0000000..6fc88cd --- /dev/null +++ b/dvc/INSTALL.windows @@ -0,0 +1,26 @@ +* 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)]) + + diff --git a/dvc/Makefile.in b/dvc/Makefile.in new file mode 100644 index 0000000..1ce5c8e --- /dev/null +++ b/dvc/Makefile.in @@ -0,0 +1,100 @@ +@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 + +%-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 + +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 \ + 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/*' + +.PHONY: all info pdf dvi html dvc dvc-verbose \ + install uninstall \ + clean distclean maintainer-clean \ + dist tarball diff --git a/dvc/configure.ac b/dvc/configure.ac new file mode 100644 index 0000000..2c6cefe --- /dev/null +++ b/dvc/configure.ac @@ -0,0 +1,176 @@ +# configure.ac --- configuration setup for DVC + +# Copyright (C) 2004-2007 by all contributors +# Author: Robert Widhopf-Fenk + +# 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 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_OUTPUT + +# configure.ac ends here diff --git a/dvc/debian/README.Debian b/dvc/debian/README.Debian new file mode 100644 index 0000000..d400ca9 --- /dev/null +++ b/dvc/debian/README.Debian @@ -0,0 +1,6 @@ +This package is a rework of Milan Zamazal's packaging based on +Matthieu Moy . + +This package use cdbs. + + -- Daniel Dehennin , Fri, 22 Aug 2008 07:04:29 +0200 diff --git a/dvc/debian/changelog b/dvc/debian/changelog new file mode 100644 index 0000000..eae7ec0 --- /dev/null +++ b/dvc/debian/changelog @@ -0,0 +1,6 @@ +dvc (0r20080829-1) unstable; urgency=low + + * New snapshot. + * Julien Danjou is the sponsor for DVC (Closes: #496930). + + -- Daniel Dehennin Fri, 29 Aug 2008 19:27:14 +0200 diff --git a/dvc/debian/compat b/dvc/debian/compat new file mode 100644 index 0000000..b8626c4 --- /dev/null +++ b/dvc/debian/compat @@ -0,0 +1 @@ +4 diff --git a/dvc/debian/control b/dvc/debian/control new file mode 100644 index 0000000..861f759 --- /dev/null +++ b/dvc/debian/control @@ -0,0 +1,30 @@ +Source: dvc +Section: devel +Priority: optional +Maintainer: Daniel Dehennin +Build-Depends: cdbs (>= 0.4.50), debhelper +Build-Depends-Indep: autoconf, emacs22 | emacs21 | xemacs21 | emacsen, texinfo +Standards-Version: 3.8.0.1 +Vcs-Bzr: http://bzr.xsteve.at/dvc/ +Homepage: http://download.gna.org/dvc/ + +Package: dvc +Architecture: all +Depends: emacs22 | emacs21 | xemacs21 | emacs-snapshot +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). diff --git a/dvc/debian/copyright b/dvc/debian/copyright new file mode 100644 index 0000000..ccbf461 --- /dev/null +++ b/dvc/debian/copyright @@ -0,0 +1,69 @@ +This package was debianized by Matthieu Moy on +Sun, 17 Oct 2004 17:15:25 +0200. Small additional changes were made by +Milan Zamazal and Daniel Dehennin + 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 +Andrea Russo +Andre Kuehne +Bojan Nikolic +Chris Gray +Christian Ohler +Daniel Dehennin +Mark Triggs +Martin Brett Pool +Masatake YAMATO +Matthieu MOY +Michael Olson +Milan Zamazal +Miles Bader +Robert Widhopf-Fenk +Sam Steingold +Sascha Wilde +Stefan Reichoer +Stephen Leake +Steve Youngs +Takuzo O'hara +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. + + 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. diff --git a/dvc/debian/dvc.dirs b/dvc/debian/dvc.dirs new file mode 100644 index 0000000..e47b9a2 --- /dev/null +++ b/dvc/debian/dvc.dirs @@ -0,0 +1,5 @@ +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 + diff --git a/dvc/debian/dvc.docs b/dvc/debian/dvc.docs new file mode 100644 index 0000000..631369c --- /dev/null +++ b/dvc/debian/dvc.docs @@ -0,0 +1,10 @@ +debian/copyright +docs/ANNOUNCEMENTS +docs/ARCHIVES +docs/BINDINGS +docs/CONTRIBUTORS +docs/DVC-API +docs/FEATURES +docs/HACKING +docs/TODO +docs/xmtn-readme.txt diff --git a/dvc/debian/dvc.emacsen-install b/dvc/debian/dvc.emacsen-install new file mode 100644 index 0000000..0eb5eae --- /dev/null +++ b/dvc/debian/dvc.emacsen-install @@ -0,0 +1,81 @@ +#! /bin/sh -e +# /usr/lib/emacsen-common/packages/install/dvc + +# Written by Jim Van Zandt , borrowing heavily +# from the install scripts for gettext by Santiago Vila +# and octave by Dirk Eddelbuettel . + +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 + diff --git a/dvc/debian/dvc.emacsen-remove b/dvc/debian/dvc.emacsen-remove new file mode 100644 index 0000000..ac242ad --- /dev/null +++ b/dvc/debian/dvc.emacsen-remove @@ -0,0 +1,29 @@ +#!/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 + diff --git a/dvc/debian/dvc.emacsen-startup b/dvc/debian/dvc.emacsen-startup new file mode 100644 index 0000000..7e9ec3a --- /dev/null +++ b/dvc/debian/dvc.emacsen-startup @@ -0,0 +1,36 @@ +;; -*-emacs-lisp-*- +;; +;; Emacs startup file for the Debian dvc package +;; +;; Originally contributed by Nils Naumann +;; Modified by Dirk Eddelbuettel +;; Adapted for dh-make by Jim Van Zandt + +;; 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)) + diff --git a/dvc/debian/dvc.info b/dvc/debian/dvc.info new file mode 100644 index 0000000..89b568f --- /dev/null +++ b/dvc/debian/dvc.info @@ -0,0 +1 @@ +texinfo/dvc.info diff --git a/dvc/debian/dvc.install b/dvc/debian/dvc.install new file mode 100644 index 0000000..b465112 --- /dev/null +++ b/dvc/debian/dvc.install @@ -0,0 +1,7 @@ +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/ diff --git a/dvc/debian/rules b/dvc/debian/rules new file mode 100644 index 0000000..60e8054 --- /dev/null +++ b/dvc/debian/rules @@ -0,0 +1,17 @@ +#!/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 diff --git a/dvc/docs/ANNOUNCEMENTS b/dvc/docs/ANNOUNCEMENTS new file mode 100644 index 0000000..aff7fe9 --- /dev/null +++ b/dvc/docs/ANNOUNCEMENTS @@ -0,0 +1,99 @@ +; -*- 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 diff --git a/dvc/docs/ARCHIVES b/dvc/docs/ARCHIVES new file mode 100644 index 0000000..562935d --- /dev/null +++ b/dvc/docs/ARCHIVES @@ -0,0 +1,36 @@ +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 + + diff --git a/dvc/docs/BINDINGS b/dvc/docs/BINDINGS new file mode 100644 index 0000000..61c24ef --- /dev/null +++ b/dvc/docs/BINDINGS @@ -0,0 +1,210 @@ +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) +) diff --git a/dvc/docs/CONTRIBUTORS b/dvc/docs/CONTRIBUTORS new file mode 100644 index 0000000..621abbd --- /dev/null +++ b/dvc/docs/CONTRIBUTORS @@ -0,0 +1,165 @@ +#!/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))))) diff --git a/dvc/docs/DVC-API b/dvc/docs/DVC-API new file mode 100644 index 0000000..8565598 --- /dev/null +++ b/dvc/docs/DVC-API @@ -0,0 +1,179 @@ +That file contains the documentation to build support for a different dvc, +using the dvc layer: + +Conventions used in the document: +* 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.el file +-------------------------------------------------------------------------------- + +When no function is provided, dvc-dvc- is used instead. + +- -dvc-tree-root + (defun -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 + managed tree (but return nil)." + +- -dvc-log-edit-done + (defun -dvc-log-edit-done () + "Finish a commit for ." + +- -dvc-diff + (defun -dvc-diff () + "Shows the changes in the current tree." + +- -dvc-log + (defun -dvc-log () + "Shows the changelog in the current tree." + +- -dvc-command-version + (defun -dvc-command-version () + "Returns and/or shows the version identity string of backend command." + +- -dvc-file-has-conflict-p + (defun -dvc-file-has-conflict-p (filename) + "Return non-nil if FILENAME is marked as having conflicts") + +- -dvc-resolved + (defun -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 -foo, that specifies which +back-end to use. + +A simple way to provide -foo is to put dvc-foo in +dvc-back-end-wrappers (in dvc-unified.el); then -foo is +automatically generated by dvc-register-dvc. This defines +-foo as (see dvc-register.el for the actual code): + + (defun -foo () + (interactive) + (let ((dvc-temp-current-active-dvc )) + (call-interactively 'dvc-foo))) + +This means that back-ends may _not_ define a function -foo. + +Note that functions defined by dvc-define-unified-command dispatch +to -dvc-foo. Calling -dvc-foo is _not_ the same as +calling -foo, since dvc-temp-current-active-dvc is not bound, +the interactive argument processing may be different, and +-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 :: ( BACK-END-ID) + ;; 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 -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. diff --git a/dvc/docs/FEATURES b/dvc/docs/FEATURES new file mode 100644 index 0000000..3333c0a --- /dev/null +++ b/dvc/docs/FEATURES @@ -0,0 +1,204 @@ +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 + + diff --git a/dvc/docs/HACKING b/dvc/docs/HACKING new file mode 100644 index 0000000..d43a603 --- /dev/null +++ b/dvc/docs/HACKING @@ -0,0 +1,263 @@ +-*- 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 : GNU Emacs 21.3.1, GNU Emacs in CVS repository +Matthieu Moy : GNU Emacs 21.2 (Solaris and Linux) +Masatake YAMATO : GNU Emacs in CVS repository +Milan Zamazal : GNU Emacs 21.3, GNU Emacs CVS +Martin Pool : ??? +Robert Widhopf-Fenk : XEmacs 21.4.5 +Mark Triggs : GNU Emacs in CVS repository + +gnuarch version +=============== + +gnuarch version which xtla's developers are using: + +Stefan Reichoer : + +Matthieu Moy : +tla 1.2, tla 1.2.2rc2 + +Masatake YAMATO : +tla lord@emf.net--2004/dists--devo--1.0--patch-9(configs/emf.net-tla/devo.tla-1.2) from regexps.com + +Milan Zamazal : tla, from Debian/testing. + +Martin Pool : + +Robert Widhopf-Fenk : + +Mark Triggs : + + +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 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 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 + diff --git a/dvc/docs/TODO b/dvc/docs/TODO new file mode 100644 index 0000000..9a064c9 --- /dev/null +++ b/dvc/docs/TODO @@ -0,0 +1,285 @@ +-*- 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 -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. + diff --git a/dvc/docs/xmtn-readme.txt b/dvc/docs/xmtn-readme.txt new file mode 100644 index 0000000..3f51ab5 --- /dev/null +++ b/dvc/docs/xmtn-readme.txt @@ -0,0 +1,348 @@ +* 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 diff --git a/dvc/dvc-load-install.el.in b/dvc/dvc-load-install.el.in new file mode 100644 index 0000000..e78b50e --- /dev/null +++ b/dvc/dvc-load-install.el.in @@ -0,0 +1,24 @@ +; -*- 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))) + diff --git a/dvc/dvc-load.el.in b/dvc/dvc-load.el.in new file mode 100644 index 0000000..3bb2716 --- /dev/null +++ b/dvc/dvc-load.el.in @@ -0,0 +1,26 @@ +; -*- 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))) + diff --git a/dvc/install-sh b/dvc/install-sh new file mode 100644 index 0000000..e9de238 --- /dev/null +++ b/dvc/install-sh @@ -0,0 +1,251 @@ +#!/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 diff --git a/dvc/lisp/Makefile.in b/dvc/lisp/Makefile.in new file mode 100644 index 0000000..1c771ed --- /dev/null +++ b/dvc/lisp/Makefile.in @@ -0,0 +1,96 @@ +@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 + +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 diff --git a/dvc/lisp/baz-dvc.el b/dvc/lisp/baz-dvc.el new file mode 100644 index 0000000..b273015 --- /dev/null +++ b/dvc/lisp/baz-dvc.el @@ -0,0 +1,54 @@ +;;; baz-dvc.el --- The dvc layer for baz + +;; Copyright (C) 2005, 2007 by all contributors + +;; Author: Stefan Reichoer, +;; Contributors: Matthieu Moy, + +;; 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 diff --git a/dvc/lisp/baz.el b/dvc/lisp/baz.el new file mode 100644 index 0000000..294a4a1 --- /dev/null +++ b/dvc/lisp/baz.el @@ -0,0 +1,337 @@ +;;; baz.el --- baz related code for dvc + +;; Copyright (C) 2005-2007 Free Software Foundation, Inc. + +;; Author: Matthieu Moy +;; 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 diff --git a/dvc/lisp/bzr-core.el b/dvc/lisp/bzr-core.el new file mode 100644 index 0000000..93525c1 --- /dev/null +++ b/dvc/lisp/bzr-core.el @@ -0,0 +1,98 @@ +;;; bzr-core.el --- Core of support for Bazaar 2 in DVC + +;; Copyright (C) 2005-2008 by all contributors + +;; Author: Matthieu Moy +;; Contributions from: +;; Stefan Reichoer, + +;; 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 ""))) + :error (lambda (output error status arguments) + (setq tree-id ""))) + (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 diff --git a/dvc/lisp/bzr-dvc.el b/dvc/lisp/bzr-dvc.el new file mode 100644 index 0000000..a51d1f1 --- /dev/null +++ b/dvc/lisp/bzr-dvc.el @@ -0,0 +1,135 @@ +;;; bzr-dvc.el --- Support for Bazaar 2 in DVC's unification layer + +;; Copyright (C) 2005-2008 by all contributors + +;; Author: Matthieu Moy +;; Contributions from: +;; Stefan Reichoer, +;; 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 diff --git a/dvc/lisp/bzr-gnus.el b/dvc/lisp/bzr-gnus.el new file mode 100644 index 0000000..7ac038b --- /dev/null +++ b/dvc/lisp/bzr-gnus.el @@ -0,0 +1,158 @@ +;;; bzr-gnus.el --- bzr dvc integration to gnus + +;; Copyright (C) 2008 by all contributors + +;; Author: Stefan Reichoer + +;; 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 + + diff --git a/dvc/lisp/bzr-revision.el b/dvc/lisp/bzr-revision.el new file mode 100644 index 0000000..a35e3e2 --- /dev/null +++ b/dvc/lisp/bzr-revision.el @@ -0,0 +1,221 @@ +;;; bzr-revision.el --- Management of revision lists in bzr + +;; Copyright (C) 2006 - 2008 by all contributors + +;; Author: Matthieu Moy +;; Contributions from: +;; Stefan Reichoer, +;; 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 diff --git a/dvc/lisp/bzr-revlog.el b/dvc/lisp/bzr-revlog.el new file mode 100644 index 0000000..596d699 --- /dev/null +++ b/dvc/lisp/bzr-revlog.el @@ -0,0 +1,69 @@ +;;; bzr-revlog.el --- Show a log entry for a bzr branch + +;; Copyright (C) 2006 by all contributors + +;; Author: Matthieu Moy +;; 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 diff --git a/dvc/lisp/bzr-submit.el b/dvc/lisp/bzr-submit.el new file mode 100644 index 0000000..c1c611e --- /dev/null +++ b/dvc/lisp/bzr-submit.el @@ -0,0 +1,272 @@ +;;; bzr-submit.el --- Patch submission support for Bazaar 2 in DVC + +;; Copyright (C) 2006 by all contributors + +;; Author: Michael Olson + +;; 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 diff --git a/dvc/lisp/bzr.el b/dvc/lisp/bzr.el new file mode 100644 index 0000000..6b8c80e --- /dev/null +++ b/dvc/lisp/bzr.el @@ -0,0 +1,1349 @@ +;;; bzr.el --- Support for Bazaar 2 in DVC + +;; Copyright (C) 2005-2009 by all contributors + +;; Author: Matthieu Moy +;; Contributions from: +;; Stefan Reichoer, + +;; 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 'bzr-core) +(require 'dvc-diff) +(require 'dvc-core) +(require 'dvc-defs) +(require 'dvc-revlist) +(require 'dvc-annotate) +(eval-and-compile (require 'dvc-lisp)) + +(eval-when-compile (require 'cl)) + +(defvar bzr-default-init-repository-directory "~/" + "The default directory that is suggested when calling `bzr-init-repository'. +This setting is useful, if you'd like to create a bunch of repositories in +a common base directory.") + +(defvar bzr-command-version nil + "Version of bzr that we are using.") + +;;example: +;;(setq bzr-mail-notification-destination +;; '(("dvc-dev-bzr" ("[commit][dvc] " "dvc-dev@gna.org" "http://xsteve.nit.at/dvc/")))) +(defcustom bzr-mail-notification-destination nil + "*Preset some useful values for commit emails. + +An alist of rules to map branch names to target +email addresses and the prefix string for the subject line. + +This is used by the `bzr-send-commit-notification' function." + :type '(repeat (list :tag "Rule" + (string :tag "Bzr branch nick") + (list :tag "Target" + (string :tag "Email subject prefix") + (string :tag "Email address") + (string :tag "Bzr branch location")))) + :group 'dvc) + + +(defvar bzr-pull-done-hook '() + "*Hooks run after a bzr pull has finished. +Each hook function is called with these parameters: +repo-path: The pull source. +working-copy-dir: The working directory. +pulled-something: If something was pulled.") + +(defun bzr-init (&optional dir) + "Run bzr init." + (interactive + (list (expand-file-name (dvc-read-directory-name "Directory for bzr init: " + (or default-directory + (getenv "HOME")))))) + (dvc-run-dvc-sync 'bzr (list "init" dir) + :finished (dvc-capturing-lambda + (output error status arguments) + (message "bzr init %s finished" dir)))) + +(defun bzr-init-repository (&optional dir) + "Run bzr init-repository. +When called interactively, `bzr-default-init-repository-directory' is used as +starting point to enter the new repository directory. That directory is created +via bzr init-repository." + (interactive + (list (expand-file-name (dvc-read-directory-name + "Directory for bzr init-repository: " + (or + bzr-default-init-repository-directory + default-directory + (getenv "HOME")))))) + (dvc-run-dvc-sync 'bzr (list "init-repository" dir) + :finished (dvc-capturing-lambda + (output error status arguments) + (message "bzr init-repository '%s' finished" dir))) + dir) + +;;;###autoload +(defun bzr-checkout (branch-location to-location &optional lightweight revision) + "Run bzr checkout." + (interactive + (let* ((branch-loc (read-string "bzr checkout branch location: " nil nil bzr-default-init-repository-directory)) + (co-dir (or default-directory (getenv "HOME"))) + (to-loc (expand-file-name + (dvc-read-directory-name + "bzr checkout to: " + co-dir + (concat co-dir (file-name-nondirectory + (replace-regexp-in-string + "/trunk/?$" "" branch-loc)))))) + (lw (y-or-n-p "Do a lightweight checkout? ")) + (rev nil)) + (list branch-loc to-loc lw rev))) + (if current-prefix-arg + (setq revision (read-string "FromRevision: ")) + (setq revision nil)) + (dvc-run-dvc-sync 'bzr (list "checkout" + (when lightweight "--lightweight") + branch-location + to-location + (when revision "-r") + revision) + :finished (dvc-capturing-lambda + (output error status arguments) + (message "bzr checkout%s %s at rev %s -> %s finished" + (if lightweight " --lightweight" "") + branch-location revision to-location) + (dired to-location)))) + + +;;;###autoload +(defun bzr-pull (&optional repo-path) + "Run bzr pull." + (interactive "sPull from bzr repository: ") + (when (string= repo-path "") + (setq repo-path nil)) + (dvc-run-dvc-async 'bzr (list "pull" repo-path) + :finished + (dvc-capturing-lambda + (output error status arguments) + (dvc-revert-some-buffers) + (message "bzr pull finished => %s" + (concat (dvc-buffer-content error) (dvc-buffer-content output))) + (let ((pulled-something)) + (with-current-buffer output + (goto-char (point-min)) + (setq pulled-something (not (search-forward "No revisions to pull" nil t))) + (run-hook-with-args 'bzr-pull-done-hook (capture repo-path) (capture default-directory) pulled-something)))))) + +;;;###autoload +(defun bzr-push (&optional repo-path) + "Run bzr push. +When called with a prefix argument, add the --remember option" + (interactive (list (let ((push-branch (bzr-info-branchinfo "push"))) + (read-string (format "Push %sto bzr repository [%s]: " + (if current-prefix-arg "--remember " "") + push-branch) + )))) + (when (string= repo-path "") + (setq repo-path nil)) + (dvc-run-dvc-async 'bzr (list "push" repo-path (when current-prefix-arg "--remember")) + :finished + (dvc-capturing-lambda + (output error status arguments) + (message "bzr push finished => %s" + (concat (dvc-buffer-content error) (dvc-buffer-content output)))))) + +;;;###autoload +(defun bzr-merge (&optional repo-path) + "Run bzr merge." + (interactive "sMerge from bzr repository: ") + (when (string= repo-path "") + (setq repo-path nil)) + (dvc-run-dvc-async 'bzr (list "merge" repo-path) + :finished + (dvc-capturing-lambda + (output error status arguments) + (message "bzr merge finished => %s" + (concat (dvc-buffer-content error) (dvc-buffer-content output)))))) + +(defun bzr-merge-bundle (bundle-file) + "Run bzr merge from BUNDLE-FILE." + (interactive "sMerge bzr bundle: ") + (message "bzr-merge-bundle: %s (%s)" bundle-file default-directory) + (dvc-run-dvc-sync 'bzr (list "merge" bundle-file) + :finished + (dvc-capturing-lambda + (output error status arguments) + (message "bzr merge finished => %s" + (concat (dvc-buffer-content error) (dvc-buffer-content output)))))) + +(defvar bzr-merge-or-pull-from-url-rules nil + "An alist that maps repository urls to working copies. This rule is used by +`bzr-merge-from-url'. + +An example setting is: + (setq bzr-merge-from-url-rules '((\"http://bzr.xsteve.at/dvc/\" . (pull \"~/site-lisp/dvc/\")) + (\"http://www-verimag.imag.fr/~moy/bzr/dvc/moy/\" . (merge \"/home/stefan/work/myprg/dvc-dev-bzr/\")))) +") +(defun bzr-merge-or-pull-from-url (url) + "Merge or pull from a given url, autodetect the working directory via +`bzr-merge-or-pull-from-url-rules'." + (interactive "sMerge from url: ") + ;; (message "bzr-merge-or-pull-from-url %s" url) + (let* ((dest (cdr (assoc url bzr-merge-or-pull-from-url-rules))) + (merge-or-pull (car dest)) + (path (cadr dest)) + (doit t)) + (when (and merge-or-pull path) + (setq doit (y-or-n-p (format "%s from %s to %s? " (if (eq merge-or-pull 'merge) "Merge" "Pull") url path)))) + (when doit + (unless merge-or-pull + (setq merge-or-pull (cdr (assoc + (dvc-completing-read + (format "Merge or pull from %s: " url) + '("Merge" "Pull")) + '(("Merge" . merge) ("Pull" . pull)))))) + (unless path + (setq path (dvc-read-directory-name (format "%s from %s to: " (if (eq merge-or-pull 'merge) "Merge" "Pull") url)))) + (let ((default-directory path)) + (if (eq merge-or-pull 'merge) + (progn + (message "merging from %s to %s" url path) + (bzr-merge url)) + (message "pulling from %s to %s" url path) + (bzr-pull url)))))) + +;;;###autoload +(defun bzr-update (&optional path) + "Run bzr update." + (interactive) + (unless path + (setq path default-directory)) + (dvc-run-dvc-async 'bzr (list "update" path) + :finished + (dvc-capturing-lambda + (output error status arguments) + (message "bzr update finished => %s" + (concat (dvc-buffer-content error) (dvc-buffer-content output)))))) + + +;; bzr-start-project implements the following idea: +;; bzr init-repo repo +;; bzr init repo/trunk +;; bzr checkout --lightweight repo/trunk trunk-checkout +;; cd trunk-checkout +;; (add files here) +(defun bzr-start-project () + "Initializes a repository with a trunk branch and finally checks out a working copy. +The following functions are called: +`bzr-init-repository': create a shared repository +`bzr-init': create the trunk branch in the repository above +`bzr-checkout': check out the trunk branch to the entered working directory" + (interactive) + (let ((init-repo-dir) + (branch-repo-dir) + (checkout-dir)) + (setq init-repo-dir (call-interactively 'bzr-init-repository)) + (setq branch-repo-dir (dvc-uniquify-file-name (concat init-repo-dir "/trunk"))) + (bzr-init branch-repo-dir) + (setq checkout-dir (dvc-uniquify-file-name + (dvc-read-directory-name "checkout the branch to: " nil + (concat default-directory + (file-name-nondirectory init-repo-dir))))) + (bzr-checkout branch-repo-dir checkout-dir t))) + +(defun bzr-parse-diff (changes-buffer) + (dvc-trace "bzr-parse-diff") + (dvc-trace-current-line) + (save-excursion + (while (re-search-forward + "^=== \\([a-z]*\\) file '\\([^']*\\)'\\( => '\\([^']*\\)'\\)?$" nil t) + (let* ((origname (match-string-no-properties 2)) + (newname (or (match-string-no-properties 4) origname)) + (renamed (string= (match-string-no-properties 1) "renamed")) + (removed (string= (match-string-no-properties 1) "removed")) + (added (string= (match-string-no-properties 1) "added"))) + (with-current-buffer changes-buffer + (ewoc-enter-last + dvc-fileinfo-ewoc (make-dvc-fileinfo-file + :mark nil + :dir "" + :file newname + :status (cond + (added 'added) + (renamed 'rename-source) + (removed 'missing) + (t 'modified)) + :more-status (when (and renamed (not added)) + origname)))))))) + +(defun bzr-revisionspec-to-rev (string-revspec path) + "Converts a bzr revision specifier (string) into a DVC revision. + +TODO: just revision number and last:N are implemented. +" + `(bzr ,(cond ((string-match "^\\(revno:\\)?\\([0-9]+\\)$" + string-revspec) + `(revision (local ,path + ,(string-to-number + (match-string 2 string-revspec))))) + ((string-match "^\\(last:\\|-\\)\\([0-9]+\\)$" + string-revspec) + `(last-revision ,path + ,(string-to-number + (match-string 2 string-revspec)))) + (t (error "Not yet implemented, sorry!"))))) + +;;;###autoload +(defun bzr-diff-against (against &optional path dont-switch) + "Run \"bzr diff\" against a particular revision. + +Same as `bzr-dvc-diff', but the interactive prompt is different." + (interactive + (let ((root (bzr-tree-root))) + (list (bzr-revisionspec-to-rev + (read-string "Diff against revisionspec: ") + root) + root + current-prefix-arg))) + (bzr-diff against path dont-switch)) + +;;;###autoload +(defun bzr-dvc-diff (&optional against path dont-switch) + "Run \"bzr diff\". + +AGAINST must be a DVC revision id ('bzr number, last:N, +revid:foobar, ...). + +TODO: DONT-SWITCH is currently ignored." + (interactive (list nil nil current-prefix-arg)) + (let* ((dvc-temp-current-active-dvc 'bzr) + (window-conf (current-window-configuration)) + (dir (or path default-directory)) + (root (bzr-tree-root dir)) + (against (or against `(bzr (last-revision ,root 1)))) + (buffer (dvc-prepare-changes-buffer + against + `(bzr (local-tree ,root)) + 'diff root 'bzr))) + (dvc-switch-to-buffer-maybe buffer) + (dvc-buffer-push-previous-window-config window-conf) + (dvc-save-some-buffers root) + (dvc-run-dvc-async + 'bzr `("diff" ,@(when against + (list "--revision" + (bzr-revision-id-to-string + against)))) + :finished + (dvc-capturing-lambda (output error status arguments) + (dvc-diff-no-changes (capture buffer) + "No changes in %s" + (capture root))) + :error + (dvc-capturing-lambda (output error status arguments) + (if (/= 1 status) + (dvc-diff-error-in-process (capture buffer) + "Error in diff process" + output error) + (dvc-show-changes-buffer output 'bzr-parse-diff + (capture buffer))))))) + +;;;###autoload +(defun bzr-delta (base modified &optional dont-switch extra-arg) + "Run bzr diff -r BASE..MODIFIED. + +TODO: dont-switch is currently ignored." + (dvc-trace "bzr-delta: base=%S, modified=%S; dir=%S" base modified default-directory) + (let* ((base-str (if (stringp base) + base + (bzr-revision-id-to-string base))) + (modified-str (if (stringp modified) + modified + (bzr-revision-id-to-string modified))) + (extra-string (if extra-arg (format ", %s" extra-arg) "")) + (buffer (dvc-prepare-changes-buffer + base modified + 'revision-diff + (concat base-str + ".." + modified-str + extra-string) + 'bzr))) + (when dvc-switch-to-buffer-first + (dvc-switch-to-buffer buffer)) + (let ((default-directory + (cond ((and (consp modified) + (bzr-revision-id-is-local modified)) + (bzr-revision-id-location modified)) + ((and (consp base) + (bzr-revision-id-is-local base)) + (bzr-revision-id-location base)) + (t default-directory)))) + (dvc-run-dvc-async + 'bzr `("diff" + "--revision" ,(concat base-str ".." modified-str) + ,extra-arg) + :finished + (dvc-capturing-lambda (output error status arguments) + (dvc-diff-no-changes (capture buffer) + "No changes between %s" + (concat (capture base-str) " and " (capture modified-str)))) + :error + (dvc-capturing-lambda (output error status arguments) + (if (/= 1 status) + (dvc-diff-error-in-process (capture buffer) + "Error in diff process" + output error) + (dvc-show-changes-buffer output 'bzr-parse-diff + (capture buffer))))) + ;; We must return the buffer (even in asynchronous mode) + (with-current-buffer buffer (goto-char (point-min))) + buffer))) + +(defun bzr-revision-at-point-localp () + "Decide whether the revision at point is in the local tree. +This is done by looking at the 'You are missing ... revision(s):' string in the current buffer." + (save-excursion + (not (re-search-backward "^You are missing [0-9]+ revision(s):" nil t)))) + +(defun bzr-get-revision-at-point () + (int-to-string + (nth 2 (dvc-revlist-get-revision-at-point)))) + +;; FIXME: Does not attempt to find the right entry in +;; bzr-mail-notification-destination according to branch nick, and it +;; really ought to. +(defun bzr-send-commit-notification () + "Send a commit notification email for the changelog entry at point. + +`bzr-mail-notification-destination' can be used to specify a prefix for +the subject line, the rest of the subject line contains the summary line +of the commit. Additionally the destination email address can be specified." + (interactive) + (let* ((dest-specs (cadar bzr-mail-notification-destination)) ;;(tla--name-match-from-list + ;;(tla--name-split (tla-changelog-revision-at-point)) + ;;tla-mail-notification-destination)) + (rev (bzr-get-revision-at-point)) + (branch-location (nth 2 dest-specs)) + (log-message (bzr-revision-st-message (dvc-revlist-current-patch-struct))) + (summary (car (split-string log-message "\n")))) + (if (not (bzr-revision-at-point-localp)) + (message "Not a local revision: %s - no commit notification prepared." rev) + (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) "") + "rev " rev ": " summary))) + (message-goto-body) + (while (looking-at "<#part[^>]*>") + (forward-line 1)) + (insert (concat "Committed revision " rev + (if branch-location (concat " to " branch-location) "") + "\n\n")) + (insert log-message) + (unless (and (bolp) (looking-at "^$")) + (insert "\n")) + (message-goto-body)))) + + +(defun bzr-unknowns () + "Run bzr unknowns." + (interactive) + (dvc-run-dvc-display-as-info 'bzr '("unknowns"))) + +(defun bzr-parse-status (changes-buffer) + (dvc-trace "bzr-parse-status (while)") + (let (current-status) + (while (> (point-max) (point)) + (dvc-trace-current-line) + + ;; Typical output: + ;; + ;; modified: + ;; lisp/bzr.el + ;; lisp/dvc-diff.el + ;; lisp/dvc-fileinfo.el + ;; removed: + ;; lisp/deleted-file.el + ;; unknown: + ;; lisp/new-file.el + ;; conflicts: + ;; lisp/dvc-status.el + ;; pending merges: + ;; Stefan Reichoer 2007-11-05 Set dvc-bookmarks-show-partners to t per default + ;; Stefan Reichoer 2007-11-05 Implemented dvc-bookmarks-find-file-in-tree (... + ;; + ;; + ;; So we need to save the status from the message line, and + ;; apply it to following file lines. + + (cond ((looking-at "^\\([^ ][^\n]*:\\)") + ;; a file group message ('missing:' etc) + (let ((msg (match-string-no-properties 1))) + (with-current-buffer changes-buffer + (ewoc-enter-last dvc-fileinfo-ewoc + (make-dvc-fileinfo-message :text msg))) + (cond + ((string-equal msg "added:") + (setq current-status 'added)) + ((string-equal msg "conflicts:") + (setq current-status 'conflict)) + ((string-equal msg "modified:") + (setq current-status 'modified)) + ((string-equal msg "removed:") + (setq current-status 'missing)) + ((string-equal msg "unknown:") + (setq current-status 'unknown)) + ((string-equal msg "pending merges:") + (setq current-status nil)) + ((string-equal msg "pending merge tips:") + (setq current-status nil)) + ((string-equal msg "renamed:") + ;; Rename case is handled explictly below + (setq current-status nil)) + (t + (error "unrecognized label '%s' in bzr-parse-status" msg))))) + + ((looking-at "^ +\\([^ ][^\n]*?\\)\\([/@]\\)? => \\([^\n]*?\\)\\([/@]\\)?$") + ;; a renamed file + (let ((oldname (match-string-no-properties 1)) + (dir (match-string-no-properties 2)) + (newname (match-string-no-properties 3))) + (with-current-buffer changes-buffer + (ewoc-enter-last dvc-fileinfo-ewoc + (make-dvc-fileinfo-file + :mark nil + :dir dir + :file newname + :status 'rename-target + :more-status oldname)) + (ewoc-enter-last dvc-fileinfo-ewoc + (make-dvc-fileinfo-file + :mark nil + :dir dir + :file oldname + :status 'rename-source + :more-status newname))))) + + ((looking-at " +\\(?:Text conflict in \\)?\\([^\n]*?\\)\\([/@*]\\)?$") + ;; A typical file in a file group, or a pending merge message + (if (not current-status) + (let ((msg (buffer-substring-no-properties + (line-beginning-position) (line-end-position)))) + (with-current-buffer changes-buffer + (ewoc-enter-last dvc-fileinfo-ewoc + (make-dvc-fileinfo-message + :text msg)))) + (let ((file (match-string-no-properties 2)) + (dir (match-string-no-properties 1))) + (with-current-buffer changes-buffer + (ewoc-enter-last dvc-fileinfo-ewoc + (make-dvc-fileinfo-file + :mark nil + :dir dir + :file file + :status current-status + :more-status "")))))) + + (t (error "unrecognized context in bzr-parse-status"))) + (forward-line 1)))) + +(defun bzr-dvc-status () + "Run \"bzr status\" in `default-directory', which must be a tree root." + (let* ((window-conf (current-window-configuration)) + (root default-directory) + (buffer (dvc-prepare-changes-buffer + `(bzr (last-revision ,root 1)) + `(bzr (local-tree ,root)) + 'status root 'bzr))) + (dvc-switch-to-buffer-maybe buffer) + (dvc-buffer-push-previous-window-config window-conf) + (setq dvc-buffer-refresh-function 'bzr-dvc-status) + (dvc-run-dvc-async + 'bzr '("status") + :finished + (dvc-capturing-lambda (output error status arguments) + (with-current-buffer (capture buffer) + (if (> (point-max) (point-min)) + (dvc-show-changes-buffer output 'bzr-parse-status + (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)))))) + +(defun bzr-parse-inventory (changes-buffer) + ;;(dvc-trace "bzr-parse-inventory (while)") + (while (> (point-max) (point)) + ;;(dvc-trace-current-line) + (cond + ((looking-at "\\([^\n]*?\\)\\([/@]\\)?$") + (let ((file (match-string-no-properties 1)) + (dir (match-string-no-properties 2))) + (with-current-buffer changes-buffer + (ewoc-enter-last + dvc-fileinfo-ewoc (make-dvc-fileinfo-file + :mark nil + :dir dir + :file file + :status 'known + :more-status ""))))) + (t (error "unrecognized context in bzr-parse-inventory"))) + (forward-line 1))) + +;;;###autoload +(defun bzr-inventory () + "Run \"bzr inventory\"." + (interactive) + (let* ((dir default-directory) + (root (bzr-tree-root dir)) + (buffer (dvc-prepare-changes-buffer + `(bzr (last-revision ,root 1)) + `(bzr (local-tree ,root)) + 'inventory root 'bzr))) + (dvc-switch-to-buffer-maybe buffer) + (setq dvc-buffer-refresh-function 'bzr-inventory) + (dvc-save-some-buffers root) + (dvc-run-dvc-async + 'bzr '("inventory") + :finished + (dvc-capturing-lambda (output error status arguments) + (with-current-buffer (capture buffer) + (dvc-show-changes-buffer output 'bzr-parse-inventory + (capture buffer))) + :error + (dvc-capturing-lambda (output error status arguments) + (dvc-diff-error-in-process (capture buffer) + "Error in inventory process" + output error)))))) + +;;;###autoload +(defun bzr-add (file) + "Adds FILE to the repository." + (interactive "fAdd file or directory: ") + (message "%s" + (let ((default-directory (bzr-tree-root))) + (dvc-run-dvc-sync + 'bzr (list "add" (file-relative-name file)) + :finished 'dvc-output-and-error-buffer-handler)))) + +;;;###autoload +(defun bzr-dvc-add-files (&rest files) + "Run bzr add." + (dvc-trace "bzr-add-files: %s" files) + (let ((default-directory (bzr-tree-root))) + (dvc-run-dvc-sync 'bzr (append '("add" "--no-recurse") (mapcar #'file-relative-name + files)) + :finished (dvc-capturing-lambda + (output error status arguments) + (message "bzr add finished"))))) + +;;;###autoload +(defun bzr-dvc-revert-files (&rest files) + "Run bzr revert." + (dvc-trace "bzr-revert-files: %s" files) + (let ((default-directory (bzr-tree-root))) + (dvc-run-dvc-sync 'bzr (append '("revert") (mapcar #'file-relative-name files)) + :finished (dvc-capturing-lambda + (output error status arguments) + (dvc-revert-some-buffers default-directory) + (message "bzr revert finished"))))) + +;;;###autoload +(defun bzr-dvc-remove-files (&rest files) + "Run bzr remove." + (dvc-trace "bzr-remove-files: %s" files) + (dvc-run-dvc-sync 'bzr (append '("remove") files) + :finished (dvc-capturing-lambda + (output error status arguments) + (message "bzr remove finished")))) + +;;;###autoload +(defun bzr-dvc-rename (from to &optional after) + "Run bzr rename." + (interactive + (let* ((from-name (dvc-confirm-read-file-name "bzr rename: ")) + (to-name (dvc-confirm-read-file-name (concat "bzr rename '" from-name "' to: ") nil "" from-name))) + (list from-name to-name nil))) + (dvc-run-dvc-sync 'bzr (list "rename" (dvc-uniquify-file-name from) (dvc-uniquify-file-name to) + (when after "--after")) + :finished (dvc-capturing-lambda + (output error status arguments) + (message "bzr rename finished")))) + +(defun bzr-is-bound (&optional path) + "True if branch containing PATH is bound" + (file-exists-p (concat (file-name-as-directory + (bzr-tree-root + (or path default-directory))) + ".bzr/branch/bound"))) + +(defun bzr-log-edit-commit-local () + "Local commit" + (interactive) + (bzr-log-edit-commit t)) + +(defun bzr-log-edit-commit (&optional local) + "Commit without --local by default. + +If LOCAL (prefix argument) is non-nil, commit with --local. +\(don't update bound branch). + +LOCAL is ignored on non-bound branches." + (interactive "P") + (let ((buffer (find-file-noselect (dvc-log-edit-file-name)))) + (dvc-log-flush-commit-file-list) + (save-buffer buffer) + (let ((default-directory (dvc-uniquify-file-name default-directory))) + (dvc-run-dvc-async + 'bzr + (append + (list "commit" "--verbose" "--file" (dvc-log-edit-file-name) + (when (and local (bzr-is-bound)) + "--local")) + ;; Get marked files to do a selected file commit. Nil + ;; otherwise (which means commit all files). + (when (buffer-live-p dvc-partner-buffer) + (with-current-buffer dvc-partner-buffer + (mapcar #'dvc-uniquify-file-name + (dvc-current-file-list 'nil-if-none-marked))))) + :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)) + (dvc-diff-clear-buffers + 'bzr + (capture default-directory) + "* Just committed! Please refresh buffer\n") + (message "Bzr commit finished !")))) + (dvc-tips-popup-maybe))) + +(defcustom bzr-work-offline 'prompt + "*Whether bzr commit should use --local for bound branches by default. + +Possible values are: +t: work offline (use --local systematialy) +nil: work online (don't use --local) +'prompt: prompt when needed." + :type '(choice (const t) + (const nil) + (const prompt)) + :group 'dvc) + +(defun bzr-inform-offline-status () + "Informs the user about the offline status of bzr." + (interactive) + (message "DVC-bzr will now %s. +Use M-x bzr-change-offline-status RET to change." + (cond ((eq bzr-work-offline t) + "work offline (use commit --local)") + ((eq bzr-work-offline nil) + "work online (don't provide --local to commit)") + ((eq bzr-work-offline 'prompt) + "prompt to use --local or not")))) + +(defun bzr-change-offline-status () + "Change the offline status of DVC-bzr. + +Prompt the user and change `bzr-work-offline' accordingly." + (interactive) + (discard-input) + (save-window-excursion + (let (answer commit-locally) + (while (null answer) + (message "Change offline status to ([C]onnected, [D]isconnected, [P]rompt)): ") + (let ((tem (downcase (let ((cursor-in-echo-area t)) + (read-char-exclusive))))) + (setq answer + (if (= tem help-char) + 'help + (cdr (assoc tem '((?c . connect) + (?d . t) + (?p . prompt)))))) + (cond ((null answer) + (beep) + (message "Please type c, p or d") + (sit-for 3)) + ((eq answer 'connect) + (setq bzr-work-offline nil)) + (t + (setq bzr-work-offline answer))) + (bzr-inform-offline-status)))))) + + +(defun bzr-ask-user-about-offline () + "Return non-nil if bzr should work offline." + (cond ((eq bzr-work-offline t) + t) + ((eq bzr-work-offline nil) + nil) + (t + (discard-input) + (save-window-excursion + (let (answer commit-locally) + (while (null answer) + (message "Commit locally only? (y, n, c, d) ") + (let ((tem (downcase (let ((cursor-in-echo-area t)) + (read-char-exclusive))))) + (setq answer + (if (= tem help-char) + 'help + (cdr (assoc tem '((?y . yes) + (?n . no) + (?c . connect) + (?d . disconnect) + (?? . help)))))) + (cond ((null answer) + (beep) + (message "Please type y, n or r; or ? for help") + (sit-for 3)) + ((eq answer 'help) + (message "Yes (commit locally), No (commit remotely too), +Connect (commit remotely from now), Disconnect (commit locally from now)") + (sit-for 5) + (setq answer nil)) + ((eq answer 'yes) + (setq commit-locally t)) + ((eq answer 'no) + (setq commit-locally nil)) + ((eq answer 'connect) + (setq bzr-work-offline nil + commit-locally nil) + (bzr-inform-offline-status)) + ((eq answer 'disconnect) + (setq bzr-work-offline t + commit-locally t) + (bzr-inform-offline-status))))) + commit-locally))))) + +(defun bzr-log-edit-done () + "Commit. Interactive prompt to know whether this should be local. + +See `bzr-log-edit-commit' and `bzr-log-edit-commit-local' for +non-interactive versions." + (interactive) + (bzr-log-edit-commit (and (bzr-is-bound) + (bzr-ask-user-about-offline)))) + + +(eval-when-compile + (defvar smerge-mode)) + +;;;###autoload +(defun bzr-resolved (file) + "Command to delete .rej file after conflicts resolution. +Asks confirmation if the file still has diff3 markers. +Then, run \"bzr resolve\". + +TODO: should share some code with `tla-resolved'." + (interactive + (list (let ((file (buffer-file-name))) + (if (string-match "^\\(.*\\)\\.\\(BASE\\|OTHER\\|THIS\\)$" file) + (let ((norej (match-string 1 file))) + (if (and (file-exists-p norej) + (y-or-n-p (format "Use file %s instead of %s? " + (file-name-nondirectory norej) + (file-name-nondirectory file)))) + norej + file)) + file)))) + (with-current-buffer (find-file-noselect file) + (if (and (boundp 'smerge-mode) smerge-mode) + (progn + (when (and + (save-excursion + (goto-char (point-min)) + (dvc-funcall-if-exists smerge-find-conflict)) + (not (y-or-n-p (concat "Buffer still has diff3 markers. " + "Mark as resolved anyway? ")))) + (error "Not marking file as resolved")) + (dvc-funcall-if-exists smerge-mode -1))) + (dolist (ext '("BASE" "OTHER" "THIS")) + (let ((buf (find-buffer-visiting (concat file ext)))) + (when buf (kill-buffer buf)))) + (dvc-run-dvc-sync 'bzr + `("resolved" + ,file) + :finished 'dvc-null-handler))) + +(defun bzr-file-has-conflict-p (file-name) + "Return non-nil if FILE-NAME has conflicts. + +In practice, check for the existance of \"FILE.BASE\"." + (let ((rej-file-name (concat default-directory + (file-name-nondirectory file-name) + ".BASE"))) + (file-exists-p rej-file-name))) + + +;; Revisions + +(defun bzr-revision-id-location (rev-id) + "Extract the location component from REV-ID." + (case (dvc-revision-get-type rev-id) + ((revision previous-revision) + (let* ((data (car (dvc-revision-get-data rev-id))) + (location (nth 1 data))) + location)) + (otherwise nil))) + +(defun bzr-revision-id-is-local (rev-id) + "Non-nil if rev-id has the same path as the local tree." + (case (dvc-revision-get-type rev-id) + ((revision previous-revision) + (let ((data (car (dvc-revision-get-data rev-id)))) + (eq (nth 0 data) 'local))) + (otherwise nil))) + +(defun bzr-revision-nth-ancestor (rev-id n) + "Get the N-th ancestor of REV-ID." + (case (dvc-revision-get-type rev-id) + ((revision previous-revision) + (let ((data (car (dvc-revision-get-data rev-id)))) + `(bzr (revision (,(nth 0 data) + ,(nth 1 data) + ,(- (nth 2 data) n)))))) + (otherwise (error "TODO: not implemented. REV-ID=%S" rev-id)))) + +(defun bzr-revision-id-to-string (rev-id) + "Turn a DVC revision ID to a bzr revision spec. + +\(bzr (revision (local \"/path/to/archive\" 3))) +=> \"revno:3\". +" + (case (dvc-revision-get-type rev-id) + (revision (let* ((data (car (dvc-revision-get-data rev-id))) + (location (nth 0 data))) + (cond ((eq location 'local) + (concat "revno:" (int-to-string (nth 2 data)))) + ((eq location 'remote) + (concat "revno:" (int-to-string (nth 2 data)) + ":" (nth 1 data)))))) + (previous-revision + (bzr-revision-id-to-string + (let* ((previous-list (nth 1 rev-id)) + (rev `(bzr ,(nth 1 previous-list))) + (n-prev (nth 2 previous-list))) + (bzr-revision-nth-ancestor rev n-prev)))) + (last-revision + (let* ((data (dvc-revision-get-data rev-id)) + (num (nth 1 data))) + (concat "last:" (int-to-string num)))) + (tag + (car (dvc-revision-get-data rev-id))) + (otherwise (error "TODO: not implemented: %S" rev-id)))) + + +(defun bzr-revision-get-file-revision (file revision) + "Insert the content of FILE in REVISION, in current buffer. + +REVISION is a back-end-revision, not a dvc revision-id. It looks like +\(local \"path\" NUM)." + (let ((bzr-rev + (if (eq (car (car revision)) 'local) + (int-to-string (nth 2 (car revision))) + (error "TODO: revision=%S" revision))) + (path (if (eq (car (car revision)) 'local) + (nth 1 (car revision)) + default-directory))) + (let ((default-directory path)) + (insert + (dvc-run-dvc-sync + ;; TODO what if I'm not at the tree root ? + 'bzr (list "cat" "--revision" bzr-rev file) + :finished 'dvc-output-buffer-handler-withnewline))))) + +;;;###autoload +(defun bzr-revision-get-last-revision (file last-revision) + "Insert the content of FILE in LAST-REVISION, in current buffer. + +LAST-REVISION looks like +\(\"root\" NUM) +" + (let ((bzr-rev (concat "last:" (int-to-string + (nth 1 last-revision)))) + (default-directory (car last-revision))) + (insert + (dvc-run-dvc-sync + 'bzr (list "cat" "--revision" bzr-rev file) + :finished 'dvc-output-buffer-handler-withnewline)))) + +;;;###autoload +(defun bzr-command-version () + "Run bzr version." + (interactive) + (setq bzr-command-version + (dvc-run-dvc-sync + 'bzr (list "version") + :finished (lambda (output error status arguments) + (set-buffer output) + (goto-char (point-min)) + (buffer-substring (point) (point-at-eol))))) + (when (interactive-p) + (message "Bazaar-NG Version: %s" bzr-command-version)) + bzr-command-version) + +(defun bzr-whoami () + "Run bzr whoami." + (interactive) + (let ((whoami (dvc-run-dvc-sync 'bzr (list "whoami") + :finished 'dvc-output-buffer-handler))) + (when (interactive-p) + (message "bzr whoami: %s" whoami)) + whoami)) + +(defun bzr-save-diff (filename) + "Save the current bzr diff to a file named FILENAME." + (interactive (list (read-file-name "Save the bzr diff to: "))) + (with-current-buffer + (find-file-noselect filename) + (let ((inhibit-read-only t)) + (erase-buffer) + (insert (dvc-run-dvc-sync 'bzr (list "diff") + ;; bzr diff has a non-zero status + :error 'dvc-output-and-error-buffer-handler)) + (save-buffer) + (kill-buffer (current-buffer))))) + +(defun bzr-nick (&optional new-nick) + "Run bzr nick. +When called with a prefix argument, ask for the new nick-name, otherwise +display the current one." + (interactive "P") + (let ((nick (dvc-run-dvc-sync 'bzr (list "nick") + :finished 'dvc-output-buffer-handler))) + (if (not new-nick) + (progn + (when (interactive-p) + (message "bzr nick: %s" nick)) + nick) + (when (interactive-p) + (setq new-nick (read-string (format "Change nick from '%s' to: " nick) nil nil nick))) + (dvc-run-dvc-sync 'bzr (list "nick" new-nick))))) + +;;;###autoload +(defun bzr-info () + "Run bzr info." + (interactive) + (dvc-run-dvc-display-as-info 'bzr '("info"))) + +(defun bzr-parse-info-key (kname) + "Parse the output of bzr info buffer and return value kname" + (progn + (re-search-forward (concat"\\s-+ " kname " branch: \\([^\n]*\\)?$") nil 't) + (match-string-no-properties 1))) + +(defun bzr-info-branchinfo (kname) + (dvc-run-dvc-sync 'bzr (list "info") + :finished + (dvc-capturing-lambda (output error status arguments) + (with-current-buffer output + (goto-char (point-min)) + (bzr-parse-info-key kname))))) + +(defun bzr-testament () + "Run bzr testament." + (interactive) + (dvc-run-dvc-display-as-info 'bzr '("testament"))) + +(defun bzr-plugins () + "Run bzr plugins." + (interactive) + (dvc-run-dvc-display-as-info 'bzr '("plugins"))) + +(defun bzr-check () + "Run bzr check." + (interactive) + (dvc-run-dvc-display-as-info 'bzr '("check") t)) + +(defun bzr-ignored () + "Run bzr ignored." + (interactive) + (dvc-run-dvc-display-as-info 'bzr '("ignored"))) + +(defun bzr-conflicts () + "Run bzr conflicts." + (interactive) + (dvc-run-dvc-display-as-info 'bzr '("conflicts"))) + +(defun bzr-deleted () + "Run bzr deleted." + (interactive) + (dvc-run-dvc-display-as-info 'bzr '("deleted"))) + +(defun bzr-renames () + "Run bzr renames." + (interactive) + (dvc-run-dvc-display-as-info 'bzr '("renames"))) + +(defun bzr-version-info () + "Run bzr verision-info." + (interactive) + (if (interactive-p) + (dvc-run-dvc-display-as-info 'bzr '("version-info")) + (dvc-run-dvc-sync 'bzr (list "version-info") + :finished 'dvc-output-buffer-handler))) + +(defun bzr-upgrade () + "Run bzr upgrade." + (interactive) + (let ((default-directory (dvc-tree-root))) + (dvc-run-dvc-display-as-info 'bzr '("upgrade") t))) + +(defun bzr-ignore (pattern) + "Run bzr ignore PATTERN." + (interactive "sbzr ignore: ") + (dvc-run-dvc-sync 'bzr (list "ignore" pattern))) + +(defun bzr-uncommit () + "Run bzr uncommit. +Ask the user before uncommitting." + (interactive) + (let ((window-conf (current-window-configuration))) + (dvc-run-dvc-display-as-info 'bzr (list "uncommit" "--dry-run" "--force")) + (if (yes-or-no-p "Remove the bzr revision? ") + (progn + (message "Removing bzr revision") + (set-window-configuration window-conf) + (dvc-run-dvc-sync 'bzr (list "uncommit" "--force"))) + (message "Aborted bzr uncommit") + (set-window-configuration window-conf)))) + +(defun bzr-config-directory () + "Path of the configuration directory for bzr." + (file-name-as-directory + (if (eq system-type 'windows-nt) + (expand-file-name "bazaar/2.0" (getenv "APPDATA")) + (expand-file-name "~/.bazaar")))) + +(defun bzr-config-file (file) + "Path of configuration file FILE for bzr. + +File can be, i.e. bazaar.conf, ignore, locations.conf, ..." + (concat (bzr-config-directory) file)) + +(defvar bzr-ignore-list ".tmp-bzr*\n" + "List of newline-terminated ignore patterns that DVC should add to + ~/.bazaar/ignore.") + +(defun bzr-ignore-setup () + "Sets up a default ignore list for DVC in ~/.bazaar/ignore" + (interactive) + (let* ((file (bzr-config-file "ignore")) + (buffer (or (when (file-exists-p file) + (find-file-noselect file)) + ;; let bzr create the file. + (let* ((dir (dvc-make-temp-dir "dvc-bzr-ignore")) + (default-directory dir)) + (dvc-run-dvc-sync 'bzr (list "init") + :finished 'dvc-null-handler) + (with-current-buffer (find-file-noselect + (expand-file-name "foo")) + (insert "foo") + (save-buffer)) + (dvc-run-dvc-sync 'bzr (list "ignored") + :finished 'dvc-null-handler) + (dvc-delete-recursively dir) + (if (file-exists-p file) + (find-file-noselect file) + (message "WARNING: Could not find or create bzr user-wide ignore file.") + nil)))) + (ins t)) + (when buffer + (with-current-buffer buffer + (goto-char (point-min)) + (if (re-search-forward "^# DVC ignore (don't edit !!)\n\\(\\(.\\|\n\\)*\n\\)# end DVC ignore$" nil 'end) + (progn + (if (string= bzr-ignore-list (match-string 1)) + (setq ins nil) + (message "Overriding old DVC ignore list for bzr") + (delete-region (match-beginning 0) (match-end 0)))) + (message "Setting up DVC ignore list for bzr")) + (when ins + (insert "# DVC ignore (don't edit !!)\n") + (insert bzr-ignore-list) + (insert "# end DVC ignore\n") + (save-buffer))) + (kill-buffer buffer)))) + +(defun bzr-do-annotate (file) + "Annote the FILE" + (let* ((file (expand-file-name file)) + (abuffer (dvc-get-buffer-create 'bzr 'annotate)) + (args (list "annotate" "--all" "--long" file))) + (dvc-switch-to-buffer-maybe abuffer) + (dvc-run-dvc-sync 'bzr args + :finished + (dvc-capturing-lambda (output error status arguments) + (progn + (with-current-buffer (capture abuffer) + (let ((inhibit-read-only t)) + (erase-buffer) + (setq truncate-lines t) + (insert-buffer-substring output) + (goto-char (point-min)) + (bzr-annotate-mode)))))))) + +(defun bzr-annotate () + "Run bzr annotate" + (interactive) + (let* ((line (dvc-line-number-at-pos)) + (filename (dvc-confirm-read-file-name "Filename to annotate: "))) + (bzr-do-annotate filename) + (goto-line line))) + +(defconst bzr-annon-parse-re + "^\\(\\S-*\\)\\s-+\\(\\S-*\\)\\s-+\\([0-9]\\{4\\}\\)\\([0-9]\\{2\\}\\)\\([0-9]\\{2\\}\\)\\s-+|") + +(defun bzr-annotate-time () + (interactive) + (when (< (point) (point-max)) + (beginning-of-line) + (if (re-search-forward bzr-annon-parse-re nil t) + (let* ((year (string-to-number (match-string 3))) + (month (string-to-number (match-string 4))) + (day (string-to-number (match-string 5))) + (ct (dvc-annotate-convert-time + (encode-time 1 1 1 day month year)))) + ct)))) + +(define-derived-mode bzr-annotate-mode fundamental-mode "bzr-annotate" + "Major mode to display bzr annotate output." + (dvc-annotate-display-autoscale t) + (dvc-annotate-lines (point-max)) + ;;(xgit-annotate-hide-revinfo) + (toggle-read-only 1)) + +(defun bzr-switch-checkout (target) + "Switch the checkout to the branch TARGET" + (interactive "sURL of the branch to switch to: ") + (dvc-run-dvc-sync 'bzr (list "switch" target) + :finished 'dvc-output-buffer-handler) + (dvc-revert-some-buffers) + (dvc-trace "Switched checkout to %s" target) + ) + +(defun bzr-switch-checkout-l (target) + "Switch the checkout to a local branch" + (interactive "DBranch to switch to: ") + (let ((target (expand-file-name target))) + (bzr-switch-checkout target)) + ) + +(defun bzr-goto-checkout-root () + "Find the directory containing the checkout source branch" + (interactive) + (find-file (bzr-info-branchinfo "checkout of"))) + + +(defun bzr-create-bundle (rev file-name &optional extra-parameter-list) + "Call bzr send --output to create a file containing a bundle" + (interactive (list (bzr-read-revision "Create bundle for revision: ") + (read-file-name "Name of the bzr bundle file: ") + (split-string (read-string "Extra parameters: ")))) + (let ((arg-list (list "send" "-o" (expand-file-name file-name) "-r" rev))) + (when extra-parameter-list + (setq arg-list (append arg-list extra-parameter-list))) + (dvc-run-dvc-sync 'bzr arg-list + :finished + (lambda (output error status arguments) + (message "Created bundle for revision %s in %s." rev file-name))))) + +;;; FIXME: this should probably be a defcustom +;;;###autoload +(defvar bzr-export-via-email-parameters nil + "list of (PATH (EMAIL BRANCH-NICK (EXTRA-ARG ...)))") +;;(add-to-list 'bzr-export-via-email-parameters '("~/work/myprg/dvc" ("joe@host.com" "dvc-el"))) +;; or: +;;(add-to-list 'bzr-export-via-email-parameters +;; '("~/work/myprg/dvc" ("joe@host.com" "dvc-el" ("--no-bundle" "." "../dvc-bundle-base")))) + +(defun bzr-export-via-email () + "Export the revision at point via email. +`bzr-export-via-email-parameters' can be used to customize the behaviour of +this function." + (interactive) + + (require 'message) + (require 'mml) + + (let* ((rev (bzr-get-revision-at-point)) + (log-message (bzr-revision-st-message (dvc-revlist-current-patch-struct))) + (base-file-name nil) + (summary (car (split-string log-message "\n"))) + (file-name nil) + (description nil) + (destination-email "") + (extra-parameter-list nil)) + (dolist (m bzr-export-via-email-parameters) + (when (string= (dvc-uniquify-file-name (car m)) (dvc-uniquify-file-name (bzr-tree-root))) + ;;(message "%S" (cadr m)) + (setq destination-email (car (cadr m))) + (setq base-file-name (nth 1 (cadr m))) + (setq extra-parameter-list (nth 2 (cadr m))))) + (message "bzr-export-via-email %s: %s to %s" rev summary destination-email) + (setq file-name (concat (dvc-uniquify-file-name dvc-temp-directory) + (or base-file-name "") rev ".patch")) + (bzr-create-bundle rev file-name extra-parameter-list) + + (setq description + (dvc-run-dvc-sync 'bzr (list "log" "-r" rev) + :finished 'dvc-output-buffer-handler)) + + (require 'reporter) + (delete-other-windows) + (reporter-submit-bug-report + destination-email + nil + nil + nil + nil + description) + + ;; we need MML converted to MIME or the attachment isn't attached! + (when (eq mail-user-agent 'sendmail-user-agent) + (add-hook 'mail-send-hook 'mml-to-mime nil t)) + + ;; delete emacs version - its not needed here + (delete-region (point) (point-max)) + + (mml-attach-file file-name "text/x-patch") + (goto-char (point-min)) + (mail-position-on-field "Subject") + ;; Bundle Buggy, and possibly other tools, require [MERGE] in the + ;; subject line in order to detect Bzr merge requests. + (insert (concat "[MERGE] " summary)))) + +;; provide 'bzr before running bzr-ignore-setup, because bzr-ignore-setup +;; loads a file and this triggers the loading of bzr. +(provide 'bzr) + +;; Must remain toplevel, and should not be autoloaded. +(when (executable-find bzr-executable) + (bzr-ignore-setup)) + +;;; bzr.el ends here diff --git a/dvc/lisp/contrib/elunit.el b/dvc/lisp/contrib/elunit.el new file mode 100644 index 0000000..b8498fc --- /dev/null +++ b/dvc/lisp/contrib/elunit.el @@ -0,0 +1,167 @@ +;;; 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 diff --git a/dvc/lisp/contrib/ewoc.el b/dvc/lisp/contrib/ewoc.el new file mode 100644 index 0000000..555dd05 --- /dev/null +++ b/dvc/lisp/contrib/ewoc.el @@ -0,0 +1,609 @@ +;;; 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 +;; Inge Wallin +;; 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 diff --git a/dvc/lisp/dvc-about.el b/dvc/lisp/dvc-about.el new file mode 100644 index 0000000..00b5e25 --- /dev/null +++ b/dvc/lisp/dvc-about.el @@ -0,0 +1,165 @@ +;;; 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 , " +;; "Contributions from: " +;; "Matthieu Moy , " +;; "Masatake YAMATO , " +;; "Milan Zamazal , " +;; "Martin Pool , " +;; "Robert Widhopf-Fenk , " +;; "Mark Triggs ")) +;; (dvc-about-message-with-rolling +;; (concat "Author: Stefan Reichoer , " +;; "Contributions from: " +;; "Matthieu Moy , " +;; "Masatake YAMATO , " +;; "Milan Zamazal , " +;; "Martin Pool , " +;; "Robert Widhopf-Fenk , " +;; "Mark Triggs ")) +(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 " : " + (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 , " + "Contributions from: " + "Matthieu Moy , " + "Masatake YAMATO , " + "Milan Zamazal , " + "Martin Pool , " + "Robert Widhopf-Fenk , " + "Mark Triggs " + "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 diff --git a/dvc/lisp/dvc-annotate.el b/dvc/lisp/dvc-annotate.el new file mode 100644 index 0000000..dd05152 --- /dev/null +++ b/dvc/lisp/dvc-annotate.el @@ -0,0 +1,279 @@ +;; 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 +;; 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 +;; . Over the years, many people have +;; contributed substantial amounts of work to VC. These include: +;; Per Cederqvist +;; Paul Eggert +;; Sebastian Kremer +;; Martin Lorentzson +;; Dave Love +;; Stefan Monnier +;; J.D. Smith +;; Andre Spiegel +;; Richard Stallman +;; Thien-Thi Nguyen + + +;; Changes made to vc.el by Takuzo O'hara, +;; +;; -. 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) diff --git a/dvc/lisp/dvc-be.el b/dvc/lisp/dvc-be.el new file mode 100644 index 0000000..cc28985 --- /dev/null +++ b/dvc/lisp/dvc-be.el @@ -0,0 +1,70 @@ +;;; dvc-be.el --- dvc integration for bugs everywhere + +;; Copyright (C) 2006 by all contributors + +;; Author: Stefan Reichoer, + +;; 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 diff --git a/dvc/lisp/dvc-bookmarks.el b/dvc/lisp/dvc-bookmarks.el new file mode 100644 index 0000000..ed67116 --- /dev/null +++ b/dvc/lisp/dvc-bookmarks.el @@ -0,0 +1,1591 @@ +;;; dvc-bookmarks.el --- The bookmark system for DVC + +;; Copyright (C) 2006-2008 by all contributors + +;; Authors: Stefan Reichoer, +;; Thierry Volpiatto + +;; 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 a hierachical bookmark system for DVC + +;;; Commands: +;; +;; Below is a complete command list: +;; +;; `dvc-cur-date-string' +;; Return current date under string form ==>2008.03.16 +;; `dvc-bookmarks-set-tree-properties' +;; color value is one of the dvc-faces ==> dvc-buffer, dvc-nested-tree, etc... +;; `dvc-bookmarks-toggle-time-stamp' +;; Toggle show/don't show time-stamp +;; `dvc-bookmarks-toggle-partner-url' +;; Toggle show/don't show partners urls +;; `dvc-bookmarks' +;; Display the *dvc-bookmarks* buffer. +;; `dvc-bookmarks-mode' +;; Mode to display DVC bookmarks. +;; `dvc-bookmarks-quit' +;; Clean dvc-bookmarks-hidden-subtree +;; `dvc-bookmarks-add' +;; Add a DVC bookmark named BOOKMARK-NAME, directory BOOKMARK-LOCAL-DIR. +;; `dvc-bookmarks-dired-add-project' +;; Add a DVC bookmark from dired +;; `dvc-bookmarks-edit' +;; Change the current DVC bookmark's BOOKMARK-NAME and/or LOCAL-DIR. +;; `dvc-bookmarks-status' +;; Run `dvc-status' for bookmark at point. +;; `dvc-bookmarks-diff' +;; Run `dvc-diff' for bookmark at point. +;; `dvc-bookmarks-pull' +;; Pull from partner at point or default into current bookmark. +;; `dvc-bookmarks-merge' +;; Merge from partner at point into current bookmark. +;; `dvc-bookmarks-yank' +;; Choose to yank marked or at point +;; `dvc-bookmarks-yank-from-list-to-sub' +;; Yank from list ==> sublist +;; `dvc-bookmarks-yank-from-sub-to-list' +;; Yank from sublist ==> list +;; `dvc-bookmarks-yank-from-sub-to-sub' +;; Yank from one sublist to another sublist, +;; `dvc-bookmarks-yank-from-list-to-list' +;; Yank inside dvc-bookmark-alist: list ==> list +;; `dvc-bookmarks-show-or-hide-subtree' +;; Hide subtree when called with no argument +;; `dvc-bookmarks-delete-at-point' +;; Destructive kill and delete function +;; `dvc-bookmarks-kill' +;; Choose to kill marked entry or entry at point +;; `dvc-bookmarks-delete' +;; Choose to delete marked entry or entry at point +;; `dvc-bookmarks-add-empty-tree' +;; Add a new family to your bookmarks +;; `dvc-bookmarks-toggle-mark-entry' +;; Mark or unmark the current bookmark entry. +;; `dvc-bookmarks-unmark-all' +;; Unmark all bookmarks. +;; `dvc-bookmarks-hg-convert-from-marked' +;; Call `xhg-convert' with current dvc-bookmark as target and +;; `dvc-bookmarks-save' +;; Save `dvc-bookmark-alist' to the file `dvc-bookmarks-file-name'. +;; + +;;; History: + +;; + +;;; Code: +(require 'dvc-core) +(require 'dvc-state) +(require 'ewoc) +(eval-when-compile (require 'cl)) + +;; this were the settings used for tla +;; ;; Generated file. Do not edit!!! +;; (setq +;; tla-bookmarks-alist +;; '(("dvc" +;; (local-tree "/home/srei/work/tla/xtla") +;; (location "stefan@xsteve.at--public-2005" "dvc" "dev" "0" nil) +;; (timestamp . "Wed Apr 27 10:45:31 2005")) +;; ("emacs-muse" +;; (local-tree "/home/srei/work/tla/emacs-muse") +;; (location "mwolson@gnu.org--2006" "muse" "main" "1.0" nil) +;; (timestamp . "Fri Dec 10 07:05:56 2004")))) + +;; what I want to have: +;; hierachical tree of bookmarks +;; support for different dvc's +;; short name for working copy/branch +;; local-tree +;; timestamp => bookmark-creation-date? +;; different colors +;; optional: dvc: xhg, bzr,... +;; bookmark editing via C-k, C-y (just like in gnus) + +;; saved under ~/.dvc/bookmarks.el + +;; a data structure for testing purposes +(defvar dvc-bookmark-alist + '(("hg" + (local-tree "~/work/hg/hg")) + ("work-stuff" + (children + ("home-dir" + (local-tree "~/")) + ("another-dir" + (local-tree "~/work"))))) + "The bookmarks used for dvc") +;;(pp-to-string dvc-bookmark-alist) + +(defvar dvc-bookmarks-file-name "dvc-bookmarks.el" "The file that holds the dvc bookmarks") + +(defvar dvc-bookmarks-show-partners t + "If non-nil, display partners. +Must be non-nil for some featurs of dvc-bookmarks to work.") + +(defvar dvc-bookmarks-mode-hook '() + "*Hooks run when entering dvc-bookmarks-mode'.") + +(defvar dvc-bookmarks-loaded nil "Whether `dvc-bookmark-alist' has been loaded from `dvc-bookmarks-file-name'.") +(defvar dvc-bookmarks-cookie nil "The ewoc cookie for the *dvc-bookmarks* buffer.") +;;(defvar dvc-bookmarks-marked-entry nil "A marked bookmark entry for some special operations.") + +(defvar dvc-bookmarks-mode-map + (let ((map (make-sparse-keymap))) + (define-key map dvc-keyvec-help 'describe-mode) + ;;(define-key map dvc-keyvec-quit 'dvc-buffer-quit) + (define-key map dvc-keyvec-quit 'dvc-bookmarks-quit) + (define-key map [return] 'dvc-bookmarks-goto) + (define-key map "\C-x\C-f" 'dvc-bookmarks-find-file-in-tree) + (define-key map "\C-m" 'dvc-bookmarks-goto) + (define-key map "\C-o" 'dvc-bookmarks-goto-other-window) + (define-key map "g" 'dvc-bookmarks) + (define-key map "h" 'dvc-buffer-pop-to-partner-buffer) + (define-key map "j" 'dvc-bookmarks-jump) + (define-key map "n" 'dvc-bookmarks-next) + (define-key map "p" 'dvc-bookmarks-previous) + (define-key map "a" 'dvc-bookmarks-add) + (define-key map "At" 'dvc-bookmarks-add-empty-tree) + (define-key map "e" 'dvc-bookmarks-edit) + (define-key map "\C-y" 'dvc-bookmarks-yank) + (define-key map "\C-k" 'dvc-bookmarks-kill) + (define-key map "D" 'dvc-bookmarks-delete) + (define-key map "H" 'dvc-bookmarks-show-or-hide-subtree) + (define-key map "S" 'dvc-bookmarks-set-tree-properties) + (define-key map "s" 'dvc-bookmarks-status) + (define-key map "d" 'dvc-bookmarks-diff) + (define-key map "c" 'dvc-bookmarks-log-edit) + (define-key map "C" 'dvc-bookmarks-hg-convert-from-marked) + (define-key map "l" 'dvc-bookmarks-changelog) + (define-key map "L" 'dvc-bookmarks-log) + (define-key map "Mm" 'dvc-bookmarks-missing) + (define-key map "Mf" 'dvc-bookmarks-pull) + (define-key map "Mp" 'dvc-bookmarks-push) + (define-key map "Mx" 'dvc-bookmarks-merge) + (define-key map "#" 'dvc-bookmarks-toggle-mark-entry) + (define-key map "U" 'dvc-bookmarks-unmark-all) + (define-key map "." 'dvc-bookmarks-show-info-at-point) + (define-key map "\C-x\C-s" 'dvc-bookmarks-save) + (define-key map "Ap" 'dvc-bookmarks-add-partner) + (define-key map "Rp" 'dvc-bookmarks-remove-partner) + (define-key map "Tp" 'dvc-bookmarks-toggle-partner-visibility) + (define-key map "Td" 'dvc-bookmarks-toggle-time-stamp) + (define-key map "Tu" 'dvc-bookmarks-toggle-partner-url) + (define-key map "An" 'dvc-bookmarks-add-nickname) + (define-key map "Am" 'dvc-bookmarks-add-push-location) ;; mnemonic: Add mirror + (define-key map "Rm" 'dvc-bookmarks-remove-push-location) + map) + "Keymap used in `dvc-bookmarks-mode'.") + +(easy-menu-define dvc-bookmarks-mode-menu dvc-bookmarks-mode-map + "`dvc-bookmarks-mode' menu" + `("dvc-bookmarks" + ["Go to working copy" dvc-bookmarks-goto t] + ["DVC diff" dvc-bookmarks-diff t] + ["DVC status" dvc-bookmarks-status t] + ["DVC changelog" dvc-bookmarks-changelog t] + ["DVC log" dvc-bookmarks-log t] + ["DVC missing" dvc-bookmarks-missing t] + ["DVC pull" dvc-bookmarks-pull t] + ["DVC push" dvc-bookmarks-push t] + ["DVC merge" dvc-bookmarks-merge t] + "--" + ["Add new bookmark" dvc-bookmarks-add t] + ["Edit current bookmark" dvc-bookmarks-edit t] + ["Add partner" dvc-bookmarks-add-partner t] + ["Remove partner" dvc-bookmarks-remove-partner t] + ["Delete bookmark" dvc-bookmarks-delete t] + ["Add/edit partner Nickname" dvc-bookmarks-add-nickname t] + ["Add Push location" dvc-bookmarks-add-push-location t] + ["Remove Push location" dvc-bookmarks-remove-push-location t] + "--" + ("Toggle visibility" + ["Partners" dvc-bookmarks-toggle-partner-visibility + :style toggle :selected dvc-bookmarks-show-partners]) + "--" + ["Save bookmarks" dvc-bookmarks-save t] + )) + +;; This data structure represents a single entry in the bookmarks +;; list. There is one of these associated with each ewoc node. +(defstruct dvc-bookmark + name ; a string + indent ; an integer + elem) ; the cdr is an alist + +(defun dvc-bookmark-properties (bookmark) + (cdr (dvc-bookmark-elem bookmark))) + +(defsetf dvc-bookmark-properties (bookmark) (val) + `(setcdr (dvc-bookmark-elem ,bookmark) ,val)) + +;; This data structure represents a partner of a bookmark. +(defstruct (dvc-bookmark-partner + (:type list)) + url + nickname) + +(defun dvc-assq-all (key alist) + "Return an alist containing all associations from ALIST matching KEY." + (delete nil (mapcar '(lambda (e) + (when (and (listp e) (eq (car e) key)) + e)) + alist))) + +(defun make-dvc-bookmark-from-assoc (assoc indent) + "Create a `dvc-bookmark' from the association ASSOC. +The indent is taken from INDENT." + (make-dvc-bookmark + :name (car assoc) + :indent indent + :elem assoc)) + +(defun dvc-bookmark-key-value (bookmark key) + "Return the association from the property of BOOKMARK matching KEY." + (assq key (dvc-bookmark-properties bookmark))) + +(defun dvc-bookmark-value (bookmark key) + "Return the value of the property of BOOKMARK matching KEY." + (cadr (dvc-bookmark-key-value bookmark key))) + +(defun dvc-bookmark-partners (bookmark) + "Return a list of the partners of BOOKMARK. +Each element is a `dvc-bookmark-partner' structure." + (mapcar 'cdr + (dvc-assq-all 'partner (dvc-bookmark-properties bookmark)))) + +(defun dvc-bookmark-partners-by-url (bookmark) + "Return an alist of the partners of BOOKMARK. +The car of each association is the URL of the partner and the cdr +is the `dvc-bookmark-partner' itself." + (mapcar (lambda (p) (cons (dvc-bookmark-partner-url p) p)) + (dvc-bookmark-partners bookmark))) + +(defun dvc-bookmark-partner-urls (bookmark) + "Return a list of the partner urls of BOOKMARK." + (mapcar 'dvc-bookmark-partner-url (dvc-bookmark-partners bookmark))) + +(defun dvc-bookmark-partner-url-from-nick (bookmark) + "Return an alist of partners of BOOKMARK with nickname as key" + (let ((partner-alist (mapcar (lambda (p) (reverse p)) + (dvc-bookmark-partners bookmark)))) + partner-alist)) + +(defun dvc-bookmark-unmask-nickname-at-point () + "Get nickname at point even when urls are masked" + (save-excursion + (let ((nickname)) + ;;(goto-char (line-beginning-position)) + (end-of-line) + (when (looking-back "\\[.+\\]") + (setq nickname (replace-regexp-in-string "\\]" "" + (replace-regexp-in-string + "\\[" + "" + (match-string 0))))) + nickname))) + +(defun dvc-bookmark-get-hidden-url-at-point () + "Get url of partner at point even if partner urls +are masked." + (let ((url (cadr (assoc (dvc-bookmark-unmask-nickname-at-point) + (dvc-bookmark-partner-url-from-nick (dvc-bookmarks-current-bookmark)))))) + (when (stringp url) + (cond ((string-match "~/" url) + (expand-file-name url)) + (t + url))))) + +;; dvc-bookmarks-properties +(defvar dvc-bookmarks-prop-file + (dvc-config-file-full-path "dvc-bookmarks-properties.el" t)) + +(defvar dvc-bookmarks-cache (make-hash-table) + "init dvc-bookmarks hash-table properties") + +(defun set-dvc-bookmarks-cache () + "Load cache file or create cache file if don't exist" + (save-excursion + (if (file-exists-p dvc-bookmarks-prop-file) + (load dvc-bookmarks-prop-file) + (find-file dvc-bookmarks-prop-file) + (goto-char (point-min)) + (erase-buffer) + (insert ";;; dvc-bookmarks-cache -*- mode: emacs-lisp; coding: utf-8; -*-") + (save-buffer) + (quit-window)))) + +;;(set-dvc-bookmarks-cache) + +(defmacro hash-get-items (hash-table) + "Get the list of all keys/values of hash-table +values are given under string form" + `(let ((li-items nil)) + (maphash #'(lambda (x y) (push (list x y) li-items)) + ,hash-table) + li-items)) + +(defmacro hash-get-symbol-keys (hash-table) + "Get the list of all the keys in hash-table +keys are given under string form" + `(let ((li-keys nil) + (li-all (hash-get-items ,hash-table))) + (setq li-keys (mapcar #'car li-all)) + li-keys)) + +(defmacro hash-has-key (key hash-table) + "check if hash-table have key key +key here must be a symbol and not a string" + `(let ((keys-list (hash-get-symbol-keys ,hash-table))) + (if (memq ,key keys-list) + t + nil))) + +(defun dvc-cur-date-string () + "Return current date under string form ==>2008.03.16" + (interactive) + (let ((year (nth 5 (decode-time (current-time)))) + (month (nth 4 (decode-time (current-time)))) + (day (nth 3 (decode-time (current-time)))) + (str-day-date "")) + (setq str-day-date + (concat (int-to-string year) + "." + (if (< (length (substring (int-to-string (/ (float month) 100)) 2)) 2) + (concat (substring (int-to-string (/ (float month) 100)) 2) "0") + (substring (int-to-string (/ (float month) 100)) 2)) + "." + (if (< (length (substring (int-to-string (/ (float day) 100)) 2)) 2) + (concat (substring (int-to-string (/ (float day) 100)) 2) "0") + (substring (int-to-string (/ (float day) 100)) 2)))) + str-day-date)) + +(defvar dvc-table-face '("dvc-id" + "dvc-excluded" + "dvc-nested-tree" + "dvc-mark" + "dvc-revision-name" + "dvc-source" + "dvc-unknown" + "dvc-separator" + "dvc-highlight" + "dvc-copy" + "dvc-duplicate")) + +(defun dvc-bookmarks-set-tree-properties (color state) + "color value is one of the dvc-faces ==> dvc-buffer, dvc-nested-tree, etc... +See dvc-defs.el. +state values can be closed or open" + (interactive + (let* ((current-tree (aref (dvc-bookmarks-current-bookmark) 1)) + (current-color (if (hash-has-key (intern current-tree) + dvc-bookmarks-cache) + (cdr (assoc + 'color + (gethash (intern current-tree) + dvc-bookmarks-cache))))) + (current-state (if (hash-has-key (intern current-tree) + dvc-bookmarks-cache) + (cdr (assoc + 'state + (gethash (intern current-tree) + dvc-bookmarks-cache))))) + (def-color (dvc-completing-read "Color: " + dvc-table-face + nil + t + (format "%s" current-color) + 'minibuffer-history)) + (def-state (dvc-completing-read "State: " + '("open" "closed") + nil + t + current-state + 'minibuffer-history))) + (list def-color def-state))) + (let* ((current-tree (aref (dvc-bookmarks-current-bookmark) 1)) + (time-stamp (if (equal (cdr (assoc + 'state + (gethash (intern current-tree) + dvc-bookmarks-cache))) + state) + (cdr (assoc + 'time-stamp + (gethash (intern current-tree) + dvc-bookmarks-cache))) + (dvc-cur-date-string))) + (new-entry (concat + (format "(puthash '%S '((color . %S) (state . %S) (time-stamp . %S))" + (intern current-tree) + (intern color) + state + time-stamp) + " dvc-bookmarks-cache)"))) + (save-excursion + (find-file dvc-bookmarks-prop-file) + (goto-char (point-min)) + (setq case-fold-search nil) + (if (hash-has-key (intern current-tree) + dvc-bookmarks-cache) + (when (re-search-forward current-tree) + (beginning-of-line) + (kill-line) + (insert new-entry)) + (goto-char (point-max)) + (forward-line) + (insert new-entry)) + (save-buffer) + (kill-buffer (current-buffer)))) + (set-dvc-bookmarks-cache) + (dvc-bookmarks)) + + +(defun dvc-bookmarks-ignore-closed-trees () + "If state of tree is closed don't print all children" + (ewoc-filter dvc-bookmarks-cookie #'(lambda (x) + (or (assoc (aref x 1) dvc-bookmark-alist) + (not (hash-has-key (intern (dvc-get-parent-elm (aref x 1) + dvc-bookmark-alist)) + dvc-bookmarks-cache)) + (equal (cdr (assoc + 'state + (gethash (intern (dvc-get-parent-elm (aref x 1) + dvc-bookmark-alist)) + dvc-bookmarks-cache))) + "open"))))) + +(add-hook 'dvc-bookmarks-mode-hook 'dvc-bookmarks-ignore-closed-trees) + +(defvar dvc-bookmarks-show-time-stamp t) +(defun dvc-bookmarks-toggle-time-stamp () + "Toggle show/don't show time-stamp" + (interactive) + (beginning-of-line) + (let ((beg (point))) + (if dvc-bookmarks-show-time-stamp + (setq dvc-bookmarks-show-time-stamp nil) + (setq dvc-bookmarks-show-time-stamp t)) + (dvc-bookmarks) + (goto-char beg) + (beginning-of-line))) + +(defun dvc-bookmarks-printer (data) + (let* ((entry (dvc-bookmark-name data)) + (indent (dvc-bookmark-indent data)) + (partners (and dvc-bookmarks-show-partners + (dvc-bookmark-partners data))) + (nick-name) + (partner-string) + (date (cadr + (assoc 'time-stamp + (assoc entry + (cadr (assoc (dvc-get-parent-elm entry dvc-bookmark-alist ) + dvc-bookmark-alist)))))) + (entry-string (if (hash-has-key (intern entry) dvc-bookmarks-cache) + (format "%s%s" (make-string indent ? ) (concat entry + " [" + (cdr (assoc + 'state + (gethash (intern entry) + dvc-bookmarks-cache))) + "][" + (cdr (assoc + 'time-stamp + (gethash (intern entry) + dvc-bookmarks-cache))) + "]")) + (format "%s%s" (make-string indent ? ) (if (and dvc-bookmarks-show-time-stamp + date) + (concat entry + " [" + date + "]") + entry))))) + ;;(dvc-trace "dvc-bookmarks-printer - data: %S, partners: %S" data partners) +;;; (when (and dvc-bookmarks-marked-entry (string= dvc-bookmarks-marked-entry entry)) +;;; (setq entry-string (dvc-face-add entry-string 'dvc-marked))) + (if (assoc entry dvc-bookmark-alist) + (if (hash-has-key (intern entry) dvc-bookmarks-cache) + (setq entry-string (dvc-face-add entry-string + (cdr (assoc + 'color + (gethash (intern entry) + dvc-bookmarks-cache))))) + (setq entry-string (dvc-face-add entry-string dvc-bookmarks-face-tree))) + (setq entry-string (dvc-face-add entry-string dvc-bookmarks-face-subtree))) + (when (and dvc-bookmarks-marked-entry-list + (member entry dvc-bookmarks-marked-entry-list)) + (setq entry-string (dvc-face-add entry-string 'dvc-marked))) + (insert entry-string) + (when partners + (dolist (p partners) + (setq nick-name (dvc-bookmark-partner-nickname p)) + (setq partner-string (format "\n%sPartner %s%s" + (make-string (+ 2 indent) ? ) + (if nick-name + (if dvc-bookmarks-show-partner-url + (dvc-bookmark-partner-url p) + "") + (dvc-bookmark-partner-url p)) + (if nick-name (format " [%s]" nick-name) ""))) + (setq partner-string (dvc-face-add partner-string dvc-bookmarks-face-partner)) + (insert partner-string))))) + +(defvar dvc-bookmarks-show-partner-url t + "Define if we show partners url or not") + +(defun dvc-bookmarks-toggle-partner-url () + "Toggle show/don't show partners urls" + (interactive) + (beginning-of-line) + (let ((beg (point))) + (if dvc-bookmarks-show-partner-url + (setq dvc-bookmarks-show-partner-url nil) + (setq dvc-bookmarks-show-partner-url t)) + (dvc-bookmarks) + (goto-char beg) + (beginning-of-line))) + +(defun dvc-bookmarks-add-to-cookie (elem indent &optional node) + (let ((curr (or node (ewoc-locate dvc-bookmarks-cookie))) + (data (make-dvc-bookmark-from-assoc elem indent)) + (enter-function (if (eq (dvc-line-number-at-pos) 1) 'ewoc-enter-before 'ewoc-enter-after))) + (cond ((or (assoc 'children elem) + (and dvc-bookmarks-show-partners + (assoc 'partner elem))) + (setq node + (if curr + (apply enter-function (list dvc-bookmarks-cookie curr data)) + (let ((n (ewoc-enter-last dvc-bookmarks-cookie data))) + (forward-line 1) + n))) + (dolist (child (reverse (cdr (assoc 'children elem)))) + (dvc-bookmarks-add-to-cookie child (+ indent 2) node))) + (t + (if curr + (apply enter-function (list dvc-bookmarks-cookie curr data)) + (ewoc-enter-last dvc-bookmarks-cookie data)))) + (forward-line 2))) + +;;;###autoload +(defun dvc-bookmarks (&optional arg) + "Display the *dvc-bookmarks* buffer. +With prefix argument ARG, reload the bookmarks file from disk." + (interactive "P") + (dvc-bookmarks-load-from-file arg) + (when (eq (hash-table-count dvc-bookmarks-cache) 0) + (set-dvc-bookmarks-cache)) + (dvc-switch-to-buffer (get-buffer-create "*dvc-bookmarks*")) + (let ((cur-pos (point))) + (toggle-read-only 0) + (erase-buffer) + (set (make-local-variable 'dvc-bookmarks-cookie) + (ewoc-create (dvc-ewoc-create-api-select + #'dvc-bookmarks-printer))) + (put 'dvc-bookmarks-cookie 'permanent-local t) + (dolist (entry dvc-bookmark-alist) + (dvc-bookmarks-add-to-cookie entry 0)) + (if (eq major-mode 'dvc-bookmarks-mode) + (goto-char cur-pos) + (goto-char (point-min)))) + (dvc-bookmarks-mode)) + +(defun dvc-bookmarks-mode () + "Mode to display DVC bookmarks. + +\\{dvc-bookmarks-mode-map}" + (interactive) + (kill-all-local-variables) + (use-local-map dvc-bookmarks-mode-map) + (setq major-mode 'dvc-bookmarks-mode) + (setq mode-name "dvc-bookmarks") + (toggle-read-only 1) + (run-hooks 'dvc-bookmarks-mode-hook)) + +(defun dvc-bookmarks-quit () + "Clean dvc-bookmarks-hidden-subtree +and quit" + (interactive) + (setq dvc-bookmarks-hidden-subtree nil) + (dvc-buffer-quit)) + +(defun dvc-bookmarks-show-info-at-point () + (interactive) + (message "%S" (dvc-bookmarks-current-bookmark))) + +(defun dvc-bookmarks-current-bookmark () + (ewoc-data (ewoc-locate dvc-bookmarks-cookie))) + +(defun dvc-bookmarks-invalidate-current-bookmark () + "Regenerate the text for the bookmark under point." + (ewoc-invalidate dvc-bookmarks-cookie (ewoc-locate dvc-bookmarks-cookie))) + +(defun dvc-bookmarks-current-value (key) + (dvc-bookmark-value (dvc-bookmarks-current-bookmark) key)) + +(defun dvc-bookmarks-current-key-value (key) + (dvc-bookmark-key-value (dvc-bookmarks-current-bookmark) key)) + +(defun dvc-bookmarks-add (bookmark-name bookmark-local-dir) + "Add a DVC bookmark named BOOKMARK-NAME, directory BOOKMARK-LOCAL-DIR." + (interactive + (let* ((bmk-name (read-string "DVC bookmark name: ")) + (bmk-loc (dvc-read-directory-name (format "DVC bookmark %s directory: " bmk-name)))) + (list bmk-name bmk-loc))) + (let* ((date (dvc-cur-date-string)) + (elem (list bookmark-name + (list 'local-tree bookmark-local-dir) + (list 'time-stamp date))) + (data (make-dvc-bookmark-from-assoc elem 0))) + (dvc-bookmarks) + (add-to-list 'dvc-bookmark-alist elem t) + (ewoc-enter-last dvc-bookmarks-cookie data))) + +(defun dvc-bookmarks-member-p (elm) + "Predicate to test if `elm' is member +of dvc-bookmark-alist +`elm' is a string" + (catch 'break + (dolist (x dvc-bookmark-alist) + (dolist (i (cdadr x)) + (when (string= elm (car i)) + (throw 'break t)))))) + +;;;###autoload +(defun dvc-bookmarks-dired-add-project () + "Add a DVC bookmark from dired" + (interactive) + (let ((ori-list (dired-get-marked-files)) + (bname-list)) + (save-excursion + (dvc-bookmarks) + (dolist (i ori-list) + (if (not (dvc-bookmarks-member-p (file-name-nondirectory i))) + (push i bname-list))) + (if (yes-or-no-p (format "Add %s bookmarks to DVC-BOOKMARKS? " + (length bname-list))) + (progn + (dolist (i bname-list) + (let ((bname (file-name-nondirectory i))) + (when (file-directory-p i) + (dvc-bookmarks-add bname i)))) + (dvc-bookmarks-save) + (dvc-bookmark-goto-name (file-name-nondirectory (car (last bname-list))))) + (message "Operation aborted"))))) + +(defun dvc-bookmarks-edit (bookmark-name bookmark-local-dir &optional bmk-time-stamp) + "Change the current DVC bookmark's BOOKMARK-NAME and/or LOCAL-DIR." + (interactive + (let* ((old-name (dvc-bookmark-name (dvc-bookmarks-current-bookmark))) + (cur-data (dvc-bookmarks-current-bookmark)) + (old-local-tree (dvc-bookmarks-current-value 'local-tree)) + (old-date (dvc-bookmarks-current-value 'time-stamp)) + (is-child (equal (first (split-string (aref cur-data 1) "-")) + "child")) + (bmk-name (read-string "DVC bookmark name: " old-name)) + (bmk-loc (dvc-read-directory-name + (format "DVC bookmark %s directory: " bmk-name) + old-local-tree)) + (bmk-tmstp (unless is-child + (read-string "DVC bookmark time-stamp: " old-date)))) + (list bmk-name bmk-loc bmk-tmstp))) + (if (assoc (aref (dvc-bookmarks-current-bookmark) 1) dvc-bookmark-alist) + (error "Tree edition is not implemented yet! Sorry!") + (let* ((node (ewoc-locate dvc-bookmarks-cookie)) + (old-data (ewoc-data node)) + (old-indent (dvc-bookmark-indent old-data)) + (elem (dvc-bookmark-elem old-data))) + (setcar elem bookmark-name) + (setcdr elem (cons (list 'local-tree bookmark-local-dir) + (cons (list 'time-stamp bmk-time-stamp) + (assq-delete-all 'time-stamp + (assq-delete-all 'local-tree + (cdr elem)))))) + (ewoc-set-data node (make-dvc-bookmark-from-assoc elem old-indent)) + (ewoc-invalidate dvc-bookmarks-cookie node)))) + +(defun dvc-bookmarks-next () + (interactive) + (forward-line 1)) + +(defun dvc-bookmarks-previous () + (interactive) + (forward-line -1)) + +(defun dvc-bookmarks-goto () + (interactive) + (let ((local-tree (dvc-bookmarks-current-value 'local-tree))) + (if local-tree + (find-file local-tree) + (message "No local-tree defined for this bookmark entry.")))) + +(defun dvc-bookmarks-goto-other-window () + (interactive) + (let ((local-tree (dvc-bookmarks-current-value 'local-tree))) + (if local-tree + (find-file-other-window local-tree) + (message "No local-tree defined for this bookmark entry.")))) + +(defun dvc-bookmarks-find-file-in-tree () + (interactive) + (let ((local-tree (dvc-bookmarks-current-value 'local-tree))) + (if local-tree + (let ((default-directory (file-name-as-directory local-tree))) + (find-file (read-file-name "Find file in bookmarked tree: "))) + (message "No local-tree defined for this bookmark entry.")))) + +(defun dvc-bookmarks-status () + "Run `dvc-status' for bookmark at point." + (interactive) + (let ((local-tree (dvc-bookmarks-current-value 'local-tree))) + (if local-tree + (dvc-status local-tree) + (message "No local-tree defined for this bookmark entry.")))) + +(defun dvc-bookmarks-diff () + "Run `dvc-diff' for bookmark at point." + (interactive) + (let ((local-tree (dvc-bookmarks-current-value 'local-tree)) + (partner (dvc-bookmark-get-hidden-url-at-point))) + (if local-tree + (if partner + (progn (message "Running dvc diff for %s, against %s" + (dvc-bookmark-name (dvc-bookmarks-current-bookmark)) + partner) + (let ((default-directory local-tree)) + (dvc-diff-against-url partner))) + (dvc-diff nil local-tree)) + (message "No local-tree defined for this bookmark entry.")))) + +(defun dvc-bookmarks-log-edit () + (interactive) + (let ((local-tree (dvc-bookmarks-current-value 'local-tree))) + (if local-tree + (let ((default-directory local-tree)) + (dvc-log-edit)) + (message "No local-tree defined for this bookmark entry.")))) + +(defun dvc-bookmarks-changelog () + (interactive) + (let ((local-tree (dvc-bookmarks-current-value 'local-tree))) + (if local-tree + (let ((default-directory local-tree)) + (dvc-changelog)) + (message "No local-tree defined for this bookmark entry.")))) + +(defun dvc-bookmarks-log () + (interactive) + (let ((local-tree (dvc-bookmarks-current-value 'local-tree))) + (if local-tree + (let ((default-directory local-tree)) + (dvc-log)) + (message "No local-tree defined for this bookmark entry.")))) + +(defun dvc-bookmarks-missing () + (interactive) + (let ((local-tree (dvc-bookmarks-current-value 'local-tree))) + (if local-tree + (let ((partner (dvc-bookmark-get-hidden-url-at-point))) + (message "Running dvc missing for %s, against %s" + (dvc-bookmark-name (dvc-bookmarks-current-bookmark)) + partner) + (sit-for 1) + (dvc-missing partner local-tree)) + (message "No local-tree defined for this bookmark entry.")))) + +(defun dvc-bookmarks-pull () + "Pull from partner at point or default into current bookmark." + (interactive) + (let ((local-tree (dvc-bookmarks-current-value 'local-tree))) + (if local-tree + (let ((default-directory local-tree) + (partner (dvc-bookmark-get-hidden-url-at-point)) + (nickname (dvc-bookmark-unmask-nickname-at-point))) + (message (if partner + (if nickname + (format "Pulling from %s, using URL %s" nickname partner) + (format "Pulling from %s" partner)) + "Pulling from default location")) + (dvc-pull partner)) + (message "No local-tree defined for this bookmark entry.")))) + +(defun dvc-bookmarks-push () + (interactive) + (let ((local-tree (dvc-bookmarks-current-value 'local-tree))) + (if local-tree + (let ((default-directory local-tree)) + (dvc-push)) + (message "No local-tree defined for this bookmark entry.")))) + +(defvar dvc-bookmarks-merge-template "Merged from %s: ") +(defun dvc-bookmarks-merge () + "Merge from partner at point into current bookmark." + (interactive) + (let ((local-tree (dvc-bookmarks-current-value 'local-tree))) + (setq local-tree (dvc-uniquify-file-name local-tree)) + (if local-tree + (let ((default-directory local-tree) + (partner (dvc-bookmarks-partner-at-point t)) + (nickname (dvc-bookmarks-nickname-at-point))) + (setq dvc-memorized-log-header (when nickname (format dvc-bookmarks-merge-template nickname))) + (setq dvc-memorized-log-message nil) + (message (if nickname + (format "Merging from %s, using URL %s" nickname partner) + (format "Merging from %s" partner))) + (dvc-merge partner)) + (message "No local-tree defined for this bookmark entry.")))) + +;; backend functions to yank +(defun dvc-get-index-el-list (elm lis) + "Get index of element in list" + (let ((n 0) + (index 0)) + (if (member elm lis) + (progn + (dolist (x lis) + (when (equal x elm) + (setq index n)) + (setq n (+ n 1))) + index) + (error "No element %s in %s" elm lis)))) + +(defun dvc-move-element-in-list (name-elm lis where) + "move element `name-elm' of list `lis' to index `where' +in list `lis'. +`name-elm' have the form of element in list. +`lis' is a LIST +`where' is an INTEGER" + (let* ((index-elm (dvc-get-index-el-list name-elm lis)) + (start-part-list (subseq lis 0 where)) + (mod-list (append (remove name-elm start-part-list) + (cons name-elm + (remove name-elm (subseq lis where)))))) + mod-list)) + +(defun dvc-add-to-list-at-ind (elm lis where) + "Add `elm' in `lis' at index `where'" + (let ((cons-list (cons elm lis)) + (appended-list nil)) + (setq appended-list + (dvc-move-element-in-list elm cons-list (+ 1 where))) + appended-list)) + +(defun dvc-move-elm-in-list-or-sublist (name-elm lis where &optional subtree) + "move element `name-elm' of list `lis' to index `where' in list `lis' + +elm ==> any element of a list +lis ==> the main list +where ==> a number, index to use of list or sublist +subtree ==> the sublist: +any quoted list or function that return a sublist of lis + +Examples: + +,---- +| ELISP> (setq *A* '((1 2 3 4) a b c d e f)) +| ((1 2 3 4) +| a b c d e f) +| +| ELISP> (dvc-move-elm-in-list-or-sublist 'a *A* 1 '(1 2 3 4)) +| ((1 a 2 3 4) +| b c d e f) +| +| ELISP> (dvc-move-elm-in-list-or-sublist 1 *A* 2 '(1 2 3 4)) +| ((2 3 4) +| a b 1 c d e f) +| +| ELISP> (dvc-move-elm-in-list-or-sublist 'e *A* 1) +| ((1 2 3 4) +| e a b c d f) +`---- + +" + (let* ((subtree-index (when subtree + (dvc-get-index-el-list subtree lis))) + (list-to-use (if subtree + (nth subtree-index lis) + lis)) + (modif-list (if (member name-elm lis) + (dvc-add-to-list-at-ind name-elm list-to-use where) + (dvc-move-element-in-list name-elm list-to-use where)))) + (if subtree + (cond ((member name-elm lis) + (dvc-add-to-list-at-ind modif-list (remove subtree (remove name-elm lis)) subtree-index)) + ((member name-elm subtree) + (let ((append-list (dvc-add-to-list-at-ind name-elm (remove subtree lis) where))) + (dvc-add-to-list-at-ind (remove name-elm subtree) append-list subtree-index))) + (t + (dvc-add-to-list-at-ind modif-list (remove subtree lis) subtree-index))) + modif-list))) + +(defun dvc-get-parent-elm (elm list) + "Return the name of sublist where current element is" + (let ((head nil)) + (dolist (x list) + (when (member (assoc elm (assoc 'children x)) + (assoc 'children x)) + (setq head (car x)))) + head)) + +;; Yanking + +(defun dvc-bookmarks-yank () + "Choose to yank marked or at point" + (interactive) + (if dvc-bookmarks-marked-entry-list + (dvc-bookmarks-yank-all-marked-at-point) + (dvc-bookmarks-really-yank))) + + +(defun dvc-bookmarks-really-yank () + "Check which function call and call it" + ;(interactive) + (let* ((killed-elm (aref dvc-bookmarks-tmp-yank-item 3)) + (yank-point (aref (dvc-bookmarks-current-bookmark) 3)) + (parent-elm (if (and (member killed-elm dvc-bookmark-alist) + (not (member yank-point dvc-bookmark-alist))) + (dvc-get-parent-elm (aref (dvc-bookmarks-current-bookmark) 1) + dvc-bookmark-alist) + (dvc-get-parent-elm (aref dvc-bookmarks-tmp-yank-item 1) + dvc-bookmark-alist))) + (child-alist (cadr (assoc parent-elm dvc-bookmark-alist))) + (cur-pos (point))) + (cond ((and (member killed-elm dvc-bookmark-alist) + (member yank-point dvc-bookmark-alist)) + (dvc-bookmarks-yank-from-list-to-list)) + ((and (member killed-elm dvc-bookmark-alist) + (member yank-point child-alist)) + (dvc-bookmarks-yank-from-list-to-sub)) + ((and (member killed-elm child-alist) + (member yank-point dvc-bookmark-alist)) + (dvc-bookmarks-yank-from-sub-to-list)) + ((and (not (member killed-elm dvc-bookmark-alist)) + (not (member yank-point dvc-bookmark-alist))) + (dvc-bookmarks-yank-from-sub-to-sub)) + (t (message "This yank is not implemented yet sorry!"))) + (goto-char cur-pos))) + +(defun dvc-bookmarks-yank-from-list-to-sub () + "Yank from list ==> sublist" + (interactive) + (let* ((elm-to-move (aref dvc-bookmarks-tmp-yank-item 3)) + (elm-at-point (aref (dvc-bookmarks-current-bookmark) 3)) + (parent (dvc-get-parent-elm (aref (dvc-bookmarks-current-bookmark) 1) + dvc-bookmark-alist)) + (sublist (assoc parent dvc-bookmark-alist)) + ;; get index of sub and store it + (sub-index (dvc-get-index-el-list sublist dvc-bookmark-alist)) + (child-dvc-bookmark-alist (cadr sublist)) + (alist-nosub (remove sublist dvc-bookmark-alist)) + (which-list (cond ((member elm-at-point child-dvc-bookmark-alist) + child-dvc-bookmark-alist) + ((member elm-at-point sublist) + sublist) + (t dvc-bookmark-alist))) + (yank-index (dvc-get-index-el-list elm-at-point which-list)) + ;; move elm at the root of sublist + (tmp-alist (dvc-move-elm-in-list-or-sublist elm-to-move + dvc-bookmark-alist + 1 + sublist))) + ;; now move elm in the '(children) + (setq sublist + (dvc-move-elm-in-list-or-sublist elm-to-move + (assoc parent tmp-alist) + (+ 1 yank-index) + child-dvc-bookmark-alist)) + (when (not (consp (nth 1 sublist))) ; hack to fix a small bug in backend func + (setq sublist (remove (nth 1 sublist) sublist))) + ;; replace the sublist modified to initial place + (setq dvc-bookmark-alist + (dvc-add-to-list-at-ind sublist alist-nosub sub-index)) + (setq dvc-bookmark-alist + (remove elm-to-move dvc-bookmark-alist)) + (ewoc-refresh dvc-bookmarks-cookie)) + (dvc-bookmarks-save) + (dvc-bookmarks)) + +(defun dvc-bookmarks-yank-from-sub-to-list () + "Yank from sublist ==> list" + (interactive) + (let* ((elm-to-move (aref dvc-bookmarks-tmp-yank-item 3)) + (elm-at-point (aref (dvc-bookmarks-current-bookmark) 3)) + (parent (dvc-get-parent-elm (aref dvc-bookmarks-tmp-yank-item 1) + dvc-bookmark-alist)) + (sublist (assoc parent dvc-bookmark-alist)) + ;; get index of sublist and store it + (sub-index (dvc-get-index-el-list sublist dvc-bookmark-alist)) + (child-dvc-bookmark-alist (cadr sublist)) + (alist-nosub (remove sublist dvc-bookmark-alist)) + (yank-index (dvc-get-index-el-list elm-at-point dvc-bookmark-alist)) + ;; now move elm out of '(children) + (tmp-sublist (dvc-move-elm-in-list-or-sublist elm-to-move + sublist + 1 + child-dvc-bookmark-alist)) + (tmp-alist nil)) + ;; replace the sublist modified to initial place + (setq tmp-alist (dvc-add-to-list-at-ind tmp-sublist alist-nosub sub-index)) + ;; now move elm to root of dvc-bookmark-alist + (if (member elm-to-move child-dvc-bookmark-alist) + ;; elm-to-move was in child + (setq dvc-bookmark-alist (dvc-move-elm-in-list-or-sublist elm-to-move + tmp-alist + yank-index + tmp-sublist)) + ;; elm-to-move was in sublist ("home-dir"...) + (setq dvc-bookmark-alist (dvc-move-elm-in-list-or-sublist elm-to-move + dvc-bookmark-alist + yank-index + sublist))) + (ewoc-refresh dvc-bookmarks-cookie)) + (dvc-bookmarks-save) + (dvc-bookmarks)) + +(defun dvc-bookmarks-yank-from-sub-to-sub () + "Yank from one sublist to another sublist, +or in the same sublist" + (interactive) + (let* ((elm-to-move (aref dvc-bookmarks-tmp-yank-item 3)) + (elm-at-point (aref (dvc-bookmarks-current-bookmark) 3)) + (parent-from (dvc-get-parent-elm (aref dvc-bookmarks-tmp-yank-item 1) + dvc-bookmark-alist)) + (parent-to (dvc-get-parent-elm (aref (dvc-bookmarks-current-bookmark) 1) + dvc-bookmark-alist)) + (sublist1 (assoc parent-from dvc-bookmark-alist)) + (sublist2 (assoc parent-to dvc-bookmark-alist)) + (sub-index (dvc-get-index-el-list sublist1 dvc-bookmark-alist)) + (sub-index2 (dvc-get-index-el-list sublist2 dvc-bookmark-alist)) + ;; index point (yank here + 1) + (yank-index (dvc-get-index-el-list elm-at-point (cadr sublist2))) + (yank-index-sub-in-sub nil) + ;; dvc-bookmark-alist without sublist1 + (alist-nosub (remove sublist1 dvc-bookmark-alist)) + ;; initial sublist with elm-to-move at root of sublist + (tmp-sublist (dvc-move-elm-in-list-or-sublist elm-to-move + sublist1 + 1 + (cadr sublist1))) + ;; replace sublist1 modified to initial place + (tmp-alist (dvc-add-to-list-at-ind tmp-sublist + alist-nosub + sub-index)) + ;; the new alist without sub2 + (alist-nosub2 nil)) + ;; check now if we yank in the same sub or an external one + (if (equal parent-from parent-to) + ;; we yank in the same sub + (progn + ;; move elm-to-move in child + (setq yank-index-sub-in-sub + (dvc-get-index-el-list elm-at-point (cadr tmp-sublist))) + (setq sublist1 + (dvc-move-elm-in-list-or-sublist elm-to-move + tmp-sublist + (+ 1 yank-index-sub-in-sub) + (cadr tmp-sublist))) + (setq dvc-bookmark-alist + (dvc-add-to-list-at-ind sublist1 + alist-nosub + sub-index))) + ;; else: we yank in another sub + ;; now move elm-to-move to root of dvc-bookmark-alist + (setq tmp-alist + (dvc-move-elm-in-list-or-sublist elm-to-move + tmp-alist + 1 + tmp-sublist)) + ;; now move elm-to-move to root of sub2 + (setq tmp-alist + (dvc-move-elm-in-list-or-sublist elm-to-move + tmp-alist + 1 + sublist2)) + + ;; now move elm-to-move to child of sub2 at yank-index + (setq sublist2 + (dvc-move-elm-in-list-or-sublist elm-to-move + (assoc parent-to tmp-alist) + (+ 1 yank-index) + (cadr sublist2))) + ;; create now a new dvc-bookmark-alist with the sub2 modified + (when (not (consp (nth 1 sublist2))) ; hack to fix a small bug in backend func + (setq sublist2 (remove (nth 1 sublist2) sublist2))) + ;; at this point we have just to remove elm-to-move from sub1 + (setq dvc-bookmark-alist + (dvc-add-to-list-at-ind (remove elm-to-move (assoc parent-from tmp-alist)) + alist-nosub + sub-index)) + ;; set an alist without old sub2 + (setq alist-nosub2 + (remove (assoc parent-to dvc-bookmark-alist) + dvc-bookmark-alist)) + ;; add new sublist2 to the alist without sub2 + (setq dvc-bookmark-alist + (dvc-add-to-list-at-ind sublist2 + alist-nosub2 + sub-index2))) + (ewoc-refresh dvc-bookmarks-cookie)) + (dvc-bookmarks-save) + (dvc-bookmarks)) + +(defun dvc-bookmarks-yank-from-list-to-list () + "Yank inside dvc-bookmark-alist: list ==> list" + (interactive) + (let* ((elm-to-move (assoc (dvc-bookmark-name dvc-bookmarks-tmp-yank-item) + dvc-bookmark-alist)) + (elm-at-point (assoc (dvc-bookmark-name (dvc-bookmarks-current-bookmark)) + dvc-bookmark-alist)) + (yank-index (dvc-get-index-el-list elm-at-point dvc-bookmark-alist))) + (setq dvc-bookmark-alist (dvc-move-element-in-list elm-to-move dvc-bookmark-alist (+ 1 yank-index))) + (ewoc-refresh dvc-bookmarks-cookie)) + (dvc-bookmarks-save) + (dvc-bookmarks)) + + +(defvar dvc-bookmarks-hidden-subtree nil + "List of all hidden subtrees") + +(defun dvc-bookmarks-show-or-hide-subtree (&optional show) + "Hide subtree when called with no argument +show subtree when called with prefix argument (C-u)" + (interactive "P") + (let ((current-tree (aref (dvc-bookmarks-current-bookmark) 1)) + (parent)) + (when (member (assoc current-tree dvc-bookmark-alist) dvc-bookmark-alist) ;check if we are really on a tree + (if current-prefix-arg + (progn + (setq dvc-bookmarks-hidden-subtree (remove current-tree dvc-bookmarks-hidden-subtree)) + (dvc-bookmarks)) + (add-to-list 'dvc-bookmarks-hidden-subtree current-tree)) + (ewoc-filter dvc-bookmarks-cookie #'(lambda (x) + (setq parent (dvc-get-parent-elm (aref x 1) dvc-bookmark-alist)) + (if (not (member parent dvc-bookmarks-hidden-subtree)) + t + nil)))))) + +(defvar dvc-bookmarks-tmp-yank-item '("hg" (local-tree "~/work/hg/hg"))) + +(defun dvc-bookmarks-delete-at-point () + "Destructive kill and delete function +do not use it to kill/yank, use dvc-bookmarks-kill instead" + (interactive) + (let ((init-place (point)) + (current-bookmark)) + (dvc-bookmarks-kill-at-point) + (setq current-bookmark (dvc-bookmark-name dvc-bookmarks-tmp-yank-item)) + (if (assoc (dvc-bookmark-name dvc-bookmarks-tmp-yank-item) dvc-bookmark-alist) + (progn + (setq dvc-bookmark-alist (remove (assoc (dvc-bookmark-name dvc-bookmarks-tmp-yank-item) dvc-bookmark-alist) + dvc-bookmark-alist)) + (ewoc-refresh dvc-bookmarks-cookie) + (dvc-bookmarks-save) + ;;(dvc-bookmarks) + (if (hash-has-key (intern current-bookmark) + dvc-bookmarks-cache) + (save-excursion + (find-file dvc-bookmarks-prop-file) + (setq case-fold-search nil) + (goto-char (point-min)) + (when (re-search-forward current-bookmark) + (beginning-of-line) + (kill-line) + (delete-blank-lines) + (save-buffer) + (kill-buffer (current-buffer))) + (set-dvc-bookmarks-cache)))) + (message "Please move first this element to root and then delete it")) + (dvc-bookmarks) + (goto-char init-place))) + +(defun dvc-bookmarks-kill-at-point () + "kill or cut bookmark at point" + (setq dvc-bookmarks-tmp-yank-item (dvc-bookmarks-current-bookmark)) + (let ((buffer-read-only nil) + (current-tree (aref (dvc-bookmarks-current-bookmark) 1)) + (parent)) + (if (member (assoc current-tree dvc-bookmark-alist) dvc-bookmark-alist) + (ewoc-filter dvc-bookmarks-cookie #'(lambda (x) + (setq parent (dvc-get-parent-elm (aref x 1) dvc-bookmark-alist)) + (when (not (equal current-tree (aref x 1))) + (if (not (equal parent current-tree)) + t + nil)))) + (dvc-ewoc-delete dvc-bookmarks-cookie (ewoc-locate dvc-bookmarks-cookie))))) + +(defun dvc-bookmarks-kill () + "Choose to kill marked entry or entry at point" + (interactive) + (if dvc-bookmarks-marked-entry-list + (dvc-bookmarks-kill-all-marked) + (dvc-bookmarks-kill-at-point))) + +(defun dvc-bookmarks-delete () + "Choose to delete marked entry or entry at point" + (interactive) + (if dvc-bookmarks-marked-entry-list + (if (yes-or-no-p (format "Really delete %s bookmarks?" + (length dvc-bookmarks-marked-entry-list))) + (dvc-bookmarks-delete-all-marked) + (message "Action aborted")) + (if (yes-or-no-p "Really delete this bookmarks?") + (dvc-bookmarks-delete-at-point) + (message "Action aborted")))) + +(defun dvc-bookmarks-add-empty-tree (name) + "Add a new family to your bookmarks" + (interactive "sName: ") + (let ((child-name (concat "child-" name))) + (if (not (assoc name dvc-bookmark-alist)) + (progn + (add-to-list 'dvc-bookmark-alist + (list name + `(children + (,child-name + (local-tree "~/")))) t) + (ewoc-refresh dvc-bookmarks-cookie)) + (error "Tree %s already exist please choose another name" name))) + (dvc-bookmarks-save) + (dvc-bookmarks)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Marked bookmark code ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar dvc-bookmarks-marked-entry-list nil + "List of marked bookmarks") + +(defun dvc-bookmarks-toggle-mark-entry () + "Mark or unmark the current bookmark entry. +And add it to the `dvc-bookmarks-marked-entry-list'" + (interactive) + (let* ((cur-data (dvc-bookmarks-current-bookmark)) + (bmk-name (dvc-bookmark-name cur-data)) + (has-children (dvc-bookmarks-current-value 'children)) + (is-child (equal (first (split-string (aref cur-data 1) "-")) + "child"))) + ;; (message "bmk-name: %s has-children: %s" bmk-name has-children) + (unless (or has-children + is-child) + (if (member bmk-name dvc-bookmarks-marked-entry-list) + (progn + (message "Unmarking bookmark entry %s" bmk-name) + (setq dvc-bookmarks-marked-entry-list + (remove bmk-name dvc-bookmarks-marked-entry-list))) + (message "Marking bookmark entry %s" bmk-name) + (push bmk-name dvc-bookmarks-marked-entry-list)) + (dvc-bookmarks-goto-next) + (dvc-bookmarks-reload)))) + +(defun dvc-bookmarks-reload () + "Remember the last position and reload dvc-bookmarks" + (let ((last-pos (dvc-bookmark-name (dvc-bookmarks-current-bookmark)))) + (dvc-bookmarks) + (dvc-bookmark-goto-name last-pos))) + +(defun dvc-bookmarks-goto-next () + "Go to next bookmark even if there is +closed tree(s) behind; in this case jump over +partners will not be performed" + (let (flag-fwdl) + (save-excursion + (when (re-search-backward "closed" nil t) + (setq flag-fwdl t))) + (if flag-fwdl + (forward-line 1) + (ewoc-goto-next dvc-bookmarks-cookie 1)))) + +(defun dvc-bookmarks-unmark-all () + "Unmark all bookmarks." + (interactive) + (setq dvc-bookmarks-marked-entry-list nil) + (message "Unmarking all") + (dvc-bookmarks-reload)) + +(defun dvc-bookmarks-marked-p () + (let* ((cur-data (dvc-bookmarks-current-bookmark)) + (bmk-name (dvc-bookmark-name cur-data)) + (has-children (dvc-bookmarks-current-value 'children))) + (unless has-children + (if (member bmk-name dvc-bookmarks-marked-entry-list) + t + nil)))) + +(defun dvc-bookmarks-apply-func-on-marked (fn) + (dolist (i dvc-bookmarks-marked-entry-list) + (dvc-bookmark-goto-name i) + (funcall fn))) + +(defun dvc-bookmarks-delete-all-marked () + (interactive) + (dvc-bookmarks-apply-func-on-marked 'dvc-bookmarks-delete-at-point) + (setq dvc-bookmarks-marked-entry-list nil)) + +(defvar dvc-bookmarks-kill-ring nil) +(defun dvc-bookmarks-kill-all-marked () + "Kill all marked entry and put them in the +`dvc-bookmarks-kill-ring'" + (setq dvc-bookmarks-kill-ring nil) + (dolist (i dvc-bookmarks-marked-entry-list) + (dvc-bookmark-goto-name i) + (dvc-bookmarks-kill-at-point) + (push dvc-bookmarks-tmp-yank-item + dvc-bookmarks-kill-ring))) + +(defun dvc-bookmarks-yank-all-marked-at-point () + "Yank all marked entries at point +and reinit `dvc-bookmarks-kill-ring'" + (if dvc-bookmarks-kill-ring + (progn + (dolist (i dvc-bookmarks-kill-ring) + (setq dvc-bookmarks-tmp-yank-item i) + (dvc-bookmarks-really-yank) + (dvc-bookmark-goto-name (aref i 1))) + (setq dvc-bookmarks-kill-ring nil) + (setq dvc-bookmarks-tmp-yank-item nil)) + (message "Did you forget to kill? (C-k)"))) + +(defun dvc-bookmarks-get-marked-with-name (name) + (when (and dvc-bookmarks-marked-entry-list + (member name dvc-bookmarks-marked-entry-list)) + (save-excursion + (dvc-bookmark-goto-name name) + (dvc-bookmarks-current-bookmark)))) + +(defun dvc-bookmarks-marked-value (key name) + "Get the value of a marked bookmark for key." + (let ((marked-bookmark (dvc-bookmarks-get-marked-with-name name))) + (when marked-bookmark + (dvc-bookmark-value marked-bookmark key)))) + +(defun dvc-bookmarks-hg-convert-from-marked () + "Call `xhg-convert' with current dvc-bookmark as target and +marked dvc-bookmark as source." + (interactive) + (let* ((target (dvc-bookmarks-current-value 'local-tree)) + (cur-dvc (dvc-bookmarks-active-dvc-at-point)) + (marked (car dvc-bookmarks-marked-entry-list)) + (source (dvc-bookmarks-marked-value 'local-tree marked))) + (when (eq cur-dvc 'xhg) + (if (= (length dvc-bookmarks-marked-entry-list) 1) + (if (y-or-n-p (format "Convert <%s> to <%s>?" + source + (propertize target + 'face 'dvc-id))) + (xhg-convert source target)) + (message "Please mark ONE source to convert from!"))))) + +(defun dvc-bookmarks-active-dvc-at-point () + (let ((path (dvc-bookmarks-current-value 'local-tree)) + (current-dvc)) + (save-excursion + (find-file path) + (setq current-dvc (dvc-current-active-dvc)) + (kill-buffer (current-buffer))) + current-dvc)) + +(defun dvc-bookmarks-save () + "Save `dvc-bookmark-alist' to the file `dvc-bookmarks-file-name'." + (interactive) + (dvc-save-state '(dvc-bookmark-alist) + (dvc-config-file-full-path dvc-bookmarks-file-name t) + t)) + +(defun dvc-bookmarks-load-from-file (&optional force) + "Load bookmarks from the file `dvc-bookmarks-file-name'. + +If FORCE is non-nil, reload the file even if it was loaded before." + (when (or force (not dvc-bookmarks-loaded)) + (dvc-load-state (dvc-config-file-full-path + dvc-bookmarks-file-name t)) + (setq dvc-bookmarks-loaded t))) + +(defun dvc-bookmark-name-1 (entry &optional parent-name) + (cond ((assoc 'children entry) + (let ((names)) + (dolist (child (cdr (assoc 'children entry))) + (add-to-list 'names (car (dvc-bookmark-name-1 child (car entry))))) + names)) + (t + (list (concat (if parent-name (concat parent-name "/") "") (car entry)))))) + +(defun dvc-bookmark-names () + "Return a list with all dvc bookmark names." + (let ((names)) + (dolist (entry dvc-bookmark-alist) + (setq names (append names (dvc-bookmark-name-1 entry)))) + names)) + +(defun dvc-bookmark-local-tree-mapping-1 (entry) + (cond ((assoc 'children entry) + (let ((tree-mapping)) + (dolist (child (cdr (assoc 'children entry))) + (add-to-list 'tree-mapping (car (dvc-bookmark-local-tree-mapping-1 child)))) + tree-mapping)) + (t + (list (list (dvc-uniquify-file-name (cadr (assoc 'local-tree (cdr entry)))) (car entry)))))) + +;; (dvc-bookmark-local-tree-mapping) + +(defun dvc-bookmark-local-tree-mapping () + "Return an alist that maps from working copies to bookmark names." + (let ((tree-mapping)) + (dolist (entry dvc-bookmark-alist) + (setq tree-mapping (append tree-mapping (dvc-bookmark-local-tree-mapping-1 entry)))) + tree-mapping)) + + +(defun dvc-bookmark-goto-name (name) + (let ((cur-pos (point)) + (name-list (split-string name "/")) + (prefix "")) + (goto-char (point-min)) + (dolist (name name-list) + (setq name (concat prefix name)) + (setq prefix (concat " " prefix)) + (search-forward name)) + (beginning-of-line-text))) + +(defun dvc-bookmarks-jump () + (interactive) + (dvc-bookmark-goto-name (dvc-completing-read "Jump to dvc bookmark: " + (dvc-bookmark-names)))) + +(defun dvc-bookmarks-get-partner-urls () + (dvc-bookmark-partner-urls (dvc-bookmarks-current-bookmark))) + +(defun dvc-bookmarks-add-partner () + (interactive) + (let* ((cur-data (dvc-bookmarks-current-bookmark)) + (partner-url (read-string (format "Add partner to '%s': " + (dvc-bookmark-name cur-data))))) + (if (not (member partner-url (dvc-bookmarks-get-partner-urls))) + (progn + (setf (dvc-bookmark-properties cur-data) + (append (dvc-bookmark-properties cur-data) + (list (cons 'partner + (make-dvc-bookmark-partner :url partner-url))))) + (dvc-trace "dvc-bookmarks-add-partner %s" cur-data) + (dvc-bookmarks-invalidate-current-bookmark)) + (message "%s is already a partner for %s" + partner-url (dvc-bookmark-name cur-data))))) + +(defun dvc-bookmarks-remove-partner () + (interactive) + (let* ((cur-data (dvc-bookmarks-current-bookmark)) + (partners-alist (dvc-bookmark-partners-by-url cur-data)) + (partner-to-remove (dvc-completing-read + (format "Remove partner from %s: " + (dvc-bookmark-name cur-data)) + (mapcar 'car partners-alist) + nil t nil nil + (dvc-bookmarks-partner-at-point)))) + (setf (dvc-bookmark-properties cur-data) + (delete (cons 'partner (cdr (assoc partner-to-remove partners-alist))) + (dvc-bookmark-properties cur-data))) + (dvc-bookmarks-invalidate-current-bookmark))) + +(defun dvc-bookmarks-toggle-partner-visibility () + (interactive) + (setq dvc-bookmarks-show-partners (not dvc-bookmarks-show-partners)) + (dvc-bookmarks)) + +(defun dvc-bookmarks-partner-at-point (&optional expand-file-name-when-possible) + (save-excursion + (let ((partner-url)) + (goto-char (line-beginning-position)) + (when (looking-at " +Partner \\(.+?\\)\\( \\[.+\\)?$") + (setq partner-url (match-string 1)) + (when (and expand-file-name-when-possible (file-directory-p partner-url)) + (setq partner-url (expand-file-name partner-url)))) + partner-url))) + +(defun dvc-bookmarks-nickname-at-point () + (save-excursion + (let ((nickname)) + (goto-char (line-beginning-position)) + (when (looking-at " +Partner \\(.+?\\) \\[\\(.+\\)?\\]$") + (setq nickname (match-string 2))) + nickname))) + +(defun dvc-bookmarks-add-nickname () + (interactive) + ;;(message "dvc-bookmarks-add-nickname %S" (dvc-bookmarks-current-bookmark)) + (let* ((url-at-point (dvc-bookmarks-partner-at-point)) + (bookmark (dvc-bookmarks-current-bookmark)) + (partner (cdr (assoc url-at-point + (dvc-bookmark-partners-by-url bookmark))))) + (if partner + (progn + (setf (dvc-bookmark-partner-nickname partner) + (read-string (format "Nickname for %s: " url-at-point) + (dvc-bookmark-partner-nickname partner))) + (dvc-bookmarks-invalidate-current-bookmark) + (message "Added nickname %s to the partner %s" + (dvc-bookmark-partner-nickname partner) url-at-point)) + (error "No partner with URL '%s'" url-at-point)))) + +(defun dvc-bookmarks-add-push-location () + (interactive) + (let* ((push-locations (dvc-bookmarks-current-value 'push-locations)) + (cur-data (dvc-bookmarks-current-bookmark)) + (push-location (read-string (format "Add push location to '%s': " (dvc-bookmark-name cur-data))))) + (if (not (member push-location push-locations)) + (progn + (if (null push-locations) + (progn + (setq push-locations (list 'push-locations (list push-location))) + (setf (dvc-bookmark-properties cur-data) + (append (dvc-bookmark-properties cur-data) + (list push-locations)))) + (setcdr push-locations (append (cdr push-locations) + (list push-location))))) + (message "%s is already a push-location for %s" + push-location (dvc-bookmark-name cur-data))))) + +(defun dvc-bookmarks-remove-push-location () + (interactive) + (let* ((push-locations (dvc-bookmarks-current-key-value 'push-locations)) + (cur-data (dvc-bookmarks-current-bookmark)) + (location-to-remove (dvc-completing-read "Remove push location: " (cadr push-locations))) + (new-push-locations (delete location-to-remove (cadr push-locations)))) + (if new-push-locations + (setcdr push-locations (list new-push-locations)) + (setf (dvc-bookmark-properties cur-data) + (delete push-locations (dvc-bookmark-properties cur-data)))))) + +;;;###autoload +(defun dvc-bookmarks-current-push-locations () + (let* ((tree-mapping (dvc-bookmark-local-tree-mapping)) + (bookmark-name (cadr (assoc (dvc-tree-root) tree-mapping))) + (push-locations)) + (when bookmark-name + (save-window-excursion + (with-current-buffer "*dvc-bookmarks*" + (dvc-bookmark-goto-name bookmark-name) + (setq push-locations (dvc-bookmarks-current-value 'push-locations))))) + ;;(message "bookmark-name: %s -> push-locations: %S" bookmark-name push-locations) + push-locations)) + + +;; (dvc-bookmarks-load-from-file t) + +(provide 'dvc-bookmarks) +;;; dvc-bookmarks.el ends here diff --git a/dvc/lisp/dvc-buffers.el b/dvc/lisp/dvc-buffers.el new file mode 100644 index 0000000..86ac642 --- /dev/null +++ b/dvc/lisp/dvc-buffers.el @@ -0,0 +1,747 @@ +;;; dvc-buffers.el --- Buffer management for DVC + +;; Copyright (C) 2005-2009 by all contributors + +;; Author: Matthieu Moy +;; Contributions from: +;; Stefan Reichoer, + +;; 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. + +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' + (let ((return-buffer + (let* ((path (or path default-directory)) + (elem (assoc type dvc-buffer-type-alist)) + (mode (car (cddr elem)))) + (or (dvc-get-buffer dvc type path mode) + ;; Buffer couldn't be reused. Create one + (let ((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)))) + (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 + (or (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 (file-truename 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)) + +(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 diff --git a/dvc/lisp/dvc-bug.el b/dvc/lisp/dvc-bug.el new file mode 100644 index 0000000..6853250 --- /dev/null +++ b/dvc/lisp/dvc-bug.el @@ -0,0 +1,87 @@ +;;; 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 diff --git a/dvc/lisp/dvc-build.el b/dvc/lisp/dvc-build.el new file mode 100644 index 0000000..f775d8b --- /dev/null +++ b/dvc/lisp/dvc-build.el @@ -0,0 +1,411 @@ +;;; dvc-build.el --- compile-time helper. + +;; Copyright (C) 2004-2008 by all contributors + +;; Author: Matthieu Moy +;; Thien-Thi Nguyen +;; Inspired from the work of Steve Youngs + +;; 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) + (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 diff --git a/dvc/lisp/dvc-cmenu.el b/dvc/lisp/dvc-cmenu.el new file mode 100644 index 0000000..96ade46 --- /dev/null +++ b/dvc/lisp/dvc-cmenu.el @@ -0,0 +1,121 @@ +;;; 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 diff --git a/dvc/lisp/dvc-config.el b/dvc/lisp/dvc-config.el new file mode 100644 index 0000000..af02de3 --- /dev/null +++ b/dvc/lisp/dvc-config.el @@ -0,0 +1,54 @@ +;;; 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 diff --git a/dvc/lisp/dvc-core.el b/dvc/lisp/dvc-core.el new file mode 100644 index 0000000..0a10749 --- /dev/null +++ b/dvc/lisp/dvc-core.el @@ -0,0 +1,1205 @@ +;;; dvc-core.el --- Core functions for distributed version control + +;; Copyright (C) 2005-2009 by all contributors + +;; Author: Stefan Reichoer, +;; Contributions From: +;; Matthieu Moy + +;; 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. + + +;;; History: + +;; This file holds general useful functions, previously only used for tla. + +;;; Code: + +(require 'dvc-defs) +(require 'dvc-register) +(eval-and-compile (require 'dvc-utils)) +(require 'dvc-buffers) +(eval-when-compile (require 'cl)) +(eval-when-compile (require 'dired)) +(eval-and-compile (require 'dvc-lisp)) + +(defvar dvc-sh-executable "sh" "The shell that is used for dvc interaction.") + +;; -------------------------------------------------------------------------------- +;; Various constants +;; -------------------------------------------------------------------------------- + +(defconst dvc-mark (dvc-face-add "*" 'dvc-mark) "Fontified string used for marking.") +(defconst dvc-exclude (dvc-face-add "E" 'dvc-mark) "Fontified string used for excluded files.") + +;; -------------------------------------------------------------------------------- +;; Internal variables +;; -------------------------------------------------------------------------------- + +(defvar dvc-memorized-log-header nil) +(defvar dvc-memorized-log-message nil) +(defvar dvc-memorized-version nil) +(defvar dvc-memorized-patch-sender nil) + +;; -------------------------------------------------------------------------------- +;; Various helper functions +;; -------------------------------------------------------------------------------- + +;; list-buffers-directory is used by uniquify to get the directory for +;; the buffer when buffer-file-name is nil, as it is for many dvc +;; buffers (dvc-diff-mode, etc). It needs to survive +;; kill-all-local-variables, so we declare it permanent local. +(make-variable-buffer-local 'list-buffers-directory) +(put 'list-buffers-directory 'permanent-local t) + +(defun dvc-find-tree-root-file-first (file-or-dir &optional location) + "Find FILE-OR-DIR upward in the file system from LOCATION. +Finding is continued upward to \"/\" until FILE-OR-DIR can be found. +Once FILE-OR-DIR is found, the finding is broken off. +A directory which holds FILE-OR-DIR is returned. If no such directory +`nil' is returned. `default-directory' is used instead if LOCATION is not +given, + +The resulting directory is guaranteed to end in a \"/\" character. + +This function may be useful to find \{arch\} and/or _darcs directories." + (let ((pwd (or location default-directory)) + (pwd-stack nil) + new-pwd) + (while (not (or (string= pwd "/") + (member pwd pwd-stack) + (file-exists-p (concat (file-name-as-directory pwd) + file-or-dir)))) + (setq pwd-stack (cons pwd pwd-stack)) + (setq new-pwd + (dvc-expand-file-name (concat (file-name-as-directory pwd) ".."))) + + ;; detect MS-Windows roots (c:/, d:/, ...) + (setq pwd (if (string= new-pwd pwd) "/" new-pwd))) + + (unless (string= pwd "/") + (setq pwd (replace-regexp-in-string "\\([^:]\\)/*$" "\\1" pwd)) + (setq pwd (file-name-as-directory pwd)) + (if (memq system-type '(ms-dos windows-nt)) + (expand-file-name pwd) + pwd)))) + +(defun dvc-tree-root-helper (file-or-dir interactivep msg + &optional location no-error) + "Find FILE-OR-DIR upward in the file system from LOCATION. + +Calls `dvc-find-tree-root-file-first', shows a message when +called interactively, and manages no-error. + +If LOCATION is nil, the tree root is returned, and it is +guaranteed to end in a \"/\" character. + +MSG must be of the form \"%S is not a ...-managed tree\"." + (let ((location (dvc-uniquify-file-name location))) + (let ((pwd (dvc-find-tree-root-file-first + file-or-dir location))) + (when (and interactivep pwd) + (dvc-trace "%s" pwd)) + (or pwd + (if no-error + nil + (error msg + (or location default-directory))))))) + +(defun dvc-find-tree-root-file-last (file-or-dir &optional location) + "Like `dvc-find-tree-root-file-upward' but recursively if FILE-OR-DIR is found. +Finding is started from LOCATION but is stoped when FILE-OR-DIR cannot be found. +Fiddled is continued upward while FILE-OR-DIR can be found. +The last found directory which holds FILE-OR-DIR is returned. `nil' is returned +if finding failed. +`default-directory' is used instead if LOCATION is not given, + +This function may be useful to find CVS or .svn directories" + (let ((pwd (or location default-directory)) + old-pwd) + (while (and pwd (not (string= pwd "/"))) + (if (file-exists-p (concat (file-name-as-directory pwd) + file-or-dir)) + (setq old-pwd pwd + pwd (expand-file-name (concat (file-name-as-directory pwd) + ".."))) + (setq pwd nil))) + (when old-pwd + (expand-file-name + (replace-regexp-in-string "/+$" "/" old-pwd))))) + +(defmacro dvc-make-bymouse-function (function) + "Create a new function by adding mouse interface to FUNCTION. +The new function is named FUNCTION-by-mouse; and takes one argument, +a mouse click event. +Thew new function moves the point to the place where mouse is clicked +then invoke FUNCTION." + (declare (debug (&define name :name -by-mouse))) + `(defun ,(intern (concat (symbol-name function) "-by-mouse")) (event) + ,(concat "`" (symbol-name function) "'" " with mouse interface.") + (interactive "e") + (mouse-set-point event) + (,function))) + +;; Adapted from `dired-delete-file' in Emacs 22 +(defun dvc-delete-recursively (file) + "Delete FILE or directory recursively." + (let (files) + (if (not (eq t (car (file-attributes file)))) + (delete-file file) + (when (setq files + (directory-files + file t "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*")) + (while files + (dvc-delete-recursively (car files)) + (setq files (cdr files)))) + (delete-directory file)))) + +;; -------------------------------------------------------------------------------- +;; File selection helpers +;; -------------------------------------------------------------------------------- + +(defvar dvc-get-file-info-at-point-function nil + "Function used to get the file at point, anywhere.") + +(defun dvc-get-file-info-at-point () + "Gets the filename at point, according to mode. +Calls the function `dvc-get-file-info-at-point-function' if defined. +When in dired mode, return the file where point is. +Otherwise return the buffer file name." + (cond (dvc-get-file-info-at-point-function + (funcall dvc-get-file-info-at-point-function)) + ((eq major-mode 'dired-mode) + (dired-get-filename)) + (t (buffer-file-name)))) + +;;;###autoload +(defun dvc-current-file-list (&optional selection-mode) + "Return a list of currently active files. +When in dired mode, return the marked files or the file under point. +In a legacy DVC mode, return `dvc-buffer-marked-file-list' if non-nil. +In a fileinfo DVC mode, return `dvc-fileinfo-marked-files'. +otherwise the result depends on SELECTION-MODE: +* When 'nil-if-none-marked, return nil. +* When 'all-if-none-marked, return all files. +* Otherwise return result of calling `dvc-get-file-info-at-point'." + (cond + ((eq major-mode 'dired-mode) + (dired-get-marked-files)) + + ((dvc-derived-mode-p 'dvc-diff-mode 'dvc-status-mode) + (or (remove nil dvc-buffer-marked-file-list) + (dvc-fileinfo-marked-files) + (cond + ((eq selection-mode 'nil-if-none-marked) + nil) + + ((eq selection-mode 'all-if-none-marked) + (dvc-fileinfo-all-files)) + + (t (list (dvc-get-file-info-at-point)))))) + + ((eq major-mode 'dvc-bookmark-mode) + (cond + ((eq selection-mode 'nil-if-none-marked) + nil) + + (t + (error "selection-mode %s not implemented for dvc bookmark buffer" selection-mode)))) + + ;; If other modes are added here, dvc-log-edit must be updated to + ;; support them as well. + + (t + ;; Some other mode. We assume it has no notion of "marked files", + ;; so there are none marked. The only file name available is + ;; buffer-file-name, so we could just return that. But some DVC + ;; mode might set dvc-get-file-info-at-point-function without + ;; updating this function, so support that. + (if (eq selection-mode 'nil-if-none-marked) + nil + (list (dvc-get-file-info-at-point)))))) + +(defun dvc-confirm-read-file-name (prompt &optional mustmatch file-name default-filename) + "A wrapper around `read-file-name' that provides some useful defaults." + (unless file-name + (setq file-name (dvc-get-file-info-at-point))) + (read-file-name prompt + (file-name-directory (or file-name "")) + default-filename + mustmatch + (file-name-nondirectory (or file-name "")))) + +(defun dvc-confirm-read-file-name-list (prompt &optional files single-prompt mustmatch) + (or + (if dvc-test-mode files) + (let ((num-files (length files))) + (if (= num-files 1) + (let ((confirmed-file-name + (dvc-confirm-read-file-name single-prompt mustmatch (car files)))) + ;; I don't think `dvc-confirm-read-file-name' can return nil. + (assert confirmed-file-name) + (list confirmed-file-name)) + (and (y-or-n-p (format prompt num-files)) + files))))) + +(defcustom dvc-confirm-file-op-method 'y-or-n-p + "Function to use for confirming file-based DVC operations. +Some valid options are: +y-or-n-p: Prompt for 'y' or 'n' keystroke. +yes-or-no-p: Prompt for \"yes\" or \"no\" string. +dvc-always-true: Do not display a prompt." + :type 'function + :group 'dvc) + +(defun dvc-always-true (&rest ignore) + "Do nothing and return t. +This function accepts any number of arguments, but ignores them." + (interactive) + t) + +(defun dvc-confirm-file-op (operation files confirm) + "Confirm OPERATION (a string, used in prompt) on FILE (list of strings). +If CONFIRM is nil, just return FILES (no prompt). +Returns FILES, or nil if not confirmed. + +If you want to adjust the function called to confirm the +operation, then customize the `dvc-confirm-file-op-method' function." + (or + ;; Allow bypassing confirmation with `dvc-test-mode'. See + ;; tests/xmtn-tests.el dvc-status-add. + (if dvc-test-mode files) + ;; Abstracted from pcvs.el cvs-do-removal + (if (not confirm) + files + (let ((nfiles (length files))) + (if (funcall (or (and (functionp dvc-confirm-file-op-method) + dvc-confirm-file-op-method) + 'y-or-n-p) + (if (= 1 nfiles) + (format "%s file: \"%s\" ? " + operation + (car files)) + (format "%s %d files? " + operation + nfiles))) + files + nil))))) + +(defun dvc-dvc-files-to-commit () + ;;todo: set the correct modifier, one of dvc-modified, dvc-added, dvc-move, now use only nil + ;; FIXME: this is only used by dvc-log-insert-commit-file-list; should just merge this code there. + (let ((files + (with-current-buffer dvc-partner-buffer (dvc-current-file-list 'all-if-none-marked)))) + (mapcar (lambda (arg) (cons nil arg)) files))) + +(defun dvc-find-file-at-point () + "Opens the file at point. +The filename is obtained with `dvc-get-file-info-at-point'." + (interactive) + (let* ((file (dvc-get-file-info-at-point))) + (cond + ((not file) + (error "No file at point")) + (t + (find-file file))))) + +(dvc-make-bymouse-function dvc-find-file-at-point) + +(defun dvc-find-file-other-window () + "Visit the current file in the other window. +The filename is obtained with `dvc-get-file-info-at-point'." + (interactive) + (let ((file (dvc-get-file-info-at-point))) + (if file + (progn + (find-file-other-window file)) + (error "No file at point")))) + +(defun dvc-view-file () + "Visit the current file in `view-mode'. +The filename is obtained with `dvc-get-file-info-at-point'." + (interactive) + (let ((file (dvc-get-file-info-at-point))) + (if file + (view-file-other-window file) + (error "No file at point")))) + +(defun dvc-dired-jump () + "Jump to a dired buffer, containing the file at point." + (interactive) + (let ((file-full-path (expand-file-name (or (dvc-get-file-info-at-point) "")))) + (let ((default-directory (file-name-directory file-full-path))) + (dvc-funcall-if-exists dired-jump)) + (dired-goto-file file-full-path))) + +(defun dvc-purge-files (&rest files) + "Delete FILES from the harddisk. No backup is created for these FILES. +These function bypasses the used revision control system." + (interactive (dvc-current-file-list)) + (let ((multiprompt (format "Are you sure to purge %%d files? ")) + (singleprompt (format "Purge file: "))) + (when (dvc-confirm-read-file-name-list multiprompt files singleprompt nil) + (mapcar #'delete-file files) + (message "Purged %S" files)))) + +(defun dvc-current-executable () + "Return the name of the binary associated with the current dvc backend. +This uses `dvc-current-active-dvc'. + +\"DVC\" is returned if `dvc-current-active-dvc' returns nil." + (let ((dvc (dvc-current-active-dvc))) + (if (not dvc) + "DVC" + (dvc-variable dvc "executable")))) + +;; partner buffer stuff +(defvar dvc-partner-buffer nil + "DVC Partner buffer; stores diff buffer for log-edit, etc. +Local to each buffer, not killed by kill-all-local-variables.") +(make-variable-buffer-local 'dvc-partner-buffer) +(put 'dvc-partner-buffer 'permanent-local t) + +(defun dvc-buffer-pop-to-partner-buffer () + "Pop to dvc-partner-buffer, if available." + (interactive) + (if (and (boundp 'dvc-partner-buffer) dvc-partner-buffer) + (if (buffer-live-p dvc-partner-buffer) + (pop-to-buffer dvc-partner-buffer) + (message "Partner buffer has been killed")) + (message "No partner buffer set for this buffer."))) + + +(defmacro dvc-with-keywords (keywords plist &rest body) + "Execute a body of code with keywords bound. +Each keyword listed in KEYWORDS is bound to its value from PLIST, then +BODY is evaluated." + (declare (indent 1) (debug (sexp form body))) + (flet ((keyword-to-symbol (keyword) + (intern (substring (symbol-name keyword) 1)))) + (let ((keyword (make-symbol "keyword")) + (default (make-symbol "default"))) + `(let ,(mapcar (lambda (keyword-entry) + (keyword-to-symbol (if (consp keyword-entry) + (car keyword-entry) + keyword-entry))) + keywords) + (dolist (keyword-entry ',keywords) + (let ((,keyword (if (consp keyword-entry) + (car keyword-entry) + keyword-entry)) + (,default (if (consp keyword-entry) + (cadr keyword-entry) + nil))) + (set (intern (substring (symbol-name ,keyword) 1)) + (or (cadr (member ,keyword ,plist)) + ,default)))) + ,@body)))) + + +;; ---------------------------------------------------------------------------- +;; Process management +;; ---------------------------------------------------------------------------- + +;; Candidates for process handlers +(defun dvc-default-error-function (output error status arguments) + "Default function called when a DVC process ends with a non-zero status. +OUTPUT is the buffer containing process standard output. +ERROR is the buffer containing process error output. +STATUS indicates the return status of the program. +ARGUMENTS is a list of the arguments that the process was called with." + (if (> (with-current-buffer error (point-max)) 1) + (dvc-show-error-buffer error) + (if (> (with-current-buffer output (point-max)) 1) + (dvc-show-error-buffer output) + (error "`%s %s' failed with code %d and no output!" + (dvc-current-executable) + (mapconcat 'identity arguments " ") + status))) + (error "`%s %s' failed with code %d" + (dvc-current-executable) + (mapconcat 'identity arguments " ") + status)) + +(defvar dvc-default-killed-function-noerror 0 + "The number of killed processes we will ignore until throwing an error. +If the value is 0, `dvc-default-killed-function' will throw an error. +See `dvc-default-killed-function'.") + +(defun dvc-default-killed-function (output error status arguments) + "Default function called when a DVC process is killed. +OUTPUT is the buffer containing process standard output. +ERROR is the buffer containing process error output. +STATUS indicates the return status of the program. +ARGUMENTS is a list of the arguments that the process was called with." + (if (> dvc-default-killed-function-noerror 0) + (setq dvc-default-killed-function-noerror + (- dvc-default-killed-function-noerror 1)) + (dvc-switch-to-buffer error) + (error "`%s %s' process killed !" + (dvc-current-executable) + (mapconcat 'identity arguments " ")))) + +(defun dvc-null-handler (output error status arguments) + "Handle a finished process without doing anything. +Candidate as an argument for one of the keywords :finished, :error or :killed +in `dvc-run-dvc-sync' or `dvc-run-dvc-async'. +OUTPUT is the buffer containing process standard output. +ERROR is the buffer containing process error output. +STATUS indicates the return status of the program. +ARGUMENTS is a list of the arguments that the process was called with." + nil) + +(defun dvc-status-handler (output error status arguments) + "Return an integer value that reflects the process status. +Candidate as an argument for one of the keywords :finished, :error or :killed +in `dvc-run-dvc-sync' or `dvc-run-dvc-async'. +OUTPUT is the buffer containing process standard output. +ERROR is the buffer containing process error output. +STATUS indicates the return status of the program. +ARGUMENTS is a list of the arguments that the process was called with." + (cond ((numberp status) status) + ((string-match "^exited abnormally with code \\(.*\\)" status) + (string-to-number (match-string 1))) + (t (error status)))) + +(defun dvc-output-buffer-handler (output error status arguments) + "Return the output of a finished process, stripping any trailing newline. +OUTPUT is the buffer containing process standard output. +ERROR is the buffer containing process error output. +STATUS indicates the return status of the program. +ARGUMENTS is a list of the arguments that the process was called with." + (dvc-buffer-content output)) + +(defun dvc-output-buffer-handler-withnewline (output error status arguments) + "Same as dvc-output-buffer-handler, but keep potential final newline." + (with-current-buffer output (buffer-string))) + +(defun dvc-output-and-error-buffer-handler (output error status arguments) + "Return the output of a finished process, stripping any trailing newline. +OUTPUT is the buffer containing process standard output. +ERROR is the buffer containing process error output. +STATUS indicates the return status of the program. +ARGUMENTS is a list of the arguments that the process was called with." + (concat (dvc-buffer-content output) + (dvc-buffer-content error))) + +(defun dvc-output-buffer-split-handler (output error status arguments) + "Return the output of a finished process as a list of lines. +OUTPUT is the buffer containing process standard output. +ERROR is the buffer containing process error output. +STATUS indicates the return status of the program. +ARGUMENTS is a list of the arguments that the process was called with." + (split-string (dvc-buffer-content output) "\n")) + +(defun dvc-default-finish-function (output error status arguments) + "Default function called when a DVC process terminates. +OUTPUT is the buffer containing process standard output. +ERROR is the buffer containing process error output. +STATUS indicates the return status of the program. +ARGUMENTS is a list of the arguments that the process was called with." + (let ((has-output)) + (with-current-buffer output + (dvc-process-buffer-mode) + (setq has-output (> (point-max) 1))) + (when has-output + (dvc-switch-to-buffer output)) + (when (or dvc-debug has-output) + (message "Process `%s %s' finished" + (dvc-current-executable) + (mapconcat 'identity arguments " "))) + status)) + +(defun dvc-finish-function-without-buffer-switch (output error status arguments) + "Similar to `dvc-default-finish-function' but no buffer switch. +OUTPUT is the buffer containing process standard output. +ERROR is the buffer containing process error output. +STATUS indicates the return status of the program. +ARGUMENTS is a list of the arguments that the process was called + with." + (with-current-buffer output + (dvc-trace "Process `%s %s' finished" + (dvc-current-executable) + (mapconcat 'identity arguments " ")) + status)) + +(defvar dvc-process-running nil + "List of DVC processes running. +A value of nil indicates no processes are running. + +The list is a list of pairs (process event) where EVENT is the event +corresponding to the beginning of the execution of process. It can be +used to get more info about the process.") + +(defun dvc-build-dvc-command (dvc list-args) + "Build a shell command to run DVC with args LIST-ARGS. +DVC can be one of 'baz, 'xhg, ..." + (let ((executable (executable-find (dvc-variable dvc "executable")))) + ;; 'executable-find' allows leading ~ + (if (not executable) + (error "executable for %s not found" (symbol-name dvc))) + (mapconcat 'shell-quote-argument + (cons executable + (remq nil list-args)) + " "))) + +(defcustom dvc-password-prompt-regexp + "[Pp]ass\\(word\\|phrase\\).*:\\s *\\'" + "*Regexp matching prompts for passwords in the inferior process." + :type 'regexp + :group 'dvc) + +(defun dvc-process-filter (proc string &optional no-insert) + "Filter PROC's STRING. +Prompt for password with `read-passwd' if the output of PROC matches +`dvc-password-prompt-regexp'. + +If NO-INSERT is non-nil, do not insert the string. + +In all cases, a new string is returned after normalizing newlines." + (with-current-buffer (process-buffer proc) + (setq string (replace-regexp-in-string "\015" "\n" string)) + (unless no-insert + (goto-char (process-mark proc)) + (insert string) + (set-marker (process-mark proc) (point))) + (when (string-match dvc-password-prompt-regexp string) + (string-match "^\\([^\n]+\\)\n*\\'" string) + (let ((passwd (read-passwd (match-string 1 string)))) + (process-send-string proc (concat passwd "\n")))) + string)) + +(defun dvc-prepare-environment (env) + "By default, do not touch the environment" + env) + +(defun dvc-default-global-argument () + "By default, no global argument." + nil) + +(defun dvc-run-dvc-async (dvc arguments &rest keys) + "Run a process asynchronously. +Current directory for the process is the current `default-directory'. +ARGUMENTS is a list of arguments. nil values in this list are removed. +KEYS is a list of keywords and values. Possible keywords are: + + :finished ....... Function run when the process finishes. If none + specified, `dvc-default-finish-function' is run. + + :killed ......... Function run when the process is killed. If none + specified, `dvc-default-killed-function' is run. + + :error .......... Function run when the process exits with a non 0 + status. If none specified, + `dvc-default-error-function' is run. + +All these functions take 4 arguments : output, error, status, and +arguments. + + - \"output\" is the output buffer + - \"error\" is the buffer where standard error is redirected + - \"status\" is the numeric exit-status or the signal number + - \"arguments\" is the list of arguments, as a list of strings, + like '(\"changes\" \"--diffs\") + + `dvc-null-handler' can be used here if there's nothing to do. + + :filter Function to call every time we receive output from + the process. It should take arguments proc and string. + The string will have been run through + `dvc-process-filter' to deal with password prompts and + newlines. + + :output-buffer .. Buffer where the output of the process should be + redirected. If none specified, a new one is + created, and will be entered in + `dvc-dead-process-buffer-queue' to be killed + later. + + :error-buffer ... Buffer where the standard error of the process + should be redirected. + + :related-buffer . Defaults to `current-buffer'. This is the buffer + where the result of the process will be used. If + this buffer is killed before the end of the + execution, the user is prompted if he wants to kill + the process." + (dvc-with-keywords + (:finished :killed :error :filter + :output-buffer :error-buffer :related-buffer) + keys + (let* ((output-buf (or (and output-buffer + (get-buffer-create output-buffer)) + (dvc-new-process-buffer nil dvc))) + (error-buf (or (and error-buffer (get-buffer-create error-buffer)) + (dvc-new-error-buffer nil dvc))) + (error-file (dvc-make-temp-name "dvc-errors")) + (global-arg (funcall (dvc-function dvc "default-global-argument"))) + (command (dvc-build-dvc-command + dvc (append global-arg arguments))) + ;; Make the `default-directory' unique. The trailing slash + ;; may be necessary in some cases. + (default-directory (dvc-uniquify-file-name default-directory)) + (process + (let ((process-environment + (funcall (dvc-function dvc "prepare-environment") + process-environment))) + (with-current-buffer output-buf + ;; process filter will need to know which dvc to run + ;; if there is a choice + (setq dvc-buffer-current-active-dvc dvc)) + + ;; `start-process' sends both stderr and stdout to + ;; `output-buf'. But we want to keep stderr separate. So + ;; we use a shell to redirect stderr before Emacs sees + ;; it. Note that this means we require "sh" even on + ;; MS Windows. + (start-process + (dvc-variable dvc "executable") output-buf + dvc-sh-executable "-c" + (format "%s 2> %s" + command error-file)))) + (process-event + (list process + (dvc-log-event output-buf + error-buf + command + default-directory "started")))) + (with-current-buffer (or related-buffer (current-buffer)) + (dvc-trace "Running process `%s' in `%s'" command default-directory) + (add-to-list 'dvc-process-running process-event) + (set-process-filter + process + (if (not filter) + 'dvc-process-filter + (dvc-capturing-lambda (proc string) + (funcall (capture filter) + proc + (dvc-process-filter proc string t))))) + (set-process-sentinel + process + (dvc-capturing-lambda (process event) + (let ((default-directory (capture default-directory))) + (dvc-log-event (capture output-buf) (capture error-buf) + (capture command) + (capture default-directory) + (dvc-strip-final-newline event)) + (setq dvc-process-running + (delq (capture process-event) dvc-process-running)) + (when (file-exists-p (capture error-file)) + (with-current-buffer (capture error-buf) + (insert-file-contents (capture error-file))) + (delete-file (capture error-file))) + (let ((state (process-status process)) + (status (process-exit-status process)) + (dvc-temp-current-active-dvc (capture dvc))) + (unwind-protect + (cond ((and (eq state 'exit) (= status 0)) + (funcall (or (capture finished) + 'dvc-default-finish-function) + (capture output-buf) (capture error-buf) + status (capture arguments))) + ((eq state 'signal) + (funcall (or (capture killed) + 'dvc-default-killed-function) + (capture output-buf) (capture error-buf) + status (capture arguments))) + ((eq state 'exit) ;; status != 0 + (funcall (or (capture error) + 'dvc-default-error-function) + (capture output-buf) (capture error-buf) + status (capture arguments))))) + ;; Schedule any buffers we created for killing + (unless (capture output-buffer) + (dvc-kill-process-buffer (capture output-buf))) + (unless (capture error-buffer) + (dvc-kill-process-buffer (capture error-buf))))))) + process)))) + +(defun dvc-run-dvc-sync (dvc arguments &rest keys) + "Run DVC synchronously. +See `dvc-run-dvc-async' for details on possible ARGUMENTS and KEYS." + (dvc-with-keywords + (:finished :killed :error :output-buffer :error-buffer :related-buffer) + keys + (let* ((output-buf (or (and output-buffer + (get-buffer-create output-buffer)) + (dvc-new-process-buffer t dvc))) + (error-buf (or (and error-buffer (get-buffer-create error-buffer)) + (dvc-new-error-buffer t dvc))) + (global-arg (funcall (dvc-function dvc "default-global-argument"))) + (command (dvc-build-dvc-command + dvc (append global-arg arguments))) + (arguments (remq nil arguments)) + (error-file (dvc-make-temp-name "arch-errors")) + ;; Make the `default-directory' unique. The trailing slash + ;; may be necessary in some cases. + (default-directory (dvc-uniquify-file-name default-directory))) + (with-current-buffer (or related-buffer (current-buffer)) + (dvc-log-event output-buf error-buf command default-directory + "started") + (let ((status (let ((process-environment + (funcall (dvc-function dvc "prepare-environment") + process-environment))) + (call-process dvc-sh-executable nil output-buf nil "-c" + (format "%s 2> %s" + command + error-file))))) + (when (file-exists-p error-file) + (with-current-buffer error-buf + (insert-file-contents error-file)) + (delete-file error-file)) + (unwind-protect + (let ((dvc-temp-current-active-dvc dvc)) + (cond ((stringp status) + (when (string= status "Terminated") + (funcall (or killed 'dvc-default-killed-function) + output-buf error-buf status arguments))) + ((numberp status) + (if (zerop status) + (funcall (or finished 'dvc-default-finish-function) + output-buf error-buf status arguments) + (funcall (or error 'dvc-default-error-function) + output-buf error-buf status arguments))) + (t (message "Unknown status - %s" status)))) + ;; Schedule any buffers we created for killing + (unless output-buffer (dvc-kill-process-buffer output-buf)) + (unless error-buffer (dvc-kill-process-buffer error-buf)))))))) + +(defun dvc-processes-related-to-buffer (buffer) + "Returns a list of DVC process whose related buffer is BUFFER." + (let ((accu nil)) + (dolist (entry dvc-process-running) + (when (eq (dvc-event-related-buffer (cadr entry)) buffer) + (push (car entry) accu))) + (setq accu (nreverse accu)) + accu)) + +(defun dvc-kill-process-maybe (buffer) + "Prompts and possibly kill process whose related buffer is BUFFER." + ;; FIXME: It would be reasonable to run this here, to give any + ;; process one last chance to run. But somehow this screws up + ;; package-maint-clean-some-elc. (accept-process-output) + (let* ((processes (dvc-processes-related-to-buffer buffer)) + (l (length processes))) + (when (and processes + (y-or-n-p (format "%s process%s running in buffer %s. Kill %s? " + l (if (= l 1) "" "es") + (buffer-name buffer) + (if (= l 1) "it" "them")))) + (dolist (process processes) + (when (eq (process-status process) 'run) + (incf dvc-default-killed-function-noerror) + (kill-process process))))) + ;; make sure it worked + (let ((processes (dvc-processes-related-to-buffer buffer))) + (when processes + (error "Process still running in buffer %s" buffer)))) + +(add-hook 'kill-buffer-hook 'dvc-kill-buffer-function) + +(defun dvc-kill-buffer-function () + "Function run when a buffer is killed." + (dvc-buffers-tree-remove (current-buffer)) + (dvc-kill-process-maybe (current-buffer))) + +(defun dvc-run-dvc-display-as-info (dvc arg-list &optional show-error-buffer info-string asynchron) + "Call either `dvc-run-dvc-async' or `dvc-run-dvc-sync' and display the result in an info buffer. +When INFO-STRING is given, insert it at the buffer beginning." + (let ((buffer (dvc-get-buffer-create dvc 'info))) + (funcall (if asynchron 'dvc-run-dvc-async 'dvc-run-dvc-sync) dvc arg-list + :finished + (dvc-capturing-lambda (output error status arguments) + (progn + (with-current-buffer (capture buffer) + (let ((inhibit-read-only t)) + (erase-buffer) + (dvc-info-buffer-mode) + (when (capture info-string) + (insert (capture info-string))) + (insert-buffer-substring output) + (when (capture show-error-buffer) + (insert-buffer-substring error)) + (toggle-read-only 1))) + (dvc-switch-to-buffer (capture buffer))))))) + +(defvar dvc-info-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 a dvc info buffer.") + +(define-derived-mode dvc-info-buffer-mode fundamental-mode + "DVC info mode" + "Major mode for dvc info buffers" + (dvc-install-buffer-menu) + (toggle-read-only 1)) + + +(defvar dvc-log-cookie nil) + +(defstruct (dvc-event) output-buffer error-buffer related-buffer + command tree event time) + +(defsubst dvc-log-printer-print-buffer (buffer function) + "Helper function for `dvc-log-printer'. +Print a buffer filed for BUFFER during printing a log event. +The printed name of BUFFER is mouse sensitive. If the user +clicks it, FUNCTION is invoked." + (let ((alive-p (buffer-live-p buffer)) + map) + (dvc-face-add + (or + ;; pp-to-string is very costly. + ;; Handle the typical case with hard-coding. + (unless alive-p "#") + ;; Normal case. + (buffer-name buffer) + ;; Extra case. + (pp-to-string buffer)) + 'dvc-buffer + (when alive-p + (setq map (make-sparse-keymap)) + (define-key map [mouse-2] function) + map) + nil + "Show the buffer"))) + +(defun dvc-log-recently-p (elem limit-minute) + "Check ELEM recorded a recent event or not. +Return nil If ELEM recorded an event older than LIMIT-MINUTE. +Else return t." + (let* ((recorded (dvc-event-time elem)) + (cur (current-time)) + (diff-minute (/ (+ (* 65536 (- (nth 0 cur) + (nth 0 recorded))) + (- (nth 1 cur) + (nth 1 recorded))) + 60))) + (if (> limit-minute diff-minute) + t + nil))) + +(defun dvc-log-printer (elem) + "Arch event printer which prints ELEM." + (let ((event (dvc-event-event elem)) + (p (point))) + (insert + "Command: " (dvc-event-command elem) + "\nDirectory: " (dvc-face-add (or (dvc-event-tree elem) "(nil)") + 'dvc-local-directory) + "\nDate: " (format-time-string "%c" (dvc-event-time elem)) + "\nRelated Buffer: " (dvc-log-printer-print-buffer + (dvc-event-related-buffer elem) + 'dvc-switch-to-related-buffer-by-mouse) + "\nOutput Buffer: " (dvc-log-printer-print-buffer + (dvc-event-output-buffer elem) + 'dvc-switch-to-output-buffer-by-mouse) + "\nError Buffer: " (dvc-log-printer-print-buffer + (dvc-event-error-buffer elem) + 'dvc-switch-to-error-buffer-by-mouse) + (if (not (string= event "started")) + (concat "\nEvent: " event) + "") + "\n") + ;; Reflect the point to `default-directory'. + ;; NOTE: XEmacs doesn't have `point-entered' special text property. + (put-text-property + p (point) + 'point-entered (lambda (old new) + (setq default-directory + (dvc-event-tree + (ewoc-data + (ewoc-locate dvc-log-cookie)))))))) + +(defmacro dvc-switch-to-buffer-macro (function accessor) + "Define a FUNCTION for switching to the buffer associated with some event. +ACCESSOR is a function for retrieving the appropriate buffer from a +`dvc-event' structure." + (declare (debug (&define name symbolp))) + `(defun ,function () + "In a log buffer, pops to the output or error buffer corresponding to the +process at point" + (interactive) + (let ((buffer (,accessor + (ewoc-data (ewoc-locate dvc-log-cookie))))) + (cond ((buffer-live-p buffer) + (dvc-switch-to-buffer buffer) + (unless (member buffer + (mapcar (lambda (p) + (process-buffer (car p))) + dvc-process-running)) + (dvc-process-buffer-mode))) + (t (error "Buffer has been killed")))))) + +(dvc-switch-to-buffer-macro dvc-switch-to-output-buffer + dvc-event-output-buffer) + +(dvc-switch-to-buffer-macro dvc-switch-to-error-buffer + dvc-event-error-buffer) + +(dvc-switch-to-buffer-macro dvc-switch-to-related-buffer + dvc-event-related-buffer) + +(dvc-make-bymouse-function dvc-switch-to-output-buffer) +(dvc-make-bymouse-function dvc-switch-to-error-buffer) +(dvc-make-bymouse-function dvc-switch-to-related-buffer) + +(defun dvc-log-event (output error command tree event) + "Log an event in the `dvc-log-buffer' buffer. +OUTPUT is the buffer containing process standard output. +ERROR is the buffer containing process error output. +COMMAND is the command that was executed. +TREE is the process's working directory. +EVENT is the event that occurred. +Returns that event." + (unless (and dvc-log-cookie + (buffer-live-p (ewoc-buffer dvc-log-cookie))) + (with-current-buffer (get-buffer-create dvc-log-buffer) + (setq dvc-log-cookie + (ewoc-create (dvc-ewoc-create-api-select + #'dvc-log-printer))) + (dvc-log-buffer-mode))) + (let ((related-buffer (current-buffer))) + (with-current-buffer (ewoc-buffer dvc-log-cookie) + (let ((elem (make-dvc-event :output-buffer output + :error-buffer error + :related-buffer related-buffer + :command command + :tree tree + :event event + :time (current-time))) + buffer-read-only) + (ewoc-enter-last dvc-log-cookie elem) + ;; If an event is too old (30 minutes after it has been + ;; recorded), throw it away. + (ewoc-filter dvc-log-cookie 'dvc-log-recently-p 30) + (ewoc-refresh dvc-log-cookie) + elem)))) + +(defun dvc-log-next () + "Move to the next log entry." + (interactive) + (let ((next (ewoc-next dvc-log-cookie + (ewoc-locate dvc-log-cookie)))) + (when next (goto-char (ewoc-location next))))) + +(defun dvc-log-prev () + "Move to the previous log entry." + (interactive) + (let ((prev (ewoc-prev dvc-log-cookie + (ewoc-locate dvc-log-cookie)))) + (when prev (goto-char (ewoc-location prev))))) + +;; +;; Log buffer mode section +;; +(defvar dvc-log-buffer-mode-map + (let ((map (make-sparse-keymap))) + (define-key map dvc-keyvec-help 'describe-mode) + (define-key map [?o] 'dvc-switch-to-output-buffer) + (define-key map "\C-m" 'dvc-switch-to-output-buffer) + (define-key map [?e] 'dvc-switch-to-error-buffer) + (define-key map [?r] 'dvc-switch-to-related-buffer) + (define-key map [?n] 'dvc-log-next) + (define-key map [?p] 'dvc-log-prev) + (define-key map dvc-keyvec-quit 'dvc-buffer-quit) + map) + "Keymap used in DVC's log buffer.") + +(define-derived-mode dvc-log-buffer-mode fundamental-mode "DVC Log" + "Major mode for DVC's internal log buffer. You can open this buffer +with `dvc-open-internal-log-buffer'." + (toggle-read-only 1)) + +(defun dvc-open-internal-log-buffer () + "Switch to the DVC's internal log buffer. +This buffer contains a list of all the DVC commands previously executed. +The buffer uses the mode `dvc-log-buffer-mode'" + (interactive) + (let ((buffer-name (buffer-name))) + (dvc-switch-to-buffer dvc-log-buffer) + (goto-char (point-max)) + (when (re-search-backward (concat " Buffer: " + (regexp-quote buffer-name) + "$") + nil t) + (dvc-flash-line)))) + +(defun dvc-clear-log-buffer () + "Kill the log buffer." + (when (bufferp (get-buffer dvc-log-buffer)) + (kill-buffer dvc-log-buffer))) + +(defun dvc-get-process-output () + "Return the content of the last process buffer. +Strips the final newline if there is one." + (dvc-buffer-content dvc-last-process-buffer)) + +(defun dvc-get-error-output () + "Return the content of the last error buffer. +Strips the final newline if there is one." + (dvc-buffer-content dvc-last-error-buffer)) + + +;; TODO: per backend cound. +(add-to-list 'minor-mode-alist + '(dvc-process-running + (:eval (if (equal (length dvc-process-running) 1) + " DVC running" + (concat " DVC running(" + (int-to-string (length dvc-process-running)) + ")"))))) + +(defun dvc-log-edit-file-name () + "Return a suitable file name to edit the commit message" + ;; FIXME: replace this with define-dvc-unified-command + (dvc-call "dvc-log-edit-file-name-func")) + +(defun dvc-dvc-log-edit-file-name-func () + (concat (file-name-as-directory (dvc-tree-root)) + (dvc-variable (dvc-current-active-dvc) + "log-edit-file-name"))) + +;; +;; Revision manipulation +;; + +;; revision grammar is specified in ../docs/DVC-API + +;; accessors +(defun dvc-revision-get-dvc (revision-id) + (car revision-id)) + +(defun dvc-revision-get-type (revision-id) + (car (nth 1 revision-id))) + +(defun dvc-revision-get-data (revision-id) + (cdr (nth 1 revision-id))) + +(defun dvc-revision-to-string (revision-id &optional prev-format orig-str) + "Return a string representation for REVISION-ID. + +If PREV-FORMAT is specified, it is the format string to use for +entries that are before the given revision ID. The format string +should take two parameters. The first is the revision ID, and +the second is a number which indicates how many generations back +to travel. + +If ORIG-STR is specified, it is the string that indicates the +current revision of the working tree." + (let* ((type (dvc-revision-get-type revision-id)) + (data (dvc-revision-get-data revision-id))) + ;;(dvc-trace "dvc-revision-to-string: type: %s, data: %s, orig-str: %s" type data orig-str) + (case type + (revision (dvc-name-construct (nth 0 data))) + (local-tree (car data)) + (last-revision (or orig-str "original")) + (previous-revision + (format (or prev-format "%s:-%s") + (dvc-revision-to-string + (list (dvc-revision-get-dvc revision-id) (nth 0 data))) + (int-to-string (nth 1 data)))) + (t "UNKNOWN")))) + +(defun dvc-revision-get-buffer (file revision-id) + "Return an empty buffer suitable for viewing FILE in REVISION-ID. + +The name of the buffer is chosen according to FILE and REVISION-ID. + +REVISION-ID may have the values described in docs/DVC-API." + (let* ((type (dvc-revision-get-type revision-id)) + (name (concat + (file-name-nondirectory file) + "(" (dvc-revision-to-string revision-id) ")"))) + ;; replace / by | to work around uniquify + (setq name (replace-regexp-in-string "\\/" "|" name)) + (let ((buffer (generate-new-buffer name))) + (with-current-buffer buffer + (let ((buffer-file-name file)) + (set-auto-mode t))) + (dvc-buffers-tree-add (dvc-revision-get-dvc revision-id) type file buffer) + buffer))) + + +(defun dvc-revision-get-file-in-buffer (file revision-id) + "Return a buffer with the content of FILE at REVISION-ID. + +REVISION-ID is as specified in docs/DVC-API." + (dvc-trace "dvc-revision-get-file-in-buffer. revision-id=%S" revision-id) + (let* ((type (dvc-revision-get-type revision-id)) + (inhibit-read-only t) + ;; find-file-noselect will call dvc-current-active-dvc in a + ;; hook; specify dvc for dvc-call + (dvc-temp-current-active-dvc (dvc-revision-get-dvc revision-id)) + (buffer (unless (eq type 'local-tree) (dvc-revision-get-buffer file revision-id)))) + (case type + (local-tree (find-file-noselect file)) + + (revision + (with-current-buffer buffer + (dvc-call "revision-get-file-revision" + file (dvc-revision-get-data revision-id)) + (set-buffer-modified-p nil) + (toggle-read-only 1) + buffer)) + + (previous-revision + (with-current-buffer buffer + (let* ((dvc (dvc-revision-get-dvc revision-id)) + (data (nth 0 (dvc-revision-get-data revision-id))) + (rev-id (list dvc data))) + (dvc-call "revision-get-previous-revision" file rev-id)) + (set-buffer-modified-p nil) + (toggle-read-only 1) + buffer)) + + (last-revision + (with-current-buffer buffer + (dvc-call "revision-get-last-revision" + file (dvc-revision-get-data revision-id)) + (set-buffer-modified-p nil) + (toggle-read-only 1) + buffer)) + + (t (error "TODO: dvc-revision-get-file-in-buffer type %S" type))))) + +(defun dvc-dvc-revision-nth-ancestor (revision n) + "Default function to get the n-th ancestor of REVISION." + (let ((count n) + (res revision)) + (while (> count 0) + (setq res (dvc-revision-direct-ancestor res) + count (- count 1))) + res)) + +;; +;; DVC command version +;; +(defun dvc-dvc-command-version () + "Fallback for `dvc-command-vesion'. Returns just `nil'. +This function is called only if the current backend doesn't +implement `command-version' function." + nil) + +(provide 'dvc-core) +;;; dvc-core.el ends here diff --git a/dvc/lisp/dvc-defs.el b/dvc/lisp/dvc-defs.el new file mode 100644 index 0000000..c10edd6 --- /dev/null +++ b/dvc/lisp/dvc-defs.el @@ -0,0 +1,630 @@ +;;; dvc-defs.el --- Common definitions for DVC + +;; Copyright (C) 2005-2009 by all contributors + +;; Author: Stefan Reichoer, +;; Contributors: Matthieu Moy, + +;; 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" + "<>\n" + "\n" + "<>\n" + "\n") + "A template that is used for functions to send patches via email. +It should contain a <> and a <> 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 diff --git a/dvc/lisp/dvc-diff.el b/dvc/lisp/dvc-diff.el new file mode 100644 index 0000000..ded07e1 --- /dev/null +++ b/dvc/lisp/dvc-diff.el @@ -0,0 +1,894 @@ +;;; dvc-diff.el --- A generic diff mode for DVC + +;; Copyright (C) 2005-2009 by all contributors + +;; Author: Matthieu Moy +;; Contributions from: +;; Stefan Reichoer, + +;; 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 "-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-mark-file]' to mark files, and '\\[dvc-diff-unmark-file]' to unmark. +If you commit from this buffer (with '\\\\[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-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 ((on-modified-file (dvc-get-file-info-at-point)) + (loc (point))) + + (if (and on-modified-file + (dvc-diff-in-ewoc-p)) + ;; on ewoc item; just ediff + (dvc-file-ediff-revisions on-modified-file + dvc-diff-base + dvc-diff-modified) + ;; 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 on-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 (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 modified) + "View changes in FILE between BASE and MODIFIED using ediff." + (dvc-ediff-buffers + (dvc-revision-get-file-in-buffer file base) + (dvc-revision-get-file-in-buffer file modified))) + +;;;###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 'bzr)) + (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 diff --git a/dvc/lisp/dvc-emacs.el b/dvc/lisp/dvc-emacs.el new file mode 100644 index 0000000..5d407cd --- /dev/null +++ b/dvc/lisp/dvc-emacs.el @@ -0,0 +1,186 @@ +;;; 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 + diff --git a/dvc/lisp/dvc-fileinfo.el b/dvc/lisp/dvc-fileinfo.el new file mode 100644 index 0000000..15077a7 --- /dev/null +++ b/dvc/lisp/dvc-fileinfo.el @@ -0,0 +1,815 @@ +;;; dvc-fileinfo.el --- An ewoc structure for displaying file information +;;; for DVC + +;; Copyright (C) 2007 - 2009 by all contributors + +;; 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 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; 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 \"\" ) + ) + +(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 " ") + (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." + (let ((fileinfo (dvc-fileinfo-current-fileinfo))) + (etypecase fileinfo + (dvc-fileinfo-file ; also matches dvc-fileinfo-dir + (dvc-fileinfo-path 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' must be let-bound to the directory being marked. + ;; It can't be a normal parameter because this is called via ewoc-map. + ;; 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." + (let ((dir-compare (file-name-as-directory dir))) + (ewoc-map (lambda (fileinfo) + (etypecase fileinfo + (dvc-fileinfo-file ; also matches dvc-fileinfo-dir + (dvc-fileinfo-mark-dir-1 fileinfo mark)) + + (dvc-fileinfo-message nil) + + (dvc-fileinfo-legacy + (error "dvc-fileinfo-mark-dir not implemented for legacy back-ends")))) + dvc-fileinfo-ewoc))) + +(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"))))) + +(defun dvc-fileinfo-next (&optional no-ding) + "Move to the next ewoc entry. If optional NO-DING, don't ding +if there is no next." + (interactive) + (let* ((current (ewoc-locate dvc-fileinfo-ewoc)) + (cur-location (ewoc-location current)) + (next (ewoc-next dvc-fileinfo-ewoc current))) + (cond + ((> cur-location (point)) + ;; not exactly at an element; move there + (goto-char cur-location)) + + (next + (goto-char (ewoc-location next))) + + (t + ;; at last element + (unless no-ding (ding)))))) + +(defun dvc-fileinfo-prev (&optional no-ding) + "Move to the previous ewoc entry. If optional NO-DING, don't ding +if there is no prev." + (interactive) + (let* ((current (ewoc-locate dvc-fileinfo-ewoc)) + (cur-location (ewoc-location current)) + (prev (ewoc-prev dvc-fileinfo-ewoc current))) + (cond + ((> (point) cur-location) + (goto-char cur-location)) + + (prev + (goto-char (ewoc-location prev))) + + (t + ;; at first element + (unless no-ding (ding)))))) + +(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) + + (while elems + (let ((fileinfo (ewoc-data (car elems)))) + (typecase fileinfo + (dvc-fileinfo-file + (if (equal 'unknown (dvc-fileinfo-file-status fileinfo)) + (progn + (delete-file (dvc-fileinfo-path fileinfo)) + (dvc-ewoc-delete dvc-fileinfo-ewoc (car elems))) + ;; `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 fileinfo)) + + (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)))))) + +(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 diff --git a/dvc/lisp/dvc-gnus.el b/dvc/lisp/dvc-gnus.el new file mode 100644 index 0000000..159f17b --- /dev/null +++ b/dvc/lisp/dvc-gnus.el @@ -0,0 +1,334 @@ +;;; dvc-gnus.el --- dvc integration to gnus + +;; Copyright (C) 2003-2009 by all contributors + +;; Author: Matthieu Moy +;; Contributions from: +;; Stefan Reichoer + +;; 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 (-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 '(("^<>" "^<>") ("^\\[\\[\\[" "^\\]\\]\\]"))) + (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 diff --git a/dvc/lisp/dvc-lisp.el b/dvc/lisp/dvc-lisp.el new file mode 100644 index 0000000..fb12c12 --- /dev/null +++ b/dvc/lisp/dvc-lisp.el @@ -0,0 +1,214 @@ +;;; dvc-lisp.el --- DVC lisp helper functions + +;; Copyright (C) 2003-2007 by all contributors + +;; Author: Stefan Reichoer, +;; Contributions from: +;; Matthieu Moy +;; Masatake YAMATO +;; Milan Zamazal +;; Martin Pool +;; Robert Widhopf-Fenk +;; Mark Triggs +;; Michael Olson + +;; 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 diff --git a/dvc/lisp/dvc-log.el b/dvc/lisp/dvc-log.el new file mode 100644 index 0000000..83627bd --- /dev/null +++ b/dvc/lisp/dvc-log.el @@ -0,0 +1,409 @@ +;;; dvc-log.el --- Manipulation of the log before committing + +;; Copyright (C) 2005-2008 by all contributors + +;; Author: Matthieu Moy +;; Contributions from: +;; Stefan Reichoer, + +;; 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) + 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 diff --git a/dvc/lisp/dvc-register.el b/dvc/lisp/dvc-register.el new file mode 100644 index 0000000..b2ce39e --- /dev/null +++ b/dvc/lisp/dvc-register.el @@ -0,0 +1,301 @@ +;;; dvc-register.el --- Registration of DVC back-ends + +;; Copyright (C) 2005-2008 by all contributors + +;; Author: Stefan Reichoer, +;; Contributions from: Matthieu Moy + +;; 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- +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- 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 diff --git a/dvc/lisp/dvc-revlist.el b/dvc/lisp/dvc-revlist.el new file mode 100644 index 0000000..dfdae2b --- /dev/null +++ b/dvc/lisp/dvc-revlist.el @@ -0,0 +1,477 @@ +;;; dvc-revlist.el --- Revision list in DVC + +;; Copyright (C) 2005-2009 by all contributors + +;; Author: Matthieu Moy + +;; 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 "-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 diff --git a/dvc/lisp/dvc-revlog.el b/dvc/lisp/dvc-revlog.el new file mode 100644 index 0000000..0ab7a2d --- /dev/null +++ b/dvc/lisp/dvc-revlog.el @@ -0,0 +1,98 @@ +;;; dvc-revlog.el --- View a single log entry in DVC + +;; Copyright (C) 2005-2008 by all contributors + +;; Author: Matthieu Moy + +;; 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 diff --git a/dvc/lisp/dvc-site.el.in b/dvc/lisp/dvc-site.el.in new file mode 100644 index 0000000..4f46bba --- /dev/null +++ b/dvc/lisp/dvc-site.el.in @@ -0,0 +1,39 @@ +;;; dvc-site.el.in --- Site-specific configuration for DVC (generated by ./configure) + +;; Copyright (C) 2005 Matthieu Moy + +;; Author: Matthieu Moy +;; 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 diff --git a/dvc/lisp/dvc-state.el b/dvc/lisp/dvc-state.el new file mode 100644 index 0000000..aaeea73 --- /dev/null +++ b/dvc/lisp/dvc-state.el @@ -0,0 +1,95 @@ +;;; 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 diff --git a/dvc/lisp/dvc-status.el b/dvc/lisp/dvc-status.el new file mode 100644 index 0000000..8393762 --- /dev/null +++ b/dvc/lisp/dvc-status.el @@ -0,0 +1,251 @@ +;;; dvc-status.el --- A generic status mode for DVC + +;; Copyright (C) 2007 - 2009 by all contributors + +;; 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 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 xmtn-status buffer." + :type 'boolean + :group 'dvc) + +(defcustom dvc-status-display-ignored nil + "If non-nil, display files with 'ignored' status in xmtn-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] + )) + +;; "-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). See +;; `xmtn-status-mode' in xmtn-dvc.el for a good example. +;; 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)) + +(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 -dvc-status. +Calls -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) + ;; typically nothing to do; just need commit + (ding) + (dvc-fileinfo-next)) + + (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 diff --git a/dvc/lisp/dvc-tips.el b/dvc/lisp/dvc-tips.el new file mode 100644 index 0000000..abfe7fd --- /dev/null +++ b/dvc/lisp/dvc-tips.el @@ -0,0 +1,290 @@ +;;; dvc-tips.el --- "Tip of the day" feature for DVC. + +;; Copyright (C) 2004-2008 by all contributors + +;; Author: Matthieu Moy +;; 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 diff --git a/dvc/lisp/dvc-ui.el b/dvc/lisp/dvc-ui.el new file mode 100644 index 0000000..9120642 --- /dev/null +++ b/dvc/lisp/dvc-ui.el @@ -0,0 +1,506 @@ +;;; dvc-ui.el --- User interface (keybinding, menus) for DVC + +;; Copyright (C) 2005-2009 by all contributors + +;; Author: Matthieu Moy +;; Contributions from: +;; Stefan Reichoer, + +;; 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-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 diff --git a/dvc/lisp/dvc-unified.el b/dvc/lisp/dvc-unified.el new file mode 100644 index 0000000..7c9fe6c --- /dev/null +++ b/dvc/lisp/dvc-unified.el @@ -0,0 +1,668 @@ +;;; dvc-unified.el --- The unification layer for dvc + +;; Copyright (C) 2005-2009 by all contributors + +;; Author: Stefan Reichoer, + +;; 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: + +(require 'dired-x) +(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 + (mapcar '(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 ""))) + (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) "") + (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))))) + ;; 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; prefix arg means prompt +for tree), LAST-N entries (default `dvc-log-last-n'; all if +nil). Use `dvc-changelog' for the full log." + (interactive (list (if current-prefix-arg nil (buffer-file-name)) + dvc-log-last-n)) + (let ((default-directory + (dvc-read-project-tree-maybe "DVC tree root (directory): " + (when path (expand-file-name path)) + (not current-prefix-arg)))) + ;; 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-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 -, whose +body is a simple wrapper around dvc-. 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 diff --git a/dvc/lisp/dvc-utils.el b/dvc/lisp/dvc-utils.el new file mode 100644 index 0000000..4c38526 --- /dev/null +++ b/dvc/lisp/dvc-utils.el @@ -0,0 +1,807 @@ +;;; dvc-utils.el --- Utility functions for DVC + +;; Copyright (C) 2005 - 2009 by all contributors + +;; Author: Matthieu Moy + +;; 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 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) + "Return a unique string designating PATH. +If PATH is a directory,the returned contains one and exactly one trailing +slash. If PATH is nil, then nil is returned." + (and path + (let ((expanded (file-truename + (expand-file-name + (if (file-directory-p path) + (file-name-as-directory path) + path))))) + (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 diff --git a/dvc/lisp/dvc-xemacs.el b/dvc/lisp/dvc-xemacs.el new file mode 100644 index 0000000..f8bf2a8 --- /dev/null +++ b/dvc/lisp/dvc-xemacs.el @@ -0,0 +1,426 @@ +;;; 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 + +;; 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 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 diff --git a/dvc/lisp/tests/bzr-tests.el b/dvc/lisp/tests/bzr-tests.el new file mode 100644 index 0000000..d4247fe --- /dev/null +++ b/dvc/lisp/tests/bzr-tests.el @@ -0,0 +1,136 @@ +;;; 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 diff --git a/dvc/lisp/tests/dvc-tests-utils.el b/dvc/lisp/tests/dvc-tests-utils.el new file mode 100644 index 0000000..6544e4d --- /dev/null +++ b/dvc/lisp/tests/dvc-tests-utils.el @@ -0,0 +1,43 @@ +;;; 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 diff --git a/dvc/lisp/tests/xmtn-tests.el b/dvc/lisp/tests/xmtn-tests.el new file mode 100644 index 0000000..db8a44b --- /dev/null +++ b/dvc/lisp/tests/xmtn-tests.el @@ -0,0 +1,657 @@ +;;; 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 diff --git a/dvc/lisp/tla-autoconf.el b/dvc/lisp/tla-autoconf.el new file mode 100644 index 0000000..9ef1473 --- /dev/null +++ b/dvc/lisp/tla-autoconf.el @@ -0,0 +1,226 @@ +;;; tla-autoconf.el --- Arch interface for emacs + +;; Copyright (C) 2003-2005 by all contributors + +;; Author: Stefan Reichoer, +;; Contributions from: +;; Matthieu Moy +;; Masatake YAMATO +;; Milan Zamazal +;; Martin Pool +;; Robert Widhopf-Fenk +;; Mark Triggs + +;; 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- and serves *only* as a cache. The possible +;; values are 'yes 'no and nil (for "don't know"). +;; The function's name is tla-, 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 diff --git a/dvc/lisp/tla-bconfig.el b/dvc/lisp/tla-bconfig.el new file mode 100644 index 0000000..f50e30d --- /dev/null +++ b/dvc/lisp/tla-bconfig.el @@ -0,0 +1,151 @@ +;;; tla-bconfig.el --- mode for input file of GNU arch's build-config + +;; Copyright (C) 2005 Free Software Foundation, Inc. + +;; Author: Masatake YAMATO +;; 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 + diff --git a/dvc/lisp/tla-browse.el b/dvc/lisp/tla-browse.el new file mode 100644 index 0000000..b295859 --- /dev/null +++ b/dvc/lisp/tla-browse.el @@ -0,0 +1,1500 @@ +;;; tla-browse.el --- Arch archives/library browser + +;; Copyright (C) 2004 by all contributors + +;; Author: Masatake YAMATO + +;; Contributions from: +;; Stefan Reichoer, +;; Matthieu Moy +;; Masatake YAMATO +;; Milan Zamazal +;; Martin Pool +;; Robert Widhopf-Fenk +;; Mark Triggs + +;; This is a part of xtla. +;; +;; 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: +;; 1. Load tla-browse.el +;; 2. M-x tla-browse RET + +;;; TODO: +;; - Generic refresh +;; + +;;; History: +;; + +;;; Code: +;; runtime use of 'cl package is discourraged. Please keep this +;; "eval-when-compile" +;; ^^^^ +(eval-when-compile (require 'cl)) +(eval-when-compile (require 'dvc-core)) +(eval-when-compile (require 'dvc-utils)) +(require 'tree-widget) +(require 'tla) +(require 'dvc-ui) + +(defvar tla--browse-buffer-name "*tla-browse*") +(defvar tla--browse-buffer-type 'browse) +(dvc-add-buffer-type tla--browse-buffer-type + tla--browse-buffer-name) + +;; ---------------------------------------------------------------------------- +;; Open node tracking +;; ---------------------------------------------------------------------------- +(defvar tla--browse-open-list '() + "List holding the name of open nodes.") + +(defun tla--browse-open-list-member (archive + &optional category branch version) + "Return a node, ARCHIVE/CATEGORY--BRANCH--VERSION is opend or not. +CATEGORY, BRANCH, VERSION are optional." + (let ((name (list archive category branch version nil))) + (member name tla--browse-open-list))) + +(defun tla--browse-open-list-add (archive + &optional category branch version) + "Add a node specified by the arguments to 'tla--browse-open-list'. +ARCHIVE/CATEGORY--BRANCH--VERSION, ARCHIVE/CATEGORY--BRANCH, +ARCHIVE/CATEGORY, ARCHIVE are added. CATEGORY, BRANCH, VERSION +are optional." + (tla--browse-open-list-add-internal (list archive category branch version nil)) + (tla--browse-open-list-add-internal (list archive category branch nil nil)) + (tla--browse-open-list-add-internal (list archive category nil nil nil)) + (tla--browse-open-list-add-internal (list archive nil nil nil nil)) + (tla--browse-open-list-add-internal (list nil nil nil nil nil))) + +(defun tla--browse-open-list-add-internal (name) + "Add NAME to `tla--browse-open-list'." + (unless (tla--browse-open-list-member (tla--name-archive name) + (tla--name-category name) + (tla--name-branch name) + (tla--name-version name)) + (push name tla--browse-open-list))) + +(defun tla--browse-open-list-remove (archive + &optional category branch version) + "Remove ARCHIVE/CATEGORY--BRANCH--VERSION from `tla--browse-open-list'. +CATEGORY, BRANCH and VERSION are optional." + (let ((name (list archive category branch version nil))) + (setq tla--browse-open-list (delete name tla--browse-open-list)))) + +(defun tla--browse-open-tracker (tree) + "Add or remove a node represented by TREE to/from `tla--browse-open-list'. +If TREE is opened, it is added. Else it is removed." + (let* ((node (widget-get tree :node)) + (a (widget-get node :archive)) + (c (widget-get node :category)) + (b (widget-get node :branch)) + (v (widget-get node :version))) + (if (widget-get tree :open) + (tla--browse-open-list-add a c b v) + (tla--browse-open-list-remove a c b v)))) + +(defun tla--browse-find-archives-root-widget () + "Return the root widget of archives tree." + (save-excursion + (goto-char (point-min)) + (re-search-forward " Archives$") + (backward-char 1) + (tla--widget-node-get-at))) + +(defun tla--browse-find-named-widget (parent name type) + "Find a widget specified with arguments. +PARENT specifies the parent widget. +NAME is the name of the widget. +TYPE is the type of widget. You can specify :archive, :category, +:branch, or :version." + (let* ((args (widget-get parent :args)) + (largs (length args)) + (index (dvc-position name args (lambda (e w) + (let ((node (widget-get w :node))) + ;; Next line is hack for version node. + (unless node (setq node w)) + (string= e (widget-get node type)))))) + (children (widget-get parent :children)) + (lchildren (length children)) + ;; The internal data structure of tree-widget bundled to develoment + ;; version of GNU Emacs may by changed; :children list becomes longer + ;; than :args list. + (tree (when index (nth (+ index (if (eq largs lchildren) 0 1)) + children))) + (node (when tree (save-excursion (goto-char (widget-get tree :from)) + (goto-char (next-single-property-change (point) 'widget)) + (tla--widget-node-get-at))))) + node)) + + +(defun tla--browse-find-widget (archive + &optional category branch version) + "Return a list of widgets: (root archive category branch version) +root is always the root of the tree, of type `tla--widget-root-node'. +archive is the widget representing ARCHIVE, of type +`tla--widget-archive-node'. The last items are potentially nil if +CATEGORY, BRANCH or VERSION is nil. Otherwise, they are respectively +of type `tla--widget-category-node', `tla--widget-revision-node' and +`tla--widget-version-node'." + (let* ((root (tla--browse-find-archives-root-widget)) + (a (tla--browse-find-named-widget + (widget-get root :parent) archive :archive)) + (c (and a category + (tla--browse-find-named-widget + (widget-get a :parent) category :category))) + (b (and c branch + (tla--browse-find-named-widget + (widget-get c :parent) branch :branch))) + (v (and b version + (tla--browse-find-named-widget + (widget-get b :parent) version :version)))) + (list root a c b v))) + +(defun tla--browse-find-single-widget (archive + &optional category branch + version) + "Similar to `tla--browse-find-widget'. +Difference is it returns only the widget representing the last non-nil +widget of the list. The means of ARCHIVE, CATEGORY, BRANCH and VERSION +are the same as that of `tla--browse-find-widget'." + (let ((widgets (tla--browse-find-widget archive category branch + version))) + (or (nth 4 widgets) + (nth 3 widgets) + (nth 2 widgets) + (nth 1 widgets) + (error "Widget not found. Please fill-in a bug report")))) + +(defun tla--browse-find-real-widget (widget) + "Find real(complete) widget from incomplete WIDGET. +When trying to find widgets using (widget-get ... :args), we +sometimes find an incomplete widget, having no :from or :to +information for example. This function takes as an argument an +incomplete widget, and finds the corresponding full widget. + +WIDGET must be of type tla--widget-*-node." + (case (widget-type widget) + (tla--widget-archive-node + (tla--browse-find-single-widget + (widget-get widget :archive))) + (tla--widget-category-node + (tla--browse-find-single-widget + (widget-get widget :archive) + (widget-get widget :category))) + (tla--widget-branch-node + (tla--browse-find-single-widget + (widget-get widget :archive) + (widget-get widget :category) + (widget-get widget :branch))) + (tla--widget-version-node + (tla--browse-find-single-widget + (widget-get widget :archive) + (widget-get widget :category) + (widget-get widget :version))))) + +(defun* tla--browse-open (flash archive + &optional category branch version) + (let (widgets root a c b v) + + (unless archive + (return-from tla--browse-open nil)) + (setq widgets (tla--browse-find-widget archive category branch nil)) + (setq root (nth 0 widgets)) + (unless root + (error "Cannot find root archives node")) + (tla--widget-node-toggle-subtree-internal root 'open) + + (setq widgets (tla--browse-find-widget archive category branch nil)) + (setq a (nth 1 widgets)) + (unless category + (if a + (progn (when flash + (goto-char (widget-get a :from)) + (dvc-flash-line)) + (return-from tla--browse-open nil)) + (error "Cannot find archive node for: %s" archive))) + (tla--widget-node-toggle-subtree-internal a 'open) + + (setq widgets (tla--browse-find-widget archive category branch nil)) + (setq c (nth 2 widgets)) + (unless branch + (if c + (progn (when flash + (goto-char (widget-get c :from)) + (dvc-flash-line)) + (return-from tla--browse-open nil)) + (error "Cannot find category node for: %s/%s" archive category))) + (tla--widget-node-toggle-subtree-internal c 'open) + + (setq widgets (tla--browse-find-widget archive category branch nil)) + (setq b (nth 3 widgets)) + (unless version + (if b + (progn (when flash + (goto-char (widget-get b :from)) + (dvc-flash-line)) + (return-from tla--browse-open nil)) + (error "Cannot find branch node for: %s/%s--%s" archive category branch))) + (tla--widget-node-toggle-subtree-internal b 'open) + + (setq widgets (tla--browse-find-widget archive category branch version)) + (setq v (nth 4 widgets)) + (if v + (progn (when flash + (goto-char (widget-get v :from)) + (dvc-flash-line)) + (return-from tla--browse-open nil)) + (error "Cannot find branch node for: %s/%s--%s--%s" archive category branch version))) + ) + +;; ---------------------------------------------------------------------------- +;; Abstract Super Widget +;; ---------------------------------------------------------------------------- +(define-widget 'tla--widget-node 'item + "Abstract super widget for tla--widget-*-node." + :tla-type nil + :format "%[ %t%]%{%v%}\n" + :face nil + :keymap nil + :menu nil + :marks " " + :keep '(:marks :open) + :open-subtree 'tla--tree-widget-node-open-subtree + :close-subtree 'tla--tree-widget-node-close-subtree) + +(defvar tla--widget-node-map + (let ((map (copy-keymap dvc-cmenu-map-template))) + (define-key map [return] + 'tla--widget-node-toggle-subtree) + (define-key map [down-mouse-2] + 'tla--widget-node-toggle-subtree-by-mouse) + (define-key map "\C-m" + 'tla--widget-node-toggle-subtree) + (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) + 'tla-bookmarks) + (define-key map dvc-keyvec-kill-ring + 'tla--widget-node-save-name-to-kill-ring) + (define-key map dvc-keyvec-add-bookmark + 'tla--widget-node-add-bookmark) + map) + "Keymap commonly used in tla--widget-*-node.") + +(defun tla--widget-node-value-create (widget keyword) + "Create value for WIDGET. +KEYWORD is used to get the base string to create the value." + (insert (let* ((marks (widget-get widget :marks)) + (string (widget-get widget keyword)) + (value (tla--widget-node-install-ui-element + widget (if (string= string "") "" + string)))) + (concat marks value)))) + +(defun tla--widget-node-install-ui-element (widget value &optional face) + "Create a string with keymap, menu and face properties. +The keymap and menu are retrieved from WIDGET. +The string is copied from VALUE. +FACE is useds as the face." + (let ((prop-value (dvc-face-add value + (if face face (widget-get widget :face)) + (widget-get widget :keymap) + (widget-get widget :menu)))) + (put-text-property 0 (length value) + 'widget widget + prop-value) + prop-value)) + +(defun tla--widget-node-get-at (&optional point) + "Get widget at POINT." + (get-text-property (if point point (point)) 'widget)) + +(defun tla--widget-node-get-name (&optional point) + "Get name list associated widget under the POINT." + (let ((widget (tla--widget-node-get-at point))) + (list (widget-get widget :archive) + (widget-get widget :category) + (widget-get widget :branch) + (widget-get widget :version) + nil))) + +(defun tla--widget-node-get-type (&optional point) + "Get type of widget under the POINT. + +Can be either 'archive, 'category, 'branch, 'version or nil for the +root of the tree." + (let ((widget (tla--widget-node-get-at point))) + (widget-get widget :tla-type))) + +(defun tla--widget-get-ancestor (widget level) + "Get the ancestor widget of WIDGET. +\"ancestor\" widget stands for the LEVEL upper widget +in the archives tree." + (let ((i 0) + (parent widget)) + (while (< i level) + (setq parent (widget-get parent :parent) + i (1+ i))) + parent)) + +(defun tla--widget-node-refresh (&optional level point + archive + category + branch) + "Refresh node and LEVEL subnode at the POINT. +Before refreshing node, names cache are also refreshed if +ARCHIVE, CATEGORY, and/or BRANCH are specified. +If POINT is a symbol, `name', node is specified by ARCHIVE, +CATEGORY, and/or BRANCH." + (interactive) + (unless level (setq level 1)) + (setq point (cond + ((null point) (point)) + ((eq 'name point) + (save-excursion + (goto-char + (next-single-property-change + (widget-get + (tla--browse-find-single-widget + archive + category + branch) + :from) + 'widget)))) + (t point))) + (if branch + (tla--archive-tree-build-versions archive + category + branch + nil t) + (if category + (tla--archive-tree-build-branches archive + category + nil t) + (if archive + (tla--archive-tree-build-categories archive + nil + t) + (tla--archive-tree-build-archives nil t)))) + + (let* ((widget (tla--widget-node-get-at point)) + (tree (tla--widget-get-ancestor widget level))) + (widget-put tree :args nil) + (widget-value-set tree (widget-value tree)) + (widget-setup))) + +(defun tla--widget-node-synchronize-mirror-to-remote () + "Synchronizes the mirror for the archive at point to remote from local." + (interactive) + (let* ((name (tla--widget-node-get-name)) + (archive (tla--name-archive name)) + (type (tla--archive-type archive)) + mirror source) + (cond + ((eq type 'normal) + (setq mirror (tla--archive-name-mirror archive t)) + (unless mirror + (error "No mirror archive for `%s'" archive))) + ((eq type 'mirror) + (setq source (tla--archive-name-source archive t)) + (if source + (setq archive source) + (error "No source archive for `%s'" archive))) + (t (error "Cannot mirror to a source archive: `%s'" archive))) + (tla-archive-mirror archive + (tla--name-category name) + (tla--name-branch name) + (tla--name-version name) + nil))) + +(defun tla--widget-node-synchronize-mirror-to-local () + "Synchronizes the mirror for the archive at point to local from remote." + (interactive) + ;; TODO + ) + +(defun tla--widget-node-save-name-to-kill-ring () + "Save the name under point to `kill-ring'." + (interactive) + (let ((name (tla--name-construct (tla--widget-node-get-name)))) + (when (equal "" name) + (error "No widget under the point")) + (kill-new name) + (message "Name: %s" name))) + +(defun tla--widget-node-add-bookmark () + "Add a name associated with a widget at point to xtla's bookmarks." + (interactive) + (let* ((target (tla--widget-node-get-name)) + (target-fq (tla--name-construct target)) + (bookmark (read-from-minibuffer (format "Name of Bookmark for `%s': " + target-fq)))) + (tla-bookmarks-add bookmark target) + (when (y-or-n-p "View bookmarks? ") + (tla-bookmarks)) + (message "bookmark %s(=> %s) added." bookmark target-fq))) + +(defun tla--widget-node-toggle-subtree (&optional point force) + "Toggle between closing and opening the node at POINT. +You can specify a symbol, `open' or `close' to FORCE to force +the node to open or to close." + (interactive) + (tla--widget-node-toggle-subtree-internal + (tla--widget-node-get-at point) force)) + +(defun tla--widget-node-toggle-subtree-recursive (&optional point + force) + "Same as `tla--widget-node-toggle-subtree'. +The difference is that when the node is expanded, expands it +recursively, which means all the children will also be expanded. (this +may take looong). +Meaning of POINT and FORCE are the same as that of +`tla--widget-node-toggle-subtree'." + (interactive) + (tla--widget-node-toggle-subtree-internal + (tla--widget-node-get-at point) force t)) + +(defun tla--widget-node-toggle-subtree-internal (widget force + &optional + recursive) + "Toggle between closing and opening the WIDGET. +You can specify a symbol, `open' or `close' to FORCE to force +the node to open or to close. If RECURSIVE is non-nil, the opening +or closing are applied recursively." + (let* ((open-subtree (widget-get widget :open-subtree)) + (close-subtree (widget-get widget :close-subtree))) + (cond + ((or (eq force 'open) + (and (not force) + (not (widget-get (widget-get widget :parent) :open)))) + (when open-subtree (funcall open-subtree widget)) + (when recursive + (tla--widget-node-toggle-subtree-recursion widget 'open))) + ((or (eq force 'close) + (and (not force) + (widget-get (widget-get widget :parent) :open))) + (when (and recursive + (widget-get (widget-get widget :parent) :open)) + (when open-subtree (funcall open-subtree widget)) + (tla--widget-node-toggle-subtree-recursion widget 'close)) + (when close-subtree (funcall close-subtree widget)))))) + +(defun tla--widget-node-toggle-subtree-recursion (widget force) + "A helper function for 'tla--widget-node-toggle-subtree-internal'. +Apply all sub node of WIDGET opening or closing which is specified +by FORCE." + (let ((args (widget-get (widget-get widget :parent) :args))) + (dolist (arg args) + (let* ((t-widget (widget-get arg :node)) + ;; surprisingly, t-widget doesn't have all the + ;; necessary fields. Look for the _real_ widget. + (full-widget + (tla--browse-find-real-widget t-widget))) + (unless (eq (widget-type t-widget) + (widget-type full-widget)) + (error "Incorrect widget. Please contact the developers")) + (when full-widget + (tla--widget-node-toggle-subtree-internal + full-widget force t)))))) + +(defun tla--tree-widget-node-open-subtree (widget) + "Open tree node function used in `tla-browse'." + (cond + ((fboundp 'tree-widget-action) + (let ((parent (widget-get widget :parent))) + (unless (widget-get parent :open) + (tree-widget-action parent)))) + ((fboundp 'tree-widget-open-node) + 'tree-widget-open-node) + (t + 'tla--tree-widget-node-toggle-subtree-for-tree-widget-v1))) + +(defun tla--tree-widget-node-close-subtree (widget) + "Close tree node function used in `tla-browse'." + (cond + ((fboundp 'tree-widget-action) + (let ((parent (widget-get widget :parent))) + (when (widget-get parent :open) + (tree-widget-action parent)))) + ((fboundp 'tree-widget-open-node) + 'tree-widget-close-node) + (t + 'tla--tree-widget-node-toggle-subtree-for-tree-widget-v1))) + +(defun tla--tree-widget-node-toggle-subtree-for-tree-widget-v1 (widget) + "Toggle tree node function used in `tla-browse' with tree-widget ver.1.0.5. +The code is the almost same as in tree-widget-toggle-folding tree-widget version +1.0.5. + +Original documents say: + \"Toggle a `tree-widget' folding. +WIDGET is a `tree-widget-node-handle-widget' and its parent the +`tree-widget' itself. IGNORE other arguments.\"" + (let* ((parent (widget-get widget :parent)) + ;; Original code + ;;(open (widget-value widget)) + ;; Here `parent' is used instead of `widget'. + (open (widget-value parent))) + (if open + (tree-widget-children-value-save parent)) + (widget-put parent :open (not open)) + (widget-value-set parent (not open)) + (run-hook-with-args 'tree-widget-after-toggle-functions parent))) + +(dvc-make-bymouse-function tla--widget-node-toggle-subtree) + +;; ---------------------------------------------------------------------------- +;; My-id +;; ---------------------------------------------------------------------------- +(define-widget 'tla--widget-my-id 'push-button + "Widget to control tla's my-id." + :format "%{My-id:%} %[%t%]" + :sample-face 'bold + :button-face 'widget-field-face + :notify 'tla--widget-my-id-set + :help-echo "Click here to change my-id") + +(defun tla--widget-my-id-set (self changed event) + "Set my-id to my-id-widget. +SELF is not used. CHANGED is just passed to `widget-value-set'. +EVENT is also not used." + (let ((new-id (tla-my-id t))) + (widget-value-set changed new-id) + (widget-setup))) + +;; ---------------------------------------------------------------------------- +;; Root node +;; ---------------------------------------------------------------------------- +(define-widget 'tla--widget-root-node 'tla--widget-node + "Root node widget for trees in tla-browse buffer." + :value-create 'tla--widget-root-node-value-create + :format " %v\n" + :face 'bold) + +(defun tla--widget-root-node-value-create (widget) + "Create a value for root node represented by WIDGET." + (insert (tla--widget-node-install-ui-element + widget + (widget-get widget :tag)))) + +(defvar tla--widget-archives-root-node-map + (let ((map (copy-keymap tla--widget-node-map))) + (define-key map dvc-keyvec-refresh + 'tla--widget-node-refresh) + (define-key map (dvc-prefix-add ?a) + 'tla--widget-archives-root-node-make-archive) + (define-key map (dvc-prefix-add ?r) + 'tla--widget-archives-root-node-register-archive) + map) + "Keymap used on the archives root node.") + +(easy-menu-define tla--widget-archives-root-node-menu nil + "Menu used on the root archives item in `tla-browse-mode' buffer." + '("Archives Root" + ["Update Archives List" + tla--widget-node-refresh t] + ["Make New Archive..." + tla--widget-archives-root-node-make-archive t] + ["Register Archive" + tla--widget-archives-root-node-register-archive t])) + +(defun tla--widget-archives-root-node-make-archive () + "Call `tla--make-archive' interactively then update the tree of `tla-browse'." + (interactive) + (call-interactively 'tla--make-archive) + (tla--widget-node-refresh 1)) + +(defun tla--widget-archives-root-node-goto (name) + "Move the point to beginning of line in where the NAME is. +This may be useful to search an archive named NAME." + (goto-char (point-min)) + (search-forward name) + (beginning-of-line)) + +(defun tla--widget-archives-root-node-register-archive () + "Call `tla--register-archive' interactively ; then update the tree of `tla-browse'." + (interactive) + (let* ((result (call-interactively 'tla--register-archive)) + (archive-registered (nth 0 result)) + (archive (nth 1 result)) + (tla-response (nth 3 result))) + (when archive-registered + (tla--widget-node-refresh 1) + (message tla-response) + (tla--widget-archives-root-node-goto + (if (string-match ".+: \\(.+\\)" tla-response) + (match-string-no-properties 1 tla-response) + archive)) + (dvc-flash-line)))) + + +;; ---------------------------------------------------------------------------- +;; Archive +;; ---------------------------------------------------------------------------- +(defface tla-location + '((((type tty) (class color)) (:weight light)) + (((class color) (background light)) (:foreground "gray")) + (((class color) (background dark)) (:foreground "gray")) + (t (:weight bold))) + "Face to highlight xtla's archive location." + :group 'tla-faces) + +(defface tla-location-ftp + '((t (:inherit tla-location))) + "Face to highlight xtla's archive ftp location." + :group 'tla-faces) + +(defface tla-location-sftp + '((t (:inherit tla-location :foreground "gray50"))) + "Face to highlight xtla's archive sftp location." + :group 'tla-faces) + +(defface tla-location-http + '((t (:inherit tla-location :foreground "gray60"))) + "Face to highlight xtla's archive sftp location." + :group 'tla-faces) + +(defface tla-location-local + '((t (:inherit tla-location :foreground "gray30"))) + "Face to highlight xtla's local archive." + :group 'tla-faces) + +(defvar tla--widget-archive-node-map + (let ((map (copy-keymap tla--widget-node-map))) + (define-key map dvc-keyvec-refresh + 'tla--widget-archive-node-refresh) + (define-key map "*" 'tla--widget-archive-node-select-default) + (define-key map dvc-keyvec-remove + 'tla--widget-archive-node-unregister-archive) + (define-key map (dvc-prefix-add ?c) + 'tla--widget-archive-node-make-category) + (define-key map (vector ?. dvc-key-reflect) + 'tla--widget-archive-node-start-project) + (define-key map dvc-keyvec-reflect + 'tla--widget-node-synchronize-mirror-to-remote) + (define-key map dvc-keyvec-get + 'tla--widget-node-synchronize-mirror-to-local) + (define-key map (dvc-prefix-add dvc-key-reflect) + 'tla--widget-archive-node-make-mirror-at-remote) + (define-key map (dvc-prefix-add dvc-key-get) + 'tla--widget-archive-node-make-mirror-at-local) + map) + "Keymap used on tla--widget-archive-node.") + +(easy-menu-define tla--widget-archive-node-menu nil + "Menu used on a archive item in `tla-browse-mode' buffer." + '("Archive" + ["Update Categories List" tla--widget-archive-node-refresh t] + ["Set Default Archive" tla--widget-archive-node-select-default t] + ["Remove Archive Registration" tla--widget-archive-node-unregister-archive t] + ["Make New Category..." tla--widget-archive-node-make-category t] + ["Start Project from Here" tla--widget-archive-node-start-project t] + ["Add a Bookmark" tla--widget-node-add-bookmark t] + ("Remote Mirror" + ["Synchronize Mirror to Remote From Local" + tla--widget-node-synchronize-mirror-to-remote + (let* ((archive (tla--name-archive (tla--widget-node-get-name))) + (type (tla--archive-type archive))) + (or (and (eq type 'normal) + (tla--archive-name-mirror archive t)) + (and (eq type 'mirror) + (tla--archive-name-source archive t))))] + ["Create a Mirror at Remote" + tla--widget-archive-node-make-mirror-at-remote + (eq (tla--archive-type (tla--name-archive (tla--widget-node-get-name))) + 'normal)]) + ("Local Mirror" + ["Synchronize Mirror to Local[TODO]" + ;; TODO + tla--widget-node-synchronize-mirror-to-local nil] + ["Create a Mirror at Local" tla--widget-archive-node-make-mirror-at-local + (eq (tla--archive-type (tla--name-archive (tla--widget-node-get-name))) + 'source)] + "--" + ["Convert to SOURCE archive" tla--widget-archive-node-convert-to-source + (eq (tla--archive-type (tla--name-archive (tla--widget-node-get-name))) + 'normal)]) + ["Save Name to Kill Ring" tla--widget-node-save-name-to-kill-ring t])) + +(defconst tla--widget-archive-node-tag "a") +(defconst tla--widget-archive-node-default-tag "A") + +(define-widget 'tla--widget-archive-node 'tla--widget-node + "Archive node in tla-browse." + :tag tla--widget-archive-node-tag + :value-create 'tla--widget-archive-node-value-create + :tla-type 'archive + :face 'tla-archive-name + :keymap 'tla--widget-archive-node-map + :menu tla--widget-archive-node-menu + :archive nil + :archive-location nil + :archive-defaultp nil) + +(defvar tla--widget-archive-node-list nil) +(defun tla--browse-expand-archives (root) + "Expand ROOT widget." + (or (and (not current-prefix-arg) (widget-get root :args)) + (let ((default-archive (tla-my-default-archive))) + (setq tla--widget-archive-node-list nil) + (mapcar + (lambda (archive) + (let ((res + `(tree-widget + :open ,(tla--browse-open-list-member (car archive)) + :has-children t + :dynargs tla--browse-expand-categories + :node (tla--widget-archive-node + :tag ,(if (equal default-archive (car archive)) + tla--widget-archive-node-default-tag + tla--widget-archive-node-tag) + :archive ,(car archive) + ;; TODO(Multiple locations) + :archive-location ,(car (cadr archive)) + :archive-defaultp ,(equal + default-archive + (car + archive)))))) + (widget-put (widget-get res :node) :parent res) + res)) + (progn + (tla--archive-tree-build-archives (not current-prefix-arg) t) + tla--archive-tree))))) + +(defun tla--widget-archive-node-value-create (widget) + "Create values for WIDGET." + (push widget tla--widget-archive-node-list) + (insert (let* ((archive (widget-get widget :archive)) + (location (widget-get widget :archive-location)) + (defaultp (widget-get widget :archive-defaultp)) + (marks (widget-get widget :marks)) + (value (progn + (case (tla--archive-type archive) + (mirror (widget-put widget :face 'tla-mirror-archive-name)) + (source (widget-put widget :face 'tla-source-archive-name))) + ;; + ;; It seems that XEmacs's format hides text properties. + ;; + (concat marks + (tla--widget-node-install-ui-element + widget archive (when defaultp + 'dvc-marked)) + " => " + (if location + (tla--widget-archive-put-face-on-location + location) + "*unknown now*"))))) + value))) + +(defun tla--widget-archive-put-face-on-location (location) + "Set face to LOCATION based on the location type(ftp, sftp, http or local)." + (let ((face (case (tla--location-type location) + (ftp 'tla-location-ftp) + (sftp 'tla-location-sftp) + (http 'tla-location-http) + (local 'tla-location-local))) + (location (copy-sequence location))) + (put-text-property 0 (length location) + 'face face location) + location)) + +(defun tla--widget-archive-node-refresh () + "Refresh an archive node under the point." + (interactive) + (tla--widget-node-refresh 1 nil + (tla--name-archive + (tla--widget-node-get-name)))) + +(defun tla--widget-archive-node-select-default () + "Mark a widget associated with the default archive. +Unmark widgets not associated with the default archive. +`:archive-defaultp' keyword is used to mark." + (interactive) + (mapc + (lambda (widget) + (when (equal tla--widget-archive-node-default-tag + (widget-get widget :tag)) + (widget-put widget :tag tla--widget-archive-node-tag) + (widget-put widget :archive-defaultp nil) + (widget-value-set widget (widget-value widget)))) + tla--widget-archive-node-list) + (let* ((widget (tla--widget-node-get-at)) + (archive (tla--name-archive (tla--widget-node-get-name) ))) + (tla-my-default-archive archive) + (widget-put widget :tag tla--widget-archive-node-default-tag) + (widget-put widget :archive-defaultp t) + (widget-value-set widget (widget-value widget)))) + +(defun tla--widget-archive-node-unregister-archive () + "Delete the registration of the archive under the point." + (interactive) + (let ((archive (tla--name-archive (tla--widget-node-get-name)))) + (if archive + (progn (tla--unregister-archive archive t) + (tla--widget-node-refresh 2)) + (error "No archive under the point")))) + +(defun tla--widget-archive-node-make-category () + "Make new category in the archive under the point." + (interactive) + (let* ((name (tla--widget-node-get-name)) + (archive (tla--name-archive name)) + (l (tla-name-read "New Category: " + archive + 'prompt))) + (tla-make-category (tla--name-archive l) (tla--name-category l)) + (tla--widget-node-refresh 1 nil (tla--name-archive l)) + (tla--browse-open t + (tla--name-archive l) + (tla--name-category l)) + )) + +(defun tla--widget-archive-node-convert-to-source () + "Convert the archive under the point to a source archive." + (interactive) + (let* ((widget (tla--widget-node-get-at)) + (archive (widget-get widget :archive)) + (location (widget-get widget :archive-location)) + (result (tla--archive-convert-to-source-archive archive location))) + (let ((archive-registered (nth 0 result)) + (archive (nth 1 result)) + (tla-response (nth 3 result))) + (when archive-registered + (tla--widget-node-refresh 2) + (message tla-response) + (tla--widget-archives-root-node-goto + (if (string-match ".+: \\(.+\\)" tla-response) + (match-string-no-properties 1 tla-response) + archive)) + (dvc-flash-line))))) + +(defun tla--widget-archive-node-start-project () + "Start new project in the archive unde the point." + (interactive) + (let* ((archive (tla--name-archive (tla--widget-node-get-name))) + (buffer (current-buffer)) + (p (point)) + (result (tla-start-project archive 'synchronously)) + (category (tla--name-category (car result))) + (branch (tla--name-branch (car result))) + (version (tla--name-version (car result))) + ) + (with-current-buffer buffer + (tla--widget-node-refresh 1 p archive) + (tla--browse-open t + archive category branch version)))) + +(defun tla--widget-archive-node-make-mirror-at-remote () + "Create a mirror for the local archive under the point at somewhere remote." + (interactive) + (let ((archive (tla--name-archive (tla--widget-node-get-name)))) + (unless archive + (error "No archive under the point")) + (tla-mirror-archive archive nil nil nil nil) + (tla--widget-node-refresh 2) + (tla--widget-archives-root-node-goto (format + (if (tla-use-baz-archive-registration) + "%s" + "%s-MIRROR") + archive)) + (dvc-flash-line))) + +(defun tla--widget-archive-node-make-mirror-at-local () + "Create a mirror for the remote archive under the point to local." + (interactive) + (let ((archive (tla--name-archive (tla--widget-node-get-name)))) + (unless archive + (error "No archive under the point")) + (tla-mirror-from-archive archive nil) + (tla--widget-node-refresh 2) + (string-match "\\(.*\\)-SOURCE$" archive) + (tla--widget-archives-root-node-goto + ;; Adding a space not to match SOURCE archive. + (concat (match-string 1 archive) " ")) + (dvc-flash-line))) + +;; ---------------------------------------------------------------------------- +;; Categories +;; ---------------------------------------------------------------------------- +(defvar tla--widget-category-node-map + (let ((map (copy-keymap tla--widget-node-map))) + (define-key map dvc-keyvec-refresh + 'tla--widget-category-node-refresh) + (define-key map (dvc-prefix-add ?b) + 'tla--widget-category-node-make-branch) + map) + "Keymap used on tla--widget-category-node.") + +(easy-menu-define tla--widget-category-node-menu nil + "Menu used on a archive item in `tla-browse-mode' buffer." + '("Category" + ["Update Branches List" tla--widget-category-node-refresh t] + ["Remove Category[NOT IMPLEMENTED]" nil t] + ["Make New Branch..." tla--widget-category-node-make-branch t] + ["Add a Bookmark" tla--widget-node-add-bookmark t] + ["Synchronize Mirror to Remote" + tla--widget-node-synchronize-mirror-to-remote t] + ["Save Name to Kill Ring" tla--widget-node-save-name-to-kill-ring t])) + +(define-widget 'tla--widget-category-node 'tla--widget-node + "Category node in tla-browse." + :tag "c" + :value-create 'tla--widget-category-node-value-create + :tla-type 'category + :face 'tla-category-name + :keymap 'tla--widget-category-node-map + :menu tla--widget-category-node-menu + :archive nil + :category nil) + +(defun tla--browse-expand-categories (archive) + "Expand ARCHIVE widget." + (or (and (not current-prefix-arg) (widget-get archive :args)) + (let ((archive-name (widget-get + (widget-get archive :node) + :archive))) + (mapcar + (lambda (category) + (let ((res `(tree-widget + :open ,(tla--browse-open-list-member archive-name + (car category)) + :has-children t + :dynargs tla--browse-expand-branches + :node (tla--widget-category-node + :archive ,archive-name + :category ,(car category))))) + (widget-put (widget-get res :node) :parent res) + res)) + (let* ((l (cddr (tla--archive-tree-get-archive + archive-name)))) + (when (or (null l) current-prefix-arg) + (tla--archive-tree-build-categories archive-name nil t)) + (cddr (tla--archive-tree-get-archive archive-name))))))) + +(defun tla--widget-category-node-value-create (widget) + "Create values for category WIDGET." + (tla--widget-node-value-create widget :category)) + +(defun tla--widget-category-node-refresh () + "Refresh a category widget at the point." + (interactive) + (let ((name (tla--widget-node-get-name))) + (tla--widget-node-refresh 1 nil + (tla--name-archive name) + (tla--name-category name)))) + +(defun tla--widget-category-node-make-branch () + "Make new branch in the category under the point." + (interactive) + (let* ((name (tla--widget-node-get-name)) + (archive (tla--name-archive name)) + (category (tla--name-category name)) + (l (tla-name-read "New Branch: " + archive + category + 'prompt))) + (tla-make-branch (tla--name-archive l) + (tla--name-category l) + (tla--name-branch l)) + (tla--widget-node-refresh 1 nil + (tla--name-archive l) + (tla--name-category l)) + (tla--browse-open t + (tla--name-archive l) + (tla--name-category l) + (tla--name-branch l)))) + +;; ---------------------------------------------------------------------------- +;; Branch +;; ---------------------------------------------------------------------------- +(defvar tla--widget-branch-node-map + (let ((map (copy-keymap tla--widget-node-map))) + (define-key map dvc-keyvec-refresh + 'tla--widget-branch-node-refresh) + (define-key map (dvc-prefix-add ?v) + 'tla--widget-branch-node-make-version) + (define-key map dvc-keyvec-get + 'tla--widget-branch-node-get-branch) + map) + "Keymap used on tla--widget-branch-node.") + +(easy-menu-define tla--widget-branch-node-menu nil + "Menu used on a archive item in `tla-browse-mode' buffer." + '("Branch" + ["Update Version List" tla--widget-branch-node-refresh t] + ["Remove Branch Registration[NOT IMPLEMENTED]" nil t] + ["Make New Version..." tla--widget-branch-node-make-version t] + ["Get..." tla--widget-branch-node-get-branch t] + ["Add a Bookmark" tla--widget-node-add-bookmark t] + ["Synchronize Mirror to Remote" + tla--widget-node-synchronize-mirror-to-remote t] + ["Save Name to Kill Ring" tla--widget-node-save-name-to-kill-ring t])) + +(define-widget 'tla--widget-branch-node 'tla--widget-node + "Branch node in tla-browse." + :tag "b" + :value-create 'tla--widget-branch-node-value-create + :tla-type 'branch + :face 'tla-branch-name + :keymap 'tla--widget-branch-node-map + :menu tla--widget-branch-node-menu + :archive nil + :category nil + :branch nil) + +(defun tla--browse-expand-branches (category) + "Expand CATEGORY widget." + (or (and (not current-prefix-arg) (widget-get category :args)) + (let* ((parent-node (widget-get category :node)) + (archive-name (widget-get parent-node :archive)) + (category-name (widget-get parent-node :category))) + (mapcar + (lambda (branch) + (let ((res + `(tree-widget + :open ,(tla--browse-open-list-member archive-name + category-name + (car branch)) + :has-children t + :leaf-control tla--widget-version-control + :dynargs tla--browse-expand-versions + :node (tla--widget-branch-node + :archive ,archive-name + :category ,category-name + :branch ,(car branch))))) + (widget-put (widget-get res :node) :parent res) + res)) + (let* ((l (cdr (tla--archive-tree-get-category + archive-name + category-name)))) + (when (or (null l) current-prefix-arg) + (tla--archive-tree-build-branches archive-name + category-name + nil t)) + (cdr (tla--archive-tree-get-category archive-name + category-name))))))) + +(defun tla--widget-branch-node-value-create (widget) + "Create values for branch WIDGET." + (tla--widget-node-value-create widget :branch)) + +(defun tla--widget-branch-node-refresh () + "Refresh a branch widget at the point." + (interactive) + (let ((name (tla--widget-node-get-name))) + (tla--widget-node-refresh 1 nil + (tla--name-archive name) + (tla--name-category name) + (tla--name-branch name)))) + +(defun tla--widget-branch-node-make-version () + "Make new version in the branch under the point." + (interactive) + (let* ((name (tla--widget-node-get-name)) + (archive (tla--name-archive name)) + (category (tla--name-category name)) + (branch (tla--name-category name)) + (l (tla-name-read "New Version: " + archive + category + branch + 'prompt))) + (tla-make-version (tla--name-archive l) + (tla--name-category l) + (tla--name-branch l) + (tla--name-version l)) + (tla--widget-node-refresh 1 nil + (tla--name-archive l) + (tla--name-category l) + (tla--name-branch l)) + (tla--browse-open t + (tla--name-archive l) + (tla--name-category l) + (tla--name-branch l) + (tla--name-version l)))) + +(defun tla--widget-branch-node-get-branch () + "Run `tla get' against the branch at point." + (interactive) + (let* ((name (tla--widget-node-get-name)) + (archive (tla--name-archive name)) + (category (tla--name-category name)) + (branch (tla--name-branch name)) + (directory (expand-file-name + (dvc-read-directory-name + (format "Restore \"%s\" to: " + (progn + (unless branch + (error "No branch under the point")) + (tla--name-construct + archive category branch))))))) + (if branch + (tla-get directory + 'ask + archive + category + branch) + (error "No branch under the point")))) + + +;; ---------------------------------------------------------------------------- +;; Version +;; ---------------------------------------------------------------------------- +(defvar tla--widget-version-node-map + (let ((map (copy-keymap tla--widget-node-map))) + (define-key map dvc-keyvec-refresh + 'tla--widget-version-node-show-revisions) + (define-key map dvc-keyvec-get + 'tla--widget-version-node-get-version) + (define-key map dvc-keyvec-tag + 'tla--widget-version-node-tag) + (define-key map [?L] + 'tla--widget-version-node-add-to-library) + map) + "Keymap used on tla--widget-version-node.") + +(easy-menu-define tla--widget-version-node-menu nil + "Menu used on a archive item in `tla-browse-mode' buffer." + '("Version" + ["Show Revisions" tla--widget-version-node-show-revisions t] + ["Remove Version Registration[NOT IMPLEMENTED]" nil t] + ["Get..." tla--widget-version-node-get-version t] + ["Add to Library" tla--widget-version-node-add-to-library t] + ["Add a Bookmark" tla--widget-node-add-bookmark t] + ["Synchronize Mirror to Remote" + tla--widget-node-synchronize-mirror-to-remote t] + ["Put Tag..." tla--widget-version-node-tag t] + ["Save Name to Kill Ring" tla--widget-node-save-name-to-kill-ring t])) + +(define-widget 'tla--widget-version-node 'tla--widget-node + "Version node in tla-browse." + :tag "v" + :value-create 'tla--widget-version-node-value-create + :tla-type 'version + :face 'tla-version-name + :keymap 'tla--widget-version-node-map + :menu tla--widget-version-node-menu + :archive nil + :category nil + :branch nil + :version nil + :open-subtree 'tla--widget-version-node-open-subtree + :close-subtree 'tla--widget-version-node-open-subtree) + + +(define-widget 'tla--widget-version-control 'tree-widget-empty-control + "Control widget that represents a leaf version node." + :tag "[->]" + :format "%[%t%]" + :action 'tla--widget-version-control-show-revisions) + +(defun tla--widget-version-control-show-revisions (widget &optional event) + "Show revisions in a version associated with WIDGET. +The version is under the point or place where click EVENT is created." + (if event + (mouse-set-point event)) + (let ((pos (next-single-property-change (point) + 'widget + (current-buffer) + (line-end-position)))) + (when pos + (tla--widget-version-node-show-revisions pos)))) + +(defun tla--browse-expand-versions (branch) + "Expand BRANCH widget." + (or (and (not current-prefix-arg) (widget-get branch :args)) + (let* ((parent-node (widget-get branch :node)) + (archive-name (widget-get parent-node :archive)) + (category-name (widget-get parent-node :category)) + (branch-name (widget-get parent-node :branch))) + (mapcar (lambda (version) + `(tla--widget-version-node + :archive ,archive-name + :category ,category-name + :branch ,branch-name + :version ,(car version))) + (let* ((l (cdr (tla--archive-tree-get-branch archive-name + category-name + branch-name)))) + (when (or (null l) current-prefix-arg) + (tla--archive-tree-build-versions archive-name + category-name + branch-name + nil t)) + (cdr (tla--archive-tree-get-branch archive-name + category-name + branch-name))))))) + +(defun tla--widget-version-node-value-create (widget) + "Create values for version WIDGET." + (tla--widget-node-value-create widget :version)) + +(defun tla--widget-version-node-show-revisions (&optional point) + "Show revisions in the version under the POINT. +If POINT is nil, use the point under `point'." + (interactive) + (let ((name (tla--widget-node-get-name (or point (point))))) + (tla-revisions (tla--name-archive name) + (tla--name-category name) + (tla--name-branch name) + (tla--name-version name) + nil nil))) + +(defun tla--widget-version-node-get-version () + "Run \"tla get\" against the version at point." + (interactive) + (let* ((name (tla--widget-node-get-name)) + (archive (tla--name-archive name)) + (category (tla--name-category name)) + (branch (tla--name-branch name)) + (version (tla--name-version name)) + (directory (expand-file-name + (dvc-read-directory-name + (format "Restore \"%s\" to: " + (progn + (unless version + (error "No version under the point")) + (tla--name-construct + archive category branch version))))))) + (if version + (tla-get directory + 'ask + archive + category + branch + version) + (error "No version under the point")))) + +(defun tla--widget-version-node-add-to-library () + "Run \"tla library-add\" against the version at point." + (interactive) + (let* ((name (tla--widget-node-get-name)) + (archive (tla--name-archive name)) + (category (tla--name-category name)) + (branch (tla--name-branch name)) + (version (tla--name-version name))) + (if version + (tla-library-add archive category branch version) + (error "No version under the point")))) + +(defun tla--widget-version-node-tag () + "Run tla tag from the version under the point." + (interactive) + (let* ((from (tla--widget-node-get-name)) + (from-fq (tla--name-construct from)) + (to (tla-name-read (format "Tag from `%s' to: " from-fq) + 'prompt 'prompt 'prompt 'prompt)) + (to-fq (tla--name-construct to))) + (unless from + (error "No version under the point")) + (unless to-fq + (error "Wrong version tagged to is given")) + (save-excursion + (tla--version-tag-internal from-fq to-fq 'synchronously)) + ;; + (tla--browse-open nil + (tla--name-archive to-fq)) + (tla--widget-node-refresh 1 + 'name + (tla--name-archive to-fq)) + (tla--browse-open nil + (tla--name-archive to-fq) + (tla--name-category to-fq)) + + (tla--widget-node-refresh 1 + 'name + (tla--name-archive to-fq) + (tla--name-category to-fq)) + (tla--browse-open nil + (tla--name-archive to-fq) + (tla--name-category to-fq) + (tla--name-branch to-fq)) + (tla--widget-node-refresh 1 + 'name + (tla--name-archive to-fq) + (tla--name-category to-fq) + (tla--name-branch to-fq)) + (tla--browse-open t + (tla--name-archive to-fq) + (tla--name-category to-fq) + (tla--name-branch to-fq) + (tla--name-version to-fq)))) + +(defun tla--widget-version-node-open-subtree (widget) + "List revisions in the version associated with WIDGET." + (tla-revisions (widget-get widget :archive) + (widget-get widget :category) + (widget-get widget :branch) + (widget-get widget :version) + nil nil)) + +;; ---------------------------------------------------------------------------- +;; Entry point +;; ---------------------------------------------------------------------------- +;; TODO: Filtered by GROUP in bookmark +;;;###autoload +(defun tla-browse (&optional initial-open-list append) + "Browse registered archives as trees within one buffer. +You can specify the node should be opened by alist, +INITIAL-OPEN-LIST. If APPEND is nil, the nodes not in +INITIAL-OPEN-LIST are made closed. If non-nil, the nodes +already opened are kept open." + + (interactive) + (switch-to-buffer (dvc-get-buffer-create tla-arch-branch + tla--browse-buffer-type)) + (make-local-variable 'tla--browse-open-list) + (setq truncate-lines t) + + (let (building) + (if (zerop (buffer-size)) + (progn (setq building t) + (tla--browse-set-initial-open-list initial-open-list t)) + (if append + (progn + (setq building nil) + (tla--browse-set-initial-open-list initial-open-list nil)) + (if (y-or-n-p (format "Remove old %s? " (buffer-name))) + (progn (setq building t) + (tla--browse-set-initial-open-list initial-open-list nil)) + (setq building nil) + (tla--browse-set-initial-open-list initial-open-list t)))) + + (if building + (progn + (tla--browse-erase-buffer) + (tla--browse-build-buffer)) + (mapc + (lambda (elt) + (tla--browse-open nil + (tla--name-archive elt) + (tla--name-category elt) + (tla--name-branch elt) + (tla--name-version elt))) + tla--browse-open-list))) + (goto-char (point-min)) + (tla-browse-mode)) + +(defun tla--browse-set-initial-open-list (list clearp) + "Insert LIST to `tla--browse-open-list'. +If CLEARP is set, clear `tla--browse-open-list' before insertion. +This is a helper function for `tla-browse'." + (when clearp + (setq tla--browse-open-list nil)) + (mapc + (lambda (elt) + (tla--browse-open-list-add (tla--name-archive elt) + (tla--name-category elt) + (tla--name-branch elt) + (tla--name-version elt))) + list)) +(defun tla--browse-erase-buffer () + "Erase *tla-browse* buffer." + (let ((inhibit-read-only t)) + (erase-buffer)) + ;; remove-overlays is not portable enough. + (mapc #'delete-overlay (overlays-in + (point-min) (point-max)))) + +(defun tla--browse-build-buffer () + "Insert contents of *tla-buffer*." + ;; Tla config + (widget-create 'tree-widget + :open t + :node '(item :format "%[%t%]\n" + :tag "Personal Configuration") + :has-chidren t + `(tla--widget-my-id ,(tla-my-id))) + + (widget-insert "\n") + + ;; Archives + (add-hook 'tree-widget-after-toggle-functions + 'tla--browse-open-tracker) + (widget-create 'tree-widget + :open t + :node `(tla--widget-root-node + :tla-type archives-root + :tag "Archives" + :keymap tla--widget-archives-root-node-map + :menu ,tla--widget-archives-root-node-menu) + :has-children t + :dynargs 'tla--browse-expand-archives) + ;; Libraries + ;; TODO + (widget-setup)) + +(defun tla--browse-toggle-subtree-maybe () + "Run `tla--browse-toggle-subtree'. +Before running a widget is searched and move the point to +the widget if it is found. If no widget is found, +`widget-button-press'." + (interactive) + (let ((p (next-single-property-change (line-beginning-position) + 'widget + nil + (line-end-position)))) + (if (and p (tla--widget-node-get-type p)) + (tla--widget-node-toggle-subtree p) + (widget-button-press (point))))) + +(defun tla--browse-dash () + "Move the point to the place where a widget is in the current line." + (interactive) + (let ((p (next-single-property-change (line-beginning-position) + 'widget + nil + (line-end-position)))) + (when (and p (tla--widget-node-get-type p)) + (goto-char p) + (dvc-flash-line)))) + +(defvar tla-browse-map + (let ((map (copy-keymap widget-keymap))) + (define-key map dvc-keyvec-help 'describe-mode) + (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) 'tla-bookmarks) + (define-key map [return] 'tla--browse-toggle-subtree-maybe) + (define-key map "\C-m" 'tla--browse-toggle-subtree-maybe) + (define-key map " " 'tla--browse-dash) + (define-key map dvc-keyvec-next 'next-line) + (define-key map dvc-keyvec-previous 'previous-line) + (define-key map dvc-keyvec-quit 'kill-this-buffer) + (define-key map [?+] 'tla--widget-node-toggle-subtree-recursive) + map) + "Keymap used in `tla-browse-mode'.") + +(defun tla-browse-mode () + "Mode for browsing tla's archives. +Don't use this function. Instead call `tla-browse'." + (dvc-install-buffer-menu) + (setq major-mode 'tla-browse-mode + mode-name "tla-browse") + (use-local-map tla-browse-map) + (set-buffer-modified-p nil) + (run-hooks 'tla-browse-mode-hook)) + +(provide 'tla-browse) + +;; Local Variables: +;; End: +;;; tla-browse.el ends here diff --git a/dvc/lisp/tla-core.el b/dvc/lisp/tla-core.el new file mode 100644 index 0000000..bc5897b --- /dev/null +++ b/dvc/lisp/tla-core.el @@ -0,0 +1,1906 @@ +;;; tla-core.el --- Core of xtla + +;; Copyright (C) 2003-2004 by all contributors + +;; Author: Stefan Reichoer, +;; Contributions from: +;; Matthieu Moy +;; Masatake YAMATO +;; Milan Zamazal +;; Martin Pool +;; Robert Widhopf-Fenk +;; Mark Triggs + +;; 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 xtla.el + + +;;; History: + +;; This file was created to split out some commonly-used functionality. + +;;; Code: +(eval-and-compile (require 'dvc-core)) +(eval-and-compile (require 'dvc-utils)) + +(require 'tla-defs) +(require 'tla-autoconf) +(eval-and-compile (require 'dvc-lisp)) + +(require 'ewoc) + +;; ---------------------------------------------------------------------------- +;; Compatibility stuff +;; ---------------------------------------------------------------------------- +(eval-when-compile + (require 'cl) + (if (featurep 'xemacs) + (require 'dvc-xemacs) + (require 'dvc-emacs))) + +(require 'pp) + +;; +;; Arch branch: baz, tla, ... +;; +(defun tla--executable () + "Return the Arch executable to use. +Can be either tla or baz." + (cond ((eq tla-arch-branch 'tla) + tla-executable) + ((eq tla-arch-branch 'baz) + baz-executable))) + +(defun tla-arch-branch-name () + "Return the name of the branch of arch, as a string." + (symbol-name tla-arch-branch)) + +(defun tla-arch-branch-name-caps () + "Return the name of the branch of arch, as a capitalized string." + (capitalize (symbol-name tla-arch-branch))) + + + + +;;;###autoload +(defun tla-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 {arch} +directory in a parent buffer of LOCATION. This is therefore very +fast. + +If LOCATION is nil, the tree root is returned, and it is +guaranteed to end in a \"/\" character. + +If NO-ERROR is non-nil, don't raise an error if LOCATION is not an +arch managed tree (but return nil)." + (interactive) + (dvc-tree-root-helper "{arch}/=tagging-method" (or interactive + (interactive-p)) + "%S is not in an arch-managed tree!" + location no-error)) + +(defun tla--last-visited-inventory-buffer () + "Return the last visited xtla's inventory buffer." + (let ((inventories (remove nil (mapcar + (lambda (elt) + (when (buffer-live-p (cadr elt)) + elt)) + (cdr (assoc 'inventory dvc-buffers-tree))))) + (bl (buffer-list))) + (cadr (car (sort inventories (lambda (a b) + (let ((aindex (dvc-position (cadr a) bl)) + (bindex (dvc-position (cadr b) bl))) + (< aindex bindex)))))))) + +(defun tla-show-inventory-buffer () + "Switch to the last visited inventory buffer." + (interactive) + (dvc-switch-to-buffer (tla--last-visited-inventory-buffer))) + +(defun tla-use-tla () + "From now, use tla." + (interactive) + (tla-autoconf-reset) + (setq tla-arch-branch 'tla)) + +(defun tla-use-baz () + "From now, use baz." + (interactive) + (tla-autoconf-reset) + (setq tla-arch-branch 'baz)) + +(defun tla--run-tla-async (arguments &rest keys) + "Run tla asynchronously. See `dvc-run-dvc-async'" + (if (and tla-arch-branch (not (eq tla-arch-branch 'none))) + (apply 'dvc-run-dvc-async tla-arch-branch arguments keys) + (error "No tla variant is installed on your system"))) + +(defun tla--run-tla-sync (arguments &rest keys) + "Run tla synchronously. See `dvc-run-dvc-sync'" + (if (and tla-arch-branch (not (eq tla-arch-branch 'none))) + (apply 'dvc-run-dvc-sync tla-arch-branch arguments keys) + (error "No tla variant is installed on your system"))) + +;; ---------------------------------------------------------------------------- +;; Arch name manipulators +;; ====================== +;; +;; Normally in xtla, a name, a revision specifier is represented as a +;; list like: +;; +;; ("archive" "category" "branch" "version" "revision") +;; +;; Nil is permitted as the element. However the list length must be 5 +;; like: +;; +;; (nil "category" "branch" nil nil) +;; +;; In other hand, in tla command, the name must be represented as a +;; string like: +;; +;; "archive/category--branch--version--revision" +;; +;; So we have to convert a name in different representation in many +;; cases. +;; +;; * tla--name-split-* is for converting from a string representation +;; to a list representation. There are semi-qualified version and +;; fully-qualified version. +;; +;; - semi-qualified: "category--branch--version--revision". +;; `tla--name-split-semi-qualified' expects a name string without +;; archive component. The archive field of returned list is filled +;; with nil. +;; +;; - fully-qualified: "archive/category--branch--version--revision". +;; `tla--name-split' expects a name string including archive. +;; +;; * tla--name-construct-* is for converting from a list +;; representation to a string representation. The functions accept +;; arguments two ways. +;; +;; - normal passing: (tla--name-construct "archive" "category"...) +;; - packed passing: (tla--name-construct '("archive" "category"...)) +;; +;; There are semi-qualified version and fully-qualified version. +;; - semi-qualified: `tla--name-construct-semi-qualified' connects +;; arguments with "--". +;; - fully-qualified: `tla--name-construct" connects the first argument +;; and the rest with "/". About the rest, +;; `tla--name-construct-semi-qualified' is applied. +;; +;; * tla--name-{archive|category|branch|version|revision} is for +;; extracting a component from a name. The both representations are +;; acceptable. +;; +;; * tla--name-mask is for replace a component in the name list with nil. +;; +;; ---------------------------------------------------------------------------- + +;; +;; String representation -> List representation +;; +(defun tla--name-split-semi-qualified (name &optional archive) + "Split \"--\" connected string NAME into 5 elements list. +The first element is always nil if ARCHIVE is not given. +If ARCHIVE is given, use it as the first. +Even if the elements in name are less than 5, the list is filled by nil +to make the length 5. + + ELISP> (tla--name-split-semi-qualified \"branch--category--version--revision\" + \"archive\") + (\"archive\" \"branch\" \"category\" \"version\" \"revision\") + + ELISP> (tla--name-split-semi-qualified + \"branch--category--version--revision\") + (nil \"branch\" \"category\" \"version\" \"revision\") + + ELISP> (tla--name-split-semi-qualified \"branch--category--version\") + (nil \"branch\" \"category\" \"version\" nil) + + ELISP> (tla--name-split-semi-qualified + \"branch--category--version\" \"archive\") + (\"archive\" \"branch\" \"category\" \"version\" nil) + + ELISP> (tla--name-split-semi-qualified \"branch--category\" \"archive\") + (\"archive\" \"branch\" \"category\" nil nil) + + ELISP> (tla--name-split-semi-qualified \"branch--category\" nil) + (nil \"branch\" \"category\" nil nil) + + ELISP> (tla--name-split-semi-qualified \"branch--category--\" nil) + (nil \"branch\" \"category\" \"\" nil)" + (let ((list (tla--name-split-semi-qualified-internal name))) + (while (> 4 (length list)) + (setq list (cons nil list))) + (let ((result (cons archive (nreverse list)))) + (when (tla--is-version-string (nth 2 result)) + (setq result (list (nth 0 result) + (nth 1 result) + "" + (nth 2 result) + (nth 3 result)))) + result))) + +(defun tla--is-version-string (string) + "Non-nil if STRING is a candidate for a version name. +That is, if it contains only digits and dots. +The regexp here is less strict than the one of tla, but must verify +\(tla--is-version-string string) => string can't be a branch name." + (and string (string-match "^[0-9\.]+$" string))) + +(defun tla--name-split-semi-qualified-internal (name) + "Helper function for `tla--name-split-semi-qualified'. +Splits a semi-qualified NAME." + (if (string-match "^\\(.+\\)--\\(\\([^-]\\|-[^-]\\)*\\)" name) + (cons (match-string 2 name) + (tla--name-split-semi-qualified-internal + (match-string 1 name))) + (cons name nil))) + +(defun tla--name-split (name) + "Parse a fully qualified revision NAME, but possibly incomplete. +email@address.com--arch/cat--branch--ver -> + (\"email@address.com--arch\" \"cat\" \"branch\" \"ver\" nil) +email@address.com--arch/cat -> + (\"email@address.com--arch\" \"cat\" nil nil nil) +email@address.com--arch -> + (\"email@address.com--arch\" nil nil nil nil)" + (if (string-match "\\(.*\\)/\\(.*\\)" name) + (tla--name-split-semi-qualified (match-string 2 name) (match-string 1 name)) + (if (string= name "") + (list nil nil nil nil nil) + (list name nil nil nil nil)))) + + +;; +;; List representation -> string +;; +(defun tla--name-construct-semi-qualified (&rest comp) + "Concatenate COMP with \"--\". +This function can accept strings or a list which contains strings. + + ELISP> (tla--name-construct-semi-qualified \"a\" \"b\" \"c\") + \"a--b--c\" + ELISP> (tla--name-construct-semi-qualified (list \"a\" \"b\" \"c\")) + \"a--b--c\"" + (if (consp (car comp)) (setq comp (car comp))) + (if (string= (cadr comp) "") + ;; Unnamed branch. + (concat (car comp) "--" + (mapconcat 'identity (remove nil (cddr comp)) "--")) + (mapconcat 'identity (remove nil comp) "--"))) + +(defun tla--name-construct (archive &optional + category + branch + version + revision) + "Create the revision name ARCHIVE/CATEGORY--BRANCH--VERSION--REVISION. +The arguments may be nil. If ARCHIVE is a revision name list like + (archive category branch version revision), the list element is mapped +to arguments before creating the fully qualified revision name. + +If the branch name is the empty string and the version is defined, +then, we have an unnamed branch. The full name is +archive/category--version." + (when (consp archive) + (setq category (tla--name-category archive) + branch (tla--name-branch archive) + version (tla--name-version archive) + revision (tla--name-revision archive) + ;; archive must be last + archive (tla--name-archive archive))) + (let ((semi (tla--name-construct-semi-qualified + category branch version revision))) + (concat + (and archive (not (string= archive "")) + (concat archive (when category "/"))) + semi))) + +(defun tla-revision-id-to-list (rev-id) + (dvc-trace "rev-id=%S" rev-id) + (unless (or (eq (car rev-id) 'tla) + (eq (car rev-id) 'baz)) + (error "%S is not a tla/baz revision ID." rev-id)) + (let* ((data (dvc-revision-get-data rev-id)) + (type (dvc-revision-get-type rev-id))) + (dvc-trace "data=%S" data) + (dvc-trace "type=%S" type) + (case type + (revision (car data)) + (previous-revision (tla-revision-direct-ancestor + (nth 1 (car data)) (nth 1 data))) + (otherwise (error "TODO: type of revision not implemented: %S" type))))) + +;; +;; Get a component from a list or string. +;; +(defun tla--name-archive (target) + "Get archive component from TARGET. +Both representation of TARGET, a string and a list is acceptable." + (when (stringp target) + (setq target (tla--name-split target))) + (car target)) + +(defun tla--name-category (target) + "Get category component from TARGET. +Both representation of TARGET, a string and a list is acceptable." + (when (stringp target) + (setq target (tla--name-split target))) + (cadr target)) + +(defun tla--name-branch (target) + "Get branch component from a TARGET. +Both representation of TARGET, a string and a list is acceptable." + (when (stringp target) + (setq target (tla--name-split target))) + (car (cddr target))) + +(defun tla--name-version (target) + "Get version component from TARGET. +Both representation of TARGET, a string and a list is acceptable." + (when (stringp target) + (setq target (tla--name-split target))) + (cadr (cddr target))) + +(defun tla--name-revision (target) + "Get revision component from TARGET. +Both representation of TARGET, a string and a list is acceptable." + (when (stringp target) + (setq target (tla--name-split target))) + (car (cddr (cddr target)))) + +;; +;; Utilities +;; Mask a specified component in the name. +;; +(defun tla--name-mask (original do-construct-p + &optional + archive-mask + category-mask + branch-mask + version-mask + revision-mask) + "Mask ORIGINAL, a tla revision name by masks; and return the masked value. + +If DO-CONSTRUCT-P is given, the result is converted to a string by +`tla--name-construct'. + +ARCHIVE-MASK, CATEGORY-MASK, BRANCH-MASK, VERSION-MASK and REVISION-MASK should +be either nil or t, and indicate whether that field should be masked. + +If a mask value is nil, the associated element in ORIGINAL is set to nil. +Else If a mask value is a string, the associated element in ORIGINAL is set +to the string. +Else the associated element in ORIGINAL is not changed. + +Examples: + ELISP> (tla--name-mask '(\"a\" \"c\" \"b\" \"v\" \"r\") nil t t t t nil) + (\"a\" \"c\" \"b\" \"v\" nil) + + ELISP> (tla--name-mask '(\"a\" \"c\" \"b\" \"v\" \"r\") nil t t t nil nil) + (\"a\" \"c\" \"b\" nil nil) + + ELISP> (tla--name-mask '(\"a\" \"c\" \"b\" \"v\" \"r\") t t t t nil nil) + \"a/c--b\" + ELISP> (tla--name-mask '(\"a\" \"c\" \"b\" \"v\" \"r\") t nil nil nil nil t) + \"r\" + ELISP> (tla--name-mask '(\"a\" \"c\" \"b\" \"v\" \"r\") t nil nil nil t t) + \"v--r\" + ELISP>" + (when (stringp original) + (setq original (tla--name-split original))) + (when (consp original) + (let ((masked (list + (if archive-mask + (if (stringp archive-mask) + archive-mask + (tla--name-archive original))) + (if category-mask + (if (stringp category-mask) + category-mask + (tla--name-category original))) + (if branch-mask + (if (stringp branch-mask) + branch-mask + (tla--name-branch original))) + (if version-mask + (if (stringp version-mask) + version-mask + (tla--name-version original))) + (if revision-mask + (if (stringp revision-mask) + revision-mask + (tla--name-revision original)))))) + (if do-construct-p + (tla--name-construct masked) + masked)))) + +(defun tla--name-match (target mask) + "Compare the fully qualified revision list TARGET with a MASK. +Each parameter is a list. The elements of the both lists are compared +via a regexp match. When the mask part of a component is nil, this +comparision is skipped. +Here are some examples: +\(tla--name-match + '(\"xsteve@nit.at--public\" \"xtla\" \"main\" \"0.1\" \"patch-116\") + '(nil \"xt.*\" \"main\" nil nil)) => t +\(tla--name-match + '(\"xsteve@nit.at--public\" \"xtla\" \"main\" \"0.1\" \"patch-116\") + '(nil \"xt.*\" \"devel\" nil nil)) => nil" ;" + (let ((tl target) + (ml mask) + (t-part) + (m-part) + (matching t)) + (while tl + (setq t-part (car tl)) + (setq m-part (car ml)) + (when m-part + (setq matching (string-match m-part t-part))) + (if matching + (progn + (setq tl (cdr tl)) + (setq ml (cdr ml))) + (setq tl nil))) + (if matching t nil))) + + +(defun tla--name-match-from-list (target match-list) + "Match TARGET against a list of possible matches. +Every entry of MATCH-LIST is a list that contains a +match element and a possible result. +The target is matched against the elements in the match-list. +If a match is found return the corresponding result, +otherwise return nil." + (let ((ml match-list) + (match) + (data) + (result)) + (while (and (not result) ml) + (setq match (caar ml)) + (setq data (car (cdar ml))) + ;;(message "match: %s, data: %s" match data) + (setq result (when (tla--name-match target match) data)) + (setq ml (cdr ml))) + result)) + +;; example: +;;(setq tla-apply-patch-mapping +;; '(((nil "atla" nil nil nil) "~/work/tlaaaa") +;; ((nil "xtla" nil nil nil) "~/work/tla/xtla"))) +;;(tla--name-match-from-list +;; '("xsteve@nit.at--public" "xtla" "main" "0.1" "patch-116") tla-apply-patch-mapping) + +;; TODO: Use tla--archive-tree. +(defun tla--version-head (archive category branch version) + "Return the newest revision for ARCHIVE/CATEGORY--BRANCH--VERSION." + (tla--run-tla-sync (list "revisions" + (tla--name-construct + archive + category + branch + version)) + :finished (lambda (output error status arguments) + (with-current-buffer output + (goto-char (point-max)) + (re-search-backward "^.") + (buffer-substring-no-properties + (point) (line-end-position)))))) + +;; ---------------------------------------------------------------------------- +;; Archive tree manipulators +;; ---------------------------------------------------------------------------- +(defvar tla--archive-tree-archives-complete nil + "Non-nil when the list of archives is built. + +In tla--archive-tree, the list of archives is built by running \"baz +archives\", but some items can be added also while adding categories, +branches, ... In this case, this variable remains nil so that \"baz +archives\" is ran next time, to get the full list of archives.") + +(defvar tla--archive-tree nil + "Arch archive/category/branch/version/revision are stored in assoc list: + + ((\"xsteve@nit.at--public\" \"http://arch.xsteve.at/2004\") + [...] + (\"mbp@sourcefrog.net--2004\" + \"http://sourcefrog.net/arch/mbp@sourcefrog.net--2004\" + (\"xtla\") + (\"tilly\") + [...] + (\"dupes\" + (\"mainline\" + (\"0.1\"))) + [...] + (\"archzoom\")) + (\"mark@dishevelled.net--2003-mst\" + \"http://members.iinet.net.au/~mtriggs/arch/\") + (\"lord@emf.net--2004\" + \"http://regexps.srparish.net/{archives}/lord@emf.net--2004\") + [...] + (\"Matthieu.Moy@imag.fr--public\" + \"http://www-verimag.imag.fr/webdav/moy/public\" + (\"xtla\" + (\"main\" + (\"0.1\" + (\"patch-228\" + \"Merged from Robert (patch8-9), Milan (patch21-22), Stefan (patch5-8)\" + \"Matthieu Moy \" + \"2004-06-03 20:13:11 GMT\") + (\"patch-227\" + \"Fix default-directory in tla--run-tla-sync, fix in dvc-diff-ediff\" + \"Matthieu Moy \" + \"2004-06-03 15:26:15 GMT\") + [...] + (\"patch-1\" + \"typo\" + \"Matthieu Moy \" + \"2004-04-07 22:57:00 GMT\") + (\"base-0\" + \"tag of xsteve@nit.at--public/xtla--main--0.1--patch-5\" + \"Matthieu Moy \" \"2004-04-07 22:52:39 GMT\"))))) + [...] + ) + +This list is initially empty, and is built/rebuilt on demand.") + +;; Utilities +(defun tla--archive-tree-setcdr (parent value &optional rest) + "In PARENT, update VALUE. +REST are the items that are already present." + (let* ((current (cdr parent)) + (list-details (assoc value current))) + (if (or (null current) (null list-details)) + ;; rest is '("summary" "creator" "date") when value is "patch-N" + (setcdr parent (cons (cons value rest) current)) + (if (and list-details rest) + ;; Field already there. update details. + (setcdr list-details rest))))) + +(defun tla--archive-tree-setcddr (parent value) + "In PARENT, update VALUE." + (let ((current (cddr parent))) + (if (or (null current) (null (assoc value current))) + (setcdr (cdr parent) (cons (cons value nil) current))))) + +;; Archive +(defun tla--archive-tree-add-archive (archive locations &optional old) + "Add ARCHIVE at LOCATIONS to the archive tree. +If OLD is provided, it is an old archive tree from which some +information can be found (this is useful to keep the category/branch/version +info for existing archives)." + (if (tla--archive-tree-get-archive archive) + (let* ((a (tla--archive-tree-get-archive archive)) + (val (cdr a)) + (oldlocation (car val))) + (setcar (cdr a) (or locations oldlocation))) + (let ((oldinfo (tla--archive-tree-get-archive archive old)) + (newinfo (list archive locations))) + (when oldinfo + (setcdr (cdr newinfo) (cddr oldinfo))) ;; list of versions. + (setq tla--archive-tree (cons newinfo + tla--archive-tree))))) + +(defun tla--archive-tree-get-archive (archive &optional archive-tree) + "Get the value of ARCHIVE from ARCHIVE-TREE. +If ARCHIVE-TREE is not given, `tla--archive-tree' is used." + (assoc archive (or archive-tree tla--archive-tree))) + +;; Category +(defun tla--archive-tree-add-category (archive category) + "Add a new category to ARCHIVE named CATEGORY." + (tla--archive-tree-add-archive archive nil) + (tla--archive-tree-setcddr + (tla--archive-tree-get-archive archive) + category)) + +(defun tla--archive-tree-get-category (archive category) + "From ARCHIVE, get CATEGORY." + (assoc category (cdr (cdr (tla--archive-tree-get-archive archive))))) + +;; Branch +(defun tla--archive-tree-add-branch (archive category branch) + "Add a new branch to ARCHIVE's CATEGORY named BRANCH." + (tla--archive-tree-add-category archive category) + (tla--archive-tree-setcdr + (tla--archive-tree-get-category archive category) + branch)) + +(defun tla--archive-tree-get-branch (archive category branch) + "Get a branch from ARCHIVE's CATEGORY named BRANCH." + (assoc branch (cdr (tla--archive-tree-get-category + archive category)))) + +;; Version +(defun tla--archive-tree-add-version (archive category branch version) + "Add a new version to ARCHIVE CATEGORY BRANCH named VERSION." + (tla--archive-tree-add-branch archive category branch) + (tla--archive-tree-setcdr + (tla--archive-tree-get-branch archive category branch ) + version)) + +(defun tla--archive-tree-get-version (archive category branch version) + "Get a version from ARCHIVE CATEGORY BRANCH named VERSION." + (assoc version (cdr (tla--archive-tree-get-branch + archive category branch)))) + +;; Revision +(defun tla--archive-tree-add-revision (archive category branch version revision + &optional rev-struct) + "Add a new revision to ARCHIVE CATEGORY BRANCH VERSION named REVISION." + (tla--archive-tree-add-version archive category branch version) + (tla--archive-tree-setcdr + (tla--archive-tree-get-version archive category branch version) + revision rev-struct)) + +(defun tla--archive-tree-get-revision (archive category branch version revision) + "Get a revision from ARCHIVE CATEGORY BRANCH VERSION named REVISION." + (assoc revision (cdr (tla--archive-tree-get-version + archive category branch version)))) + +(defun tla--archive-tree-get-revision-struct (archive category branch version revision) + "Get a revision from ARCHIVE CATEGORY BRANCH VERSION named REVISION. + +Return a structure `tla--revision'." + (or (cdr (assoc revision (cdr (tla--archive-tree-get-version + archive category branch version)))) + (progn + (tla--archive-tree-build-revisions + archive category branch version t) + (cdr (assoc revision (cdr (tla--archive-tree-get-version + archive category branch version))))))) + +;; Archive tree builders +(defun tla--archive-tree-build (basename &optional use-cache ignore-error) + "Generic version of tla--archive-tree-build-*. +BASENAME is used as a base for this tree. +If USE-CACHE is non-nil, load details from the cache where possible. +If IGNORE-ERROR is non-nil, don't throw errors." + (when (stringp basename) + (setq basename (tla--name-split basename))) + (let ((archive (tla--name-archive basename)) + (category (tla--name-category basename)) + (branch (tla--name-branch basename)) + (version (tla--name-version basename))) + (cond + (version + (tla--archive-tree-build-revisions archive + category + branch + version + use-cache + ignore-error)) + (branch + (tla--archive-tree-build-versions archive + category + branch + use-cache + ignore-error)) + (category + (tla--archive-tree-build-branches archive + category + use-cache + ignore-error)) + (archive + (tla--archive-tree-build-categories archive + use-cache + ignore-error)) + (t + (tla--archive-tree-build-archives use-cache + ignore-error))))) + +(defun tla--archive-tree-build-archives (&optional use-cache ignore-error) + "Builds the list of archives. +If USE-CACHE is non-nil, load details from the cache where possible. +If IGNORE-ERROR is non-nil, don't throw errors." + (when (or (not use-cache) + (not tla--archive-tree) + (not tla--archive-tree-archives-complete)) + (tla--run-tla-sync `("archives" ,(when + (tla-archives-has-all-locations-option) + "--all-locations")) + :finished 'dvc-null-handler + :error + (if ignore-error + 'dvc-null-handler + 'dvc-default-error-function)) + (setq tla--archive-tree-archives-complete t) + (let ((old-archive-tree tla--archive-tree)) + (setq tla--archive-tree nil) + (save-excursion + (let (archive-name) + (set-buffer dvc-last-process-buffer) + (goto-char (point-min)) + (while (> (line-end-position) (line-beginning-position)) + (setq archive-name (buffer-substring-no-properties + (line-beginning-position) + (line-end-position))) + (forward-line 1) + (let (archive-locations) + (while (looking-at "^ \\(.*\\)$") + (push (match-string 1) archive-locations) + (forward-line 1)) + (tla--archive-tree-add-archive archive-name + ;; + ;; Make master archive becoming the + ;; first of list of the list. + ;; + (reverse archive-locations) + old-archive-tree)))))))) + +(defun tla--archive-tree-build-categories (archive &optional + use-cache + ignore-error) + "Build the list of categories for ARCHIVE in `tla--archive-tree'. +If USE-CACHE is non-nil, load details from the cache where possible. +If IGNORE-ERROR is non-nil, don't throw errors." + (tla--archive-tree-build-archives t ignore-error) + (when (or (not use-cache) + (not (cddr (tla--archive-tree-get-archive archive)))) + (let ((basename archive)) + (message "building categories for `%s'..." basename) + (tla--run-tla-sync (list "categories" basename) + :finished 'dvc-null-handler + :error + (if ignore-error + 'dvc-null-handler + 'dvc-default-error-function)) + (message "building categories for `%s'...done" basename) + (sit-for 0) + (message nil)) + (with-current-buffer dvc-last-process-buffer + (let (category) + (goto-char (point-min)) + (while (> (line-end-position) (line-beginning-position)) + (setq category (buffer-substring-no-properties + (line-beginning-position) + (line-end-position))) + (forward-line 1) + (tla--archive-tree-add-category archive category) + ))))) + +(defun tla--archive-tree-build-branches (archive category + &optional + use-cache + ignore-error) + "Build the list of branches for ARCHIVE/CATEGORY in `tla--archive-tree'. +If USE-CACHE is non-nil, load details from the cache where possible. +If IGNORE-ERROR is non-nil, don't throw errors." + (tla--archive-tree-build-categories archive t ignore-error) + (when (or (not use-cache) + (not (cdr (tla--archive-tree-get-category archive category)))) + (let ((basename (tla--name-construct archive category))) + (message "building branches for `%s'..." basename) + (tla--run-tla-sync (list "branches" basename) + :finished 'dvc-null-handler + :error + (if ignore-error + 'dvc-null-handler + 'dvc-default-error-function)) + (message "building branches for `%s'...done" basename) + (sit-for 0) + (message nil)) + (with-current-buffer dvc-last-process-buffer + (let (branch) + (goto-char (point-min)) + (while (> (line-end-position) (line-beginning-position)) + (setq branch (buffer-substring-no-properties + (line-beginning-position) + (line-end-position))) + (tla--archive-tree-add-branch + archive + category + (if (looking-at ".*--") + (tla--name-branch (tla--name-split-semi-qualified + branch)) + ;; unnamed branch + "")) + (forward-line 1)))))) + +(defun tla--archive-tree-build-versions (archive category branch + &optional + use-cache + ignore-error) + "Build the version list in ARCHIVE/CATEGORY--BRANCH in `tla--archive-tree'. +If USE-CACHE is non-nil, load details from the cache where possible. +If IGNORE-ERROR is non-nil, don't throw errors." + (tla--archive-tree-build-branches archive category t ignore-error) + (when (or (not use-cache) + (not (cdr (tla--archive-tree-get-branch archive category + branch)))) + (let ((basename (tla--name-construct archive category branch))) + (message "building versions for `%s'..." basename) + (tla--run-tla-sync (list "versions" basename) + :finished 'dvc-null-handler + :error + (if ignore-error + 'dvc-null-handler + 'dvc-default-error-function)) + (message "building versions for `%s'...done" basename) + (sit-for 0) + (message nil)) + (with-current-buffer dvc-last-process-buffer + (let (version) + (goto-char (point-min)) + (while (> (line-end-position) (line-beginning-position)) + (setq version (buffer-substring-no-properties + (line-beginning-position) + (line-end-position))) + (forward-line 1) + (tla--archive-tree-add-version + archive + category + branch + (tla--name-version (tla--name-split-semi-qualified version)))))))) + +(defun tla--read-field (field) + "Read the contents of FIELD from a log buffer. +Must be called from a log file buffer. Returns the content of the +field FIELD. FIELD is just the name of the field, without trailing +\": \"" + (save-excursion + (goto-char (point-min)) + (if (re-search-forward (concat "^" field ": ") nil t) + (buffer-substring-no-properties + (point) (progn + (re-search-forward "^[^ \t]") + (- (point) 2))) ;; back to the end of the last line + ;; of the field. + ""))) + +(defun tla--read-field-str (field log-as-string) + "Read the contents of FIELD from a log buffer. + +Returns the content of the field FIELD, extracted from the log +LOG-AS-STRING. FIELD is just the name of the field, without trailing +\": \"" + (with-temp-buffer + (insert log-as-string) + (tla--read-field field))) + +(defun tla--read-complete-log-string (&optional buffer) + "Read the output of \"baz .. --complete-log\", starting at \"N chars\". + +Return the log as a string." + (with-current-buffer (or buffer (current-buffer)) + (dvc-funcall-if-exists set-buffer-multibyte nil) + (let ((chars (string-to-number + (buffer-substring-no-properties + (point) + (search-forward " "))))) + (forward-line 1) + (let ((result (buffer-substring-no-properties + (point) + (progn (forward-char chars) + (point))))) + result)))) + +(defun tla--skip-complete-log (&optional buffer) + "Skip a log in the output of \"baz .. --complete-log\", starting at \"N chars\". + +Same as `tla--read-complete-log-string', but don't return anything and +is faster." + (with-current-buffer (or buffer (current-buffer)) + (dvc-funcall-if-exists set-buffer-multibyte nil) + (let ((chars (string-to-number + (buffer-substring-no-properties + (point) + (search-forward " "))))) + (forward-line 1) + (forward-char chars)))) + +(defun tla--read-complete-log-struct (&optional buffer) + "Read the output of \"baz .. --complete-log\", starting at \"N chars\". + +Return the log as a string." + (tla--parse-log-file (tla--read-complete-log-string buffer))) + +(defun tla--parse-log-file (log-as-string) + "Parses a log file and return a structure `tla--revision'." + (let ((rev-struct (make-tla--revision)) + archive) + (with-temp-buffer + (insert log-as-string) + (goto-char (point-min)) + (while (re-search-forward "^\\([A-Za-z0-9_-]*\\): ?" nil t) + (let ((header (match-string-no-properties 1)) + (begin (point))) + (forward-line 1) + (while (looking-at "^[\t ]") + (forward-line 1)) + (let ((value (buffer-substring-no-properties + begin (- (point) 1)))) + (cond ((string= header "Summary") + (setf (tla--revision-summary rev-struct) + value)) + ((string= header "Creator") + (setf (tla--revision-creator rev-struct) + value)) + ((string= header "Standard-date") + (setf (tla--revision-date rev-struct) + value)) + ((string= header "New-patches") + (setf (tla--revision-merges rev-struct) + (split-string value))) + ((string= header "Revision") + (setf (tla--revision-revision rev-struct) + (tla--name-split-semi-qualified value))) + ((string= header "Archive") + (setq archive value)) + )))) + (forward-line 1) + (setf (tla--revision-body rev-struct) + (buffer-substring-no-properties (point) + (point-max))) + (setf (car (tla--revision-revision rev-struct)) + archive) + (setf (tla--revision-merges rev-struct) + (remove (tla--name-construct (tla--revision-revision rev-struct)) + (tla--revision-merges rev-struct)))) + (setf (tla--revision-log rev-struct) log-as-string) + rev-struct)) + +(defun tla--archive-tree-build-revisions (archive category branch version + &optional + use-cache + ignore-error + need-complete-info + callback) + "Build the revision list in ARCHIVE/CATEGORY--BRANCH--VERSION. +Updates `tla--archive-tree'. +If USE-CACHE is non-nil, load details from the cache where possible. +If IGNORE-ERROR is non-nil, don't throw errors. + +If CALLBACK is non-nil, run the process asynchronously and call +callback afterwards." + (tla--archive-tree-build-versions archive category branch t ignore-error) + (when (or (not use-cache) + (not (cdr (tla--archive-tree-get-version archive category branch + version))) + (and need-complete-info + (not (cdar (cdr (tla--archive-tree-get-version + archive category branch version)))))) + (let ((details (or dvc-revisions-shows-summary + dvc-revisions-shows-date + dvc-revisions-shows-creator)) + (basename (tla--name-construct + archive category branch version))) + (message "building revisions for `%s'..." basename) + (funcall + (if callback 'tla--run-tla-async 'tla--run-tla-sync) + `("revisions" + ,@(when details + (if (tla-revisions-has-complete-log-option) + '("--complete-log") + '("--summary" "--date" "--creator"))) + ,basename) + :error (if ignore-error + 'dvc-null-handler + 'dvc-default-error-function) + :finished + (dvc-capturing-lambda (output errors status arguments) + (message "building revisions for `%s'...done" (capture basename)) + (sit-for 0) + (message nil) + (with-current-buffer output + (let (revision date creator summary rev-struct) + (goto-char (point-min)) + (while (> (line-end-position) (line-beginning-position)) + (setq revision (buffer-substring-no-properties + (line-beginning-position) + (line-end-position))) + (while (string-match ".*password: $" revision) + (forward-line 1) + (setq revision (buffer-substring-no-properties + (line-beginning-position) + (line-end-position)))) + (forward-line 1) + (if (capture details) + (if (tla-revisions-has-complete-log-option) + (setq rev-struct (tla--read-complete-log-struct)) + (skip-chars-forward " ") + (setq date (buffer-substring-no-properties (point) + (line-end-position))) + (forward-line 1) + (skip-chars-forward " ") + (setq creator (buffer-substring-no-properties (point) + (line-end-position))) + (forward-line 1) + (skip-chars-forward " ") + (setq summary (buffer-substring-no-properties + (point) + (progn (re-search-forward "^\\([^ \t]\\|$\\)") + (previous-line 1) + (end-of-line) + (point)))) + (forward-line 1) + (setq rev-struct (make-tla--revision + :creator creator + :summary summary + :date date + :revision + (list + (capture archive) + (capture category) + (capture branch) + (capture version) + revision)))) + (setq rev-struct nil)) + (tla--archive-tree-add-revision + (capture archive) + (capture category) + (capture branch) + (capture version) + revision + rev-struct)))) + (when (capture callback) (funcall (capture callback)))))))) + + +(defun tla--revisions-tree-contains-details + (archive category branch version) + "Whether VERSION has already been listed full details. +Details include summary lines, dates, and creator in the archive tree." + (let ((vtree (tla--archive-tree-get-version archive category branch + version))) + (and (cdr vtree) ;; revision list is here + (cadr (cadr vtree))))) ;; summary line also + +;; ---------------------------------------------------------------------------- +;; Revlib tree manipulators +;; ---------------------------------------------------------------------------- +(defvar tla--revlib-tree nil + "Same as `tla--archive-tree', but for revision library. + +Does not contain details for revisions, since they would be redundant +with the archive tree.") + +(defun tla--revlib-tree-get-archive (archive &optional archive-tree) + "Get ARCHIVE from ARCHIVE-TREE. +If ARCHIVE-TREE is not given, `tla--revlib-tree' is used instead." + (assoc archive (or archive-tree tla--revlib-tree))) + +(defun tla--revlib-tree-build-archives (&optional use-cache ignore-error) + "Build the list of archives in `tla--revlib-tree'. +If USE-CACHE is non-nil, load from the cache where possible. +If IGNORE-ERROR is non-nil, error is not reported. +Return non-nil if the tree entry for archives are updated." + (when (or (not use-cache) + (not tla--revlib-tree)) + (tla--run-tla-sync '("library-archives") + :finished 'dvc-null-handler + :error + (if ignore-error + 'dvc-null-handler + 'dvc-default-error-function)) + (let ((old-revlib-tree tla--revlib-tree) ) + (setq tla--revlib-tree nil) + (save-excursion + (let ((archive-name) + (tmp tla--archive-tree) + (tla--archive-tree tla--revlib-tree) + result) + (set-buffer dvc-last-process-buffer) + (goto-char (point-min)) + (while (> (line-end-position) (line-beginning-position)) + (setq result t) + (setq archive-name (buffer-substring-no-properties + (line-beginning-position) + (line-end-position))) + (forward-line 1) + (tla--archive-tree-add-archive archive-name + nil + old-revlib-tree)) + (setq tla--revlib-tree tla--archive-tree + tla--archive-tree tmp) + result))))) + +(defun tla--revlib-tree-get-category (archive category) + "Get a category from ARCHIVE named CATEGORY." + (assoc category (cdr (cdr (tla--revlib-tree-get-archive archive))))) + +(defun tla--revlib-tree-build-categories (archive &optional + use-cache + ignore-error) + "Builds the list of categories for an ARCHIVE in `tla--revlib-tree'. +If USE-CACHE is non-nil, load from the cache where possible. +If IGNORE-ERROR is non-nil, error is not reported. +Return non-nil if the tree entry for categories are updated." + (when (or (not use-cache) + (not (cddr (tla--revlib-tree-get-archive archive)))) + (tla--run-tla-sync (list "library-categories" archive) + :finished 'dvc-null-handler + :error + (if ignore-error + 'dvc-null-handler + 'dvc-default-error-function)) + (with-current-buffer dvc-last-process-buffer + (let (category + (tmp tla--archive-tree) + (tla--archive-tree tla--revlib-tree) + result) + (goto-char (point-min)) + (while (> (line-end-position) (line-beginning-position)) + (setq result t) + (setq category (buffer-substring-no-properties + (line-beginning-position) + (line-end-position))) + (forward-line 1) + (tla--archive-tree-add-category archive category)) + (setq tla--revlib-tree tla--archive-tree + tla--archive-tree tmp) + result)))) + +(defun tla--revlib-tree-get-branch (archive category branch) + "From ARCHIVE/CATEGORY, get BRANCH." + (assoc branch (cdr (tla--revlib-tree-get-category + archive category)))) + +(defun tla--revlib-tree-build-branches (archive category + &optional + use-cache + ignore-error) + "Build the list of branches for ARCHIVE/CATEGORY in `tla--revlib-tree'. +If USE-CACHE is non-nil, load from the cache where possible. +If IGNORE-ERROR is non-nil, error is not reported. +Return non-nil if the tree entry for branches are updated." + (when (or (not use-cache) + (not (cdr (tla--revlib-tree-get-category archive category)))) + (tla--run-tla-sync (list "library-branches" + (tla--name-construct archive category)) + :finished 'dvc-null-handler + :error + (if ignore-error + 'dvc-null-handler + 'dvc-default-error-function)) + (with-current-buffer dvc-last-process-buffer + (let (branch + (tmp tla--archive-tree) + (tla--archive-tree tla--revlib-tree) + result) + (goto-char (point-min)) + (while (> (line-end-position) (line-beginning-position)) + (setq result t) + (setq branch (buffer-substring-no-properties + (line-beginning-position) + (line-end-position))) + (forward-line 1) + (tla--archive-tree-add-branch + archive + category + (tla--name-branch (tla--name-split-semi-qualified branch)))) + (setq tla--revlib-tree tla--archive-tree + tla--archive-tree tmp) + result)))) + +(defun tla--revlib-tree-get-version (archive category branch version) + "Get ARCHIVE/CATEGORY--BRANCH--VERSION from the revlib tree." + (assoc version (cdr (tla--revlib-tree-get-branch + archive category branch)))) + +(defun tla--revlib-tree-build-versions (archive category branch + &optional + use-cache + ignore-error) + "Build the versions list in ARCHIVE/CATEGORY/BRANCH in `tla--archive-tree'. +If USE-CACHE is non-nil, load from the cache where possible. +If IGNORE-ERROR is non-nil, error is not reported. +Return non-nil if the tree entry for versions are updated." + (when (or (not use-cache) + (not (cdr (tla--revlib-tree-get-branch archive category + branch)))) + (tla--run-tla-sync (list "library-versions" + (tla--name-construct + archive category branch)) + :finished 'dvc-null-handler + :error + (if ignore-error + 'dvc-null-handler + 'dvc-default-error-function)) + (with-current-buffer dvc-last-process-buffer + (let (version + (tmp tla--archive-tree) + (tla--archive-tree tla--revlib-tree) + result) + (goto-char (point-min)) + (while (> (line-end-position) (line-beginning-position)) + (setq result t) + (setq version (buffer-substring-no-properties + (line-beginning-position) + (line-end-position))) + (forward-line 1) + (tla--archive-tree-add-version + archive + category + branch + (tla--name-version (tla--name-split-semi-qualified version)))) + (setq tla--revlib-tree tla--archive-tree + tla--archive-tree tmp) + result)))) + +(defun tla--revlib-tree-get-revision (archive category branch version revision) + "Get ARCHIVE/CATEGORY--BRANCH--VERSION--REVISION from the revlib tree." + (assoc revision (cdr (tla--revlib-tree-get-version + archive category branch version)))) + +(defun tla--revlib-tree-build-revisions (archive category branch version + &optional + use-cache + ignore-error) + + "Build the revision list of ARCHIVE/CATEGORY--BRANCH--VERSION. +Updates `tla--revlib-tree'. +If IGNORE-ERROR is non-nil, error is not reported. +Return non-nil if the tree entry for revisions are updated." + (when (or (not use-cache) + (not (cdr (tla--revlib-tree-get-version archive category branch + version)))) + (tla--run-tla-sync (list "library-revisions" + (tla--name-construct + archive category branch version)) + :finished 'dvc-null-handler + :error (if ignore-error + 'dvc-null-handler + 'dvc-default-error-function)) + (with-current-buffer dvc-last-process-buffer + (let (revision + (tmp tla--archive-tree) + (tla--archive-tree tla--revlib-tree) + result) + (goto-char (point-min)) + (while (> (line-end-position) (line-beginning-position)) + (setq result t) + (setq revision (buffer-substring-no-properties + (line-beginning-position) + (line-end-position))) + (forward-line 1) + (tla--archive-tree-add-revision + archive + category + branch + version + revision)) + (setq tla--revlib-tree tla--archive-tree + tla--archive-tree tmp) + result + )))) + +;; ---------------------------------------------------------------------------- +;; Name reading engine +;; ---------------------------------------------------------------------------- +;;Currently only able to read a full revision starting from nothing. +(defun tla-name-read-refresh-cache () + "Function to be called from the minibuffer while reading a name." + (interactive) + (tla--archive-tree-build + (tla--name-construct + (butlast (delete nil (tla--name-split (minibuffer-contents)))))) + (setq tla--archive-tree nil)) + +(defvar tla--name-read-arguments "This value should not be refereed." + "Used to suppress warnings from the byte code compiler. +This variable is a just placeholder introduced to suppress the +warnings from byte code compiler. Variable `tla--name-read-arguments' +should be bound in `let'. Variable `tla--name-read-arguments' is used +for passing information from `tla-name-read' to functions called internally +from `tla-name-read'. Use function `tla--name-read-arguments' to get the +information") + +(defun tla--name-read-arguments (key) + "Get `tla-name-read' context information associated to KEY. +`tla-name-read' calls some functions to read a tla name. +In the functions, the arguments passed to `tla-name-read'(context information) +are needed to know. However, `tla-name-read' cannot pass the context +information directly to the functions because the functions are something to do +with Emacs's completion mechanism; and the mechanism specifies the number +of arguments of the functions. So the context information is passed via +a local variable, `tla--name-read-arguments', defined in let. + +Symbol `archive', `category', `branch', `version', or `revision' are +acceptable as KEY." + (cdr (assoc key tla--name-read-arguments))) + + +(defun tla--name-read-complete (string predicate what) + "Completion function for name reading. + +Displays STRING and prompts for something satisfying PREDICATE. + +This function uses the free variables archive, category, branch, +version, and revision. If one of these variables is non-nil, it means +the corresponding value must be read from keyboard. + +REMINDER: this function may be called several times, with different +values for WHAT: + + - nil : The function must return the longest prefix + - t : The function must return the list of completions + - 'lambda : The function must return t if the completion correspond + to an exact match, nil otherwise. (so that Emacs can distinguish + between \"sole completion\" and \"complete, but not unique\"." + (if (and (eq what 'lambda) + (string-match "/\\(.*--\\)?$" string)) + ;; The caller just want to know whether this is a full + ;; completion. This can not be the case with such suffix. + nil + (let* ((empty-branch nil) + (use-cache (not current-prefix-arg)) + (splited (tla--name-split string)) + (archive-loc (tla--name-archive splited)) + (category-loc (tla--name-category splited)) + (branch-loc (tla--name-branch splited)) + (version-loc (tla--name-version splited)) + (revision-loc (tla--name-revision splited)) + (suffix (cond + ((and (tla--name-read-arguments 'category) + (not category-loc) "/")) + ((and (tla--name-read-arguments 'branch) + (not branch-loc) "--")) + ((and (tla--name-read-arguments 'version) + (not version-loc) "--")) + ((and (tla--name-read-arguments 'revision) + (not revision-loc) "--")) + (t nil))) + (maybep (cond + ((eq 'maybe (tla--name-read-arguments 'category)) + t) + ((and (eq 'maybe (tla--name-read-arguments 'branch)) + archive-loc category-loc) + t) + ((and (eq 'maybe (tla--name-read-arguments 'version)) + archive-loc category-loc branch-loc) + t) + ((and (eq 'maybe (tla--name-read-arguments 'revision)) + archive-loc category-loc branch-loc version-loc) + t) + (t nil))) + (completions + (cond + ;; If the user started to write a revision ... + (revision-loc + ;; ... and if the user is supposed to be prompted a + ;; revision + (when (tla--name-read-arguments 'revision) + (let ((dvc-revisions-shows-summary nil) + (dvc-revisions-shows-date nil) + (dvc-revisions-shows-creator nil)) + (tla--archive-tree-build-revisions + archive-loc category-loc branch-loc version-loc use-cache t)) + (cdr (tla--archive-tree-get-version + archive-loc category-loc branch-loc version-loc)))) + (version-loc + (when (tla--name-read-arguments 'version) + (tla--archive-tree-build-versions + archive-loc category-loc branch-loc use-cache t) + (cdr (tla--archive-tree-get-branch + archive-loc category-loc branch-loc)))) + ;; If the user started a branch ... + (branch-loc + ;; And a branch is needed + (when (tla--name-read-arguments 'branch) + (tla--archive-tree-build-branches + archive-loc category-loc use-cache t) + (let ((result (cdr (tla--archive-tree-get-category + archive-loc category-loc)))) + (when (and (string= branch-loc "") + (tla--name-read-arguments 'version) + (let ((empty-br-exists nil)) + (dolist (branch + (cdr (tla--archive-tree-get-category + archive-loc category-loc))) + (when (string= (car branch) "") + (setq empty-br-exists t))) + empty-br-exists)) + (tla--archive-tree-build-versions + archive-loc category-loc "") + (setq empty-branch (tla--archive-tree-get-branch + archive-loc category-loc "")) + (when empty-branch + ;; Remove the "" branch to avoid the ---- + ;; completion. + (let ((tmp result)) + (setq result nil) + (while tmp + (when (not (string= (caar tmp) "")) + (setq result (cons (car tmp) result))) + (setq tmp (cdr tmp)))))) + result))) + (category-loc + (when (tla--name-read-arguments 'category) + (tla--archive-tree-build-categories archive-loc use-cache t) + (cddr (tla--archive-tree-get-archive archive-loc)))) + (t + (when (tla--name-read-arguments 'archive) + (tla--archive-tree-build-archives use-cache t) + tla--archive-tree))))) + (let* ((base (mapcar (lambda (x) + (tla--name-construct + (delete + nil + (list + (when category-loc archive-loc) + (when branch-loc category-loc) + (when version-loc branch-loc) + (when revision-loc version-loc) + (car x))))) + completions)) + (sans-suffix + (and maybep suffix)) + (empty-branch-versions + (and empty-branch + (mapcar (lambda (x) + (tla--name-construct + archive-loc category-loc "" (car x))) + (cdr empty-branch)))) + (completions (funcall 'all-completions + string + (nconc (mapcar + (lambda (x) + (list (concat x suffix))) + base) + (when sans-suffix + (mapcar + (lambda (x) (list x)) + base)) + (when empty-branch + (mapcar + (lambda (x) (list x)) + empty-branch-versions))) + predicate))) + (let ((result + (cond ((eq what t) + ;; We just want the list of completions + completions) + ((eq (length completions) 1) + ;; There's only one completion + (if (eq what 'lambda) + (string= (car completions) string) + (cond ((string= (car completions) string) t) + (t (car completions))))) + ;; there are several possible completions + (t (if (eq what 'lambda) + ;; complete, but not unique ? + (member string completions) + (try-completion string (mapcar 'list + completions))))))) + ;; (dvc-trace "string=%s predicate=%S what=%s ==> result=%S\ncompletions=%S" + ;; string predicate what result completions) + result))))) + +(defconst tla-part-of-name-regex "\\([^/ \t\n-]\\|-[^-]\\)+") + +;;;###autoload +(defun tla-make-name-regexp (level slash-mandatory exact) + "Make a regexp for an Arch name (archive, category, ...). + +LEVEL can be 0 (archive), 1 (category), 2 (branch), 3 (version) +or 4 (revision). + +If SLASH-MANDATORY is non-nil, the '/' after the archive name is +mandatory. (allows to distinguish between Arch archives and emails. + +If EXACT is non-nil, match exactly LEVEL." + (let ((qmark (if exact "" "?"))) + (concat + "\\([^/@ \t\n]+" "@" "[^/ \t\n]+" ;; email + "\\(--" + "[^/ \t\n]+\\)?" ;; suffix (not mandatory) + (when (>= level 1) + (concat + "/\\(" ;; Separator archive/category + tla-part-of-name-regex ;; category + (when (>= level 2) + (concat + "\\(" + "--" + tla-part-of-name-regex ;; branch + (when (>= level 3) + (concat + "\\(" + "--" + "[0-9]+[.0-9]*" ;; version + (when (>= level 4) + (concat + "\\(" + "--" + "\\(base\\|patch\\|version\\|versionfix\\)-[0-9]+" ;; patch + "\\)" qmark)) + "\\)" qmark)) + "\\)" qmark)) + "\\)" qmark)) + "\\)" ;; end of group + (when (and slash-mandatory (< level 1)) + "/") + "\\( \\|\n\\|:\\)"))) + +(defun tla-get-name-at-point () + "Provides a default value for tla-name-read. +It first looks, if a name is found near point. +If this does not succeed, use the revision at point, when in tla-changelog-mode." + (interactive) + (let ((name)) + (save-excursion + (if (re-search-backward "[ \t\n]" (point-min) t) + (goto-char (1+ (point))) + (beginning-of-line)) + (when (looking-at (tla-make-name-regexp 4 nil nil)) + (setq name (match-string 1)))) + (unless name + (when (eq major-mode 'tla-changelog-mode) + (setq name (tla-changelog-revision-at-point)))) + name)) + +;; Test cases +;; (tla-name-read "enter category: " "Matthieu.Moy@imag.fr--public" 'prompt) +;; (tla-name-read "branch: " "lord@emf.net--2004" 'prompt 'prompt) +;; (tla-name-read "revision: " 'prompt 'prompt 'prompt 'prompt 'prompt) +;; (tla-name-read "revision or version: " 'prompt 'prompt 'prompt 'prompt 'maybe) +;; (tla-name-read "revision or version: " "jet@gyve.org--xtla" "xtla" "jet" 'prompt 'maybe) +;; +(defvar tla--name-read-history nil) ; TODO: multiple history list? +(defvar tla--name-read-debug nil + "If non-nil, `condition-case' in `tla-name-read' is made disabled.") +(defun tla-name-read (&optional prompt archive category + branch version revision) + "Read a name. +To get help on the user interface of `tla-name-read', please type +M-x tla-name-read-help RET. + +Function reading an archive location from keyboard. +Read name is expressed in a list built by `tla--name-split'. + +First argument PROMPT is the prompt the user will get. Next arguments +ARCHIVE CATEGORY BRANCH VERSION and REVISION are either the default +value, or a request for a value. They can take four values: + + - A string means the default value, and will be used as an initial + input. + + - The symbol 'prompt means the value will be prompted from the user. + The user will HAVE to give this value. + + - The symbol 'maybe means the value will be prompted, but is optional + for the user. + + - nil means the value won't be prompted. + +They should appear in the same order as above. + +Example: +- Read a category in archive \"Matthieu.Moy@imag.fr--public\": + (tla-name-read \"enter category: \" \"Matthieu.Moy@imag.fr--public\" 'prompt) +- Read a revision, anywhere: + (tla-name-read \"revision: \" 'prompt 'prompt 'prompt 'prompt 'prompt) +- Read either a revision or a version: + (tla-name-read \"revision: \" 'prompt 'prompt 'prompt 'prompt 'maybe) + +While prompting, a menu \"Xtla\" is added to the menubar. The +following commands are available: + +\\{tla--name-read-minibuf-map}" + + ;; use the defaults found under point if no defaults have been provided + (let ((l (tla-get-name-at-point))) + (when l + (setq l (tla--name-split l)) + (if (and archive (symbolp archive)) (setq archive (or (nth 0 l) archive))) + (if (and category (symbolp category)) (setq category (or (nth 1 l) category))) + (if (and branch (symbolp branch)) (setq branch (or (nth 2 l) branch))) + (if (and version (symbolp version)) (setq version (or (nth 3 l) version))) + (if (and revision (symbolp revision)) (setq revision (or (nth 4 l) revision))))) + + (let ((tla--name-read-arguments `((archive . ,archive) + (category . ,category) + (branch . ,branch) + (version . ,version) + (revision . ,revision)))) + (if tla--name-read-debug + (tla--name-read-internal prompt archive category branch version revision) + (condition-case reason + (tla--name-read-internal prompt archive category branch version revision) + ((quit error) + (run-hooks 'tla-name-read-error-hook) + (signal (car reason) (cdr reason))))))) + +(defun tla--name-read-internal (prompt archive category branch version revision) + "See `tla-name-read'." + (run-hooks 'tla-name-read-init-hook) + + (let* ((minibuffer-local-completion-map tla--name-read-minibuf-map) + (result (tla--name-construct + (delete + 'maybe + (delete 'prompt (list archive category + branch version revision))))) + (first-try t) + not-finished too-long last-empty) + ;; Without in some case 'maybe is ignored by tla--prompt-not-finished + ;; and never the control flow enters the while loop. + ;; We need C language's do-while loop. + (while (or first-try + not-finished + too-long + last-empty) + (unless first-try + (unless (eq this-command 'choose-completion) + (ding) + (message (cond (not-finished "%s%s [incomplete input: %s]") + (too-long "%s%s [too long input for: %s]") + (last-empty (concat "%s%s [empty " last-empty + " name]")) + (t (error + (concat "case not managed." + " Please submit a bug report")))) + prompt result + (tla--name-read-required-input archive + category + branch + version + revision)) + (sit-for 2) + (message nil))) + + (setq result (dvc-completing-read + (or prompt "Location: ") + 'tla--name-read-complete + nil nil result + 'tla--name-read-history) + first-try nil) + (setq not-finished (tla--prompt-not-finished + result archive category branch + version revision)) + (setq too-long (tla--prompt-too-long + result archive category branch + version revision)) + (setq last-empty (tla--prompt-last-empty result))) + + (when result + (setq result (tla--name-split result))) + (run-hook-with-args 'tla-name-read-final-hook result) + result)) + +(defun tla--prompt-not-finished (result archive category branch + version revision) + "Check whether user input is complete. +True if RESULT (a string) is not sufficient when the user is +prompted for ARCHIVE CATEGORY BRANCH VERSION REVISION." + (let ((res-split (tla--name-split result))) + (or (and (eq archive 'prompt) ;; archive required + (not (tla--name-archive res-split))) ;; but not provided + (and (eq category 'prompt) + (not (tla--name-category res-split))) + (and (eq branch 'prompt) + (not (tla--name-branch res-split))) + (and (eq version 'prompt) + (not (tla--name-version res-split))) + (and (eq revision 'prompt) + (not (tla--name-revision res-split)))))) + +(defun tla--prompt-too-long (result archive category branch + version revision) + "Check whether the user has entered too many elements. +True if RESULT (a string) contains too many elements when the user +is prompted for ARCHIVE CATEGORY BRANCH VERSION REVISION. + +For example, will return true if the user entered +foo@bar--2004/xtla--main while prompted only for a category." + (let ((res-split (tla--name-split result))) + (or (and (not revision) ;; revision not needed + (tla--name-revision res-split)) ;; but provided + (and (not version) + (tla--name-version res-split)) + (and (not branch) + (tla--name-branch res-split)) + (and (not category) + (tla--name-category res-split)) + (and (not archive) + (tla--name-archive res-split))))) + +(defun tla--prompt-last-empty (result) + "Check whether the last field is empty. +Non-nil if RESULT (a string) is terminated by \"--\" or \"/\". This +means the user entered a delimiter but not the element after. + +When non-nil, the returned value is a string giving the name of the +item that is currently empty. (eg: archive, category, ...)" + (let ((res-split (tla--name-split result))) + (cond ((equal (tla--name-archive res-split) "") "archive" ) + ((equal (tla--name-category res-split) "") "category") + ((and (equal (tla--name-branch res-split) "") + (not (tla--name-version res-split))) "branch" ) + ((equal (tla--name-version res-split) "") "version" ) + ((equal (tla--name-revision res-split) "") "revision") + (t nil)))) + + +(defun tla--name-read-required-input (archive + category + branch + version + revision) + "Return string which represents the elements to be readin `tla-name-read'. +If ARCHIVE, CATEGORY, BRANCH, VERSION or REVISION are equal to 'maybe, the +corresponding element will be optionally read. +If any of these are non-nil (but not 'maybe), the corresponding element will be +required. +If any of these are nil, the correpsonding element is not required." + (concat + (cond ((eq archive 'maybe) "[A]") + (archive "A") + (t "")) + (cond ((eq category 'maybe) "[/C]") + (category "/C") + (t "")) + (cond ((eq branch 'maybe) "[--B]") + (branch "--B") + (t "")) + (cond ((eq version 'maybe) "[--V]") + (version "--V") + (t "")) + (cond ((eq revision 'maybe) "[--R]") + (revision "--R") + (t "")))) + + + +(defun tla--location-type (location) + "Return the type of LOCATION." + (cond + ((string-match "^ftp://" location) 'ftp) + ((string-match "^sftp://" location) 'sftp) + ((string-match "^http://" location) 'http) + (t 'local))) + +(defun tla--archive-type (archive) + "Return the type of ARCHIVE." + (cond + ((string-match "SOURCE$" archive) 'source) + ;; archive-MIRROR, archive-MIRROR-2 should be treated as mirror + ((string-match ".+-MIRROR" archive) 'mirror) + (t 'normal))) + +;; (tla--archive-name-source "a") +;; (tla--archive-name-source "a-SOURCE") +;; (tla--archive-name-source "a-MIRROR") +(defun tla--archive-name-source (archive &optional existence-check) + "Make source archive name from ARCHIVE. +If EXISTENCE-CHECK is non-nil, check whether the made source archive name +already exists or not; return nil if it doesn't exists. +Example: +ELISP> (tla--archive-name-source \"jet@gyve.org--xtla\") +\"jet@gyve.org--xtla-SOURCE\" +ELISP> (tla--archive-name-source \"jet@gyve.org--xtla-MIRROR\") +\"jet@gyve.org--xtla\" +ELISP> (tla--archive-name-source \"jet@gyve.org--xtla-SOURCE\") +nil" + (let* ((type (tla--archive-type archive)) + (source (cond + ((eq 'normal type) + (concat archive "-SOURCE")) + ((eq 'mirror type) + (string-match "\\(.*\\)-MIRROR$" archive) + (match-string 1 archive)) + (t nil)))) + (if existence-check + (progn + (tla--archive-tree-build-archives t) + (when (and source (tla--archive-tree-get-archive source)) + source)) + source))) + +;; (tla--archive-name-mirror "a") +;; (tla--archive-name-mirror "a-SOURCE") +;; (tla--archive-name-mirror "a-MIRROR") +(defun tla--archive-name-mirror (archive &optional existence-check) + "Make mirror archive name from ARCHIVE. +If EXISTENCE-CHECK is non-nil, check whether the made mirror archive name +already exists or not; return nil if it doesn't exists. +Example: +ELISP> (tla--archive-name-mirror \"jet@gyve.org--xtla\") +\"jet@gyve.org--xtla-MIRROR\" +ELISP> (tla--archive-name-mirror \"jet@gyve.org--xtla-SOURCE\") +\"jet@gyve.org--xtla\" +ELISP> (tla--archive-name-mirror \"jet@gyve.org--xtla-MIRROR\") +nil" + (let* ((type (tla--archive-type archive)) + (mirror (cond + ((eq 'normal type) + (concat archive "-MIRROR")) + ((eq 'source type) + (string-match "\\(.*\\)-SOURCE" archive) + (match-string 1 archive)) + (t nil)))) + (if existence-check + (progn + (tla--archive-tree-build-archives t) + (when (and mirror (tla--archive-tree-get-archive mirror)) + mirror)) + mirror))) + +(defun tla-revision-direct-ancestor (&optional revision num) + "Compute the direct ancestor of REVISION. +REVISION must be provided as a list, and a list is returned. +If revision is nil, return the ancestor of the last revision +of the local tree." + (interactive + (list (tla-name-read "Compute direct ancestor of: " + 'prompt 'prompt 'prompt 'prompt 'prompt))) + (let ((ancestor + (tla--run-tla-sync (list "ancestry-graph" "--immediate" + (and revision + (tla--name-construct revision))) + :finished (lambda (output error status arguments) + (tla--name-split + (dvc-buffer-content + output)))))) + (when (interactive-p) + (message "Ancestor of: %s\n is: %s" + (tla--name-construct ancestor) + (tla--name-construct revision))) + (if (or (eq num 1) (eq num nil)) ancestor + (tla-revision-direct-ancestor ancestor (- num 1))))) + +;; Copied from ediff-mouse-event-p. I prefer keeping this duplication +;; to avoid one more dependancy on ediff.el (whose interface may +;; change one day ...) +(defsubst tla--mouse-event-p (event) + "Return true if EVENT is a mouse-related event." + (if (featurep 'xemacs) + (dvc-do-in-xemacs (button-event-p event)) + (dvc-do-in-gnu-emacs + (string-match "mouse" (format "%S" (event-basic-type event)))))) + +(defun tla-escape (string &optional unescape message) + "Return the pika escaped value of STRING. +If pika escaping is not supported by tla, return STRING. +If UNESCAPE is non-nil, returns the unescaped version of string. +If MESSAGE is non-nil or if run interactively, also display the value +as a message." + (interactive "sString to escape: ") + (let ((res (if (and (string-match (if unescape "\\\\" + "[^a-zA-Z._+,{}-]") string) + (tla-has-escape-command)) + ;; We need to do the (un)escaping + (tla--run-tla-sync + (list "escape" (when unescape "--unescaped") string) + :finished (lambda (output error status arguments) + (dvc-buffer-content output))) + string))) + (when (or (interactive-p) message) + (message res)) + res)) + +(defun tla-unescape (string) + "Run \"tla escape --unescaped\" on STRING. + +Return STRING if \"tla escape\" is not available." + (interactive "sString to unescape: ") + (when string (tla-escape string t (interactive-p)))) + +;; ---------------------------------------------------------------------------- +;; Saving and loading state variables +;; ---------------------------------------------------------------------------- + + +;; (setq tla--archive-tree nil) +;; (setq tla--revlib-tree nil) +(provide 'tla-core) +;;; tla-core.el ends here diff --git a/dvc/lisp/tla-defs.el b/dvc/lisp/tla-defs.el new file mode 100644 index 0000000..e96b55d --- /dev/null +++ b/dvc/lisp/tla-defs.el @@ -0,0 +1,2040 @@ +;;; tla-defs.el --- UI Xtla's element definitions + +;; Copyright (C) 2003-2008 by all contributors + +;; Author: Stefan Reichoer, +;; Contributions from: +;; Matthieu Moy +;; Masatake YAMATO +;; Milan Zamazal +;; Martin Pool +;; Robert Widhopf-Fenk +;; Mark Triggs + +;; This file is part of Xtla. +;; +;; 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: +;; In order to keep UI consistency, especially about key binding, +;; we gather all UI definition in this separated file. +;; + + +;;; History: +;; + +;;; Code: + +(eval-when-compile + (require 'cl)) + +(eval-and-compile + (autoload 'ad-add-advice "advice") + (require 'ediff) + (require 'diff-mode) + (require 'font-lock) + (require 'add-log) + (require 'ffap) + (require 'dvc-log) + (require 'dvc-utils) + (require 'dvc-core) + (require 'dvc-ui) + (require 'dvc-defs)) + +(condition-case nil + (progn + ;; Contains the site-specific config info. Must remain + ;; optional. + (require 'dvc-site)) + (error nil)) + +;;;###autoload +(eval-and-compile + (require 'easymenu) + (require 'dvc-core)) + +;; +;; Minibuffer(for reading engine) +;; +(defvar xtla--name-read-partner-menu (cons "Insert Partner Version" nil)) +(fset 'xtla--name-read-partner-menu (cons 'keymap xtla--name-read-partner-menu)) +(defvar xtla--name-read-bookmark-menu (cons "Insert Version in Bookmarks" nil)) +(fset 'xtla--name-read-bookmark-menu (cons 'keymap xtla--name-read-bookmark-menu)) + +(defvar tla--name-read-extension-keydefs + '(([(control r)] . tla-name-read-refresh-cache) + ([(meta *)] . tla-name-read-insert-default-archive) + ([(meta \.)] . tla-name-read-insert-info-at-point) + ([(meta \;)] . tla-name-read-insert-version-associated-with-default-directory) + ([(control n)] . tla-name-read-insert-partner-next) + ([(control p)] . tla-name-read-insert-partner-previous) + ([(control v)] . tla-name-read-insert-bookmark-next) + ([(meta v)] . tla-name-read-insert-bookmark-previous) + ([(meta ^)] . tla-name-read-insert-ancestor) + ([(control h)] . tla-name-read-help) + ([(meta \?)] . tla-name-read-inline-help)) + "Key definitions table for `tla--name-read-minibuf-map'. +The reason these definitions are defined separately from +`tla--name-read-minibuf-map' is that to reuse these definitions +in `tla-name-read-help'. Don't forget to evalute +`tla--name-read-minibuf-map' again after updating this value.") + +(defun tla-name-read-minibuf-map-fn () + (let ((map (copy-keymap minibuffer-local-completion-map))) + ;; Keys + (mapc + (lambda (pair) + (let ((key (car pair)) + (func (cdr pair))) + (define-key map key func))) + tla--name-read-extension-keydefs) + ;; Menus + (define-key map [menu-bar xtla] + (cons "Xtla" (make-sparse-keymap "Xtla"))) + (define-key map [menu-bar xtla refresh] + (list 'menu-item "Refresh Completion Cache" + 'tla-name-read-refresh-cache)) + (define-key map [menu-bar xtla ancestor] + (list 'menu-item "Insert Ancestor" + 'tla-name-read-insert-ancestor + :enable '(and + (minibufferp) + (equal "" (minibuffer-contents)) + (member archive '(prompt maybe)) + (not (eq this-command 'tla-revision-direct-ancestor)) + ))) + (define-key map [menu-bar xtla default] + (list 'menu-item "Insert Default Archive" + 'tla-name-read-insert-default-archive + :enable '(and + (minibufferp) + (equal "" (minibuffer-contents)) + (member archive '(prompt maybe))))) + (define-key map [menu-bar xtla here] + (list 'menu-item "Insert Thing at Point" + 'tla-name-read-insert-info-at-point + :enable '(and (minibufferp) + (equal "" (minibuffer-contents)) + tla-name-read-insert-info-at-point))) + (define-key map [menu-bar xtla bookmark] + (list 'menu-item "Insert Version in Bookmark" 'xtla--name-read-bookmark-menu + :enable '(let* ((l (condition-case nil + (let ((default-version (tla-tree-version-list default-directory))) + (tla-bookmarks-get-partner-versions default-version)) + (error nil)))) + (and l (< 0 (length l)))))) + (define-key map [menu-bar xtla partner] + (list 'menu-item "Insert Partner Version" 'xtla--name-read-partner-menu + :enable '(let* ((l (condition-case nil (tla-partner-list) + (error nil)))) + (and l (< 0 (length l)))))) + map)) + +(defvar tla--name-read-minibuf-map (tla-name-read-minibuf-map-fn) + "Keymap to input a gnuarch revision at the minibuffer.") + +(defvar tla--tree-lint-nowarning-fn nil + "Function to run when all lint warnings have been eliminated. + +Must be buffer-local, in a tree-lint mode buffer.") + + +;; +;; Bookmarks mode +;; +(defvar tla-bookmarks-mode-map + (let ((map (make-sparse-keymap))) + (define-key map dvc-keyvec-help 'describe-mode) + ;; Move + (define-key map dvc-keyvec-next 'tla-bookmarks-next) + (define-key map dvc-keyvec-previous 'tla-bookmarks-previous) + (define-key map [?N] 'tla-bookmarks-move-down) + (define-key map [?P] 'tla-bookmarks-move-up) + ;; Actions + (define-key map (dvc-prefix-merge dvc-key-star-merge) + 'tla-bookmarks-star-merge) + (define-key map (dvc-prefix-merge dvc-key-replay) + 'tla-bookmarks-replay) + (define-key map (dvc-prefix-merge dvc-key-update) + 'tla-bookmarks-update) + (define-key map (dvc-prefix-merge dvc-key-missing) + 'tla-bookmarks-missing) + (define-key map (dvc-prefix-merge dvc-key-tag) + 'tla-bookmarks-tag) + (define-key map [?o] 'tla-bookmarks-open-tree) + (define-key map [(control x) (control f)] 'tla-bookmarks-find-file) + (define-key map dvc-keyvec-diff 'tla-bookmarks-changes) + (define-key map dvc-keyvec-get 'tla-bookmarks-get) + (define-key map "\C-m" 'tla-bookmarks-goto) + ;; Marks + (define-key map dvc-keyvec-mark 'tla-bookmarks-mark) + (define-key map dvc-keyvec-unmark 'tla-bookmarks-unmark) + (define-key map dvc-keyvec-unmark-all 'tla-bookmarks-unmark-all) + (define-key map (dvc-prefix-mark ?g) 'tla-bookmarks-select-by-group) + ;; Partners + (define-key map [(meta p)] 'tla-bookmarks-marked-are-partners) + (define-key map (dvc-prefix-add ?p) + 'tla-bookmarks-add-partner-interactive) + (define-key map (dvc-prefix-remove ?p) + 'tla-bookmarks-delete-partner-interactive) + (define-key map (dvc-prefix-partner-file ?r) + 'tla-bookmarks-add-partners-from-file) + (define-key map (dvc-prefix-partner-file ?w) + 'tla-bookmarks-write-partners-to-file) + ;; Bookmark manipulation + (define-key map (dvc-prefix-add ?b) 'tla-bookmarks-add) + (define-key map (dvc-prefix-remove ?b) 'tla-bookmarks-delete) + (define-key map [?e] 'tla-bookmarks-edit) + (define-key map dvc-keyvec-toggle 'tla-bookmarks-toggle-details) + ;; Fields + (define-key map (dvc-prefix-add ?t) + 'tla-bookmarks-add-tree-interactive) + (define-key map (dvc-prefix-remove ?t) + 'tla-bookmarks-delete-tree-interactive) + (define-key map (dvc-prefix-add ?g) + 'tla-bookmarks-add-group-interactive) + (define-key map (dvc-prefix-remove ?g) + 'tla-bookmarks-delete-group-interactive) + (define-key map (dvc-prefix-add ?n) + 'tla-bookmarks-add-nickname-interactive) + (define-key map (dvc-prefix-remove ?n) + 'tla-bookmarks-delete-nickname-interactive) + (define-key map [?s] 'tla-bookmarks-edit-summary) + ;; Switch to other buffers + (define-key map dvc-keyvec-inventory 'tla-bookmarks-inventory) + (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-keyvec-quit 'dvc-buffer-quit) + map) + "Keymap used in `tla-bookmarks-mode' buffers.") + +(defvar tla-bookmarks-entry-map + (let ((map (copy-keymap dvc-cmenu-map-template))) + (define-key map dvc-mouse-2 'tla-bookmarks-goto-by-mouse) + map) + "Keymap used on entries in `tla-bookmarks-mode' buffers.") + +;; +;; Inventory mode +;; +(defvar tla-inventory-mode-map + (let ((map (make-sparse-keymap))) + (define-key map dvc-keyvec-help 'describe-mode) + (define-key map dvc-keyvec-refresh 'dvc-generic-refresh) + (define-key map dvc-keyvec-add 'tla-inventory-add-files) + (define-key map dvc-keyvec-remove 'tla-inventory-remove-files) + (define-key map dvc-keyvec-quit 'dvc-buffer-quit) + (define-key map dvc-keyvec-next 'tla-inventory-next) + (define-key map dvc-keyvec-previous 'tla-inventory-previous) + (define-key map dvc-keyvec-parent 'tla-inventory-parent-directory) + (define-key map [(control x) (control j)] 'dvc-dired-jump) + ;; + ;; + ;; + (define-key map [?X] 'tla-inventory-delete-files) + (define-key map (dvc-prefix-move dvc-key-move) 'tla-inventory-move) + (define-key map dvc-keyvec-commit 'tla-inventory-edit-log) + (define-key map [?l] 'tla-changelog) + (define-key map dvc-keyvec-logs 'tla-logs) + ;; + ;; Find file group + ;; + (define-key map [?f] 'tla-inventory-find-file) + (define-key map [return] 'tla-inventory-find-file) + (define-key map "\C-m" 'tla-inventory-find-file) + (define-key map [?o] 'dvc-find-file-other-window) + (define-key map [?v] 'dvc-view-file) + ;; + ;; Diffs group + ;; + (define-key map (dvc-prefix-merge dvc-key-missing) + 'tla-inventory-missing) + (define-key map (dvc-prefix-diff dvc-key-diff) + 'tla-inventory-changes) + (define-key map (dvc-prefix-diff ?l) 'tla-changes-last-revision) + (define-key map (dvc-prefix-diff dvc-key-ediff) + 'tla-inventory-file-ediff) + (define-key map (dvc-prefix-diff dvc-key-get) + 'tla-inventory-delta) + ;; Alias for above bindings + (define-key map dvc-keyvec-diff 'tla-inventory-changes) + (define-key map dvc-keyvec-ediff 'tla-inventory-file-ediff) + ;; + (define-key map dvc-keyvec-reflect 'tla-inventory-mirror) + ;; + ;; Merge group + ;; + (define-key map (dvc-prefix-merge dvc-key-star-merge) + 'tla-inventory-star-merge) + (define-key map (dvc-prefix-merge dvc-key-replay) + 'tla-inventory-replay) + (define-key map (dvc-prefix-merge dvc-key-update) + 'tla-inventory-update) + (define-key map (dvc-prefix-merge dvc-key-reflect) + 'tla-inventory-apply-changeset) + ;; + ;; Buffers group + ;; + (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) 'tla-bookmarks) + ;; + ;; Undo and redo group + ;; + (define-key map dvc-keyvec-revert 'tla-inventory-revert) + (define-key map (dvc-prefix-working-copy dvc-key-revert) 'tla-inventory-undo) + (define-key map (dvc-prefix-working-copy ?R) 'tla-inventory-redo) + ;; + ;; Patches group + ;; + (define-key map (dvc-prefix-working-copy ?S) 'tla-changes-save) + (define-key map (dvc-prefix-working-copy ?s) 'tla-changes-save-as-tgz) + (define-key map (dvc-prefix-working-copy ?V) 'tla-show-changeset) + (define-key map (dvc-prefix-working-copy ?v) 'tla-show-changeset-from-tgz) + (define-key map (dvc-prefix-working-copy ?A) 'tla-inventory-apply-changeset) + (define-key map (dvc-prefix-working-copy ?a) 'tla-inventory-apply-changeset-from-tgz) + ;; + ;; Kill ring group + ;; + (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) + + ;; + ;; Tree lint + ;; + (define-key map (dvc-prefix-working-copy dvc-key-tree-lint) + 'tla-tree-lint) + ;; + ;; Mark group + ;; + (define-key map (dvc-prefix-mark dvc-key-mark) 'tla-inventory-mark-file) + (define-key map (dvc-prefix-mark dvc-key-unmark) 'tla-inventory-unmark-file) + ;; (define-key map dvc-keyvec-mark-all 'tla-inventory-mark-all) + (define-key map dvc-keyvec-unmark-all 'tla-inventory-unmark-all) + ;; Alias for above bindings + (define-key map dvc-keyvec-mark 'tla-inventory-mark-file) + (define-key map dvc-keyvec-unmark 'tla-inventory-unmark-file) + ;; + ;; Tagging method + ;; + (define-key map (dvc-prefix-tagging-method ?=) 'tla-edit-=tagging-method-file) + (define-key map (dvc-prefix-tagging-method ?.) 'tla-edit-.arch-inventory-file) + ;; + ;; Exclude, junk, precious, unrecognized... + ;; + (define-key map (dvc-prefix-move ?j) 'tla-inventory-make-junk) + (define-key map (dvc-prefix-move ?,) 'tla-inventory-make-junk) + (define-key map (dvc-prefix-move ?p) 'tla-inventory-make-precious) + (define-key map (dvc-prefix-move ?+) 'tla-inventory-make-precious) + (define-key map (dvc-prefix-tagging-method ?M) 'tla-generic-set-id-tagging-method) + (define-key map (dvc-prefix-tagging-method ?V) 'tla-generic-set-tree-version) + (define-key map (dvc-prefix-tagging-method ?x) 'tla-generic-add-to-exclude) ; alias + (define-key map (dvc-prefix-tagging-method ?e) 'tla-generic-add-to-exclude) ; alias + (define-key map (dvc-prefix-tagging-method ?j) 'tla-generic-add-to-junk) + (define-key map (dvc-prefix-tagging-method ?b) 'tla-generic-add-to-backup) + (define-key map (dvc-prefix-tagging-method ?~) 'tla-generic-add-to-backup) ; alias + (define-key map (dvc-prefix-tagging-method ?p) 'tla-generic-add-to-precious) + (define-key map (dvc-prefix-tagging-method ?u) 'tla-generic-add-to-unrecognized) + (define-key map (dvc-prefix-tagging-method ?X) 'tla-generic-add-ext-to-exclude) ; alias + (define-key map (dvc-prefix-tagging-method ?E) 'tla-generic-add-ext-to-exclude) ; alias + (define-key map (dvc-prefix-tagging-method ?J) 'tla-generic-add-ext-to-junk) + (define-key map (dvc-prefix-tagging-method ?B) 'tla-generic-add-ext-to-backup) + (define-key map (dvc-prefix-tagging-method ?P) 'tla-generic-add-ext-to-precious) + (define-key map (dvc-prefix-tagging-method ?U) 'tla-generic-add-ext-to-unrecognized) + ;; + ;; Toggles + ;; + (define-key map dvc-keyvec-toggle-set 'tla-inventory-set-all-toggle-variables) + (define-key map dvc-keyvec-toggle-reset 'tla-inventory-reset-all-toggle-variables) + (define-key map dvc-keyvec-toggle-invert 'tla-inventory-toggle-all-toggle-variables) + map) + "Keymap used in `tla-inventory-mode' buffers.") + +(defvar tla-inventory-item-map + (let ((map (copy-keymap dvc-cmenu-map-template))) + (define-key map dvc-mouse-2 'tla-inventory-find-file-by-mouse) + map) + "Keymap used on items in `tla-inventory-mode' buffers.") + +(defvar tla-inventory-default-version-map + (let ((map (copy-keymap dvc-cmenu-map-template))) + (define-key map [return] 'tla-generic-set-tree-version) + (define-key map "\C-m" 'tla-generic-set-tree-version) + map) + "Keymap used on the default version field in `tla-inventory-mode' buffers.") + +(defvar tla-inventory-tagging-method-map + (let ((map (copy-keymap dvc-cmenu-map-template))) + (define-key map dvc-mouse-2 'tla-generic-set-id-tagging-method-by-mouse) + (define-key map [return] 'tla-generic-set-id-tagging-method) + (define-key map "\C-m" 'tla-inventory-id-tagging-method) + map) + "Keymap used on the tagging method field in `tla-inventory-mode' buffers.") + +(defconst tla-inventory-file-types-manipulators + '((?S tla-inventory-display-source + tla-inventory-toggle-source ?s "source") + (?P tla-inventory-display-precious + tla-inventory-toggle-precious ?p "precious") + (?J tla-inventory-display-junk + tla-inventory-toggle-junk ?j "junk") + (?B tla-inventory-display-backup + tla-inventory-toggle-backup ?b "backup") + (?T tla-inventory-display-tree + tla-inventory-toggle-tree ?t "tree root") + (?U tla-inventory-display-unrecognized + tla-inventory-toggle-unrecognized ?u "unrecognized")) + "List of possible file types in inventory.") + +(dolist (type-arg tla-inventory-file-types-manipulators) + (define-key tla-inventory-mode-map `[?t ,(cadr (cddr type-arg))] + (car (cddr type-arg)))) + +(dolist (type-arg tla-inventory-file-types-manipulators) + (eval `(defcustom ,(cadr type-arg) t + ,(concat "Wether " (nth 4 type-arg) + " should be printed in inventory") + :group 'tla-inventory + :type 'boolean))) + +(defvar tla-tree-lint-mode-map + (let ((map (make-sparse-keymap))) + (define-key map dvc-keyvec-help 'describe-mode) + (define-key map dvc-keyvec-refresh 'dvc-generic-refresh) + (define-key map dvc-keyvec-add 'tla-tree-lint-add-files) + (define-key map dvc-keyvec-remove 'tla-tree-lint-delete-files) + (define-key map dvc-keyvec-quit 'dvc-buffer-quit) + (define-key map [(control x) (control j)] 'dvc-dired-jump) + (define-key map dvc-keyvec-commit 'tla-edit-log) + (define-key map dvc-keyvec-next 'tla-tree-lint-next) + (define-key map dvc-keyvec-previous 'tla-tree-lint-previous) + (define-key map [down] 'tla-tree-lint-next) + (define-key map [up] 'tla-tree-lint-previous) + (define-key map dvc-keyvec-id 'tla-tree-lint-regenerate-id) + (define-key map (dvc-prefix-move ?j) 'tla-tree-lint-make-junk) + (define-key map (dvc-prefix-move ?,) 'tla-tree-lint-make-junk) + (define-key map (dvc-prefix-move ?p) 'tla-tree-lint-make-precious) + (define-key map (dvc-prefix-move ?+) 'tla-tree-lint-make-precious) + ;; + (define-key map (dvc-prefix-tagging-method ?=) 'tla-edit-=tagging-method-file) + (define-key map (dvc-prefix-tagging-method ?.) 'tla-edit-.arch-inventory-file) + (define-key map (dvc-prefix-tagging-method ?M) 'tla-generic-set-id-tagging-method) + (define-key map (dvc-prefix-tagging-method ?V) 'tla-generic-set-tree-version) + (define-key map (dvc-prefix-tagging-method ?x) 'tla-generic-add-to-exclude) ; alias + (define-key map (dvc-prefix-tagging-method ?X) 'tla-generic-add-ext-to-exclude) ; alias + (define-key map (dvc-prefix-tagging-method ?e) 'tla-generic-add-to-exclude) ; alias + (define-key map (dvc-prefix-tagging-method ?E) 'tla-generic-add-ext-to-exclude) ; alias + (define-key map (dvc-prefix-tagging-method ?j) 'tla-generic-add-to-junk) + (define-key map (dvc-prefix-tagging-method ?J) 'tla-generic-add-ext-to-junk) + (define-key map (dvc-prefix-tagging-method ?b) 'tla-generic-add-to-backup) + (define-key map (dvc-prefix-tagging-method ?B) 'tla-generic-add-ext-to-backup) + (define-key map (dvc-prefix-tagging-method ?~) 'tla-generic-add-to-backup) ; alias + (define-key map (dvc-prefix-tagging-method ?p) 'tla-generic-add-to-precious) + (define-key map (dvc-prefix-tagging-method ?P) 'tla-generic-add-ext-to-precious) + (define-key map (dvc-prefix-tagging-method ?u) 'tla-generic-add-to-unrecognized) + (define-key map (dvc-prefix-tagging-method ?U) 'tla-generic-add-ext-to-unrecognized) + ;; Other commands + (define-key map dvc-keyvec-diff 'tla-changes) + (define-key map dvc-keyvec-inventory 'tla-inventory) + ;; + (define-key map [return] 'dvc-find-file-at-point) + (define-key map "\C-m" 'dvc-find-file-at-point) + (define-key map [?o] 'dvc-find-file-other-window) + (define-key map [?v] 'dvc-view-file) + ;; + ;; Mark group + ;; + (define-key map (dvc-prefix-mark dvc-key-mark) 'tla-tree-lint-mark-file) + (define-key map (dvc-prefix-mark dvc-key-unmark) 'tla-tree-lint-unmark-file) + ;; TODO + ;; (define-key map dvc-keyvec-mark-all 'tla-tree-lint-mark-all) + (define-key map dvc-keyvec-unmark-all 'tla-tree-lint-unmark-all) + ;; Alias for above bindings + (define-key map dvc-keyvec-mark 'tla-tree-lint-mark-file) + (define-key map dvc-keyvec-unmark 'tla-tree-lint-unmark-file) + ;; + ;; Buffers group + ;; + (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) 'tla-bookmarks) + map) + "Keymap used in `tla-tree-lint-mode' buffers.") + +(defvar tla-tree-lint-file-map + (let ((map (copy-keymap dvc-cmenu-map-template))) + (define-key map dvc-mouse-2 'dvc-find-file-at-point-by-mouse) + map) + "Keymap used on files in tla-lint-mode buffers.") + +;; +;; Revlog mode +;; +(defvar tla-revlog-mode-map + (let ((map (make-sparse-keymap))) + (define-key map dvc-keyvec-help 'describe-mode) + (define-key map dvc-keyvec-inventory 'dvc-pop-to-inventory) + (define-key map dvc-keyvec-quit 'dvc-buffer-quit) + (define-key map dvc-keyvec-diff 'tla-log-get-changeset) + (define-key map "\C-m" 'tla-press-button) + (define-key map dvc-mouse-2 'tla-push-button) + map) + "Keymap used in `tla-revlog-mode' buffers.") + +(defvar tla-current-revision nil + "Revision displayed in a `tla-revlog-mode' buffer.") + +(defcustom tla-button-revision-fn 'tla-revlog-any + "*Function to call when clicking a revision button. + +Buttons appear in Gnus Article buffer if `tla-insinuate-gnus' has +been run, and in log buffers. + +The function must take a string as argument." + :type 'function + :group 'xtla) + +;; +;; Log edit mode +;; +(defvar tla-log-edit-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [(control ?c) (control ?c)] 'tla-log-edit-done) + (define-key map [(control ?c) (control ?d)] 'tla-changes) + (define-key map [(control ?c) (control ?l)] 'tla-changelog) + (define-key map [(control ?c) (control ?m)] 'tla-log-edit-insert-log-for-merge) + (define-key map [(control ?c) ?m ] + 'tla-log-edit-insert-log-for-merge-and-headers) + (define-key map [(control ?c) (control ?p)] 'tla-log-edit-insert-memorized-log) + (define-key map [(control ?c) (control ?q)] 'tla-log-edit-abort) + (define-key map [(control ?c) (control ?s)] 'tla-log-goto-summary) + (define-key map [(control ?c) (control ?b)] 'tla-log-goto-body) + (define-key map [(control ?c) (control ?k)] 'tla-log-edit-keywords) + (define-key map "\t" 'tla-log-edit-next-field) + map) + "Keymap used in `tla-log-edit-mode' buffers.") + +;; +;; Archive list mode +;; +(defvar tla-archive-list-mode-map + (let ((map (make-sparse-keymap))) + (define-key map dvc-keyvec-help 'describe-mode) + (define-key map (dvc-prefix-kill-ring ?a) 'tla-save-archive-to-kill-ring) + (define-key map "\C-m" 'tla-archive-list-categories) + (define-key map [return] 'tla-archive-list-categories) + + ;; Buffers group + (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) 'tla-bookmarks) + + (define-key map dvc-keyvec-add-bookmark 'tla-bookmarks-add) + (define-key map [?o] 'tla-archive-browse-archive) + (define-key map [?*] 'tla-archive-select-default) + (define-key map (dvc-prefix-add ?r) 'tla-register-archive) + (define-key map (dvc-prefix-add ?a) 'tla-make-archive) + (define-key map (dvc-prefix-add ?m) 'tla-archive-mirror-archive) + (define-key map dvc-keyvec-remove 'tla-archive-unregister-archive) + (define-key map [?g] 'tla-archives) + (define-key map [?s] 'tla-archive-synchronize-archive) + (define-key map [?e] 'tla-archive-edit-archive-location) + (define-key map [down] 'tla-archive-next) + (define-key map [up] 'tla-archive-previous) + (define-key map [?n] 'tla-archive-next) + (define-key map [?p] 'tla-archive-previous) + (define-key map dvc-keyvec-quit 'dvc-buffer-quit) + map) + "Keymap used in `tla-archive-list-mode' buffers.") + +(defvar tla-archive-archive-map + (let ((map (make-sparse-keymap))) + (define-key map dvc-mouse-2 'tla-archive-list-categories-by-mouse) + map) + "Keymap used archives in `tla-archive-list-mode' buffers.") + +;; +;; Category list mode +;; +(defvar tla-category-list-mode-map + (let ((map (make-sparse-keymap))) + (define-key map dvc-keyvec-help 'describe-mode) + (define-key map "\C-m" 'tla-category-list-branches) + (define-key map [return] 'tla-category-list-branches) + + ;; Buffers group + (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) 'tla-bookmarks) + + (define-key map dvc-keyvec-add-bookmark 'tla-category-bookmarks-add-here) + (define-key map [?^] 'tla-archives) + (define-key map (dvc-prefix-add ?c) 'tla-category-make-category) + (define-key map [?g] 'tla-category-refresh) + (define-key map [?s] 'tla-category-mirror-archive) + (define-key map [down] 'tla-category-next) + (define-key map [up] 'tla-category-previous) + (define-key map [?n] 'tla-category-next) + (define-key map [?p] 'tla-category-previous) + (define-key map dvc-keyvec-quit 'dvc-buffer-quit) + map) + "Keymap used in `tla-category-list-mode' buffers.") + +(defvar tla-category-category-map + (let ((map (make-sparse-keymap))) + (define-key map dvc-mouse-2 'tla-category-list-branches-by-mouse) + map) + "Keymap used categories in `tla-category-list-mode' buffers.") + +;; +;; Branch list mode section +;; +(defvar tla-branch-list-mode-map + (let ((map (make-sparse-keymap))) + (define-key map dvc-keyvec-help 'describe-mode) + (define-key map "\C-m" 'tla-branch-list-versions) + (define-key map [return] 'tla-branch-list-versions) + + ;; Buffers group + (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) 'tla-bookmarks) + + (define-key map dvc-keyvec-parent 'tla-branch-list-parent-category) + (define-key map (dvc-prefix-add ?b) 'tla-branch-make-branch) + (define-key map [?>] 'tla-branch-get-branch) + (define-key map [?g] 'tla-branch-refresh) + (define-key map [?s] 'tla-branch-mirror-archive) + (define-key map [down] 'tla-category-next) + (define-key map [up] 'tla-category-previous) + (define-key map [?n] 'tla-category-next) + (define-key map [?p] 'tla-category-previous) + (define-key map dvc-keyvec-quit 'dvc-buffer-quit) + (define-key map dvc-keyvec-add-bookmark 'tla-branch-bookmarks-add-here) + map) + "Keymap used in `tla-branch-list-mode' buffers.") + +(defvar tla-branch-branch-map + (let ((map (make-sparse-keymap))) + (define-key map dvc-mouse-2 'tla-branch-list-versions-by-mouse) + map) + "Keymap used branches in `tla-branch-list-mode' buffers.") + +;; +;; Version list mode +;; +(defvar tla-version-list-mode-map + (let ((map (make-sparse-keymap))) + (define-key map dvc-keyvec-help 'describe-mode) + (define-key map "\C-m" 'tla-version-list-revisions) + (define-key map [return] 'tla-version-list-revisions) + + ;; Buffers group + (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) 'tla-bookmarks) + + (define-key map (dvc-prefix-kill-ring ?v) 'tla-version-save-version-to-kill-ring) + (define-key map dvc-keyvec-parent 'tla-version-list-parent-branch) + (define-key map (dvc-prefix-add ?v) 'tla-version-make-version) + (define-key map [?>] 'tla-version-get-version) + (define-key map [?g] 'tla-version-refresh) + (define-key map [?s] 'tla-version-mirror-archive) + (define-key map [down] 'tla-category-next) + (define-key map [up] 'tla-category-previous) + (define-key map [?n] 'tla-category-next) + (define-key map [?p] 'tla-category-previous) + (define-key map dvc-keyvec-quit 'dvc-buffer-quit) + (define-key map dvc-keyvec-add-bookmark 'tla-version-bookmarks-add-here) + (define-key map dvc-keyvec-tag 'tla-version-tag) + map) + "Keymap used in `tla-version-list-mode' buffers.") + +(defvar tla-version-version-map + (let ((map (make-sparse-keymap))) + (define-key map dvc-mouse-2 'tla-version-list-revisions-by-mouse) + map) + "Keymap used versions in `tla-version-list-mode' buffers.") + +;; +;; Revision list mode +;; +(defvar tla-revision-list-mode-map + (let ((map (make-sparse-keymap))) + (define-key map dvc-keyvec-parent 'tla-revision-list-parent-version) + (define-key map [?> ?g] 'tla-revision-get-revision) + (define-key map [?> ?C] 'tla-revision-cache-revision) + (define-key map [?> ?L] 'tla-revision-add-to-library) + + ;; Buffers group + (define-key map (dvc-prefix-kill-ring ?r) 'tla-revision-save-revision-to-kill-ring) + (define-key map (dvc-prefix-kill-ring ?v) 'tla-revision-save-version-to-kill-ring) + + (define-key map dvc-keyvec-add-bookmark 'tla-bookmarks-add) + + (define-key map (dvc-prefix-toggle ??) 'tla-revision-toggle-help) + (define-key map (dvc-prefix-toggle ?l) 'tla-revision-toggle-library) + (define-key map (dvc-prefix-toggle ?m) 'tla-revision-toggle-merges) + (define-key map (dvc-prefix-toggle ?b) 'tla-revision-toggle-merged-by) + (define-key map (dvc-prefix-toggle ?r) 'tla-revision-toggle-reverse) + + ;; + ;; Star merge + ;; from here + (define-key map dvc-keyvec-star-merge 'tla-revision-star-merge) + ;; from head + (define-key map (dvc-prefix-merge dvc-key-star-merge) + 'tla-revision-star-merge-version) + + ;; + ;; Replay + ;; from here + (define-key map dvc-keyvec-replay 'tla-revision-replay) + ;; from head + (define-key map (dvc-prefix-merge dvc-key-replay) + 'tla-revision-replay-version) + + ;; + ;; Sync tree + (define-key map [?y] 'tla-revision-sync-tree) + ;; + ;; Update + (define-key map (dvc-prefix-merge dvc-key-update) + 'tla-revision-update) + ;; + ;; Tag + ;; from here + (define-key map dvc-keyvec-tag 'tla-revision-tag-from-here) + + (define-key map [?l] 'tla-revision-revlog) + (define-key map (dvc-prefix-merge dvc-key-missing) 'tla-missing-show-all-revisions) + (define-key map (dvc-prefix-diff dvc-key-diff) 'tla-revision-delta) + (define-key map (dvc-prefix-diff dvc-key-get) + 'tla-revision-store-delta) + ;; Moved to DVC now. + ;; (define-key map [?=] 'tla-revision-changeset) + ;; (define-key map [(meta ?=)] 'tla-revision-scroll-up-or-show-changeset) + (define-key map dvc-keyvec-add-bookmark 'tla-revision-bookmarks-add) + map) + "Keymap used in `tla-revision-list-mode' buffers.") + +(defstruct (tla--revision) + revision ;; The revision, as a list + summary creator date + merges ;; List of patches merged by this revision + body ;; Body of the log file (after headers) + log ;; full log (redundant with other fields) + ) + +(defvar tla-revision-revision-map + (let ((map (copy-keymap dvc-cmenu-map-template))) + (define-key map dvc-mouse-2 'dvc-revlist-show-item-by-mouse) + map) + "Keymap used on revisions in `tla-revision-list-mode' buffers.") + + +;; +;; ChangeLog mode section +;; +(defvar tla-changelog-mode-map + (let ((map (copy-keymap change-log-mode-map))) + (suppress-keymap map) + (define-key map dvc-keyvec-quit 'dvc-buffer-quit) + (define-key map [?n] 'tla-changelog-next-entry) + (define-key map [?p] 'tla-changelog-previous-entry) + (define-key map [?=] 'tla-changelog-show-changeset) + (define-key map [?M] 'tla-send-commit-notification) + (define-key map "\C-m" 'tla-press-button) + (define-key map dvc-mouse-2 'tla-push-button) + ;; + ;; Kill ring group + ;; + (define-key map dvc-keyvec-kill-ring nil) + (define-key map (dvc-prefix-kill-ring ?l) 'tla-changelog-save-log-message-as-kill) + (define-key map (dvc-prefix-kill-ring ?r) 'tla-changelog-save-revision-as-kill) + (define-key map (dvc-prefix-kill-ring ?v) 'tla-changelog-save-version-as-kill) + map) + "Keymap used in `tla-changelog-mode'.") + + +;; +;; Log edit buffer mode section +;; + +(defvar tla-log-edit-keywords-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [?n] 'tla-log-edit-keywords-next) + (define-key map [?p] 'tla-log-edit-keywords-previous) + (define-key map [?m] 'tla-log-edit-keywords-mark) + (define-key map [?u] 'tla-log-edit-keywords-unmark) + (define-key map [?t] 'tla-log-edit-keywords-toggle-mark) + (define-key map [?* ?!] 'tla-log-edit-keywords-unmark-all) + (define-key map [?* ?*] 'tla-log-edit-keywords-mark-all) + (define-key map "\C-c\C-c" 'tla-log-edit-keywords-insert) + map) + "Keymap used in tla-log-edit-keywords-mode buffers.") + + +;; ---------------------------------------------------------------------------- +;; Menu entries +;; ---------------------------------------------------------------------------- +;; +;; Conventions +;; +;; 1. Each Nouns and verbs in menu items are should be capitalized. +;; 2. TODO: Consider menu items order. + +;; +;; Common submenus +;; + +(defconst tla-.arch-inventory-menu-list + '("Put to .arch-inventory" + ["Junk" tla-generic-add-to-junk t] + ["Backup" tla-generic-add-to-backup t] + ["Precious" tla-generic-add-to-precious t] + ["Unrecognized" tla-generic-add-to-unrecognized t])) + +(defconst tla-=tagging-method-menu-list + '("Put to =tagging-method" + ["Junk" (tla-generic-add-to-junk t) t] + ["Backup" (tla-generic-add-to-backup t) t] + ["Precious" (tla-generic-add-to-precious t) t] + ["Unrecognized" (tla-generic-add-to-junk t) t])) + +;; +;; Bookmarks mode +;; +(defconst tla-bookmarks-entry-menu-list + '("Bookmark Entry" + ["Delete" tla-bookmarks-delete t] + ["Goto Location" tla-bookmarks-goto t] + ("File Tree" + ["Find File" tla-bookmarks-find-file t] + ["Run Dired" tla-bookmarks-open-tree t] + ["Run Inventory" tla-bookmarks-inventory t] + ["View Changes" tla-bookmarks-changes t] + ) + ("Merge/Tag" + ["View Missing Patches" tla-bookmarks-missing t] + ["Replay" tla-bookmarks-replay t] + ["Update" tla-bookmarks-update t] + ["Star-merge" tla-bookmarks-star-merge t] + ["Tag" tla-bookmarks-tag t] + ) + ("Edit" + ["Edit Bookmark" tla-bookmarks-edit t] + ["Add Nickname" tla-bookmarks-add-nickname-interactive t] + ["Remove Nickname" tla-bookmarks-delete-nickname-interactive t] + ["Add Local Tree" tla-bookmarks-add-tree-interactive t] + ["Remove Local Tree" tla-bookmarks-delete-tree-interactive t] + ["Add Group" tla-bookmarks-add-group-interactive t] + ["Remove Group" tla-bookmarks-delete-group-interactive t] + ["Add Partner" tla-bookmarks-add-partner-interactive t] + ["Remove Partner" tla-bookmarks-delete-partner-interactive t] + ) + ("Partners" + ["Add Partner" tla-bookmarks-add-partner-interactive t] + ["Remove Partner" tla-bookmarks-delete-partner-interactive t] + ["Write to Partner File" tla-bookmarks-write-partners-to-file t] + ["Load from Partner File" tla-bookmarks-add-partners-from-file t] + ["View Missing Patches" tla-bookmarks-missing t] + )) + "Used both for the local and the global menu." + ) + +(easy-menu-define tla-bookmarks-mode-menu tla-bookmarks-mode-map + "`tla-bookmarks-mode' menu" + `("Xtla-Bookmarks" + ["Add Bookmark" tla-bookmarks-add t] + ["Show Details" tla-bookmarks-toggle-details + :style toggle :selected tla-bookmarks-show-details] + ["Select by Group" tla-bookmarks-select-by-group t] + ["Cleanup 'local-tree fields" tla-bookmarks-cleanup-local-trees t] + ,tla-bookmarks-entry-menu-list + )) + +(easy-menu-define tla-bookmarks-entry-menu nil + "Menu used on a tla bookmark entry." + tla-bookmarks-entry-menu-list) + +;; +;; Inventory mode +;; +(easy-menu-define tla-inventory-mode-partners-menu tla-inventory-mode-map + "`tla-inventory-mode' partners menu" + '("Partners" + ["Add Partner..." tla-partner-add t] + ("Set Tree Version" :filter (lambda (x) + (tla--partner-create-menu + 'tla-generic-set-tree-version))) + "--" + ("Show Changes" :filter (lambda (x) + (tla--partner-create-menu + '(lambda (x) + (tla-changes current-prefix-arg + (list tla-arch-branch + (list 'revision + (tla--name-split x)))))))) + ("Show Missing" :filter (lambda (x) + (tla--partner-create-menu + '(lambda (x) + (tla-missing-1 default-directory x))))) + ("Show ChangeLog" :filter (lambda (x) + (tla--partner-create-menu + '(lambda (x) + (tla-changelog x))))) + "--" + ("Replay" :filter (lambda (x) + (tla--partner-create-menu + 'tla-inventory-replay))) + ("Star-merge" :filter (lambda (x) + (tla--partner-create-menu + 'tla-inventory-star-merge))))) + +(defconst tla-inventory-item-menu-list + `("Inventory Item" + ["Open File" tla-inventory-find-file t] + ["View File" dvc-view-file t] + "--" + ["Add" tla-inventory-add-files t] + ["Move" tla-inventory-move t] + ["Revert" tla-inventory-revert t] + ["Remove" tla-inventory-remove-files t] + ["Delete" tla-inventory-delete-files t] + "--" + ["Make Junk" tla-inventory-make-junk t] + ["Make Precious" tla-inventory-make-precious t] + ,tla-.arch-inventory-menu-list + ,tla-=tagging-method-menu-list) + "Used both in the context and the global menu for inventory.") + +(easy-menu-define tla-inventory-mode-menu tla-inventory-mode-map + "`tla-inventory-mode' menu" + `("Inventory" + ["Edit Log" tla-inventory-edit-log t] + "--" + ["Show Changes" tla-inventory-changes t] + ["Show Changelog" tla-changelog t] + ["Show Logs" tla-logs t] + ["Show Missing" tla-inventory-missing t] + "--" + ,tla-inventory-item-menu-list + "--" + ["Update" tla-inventory-update t] + ["Replay" tla-inventory-replay t] + ["Star-merge" tla-inventory-star-merge t] + ("Changesets" + ["Save actual changes in directory" tla-changes-save t] + ["Save actual changes in tarball" tla-changes-save-as-tgz t] + ["View changeset from directory" tla-show-changeset t] + ["View changeset from tarball" tla-show-changeset-from-tgz t] + ["Apply changeset from directory" tla-inventory-apply-changeset t] + ["Apply changeset from tarball" tla-inventory-apply-changeset-from-tgz t] + ) + "--" + ["Undo" tla-inventory-undo t] + ["Redo" tla-inventory-redo t] + "--" + ["Synchronize Mirror" tla-inventory-mirror t] + ("Taging Method" + ["Edit .arch-inventory" tla-edit-.arch-inventory-file t] + ["Edit =tagging-method" tla-edit-=tagging-method-file t] + ["Set Tagging Method" tla-generic-set-id-tagging-method t] + ["Set Tree Version From Scratch" tla-generic-set-tree-version t] + ) + ["Tree-lint" tla-tree-lint t] + "--" + ("Toggles" + ["Set All Toggle Variables" tla-inventory-set-all-toggle-variables t] + ["Reset All Toggle Variables" tla-inventory-reset-all-toggle-variables t] + ["Toggle All Toggle Variables" tla-inventory-toggle-all-toggle-variables t] . + ,(mapcar '(lambda (elem) `[,(concat "Toggle " (car (cddddr elem))) + ,(car (cddr elem)) + :style toggle + :selected ,(cadr elem)]) + tla-inventory-file-types-manipulators)))) + +(easy-menu-define tla-inventory-item-menu nil + "Menu used on a inventory item." + tla-inventory-item-menu-list) + +(easy-menu-define tla-inventory-tagging-method-menu nil + "Menu used on the taggine method line in a inventory buffer." + '("Switch Taggine Method" + ["Tagline" (tla-generic-set-id-tagging-method "tagline") t] + ["Explicit" (tla-generic-set-id-tagging-method "explicit") t] + ["Names" (tla-generic-set-id-tagging-method "names") t] + ["Implicit" (tla-generic-set-id-tagging-method "implicit") t])) + +;; +;; revlog mode +;; +(easy-menu-define tla-revlog-mode-menu tla-revlog-mode-map + "'tla-revlog-mode' menu" + '("Revlog" + ["Inventory" dvc-pop-to-inventory t] + ["Show Changeset" tla-log-get-changeset t] + ["Quit" dvc-buffer-quit t] + )) + +;; +;; Log edit mode +;; +(easy-menu-define tla-log-edit-mode-menu tla-log-edit-mode-map + "`tla-log-edit-mode' menu" + '("Log" + ["Insert tla log-for-merge" tla-log-edit-insert-log-for-merge t] + ["log-for-merge and headers" + tla-log-edit-insert-log-for-merge-and-headers t] + ["Insert memorized log" tla-log-edit-insert-memorized-log t] + ["Show changes" tla-changes t] + ["Commit" tla-log-edit-done t] + ("Manage Version" + ["Commit with Sealing" tla-log-edit-done-with-sealing t] + ["Commit with Fixing" tla-log-edit-done-with-fixing t]) + ["Show Changelog" tla-changelog t] + "--" + ["Goto Summary Field" tla-log-goto-summary t] + ["Goto Body" tla-log-goto-body t] + ["Edit Keywords Field" tla-log-edit-keywords t] + ["Kill Body" tla-log-kill-body t] + "--" + ["Tree Lint" tla-tree-lint t] + ["Abort" tla-log-edit-abort t])) + +;; +;; Archive list mode +;; +(easy-menu-define tla-archive-list-mode-menu tla-archive-list-mode-map + "`tla-archive-list-mode' menu" + '("Archives" + ["Register New Archive" tla-register-archive t] + ["Add a Bookmark" tla-bookmarks-add t] + ["Update Archives List" tla-archives t] + ["Set Default Archive" tla-archive-select-default t] + ["Remove Archive Registration" tla-archive-unregister-archive t] + ["Edit Archive Location" tla-archive-edit-archive-location t] + ["Make New Archive..." tla-make-archive t] + ["Create a Mirror" tla-archive-mirror-archive t] + ["Use as default Mirror" tla-archive-use-as-default-mirror t] + ["Synchronize Mirror" tla-archive-synchronize-archive t] + )) + +;; +;; Category list mode +;; +(easy-menu-define tla-category-list-mode-menu tla-category-list-mode-map + "`tla-category-list-mode' menu" + '("Categories" + ["List Archives" tla-archives t] + ["Update Categories List" tla-category-refresh t] + ["Make New Category..." tla-category-make-category t] + ["Add a Bookmark" tla-bookmarks-add t] + ["Synchronize Mirror" tla-category-mirror-archive t] + )) + + +;; +;; Branch list mode +;; +(easy-menu-define tla-branch-list-mode-menu tla-branch-list-mode-map + "`tla-branch-list-mode' menu" + '("Branches" + ["Update Branches List" tla-branch-refresh t] + ["List Parent Category" tla-branch-list-parent-category t] + ["Make New Branch..." tla-branch-make-branch t] + ["Synchronize Mirror" tla-branch-mirror-archive t] + ["Bookmark Branch under Point" tla-branch-bookmarks-add t] + ["Get..." tla-branch-get-branch t] + )) + +;; +;; Version list mode +;; +(easy-menu-define tla-version-list-mode-menu tla-version-list-mode-map + "`tla-version-list-mode' menu" + '("Versions" + ["Update Versions List" tla-version-refresh t] + ["Get..." tla-version-get-version t] + ["Make New Version..." tla-version-make-version t] + ["List Parent Branch" tla-version-list-parent-branch t] + ["Synchronize Mirror" tla-version-mirror-archive t] + ["Bookmark Version under Point" tla-version-bookmarks-add t] + ["Tag This Version" tla-version-tag t])) + +;; +;; Revision list mode +;; +(easy-menu-define tla-revision-list-mode-menu tla-revision-list-mode-map + "`tla-revision-list-mode' menu" + '("Revisions" + ["Refresh Revisions List" dvc-generic-refresh t] + ["List Parent Version" tla-revision-list-parent-version t] + ["Show all revisions" tla-missing-show-all-revisions t] + "--" + ["Bookmark Revision under Point" tla-revision-bookmarks-add t] + ("Mark" + ["Mark Revision" dvc-revision-mark-revision t] + ["Unmark Revision" dvc-revision-unmark-revision t]) + "--" + ["Show Log" tla-revision-revlog t] + ["Unify Patch Logs with This Revision" tla-revision-sync-tree t] + ["View changeset" tla-revision-changeset t] + ("Delta" + ["View" (tla-revision-delta t) t] + ["Store to Directory" (tla-revision-store-delta t) t]) + "--" + ["Update" tla-revision-update t] + ("Replay" + ["From Head Revision" tla-revision-replay-version t] + ["From Revision under Point" tla-revision-replay t] + ["Revision under Point Reversely" (tla-revision-replay 'reversely) t]) + ("Star-Merge" + ["From Head Revision" tla-revision-star-merge-version t] + ["From Revision under Point" tla-revision-star-merge t]) + ("Get" + ["Get a Local Copy" tla-revision-get-revision t] + ["Make Cache" tla-revision-cache-revision t] + ["Add to Library" tla-revision-add-to-library t]) + ("Tag " + ["From Head Revision" tla-revision-tag-from-head t] + ["From Revision under Point" tla-revision-tag-from-here t]) + ["Send comment to author" tla-revision-send-comments t] + "--" + ("Filter Display" + ["Date" dvc-revlist-toggle-date + :style toggle :selected dvc-revisions-shows-date] + ["Creator" dvc-revlist-toggle-creator + :style toggle :selected dvc-revisions-shows-creator] + ["Summary" dvc-revlist-toggle-summary + :style toggle :selected dvc-revisions-shows-summary] + ["Presence in Revlib" tla-revision-toggle-library + :style toggle :selected tla-revisions-shows-library] + ["Merged Patches" tla-revision-toggle-merges + :style toggle :selected tla-revisions-shows-merges] + ["Patches Merging ..." tla-revision-toggle-merged-by + :style toggle :selected tla-revisions-shows-merged-by]))) + +(easy-menu-define tla-revision-revision-menu nil + "Menu used on a revision item in `tla-revision-list-mode' buffer" + '("Revision" + ["Show Log" tla-revision-revlog t] + ["Unify Patch Logs with This Revision" tla-revision-sync-tree t] + ["View changeset" tla-revision-changeset t] + ["Set Bookmark" tla-revision-bookmarks-add t] + ("Mark" + ["Mark Revision" dvc-revision-mark-revision t] + ["Unmark Revision" dvc-revision-unmark-revision t]) + ("Delta" + ["In This Version" tla-revision-delta t] + ["With Revision in Another Archive" tla-revision-store-delta t]) + ("Merge" + ["Star-Merge" tla-revision-star-merge t] + ["Replay" tla-revision-replay t] + ["Replay Reversely" (tla-revision-replay 'reversely) t]) + ("Get" + ["Get a Local Copy" tla-revision-get-revision t] + ["Make Cache" tla-revision-cache-revision t] + ["Add to Library" tla-revision-add-to-library t]) + ["Send comment to author" tla-revision-send-comments t] + ["Tag from Here" tla-revision-tag-from-here])) + +;; +;; Lint mode +;; +(defconst tla-tree-lint-file-menu-list + `("File" + ["Jump to File" dvc-find-file-at-point t] + ("Mark" + ["Mark File" tla-tree-lint-mark-file t] + ["Unmark File" tla-tree-lint-unmark-file t]) + "--" + ["Add File" tla-tree-lint-add-files t] + ["Delete File" tla-tree-lint-delete-files t] + ["Regenerate ID" tla-tree-lint-regenerate-id t] + "--" + ["Make Junk" tla-tree-lint-make-junk t] + ["Make Precious" tla-tree-lint-make-precious t] + ,tla-.arch-inventory-menu-list + ,tla-=tagging-method-menu-list + ) + "Used both for context and global menu.") + +(easy-menu-define tla-tree-lint-file-menu nil + "Menu used on files listed in `tla-tree-lint'" + tla-tree-lint-file-menu-list + ) + +(easy-menu-define tla-tree-lint-mode-menu tla-tree-lint-mode-map + "`tla-tree-lint' menu" + `("Tree Lint" + ["Refresh Buffer" dvc-generic-refresh t] + ,tla-tree-lint-file-menu-list + )) + +;; +;; Event Log buffer +;; +(easy-menu-define dvc-log-buffer-mode-menu dvc-log-buffer-mode-map + "`dvc-log-buffer' menu" + '("Logs" + ["Show Related Buffer" dvc-switch-to-related-buffer t] + ["Show Output Buffer" dvc-switch-to-output-buffer t] + ["Show Error Buffer" dvc-switch-to-error-buffer t] + )) + + +;; ---------------------------------------------------------------------------- +;; User customization section +;; ---------------------------------------------------------------------------- + +;;;###autoload +(defgroup xtla nil + "Arch interface for emacs." + :group 'dvc + :prefix "tla-") + +(defgroup tla-inventory nil + "This group contains items used in inventory mode." + :group 'xtla) + +(defgroup tla-revisions nil + "This group contains items used in revisions mode." + :group 'xtla) + +(defgroup tla-bindings nil + "This group contains items related to key bindings." + :group 'xtla) + +(defgroup tla-faces nil + "This group contains faces defined for Xtla." + :group 'dvc-faces) + +(defcustom tla-executable (dvc-first-set + dvc-site-tla-executable + "tla") + "*The name of the tla executable." + :type 'string + :group 'xtla) + +(defcustom baz-executable (dvc-first-set + dvc-site-baz-executable + "baz") + "*The name of the baz executable. +baz is the command name for bazaar, a branch of tla." + :type 'string + :group 'xtla) + +(defcustom tla-arch-branch (dvc-first-set + dvc-site-arch-branch + (if (executable-find + baz-executable) + 'baz + 'tla)) + "*Branch of GNU Arch to use. +Currently supported are 'tla and 'baz." + :type '(choice (const baz) + (const tla) + (const :tag "No tla variant installed" none)) + :group 'xtla) + +(defcustom tla-install-command-help-system t + "*Use f1 to display help for the actual function call during minibuffer input. +Note: this functionality is provided for all minibuffer prompts." + :type 'boolean + :group 'xtla) + +(defcustom tla-changes-recursive t + "*Whether or not Xtla will compute changes recursively. + +If non nil, `tla-changes' will be applied recursively to subprojects +of the current tree" + :type 'boolean + :group 'xtla) + +(defcustom tla-update-recursive t + "*Whether or not Xtla will run update recursively. + +If non nil, `tla-update' will be applied recursively to subprojects +of the current tree" + :type 'boolean + :group 'xtla) + +(defcustom tla-strict-commits nil + "*If non-nil, commit operations are invoked with the --strict option." + :type 'boolean + :group 'xtla) + +(defcustom tla-commit-check-log-buffer-functions + '(tla-commit-check-empty-headers + tla-commit-check-empty-line + tla-commit-check-missing-space) + "*List of functions to check the ++log.. buffer. + +Each function is called, from the log buffer, with no argument. It +should raise an error if commit should be canceled." + :type 'hook + :group 'xtla) + +(defcustom tla-commit-headers-allowed-to-be-empty + "^\\(Keywords\\)$" + "*Headers allowed to be empty in the ++log.. buffer. + +This should be a regexp matching the header names. Headers not +matching this regexp should not be empty when committing." + :type 'string + :group 'xtla) + +(defcustom tla-commit-fix-missing-space t + "*Whether or not Xtla will add missing spaces after header names. + +If non-nil, missing spaces after a space will be inserted +automatically instead of raising an error when committing." + :type 'boolean + :group 'xtla) + +;;;###autoload +(defcustom tla-three-way-merge t + "*If non-nil, merge operations are invoked with --three-way. +\(or without --two-way for branches of arch in which --three-way is the +default)." + :type 'boolean + :group 'xtla) + +;;;###autoload +(defcustom tla-show-ancestor nil + "*If non-nil, merge operations are invoked with --show-ancestor. + +With this option, conflicts markers will include TREE, MERGE-SOURCE, +and ancestor versions. `smerge-ediff' allows you to view the ancestor +with `ediff-show-ancestor' (usually bound to `/'). + +Unfortunately, this will also report more conflicts: Conflicts will be +reported even when TREE and MERGE-SOURCE are identical, if they differ +from ANCESTOR." + :type 'boolean + :group 'xtla) + +(defcustom tla-update-strategy 'merge + "*Which strategy to apply for `tla-update'. + +\"baz merge\" has the advantage of being able to use a 3-way merge. +\"baz replay\" is the fastest: No need to build any reference tree. +\"baz update\" is \"safe\": The local changes are backed-up before +updating. + +In the absence of conflicts, the result should be identical. In the +case of conflicts: + +\"baz merge\" will leave diff3 inline markers in the code. +\"baz update\" will leave the rejected changes from YOUR modifications +in .rej files. +\"baz replay\" will leave the rejected changes from THE ARCHIVE +modifications in .rej files. It also stops when it encounters +conflicts, so it doesn't always apply every upstream change." + :type '(choice (const 'update) + (const 'merge) + (const 'replay)) + :group 'xtla) + +;;;###autoload +(defcustom tla-non-recursive-inventory t + "*If non-nil, inventory is run with --no-recursion (if available)." + :type 'boolean + :group 'xtla) + +;; --forward is actually a no-op ! +;; ;;;###autoload +;; (defcustom tla-use-forward-option nil +;; "*If non-nil, use the --forward option with commands that allow it." +;; :type 'boolean +;; :group 'xtla) + +(defcustom tla-tag-does-cacherev 'ask + "*Whether \"tla tag\" or \"baz branch\" should create a cacherev. + +Supported values are: + 'yes + 'no + 'ask" + :type '(choice (const 'yes) + (const 'no) + (const 'ask)) + :group 'xtla) + +;;;###autoload +(defcustom tla-use-skip-present-option nil + "*If non-nil, use --skip-present with commands that allow it." + :type 'boolean + :group 'xtla) + +;; ;;;###autoload +;; (defun tla-toggle-use-forward-option () +;; "Toggle the value of `tla-use-forward-option'." +;; (interactive) +;; (setq tla-use-forward-option (not tla-use-forward-option))) + +(defun tla-toggle-use-skip-present-option () + "Toggle the value of `tla-use-skip-present-option'." + (interactive) + (setq tla-use-skip-present-option + (not tla-use-skip-present-option))) + +;;;###autoload +(defun tla-toggle-three-way-merge () + "Toggle the value of `tla-three-way-merge'." + (interactive) + (setq tla-three-way-merge (not tla-three-way-merge))) + +;;;###autoload +(defun tla-toggle-show-ancestor () + "Toggle the value of `tla-show-ancestor'." + (interactive) + (setq tla-show-ancestor (not tla-show-ancestor))) + +;;;###autoload +(defun tla-toggle-non-recursive-inventory () + "Toggle the value of `tla-toggle-non-recursive-inventory'." + (interactive) + (setq tla-non-recursive-inventory + (not tla-non-recursive-inventory))) + +(defgroup tla-bookmarks nil + "Xtla bookmarks allows you to save places (archive, category, +branch, version) in the archive that you use often. Try M-x +tla-bookmarks RET to see." + :group 'xtla) + +(defcustom tla-bookmarks-file-name "bookmarks.el" + "*File in which Xtla bookmarks will be saved. +The bookmark file is stored in the `dvc-config-directory'" + :type 'file + :group 'tla-bookmarks) + +(defcustom tla-tag-function 'tla-tag-uuid + "Function called to generate the value of the arch-tag. + +The function must take no argument, and return a string without a +final newline." + :type '(choice (const tla-tag-uuid) + (const tla-tag-name-date-filename) + function) + :group 'xtla) + +(defcustom tla-log-library "~/.arch-log-library/" + "*Directory in which the log library will be stored." + :type 'directory + :group 'xtla) + +(defcustom tla-log-library-greedy t + "*Whether log files are automatically saved in the log library. + +If non-nil, then, whenever Xtla needs to access a log file, this file +will be copied to the log library." + :type 'boolean + :group 'xtla) + +(defcustom tla-bookmarks-cleanup-dont-prompt nil + "*Whether Xtla should prompt before cleaning a local tree. + +non nil means `tla-bookmarks-cleanup-local-trees' shouldn't prompt +before removing a local-tree" + :type 'boolean + :group 'tla-bookmarks) + +(defcustom tla-send-comments-width 25 + "*Max length for the summary line when using %t in +`tla-send-comments-format'." + :type 'integer + :group 'xtla) + +(defcustom tla-send-comments-format "Your patch %c--%b--%v--%r (%t)" + "Format for the Subject line for `tla-revision-send-comments'. + +The following substring will be substituted: + +%f: Full revision name +%a: The archive name +%c: The category name +%b: The branch name +%v: The version name +%r: The revision name +%s: The summary line +%t: The summary line, truncated to `tla-send-comments-width' +characters." + :type 'string + :group 'xtla) + +(defcustom tla-switch-to-changes-buffer nil + "Switch to the changes buffer or stay in the current buffer." + :type 'boolean + :group 'xtla) + +(defgroup tla-hooks nil + "This group contains hooks into Xtla." + :group 'xtla) + +(defcustom tla-commit-done-hook '() + "*Hooks run after a successful commit via `tla-commit'." + :type 'hook + :group 'tla-hooks) + +(defcustom tla-archive-list-mode-hook '() + "*Hooks run after switching to `tla-archive-list-mode'." + :type 'hook + :group 'tla-hooks) + +(defcustom tla-bookmarks-mode-hook '() + "*Hooks run after switching to `tla-bookmarks-mode'." + :type 'hook + :group 'tla-hooks) + +(defcustom tla-branch-list-mode-hook '() + "*Hooks run after switching to `tla-branch-list-mode'." + :type 'hook + :group 'tla-hooks) + +(defcustom tla-revlog-mode-hook '() + "*Hooks run after switching to `tla-revlog-mode'." + :type 'hook + :group 'tla-hooks) + +(defcustom tla-category-list-mode-hook '() + "*Hooks run after switching to `tla-category-list-mode'." + :type 'hook + :group 'tla-hooks) + +(defcustom tla-inventory-file-mode-hook '() + "*Hooks run after switching to `tla-inventory-file-mode'." + :type 'hook + :group 'tla-hooks) + +(defcustom tla-inventory-mode-hook '() + "*Hooks run after switching to `tla-inventory-mode'." + :type 'hook + :group 'tla-hooks) + +(defcustom tla-log-edit-mode-hook '() + "*Hooks run after switching to `tla-log-edit-mode'." + :type 'hook + :group 'tla-hooks) + +(defcustom tla-logs-mode-hook '() + "*Hooks run after switching to `tla-logs-mode'." + :type 'hook + :group 'tla-hooks) + +(defcustom tla-revision-list-mode-hook '() + "*Hooks run after switching to `tla-revision-list-mode'." + :type 'hook + :group 'tla-hooks) + +(defcustom tla-version-list-mode-hook '() + "*Hooks run after switching to `tla-version-list-mode'." + :type 'hook + :group 'tla-hooks) + +(defcustom tla-make-branch-hook '() + "*Hooks run after making a branch." + :type 'hook + :group 'tla-hooks) + +(defcustom tla-make-category-hook '() + "*Hooks run after making a category." + :type 'hook + :group 'tla-hooks) + +(defcustom tla-make-version-hook '() + "*Hooks run after making a version." + :type 'hook + :group 'tla-hooks) + +(defcustom tla-make-archive-hook '() + "*Hooks run after creating a new archive." + :type 'hook + :group 'tla-hooks) + +(defcustom tla-name-read-init-hook '() + "*Hooks run when the control enters to `tla-name-read'." + :type 'hook + :group 'tla-hooks) + +(defcustom tla-name-read-final-hook '() + "*Hooks run when the control leaves `tla-name-read'. +The name read by `tla-name-read' is passed to functions connected +to this hook as an argument." + :type 'hook + :group 'tla-hooks) + +(defcustom tla-name-read-error-hook '() + "*Hooks run when an error is occurred in `tla-name-read'." + :type 'hook + :group 'tla-hooks) + +(defcustom tla-follow-symlinks 'tree + "*Follow symlinks of this type." + :type '(choice (const :tag "None" nil) + (const :tag "Symlinks into an arch-managed tree" tree) + (const :tag "Symlinks to an arch-managed file" id)) + :group 'dvc-file-actions) + +(defcustom tla-follow-symlinks-mode 'follow + "*Before following a symlink do this." + :type '(choice (const :tag "Ask" ask) + (const :tag "Follow" follow) + (const :tag "Warn" warn)) + :group 'dvc-file-actions) + +(defcustom tla-use-arrow-keys-for-navigation nil + "*Enable left/right for navigation. +This works best if `dvc-switch-to-buffer-mode' is set to 'single-window. + +It enables binding for navigation allowing you to browse by only using the +cursor keys, which is much faster than n/p/return/^. Use up/down to move to +an item, right to select it and left to go to its \"logical\" parent! + +Got the idea? + +See the variable `tla-use-arrow-keys-for-navigation-list' for a list of +bindings that will be installed." + :type '(choice (const :tag "Disabled" nil) + (const :tag "Enabled" t) + (const :tag "Enabled with Shift" shift)) + :group 'tla-bindings) + +(defcustom tla-revisions-shows-library t + "*Display library information in revision lists. + +If non-nil the presence of this revision in the library should be +displayed for `tla-revisions'" + :type 'boolean + :group 'tla-revisions) + +(defcustom tla-revisions-shows-merges nil + "*Display merge information in revision lists. + +If non-nil, the list of merged patches of this revision should be +displayed for `tla-revisions'" + :type 'boolean + :group 'tla-revisions) + +(defcustom tla-revisions-shows-merged-by t + "*Display \"merged-by\" field in revision lists. + +If non-nil the list of patches merged by this revision should be +displayed for `tla-revisions'" + :type 'boolean + :group 'tla-revisions) + +(defcustom tla-log-edit-keywords + '( + ;; I am not sure how to group keywords ... + "bugfix" ; should it be bugfix=BUGNO + "docfix" + "warnfix" + "linting" ; whitespace only change + ;; + "newfeature" + ;; + "merge" + "update" + "rename" + "delete" + "newfile" + ) + "A list of keywords for the Keywords field of a log message." + :type '(repeat (string)) + :group 'xtla) + +(defcustom tla-apply-patch-mapping nil + "*Tree in which patches should be applied. + +An alist of rules to map fully qualified revision names to target +directories. + +This is used by the `tla-gnus-apply-patch' function. +Example setting: '(((nil \"xtla\" nil nil nil) \"~/work/tla/xtla\")))" + :type '(repeat (list :tag "Rule" + (list :tag "Full revision (regexps)" + (choice (const :tag "Any archive" nil) + (regexp :tag "Archive")) + (choice (const :tag "Any category" nil) + (regexp :tag "Category")) + (choice (const :tag "Any branch" nil) + (regexp :tag "Branch")) + (choice (const :tag "Any version" nil) + (regexp :tag "Version")) + (choice (const :tag "Any revision" nil) + (string :tag "Revision"))) + (string :tag "Target directory"))) + :group 'xtla) + +(defcustom tla-submit-patch-mapping + '(((nil "xtla" nil nil nil) ("xtla-el-dev@gna.org" "xtla"))) + "*Email addresses that should be used to send patches + +An alist of rules to map fully qualified revision names to target +email addresses and the base name to use in the attached patch. + +This is used by the `tla-submit-patch' function." + :type '(repeat (list :tag "Rule" + (list :tag "Full revision (regexps)" + (choice (const :tag "Any archive" nil) + (regexp :tag "Archive")) + (choice (const :tag "Any category" nil) + (regexp :tag "Category")) + (choice (const :tag "Any branch" nil) + (regexp :tag "Branch")) + (choice (const :tag "Any version" nil) + (regexp :tag "Version")) + (choice (const :tag "Any revision" nil) + (string :tag "Revision"))) + (list :tag "Target" + (string :tag "Email address") + (string :tag "Base name of tarball")))) + :group 'xtla) + +(defcustom tla-patch-sent-action 'keep-tarball + "*What shall be done, after sending a patch via mail. +The possible values are 'keep-tarball, 'keep-changes, 'keep-both, 'keep-none." + :type '(choice (const keep-tarball) + (const keep-changes) + (const keep-both) + (const keep-none)) + :group 'xtla) + +;;example: +;;(setq tla-mail-notification-destination +;; '(((nil "xtla" nil nil nil) ("[commit][xtla 1.2] " "xtla-el-dev@gna.org")))) +(defcustom tla-mail-notification-destination nil + "*Preset some useful values for commit emails. + +An alist of rules to map fully qualified revision names to target +email addresses and the prefix string for the subject line. + +This is used by the `tla-send-commit-notification' function." + :type '(repeat (list :tag "Rule" + (list :tag "Full revision (regexps)" + (choice (const :tag "Any archive" nil) + (regexp :tag "Archive")) + (choice (const :tag "Any category" nil) + (regexp :tag "Category")) + (choice (const :tag "Any branch" nil) + (regexp :tag "Branch")) + (choice (const :tag "Any version" nil) + (regexp :tag "Version")) + (choice (const :tag "Any revision" nil) + (string :tag "Revision"))) + (list :tag "Target" + (string :tag "Email subject prefix") + (string :tag "Email address")))) + :group 'xtla) + +(defgroup tla-merge nil + "Merging with Xtla." + :group 'xtla) + +(defcustom tla-version-to-name-function nil + "*Function returning a name for a version. + +If non-nil, it must be a function that is called with the version as +an argument, and must return a string that will be used to instead of +the nickname. + +See `tla-merge-summary-line-for-log'." + :type '(choice (const nil) + function) + :group 'tla-merge) + +(defcustom tla-generate-line-function nil + "*Function generating a string summarizing the merge. + +If non-nil, it must be a function that is called with a list like +\((\"Robert\" 167 168 170) (\"Masatake\" 209 213 214 215 217 218)) as +an argument, and must return a string. + +See `tla-merge-summary-line-for-log'." + :type '(choice (const nil) + function) + :group 'tla-merge) + + +(defcustom tla-format-line-function nil + "*Function formatting the summary line. + +If non-nil, it must be a function that is called with a string as an +argument, and returns another string (typically adding a \"Merges \" +comment in front of it. + +See `tla-merge-summary-line-for-log'." + :type '(choice (const nil) + function) + :group 'tla-merge) + +(defcustom tla-description-format + '(patch-id "\n " summary "\n Located at: " location "\n") + "*Format to use to display description of patch-id. + +Must be a list. Each element is either + - A string to be inserted. + - The symbol 'patch-id => print the patch-id as entered in the + prompt. + - The symbol 'summary => if patch-id is actually a patch level, + insert its summary line. + - The symbol 'location => insert the location of the archive." + :type '(repeat (choice symbol string)) + :group 'xtla) + +(defcustom tla-dont-hyperlink-changelog nil + "*If non-nil, don't insert hyperlink in ChangeLog buffer. + +Hyperlink are sometimes long to set up with large ChangeLogs ..." + :type 'boolean + :group 'xtla) + + +;; ---------------------------------------------------------------------------- +;; Face +;; ---------------------------------------------------------------------------- + + +(defface tla-archive-name + '((t (:inherit dvc-repository-name))) + "Face to highlight Xtla archive names." + :group 'tla-faces) + +(defface tla-source-archive-name + '((t (:inherit tla-archive-name))) + "Face to highlight Xtla source archive names." + :group 'tla-faces) + +(defface tla-mirror-archive-name + '((t (:inherit tla-archive-name))) + "Face to highlight Xtla mirror archive names." + :group 'tla-faces) + +(defface tla-category-name + '((t (:inherit tla-archive-name))) + "Face to highlight Xtla category names." + :group 'tla-faces) + +(defface tla-branch-name + '((t (:inherit tla-archive-name))) + "Face to highlight Xtla branch names." + :group 'tla-faces) + +(defface tla-version-name + '((t (:inherit tla-archive-name))) + "Face to highlight Xtla version names." + :group 'tla-faces) + +(defface tla-tagging-method + '((t (:inherit tla-archive-name))) + "Face to highlight tagging methods." + :group 'tla-faces) + +(defface tla-junk + '((t (:inherit font-lock-function-name-face))) + "Face to highlight junk entries" + :group 'dvc-faces) + + +;; ---------------------------------------------------------------------------- +;; Font lock keywords +;; ---------------------------------------------------------------------------- + +;; +;; Inventory file mode +;; +(defvar tla-inventory-file-font-lock-keywords + '( + ("^#.*$" . 'dvc-comment) + ("^[ \t]*\\(backup\\|exclude\\|junk\\|precious\\|unrecognized\\|source\\)\\>[ ]*\\(.*\\)$" + (1 font-lock-keyword-face) + (2 font-lock-string-face)) + ("^[ \t]*\\(untagged-source\\)" + (1 font-lock-builtin-face)) + ("^[ \t]*\\(untagged-source\\) \\(precious\\|source\\|backup\\|junk\\|unrecognized\\)\\>" + (1 font-lock-builtin-face) + (2 font-lock-keyword-face)) + ("^[ \t]*\\(explicit\\|tagline\\|names\\|implicit\\)\\>" + (1 font-lock-builtin-face)) + ) + "Keywords in tla-inventory-file mode.") + +;; +;; Logs mode +;; +(defvar tla-logs-font-lock-keywords + '(("^[^ \t]*\\(base\\|patch\\|version\\(fix\\)?\\)-[0-9]+" . + font-lock-function-name-face)) + "Keywords in tla-logs-mode.") + +;; +;; Revlog mode +;; +(defvar tla-revlog-font-lock-keywords + '(("^\\(Revision\\|Archive\\|Creator\\|Date\\|Standard-date\\|Modified-files\\|New-patches\\|Summary\\|Keywords\\|New-files\\|New-directories\\|Removed-files\\|Removed-directories\\|Renamed-files\\|Renamed-directories\\|Modified-directories\\|Removed-patches\\):" . font-lock-function-name-face)) + "Keywords in `tla-revlog-mode'.") + +;; +;; Log edit mode +;; +(defvar tla-log-edit-font-lock-keywords + `(("^Summary: " . 'dvc-header) + ("^Keywords: " . 'dvc-header) + ("^\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 tla-log-edit mode.") + +;; +;; Changes mode +;; +(defvar tla-changes-font-lock-keywords + (append + '(("^\\* looking for .* to compare with$" . font-lock-function-name-face) + ("^\\* comparing to .*$" . font-lock-function-name-face) + ("^\\* dir metadata changed$" . font-lock-function-name-face) + ("^\\* file metadata changed$" . font-lock-function-name-face) + ("^\\* modified files" . font-lock-function-name-face) + ("^\\* added files" . font-lock-function-name-face) + ("^\\* removed files" . font-lock-function-name-face) + ("^ +-?-/ .*$" . 'dvc-meta-info) + ("^ +-- .*$" . 'dvc-meta-info) + ("^ *T. .*$" . 'dvc-nested-tree)) + diff-font-lock-keywords) + "Keywords in `tla-changes' mode.") + +;; +;; ChangeLog mode +;; +(defvar tla-changelog-font-lock-keywords + (append + '((" \\([^ ].+:\\)$" (1 'dvc-keyword)) + ("\t\\(patch-[0-9]+\\)" (1 'dvc-keyword)) + ("\t\\(base-0\\)" (1 'dvc-keyword)) + ("^#.*$" . 'dvc-comment)) + change-log-font-lock-keywords) + "Keywords in `tla-changelog' mode.") + + +;; ---------------------------------------------------------------------------- +;; Auto-mode-alist entries +;; ---------------------------------------------------------------------------- +;;;###autoload +(add-to-list 'auto-mode-alist + '("/\\(=tagging-method\\|\\.arch-inventory\\)$" . + tla-inventory-file-mode)) + +;; ---------------------------------------------------------------------------- +;; Hooks into other packages and/or functions +;; ---------------------------------------------------------------------------- + +;; +;; ediff +;; +(defvar tla-ediff-keymap (copy-keymap dvc-global-keymap) + "Global keymap used by Xtla in the ediff control buffer.") + +(define-key tla-ediff-keymap dvc-keyvec-log-entry 'tla-ediff-add-log-entry) + +(add-hook 'ediff-keymap-setup-hook + #'(lambda () + (define-key ediff-mode-map dvc-prefix-key tla-ediff-keymap))) + +;; +;; find-file +;; +(autoload 'tla-find-file-hook "tla") +(add-hook 'find-file-hooks 'tla-find-file-hook) + +;; ---------------------------------------------------------------------------- +;; Enables arrow key navigation for left/right +;; ---------------------------------------------------------------------------- +(defvar tla-use-arrow-keys-for-navigation-list + '((tla-inventory-mode-map right 'tla-inventory-find-file) + (tla-inventory-mode-map left 'tla-inventory-parent-directory) + (tla-archive-list-mode-map right 'tla-archive-list-categories) + (tla-archive-list-mode-map left 'dvc-buffer-quit) + (tla-category-list-mode-map right 'tla-category-list-branches) + (tla-category-list-mode-map left 'tla-archives) + (tla-branch-list-mode-map right 'tla-branch-list-versions) + (tla-branch-list-mode-map left 'tla-branch-list-parent-category) + (tla-version-list-mode-map right 'tla-version-list-revisions) + (tla-version-list-mode-map left 'tla-version-list-parent-branch) + (tla-revision-list-mode-map left 'tla-revision-list-parent-version) + (tla-revision-list-mode-map right 'dvc-revlist-show-item) + (dvc-diff-mode-map left 'dvc-diff-jump-to-change) + (dvc-diff-mode-map right 'dvc-diff-view-source) + (tla-changelog-mode-map left 'dvc-buffer-quit) + (dvc-process-buffer-mode-map left 'dvc-buffer-quit) + (tla-bookmarks-mode-map right 'tla-bookmarks-inventory) + )) + +(defun tla-use-arrow-keys-for-navigation (&optional uninstall) + "Bind the left/right keys for navigation. + +This function will be called automatically if variable +`tla-use-arrow-keys-for-navigation' is non-nil. + +If argument UNINSTALL is non-nil, undefine the keys instead of +defining it." + (interactive "P") + ;; eval-after-load would be better. + (unless (boundp 'dvc-diff-mode-map) + (load-library "dvc-diff")) + (let ((bl tla-use-arrow-keys-for-navigation-list) b + (m tla-use-arrow-keys-for-navigation)) + (while bl + (setq b (car bl) + bl (cdr bl)) + (eval + (append (list 'define-key + (car b)) + (cond ((eq nil m) + (list (vector (cadr b)) nil)) + ((eq 'shift m) + (if uninstall + (list (vector (list 'shift (cadr b))) nil) + (list (vector (list 'shift (cadr b))) (car (cddr b))))) + ((eq t m) + (if uninstall + (list (vector (cadr b)) nil) + (list (vector (cadr b)) (car (cddr b))))))))) + (if uninstall + (message "%sleft/right bindings for Xtla have been removed." + (if (eq 'shift m) "Shifted " "")) + (message "%sleft/right bindings for Xtla have been installed." + (if (eq 'shift m) "Shifted " ""))))) + +;; install them if customized +(if tla-use-arrow-keys-for-navigation + (tla-use-arrow-keys-for-navigation)) + +(provide 'tla-defs) + +;;; tla-defs.el ends here diff --git a/dvc/lisp/tla-dvc.el b/dvc/lisp/tla-dvc.el new file mode 100644 index 0000000..95e9499 --- /dev/null +++ b/dvc/lisp/tla-dvc.el @@ -0,0 +1,141 @@ +;;; tla-dvc.el --- The dvc layer for xtla + +;; Copyright (C) 2005-2008 by all contributors + +;; Author: Stefan Reichoer, +;; Contributors: Matthieu Moy, + +;; 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 diff --git a/dvc/lisp/tla-gnus.el b/dvc/lisp/tla-gnus.el new file mode 100644 index 0000000..535c5e0 --- /dev/null +++ b/dvc/lisp/tla-gnus.el @@ -0,0 +1,168 @@ +;;; tla-gnus.el --- dvc integration to gnus + +;; Copyright (C) 2003-2006 by all contributors + +;; Author: Stefan Reichoer, + +;; 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 diff --git a/dvc/lisp/tla-tests.el b/dvc/lisp/tla-tests.el new file mode 100644 index 0000000..f11f816 --- /dev/null +++ b/dvc/lisp/tla-tests.el @@ -0,0 +1,537 @@ +;;; tla-tests.el --- unit tests for tla.el + +;; Copyright (C) 2004 Free Software Foundation, Inc. + +;; Author: Matthieu Moy +;; Modified by: Mark Triggs + +;; 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\\ \\" + "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 ")) + (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)) + (previous-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 ")) + (tla-my-id t)) + (unless (string= (tla-my-id) + "John Smith ") + (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 diff --git a/dvc/lisp/tla.el b/dvc/lisp/tla.el new file mode 100644 index 0000000..ebff058 --- /dev/null +++ b/dvc/lisp/tla.el @@ -0,0 +1,9790 @@ +;;; tla.el --- Arch interface for emacs + +;; Copyright (C) 2003-2008 by all contributors + +;; Author: Stefan Reichoer, +;; Contributions from: +;; Matthieu Moy +;; Masatake YAMATO +;; Milan Zamazal +;; Martin Pool +;; Robert Widhopf-Fenk +;; Mark Triggs + +;; 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: + +;; Some documentation can be found on the wiki here +;; http://wiki.gnuarch.org/xtla +;; The manual is available online +;; http://download.gna.org/xtla-el/docs/xtla-snapshot.html +;; and in the texinfo directory of the Xtla distribution. + +;; There is a project page at +;; https://gna.org/projects/xtla-el +;; You can subscribe to the mailing list via +;; https://mail.gna.org/listinfo/xtla-el-dev + +;; Usage: put the following in your .emacs: (require 'xtla-autoloads) + +;; The main commands are available with the prefix key C-x V. +;; Type C-x V C-h for a list. + +;; M-x tla-inventory shows a tla inventory +;; In this inventory buffer the following commands are available: +;; e ... tla-edit-log +;; = ... tla-changes +;; l ... tla-changelog +;; L ... tla-logs + +;; To Edit a logfile issue: M-x tla-edit-log +;; In this mode you can hit C-c C-d to show the changes +;; Edit the log file +;; After that you issue M-x tla-commit (bound to C-c C-c) to commit the files + +;; M-x tla-archives starts the interactive archive browser + +;; M-x tla-make-archive creates a new archive directory +;; Many commands are available from here. Look at the menus, they're +;; very helpful to begin. + +;; M-x tla-bookmarks RET +;; Is another good starting point. This is the place where you put the +;; project you work on most often, and you can get a new version, see +;; the missing patches, and a few other useful features from here. +;; Use `a' to add a bookmark. Add your own projects, and your +;; contributor's projects too. Select several related projects with +;; `m' (unselect with M-u or M-del). Make them partners with 'M-p'. +;; Now, with your cursor on a bookmark, view the uncommitted changes, +;; the missing patches from your archive and your contributors with +;; 'M'. + +;; M-x tla-file-ediff RET +;; Is an wrapper to tla file-diff, ediff to view the changes +;; interactively. + +;; Misc commands: +;; tla-tag-insert inserts a arch-tag entry generated with uuidgen + +;; If you find xtla.el useful, and you have some ideas to improve it +;; please share them with us (Patches are preferred :-)) + +;;; Todo: +;; See docs/Todo + + +;;; History: +;; +;; Beginning of 2004: Initial version by Stefan Reichoer +;; +;; + +;;; Code: + +(eval-and-compile + (if (featurep 'xemacs) + (require 'dvc-xemacs) + (require 'dvc-emacs)) + (require 'dvc-lisp) + (require 'dvc-revlist) + + (when (locate-library "dvc-version") + (require 'dvc-version))) + +;; runtime use of 'cl package is discouraged. Please keep this +;; "eval-when-compile" +;; ^^^^ +(eval-when-compile (require 'cl)) +(eval-and-compile (require 'dvc-about)) +(eval-and-compile (require 'dvc-utils)) +(eval-and-compile (require 'dvc-cmenu)) +(eval-and-compile (require 'dvc-core)) + +(eval-and-compile (require 'tla-gnus)) + +(autoload 'dired-get-filename "dired") + +(eval-and-compile + (require 'ediff) + (require 'font-lock) + ;; on some systems, sendmail is not available. + (when (locate-library "sendmail") + (require 'sendmail))) + +(require 'pp) +(require 'ewoc) +(require 'diff) +(require 'time-date) +(require 'dvc-diff) +(require 'dvc-state) + +(eval-and-compile + (require 'tla-defs) + (require 'tla-core) + (require 'tla-autoconf) + (when (locate-library "smerge-mode") + (require 'smerge-mode))) + +(eval-when-compile + (if (locate-library "hl-line") + (require 'hl-line) + (if (locate-library "highline") + (require 'highline)))) + +;; ---------------------------------------------------------------------------- +;; Internal variables +;; ---------------------------------------------------------------------------- +(defvar tla-edit-arch-command nil) +(defvar tla-pre-commit-window-configuration nil) +(defvar tla-pre-tree-lint-window-configuration nil) +(defvar tla-log-edit-file-name nil) +(defvar tla-log-edit-file-buffer nil) +(defvar tla-my-id-history nil) +(defvar tla-last-commit-message nil) + +(defvar tla-buffer-archive-name nil) +(defvar tla-buffer-category-name nil) +(defvar tla-buffer-branch-name nil) +(defvar tla-buffer-version-name nil) + +(defvar tla-mode-line-process "") +(defvar tla-mode-line-process-status "") + +;; Overlay category +(put 'tla-default-button 'mouse-face 'highlight) +(put 'tla-default-button 'evaporate t) +;;(put 'tla-default-button 'rear-nonsticky t) +;;(put 'tla-default-button 'front-nonsticky t) + +;; ---------------------------------------------------------------------------- +;; Macros +;; ---------------------------------------------------------------------------- +(defmacro tla-toggle-list-entry (list entry) + "Either add or remove from the value of LIST the value ENTRY." + `(if (member ,entry ,list) + (setq ,list (delete ,entry ,list)) + (add-to-list ',list ,entry))) + +;; ---------------------------------------------------------------------------- +;; Common used functions for many xtla modes +;; ---------------------------------------------------------------------------- +(defun tla-edit-=tagging-method-file () + "Edit the {arch}/=tagging-method file." + (interactive) + (find-file (expand-file-name "{arch}/=tagging-method" (tla-tree-root)))) + +(defun tla-edit-.arch-inventory-file (&optional dir) + "Edit DIR/.arch-inventory file. +`default-directory' is used as DIR if DIR is nil. +If it is called interactively and the prefix argument is given via DIR, +use the directory of a file associated with the point to find .arch-inventory. +In the case no file is associated with the point, it reads the directory name +with `dvc-read-directory-name'." + (interactive + (list (if (not (interactive-p)) + default-directory + (let ((file (dvc-get-file-info-at-point))) + (if file + (if (not (file-name-absolute-p file)) + (concat default-directory + (file-name-directory file)) + (file-name-directory file)) + (expand-file-name (dvc-read-directory-name + "Directory containing \".arch-inventory\": "))))))) + (let* ((dir (or dir default-directory)) + (file (expand-file-name ".arch-inventory" dir)) + (newp (not (file-exists-p file)))) + (find-file file) + (save-excursion + (when (and newp (y-or-n-p + (format "Insert arch tag to \"%s\"? " file))) + (tla-tag-insert))))) + +(defun tla--insert-right-justified (string count &optional face) + "Insert a string with a right-justification. + +Inserts STRING preceded by spaces so that the line ends exactly at +COUNT characters (or after if STRING is too long). +If FACE is non-nil, insert the string fontified with FACE." + (insert-char ?\ (max 0 (- count (length string)))) + (insert (if face (dvc-face-add string face) string)) + ) + +;; ---------------------------------------------------------------------------- +;; Name read engine helpers +;; ---------------------------------------------------------------------------- +;; +;; Extended version of tla--read-name +;; +(defun tla-name-read-reinit-minibuf-map () + "Redefine `tla--name-read-minibuf-map'. + +Compute the new value based on the current +`minibuffer-local-completion-map'. This is usefull if you want to add +bindings to your `minibuffer-local-completion-map' globally after +loading Xtla." + (setq tla--name-read-minibuf-map (tla-name-read-minibuf-map-fn))) + +(defun tla-name-read-help () + "Displays a help message with keybindings for the minibuffer prompt." + (interactive) + (set-buffer (get-buffer-create "*Help*")) + (let ((inhibit-read-only t)) + (erase-buffer) + (kill-all-local-variables) + (help-mode) + (view-mode -1) + (insert "This buffer describes the name reading engine for xtla + +You are prompted for a fully qualified archive, category, branch, +version, or revision, which means a string like +\"John.Smith@rt.fm--arch/xtla--revolutionary--1.0\". Completion is +available with TAB. Only the item being entered is proposed for +completion, which means that if you're typing the archive name, +pressing TAB will give you the list of archives. If you started to +type the category name, you'll get the list of category for this +archive. + +Here's a list of other interesting bindings available in the +minibuffer: + +") + (let ((interesting (mapcar (lambda (pair) (cdr pair)) + tla--name-read-extension-keydefs))) + (dolist (func interesting) + (let* ((keys (where-is-internal func tla--name-read-minibuf-map)) + (keys1 "")) + (while keys + (when (not (eq 'menu-bar (aref (car keys) 0))) + (setq keys1 (if (string= keys1 "") (key-description (car keys)) + (concat keys1 ", " + (key-description (car keys)))))) + (setq keys (cdr keys))) + (insert (format "%s%s\t`%s'\n" keys1 + (make-string (max 0 (- 5 (length keys1))) ?\ ) + (symbol-name func)))))) + (goto-char (point-min)) + (dvc-funcall-if-exists + help-setup-xref (list 'tla-name-read-help) + (interactive-p))) + (display-buffer (current-buffer)) + (toggle-read-only 1)) + +(defun tla-name-read-inline-help () + "Displays a help message in echo area." + (interactive) + (let ((interesting (mapcar (lambda (pair) (cdr pair)) + tla--name-read-extension-keydefs)) + (line "")) + (dolist (func interesting) + (let* ((keys (where-is-internal func tla--name-read-minibuf-map)) + (keys1 "") + (func (symbol-name func))) + (while keys + (when (not (eq 'menu-bar (aref (car keys) 0))) + (setq keys1 (if (string= keys1 "") (key-description (car keys)) + (concat keys1 ", " + (key-description (car keys)))))) + (setq keys (cdr keys))) + (setq func (progn (string-match "tla-name-read-\\(.+\\)" + func) + (match-string 1 func))) + (setq line (concat line (format "%s => `%s'" keys1 func) " ")))) + (dvc-about-message-with-rolling line) + )) + + + + +(defun tla--read-revision-with-default-tree (&optional prompt tree) + "Read revision name with `tla-name-read'. +PROMPT is passed to `tla-name-read' without changing. +Default version associated with TREE, a directory is used as default arguments +for`tla-name-read'." + (setq tree (tla-tree-root (or tree default-directory) t)) + (let ((tree-rev (tla-tree-version-list tree))) + (tla-name-read prompt + (if tree-rev (tla--name-archive tree-rev) 'prompt) + (if tree-rev (tla--name-category tree-rev) 'prompt) + (if tree-rev (tla--name-branch tree-rev) 'prompt) + (if tree-rev (tla--name-version tree-rev) 'prompt) + 'prompt))) + +;; +;; Version for the tree of default directory +;; +(defvar tla--name-read-insert-version-associated-with-default-directory nil) +(defun tla-name-read-insert-version-associated-with-default-directory (&optional force) + "Insert the version for the tree of the directory specified by . + +If FORCE is non-nil, insert the version even if the minibuffer isn't empty." + (interactive "P") + (let ((version-for-tree + (tla--name-mask + (tla-tree-version-list + (if tla--name-read-insert-version-associated-with-default-directory + tla--name-read-insert-version-associated-with-default-directory + default-directory)) + t + (tla--name-read-arguments 'archive) + (tla--name-read-arguments 'category) + (tla--name-read-arguments 'branch) + (tla--name-read-arguments 'version)))) + (if (and (window-minibuffer-p (selected-window)) + (or force (equal "" (minibuffer-contents)))) + (insert version-for-tree)))) + +;; +;; Default archive +;; +(defun tla-name-read-insert-default-archive (&optional force) + "Insert default archive name into the minibuffer if it is empty. + +If FORCE is non-nil, insert the archive name even if the minibuffer +isn't empty." + (interactive "P") + (if (and (window-minibuffer-p (selected-window)) + (or (equal "" (minibuffer-contents)) force) + (member + (tla--name-read-arguments 'archive) + '(prompt maybe))) + (insert (tla-my-default-archive)))) + +;; +;; Info at point +;; +(defvar tla-name-read-insert-info-at-point nil) +(defvar tla--name-read-insert-info-at-point-overlay nil) +(defun tla-name-read-insert-info-at-point (&optional force) + "Insert the info(maybe revision) under the point to the minibuffer. + +If FORCE is non-nil, insert the version even if the minibuffer isn't +empty." + (interactive "P") + (let ((info-at-point + (or tla-name-read-insert-info-at-point + (tla-name-read-insert-version-associated-with-default-directory)))) + (when (and (window-minibuffer-p (selected-window)) + (or (equal "" (minibuffer-contents)) force) + info-at-point) + (insert info-at-point)))) + +(defun tla--name-read-insert-info-at-point-init () + "This function retrieves the info at point. + +Further call to `tla--name-read-insert-info-at-point-final' will +actuall insert the value computed here." + (setq tla-name-read-insert-info-at-point + (let ((raw-info (tla--revision-get-revision-at-point)) + (b (dvc-cmenu-beginning (point))) + (e (dvc-cmenu-end (point)))) + (when raw-info + (when (and b e) + (setq tla--name-read-insert-info-at-point-overlay + (make-overlay (1- b) e)) + (overlay-put tla--name-read-insert-info-at-point-overlay + 'face 'dvc-highlight)) + (tla--name-mask + (tla--name-split raw-info) t + (tla--name-read-arguments 'archive) + (tla--name-read-arguments 'category) + (tla--name-read-arguments 'branch) + (tla--name-read-arguments 'version) + (tla--name-read-arguments 'revision)))))) + +(defun tla--name-read-insert-info-at-point-final (&optional no-use) + "Called when exitting the minibuffer prompt. + +Cancels the effect of `tla--name-read-insert-info-at-point-init'. + +Argument NO-USE is ignored." + (when tla--name-read-insert-info-at-point-overlay + (delete-overlay tla--name-read-insert-info-at-point-overlay) + (setq tla--name-read-insert-info-at-point-overlay nil))) + +;; +;; Partner file +;; +(defvar tla--name-read-insert-partner-ring-position nil) +(defun tla--name-read-insert-partner-init () + "Initialize \"Insert Partner Version\" menu used in `tla-name-read'." + (setq tla--name-read-insert-partner-ring-position nil) + ;; Create menu items + (setq xtla--name-read-partner-menu (cons "Insert Partner Version" nil)) + (let ((partners (reverse (tla-partner-list)))) + (mapc (lambda (p) + (setq p (tla--name-mask + (tla--name-split p) t + (tla--name-read-arguments 'archive) + (tla--name-read-arguments 'category) + (tla--name-read-arguments 'branch) + (tla--name-read-arguments 'version) + (tla--name-read-arguments 'revision))) + (setcdr xtla--name-read-partner-menu + (cons (cons p + (cons p + (lexical-let ((this-p p)) + (lambda () (interactive) + (delete-region + (minibuffer-prompt-end) (point-max)) + (insert this-p))))) + (cdr xtla--name-read-partner-menu)))) + partners)) + (fset 'xtla--name-read-partner-menu (cons 'keymap xtla--name-read-partner-menu))) + +(defun tla-name-read-insert-partner-previous () + "Insert the previous partner version into miniffer." + (interactive) + (let* ((partners (tla-partner-list)) + (plen (length partners)) + (pos (if tla--name-read-insert-partner-ring-position + (if (eq tla--name-read-insert-partner-ring-position 0) + (1- plen) + (1- tla--name-read-insert-partner-ring-position)) + 0)) + (pversion (when partners (tla--name-mask + (tla--name-split (nth pos partners)) t + (tla--name-read-arguments 'archive) + (tla--name-read-arguments 'category) + (tla--name-read-arguments 'branch) + (tla--name-read-arguments 'version) + (tla--name-read-arguments 'revision))))) + (when (and (window-minibuffer-p (selected-window)) + partners + pversion) + (delete-region (minibuffer-prompt-end) (point-max)) + (insert pversion) + (setq tla--name-read-insert-partner-ring-position pos)))) + +(defun tla-name-read-insert-partner-next () + "Insert the next partner version into the miniffer." + (interactive) + (let* ((partners (tla-partner-list)) + (plen (length partners)) + (pos (if tla--name-read-insert-partner-ring-position + (if (eq tla--name-read-insert-partner-ring-position (1- plen)) + 0 + (1+ tla--name-read-insert-partner-ring-position)) + 0)) + (pversion (when partners (tla--name-mask + (tla--name-split (nth pos partners)) t + (tla--name-read-arguments 'archive) + (tla--name-read-arguments 'category) + (tla--name-read-arguments 'branch) + (tla--name-read-arguments 'version) + (tla--name-read-arguments 'revision))))) + (when (and (window-minibuffer-p (selected-window)) + partners + pversion) + (delete-region (minibuffer-prompt-end) (point-max)) + (insert pversion) + (setq tla--name-read-insert-partner-ring-position pos)))) + +;; +;; Ancestor +;; +(defun tla-name-read-insert-ancestor (&optional force) + "Insert the ancestor name into the minibuffer if it is empty. + +If FORCE is non-nil, insert the ancestor even if the minibuffer isn't +empty." + (interactive "P") + (let* ((version (tla-tree-version-list default-directory)) + (ancestor (when (and version + (not (eq this-command 'tla-revision-direct-ancestor))) + (tla-revision-direct-ancestor + (tla--name-mask version nil + t t t t "base-0"))))) + (when (and ancestor + (window-minibuffer-p (selected-window)) + (or (equal "" (minibuffer-contents)) force) + (member + (tla--name-read-arguments 'archive) + '(prompt maybe))) + (insert (tla--name-mask + ancestor t + t + (member + (tla--name-read-arguments 'category) + '(prompt maybe)) + (member + (tla--name-read-arguments 'branch) + '(prompt maybe)) + (member + (tla--name-read-arguments 'version) + '(prompt maybe)) + (member + (tla--name-read-arguments 'revision) + '(prompt maybe))))))) + +;; +;; Partners in Bookmark +;; +(defvar tla--name-read-insert-bookmark-ring-position nil) +(defun tla--name-read-insert-bookmark-init () + "Initialize \"Insert Version in Bookmark\" menu used in `tla-name-read'." + (setq tla--name-read-insert-bookmark-ring-position nil) + ;; Create menu items + (setq xtla--name-read-bookmark-menu (cons "Insert Version in Bookmark" nil)) + (let* ((default-version (tla-tree-version-list default-directory 'no-error)) + (bookmarks (when default-version + (nreverse (tla-bookmarks-get-partner-versions default-version))))) + (mapc (lambda (p) + (setq p (tla--name-mask + p t + (tla--name-read-arguments 'archive) + (tla--name-read-arguments 'category) + (tla--name-read-arguments 'branch) + (tla--name-read-arguments 'version) + (tla--name-read-arguments 'revision))) + (setcdr xtla--name-read-bookmark-menu + (cons (cons p + (cons p + (lexical-let ((lex-p p)) + (lambda () (interactive) + (delete-region + (minibuffer-prompt-end) (point-max)) + (insert p))))) + (cdr xtla--name-read-bookmark-menu)))) + bookmarks)) + (fset 'xtla--name-read-bookmark-menu (cons 'keymap xtla--name-read-bookmark-menu))) + +(defun tla-name-read-insert-bookmark-previous () + "Insert the previous partner version in the bookmark into miniffer." + (interactive) + (let* ((default-version (tla-tree-version-list default-directory)) + (bookmarks (when default-version + (nreverse (tla-bookmarks-get-partner-versions default-version)))) + (plen (length bookmarks)) + (pos (if tla--name-read-insert-bookmark-ring-position + (if (eq tla--name-read-insert-bookmark-ring-position 0) + (1- plen) + (1- tla--name-read-insert-bookmark-ring-position)) + 0)) + (pversion (when bookmarks (tla--name-mask + (nth pos bookmarks) t + (tla--name-read-arguments 'archive) + (tla--name-read-arguments 'category) + (tla--name-read-arguments 'branch) + (tla--name-read-arguments 'version) + (tla--name-read-arguments 'revision))))) + (when (and (window-minibuffer-p (selected-window)) + bookmarks + pversion) + (delete-region (minibuffer-prompt-end) (point-max)) + (insert pversion) + (setq tla--name-read-insert-bookmark-ring-position pos)))) + +(defun tla-name-read-insert-bookmark-next () + "Insert the next partner version in the bookmark into the miniffer." + (interactive) + (let* ((default-version (tla-tree-version-list default-directory)) + (bookmarks (when default-version + (nreverse (tla-bookmarks-get-partner-versions default-version)))) + (plen (length bookmarks)) + (pos (if tla--name-read-insert-bookmark-ring-position + (if (eq tla--name-read-insert-bookmark-ring-position (1- plen)) + 0 + (1+ tla--name-read-insert-bookmark-ring-position)) + 0)) + (pversion (when bookmarks (tla--name-mask + (nth pos bookmarks) t + (tla--name-read-arguments 'archive) + (tla--name-read-arguments 'category) + (tla--name-read-arguments 'branch) + (tla--name-read-arguments 'version) + (tla--name-read-arguments 'revision))))) + (when (and (window-minibuffer-p (selected-window)) + bookmarks + pversion) + (delete-region (minibuffer-prompt-end) (point-max)) + (insert pversion) + (setq tla--name-read-insert-bookmark-ring-position pos)))) + +(add-hook 'tla-name-read-init-hook + 'tla--name-read-insert-info-at-point-init) +(add-hook 'tla-name-read-final-hook + 'tla--name-read-insert-info-at-point-final) +(add-hook 'tla-name-read-error-hook + 'tla--name-read-insert-info-at-point-final) +(add-hook 'tla-name-read-init-hook + 'tla--name-read-insert-partner-init) +(add-hook 'tla-name-read-init-hook + 'tla--name-read-insert-bookmark-init) + +(defun tla-file-name-relative-to-root (file) + (let* ((file (dvc-uniquify-file-name file)) + (tree-root (tla-tree-root file))) + (replace-regexp-in-string + ;; note: tree-root always ends with a slash, so the effect of "*" + ;; is to match one or more trailing slashes + (concat "^" (regexp-quote tree-root) "*") + "" + file))) + +(defun tla--read-directory-maybe (&optional prompt directory) + "Read a directory name inside an arch managed tree. + +Return a directory name which is a subdirectory or the root of some +project tree. Works in a way similar to +`dvc-read-project-tree-maybe', but is customized with the variable +`dvc-read-directory-mode'. + +PROMPT is the user prompt, and DIRECTORY is the default directory." + (let ((root (tla-tree-root (or directory default-directory) t)) + (default-directory (or directory default-directory)) + (prompt (or prompt "Use directory: "))) + (case dvc-read-directory-mode + (always (dvc-read-directory-name prompt)) + (sometimes (if root (or directory default-directory) + (dvc-read-directory-name prompt))) + (never (if root (or directory default-directory) + (error "Not in a project tree"))) + (t (error "Wrong value for dvc-read-directory-mode"))))) + +(defun tla-close-project (&optional tree) + "Close all buffers whose directory is in the same project as TREE." + (interactive) + (let ((tree (dvc-uniquify-file-name (tla-tree-root tree)))) + (dolist (buffer (buffer-list)) + (with-current-buffer buffer + (let ((current-proj (dvc-uniquify-file-name + (tla-tree-root default-directory t)))) + (when (string= tree current-proj) + ;; Keep the buffer if the file doesn't exist + (kill-buffer buffer))))))) + +;; ---------------------------------------------------------------------------- +;; tla help system for commands that get input from the user via the minibuffer +;; ---------------------------------------------------------------------------- + +;; GENERIC: This functionality should be in emacs itself. >> Masatake +;; to check: we should use some other binding for this, perhaps f1 C-m +(defun tla--display-command-help (command) + "Help system for commands that get input via the minibuffer. + +This is an internal function called by `tla-show-command-help'. + +COMMAND is the last command executed." + (with-electric-help + (lambda () + (let ((cmd-help (when (fboundp command) + (documentation command)))) + (delete-region (point-min) (point-max)) + (insert (if cmd-help + (format "Help for %S:\n%s" command cmd-help) + (format "No help available for %S" command))))) + (concat " *" (tla-arch-branch-name) "-command-help*"))) + +(defvar tla-command-stack nil) + +(defun tla-minibuffer-setup () + "Function called in `minibuffer-setup-hook'. + +Memorize last command run." + (push this-command tla-command-stack)) + +(defun tla-minibuffer-exit () + "Function called in `minibuffer-exit-hook'. + +Cancels the effect of `tla-minibuffer-setup'." + (pop tla-command-stack)) + +(defun tla-show-command-help () + "Help system for commands that get input via the minibuffer. + +When the user is asked for input in the minibuffer, a help for the +command will be shown, if the user hits \\\\[tla-show-command-help]. +This functionality is not only for xtla commands available it is +available for all Emacs commands." + (interactive) + (tla--display-command-help (car tla-command-stack))) + +(when tla-install-command-help-system + (define-key minibuffer-local-map [f1] + 'tla-show-command-help) + (define-key minibuffer-local-completion-map [f1] + 'tla-show-command-help) + (define-key minibuffer-local-must-match-map [f1] + 'tla-show-command-help) + (define-key minibuffer-local-map [(control meta ?h)] + 'tla-show-command-help) + (define-key minibuffer-local-completion-map [(control meta ?h)] + 'tla-show-command-help) + (define-key minibuffer-local-must-match-map [(control meta ?h)] + 'tla-show-command-help) + (add-hook 'minibuffer-setup-hook 'tla-minibuffer-setup) + (add-hook 'minibuffer-exit-hook 'tla-minibuffer-exit)) + +;; ---------------------------------------------------------------------------- +;; Top level tla commands +;; ---------------------------------------------------------------------------- +(defcustom tla-make-log-function 'tla-default-make-log-function + "*Function used to create the log buffer. + +Must return a string which is the absolute name of the log file. This +function is called only when the log file doesn't exist already. The +default is `tla-default-make-log-function', which just calls \"tla +make-log\". If you want to override this function, you may just write +a wrapper around `tla-default-make-log-function'." + :type 'function + :group 'xtla) + +(defun tla-make-log (&optional nocreate) + "Create the log file and return its filename. + +If the file exists, its name is returned. Otherwise, the log file is +created by the function specified by `tla-make-log-function', which, +by default, calls \"tla make-log\"." + (interactive) + (let* ((version (tla-tree-version-list)) + (file (concat (tla-tree-root) "++log." + (tla--name-category version) "--" + (tla--name-branch version) "--" + (tla--name-version version) "--" + (tla--name-archive version)))) + (cond ((file-exists-p file) + file) + (nocreate nil) + (t (funcall tla-make-log-function))))) + +(defun tla-default-make-log-function () + "Candidate (and default value) for `tla-make-log-function'. +Calls \"tla make-log\" to generate the log file." + (tla--run-tla-sync '("make-log") + :finished + (lambda (output error status arguments) + (dvc-buffer-content output)))) + +(defun dvc-pop-to-inventory () + "Call `tla-inventory' with a prefix arg." + (interactive) + (tla-inventory nil t)) + +(defvar tla-inventory-cookie nil) +(defvar tla-inventory-list nil + "Full list for the inventory.") + +(defun tla-inventory-goto-file (file) + "Put cursor on FILE. nil return means the file hasn't been found." + (goto-char (point-min)) + (let ((current (ewoc-locate tla-inventory-cookie))) + (while (and current (not (string= (car (cddr (ewoc-data current))) + file))) + (setq current (ewoc-next tla-inventory-cookie current))) + (when current (tla-inventory-cursor-goto current)) + current)) + + +(defun tla-inventory-make-toggle-fn-and-var (variable function) + "Define the VARIABLE and the toggle FUNCTION for type TYPE." + (make-variable-buffer-local variable) + (eval `(defun ,function () + (interactive) + (setq ,variable (not ,variable)) + (tla-inventory-redisplay)))) + +(dolist (type-arg tla-inventory-file-types-manipulators) + (tla-inventory-make-toggle-fn-and-var (cadr type-arg) (car (cddr type-arg)))) + +(defun tla-inventory-redisplay () + "Refresh inventory buffer." + (let* ((elem (ewoc-locate tla-inventory-cookie)) + (file (when elem (car (cddr (ewoc-data elem))))) + (pos (point))) + (tla-inventory-display) + (or (and file + (tla-inventory-goto-file file)) + (goto-char pos)) + (tla-inventory-cursor-goto (ewoc-locate tla-inventory-cookie)))) + + +(defun tla-inventory-set-toggle-variables (new-value) + "Set all tla-inventory-display-* variables. +If NEW-VALUE is 'toggle set the values to (not tla-inventory-display-* +Otherwise set it to NEW-VALUE." + (dolist (type-arg tla-inventory-file-types-manipulators) + (eval `(setq ,(cadr type-arg) + (if (eq new-value 'toggle) + (not ,(cadr type-arg)) + new-value))))) + +(defun tla-inventory-set-all-toggle-variables () + "Set all inventory toggle variables to t." + (interactive) + (tla-inventory-set-toggle-variables t) + (tla-inventory-redisplay)) + +(defun tla-inventory-reset-all-toggle-variables () + "Set all inventory toggle variables to nil." + (interactive) + (tla-inventory-set-toggle-variables nil) + (tla-inventory-redisplay)) + +(defun tla-inventory-toggle-all-toggle-variables () + "Toggle the value of all inventory toggle variables." + (interactive) + (tla-inventory-set-toggle-variables 'toggle) + (tla-inventory-redisplay)) + +(defun tla-inventory-goto (&optional directory arg) + "Goto inventory buffer, or run `tla-inventory'." + (interactive (list (tla--read-directory-maybe + "Run inventory in (directory): ") + current-prefix-arg)) + (let* ((default-directory (or directory default-directory)) + (buffer (dvc-get-buffer tla-arch-branch 'inventory default-directory))) + (if buffer + (if arg + (pop-to-buffer buffer) + (switch-to-buffer buffer)) + (tla-inventory directory arg)))) + +;;;###autoload +(defun tla-inventory (&optional directory arg) + "Show a tla inventory at DIRECTORY. +When called with a prefix arg, pop to the inventory buffer. +DIRECTORY defaults to the current one when within an arch managed tree, +unless prefix argument ARG is non-nil." + (interactive (list (tla--read-directory-maybe + "Run inventory in (directory): ") + current-prefix-arg)) + (let ((default-directory (or directory default-directory))) + (if arg + (pop-to-buffer (dvc-get-buffer-create tla-arch-branch 'inventory + default-directory)) + (switch-to-buffer (dvc-get-buffer-create tla-arch-branch 'inventory + default-directory)))) + (tla-inventory-mode) + (tla--run-tla-sync + ;; We have to provide all file types or tla inventory won't display + ;; junk files + `("inventory" "--both" "--kind" "--source" "--backups" "--junk" + "--unrecognized" "--precious" + ,(when (and (tla-inventory-has-no-recursion-option) + tla-non-recursive-inventory) + "--no-recursion")) + :finished + (lambda (output error status arguments) + (let ((list (split-string (dvc-buffer-content output) "\n")) + (inventory-list '())) + (mapc + (lambda (item) + (when (string-match "\\([A-Z]\\)\\([\\? ]\\) +\\([^ ]\\) \\(.*\\)" + item) + (let ((tla-type (string-to-char (match-string 1 item))) + (question (string= (match-string 2 item) "?")) + (escaped-filename (match-string 4 item)) + (type (string-to-char (match-string 3 item)))) + (push (list tla-type + question + (tla-unescape escaped-filename) + type) + inventory-list)))) + list) + (setq inventory-list (reverse inventory-list)) + (set (make-local-variable 'tla-inventory-list) + inventory-list) + (tla-inventory-display))))) + +(defun tla-inventory-display () + "Display the inventory. +This function creates the ewoc from the variable `tla-inventory-list', +selecting only files to print." + (interactive) + (setq dvc-buffer-marked-file-list nil) + (let (buffer-read-only) + (erase-buffer) + (set (make-local-variable 'tla-inventory-cookie) + (ewoc-create (dvc-ewoc-create-api-select + #'tla-inventory-printer))) + (tla-inventory-insert-headers) + (dolist (elem tla-inventory-list) + (let ((type (car elem)) + (file (nth 2 elem))) + (when (eval (cadr (assoc type + tla-inventory-file-types-manipulators))) + (when (member file dvc-buffer-all-marked-file-list) + (push file dvc-buffer-marked-file-list)) + (ewoc-enter-last tla-inventory-cookie elem))))) + (goto-char (point-min))) + +;; When there are too many files, tla-inventory is +;; too slow. Putting faces and inserting type-character +;; are the reason of slowness. +;; About putting faces, setting `dvc-highlight' to nil +;; helps. For making inserting type-character faster +;; I(Masatake) introduces a table-lookup code instead +;; of case statement. +;; OLD case based code is here: +;;(defun tla--inventory-chose-face (type) +;; "Return a face adapted to TYPE, which can be J, S, P, T or U." +;; (case type +;; (?J 'tla-junk) ; 74 +;; (?P 'dvc-ignored) ; 80 +;; (?S 'dvc-source) ; 83 +;; (?T 'dvc-nested-tree) ; 84 +;; (?U 'dvc-unrecognized) ; 85 +;; )) + +;; The new table-lookup code is here: +(defconst tla--inventory-chose-face-table + [ + nil ; ?B: 66->0 + nil ; 67 + nil ; 68 + nil ; 69 + nil ; 79 + nil ; 71 + nil ; 72 + nil ; 73 + tla-junk ; ?J: 74->0 + nil ; 75 + nil ; 76 + nil ; 77 + nil ; 78 + nil ; 79 + dvc-ignored ; ?P: 80 + nil ; 81 + nil ; 82 + dvc-source ; ?S: 83 + dvc-nested-tree ; :T: 84 + dvc-unrecognized ; :U: 85 + ] + "from-type-to-face table used in 'tla--inventory-chose-face' +This is for optimization. ") + +(defun tla--inventory-chose-face (type) + "Return a face adapted to TYPE, which can be J, S, P, T or U." + (aref + tla--inventory-chose-face-table + (- type ?B))) + +(defun tla-inventory-printer (elem) + "Ewoc printer for `tla-inventory-cookie'. +Pretty print ELEM." + (let* ((type (nth 0 elem)) + (question (nth 1 elem)) + (file (nth 2 elem)) + (file-type (nth 3 elem)) + (face (tla--inventory-chose-face type))) + (insert (if (member file dvc-buffer-marked-file-list) + (concat " " dvc-mark " ") " ")) + (insert (dvc-face-add (format "%c%s " + type + (if question "?" " ")) + face) + (dvc-face-add + (format "%s%s" file + (case file-type (?d "/") (?> "@") (t ""))) + face + 'tla-inventory-item-map + tla-inventory-item-menu)))) + +(defun tla-inventory-mark-file () + "Mark file at point in inventory mode. + +Adds it to the variable `dvc-buffer-marked-file-list', and move cursor +to the next entry." + (interactive) + (let ((current (ewoc-locate tla-inventory-cookie)) + (file (dvc-get-file-info-at-point))) + (add-to-list 'dvc-buffer-marked-file-list file) + (add-to-list 'dvc-buffer-all-marked-file-list file) + (ewoc-invalidate tla-inventory-cookie current) + (tla-inventory-cursor-goto (or (ewoc-next tla-inventory-cookie + current) + current)))) + +(defun tla-inventory-unmark-file () + "Unmark file at point in inventory mode." + (interactive) + (let ((current (ewoc-locate tla-inventory-cookie)) + (file (dvc-get-file-info-at-point))) + (setq dvc-buffer-marked-file-list + (delete file dvc-buffer-marked-file-list)) + (setq dvc-buffer-all-marked-file-list + (delete file dvc-buffer-all-marked-file-list)) + (ewoc-invalidate tla-inventory-cookie current) + (tla-inventory-cursor-goto (or (ewoc-next tla-inventory-cookie + current) + current)))) + +(defun tla-inventory-unmark-all () + "Unmark all files in inventory mode." + (interactive) + (let ((current (ewoc-locate tla-inventory-cookie))) + (setq dvc-buffer-marked-file-list nil) + (setq dvc-buffer-all-marked-file-list nil) + (ewoc-refresh tla-inventory-cookie) + (tla-inventory-cursor-goto current))) + +(defvar tla-generic-select-files-function nil + "Function called by `tla--generic-select-files'. +Must be local to each buffer.") + +(defun tla--generic-select-files (msg-singular + msg-plural msg-err + msg-prompt + &optional + no-group ignore-marked + no-prompt + y-or-n) + "Get the list of files at point, and ask confirmation of the user. + +This is a generic function calling +`tla-generic-select-files-function', defined locally for each tla +buffer. The behavior should be the following: + +Prompt with either MSG-SINGULAR, MSG-PLURAL, MSG-ERR OR MSG-PROMPT. If +NO-GROUP is nil and if the cursor is on the beginning of a group, all +the files belonging to this message are selected. If some files are +marked \(i.e. `dvc-buffer-marked-file-list' is non-nil) and +IGNORE-MARKED is non-nil, the list of marked files is returned. If +NO-PROMPT is non-nil, don't ask for confirmation. If Y-OR-N is +non-nil, then this function is used instead of `y-or-n-p'." + (when tla-generic-select-files-function + (funcall tla-generic-select-files-function + msg-singular msg-plural msg-err msg-prompt no-group + ignore-marked no-prompt y-or-n))) + +(defun tla-inventory-get-file-info-at-point () + "Gets the file at point in inventory mode." + (let ((cookie (ewoc-locate tla-inventory-cookie))) + (when cookie (car (cddr (ewoc-data cookie)))))) + +(defun tla-inventory-insert-headers () + "Insert the header (top of buffer) for *{tla|baz}-inventory*." + (let* ((tree-version (tla--name-construct + (tla-tree-version-list nil 'no-error))) + (tagging-method (tla-id-tagging-method nil)) + (separator + (dvc-face-add (make-string + (max (+ (length "Directory: ") (length default-directory)) + (+ (length "Default Tree Version: ") (length tree-version)) + (+ (length "ID Tagging Method: ") (length tagging-method))) + ?\ ) + 'dvc-separator))) + (ewoc-set-hf + tla-inventory-cookie + (concat + "Directory: " (dvc-face-add default-directory 'dvc-local-directory + (lexical-let + ((map (make-sparse-keymap)) + (func (lambda () + (interactive) + (dired default-directory)))) + (define-key map [return] func) + (define-key map "\C-m" func) + (define-key map [mouse-2] func) + map) + nil + "Run Dired Here") "\n" + "Default Tree Version: " (dvc-face-add tree-version 'tla-archive-name + 'tla-inventory-default-version-map + (tla--partner-create-menu + 'tla-generic-set-tree-version + "Change the Default Tree Version")) "\n" + "ID Tagging Method: " (dvc-face-add tagging-method 'tla-tagging-method + 'tla-inventory-tagging-method-map + tla-inventory-tagging-method-menu) "\n" + separator "\n") + (concat "\n" separator)))) + +(defvar tla-buffer-source-buffer nil + "Buffer from where a command was called.") + +(defun tla-edit-log-delete-file-list (&optional noerror) + "Delete the temporary file list in the current buffer. + +Return t if something was actually deleted, nil otherwise. +Raise an error if the file list was not found, unless NOERROR is +specified." + (save-excursion + (goto-char (point-min)) + (if (search-forward + (concat "\n" dvc-log-edit-file-list-marker "\n") + (point-max) t) + (progn + (delete-region (1+ (match-beginning 0)) (point-max)) + (goto-char (point-max)) + (delete-blank-lines) + (beginning-of-line) + (forward-line -1) + (when (looking-at "Keywords:") + (end-of-line) + (newline)) + t) ;; return + ;; (if (not (or noerror + ;; (yes-or-no-p (format "The marker %S was not found! Commit anyway? " + ;; dvc-log-edit-file-list-marker)))) + ;; (error (format "The marker %s was not found!" + ;; dvc-log-edit-file-list-marker)) + ;; nil) + ))) + +(defun tla-changes-file-list () + "Return the list of modified files in a changes buffer. + +Return 'dont-know if the list can't be computed easily. + +The result is based on `dvc-fileinfo-ewoc'." + (if dvc-fileinfo-ewoc + (let ((res nil)) + (ewoc-map (lambda (fi) + (let ((x (dvc-fileinfo-legacy-data fi))) + (when (eq (car x) 'file) + (push (cadr x) res)))) + dvc-fileinfo-ewoc) + res) + 'dont-know)) + +;;;###autoload +(defun tla-edit-log (&optional insert-changelog source-buffer other-frame) + "Edit the tla log file. + +With an optional prefix argument INSERT-CHANGELOG, insert the last +group of entries from the ChangeLog file. SOURCE-BUFFER, if non-nil, +is the buffer from which the function was called. It is used to get +the list of marked files, and potentially run a selected file commit." + (interactive "P") + (setq source-buffer (or source-buffer + (dvc-get-buffer tla-arch-branch 'diff) + (dvc-get-buffer tla-arch-branch 'status))) + (setq tla-pre-commit-window-configuration + (current-window-configuration)) + (setq tla-log-edit-file-name (tla-make-log)) + (dvc-switch-to-buffer + (find-file-noselect tla-log-edit-file-name)) + (when insert-changelog + (goto-char (point-max)) + (let ((buf (find-file-noselect (find-change-log)))) + (insert-buffer-substring buf)) + (when (re-search-forward "^2" nil t) + (delete-region (line-beginning-position) + (line-beginning-position 3))) + (when (re-search-forward "^2" nil t) + (delete-region (line-beginning-position) (point-max))) + (goto-char (point-min))) + ;; append list of marked files that will be committed with this log message + (save-excursion + (let ((file-list (if (buffer-live-p source-buffer) + (with-current-buffer source-buffer + (or dvc-buffer-marked-file-list + (tla-changes-file-list))) + 'dont-know)) + (deleted (tla-edit-log-delete-file-list t))) + (unless (and (eq file-list 'dont-know) (not deleted)) + (goto-char (point-max)) + ;; Previous line is not empty or headers are too close. + (while (save-excursion (or (not (progn (forward-line -1) + (looking-at "[ \t]*\n"))) + (progn (forward-line -1) + (looking-at "[a-zA-Z]*:")) + (progn (forward-line -1) + (looking-at "[a-zA-Z]*:")))) + (insert "\n")) + (insert dvc-log-edit-file-list-marker "\n") + (if (not file-list) + (insert "No modified files.\n") + (insert "Files to commit:\n") + (if (eq file-list 'dont-know) + (insert " \n") + (while file-list + (insert " " (car file-list) "\n") + (setq file-list (cdr file-list))))) + (insert "\nThis list might be incomplete or outdated if editing the log") + (insert "\nmessage was not invoked from an up-to-date changes buffer!")))) + (tla-log-edit-mode) + (set (make-local-variable 'tla-buffer-source-buffer) + source-buffer) + (goto-char (point-min)) + (tla-log-edit-next-field t) + (let ((previous-point nil)) + (while (and (not (or (looking-at "$") + (equal (line-beginning-position) + (point)))) + ;; avoid loop. + (not (equal previous-point (point)))) + (tla-log-edit-next-field t) + (setq previous-point (point))))) + +(defvar tla--changes-file-list nil + "List of modified files.") + +(defun tla--ewoc-collect-elem (ewoc predicate &rest args) + "Same as `ewoc-collect', but returns the list of ewoc element." + (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 node result)) + (setq node (ewoc--node-prev dll node))) + (nreverse result))) + +(defun tla--changes-find-subtree-message () + "Finds the messages \"searching subtree\" from the ewoc." + (when dvc-fileinfo-ewoc + (tla--ewoc-collect-elem + dvc-fileinfo-ewoc + (lambda (fi) + (let ((elem (when (dvc-fileinfo-legacy-p fi) (dvc-fileinfo-legacy-data fi)))) + (eq (car elem) 'searching-subtrees)))))) + +(defvar tla--changes-summary nil + "Wether the current buffer display only a summary or a full diff.") + +(defvar tla--changes-buffer-master-buffer nil + "Master buffer for a nested *{tla|baz}-changes* buffer.") + +(defvar tla--changes-summary nil + "Wether the current buffer display only a summary or a full diff.") + +(defun tla--changes-command () + "\"tla changes\" or \"baz diff\" depending on `tla-arch-branch'." + (if (eq tla-arch-branch 'tla) + "tla changes" "baz diff")) + +(defun tla-changes-goto (&optional summary) + "Go to the changes buffer, or run `tla-changes'." + (interactive "P") + (let* ((root (dvc-read-project-tree-maybe + (format "Run %s in: " + (tla--changes-command)))) + (default-directory root) + (buffer (dvc-get-buffer tla-arch-branch 'diff root))) + (if buffer (dvc-switch-to-buffer buffer) + (tla-changes summary)))) + +(defmacro tla-recursive-command (function-to-define + args command + prepare-buffer + recursive + expression + &optional expression-rec) + (declare (indent 2) (debug (&define name sexp form form symbolp body))) + `(defun ,function-to-define ,args + ,(format "Run \"tla %s\". + +When called without a prefix argument: show the detailed diffs also. +When called with a prefix argument SUMMARY: do not show detailed +diffs. When AGAINST is non-nil, use it as comparison tree." command) + (interactive "P") + (let* ((root (dvc-read-project-tree-maybe + (format "Run %s in: " + ,command))) + (default-directory root) + (buffer ,prepare-buffer)) + (with-current-buffer buffer + (make-local-variable 'tla--changes-summary) + (let ((inhibit-read-only t)) + (ewoc-enter-first + dvc-fileinfo-ewoc + (make-dvc-fileinfo-message + :text (concat "* running " ,command " in tree " root + "...\n\n")))) + (when ,recursive + (ewoc-enter-last dvc-fileinfo-ewoc + (make-dvc-fileinfo-legacy + :data (list 'searching-subtrees)))) + (ewoc-refresh dvc-fileinfo-ewoc)) + (when dvc-switch-to-buffer-first + (dvc-switch-to-buffer buffer)) + (dvc-save-some-buffers) + ,expression + (when ,recursive + (tla--run-tla-async + '("inventory" "--nested" "--trees") + :related-buffer buffer + :finished + (dvc-capturing-lambda (output error status arguments) + (let ((subtrees (delete "" + (split-string + (with-current-buffer + output (buffer-string)) "\n")))) + (with-current-buffer (capture buffer) + (let ((subtree-message (car (tla--changes-find-subtree-message))) + (buffer-read-only nil)) + (dolist (subtree subtrees) + (let ((buffer-sub (dvc-get-buffer-create tla-arch-branch + 'diff subtree))) + (with-current-buffer buffer-sub + (dvc-save-some-buffers) + (let ((inhibit-read-only t)) + (erase-buffer)) + (dvc-diff-mode) + (set (make-local-variable + 'tla--changes-buffer-master-buffer) + (capture buffer))) + (ewoc-enter-after dvc-fileinfo-ewoc + subtree-message + (make-dvc-fileinfo-legacy + :data (list 'subtree buffer-sub subtree + nil))) + ,(or expression-rec expression))) + (dvc-ewoc-delete dvc-fileinfo-ewoc + subtree-message)))))))))) + +(tla-recursive-command tla-changes-rec (&optional summary against) + (tla--changes-command) + (dvc-prepare-changes-buffer + (or against + `(,tla-arch-branch (last-revision ,root 1))) + `(tla (local-tree ,root)) + 'diff + default-directory + tla-arch-branch) + tla-changes-recursive + (progn + (setq tla--changes-summary summary) + (tla--changes-internal (not summary) + against + root buffer nil)) + (progn + (setq tla--changes-summary (capture summary)) + (tla--changes-internal + (not (capture summary)) + nil ;; TODO "against" what for a nested tree? + subtree + buffer-sub + (capture buffer)))) + +;;;###autoload +(defun tla-changes (&optional summary against dont-switch) + "Run \"tla changes\". + +When called without a prefix argument: show the detailed diffs also. +When called with a prefix argument SUMMARY: do not show detailed +diffs. When AGAINST is non-nil, use it as comparison tree. + +DONT-SWITCH is necessary for DVC, but currently ignored." + (interactive "P") + (tla-changes-rec summary against)) + +(defun tla--update-command () + (cond ((eq tla-update-strategy 'update) "update") + ((eq tla-update-strategy 'merge) (if (tla-has-merge-command) "merge" "star-merge")) + ((eq tla-update-strategy 'replay) "replay"))) + +(defun tla--three-way-merge-option () + "Returns \"--three-way\", \"--two-way\", or nil. + +Value is chosen depending on user configuration and arch branch." + (if tla-three-way-merge + (if (tla-merge-has-two-way-option) + nil ;; Requested a 3-way, but it's the default. + "--three-way") ;; Requested a 3-way, not the default. + (if (tla-merge-has-two-way-option) + "--two-way" + nil))) + +(defun tla--show-ancestor-option () + "Returns \"--show-ancestor\" or nil. + +Value is chosen depending on user configuration and arch branch." + (if (and tla-show-ancestor + (tla-merge-has-show-ancestor-option)) + "--show-ancestor" + nil)) + +(defun tla--update-internal (root buffer master-buffer handle) + (with-current-buffer (or buffer (current-buffer)) + (tla--run-tla-async + (list (tla--update-command) + (when (eq tla-update-strategy 'merge) + (tla--three-way-merge-option)) + (when (eq tla-update-strategy 'merge) + (tla--show-ancestor-option))) + :finished (dvc-capturing-lambda (output error status arguments) + (let ((modifs (with-current-buffer output + (goto-char (point-min)) + (not (re-search-forward + "^\\* \\(tree is already up to date\\|skipping (empty delta)\\)" + nil t))))) + (with-current-buffer (or (capture master-buffer) + (capture buffer)) + ;; (dvc-trace "buf=%S modifs=%S" (capture buffer) modifs) + (ewoc-map (lambda (fi) + (let ((x (dvc-fileinfo-legacy-data fi))) + (when (and (eq (car x) 'subtree) + (eq (cadr x) (capture buffer))) + (setcar (cdr (cddr x)) + (if modifs 'updated 'no-changes))) + )) + ;; (ewoc-refresh dvc-fileinfo-ewoc))) + dvc-fileinfo-ewoc) + )) + (dvc-show-changes-buffer + output 'tla--parse-other (capture buffer)) + (message "`%s update' finished" (tla--executable)) + (dvc-revert-some-buffers (capture root)) + (when (capture handle) (funcall (capture handle)))) + :error + (lambda (output error status arguments) + (dvc-show-error-buffer error) + (dvc-show-last-process-buffer) + )))) + +(tla-recursive-command tla-update-rec (tree &optional handle recursive) + (tla--update-command) + (dvc-prepare-changes-buffer + `(,tla-arch-branch (last-revision ,default-directory)) + `(,tla-arch-branch (local-tree ,default-directory)) + 'diff + default-directory + tla-arch-branch) + tla-update-recursive + (tla--update-internal root buffer nil handle) + (tla--update-internal subtree buffer-sub (capture buffer) + (capture handle))) + +;;;###autoload +(defun tla-update (tree &optional handle recursive) + "Run tla update in TREE. + +Also runs update recursively for subdirectories. +After running update, execute HANDLE (function taking no argument)." + (interactive (list (expand-file-name + (tla--read-directory-maybe "Update tree: ")))) + (tla-update-rec tree handle recursive)) + +;;;###autoload +(defun tla-changes-against (&optional summary against) + "Wrapper for `tla-changes'. + +When called interactively, SUMMARY is the prefix arg, and AGAINST is +read from the user." + (interactive (list current-prefix-arg + `(,tla-arch-branch (revision ,(tla-name-read "Compute changes against: " + 'prompt 'prompt 'prompt 'prompt + 'maybe))))) + (tla-changes summary against)) + +;;;###autoload +(defun tla-changes-last-revision (&optional summary) + "Run `tla-changes' against the last but one revision. + +The idea is that running this command just after a commit should be +equivalent to running `tla-changes' just before the commit. + +SUMMARY is passed to `tla-changes'." + (interactive "P") + (let ((default-directory (dvc-read-project-tree-maybe + "Review last patch in directory: "))) + (tla-changes summary `(,tla-arch-branch + (revision + ,(tla-revision-direct-ancestor)))))) + +(defun tla--changes-internal (diffs against root buffer master-buffer) + "Internal function to run \"tla changes\". + +If DIFFS is non nil, show the detailed diffs also. +Run the command against tree AGAINST 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 + (dvc-trace "against=%S, (dvc-revision-get-data against)=%S" + against (dvc-revision-get-data against)) + (tla--run-tla-async + `(,(if (eq tla-arch-branch 'tla) "changes" "diff") + ,(when (and (eq tla-arch-branch 'tla) diffs) "--diffs") + ,@(when (and (eq tla-arch-branch 'baz) against root) (list "--dir" root)) + ,(case (dvc-revision-get-type against) + (local-tree + (error "Can not run tla changes or baz diff against a local tree")) + (previous-revision (tla-revision-direct-ancestor + (dvc-revision-get-data against))) + (last-revision (if (string= (dvc-uniquify-file-name + (nth 0 (dvc-revision-get-data against))) + (dvc-uniquify-file-name + (tla-tree-root))) + nil + (error "Tla changes against last %s %s" + "revision of local tree not" + "implemented."))) + (revision (tla--name-construct (car (dvc-revision-get-data against)))) + (t (when against (message "WRONG REVISION: %S" against) (sit-for 1) (debug))))) + :finished + (dvc-capturing-lambda (output error status arguments) + (if (capture master-buffer) + (message "No changes in subtree %s" (capture root)) + (message "No changes in %s" (capture root))) + (with-current-buffer (capture buffer) + (let ((inhibit-read-only t)) + (dvc-fileinfo-delete-messages) + (ewoc-enter-last dvc-fileinfo-ewoc + (make-dvc-fileinfo-message + :text (concat "* No changes in " + (capture root) ".\n\n"))) + (when (capture master-buffer) + (with-current-buffer (capture master-buffer) + (ewoc-map (lambda (fi) + (let ((x (dvc-fileinfo-legacy-data fi))) + (when (and (eq (car x) 'subtree) + (eq (cadr x) (capture buffer))) + (setcar (cdr (cddr x)) 'no-changes))) + ) + ;; (ewoc-refresh dvc-fileinfo-ewoc))) + dvc-fileinfo-ewoc))) + (ewoc-refresh dvc-fileinfo-ewoc)))) + :error + (dvc-capturing-lambda (output error status arguments) + (if (/= 1 status) + (let ((lint-pb + (with-current-buffer error + (goto-char (point-min)) + (re-search-forward "(try \\(tree-lint\\|status --lint\\))" + nil t)))) + (if lint-pb + (progn + (message "Tree is not lint clean. Running lint") + (save-window-excursion + (tla-tree-lint (capture root))) + (let ((buffer (dvc-get-buffer + tla-arch-branch + 'tree-lint (capture root)))) + (when buffer + (switch-to-buffer buffer) + ;; (dvc-trace "buf=%S" (buffer-name)) + (set (make-local-variable + 'tla--tree-lint-nowarning-fn) + ;; I prefer not trying to nest + ;; dvc-capturing-lambda ... + `(lambda () + (tla--changes-internal + ,(capture diffs) ,(capture against) + ,(capture root) ,(capture buffer) + ,(capture master-buffer)) + (switch-to-buffer + (dvc-get-buffer + tla-arch-branch 'diff + ,(capture root)))))))) + (with-current-buffer (capture buffer) + (dvc-fileinfo-delete-messages) + (ewoc-enter-last + dvc-fileinfo-ewoc + (make-dvc-fileinfo-message + :text (concat "* error in process:\n" + (dvc-buffer-content output) + (dvc-buffer-content error)))) + (ewoc-refresh dvc-fileinfo-ewoc) + (message "Error in diff process")))) + (dvc-show-changes-buffer output + (if (eq tla-arch-branch 'tla) + 'tla--parse-other 'tla--parse-baz-diff) + (capture buffer) + (capture master-buffer) + "^[^*\\.]") + ;; FIXME: DVC does not currently support nested trees + (when (capture master-buffer) + (with-current-buffer (capture master-buffer) + (ewoc-map (lambda (fi) + (let ((x (dvc-fileinfo-legacy-data fi))) + (when (and (eq (car x) 'subtree) + (eq (cadr x) (capture buffer))) + (setcar (cdddr x) 'changes)))) + dvc-fileinfo-ewoc))))) + ))) + +(defconst tla-verbose-format-spec + '(("added files" "A" " ") + ("modified files" "M" " ") + ("removed files" "D" " ")) + "Internal variable used to parse the output of tla show-changeset." + ) + +(defun tla--parse-show-changeset (changes-buffer) + (progn + (goto-char (point-min)) + (while (re-search-forward + (concat "^\\* \\(" (regexp-opt + (mapcar 'car tla-verbose-format-spec)) + "\\)\n") + nil t) + (let* ((elem (assoc (match-string 1) + tla-verbose-format-spec)) + (modif (cadr elem)) + (dir (caddr elem))) + ;; (dvc-trace "modif=%S" modif) + (if (string= modif "M") + (while (re-search-forward "^--- orig/\\(.*\\)$" + nil t) + (let ((file (match-string 1))) + (with-current-buffer changes-buffer + (ewoc-enter-last + dvc-fileinfo-ewoc + (make-dvc-fileinfo-legacy + :data (list 'file (tla-unescape file) + modif dir)))))) + (while (looking-at "^$") (forward-line 1)) + (while (looking-at "^ +\\([^ ].*\\)$") + (let ((file (match-string 1))) + (with-current-buffer changes-buffer + (ewoc-enter-last + dvc-fileinfo-ewoc + (make-dvc-fileinfo-legacy + :data (list 'file (tla-unescape file) + modif dir)))) + (forward-line 1))) + (while (looking-at "^--- /dev/null\n\\+\\+\\+ mod/\\(.*\\)$") + (let ((file (match-string 1))) + (with-current-buffer changes-buffer + (ewoc-enter-last + dvc-fileinfo-ewoc + (make-dvc-fileinfo-legacy + :data (list 'file (tla-unescape file) + modif dir)))) + (forward-line 1) + (re-search-forward "^\\(---\\|$\\|\\*\\)" nil t) + (beginning-of-line)))))) + (goto-char (point-min)) + (re-search-forward "^---" nil t) + (beginning-of-line))) + +(defconst tla--files-conflicted-regexp + "^\\* The following.*files are conflicted:") + +(defun tla--parse-baz-status (changes-buffer) + "Called from the output buffer of \"baz status\". + +CHANGES-BUFFER is the target buffer." + (goto-char (point-min)) + (re-search-forward "^[^*\\.]" nil t) + (beginning-of-line) + ;; point is at the beginning of first relevant line. + (unless (re-search-backward tla--files-conflicted-regexp nil t) + (while (looking-at + "\\([CRADP\\? ]\\)\\(.\\) *\\([^ \n\t]*\\)\\( => \\([^ \n\t]*\\)\\)?$") + (let ((file-es (match-string-no-properties 3)) + (status (match-string-no-properties 1)) + (modif (match-string-no-properties 2)) + (origname-es (match-string-no-properties 5))) + (let ((file (tla-unescape file-es)) + (origname (tla-unescape origname-es))) + (if origname + (let ((tmp origname)) + (setq origname file) + (setq file tmp))) + (with-current-buffer changes-buffer + (ewoc-enter-last + dvc-fileinfo-ewoc + (make-dvc-fileinfo-legacy + :data (list 'file + file status modif + (if (file-directory-p file) + "/" " ") + origname)))) + (forward-line 1))))) + (save-excursion + (goto-char (point-min)) + (when (re-search-forward + tla--files-conflicted-regexp nil t) + (re-search-forward "[^ \n\t]" nil t) + (beginning-of-line) + (while (looking-at "[ \t]*\\([^ \t\n]+\\)$") + (let ((file (match-string-no-properties 1))) + (with-current-buffer changes-buffer + (ewoc-enter-last + dvc-fileinfo-ewoc + (make-dvc-fileinfo-legacy + :data (list 'file + file "C" " " + (if (file-directory-p file) + "/" " "))))) + (forward-line 1)))))) + +(defun tla--parse-other (changes-buffer) + "Parses, for example, the output of tla-changes." + (beginning-of-line) + (while (or (eq (char-after) ?*) + (eq (char-after) ?.) + (looking-at "Searching for best merge") + ;; WARNING: If `-' doesn't stand for a range, + ;; it must be at the last in `[]'. + (looking-at "^\\([^=]\\|=[A-Z>]\\)\\([ /Abfl>M-]?\\)\\(/?\\) +\\([^\t\n]*\\)\\(\t\\(.*\\)\\)?$")) + (if (or (looking-at "Searching for best merge") + (eq (char-after) ?*) + (eq (char-after) ?.)) + (let ((msg (buffer-substring-no-properties + (point) (line-end-position)))) + (with-current-buffer changes-buffer + (ewoc-enter-last dvc-fileinfo-ewoc + (make-dvc-fileinfo-message :text msg)))) + (let ((file (match-string 4)) + (modif (match-string 1)) + (dir (match-string 2)) + (maybedir (match-string 3)) + (newname (match-string 6))) + ;; (dvc-trace "file=%S modif=%S dir=%S maybedir=%S newname=%S" + ;; file modif dir maybedir newname) + (if (and (string= modif "-") + (string= dir "-")) + (setq dir maybedir)) + (when (and (not (string= dir "/")) + (not (string= dir " "))) + (setq dir " ")) + (when (string= dir "b") + (setq dir " ")) + (let ((baz-modif modif) + (baz-status " ")) + (cond ((string= modif "M") + (setq baz-modif "M")) + ((string= modif "A") + (setq baz-status "A") + (setq baz-modif " ")) + ((string= modif "D") + (setq baz-status "D") + (setq baz-modif " ")) + ((and (string= modif "=") + (string= dir ">")) + (setq baz-modif " ") + (setq baz-status "R") + (setq dir " ")) + ((and (string= modif "/") + (string= dir ">")) + (setq baz-modif " ") + (setq baz-status "R") + (setq dir "/")) + ((string= modif "-") + (setq baz-status "P") + (setq baz-modif " ")) + ((and (string= modif "?") + (string= dir "M")) + (setq baz-status "?") + (setq baz-modif " "))) + (with-current-buffer changes-buffer + (if newname + (ewoc-enter-last + dvc-fileinfo-ewoc + (make-dvc-fileinfo-legacy + :data (list 'file + (tla-unescape newname) + baz-status baz-modif dir + (tla-unescape file)))) + (ewoc-enter-last + dvc-fileinfo-ewoc + (make-dvc-fileinfo-legacy + :data (list 'file + (tla-unescape file) + baz-status + baz-modif dir)))))))) + (forward-line 1))) + +(defun tla--parse-baz-diff (changes-buffer) + (if (looking-at "^[^\\*]") + (tla--parse-other changes-buffer) + (save-excursion + (while (re-search-forward + "^--- \\(orig/\\)?\\([^\n]*\\)\n\\+\\+\\+ mod/\\([^\n]*\\)$" nil t) + (let* ((origname (match-string-no-properties 2)) + (newname (match-string-no-properties 3)) + (renamed (not (string= origname newname))) + (added (not (string= (match-string-no-properties 1) + "orig/")))) + (dvc-trace "entering file %S in ewoc (orig=%S, renamed=%S, added=%S)" + newname origname renamed added) + (with-current-buffer changes-buffer + (ewoc-enter-last + dvc-fileinfo-ewoc + (make-dvc-fileinfo-legacy + :data (list 'file + newname + (cond (added "A") + (renamed "R") + (t " ")) + (cond (added " ") + (t "M")) + " " ; dir + (when (and renamed + (not added)) + origname)))))))))) + +(defun tla-changes-save (directory) + "Run \"tla changes -o\" to create a changeset. +When tla has a diff command, use \"baz diff -o\". + +The changeset is stored in DIRECTORY." + (interactive "FDirectory to store the changeset: ") + (tla--run-tla-sync (list (if (tla-has-diff-command) + "diff" "changes") "-o" directory) + :finished (lambda (output error status arguments) + (dvc-trace "tla-changes-save: 0")) + :error (dvc-capturing-lambda (output error status arguments) + (case status + (1 (message "tla-changes-save to %s finished" (capture directory))) + (otherwise (dvc-default-error-function + output error status arguments)))))) + +(defun tla-changes-save-as-tgz (file-name) + "Run \"tla changes -o\" to create .tar.gz file. +The changeset is stored in the tarball 'FILE-NAME.tar.gz'." + (interactive "FFile to store the changeset (without .tar.gz extension): ") + (let* ((changeset-dir (expand-file-name file-name)) + (tgz-file-name (concat changeset-dir ".tar.gz"))) + (when (file-directory-p changeset-dir) + (error "The changeset directory %s does already exist" changeset-dir)) + (when (file-exists-p tgz-file-name) + (error "The changeset tarball %s does already exist" tgz-file-name)) + (tla-changes-save changeset-dir) + (dvc-create-tarball-from-intermediate-directory changeset-dir tgz-file-name))) + +(defun tla-changeset-save-as-tgz (revision file-name) + "Create a changeset tarball for a given REVISION. + +FILE-NAME specifies the base name. A '.tar.gz' extension is appended." + (interactive (list + (tla--name-construct + (tla-name-read "Revision: " + 'prompt 'prompt 'prompt 'prompt 'prompt)) + (read-file-name "File to store the changeset (without .tar.gz extension): "))) + (let ((changeset-dir (dvc-make-temp-name "tla-changeset")) + (tgz-file-name (concat (expand-file-name file-name) ".tar.gz"))) + (tla-get-changeset revision nil changeset-dir) + (dvc-create-tarball-from-intermediate-directory changeset-dir tgz-file-name))) + +;;;###autoload +(defun tla-delta (base modified &optional directory dont-switch) + "Run tla delta BASE MODIFIED. +If DIRECTORY is a non-empty string, the delta is stored to it. +If DIRECTORY is ask, a symbol, ask the name of directory. +If DIRECTORY is nil or an empty string, just show the delta using --diffs." + (interactive (list + (tla--name-construct + (tla-name-read "Base: " + 'prompt 'prompt 'prompt 'prompt 'prompt)) + (tla--name-construct + (tla-name-read "Modified: " + 'prompt 'prompt 'prompt 'prompt 'prompt)) + (when current-prefix-arg + 'ask))) + + (when (eq directory 'ask) + (setq directory + (dvc-read-directory-name "Stored to: " + (tla-tree-root default-directory t) + (tla-tree-root default-directory t) + nil + ""))) + + (when (and directory (stringp directory) (string= directory "")) + (setq directory nil)) + + (when (and directory (file-directory-p directory)) + (error "%s already exists" directory)) + + (let ((args + (if directory + (list "delta" base modified directory) + (list "delta" "--diffs" base modified))) + (run-dired-p (when directory 'ask)) + (buffer (dvc-prepare-changes-buffer + `(,tla-arch-branch + (revision ,(tla--name-split base))) + `(,tla-arch-branch + (revision ,(tla--name-split modified))) + 'changeset + modified + tla-arch-branch))) + (if dvc-switch-to-buffer-first + (dvc-switch-to-buffer buffer)) + (tla--run-tla-async args + :finished + (dvc-capturing-lambda (output error status arguments) + (if (capture directory) + (tla--delta-show-directory (capture directory) (capture run-dired-p)) + (tla--delta-show-diff-on-buffer + (capture buffer) + output (capture base) (capture modified) + (capture dont-switch))))) + buffer)) + +(defun tla--delta-show-diff-on-buffer (buffer output base modified &optional dont-switch) + "Show the result of \"delta -diffs\". + +OUTPUT is the output buffer of the tla process. +BASE is the name of the base revision, and MODIFIED is the name of the +modified revision, (then command being run is tla delta BASE +MODIFIED)." + (with-current-buffer output + (let ((no-changes + ;; There were no changes if the last line of + ;; the buffer is "* changeset report" + (save-excursion + (goto-char (point-max)) + (previous-line 1) + (beginning-of-line) + (looking-at "^* changeset report")))) + (if no-changes + (message + (concat "tla delta finished: " + "No changes in this arch working copy")) + (dvc-show-changes-buffer output 'tla--parse-other buffer) + (unless dont-switch + (dvc-switch-to-buffer buffer)) + (message "tla delta finished"))))) + +(defun tla--delta-show-directory (directory run-dired-p) + "Called by `tla-delta' to show a changeset in DIRECTORY. + +If RUN-DIRED-P is non-nil, run dired in the parent directory of the +changeset." + (tla-show-changeset directory nil) + (when (tla--do-dired (concat (file-name-as-directory directory) "..") run-dired-p) + (revert-buffer) + (goto-char (point-min)) + (re-search-forward (concat + (regexp-quote (file-name-nondirectory directory)) + "$")) + (goto-char (match-beginning 0)) + (dvc-flash-line))) + +;; (defvar tla--get-changeset-start-time nil) +;; (defvar tla--changeset-cache (make-hash-table :test 'equal) +;; "The cache for `tla-get-changeset'. +;; A hashtable, where the revisions are used as keys. +;; The value is a list containing the time the cache data was recorded and +;; the text representation of the changeset.") + +;;;###autoload +(defun tla-get-changeset (revision justshow &optional destination + without-diff) + "Gets the changeset corresponding to REVISION. + +When JUSTSHOW is non-nil (no prefix arg), just show the diff. +Otherwise, store changeset in DESTINATION. +If WITHOUT-DIFF is non-nil, don't use the --diff option to show the +changeset." + (interactive + (list (let ((current-version (tla-tree-version nil t))) + (tla--name-construct + (apply 'tla-name-read "Revision to view: " + (if current-version + (mapcar (lambda (x) + (or x 'prompt)) + (tla--name-split current-version)) + (list 'prompt 'prompt 'prompt 'prompt 'prompt))))) + (not current-prefix-arg))) + (let ((buffer (dvc-get-buffer tla-arch-branch 'changeset revision))) + (if buffer (save-selected-window (dvc-switch-to-buffer buffer)) + (let* ((dest (or destination + (dvc-make-temp-name "tla-changeset"))) + (rev-list (if (stringp revision) + (tla--name-split revision) revision)) + (revision (if (stringp revision) revision + (tla--name-construct revision))) + (buffer (and justshow + (dvc-prepare-changes-buffer + `(,tla-arch-branch + (previous-revision (,tla-arch-branch + (revision ,rev-list)) + 1)) + `(,tla-arch-branch + (revision ,rev-list)) + 'changeset revision + tla-arch-branch))) + (dvc-switch-to-buffer-mode + (if tla-switch-to-changes-buffer + dvc-switch-to-buffer-mode 'show-in-other-window))) + (when (and justshow dvc-switch-to-buffer-first) + (dvc-switch-to-buffer buffer)) + (tla--run-tla-async + (list "get-changeset" revision dest) + :finished + (dvc-capturing-lambda (output error status arguments) + (when (capture justshow) + (tla-show-changeset + (capture dest) (capture without-diff) (capture buffer)) + (call-process "rm" nil nil nil "-rf" (capture dest))))) + buffer)))) + +(defun tla-show-changeset (directory &optional without-diff buffer + base modified) + "Run tla show-changeset on DIRECTORY. + +If prefix argument, WITHOUT-DIFF is non-nil, just show the summary. +BUFFER is the target buffer to output. If BUFFER is nil, create a new +one. + +BASE and MODIFIED are the name of the base and modified. Their values +will be used for the variables `dvc-diff-base' and +`dvc-diff-modified'." + (interactive (list (let ((changeset-dir (or (dvc-get-file-info-at-point) ""))) + (unless (file-directory-p (expand-file-name changeset-dir)) + (setq changeset-dir "")) + (dvc-uniquify-file-name + (dvc-read-directory-name + "Changeset directory to view: " changeset-dir changeset-dir))))) + (unless buffer + (setq buffer (dvc-prepare-changes-buffer + base modified ;; TODO don't seem to be set. + 'changeset directory + tla-arch-branch)) + (if dvc-switch-to-buffer-first + (dvc-switch-to-buffer buffer))) + (tla--run-tla-sync (list "show-changeset" + (unless without-diff + "--diffs") + directory) + :finished + (dvc-capturing-lambda (output error status arguments) + (dvc-show-changes-buffer output + (if (capture without-diff) + 'tla--parse-other + 'tla--parse-show-changeset) + (capture buffer) + (capture dvc-switch-to-buffer-first)) + (dvc-post-switch-to-buffer)))) + +(defun tla-show-changeset-from-tgz (file) + "Show the archived changeset from a tar.gz FILE. +Such a changeset can be created via `tla-changes-save-as-tgz'." + (interactive (list (let ((changeset-tarball (or (dvc-get-file-info-at-point) + (and + (eq major-mode 'dired-mode) + (dired-get-filename)) + ""))) + (expand-file-name + (read-file-name "Changeset tarball to view: " + nil changeset-tarball t changeset-tarball))))) + (let ((temp-dir (dvc-make-temp-name "tla-changeset-tgz")) + (changeset-dir)) + ;;(message "temp-dir: %s" temp-dir) + (call-process "mkdir" nil nil nil temp-dir) + (call-process "tar" nil nil nil "xfz" file "-C" temp-dir) + (setq changeset-dir (car (delete "." (delete ".." (directory-files temp-dir))))) + (tla-show-changeset (concat (dvc-uniquify-file-name temp-dir) changeset-dir)) + (call-process "rm" nil nil nil "-rf" temp-dir))) + +;;;###autoload +(defun tla-apply-changeset (changeset target &optional reverse) + "Call \"tla apply-changeset\". + +CHANGESET is the changeset to apply, TARGET is the directory in which +to apply the changeset. If REVERSE is non-nil, apply the changeset in +reverse." + (interactive "DChangeset Directory: \nDTarget Directory: \nP") + (if (file-directory-p changeset) + (setq changeset (expand-file-name changeset)) + (error "%s is not directory" changeset)) + (if (file-directory-p target) + (setq target (expand-file-name target)) + (error "%s is not directory" target)) + + (or (dvc-save-some-buffers target) + (y-or-n-p + "Apply-change may delete unsaved changes. Continue anyway? ") + (error "Not applying")) + (tla--apply-changeset-internal changeset target reverse) + (when (y-or-n-p (format "Run inventory at `%s'? " target)) + (tla-inventory target))) + +(defun tla--apply-changeset-internal (changeset target reverse) + "Actually call \"tla apply-changeset CHANGESET TARGET\". + +If REVERSE is non-nil, use --reverse too." + (let ((buffer (dvc-prepare-changes-buffer nil nil 'diff default-directory tla-arch-branch))) + (tla--run-tla-sync (list "apply-changeset" + (when reverse "--reverse") + ;; (when tla-use-forward-option "--forward") + changeset target) + :finished (dvc-capturing-lambda (output error status arguments) + ;; (tla--show-last--process-buffer) + (dvc-show-changes-buffer output 'tla--parse-other (capture buffer)) + (message "tla apply-changeset finished") + (dvc-revert-some-buffers (capture target)))))) + +(defun tla-apply-changeset-from-tgz (file tree show-changeset) + "Apply changeset in FILE to TREE. +If SHOW-CHANGESET is t: Show the changeset and ask the user, if the patch should +be applied. Otherwise apply the changeset without confirmation." + (interactive "fApply changeset from tarball: \nDApply to tree: ") + (let ((target (tla-tree-root tree)) + (temp-dir (dvc-make-temp-name "tla-changeset-tgz")) + (changeset-dir)) + (call-process "mkdir" nil nil nil temp-dir) + (call-process "tar" nil nil nil "xfz" (expand-file-name file) "-C" temp-dir) + (setq changeset-dir (concat (dvc-uniquify-file-name temp-dir) + (car (delete "." (delete ".." (directory-files temp-dir)))))) + (when show-changeset + (tla-show-changeset changeset-dir)) + (when (or (not show-changeset) (yes-or-no-p "Apply the changeset? ")) + (setq default-directory tree) + (tla-apply-changeset changeset-dir target)) + (call-process "rm" nil nil nil "-rf" temp-dir))) + + +;;;###autoload +(defun tla-file-ediff-against (file &optional base) + "View changes in FILE between BASE and MODIFIED using ediff." + (interactive (let ((version-list (tla-tree-version-list))) + (list (buffer-file-name) + (list 'revision + (tla-name-read "Base revision: " + (tla--name-archive version-list) + (tla--name-category version-list) + (tla--name-branch version-list) + (tla--name-version version-list) + 'prompt))))) + (dvc-ediff-buffers + (or (get-file-buffer file) (find-file-noselect file)) + (tla-file-get-revision-in-buffer file base))) + +;;;###autoload +(defun tla-file-diff (file &optional base modified dont-switch) + "Run \"tla file-diff\" on file FILE. + +In interactive mode, the file is the current buffer's file. +If REVISION is specified, it must be a string representing a revision +name, and the file will be diffed according to this revision." + (interactive (list (buffer-file-name))) + (let* ((file (dvc-uniquify-file-name file)) + (buffer (dvc-get-buffer-create tla-arch-branch 'file-diff file)) + (orig-buffer (current-buffer))) + (if dvc-switch-to-buffer-first + (dvc-switch-to-buffer buffer) + (set-buffer buffer)) + (let ((inhibit-read-only t)) + (erase-buffer)) + (diff-mode) + (when dont-switch (pop-to-buffer orig-buffer)) + (let ((default-directory (tla-tree-root file)) + (file (tla-file-name-relative-to-root file))) + (tla--run-tla-async + (list (if (tla-has-file-diff-command) + "file-diff" "file-diffs") + file base) + :finished + (lambda (output error status arguments) + (message "No changes in this arch working copy")) + :error + (dvc-capturing-lambda (output error status arguments) + (if (= 1 status) + (progn + (with-current-buffer (capture buffer) + (let ((inhibit-read-only t)) + (erase-buffer) + (insert-buffer-substring output) + (toggle-read-only 1))) + (unless (or dvc-switch-to-buffer-first (capture dont-switch)) + (dvc-switch-to-buffer (capture buffer)))) + (dvc-default-error-function + output error status arguments))))))) + +(defvar tla-mine-string "TREE") +(defvar tla-his-string "MERGE-SOURCE") + +(eval-when-compile + (defvar smerge-mode)) + +;;;###autoload +(defun tla-resolved (file) + "Command to delete .rej file after conflicts resolution. +Asks confirmation if the file still has diff3 markers. + +If \"resolved\" command is available, also run it." + (interactive + (list (let ((file (buffer-file-name))) + (if (string-match "^\\(.*\\)\\.rej$" file) + (let ((norej (match-string 1 file))) + (if (y-or-n-p (format "Use file %s instead of %s? " + (file-name-nondirectory norej) + (file-name-nondirectory file))) + norej + file)) + file)))) + (with-current-buffer (find-file-noselect file) + (if (and (boundp 'smerge-mode) smerge-mode) + (progn + (when (and + (save-excursion + (goto-char (point-min)) + (dvc-funcall-if-exists smerge-find-conflict)) + (not (y-or-n-p (concat "Buffer still has diff3 markers. " + "Delete .rej file anyway? ")))) + (error "Not deleting .rej file")) + (dvc-funcall-if-exists smerge-mode -1)) + (when (not (y-or-n-p (concat "Buffer " + (buffer-name) + " is not in in smerge-mode. " + "Delete .rej file anyway? "))) + (error "Not deleting .rej file"))) + ;; maybe run baz resolved. + (if (tla-has-resolved-command) + (let ((default-directory (tla-tree-root file))) + (tla--run-tla-async `("resolved" + ,(tla-file-name-relative-to-root + file)) + :finished 'dvc-null-handler))) + ;; delete .rej file + (let ((rejfile (concat file ".rej"))) + (if (file-exists-p rejfile) + (progn + (when (get-file-buffer rejfile) + (kill-buffer (get-file-buffer rejfile))) + (delete-file rejfile) + (message "deleted file %s" rejfile)) + (error (format "%s: no such file" rejfile)))))) + +(defalias 'tla-conflicts-finish 'tla-resolved) + +;;;###autoload +(defun tla-view-conflicts (buffer) + "*** WARNING: semi-deprecated function. +Use this function if you like, but M-x smerge-mode RET is actually +better for the same task **** + +Graphical view of conflicts after tla star-merge --three-way. The +buffer given as an argument must be the content of a file with +conflicts markers like. + + <<<<<<< TREE + my text + ======= + his text + >>>>>>> MERGE-SOURCE + +Priority is given to your file by default. (This means all conflicts +will be rejected if you do nothing)." + (interactive (list (find-file (read-file-name "View conflicts in: ")))) + (let ((mine-buffer buffer) + (his-buffer (get-buffer-create "*tla-his*"))) + (with-current-buffer his-buffer + (erase-buffer) + (insert-buffer-substring mine-buffer) + (goto-char (point-min)) + (while (re-search-forward (concat "^<<<<<<< " + (regexp-quote tla-mine-string) "$") + nil t) + (beginning-of-line) + (delete-region (point) (progn + (re-search-forward "^=======\n"))) + (re-search-forward + (concat "^>>>>>>> " + (regexp-quote tla-his-string) "$")) + (beginning-of-line) + (delete-region (point) (1+ (line-end-position))) + ) + ) + (with-current-buffer mine-buffer + (goto-char (point-min)) + (while (re-search-forward (concat "^<<<<<<< " + (regexp-quote tla-mine-string) "$") + nil t) + (beginning-of-line) + (delete-region (point) (1+ (line-end-position))) + (re-search-forward "^=======$") + (beginning-of-line) + (delete-region (point) (progn + (re-search-forward + (concat "^>>>>>>> " + (regexp-quote tla-his-string) "\n")))) + )) + (dvc-ediff-buffers mine-buffer his-buffer) + )) + +(defun tla-file-get-revision-in-file (file &optional revision) + "Get the last-committed version of FILE. + +If REVISION is non-nil, it must be a cons representing the revision, +and this revision will be used as a reference. + +Return (file temporary). temporary is non-nil when the file is +temporary and should be deleted." + (case (car revision) + (local-tree (list file nil)) + (previous-revision (tla-file-get-revision-in-file + file + (list 'revision + (tla-revision-direct-ancestor + (cadr revision))))) + ((last-revision revision) + (error "tla-file-get-revision-in-file has moved to DVC, use dvc-revision-get-file-in-buffer instead")))) + +(defun tla-file-revert (file &optional revision) + "Revert the file FILE to the last committed version. + +Warning: You use version control to keep backups of your files. This +function will by definition not keep any backup in the archive. + +Most of the time, you should not use this function. Call +`tla-file-ediff' instead, and undo the changes one by one with the key +`b', then save your buffer. + +As a last chance, `tla-file-revert' keeps a backup of the last-saved in +~ backup file. + +If REVISION is non-nil, it must be a cons representing the revision, +and this revision will be used as a reference." + (interactive (list (progn (when (and (buffer-modified-p) + (or dvc-do-not-prompt-for-save + (y-or-n-p (format "Save buffer %s? " + (buffer-name + (current-buffer)))))) + (save-buffer)) + (buffer-file-name)))) + ;; set aside a backup copy + (when (file-exists-p file) + (copy-file file (car (find-backup-file-name file)) t)) + + (let* ((file-unmo-temp (dvc-revision-get-file-in-buffer + file (if revision + (list 'revision revision) + `(baz (last-revision ,(tla-tree-root) 1))))) + (original file-unmo-temp)) + + ;; display diff + (tla--run-tla-sync (list "file-diffs" file revision) + :finished + (lambda (output error status arguments) + (if (equal (nth 8 (file-attributes file)) + (nth 8 (file-attributes original))) + (error "File %s is not modified!" + (cadr arguments)))) + :error + (lambda (output error status arguments) + (if (/= 1 status) + (dvc-default-error-function + output error status arguments) + (dvc-show-last-process-buffer + 'file-diff + (lambda () + (goto-char (point-min)) + (let ((inhibit-read-only t)) + (insert + (format "M %s\n" (cadr arguments)) + "Do you really want to revert ALL the changes listed below?\n") + (if dvc-highlight (font-lock-fontify-buffer))) + (diff-mode)))))) + + + (unless (yes-or-no-p (format "Really revert %s? " file)) + (bury-buffer) + (error "Not reverting file %s!" file)) + (bury-buffer) + (let ((buf (get-file-buffer file))) + (erase-buffer) + (insert-buffer-substring original) + (save-buffer)))) + +(defun tla-undo (tree &optional + archive category branch version revision) + ;;checkdoc-params: (archive category branch version revision) + "Undo whole local TREE against ARCHIVE/CATEGORY-BRANCH-VERSION-REVISION. +If ARCHIVE is nil, default ARCHIVE/CATEGORY-BRANCH-VERSION-REVISION +associated with TREE. + +When called interactively, call tla undo in the current tree. +When called interactively with a prefix argument, additionally ask +for the revision to revert to. + +The tla-undo shows the changeset first, then it asks for confirmation before +running tla undo." + (interactive + (if (not current-prefix-arg) + (list default-directory nil nil nil nil nil) + (cons default-directory + (tla--read-revision-with-default-tree "Undo against revision: " + default-directory)))) + (tla--undo-internal tree nil nil archive category branch version revision)) + + +(defun tla--undo-internal (tree &optional dont-ask-for-confirmation no-output + archive category branch version revision) + ;;checkdoc-params: (tree archive category branch version revision) + "Internal function used by `tla-undo'. +If DONT-ASK-FOR-CONFIRMATION is given, don't show the changes buffer and don't +ask for confirmation. +If NO-OUTPUT is given, run tla undo with the --no-output flag." + (unless dont-ask-for-confirmation + (save-excursion (if archive + (tla-changes nil (tla--name-construct + archive category branch version revision)) + (tla-changes))) + (sit-for 1)) ;;tla-changes should start before the yes-or-no-p query + (when (or dont-ask-for-confirmation (yes-or-no-p + (if archive + (format "Revert whole local tree (%s) from `%s'? " + tree (tla--name-construct + archive category branch version revision)) + (format "Revert whole local tree (%s) from default revision? " tree)))) + (let ((default-directory tree) + (rev (when archive (tla--name-construct archive category branch version revision))) + (extra-flags (when no-output "--no-output"))) + (tla--run-tla-sync (delete nil (list "undo" extra-flags rev))) + ;; TODO in case of files violating the naming + ;; conventions we could offer to delete them or + ;; switch to inventory-mode and do it there, + ;; basically saying YES should delete them and + ;; perform the undo operation again + )) + (dvc-revert-some-buffers tree)) + +(defun tla--get-undo-changeset-names () + "Get the list of directories starting with \",,undo-\". + +This is used by tla-redo to get the list of candidates for an undo +changeset." + (interactive) + (directory-files (tla-tree-root default-directory t) t ",,undo-")) + +(defun tla--select-changeset (dir-list) + "Select a changeset. + +DIR-LIST is intended to be the result of +`tla--get-undo-changeset-names'." + (dvc-completing-read "Select changeset: " (mapcar 'list dir-list) nil nil (car dir-list))) + + +(defun tla-redo (&optional target) + "Run tla redo. +If TARGET directroy is given, TARGET should hold undo data generated by `tla undo'." + (interactive) + (let* ((undo-changesets (tla--get-undo-changeset-names)) + (undo-changeset (or target + (when (= (length undo-changesets) 1) (car undo-changesets)) + (tla--select-changeset undo-changesets)))) + (tla-show-changeset undo-changeset) + (when (yes-or-no-p (format "Redo the %s changeset? " undo-changeset)) + (tla--run-tla-sync (list "redo" undo-changeset))))) + + +;; TODO: being ported to DVC. +;;;###autoload +(defun tla-file-ediff (file &optional revision) + "Interactive view of differences in FILE with ediff. + +Changes are computed since last commit (or REVISION if specified)." + (interactive (list (progn (when (and (buffer-modified-p) + (y-or-n-p (format "Save buffer %s? " + (buffer-name + (current-buffer))))) + (save-buffer)) + (buffer-file-name)))) + (let ((original (tla-file-get-revision-in-buffer + file (or revision (list 'last-revision + (tla-tree-root)))))) + (when (string= (with-current-buffer original (buffer-string)) + (buffer-string)) + (error "No modification in this file")) + (dvc-ediff-buffers (or (get-file-buffer file) + (find-file-noselect file)) + original))) + +;;;###autoload +(defun tla-file-view-original (file &optional revision) + "Get the last-committed version of FILE in a buffer. + +If REVISION is specified, it must be a cons representing the revision +for which to get the original." + (interactive (list (buffer-file-name))) + (let ((original (tla-file-get-revision-in-buffer + file (or revision (list 'last-revision + (tla-tree-root)))))) + (when (string= (with-current-buffer original (buffer-string)) + (buffer-string)) + (message "No modification in this file")) + (dvc-switch-to-buffer original))) + +(defun tla--buffer-for-rev (file revision) + "Return an empty buffer suitable for viewing FILE in REVISION. + +The name of the buffer is chosen according to FILE and REVISION. + +REVISION may have one of the values described in the docstring of +`dvc-diff-modified' or `dvc-diff-base'." + (dvc-trace "OBSOLETE") + (let ((name (concat + (file-name-nondirectory file) + "(" (cond + ((eq (car revision) 'revision) + (tla--name-construct (cadr revision))) + ((eq (car revision) 'local-tree) + (cadr revision)) + ((eq (car revision) 'last-revision) "original") + ((eq (car revision) 'previous-revision) + (tla--name-construct-semi-qualified + (tla-revision-direct-ancestor (cadr revision)))) + (t "")) + ")"))) + ;; replace / by -- to work around uniquify + (setq name (replace-regexp-in-string "\\/" "--" name)) + (generate-new-buffer name))) + +;; TODO being ported to DVC. See below +(defun tla-file-get-revision-in-buffer (file &optional revision) + "Get the last committed version of FILE in a buffer. + +Returned value is the buffer. + +REVISION can have any of the values described in the docstring of +`dvc-diff-base' and `dvc-diff-modified'" + (dvc-trace "OBSOLETE") + (let* ((default-directory (or (tla-tree-root nil t) + default-directory)) + (file-unmo-temp (tla-file-get-revision-in-file file revision)) + (original (car file-unmo-temp)) + (original-to-be-removed (cadr file-unmo-temp))) + (if (eq (car revision) 'local-tree) + (find-file-noselect original) + (let ((buffer-orig (tla--buffer-for-rev file revision))) + (with-current-buffer buffer-orig + (erase-buffer) + (insert-file-contents original) + (set-buffer-modified-p nil) + (toggle-read-only 1) + (let ((buffer-file-name file)) + (set-auto-mode t)) + (when original-to-be-removed + (delete-file original))) + buffer-orig)))) + +(defun tla-revision-get-last-or-file-revision (file revision last) + "Insert the content of FILE in LAST-REVISION, in current buffer. + +REVISION is either a string or nil. nil means the last commited +revision, non-nil means a revision to pass as command line argument." + (let* ((original (progn + (tla--run-tla-sync + (list "file-find" file revision) + :finished + (dvc-capturing-lambda (output error + status + arguments) + (with-current-buffer output + (goto-char (point-min)) + (re-search-forward "^[^*]") + (buffer-substring-no-properties + (line-beginning-position) + (line-end-position))))))) + file-unmodified-p) + (if (file-exists-p original) + (insert-file-contents original) + ;; Probably tla is ran remotely or whatever. Well, get the + ;; file using the old good tla file-diff | patch -R -o ... + (setq original (dvc-make-temp-name "tla-ediff")) + (tla--run-tla-sync (list (if (tla-has-file-diff-command) + "file-diff" "file-diffs") + file revision) + :finished 'dvc-null-handler + :error + (lambda (output error status arguments) + (if (not (eq status 1)) + (dvc-default-error-function + output error status arguments)))) + (with-current-buffer dvc-last-process-buffer + (call-process-region (point-min) (point-max) + dvc-patch-executable + nil nil nil + "-R" "-o" original file))))) + +;; TODO port of `tla-file-get-revision-in-buffer' to DVC +;;;###autoload +(defun tla-revision-get-last-revision (file last-revision) + "Insert the content of FILE in LAST-REVISION, in current buffer. + +LAST-REVISION looks like +\(\"path\" NUM)." + (when (not (eq (nth 1 last-revision) 1)) + (error "TODO. revision=%S" last-revision)) + (let* ((default-directory (car last-revision))) + (tla-revision-get-last-or-file-revision file nil t))) + +(defun tla-revision-get-file-revision (file revision) + "Insert the content of FILE in REVISION, in current buffer. + +REVISION looks like +\(\"archive\" \"cat\" ...)." + (let* ((default-directory (tla-tree-root file))) + (tla-revision-get-last-or-file-revision + file (tla--name-construct (car revision)) nil))) + +(defalias 'baz-revision-get-last-revision 'tla-revision-get-last-revision) +(defalias 'baz-revision-get-file-revision 'tla-revision-get-file-revision) + +(defun tla-commit-check-empty-line () + "Check that the headers are followed by an empty line. + +Current buffer must be a log buffer. This function checks it starts +with RFC822-like headers, followed by an empty line" + (interactive) + (goto-char (point-min)) + (while (not (looking-at "^$")) + (unless (looking-at "^[A-Za-z0-9_-]*:") + (error "A blank line must follow the last header field")) + (forward-line 1) + ;; space and tabs are continuation line. + (while (looking-at "[ \t]+") + (forward-line 1)))) + +(defun tla-commit-check-empty-headers () + "Check that the current buffer starts with non-empty headers. + +Also checks that the the line following headers is empty (or the +notion of \"header\" would loose its meaning)." + (interactive) + (goto-char (point-min)) + (while (not (looking-at "^$")) + (unless (looking-at "^[A-Za-z0-9_-]*:") + (error "A blank line must follow the last header field")) + (when (looking-at "^\\([A-Za-z0-9_-]*\\):[ \t]*$") + (let ((header (match-string 1))) + (unless (string-match tla-commit-headers-allowed-to-be-empty + header) + (end-of-line) + (when (eq (char-before) ?:) (insert " ")) + (error (format "Empty \"%s: \" header" header))))) + (forward-line 1) + ;; space and tabs are continuation line. + (while (looking-at "[ \t]+") + (forward-line 1)))) + +(defun tla-commit-check-missing-space () + "Check the space after the colon in each header: + +Check that no header in the summary buffer miss the SPC character +following the semicolon. Also checks that the the line following +headers is empty (or the notion of \"header\" would loose its +meaning)" + (interactive) + (goto-char (point-min)) + (let ((stg-changed)) + (while (not (looking-at "^$")) + (unless (looking-at "^[A-Za-z0-9_-]*:") + (error "A blank line must follow the last header field")) + (when (looking-at "^\\([A-Za-z0-9_-]*\\):[^ ]") + (let ((header (match-string 1))) + (if tla-commit-fix-missing-space + (progn + (setq stg-changed t) + (search-forward ":") + (insert " ")) + (error (format "Missing space after colon for \"%s:\"" + header))))) + (forward-line 1) + ;; space and tabs are continuation line. + (while (looking-at "[ \t]+") + (forward-line 1))) + (when stg-changed + (save-buffer)))) + +(defun tla-commit-check-log-buffer () + "Function to call from the ++log... buffer, before comitting. + +\(`tla-commit' calls it automatically). This runs the tests listed in +`tla-commit-check-log-buffer-functions'. Each function is called with +no argument and can raise an error in case the log buffer isn't +correctly filled in." + (dolist (function tla-commit-check-log-buffer-functions) + (funcall function))) + +;;;###autoload +(defun tla-commit (&optional handler version-flag summary-line) + "Run tla commit. + +Optional argument HANDLER is the process handler for the commit +command. `nil' or a symbol(`seal' or `fix') is acceptable as +VERSION-FLAG. +When the commit finishes successful, `tla-commit-done-hook' is called." + (interactive + (list nil nil (when (and current-prefix-arg + (not (tla-make-log t))) + (read-string "Summary line for commit: ")))) + (let (file-list + arglist + dont-commit) + (if current-prefix-arg + (when (tla-make-log t) + (tla-edit-log) + (setq dont-commit t)) + (with-current-buffer + (find-file-noselect (tla-make-log)) + (condition-case x + (tla-commit-check-log-buffer) + (error (progn (switch-to-buffer (current-buffer)) + (eval x)))) + (or (dvc-save-some-buffers) + (y-or-n-p + "Commit with unsaved changes is a bad idea. Continue anyway? ") + (error "Not committing")) + (setq tla-last-commit-message (buffer-substring-no-properties (point-min) (point-max))) + (setq file-list (and (buffer-live-p tla-buffer-source-buffer) + (with-current-buffer tla-buffer-source-buffer + dvc-buffer-marked-file-list))) + (when file-list (setq arglist (append arglist (cons "--" + file-list)))))) + (unless dont-commit + (with-current-buffer + (find-file-noselect (tla-make-log)) + ;; raises an error if commit isn't possible + (tla--run-tla-async + `("commit" + ,(when tla-strict-commits "--strict") + ,@(when summary-line (list "--summary" summary-line)) + ,(cond + ((eq version-flag 'fix) "--fix") + ((eq version-flag 'seal) "--seal") + ((eq version-flag nil) nil) + (t (error "Wrong version flag: %s" version-flag))) + ,@arglist) + :finished + (dvc-capturing-lambda (output error status arguments) + (dvc-show-error-buffer output 'commit) + (run-hooks 'tla-commit-done-hook) + (dvc-buffer-push-previous-window-config tla-pre-commit-window-configuration) + (dvc-diff-clear-buffers + tla-arch-branch + (capture default-directory) + "* Just committed! Please refresh buffer\n") + (when (capture handler) (funcall (capture handler) output error status + arguments)))))))) + +(defun tla-import (&optional dir synchronously) + "Run tla import." + (interactive) + (let* ((default-directory (or dir default-directory)) + (logfile (tla-make-log t))) + (when logfile + (with-current-buffer + (find-file-noselect logfile) + (tla-edit-log-delete-file-list t) + (save-buffer))) + (funcall + (if synchronously 'tla--run-tla-sync 'tla--run-tla-async) + (list "import" (if (tla-import-has-setup-option) "--setup")) + :finished (dvc-capturing-lambda (output error status arguments) + (tla-inventory (capture default-directory)) + (message "Import finished.")) + :error + (dvc-capturing-lambda (output error status arguments) + (let* ((default-directory (capture default-directory)) + (archive (tla--name-archive (tla-tree-version-list)))) + (with-current-buffer error + (goto-char (point-min)) + (if (and (re-search-forward + "^No commitable locations for.*are registered" nil t) + (y-or-n-p (format "Archive %s not registered. Create it?" + archive))) + (progn + (tla--make-archive archive + (tla--make-archive-read-location) + (y-or-n-p "Sign the archive? ") + (y-or-n-p "Create .listing files? ")) + (tla-import (capture default-directory))) + (dvc-default-error-function + output error status arguments)))))))) + +(defun tla-archive-ensure-registration (archive) + "Ensures ARCHIVE is registered. + +If not, offer to create it or to register it." + (interactive (list (tla--name-archive (tla-name-read "Archive: " 'prompt)))) + (tla--run-tla-sync + (list "whereis-archive" archive) + :error (dvc-capturing-lambda + (output error status arguments) + (cond ((y-or-n-p (format "Archive %s not registered. Create it? " + archive)) + (tla--make-archive + archive + (tla--make-archive-read-location) + (y-or-n-p "Sign the archive? ") + (y-or-n-p "Create .listing files? "))) + ((y-or-n-p (format "Register it? ")) + (call-interactively + 'tla--register-archive)) + (t (message "Archive still not registered.")))) + :finished 'dvc-null-handler)) + +(defun tla-init-tree (&optional dir version) + "Run tla init-tree." + (interactive + (let* ((dir (list (dvc-read-directory-name "Directory to init: " + (or default-directory + (getenv "HOME"))))) + (version (tla-name-read (format "Set version for `%s' to: " + default-directory) + 'prompt 'prompt 'prompt 'prompt))) + (list dir version))) + (let* ((default-directory (or dir default-directory)) + (project (tla--name-construct version))) + (tla-archive-ensure-registration (tla--name-archive version)) + (tla--run-tla-sync (list "init-tree" "--nested" project) + :finished (dvc-capturing-lambda + (output error status arguments) + (message "init-tree finished"))))) +;; +;; Import;; +;;;###autoload +(defun tla-start-project (&optional archive synchronously) + "Start a new project. +Prompts for the root directory of the project and the fully +qualified version name to use. Sets up and imports the tree and +displays an inventory buffer to allow the project's files to be +added and committed. +If ARCHIVE is given, use it when reading version. +Return a cons pair: its car is the new version name string, and +its cdr is imported location. +If SYNCHRONOUSLY is non-nil, run \"tla import\" synchronously. +Else run it asynchronously." + (interactive) + (let* ((base (dvc-read-directory-name "Directory containing files to import: " + (or default-directory + (getenv "HOME")))) + (l (tla-name-read (format "Import `%s' to: " base) + (if archive archive (tla-my-default-archive)) + 'prompt 'prompt 'prompt)) + (project (tla--name-construct l))) + (let ((default-directory (file-name-as-directory base))) + (tla-init-tree default-directory l) + (save-excursion + (tla-inventory default-directory) + (message "Type %s when ready to import" + (substitute-command-keys "\\[exit-recursive-edit]")) + (recursive-edit)) + (tla-import default-directory synchronously) + (cons project default-directory)))) + +;;;###autoload +(defun tla-rm (file) + "Call tla rm on file FILE. Prompts for confirmation before." + (when (yes-or-no-p (format "Delete file %s? " file)) + (tla--run-tla-sync (list "rm" file) + :finished 'dvc-null-handler))) + +(defun tla-pristines () + "Run \"tla pristine\"." + (interactive) + (tla--run-tla-sync '("pristines"))) + +;;;###autoload +(defun tla-changelog (&optional name) + "Run \"tla changelog\". + +display the result in an improved ChangeLog mode. +If NAME is given, name is passed to \"tla changelog\" +as the place where changelog is got." + (interactive (when current-prefix-arg + (list (tla--name-construct + (tla-name-read "ChangeLog of: " + 'prompt 'prompt 'prompt 'prompt))))) + (let ((default-directory (dvc-read-project-tree-maybe)) + arguments) + (when name + (setq arguments (cons name arguments))) + (setq arguments (cons "changelog" arguments)) + (tla--run-tla-sync arguments + :finished 'dvc-null-handler) + (dvc-show-last-process-buffer 'changelog 'tla-changelog-mode) + (goto-char (point-min)))) + +;;;###autoload +(defun tla-logs () + "Run tla logs." + (interactive) + (let ((default-directory (dvc-read-project-tree-maybe)) + ;; (details (or dvc-revisions-shows-date + ;; dvc-revisions-shows-creator + ;; dvc-revisions-shows-summary)) + ) + (tla--run-tla-async + (list "logs" "--full" "--reverse" + (when (tla-revisions-has-complete-log-option) "--complete-log") + + ;; (when details "--date") + ;; (when details "--creator") + ;; (when details "--summary")) + ) + :finished + (dvc-capturing-lambda (output error status arguments) + (let ((dvc-temp-current-active-dvc (dvc-current-active-dvc)) + (buffer (dvc-get-buffer-create tla-arch-branch 'log (tla-tree-root)))) + (dvc-switch-to-buffer buffer) + (tla-revision-list-mode) + (tla--revisions-parse-list 'log nil ;;(capture details) + nil ;; TODO (merges) + output nil + dvc-revlist-cookie) + (setq dvc-buffer-refresh-function 'tla-logs)) + (goto-char (point-min)) + (dvc-revision-prev) + (recenter -4))))) + +;;;###autoload +(defun tla-help (command) + "Run tla COMMAND -H." + (interactive + (list (dvc-completing-read + "Get help for: " + (tla--run-tla-sync + '("help") + :finished + (dvc-capturing-lambda (output error status arguments) + (with-current-buffer output + (goto-char (point-min)) + (let (listcmd) + (while (re-search-forward + " *\\([^ ]*\\) : " nil t) + (setq listcmd + (cons (list (match-string 1)) + listcmd))) + listcmd))))))) + (tla--run-tla-sync (list command "-H"))) + +(defun tla-tree-version-list-tla () + "Return the tree version, or nil if not in a project tree." + (tla--run-tla-sync '("tree-version") + :finished + (lambda (output error status arguments) + (with-current-buffer output + (and + (goto-char (point-min)) + (re-search-forward "\\(.*\\)/\\(.*\\)--\\(.*\\)--\\(.*\\)" nil t) + (list (match-string 1) + (match-string 2) + (match-string 3) + (match-string 4))))))) + +(defun tla-tree-version-list (&optional location no-error) + "Elisp implementation of `tla-tree-version-list-tla'. + +A string, LOCATION is used as a directory where +\"/{arch}/++default-version\" is. If NO-ERROR is non-nil, errors are +not reported; just return nil." + (let ((version-string (tla-tree-version location no-error))) + (and version-string + (string-match "\\(.*\\)/\\(.*\\)--\\(.*\\)--\\(.*\\)" version-string) + (list (match-string 1 version-string) + (match-string 2 version-string) + (match-string 3 version-string) + (match-string 4 version-string))))) + +(defun tla-tree-root-tla () + "Run tla tree-root." + (interactive) + (let ((i-p (interactive-p))) + (tla--run-tla-sync '("tree-root") + :finished + (dvc-capturing-lambda (output error status arguments) + (let ((result (dvc-buffer-content output))) + (when (capture i-p) + (message "tla tree-root is: %s" + result)) + result))))) + +;;;###autoload +(defun tla-tree-version (&optional location no-error) + "Equivalent of tla tree-version (but implemented in pure elisp). + +Optional argument LOCATION is the directory in which the command must +be ran. If NO-ERROR is non-nil, don't raise errors if ran outside an +arch managed tree." + (interactive (list nil nil)) + (let* ((tree-root (tla-tree-root location no-error)) + (default-version-file (when tree-root + (expand-file-name + "{arch}/++default-version" + tree-root))) + (version (and (boundp 'tla-buffer-version-name) + (tla--name-construct + tla-buffer-archive-name + tla-buffer-category-name + tla-buffer-branch-name + tla-buffer-version-name)))) + (if (and (or (null version) (string= version "")) + default-version-file + (file-readable-p default-version-file)) + (with-temp-buffer + (insert-file-contents default-version-file) + (setq version (buffer-substring-no-properties (point-min) + (- (point-max) 1))))) + (when (interactive-p) + (message "%s" version)) + version)) + +;;;###autoload +(defun tla-my-id (&optional arg my-id) + "Run tla my-id. + +When called without a prefix argument ARG, just print the my-id from +tla and return it. If MY-ID is not set yet, return an empty string. +When called with a prefix argument, ask for a new my-id. + +The my-id should have the following format: + +Your id is recorded in various archives and log messages as you use +arch. It must consist entirely of printable characters and fit on one +line. By convention, it should have the form of an email address, as +in this example: + +Jane Hacker " + (interactive "P") + (let ((id (tla--run-tla-sync '("my-id") + :finished + (lambda (output error status arguments) + (dvc-buffer-content output)) + :error + (lambda (output error status arguments) + nil)))) + (if arg + ;; Set the user's ID + (let ((new-id (or my-id + (read-string "New arch my-id: " + id tla-my-id-history id)))) + (if (string= id new-id) + (message "Id unchanged! Id = %s" new-id) + (message "Setting id to: %s" new-id) + (tla--run-tla-sync (list "my-id" new-id) + :finished (lambda (output error status arguments) + (message "Id changed to '%s'" new-id)) + :error + (lambda (output error status arguments) + (message "Could not change Id") + (dvc-show-error-buffer error) + ))) + new-id) + (cond (id (when (interactive-p) + (message "Arch my-id: %s" id)) + id) + (t (when (interactive-p) + (message (concat "Arch my-id has not been given yet. " + "Call `%s' to set.") + "tla-set-my-id")) + ""))))) + +(defun tla-set-my-id () + "Set tla's my-id." + (interactive) + (tla-my-id 1)) + +;;;###autoload +(defun tla-tree-id () + "Call either 'baz tree-id' or 'tla logs -f -r' to get the tree-id." + (interactive) + (let ((tree-id) + (cmd-list (if (tla-has-tree-id-command) + '("tree-id") '("logs" "-f" "-r")))) + (tla--run-tla-sync + cmd-list + :finished + (lambda (output error status arguments) + (set-buffer output) + (goto-char (point-min)) + (setq tree-id + (buffer-substring-no-properties + (point) + (line-end-position)))) + :error + (lambda (output error status arguments) + (setq tree-id ""))) + (when (interactive-p) + (message "tree-id for %s: %s" default-directory tree-id)) + tree-id)) + +;; +;; Library +;; + +;;;###autoload +(defun tla-my-revision-library (&optional arg) + "Run tla my-revision-library. + +When called without a prefix argument ARG, just print the +my-revision-library from tla. When called with a prefix argument, ask +for a new my-revision-library. + +my-revision-library specifies a path, where the revision library is +stored to speed up tla. For example ~/tmp/arch-lib. + +You can configure the parameters for the library via +`tla-library-config'." + (interactive "P") + (let ((result (tla--run-tla-sync '("my-revision-library") + :finished 'dvc-status-handler + :error 'dvc-null-handler)) + (rev-lib (dvc-get-process-output))) + (when (eq 0 result) + (if arg + (tla--library-add-interactive rev-lib) + (if (and rev-lib (string= "" rev-lib)) + (message "Arch my-revision-library has not been given yet. Call `%s' with prefix arguments to set." + this-command) + (when (interactive-p) (message "Arch my-revision-library: %s" rev-lib))) + rev-lib)))) + +(defun tla--library-add-interactive (&optional old-rev-lib) + "Prompts for argument and run `tla--library-add'. + +Argument OLD-REV-LIB is the previously set revision library (a +string)." + (unless old-rev-lib (setq old-rev-lib "")) + (let ((new-rev-lib (expand-file-name (dvc-read-directory-name + "New arch revision library: " old-rev-lib)))) + (if (not (string= old-rev-lib new-rev-lib)) + (progn + (message "Setting my-revision-library to: %s" new-rev-lib) + (tla--library-add new-rev-lib)) + old-rev-lib))) + +(defun tla-library-delete (rev-lib) + "Unregister revision library REV-LIB." + (interactive (list (tla--read-revision-library))) + (tla--run-tla-sync (list "my-revision-library" "--delete" rev-lib) + :finished (lambda (output error status arguments) + (message "Library %s removed." + rev-lib)))) + +(defun tla--library-add (new-rev-lib) + "Change the revision library path to NEW-REV-LIB." + (let ((dir-attr (file-attributes new-rev-lib))) + (unless dir-attr + (make-directory new-rev-lib t)) + (tla--run-tla-sync (list "my-revision-library" new-rev-lib) + :finished + (lambda (output error status arguments) + (message (dvc-buffer-content output)))) + new-rev-lib)) + +(defun tla--revision-library-list () + "Parse `tla my-revision-library' into a list of revision libraries." + (tla--run-tla-sync '("my-revision-library") + :finished + 'dvc-output-buffer-split-handler)) + +(defvar tla--library-history nil) + +(defun tla--read-revision-library (&optional prompt) + "Read a revision library from keyboard. +Prompt the user with PROMPT if given." + (let ((list-lib (tla--revision-library-list))) + (if (null (cdr list-lib)) + (car list-lib) + (dvc-completing-read (or prompt + (format "Revision library (default %s): " + (car list-lib))) + (mapcar 'list (tla--revision-library-list)) + nil t nil 'tla--library-history + (car list-lib))))) + +(defun tla-library-config (&optional arg) + "Run tla library-config. +When called without prefix argument ARG, just print the config. +When called with prefix argument ARG, let the user change the config." + (interactive "P") + (let ((rev-lib (tla--read-revision-library)) + (config-param (when arg + (dvc-completing-read "tla library config " + (mapcar 'list '("--greedy" + "--sparse" + "--non-greedy" + "--non-sparse")) + nil t "--")))) + (tla--run-tla-sync (list "library-config" config-param rev-lib) + :finished 'dvc-null-handler) + (message (dvc-get-process-output)))) + +(defun tla-library-add (archive category branch version &optional revision) + "Add ARCHIVE/CATEGORY--BRANCH--VERSION--REVISION to the revision +library. REVISION is optional argument; if it is omitted or `nil' is +given, the last revision in ARCHIVE/CATEGORY--BRANCH--VERSION is added +to the library." + (dvc-show-last-process-buffer) + (tla--run-tla-async `("library-add" + ,(tla--name-construct archive category + branch version + revision)))) + +(defun tla-library-find (archive category branch version revision + &optional silent) + "Find ARCHIVE--CATEGORY--BRANCH--VERSION--REVISION in the revision library. +If the revision is found, return the path for it. Else return nil." + (if (zerop (tla--run-tla-sync (list "library-find" (when silent "--silent") + (tla--name-construct + archive category branch + version revision)) + :finished 'dvc-status-handler + :error 'dvc-status-handler)) + (dvc-get-process-output))) + +;; completing-read: tagline, explicit, names, implicit +(defvar tla-id-tagging-method-history nil) + +;;;###autoload +(defun tla-id-tagging-method (arg) + "View (and return) or change the id-tagging method. +When called without prefix argument ARG: show the actual tagging method. +When called with prefix argument ARG: Ask the user for the new tagging method." + (interactive "P") + (let ((tm (progn (tla--run-tla-sync '("id-tagging-method") + :finished + (lambda (output error status arguments) + (dvc-buffer-content output))))) + (new-tagging-method)) + (if arg + (progn + (setq new-tagging-method + (tla--id-tagging-method-read tm)) + (when (not (string= tm new-tagging-method)) + (tla--id-tagging-method-set new-tagging-method))) + (when (interactive-p) + (message "Arch id tagging method: %s" tm)) + tm + ))) + +(defun tla--id-tagging-method-read (old-method) + "Read id tagging method. +If OLD-METHOD is given, use it as the default method." + (dvc-completing-read + (if old-method + (format "New id tagging method (default %s): " old-method) + "New id tagging method: ") + (mapcar 'list '("tagline" "explicit" "names" "implicit")) + nil t nil + 'tla-id-tagging-method-history + old-method)) + +(defun tla--id-tagging-method-set (method) + "Set the tagging method to METHOD." + (message "Setting tagging method to: %s" method) + (tla--run-tla-sync (list "id-tagging-method" + method) + :finished 'dvc-null-handler)) + +(defun tla-archive-mirror (archive &optional category branch version to) + "Synchronize the mirror for ARCHIVE. +Limit to CATEGORY--BRANCH--VERSION. When called interactively you can specify +the limit as part of the source archive. With a prefix arg also query for TO, +i.e. the destination mirror." + (interactive (let ((from (tla-name-read "Mirror from: " 'prompt 'maybe 'maybe 'maybe)) + (to (if current-prefix-arg (tla-name-read "Mirror to: " 'maybe)))) + (list (tla--name-archive from) + (tla--name-category from) + (tla--name-branch from) + (tla--name-version from) + (tla--name-archive to)))) + (let ((from archive) + (limit (tla--name-construct-semi-qualified category branch + version)) + options) + (if (string= limit "") + (setq limit nil)) + (if (tla-archive-mirror-has-all-mirrors-option) + (push "--all-mirrors" options) + (if (not to) + (if (string-match "-MIRROR$" from) + (setq to from + from (replace-regexp-in-string "-MIRROR$" "" from)) + (setq to (concat from "-MIRROR"))))) + (tla--run-tla-async `("archive-mirror" + ,@options + ,from + ,to + ,limit) + :finished (dvc-capturing-lambda (output error status arguments) + (message "tla archive-mirror finished")) + ))) + +(defun tla-archive-fixup (archive) + "Run tla archive-fixup for ARCHIVE." + (interactive (list (car (tla-name-read "Archive to fixup: " 'prompt)))) + (tla--run-tla-async (list "archive-fixup" archive) + :finished (dvc-capturing-lambda (output error status arguments) + (message "tla archive-fixup %s finished" (capture archive))) + )) + +;;;###autoload +(defun tla-star-merge (from &optional to-tree) + "Star merge from version/revision FROM to local tree TO-TREE." + (interactive (list (tla--name-construct + (tla-name-read "Merge from: " 'prompt 'prompt + 'prompt 'maybe 'maybe)) + (dvc-read-directory-name "Merge to: "))) + (let ((to-tree (when to-tree (expand-file-name to-tree)))) + (or (dvc-save-some-buffers (or to-tree default-directory)) + (y-or-n-p + "Star-merge may delete unsaved changes. Continue anyway? ") + (error "Not running star-merge")) + (let* ((default-directory (or to-tree default-directory)) + (buffer (dvc-prepare-changes-buffer + `(,tla-arch-branch + (last-revision ,default-directory)) + `(,tla-arch-branch + (local-tree ,default-directory)) + ;; TODO using tla-changes here makes it simpler. + ;; The user can just type `g' and get the real + ;; changes. Maybe a 'star-merge would be better + ;; here ... + 'diff default-directory + tla-arch-branch))) + (when dvc-switch-to-buffer-first + (dvc-switch-to-buffer buffer)) + (tla--run-tla-async (list (if (tla-has-merge-command) "merge" "star-merge") + (tla--three-way-merge-option) + (tla--show-ancestor-option) + from) + :finished (dvc-capturing-lambda (output error status arguments) + ;; (tla--show-last--process-buffer) + (dvc-show-changes-buffer + output 'tla--parse-other (capture buffer)) + (message "merge command finished") + (dvc-revert-some-buffers (capture to-tree))) + :error (dvc-capturing-lambda (output error status arguments) + (case status + ;; 2 stands for an error. + (2 (dvc-default-error-function + output error status arguments)) + ;; How about other status? + (otherwise (dvc-show-changes-buffer output 'tla--parse-other) + output nil (capture buffer)))))))) + +(defun tla--replay-arguments () + "Build an argument list for the replay command. +Used to factorize the code of (interactive ...) between `tla-replay-reverse' +and `tla-replay'." + (list (tla--name-construct + (tla-name-read (if current-prefix-arg + "Reversely relay version or revision: " + "Relay version or revision: ") + 'prompt 'prompt 'prompt 'prompt 'maybe)) + (dvc-read-directory-name (if current-prefix-arg + "Reversely replay in tree: " + "Replay in tree: ")) + current-prefix-arg)) + +(defun tla-replay-reverse (from &optional to-tree arg) + "Call `tla-replay' with the REVERSE option." + (interactive (tla--replay-arguments)) + (tla-replay from to-tree t)) + + +(defun tla-replay (from &optional to-tree reverse) + "Replay the revision FROM into tree TO-TREE. +If FROM is a string, it should be a fully qualified revision. +If FROM is a list, it should be a list of fully qualified revisions to +be replayed. + +If REVERSE is non-nil, reverse the requested revision." + (interactive (tla--replay-arguments)) + (let ((default-directory (or to-tree default-directory))) + (or (dvc-save-some-buffers) + (y-or-n-p + "Replay may delete unsaved changes. Continue anyway? ") + (error "Not replaying")) + (dvc-show-last-process-buffer) + (let ((buffer (dvc-prepare-changes-buffer + `(,tla-arch-branch + (last-revision ,default-directory)) + `(,tla-arch-branch + (local-tree ,default-directory)) + 'diff default-directory + tla-arch-branch))) + (when dvc-switch-to-buffer-first + (dvc-switch-to-buffer buffer)) + (tla--run-tla-async `("replay" + ;; ,(when tla-use-forward-option "--forward") + ,(when reverse "--reverse") + ,(when tla-use-skip-present-option "--skip-present") + ,@(if (listp from) + from + (list from))) + :finished (dvc-capturing-lambda (output error status arguments) + (dvc-show-changes-buffer output + 'tla--parse-other + (capture buffer)) + (message "tla replay finished") + (dvc-revert-some-buffers (capture to-tree))) + :error (lambda (output error status arguments) + (dvc-show-error-buffer error) + (dvc-show-last-process-buffer)))))) + +(defun tla-sync-tree (from &optional to-tree) + "Synchronize the patch logs of revision FROM and tree TO-TREE." + (interactive (list + (tla--name-construct + (tla-name-read "Sync tree with revision: " + 'prompt 'prompt 'prompt 'prompt 'prompt)) + (dvc-read-directory-name "Sync tree: "))) + (let ((default-directory (or to-tree default-directory))) + (or (dvc-save-some-buffers) + (y-or-n-p + "Sync-tree may delete unsaved changes. Continue anyway? ") + (error "Not running Sync-tree.")) + (dvc-show-last-process-buffer) + (tla--run-tla-async `("sync-tree" ,from) + :finished (dvc-capturing-lambda (output error status arguments) + (dvc-show-last-process-buffer) + (message "tla sync-tree finished") + (dvc-revert-some-buffers (capture to-tree))) + :error (lambda (output error status arguments) + (dvc-show-changes-buffer + output 'tla--parse-other + (dvc-prepare-changes-buffer nil nil 'diff default-directory tla-arch-branch)))))) + +;;;###autoload +(defun tla-switch (tree version &optional handle) + "Run tla switch to VERSION in TREE. + +After running update, execute HANDLE (function taking no argument)." + (interactive (list (expand-file-name + (dvc-read-directory-name "Switch in tree: " nil + nil nil "")) + (tla-name-read "Switch to version: " + 'prompt 'prompt 'prompt 'maybe 'maybe))) + (unless (tla-has-switch-command) + (error "switch not available with this arch branch")) + (or (dvc-save-some-buffers tree) + (y-or-n-p + "Update may delete unsaved changes. Continue anyway? ") + (error "Not updating")) + (let* ((default-directory (or tree default-directory)) + (buffer (dvc-prepare-changes-buffer + (list 'last-revision default-directory) + (list 'local-tree default-directory) + 'status default-directory 'tla))) + (when dvc-switch-to-buffer-first + (dvc-switch-to-buffer buffer)) + (tla--run-tla-async `("switch" + ,(when (and + (tla-switch-has-show-ancestor-option) + tla-show-ancestor) + "--show-ancestor") + ,(tla--name-construct version)) + :finished (lexical-let ((buffer-lex buffer) (tree-lex tree) (handle-lex handle)) + (lambda (output error status arguments) + ;; (tla--show-last--process-buffer) + (dvc-show-changes-buffer + output 'tla--parse-other buffer-lex) + (message "`%s switch' finished" (tla--executable)) + (dvc-revert-some-buffers tree-lex) + (when handle-lex (funcall handle-lex)))) + :error + (lambda (output error status arguments) + (dvc-show-error-buffer error) + (dvc-show-last-process-buffer) + )) + (dvc-revert-some-buffers tree))) + +(defvar tla-default-export-directory nil "Default directory that is suggested for `tla-export'") +;;;###autoload +(defun tla-export (revision dir) + "Run tla export to export REVISION to DIR." + (interactive (list (tla-name-read "Export version: " + 'prompt 'prompt 'prompt 'maybe 'maybe) + (dvc-read-directory-name "Export to directory: " nil tla-default-export-directory nil))) + (setq dir (dvc-uniquify-file-name dir)) + (tla--run-tla-async `("export" ,(tla--name-construct revision) ,dir) + :finished + (dvc-capturing-lambda (output error status arguments) + (message "Finished tla export %s to %s" (capture revision) (capture dir))))) + +(defun tla-export-as-tgz (version export-directory) + "Run tla export to export REVISION and create a tarball afterwards." + (interactive (list (tla-name-read "Export version: " + 'prompt 'prompt 'prompt 'maybe 'maybe) + (dvc-read-directory-name "Export to directory: " nil tla-default-export-directory nil))) + (let* ((export-dir (dvc-make-temp-name "tla-export")) + (export-base-name (tla--name-construct-semi-qualified (cdr version))) + (export-full-path (concat export-dir "/" export-base-name)) + (tgz-file-name (dvc-uniquify-file-name (concat export-directory "/" export-base-name ".tar.gz")))) + (message "export as tgz to %s using %s" tgz-file-name export-full-path) + (make-directory export-dir) + (tla-export version export-full-path) + (dvc-create-tarball-from-intermediate-directory export-full-path tgz-file-name))) + +(defun tla--tag-does-cacherev () + (cond ((eq tla-tag-does-cacherev 'yes) t) + ((eq tla-tag-does-cacherev 'no) nil) + (t (y-or-n-p "Create cachedrev on tag? ")))) + +;;;###autoload +(defun tla-tag (source-revision tag-version &optional cacherev synchronously) + "Create a tag from SOURCE-REVISION to TAG-VERSION. +Run tla tag --setup. +If SYNCHRONOUSLY is non-nil, the process for tagging runs synchronously. +Else it runs asynchronously." + (interactive + (list (tla--name-construct + (tla-name-read "Source revision (or version): " 'prompt 'prompt 'prompt + 'prompt 'maybe)) + (tla--name-construct + (tla-name-read "Tag version: " 'prompt 'prompt 'prompt + 'prompt)) + (tla--tag-does-cacherev) + nil)) + (when (tla-has-merge-command) + (error "tla-tag not available. Use baz-branch instead.")) + (funcall (if synchronously 'tla--run-tla-sync 'tla--run-tla-async) + (list (when (tla-has-branch-command) "branch" "tag") + (when (tla-tag-has-setup-option) "--setup") + (when (not cacherev) "--no-cacherev") + source-revision tag-version))) + +(defun tla-set-tree-version (version) + "Run tla set-tree-version VERSION." + (interactive (list (tla-name-read "Set tree version to: " + 'prompt 'prompt 'prompt 'prompt))) + + (let ((new-version (tla--name-construct version)) + (old-version (tla-tree-version))) + (when (y-or-n-p (format "Switch tree version from `%s' to `%s'? " + old-version + new-version)) + (tla--run-tla-sync (list "set-tree-version" new-version))))) + +;; ---------------------------------------------------------------------------- +;; Xtla bookmarks +;; ---------------------------------------------------------------------------- + +(defvar tla-bookmarks-loaded nil + "Whether `tla-bookmarks' have been loaded from file.") + +(defvar tla-bookmarks-alist nil + "Alist containing Xtla bookmarks.") + +(defvar tla-bookmarks-show-details nil + "Whether `tla-bookmarks' should show bookmark details.") + +(defvar tla-bookmarks-cookie nil + "Ewoc dll.") + +(defvar tla-missing-buffer-todolist nil + "List of (kind info). + +Can be +\(separator \"label\" bookmark \"local-tree\") +\(changes \"local-tree\") +\(missing \"local-tree\" \"location\" \"bookmark-name\")") + +(defvar tla-bookmarks-marked-list nil + "A list of marked bookmarks.") + +(defun tla-bookmarks-load-from-file-OBSOLETE (&optional force) + "Load bookmarks from the bookmarks file. +If FORCE is non-nil, reload the file even if it was loaded before." + (when (or force (not tla-bookmarks-loaded)) + (let ((file (dvc-config-file-full-path tla-bookmarks-file-name t))) + (save-excursion + (unless (file-exists-p file) + (with-temp-file file + (insert "()"))) + (unless (file-readable-p file) + (error "Xtla bookmark file not readable")) + (with-temp-buffer + (insert-file-contents file) + (setq tla-bookmarks-alist (read (current-buffer)) + tla-bookmarks-loaded t)))))) + +(defun tla-bookmarks-load-from-file (&optional force) + "Load bookmarks from the file `tla-bookmarks-file-name'. + +If FORCE is non-nil, reload the file even if it was loaded before." + ;; TODO remove condition case (after some time) + (condition-case nil + (when (or force (not tla-bookmarks-loaded)) + (dvc-load-state (dvc-config-file-full-path + tla-bookmarks-file-name t)) + (setq tla-bookmarks-loaded t)) + (error (progn + (tla-bookmarks-load-from-file-OBSOLETE force))))) + +(defun tla-bookmarks-save-to-file () + "Save `tla-bookmarks-alist' to the file `tla-bookmarks-file-name'." + (dvc-save-state '(tla-bookmarks-alist) + (dvc-config-file-full-path tla-bookmarks-file-name t) + t)) + +(defun tla-bookmarks-toggle-details (&optional val) + "Toggle the display of bookmark details. +If VAL is positive, enable bookmark details. +If VAL is negative, disable bookmark details." + (interactive "P") + (let ((current-bookmark (ewoc-locate tla-bookmarks-cookie))) + (setq tla-bookmarks-show-details + (if val + (if (> val 0) t + (if (< val 0) nil + (not tla-bookmarks-show-details))) + (not tla-bookmarks-show-details))) + (ewoc-refresh tla-bookmarks-cookie) + (tla-bookmarks-cursor-goto current-bookmark))) + +(defvar tla-bookmarks-align 19 + "Position, in chars, of the `:' when displaying the bookmarks buffer.") + +(defun tla-bookmarks-printer (element) + "Pretty print ELEMENT, an entry of the bookmark list. +This is invoked by ewoc when displaying the bookmark list." + (insert (if (member element tla-bookmarks-marked-list) + (concat " " dvc-mark " ") " ")) + (tla--insert-right-justified (concat (car element) ": ") + (- tla-bookmarks-align 3) + 'dvc-bookmark-name) + (insert (dvc-face-add (tla--name-construct + (cdr (assoc 'location (cdr element)))) + 'dvc-revision-name + 'tla-bookmarks-entry-map + tla-bookmarks-entry-menu + )) + (when tla-bookmarks-show-details + (newline) + (insert-char ?\ tla-bookmarks-align) + (insert (cdr (assoc 'timestamp (cdr element)))) + (newline) + (let ((notes (assoc 'notes (cdr element)))) + (when notes + (insert-char ?\ tla-bookmarks-align) + (insert (cdr notes)) + (newline))) + (let ((nickname (assoc 'nickname (cdr element)))) + (when nickname + (tla--insert-right-justified "nickname: " tla-bookmarks-align) + (insert (cadr nickname)) + (newline))) + (let ((partners (assoc 'partners (cdr element)))) + (when partners + (tla--insert-right-justified "partners: " tla-bookmarks-align) + (insert (cadr partners)) + (dolist (x (cddr partners)) + (insert ",\n") + (insert-char ?\ tla-bookmarks-align) + (insert x)) + (newline))) + (let ((local-tree (assoc 'local-tree (cdr element)))) + (when local-tree + (tla--insert-right-justified "local trees: " tla-bookmarks-align) + (insert (cadr local-tree)) + (dolist (x (cddr local-tree)) + (insert ", " x )) + (newline))) + (let ((groups (assoc 'groups (cdr element)))) + (when groups + (tla--insert-right-justified "Groups: " tla-bookmarks-align) + (insert (cadr groups)) + (dolist (x (cddr groups)) + (insert ", " x )) + (newline))) + (let ((summary-format (assoc 'summary-format (cdr element)))) + (when summary-format + (tla--insert-right-justified "Summary format: " tla-bookmarks-align) + (insert "\"" (cadr summary-format) "\"") + (newline))))) + +(defun tla-bookmarks-read-local-tree (&optional bookmark arg) + "Read a local tree for BOOKMARK, and possibly add it to the bookmarks. +If ARG is non-nil, user will be prompted anyway. Otherwise, just use the +default if it exists." + (let* ((loc (ewoc-locate tla-bookmarks-cookie)) + (bookmark (or bookmark + (and loc (ewoc-data loc)))) + (local-trees (assoc 'local-tree (cdr bookmark)))) + (cond + ((not loc) nil) + ((not local-trees) + (let ((dir (dvc-read-directory-name + (format "Local tree for \"%s\": " + (car bookmark))))) + (when (y-or-n-p "Add this tree in your bookmarks? ") + (tla-bookmarks-add-tree bookmark dir)) + dir)) + (arg + ;; multiple local trees. + (let ((dir (dvc-completing-read + (format "Local tree for \"%s\": " + (car bookmark)) + (mapcar (lambda (x) (cons x nil)) + (cdr local-trees)) + nil nil nil nil (cadr local-trees)))) + (when (and (not (member dir (cdr local-trees))) + (y-or-n-p "Add this tree in your bookmarks? ")) + (tla-bookmarks-add-tree bookmark dir)) + (when (and (not (string= + dir (cadr local-trees))) + (y-or-n-p "Make this the default? ")) + (tla-bookmarks-delete-tree bookmark dir) + (tla-bookmarks-add-tree bookmark dir)) + dir)) + (t (cadr local-trees))))) + +(defun tla-bookmarks-missing (&optional arg) + "Show the missing patches from your partners. +The missing patches are received via tla missing. +Additionally the local changes in your working copy are also shown. + +If prefix argument ARG is specified, the local tree is prompted even +if already set in the bookmarks." + (interactive "P") + (unless tla-bookmarks-cookie + (error "Please, run this command from the bookmarks buffer%s" + " (M-x tla-bookmarks RET)")) + (let ((list (or tla-bookmarks-marked-list + (list (ewoc-data (ewoc-locate + tla-bookmarks-cookie)))))) + (let ((dvc-temp-current-active-dvc (dvc-current-active-dvc)) + (tla-bookmarks-missing-buffer-list-elem + (mapcar + (lambda (elem) + (cons + elem + (tla-bookmarks-read-local-tree elem arg))) + list))) + (set-buffer (dvc-get-buffer-create tla-arch-branch 'tla-missing)) + (tla-revision-list-mode) + (setq dvc-buffer-refresh-function 'tla-missing-refresh) + (set (make-local-variable 'tla-missing-buffer-todolist) + (reverse + (apply 'append + (mapcar (lambda (elem) + (tla-bookmarks-missing-elem + (car elem) arg (cdr elem) t t)) + tla-bookmarks-missing-buffer-list-elem)))) + (tla-missing-refresh)))) + +(defvar tla--nb-active-processes 1 + "Number of active processes in this buffer. + +Used internally as a counter to launch a global handler when all +processes have finished.") + +(defun tla-missing-refresh () + "Refreshed a *{tla|baz}-missing* buffer. + +Process the variable `tla-missing-buffer-todolist' and launches the +tla processes with the appropriate handlers to fill in the ewoc." + (interactive) + (set (make-local-variable 'tla--nb-active-processes) 1) + (let ((buffer-read-only nil)) + (erase-buffer) + (set (make-local-variable 'dvc-revlist-cookie) + (ewoc-create (dvc-ewoc-create-api-select + #'dvc-revlist-printer))) + (dvc-kill-process-maybe (current-buffer)) + (dolist (item tla-missing-buffer-todolist) + (case (car item) + (missing + ;; This item is a version that we want to check for missing patches. + ;; ITEM is of the form: + ;; (missing [bookmark name]) + (let* ((local-tree (nth 1 item)) + (version (nth 2 item)) + (bookmark-name (nth 3 item)) + (shorttext (or bookmark-name version)) + (text (if bookmark-name + (format "Missing patches from partner %s:" + bookmark-name) + (concat "Missing patches from archive " version))) + (node (ewoc-enter-last dvc-revlist-cookie + (list 'separator (concat + text) + 'partner)))) + (ewoc-enter-last dvc-revlist-cookie + '(message "Checking for missing patches...")) + (let ((default-directory local-tree)) + ;; Set the default-directory for the *{tla|baz}-missing* buffer. + (cd default-directory) + (setq tla--nb-active-processes + (+ tla--nb-active-processes 1)) + (tla--run-tla-async + `("missing" + ,(when (tla-revisions-has-complete-log-option) "--complete-log") + ,(when (tla-missing-has-full-option) "--full") + ,(when tla-use-skip-present-option "--skip-present") + ,version) + :finished + (dvc-capturing-lambda (output error status arguments) + (when (and (dvc-get-buffer tla-arch-branch 'missing) + (buffer-live-p (dvc-get-buffer + tla-arch-branch 'missing))) + (with-current-buffer (dvc-get-buffer-create tla-arch-branch 'tla-missing) + (when (ewoc-p dvc-revlist-cookie) + (let* ((cookie dvc-revlist-cookie) + (to-delete (ewoc-next cookie (capture node))) + (prev (ewoc-prev + dvc-revlist-cookie + to-delete)) + (cur (ewoc-locate + dvc-revlist-cookie)) + (deleted (eq cur to-delete))) + (tla--revisions-parse-list + 'missing nil + nil + output (capture node) cookie + 'tla-revision-compute-merged-by + ) + (dvc-ewoc-delete cookie to-delete) + (ewoc-refresh dvc-revlist-cookie) + (let ((loc (if deleted + (ewoc-next + dvc-revlist-cookie + prev) + cur))) + (when loc + (goto-char (ewoc-location loc))))))))) + :error + (dvc-capturing-lambda (output error status arguments) + (when (and (dvc-get-buffer tla-arch-branch 'missing) + (buffer-live-p (dvc-get-buffer + tla-arch-branch 'missing))) + (with-current-buffer (dvc-get-buffer-create tla-arch-branch 'tla-missing) + (when (ewoc-p dvc-revlist-cookie) + (let* ((cookie dvc-revlist-cookie) + (to-delete (ewoc-next cookie (capture node)))) + (setf (ewoc-data to-delete) + (list 'message + (concat + "Error in " + (tla-arch-branch-name) + " process for " + (capture shorttext) + ":\n" + (dvc-buffer-content + error)))))))) + (message "Abnormal exit with code %d!\n%s" status + (dvc-buffer-content error))))))) + (separator + ;; This item is a separator -- the name of a bookmark. + ;; ITEM is of the form: + ;; (separator bookmark ) + (let* ((text (nth 1 item)) + (local-tree (nth 3 item))) + (ewoc-enter-last dvc-revlist-cookie + (list 'separator + text + 'bookmark + local-tree)))) + (changes + ;; This item is a local-tree that should be checked for changes. + ;; ITEM is of the form: + ;; (changes ) + (let ((to-delete + (ewoc-enter-last dvc-revlist-cookie + '(message "Checking for local changes..."))) + (cur-buf (current-buffer)) + (parent-node (ewoc-nth dvc-revlist-cookie -1))) + (setq default-directory (nth 1 item)) + (tla--run-tla-async + '("changes") + :error (dvc-capturing-lambda (output error status arguments) + (with-current-buffer (capture cur-buf) + (let* ((prev (ewoc-prev + dvc-revlist-cookie + (capture to-delete))) + (cur (ewoc-locate + dvc-revlist-cookie)) + (deleted (eq cur (capture to-delete)))) + (tla-bookmarks-missing-parse-changes + output (capture parent-node)) + (dvc-ewoc-delete dvc-revlist-cookie (capture to-delete)) + (ewoc-refresh dvc-revlist-cookie) + (let ((loc (if deleted + (ewoc-next + dvc-revlist-cookie + prev) + cur))) + (when loc + (goto-char (ewoc-location loc))))))) + :finished (dvc-capturing-lambda (output error status arguments) + (with-current-buffer (capture cur-buf) + (let* ((prev (ewoc-prev + dvc-revlist-cookie + (capture to-delete))) + (cur (ewoc-locate + dvc-revlist-cookie)) + (deleted (eq cur (capture to-delete)))) + (dvc-ewoc-delete dvc-revlist-cookie (capture to-delete)) + (ewoc-refresh dvc-revlist-cookie) + (let ((loc (if deleted + (ewoc-next + dvc-revlist-cookie + prev) + cur))) + (when loc + (goto-char (ewoc-location loc))))))) + )))) + (ewoc-set-hf dvc-revlist-cookie "" + (concat "\n" (dvc-face-add "end." + 'dvc-separator))))) + (goto-char (point-min)) + ;; If all processes have been run synchronously, + ;; tla--nb-active-processes is 1 now, and we should run the + ;; callback. + (setq tla--nb-active-processes + (- tla--nb-active-processes 1)) + (when (zerop tla--nb-active-processes) + (tla-revision-compute-merged-by)) + ) + +(defun tla--revision-ewoc-map (function ewoc-list) + "Invoke FUNCTION on 'entry-patch nodes of EWOC-LIST. +Like (ewoc-map FUNCTION EWOC-LIST), but call FUNCTION only on +'entry-patch nodes. The argument passed to FUNCTION is the element of +the ewoc." + (ewoc-map (lambda (elem) + (when (eq (car elem) 'entry-patch) + (funcall function elem))) + ewoc-list)) + +(defun tla--revision-ewoc-map-struct (function ewoc-list) + "Invoke FUNCTION on 'entry-patch nodes of EWOC-LIST. +Like (ewoc-map FUNCTION EWOC-LIST), but call FUNCTION only on +'entry-patch nodes. The argument passed to FUNCTION is a struct of +type tla--revisions." + (ewoc-map (lambda (elem) + (when (eq (car elem) 'entry-patch) + (funcall function (nth 3 elem)))) + ewoc-list)) + + +(defvar tla-revision-merge-by-computed nil + "Non-nil when the \"merged-by\" field have been computed.") + +(defvar tla--merged-table nil + "Lint trap. (global value never used, always defined in a let) + +A hashtable + Revision (as string) -> (cons patches merged by this revision . nil) +We use a cons to be able to use setcar on it. +") + +(defun tla-revision-compute-merged-by () + "Computes the field \"merged-by:\" for a revision. + +In a revision list buffer, with revisions containing the \"merges:\" +information, compute another field \"merged-by:\", containing the +reverse information. If revision-A is a merge of revision-B, then, +you'll get revision-A merges: revision-B revision-B merged-by: +revision-A" + (interactive) + (let ((tla--merged-table (make-hash-table :test 'equal))) + (tla--revision-ewoc-map + (lambda (elem) + (setf (dvc-revlist-entry-patch-merged-by (nth 1 elem)) nil)) + dvc-revlist-cookie) + (tla--revision-ewoc-map 'tla--revision-fill-in-table + dvc-revlist-cookie) + (tla--revision-ewoc-map 'tla--revision-set-merged-patches + dvc-revlist-cookie) + (set (make-local-variable 'tla-revision-merge-by-computed) t) + )) + +(defun tla--revision-fill-in-table (elem) + "Fills in `tla--merged-table' for ELEM." + (let* ((struct (dvc-revlist-entry-patch-struct (nth 1 elem))) + (current-list (tla--revision-revision struct)) + (current (tla--name-construct current-list))) + (dolist (merged-rev (tla--revision-merges struct)) + (let ((hash-elem (gethash merged-rev tla--merged-table))) + (if hash-elem + ;; Add current to the list + (setcar hash-elem (cons current (cdr hash-elem))) + ;; Create the list with only current in it + (puthash merged-rev (cons current nil) + tla--merged-table)))))) + +(eval-when-compile + (defvar tla--merged-rev)) + +(defun tla--revision-set-merged-patches (elem) + "Set the \"merged-by\" field for other revisions according to ELEM. + +Adds ELEM to the list of all patches merged by ELEM." + (let* ((struct (dvc-revlist-entry-patch-struct (nth 1 elem))) + (current-list (tla--revision-revision struct)) + (current (tla--name-construct current-list)) + (merged-patches (gethash current tla--merged-table))) + (dvc-trace "let") + (setf (dvc-revlist-entry-patch-merged-by (nth 1 elem)) + (or (car merged-patches) 'nobody)))) + +(defun tla-bookmarks-missing-elem (data arg local-tree header + &optional changes-too) + "Show missing patches for DATA. +ARG is currently ignored but is present for backwards compatibility. +LOCAL-TREE is the local tree for which missing patches should be shown. +HEADER is currently ignored but is present for backwards compatibility. +If CHANGES-TOO is non-nil, show changes for DATA as well as missing patches." + (let* ((default-directory local-tree) + (partners (assoc 'partners (cdr data))) + (location (cdr (assoc 'location (cdr data))))) + (dvc-switch-to-buffer (dvc-get-buffer-create tla-arch-branch 'tla-missing)) + ;; The buffer was created in a context where we didn't know the + ;; path to use. Set it now. + (cd local-tree) + (let ((item '())) + (add-to-list 'item + `(separator + ,(format "Bookmark %s (%s):" + (car data) + (tla--name-construct location)) + bookmark + ,local-tree)) + (when changes-too + (add-to-list 'item `(changes ,local-tree))) + (dolist (partner (cons (tla--name-construct + (cdr (assoc 'location (cdr data)))) ; Me + (cdr partners))) ; and my partners + (let* ((bookmark-list + (mapcar (lambda (bookmark) + (and (string= partner + (tla--name-construct + (cdr (assoc 'location bookmark)))) + (car bookmark))) + tla-bookmarks-alist)) + (bookmark-name (progn (while (and (not (car bookmark-list)) + (cdr bookmark-list)) + (setq bookmark-list + (cdr bookmark-list))) + (car bookmark-list)))) + (add-to-list 'item `(missing ,local-tree ,partner ,bookmark-name)))) + item))) + +(defun tla--revisions-parse-list (type details merges buffer + parent-node cookie + &optional callback) + "Parse a list of revisions. +TYPE can be either 'log, 'missing, but +could be extended in the future. + +DETAILS must be non-nil if the buffer contains date, author and +summary. +MERGES must be non-nil if the buffer contains list of merged patches +for each revision. +BUFFER is the buffer to parse. + +PARENT-NODE is an ewoc node to which the new items will be appened. If +nil, append at the end of the ewoc list. +COOKIE must be the ewoc list containing PARENT-NODE. + +If CALLBACK is given, it should be a function (or symbol naming a +function) that will be called once the revision list has been fully +parsed." + (with-current-buffer (ewoc-buffer cookie) + (set (make-local-variable 'tla-revision-merge-by-computed) nil)) + (let ((last-node parent-node) + (buffer-to-parse (with-current-buffer buffer + (clone-buffer))) + (parent-buffer (ewoc-buffer cookie)) + revision) + (with-current-buffer buffer-to-parse + (goto-char (point-min)) + (re-search-forward ".*/.*--.*--.*--.*" nil t) + (beginning-of-line) + (while (progn (> (point-max) (point))) + (setq revision (buffer-substring-no-properties + (point) (line-end-position))) + (forward-line 1) + (let* ((rev-struct (make-tla--revision + :revision (tla--name-split revision))) + (elem (list 'entry-patch + (make-dvc-revlist-entry-patch + :dvc 'tla + :struct rev-struct + :rev-id `(tla (revision ,(tla--name-split revision))))))) + (when (or dvc-revisions-shows-summary + dvc-revisions-shows-creator + dvc-revisions-shows-date + tla-revisions-shows-merges + tla-revisions-shows-merged-by) + (with-current-buffer parent-buffer + (if (tla-revisions-has-complete-log-option) + (let* ((rev-list (tla--name-split revision)) + (tree-str (apply 'tla--archive-tree-get-revision-struct + rev-list)) + (log-str (or tree-str + (tla--read-complete-log-struct + buffer-to-parse)))) + (if tree-str (tla--skip-complete-log + buffer-to-parse) + (tla--archive-tree-add-revision + (nth 0 rev-list) + (nth 1 rev-list) + (nth 2 rev-list) + (nth 3 rev-list) + (nth 4 rev-list) + log-str)) + (setf (dvc-revlist-entry-patch-struct (nth 1 elem)) + log-str) + (when (and callback + (zerop tla--nb-active-processes)) + (funcall callback))) + (setq tla--nb-active-processes + (+ tla--nb-active-processes 1)) + (tla--revlog-any + (tla--name-split revision) + nil + (dvc-capturing-lambda (output error status arguments) + (with-current-buffer output + (setf (tla--revision-date (capture rev-struct)) + (tla--read-field "Standard-date")) + (setf (tla--revision-creator (capture rev-struct)) + (tla--read-field "Creator")) + (setf (tla--revision-summary (capture rev-struct)) + (tla--read-field "Summary")) + (setf (tla--revision-merges (capture rev-struct)) + (remove (capture revision) + (split-string (tla--read-field + "New-patches"))))) + (dvc-trace "rev-struct=%s" (capture rev-struct)) + (dvc-trace "elem=%s" (capture elem)) + (with-current-buffer (capture parent-buffer) + (setq tla--nb-active-processes + (- tla--nb-active-processes 1)) + (when (and (capture callback) + (zerop tla--nb-active-processes)) + (funcall (capture callback)))) + (let* ((cur (and + dvc-revlist-cookie + (ewoc-locate dvc-revlist-cookie)))) + (ewoc-refresh (capture cookie)) + (when cur (goto-char (ewoc-location cur)))))) + ))) + (if last-node + (setq last-node + (condition-case nil + (ewoc-enter-after cookie last-node elem) + (error nil))) ; ignore bad data + (ewoc-enter-last cookie elem))) + (beginning-of-line)) + (kill-buffer (current-buffer))) + (with-current-buffer (ewoc-buffer cookie) + (setq tla--nb-active-processes (- tla--nb-active-processes 1)) + (when (and callback + (zerop tla--nb-active-processes)) + (funcall callback)))) + (ewoc-refresh cookie)) + +(defun tla-bookmarks-missing-parse-changes (buffer parent-node) + "Parse the output of `tla changes' from BUFFER and update PARENT-NODE." + (with-current-buffer buffer + (let ((changes + (progn (goto-char (point-min)) + (when (re-search-forward "^[^\\*]" nil t) + (buffer-substring-no-properties + (line-beginning-position) + (point-max))))) + (local-tree default-directory)) + (when changes + (with-current-buffer (dvc-get-buffer-create tla-arch-branch 'tla-missing) + (ewoc-enter-after dvc-revlist-cookie + parent-node + (list 'entry-change + changes + local-tree))))))) + +(defun tla-bookmarks-open-tree () + "Open a local tree in a dired buffer." + (interactive) + (dired-other-window (tla-bookmarks-read-local-tree))) + +(defun tla-bookmarks-find-file () + "Find a file starting from the local tree of the current bookmark. +This way, you can type C-x C-f in the bookmarks buffer to open a file +of a bookmarked project." + (interactive) + (let ((default-directory (dvc-uniquify-file-name + (tla-bookmarks-read-local-tree)))) + (call-interactively 'find-file))) + +(defun tla-bookmarks-tag (arg) + "Run `tla tag' on the current bookmark. + +If multiple bookmarks are marked, create a tag for each of them. If a +prefix argument ARG is given, explicitly ask for the revision to tag +from." + (interactive "P") + (unless tla-bookmarks-cookie + (error "Please, run this command from the bookmarks buffer%s" + " (M-x tla-bookmarks RET)")) + (let ((list (or tla-bookmarks-marked-list + (list (ewoc-data (ewoc-locate tla-bookmarks-cookie)))))) + (let ((tags (mapcar + (lambda (bookmark) + (let ((location + (tla--name-construct + (if arg + (apply 'tla-name-read "Tag from revision: " + (append (cdr (assoc 'location bookmark)) + '(prompt))) + (cdr (assoc 'location bookmark)))))) + (list location + (tla--name-construct + (tla-name-read (format "Tag version for '%s': " + location) + 'prompt 'prompt 'prompt 'prompt)) + (read-string + "Name of the bookmark for this tag: ")))) + list))) + (dolist (tag tags) + (destructuring-bind (src destination name) tag + (tla--run-tla-async + (list "tag" (when (tla-tag-has-setup-option) "--setup") + src destination) + :finished + (dvc-capturing-lambda (output error status arguments) + (tla-bookmarks-add (capture name) (tla--name-split (capture destination))) + (tla-bookmarks-add-partner (assoc (capture name) tla-bookmarks-alist) + (capture src) t)) + :error + (dvc-capturing-lambda (output error status arguments) + (error "Fail to create a tag for %s" (capture src))))))) + (setq tla-bookmarks-marked-list nil) + (ewoc-refresh tla-bookmarks-cookie))) + +(defun tla-bookmarks-inventory () + "Run `tla inventory' on a local tree." + (interactive) + (let ((default-directory (tla-bookmarks-read-local-tree))) + (tla-inventory nil t))) + +(defun tla-bookmarks-changes () + "Run `tla-changes' on a local tree." + (interactive) + (let ((default-directory (tla-bookmarks-read-local-tree))) + (tla-changes nil nil))) + +;;;###autoload +(defun tla-bookmarks (&optional arg) + "Display xtla bookmarks in a buffer. +With prefix argument ARG, reload the bookmarks file from disk." + (interactive "P") + (tla-bookmarks-load-from-file arg) + (pop-to-buffer (dvc-get-buffer-create tla-arch-branch 'bookmark)) + (let ((pos (point))) + (toggle-read-only -1) + (erase-buffer) + (set (make-local-variable 'tla-bookmarks-cookie) + (ewoc-create (dvc-ewoc-create-api-select + #'tla-bookmarks-printer))) + (set (make-local-variable 'tla-bookmarks-marked-list) nil) + (dolist (elem tla-bookmarks-alist) + (ewoc-enter-last tla-bookmarks-cookie elem)) + (tla-bookmarks-mode) + (if (equal pos (point-min)) + (if (ewoc-nth tla-bookmarks-cookie 0) + (tla-bookmarks-cursor-goto (ewoc-nth tla-bookmarks-cookie 0)) + (message "You have no bookmarks, create some in the other buffers")) + (goto-char pos)))) + + +(defun tla-bookmarks-mode () + "Major mode to show xtla bookmarks. + +You can add a bookmark with '\\\\[tla-bookmarks-add]', and remove one with '\\[tla-bookmarks-delete]'. After +marking a set of files with '\\[tla-bookmarks-mark]', make them partners with '\\[tla-bookmarks-marked-are-partners]', and +you will then be able to use '\\[tla-bookmarks-missing]' to view the missing patches. + +Commands: +\\{tla-bookmarks-mode-map}" + (interactive) + (use-local-map tla-bookmarks-mode-map) + (setq major-mode 'tla-bookmarks-mode) + (setq mode-name "tla-bookmarks") + (toggle-read-only 1) + (run-hooks 'tla-bookmarks-mode-hook)) + +(defun tla-bookmarks-cursor-goto (ewoc-bookmark) + "Move cursor to the ewoc location of EWOC-BOOKMARK." + (interactive) + (goto-char (ewoc-location ewoc-bookmark)) + (search-forward ":")) + +(defun tla-bookmarks-next () + "Move the cursor to the next bookmark." + (interactive) + (let* ((cookie tla-bookmarks-cookie) + (elem (ewoc-locate cookie)) + (next (or (ewoc-next cookie elem) elem))) + (tla-bookmarks-cursor-goto next))) + +(defun tla-bookmarks-previous () + "Move the cursor to the previous bookmark." + (interactive) + (let* ((cookie tla-bookmarks-cookie) + (elem (ewoc-locate cookie)) + (previous (or (ewoc-prev cookie elem) elem))) + (tla-bookmarks-cursor-goto previous))) + +(defun tla-bookmarks-move-down () + "Move the current bookmark down." + (interactive) + (let* ((cookie tla-bookmarks-cookie) + (elem (ewoc-locate cookie)) + (data (ewoc-data elem)) + (oldname (car data)) + (next (ewoc-next cookie elem))) + (unless next + (error "Can't go lower")) + (dvc-ewoc-delete cookie elem) + (goto-char (ewoc-location + (ewoc-enter-after cookie next data))) + (let ((list tla-bookmarks-alist) + newlist) + (while list + (if (string= (caar list) oldname) + (progn + (setq newlist (cons (car (cdr list)) newlist)) + (setq newlist (cons (car list) newlist)) + (setq list (cdr list))) + (setq newlist (cons (car list) newlist))) + (setq list (cdr list))) + (setq tla-bookmarks-alist (reverse newlist))) + (search-forward ":"))) + +(defun tla-bookmarks-move-up () + "Move the current bookmark up." + (interactive) + (let* ((cookie tla-bookmarks-cookie) + (elem (ewoc-locate cookie)) + (data (ewoc-data elem)) + (oldname (car data)) + (previous (ewoc-prev cookie elem))) + (unless previous + (error "Can't go upper")) + (dvc-ewoc-delete cookie elem) + (goto-char (ewoc-location + (ewoc-enter-before cookie previous data))) + (let ((list tla-bookmarks-alist) + newlist) + (while list + (if (string= (caar (cdr list)) oldname) + (progn + (setq newlist (cons (car (cdr list)) newlist)) + (setq newlist (cons (car list) newlist)) + (setq list (cdr list))) + (setq newlist (cons (car list) newlist))) + (setq list (cdr list))) + (setq tla-bookmarks-alist (reverse newlist))) + (search-forward ":"))) + +(defun tla--get-location-as-string () + "Construct an a/c--b--v--r string from the current bookmark." + (let* ((elem (ewoc-data (ewoc-locate tla-bookmarks-cookie))) + (location (cdr (assoc 'location elem)))) + (tla--name-construct location))) + +(defun tla-bookmarks-get (directory) + "Run `tla get' on the bookmark under point, placing the tree in DIRECTORY." + (interactive (list (expand-file-name + (dvc-read-directory-name + (format "Get %s in directory: " (tla--get-location-as-string)))))) + (let* ((elem (ewoc-data (ewoc-locate tla-bookmarks-cookie))) + (location (cdr (assoc 'location elem)))) + (tla-get directory t + (tla--name-archive location) + (tla--name-category location) + (tla--name-branch location) + (tla--name-version location)))) + +(defun tla-bookmarks-goto () + "Browse the archive of the current bookmark." + (interactive) + (let* ((elem (ewoc-data (ewoc-locate tla-bookmarks-cookie))) + (location (cdr (assoc 'location elem))) + (archive (tla--name-archive location)) + (category (tla--name-category location)) + (branch (tla--name-branch location)) + (version (tla--name-version location))) + (cond (version (tla-revisions archive category branch version)) + (branch (tla-versions archive category branch)) + (category (tla-branches archive category)) + (archive (tla-categories archive)) + (t (error "Nothing specified for this bookmark"))))) + +(dvc-make-bymouse-function tla-bookmarks-goto) + +(defun tla-bookmarks-star-merge (arg) + "Star-merge the current bookmark to a local tree. +Accepts prefix argument ARG for future extension." + (interactive "P") + (let* ((elem (ewoc-data (ewoc-locate tla-bookmarks-cookie))) + (location (cdr (assoc 'location elem))) + (local-tree (dvc-read-directory-name "Star-merge into: "))) + (tla-star-merge (tla--name-construct location) + local-tree))) + +(defun tla-bookmarks-replay (arg) + "Replay the current bookmark to some local tree. +Accepts prefix argument ARG for future extension." + (interactive "P") + (let* ((elem (ewoc-data (ewoc-locate tla-bookmarks-cookie))) + (location (tla--name-construct (cdr (assoc 'location elem)))) + (local-tree (dvc-read-directory-name + (format "Replay %s into: " location)))) + (tla-replay location local-tree))) + +(defun tla-bookmarks-update (arg) + "Update the local tree of the current bookmark. +Accepts prefix argument ARG for future extension." + (interactive "P") + (let* ((buf (current-buffer)) + (work-list (or tla-bookmarks-marked-list + (list (ewoc-data (ewoc-locate tla-bookmarks-cookie))))) + (update-trees + (mapcar (lambda (bookmark) + (let ((local-trees (cdr (assoc 'local-tree bookmark)))) + (dvc-uniquify-file-name + (cond ((null local-trees) + (dvc-read-directory-name + (format "Local tree for '%s'?: " + (car bookmark)) nil nil t)) + ((not (null (cdr local-trees))) + (dvc-completing-read + (format "Local tree for '%s'?: " + (car bookmark)) + local-trees nil t)) + (t (car local-trees)))))) + work-list))) + (mapc 'tla-update update-trees) + (with-current-buffer buf + (setq tla-bookmarks-marked-list '()) + (ewoc-refresh tla-bookmarks-cookie)))) + +(defun tla-bookmarks-add-elem (name info) + "Add the association (NAME . INFO) to the list of bookmarks, and save it. +This is an internal function." + (when (assoc name tla-bookmarks-alist) + (error (concat "Already got a bookmark " name))) + (let ((elem (cons name info))) + (dvc-add-to-list 'tla-bookmarks-alist elem t) + (tla-bookmarks-save-to-file) + (ewoc-enter-last tla-bookmarks-cookie elem) + )) + +(defun tla-bookmarks-add (name revision-spec) + "Add a bookmark named NAME for REVISION-SPEC." + (interactive (let* ((fq (tla-name-read "Version: " + 'prompt 'prompt 'prompt 'prompt)) + (n (read-string (format "Name of the bookmark for `%s': " + (tla--name-construct fq))))) + (list n fq))) + (unless (dvc-get-buffer tla-arch-branch 'bookmark) + (tla-bookmarks)) + (with-current-buffer (dvc-get-buffer-create tla-arch-branch 'bookmark) + (let* ((info (list (cons 'location + revision-spec) + (cons 'timestamp (current-time-string))))) + (tla-bookmarks-add-elem name info)))) + +(defun tla-bookmarks-mark () + "Mark the bookmark at point." + (interactive) + (let ((pos (point))) + (add-to-list 'tla-bookmarks-marked-list + (ewoc-data (ewoc-locate tla-bookmarks-cookie))) + (ewoc-refresh tla-bookmarks-cookie) + (goto-char pos)) + (tla-bookmarks-next)) + +(defun tla-bookmarks-unmark () + "Unmark the bookmark at point." + (interactive) + (let ((pos (point))) + (setq tla-bookmarks-marked-list + (delq (ewoc-data (ewoc-locate tla-bookmarks-cookie)) + tla-bookmarks-marked-list)) + (ewoc-refresh tla-bookmarks-cookie) + (goto-char pos)) + (tla-bookmarks-next)) + +(defun tla-bookmarks-unmark-all () + "Unmark all bookmarks in current buffer." + (interactive) + (let ((pos (point))) + (setq tla-bookmarks-marked-list nil) + (ewoc-refresh tla-bookmarks-cookie) + (goto-char pos))) + +(defun tla-bookmarks-marked-are-partners () + "Make marked bookmarks mutual partners." + (interactive) + (let ((list-arch (mapcar + (lambda (x) + (format "%s" + (tla--name-construct + (cdr (assoc 'location x))))) + tla-bookmarks-marked-list))) + (dolist (book tla-bookmarks-marked-list) + (let ((myloc (tla--name-construct + (cdr (assoc 'location book))))) + (message myloc) + (dolist (arch list-arch) + (unless (string= myloc arch) + (tla-bookmarks-add-partner book arch t)))))) + (tla-bookmarks-save-to-file) + (save-window-excursion + (tla-bookmarks))) + +(defun tla-bookmarks-cleanup-local-trees () + "Remove LOCAL-TREE field from bookmarks if they don't exist." + (interactive) + (dolist (book tla-bookmarks-alist) + (let () + (dolist (local-tree (cdr (assoc 'local-tree book))) + (when (and (not (file-exists-p local-tree)) + (or tla-bookmarks-cleanup-dont-prompt + (y-or-n-p + (format + "Remove tree %s from bookmarks %s? " + local-tree + (car book))))) + (tla-bookmarks-delete-tree book local-tree t))))) + (tla-bookmarks-save-to-file) + (save-window-excursion + (tla-bookmarks))) + +(defun tla-bookmarks-delete (elem &optional force) + "Delete the bookmark entry ELEM. +If FORCE is non-nil, don't ask for confirmation." + (interactive (list (ewoc-locate tla-bookmarks-cookie))) + (let* ((data (ewoc-data elem))) + (when (or force + (yes-or-no-p (format "Delete bookmark \"%s\"? " (car data)))) + (dvc-ewoc-delete tla-bookmarks-cookie elem) + (let ((list tla-bookmarks-alist) + newlist) + (while list + (unless (string= (caar list) (car data)) + (setq newlist (cons (car list) newlist))) + (setq list (cdr list))) + (setq tla-bookmarks-alist (reverse newlist))) + ;; TODO could be optimized + (tla-bookmarks-save-to-file) + ))) + +(defun tla-bookmarks-find-bookmark (location) + "Find the bookmark whose location is LOCATION (a string)." + (let ((list tla-bookmarks-alist) + result) + (while list + (when (string= (tla--name-construct + (cdr (assoc 'location (cdar list)))) + location) + (setq result (car list)) + (setq list nil)) + (setq list (cdr list))) + result)) + +(defun tla-bookmarks-get-field (version field default) + "Return VERSION'S value of FIELD, or DEFAULT if there is no value." + (tla-bookmarks-load-from-file) + (block dolist + (dolist (elem tla-bookmarks-alist) + (let ((location (cdr (assoc 'location elem)))) + (when (and (string= (tla--name-archive location) + (tla--name-archive version)) + (string= (tla--name-category location) + (tla--name-category version)) + (string= (tla--name-branch location) + (tla--name-branch version)) + (string= (tla--name-version location) + (tla--name-version version))) + (return-from dolist (or (cadr (assoc field (cdr elem))) default))))) + default)) + +(defmacro tla--bookmarks-make-edit-fn (name field read-fn) + "Define an interactive function called NAME for editing FIELD of a bookmark +entry." + (declare (indent 2) (debug (&define name form function-form))) + `(defun ,name (bookmarks value &optional dont-save) + "Adds the directory VALUE to the list of local trees of bookmark +BOOKMARK. +Unless DONT-SAVE is non-nil, save the bookmark file." + (interactive + (let* ((bookmarks (or tla-bookmarks-marked-list + (list (ewoc-data (ewoc-locate + tla-bookmarks-cookie))))) + (bookmark (car bookmarks))) + (list bookmarks nil))) + (dolist (bookmark bookmarks) + (let* ((field-contents (assoc ,field (cdr bookmark))) + (value (or value + (,read-fn + (car bookmark) + (cadr field-contents))))) + (if field-contents + (setcdr (assoc ,field (cdr bookmark)) + (list value)) + (setcdr bookmark (cons (list ,field value) + (cdr bookmark)))))) + (unless dont-save + (tla-bookmarks-save-to-file) + (save-window-excursion + (tla-bookmarks))))) + +(tla--bookmarks-make-edit-fn + tla-bookmarks-edit-summary + 'summary-format + (lambda (prompt val) + (read-string (format + "Summary for %s (use %%s for the merge string): " + prompt) + val))) + +(defmacro tla-bookmarks-make-add-fn (name field message-already message-add) + "Define a function called NAME for adding FIELD to a bookmark entry. +This function will display MESSAGE-ALREADY if the user tries to add a field +twice, and will display MESSAGE-ADD when a new field is successfully added." + (declare (indent 2) (debug (&define name form stringp stringp))) + `(defun ,name (bookmark value &optional dont-save) + "Adds the directory VALUE to the list of local trees of bookmark +BOOKMARK. +Unless DONT-SAVE is non-nil, save the bookmark file." + (let ((field-contents (assoc ,field (cdr bookmark)))) + (if field-contents + (if (member value (cdr field-contents)) + (message ,message-already) + (progn + (message ,message-add) + (setcdr field-contents (cons value + (cdr field-contents))))) + (progn + (message ,message-add) + (setcdr bookmark (cons (list ,field value) + (cdr bookmark))))) + (unless dont-save + (tla-bookmarks-save-to-file) + (save-window-excursion + (tla-bookmarks))))) + ) + +(tla-bookmarks-make-add-fn tla-bookmarks-add-tree + 'local-tree + "Local tree already in the list" + "Local tree added to your bookmarks") + +(tla-bookmarks-make-add-fn tla-bookmarks-add-partner + 'partners + "Partner already in the list" + "Partner added to your bookmarks") + +(tla-bookmarks-make-add-fn tla-bookmarks-add-group + 'groups + "Group already in the list" + "Group added to your bookmarks") + +(tla-bookmarks-make-add-fn tla-bookmarks-add-nickname + 'nickname + "Nickname already in the list" + "Nickname added to your bookmark") + +(defmacro tla-bookmarks-make-delete-fn (name field) + "Define a function called NAME for removing FIELD from bookmark entries." + (declare (indent 2) (debug (&define name form))) + `(defun ,name (bookmark value &optional dont-save) + "Deletes the directory VALUE to the list of local trees of bookmark +BOOKMARK." + (let ((local-trees (assoc ,field (cdr bookmark)))) + (when local-trees + (let ((rem-list (delete value (cdr (assoc ,field + bookmark))))) + (if rem-list + (setcdr local-trees rem-list) + ;; Remove the whole ('field ...) + (setcdr bookmark (delq local-trees (cdr bookmark)))))) + (unless dont-save + (tla-bookmarks-save-to-file) + (save-window-excursion + (tla-bookmarks))))) + ) + +(tla-bookmarks-make-delete-fn tla-bookmarks-delete-tree + 'local-tree) + +(tla-bookmarks-make-delete-fn tla-bookmarks-delete-partner + 'partners) + +(tla-bookmarks-make-delete-fn tla-bookmarks-delete-group + 'groups) + +(tla-bookmarks-make-delete-fn tla-bookmarks-delete-nickname + 'nickname) + +(defun tla-bookmarks-add-partner-interactive () + "Add a partner to the current or marked bookmarks." + (interactive) + (let ((bookmarks (or tla-bookmarks-marked-list + (list (ewoc-data (ewoc-locate + tla-bookmarks-cookie))))) + (partner (tla--name-construct + (tla-name-read "Add partner version: " + 'prompt 'prompt 'prompt 'prompt)))) + (dolist (bookmark bookmarks) + (tla-bookmarks-add-partner bookmark partner t)) + (tla-bookmarks-save-to-file) + (save-window-excursion + (tla-bookmarks)))) + +(defun tla-bookmarks-add-partners-from-file () + "Add a partner to the current or marked bookmarks." + (interactive) + (let ((bookmarks (or tla-bookmarks-marked-list + (list (ewoc-data (ewoc-locate + tla-bookmarks-cookie)))))) + (dolist (bookmark bookmarks) + (let ((partners (tla-partner-list + (tla-bookmarks-read-local-tree bookmark)))) + (dolist (partner partners) + (tla-bookmarks-add-partner bookmark partner t)))) + (tla-bookmarks-save-to-file) + (save-window-excursion + (tla-bookmarks)))) + +(defun tla-bookmarks-write-partners-to-file () + "Add the partners recorded in the bookmarks to the partner file." + (interactive) + (let ((bookmarks (or tla-bookmarks-marked-list + (list (ewoc-data (ewoc-locate + tla-bookmarks-cookie)))))) + (dolist (bookmark bookmarks) + (let* ((local-tree (tla-bookmarks-read-local-tree bookmark)) + (partners (tla-partner-list local-tree))) + (with-current-buffer + (tla-partner-find-partner-file local-tree) + (goto-char (point-max)) + (when (not (eq (point) (line-beginning-position))) + (newline)) + (dolist (partner (cdr (assoc 'partners (cdr bookmark)))) + (unless (member partner partners) + (insert partner "\n"))) + (and (buffer-modified-p) + (progn (switch-to-buffer (current-buffer)) + (y-or-n-p (format "Save file %s? " + (buffer-file-name)))) + (write-file (buffer-file-name)))))))) + + +(defun tla-bookmarks-delete-partner-interactive () + "Delete a partner from the current or marked bookmarks." + (interactive) + (let* ((bookmarks (or tla-bookmarks-marked-list + (list (ewoc-data (ewoc-locate + tla-bookmarks-cookie))))) + (choices (apply 'append + (mapcar (lambda (x) + (cdr (assoc 'partners + (cdr x)))) + bookmarks))) + (choices-alist (mapcar (lambda (x) (list x)) choices)) + (partner (dvc-completing-read "Partner to remove: " choices-alist))) + (dolist (bookmark bookmarks) + (tla-bookmarks-delete-partner bookmark partner t)) + (tla-bookmarks-save-to-file) + (save-window-excursion + (tla-bookmarks)))) + +(defun tla-bookmarks-add-tree-interactive () + "Add a local tree to the current or marked bookmarks." + (interactive) + (let ((bookmarks (or tla-bookmarks-marked-list + (list (ewoc-data (ewoc-locate + tla-bookmarks-cookie))))) + (local-tree (dvc-read-directory-name "Local tree to add: "))) + (unless (file-exists-p (concat (file-name-as-directory local-tree) "{arch}")) + (error (concat local-tree " is not an arch local tree."))) + (dolist (bookmark bookmarks) + (tla-bookmarks-add-tree bookmark local-tree t)) + (tla-bookmarks-save-to-file) + (save-window-excursion + (tla-bookmarks)))) + +(defun tla-bookmarks-delete-tree-interactive () + "Add a local tree to the current or marked bookmarks." + (interactive) + (let* ((bookmarks (or tla-bookmarks-marked-list + (list (ewoc-data (ewoc-locate + tla-bookmarks-cookie))))) + (choices (apply 'append + (mapcar (lambda (x) + (cdr (assoc 'local-tree + (cdr x)))) + bookmarks))) + (choices-alist (mapcar (lambda (x) (list x)) choices)) + (local-tree (dvc-completing-read "Local tree to remove: " + choices-alist))) + (dolist (bookmark bookmarks) + (tla-bookmarks-delete-tree bookmark local-tree t)) + (tla-bookmarks-save-to-file) + (save-window-excursion + (tla-bookmarks)))) + +(defun tla-bookmarks-list-groups () + "Return the list of groups currently used by bookmarks." + (let ((list (apply 'append + (mapcar (lambda (x) + (cdr (assoc 'groups + (cdr x)))) + tla-bookmarks-alist))) + result) + ;; Make elements unique + (dolist (elem list) + (add-to-list 'result elem)) + result)) + +(defun tla-bookmarks-add-group-interactive () + "Add a group entry in the current or marked bookmarks." + (interactive) + (let* ((bookmarks (or tla-bookmarks-marked-list + (list (ewoc-data (ewoc-locate + tla-bookmarks-cookie))))) + (group (dvc-completing-read "Group of bookmarks: " + (mapcar (lambda (x) (list x)) + (tla-bookmarks-list-groups))))) + (dolist (bookmark bookmarks) + (tla-bookmarks-add-group bookmark group t))) + (tla-bookmarks-save-to-file) + (save-window-excursion + (tla-bookmarks))) + + +(defun tla-bookmarks-delete-group-interactive () + "Delete a group of bookmark entry from the current or marked bookmarks." + (interactive) + (let* ((bookmarks (or tla-bookmarks-marked-list + (list (ewoc-data (ewoc-locate + tla-bookmarks-cookie))))) + (choices (apply 'append + (mapcar (lambda (x) + (cdr (assoc 'groups + (cdr x)))) + bookmarks))) + (choices-alist (mapcar (lambda (x) (list x)) choices)) + (group (dvc-completing-read "Group to remove: " choices-alist))) + (dolist (bookmark bookmarks) + (tla-bookmarks-delete-group bookmark group t))) + (tla-bookmarks-save-to-file) + (save-window-excursion + (tla-bookmarks))) + +(defun tla-bookmarks-select-by-group (group) + "Select all bookmarks in GROUP." + (interactive (list (dvc-completing-read + "Group to select: " + (mapcar (lambda (x) (list x)) + (tla-bookmarks-list-groups))))) + (dolist (bookmark tla-bookmarks-alist) + (when (member group (cdr (assoc 'groups bookmark))) + (add-to-list 'tla-bookmarks-marked-list bookmark)) + ) + (ewoc-refresh tla-bookmarks-cookie)) + +(defun tla-bookmarks-add-nickname-interactive () + "Add a nickname to the current bookmark." + (interactive) + (let* ((bookmark (ewoc-data (ewoc-locate + tla-bookmarks-cookie))) + (prompt (format "Nickname for %s: " (tla--name-construct + (cdr (assoc 'location bookmark)))))) + (tla-bookmarks-add-nickname bookmark (read-string prompt) t) + (tla-bookmarks-save-to-file) + (save-window-excursion + (tla-bookmarks)))) + +(defun tla-bookmarks-delete-nickname-interactive () + "Delete the nickname of the current bookmark." + (interactive) + (let* ((bookmark (ewoc-data (ewoc-locate + tla-bookmarks-cookie))) + (nickname (cadr (assoc 'nickname bookmark)))) + (tla-bookmarks-delete-nickname bookmark nickname t) + (tla-bookmarks-save-to-file) + (save-window-excursion + (tla-bookmarks)))) + +(defvar tla-buffer-bookmark nil + "The bookmark manipulated in the current buffer.") + +(defun tla-bookmarks-edit () + "Edit the bookmark at point." + (interactive) + (let* ((elem (ewoc-locate tla-bookmarks-cookie)) + (data (ewoc-data elem))) + (pop-to-buffer (concat "*xtla bookmark " (car data) "*")) + (erase-buffer) + (emacs-lisp-mode) + (make-local-variable 'tla-buffer-bookmark) + (setq tla-buffer-bookmark elem) + (insert ";; Edit the current bookmark. C-c C-c to finish\n\n") + (pp data (current-buffer)) + (goto-char (point-min)) (forward-line 2) (forward-char 2) + (local-set-key [(control ?c) (control ?c)] + (lambda () (interactive) + (goto-char (point-min)) + (let* ((newval (read (current-buffer))) + (elem tla-buffer-bookmark) + (oldname (car (ewoc-data elem)))) + (kill-buffer (current-buffer)) + (pop-to-buffer (dvc-get-buffer-create tla-arch-branch + 'bookmark)) + (setcar (ewoc-data elem) (car newval)) + (setcdr (ewoc-data elem) (cdr newval)) + (let ((list tla-bookmarks-alist) + newlist) + (while list + (if (string= (caar list) oldname) + (setq newlist (cons newval newlist)) + (setq newlist (cons (car list) newlist))) + (setq list (cdr list))) + (setq tla-bookmarks-alist (reverse newlist))) + (tla-bookmarks-save-to-file) + (save-excursion (tla-bookmarks))))))) + +(defun tla-bookmarks-get-partner-versions (version) + "Return version lists of partners in bookmarks for VERSION. +Each version in the returned list has a list form. +If no partner, return nil. +VERSION is a fully qualified version string or a list." + (tla-bookmarks-load-from-file) + (when (consp version) + (setq version (tla--name-mask version t + t t t t))) + (let* ((bookmark (tla-bookmarks-find-bookmark version)) + (partners (cdr (assoc 'partners bookmark)))) + (mapcar 'tla--name-split partners))) + +;; +;; Archives +;; + +(defvar tla-archives-list-cookie nil) + +;;;###autoload +(defun tla-archives () + "Start the archive browser." + (interactive) + (dvc-switch-to-buffer (dvc-get-buffer-create tla-arch-branch 'archives)) + (tla--archive-tree-build-archives) + (let ((a-list (reverse tla--archive-tree)) + (inhibit-read-only t) + (my-default-archive (tla-my-default-archive)) + defaultp + archive-name + archive-locations + p) + (toggle-read-only -1) + (tla-archive-list-mode) + (set (make-local-variable 'tla-archives-list-cookie) + (ewoc-create (dvc-ewoc-create-api-select + #'tla-archives-list-printer))) + (erase-buffer) + (while a-list + (setq archive-name (caar a-list) + archive-locations (car (cdar a-list)) + a-list (cdr a-list) + defaultp (string= archive-name my-default-archive)) + (if defaultp (setq p (point))) + (ewoc-enter-last tla-archives-list-cookie + (list archive-name + archive-locations + defaultp))) + (let ((inhibit-read-only 1)) + (ewoc-refresh tla-archives-list-cookie) + (if (> (point) (point-min)) + (delete-backward-char 1))) + (when p (goto-char p)))) + +(defun tla-archives-list-printer (item) + "Add an entry for ARCHIVE at LOCATIONS to the archive list. +If DEFAULTP is non-nil, this item will be rendered as the default +archive." + (let ((archive (nth 0 item)) + (locations (nth 1 item)) + (defaultp (nth 2 item)) + (start-pos (point)) + overlay) + (insert (if defaultp dvc-mark " ") + " " + (dvc-face-add-with-condition + defaultp + archive 'dvc-marked 'tla-archive-name)) + (newline) + (dolist (location locations) + (insert " " location "\n")) + (backward-delete-char 1) + (setq overlay (make-overlay start-pos (point))) + (overlay-put overlay 'category 'tla-default-button) + (overlay-put overlay 'keymap tla-archive-archive-map) + (overlay-put overlay 'tla-archive-info archive))) + +(defun tla-archives-goto-archive-by-name (name) + "Jump to the archive named NAME." + (unless (eq (current-buffer) (dvc-get-buffer tla-arch-branch + 'archives)) + (error "`tla-archives-goto-archive-by-name' can only be called in *{tla|baz}-archives* buffer")) + (goto-char (point-min)) + (search-forward name) + (beginning-of-line)) + +(defun tla-get-archive-info (&optional property) + "Get some PROPERTY of the archive at point in an archive list buffer." + (unless property + (setq property 'tla-archive-info)) + (let ((overlay (car (overlays-at (point))))) + (when overlay + (overlay-get overlay property)))) + +(defun tla-my-default-archive (&optional new-default) + "Set or get the default archive. +When called with a prefix argument NEW-DEFAULT: Ask the user for the new +default archive. +If NEW-DEFAULT IS A STRING: Set the default archive to this string. +When called with no argument: return the name of the default argument. +When called interactively, with no argument: Show the name of the default archive." + (interactive "P") + (when (or (numberp new-default) (and (listp new-default) (> (length new-default) 0))) + (setq new-default (car (tla-name-read nil 'prompt)))) + (let ((i-p (interactive-p))) + (cond ((stringp new-default) + (message "Setting arch default archive to: %s" new-default) + (tla--run-tla-sync (list "my-default-archive" new-default) + :finished 'dvc-null-handler)) + (t + (tla--run-tla-sync '("my-default-archive") + :finished + (dvc-capturing-lambda (output error status arguments) + (let ((result (dvc-buffer-content output))) + (when (capture i-p) + (message "Default arch archive: %s" + result)) + result)) + :error + (dvc-capturing-lambda (output error status arguments) + (if (eq status 1) + (if (capture i-p) + (message "default archive not set") + "") + (dvc-default-error-function + output error status arguments)))))))) + +(defun tla-whereis-archive (&optional archive) + "Call tla whereis-archive on ARCHIVE." + (interactive "P") + (let (location) + (unless archive + (setq archive (tla--name-mask (tla-name-read "Archive: " 'prompt) + t + :archive))) + (setq location + (tla--run-tla-sync (list "whereis-archive" archive) + :finished + (lambda (output error status arguments) + (dvc-buffer-content output)))) + (when (interactive-p) + (message "archive location for %s: %s" archive location)) + location)) + +(defvar tla--ffap-url-regexp + (if (ffap-url-p "sftp://host") + ffap-url-regexp + (concat + "\\`\\(" + "news\\(post\\)?:\\|mailto:\\|file:" ; no host ok + "\\|" + "\\(s?ftp\\|https?\\|telnet\\|gopher\\|www\\|wais\\)://" ; needs host + "\\)." ; require one more character + )) + "If ffap-url-regexp doesn't match sftp URL, use another value that +matches it.") + +(defun tla--read-location (prompt) + "Read the location for an archive operation, prompting with PROMPT. +The following forms are supported: +* local path: e.g.: ~/archive2004 +* ftp path: e.g.: ftp://user:passwd@host.name.com/remote-path +* sftp path: e.g.: sftp://user:passwd@host.name.com/remote-path +* HTTP/WebDAV path: e.g.: http://user:passwd@host.name.com/remote-path" + (let* ((ffap-url-regexp tla--ffap-url-regexp) + (l (ffap-read-file-or-url prompt (ffap-url-at-point)))) + (if (string-match "^~" l) + (expand-file-name l) + l))) + +;;;###autoload +(defun tla-register-archive () + "Call `tla--register-archive' interactively and `tla-archives' on success." + (interactive) + (let* ((result (call-interactively 'tla--register-archive)) + (archive-registered (nth 0 result)) + (archive (nth 1 result)) + (tla-response (nth 3 result))) + (when archive-registered + (tla-archives) + (tla-archives-goto-archive-by-name + (progn + (message tla-response) ; inform the user about the response from tla + (if (string-match ".+: \\(.+\\)" tla-response) + (match-string-no-properties 1 tla-response) + archive))) + (dvc-flash-line)))) + +(defun tla--register-archive (location &optional archive) + "Register arch archive. +LOCATION should be either a local directory or a remote path. +When ffap is available the url at point is suggested for LOCATION. +ARCHIVE is the name is archive. If ARCHIVE is not given or an empty string, +the default name is used. +The return value is a list. +- The first element shows whether the archive is registered or not; t means that + it is registered, already means that the archive was already + registered, and nil means that it is not registered. +- The second element shows archive name. +- The third element shows archive location. +- The fourth element is the command output string." + (interactive (list (tla--read-location "Location: ") + (when (eq tla-arch-branch 'tla) + (read-string "Archive (empty for default): ")))) + (if (and archive (eq 0 (length archive))) + (setq archive nil)) + (let ((archive-registered nil) + (tla-response nil)) + (tla--run-tla-sync (list "register-archive" archive location) + :finished + (lambda (output error status arguments) + (setq tla-response (dvc-get-process-output)) + (setq archive-registered t) + (message "%s (=> %s)" + (dvc-buffer-content output) location)) + :error + (lambda (output error status arguments) + (setq tla-response (dvc-get-error-output)) + (if (eq status 2) ;; already registered + (setq archive-registered 'already) + (dvc-default-error-function output error + status + arguments)))) + (list archive-registered archive location tla-response))) + +(defun tla--unregister-archive (archive ask-for-confirmation) + "Delete the registration of ARCHIVE. +When ASK-FOR-CONFIRMATION is non nil, ask the user for confirmation." + (unless (tla--archive-tree-get-archive archive) + (tla--archive-tree-build-archives)) + (let ((location (cadr (tla--archive-tree-get-archive archive)))) + (when (or (not ask-for-confirmation) + (yes-or-no-p (format "Delete the registration of %s(=> %s)? " archive location))) + (tla--run-tla-sync + (list "register-archive" "--delete" archive) + :finished + (lambda (output error status arguments) + (message "Deleted the registration of %s (=> %s)" archive location)))))) + +(defun tla--edit-archive-location (archive) + "Edit the location of ARCHIVE." + (let* ((old-location (tla-whereis-archive archive)) + (new-location (read-string (format "New location for %s: " archive) old-location))) + (unless (string= old-location new-location) + (tla--unregister-archive archive nil) + (tla--register-archive new-location archive)))) + +;;;###autoload +(defun tla-make-archive () + "Call `tla--make-archive' interactively then call `tla-archives'." + (interactive) + (call-interactively 'tla--make-archive) + (tla-archives)) + +(defun tla--make-archive-read-location () + (let ((path-ok nil) + location) + (while (not path-ok) + (setq location (tla--read-location "Location: ")) + (setq path-ok t) + (when (eq 'local (tla--location-type location)) + (setq location (expand-file-name location)) + (when (file-directory-p location) + (message "directory already exists: %s" location) + (setq path-ok nil) + (sit-for 1)) + (when (not (file-directory-p + (file-name-directory location))) + (message "parent directory doesn't exists for %s" + location) + (setq path-ok nil) + (sit-for 1)))) + location)) + +(defun tla--make-archive (name location &optional signed listing) + "Create a new arch archive. +NAME is the global name for the archive. It must be an +email address with a fully qualified domain name, optionally +followed by \"--\" and a string of letters, digits, periods +and dashes. +LOCATION specifies the path, where the archive should be created. + +Examples for name are: +foo.bar@flups.com--public +foo.bar@flups.com--public-2004 + +If SIGNED is non-nil, the archive will be created with --signed. +If LISTING is non-nil, the archive will be created with --listing + (Usefull for http mirrors)." + (interactive + (list (read-string "Archive name: ") + (tla--make-archive-read-location) + (y-or-n-p "Sign the archive? ") + (y-or-n-p "Create .listing files? "))) + (tla--run-tla-sync (list "make-archive" + (when listing "--listing") + (when signed "--signed") + name location) + :error + (lambda (output error status arguments) + (dvc-show-error-buffer error) + (dvc-show-last-process-buffer) + (error (format "%s failed: exits-status=%s" + (tla-arch-branch-name) + status))))) + +(defun tla-mirror-archive (&optional archive location mirror signed + listing) + "Create a mirror for ARCHIVE, at location LOCATION, named MIRROR. +If SIGNED is non-nil, the archive will be signed. +If LISTING is non-nil, .listing files will be created (useful for HTTP +mirrors)." + (interactive) + (let* ((archive (or archive (car (tla-name-read "Archive to mirror: " 'prompt)))) + (location (or location (tla--read-location + (format "Location of the mirror for %s: " archive)))) + ;;todo: take a look ath the mirror-list, when suggesting a mirror name + ;;(mirror-list (tla--get-mirrors-for-archive archive)) + (mirror (unless (tla-use-baz-archive-registration) + (or mirror (read-string "Name of the mirror: " + (concat archive + "-MIRROR"))))) + (signed (or signed (y-or-n-p "Sign mirror? "))) + (listing (or listing (y-or-n-p "Create .listing files? ")))) + (tla--run-tla-sync (list "make-archive" + (when listing "--listing") + (when signed "--signed") + "--mirror" + archive mirror location)))) + +(defun tla-mirror-from-archive (&optional from-archive location) + "Create a mirror-from archive for FROM-ARCHIVE, at location LOCATION. +The archive name FROM-ARCHIVE must end with \"-SOURCE\"." + (interactive) + (let* ((from-archive (or from-archive + (car (tla-name-read "Mirror from archive: " 'prompt)))) + (location (or location (read-string + (format "Location of the mirror for %s : " from-archive))))) + (unless (eq (tla--archive-type from-archive) 'source) + (error "%s is not SOURCE archive" from-archive)) + (tla--run-tla-sync (list "make-archive" + "--mirror-from" + from-archive location)))) + +(defun tla--get-mirrors-for-archive (archive) + "Get a list of all mirrors for the given ARCHIVE." + (tla--archive-tree-build-archives) + (delete nil (mapcar '(lambda (elem) + (let ((a-name (car elem))) + (when (and (eq (tla--archive-type a-name) 'mirror) + (string= archive + (substring a-name 0 (length archive)))) + a-name))) + tla--archive-tree))) + +;; in tla-browse use: (tla--name-archive (tla--widget-node-get-name)) +;; to get the name of an archive. +;; in tla-archives: use (tla-get-archive-info) + +;; (tla--get-mirrors-for-archive (tla-get-archive-info)) +;; (tla--get-mirrors-for-archive "xsteve@nit.at--public") + +(defun tla--mirror-base-name (archive) + "Return the base name of the mirror ARCHIVE." + (when (eq (tla--archive-type archive) 'mirror) + (substring archive 0 (string-match "-MIRROR.*$" archive)))) + +(defun tla-use-as-default-mirror (archive) + "Use the ARCHIVE as default mirror. +This function checks, if ARCHIVE is a mirror (contains -MIRROR). +The default mirror ends with -MIRROR. Other mirrors have some +other characters after -MIRROR (e.g.: -MIRROR-2. +This function swaps the location of that -MIRROR and the -MIRROR-2. +The effect of the swapping is, that the mirroring functions work +per default on the default mirror." + (interactive (list (tla--name-archive (tla-name-read "Mirror archive name: " 'prompt)))) + (unless (eq (tla--archive-type archive) 'mirror) + (error "%s is not a mirror" archive)) + (if (string-match "-MIRROR$" archive) + (message "%s is already the default mirror." archive) + (let* ((archive-base-name (tla--mirror-base-name archive)) + (mirror-list (tla--get-mirrors-for-archive archive-base-name)) + (default-mirror (concat archive-base-name "-MIRROR")) + (default-mirror-present (member default-mirror mirror-list)) + (archive-location (tla-whereis-archive archive)) + (default-mirror-location (and default-mirror-present + (tla-whereis-archive default-mirror)))) + (if default-mirror-present + (message "swapping mirrors %s <-> %s." archive default-mirror) + (message "using %s as default mirror." archive)) + (tla--unregister-archive archive nil) + (when default-mirror-present + (tla--unregister-archive default-mirror nil)) + (tla--register-archive archive-location default-mirror) + (when default-mirror-present + (tla--register-archive default-mirror-location archive))))) + + +(defun tla--archive-convert-to-source-archive (archive &optional location) + "Change the name of ARCHIVE to ARCHIVE-SOURCE. +Sets the archive location to LOCATION." + (unless location + (setq location (nth 1 (tla--archive-tree-get-archive archive)))) + (unless location + (error "Location for `%s' is unknown" archive)) + (when (eq 'source (tla--archive-type archive)) + (error "%s is already source" archive)) + ;; (unless (eq 'http (tla--location-type location)) + ;; (error "Read only archive is supported in xtla: " location)) + (tla--unregister-archive archive nil) + (tla--register-archive location (concat archive "-SOURCE"))) + +;; +;; Categories +;; +(defun tla-categories (archive) + "List the categories of ARCHIVE." + (interactive (list (tla--name-archive + (tla-name-read nil 'prompt)))) + (unless archive + (setq archive (tla-my-default-archive))) + (tla--archive-tree-build-categories archive) + (dvc-switch-to-buffer (dvc-get-buffer-create tla-arch-branch 'categories archive)) + (let ((list (cddr (tla--archive-tree-get-archive archive))) + category start-pos overlay) + (toggle-read-only -1) + (erase-buffer) + ;; TODO: button to invoke tla-archives. + (insert (format "Archive: %s\n%s\n" archive + (make-string (+ (length archive) + (length "Archive: ")) ?=))) + (save-excursion + (while list + (setq category (car (car list)) + start-pos (point) + list (cdr list)) + (insert " " (dvc-face-add category 'tla-category-name)) + (newline) + (setq overlay (make-overlay start-pos (point))) + (overlay-put overlay 'category 'tla-default-button) + (overlay-put overlay 'keymap tla-category-category-map) + (overlay-put overlay 'tla-category-info category) + ) + (delete-backward-char 1))) + (tla-category-list-mode) + (set (make-local-variable 'tla-buffer-archive-name) + archive)) + +(defun tla-make-category (archive category) + "In ARCHIVE, create CATEGORY." + (interactive (let ((l (tla-name-read "New Category: " 'prompt 'prompt))) + (list (tla--name-archive l) + (tla--name-category l)))) + (tla--run-tla-sync (list "make-category" + (tla--name-construct archive category))) + (let ((tla-buffer-archive-name archive)) + (run-hooks 'tla-make-category-hook))) + +;; +;; Branches +;; +(defun tla-branches (archive category) + "Display the branches of ARCHIVE/CATEGORY." + (interactive (let ((l (tla-name-read nil 'prompt 'prompt))) + (list (tla--name-archive l) + (tla--name-category l)))) + (tla--archive-tree-build-branches archive category) + (dvc-switch-to-buffer (dvc-get-buffer-create tla-arch-branch + 'branches (tla--name-construct + archive category))) + (let ((list (cdr (tla--archive-tree-get-category archive category))) + alength + clength + branch + start-pos + overlay) + (toggle-read-only -1) + (erase-buffer) + ;; TODO: button to invoke tla-categories and tla-archives + (setq alength (+ (length archive) (length "Archive: ")) + clength (+ (length category) (length "Category: "))) + (insert (format "Archive: %s\nCategory: %s\n%s\n" archive category + (make-string (max alength clength) ?=))) + (save-excursion + (while list + (setq branch (car (car list)) + start-pos (point) + list (cdr list)) + (insert " " (dvc-face-add (if (string= branch "") + "" branch) + 'tla-branch-name)) + (newline) + (setq overlay (make-overlay start-pos (point))) + (overlay-put overlay 'category 'tla-default-button) + (overlay-put overlay 'keymap tla-branch-branch-map) + (overlay-put overlay 'tla-branch-info branch)) + (delete-backward-char 1))) + (tla-branch-list-mode) + (set (make-local-variable 'tla-buffer-archive-name) + archive) + (set (make-local-variable 'tla-buffer-category-name) + category)) + +(defun tla-make-branch (archive category branch) + "Make a new branch in ARCHIVE/CATEGORY called BRANCH." + (interactive (let ((l (tla-name-read "New Branch: " + 'prompt 'prompt 'prompt))) + (list (tla--name-archive l) + (tla--name-category l) + (tla--name-branch l)))) + (tla--run-tla-sync (list "make-branch" + (tla--name-construct + archive category branch))) + (let ((tla-buffer-archive-name archive) + (tla-buffer-category-name category)) + (run-hooks 'tla-make-branch-hook))) + +;; +;; Versions +;; +(defun tla-versions (archive category branch) + "Display the versions of ARCHIVE/CATEGORY in BRANCH." + (interactive (let ((l (tla-name-read nil + 'prompt 'prompt 'prompt))) + (list (tla--name-archive l) + (tla--name-category l) + (tla--name-branch l)))) + (tla--archive-tree-build-versions archive category branch) + (dvc-switch-to-buffer (dvc-get-buffer-create tla-arch-branch + 'versions (tla--name-construct archive + category branch))) + (let ((list (cdr (tla--archive-tree-get-branch + archive category branch))) + alength + clength + blength + version + start-pos + overlay) + (toggle-read-only -1) + (erase-buffer) + ;; TODO: button to invoke tla-categories and tla-archives + (setq alength (+ (length archive) (length "Archive: ")) + clength (+ (length category) (length "Category: ")) + blength (+ (length branch) (length "Branch: "))) + (insert (format "Archive: %s\nCategory: %s\nBranch: %s\n%s\n" + archive category branch + (make-string (max alength clength blength) ?=))) + (save-excursion + (while list + (setq version (car (car list)) + start-pos (point) + list (cdr list)) + (insert " " (dvc-face-add version 'tla-version-name)) + (newline) + (setq overlay (make-overlay start-pos (point))) + (overlay-put overlay 'category 'tla-default-button) + (overlay-put overlay 'keymap tla-version-version-map) + (overlay-put overlay 'tla-version-info version)) + (delete-backward-char 1))) + (tla-version-list-mode) + (set (make-local-variable 'tla-buffer-archive-name) archive) + (set (make-local-variable 'tla-buffer-category-name) category) + (set (make-local-variable 'tla-buffer-branch-name) branch)) + +(defun tla-make-version (archive category branch version) + "In ARCHIVE/CATEGORY, add a version to BRANCH called VERSION." + (interactive (let ((l (tla-name-read "Version: " + 'prompt 'prompt 'prompt 'prompt))) + (list (tla--name-archive l) + (tla--name-category l) + (tla--name-branch l) + (tla--name-version l)))) + + (tla--run-tla-sync (list "make-version" + (tla--name-construct + archive category branch version))) + (let ((tla-buffer-archive-name archive) + (tla-buffer-category-name category) + (tla-buffer-branch-name branch)) + (run-hooks 'tla-make-version-hook))) + +;; +;; Revisions +;; +(defun tla-revision-list-entry-patch-printer (elem) + "Print an element ELEM of the revision list." + (let* ((struct (dvc-revlist-entry-patch-struct elem)) + (merged-by (dvc-revlist-entry-patch-merged-by elem)) + (unmerged (eq merged-by 'nobody))) + (insert (if (dvc-revlist-entry-patch-marked elem) + (concat " " dvc-mark) " ") + ;; The revision is in library? + (if (and tla-revisions-shows-library + (apply 'tla--revlib-tree-get-revision + (tla--revision-revision struct))) + ;; + ;; (apply 'tla-library-find + ;; (append (car (cddr elem) '(t))) + + "L " " ") + (dvc-face-add (tla--name-construct + (tla--revision-revision struct)) + (if unmerged 'dvc-unmerged + 'dvc-revision-name) + 'tla-revision-revision-map + tla-revision-revision-menu) + (if unmerged (dvc-face-add " [NOT MERGED]" + 'dvc-unmerged) + "")) + (let ((summary (tla--revision-summary struct)) + (creator (tla--revision-creator struct)) + (date (tla--revision-date struct))) + (when (and summary dvc-revisions-shows-summary) + (insert "\n " summary)) + (when (and creator dvc-revisions-shows-creator) + (insert "\n " creator)) + (when (and date dvc-revisions-shows-date) + (insert "\n " date))) + (when (and tla-revisions-shows-merges + (tla--revision-merges struct) + (not (null (car (tla--revision-merges struct))))) + (insert "\n Merges:") + (dolist (elem (tla--revision-merges struct)) + (insert "\n " elem))) + (when tla-revisions-shows-merged-by + (cond ((null merged-by) nil) + ((listp merged-by) + (insert "\n Merged-by:") + (dolist (elem merged-by) + (insert "\n " elem))))))) + +;;;###autoload +(defun tla-tree-revisions-goto (root) + "Goto tree revisions buffer or call `tla-tree-revisions'." + (interactive (list (dvc-read-project-tree-maybe + "Revisions for tree: "))) + (let* ((default-directory root) + (buffer (dvc-get-buffer tla-arch-branch 'revisions + (tla-tree-version)))) + (if buffer + (dvc-switch-to-buffer buffer) + (tla-tree-revisions root)))) + +;;;###autoload +(defun tla-tree-revisions (root) + "Call `tla-revisions' in the current tree." + (interactive (list (dvc-read-project-tree-maybe + "Revisions for tree: "))) + (let* ((default-directory root) + (version (tla-tree-version-list default-directory))) + (unless version + (error "Not in a project tree")) + (apply 'tla-revisions version))) + +;;;###autoload +(defun tla-revisions (archive category branch version + &optional unused from-revlib) + "List the revisions of ARCHIVE/CATEGORY--BRANCH--VERSION. + +UNUSED is left here to keep the position of FROM-REVLIB" + (interactive (let ((l (tla-name-read "Version: " 'prompt 'prompt 'prompt 'prompt))) + (list + (tla--name-archive l) + (tla--name-category l) + (tla--name-branch l) + (tla--name-version l)))) + (let ((dvc-temp-current-active-dvc (dvc-current-active-dvc)) + (output-buf (dvc-get-buffer-create tla-arch-branch + 'revisions + (tla--name-construct + archive category branch version))) + separator) + (with-current-buffer output-buf + (tla-revision-list-mode) + (toggle-read-only -1) + (setq dvc-buffer-refresh-function 'tla-revision-refresh) + (set (make-local-variable 'tla-buffer-archive-name) archive) + (set (make-local-variable 'tla-buffer-category-name) category) + (set (make-local-variable 'tla-buffer-branch-name) branch) + (set (make-local-variable 'tla-buffer-version-name) version) + (setq separator (dvc-face-add + (make-string + (max (+ (length archive) + (length category) + (length branch) + (length version) + (length " /------patch-4242"))) + ?\ ) + 'dvc-separator)) + (ewoc-set-hf dvc-revlist-cookie + (tla--revisions-header archive category branch version + from-revlib separator) + (concat "\n" separator))) + (when dvc-switch-to-buffer-first + (dvc-switch-to-buffer output-buf)) + ;; TODO: Consider the case where (and update-display from-revlib) + ;; is t. + (funcall + (if from-revlib 'tla--revlib-tree-build-revisions + 'tla--archive-tree-build-revisions) + archive category branch version nil nil nil + (dvc-capturing-lambda () + (unless dvc-switch-to-buffer-first + (dvc-switch-to-buffer (capture output-buf))) + (let ((list (cdr (funcall (if (capture from-revlib) + 'tla--revlib-tree-get-version + 'tla--archive-tree-get-version) + (capture archive) + (capture category) + (capture branch) + (capture version))))) + (with-current-buffer (capture output-buf) + (if tla-revisions-shows-library + (tla--revlib-tree-build-revisions + (capture archive) + (capture category) + (capture branch) + (capture version) nil t)) + (while list + (let* ((rev-list (list (capture archive) + (capture category) + (capture branch) + (capture version) + (caar list))) + (rev-struct (or (cdar list) + (make-tla--revision + :revision rev-list)))) + (ewoc-enter-last dvc-revlist-cookie + (list 'entry-patch + (make-dvc-revlist-entry-patch + :dvc 'tla + :struct rev-struct + :rev-id `(tla (revision ,rev-list)))))) + (setq list (cdr list))) + (ewoc-refresh dvc-revlist-cookie) + (toggle-read-only t))))))) + +(defun tla--revisions-header (archive category branch version from-revlib separator) + "Construct a header for the revision ARCHIVE/CATEGORY--BRANCH--VERSION. +Mark the revision as contained in FROM-REVLIB and use SEPARATOR to separate +the entries." + (concat + "Version: " + (dvc-face-add archive 'tla-archive-name) "/" + (dvc-face-add category 'tla-category-name) "--" + (dvc-face-add branch 'tla-branch-name) "--" + (dvc-face-add version 'tla-version-name) "\n" + "In Revision Library: " (dvc-face-add (if from-revlib "Yes" "No") 'bold) + "\n" + separator "\n")) + +(defun tla-revisions-string (string) + (let* ((list (tla--name-split string)) + (archive (nth 0 list)) + (category (nth 1 list)) + (branch (nth 2 list)) + (version (nth 3 list))) + (tla-revisions archive category branch version))) + +(defun tla-versions-string (string) + (let* ((list (tla--name-split string)) + (archive (nth 0 list)) + (category (nth 1 list)) + (branch (nth 2 list))) + (tla-versions archive category branch))) + +(defun tla-branches-string (string) + (let* ((list (tla--name-split string)) + (archive (nth 0 list)) + (category (nth 1 list))) + (tla-branches archive category))) + +(defun tla-categories-string (string) + (let* ((list (tla--name-split string)) + (archive (nth 0 list))) + (tla-categories archive))) + +;;;###autoload +(defun tla-missing-1 (local-tree location) + "Search in directory LOCAL-TREE for missing patches from LOCATION. +If the current buffers default directory is in an arch managed tree use that +one unless called with a prefix arg. In all other cases prompt for the local +tree and the location." + (interactive (let ((dir + (or (if (not current-prefix-arg) + (tla-tree-root nil t)) + (expand-file-name + (dvc-read-directory-name + "Search missing patches in directory: " + default-directory default-directory t nil))))) + (list dir + (let ((default-directory dir)) + (if current-prefix-arg + (tla-name-read + "From location: " + 'prompt 'prompt 'prompt 'prompt) + (tla-tree-version)))))) + (let ((dir (tla-tree-root))) + (pop-to-buffer (dvc-get-buffer-create tla-arch-branch 'tla-missing)) + (cd dir)) + (let ((dvc-temp-current-active-dvc (dvc-current-active-dvc))) + (tla-revision-list-mode)) + (setq dvc-buffer-refresh-function 'tla-missing-refresh) + (set (make-local-variable 'tla-missing-buffer-todolist) + `((missing ,local-tree ,(tla--name-construct location) nil))) + (tla-missing-refresh)) + +(defun tla-missing-show-all-revisions () + "Show all revisions for the current entry in the *{tla|baz}-missing* buffer." + (interactive) + (if tla-missing-buffer-todolist ;; we are in a tla-missing buffer + (apply 'tla-revisions (tla--name-split (cadr (tla--revision-get-version-info-at-point)))) + (message "Not in the *%s-missing* buffer, already all revisions visible." + (tla-arch-branch-name)))) +;; +;; Rbrowse interface +;; +(defun tla-browse-archive (archive) + "Browse ARCHIVE. + +The interface is rather poor, but tla-browse does a better job +anyway ..." + (interactive (let ((l (tla-name-read nil 'prompt))) + (list (tla--name-archive l)))) + (unless archive + (setq archive (tla-my-default-archive))) + (tla--run-tla-sync (list "rbrowse" archive))) + +(defun tla--read-config-file (prompt-file) + "Interactively read the arguments of `tla-build-config'and `tla-cat-config'. + +The string PROMPT-FILE will be used when prompting the user for a file." + (let* ((file (read-file-name prompt-file + nil + (when (not (eq major-mode 'tla-bconfig-mode)) + default-directory) + t + (when (eq major-mode 'tla-bconfig-mode) + (tla-file-name-relative-to-root + (buffer-file-name))))) + (buffer (get-file-buffer file)) + (relative-conf-file + (tla-file-name-relative-to-root file))) + (when (and buffer + (buffer-modified-p buffer) + (y-or-n-p (format "Save buffer %s" + (buffer-name buffer)))) + (save-buffer buffer)) + (list (tla-tree-root file) relative-conf-file))) + +(defun tla-build-config (tree-root config-file) + "Run tla build-config in TREE-ROOT, outputting to CONFIG-FILE. +CONFIG-FILE is the relative path-name of the configuration. + +When called interactively, arguments are read with the function +`dvc-read-project-tree-maybe'." + (interactive (tla--read-config-file "Build configuration: ")) + (let ((default-directory tree-root)) + (tla--run-tla-async (list "build-config" config-file)))) + +(defun tla-cat-config (tree-root config-file snap) + "Run tla cat-config in TREE-ROOT, showing CONFIG-FILE. +If SNAP is non-nil, then the --snap option of tla is used. + +When called interactively, arguments TREE-ROOT and CONFIG-FILE are +read with the function `dvc-read-project-tree-maybe'." + (interactive (append (tla--read-config-file "Cat configuration: ") + (list (y-or-n-p "Include revision number? ")))) + (let ((default-directory tree-root)) + (tla--run-tla-async + (list "cat-config" (when snap "--snap") config-file)))) + +;; +;; Get +;; +;;;###autoload +(defun tla-get (directory run-dired-p archive category branch + &optional version revision synchronously) + "Run tla get in DIRECTORY. +If RUN-DIRED-P is non-nil, display the new tree in dired. +ARCHIVE, CATEGORY, BRANCH, VERSION and REVISION make up the revision to be +fetched. +If SYNCHRONOUSLY is non-nil, run the process synchronously. +Else, run the process asynchronously." + ;; run-dired-p => t, nil, ask + (interactive (let* ((l (tla-name-read "Get: " + 'prompt 'prompt 'prompt 'maybe 'maybe)) + (name (tla--name-construct l)) + (d (dvc-read-directory-name (format "Store \"%s\" to: " name)))) + (cons d (cons 'ask l)))) + (setq directory (expand-file-name directory)) + (if (file-exists-p directory) + (error "Directory %s already exists" directory)) + (let* ((name (tla--name-construct + (if (or + ;; the name element are given in interactive form + (interactive-p) + ;; not interactive, but revision(and maybe version) is + ;; passed tothis function. + (and revision (stringp revision))) + (list archive category branch version revision) + (tla-name-read "Version--Revision for Get(if necessary): " + archive category branch + (if version version 'maybe) + 'maybe))))) + (funcall (if synchronously 'tla--run-tla-sync 'tla--run-tla-async) + (list "get" name directory) + :finished (dvc-capturing-lambda (output error status arguments) + (let ((i (dvc-status-handler output error status arguments))) + (when (zerop i) + (tla--get-do-bookmark (capture directory) (capture archive) (capture category) (capture branch) (capture version)) + (tla--do-dired (capture directory) (capture run-dired-p)))))))) + +(defun tla--get-do-bookmark (directory archive category branch version) + "Add DIRECTORY to the bookmark for ARCHIVE/CATEGORY--BRANCH--VERSION." + (let ((bookmark (tla-bookmarks-find-bookmark + (tla--name-construct + archive category branch version)))) + (when bookmark + (tla-bookmarks-add-tree bookmark directory)))) + +(defun tla--do-dired (directory run-dired-p) + "Possible run dired in DIRECTORY. +If RUN-DIRED-P is 'ask, ask the user whether to run dired. +If RUN-DIRED-P is nil, do not run dired. +Otherwise, run dired." + (setq directory (expand-file-name directory)) + (case run-dired-p + (ask (when (y-or-n-p (format "Run dired at %s? " directory)) + (dired directory))) + ('nil nil) + (t (dired directory)))) + +;; +;; Cacherev +;; +;; TODO: +;; - provide the way to run interactively +;; - show progress +;; +(defun tla-cache-revision (archive category branch version revision) + "Cache the revision named by ARCHIVE/CATEGORY--BRANCH--VERSION--REVISION." + (interactive (tla-name-read "Revision to cache: " + 'prompt 'prompt 'prompt 'prompt 'prompt)) + (let ((result (tla--run-tla-async (list "cacherev" + (tla--name-construct + archive category branch version revision))))) + ;; (dvc-show-last-process-buffer) + result)) + +;; +;; Add +;; +(defun tla-add (id &rest files) + "Using ID, add FILES to this tree. +When called interactively, ask for the file to add. +When called interactively with a prefix argument, ask additionally for the ID." + (interactive (let ((name + (read-file-name "Add file as source: " + nil nil t + (file-name-nondirectory (or + (buffer-file-name) "")))) + (id (if current-prefix-arg (read-string "id (empty for default): ") ""))) + (list id name))) + (if (and id (string= id "")) + (setq id nil)) + (setq files (mapcar 'expand-file-name files)) + (tla--run-tla-sync `(,(if (tla-has-add-id-command) "add-id" "add") + ,@(when id (list "--id" id)) . ,files))) + +;;;###autoload +(defun tla-dvc-add-files (&rest files) + "Run tla add." + (message "tla-add-files: %s" files) + (dvc-run-dvc-sync tla-arch-branch (append (list (if (tla-has-add-id-command) "add-id" "add")) files) + :finished (dvc-capturing-lambda + (output error status arguments) + (message "tla add finished")))) +;; +;; Remove +;; +(defun tla-remove (only-id &rest files) + "Remove the ids of FILES, possibly also deleting the files. +If ONLY-ID is non-nil, remove the files as well as their ids. Otherwise, +just remove the ids." + (interactive (let* ((name + (read-file-name "Remove file from archive: " + nil nil t + (file-name-nondirectory (or + (buffer-file-name) "")))) + (only-id (not (y-or-n-p (format + "Delete the \"%s\" locally also? " + name))))) + (list only-id name))) + (setq files (mapcar 'expand-file-name files)) + (dolist (f files) + (when (equal 0 (tla--run-tla-sync (list "id" "--explicit" f) + :finished 'dvc-status-handler + :error 'dvc-status-handler)) + (tla--run-tla-sync (list "delete-id" f) + :finished 'dvc-status-handler)) + (unless only-id + (delete-file f)))) + +;; +;; Move +;; +(defun tla-move (from to only-id) + "Move the file FROM to TO. +If ONLY-ID is non-nil, move only the ID file." + (interactive + (list (read-file-name "Move file: " + nil nil t + (file-name-nondirectory + (or (dvc-get-file-info-at-point) ""))) + nil nil)) + (setq to (or to (read-file-name (format "Move file %S to: " from) + nil nil nil (file-name-nondirectory from))) + only-id (if (eq only-id 'ask) + (not (y-or-n-p "Move the file locally also? ")) + only-id) + from (expand-file-name from) + to (expand-file-name to)) + (let ((buffer (get-file-buffer from)) + (cmd (if only-id "move-id" "mv"))) + (if buffer + (save-excursion + (set-buffer buffer) + (set-visited-file-name to))) + (tla--run-tla-sync (list cmd from to) + :finished + (dvc-capturing-lambda (output error status arguments) + (let ((buf (find-buffer-visiting (capture from)))) + (when buf + (with-current-buffer buf + (rename-buffer (file-name-nondirectory + (capture to))) + (set-visited-file-name (capture to))))) + status)))) + +(defalias 'tla-mv 'tla-move) + +;; ---------------------------------------------------------------------------- +;; Xtla partner stuff +;; ---------------------------------------------------------------------------- +(defvar tla-partner-file-precious "{arch}/+partner-versions" + "Precious version of the partner file. +We strongly suggest keeping the default value since this is a +convention used by other tla front-ends like Aba.") + +(defvar tla-partner-file-source "{arch}/=partner-versions" + "Source version of the partner file. +We strongly suggest keeping the default value since this is +a convention used by other tla front-ends like Aba.") + +(defun tla-partner-find-partner-file (&optional local-tree) + "Do `find-file' tla-partners file and return the buffer. +If the file `tla-partner-file-precious' exists, it is used in priority. +Otherwise,use `tla-partner-file-source'. The precious one is meant for user +configuration, whereas the source one is used for project-wide +configuration. If LOCAL-TREE is not managed by arch, return nil." + (interactive) + (let ((default-directory (or local-tree + (tla-tree-root default-directory t)))) + (let* ((partner-file + (cond ((not default-directory) nil) + ((file-exists-p (concat (tla-tree-root) + tla-partner-file-precious)) + (concat (tla-tree-root) tla-partner-file-precious)) + (t (concat (tla-tree-root) + tla-partner-file-source)))) + (buffer-visiting (and partner-file (find-buffer-visiting partner-file)))) + (if buffer-visiting + (with-current-buffer buffer-visiting + (if (buffer-modified-p) + (if (progn (switch-to-buffer (current-buffer)) + (y-or-n-p (format "Save file %s? " + (buffer-file-name)))) + (save-buffer) + (revert-buffer))) + buffer-visiting) + (when partner-file + (find-file-noselect partner-file)))))) + + +(defun tla-partner-add (partner &optional local-tree) + "Add a partner for this xtla working copy. +Return nil if PARTNER is alerady in partners file. +Look for the parners file in LOCAL-TREE. +For example: Franz.Lustig@foo.bar--public/tla--main--0.1" + (interactive (list (tla--name-construct + (tla-name-read + "Version to Add Partner File: " + 'prompt 'prompt 'prompt 'prompt)))) + (let ((list (tla-partner-list local-tree))) + (if (member partner list) + nil + (with-current-buffer (tla-partner-find-partner-file) + (goto-char (point-min)) + (insert partner) + (newline) + (save-buffer)) + partner))) + +(defun tla-partner-list (&optional local-tree) + "Read the partner list from partner files in LOCAL-TREE. +If LOCAL-TREE is nil, use the `tla-tree-root' of `default-directory' instead. +If LOCAL-TREE is not managed by arch, return nil." + (let ((buffer (tla-partner-find-partner-file local-tree))) + (when buffer + (with-current-buffer buffer + (let ((partners (split-string (buffer-substring (point-min) (point-max)) "\n"))) + (remove "" partners)))))) + +(defun tla--partner-member (version &optional local-tree) + "Predicate to check whether VERSION is in the partners file in LOCAL-TREE." + (let ((list (tla-partner-list local-tree))) + (member version list))) + +(defun tla--partner-read-version (&optional prompt including-self) + "Specialized version for `tla-name-read' to read a partner. +- This function displays PROMPT, reads an archive/category--branch--version, +and: +- Return the result in a string form (not in a list form) and +- Ask to the user whether adding the result to the partner file or not + if the result is not in the partner file. + +If INCLUDING-SELF is non-nil, this function asks a question whether +using self as partner or not. If the user answers `y' as the question, +this function returns a symbol, `self'. If the user answers `n' as the +question, this function runs as the same as if INCLUDING-SELF is nil." + (unless prompt (setq prompt "Enter Xtla Partner: ")) + (if (and including-self + (y-or-n-p "Select `self' as partner? ")) + 'self + (let ((version (tla--name-construct + (tla-name-read + prompt + 'prompt 'prompt 'prompt 'prompt)))) + (when (and (not (tla--partner-member version)) + (y-or-n-p (format "Add `%s' to Partner File? " version))) + (tla-partner-add version)) + version))) + +;; FIXME: Currently does nothing in XEmacs. +(defun tla--partner-create-menu (action &optional prompt) + "Create the partner menu with ACTION using PROMPT as the menu name." + (let ((list (tla-partner-list))) + (dvc-funcall-if-exists + easy-menu-create-menu prompt + (mapcar + (lambda (item) + (let ((v (make-vector 3 nil))) + (aset v 0 item) ; name + (aset v 1 `(,action ,item)) + (aset v 2 t) ; enable + ;;(aset v 3 :style) + ;;(aset v 4 'radio) + ;;(aset v 5 :selected) + ;;(aset v 6 (if ...)) + v)) + list)))) + +;; ---------------------------------------------------------------------------- +;; tla-inventory-mode: +;; ---------------------------------------------------------------------------- + +(defun tla-inventory-mode () + "Major Mode to show the inventory of a tla working copy. + +This allows you to view the list of files in your local tree. You can +display only some particular kinds of files with 't' keybindings: +'\\\\[tla-inventory-toggle-source]' to toggle show sources, +'\\[tla-inventory-toggle-precious]' to toggle show precious, ... + +Use '\\[tla-inventory-mark-file]' to mark files, and '\\[tla-inventory-unmark-file]' to unmark. +If you commit from this buffer (with '\\[tla-inventory-edit-log]'), then, the list of selected +files in this buffer at the time you actually commit with +\\\\[tla-log-edit-done]. + +Commands: +\\{tla-inventory-mode-map}" + (interactive) + ;; don't kill all local variables : this would clear the values of + ;; tla-inventory-display-*, and refresh wouldn't work well anymore. + ;; (kill-all-local-variables) + (use-local-map tla-inventory-mode-map) + (setq dvc-buffer-refresh-function 'tla-inventory) + (make-local-variable 'dvc-buffer-marked-file-list) + (easy-menu-add tla-inventory-mode-menu) + (dvc-install-buffer-menu) + (setq major-mode 'tla-inventory-mode) + (setq mode-name "tla-inventory") + (setq mode-line-process 'tla-mode-line-process) + (set (make-local-variable 'dvc-get-file-info-at-point-function) + 'tla-inventory-get-file-info-at-point) + (set (make-local-variable 'tla-generic-select-files-function) + 'tla--inventory-select-files) + (toggle-read-only 1) + (run-hooks 'tla-inventory-mode-hook)) + +(defun tla-inventory-cursor-goto (ewoc-inv) + "Move cursor to the ewoc location of EWOC-INV." + (interactive) + (if ewoc-inv + (progn (goto-char (ewoc-location ewoc-inv)) + (forward-char 6)) + (goto-char (point-min)))) + +(defun tla-inventory-next () + "Go to the next inventory item." + (interactive) + (let* ((cookie tla-inventory-cookie) + (elem (ewoc-locate cookie)) + (next (or (ewoc-next cookie elem) elem))) + (tla-inventory-cursor-goto next))) + +(defun tla-inventory-previous () + "Go to the previous inventory item." + (interactive) + (let* ((cookie tla-inventory-cookie) + (elem (ewoc-locate cookie)) + (previous (or (ewoc-prev cookie elem) elem))) + (tla-inventory-cursor-goto previous))) + +(defun tla-inventory-edit-log (&optional insert-changelog) + "Wrapper around `tla-edit-log', setting the source buffer to current buffer. +If INSERT-CHANGELOG is non-nil, insert a changelog too." + (interactive "P") + (tla-edit-log insert-changelog (current-buffer))) + +(defun tla-inventory-add-files (files) + "Create explicit inventory ids for FILES." + (interactive + (list + (if dvc-buffer-marked-file-list + (progn + (unless (y-or-n-p (if (eq 1 (length dvc-buffer-marked-file-list)) + (format "Add %s? " + (car dvc-buffer-marked-file-list)) + (format "Add %s files? " + (length dvc-buffer-marked-file-list)))) + (error "Not adding any file")) + dvc-buffer-marked-file-list) + (list (read-file-name "Add file: " default-directory + nil nil + (dvc-get-file-info-at-point)))))) + (apply 'tla-add nil files) + (tla-inventory)) + +(defun tla-inventory-remove-files (files id-only) + "Remove explicit inventory ids of FILES. +If ID-ONLY is nil, remove the files as well." + (interactive + (let ((read-files + (if dvc-buffer-marked-file-list + (progn + (unless (yes-or-no-p + (format "Remove %d MARKED file%s from archive? " + (length dvc-buffer-marked-file-list) + (if (< (length dvc-buffer-marked-file-list) 2) + "" "s"))) + (error "Not removing any file")) + dvc-buffer-marked-file-list) + (list (let ((file (dvc-get-file-info-at-point))) + (if (yes-or-no-p (format "Remove %s? " file)) + file + (error "Not removing any file"))))))) + (list read-files (not (y-or-n-p (format "Delete %d %sfile%s also locally? " + (length read-files) + (if dvc-buffer-marked-file-list "MARKED " "") + (if (< (length read-files) 2) "" "s"))))))) + (apply 'tla-remove id-only files) + (tla-inventory)) + +(defun tla-inventory-delete-files (files no-questions) + "Delete FILES locally. +This is here for convenience to delete left over, temporary files or files +avoiding a commit or conflicting with tree-lint. + +It is not meant to delete tla managed files, i.e. files with IDs will be +passed to `tla-inventory-remove-files'! + +When called with a prefix arg NO-QUESTIONS, just delete the files." + (interactive + (list + (if dvc-buffer-marked-file-list + (progn + (or current-prefix-arg + (unless (yes-or-no-p + (format "Delete %d files permanently? " + (length dvc-buffer-marked-file-list))) + (error "Not deleting any files"))) + dvc-buffer-marked-file-list) + (if (or current-prefix-arg + (yes-or-no-p (format "Delete file %S permanently? " + (dvc-get-file-info-at-point)))) + (list (dvc-get-file-info-at-point)))) + current-prefix-arg)) + (while files + (let ((f (car files))) + (if (= 0 (tla--run-tla-sync (list "id" f) + :finished 'dvc-status-handler + :error 'dvc-status-handler)) + (if (or no-questions + (y-or-n-p (format (concat "File %s is arch managed! " + "Delete it with its id?") f))) + (tla-inventory-remove-files (list f) nil)) + (if (file-directory-p f) + (condition-case nil + (delete-directory f) + (file-error + (if (or no-questions + (y-or-n-p (format "Delete non-empty directory %S? " f))) + (dired-delete-file f 'always)))) + (delete-file f)))) + (setq files (cdr files))) + (if dvc-buffer-marked-file-list + (setq dvc-buffer-marked-file-list nil)) + (tla-inventory)) + +(defun tla-inventory-move () + "Rename file at the current point and update its inventory id if present." + (interactive) + (if (eq 0 (tla-move (dvc-get-file-info-at-point) nil 'ask)) + (dvc-generic-refresh) + (dvc-show-last-process-buffer))) + +(defun tla-inventory-revert (files) + "Reverts file at point or marked files." + (interactive + (list (if dvc-buffer-marked-file-list + (progn + (unless (yes-or-no-p + (format "Revert %d MARKED file%s? " + (length dvc-buffer-marked-file-list) + (if (< (length dvc-buffer-marked-file-list) 2) + "" "s"))) + (error "Not reverting any file")) + dvc-buffer-marked-file-list) + (list (let ((file (dvc-get-file-info-at-point))) + (if (yes-or-no-p (format "Revert %s? " file)) + file + (error "Not reverting any file"))))))) + (mapcar 'tla-inventory-revert-file files)) + +(defun tla-inventory-revert-file (file) + "Reverts FILE." + (let* ((absolute (if (file-name-absolute-p file) + file + (expand-file-name + (concat (file-name-as-directory + default-directory) file))))) + (tla-file-revert absolute))) + +(defun tla-inventory-undo (specify-revision) + "Undo whole local tree associated with the current inventory buffer. +If prefix arg, SPECIFY-REVISION is non-nil, read a revision and use it to undo. +The changes are saved in an ,,undo directory. You can restore them again via +`tla-inventory-redo'." + (interactive "P") + (let* ((tree (tla-tree-root default-directory t)) + (revision (if specify-revision + (tla--read-revision-with-default-tree + "Undo against archive: " + tree) + (list nil nil nil nil nil)))) + (apply 'tla--undo-internal tree nil nil revision))) + +(defun tla-inventory-maybe-undo-directory () + "Return the directory name under point if it may be an ,,undo-? directory. +Return nil otherwise." + (car (member (expand-file-name (dvc-get-file-info-at-point)) + (tla--get-undo-changeset-names)))) + +(defun tla-inventory-redo () + "Redo whole local tree associated with the current inventory buffer. +This function restores the saved changes from `tla-inventory-undo'." + (interactive) + (tla-redo (tla-inventory-maybe-undo-directory))) + +;;;###autoload +(defun tla-file-has-conflict-p (file-name) + "Return non-nil if FILE-NAME has conflicts." + (let ((rej-file-name (concat default-directory + (file-name-nondirectory file-name) + ".rej"))) + (file-exists-p rej-file-name))) + +(defun tla-inventory-find-file () + "Visit the current inventory file." + (interactive) + (let* ((file (dvc-get-file-info-at-point))) + (cond + ((not file) + (error "No file at point")) + ((eq t (car (file-attributes file))) ; file is a directory + (tla-inventory (expand-file-name file))) + (t + (find-file file))))) + +(defun tla-inventory-parent-directory () + "Go to parent directory in inventory mode." + (interactive) + (tla-inventory (expand-file-name ".."))) + +(defun tla-inventory-mirror () + "Create a mirror of version of the current tree." + (interactive) + (let ((tree-version (tla-tree-version-list))) + (tla-archive-mirror (tla--name-archive tree-version) + (tla--name-category tree-version) + (tla--name-branch tree-version) + (tla--name-version tree-version)))) + +(defun tla-inventory-star-merge (&optional merge-partner) + "Run tla star-merge. +Either use a partner in the tree's \"++tla-partners\" file or ask the user +for MERGE-PARTNER." + (interactive (list (tla--partner-read-version "Star-merge with: "))) + (when (y-or-n-p (format "Star-merge with %s ? " merge-partner)) + (tla-star-merge merge-partner))) + +(defun tla-inventory-changes (summary) + "Run tla changes. +A prefix argument decides whether the user is asked for a diff partner +and whether only a summary without detailed diffs will be shown. + +When called without a prefix argument: Show the changes for your tree. +When called with C-u as prefix: Ask the user for a diff partner via `tla--partner-read-version'. +When called with a negative prefix: Show only a summary of the changes. +When called with C-- C-u as prefix: Ask the user for a diff partner, show only change summary." + (interactive "P") + (let* ((ask-for-compare-partner (and summary (listp summary))) + (compare-partner (if ask-for-compare-partner + (tla--partner-read-version + "Compare with (default is your tree): " + t) + 'self))) + (if (eq 'self compare-partner) + (setq compare-partner nil) + (setq compare-partner (list 'revision (tla--name-split compare-partner)))) + (when (listp summary) + (setq summary (car summary))) + (tla-changes summary compare-partner))) + +(defun tla-inventory-replay (&optional merge-partner) + "Run tla replay. +Either use a partner in the tree's ++tla-partners file, or ask the user +for MERGE-PARTNER." + (interactive (list (tla--partner-read-version "Replay from: "))) + (when (y-or-n-p (format "Replay from %s ? " merge-partner)) + (tla-replay merge-partner))) + +(defun tla-inventory-update () + "Run tla update." + (interactive) + (tla-update default-directory)) + +(defun tla-inventory-missing (&optional arg) + "Run tla missing in `default-directory'. +With an prefix ARG, do this for the archive of one of your partners." + (interactive "P") + (if arg + (let ((missing-partner (tla--partner-read-version "Check missing against: "))) + (when (y-or-n-p (format "Check missing against %s ? " missing-partner)) + (tla-missing-1 default-directory missing-partner))) + (tla-missing-1 default-directory (tla-tree-version)))) + +(defun tla-inventory-file-ediff (&optional file) + "Run `ediff' on FILE." + (interactive (list (car (cddr (ewoc-data (ewoc-locate tla-inventory-cookie)))))) + (tla-file-ediff file)) + +(dvc-make-bymouse-function tla-inventory-find-file) + +(defun tla-inventory-delta () + "Run tla delta. +Use the head revision of the version associated with the current inventory +buffer as modified tree. Give the base tree interactively." + (interactive) + (let* ((modified (tla-tree-version-list)) + (modified-revision (apply 'tla--version-head modified)) + (modified-fq (tla--name-construct + (tla--name-archive modified) + (tla--name-category modified) + (tla--name-branch modified) + (tla--name-version modified) + modified-revision)) + (base (tla-name-read + (format "Revision for delta to %s(HEAD) from: " modified-fq) + 'prompt 'prompt 'prompt 'prompt 'prompt)) + (base-fq (tla--name-construct base))) + (tla-delta base-fq modified-fq 'ask))) + + +(defun tla-inventory-apply-changeset (reverse) + "Apply changeset to the tree visited by the current inventory buffer. +With a prefix argument REVERSE, reverse the changeset." + (interactive "P") + (let ((inventory-buffer (current-buffer)) + (target (tla-tree-root)) + (changeset (let ((changeset-dir (or (dvc-get-file-info-at-point) ""))) + (unless (file-directory-p (expand-file-name changeset-dir)) + (setq changeset-dir "")) + (dvc-uniquify-file-name + (dvc-read-directory-name + "Changeset directory: " changeset-dir changeset-dir))))) + (tla-show-changeset changeset nil) + (when (yes-or-no-p (format "Apply the changeset%s? " + (if reverse " in REVERSE" ""))) + (tla-apply-changeset changeset target reverse) + (with-current-buffer inventory-buffer + (dvc-generic-refresh))))) + +(defun tla-inventory-apply-changeset-from-tgz (file) + "Apply the changeset in FILE to the currently visited tree." + (interactive (list (let ((changeset-tarball (or (dvc-get-file-info-at-point) ""))) + (read-file-name "Apply changeset from tarball: " nil changeset-tarball t changeset-tarball)))) + (let ((inventory-buffer (current-buffer)) + (target (tla-tree-root))) + (tla-apply-changeset-from-tgz file target t) + (with-current-buffer inventory-buffer + (dvc-generic-refresh)))) + +;; TODO: Use `tla--inventory-select-file' in other tla-inventory-*. +;; TODO: Mouse event check like `tla--tree-lint-select-files'. +;; TODO: Unify with `tla--tree-lint-select-files'. +(defun tla--inventory-select-files (prompt-singular + prompt-plural msg-err + &optional + msg-prompt no-group ignore-marked + no-prompt y-or-n) + "Get the list of marked files and ask confirmation of the user. +PROMPT-SINGULAR or PROMPT-PLURAL is used as prompt. If no file is under +the point MSG-ERR is passed to `error'. + +MSG-PROMPT NO-GROUP IGNORE-MARKED NO-PROMPT and Y-OR-N are currently +ignored." + (let ((files (if dvc-buffer-marked-file-list + dvc-buffer-marked-file-list + (list (dvc-get-file-info-at-point))))) + (unless files + (error msg-err)) + (if (y-or-n-p + (format + (if (> (length files) 1) + prompt-plural + prompt-singular) + (if (> (length files) 1) + (length files) + (car files)))) + files + (error msg-err)))) + +(defun tla-inventory-make-junk (files) + "Prompts and make the FILES junk. +If marked files are, use them as FIELS. +If not, a file under the point is used as FILES." + (interactive + (list + (tla--inventory-select-files "Make `%s' junk? " + "Make %s files junk? " + "Not making any file junk"))) + (tla-tree-lint-put-file-prefix files ",,")) + +(defun tla-inventory-make-precious (files) + "Prompts and make the FILES precious. +If marked files are, use them as FILES. +If not, a file under the point is used as FILES." + (interactive + (list + (tla--inventory-select-files "Make `%s' precious? " + "Make %s files precious? " + "Not making any file precious"))) + (tla-tree-lint-put-file-prefix files "++")) + +(defun tla-generic-add-to-exclude (=tagging-method) + "Exclude the file/directory under point by adding it to =TAGGING-METHOD. +Adds an entry for the file to .arch-inventory or =tagging-method. +If prefix argument =TAGGING-METHOD is non-nil, the entry is added to +\"=tagging-method\" file. Else it is added to \".arch-inventory\" file." + (interactive "P") + (tla--generic-add-to-* "exclude" =tagging-method)) + +(defun tla-generic-add-ext-to-exclude (=tagging-method) + "Exclude the file/directory with the same extension as the one under +point by adding it to =TAGGING-METHOD. Adds an entry for the file to +.arch-inventory or =tagging-method. If prefix argument =TAGGING-METHOD +is non-nil, the entry is added to \"=tagging-method\" file. Else it is +added to \".arch-inventory\" file." + (interactive "P") + (tla--generic-add-ext-to-* "exclude" =tagging-method)) + +(defun tla-generic-add-to-junk (=tagging-method) + "Add the file/directory under point to =TAGGING-METHOD. +Adds an entry for the file to .arch-inventory or =tagging-method. +If prefix argument =TAGGING-METHOD is non-nil, the entry is added to +\"=tagging-method\" file. Else it is added to \".arch-inventory\" file." + (interactive "P") + (tla--generic-add-to-* "junk" =tagging-method)) + +(defun tla-generic-add-ext-to-junk (=tagging-method) + "Add the file/directory with the same extension as the one under +point to =TAGGING-METHOD. Adds an entry for the file to +.arch-inventory or =tagging-method. If prefix argument =TAGGING-METHOD +is non-nil, the entry is added to \"=tagging-method\" file. Else it is +added to \".arch-inventory\" file." + (interactive "P") + (tla--generic-add-ext-to-* "junk" =tagging-method)) + +(defun tla-generic-add-to-backup (=tagging-method) + "Add the file/directory under the point to =TAGGING-METHOD. +Adds an entry for the file to .arch-inventory or =tagging-method. +If prefix argument =TAGGING-METHOD is non-nil, the entry is added to +\"=tagging-method\" file. Else it is added to \".arch-inventory\" file." + (interactive "P") + (tla--generic-add-to-* "backup" =tagging-method)) + +(defun tla-generic-add-ext-to-backup (=tagging-method) + "Add the file/directory with the same extension as the one under the +point to =TAGGING-METHOD. Adds an entry for the file to +.arch-inventory or =tagging-method. If prefix argument =TAGGING-METHOD +is non-nil, the entry is added to \"=tagging-method\" file. Else it is +added to \".arch-inventory\" file." + (interactive "P") + (tla--generic-add-ext-to-* "backup" =tagging-method)) + +(defun tla-generic-add-to-precious (=tagging-method) + "Add the file/directory under the point to =TAGGING-METHOD. +Adds an entry for the file to .arch-inventory or =tagging-method. +If prefix argument =TAGGING-METHOD is non-nil, the entry is added to +\"=tagging-method\" file. Else it is added to \".arch-inventory\" file." + (interactive "P") + (tla--generic-add-to-* "precious" =tagging-method)) + +(defun tla-generic-add-ext-to-precious (=tagging-method) + "Add files with the same extension as the current to =TAGGING-METHOD. +Adds an entry for the file to .arch-inventory or =tagging-method. +If prefix argument =TAGGING-METHOD is non-nil, the entry is added to +\"=tagging-method\" file. Else it is added to \".arch-inventory\" file." + (interactive "P") + (tla--generic-add-ext-to-* "precious" =tagging-method)) + +(defun tla-generic-add-to-unrecognized (=tagging-method) + "Add the file/directory under the point as an unrecognized entry +of .arch-inventory or =tagging-method file. +If prefix argument =TAGGING-METHOD is non-nil, the entry is added to +\"=tagging-method\" file. Else it is added to \".arch-inventory\" file." + (interactive "P") + (tla--generic-add-to-* "unrecognized" =tagging-method)) + +(defun tla-generic-add-ext-to-unrecognized (=tagging-method) + "Add the file/directory with the same extension as the one under the +point as an unrecognized entry of .arch-inventory or =tagging-method +file. If prefix argument =TAGGING-METHOD is non-nil, the entry is +added to \"=tagging-method\" file. Else it is added to +\".arch-inventory\" file." + (interactive "P") + (tla--generic-add-ext-to-* "unrecognized" =tagging-method)) + +(defun tla--generic-add-to-* (category =tagging-method) + "Categorize currently marked files or the file under point. +Each file is categorized as CATEGORY by adding it to =TAGGING-METHOD. +If EXT-ONLY is non-nil, add only the file extension." + (let ((write-in (if =tagging-method "=tagging-method" ".arch-inventory"))) + (tla-generic-add-files-to-* + category =tagging-method + (tla--generic-select-files + (format "Make `%%s' %s in %s file? " category write-in) + (format "Make %%s files %s in %s file? " category write-in) + (format "Not making any file %s in %s file " category write-in) + (format "Make file %s in %s file: " category write-in)) + nil))) + +(defun tla--generic-add-ext-to-* (category =tagging-method) + "Categorize currently marked files or the file under point. +Each file is categorized as CATEGORY by adding it to =TAGGING-METHOD. +If EXT-ONLY is non-nil, add only the file extension." + (let ((write-in (if =tagging-method "=tagging-method" ".arch-inventory"))) + (tla-generic-add-files-to-* + category =tagging-method + (tla--generic-select-files + (format "Make files with same extension as `%%s' %s in %s file? " category write-in) + (format "Make %%s file extensions %s in %s file? " category write-in) + (format "Not making any file extensions %s in %s file " category write-in) + (format "Make file extension %s in %s file: " category write-in)) + t))) + +(defun tla-generic-add-files-to-* (category =tagging-method files + &optional ext-only) + "Categorize FILES as CATEGORY in =TAGGING-METHOD. +If =TAGGING-METHOD is t, entries for the files are added to =tagging-method. +Else, they are added to .arch-inventory. +CATEGORY is one of the following strings: \"unrecognized\", \"precious\", +\"backup\",\"junk\" or \"exclude\". +If EXT-ONLY is non-nil, add only the file extension." + (let ((point (point)) + (basedir (expand-file-name default-directory))) + ;; Write down + (save-excursion + (mapc (lambda (file) + (if =tagging-method + (tla-edit-=tagging-method-file) + (tla-edit-.arch-inventory-file + (concat basedir (file-name-directory file)))) + (tla--inventory-file-add-file + category (dvc-regexp-quote + (if ext-only + (replace-regexp-in-string + "^.*\\." "." + (file-name-nondirectory file)) + (file-name-nondirectory file))) + ext-only) + (save-buffer)) files)) + ;; Keep the position + (prog1 + (dvc-generic-refresh) + (if (< point (point-max)) + (goto-char point))))) + + +(defun tla-generic-set-id-tagging-method (method) + "Set the id tagging method of the current tree to METHOD." + (interactive (list (tla--id-tagging-method-read + (tla-id-tagging-method nil)))) + (tla--id-tagging-method-set method) + (dvc-generic-refresh)) + +(defun tla-generic-set-id-tagging-method-by-mouse (dummy-event) + "Interactively set the id tagging method of the current tree. +DUMMY-EVENT is ignored." + (interactive "e") + (call-interactively 'tla-generic-set-id-tagging-method)) + +(defun tla-generic-set-tree-version (&optional version) + "Run tla set-tree-version, setting the tree to VERSION." + (interactive) + (if version + (tla-set-tree-version version) + (call-interactively 'tla-set-tree-version)) + (dvc-generic-refresh)) + +;; ---------------------------------------------------------------------------- +;; tla-revlog-mode: +;; ---------------------------------------------------------------------------- +(defun tla-revlog-mode () + "Major Mode to show a specific log message. +Commands: +\\{tla-revlog-mode-map}" + (interactive) + (kill-all-local-variables) + (use-local-map tla-revlog-mode-map) + (set (make-local-variable 'font-lock-defaults) + '(tla-revlog-font-lock-keywords t)) + (set (make-local-variable 'tla-button-marker-list) + nil) + (set (make-local-variable 'tla-current-revision) + (save-excursion + (concat + (progn + (goto-char (point-min)) + (re-search-forward "^Archive: ") + (buffer-substring-no-properties (point) + (line-end-position))) + "/" + (progn + (goto-char (point-min)) + (re-search-forward "^Revision: ") + (buffer-substring-no-properties (point) + (line-end-position)))))) + (setq major-mode 'tla-revlog-mode) + (setq mode-name "tla-revlog") + (toggle-read-only 1) + (tla-add-buttons) + (run-hooks 'tla-revlog-mode-hook)) + +(defun tla-annotate-mode () + "Major Mode to show a specific annotate message. + +Mostly similar to `tla-annotate-mode'. +Commands: +\\{tla-revlog-mode-map}" + (interactive) + (kill-all-local-variables) + (use-local-map tla-revlog-mode-map) + (set (make-local-variable 'font-lock-defaults) + '(tla-revlog-font-lock-keywords t)) + (set (make-local-variable 'tla-button-marker-list) + nil) + (setq major-mode 'tla-revlog-mode) + (setq mode-name "tla-revlog") + (toggle-read-only 1) + (tla-add-buttons) + (run-hooks 'tla-revlog-mode-hook)) + +(defun tla-dvc-revlog-get-revision (rev-id) + (let* ((buf (tla--revlog-any (car (dvc-revision-get-data rev-id)))) + (str (with-current-buffer buf (buffer-string)))) + str)) + + +;; +;; Copied and adapted from gnus-art.el +;; + +(defvar tla-button-alist + `((,(tla-make-name-regexp 0 t t) 1 t + tla-categories-string 1) + (,(tla-make-name-regexp 1 t t) 1 t + tla-branches-string 1) + (,(tla-make-name-regexp 2 t t) 1 t + tla-versions-string 1) + (,(tla-make-name-regexp 3 t t) 1 t + tla-revisions-string 1) + (,(tla-make-name-regexp 4 t t) 1 t + tla--button-revision-fn 1) + ("Creator: \\(.*\\)$" 1 t + tla-revlog-send-comments 1) + ("Archive: \\(.*\\)$" 1 t + tla-categories-string 1))) + + +(defvar tla-button-marker-list '()) + +(defun tla--button-revision-fn (revision) + (funcall tla-button-revision-fn revision)) + +(defun tla-revlog-send-comments (email) + (interactive (list (save-excursion + (goto-char (point-min)) + (re-search-forward "^Creator: \\(.*\\)$") + (match-string-no-properties 1)))) + (tla-revision-send-comments (tla--archive-tree-get-revision-struct + (tla--name-archive tla-current-revision) + (tla--name-category tla-current-revision) + (tla--name-branch tla-current-revision) + (tla--name-version tla-current-revision) + (tla--name-revision tla-current-revision)) + email)) + +(defun tla-button-entry () + "Return the first entry in `tla-button-alist' matching this place." + (let ((alist tla-button-alist) + (entry nil)) + (while alist + (setq entry (pop alist)) + (if (looking-at (eval (car entry))) + (setq alist nil) + (setq entry nil))) + entry)) + +(defun tla-button-in-region-p (b e prop) + "Say whether PROP exists in the region." + (text-property-not-all b e prop nil)) + +;;; Copied from gnus-article-add-buttons +(defun tla-add-buttons (&optional buffer force) + "Find external references in the article and make buttons of them. +\"External references\" are things like Message-IDs and URLs, as +specified by `tla-button-alist'." + (interactive (list (current-buffer) 'force)) + (with-current-buffer (or buffer (current-buffer)) + (let ((inhibit-read-only t)o + (inhibit-point-motion-hooks t) + (case-fold-search t) + (alist tla-button-alist) + beg entry regexp) + ;; Remove all old markers. + (let (marker entry new-list) + (while (setq marker (pop tla-button-marker-list)) + (if (or (< marker (point-min)) (>= marker (point-max))) + (push marker new-list) + (goto-char marker) + (when (setq entry (tla-button-entry)) + (put-text-property (match-beginning (nth 1 entry)) + (match-end (nth 1 entry)) + 'tla-callback nil)) + (set-marker marker nil))) + (setq tla-button-marker-list new-list)) + ;; We skip the headers. + (goto-char (point-min)) + (setq beg (point)) + (while (setq entry (pop alist)) + (setq regexp (eval (car entry))) + (goto-char beg) + (while (re-search-forward regexp nil t) + (let* ((start (and entry (match-beginning (nth 1 entry)))) + (end (and entry (match-end (nth 1 entry)))) + (from (match-beginning 0))) + (when (and (or (eq t (nth 2 entry)) + (eval (nth 2 entry))) + (not (tla-button-in-region-p + start end 'tla-callback))) + ;; That optional form returned non-nil, so we add the + ;; button. + (tla-add-button + start end 'tla-button-push + (car (push (set-marker (make-marker) from) + tla-button-marker-list)))))))))) + +(defun tla-button-push (marker) + ;; Push button starting at MARKER. + (save-excursion + (goto-char marker) + (let* ((entry (tla-button-entry)) + (inhibit-point-motion-hooks t) + (fun (nth 3 entry)) + (args (mapcar (lambda (group) + (let ((string (match-string group))) + (set-text-properties + 0 (length string) nil string) + string)) + (nthcdr 4 entry)))) + (cond + ((fboundp fun) + (apply fun args)) + ((and (boundp fun) + (fboundp (symbol-value fun))) + (apply (symbol-value fun) args)) + (t + (message "You must define `%S' to use this button" + (cons fun args))))))) + +(defun tla-add-button (from to fun &optional data) + "Create a button between FROM and TO with callback FUN and data DATA." + (when dvc-button-face + (dvc-overlay-put (dvc-make-overlay from to) + 'face dvc-button-face)) + (dvc-add-text-properties + from to + (nconc (and dvc-mouse-face + (list dvc-mouse-face-prop dvc-mouse-face)) + (list 'tla-callback fun) + (and data (list 'tla-data data)))) + (widget-convert-button 'link from to :action 'tla-widget-press-button + :button-keymap nil)) + +(defun tla-widget-press-button (elems el) + (goto-char (widget-get elems :from)) + (tla-press-button)) + +(defun tla-push-button (event) + "Check text under the mouse pointer for a callback function. +If the text under the mouse pointer has a `tla-callback' property, +call it with the value of the `tla-data' text property." + (interactive "e") + (unless event (error "Event is nil")) + (let ((buffer + (or (let ((window (dvc-funcall-if-exists + posn-window (dvc-funcall-if-exists + event-start event)))) + ;; XEmacs + (and window (window-buffer window))) + ;; GNU Emacs + (dvc-funcall-if-exists event-buffer event)))) + (pop-to-buffer buffer) + (set-buffer buffer) + (let* ((pos (or (dvc-funcall-if-exists posn-point (event-start event)) + (dvc-funcall-if-exists event-point event) + (error "No way to determine point"))) + (data (get-text-property pos 'tla-data)) + (fun (get-text-property pos 'tla-callback))) + (when pos (goto-char pos)) + (when fun + (funcall fun data))))) + +(defun tla-press-button () + "Check text at point for a callback function. +If the text at point has a `tla-callback' property, +call it with the value of the `tla-data' text property." + (interactive) + (let ((data (get-text-property (point) 'tla-data)) + (fun (get-text-property (point) 'tla-callback))) + (when fun + (funcall fun data)))) + +;; +;; End copied and adapted from gnus-art.el +;; +;;;###autoload +(defun tla-revlog (revision-spec) + "Show the log for REVISION-SPEC." + (interactive (list (tla--name-construct + (tla-name-read "Revision spec: " + 'prompt 'prompt 'prompt 'prompt 'prompt)))) + (tla--run-tla-sync (list "cat-log" revision-spec) + :finished 'dvc-finish-function-without-buffer-switch) + (dvc-show-last-process-buffer 'revlog 'tla-revlog-mode revision-spec)) +(defalias 'tla-cat-log 'tla-revlog) + +(defun tla-cat-archive-log (revision-spec) + "Run cat-archive-log for REVISION-SPEC." + (interactive (list (tla--name-construct + (tla-name-read "Revision spec: " + 'prompt 'prompt 'prompt 'prompt 'prompt)))) + (tla--run-tla-sync (list "cat-archive-log" revision-spec) + :finished 'dvc-finish-function-without-buffer-switch) + (dvc-show-last-process-buffer 'revlog 'tla-revlog-mode revision-spec)) + +(defun tla--maybe-save-log (revision) + "Must be called from the buffer containing the log for REVISION. +Saves this buffer to the corresponding file in the log-library if +`tla-log-library-greedy' is non-nil." + (if tla-log-library-greedy + (let ((dir (expand-file-name + (concat (file-name-as-directory tla-log-library) + (car revision)))) + (file (tla--name-construct-semi-qualified (cdr revision)))) + (unless (file-directory-p dir) + (make-directory dir)) + (let ((name (concat " *tla-log-rev-" (tla--name-construct + revision) "*")) + make-backup-files) + (write-file (concat (file-name-as-directory dir) file)) + (set-visited-file-name + (concat (file-name-as-directory dir) file)) + (set-buffer-modified-p nil) + (rename-buffer name) + (current-buffer))) + (clone-buffer))) + +(defun tla--revlog-any (revision &optional tree async-handler) + "Create a buffer containing the log file for REVISION. + +Either call cat-log, cat-archive-log, or read the log from the log library. + +REVISION must be specified as a list. If TREE is provided, try a +cat-log in TREE preferably. Otherwise, try a cat-log in the local +directory. If both are impossible, run cat-archive-log. (same result, +but needs to retrieve something from the archive). + +Call the function ASYNC-HANDLER in the created buffer, with arguments + (output error status arguments)." + ;; (message "tla-revlog-any %S" revision) + ;; See if the log is in the log library + (when tla-log-library-greedy + (if (not (file-directory-p tla-log-library)) + (make-directory tla-log-library))) + (let* ((rev-str (if (stringp revision) revision + (tla--name-construct revision))) + (rev-list (if (listp revision) revision + (tla--name-split revision))) + (lib-log (concat (file-name-as-directory tla-log-library) + rev-str)) + (buffer + (or (get-file-buffer lib-log) + (when (file-exists-p lib-log) + (let* ((name (concat " *tla-log(" + rev-str ")*"))) + (or (get-buffer name) + ;; Surprisingly, (rename-buffer) didn't rename + ;; anything here. Solution: Create a buffer with + ;; the right name, and simulate a find-file. + (with-current-buffer + (get-buffer-create name) + (insert-file-contents lib-log) + (set-visited-file-name lib-log) + (rename-buffer name) + (set-buffer-modified-p nil) + (current-buffer)))))))) + (if buffer + (if async-handler + (funcall async-handler buffer nil 0 "cat-log") + buffer) + ;; Try a revlog + (let ((run-mode (if async-handler 'tla--run-tla-async 'tla--run-tla-sync)) + (handler (if async-handler + (dvc-capturing-lambda (output error status arguments) + (with-current-buffer output + (tla--maybe-save-log (capture rev-list))) + (funcall (capture async-handler) output error status + arguments)) + (dvc-capturing-lambda (output error status arguments) + (with-current-buffer output + (tla--maybe-save-log (capture rev-list))))))) + (tla--run-tla-sync ;; Anyway, tla revlog is fast, so, no + ;; need for an asynchronous process. For some reason, + ;; running it asynchronously caused a random bug when + ;; running tla remotely. + (list "revlog" rev-str) + :finished handler + ;; revlog failed: cat-archive-log is needed + :error (dvc-capturing-lambda (output error status arguments) + (funcall (capture run-mode) + (list "cat-archive-log" + (capture rev-str)) + :finished (capture handler)))))))) + +(defun tla-log-get-changeset () + "Get and show the changeset whose log is being displayed." + (interactive) + (tla-get-changeset tla-current-revision t)) + +;; ---------------------------------------------------------------------------- +;; tla-log-edit-mode: +;; ---------------------------------------------------------------------------- +(defun tla-log-edit-next-field (&optional notab) + "Go to next field in a log edition." + (interactive) + (let ((in-field (string-match "^\\([A-Z][A-Za-z]*\\(: ?\\)?\\)?$" + (buffer-substring + (line-beginning-position) (point)))) + (oldpoint (point))) + (if (and in-field + (string-match "^[A-Z][A-Za-z]*: $" + (buffer-substring + (line-beginning-position) (point)))) + (forward-line)) + (if in-field (beginning-of-line) (forward-line 1)) + (or (and (looking-at "^[A-Z][a-zA-Z]*: ") + (goto-char (match-end 0))) + (and (looking-at "^[A-Z][a-zA-Z]*:$") + (goto-char (match-end 0)) + (progn (insert " ") t)) + (let ((body + (save-excursion + (when (search-forward + (concat "\n" + dvc-log-edit-file-list-marker + "\n") nil t) + (progn (goto-char (point-min)) + (re-search-forward "^$" nil t) + (forward-line 1) + (point)))))) + (when (and body (> body (point))) + (goto-char body))) + (progn (goto-char oldpoint) + (unless notab (insert "\t")))))) + +(defun tla-log-goto-field (field) + "Go to FIELD in a log file." + (goto-char (point-min)) + (re-search-forward field) + (save-excursion + (if (not (looking-at " ")) + (insert " "))) + (forward-char 1)) + +(defun tla-log-goto-summary () + "Go to the Summary field in a log file." + (interactive) + (tla-log-goto-field "^Summary:")) + +(defun tla-log-goto-keywords () + "Go to the Keywords field in a log file." + (interactive) + (tla-log-goto-field "^Keywords:")) + +(defun tla-log-goto-body () + "Go to the Body in a log file." + (interactive) + (goto-char (point-min)) + (forward-line 3)) + +(defun tla-log-kill-body () + "Kill the content of the log file body." + (interactive) + (tla-log-goto-body) + (kill-region (point) (point-max))) + +;;;###autoload +(add-to-list 'auto-mode-alist '("\\+\\+log\\." . tla-log-edit-mode)) + +;;;###autoload +(define-derived-mode tla-log-edit-mode dvc-log-edit-mode "tla-log-edit" + "Major Mode to edit xtla log messages. +Commands: +\\{tla-log-edit-mode-map} +" + (use-local-map tla-log-edit-mode-map) + (easy-menu-add tla-log-edit-mode-menu) + (dvc-install-buffer-menu) + (set (make-local-variable 'font-lock-defaults) + '(tla-log-edit-font-lock-keywords t)) + (setq fill-column 73) + (run-hooks 'tla-log-edit-mode-hook)) + +(defun tla-log-edit-abort () + "Abort the current log edit." + (interactive) + (bury-buffer) + (set-window-configuration tla-pre-commit-window-configuration)) + +(autoload 'dvc-tips-popup-maybe "dvc-tips") + +(defun tla-log-edit-done () + "Finish the current log edit and commit." + (interactive) + (tla-log-edit-done-internal nil)) + +(defun tla-log-edit-done-with-sealing () + "Finish the current log edit and commit with sealing(--seal)." + (interactive) + (if (yes-or-no-p + (format "Do you really want to seal: \"%s\" ?" + (tla-tree-version))) + (tla-log-edit-done-internal 'seal) + (error "Abort to seal this version"))) + +(defun tla-log-edit-done-with-fixing () + "Finish the current log edit and commit with fixing(--fix)." + (interactive) + (if (yes-or-no-p + (format "Do you really want to fix: \"%s\" ?" + (tla-tree-version))) + (tla-log-edit-done-internal 'fix) + (error "Abort to fix this version"))) + +(defun tla-log-edit-done-internal (version-flag) + "Finish the current log edit and commit. +`nil' or a symbol(`seal' or `fix') is acceptable as VERSION-FLAG." + (tla-edit-log-delete-file-list) + (save-buffer) + (let ((dir default-directory) + (log-buffer (current-buffer))) + (dvc-tips-popup-maybe) + (let ((default-directory dir)) + (tla-commit + (dvc-capturing-lambda (output error status args) + (kill-buffer (capture log-buffer))) + version-flag)))) + +(defun tla-archive-maintainer-name (version) + "Return the maintainer name for a given VERSION. +This function looks in the bookmarks file for the nickname field and +returns it. +If the nickname field is not present, just return VERSION as string." + (tla-bookmarks-get-field version 'nickname (tla--name-mask version t t t t t))) + +(defun tla-archive-maintainer-id (archive &optional shorter) + "Return my-id substring from ARCHIVE. +If SHORTER is non-nil, return login name part of the my-id substring. +E.g. If ARCHIVE is x@y.z--a, the result is x@y.z. +If SHORTER is non-nil, the result is x." + (if (string-match "\\(\\(.+\\)@.+\\)--.+" archive) + (if shorter + (match-string 2 archive) + (match-string 1 archive)))) + +(defun tla-archive-default-maintainer-name (version) + "Return a suitable maintainer name or version name for VERSION. +Either the nickname if defined in the bookmarks, or the left hand side +of the email in the archive name." + (or (tla-archive-maintainer-name version) + (tla-archive-maintainer-id (tla--name-archive version) t))) + +(defun tla--merge-summary-end-of-sequence (string low high) + "Pretty-print a range of merged patches. +STRING is an identifier for this merge, while LOW and HIGH are the lowest +and highest patches that were merged." + (let ((elem + (if (= low high) + ;; singleton + (int-to-string low) + (format "%d-%d" low high)))) + (if (string= string "") + (concat "patch " elem) + (concat string ", " elem)))) + + +(defun tla-merge-summary-line (mergelist) + "Create a suitable log summary line for a list of merges. +MERGELIST is an alist in the form +\((maintainer1 12 13 14 25 26) + ... + (maintainerN num42)) +The return value is a string in the form +\"maintainer1 (patch 12-14, 25-26), maintainerN (patch-num42)\"" + (let ((res "")) + (while mergelist + (let ((patch-list (sort (cdar mergelist) '<)) + (list-string "") + last-patch-number-low + last-patch-number-high) + ;; patch-list is the list of patch numbers. + (while patch-list + (unless last-patch-number-low + (setq last-patch-number-low (car patch-list)) + (setq last-patch-number-high (- (car patch-list) 1))) + (if (= (1+ last-patch-number-high) (car patch-list)) + ;; normal sequence + (setq last-patch-number-high (car patch-list)) + (setq list-string + (tla--merge-summary-end-of-sequence + list-string + last-patch-number-low + last-patch-number-high)) + (setq last-patch-number-low (car patch-list))) + (setq last-patch-number-high (car patch-list)) + (setq patch-list (cdr patch-list))) + (setq list-string + (tla--merge-summary-end-of-sequence + list-string + last-patch-number-low + last-patch-number-high)) + (setq last-patch-number-low nil) + (setq res + (let ((maint (format "%s (%s)" (caar mergelist) + list-string))) + (if (string= res "") + maint + (concat res ", " maint))))) + (setq mergelist (cdr mergelist))) + res)) + +(defun tla--merge-summary-default-format-function (string) + "Return an appropriate \"Merged from\" summary line for STRING. + +Gets the 'summary-format field for that version in the bookmarks (or +use \"Merged from %s\" by default), and calls +\(format summary-format S)." + (let ((format-string (tla-bookmarks-get-field + (tla-tree-version-list) + 'summary-format + "Merged from %s"))) + (format format-string string))) + +(defun tla-merge-summary-line-for-log () + "Generate an appropriate summary line after a merge. +The generated line is of the form +\"Merged from Robert (167-168, 170), Masatake (209, 213-215, 217-218)\". +The names \"Robert\" and \"Masatake\" in this example are nicknames +defined in the bookmarks for the corresponding versions. + +First, an alist A like +\((\"Robert\" 167 168 170) (\"Masatake\" 209 213 214 215 217 218)) is +generated. If `tla-version-to-name-function' is non-nil, then it must +be a function that is called with the version as an argument, and must +return a string that will be used to instead of the nickname. + +Then, a string S like +\"Robert (167-168, 170), Masatake (209, 213-215, 217-218)\" +is generated. This is done by default by `tla-merge-summary-line', +which can be overridden by `tla-generate-line-function'. + +Then, the function `tla-format-line-function' is called with this +string S as an argument. If `tla-format-line-function' is nil, then, +`tla--merge-summary-default-format-function' is called. It retrieves +the fields summary-format from the bookmark for the tree version, and +calls (format summary-format S)." + (save-excursion + (let ((rev-list) + (maintainer) + (rev) + (patch-list)) + (goto-char (point-min)) + (while (re-search-forward "^ \\* \\(.+@.+--.+/.+--.+\\)$" nil t) + (setq rev-list (tla--name-split (match-string-no-properties 1))) + (setq maintainer (funcall (or tla-version-to-name-function + 'tla-archive-default-maintainer-name) + rev-list)) + (setq rev (cadr (split-string (tla--name-revision rev-list) "-"))) + (add-to-list 'patch-list (list maintainer rev))) + ;; patch-list has now the form + ;; ((maintainer1 num1) (maintainer1 num2) ... (maintainerN num42)) + (let ((alist)) + (while patch-list + (let* ((elem (car patch-list)) + (patch-number-list (assoc (car elem) alist))) + (if patch-number-list + ;; This maintainer already has a patch in the list + (setcdr patch-number-list + (cons (string-to-number (cadr elem)) + (cdr patch-number-list))) + ;; First patch for this maintainer. add + ;; (maintainer patch-number) to the alist. + (setq alist (cons (list (car elem) + (string-to-number (cadr elem))) + alist)))) + (setq patch-list (cdr patch-list))) + ;; alist now has the form + ;; ((maintainer1 num1 num2) + ;; ... + ;; (maintainerN num42)) + ;; where numX are of type integer. + (funcall (or tla-format-line-function + 'tla--merge-summary-default-format-function) + (funcall (or tla-generate-line-function + 'tla-merge-summary-line) alist)))))) + +(defun tla-log-edit-insert-log-for-merge-and-headers () + "Call `tla-log-edit-insert-log-for-merge' with a prefix arg." + (interactive) + (tla-log-edit-insert-log-for-merge t)) + +(defun tla-log-edit-insert-log-for-merge (arg) + "Insert the output of tla log-for-merge at POINT. + +When called with a prefix argument ARG, create a standard Merged from +line as Summary with `tla-merge-summary-line-for-log'." + (interactive "P") + (let ((cur-buf (current-buffer))) + (tla--run-tla-sync '("log-for-merge") + :finished + (dvc-capturing-lambda (output error status arguments) + (let ((content (dvc-buffer-content + output))) + (if (= 0 (length content)) + (error "There was no merge!")) + (with-current-buffer (capture cur-buf) + (let ((on-summary-line + (= 1 (count-lines (point-min) (point)))) + (old-pos (point))) + (if on-summary-line + (tla-log-goto-body) + (goto-char old-pos)) + (insert content))) + (when arg + (tla-log-goto-summary) + (delete-region (point) (line-end-position)) + (insert + (with-current-buffer output + (tla-merge-summary-line-for-log))) + (tla-log-goto-keywords) + (delete-region (point) (line-end-position)) + (insert "merge") + (tla-log-goto-summary))))))) + + +(defun tla-log-edit-insert-memorized-log () + "Insert a memorized log message." + (interactive) + (when dvc-memorized-log-header + (tla-log-goto-summary) + (delete-region (point) (line-end-position)) + (insert dvc-memorized-log-header)) + (when dvc-memorized-log-message + (tla-log-goto-body) + (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/xtla.el: " + (end-of-line) + (newline)) + (insert dvc-memorized-log-message))) + + +;; ---------------------------------------------------------------------------- +;; tla-log-edit-insert-keywords: +;; ---------------------------------------------------------------------------- + +(defvar tla-log-edit-keywords-marked-list) +(defvar tla-log-edit-keywords-cookie) +(defvar tla-log-edit-keywords-log-buffer) + +(defun tla-log-edit-keywords-printer (elem) + "If ELEM is a keyword, print it differently." + (insert (if (member elem tla-log-edit-keywords-marked-list) + (concat dvc-mark " ") " ") + elem)) + +(defun tla-log-edit-keywords (arg) + "Add keywords listed in variable `tla-log-edit-keywords'. +When called with a prefix argument ARG, delete all current keywords." + (interactive "P") + (let ((current-keywords + (save-excursion + (tla-log-goto-keywords) + (buffer-substring (point) (line-end-position)))) + (log-buffer (current-buffer)) + keywords) + (setq current-keywords (replace-regexp-in-string "," " " current-keywords nil t) + current-keywords (mapcar (lambda (k) (format "%s" k)) + (read (concat "(" current-keywords ")")))) + (switch-to-buffer (concat " *" (tla-arch-branch-name) "log-keywords*")) + (toggle-read-only 0) + (erase-buffer) + (make-local-variable 'tla-log-edit-keywords) + (make-local-variable 'tla-log-edit-keywords-marked-list) + (make-local-variable 'tla-log-edit-keywords-cookie) + (make-local-variable 'tla-log-edit-keywords-log-buffer) + (setq tla-log-edit-keywords-log-buffer + log-buffer + tla-log-edit-keywords-marked-list + current-keywords + tla-log-edit-keywords-cookie + (ewoc-create (dvc-ewoc-create-api-select + #'tla-log-edit-keywords-printer) + "List of keywords from `tla-log-edit-keywords':\n" + (format "type C-c C-c to insert the marked keywords to the buffer\n%s" + (buffer-name log-buffer)))) + + (while current-keywords + (add-to-list 'tla-log-edit-keywords (car current-keywords)) + (setq current-keywords (cdr current-keywords))) + + (setq keywords tla-log-edit-keywords) + + (while keywords + (add-to-list 'tla-log-edit-keywords (car keywords)) + (ewoc-enter-last tla-log-edit-keywords-cookie (car keywords)) + (setq keywords (cdr keywords)))) + + (use-local-map tla-log-edit-keywords-mode-map) + (setq major-mode 'tla-log-edit-keywords-mode) + (setq mode-name "tla-log-keywords") + (toggle-read-only 1) + (message "Type C-c C-c to finish.") + (goto-char (point-min)) + (forward-line 1)) + +(defun tla-log-edit-keywords-cursor-goto (elem) + "Jump to the location of ELEM." + (interactive) + (goto-char (ewoc-location elem)) + (re-search-forward "^")) + +(defun tla-log-edit-keywords-next () + "Go to the next keyword." + (interactive) + (let* ((cookie tla-log-edit-keywords-cookie) + (elem (ewoc-locate cookie)) + (next (or (ewoc-next cookie elem) elem))) + (tla-log-edit-keywords-cursor-goto next))) + +(defun tla-log-edit-keywords-previous () + "Go to the previous keyword." + (interactive) + (let* ((cookie tla-log-edit-keywords-cookie) + (elem (ewoc-locate cookie)) + (previous (or (ewoc-prev cookie elem) elem))) + (tla-log-edit-keywords-cursor-goto previous))) + +(defun tla-log-edit-keywords-mark () + "Mark the current keyword." + (interactive) + (let ((pos (point))) + (add-to-list 'tla-log-edit-keywords-marked-list + (ewoc-data (ewoc-locate tla-log-edit-keywords-cookie))) + (ewoc-refresh tla-log-edit-keywords-cookie) + (goto-char pos)) + (tla-log-edit-keywords-next)) + +(defun tla-log-edit-keywords-unmark () + "Unmark the current keyword." + (interactive) + (let ((pos (point))) + (setq tla-log-edit-keywords-marked-list + (delete (ewoc-data (ewoc-locate tla-log-edit-keywords-cookie)) + tla-log-edit-keywords-marked-list)) + (ewoc-refresh tla-log-edit-keywords-cookie) + (goto-char pos)) + (tla-log-edit-keywords-next)) + +(defun tla-log-edit-keywords-unmark-all () + "Unmark all marked keywords." + (interactive) + (let ((pos (point))) + (setq tla-log-edit-keywords-marked-list nil) + (ewoc-refresh tla-log-edit-keywords-cookie) + (goto-char pos))) + +(defun tla-log-edit-keywords-mark-all () + "Mark all keywords." + (interactive) + (let ((pos (point))) + (setq tla-log-edit-keywords-marked-list tla-log-edit-keywords) + (ewoc-refresh tla-log-edit-keywords-cookie) + (goto-char pos))) + +(defun tla-log-edit-keywords-toggle-mark () + "Toggle marking of the current keyword." + (interactive) + (let ((pos (point))) + (if (member (ewoc-data (ewoc-locate tla-log-edit-keywords-cookie)) + tla-log-edit-keywords-marked-list) + (tla-log-edit-keywords-unmark) + (tla-log-edit-keywords-mark)) + (ewoc-refresh tla-log-edit-keywords-cookie) + (goto-char pos))) + +(defun tla-log-edit-keywords-insert () + "Insert marked keywords into log buffer." + (interactive) + (let ((keywords tla-log-edit-keywords-marked-list)) + (switch-to-buffer tla-log-edit-keywords-log-buffer) + (kill-buffer (concat " *" (tla-arch-branch-name) "log-keywords*")) + (save-excursion + (tla-log-goto-keywords) + (delete-region (point) (line-end-position)) + (insert (mapconcat 'identity (reverse keywords) ", "))))) + +;; ---------------------------------------------------------------------------- +;; tla-archive-list-mode: +;; ---------------------------------------------------------------------------- +(defun tla-archive-mirror-archive () + "Mirror the archive at point." + (interactive) + (let ((archive-info (tla-get-archive-info))) + (when archive-info + (tla-mirror-archive archive-info) + (tla-archives)))) + +(defun tla-archive-synchronize-archive () + "Synchronizes the mirror for the archive at point." + (interactive) + (let ((archive-info (tla-get-archive-info))) + (when archive-info + (tla-archive-mirror archive-info)))) + +(defun tla-archive-list-mode () + "Major Mode to show arch archives: +\\{tla-archive-list-mode-map}" + (interactive) + (kill-all-local-variables) + (use-local-map tla-archive-list-mode-map) + (easy-menu-add tla-archive-list-mode-menu) + (dvc-install-buffer-menu) + (setq major-mode 'tla-archive-list-mode) + (setq mode-name "tla-archives") + + (toggle-read-only 1) + (set-buffer-modified-p nil) + (set (make-local-variable 'dvc-get-revision-info-at-point-function) + 'tla--get-archive-info-at-point) + (run-hooks 'tla-archive-list-mode-hook)) + +(defun tla--get-archive-info-at-point () + "Get archive information." + (list 'archive (tla-get-archive-info))) + +(defun tla-archive-select-default () + "Select the default archive." + (interactive) + (when (tla-get-archive-info) + (let ((pos (point))) + (tla-my-default-archive (tla-get-archive-info)) + (tla-archives) + (goto-char pos)))) + +(defun tla-archive-unregister-archive () + "Delete the registration of the selected archive." + (interactive) + (let ((archive (tla-get-archive-info))) + (if archive + (progn (tla--unregister-archive archive t) + (tla-archives)) + (error "No archive under the point")))) + +(defun tla-archive-edit-archive-location () + "Edit the archive location for a archive. +This is done by unregistering the archive, followed by a new registration with +the new location." + (interactive) + (let ((archive (tla-get-archive-info))) + (tla--edit-archive-location archive) + (save-excursion + (tla-archives)))) + +(defun tla-archive-use-as-default-mirror () + "Use the mirror archive as default mirror." + (interactive) + (let ((archive (tla-get-archive-info))) + (tla-use-as-default-mirror archive) + (save-excursion + (tla-archives)))) + +(defun tla-archive-list-categories () + "List the categories for the current archive." + (interactive) + (let ((archive (tla-get-archive-info))) + (if archive + (tla-categories archive) + (error "No archive under the point")))) + +(dvc-make-bymouse-function tla-archive-list-categories) + +(defun tla-archive-browse-archive () + "Browse the current archive." + (interactive) + (let ((archive (tla-get-archive-info))) + (if archive + (tla-browse-archive archive) + (error "No archive under the point")))) + +(dvc-make-move-fn ewoc-next tla-archive-next + tla-archives-list-cookie) + +(dvc-make-move-fn ewoc-prev tla-archive-previous + tla-archives-list-cookie) + +(defun tla-save-archive-to-kill-ring () + "Save the name of the current archive to the kill ring." + (interactive) + (let ((archive (or (tla-get-archive-info) + tla-buffer-archive-name + (tla--name-archive (tla-tree-version-list nil 'no-error))))) + (unless archive + (error "No archive name associated with current buffer")) + (kill-new archive) + (if (interactive-p) + (message "%s" archive)) + archive)) + +(defun tla-save-version-to-kill-ring () + "Save tla tree-version to the kill ring." + (interactive) + (let ((version (tla-tree-version))) + (kill-new version) + (if (interactive-p) + (message "%s" version)) + version)) + +(defun tla-save-revision-to-kill-ring () + "Save tla tree-version to the kill ring." + (interactive) + (let ((revision (tla-tree-id))) + (kill-new revision) + (if (interactive-p) + (message "%s" revision)) + revision)) + +;; ---------------------------------------------------------------------------- +;; tla-category-list-mode: +;; ---------------------------------------------------------------------------- +(defun tla-category-list-mode () + "Major Mode to show arch categories: +\\{tla-category-list-mode-map}" + (interactive) + (kill-all-local-variables) + (use-local-map tla-category-list-mode-map) + (easy-menu-add tla-category-list-mode-menu) + (dvc-install-buffer-menu) + (setq major-mode 'tla-category-list-mode) + (setq mode-name "tla-category") + (add-hook 'tla-make-category-hook 'tla-category-refresh) + + (toggle-read-only 1) + (set-buffer-modified-p nil) + (set (make-local-variable 'dvc-get-revision-info-at-point-function) + 'tla--get-category-info-at-point) + (run-hooks 'tla-category-list-mode-hook)) + +(defun tla--get-category-info-at-point () + "Get archive/category--branch information." + (let ((buffer-version (tla--name-construct + tla-buffer-archive-name + (tla-get-archive-info 'tla-category-info)))) + (list 'category buffer-version))) + +(defun tla-category-list-branches () + "List branches of the current category." + (interactive) + (let ((category (tla-get-archive-info 'tla-category-info))) + (if category + (tla-branches tla-buffer-archive-name category) + (error "No category under the point")))) + +(dvc-make-bymouse-function tla-category-list-branches) + +(defun tla-category-make-category (category) + "Create a new category named CATEGORY." + (interactive "sCategory name: ") + (tla-make-category tla-buffer-archive-name category)) + +(defun tla-category-refresh () + "Refresh the current category list." + (interactive) + (tla-categories tla-buffer-archive-name)) + +(defun tla-category-next () + "Move to the next category." + (interactive) + (forward-line 1) + (beginning-of-line)) + +(defun tla-category-previous () + "Move to the previous category." + (interactive) + (forward-line -1) + (beginning-of-line) + (unless (looking-at "^ ") + (forward-line 1))) + +(defun tla-category-mirror-archive () + "Mirror the current category." + (interactive) + (let ((category (tla-get-archive-info 'tla-category-info))) + (unless category + (error "No category at point")) + (tla-archive-mirror tla-buffer-archive-name + category))) + + +(defun tla-category-bookmarks-add-here (name) + "Add a bookmark named NAME for this category." + (interactive "sBookmark name: ") + (tla-bookmarks-add name + (list tla-buffer-archive-name + (tla-get-archive-info 'tla-category-info) + nil nil nil)) + (message "bookmark %s added." name)) + +(defun tla-category-bookmarks-add (name) + "Add a bookmark named NAME for this category." + (interactive "sBookmark name: ") + (tla-bookmarks-add name + (list tla-buffer-archive-name nil nil nil)) + (message "bookmark %s added." name)) + +;; ---------------------------------------------------------------------------- +;; tla-branch-list-mode +;; ---------------------------------------------------------------------------- +(defun tla-branch-list-mode () + "Major Mode to show arch branches: +\\{tla-branch-list-mode-map}" + (interactive) + (kill-all-local-variables) + (use-local-map tla-branch-list-mode-map) + (easy-menu-add tla-branch-list-mode-menu) + (dvc-install-buffer-menu) + (setq major-mode 'tla-branch-list-mode) + (setq mode-name "tla-branch") + (add-hook 'tla-make-branch-hook 'tla-branch-refresh) + + (toggle-read-only 1) + (set-buffer-modified-p nil) + (set (make-local-variable 'dvc-get-revision-info-at-point-function) + 'tla--get-branch-info-at-point) + (run-hooks 'tla-branch-list-mode-hook)) + +(defun tla--get-branch-info-at-point () + "Get archive/category--branch--version information." + (let ((buffer-version (tla--name-construct + tla-buffer-archive-name + tla-buffer-category-name + (tla-get-archive-info 'tla-branch-info)))) + (list 'branch buffer-version))) + +(defun tla-branch-make-branch (branch) + "Create a new branch named BRANCH." + (interactive "sBranch name: ") + (tla-make-branch tla-buffer-archive-name + tla-buffer-category-name + branch)) + +(defun tla-branch-refresh () + "Refresh the current branch list." + (interactive) + (tla-branches + tla-buffer-archive-name + tla-buffer-category-name)) + +(defun tla-branch-list-parent-category () + "List the parent category of the current branch." + (interactive) + (tla-categories tla-buffer-archive-name)) + +(defun tla-branch-list-versions () + "List the versions of the current branch." + (interactive) + (let ((branch (tla-get-archive-info 'tla-branch-info))) + (if branch + (tla-versions tla-buffer-archive-name + tla-buffer-category-name + branch) + (error "No branch under the point")))) + +(dvc-make-bymouse-function tla-branch-list-versions) + +(defun tla-branch-mirror-archive () + "Mirror the current branch." + (interactive) + (let ((branch (tla-get-archive-info 'tla-branch-info))) + (unless branch + (error "No branch under the point")) + (tla-archive-mirror tla-buffer-archive-name + tla-buffer-category-name + branch))) + +(defun tla-branch-get-branch (directory) + "Get the current branch and place it in DIRECTORY." + (interactive (list (expand-file-name + (dvc-read-directory-name + (format "Restore \"%s\" to: " + (let ((branch + (tla-get-archive-info 'tla-branch-info))) + (unless branch + (error "No branch under the point")) + (tla--name-construct + tla-buffer-archive-name + tla-buffer-category-name + branch))))))) + (let ((branch (tla-get-archive-info 'tla-branch-info))) + (if branch + (tla-get directory + t + tla-buffer-archive-name + tla-buffer-category-name + branch) + (error "No branch under the point")))) + +(defun tla-branch-bookmarks-add-here (name) + "Add a bookmark named NAME for the current branch." + (interactive "sBookmark name: ") + (tla-bookmarks-add name + (list tla-buffer-archive-name + tla-buffer-category-name + (tla-get-archive-info 'tla-branch-info) + nil nil)) + (message "bookmark %s added." name)) + +(defun tla-branch-bookmarks-add (name) + "Add a bookmark named NAME for the current branch." + (interactive "sBookmark name: ") + (tla-bookmarks-add name + (list tla-buffer-archive-name + tla-buffer-category-name + nil nil nil)) + (message "bookmark %s added." name)) + + + + +;; ---------------------------------------------------------------------------- +;; tla-version-list-mode +;; ---------------------------------------------------------------------------- +(defun tla-version-list-mode () + "Major Mode to show arch versions: +\\{tla-version-list-mode-map}" + (interactive) + (kill-all-local-variables) + (use-local-map tla-version-list-mode-map) + (easy-menu-add tla-version-list-mode-menu) + (dvc-install-buffer-menu) + (setq major-mode 'tla-version-list-mode) + (setq mode-name "tla-version") + (add-hook 'tla-make-version-hook 'tla-version-refresh) + + (toggle-read-only 1) + (set-buffer-modified-p nil) + (set (make-local-variable 'dvc-get-revision-info-at-point-function) + 'tla--get-version-info-at-point) + (run-hooks 'tla-version-list-mode-hook)) + +(defun tla--get-version-info-at-point () + "Get archive/category--branch--version--revision information." + (let ((buffer-version (tla--name-construct + tla-buffer-archive-name + tla-buffer-category-name + tla-buffer-branch-name + (tla-get-archive-info 'tla-version-info)))) + (list 'version buffer-version))) + +(defun tla-version-refresh () + "Refresh the current version list." + (interactive) + (tla-versions + tla-buffer-archive-name + tla-buffer-category-name + tla-buffer-branch-name)) + +(defun tla-version-list-parent-branch () + "List the parent branch of this version." + (interactive) + (tla-branches tla-buffer-archive-name + tla-buffer-category-name)) + +(defun tla-version-list-revisions () + "List the revisions of this version." + (interactive) + (let ((version (tla-get-archive-info 'tla-version-info))) + (if version + (tla-revisions tla-buffer-archive-name + tla-buffer-category-name + tla-buffer-branch-name + version) + (error "No version under the point")))) + +(dvc-make-bymouse-function tla-version-list-revisions) + +(defun tla-version-make-version (version) + "Create a new version named VERSION." + (interactive "sVersion name: ") + (tla-make-version tla-buffer-archive-name + tla-buffer-category-name + tla-buffer-branch-name + version)) + +(defun tla-version-bookmarks-add-here (name) + "Add a bookmark named NAME for the current version." + (interactive "sBookmark name: ") + (tla-bookmarks-add name + (list tla-buffer-archive-name + tla-buffer-category-name + tla-buffer-branch-name + (tla-get-archive-info 'tla-version-info) + nil)) + (message "bookmark %s added." name)) + +(defun tla-version-bookmarks-add (name) + "Add a bookmark named NAME for the current version." + (interactive "sBookmark name: ") + (tla-bookmarks-add name + (list tla-buffer-archive-name + tla-buffer-category-name + tla-buffer-branch-name + nil nil)) + (message "bookmark %s added." name)) + +(defun tla-version-save-version-to-kill-ring () + "Save the version to the kill-ring." + (interactive) + (let ((version (cadr (tla--get-version-info-at-point)))) + (kill-new version) + (if (interactive-p) + (message "%s" version)) + version)) + +(defun tla-version-get-version (directory) + "Get a version and place it in DIRECTORY." + (interactive (list (expand-file-name + (dvc-read-directory-name + (format "Restore \"%s\" to: " + (let ((version + (tla-get-archive-info 'tla-version-info))) + (unless version + (error "No version under the point")) + (tla--name-construct + tla-buffer-archive-name + tla-buffer-category-name + tla-buffer-branch-name + version))))))) + (let ((version (tla-get-archive-info 'tla-version-info))) + (if version + (tla-get directory + t + tla-buffer-archive-name + tla-buffer-category-name + tla-buffer-branch-name + version) + (error "No version under the point")))) + + +(defun tla-version-mirror-archive () + "Mirror the current version." + (interactive) + (let ((version (tla-get-archive-info 'tla-version-info))) + (if version + (tla-archive-mirror tla-buffer-archive-name + tla-buffer-category-name + tla-buffer-branch-name + version)))) + +(defun tla-version-tag (to-archive to-category to-branch to-version) + "Run tla tag from the current location in version buffer. +The tag is created in TO-ARCHIVE/TO-CATEGORY--TO-BRANCH--TO-VERSION." + (interactive + (let ((l (tla-name-read "Tag to: " 'prompt 'prompt 'prompt 'prompt))) + (list + (tla--name-archive l) + (tla--name-category l) + (tla--name-branch l) + (tla--name-version l)))) + (let ((to-fq (tla--name-construct to-archive + to-category + to-branch + to-version)) + from-fq + (from-version (tla-get-archive-info 'tla-version-info))) + (unless from-version + (error "No version under the point")) + (setq from-fq (tla--name-construct + tla-buffer-archive-name + tla-buffer-category-name + tla-buffer-branch-name + from-version)) + (tla--version-tag-internal from-fq to-fq))) + + +(defun tla--version-tag-internal (from-fq to-fq &optional synchronously) + "Create a tag from FROM-FQ to TO-FQ. +If SYNCHRONOUSLY is non-nil, internal `tla-tag' and `tla-get' runs synchronously. +Else it runs asynchronously." + ;; `baz-branch' supports operations on both local working tree and + ;; archive side. If the first argument, from-fq of baz-branch not given, + ;; The operation on local working tree is taken. Here what we want is + ;; archive side operation. So check from-fq heavily. + (cond + ((null from-fq) (error "from-fq is not specified")) + ((not (stringp from-fq)) (error "from-fq is not string")) + ((string= from-fq "") (error "from-fq is an empty string"))) + (when (yes-or-no-p (format "Create a tag from `%s' to `%s'? " from-fq to-fq)) + (unless (funcall (if (tla-has-branch-command) + 'baz-branch + 'tla-tag) + from-fq to-fq (tla--tag-does-cacherev) synchronously) + (error "Fail to create a tag")) + (when (y-or-n-p "Tag created. Get a copy of this revision? ") + (let* ((prompt "Get a copy in: ") + dir parent + to-fq-split) + (while (not dir) + (setq dir (dvc-read-directory-name prompt dir) + parent (expand-file-name + (concat (file-name-as-directory dir) ".."))) + (cond + ;; Parent directoy must be. + ((not (file-directory-p parent)) + (message "`%s' is not directory" parent) + (sit-for 2) + (setq dir nil)) + ;; dir itself must not be. + ((file-exists-p dir) + (message "`%s' exists already" dir) + (sit-for 2) + (setq dir nil)))) + (setq to-fq-split (tla--name-split to-fq)) + (tla-get dir 'ask + (nth 0 to-fq-split) + (nth 1 to-fq-split) + (nth 2 to-fq-split) + (nth 3 to-fq-split) + (nth 4 to-fq-split) + synchronously))))) + +;; ---------------------------------------------------------------------------- +;; tla-revision-list-mode +;; ---------------------------------------------------------------------------- +(require 'dvc-revlist) +(define-derived-mode tla-revision-list-mode dvc-revlist-mode + "tla-revisions" + "Major mode to show Arch revision lists: +\\{tla-revision-list-mode-map}." + (use-local-map tla-revision-list-mode-map) + (set (make-local-variable 'dvc-get-revision-info-at-point-function) + 'tla--revision-get-revision-at-point)) + +(defun tla--revision-get-revision-at-point () + "Get archive/category--branch--version--revision--patch information. +Returns nil if not on a revision list, or not on a revision entry in a +revision list." + (let ((elem (ewoc-data (ewoc-locate dvc-revlist-cookie)))) + (when (eq (car elem) 'entry-patch) + (let ((full (tla--revision-revision + (dvc-revlist-entry-patch-struct (nth 1 elem))))) + (tla--name-construct full))))) + +(defun tla--revision-get-version-info-at-point () + "Get archive/category--branch--version--revision information. +Returns nil if not on a revision list, or not on a revision entry in a +revision list." + (list 'version + (tla--name-mask (tla--name-split + (tla--revision-get-revision-at-point)) t + t t t t))) + +(defun tla-revision-save-revision-to-kill-ring () + "Save the name of the current revision to the kill ring." + (interactive) + (let ((rev (tla--revision-get-revision-at-point))) + (unless rev + (error "No revision at point")) + (kill-new rev) + (if (interactive-p) + (message "%s" rev)) + rev)) + +(defun tla-revision-save-version-to-kill-ring () + "Save the name of the current version to the kill ring." + (interactive) + (let ((rev (cadr (tla--revision-get-version-info-at-point)))) + (unless rev + (error "No version at point")) + (kill-new rev) + (if (interactive-p) + (message "%s" rev)) + rev)) + +(defun tla-revision-refresh () + "Refresh the current list of revisions." + (interactive) + (tla-revisions + tla-buffer-archive-name + tla-buffer-category-name + tla-buffer-branch-name + tla-buffer-version-name)) + +(defun tla-revision-list-parent-version () + "List the versions of the parent of this revision." + (interactive) + (tla-versions tla-buffer-archive-name + tla-buffer-category-name + tla-buffer-branch-name)) + +(defun tla-revision-get-revision (directory archive category branch + version revision) + "Get a revision and place it in DIRECTORY. +The revision is named by ARCHIVE/CATEGORY--BRANCH--VERSION--REVISION." + (interactive + (let* ((elem (ewoc-data (ewoc-locate dvc-revlist-cookie))) + (full (tla--revision-revision + (dvc-revlist-entry-patch-struct (nth 1 elem)))) + (revision (tla--name-revision full)) + (archive (tla--name-archive full)) + (category (tla--name-category full)) + (branch (tla--name-branch full)) + (version (tla--name-version full)) + dir) + (unless revision + (error "No revision under the point")) + (setq dir (expand-file-name + (dvc-read-directory-name + (format "Restore \"%s\" to: " + (tla--name-construct + archive category branch version revision))))) + (if (file-exists-p dir) + (error "Directory %s already exists" dir)) + (list dir archive category branch version revision))) + (if revision + (tla-get directory t archive category branch version revision) + (error "No revision under the point"))) + +(defun tla-revision-cache-revision (archive category branch version revision) + "Create a cached revision for the revision at point." + (interactive + (let* ((elem (ewoc-data (ewoc-locate dvc-revlist-cookie))) + (full (tla--revision-revision (car (cddr elem)))) + (archive (tla--name-archive full)) + (category (tla--name-category full)) + (branch (tla--name-branch full)) + (version (tla--name-version full)) + (revision (tla--name-revision full))) + (unless revision + (error "No revision under the point")) + (list archive category branch version revision))) + (if revision + (tla-cache-revision archive category branch version revision) + (error "No revision under the point"))) + +(defun tla-revision-add-to-library (archive category branch version revision) + "Add the revision at point to library." + (interactive + (let* ((elem (ewoc-data (ewoc-locate dvc-revlist-cookie))) + (full (tla--revision-revision (car (cddr elem)))) + (archive (tla--name-archive full)) + (category (tla--name-category full)) + (branch (tla--name-branch full)) + (version (tla--name-version full)) + (revision (tla--name-revision full))) + (unless revision + (error "No revision under the point")) + (list archive category branch version revision))) + (if revision + (tla-library-add archive category branch version revision) + (error "No revision under the point"))) + +(defun tla-revision-refresh-maybe () + "Refresh the revision list if new information is available. +If the current ewoc doesn't contain creator, date, and summary, and +if these values should now be displayed, run the refresh function." + (when (or dvc-revisions-shows-date + dvc-revisions-shows-creator + dvc-revisions-shows-summary + tla-revisions-shows-merges + tla-revisions-shows-merged-by) + (let ((stop nil) + (ewoc-elem (ewoc-nth dvc-revlist-cookie 0))) + (while (and ewoc-elem (not stop)) + (let ((elem (ewoc-data ewoc-elem))) + (if (eq (car elem) 'entry-patch) + (setq stop t) + (setq ewoc-elem (ewoc-next dvc-revlist-cookie + ewoc-elem))))) + (when (and ewoc-elem + (null (tla--revision-summary + (dvc-revlist-entry-patch-struct (nth 1 (ewoc-data ewoc-elem)))))) + (dvc-generic-refresh))))) + +(defun tla-revision-toggle-library () + "Toggle display of the revision library in the revision list." + (interactive) + (setq tla-revisions-shows-library (not tla-revisions-shows-library)) + (ewoc-refresh dvc-revlist-cookie)) + +(defun tla-revision-toggle-merges () + "Toggle display of the merges in the revision list." + (interactive) + (setq tla-revisions-shows-merges (not tla-revisions-shows-merges)) + (tla-revision-refresh-maybe) + (ewoc-refresh dvc-revlist-cookie)) + +(defun tla-revision-toggle-merged-by () + "Toggle display of merged-by in the revision list." + (interactive) + (setq tla-revisions-shows-merged-by + (not tla-revisions-shows-merged-by)) + (when (and (not tla-revision-merge-by-computed) + tla-revisions-shows-merged-by) + (tla-revision-refresh-maybe) + (tla-revision-compute-merged-by)) + (ewoc-refresh dvc-revlist-cookie)) + +(defun tla-revision-scroll-or-show-changeset (up-or-down) + "If file-diff buffer is visible, scroll. Otherwise, show it." + (interactive) + (let* ((cookie dvc-revlist-cookie) + (full (tla--revision-revision + (caddr (ewoc-data (ewoc-locate cookie))))) + (revision (tla--name-construct full))) + (unless revision + (error "No revision info at point.")) + (let ((buffer (dvc-get-buffer + tla-arch-branch 'changeset revision))) + (dvc-trace "buffer=%S revision=%S tla-arch-branch=%S" buffer + revision tla-arch-branch) + (unless (dvc-scroll-maybe buffer up-or-down) + (tla-revision-changeset))))) + +(defun tla-revision-scroll-up-or-show-changeset () + (interactive) + (tla-revision-scroll-or-show-changeset 'scroll-up)) + +(defun tla-revision-scroll-down-or-show-changeset () + (interactive) + (tla-revision-scroll-or-show-changeset 'scroll-down)) + +;;TODO: remove tla-revision-changeset if it is really no longer needed... +(defun tla-revision-changeset (&optional arg) + "Gets and display the changeset at point in a revision list buffer. +If used with a prefix arg ARG, don't include the diffs from the output." + (interactive "P") + (error "tla-revision-changeset should be handled by DVC now...") + (let* ((window-conf (current-window-configuration)) + (cur-buf (current-buffer)) + (cookie dvc-revlist-cookie) + (full (tla--revision-revision + (dvc-revlist-entry-patch-struct + (nth 1 (ewoc-data (ewoc-locate cookie)))))) + (revision (tla--name-construct full))) + (tla-get-changeset revision t nil arg) + + (setq dvc-partner-buffer + (dvc-get-buffer-create tla-arch-branch + 'changeset revision)) + (dvc-trace "before with. dvc-partner-buffer=%S" dvc-partner-buffer) + (with-current-buffer dvc-partner-buffer + (setq dvc-partner-buffer cur-buf)) + + (when (or (dvc-do-in-xemacs (setq window-conf t) + window-conf ;; we use window-conf only to get rid of warnings + ) + (dvc-do-in-gnu-emacs (compare-window-configurations + (current-window-configuration) window-conf))) + (dvc-scroll-maybe dvc-partner-buffer 'scroll-up)))) + +(defun tla-revision-store-delta (across-versions) + "Store a delta between two marked revisions. +If prefix argument ACROSS-VERSIONS is given, read revision details from the +user." + (interactive "P") + (tla-revision-delta across-versions t)) + +(defun tla-revision-delta (across-versions &optional stored-to-directory) + "Run tla delta from marked revision to revision at point. +If prefix-argument ACROSS-VERSIONS is nil, read a revision +in the current version. If ACROSS-VERSIONS is non-nil, read an archive, +a category, a branch, a version, and a revision to specify the revision. +If STORED-TO-DIRECTORY is nil, ask the user whether the changeset is stored +to or not. If STORED-TO-DIRECTORY is non-nil, don't ask the use and the +changeset is stored." + (interactive "P") + (let* ((modified + (tla--revision-revision + (car (cddr (ewoc-data (ewoc-locate dvc-revlist-cookie)))))) + (modified-fq (tla--name-construct modified)) + (base + (let ((marked (dvc-revision-marked-revisions))) + (when (< 1 (length marked)) + (error "Delta can be run against one marked revision as the base revision")) + (cond ((and marked (null (cdr marked))) + ;; use the marked revision + ;; (dvc-revision-unmark-all) + (tla--revision-revision (car marked))) + (t + (tla-name-read + (format "Revision for delta to %s from: " + (if across-versions + modified-fq + (tla--name-revision modified))) + (if across-versions 'prompt (tla--name-archive modified)) + (if across-versions 'prompt (tla--name-category modified)) + (if across-versions 'prompt (tla--name-branch modified)) + (if across-versions 'prompt (tla--name-version modified)) + 'maybe)))))) + + (unless (tla--name-archive base) + (error "Archive for the base is not specified")) + (unless (tla--name-category base) + (error "Cateogory for the base is not specified")) + (unless (tla--name-branch base) + (error "Branch for the base is not specified")) + (unless (tla--name-version base) + (error "Version for the base is not specified")) + (unless (tla--name-revision base) + ;; No revision for modified is specified. + ;; Use HEAD revision. + (setcar (nthcdr 4 base) + (tla--version-head + (tla--name-archive base) + (tla--name-category base) + (tla--name-branch base) + (tla--name-version base)))) + + (when (or stored-to-directory + (and (not stored-to-directory) + (y-or-n-p "Store the delta to a directory? "))) + (setq stored-to-directory 'ask)) + + (tla-delta (tla--name-construct base) + modified-fq + stored-to-directory))) + +(defun tla-revision-bookmarks-add (name) + "Add a bookmark named NAME for the current revision." + (interactive "sBookmark name: ") + (tla-bookmarks-add name + (tla--revision-revision + (car (cddr (ewoc-data (ewoc-locate dvc-revlist-cookie)))))) + (message "bookmark %s added." name)) + +(defun tla-revision-sync-tree (arg) + "Unify a tree's patch log with the current revision. +With prefix argument ARG, use the latest version instead." + (interactive "P") + (let* ((last-inventory (tla--last-visited-inventory-buffer)) + (local-tree (or (if last-inventory + (with-current-buffer last-inventory + default-directory) + default-directory))) + (current (ewoc-locate dvc-revlist-cookie))) + (while (and current + (not (and (eq (car (ewoc-data current)) + 'separator) + (eq (car (cddr (ewoc-data current))) + 'bookmark)))) + (setq current (ewoc-prev dvc-revlist-cookie current))) + (when (and current + (eq (car (ewoc-data current)) 'separator) + (eq (car (cddr (ewoc-data current))) 'bookmark)) + (setq local-tree (cadddr (ewoc-data current)))) + (let ((to-tree (dvc-read-directory-name "Sync with tree: " local-tree))) + (let* ((elem (ewoc-data (ewoc-locate + dvc-revlist-cookie))) + (full (tla--revision-revision + (dvc-revlist-entry-patch-struct (nth 1 elem))))) + (tla-sync-tree (tla--name-construct + (if arg (butlast full) full)) + to-tree))))) + +(defun tla-revision-star-merge-version () + "Run star-merge for the version at point." + (interactive) + (tla-revision-star-merge t)) + +(defun tla-revision-star-merge (arg) + "Run star-merge from the revision at point. +With prefix argument ARG, merge all missing revisions from this version." + (interactive "P") + (let* ((last-inventory (tla--last-visited-inventory-buffer)) + (local-tree (or (if last-inventory + (with-current-buffer last-inventory + default-directory) + default-directory))) + (current (ewoc-locate dvc-revlist-cookie))) + (while (and current + (not (and (eq (car (ewoc-data current)) + 'separator) + (eq (car (cddr (ewoc-data current))) + 'bookmark)))) + (setq current (ewoc-prev dvc-revlist-cookie current))) + (when (and current + (eq (car (ewoc-data current)) 'separator) + (eq (car (cddr (ewoc-data current))) 'bookmark)) + (setq local-tree (cadddr (ewoc-data current)))) + (let ((to-tree (dvc-read-directory-name "Merge to tree: " + local-tree local-tree t))) + (let* ((elem (ewoc-data (ewoc-locate + dvc-revlist-cookie))) + (full (tla--revision-revision + (dvc-revlist-entry-patch-struct (nth 1 elem))))) + (tla-star-merge (tla--name-construct + (if arg (butlast full) full)) + to-tree))))) + +(defun tla-revision-replay-version () + "Call `tla-revision-replay' with a prefix arg." + (interactive) + (tla-revision-replay 'all)) + +(defun tla-revision-lessp (rev1 rev2) + "Compares REV1 and REV2 as strings. + +Similar to `string-lessp', but sorts numerical substring according to +numerical value instead of lexicographical order. + +\(tla-revision-lessp \"patch-2\" \"patch-10\") will be true for +example." + (let ((s1 (string-to-list rev1)) + (s2 (string-to-list rev2)) + (result 'dont-know)) + (while (eq result 'dont-know) + (cond ((and (null s1) (null s2)) + (setq result t)) + ((null s1) + (setq result t)) + ((null s2) + (setq result nil)) + ((and (dvc-digit-char-p (car s1)) + (dvc-digit-char-p (car s2))) + (setq result (tla-revision-lessp-digit s1 s2))) + ((not (eq (car s1) (car s2))) + (setq result (< (car s1) (car s2)))) + (t + (setq s1 (cdr s1) + s2 (cdr s2))))) + result)) + +(defun tla-revision-lessp-digit (s1 s2) + "Compare S1 and S2 (as lists of char) starting with a number. + +For example, '(?1 ?2 ?f ?o? ?o) and '(?4 ?2 ?b ?a ?r)." + (let (sub1 sub2) + (while (and s1 (dvc-digit-char-p (car s1))) + (setq sub1 (cons (car s1) sub1)) + (setq s1 (cdr s1))) + (while (and s2 (dvc-digit-char-p (car s2))) + (setq sub2 (cons (car s2) sub2)) + (setq s2 (cdr s2))) + (let* ((num1 (string-to-number (concat (nreverse sub1)))) + (num2 (string-to-number (concat (nreverse sub2))))) + (cond ((equal num1 num2) + (tla-revision-lessp s1 s2)) + (t (< num1 num2)))))) + +(defun tla-revision-replay (arg) + "Run replay from the current location. +If there are marked revisions, these are replayed. +If these are marked revisions and ARG is `reversely', these +are replayed reversely. If ARG is `all', all missing revisions +from this version are replayed. If there are no marked +revisions is given, and ARG is `nil', the revision under the point +is replayed. If you call this function interactively, give a positive +prefix argument to set ARG `all' or give a negative prefix argument +to set ARG `reversely'. If no prefix argument is given, ARG is set to `nil'." + (interactive (list + (cond + ((eq current-prefix-arg nil) nil) + ((or (eq current-prefix-arg '-) + (and + (numberp current-prefix-arg) + (> 0 current-prefix-arg))) + 'reversely) + (current-prefix-arg + 'all)))) + (let* ((last-inventory (tla--last-visited-inventory-buffer)) + (local-tree (or (if last-inventory + (with-current-buffer last-inventory + default-directory) + default-directory))) + (current (ewoc-locate dvc-revlist-cookie)) + marked) + (while (and current + (not (and (eq (car (ewoc-data current)) + 'separator) + (eq (car (cddr (ewoc-data current))) + 'bookmark)))) + (setq current (ewoc-prev dvc-revlist-cookie current))) + (when (and current + (eq (car (ewoc-data current)) 'separator) + (eq (car (cddr (ewoc-data current))) 'bookmark)) + (setq local-tree (cadddr (ewoc-data current)))) + + (setq marked (dvc-revision-marked-revisions)) + (let ((to-tree (dvc-read-directory-name + (format "Replay%s to tree: " + (cond + ((eq arg 'reversely) + (if marked + (format " %d MARKED revision%s REVERSELY" + (length marked) + (if (eq (length marked) 1) "" "s")) + " a revision under the point REVERSELY")) + ((eq arg 'all) + " ALL missing revisions") + (t (if marked + (format " %d MARKED revision%s" + (length marked) + (if (eq (length marked) 1) "" "s")) + " a revision under the point")))) + local-tree + ))) + (if marked + (let ((revisions (mapcar 'tla--revision-revision marked))) + (tla-replay (sort (mapcar (lambda (revision) + (tla--name-construct + revision)) + revisions) + 'tla-revision-lessp) + to-tree + (when (eq arg 'reversely) t))) + (let* ((elem (ewoc-data (ewoc-locate + dvc-revlist-cookie))) + (full (tla--revision-revision (or (car (cddr elem)) + ;; single unmarked item + (aref (cadr elem) 3))))) + (tla-replay (tla--name-construct + (if (eq arg 'all) (butlast full) full)) + to-tree + (when (eq arg 'reversely) t))))))) + +(defun tla-revision-tag-from-head () + "Run tla tag from the newest revision in revision buffer." + (interactive) + (let* ((from (when tla-buffer-archive-name + (tla--name-construct tla-buffer-archive-name + tla-buffer-category-name + tla-buffer-branch-name + tla-buffer-version-name)))) + (unless from (error "No head revision")) + (tla--revision-tag-internal from))) + +(defun tla-revision-tag-from-here () + "Run tla tag from the current location in revision buffer." + (interactive) + (let ((from (when dvc-revlist-cookie + (let* ((elem (ewoc-data (ewoc-locate + dvc-revlist-cookie)))) + (apply 'tla--name-construct (aref (car (cddr elem)) 1)))))) + (unless from (error "No revision here")) + (tla--revision-tag-internal from))) + +(defun tla--revision-tag-internal (from-fq) + "Tag from FROM-FQ to some destination." + (let* ((to (tla-name-read "Tag to: " + 'prompt 'prompt 'prompt 'prompt)) + (to-fq (tla--name-construct to))) + (tla--version-tag-internal from-fq to-fq))) + +(defun tla-revision-revlog () + "Show the log entry for the revision at point." + (interactive) + (let* ((elem (ewoc-data (ewoc-locate + dvc-revlist-cookie))) + (full (tla--revision-revision + (dvc-revlist-entry-patch-struct (nth 1 elem)))) + (cur-buf (current-buffer)) + (log-buf (tla--revlog-any full)) + (display-buf (dvc-get-buffer-create tla-arch-branch 'revlog + (tla--name-construct full)))) + (dvc-switch-to-buffer display-buf) + (let ((inhibit-read-only t)) + (erase-buffer) + (insert (with-current-buffer log-buf + (buffer-string))) + (goto-char (point-min))) + (tla-revlog-mode) + (when (eq dvc-switch-to-buffer-mode 'pop-to-buffer) + (pop-to-buffer cur-buf)))) + +;;;###autoload +(defun tla-revlog-any (revision) + "Show the log entry for REVISION (a string)." + (interactive (list (tla--name-construct + (tla-name-read "Revision spec: " + 'prompt 'prompt 'prompt 'prompt 'prompt)))) + (let* ((log-buf (tla--revlog-any revision)) + (display-buf (dvc-get-buffer-create tla-arch-branch 'revlog revision))) + (dvc-switch-to-buffer display-buf) + (let ((inhibit-read-only t)) + (erase-buffer) + (insert (with-current-buffer log-buf + (buffer-string))) + (goto-char (point-min))) + (tla-revlog-mode))) + +(defun tla-revision-update () + "Run tla update for this revision." + (interactive) + (let ((local-tree default-directory) ;; Default value + (current (ewoc-locate dvc-revlist-cookie))) + (while (and current + (not (and (eq (car (ewoc-data current)) + 'separator) + (eq (car (cddr (ewoc-data current))) + 'bookmark)))) + (setq current (ewoc-prev dvc-revlist-cookie current))) + (when (and current + (eq (car (ewoc-data current)) 'separator) + (eq (car (cddr (ewoc-data current))) 'bookmark)) + (setq local-tree (cadddr (ewoc-data current)))) + (let ((buffer (current-buffer))) + (tla-update (dvc-read-directory-name "Update tree: " + local-tree) + (dvc-capturing-lambda () + (pop-to-buffer (capture buffer)) + (dvc-generic-refresh)))))) + +(defun tla-revision-send-comments (revision &optional email) + "Sends comments to the author of REVISION. + +The email is extracted from the archive name. A new mail message is +opened with a description of the revision. REVISION must be the same +structure as the elem of `dvc-revlist-cookie', or a string. + +When called interactively, REVISION is the revision at point." + (interactive (list (car (cddr (ewoc-data (ewoc-locate dvc-revlist-cookie)))))) + (let* ((full-rev (tla--revision-revision revision)) + (archive (tla--name-archive full-rev)) + (email (or email + (progn (string-match "\\(.*\\)--\\([^-]\\|-[^-]\\)" + archive) + (match-string 1 archive)))) + (summary (tla--revision-summary revision)) + (subject tla-send-comments-format)) + (dolist (pair '(("%f" . (tla--name-construct full-rev)) + ("%a" . archive) + ("%c" . (tla--name-category full-rev)) + ("%b" . (tla--name-branch full-rev)) + ("%v" . (tla--name-version full-rev)) + ("%r" . (tla--name-revision full-rev)) + ("%s" . summary) + ("%t" . (if (> (string-width summary) + tla-send-comments-width) + (concat (truncate-string-to-width summary 25) + "...") + summary)))) + (setq subject + (replace-regexp-in-string (car pair) (eval (cdr pair)) + subject))) + (compose-mail email subject) + (save-excursion + (insert "\n\n" (tla--name-construct full-rev) "\n" + " " summary "\n" + " " (tla--revision-date revision) "\n" + " " (tla--revision-creator revision) "\n")))) + +(defun tla--changes-what-changed-original-file (file) + "Remove what-changed directory part from FILE and return it." + (if (string-match + "\\(/,,what-changed[^/]+/new-files-archive\\)" + file) + (concat (substring file 0 (match-beginning 1)) + (substring file (match-end 1))) + file)) + + +(defun dvc-diff-master-buffer () + "Jump to the master *{tla|baz}-changes* buffer for a nested changes buffer." + (interactive) + (unless tla--changes-buffer-master-buffer + (error "No master buffer")) + (dvc-switch-to-buffer tla--changes-buffer-master-buffer)) + +(defun dvc-diff-view-source (&optional other-file) + "Show the corresponding file and location of the change. +This function does not switch to the file, but it places the cursor +temporarily at the location of the change and will stay in the changes +buffer. Thus you can quickly see more context on a specific change without +switching buffers. +The prefix argument OTHER-FILE controls whether the original or new +file is visited." + (interactive "P") + (let ((diff-window (selected-window))) + (save-excursion + (diff-goto-source other-file) + (recenter) + (dvc-flash-line) + (select-window diff-window)))) + +(defun dvc-diff-save-current-defun-as-kill () + "Copy the function name for the change at point to the kill-ring. +That function uses `add-log-current-defun'" + (interactive) + (let ((func-name (add-log-current-defun))) + (if func-name + (progn + (kill-new func-name) + (message "Copied %S" func-name)) + (message "No current defun detected.")))) + + +(defun dvc-diff-jump-to-change-by-mouse (event &optional other-file) + "Jump to the changes." + (interactive "e\nP") + (mouse-set-point event) + (dvc-diff-jump-to-change other-file)) + +(defalias 'tla-changes-revert 'tla-inventory-revert) + + +;; ---------------------------------------------------------------------------- +;; tla-changelog-mode +;; ---------------------------------------------------------------------------- + +(define-derived-mode tla-changelog-mode change-log-mode "tla-changelog" + (set (make-local-variable 'font-lock-defaults) + (list 'tla-changelog-font-lock-keywords + t nil nil 'backward-paragraph)) + (use-local-map tla-changelog-mode-map) + (set (make-local-variable 'tla-button-marker-list) + nil) + (unless tla-dont-hyperlink-changelog (tla-add-buttons))) + +(defconst tla-changelog-start-regexp "^[0-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9] ") +(defun tla-changelog-next-entry (n) + "Go to the next entry in the changelog. +If called with a prefix argument, skip n entries forward." + (interactive "p") + (re-search-forward tla-changelog-start-regexp nil t n) + (search-forward "Summary:" nil t)) + +(defun tla-changelog-previous-entry (n) + "Go to the previous entry in the changelog. +If called with a prefix argument, skip n entries backward." + (interactive "p") + (end-of-line) + (re-search-backward tla-changelog-start-regexp) + (re-search-backward tla-changelog-start-regexp nil t n) + (search-forward "Summary:")) + +(defun tla-changelog-revision-at-point () + "Return the patch number at point in a tla changelog buffer." + (save-excursion + (let ((patch-nr (progn + (end-of-line) + (re-search-backward tla-changelog-start-regexp) + (re-search-forward "\\(\\(patch\\|base\\|version\\)-[0-9]+\\)$") + (match-string-no-properties 1))) + (version (progn + (goto-char (point-min)) + (search-forward "arch-tag: automatic-ChangeLog--") + (buffer-substring-no-properties (point) (line-end-position))))) + (concat version "--" patch-nr)))) + +(defun tla-changelog-version-at-point () + "Return the version at point in a tla changelog buffer." + (tla--name-mask (tla--name-split (tla-changelog-revision-at-point)) t t t t t nil)) + +(defun tla-changelog-show-changeset () + "Show the changeset for the actual changelog entry." + (interactive) + (tla-get-changeset (tla-changelog-revision-at-point) t)) + +(defun tla-changelog-log-summary-at-point () + "Return the log message summary string at point as string." + (save-excursion + (re-search-backward tla-changelog-start-regexp) + (re-search-forward "Summary:\n +") + (buffer-substring-no-properties (point) (line-end-position)))) + +(defun tla-changelog-log-message-at-point () + "Return the log message at point as string." + (save-excursion + (let ((start-pos (progn + (re-search-backward tla-changelog-start-regexp) + (point))) + (end-pos (progn + (re-search-forward "\\(modified\\|new\\) files:") + (forward-line -2) + (line-end-position)))) + (buffer-substring-no-properties start-pos end-pos)))) + +(defun tla-changelog-save-log-message-as-kill () + "Save the log message for the actual patch." + (interactive) + (kill-new (tla-changelog-log-message-at-point)) + (message "Copied log message for %s" (tla-changelog-revision-at-point))) + +(defun tla-changelog-save-revision-as-kill () + "Save the revision for the actual patch to the kill-ring." + (interactive) + (kill-new (tla-changelog-revision-at-point)) + (message "Copied %s" (tla-changelog-revision-at-point))) + +(defun tla-changelog-save-version-as-kill () + "Save the version for the actual patch to the kill-ring." + (interactive) + (kill-new (tla-changelog-version-at-point)) + (message "Copied %s" (tla-changelog-version-at-point))) + +;; ---------------------------------------------------------------------------- +;; tla-inventory-file-mode +;; ---------------------------------------------------------------------------- +;;;###autoload +(defun tla-inventory-file-mode () + "Major mode to edit tla inventory files (=tagging-method, .arch-inventory)." + (interactive) + (kill-all-local-variables) + (set (make-local-variable 'font-lock-defaults) + '(tla-inventory-file-font-lock-keywords t)) + (set (make-local-variable 'comment-start) "# ") + (setq major-mode 'tla-inventory-file-mode + mode-name "tla-inventory-file") + (run-hooks 'tla-inventory-file-mode-hook)) + +(defun tla--inventory-file-jump-from-head (category) + "Search CATEGORY from the head of the buffer." + (let ((p (save-excursion (goto-char (point-min)) + (re-search-forward + (concat "^" category) nil t)))) + (when p + (goto-char p)))) + +(defun tla--inventory-file-jump-from-tail (category) + "Search CATEGORY from the tail of the buffer. +Return nil if CATEGORY is not found." + (let ((p (save-excursion (goto-char (point-max)) + (re-search-backward + (concat "^" category) nil t)))) + (when p + (goto-char p)))) + +(defun tla--inventory-file-add-file (category file &optional ext-only) + "Added FILE to CATEGORY." + (unless (tla--inventory-file-jump-from-tail category) + (goto-char (point-min))) + (save-excursion (open-line 1)) + ;; TODO regexp quote FILE + (insert (format (if ext-only "%s %s$" "%s ^(%s)$") category file))) + +;; ---------------------------------------------------------------------------- +;; Find file hook +;; ---------------------------------------------------------------------------- +;; just 99% cut&paste from vc-follow-link in vc-hook.el, but this way there is +;; no need to load it thus avoiding interfering with VC ... +(defun tla-follow-link () + "Follow a symbolic link. +If the current buffer visits a symbolic link, this function makes it +visit the real file instead. If the real file is already visited in +another buffer, make that buffer current, and kill the buffer +that visits the link." + (let* ((truename (abbreviate-file-name (file-truename buffer-file-name))) + (true-buffer (find-buffer-visiting truename)) + (this-buffer (current-buffer))) + (if (eq true-buffer this-buffer) + (progn + (kill-buffer this-buffer) + ;; In principle, we could do something like set-visited-file-name. + ;; However, it can't be exactly the same as set-visited-file-name. + ;; I'm not going to work out the details right now. -- rms. + (set-buffer (find-file-noselect truename))) + (set-buffer true-buffer) + (kill-buffer this-buffer)))) + +(defun tla-find-file-hook () + "Hook executed when opening a file. +Follow symlinked files/directories to the actual location of a file. +See also `dvc-find-file-hook'." + (let (link file result) + (when (and (if (boundp 'vc-ignore-vc-files) + (not vc-ignore-vc-files) + t) + (if (fboundp 'file-remote-p) + (not (file-remote-p (buffer-file-name))) + t) + tla-follow-symlinks + (setq file buffer-file-name) + (not (string= (setq link (file-truename file)) file))) + (setq file link + result (cond ((equal tla-follow-symlinks 'tree) + (tla-tree-root file t)) + ((equal tla-follow-symlinks 'id) + (= 0 (tla--run-tla-sync + (list "id" file) + :finished 'dvc-status-handler + :error 'dvc-status-handler))))) + + (if result + (cond ((eq tla-follow-symlinks-mode 'warn) + (message + "Warning: symbolic link to arch-controlled source file: %s" + file)) + ((or (eq tla-follow-symlinks-mode 'follow) + (find-buffer-visiting file)) + (tla-follow-link) + (message "Followed link to arch-controlled %s" + buffer-file-name)) + ((eq tla-follow-symlinks-mode 'ask) + (if (y-or-n-p "Follow symbolic link to arch-controlled source file? ") + (progn + (tla-follow-link) + (message "Followed link to arch-controlled %s" + buffer-file-name)) + (message + "Warning: editing through the link bypasses version control"))) + (t (error "Unknown mode for tla-follow-symlinks-mode=%s" + tla-follow-symlinks-mode))) + )))) + +;; ---------------------------------------------------------------------------- +;; Misc functions +;; ---------------------------------------------------------------------------- +(defvar tla--insert-arch-tag-functions + '((autoconf-mode . tla--insert-arch-tag-for-autoconf-mode) + (makefile-mode . tla--insert-arch-tag-for-makefile-mode) + (texinfo-mode . tla--insert-arch-tag-for-texinfo-mode) + ) + "Alist containing per mode specialized functions for inserting arch-tag. +Key stands for a major mode. Value is a function which inserts arch-tag. +The function takes two arguments. The first argument is an uuid string. +The second argument is a boolean showing whether the point is in a comment +or not." ) + +(defconst tla--arch-tag-string (concat "arch-ta" "g: ") + "To avoid having the string a-r-c-h--t-a-g: in this buffer ;-).") + +(defun tla-tag-uuid () + "Candidate for `tla-tag-function'. +Returns a unique string using uuidgen" + (dvc-strip-final-newline (shell-command-to-string "uuidgen"))) + +(defun tla-tag-name-date-filename () + "Candidate for `tla-tag-function'. +Returns a string containing the name of the user, the precise date, +and the name of the current file. This should be unique worldwide, +has the advantage of containing usefull information in addition to +the unique identifier. The inconvenient in comparison to +`tla-tag-uuid' is that an unfortunate modification of the tag is more +easily made (sed script or manual modification)" + (concat (user-full-name) ", " + (format-time-string "%c") + " (" (file-name-nondirectory (buffer-file-name)) ")")) + +;;;###autoload +(defun tla-tag-string () + "Return a suitable string for an arch-tag. +Actually calls `tla-tag-function', which defaults to `tla-tag-uuid' to generate +string (and possibly add a comment-end after). + +Interactively, you should call `tla-tag-insert', but this function can +be usefull to write template files." + (funcall tla-tag-function)) + +;;;###autoload +(defun tla-tag-insert () + "Insert a unique arch-tag in the current file. +Actually calls `tla-tag-function', which defaults to `tla-tag-uuid' to generate +string (and possibly add a comment-end after)" + (interactive) + (let ((the-tag-itself (tla-tag-string)) + (in-comment-p (nth 4 (parse-partial-sexp (point) (point-min)))) + (header "") + (footer "") + (handler (assoc major-mode tla--insert-arch-tag-functions))) + (if (cdr handler) + (funcall (cdr handler) the-tag-itself in-comment-p) + (unless in-comment-p + (setq header (if comment-start + (concat comment-start + (if (string-match " $" comment-start) + "" " ")) + "") + footer (if (and comment-end (not (string= "" comment-end))) + (format "\n%s(do not change this comment)%s%s" + (make-string (length header) ?\ ) + comment-end + (if (string-match "^ " comment-end) + "" " ")) + ""))) + (insert (concat header tla--arch-tag-string the-tag-itself + footer))))) + +;;;###autoload +(defun tla-tag-regenerate () + "Find an arch tag in the current buffer and regenerates it. +This means changing the ID of the file, which will usually be done after +copying a file in the same tree to avoid duplicates ID. + +Raises an error when multiple tags are found or when no tag is found." + (interactive) + (let ((second-tag + (save-excursion + (goto-char (point-min)) + (unless (search-forward tla--arch-tag-string nil t) + (error "No arch tag in this buffer")) + (delete-region (point) (progn (end-of-line) (point))) + (insert (funcall tla-tag-function)) + (if (search-forward tla--arch-tag-string nil t) + (point) + nil)))) + (when second-tag + (goto-char second-tag) + (beginning-of-line) + (error "Multiple tag in this buffer")))) + +(defun tla-regenerate-id-for-file (file) + "Create a new id for the file FILE. +Does roughly + +$ tla delete file +$ tla add file + +But also works for the tagline method. When the tagline method is +used, the file is opened in a buffer. If the file had modifications, +the tag is modified in the buffer, and the user is prompted for +saving. If the file had no unsaved modifications, the modification is +done in the buffer and the file is saved without prompting. + +FILE must be an absolute filename. It can also be a directory" + (interactive "f") + (cond + ((file-directory-p file) + (progn + (delete-file (concat (file-name-as-directory file) + ".arch-ids/=id")) + (tla-add nil file))) + ((string-match "^\\(.*\\)/\\.arch-ids/=id" file) ;; file is an =id file. + (tla-regenerate-id-for-file (match-string 1 file))) + ((string-match "^\\(.*\\)/\\.arch-ids/\\([^/]*\\)\\.id" file) + ;; file is an id file. + (tla-regenerate-id-for-file + (concat (match-string 1 file) "/" (match-string 2 file)))) + (t + (let* ((dir (file-name-directory file)) + (basename (file-name-nondirectory file)) + (id-file (concat dir + (file-name-as-directory ".arch-ids") + basename ".id"))) + (if (file-exists-p id-file) + (progn (delete-file id-file) + (tla-add nil file)) + (with-current-buffer + (find-file-noselect file) + (let ((modif (buffer-modified-p))) + (tla-tag-regenerate) + (if modif + (when (y-or-n-p (format "Save buffer %s? " (buffer-name))) + (save-buffer)) + ;; No modif. We can safely save without prompting. + (save-buffer))))))))) + +(defun tla--insert-arch-tag-for-autoconf-mode (uuid in-comment-p) + "Insert arch-tag, UUID to the current `autoconf-mode' buffer. +IN-COMMENT-P indicates whether we are currently inside a comment." + (when in-comment-p + ;; In current GNU Emacs's autoconf-mode implementation, + ;; next line is never executed. + (error "Comment prefix \"dnl\" is not suitable for gnuarch")) + (let ((header "m4_if(dnl Do not change this comment\n") + (footer "\n)dnl\n")) + (insert (concat header " " tla--arch-tag-string uuid footer)))) + +(defun tla--insert-arch-tag-for-makefile-mode (uuid in-comment-p) + "Insert arch-tag, UUID to the current `makefile-mode' buffer. +If the file is Makefile.am, input for automake, use `##' as `comment-start'. +Comment started with `##' in Makefile.am is automatically stripped by automake. +IN-COMMENT-P indicates whether we are currently inside a comment." + (let ((tla--insert-arch-tag-functions + (assq-delete-all 'makefile-mode + (copy-sequence tla--insert-arch-tag-functions))) + (comment-start (if (and (buffer-file-name) + (string-match "Makefile.am$" (buffer-file-name))) + "##" + comment-start))) + (tla-tag-insert))) + +(defun tla--insert-arch-tag-for-texinfo-mode (uuid in-comment-p) + "Insert arch-tag, UUID to the current `texinfo-mode' buffer. +IN-COMMENT-P indicates whether we are currently inside a comment." + (when in-comment-p + (error "Comment prefix \"@c\" is not suitable for gnuarch")) + (let ((header "@ignore\n") + (footer "\n@end ignore\n")) + (insert (concat header " " tla--arch-tag-string uuid footer)))) + +;;;###autoload +(defun tla-ediff-add-log-entry () + "Add a log entry." + (interactive) + (pop-to-buffer ediff-buffer-A) + (dvc-add-log-entry)) + +;; +;; Tree-lint mode +;; +(defvar tla--tree-lint-cookie nil + "Ewoc cookie used in tree-lint mode.") + +(define-derived-mode tla-tree-lint-mode fundamental-mode + "tla-tree-lint" + "Major mode to view tree-lint warnings. +Commands: +\\{tla-tree-lint-mode-map} +" + (dvc-install-buffer-menu) + (let ((inhibit-read-only t)) + (erase-buffer)) + (setq dvc-buffer-refresh-function + (lexical-let ((lex-default-directory default-directory)) + (lambda () (interactive) (tla-tree-lint default-directory)))) + (set (make-local-variable 'tla--tree-lint-cookie) + (ewoc-create (dvc-ewoc-create-api-select + #'tla--tree-lint-printer))) + (set (make-local-variable 'dvc-get-file-info-at-point-function) + 'tla-tree-lint-get-file-at-point) + (set (make-local-variable 'dvc-buffer-marked-file-list) + nil) + (set (make-local-variable 'dvc-buffer-all-marked-file-list) + nil) + (set (make-local-variable 'tla-generic-select-files-function) + 'tla--tree-lint-select-files) + (toggle-read-only t)) + +(defun tla-tree-lint-get-file-at-point () + "Find file at point in *{tla|baz}-tree-lint*. Error when not on a file." + (let ((data (ewoc-data (ewoc-locate tla--tree-lint-cookie)))) + (if (eq (car data) 'message) + nil + (cadr data)))) + +(defun tla--tree-lint-prepare-buffer (root &optional function) + "Prepare the buffer to display the tree-lint warnings for tree ROOT. + +If FUNCTION is provided, it will be ran when all warnings will have +been eliminated." + (let* ((buffer (dvc-get-buffer-create tla-arch-branch 'tree-lint root)) + (function (or function tla--tree-lint-nowarning-fn))) + (with-current-buffer buffer + (tla-tree-lint-mode) + (set (make-local-variable 'tla--tree-lint-nowarning-fn) + function) + (ewoc-enter-last + tla--tree-lint-cookie + (list 'message (format "Running tree-lint in %s ..." + root))) + buffer))) + +(defun tla-tree-lint-goto (root) + "Goto tree-lint buffer or run `tla-tree-lint'." + (interactive + (list (dvc-read-project-tree-maybe "Run tla tree-lint in: "))) + (let* ((default-directory root) + (buffer (dvc-get-buffer tla-arch-branch 'tree-lint default-directory))) + (if buffer + (dvc-switch-to-buffer buffer) + (tla-tree-lint root)))) + +;;;###autoload +(defun tla-tree-lint (root) + "Run tla tree-lint in directory ROOT." + (interactive + (list (dvc-read-project-tree-maybe "Run tla tree-lint in: "))) + (setq tla-pre-tree-lint-window-configuration (current-window-configuration)) + (let ((default-directory root) + (buffer (tla--tree-lint-prepare-buffer root))) + (when dvc-switch-to-buffer-first + (dvc-switch-to-buffer buffer)) + (tla--run-tla-async + (list (if (tla-has-lint-command) "lint" "tree-lint")) + :related-buffer buffer + :finished + (dvc-capturing-lambda (output error status arguments) + (if (> (buffer-size output) 0) + (progn + (save-excursion + (tla--tree-lint-parse-buffer output (capture buffer))) + (with-current-buffer (capture buffer) + (tla--tree-lint-cursor-goto + (ewoc-nth tla--tree-lint-cookie 0)))) + (message "No tree-lint warnings for %s." (capture default-directory)) + (with-current-buffer (capture buffer) + (let ((inhibit-read-only t)) + (erase-buffer) + (ewoc-enter-last + tla--tree-lint-cookie + (list 'message (format "No tree-lint warnings for %s." + (capture default-directory)))))) + (set-window-configuration + tla-pre-tree-lint-window-configuration) + (when tla--tree-lint-nowarning-fn + (funcall tla--tree-lint-nowarning-fn) + (setq tla--tree-lint-nowarning-fn nil)))) + :error + (dvc-capturing-lambda (output error status arguments) + (if (equal status 2) + (with-current-buffer (capture buffer) + (set 'tla--tree-lint-cookie + (ewoc-create (dvc-ewoc-create-api-select + #'tla--tree-lint-printer))) + (let ((inhibit-read-only t)) + (erase-buffer)) + (ewoc-enter-last + tla--tree-lint-cookie + (list 'message + (concat "* Error running lint:\n" + (dvc-buffer-content output) + (dvc-buffer-content error)))) + (ewoc-refresh tla--tree-lint-cookie) + (goto-char (point-min))) + (save-excursion + (tla--tree-lint-parse-buffer output (capture buffer))) + (with-current-buffer (capture buffer) + (tla--tree-lint-cursor-goto + (ewoc-nth tla--tree-lint-cookie 0)))))))) + +(defconst tla--tree-lint-message-alist + '(("^These files would be source but lack inventory ids" + missing-file) + ("^These explicit ids have no corresponding file:" + id-without-file) + ("^These files violate naming conventions:" + unrecognized) + ("^These symlinks point to nonexistent files:" + broken-link) + ("^Duplicated ids among each group of files listed here:" + duplicate-id) + )) + +(defun tla--tree-lint-message-type (message) + "Return a symbol saying which type of message the string MESSAGE is." + (let ((result nil) + (iterator tla--tree-lint-message-alist)) + (while (and iterator (not result)) + (when (string-match (caar iterator) message) + (setq result (car (cdar iterator)))) + (setq iterator (cdr iterator))) + (or result 'unknown))) + +(defun tla--tree-lint-parse-buffer (buffer output-buffer) + "Parse the output of tla tree-lint in BUFFER. +Show in in the tree-lint-mode buffer OUTPUT-BUFFER." + (with-current-buffer output-buffer + (let ((inhibit-read-only t)) + (erase-buffer) + (insert (dvc-face-add (format "Tree lint warnings in %s\n" + default-directory) + 'dvc-messages))) + (setq tla--tree-lint-cookie + (ewoc-create (dvc-ewoc-create-api-select + #'tla--tree-lint-printer)))) + (with-current-buffer buffer + (goto-char (point-min)) + (let ((cookie (with-current-buffer output-buffer + tla--tree-lint-cookie))) + (while (re-search-forward "^." nil t) + (goto-char (line-beginning-position)) + (let* ((message (buffer-substring-no-properties + (point) (line-end-position))) + (type (tla--tree-lint-message-type message))) + (ewoc-enter-last cookie (list 'message message)) + (forward-line 2) + (if (eq type 'duplicate-id) + (progn + (while (looking-at "\\([^ \t]*\\)[ \t]+\\(.*\\)") + (let* ((file (match-string 1)) + (id (match-string 2))) + ;; Format: (duplicate-id "filename" "id" first? last?) + (ewoc-enter-last + cookie (list 'duplicate-id (tla-unescape file) id + t nil)) + (forward-line 1) + (while (not (eq (char-after) ?\n)) + (let ((file (buffer-substring-no-properties + (point) (line-end-position)))) + (forward-line 1) + (ewoc-enter-last cookie + (list 'duplicate-id + (tla-unescape file) + id nil + (eq (char-after) ?\n))))) + (forward-line 1) + ))) + (while (not (eq (char-after) ?\n)) + (ewoc-enter-last cookie + (list type (tla-unescape + (buffer-substring-no-properties + (point) + (line-end-position))))) + (forward-line 1))))) + (let ((inhibit-read-only t)) + (ewoc-refresh cookie))))) + +(defvar tla--tree-lint-printer-first-duplicate nil + "Internal variable. +non-nil when the ewoc printer is printing the first group of duplicate ID's") + +(defun tla--tree-lint-printer (elem) + "Ewoc printer for the tree-lint buffer. +Displays ELEM." + (when (not (eq (car elem) 'message)) + (insert (if (member (cadr elem) + dvc-buffer-marked-file-list) + (concat " " dvc-mark " ") " "))) + (case (car elem) + (message (insert "\n" (dvc-face-add (cadr elem) 'dvc-messages) + "\n") + (setq tla--tree-lint-printer-first-duplicate t)) + (missing-file (insert + (dvc-face-add (cadr elem) 'dvc-to-add + 'tla-tree-lint-file-map + tla-tree-lint-file-menu))) + (id-without-file (insert + (dvc-face-add (cadr elem) 'dvc-to-add + 'tla-tree-lint-file-map + tla-tree-lint-file-menu))) + (unrecognized (insert + (dvc-face-add (cadr elem) + 'dvc-unrecognized + 'tla-tree-lint-file-map + tla-tree-lint-file-menu))) + (broken-link (insert (dvc-face-add (cadr elem) + 'dvc-broken-link + 'tla-tree-lint-file-map + tla-tree-lint-file-menu))) + (unknown (insert (dvc-face-add (cadr elem) + 'dvc-unrecognized + 'tla-tree-lint-file-map + tla-tree-lint-file-menu))) + (duplicate-id + (insert (dvc-face-add (cadr elem) + 'dvc-duplicate + 'tla-tree-lint-file-map + tla-tree-lint-file-menu)) + (when (nth 3 elem) (insert "\t" + (dvc-face-add (car (cddr elem)) + 'dvc-id))) + (when (nth 4 elem) (insert "\n"))) + (t (error "Unimplemented type of tree-lint error"))) + ) + +(defun tla--tree-lint-cursor-goto (ewoc-tree-lint) + "Move cursor to the ewoc location of EWOC-TREE-LINT." + (interactive) + (if ewoc-tree-lint + (progn (goto-char (ewoc-location ewoc-tree-lint)) + (re-search-forward "." nil t) + (backward-char 1)) + (goto-char (point-min)))) + +(defun tla-tree-lint-next () + "Move to the next tree lint item." + (interactive) + (let* ((cookie tla--tree-lint-cookie) + (elem (ewoc-locate cookie)) + (next (or (ewoc-next cookie elem) elem))) + (tla--tree-lint-cursor-goto next))) + +(defun tla-tree-lint-previous () + "Move to the previous tree lint item." + (interactive) + (let* ((cookie tla--tree-lint-cookie) + (elem (ewoc-locate cookie)) + (previous (or (ewoc-prev cookie elem) elem))) + (tla--tree-lint-cursor-goto previous))) + +(defun tla-tree-lint-mark-file () + "Mark the current tree-lint file." + (interactive) + (let ((current (ewoc-locate tla--tree-lint-cookie)) + (files (tla--tree-lint-select-files nil nil nil nil nil t t))) + (when files + (dolist (file files) + (add-to-list 'dvc-buffer-marked-file-list file) + (add-to-list 'dvc-buffer-all-marked-file-list file)) + (ewoc-refresh tla--tree-lint-cookie)) + (tla--tree-lint-cursor-goto + (if (eq (car (ewoc-data current)) 'message) + current + (ewoc-next tla--tree-lint-cookie current))))) + +(defun tla-tree-lint-unmark-file () + "Unmark the current tree-lint file." + (interactive) + (let ((current (ewoc-locate tla--tree-lint-cookie)) + (files (tla--tree-lint-select-files nil nil nil nil nil t t))) + (when files + (dolist (file files) + (setq dvc-buffer-all-marked-file-list + (delete file dvc-buffer-all-marked-file-list)) + (setq dvc-buffer-marked-file-list + (delete file dvc-buffer-marked-file-list))) + (ewoc-refresh tla--tree-lint-cookie)) + (tla--tree-lint-cursor-goto + (if (eq (car (ewoc-data current)) 'message) + current + (ewoc-next tla--tree-lint-cookie current))))) + +(defun tla-tree-lint-unmark-all () + "Unmark all tree-lint files." + (interactive) + (let ((current (ewoc-locate tla--tree-lint-cookie))) + (setq dvc-buffer-marked-file-list nil) + (setq dvc-buffer-all-marked-file-list nil) + (ewoc-refresh tla--tree-lint-cookie) + (tla--tree-lint-cursor-goto current))) + + +(defun tla--tree-lint-select-files (msg-singular + msg-plural msg-err + msg-prompt + &optional + no-group ignore-marked + no-prompt + y-or-n) + "Get the list of files under cursor, and ask confirmation of the user. +Prompt with either MSG-SINGULAR, MSG-PLURAL, MSG-ERR OR MSG-PROMPT. +If NO-GROUP is nil and if the cursor is on a message, all the +files belonging to this message are selected. If some files are marked + (i.e. `dvc-buffer-marked-file-list' is non-nil) and IGNORE-MARKED is +non-nil, the list of marked files is returned. If NO-PROMPT is +non-nil, don't ask for confirmation. If Y-OR-N is non-nil, then this +function is used instead of `y-or-n-p'." + (if (and dvc-buffer-marked-file-list + (not ignore-marked) + (not (tla--mouse-event-p last-input-event))) + (let ((list dvc-buffer-marked-file-list)) + (unless (or no-prompt + (funcall (or y-or-n 'y-or-n-p) + (if (eq 1 (length list)) + (format msg-singular + (car list)) + (format msg-plural + (length list)))) + (error msg-err))) + list) + (let* ((ewoc-elem (ewoc-locate tla--tree-lint-cookie)) + (elem (ewoc-data ewoc-elem))) + (if (eq (car elem) 'message) + (progn + (when no-group (error msg-err)) + (let ((list nil)) + (setq ewoc-elem + (ewoc-next tla--tree-lint-cookie ewoc-elem)) + (setq elem (and ewoc-elem (ewoc-data ewoc-elem))) + (while (and ewoc-elem (not (eq (car elem) 'message))) + (add-to-list 'list (cadr elem)) + (setq ewoc-elem + (ewoc-next tla--tree-lint-cookie ewoc-elem)) + (setq elem (and ewoc-elem (ewoc-data ewoc-elem)))) + (progn + (unless (or no-prompt + (funcall (or y-or-n 'y-or-n-p) + (if (eq 1 (length list)) + (format msg-singular + (car list)) + (format msg-plural + (length list))))) + (error msg-err)) + list))) + (list (if (or no-prompt + (funcall (or y-or-n 'y-or-n-p) + (format msg-singular + (cadr elem)))) + (cadr elem) + (error msg-err))))))) + +(defun tla-tree-lint-add-files (files) + "Prompts and add FILES. +If on a message field, add all the files below this message." + (interactive + (list + (tla--tree-lint-select-files "Add %s? " + "Add %s files? " + "Not adding any file" + "Add file: "))) + (apply 'tla-add nil files) + (tla-tree-lint default-directory)) + +(defun tla-tree-lint-delete-files (files) + "Prompts and delete FILES. +If on a message field, delete all the files below this message." + (interactive + (list + (tla--tree-lint-select-files "Delete %s? " + "Delete %s files? " + "Not deleting any file" + "Delete file: " + nil nil nil + 'yes-or-no-p))) + (mapcar 'delete-file files) + (tla-tree-lint default-directory)) + +(defun tla-tree-lint-regenerate-id (files) + "Prompts and regenerate an ID (either explicit or tagline) for FILES." + (interactive + (list + (tla--tree-lint-select-files "Regenerate ID for %s? " + "Regenerate ID for %s files? " + "Not regenerating ID for any file" + "Regenerate ID for file: " + t))) + (mapcar 'tla-regenerate-id-for-file files) + (tla-tree-lint default-directory)) + +(defun tla-tree-lint-make-junk (files) + "Prompts and make the FILES junk. +If marked files are, use them as FIELS. +If not, a file under the point is used as FILES. +If on a message field, make all the files below this message junk." + (interactive + (list + (tla--tree-lint-select-files "Make %s junk(prefixing \",,\")? " + "Make %s files junk? " + "Not making any file junk" + "Make file junk: " + nil nil nil + 'yes-or-no-p))) + (tla-tree-lint-put-file-prefix files ",,")) + +(defun tla-tree-lint-make-precious (files) + "Prompts and make the FILES precious. +If marked files are, use them as FIELS. +If not, a file under the point is used as FILES. +If on a message field, make all the files below this message precious." + (interactive + (list + (tla--tree-lint-select-files "Make %s precious(prefixing \"++\")? " + "Make %s files precious? " + "Not making any file precious? " + "Make file precious: " + nil nil nil + 'yes-or-no-p))) + (tla-tree-lint-put-file-prefix files "++")) + +(defun tla-tree-lint-put-file-prefix (files prefix) + "Rename FILES with adding prefix PREFIX. +Visited buffer associations also updated." + (mapcar + (lambda (from) + (let* ((buf (find-buffer-visiting from)) + (to (concat + (file-name-directory from) + prefix + (file-name-nondirectory from)))) + (rename-file from to) + (when buf + (with-current-buffer buf + (rename-buffer to) + (set-visited-file-name to))))) + files) + (dvc-generic-refresh)) + + +;; end tree-lint-mode + +;; +;; Small editor functions +;; +(defun tla-to-kill-ring () + "Prompts an archive location and add it to kill ring." + (interactive) + (kill-new + (tla--name-construct + (tla-name-read "Save to kill ring: " + 'maybe 'maybe 'maybe 'maybe 'maybe)))) + +;;;###autoload +(defun tla-insert-location () + "Prompts an archive location and insert it on the current point location." + (interactive) + (insert + (tla--name-construct + (tla-name-read "Insert string: " + 'maybe 'maybe 'maybe 'maybe 'maybe)))) + +(defun tla-insert-description (patch-id) + "Prompts an archive location and insert its description at point. + +LOCATION is a list." + (interactive (list (tla-name-read "Insert description for: " + 'maybe 'maybe 'maybe 'maybe 'maybe))) + (dolist (element tla-description-format) + (cond ((eq element 'patch-id) + (insert (tla--name-construct patch-id))) + ((eq element 'summary) + (when (tla--name-revision patch-id) + (tla--archive-tree-build-revisions + (tla--name-archive patch-id) + (tla--name-category patch-id) + (tla--name-branch patch-id) + (tla--name-version patch-id) + t nil t) + (insert (tla--revision-summary + (apply 'tla--archive-tree-get-revision-struct + patch-id))))) + ((eq element 'location) + (insert + (tla-whereis-archive + (tla--name-archive patch-id)))) + ((stringp element) + (insert element))))) + +;; +;; Version information +;; +(defvar tla-command-version nil + "Version of tla version.") + +(defun tla-command-version () + "Return the TLA (arch) version." + (interactive) + (setq tla-command-version + (tla--run-tla-sync '("-V") + :finished + (lambda (output error status arguments) + (dvc-buffer-content output)))) + (if (interactive-p) + (message tla-command-version)) + tla-command-version) + +(defvar tla-version nil "Version of xtla") +(defun tla-version () + "Return the Xtla version." + (interactive) + (let ((version + (or (when (locate-library "dvc-version") + (load-library "dvc-version") + (when (boundp 'tla-version) + tla-version)) + (let ((default-directory + (file-name-directory (locate-library "tla")))) + (setq tla-version (tla-tree-id)))))) + (if (not version) + (progn + (message "We did not find dvc-version.el nor the arch-tree containing xtla.el!") + (sit-for 2) + (message "Are you using a developer version of Xtla?") + (sit-for 2)) + (if (interactive-p) + (message tla-version)) + tla-version))) + +(defvar tla-patch-data nil) +;;;###autoload +(defun tla-prepare-patch-submission (tla-tree-root tarball-base-name email version-string + &optional description subject) + "Submit a patch to a tla working copy (at TLA-TREE-ROOT) via email. +With this feature it is not necessary to tag an tla archive. +You simply edit your checked out copy from your project and call this function. +The function will create a patch as *.tar.gz file (based on TARBALL-BASE-NAME) +and send it to the given email address EMAIL. +VERSION-STRING should indicate the version of tla that the patch applies to. +DESCRIPTION is a brief descsription of the patch. +SUBJECT is the subject for the email message. +For an example, how to use this function see: `tla-submit-patch'." + (interactive) + + ;; create the patch + (let* ((default-directory tla-tree-root) + (tarball-full-base-name (concat default-directory tarball-base-name)) + (tarball-full-name (concat tarball-full-base-name ".tar.gz"))) + (tla-changes-save-as-tgz tarball-full-base-name) + + (require 'reporter) + (delete-other-windows) + (reporter-submit-bug-report + email + nil + nil + nil + nil + description) + + (set (make-local-variable 'tla-patch-data) (list tla-tree-root tarball-full-name)) + + (insert "[VERSION] " version-string) + (goto-char (point-max)) + (mml-attach-file tarball-full-name "application/octet-stream") + (tla-show-changeset-from-tgz tarball-full-name) + (other-window 1) + + (goto-char (point-min)) + (mail-position-on-field "Subject") + (insert (or subject "[PATCH] ")))) + +;;;###autoload +(defun tla-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 tarball (see: `tla-patch-sent-action'." + (when tla-patch-data + (when (member tla-patch-sent-action '(keep-tarball keep-none)) + (message "Reverting the sent changes in %s" (car tla-patch-data)) + (tla--undo-internal (car tla-patch-data) t t)) + (when (member tla-patch-sent-action '(keep-changes keep-none)) + (message "Deleting the sent tarball %s" (cadr tla-patch-data)) + (delete-file (cadr tla-patch-data))) + (when (member tla-patch-sent-action '(keep-both)) + (message "Keeping the sent changes and the sent tarball %s" (cadr tla-patch-data))))) + +(defun tla-submit-patch () + "Submit a patch for the current arch 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 `tla-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, `tla-submit-patch-done' is called." + (interactive) + (tla-command-version) + (let* ((submit-patch-info (tla--name-match-from-list + (tla--name-split (tla-tree-version)) tla-submit-patch-mapping)) + (mail-address (or (nth 0 submit-patch-info) "")) + (patch-base-file-name (or (nth 1 submit-patch-info) "arch"))) + (tla-prepare-patch-submission (dvc-uniquify-file-name (tla-tree-root)) + (concat "++" patch-base-file-name "-patch-" + (format-time-string "%Y-%m-%d_%H-%M-%S" (current-time))) + mail-address + (tla-tree-id) + dvc-patch-email-message-body-template + ))) + +(defun tla-send-commit-notification () + "Send a commit notification email for the changelog entry at point. + +`tla-mail-notification-destination' can be used to specify a prefix for +the subject line, the rest of the subject line contains the summary line +of the commit. Additionally the destination email address can be specified." + (interactive) + (let ((dest-specs (tla--name-match-from-list + (tla--name-split (tla-changelog-revision-at-point)) + tla-mail-notification-destination)) + (rev (tla-changelog-revision-at-point)) + (summary (tla-changelog-log-summary-at-point)) + (log-message (tla-changelog-log-message-at-point))) + (message "Preparing commit email for %s" rev) + (compose-mail (if dest-specs (cadr dest-specs) "") + (if dest-specs (car dest-specs) "")) + (message-goto-subject) + (insert summary) + (message-goto-body) + (insert (concat "Committed " rev "\n\n")) + (insert log-message) + (message-goto-body))) + +;; Local Variables: +;; End: + +(provide 'tla) + +;;; tla.el ends here diff --git a/dvc/lisp/xdarcs-core.el b/dvc/lisp/xdarcs-core.el new file mode 100644 index 0000000..74289b8 --- /dev/null +++ b/dvc/lisp/xdarcs-core.el @@ -0,0 +1,61 @@ +;;; xdarcs-core.el --- Common definitions for darcs support in DVC + +;; Copyright (C) 2006 by all contributors + +;; Author: Stefan Reichoer, + +;; 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 diff --git a/dvc/lisp/xdarcs-dvc.el b/dvc/lisp/xdarcs-dvc.el new file mode 100644 index 0000000..4ac3ad4 --- /dev/null +++ b/dvc/lisp/xdarcs-dvc.el @@ -0,0 +1,80 @@ +;;; xdarcs-dvc.el --- The dvc layer for darcs + +;; Copyright (C) 2006, 2007, 2008 by all contributors + +;; Author: Stefan Reichoer, + +;; 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 diff --git a/dvc/lisp/xdarcs.el b/dvc/lisp/xdarcs.el new file mode 100644 index 0000000..a205ddc --- /dev/null +++ b/dvc/lisp/xdarcs.el @@ -0,0 +1,383 @@ +;;; xdarcs.el --- darcs interface for dvc + +;; Copyright (C) 2006, 2007, 2008 by all contributors + +;; Author: Stefan Reichoer, + +;; 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 diff --git a/dvc/lisp/xgit-annotate.el b/dvc/lisp/xgit-annotate.el new file mode 100644 index 0000000..6965aa1 --- /dev/null +++ b/dvc/lisp/xgit-annotate.el @@ -0,0 +1,138 @@ +;;; xgit-annotate.el --- Git interface for dvc: mode for git-annotate style output + +;; Copyright (C) 2007-2009 by all contributors + +;; Author: Takuzo O'hara, + +;; 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 diff --git a/dvc/lisp/xgit-core.el b/dvc/lisp/xgit-core.el new file mode 100644 index 0000000..9eba232 --- /dev/null +++ b/dvc/lisp/xgit-core.el @@ -0,0 +1,127 @@ +;;; xgit-core.el --- Common definitions for git support in DVC + +;; Copyright (C) 2006-2007 by all contributors + +;; Author: Stefan Reichoer, +;; Contributions from: +;; Takuzo O'hara + +;; 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 diff --git a/dvc/lisp/xgit-dvc.el b/dvc/lisp/xgit-dvc.el new file mode 100644 index 0000000..6922f9a --- /dev/null +++ b/dvc/lisp/xgit-dvc.el @@ -0,0 +1,167 @@ +;;; xgit-dvc.el --- The dvc layer for git + +;; Copyright (C) 2006-2009 by all contributors + +;; Author: Stefan Reichoer, + +;; 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 diff --git a/dvc/lisp/xgit-gnus.el b/dvc/lisp/xgit-gnus.el new file mode 100644 index 0000000..e5f19b2 --- /dev/null +++ b/dvc/lisp/xgit-gnus.el @@ -0,0 +1,294 @@ +;;; xgit-gnus.el --- dvc integration to gnus + +;; Copyright (C) 2003-2007 by all contributors + +;; Author: Michael Olson , +;; Stefan Reichoer +;; Contributions from: +;; Matthieu Moy + +;; 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 diff --git a/dvc/lisp/xgit-log-edit.el b/dvc/lisp/xgit-log-edit.el new file mode 100644 index 0000000..1e9cba7 --- /dev/null +++ b/dvc/lisp/xgit-log-edit.el @@ -0,0 +1,72 @@ +;;; xgit-log-edit.el --- Major mode to edit commit messages for git + +;; Copyright (C) 2009 Matthieu Moy + +;; Author: Matthieu Moy +;; 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 . + +;;; 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 diff --git a/dvc/lisp/xgit-log.el b/dvc/lisp/xgit-log.el new file mode 100644 index 0000000..0032b5e --- /dev/null +++ b/dvc/lisp/xgit-log.el @@ -0,0 +1,390 @@ +;;; xgit-log.el --- git interface for dvc: mode for git log style output + +;; Copyright (C) 2006-2009 by all contributors + +;; Author: Stefan Reichoer, + +;; 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 + ;; |AuthorDate: Wed Aug 15 21:38:38 2007 -0700 + ;; |Commit: Junio C Hamano + ;; |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 diff --git a/dvc/lisp/xgit-rebase-todo.el b/dvc/lisp/xgit-rebase-todo.el new file mode 100644 index 0000000..d4f5aa9 --- /dev/null +++ b/dvc/lisp/xgit-rebase-todo.el @@ -0,0 +1,91 @@ +;;; xgit-rebase-todo.el --- Major mode for editting git-rebase-todo files. + +;; Copyright (C) 2009 Matthieu Moy + +;; Author: Matthieu Moy +;; 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 . + +;;; 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 diff --git a/dvc/lisp/xgit-revision.el b/dvc/lisp/xgit-revision.el new file mode 100644 index 0000000..bd8f523 --- /dev/null +++ b/dvc/lisp/xgit-revision.el @@ -0,0 +1,116 @@ +;;; xgit-revision.el --- Management of revision lists for git + +;; Copyright (C) 2006-2007 by all contributors + +;; Author: Stefan Reichoer, +;; 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 diff --git a/dvc/lisp/xgit.el b/dvc/lisp/xgit.el new file mode 100644 index 0000000..a10cf9f --- /dev/null +++ b/dvc/lisp/xgit.el @@ -0,0 +1,1004 @@ +;;; xgit.el --- git interface for dvc + +;; Copyright (C) 2006-2009 by all contributors + +;; Author: Stefan Reichoer +;; Contributions from: +;; Takuzo O'hara + +;; 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 the git backend for DVC. It requires git version 1.5.0 or +;; later. + +;;; History: + +;; + +;;; Code: + +(require 'dvc-core) +(require 'dvc-diff) +(require 'xgit-core) +(require 'xgit-log) +(eval-when-compile (require 'cl)) +(require 'xgit-annotate) +(require 'cus-edit) + +;;;###autoload +(defun xgit-init (&optional dir) + "Run git init." + (interactive + (list (expand-file-name (dvc-read-directory-name "Directory for git init: " + (or default-directory + (getenv "HOME")))))) + (let ((default-directory (or dir default-directory))) + (dvc-run-dvc-sync 'xgit (list "init-db") + :finished (dvc-capturing-lambda + (output error status arguments) + (message "git init finished"))))) + +;;;###autoload +(defun xgit-clone (src &optional dest) + "Run git clone." + (interactive (list (read-string "git clone from: "))) + (dvc-run-dvc-async 'xgit (list "clone" src dest))) + +;;;###autoload +(defun xgit-add (file) + "Add FILE to the current git project." + (interactive (list (dvc-confirm-read-file-name "Add file or directory: "))) + (xgit-dvc-add-files file)) + +;;;###autoload +(defun xgit-add-patch (files) + ;; this is somehow a dirty hack. DVC should have it's own + ;; hunk-by-hunk staging feature, but waiting for that, 'git add -p' + ;; is sooo nice, let's use it through term.el + "Add FILES to the current git project using 'git add --patch ...'. +If FILES is nil, just run 'git add --patch'" + (interactive (list (list (expand-file-name (dvc-confirm-read-file-name "Add file or directory: "))))) + (require 'term) + (let* ((root (dvc-tree-root (car files))) + (default-directory root) + (buffer (dvc-get-buffer-create 'xgit 'add-patch)) + (args (mapcar (lambda (f) + (file-relative-name (dvc-uniquify-file-name + f) root)) + files))) + (switch-to-buffer + (eval `(term-ansi-make-term ,(buffer-name buffer) + ,xgit-executable nil "add" "-p" "--" + ,@args))))) + +(defun xgit-add-patch-all () + "Call `xgit-add-patch' without argument, to run plain 'git add -p'" + (interactive) + (xgit-add-patch nil)) + +;;;###autoload +(defun xgit-dvc-add-files (&rest files) + "Run git add. + +When called with a prefix argument, use `xgit-add-patch'." + (dvc-trace "xgit-add-files: %s" files) + (if current-prefix-arg + (xgit-add-patch files) + (let ((default-directory (xgit-tree-root))) + (dvc-run-dvc-sync 'xgit (append '("add") + (mapcar #'file-relative-name files)) + :finished (dvc-capturing-lambda + (output error status arguments) + (message "git add finished")))))) + +;;;###autoload +(defun xgit-remove (file &optional force) + "Remove FILE from the current git project. +If FORCE is non-nil, then remove the file even if it has +uncommitted changes." + (interactive (list (dvc-confirm-read-file-name "Remove file: ") + current-prefix-arg)) + (let ((default-directory (xgit-tree-root))) + (dvc-run-dvc-sync + 'xgit (list "rm" (when force "-f") "--" (file-relative-name file)) + :finished (dvc-capturing-lambda + (output error status arguments) + (message "git remove finished"))))) + +;;;###autoload +(defun xgit-dvc-remove-files (&rest files) + "Run git rm." + (dvc-trace "xgit-remove-files: %s" files) + (dvc-run-dvc-sync 'xgit (nconc (list "rm" "--") + (mapcar #'file-relative-name files)) + :finished (dvc-capturing-lambda + (output error status arguments) + (message "git rm finished")))) + +(defun xgit-command-version () + "Run git version." + (interactive) + (let ((version (dvc-run-dvc-sync 'xgit (list "version") + :finished 'dvc-output-buffer-handler))) + (when (interactive-p) + (message "Git Version: %s" version)) + version)) + +;;;###autoload +(defun xgit-add-all-files (arg) + "Run 'git add .' to add all files in the current directory tree to git. + +Normally run 'git add -n .' to simulate the operation to see +which files will be added. + +Only when called with a prefix argument, add the files." + (interactive "P") + (dvc-run-dvc-sync 'xgit (list "add" (unless arg "-n") "."))) + +;;;###autoload +(defun xgit-addremove () + "Add all new files to the index, remove all deleted files from +the index, and add all changed files to the index. + +This is done only for files in the current directory tree." + (interactive) + (dvc-run-dvc-sync + 'xgit (list "add" ".") + :finished (lambda (output error status arguments) + (dvc-run-dvc-sync + 'xgit (list "add" "-u" ".") + :finished + (lambda (output error status args) + (message "Finished adding and removing files to index")))))) + +;;;###autoload +(defun xgit-reset-hard (&rest extra-param) + "Run 'git reset --hard'" + (interactive) + (when (interactive-p) + (setq extra-param (list (ido-completing-read "git reset --hard " '("HEAD" "ORIG_HEAD") + nil nil nil nil '("HEAD" "ORIG_HEAD"))))) + (dvc-run-dvc-sync 'xgit (append '("reset" "--hard") extra-param))) + +(defvar xgit-status-line-regexp + "^#[ \t]+\\([[:alpha:]][[:alpha:][:blank:]]+\\):\\(?:[ \t]+\\(.+\\)\\)?$" + "Regexp that matches a line of status output. +The first match string is the status type, and the optional +second match is the file.") + +(defvar xgit-status-untracked-regexp "^#\t\\(.+\\)$" + "Regexp that matches a line of status output indicating an +untracked file. + +The first match is the file.") + +(defvar xgit-status-renamed-regexp "^\\(.+\\) -> \\(.+\\)$" + "Regexp that divides a filename string. +The first match is the original file, and the second match is the +new file.") + +(defun xgit-parse-status-sort (status-list) + "Sort STATUS-LIST according to :status in the order +conflict, added, modified, renamed, copied, deleted, unknown." + (let ((order '((conflict . 0) + (added . 1) (modified . 2) + (rename-source . 3) (rename-target . 3) + (copy-source . 4) (copy-target . 4) + (deleted . 5) (unknown . 6))) + (get (lambda (item) + (catch 'status + (while item + (if (eq (car item) :status) + (throw 'status (cadr item)) + (setq item (cddr item)))))))) + (sort status-list + (dvc-capturing-lambda (a b) + (let ((ao (cdr (assq (funcall (capture get) a) order))) + (bo (cdr (assq (funcall (capture get) b) order)))) + (and (integerp ao) (integerp bo) + (< ao bo))))))) + +(defun xgit-parse-status (changes-buffer) + (dvc-trace "xgit-parse-status (dolist)") + (let ((output (current-buffer))) + (with-current-buffer changes-buffer + (setq dvc-header (format "git status for %s\n" default-directory)) + (with-current-buffer output + (save-excursion + (goto-char (point-min)) + (let ((buffer-read-only) + (grouping "") + status-string + file status dir + status-list + indexed) + (while (re-search-forward xgit-status-line-regexp nil t) + (setq status-string (match-string 1) + file (match-string 2) + indexed t) + (cond ((or (null file) (string= "" file)) + (when (string= status-string "Untracked files") + (let ((end + (save-excursion + (re-search-forward xgit-status-line-regexp + nil 'end) + (point)))) + (forward-line 2) + (while (re-search-forward xgit-status-untracked-regexp + end t) + (when (match-beginning 1) + (setq status-list + (cons (list :file (match-string 1) + :status 'unknown + :indexed t) + status-list)))) + (forward-line -1))) + (setq grouping status-string + status nil)) + ((string= status-string "modified") + (setq status 'modified) + (when (string= grouping "Changed but not updated") + (setq indexed nil))) + ((string= status-string "new file") + (setq status 'added)) + ((string= status-string "deleted") + (setq status 'deleted) + (when (string= grouping "Changed but not updated") + (setq indexed nil))) + ((string= status-string "renamed") + (setq status nil) + (when (string-match xgit-status-renamed-regexp file) + (let ((orig (match-string 1 file)) + (new (match-string 2 file))) + (setq status-list + (cons + (list :file new :dir nil + :status 'rename-target :indexed t) + (cons (list :file orig :dir nil + :status 'rename-source :indexed t) + status-list)))))) + ((string= status-string "copied") + (setq status nil) + (when (string-match xgit-status-renamed-regexp file) + (let ((orig (match-string 1 file)) + (new (match-string 2 file))) + (setq status-list + (cons + (list :file new :dir nil + :status 'copy-target :indexed t) + (cons (list :file orig :dir nil + :status 'copy-source :indexed t) + status-list)))))) + ((string= status-string "unmerged") + (setq status 'conflict)) + (t + (setq status nil))) + (when status + (setq status-list + (cons (list :file file :dir nil + :status status :indexed indexed) + status-list)))) + (with-current-buffer changes-buffer + (dolist (elem (xgit-parse-status-sort (nreverse status-list))) + (ewoc-enter-last dvc-fileinfo-ewoc + (apply #'make-dvc-fileinfo-file elem)))))))))) + +(defun xgit-dvc-status (&optional verbose) + "Run git status." + (let* ((root default-directory) + (buffer (dvc-prepare-changes-buffer + `(xgit (last-revision ,root 1)) + `(git (local-tree ,root)) + 'status root 'xgit))) + (dvc-switch-to-buffer-maybe buffer) + (setq dvc-buffer-refresh-function 'xgit-dvc-status) + (dvc-save-some-buffers root) + (let ((show-changes-buffer + (dvc-capturing-lambda (output error status arguments) + (with-current-buffer (capture buffer) + (if (> (point-max) (point-min)) + (dvc-show-changes-buffer output 'xgit-parse-status + (capture buffer)) + (dvc-diff-no-changes (capture buffer) + "No changes in %s" + (capture root))))))) + (dvc-run-dvc-sync + 'xgit `("status" ,(when verbose "-v")) + :finished show-changes-buffer + :error show-changes-buffer)))) + +(defun xgit-status-verbose () + (interactive) + (xgit-dvc-status t)) + +(defun xgit-status-add-patch () + "Run `xgit-add-patch' on selected files." + (interactive) + (xgit-add-patch (dvc-current-file-list))) + +(defun xgit-status-add-u () + "Run \"git add -u\" and refresh current buffer." + (interactive) + (lexical-let ((buf (current-buffer))) + (dvc-run-dvc-async + 'xgit '("add" "-u") + :finished (dvc-capturing-lambda + (output error status arguments) + (with-current-buffer buf + (dvc-generic-refresh)))))) + +(defun xgit-status-reset-mixed () + "Run \"git reset --mixed\" and refresh current buffer. + +This reset the index to HEAD, but doesn't touch files." + (interactive) + (lexical-let ((buf (current-buffer))) + (dvc-run-dvc-async + 'xgit '("reset" "--mixed") + :finished (dvc-capturing-lambda + (output error status arguments) + (with-current-buffer buf + (dvc-generic-refresh)))))) + +(defvar xgit-diff-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [?A] 'xgit-status-add-u) + (define-key map [?G ?r] 'xgit-status-reset-mixed) + (define-key map [?G ?p] 'xgit-status-add-patch) + (define-key map [?G ?P] 'xgit-add-patch-all) + ;; 's'taged. + (define-key map [?G ?s] 'xgit-diff-cached) + ;; 'u'nstaged. + (define-key map [?G ?u] 'xgit-diff-index) + map)) + +(easy-menu-define xgit-diff-mode-menu xgit-diff-mode-map + "`Git specific changes' menu." + `("GIT-Diff" + ["Re-add modified files (add -u)" xgit-status-add-u t] + ["Reset index (reset --mixed)" xgit-status-reset-mixed t] + "---" + ["View staged changes" xgit-diff-cached t] + ["View unstaged changes" xgit-diff-index t] + ["View all local changes" xgit-diff-head t] + )) + +(define-derived-mode xgit-diff-mode dvc-diff-mode "xgit-diff" + "Mode redefining a few commands for diff." + ) + +(dvc-add-uniquify-directory-mode 'xgit-diff-mode) + +(defun xgit-parse-diff (changes-buffer) + (save-excursion + (while (re-search-forward + "^diff --git [^ ]+ b/\\(.*\\)$" nil t) + (let* ((name (match-string-no-properties 1)) + ;; added, removed are not yet working + (added (progn (forward-line 1) + (looking-at "^new file"))) + (removed (looking-at "^deleted file"))) + (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)))))))) + +(defun xgit-diff-1 (against-rev path dont-switch base-rev) + (let* ((cur-dir (or path default-directory)) + (orig-buffer (current-buffer)) + (root (xgit-tree-root cur-dir)) + (against (if against-rev + (dvc-revision-to-string against-rev + xgit-prev-format-string "HEAD") + "HEAD")) + (against-rev (or against-rev (if (xgit-use-index-p) + '(xgit (index)) + `(xgit (last-revision ,root 1))))) + (base (if base-rev + (dvc-revision-to-string base-rev xgit-prev-format-string + "HEAD") + nil)) + (local-tree `(xgit (local-tree ,root))) + (base-rev (or base-rev local-tree)) + (buffer (dvc-prepare-changes-buffer + against-rev base-rev + 'diff root 'xgit)) + (command-list (if (equal against-rev '(xgit (index))) + (if (equal base-rev local-tree) + '("diff" "-M") + (message "%S != %S" base-rev local-tree) + `("diff" "-M" "--cached" ,against)) + `("diff" "-M" ,base ,against)))) + (dvc-switch-to-buffer-maybe buffer) + (when dont-switch (pop-to-buffer orig-buffer)) + (dvc-save-some-buffers root) + (dvc-run-dvc-sync 'xgit command-list + :finished + (dvc-capturing-lambda (output error status arguments) + (dvc-show-changes-buffer output + 'xgit-parse-diff + (capture buffer) + nil nil + (mapconcat + (lambda (x) x) + (cons "git" command-list) + " ")))))) + +(defun xgit-last-revision (path) + (if (xgit-use-index-p) + '(xgit (index)) + `(xgit (last-revision ,path 1)))) + +;; TODO offer completion here, e.g. xgit-tag-list +(defun xgit-read-revision-name (prompt) + (read-string prompt)) + +;;;###autoload +(defun xgit-dvc-diff (&optional against-rev path dont-switch) + (interactive (list nil nil current-prefix-arg)) + (xgit-diff-1 against-rev path dont-switch nil)) + +;;;###autoload +(defun xgit-diff-cached (&optional against-rev path dont-switch) + "Call \"git diff --cached\"." + (interactive (list nil nil current-prefix-arg)) + (let ((xgit-use-index 'always)) + (xgit-diff-1 against-rev path dont-switch '(xgit (index))))) + +;;;###autoload +(defun xgit-diff-index (&optional against-rev path dont-switch) + "Call \"git diff\" (diff between tree and index)." + (interactive (list nil nil current-prefix-arg)) + (let ((path (or path (xgit-tree-root))) + (against-rev (or against-rev '(xgit (index))))) + (xgit-diff-1 against-rev path dont-switch + `(xgit (local-tree ,path))))) + +;;;###autoload +(defun xgit-diff-head (&optional path dont-switch) + "Call \"git diff HEAD\"." + (interactive (list nil current-prefix-arg)) + (xgit-diff-1 `(xgit (local-tree ,path)) + path dont-switch + `(xgit (last-revision ,path 1)))) + +;;;###autoload +(defun xgit-diff2 (base-rev against-rev &optional path dont-switch) + "Call \"git diff BASE-REV AGAINST-REV\"." + (interactive (list + (xgit-read-revision-name "Base Revision: ") + (xgit-read-revision-name "Against Revision: ") + nil + current-prefix-arg)) + (xgit-diff-1 `(xgit (revision ,against-rev)) + path dont-switch + `(xgit (revision ,base-rev)))) + +(defvar xgit-prev-format-string "%s~%s" + "This is a format string which is used by `dvc-revision-to-string' +when encountering a (previous ...) component of a revision indicator. +. +The first argument is a commit ID, and the second specifies how +many generations back we want to go from the given commit ID.") + +(defun xgit-delta (base-rev against &optional dont-switch) + (interactive (list nil nil current-prefix-arg)) + (let* ((root (xgit-tree-root)) + (buffer (dvc-prepare-changes-buffer + `(xgit (last-revision ,root 1)) + `(xgit (local-tree ,root)) + 'diff root 'xgit))) + (xgit-diff-1 against root dont-switch base-rev) + (with-current-buffer buffer (goto-char (point-min))) + buffer)) + +;;;###autoload +(defun xgit-fetch (&optional repository) + "Call git fetch. +When called with a prefix argument, ask for the fetch source." + (interactive "P") + (when (interactive-p) + (when current-prefix-arg + (setq repository (read-string "Git fetch from: ")))) + (dvc-run-dvc-async 'xgit (list "fetch" repository))) + +(defun* xgit-push (url &optional (branch "master")) + "Run 'git push url'. +with prefix arg ask for branch, default to master." + (interactive "sGit push to: ") + (lexical-let ((branch-name (if current-prefix-arg + (read-string "Which Branch?: ") + branch)) + (to url)) + (dvc-run-dvc-async 'xgit (list "push" url branch-name) + :finished + (dvc-capturing-lambda (output error status arguments) + (if (eq status 0) + (message "xgit-push <%s> to <%s> finished" branch-name to) + (dvc-switch-to-buffer error)))))) + +;;;###autoload +(defun xgit-pull (&optional repository) + "Call git pull. +When called with a prefix argument, ask for the pull source." + (interactive "P") + (when (interactive-p) + (when current-prefix-arg + (setq repository (read-string "Git pull from: ")))) + (dvc-run-dvc-async 'xgit (list "pull" repository) + :finished + (dvc-capturing-lambda (output error status arguments) + (with-current-buffer output + (xgit-parse-pull-result t)) + (when xgit-pull-result + (dvc-switch-to-buffer output) + (when (y-or-n-p "Run xgit-whats-new? ") + (xgit-whats-new)))))) + +(defvar xgit-pull-result nil) +(defun xgit-parse-pull-result (reset-parameters) + "Parse the output of git pull." + (when reset-parameters + (setq xgit-pull-result nil)) + (goto-char (point-min)) + (cond ((looking-at "Updating \\([0-9a-z]+\\)\.\.\\([0-9a-z]+\\)") + (setq xgit-pull-result (list (match-string 1) (match-string 2))) + (message "Execute M-x xgit-whats-new to see the arrived changes.")) + ((looking-at "Already up-to-date.") + (message "Already up-to-date.")))) + +(defun xgit-whats-new () + "Show the changes since the last git pull." + (interactive) + (when xgit-pull-result + (xgit-changelog (car xgit-pull-result) (cadr xgit-pull-result) t))) + +(defun xgit-split-out-added-files (files) + "Remove any files that have been newly added to git from FILES. +This returns a two-element list. + +The first element of the returned list is a list of the +newly-added files from FILES. + +The second element is the remainder of FILES." + (let* ((tree-added nil) + (added nil) + (not-added nil)) + ;; get list of files that have been added + (with-temp-buffer + (dvc-run-dvc-sync 'xgit (list "status") + :output-buffer (current-buffer) + :finished #'ignore :error #'ignore) + (goto-char (point-min)) + (while (re-search-forward xgit-status-line-regexp nil t) + (when (string= (match-string 1) "new file") + (setq tree-added (cons (match-string 2) tree-added))))) + ;; filter FILES + (dolist (file files) + (if (member file tree-added) + (setq added (cons file added)) + (setq not-added (cons file not-added)))) + (list added not-added))) + +;;;###autoload +(defun xgit-revert-file (file) + "Revert uncommitted changes made to FILE in the current branch." + (interactive "fRevert file: ") + (xgit-revert-files file)) + +;;;###autoload +(defun xgit-dvc-revert-files (&rest files) + "Revert uncommitted changes made to FILES in the current branch." + (let ((default-directory (xgit-tree-root))) + (setq files (mapcar #'file-relative-name files)) + (destructuring-bind (added not-added) + (xgit-split-out-added-files files) + ;; remove added files from the index + (when added + (let ((args (nconc (list "update-index" "--force-remove" "--") + added))) + (dvc-run-dvc-sync 'xgit args + :finished #'ignore))) + ;; revert other files using "git checkout HEAD ..." + (when not-added + (let ((args (nconc (list "checkout" "HEAD") + not-added))) + (dvc-run-dvc-sync 'xgit args + :finished #'ignore))) + (if (or added not-added) + (message "git revert finished") + (message "Nothing to do"))))) + +(defcustom xgit-show-filter-filename-func nil + "Function to filter filenames in xgit-show. +Function is passed a list of files as a parameter. + +Function should return list of filenames that is passed to +git-show or nil for all files." + :type '(choice (const xgit-show-filter-filename-not-quilt) + (function) + (const :tag "None" nil)) + :group 'dvc-xgit) + +(defun xgit-show-filter-filename-not-quilt (files) + "Function to filter-out quilt managed files under .pc/ and patches/." + (loop for f in files + when (not (string-match "\.pc/\\|patches/" f)) + collect f)) + +(defun xgit-changed-files (dir rev) + "Returns list of files changed in given revision" + (let* ((repo (xgit-git-dir-option dir)) + (cmd "diff-tree") + (args (list repo cmd "--numstat" rev)) + (result (dvc-run-dvc-sync + 'xgit args + :finished 'dvc-output-buffer-split-handler))) + (mapcar (lambda (x) (nth 2 (split-string x))) + (cdr result )))) + +(defun xgit-show (dir rev &optional files) + "Shows diff for a given revision. +Optional argument FILES is a string of filename or list of +filenames of to pass to git-show. + +If FILES is nil and `xgit-show-filter-filename-func' is non-nil, +files changed in the revision is passed to +`xgit-show-filter-filename-func' and result is used." + (interactive (list default-directory + (read-string "Revision (default: HEAD): " + (let ((candidate (thing-at-point + 'word))) + (when (and candidate + (string-match "[0-9a-f]" + candidate)) + candidate)) + nil "HEAD"))) + (if (and (null files) xgit-show-filter-filename-func) + (setq files (funcall xgit-show-filter-filename-func + (xgit-changed-files dir rev)))) + (let* ((buffer (dvc-get-buffer-create 'xgit 'diff dir)) + (cmd "show") + (args (list cmd rev "--"))) + (if files + (setq args (nconc args (if (stringp files) (list files) files)))) + (dvc-switch-to-buffer-maybe buffer) + (with-current-buffer buffer + (dvc-run-dvc-sync 'xgit args + :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 "git %s\n\n" + (mapconcat #'identity + args " "))) + (dvc-diff-mode) + (toggle-read-only 1))))))))) + +(defvar xgit-describe-regexp "^\\(.*?\\)-\\([0-9]+\\)-g[[:xdigit:]]\\{7\\}") + +(defun xgit-describe-tag? (abbrev) + (not (string-match xgit-describe-regexp abbrev))) + +(defun xgit-describe (dir rev) + "Show the most recent tag that is reachable from a commit. +If there is no tag return nil, +if revision is a tag, return tag in a string, +else returns list of '(tag offset all-described-string)." + (interactive (list default-directory (read-string "Revision: "))) + (let* ((repo (xgit-git-dir-option dir)) + (cmd "describe") + (args (list repo cmd rev)) + (info (dvc-run-dvc-sync 'xgit args + :finished 'dvc-output-buffer-handler + :error 'dvc-output-buffer-handler))) + (if (string= "" info) + nil ;no tag yet + (if (xgit-describe-tag? info) + info + (progn + (list (match-string 1 info) + (match-string 2 info) + info)))))) + +(defun xgit-do-annotate (dir file) + "Run git annotate for FILE in DIR. +DIR is a directory controlled by Git. +FILE is filename in the repository at DIR." + (let* ((buffer (dvc-get-buffer-create 'xgit 'annotate)) + (repo (xgit-git-dir-option dir)) + (cmd "blame") + (fname (file-relative-name (dvc-uniquify-file-name file) + (xgit-tree-root dir))) + (args (list repo cmd "--" fname))) + (dvc-switch-to-buffer-maybe buffer) + (dvc-run-dvc-sync 'xgit args + :finished + (dvc-capturing-lambda (output error status arguments) + (progn + (with-current-buffer (capture buffer) + (let ((inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (insert-buffer-substring output) + (goto-char (point-min)) + (xgit-annotate-mode)))))))) + +(defun xgit-annotate () + "Run git annotate" + (interactive) + (let* ((line (dvc-line-number-at-pos)) + (filename (dvc-confirm-read-file-name "Filename to annotate: ")) + (default-directory (xgit-tree-root filename))) + (xgit-do-annotate default-directory filename) + (goto-line line))) + +(defun xgit-stash-save (message) + "Run git-stash." + (interactive "sComment: ") + (if (equal message "") + (dvc-run-dvc-sync 'xgit (list "stash")) + (dvc-run-dvc-sync 'xgit (list "stash" "save" message)))) + +(defun xgit-stash-list (&optional only-list) + "Run git-stash list." + (interactive) + (dvc-run-dvc-display-as-info 'xgit (list "stash" "list")) + (when only-list + (with-current-buffer "*xgit-info*" + (let ((stash-list (split-string (buffer-string) "\n"))) + (loop for i in stash-list + with s = nil + collect (car (split-string i ":")) into s + finally (return s)))))) + +(defun xgit-stash-apply (&optional stash) + "Run git-stash apply." + (interactive) + (if current-prefix-arg + (save-window-excursion + (let ((sl (xgit-stash-list t)) + stash-num) + (setq stash-num (dvc-completing-read "Stash: " sl)) + (dvc-run-dvc-sync 'xgit (list "stash" "apply" stash-num)))) + (dvc-run-dvc-sync 'xgit (list "stash" "apply")))) + +(defun xgit-stash-clear () + "Run git-stash clear." + (interactive) + (dvc-run-dvc-sync 'xgit (list "stash" "clear")) + (message "All stash deleted")) ;; TODO run message in :finished + +(defun xgit-stash-drop (&optional stash) + "Run git-stash drop." + (interactive) + (if current-prefix-arg + (let ((sl (xgit-stash-list t)) + stash-num) + (save-window-excursion + (setq stash-num (dvc-completing-read "Stash: " sl))) + (dvc-run-dvc-sync 'xgit (list "stash" "drop" stash-num))) + (dvc-run-dvc-sync 'xgit (list "stash" "drop")))) + +(defun xgit-stash-pop (&optional stash) + "Run git-stash pop." + (interactive) + (if current-prefix-arg + (let ((sl (xgit-stash-list t)) + stash-num) + (save-window-excursion + (setq stash-num (dvc-completing-read "Stash: " sl))) + (dvc-run-dvc-sync 'xgit (list "stash" "pop" stash-num))) + (dvc-run-dvc-sync 'xgit (list "stash" "pop")))) + +(defun xgit-stash-show (&optional stash) + "Run git-stash show." + (interactive) + (if current-prefix-arg + (let ((sl (xgit-stash-list t)) + stash-num) + (save-window-excursion + (setq stash-num (dvc-completing-read "Stash: " sl))) + (dvc-run-dvc-display-as-info 'xgit (list "stash" "show" "-p" stash-num))) + (dvc-run-dvc-display-as-info 'xgit (list "stash" "show" "-p"))) + (with-current-buffer "*xgit-info*" + (diff-mode))) + +(defun xgit-tag-list () + "Run \"git tag\" and list all defined tags" + (interactive) + (if (interactive-p) + (dvc-run-dvc-display-as-info 'xgit (list "tag")) + (dvc-run-dvc-sync 'xgit (list "tag") + :finished 'dvc-output-buffer-split-handler))) + +(defun xgit-branch-list (&optional all) + "Run \"git branch\" and list all known branches. +When ALL is given, show all branches, using \"git branch -a\". +When called via lisp, return the list of branches. The currently selected branch is +returned as first entry." + (interactive "P") + (if (interactive-p) + (dvc-run-dvc-display-as-info 'xgit (list "branch" (when all "-a"))) + (let ((branch-list-raw + (dvc-run-dvc-sync 'xgit (list "branch" (when all "-a")) + :finished 'dvc-output-buffer-split-handler)) + (branch-list)) + (dolist (branch-entry branch-list-raw) + (cond ((string= (substring branch-entry 0 2) "* ") + (add-to-list 'branch-list (substring branch-entry 2))) + ((string= (substring branch-entry 0 2) " ") + (add-to-list 'branch-list (substring branch-entry 2) t)))) + branch-list))) + +(defun xgit-branch (branch-name) + "Run \"git branch BRANCH-NAME\" to create a new branch." + (interactive "sCreate new git branch: ") + (dvc-run-dvc-sync 'xgit (list "branch" branch-name))) + +(defun xgit-checkout (branch-name) + "Run \"git checout BRANCH-NAME\" to checkout an existing branch." + (interactive (list (dvc-completing-read "Checkout git branch: " (xgit-branch-list t)))) + (dvc-run-dvc-sync 'xgit (list "checkout" branch-name)) + (message "git checkout %s done." branch-name)) + +;;;###autoload +(defun xgit-apply-patch (file) + "Run \"git apply\" to apply the contents of FILE as a patch." + (interactive (list (dvc-confirm-read-file-name + "Apply file containing patch: " t))) + (dvc-run-dvc-sync 'xgit + (list "apply" (expand-file-name file)) + :finished + (lambda (output error status arguments) + (message "Imported git patch from %s" file)) + :error + (lambda (output error status arguments) + (dvc-show-error-buffer error) + (error "Error occurred while applying patch(es)")))) + +;;;###autoload +(defun xgit-apply-mbox (mbox &optional force) + "Run \"git am\" to apply the contents of MBOX as one or more patches. +If this command succeeds, it will result in a new commit being added to +the current git repository." + (interactive (list (dvc-confirm-read-file-name + "Apply mbox containing patch(es): " t))) + (dvc-run-dvc-sync 'xgit + (delq nil (list "am" (when force "-3") + (expand-file-name mbox))) + :finished + (lambda (output error status arguments) + (message "Imported git mbox from %s" mbox)) + :error + (lambda (output error status arguments) + (dvc-show-error-buffer error) + (error "Error occurred while applying patch(es)")))) + +;;; DVC revision support + +;;;###autoload +(defun xgit-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 "xgit-revision-get-last-revision file:%S last-revision:%S" + file last-revision) + (let* ((xgit-rev (int-to-string (1- (nth 1 last-revision)))) + (default-directory (car last-revision)) + (fname (file-relative-name + (dvc-uniquify-file-name file) + (xgit-tree-root)))) + (insert (dvc-run-dvc-sync + 'xgit (list "cat-file" "blob" + (format "HEAD~%s:%s" xgit-rev fname)) + :finished 'dvc-output-buffer-handler-withnewline)))) + +(defcustom xgit-use-index 'ask + "Whether xgit should use the index (aka staging area). + +\"Use the index\" means commit the content of the index, not the +content of the working tree. In practice, this means commit with +\"git commit\" (without -a), and diff with \"git diff\". + +\"Not use the index\" means commit the content of the working tree, +like most version control systems do. In practice, this means commit +with \"git commit -a\", and diff with \"git diff HEAD\". + +This option can be set to + + 'ask : ask whenever xgit needs the value, + 'always : always use the index, + 'never : never use the index. +" + :type '(choice (const ask) + (const always) + (const never)) + :group 'dvc-xgit) + +(defun xgit-use-index-p () + "Whether xgit should use the index this time. + +The value is determined based on `xgit-use-index'." + (case xgit-use-index + (always t) + (never nil) + (ask (message "Use git index (y/n/a/e/c/?)? ") + (let ((answer 'undecided)) + (while (eq answer 'undecided) + (case (progn + (let* ((tem (downcase (let ((cursor-in-echo-area t)) + (read-char-exclusive))))) + (if (= tem help-char) + 'help + (cdr (assoc tem '((?y . yes) + (?n . no) + (?a . always) + (?e . never) + (?c . customize) + (?? . help))))))) + (yes (setq answer t)) + (no (setq answer nil)) + (always + (setq xgit-use-index 'always) + (setq answer t)) + (never + (setq xgit-use-index 'never) + (setq answer nil)) + (customize + (customize-variable 'xgit-use-index) + (message "Use git index (y/n/a/e/c/?)? ")) + (help (message + "\"Use the index\" (aka staging area) means add file content +explicitly before commiting. Concretely, this means run commit +without -a, and run diff without options. + +Use git index? + y (Yes): yes, use the index this time + n (No) : no, not this time + a (Always) : always use the index from now + e (nEver) : never use the index from now + c (Customize) : customize the option so that you can save it for next + Emacs sessions. You'll still have to answer the question after. + +\(y/n/a/e/c/?)? ")))) + answer)))) + +(defun xgit-get-root-exclude-file (&optional root) + "returns exclude file for ROOT" + (concat (file-name-as-directory (xgit-git-dir root)) + "info/" + "exclude")) + +(provide 'xgit) +;;; xgit.el ends here diff --git a/dvc/lisp/xhg-annotate.el b/dvc/lisp/xhg-annotate.el new file mode 100644 index 0000000..2901556 --- /dev/null +++ b/dvc/lisp/xhg-annotate.el @@ -0,0 +1,143 @@ +;;; xhg-annotate.el --- + +;; Copyright (C) 2009 Thierry Volpiatto. +;; Author: Thierry Volpiatto +;; 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 "") '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 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 diff --git a/dvc/lisp/xhg-be.el b/dvc/lisp/xhg-be.el new file mode 100644 index 0000000..0df6890 --- /dev/null +++ b/dvc/lisp/xhg-be.el @@ -0,0 +1,57 @@ +;;; xhg-be.el --- dvc integration for the mercurial bugs everywhere plugin + +;; Copyright (C) 2006 by all contributors + +;; Author: Stefan Reichoer, + +;; 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 diff --git a/dvc/lisp/xhg-core.el b/dvc/lisp/xhg-core.el new file mode 100644 index 0000000..986a9ce --- /dev/null +++ b/dvc/lisp/xhg-core.el @@ -0,0 +1,65 @@ +;;; xhg-core.el --- Common definitions for mercurial support in DVC + +;; Copyright (C) 2005-2006 by all contributors + +;; Author: Stefan Reichoer, + +;; 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))) + +(provide 'xhg-core) +;;; xhg-core.el ends here diff --git a/dvc/lisp/xhg-dvc.el b/dvc/lisp/xhg-dvc.el new file mode 100644 index 0000000..df7e8e9 --- /dev/null +++ b/dvc/lisp/xhg-dvc.el @@ -0,0 +1,218 @@ +;;; xhg-dvc.el --- The dvc layer for xhg + +;; Copyright (C) 2005-2008 by all contributors + +;; Author: Stefan Reichoer, + +;; 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)) + +;; 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 diff --git a/dvc/lisp/xhg-gnus.el b/dvc/lisp/xhg-gnus.el new file mode 100644 index 0000000..b1885fa --- /dev/null +++ b/dvc/lisp/xhg-gnus.el @@ -0,0 +1,144 @@ +;;; xhg-gnus.el --- dvc integration to gnus + +;; Copyright (C) 2003-2007 by all contributors + +;; Author: Stefan Reichoer, +;; Contributions from: +;; Matthieu Moy + +;; 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) + +;; 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 xhg-insinuate-gnus () + "Integrate Xhg into Gnus. +The following keybindings are installed for gnus-summary: +K t s `xhg-gnus-article-view-status-for-import-patch'" + (interactive) + (dvc-gnus-initialize-keymap) + (define-key gnus-summary-dvc-submap [?s] 'xhg-gnus-article-view-status-for-import-patch) + ) + +(defvar xhg-apply-patch-mapping nil) +;;(add-to-list 'xhg-apply-patch-mapping '("my-wiki" "~/work/wiki/")) + +(defvar xhg-gnus-patch-from-user nil) + +(defvar xhg-gnus-import-patch-force nil) +(defun xhg-gnus-article-import-patch (n) + "Import MIME part N, as hg patch. +When N is negative, force applying the patch, even if there are +outstanding uncommitted changes." + (interactive "p") + (if (and (numberp n) (< n 0)) + (progn + (setq xhg-gnus-import-patch-force t) + (setq n (- n))) + (setq xhg-gnus-import-patch-force nil)) + (gnus-article-part-wrapper n 'xhg-gnus-import-patch)) + +(defun xhg-gnus-import-patch (handle) + "Import a hg patch via gnus. HANDLE should be the handle of the part." + (let ((patch-file-name (concat (dvc-make-temp-name "gnus-xhg-import-") ".patch")) + (window-conf (current-window-configuration)) + (import-dir)) + (gnus-summary-select-article-buffer) + (save-excursion + (goto-char (point-min)) + ;; handle does not seem to exist for text/x-patch ... + (when (re-search-forward "^user: +\\(.+\\)$" nil t) + (setq xhg-gnus-patch-from-user (match-string-no-properties 1)))) + (save-excursion + (goto-char (point-min)) + ;; handle does not seem to exist for text/x-patch ... + (search-forward "text/x-patch; ") + (mm-save-part-to-file (get-text-property (point) 'gnus-data) patch-file-name) + (dolist (m xhg-apply-patch-mapping) + (when (looking-at (car m)) + (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 "Import hg patch to: " nil nil t import-dir)) + (when import-dir + (let ((default-directory import-dir) + (current-dvc)) + (setq current-dvc (dvc-current-active-dvc)) + (case current-dvc + ('xhg (xhg-import patch-file-name xhg-gnus-import-patch-force)) + ('xgit (xgit-apply-patch patch-file-name)) + ;; TODO Add here new backend + (t (error "Unknow backend"))))) + (delete-file patch-file-name) + (kill-buffer (current-buffer)) ;; the patch file + (set-window-configuration window-conf) + (let ((default-directory import-dir) + (current-dvc)) + (setq current-dvc (dvc-current-active-dvc)) + (case current-dvc + ;; TODO Add here new backend + ('xhg (when (and import-dir (y-or-n-p "Run hg log in patched directory? ")) + (xhg-log "tip" "-10") + (delete-other-windows))) + ('xgit (when (and import-dir (y-or-n-p "Run xgit-status?")) + (xgit-status))))))) + + +(defvar xhg-gnus-status-window-configuration nil) +(defun xhg-gnus-article-view-status-for-import-patch (n) + "View the status for the repository, where MIME part N would be applied as hg patch. + +Use the same logic as in `xhg-gnus-article-import-patch' to guess the repository path +via `xhg-apply-patch-mapping'." + (interactive "p") + (gnus-article-part-wrapper n 'xhg-gnus-view-status-for-import-patch) + (set-window-configuration xhg-gnus-status-window-configuration)) + +(defun xhg-gnus-view-status-for-import-patch (handle) + "View the status for a repository before applying a hg patch via gnus. +HANDLE should be the handle of the part." + (let ((window-conf (current-window-configuration)) + (import-dir)) + (gnus-summary-select-article-buffer) + (save-excursion + (goto-char (point-min)) + ;; handle does not seem to exist for text/x-patch ... + (search-forward "text/x-patch; ") + (dolist (m xhg-apply-patch-mapping) + (when (looking-at (car m)) + (setq import-dir (dvc-uniquify-file-name (cadr m)))))) + (unless import-dir ;; when we find the directory in xhg-apply-patch-mapping don't ask for confirmation + (setq import-dir (dvc-read-directory-name "View hg repository status for: " nil nil t import-dir))) + (let ((default-directory import-dir)) + (xhg-dvc-status) + (delete-other-windows) + (setq xhg-gnus-status-window-configuration (current-window-configuration)) + (dvc-buffer-push-previous-window-config window-conf)))) + +(provide 'xhg-gnus) +;;; xhg-gnus.el ends here diff --git a/dvc/lisp/xhg-log.el b/dvc/lisp/xhg-log.el new file mode 100644 index 0000000..ed5b9fe --- /dev/null +++ b/dvc/lisp/xhg-log.el @@ -0,0 +1,237 @@ +;;; xhg-log.el --- Mercurial interface for dvc: mode for hg log style output + +;; Copyright (C) 2005-2008 by all contributors + +;; Author: Stefan Reichoer, + +;; 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 mercurial interface for dvc: a mode to handle xhg log style output + +;;; Commands: +;; +;; Below is a complete command list: +;; +;; `xhg-log-mode' +;; Major mode to display hg log output with embedded diffs. Derives from `diff-mode'. +;; `xhg-log-next' +;; Move to the next changeset header of the next diff hunk +;; `xhg-log-previous' +;; Move to the previous changeset header of the previous diff hunk +;; `xhg-log-dwim-next' +;; Either move to the next changeset via `xhg-log-next' or call `scroll-up'. +;; `xhg-log-toggle-diff-for-changeset' +;; Toggle displaying the diff for the current changeset. +;; `xhg-log-review-next-diff' +;; Close the previous viewed inline diff and open the next one for reviewing. +;; `xhg-log-review-previous-diff' +;; Close the previous viewed inline diff and open the previous one for reviewing. +;; + +;;; History: + +;; + +;;; Code: + +(require 'diff-mode) + +(defvar xhg-log-mode-map + (let ((map (copy-keymap diff-mode-shared-map))) + (define-key map dvc-keyvec-help 'describe-mode) + (define-key map [?g] 'xhg-log) + (define-key map [?R] 'xhg-rollback) + (define-key map [?T] 'xhg-log-toggle-verbose) + (define-key map [?G] 'xhg-search-regexp-in-log) + (define-key map [?h] 'dvc-buffer-pop-to-partner-buffer) + (define-key map [?e] 'xhg-export) + (define-key map [?E] 'xhg-export-via-mail) + (define-key map [?s] 'xhg-status) + (define-key map [?=] 'xhg-log-toggle-diff-for-changeset) + (define-key map [?v] 'xhg-log-review-next-diff) + (define-key map [?V] 'xhg-log-review-previous-diff) + (define-key map dvc-keyvec-next 'xhg-log-next) + (define-key map dvc-keyvec-previous 'xhg-log-previous) + (define-key map [?\ ] 'xhg-log-dwim-next) + (define-key map dvc-keyvec-quit 'dvc-buffer-quit) + + ;; 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))) + map) + "Keymap used in `xhg-log-mode'.") + +(easy-menu-define xhg-log-mode-menu xhg-log-mode-map + "`xhg-log-mode' menu" + `("hg-log" + ["Show status" dvc-status t] ;; `xhg-status' is not defined at compile time. + ["Toggle embedded diff" xhg-log-toggle-diff-for-changeset t] + ["Start Commiting" dvc-log-edit t] + ["Export Changeset" xhg-export t] + ["Export Changeset via Email" xhg-export-via-mail t] + )) + + +(defvar xhg-log-font-lock-keywords + (append + '(("^changeset:" . font-lock-function-name-face) + ("^branch:" . font-lock-function-name-face) + ("^tag:" . font-lock-function-name-face) + ("^user:" . font-lock-function-name-face) + ("^date:" . font-lock-function-name-face) + ("^summary:" . font-lock-function-name-face) + ("^parent:" . font-lock-function-name-face)) + diff-font-lock-keywords) + "Keywords in `xhg-log-mode' mode.") + +(defvar xhg-log-review-current-diff-revision nil) +(defvar xhg-log-review-recenter-position-on-next-diff 5) + +(define-derived-mode xhg-log-mode fundamental-mode "xhg-log" + "Major mode to display hg log output with embedded diffs. Derives from `diff-mode'. + +Commands: +\\{xhg-log-mode-map} +" + (let ((diff-mode-shared-map (copy-keymap xhg-log-mode-map)) + major-mode mode-name) + (diff-mode)) + (set (make-local-variable 'font-lock-defaults) + (list 'xhg-log-font-lock-keywords t nil nil)) + (set (make-local-variable 'xhg-log-review-current-diff-revision) nil)) + +(defconst xhg-log-start-regexp "^ *changeset: +\\([0-9]+:[0-9a-f]+\\)") +(defun xhg-log-next (n) + "Move to the next changeset header of the next diff hunk" + (interactive "p") + (end-of-line) + (re-search-forward xhg-log-start-regexp nil t n) + (beginning-of-line) + (when xhg-log-review-recenter-position-on-next-diff + (recenter xhg-log-review-recenter-position-on-next-diff))) +;; TODO: add (diff-hunk-next) + +(defun xhg-log-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 xhg-log-start-regexp)) + (re-search-backward xhg-log-start-regexp)) + (re-search-backward xhg-log-start-regexp nil t n) + (when xhg-log-review-recenter-position-on-next-diff + (recenter xhg-log-review-recenter-position-on-next-diff))) +;; TODO: add (diff-hunk-prev) + +(defun xhg-log-dwim-next () + "Either move to the next changeset via `xhg-log-next' or call `scroll-up'. +When the beginning of the next changeset is already visible, call `xhg-log-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 (xhg-log-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) + (xhg-log-next 1)))) + +(defun xhg-log-revision-at-point () + (save-excursion + (end-of-line) + (re-search-backward xhg-log-start-regexp) + (match-string-no-properties 1))) + +(defun xhg-log-inline-diff-opened-here () + (save-excursion + (end-of-line) + (re-search-backward xhg-log-start-regexp) + (re-search-forward "^$") + (forward-line 1) + (looking-at "diff"))) + +(defun xhg-log-toggle-diff-for-changeset () + "Toggle displaying the diff for the current changeset." + (interactive) + (let ((rev (xhg-log-revision-at-point)) + (insert-diff)) + (dvc-trace "xhg-log-toggle-diff-for-changeset %s" rev) + (save-excursion + (end-of-line) + (re-search-backward xhg-log-start-regexp) + (re-search-forward "^$") + (forward-line 1) + (setq insert-diff (not (looking-at "diff"))) + (let ((buffer-read-only nil)) + (save-excursion + (if insert-diff + (progn (save-excursion + (insert + (dvc-run-dvc-sync 'xhg (list "log" "-r" rev "-p") + :finished 'dvc-output-buffer-handler))) + (delete-region (point) (- (re-search-forward "^diff") 4))) + (delete-region (point) + (or (and (re-search-forward xhg-log-start-regexp nil t) (line-beginning-position)) + (goto-char (point-max)))))))))) + +(defun xhg-log-goto-revision (rev) + "Move point to the revision REV. If REV is not found in the log buffer, do nothing." + (let ((rev-pos)) + (save-excursion + (when + (re-search-forward (concat "^changeset: +" rev) nil t) + (setq rev-pos (point)))) + (when rev-pos + (goto-char rev-pos)))) + +(defun xhg-log-review-next-diff (n) + "Close the previous viewed inline diff and open the next one for reviewing. +When invoked the first time, just open the diff at point via `xhg-log-toggle-diff-for-changeset'. +For every further invocation close the previously opened diff and open the next one. +N is the number of revisions to skip. Per default advance 1 revision." + (interactive "p") + (when (and (numberp n) (< n 0)) + (setq n (- n 1))) + (let ((cur-pos (point))) + (when xhg-log-review-current-diff-revision + ;; close the previous diff + (xhg-log-goto-revision xhg-log-review-current-diff-revision) + (when (xhg-log-inline-diff-opened-here) + (xhg-log-toggle-diff-for-changeset)) + (if (eq n 0) + (goto-char cur-pos) + (xhg-log-next n))) + (setq xhg-log-review-current-diff-revision (xhg-log-revision-at-point)) + (unless (xhg-log-inline-diff-opened-here) + (xhg-log-toggle-diff-for-changeset)) + (when xhg-log-review-recenter-position-on-next-diff + (recenter xhg-log-review-recenter-position-on-next-diff)))) + +(defun xhg-log-review-previous-diff (n) + "Close the previous viewed inline diff and open the previous one for reviewing. +See `xhg-log-review-next-diff' for details." + (interactive "p") + (xhg-log-review-next-diff (- n))) + +(provide 'xhg-log) +;;; xhg-log.el ends here diff --git a/dvc/lisp/xhg-mq.el b/dvc/lisp/xhg-mq.el new file mode 100644 index 0000000..eb4da97 --- /dev/null +++ b/dvc/lisp/xhg-mq.el @@ -0,0 +1,711 @@ +;;; xhg-mq.el --- dvc integration for hg's mq + +;; Copyright (C) 2006-2009 by all contributors + +;; Author: Stefan Reichoer, + +;; 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 mq see: +;; http://www.selenic.com/mercurial/wiki/index.cgi/MqTutorial + +;;; Commands: +;; +;; Below is a complete command list: +;; +;; `xhg-qinit' +;; Run hg qinit. +;; `xhg-qnew' +;; Run hg qnew. +;; `xhg-qrefresh' +;; Run hg qrefresh. +;; `xhg-qrefresh-header' +;; Run hg qrefresh --message. +;; `xhg-qrefresh-edit-message-done' +;; Use the current buffer content as parameter for hg qrefresh --message. +;; `xhg-qrefresh-edit-message-mode' +;; Major mode to edit the mq header message for the current patch. +;; `xhg-qpop' +;; Run hg qpop. +;; `xhg-qpush' +;; Run hg qpush. +;; `xhg-qapplied' +;; Run hg qapplied. +;; `xhg-qunapplied' +;; Run hg qunapplied. +;; `xhg-qseries' +;; Run hg qseries. +;; `xhg-qdiff' +;; Run hg qdiff. +;; `xhg-qdelete' +;; Run hg qdelete +;; `xhg-qconvert-to-permanent' +;; Convert all applied patchs in permanent changeset. +;; `xhg-qrename' +;; Run hg qrename +;; `xhg-qtop' +;; Run hg qtop. +;; `xhg-qnext' +;; Run hg qnext. +;; `xhg-qprev' +;; Run hg qprev. +;; `xhg-qheader' +;; Run hg qheader. +;; `xhg-qsingle' +;; Merge applied patches in a single patch satrting from "qbase". +;; `xhg-qimport' +;; Run hg qimport +;; `xhg-mq-export-via-mail' +;; Prepare an email that contains a mq patch. +;; `xhg-mq-show-stack' +;; Show the mq stack. +;; `xhg-qdiff-at-point' +;; Show the diff for a given patch. +;; `xhg-mq-mode' +;; Major mode for xhg mq interaction. +;; `xhg-mq-edit-series-file' +;; Edit the mq patch series file +;; + +;; The following commands are available for hg's mq: +;; X qapplied print the patches already applied +;; qclone clone main and patch repository at same time +;; qcommit commit changes in the queue repository +;; X qdelete remove a patch from the series file +;; X qdiff diff of the current patch +;; qfold fold the named patches into the current patch +;; qgoto push or pop patches until named patch is at top of stack +;; qguard set or print guards for a patch +;; X qheader Print the header of the topmost or specified patch +;; X qimport import a patch +;; X qinit init a new queue repository +;; X qnew create a new patch +;; X qnext print the name of the next patch +;; X qpop pop the current patch off the stack +;; X qprev print the name of the previous patch +;; X qpush push the next patch onto the stack +;; X qrefresh update the current patch +;; X qrename rename a patch +;; qrestore restore the queue state saved by a rev +;; qsave save current queue state +;; qselect set or print guarded patches to push +;; X qseries print the entire series file +;; X qtop print the name of the current patch +;; X qunapplied print the patches not yet applied + +;;; Code: + +(defvar xhg-mq-submenu + '("mq" + ["Show mq stack" xhg-mq-show-stack t] + ["mq refresh" xhg-qrefresh t] + ["mq diff" xhg-qdiff t] + ["mq push" xhg-qpush t] + ["mq pop" xhg-qpop t] + ["mq applied" xhg-qapplied t] + ["mq unapplied" xhg-qunapplied t] + ["mq series" xhg-qseries t] + ["mq delete" xhg-qdelete t] + ["mq rename" xhg-qrename t] + ["mq header" xhg-qheader t] + "--" + ["mq init" xhg-qinit t] + ["mq new" xhg-qnew t] + )) + +(defvar xhg-mq-sub-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [?A] 'xhg-qapplied) + (define-key map [?U] 'xhg-qunapplied) + (define-key map [?S] 'xhg-qseries) + (define-key map [?s] 'xhg-mq-show-stack) + (define-key map [?e] 'xhg-mq-edit-series-file) + (define-key map [?h] 'xhg-qheader) + (define-key map [?H] 'xhg-qrefresh-header) + (define-key map [?R] 'xhg-qrefresh) + (define-key map [?M] 'xhg-qrename) + (define-key map [?P] 'xhg-qpush) ;; mnemonic: stack gets bigger + (define-key map [?p] 'xhg-qpop) ;; mnemonic: stack gets smaller + (define-key map [?t] 'xhg-qtop) + (define-key map [?+] 'xhg-qnext) + (define-key map [?-] 'xhg-qprev) + (define-key map [?=] 'xhg-qdiff) + (define-key map [?d] 'xhg-qdelete) + (define-key map [?N] 'xhg-qnew) + (define-key map [?E] 'xhg-mq-export-via-mail) + (define-key map [?x] 'xhg-qsingle) + (define-key map [?C] 'xhg-qconvert-to-permanent) + map) + "Keymap used for xhg-mq commands.") + +(defvar xhg-mq-cookie nil "Ewoc cookie for xhg mq buffers.") + +;;;###autoload +(defun xhg-qinit (&optional dir qinit-switch) + "Run hg qinit. +When called without a prefix argument run hg qinit -c, otherwise hg qinit." + (interactive + (list (progn (setq qinit-switch (if current-prefix-arg "" "-c")) + (expand-file-name (dvc-read-directory-name (format "Directory for hg qinit %s: " qinit-switch) + (or default-directory + (getenv "HOME"))))) + qinit-switch)) + (let ((default-directory dir)) + (dvc-run-dvc-sync 'xhg (list "qinit" qinit-switch) + :finished (dvc-capturing-lambda + (output error status arguments) + (message "hg qinit finished"))))) + +(defun xhg-qnew-name-patch () + "Return a default name for a new patch based on last revision number" + (let ((cur-patch (xhg-qtop)) + (cur-rev (xhg-dry-tip)) + (patch-name) + (patch-templ-regex "\\(patch-r[0-9]+\\)")) + (if cur-patch + (if (string-match patch-templ-regex cur-patch) + (setq patch-name + (replace-regexp-in-string "\\([0-9]+\\)" + (int-to-string + (+ (string-to-number cur-rev) 1)) + cur-patch)) + (setq patch-name + (replace-regexp-in-string "\\([0-9]+\\)" + (int-to-string + (+ (string-to-number cur-rev) 1)) + "patch-r0"))) + (setq patch-name + "Initial-patch")) + patch-name)) + +;;;###autoload +(defun xhg-qnew (patch-name &optional commit-description force) + "Run hg qnew. +Asks for the patch name and an optional commit description. +If the commit description is not empty, run hg qnew -m \"commit description\" +When called with a prefix argument run hg qnew -f." + (interactive + (list (read-from-minibuffer "qnew patch name: " nil nil nil nil (xhg-qnew-name-patch)) + (read-from-minibuffer "qnew commit message (empty for none): " nil nil nil nil + "New patch, edit me when done with ") + current-prefix-arg)) + (when (string= commit-description "") + (setq commit-description nil)) + (dvc-run-dvc-sync 'xhg (list "qnew" + (when force "-f") + (when commit-description "-m") + (when commit-description (concat "\"" commit-description "\"")) + patch-name))) + +;;;###autoload +(defun xhg-qrefresh () + "Run hg qrefresh." + (interactive) + (let ((top (xhg-qtop))) + (dvc-run-dvc-sync 'xhg (list "qrefresh")) + (message (format "hg qrefresh for %s finished" top)))) + +;;;###autoload +(defun xhg-qrefresh-header () + "Run hg qrefresh --message." + (interactive) + (let ((cur-message (xhg-qheader)) + (cur-dir default-directory)) + (dvc-buffer-push-previous-window-config) + (pop-to-buffer (get-buffer-create (format "*xhg header for %s*" (xhg-qtop)))) + (setq default-directory (dvc-tree-root cur-dir)) + (erase-buffer) + (insert cur-message) + (xhg-qrefresh-edit-message-mode) + (message "Edit the message and hit C-c C-c to accept it."))) + +(defun xhg-qrefresh-edit-message-done () + "Use the current buffer content as parameter for hg qrefresh --message." + (interactive) + (let ((logfile-name (make-temp-file "xhg-qrefresh")) + (new-message (buffer-substring-no-properties (point-min) (point-max))) + (message-buf)) + (save-excursion + (find-file logfile-name) + (setq message-buf (current-buffer)) + (insert new-message) + (save-buffer)) + (dvc-run-dvc-sync 'xhg (list "qrefresh" "--logfile" logfile-name)) + (kill-buffer message-buf) + (delete-file logfile-name) + (let ((dvc-buffer-quit-mode 'kill)) + (dvc-buffer-quit)))) + +(defvar xhg-qrefresh-edit-message-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [(control ?c) (control ?c)] 'xhg-qrefresh-edit-message-done) + map) + "Keymap used in a xhg qrefresh edit message buffer.") + +(define-derived-mode xhg-qrefresh-edit-message-mode fundamental-mode + "xhg qrefresh edit message" + "Major mode to edit the mq header message for the current patch." + (dvc-install-buffer-menu)) + +;;;###autoload +(defun xhg-qpop (&optional all) + "Run hg qpop. +When called with a prefix argument run hg qpop -a." + (interactive + (list current-prefix-arg)) + (let ((curbuf (current-buffer))) + (message (format "qpop -> %s" + (dvc-run-dvc-sync 'xhg (list "qpop" (when all "-a")) + :finished 'dvc-output-buffer-handler + :error (lambda (output error status arguments) + (if (eq status 1) + (message "no patches applied") + (message "error status: %d" status)))))) + (xhg-mq-maybe-refresh-patch-buffer) + (pop-to-buffer curbuf))) + +;;;###autoload +(defun xhg-qpush (&optional all) + "Run hg qpush. +When called with a prefix argument run hg qpush -a." + (interactive + (list current-prefix-arg)) + (let ((curbuf (current-buffer))) + (message (format "qpush -> %s" + (dvc-run-dvc-sync 'xhg (list "qpush" (when all "-a")) + :finished 'dvc-output-buffer-handler + :error (lambda (output error status arguments) + (if (eq status 1) + (message "patch series fully applied") + (message "error status: %d" status)))))) + (xhg-mq-maybe-refresh-patch-buffer) + (pop-to-buffer curbuf))) + +(defun xhg-mq-maybe-refresh-patch-buffer () + (let ((patch-buffer (dvc-get-buffer 'xhg 'patch-queue))) + (when patch-buffer + (with-current-buffer patch-buffer + (dvc-generic-refresh))))) + +(defun xhg-mq-printer (elem) + "Print an element ELEM of the mq patch list." + (insert (dvc-face-add (car elem) (cadr elem)))) + +(defun xhg-process-mq-patches (cmd-list header refresh-function &optional only-show) + (let ((patches (delete "" (dvc-run-dvc-sync 'xhg cmd-list + :finished 'dvc-output-buffer-split-handler)))) + (when only-show + (let ((curbuf (current-buffer))) + (pop-to-buffer (dvc-get-buffer-create 'xhg 'patch-queue)) + (let ((inhibit-read-only t)) + (erase-buffer) + (insert header) + (set (make-local-variable 'xhg-mq-cookie) + (ewoc-create (dvc-ewoc-create-api-select #'xhg-mq-printer))) + (put 'xhg-mq-cookie 'permanent-local t) + (dolist (patch patches) + (ewoc-enter-last xhg-mq-cookie (list patch nil)))) + (xhg-mq-mode) + (setq dvc-buffer-refresh-function refresh-function) + (goto-char (point-min)) + (forward-line 1) + (pop-to-buffer curbuf))) + patches)) + +;;;###autoload +(defun xhg-qapplied () + "Run hg qapplied." + (interactive) + (xhg-process-mq-patches '("qapplied") "hg qapplied:" 'xhg-qapplied (interactive-p))) + +;;;###autoload +(defun xhg-qunapplied () + "Run hg qunapplied." + (interactive) + (xhg-process-mq-patches '("qunapplied") "hg qunapplied:" 'xhg-qunapplied (interactive-p))) + +;;;###autoload +(defun xhg-qseries () + "Run hg qseries." + (interactive) + (xhg-process-mq-patches '("qseries") "hg series:" 'xhg-qseries (interactive-p))) + +;;;###autoload +(defun xhg-qdiff (&optional file) + "Run hg qdiff." + (interactive) + (let ((curbuf (current-buffer))) + (dvc-run-dvc-display-as-info 'xhg (list "qdiff" file) nil (format "hg qdiff %s:\n" (xhg-qtop))) + (with-current-buffer "*xhg-info*" + (diff-mode)) + (pop-to-buffer curbuf))) + +;;;###autoload +(defun xhg-qdelete (patch) + "Run hg qdelete" + (interactive (list + (let ((unapplied (xhg-qunapplied))) + (if unapplied + (dvc-completing-read "Delete mq patch: " unapplied nil t + (car (member (xhg-mq-patch-name-at-point) unapplied))) + (message "No unapplied patch to delete from the mq series file") + nil)))) + (when patch + (dvc-run-dvc-sync 'xhg (list "qdelete" patch)) + (xhg-mq-maybe-refresh-patch-buffer))) + +;;;###autoload +(defun xhg-qconvert-to-permanent (&optional force) + "Convert all applied patchs in permanent changeset. +Run the command hg qdelete -r qbase:qtip +Called with prefix-arg, do not prompt for confirmation" + (interactive) + (let ((tip (with-temp-buffer + (apply #'call-process "hg" nil t nil + (list "tip" "--template" "#rev#")) + (buffer-string))) + (confirm)) + (if current-prefix-arg + (progn + (dvc-run-dvc-sync 'xhg (list "qdelete" "-r" "qbase:qtip")) + (message "All patchs converted to permanent changeset: now at rev %s" tip)) + (setq confirm (read-string "Really add permanent changesets to this repo?\(y/n\): ")) + (if (equal confirm "y") + (progn + (dvc-run-dvc-sync 'xhg (list "qdelete" "-r" "qbase:qtip")) + (message "All patchs converted to permanent changeset: now at rev %s" tip)) + (message "Operation cancelled"))))) + +;;;###autoload +(defun xhg-qrename (from to) + "Run hg qrename" + (interactive (let ((old-name (or (xhg-mq-patch-name-at-point) (xhg-qtop)))) + (list + old-name + (if old-name + (read-from-minibuffer (format "Rename mq patch '%s' to: " old-name) old-name) + (message "No mq patch to rename found") + nil)))) + (message "Running hg qrename %s %s" from to) + (when (and from to) + (dvc-run-dvc-sync 'xhg (list "qrename" from to)))) + +;;;###autoload +(defun xhg-qtop () + "Run hg qtop." + (interactive) + (let ((top (dvc-run-dvc-sync 'xhg '("qtop") + :finished 'dvc-output-buffer-handler + :error (lambda (output error status arguments) + nil)))) + (when (interactive-p) + (if top + (message "Mercurial qtop: %s" top) + (message "Mercurial qtop: no patches applied"))) + top)) + +;;;###autoload +(defun xhg-qnext () + "Run hg qnext." + (interactive) + (let ((next (dvc-run-dvc-sync 'xhg '("qnext") + :finished 'dvc-output-buffer-handler))) + (when (interactive-p) + (message "Mercurial qnext: %s" next)) + next)) + +;;;###autoload +(defun xhg-qprev () + "Run hg qprev." + (interactive) + (let ((prev (dvc-run-dvc-sync 'xhg '("qprev") + :finished 'dvc-output-buffer-handler))) + (when (interactive-p) + (message "Mercurial qprev: %s" prev)) + prev)) + +;;;###autoload +(defun xhg-qheader (&optional patch) + "Run hg qheader." + (interactive + (list + (xhg-mq-patch-name-at-point))) + (let ((header (dvc-run-dvc-sync 'xhg (list "qheader" patch) + :finished 'dvc-output-buffer-handler))) + (when (interactive-p) + (message "Mercurial qheader: %s" header)) + header)) + +(defun xhg-mq-patch-file-name (patch) + (concat (xhg-tree-root) "/.hg/patches/" patch)) + +;;;###autoload +(defun* xhg-qsingle (file &optional (start-from "qbase")) + "Merge applied patches in a single patch starting from \"qbase\". +If prefix arg, merge applied patches starting from revision number or patch-name." + (interactive "FPatchName: ") + (when (and current-prefix-arg (interactive-p)) + (let ((series (xhg-qseries))) + (setq start-from (completing-read "PatchName: " + series nil t + (car (member (xhg-mq-patch-name-at-point) series)))))) + (let* ((base (with-temp-buffer + (apply #'call-process "hg" nil t nil + `("parents" + "-r" + ,start-from + "--template" + "#rev#")) + (buffer-string))) + (patch (with-temp-buffer + (apply #'call-process "hg" nil t nil + (list "diff" + "-r" + base + "-r" + "qtip" + (when xhg-export-git-style-patches "--git"))) + (buffer-string))) + (applied (split-string + (with-temp-buffer + (apply #'call-process "hg" nil t nil + (list "qapplied" "-s")) + (buffer-string)) "\n"))) + (when (not (equal start-from "qbase")) + (let (pos elm) + (catch 'break + (dolist (i applied) + (when (string-match start-from i) + (throw 'break + (setq elm i))))) + (setq pos (position elm applied)) + (setq applied (subseq applied pos)))) + (find-file file) + (goto-char (point-min)) + (erase-buffer) + (insert (format "##Merge of all patches applied from revision %s\n" base)) + (mapc #'(lambda (x) + (insert (concat "## " x "\n"))) + applied) + (insert patch) + (save-buffer) + (kill-buffer (current-buffer)) + (message "Ok patch extracted from rev %s to tip in %s" base file))) + +;;;###autoload +(defun xhg-qimport (patch &optional push) + "Run hg qimport" + (interactive (list (read-file-name "Import hg qpatch: " + nil + nil + t + (when + (eq major-mode 'dired-mode) + (file-name-nondirectory (dired-get-filename)))))) + (if current-prefix-arg + (progn + (and (dvc-run-dvc-sync 'xhg (list "qimport" (expand-file-name patch))) + (dvc-run-dvc-sync 'xhg (list "qpush"))) + (message "Ok patch %s added" patch)) + (dvc-run-dvc-sync 'xhg (list "qimport" (expand-file-name patch))) + (message "Ok patch %s added ; don't forget to qpush" patch))) + +;; -------------------------------------------------------------------------------- +;; Higher level functions +;; -------------------------------------------------------------------------------- + +;;;###autoload +(defun xhg-mq-export-via-mail (patch &optional single) + "Prepare an email that contains a mq patch. +`xhg-submit-patch-mapping' is honored for the destination email address and the project name +that is used in the generated email." + (interactive (list + (let ((series (xhg-qseries))) + (dvc-completing-read (if current-prefix-arg + "Send single patch from: " + "Send mq patch via mail: ") series nil t + (car (member (xhg-mq-patch-name-at-point) series)))))) + (let ((file-name) + (destination-email "") + (base-file-name nil) + (subject) + (log)) + (dolist (m xhg-submit-patch-mapping) + (when (string= (dvc-uniquify-file-name (car m)) (dvc-uniquify-file-name (xhg-tree-root))) + ;;(message "%S" (cadr m)) + (setq destination-email (car (cadr m))) + (setq base-file-name (cadr (cadr m))))) + (message "Preparing an email for the mq patch '%s' for '%s'" patch destination-email) + (if (or current-prefix-arg single) + (let ((pname (format "single-from-%s-to-tip.patch" patch))) + (setq file-name (concat (dvc-uniquify-file-name dvc-temp-directory) + pname)) + (xhg-qsingle file-name patch) + (setq log + (with-temp-buffer + (let (beg end) + (insert-file-contents file-name) + (goto-char (point-min)) + (setq beg (point)) + (when (re-search-forward "^diff" nil t) + (setq end (point-at-bol))) + (replace-regexp-in-string "^#*" "" (buffer-substring beg end))))) + (setq subject pname)) + (setq file-name (concat (dvc-uniquify-file-name dvc-temp-directory) + (or base-file-name "") "-" patch ".patch")) + (copy-file (xhg-mq-patch-file-name patch) file-name t t)) + + (require 'reporter) + (delete-other-windows) + (reporter-submit-bug-report + destination-email + nil + nil + nil + nil + (if (or current-prefix-arg single) + log + dvc-patch-email-message-body-template)) + (unless (or current-prefix-arg single) + (setq subject (if base-file-name (concat base-file-name ": " patch) patch))) + + ;; delete emacs version - its not needed here + (delete-region (point) (point-max)) + + (mml-attach-file file-name "text/x-patch") + (goto-char (point-min)) + (mail-position-on-field "Subject") + (insert (concat "[MQ-PATCH] " subject)) + (when (search-forward "<>" nil t) + (forward-line 1)) + (find-file-other-window file-name) + (other-window -1))) + +;;;###autoload +(defun xhg-mq-show-stack () + "Show the mq stack." + (interactive) + (xhg-process-mq-patches '("qseries") "hg stack:" 'xhg-mq-show-stack (interactive-p)) + (let ((applied (xhg-qapplied)) + (unapplied (xhg-qunapplied)) + (top (xhg-qtop)) + (top-pos)) + (with-current-buffer (dvc-get-buffer 'xhg 'patch-queue) + (let ((buffer-read-only nil) + (old-applied-patches (progn (goto-char (point-min)) (next-line 1) + (split-string (buffer-substring-no-properties (point) (- (point-max) 1))))) + (act-patches (append applied unapplied))) + (dolist (u unapplied) + (goto-char (point-min)) + (when (re-search-forward (concat "^" u "$") nil t) + (setcar (cdr (xhg-mq-ewoc-data-at-point)) nil))) + (dolist (a applied) + (goto-char (point-min)) + (when (re-search-forward (concat "^" a "$") nil t) + (setcar (cdr (xhg-mq-ewoc-data-at-point)) 'dvc-move))) + (dolist (p old-applied-patches) + (when (not (member p act-patches)) + (goto-char (point-min)) + (when (re-search-forward (concat "^" p "$") nil t) + (message "Patch %s no longer present" p) + (dvc-ewoc-delete xhg-mq-cookie (ewoc-locate xhg-mq-cookie))))) + (when top + (goto-char (point-min)) + (when (re-search-forward (concat "^" top "$") nil t) + (setq top-pos (line-beginning-position)) + (setcar (cdr (xhg-mq-ewoc-data-at-point)) 'bold))) + (ewoc-refresh xhg-mq-cookie) + (when top-pos + (goto-char top-pos)))))) + +(defun xhg-qdiff-at-point (&optional patch) + "Show the diff for a given patch." + (interactive) + (let ((patch-name (or patch (xhg-mq-patch-name-at-point))) + (cur-buf (current-buffer))) + (find-file-other-window (xhg-mq-patch-file-name patch-name)) + (toggle-read-only 1) + (diff-mode) + (pop-to-buffer cur-buf))) + +;; -------------------------------------------------------------------------------- +;; the xhg mq mode +;; -------------------------------------------------------------------------------- + +(defvar xhg-mq-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 [?g] 'dvc-generic-refresh) + (define-key map [?e] 'xhg-mq-edit-series-file) + (define-key map [down] 'xhg-mq-next) + (define-key map [up] 'xhg-mq-previous) + (define-key map [?P] 'xhg-qpush) ;; mnemonic: stack gets bigger + (define-key map [?p] 'xhg-qpop) ;; mnemonic: stack gets smaller + (define-key map [?=] 'xhg-qdiff-at-point) + (define-key map [?E] 'xhg-mq-export-via-mail) + (define-key map [?M] 'xhg-qrename) + (define-key map [?x] 'xhg-qsingle) + (define-key map [?C] 'xhg-qconvert-to-permanent) + (define-key map [?Q] xhg-mq-sub-mode-map) + map) + "Keymap used in a xhg mq buffer.") + +(easy-menu-define xhg-mq-mode-menu xhg-mq-mode-map + "`xhg-mq-mode' menu" + xhg-mq-submenu) + +(define-derived-mode xhg-mq-mode fundamental-mode + "xhg mq mode" + "Major mode for xhg mq interaction." + (dvc-install-buffer-menu) + (toggle-read-only 1)) + +(defun xhg-mq-ewoc-data-at-point () + (if (or (= (dvc-line-number-at-pos) 1) + (eq (line-beginning-position) (line-end-position)) + (not (eq major-mode 'xhg-mq-mode))) + nil + (ewoc-data (ewoc-locate xhg-mq-cookie)))) + +(defun xhg-mq-patch-name-at-point () + "Return the patch name at point in a xhg mq buffer." + (car (xhg-mq-ewoc-data-at-point))) + +(defun xhg-mq-edit-series-file () + "Edit the mq patch series file" + (interactive) + (find-file-other-window (concat (dvc-tree-root) "/.hg/patches/series")) + (message "You can carefully reorder the patches in the series file. Comments starting with '#' and empty lines are allowed.")) + +(defun xhg-mq-next () + (interactive) + (let ((pos (point))) + (forward-line 1) + (unless (xhg-mq-ewoc-data-at-point) + (goto-char pos)))) + +(defun xhg-mq-previous () + (interactive) + (let ((pos (point))) + (forward-line -1) + (unless (xhg-mq-ewoc-data-at-point) + (goto-char pos)))) + +(provide 'xhg-mq) +;;; xhg-mq.el ends here diff --git a/dvc/lisp/xhg-revision.el b/dvc/lisp/xhg-revision.el new file mode 100644 index 0000000..af9863f --- /dev/null +++ b/dvc/lisp/xhg-revision.el @@ -0,0 +1,126 @@ +;;; xhg-revision.el --- Management of revision lists in xhg + +;; Copyright (C) 2006, 2007 by all contributors + +;; Author: Stefan Reichoer, +;; 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 (xhg-revision-st) + changeset + message + creator + tag + date) + +;; xhg dvc revision list + +(defun xhg-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 "changeset: " 'dvc-header) + (dvc-face-add (xhg-revision-st-changeset struct) 'dvc-revision-name) + "\n") + (when dvc-revisions-shows-creator + (insert " " (dvc-face-add "user: " 'dvc-header) + (or (xhg-revision-st-creator struct) "?") "\n")) + (when dvc-revisions-shows-date + (insert " " (dvc-face-add "timestamp: " 'dvc-header) + (or (xhg-revision-st-date struct) "?") "\n")) + (when (xhg-revision-st-tag struct) + (insert " " (dvc-face-add "tag: " 'dvc-header) + (xhg-revision-st-tag struct) "\n")) + (when dvc-revisions-shows-summary + (insert " " (dvc-face-add "summary: " 'dvc-header) + (or (xhg-revision-st-message struct) "?") "\n")))) + +;;; xhg dvc log + +(defun xhg-dvc-log-parse (log-buffer location) + (goto-char (point-min)) + (let ((root location) + (elem (make-xhg-revision-st)) + (field) + (field-value)) + (while (> (point-max) (point)) + (beginning-of-line) + (when (looking-at "^\\([a-z][a-z ]*[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 "changeset") + (setf (xhg-revision-st-changeset elem) field-value)) + ((string= field "user") + (setf (xhg-revision-st-creator elem) field-value)) + ((string= field "tag") + (setf (xhg-revision-st-tag elem) field-value)) + ((string= field "date") + (setf (xhg-revision-st-date elem) field-value)) + ((string= field "summary") + (setf (xhg-revision-st-message elem) field-value)) + (t (dvc-trace "xhg-dvc-log-parse: unmanaged field %S" field))) + (forward-line 1)) + (when (looking-at "^$") + ;; (dvc-trace "empty line") + (with-current-buffer log-buffer + (ewoc-enter-last + dvc-revlist-cookie + `(entry-patch + ,(make-dvc-revlist-entry-patch + :dvc 'xhg + :struct elem + :rev-id `(xhg (revision (local ,root ,(xhg-revision-st-changeset elem)))))))) + (setq elem (make-xhg-revision-st)) + (forward-line 1)))) + (with-current-buffer log-buffer + (goto-char (point-min)))) + +;;;###autoload +(defun xhg-dvc-log (path last-n) + "Show a dvc formatted log for xhg." + (interactive (list default-directory nil)) + (dvc-build-revision-list 'xhg 'log (xhg-tree-root (or path default-directory)) '("log") 'xhg-dvc-log-parse + t last-n path + (dvc-capturing-lambda () + (xhg-dvc-log (capture path) (capture last-n))))) + +(defun xhg-revlog-get-revision (rev-id) + (let ((rev (car (dvc-revision-get-data rev-id)))) + (case (car rev) + (local + (dvc-run-dvc-sync 'xhg `("log" "-r" ,(nth 2 rev)) + :finished 'dvc-output-buffer-handler)) + (t (error "Not implemented (rev=%s)" rev))))) + +(defun xhg-name-construct (rev-id) + (case (car rev-id) + (local (nth 1 rev-id)) + (t (error "Not implemented (rev-id=%s)" rev-id)))) + +(provide 'xhg-revision) +;;; xhg-revision.el ends here diff --git a/dvc/lisp/xhg.el b/dvc/lisp/xhg.el new file mode 100644 index 0000000..047c2d4 --- /dev/null +++ b/dvc/lisp/xhg.el @@ -0,0 +1,1359 @@ +;;; xhg.el --- Mercurial interface for dvc + +;; Copyright (C) 2005-2009 by all contributors + +;; Author: Stefan Reichoer, + +;; 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: + +;; The mercurial interface for dvc + +;;; Commands: +;; +;; Below are complete command list: +;; +;; `xhg-init' +;; Run hg init. +;; `xhg-rollback' +;; Run hg rollback. +;; `xhg-addremove' +;; Run hg addremove. +;; `xhg-dvc-rename' +;; Run hg rename. +;; `xhg-forget' +;; Run hg forget. +;; `xhg-add-all-files' +;; Run 'hg add' to add all files to mercurial. +;; `xhg-log' +;; Run hg log. +;; `xhg-search-regexp-in-log' +;; Run hg log -k +;; `xhg-diff-1' +;; Run hg diff. +;; `xhg-dvc-diff' +;; Run hg diff. +;; `xhg-pull' +;; Run hg pull. +;; `xhg-push' +;; Run hg push. +;; `xhg-clone' +;; Run hg clone. +;; `xhg-dired-clone' +;; Run `xhg-clone' from dired. +;; `xhg-bundle' +;; Run hg bundle. +;; `xhg-unbundle' +;; Run hg unbundle. +;; `xhg-incoming' +;; Run hg incoming. +;; `xhg-outgoing' +;; Run hg outgoing. +;; `xhg-strip' +;; Run hg strip. +;; `xhg-merge' +;; Run hg merge. +;; `xhg-resolve' +;; Run hg resolve --all or . +;; `xhg-resolve-list' +;; Run hg resolve --list. +;; `xhg-command-version' +;; Run hg version. +;; `xhg-branch' +;; Run hg branch. +;; `xhg-branches' +;; run xhg-branches +;; `xhg-merge-branch' +;; Run hg merge . +;; `xhg-manifest' +;; Run hg manifest. +;; `xhg-tip' +;; Run hg tip. +;; `xhg-heads' +;; Run hg heads. +;; `xhg-parents' +;; Run hg parents. +;; `xhg-identify' +;; Run hg identify. +;; `xhg-verify' +;; Run hg verify. +;; `xhg-showconfig' +;; Run hg showconfig. +;; `xhg-paths' +;; Run hg paths. +;; `xhg-tag' +;; Run hg tag -r NAME. +;; `xhg-tags' +;; Run hg tags. +;; `xhg-view' +;; Run hg view. +;; `xhg-export' +;; Run hg export. +;; `xhg-import' +;; Run hg import. +;; `xhg-undo' +;; Run hg undo. +;; `xhg-update' +;; Run hg update. +;; `xhg-convert' +;; Convert a foreign SCM repository to a Mercurial one. +;; `xhg-serve' +;; Run hg serve --daemon. +;; `xhg-serve-kill' +;; Kill a hg serve process started with `xhg-serve'. +;; `xhg-revision-get-last-or-num-revision' +;; Run the command: +;; `xhg-ediff-file-at-rev' +;; Ediff file at rev1 against rev2. +;; `xhg-missing-1' +;; Shows the logs of the new arrived changesets after a pull and before an update. +;; `xhg-save-diff' +;; Save the current hg diff to a file named FILENAME. +;; `xhg-hgrc-edit-repository-hgrc' +;; Edit the .hg/hgrc file for the current working copy +;; `xhg-hgrc-edit-global-hgrc' +;; Edit the ~/.hgrc file +;; `hgrc-mode-help' +;; Show the manual for the hgrc configuration file. +;; +;;; Customizable Options: +;; +;; Below are customizable option list: +;; + +;;; History: + +;; + +;;; Code: + +(require 'dired-x) +(require 'dvc-core) +(require 'dvc-diff) +(require 'xhg-core) +(require 'xhg-log) +(require 'xhg-mq) +(require 'xhg-annotate) + +(defvar xhg-export-git-style-patches t "Run hg export --git.") + +;;;###autoload +(defun xhg-init (&optional dir) + "Run hg init." + (interactive + (list (expand-file-name (dvc-read-directory-name "Directory for hg init: " + (or default-directory + (getenv "HOME")))))) + (dvc-run-dvc-sync 'xhg (list "init" dir) + :finished (dvc-capturing-lambda + (output error status arguments) + (message "hg init %s finished" dir)))) + +;;;###autoload +(defun xhg-dvc-add-files (&rest files) + "Run hg add." + (dvc-trace "xhg-add-files: %s" files) + (let ((default-directory (xhg-tree-root))) + (dvc-run-dvc-sync 'xhg (append '("add") (mapcar #'file-relative-name files)) + :finished (dvc-capturing-lambda + (output error status arguments) + (message "hg add finished"))))) + +;;;###autoload +(defun xhg-dvc-revert-files (&rest files) + "Run hg revert." + (dvc-trace "xhg-revert-files: %s" files) + (let ((default-directory (xhg-tree-root))) + (dvc-run-dvc-sync 'xhg (append '("revert") (mapcar #'file-relative-name files)) + :finished (dvc-capturing-lambda + (output error status arguments) + (message "hg revert finished"))))) + +(defun xhg-dry-tip () + "Extract only the revision number of tip" + (let ((revision (with-temp-buffer + (apply #'call-process "hg" nil t nil + '("tip" "--template" "#rev#")) + (buffer-string)))) + revision)) + +;;;###autoload +(defun xhg-rollback (&optional revert) + "Run hg rollback. +if prefix-arg (C-u) run hg revert" + (interactive "P") + (let ((act-rev (xhg-dry-tip)) + (new-rev)) + (if (yes-or-no-p (format "Really rollback rev %s?" act-rev)) + (progn + (dvc-run-dvc-sync 'xhg (list "rollback") + :finished + (lambda (output error status arguments) + (setq new-rev (xhg-dry-tip)) + (message + (when (equal act-rev new-rev) + "no rollback information available")))) + (if (and current-prefix-arg + (not (equal act-rev new-rev))) + (progn + (dvc-run-dvc-sync 'xhg (list "revert" "--all") + :finished + (lambda (output error status arguments) + (message "hg revert finished, now at rev %s" new-rev)))) + (when (not (equal act-rev new-rev)) + (message + "hg rollback finished, tip is now at %s don't forget to revert" new-rev)))) + (message "hg rollback aborted")))) + +;;;###autoload +(defun xhg-dvc-remove-files (&rest files) + "Run hg remove." + (dvc-trace "xhg-remove-files: %s" files) + (let ((default-directory (xhg-tree-root))) + (dvc-run-dvc-sync 'xhg (append '("remove") (mapcar #'file-relative-name files)) + :finished (dvc-capturing-lambda + (output error status arguments) + (message "hg remove finished"))))) + +;;;###autoload +(defun xhg-addremove () + "Run hg addremove." + (interactive) + (dvc-run-dvc-sync 'xhg '("addremove") + :finished (dvc-capturing-lambda + (output error status arguments) + (message "hg addremove finished")))) + +;;;###autoload +(defun xhg-dvc-rename (from to &optional after force) + "Run hg rename." + (interactive + (let* ((from-name (dvc-confirm-read-file-name "xhg rename: ")) + (to-name (dvc-confirm-read-file-name (concat "xhg rename '" from-name "' to: ") nil "" from-name))) + (list from-name to-name nil nil))) + (dvc-run-dvc-sync 'xhg (list "rename" (dvc-uniquify-file-name from) (dvc-uniquify-file-name to) + (when after "--after") (when force "--force")) + :finished (dvc-capturing-lambda + (output error status arguments) + (message "hg rename finished")))) + +;;;###autoload +(defun xhg-forget (&rest files) + "Run hg forget." + (interactive (dvc-current-file-list)) + (let ((multiprompt (format "Forget %%d files for hg? ")) + (singleprompt (format "Forget file for hg: "))) + (when (dvc-confirm-read-file-name-list multiprompt files singleprompt t) + (dvc-run-dvc-sync 'xhg (append '("forget") files) + :finished (dvc-capturing-lambda + (output error status arguments) + (message "hg forget finished")))))) + +;;;###autoload +(defun xhg-add-all-files (arg) + "Run 'hg add' to add all files to mercurial. +Normally run 'hg add -n' to simulate the operation to see which files will be added. +Only when called with a prefix argument, add the files." + (interactive "P") + (dvc-run-dvc-sync 'xhg (list "add" (unless arg "-n")))) + +;;;###autoload +(defun xhg-log-toggle-verbose () + (interactive) + (if xhg-log-verbose + (progn + (setq xhg-log-verbose nil) + (apply #'xhg-log + xhg-log-remember-func-args)) + (setq xhg-log-verbose t) + (apply #'xhg-log + xhg-log-remember-func-args))) + +(defvar xhg-log-verbose nil) +(defvar xhg-log-remember-last-args nil) +(defvar xhg-log-remember-func-args nil) +;;;###autoload +(defun xhg-log (&optional r1 r2 show-patch file) + "Run hg 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 "hg log, R1:")) + (setq r2 (read-string "hg log, R2:")))) + (let ((buffer (dvc-get-buffer-create 'xhg 'log)) + (command-list '("log")) + (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 "-r" (concat r2 ":" r1)))) + (when (> (length r1) 0) + (let ((r1-num (string-to-number r1))) + (if (> r1-num 0) + (setq command-list (append command-list (list "-r" r1))) + (setq command-list + (append command-list + (list "-l" (number-to-string (abs r1-num))))))))) + (when show-patch + (setq command-list (append command-list (list "-p")))) + ;; be verbose or not + (setq xhg-log-remember-last-args command-list) + (setq xhg-log-remember-func-args (list r1 r2 show-patch file)) + (if (and xhg-log-remember-last-args + xhg-log-verbose) + (setq command-list (append '("-v") xhg-log-remember-last-args)) + (setq command-list xhg-log-remember-last-args)) + (dvc-switch-to-buffer-maybe buffer) + (let ((inhibit-read-only t)) + (erase-buffer)) + (xhg-log-mode) + ;;(dvc-trace "xhg-log command-list: %S, default-directory: %s" command-list cur-dir) + (let ((default-directory cur-dir)) + (dvc-run-dvc-sync 'xhg 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 "hg log for %s\n\n" default-directory)) + (toggle-read-only 1))))))))) + +;;;###autoload +(defun xhg-search-regexp-in-log () + "Run hg log -k " + (interactive) + (let* ((regex (read-string "Pattern: ")) + (args `("log" "-k" ,regex)) + (buffer (dvc-get-buffer-create 'xhg 'log))) + (dvc-switch-to-buffer-maybe buffer) + (let ((inhibit-read-only t)) + (erase-buffer)) + (xhg-log-mode) + (dvc-run-dvc-sync 'xhg args + :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 "hg log for %s\n\n" default-directory)) + (toggle-read-only 1)))))))) + +(defun xhg-parse-diff (changes-buffer) + (save-excursion + (while (re-search-forward + "^diff -r [^ ]+ \\(.*\\)$" nil t) + (let* ((name (match-string-no-properties 1)) + (added (progn (forward-line 1) + (looking-at "^--- /dev/null"))) + (removed (progn (forward-line 1) + (looking-at "^\\+\\+\\+ /dev/null")))) + (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. Nothing is a directory in hg. + nil)))))))) + +(defun xhg-parse-status (changes-buffer) + (let ((status-list (split-string (dvc-buffer-content (current-buffer)) "\n"))) + (let ((inhibit-read-only t) + (modif) + (modif-char)) + (erase-buffer) + (setq dvc-header (format "hg status for %s\n" default-directory)) + (dolist (elem status-list) + (unless (string= "" elem) + (setq modif-char (substring elem 0 1)) + (with-current-buffer changes-buffer + (ewoc-enter-last + dvc-fileinfo-ewoc + (make-dvc-fileinfo-legacy + :data (list 'file (substring elem 2) modif-char))))))))) + +(defun xhg-diff-1 (modified path dont-switch base-rev) + "Run hg diff. +If DONT-SWITCH, don't switch to the diff buffer" + (interactive (list nil nil current-prefix-arg)) + (let* ((window-conf (current-window-configuration)) + (cur-dir (or path default-directory)) + (orig-buffer (current-buffer)) + (root (xhg-tree-root cur-dir)) + (buffer (dvc-prepare-changes-buffer + `(xhg (last-revision ,root 1)) + `(xhg (local-tree ,root)) + 'diff root 'xhg)) + (command-list '("diff"))) + (dvc-switch-to-buffer-maybe buffer) + (dvc-buffer-push-previous-window-config window-conf) + (when dont-switch (pop-to-buffer orig-buffer)) + (dvc-save-some-buffers root) + (when base-rev + (setq command-list (append command-list (list "-r" base-rev))) + (when modified + (setq command-list (append command-list (list "-r" modified))))) + (dvc-run-dvc-sync 'xhg command-list + :finished + (dvc-capturing-lambda (output error status arguments) + (dvc-show-changes-buffer output 'xhg-parse-diff + (capture buffer)))))) + +;;;###autoload +(defun xhg-dvc-diff (&optional base-rev path dont-switch) + "Run hg diff. +If DONT-SWITCH, don't switch to the diff buffer" + (interactive (list nil nil current-prefix-arg)) + (xhg-diff-1 nil path dont-switch + (dvc-revision-to-string base-rev nil "tip"))) + +(defun xhg-delta (base-rev modified &optional path dont-switch) + ;; TODO: dvc-revision-to-string doesn't work for me. + (interactive (list nil nil nil current-prefix-arg)) + (xhg-diff-1 (dvc-revision-to-string modified) path dont-switch + (dvc-revision-to-string base-rev))) + +(defun xhg-dvc-status () + "Run hg status." + (let* ((window-conf (current-window-configuration)) + (root (xhg-tree-root)) + (buffer (dvc-prepare-changes-buffer + `(xhg (last-revision ,root 1)) + `(xhg (local-tree ,root)) + 'status root 'xhg))) + (dvc-switch-to-buffer-maybe buffer) + (dvc-buffer-push-previous-window-config window-conf) + (dvc-save-some-buffers root) + (dvc-run-dvc-sync 'xhg '("status") + :finished + (dvc-capturing-lambda (output error status arguments) + (with-current-buffer (capture buffer) + (xhg-status-extra-mode-setup) + (if (> (point-max) (point-min)) + (dvc-show-changes-buffer output 'xhg-parse-status + (capture buffer)) + (dvc-diff-no-changes (capture buffer) + "No changes in %s" + (capture root)))))))) + +(easy-menu-define xhg-mode-menu dvc-diff-mode-map + "`xhg' menu" + `("hg" + ,xhg-mq-submenu + ["Edit project hgrc file" xhg-hgrc-edit-repository-hgrc t] + ["Edit global ~/.hgrc file" xhg-hgrc-edit-global-hgrc t] + )) + +(defun xhg-status-extra-mode-setup () + "Do some additonal setup for xhg status buffers." + (dvc-trace "xhg-status-extra-mode-setup called.") + (easy-menu-add xhg-mode-menu) + (when (boundp 'xhg-mq-sub-mode-map) + (local-set-key [?Q] xhg-mq-sub-mode-map)) + (setq dvc-buffer-refresh-function 'xhg-dvc-status)) + +(defun xhg-pull-finish-function (output error status arguments) + (let ((buffer (dvc-get-buffer-create 'xhg '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 xhg-pull (src &optional update-after-pull) + "Run hg pull." + (interactive (list (let* ((completions (xhg-paths 'both)) + (initial-input (car (member "default" completions)))) + (dvc-completing-read + "Pull from hg repository: " + completions nil nil initial-input)))) + (dvc-run-dvc-async 'xhg (list "pull" (when update-after-pull "--update") src) + :error 'xhg-pull-finish-function + :finished 'xhg-pull-finish-function)) + +(defun xhg-push-finish-function (output error status arguments) + (let ((buffer (dvc-get-buffer-create 'xhg 'push))) + (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 xhg-push (src) + "Run hg push." + (interactive (list (let* ((completions (xhg-paths 'both)) + (initial-input (car (member "default" completions)))) + (dvc-completing-read + "Push to hg repository: " + completions nil nil initial-input)))) + (dvc-run-dvc-async 'xhg (list "push" src) + :error 'xhg-push-finish-function + :finished 'xhg-push-finish-function)) + +;;;###autoload +(defun xhg-clone (src &optional dest rev noupdate pull) + "Run hg clone." + (interactive (list (read-string "hg clone from: ") + (read-string "hg clone to: ") + (if current-prefix-arg + (read-string "hg revision: ") ;; rev + nil) + nil ;; noupdate + nil ;; pull + )) + (if rev + (dvc-run-dvc-async 'xhg (list "clone" "--rev" rev src dest)) + (dvc-run-dvc-async 'xhg (list "clone" src dest)))) + +;;;###autoload +(defun xhg-dired-clone () + "Run `xhg-clone' from dired." + (interactive) + (let* ((source (dired-filename-at-point)) + (target + (read-string (format "Clone(%s)To: " (file-name-nondirectory source)) + (file-name-directory source)))) + (xhg-clone source target))) + +;;;###autoload +(defun xhg-bundle (name) + "Run hg bundle." + (interactive "sBundleName: ") + (let ((bundle-name (if (string-match ".*\.hg$" name) + name + (concat name ".hg")))) + (dvc-run-dvc-async 'xhg (list "bundle" "--base" "null" bundle-name)))) + +;;;###autoload +(defun xhg-unbundle (fname) + "Run hg unbundle." + (interactive "fBundleName: ") + (dvc-run-dvc-async 'xhg (list "unbundle" (expand-file-name fname)) + :finished + (dvc-capturing-lambda (output error status arguments) + (if (y-or-n-p "Update now?") + (xhg-update) + (message "Don't forget to update!"))))) + +;;;###autoload +(defun xhg-incoming (&optional src show-patch no-merges) + "Run hg incoming." + (interactive (list (let* ((completions (xhg-paths 'both)) + (initial-input (car (member "default" completions)))) + (dvc-completing-read + "Show incoming from hg repository: " + completions nil nil initial-input)) + nil ;; show-patch + nil ;; no-merges + )) + (let ((window-conf (current-window-configuration)) + (buffer (dvc-get-buffer-create 'xhg 'log))) + (dvc-switch-to-buffer-maybe buffer t) + (let ((inhibit-read-only t)) + (erase-buffer)) + (xhg-log-mode) + (dvc-run-dvc-async 'xhg (list "incoming" (when show-patch "--patch") (when no-merges "--no-merges") src) + :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 "hg incoming for %s\n\n" default-directory)) + (toggle-read-only 1) + (xhg-log-next 1))))) + :error + (dvc-capturing-lambda (output error status arguments) + (with-current-buffer output + (goto-char (point-max)) + (forward-line -1) + (if (looking-at "no changes found") + (progn + (message "No changes found") + (set-window-configuration (capture window-conf))) + (dvc-default-error-function output error status arguments))))))) + +;;;###autoload +(defun xhg-outgoing (&optional src show-patch no-merges) + "Run hg outgoing." + (interactive (list (let* ((completions (xhg-paths 'both)) + (initial-input (car (member "default" completions)))) + (dvc-completing-read + "Show outgoing to hg repository: " + completions nil nil initial-input)) + nil ;; show-patch + nil ;; no-merges + )) + (let ((window-conf (current-window-configuration)) + (buffer (dvc-get-buffer-create 'xhg 'log))) + (dvc-switch-to-buffer-maybe buffer t) + (let ((inhibit-read-only t)) + (erase-buffer)) + (xhg-log-mode) + (dvc-run-dvc-async 'xhg (list "outgoing" (when show-patch "--patch") (when no-merges "--no-merges") src) + :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 "hg outgoing for %s\n\n" default-directory)) + (toggle-read-only 1))))) + :error + (dvc-capturing-lambda (output error status arguments) + (with-current-buffer output + (goto-char (point-max)) + (forward-line -1) + (if (looking-at "no changes found") + (progn + (message "No changes found") + (set-window-configuration (capture window-conf))) + (dvc-default-error-function output error status arguments))))))) + + +(defun xhg-get-all-heads-list () + "Get a list of all heads available from the output of hg heads." + (let ((rev-list (with-temp-buffer + (apply #'call-process "hg" nil t nil + '("heads" + "--template" + "#rev#\n")) + (buffer-string)))) + (setq rev-list (cons "auto" + (remove "" (split-string rev-list "\n")))) + rev-list)) + +(defun xhg-changep () + (let ((change (with-temp-buffer + (apply #'call-process "hg" nil t nil + '("diff")) + (buffer-string)))) + (setq change (remove "" (split-string change "\n"))) + (if change + t + nil))) + +;;;###autoload +(defun xhg-strip (rev) + "Run hg strip." + (interactive (list (dvc-completing-read "Remove head: " + (xhg-get-all-heads-list)))) + (dvc-run-dvc-sync 'xhg (list "strip" rev))) + +;;;###autoload +(defun xhg-merge () + "Run hg merge. +To merge from specific revision, choose it in completion with tab. +If `auto' is choose use default revision (last) unless there is ONLY +one more head. +See \(hg help merge.\)" + (interactive) + (let* ((haschange (xhg-changep)) + (collection (xhg-get-all-heads-list)) + (revision (dvc-completing-read "Merge from hg revision: " + collection nil t)) + (arg)) + (when (or (string= revision "") + (string= revision "auto")) + (setq revision nil)) + (setq arg (if revision + '("merge" "--rev") + '("merge"))) + (cond ((and (> (length collection) 3) + (not revision)) + (error "Abort: branch 'default' has more than 2 heads - please merge with an explicit rev.")) + ((equal revision (xhg-dry-tip)) + (error "Abort:can't merge with ancestor.")) + ((and (not haschange) + (> (length collection) 2)) + (dvc-run-dvc-async 'xhg `(,@arg ,revision) + :finished + (dvc-capturing-lambda (output error status arguments) + (message "hg %s %s %s finished => %s" + (nth 0 arg) + (if revision + (nth 1 arg) + "") + (if revision + revision + "") + (concat (dvc-buffer-content error) + (dvc-buffer-content output)))) + :error + ;; avoid dvc-error buffer to appear in ediff + (lambda (output error status arguments) + nil))) + (haschange + (error "abort: outstanding uncommitted merges, Please commit before merging")) + ((< (length collection) 3) + (error "There is nothing to merge here"))))) + +;;;###autoload +(defun xhg-resolve (&optional file) + "Run hg resolve --all or . +With current prefix arg, take a file as argument. +You should run xhg-merge before this. +This command will cleanly retry unresolved file merges +using file revisions preserved from the last update or merge. +If file is given resolve this file else resolve all files." + (interactive) + (let ((unresolved-files + (loop for i in (xhg-resolve-list t) + if (equal (car i) "U") + collect (cadr i)))) + (when current-prefix-arg + (setq file + (file-name-nondirectory (read-file-name "File: ")))) + (if file + (if (member file unresolved-files) + (dvc-run-dvc-sync 'xhg (list "resolve" file) + :finished + (dvc-capturing-lambda (output error status arguments) + (message "ok finished with status %s" status) + (xhg-resolve-list))) + (message "%s have been already resolved" file)) + (dvc-run-dvc-sync 'xhg (list "resolve" "--all") + :finished + (dvc-capturing-lambda (output error status arguments) + (message "ok finished with status %s" status) + (xhg-resolve-list)))))) + +;;;###autoload +(defun xhg-resolve-list (&optional quiet) + "Run hg resolve --list. +Call interactively, show buffer with info. +Non interactively, return an alist with +string keys as: +U = unresolved +R = resolved" + (interactive) + (let ((resolve-alist nil)) + (if quiet + (progn + (save-window-excursion + (dvc-run-dvc-display-as-info 'xhg (list "resolve" "--list")) + (with-current-buffer "*xhg-info*" + (setq resolve-alist + (mapcar #'split-string + (split-string (buffer-substring-no-properties + (point-min) + (point-max)) + "\n")))) + (kill-buffer "*xhg-info*") + resolve-alist)) + (dvc-run-dvc-display-as-info 'xhg (list "resolve" "--list"))))) + + +(defun xhg-command-version () + "Run hg version." + (interactive) + (let ((version (dvc-run-dvc-sync 'xhg '("version") + :finished 'dvc-output-buffer-handler))) + (when (interactive-p) + (message "Mercurial version: %s" version)) + version)) + +;;;###autoload +(defun xhg-branch (&optional new-name) + "Run hg branch. +When called with a prefix argument, ask for the new branch-name, otherwise +display the current one." + (interactive "P") + (let ((branch (dvc-run-dvc-sync 'xhg (list "branch") + :finished 'dvc-output-buffer-handler))) + (if (not new-name) + (progn + (when (interactive-p) + (message "xhg branch: %s" branch)) + branch) + (when (interactive-p) + (setq new-name (read-string (format "Change branch from '%s' to: " branch) nil nil branch))) + (dvc-run-dvc-sync 'xhg (list "branch" new-name))))) + +;;;###autoload +(defun xhg-branches (&optional only-list) + "run xhg-branches" + (interactive) + (dvc-run-dvc-display-as-info 'xhg '("branches")) + (let ((branchs-list (with-current-buffer "*xhg-info*" + (split-string (buffer-string) "\n")))) + (when only-list + (kill-buffer "*xhg-info*") + (loop for i in branchs-list + for e = (car (split-string i)) + when e + collect e)))) + +(defun xhg-branches-sans-current () + "Run xhg-branches but remove current branch." + (save-window-excursion + (let ((cur-branch (xhg-branch)) + (branches (xhg-branches t))) + (remove cur-branch branches)))) + +;;;###autoload +(defun xhg-merge-branch () + "Run hg merge . +Usually merge the change made in dev branch in default branch." + (interactive) + (let* ((current-branch (xhg-branch)) + (branch (dvc-completing-read "BranchName: " + (xhg-branches-sans-current)))) + (when (y-or-n-p (format "Really merge %s in %s" branch current-branch)) + (dvc-run-dvc-sync 'xhg (list "merge" branch) + :finished + (dvc-capturing-lambda (output error status arguments) + (message "Updated! Don't forget to commit.")))))) + +;;todo: add support to specify a rev +(defun xhg-manifest () + "Run hg manifest." + (interactive) + (let ((buffer (dvc-get-buffer-create 'xhg 'manifest))) + (dvc-run-dvc-sync 'xhg '("manifest") + :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) + (toggle-read-only 1))) + (dvc-switch-to-buffer (capture buffer))))))) + +;;;###autoload +(defun xhg-tip () + "Run hg tip." + (interactive) + (dvc-run-dvc-display-as-info 'xhg '("tip"))) + +;;;###autoload +(defun xhg-heads () + "Run hg heads." + (interactive) + (dvc-run-dvc-display-as-info 'xhg '("heads"))) + +;;;###autoload +(defun xhg-parents () + "Run hg parents." + (interactive) + (dvc-run-dvc-display-as-info 'xhg '("parents"))) + +;;;###autoload +(defun xhg-identify () + "Run hg identify." + (interactive) + (let ((id)) + (dvc-run-dvc-sync 'xhg '("identify") + :finished + (lambda (output error status arguments) + (set-buffer output) + (goto-char (point-min)) + (setq id + (buffer-substring-no-properties + (point) + (line-end-position)))) + :error + (lambda (output error status arguments) + (setq id ""))) + (when (interactive-p) + (message "hg identity for %s: %s" default-directory id)) + id)) + +;;;###autoload +(defun xhg-verify () + "Run hg verify." + (interactive) + (dvc-run-dvc-display-as-info 'xhg '("verify"))) + +;;;###autoload +(defun xhg-showconfig () + "Run hg showconfig." + (interactive) + (dvc-run-dvc-display-as-info 'xhg '("showconfig"))) + +;;;###autoload +(defun xhg-paths (&optional type) + "Run hg paths. +When called interactive, display them in an *xhg-info* buffer. +Otherwise the return value depends on TYPE: +'alias: Return only alias names +'path: Return only the paths +'both Return the aliases and the paths in a flat list +otherwise: Return a list of two element sublists containing alias, path" + (interactive) + (if (interactive-p) + (dvc-run-dvc-display-as-info 'xhg '("paths")) + (let* ((path-list (dvc-run-dvc-sync 'xhg (list "paths") + :finished 'dvc-output-buffer-split-handler)) + (lisp-path-list (mapcar '(lambda(arg) (dvc-split-string arg " = " arg)) path-list)) + (result-list)) + (cond ((eq type 'alias) + (setq result-list (mapcar 'car lisp-path-list))) + ((eq type 'path) + (setq result-list (mapcar 'cadr lisp-path-list))) + ((eq type 'both) + (setq result-list (append (mapcar 'car lisp-path-list) (mapcar 'cadr lisp-path-list)))) + (t + (setq result-list lisp-path-list)))))) + +;;;###autoload +(defun xhg-tag (rev name) + "Run hg tag -r NAME." + (interactive (list (read-from-minibuffer "Revision: " + nil nil nil nil + (xhg-dry-tip)) + (read-string "TagName: "))) + (dvc-run-dvc-sync 'xhg (list "tag" "-r" rev name) + :finished (lambda (output error status arguments) + (message "Ok revision %s tagged as %s" + rev name)))) + +;;;###autoload +(defun xhg-tags () + "Run hg tags." + (interactive) + (dvc-run-dvc-display-as-info 'xhg '("tags"))) + +;; hg annotate: add support to edit the parameters +;; -r --rev revision +;; -a --text treat all files as text +;; -u --user show user +;; -n --number show revision number +;; -c --changeset show changeset + +;; (defun xhg-annotate () +;; "Run hg annotate." +;; (interactive) +;; (dvc-run-dvc-display-as-info 'xhg (append '("annotate") (dvc-current-file-list)))) + +;;;###autoload +(defun xhg-view () + "Run hg view." + (interactive) + (dvc-run-dvc-async 'xhg '("view"))) + +;;;###autoload +(defun xhg-export (rev fname) + "Run hg export. +`xhg-export-git-style-patches' determines, if git style patches are created." + (interactive (list (xhg-read-revision "Export revision: ") + (read-file-name "Export hg revision to: "))) + (dvc-run-dvc-sync 'xhg (list "export" (when xhg-export-git-style-patches "--git") "-o" (expand-file-name fname) rev) + :finished + (lambda (output error status arguments) + (message "Exported revision %s to %s." rev fname)))) + +;;;###autoload +(defun xhg-import (patch-file-name &optional force) + "Run hg import." + (interactive (list (read-file-name "Import hg patch: " nil nil t (when (eq major-mode 'dired-mode) + (file-name-nondirectory (dired-get-filename)))))) + (dvc-run-dvc-sync 'xhg (delete nil (list "import" (when force "--force") (expand-file-name patch-file-name))) + :finished + (lambda (output error status arguments) + (message "Imported hg patch from %s." patch-file-name)))) + +;;;###autoload +(defun xhg-undo () + "Run hg undo." + (interactive) + (let ((undo-possible (file-exists-p (concat (xhg-tree-root) ".hg/undo")))) + (if undo-possible + (save-window-excursion + (xhg-log "-1" nil t) + (if (yes-or-no-p "Undo this transaction? ") + (progn + (dvc-run-dvc-sync 'xhg (list "undo") + :finished + (lambda (output error status arguments) + (message "Finished xhg undo.")))) + (message "xhg undo aborted."))) + (message "xhg: No undo information available.")))) + +;;;###autoload +(defun xhg-update (&optional clean switch) + "Run hg update. +When called with one prefix-arg run hg update -C (clean). +Called with two prefix-args run hg update -C (switch to branch)." + (interactive) + (let* ((opt-list (cond ((or clean + (equal current-prefix-arg '(4))) + (list "update" "-C")) + ((or switch + (equal current-prefix-arg '(16))) + (list "update" "-C" (dvc-completing-read "BranchName: " + (xhg-branches-sans-current)))) + (t + (list "update")))) + (opt-string (mapconcat 'identity opt-list " "))) + (dvc-run-dvc-sync 'xhg opt-list + :finished + (lambda (output error status arguments) + (dvc-default-finish-function output error status arguments) + (message "hg %s complete for %s" opt-string default-directory))))) + +(defun xhg-convert (source target) + "Convert a foreign SCM repository to a Mercurial one. + + Accepted source formats [identifiers]:(Mercurial-1.1.2) + - Mercurial [hg] + - CVS [cvs] + - Darcs [darcs] + - git [git] + - Subversion [svn] + - Monotone [mtn] + - GNU Arch [gnuarch] + - Bazaar [bzr] + +Be sure to add to your hgrc: +\[extensions\] +hgext.convert = + +Read also: hg help convert. +" + (interactive "DSource: \nsTarget: ") + (message "Started hg conversion of [%s] to [%s] ..." source target) + (dvc-run-dvc-async 'xhg (list "convert" + (expand-file-name source) + (expand-file-name target)) + :finished (dvc-capturing-lambda (output error status arguments) + (let ((default-directory (capture target))) + (xhg-update)) + (message "hg: [%s] successfully converted to [%s]" (capture source) (capture target))))) + +;; -------------------------------------------------------------------------------- +;; hg serve functionality +;; -------------------------------------------------------------------------------- + +(defvar xhg-serve-parameter-list (make-hash-table :test 'equal) + "A hash table that holds the mapping from work directory roots to +extra parameters used for hg serve. +The extra parameters are given as alist. The following example shows the supported settings: +'((port 8235) (name \"my-project\"))") + +;;;###autoload +(defun xhg-serve-register-serve-parameter-list (working-copy-root parameter-list &optional start-server) + "Register a mapping from a work directory root to a parameter list for hg serve. +When START-SERVER is given, start the server immediately. +Example usage: + (xhg-serve-register-serve-parameter-list \"~/proj/simple-counter-1/\" '((port 8100) (name \"simple-counter\")))" + (puthash (dvc-uniquify-file-name working-copy-root) parameter-list xhg-serve-parameter-list) + (when start-server + (let ((default-directory (dvc-uniquify-file-name working-copy-root))) + (xhg-serve)))) + +(defun xhg-serve () + "Run hg serve --daemon. +See `xhg-serve-register-serve-parameter-list' to register specific parameters for the server process." + (interactive) + (let* ((tree-root (dvc-tree-root)) + (server-status-dir (concat tree-root ".xhg-serve/")) + (parameter-alist (gethash (dvc-uniquify-file-name tree-root) xhg-serve-parameter-list)) + (port (or (cadr (assoc 'port parameter-alist)) 8000)) + (name (cadr (assoc 'name parameter-alist))) + (errorlog (concat server-status-dir "error.log")) + (accesslog (concat server-status-dir "access.log")) + (pid-file (concat server-status-dir "server.pid"))) + (when (numberp port) + (setq port (number-to-string port))) + (unless (file-directory-p server-status-dir) + (make-directory server-status-dir)) + (dvc-run-dvc-sync 'xhg (list "serve" "--daemon" (when port "--port") port (when name "--name") name + "--pid-file" pid-file "--accesslog" accesslog "--errorlog" errorlog) + :finished (dvc-capturing-lambda (output error status arguments) + (message "hg server started for %s, using port %s" tree-root port))))) + +(defun xhg-serve-kill () + "Kill a hg serve process started with `xhg-serve'." + (interactive) + (let* ((tree-root (dvc-tree-root)) + (server-status-dir (concat tree-root ".xhg-serve/")) + (pid-file (concat server-status-dir "server.pid")) + (pid) + (kill-status)) + (if (file-readable-p pid-file) + (with-current-buffer + (find-file-noselect pid-file) + (setq pid (buffer-substring-no-properties (point-min) (- (point-max) 1))) + (kill-buffer (current-buffer))) + (message "no hg serve pid file found - aborting")) + (when pid + (setq kill-status (call-process "kill" nil nil nil pid)) + (if (eq kill-status 0) + (progn + (delete-file pid-file) + (message "hg serve process killed.")) + (message "kill hg serve process failed, return status: %d" kill-status))))) + +;; -------------------------------------------------------------------------------- +;; dvc revision support +;; -------------------------------------------------------------------------------- +;;;###autoload +(defun xhg-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 "xhg-revision-get-last-revision file:%S last-revision:%S" file last-revision) + (let ((xhg-rev (int-to-string (nth 1 last-revision))) + (default-directory (car last-revision))) + ;; TODO: support the last-revision parameter?? + (insert (dvc-run-dvc-sync + 'xhg (list "cat" file) + :finished 'dvc-output-buffer-handler-withnewline)))) + +;;;###autoload +(defun xhg-revision-get-last-or-num-revision (infile outfile &optional revision) + "Run the command: +hg cat --rev -o outputfile inputfile" + (interactive + (let* ((xhg-infile (read-file-name "InputFile: ")) + (xhg-outfile (read-file-name "OutputFile: ")) + (xhg-rev (if current-prefix-arg + (read-string "Revision: ") + "tip"))) + (setq xhg-infile (expand-file-name xhg-infile) + xhg-outfile (concat (expand-file-name xhg-outfile) + "." + xhg-rev)) + (list xhg-infile xhg-outfile xhg-rev))) + (dvc-run-dvc-sync 'xhg (list "cat" + "--rev" + revision + "-o" + outfile + infile) + :finished 'dvc-output-buffer-handler-withnewline) + (message "%s extracted in %s at revision %s" + (file-name-nondirectory infile) + (file-relative-name outfile) + revision)) + +;;;###autoload +(defun xhg-ediff-file-at-rev (file rev1 rev2 &optional keep-variants) + "Ediff file at rev1 against rev2. +With prefix arg do not delete the files. +If rev1 or rev2 are empty, ediff current file against last revision. +Tip: to quit ediff, use C-u q to kill the ediffied buffers." + (interactive (list (read-file-name "File:" nil (dvc-get-file-info-at-point)) + (read-from-minibuffer "Rev1: " nil nil nil nil (xhg-dry-tip)) + (read-string "Rev2: "))) + (let* ((fname (expand-file-name file)) + (bfname (file-name-nondirectory file)) + (file1 (concat dvc-temp-directory "/" rev1 "-" bfname)) + (file2 (concat dvc-temp-directory "/" rev2 "-" bfname)) + (pref-arg (or keep-variants + current-prefix-arg))) + (if (or (equal "" rev1) + (equal "" rev2)) + (dvc-file-ediff fname) + (unless (equal rev1 rev2) + (xhg-revision-get-last-or-num-revision fname file1 rev1) + (xhg-revision-get-last-or-num-revision fname file2 rev2) + (ediff-files file1 file2) + (unless pref-arg + (delete-file file1) + (delete-file file2)))))) + + +;; -------------------------------------------------------------------------------- +;; higher level commands +;; -------------------------------------------------------------------------------- + +(defvar xhg-submit-patch-mapping nil) +;;(add-to-list 'xhg-submit-patch-mapping '("~/data/wiki" ("joe@host.com" "my-wiki"))) + +(defun xhg-export-via-mail (rev) + (interactive (list (xhg-read-revision "Export revision: "))) + (let ((file-name) + (destination-email "") + (base-file-name nil) + (subject) + (description)) + (dolist (m xhg-submit-patch-mapping) + (when (string= (dvc-uniquify-file-name (car m)) (dvc-uniquify-file-name (xhg-tree-root))) + ;;(message "%S" (cadr m)) + (setq destination-email (car (cadr m))) + (setq base-file-name (cadr (cadr m))))) + (setq file-name (concat (dvc-uniquify-file-name dvc-temp-directory) (or base-file-name "") rev ".patch")) + (xhg-export rev file-name) + + (setq description + (dvc-run-dvc-sync 'xhg (list "log" "-r" rev) + :finished 'dvc-output-buffer-handler)) + + (require 'reporter) + (delete-other-windows) + (reporter-submit-bug-report + destination-email + nil + nil + nil + nil + description) + (save-excursion + (re-search-backward "^summary: +\\(.+\\)") + (setq subject (match-string-no-properties 1))) + + ;; delete emacs version - its not needed here + (delete-region (point) (point-max)) + + (mml-attach-file file-name "text/x-patch") + (goto-char (point-min)) + (mail-position-on-field "Subject") + (insert (concat "[PATCH] " subject)))) + +;; hg log -r $(hg identify) +;; add one to that revision number -> actual-rev+1 +;; hg log -r actual-rev+1:tip, e.g. hg log -r 5:tip +;;;###autoload +(defun xhg-missing-1 () + "Shows the logs of the new arrived changesets after a pull and before an update." + (interactive) + (let ((id (split-string (xhg-identify))) + (last-log) + (actual-rev)) + (if (= 2 (length id)) + (message "Nothing missing, already at tip.") + (if (string= (car id) "unknown") + (setq actual-rev -1) + (setq last-log (dvc-run-dvc-sync 'xhg (list "log" "-r" (car id)) + :finished 'dvc-output-buffer-handler)) + (string-match "changeset: +\\([0-9]+\\)" last-log) + (setq actual-rev (string-to-number (match-string-no-properties 1 last-log)))) + (xhg-log (concat (number-to-string (+ actual-rev 1)) ":tip"))))) + +(defun xhg-save-diff (filename) + "Save the current hg diff to a file named FILENAME." + (interactive (list (read-file-name "Save the hg diff to: "))) + (with-current-buffer + (find-file-noselect filename) + (let ((inhibit-read-only t)) + (erase-buffer) + (insert (dvc-run-dvc-sync 'xhg (list "diff") + :finished 'dvc-output-buffer-handler-withnewline)) + (save-buffer) + (kill-buffer (current-buffer))))) + + +;; -------------------------------------------------------------------------------- +;; hgrc-mode +;; -------------------------------------------------------------------------------- + +(defun xhg-hgrc-open-hgrc-file (file-name) + (find-file file-name) + (unless (file-exists-p file-name) + (insert "# -*- hgrc -*-\n\n"))) + +(defun xhg-hgrc-edit-repository-hgrc () + "Edit the .hg/hgrc file for the current working copy" + (interactive) + (xhg-hgrc-open-hgrc-file (concat (xhg-tree-root) ".hg/hgrc"))) + +(defun xhg-hgrc-edit-global-hgrc () + "Edit the ~/.hgrc file" + (interactive) + (xhg-hgrc-open-hgrc-file "~/.hgrc")) + +;; Note: this mode is named hgrc-mode and not xhgrc-mode, because +;; a similar thing does not exist in mercurial.el yet and +;; that mode should be settable via a file local variable in .hgrc files + +(defvar hgrc-mode-map + (let ((map (make-sparse-keymap))) + map) + "Keymap used in `hgrc-mode'.") + +(easy-menu-define hgrc-mode-menu hgrc-mode-map + "`hgrc-mode' menu" + `("hgrc" + ["Show hgrc manpage" hgrc-mode-help t] + )) + +(dvc-do-in-gnu-emacs + ;; TODO : define-generic-mode doesn't exist in XEmacs. + ;; http://list-archive.xemacs.org/xemacs-beta/200408/msg00016.html + ;; world be better to use define-derived-mode below + (define-generic-mode 'hgrc-mode + '(?\; ?#) + nil + '(("^\\(\\[.*\\]\\)" 1 font-lock-constant-face) + ("^\\s-*\\(.+\\)=\\([^\r\n]*\\)" + (1 font-lock-variable-name-face) + (2 font-lock-type-face))) + '("\\.?hgrc\\'") + '(hgrc-mode-setup-function) + "Mode to edit mercurial configuration files.") + ) + +(dvc-do-in-xemacs + (define-derived-mode hgrc-mode fundamental-mode + "Hgrc-mode" + "Major mode to edit hgrc files" + ;; Empty mode for XEmacs users :-( + )) + +(defun hgrc-mode-setup-function () + (use-local-map hgrc-mode-map)) + +(defun hgrc-mode-help () + "Show the manual for the hgrc configuration file." + (interactive) + (split-window) + (other-window 1) + (apply (if (featurep 'xemacs) 'manual-entry 'woman) '("hgrc")) + (other-window -1)) + +(provide 'xhg) +;;; xhg.el ends here diff --git a/dvc/lisp/xmtn-automate.el b/dvc/lisp/xmtn-automate.el new file mode 100644 index 0000000..671ed40 --- /dev/null +++ b/dvc/lisp/xmtn-automate.el @@ -0,0 +1,994 @@ +;;; xmtn-automate.el --- Interface to monotone's "automate" functionality + +;; Copyright (C) 2008, 2009 Stephen Leake +;; Copyright (C) 2006, 2007 Christian M. Ohler + +;; Author: Christian M. Ohler +;; 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 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: + +;; This library provides access to monotone's "automate" interface +;; from Emacs Lisp. +;; +;; I found monotone's automate stdio mode (see +;; http://www.venge.net/monotone/docs/Automation.html for details) +;; rather intriguing, so I tried to make full use of it. I don't know +;; whether it is really significantly more efficient than spawning a +;; new subprocess for each command. But, in theory, feeding multiple +;; commands to one process allows that process to do all kinds of +;; smart caching, so it could make very large differences, even +;; differences in orders of magnitude. I don't know whether monotone +;; currently does any caching, but at least this means we have an +;; excuse for not doing any caching in Emacs. (If it becomes clear +;; that caching would be a good idea, it can be implemented in +;; monotone instead of Emacs; this way, other front-ends to monotone +;; can also benefit from it.) +;; +;; To allow xmtn-automate to track how long an automate stdio process +;; needs to be kept around, we introduce the concept of a session. To +;; the programmer using this library, a session is an opaque object +;; that is needed to run automate commands. Each session is +;; associated with a monotone workspace ("root") that the commands +;; will operate on. (Using xmtn-auomate to run commands with no +;; workspace is not currently part of the design.) A session can be +;; obtained using `xmtn-automate-with-session' and has dynamic extent. +;; Note that `xmtn-automate-with-session' doesn't necessarily start a +;; fresh monotone process; xmtn-automate may reuse existing session +;; objects and processes, or launch the process only when the first +;; command is sent to the session. There is also no guarantee about +;; how long xmtn-automate will keep the process running after +;; `xmtn-automate-with-session' exits. (The function +;; `xmtn-automate-terminate-processes-in-root' can be used to tell +;; xmtn-automate to terminate all processes in a given root as soon as +;; possible, and wait until they terminate. I imagine this could be +;; necessary to free locks, but whether mtn automate stdio does any +;; locking doesn't seem to be specified in monotone's manual.) To put +;; it another way, the mapping between `xmtn-automate-with-session' +;; forms and monotone processes is not necessarily one-to-one. +;; +;; `xmtn-automate-with-session' forms can safely be nested. +;; +;; Once you have a session object, you can use +;; `xmtn-automate-with-command' forms to send commands to monotone. +;; Each such form gets you a so-called command-handle. Again, this is +;; an opaque object with dynamic extent. You can use this handle to +;; check the error code of the command and obtain its output. Your +;; Emacs Lisp code can also do other computation while the monotone +;; command runs. Allowing this kind of parallelism and incremental +;; processing of command output is the main reason for introducing +;; command handles. +;; +;; The following operations are defined on command handles. +;; +;; * xmtn-automate-command-error-code (command-handle) --> 0, 1 or 2 +;; +;; Returns the error code of the command. See monotone +;; documentation. This operation blocks until the monotone process +;; has sent the error code. +;; +;; * xmtn-automate-command-wait-until-finished (command-handle) --> +;; nil +;; +;; Blocks until the command has finished (successfully or not). +;; After this operation returns, `xmtn-automate-command-finished-p' +;; will return true for this command. +;; +;; * xmtn-automate-command-buffer (command-handle) --> buffer +;; +;; Returns the so-called command buffer associated with the command +;; handle. This is a buffer with the output that the command has +;; generated so far. The buffer contents will be updated as new +;; output arrives. The buffer has the same extent as the command +;; handle. This operation does not block. +;; +;; * xmtn-automate-command-write-marker-position (command-handle) +;; --> position +;; +;; The position in the output buffer after the last character of +;; output the command has generated so far. This is also where new +;; output will be inserted. This operation does not block. +;; +;; * xmtn-automate-command-finished-p (command-handle) --> boolean +;; +;; Returns nil if the command is still running, non-nil if it has +;; finished (successfully or not). If this function returns non-nil, +;; the full output of the command is available in the command buffer. +;; This operation does not block. +;; +;; * xmtn-automate-command-accept-output (command-handle) --> +;; output-received-p +;; +;; Allows Emacs to process more output from the command (and +;; possibly from other processes). Blocks until more output has +;; been received from the command or the command has finished. +;; Returns non-nil if more output has been received. +;; +;; The intention behind this protocol is to allow Emacs Lisp code to +;; process command output incrementally as it arrives instead of +;; waiting until it is complete. However, for xmtn-basic-io, the +;; bookkeeping overhead for this kind of pipelining was excessive -- +;; byte-compiled Emacs Lisp is rather slow. But I didn't try very +;; hard to tune it, either. So I'm not sure whether incremental +;; processing is useful. +;; +;; In the output buffer, the "chunking" (the :::: thing) that monotone automate stdio does +;; has already been decoded and removed. However, no other processing or +;; parsing has been done. The output buffer contains raw 8-bit data. +;; +;; Different automate commands generate data in different formats: For +;; example, get_manifest generates basic_io; select generates a list +;; of lines with one ID each, graph generates a list of lines with one +;; or more IDs each; inventory and the packet_* commands generate +;; different custom line-based formats; and get_file generates binary +;; output. Parsing these formats is not part of xmtn-automate. +;; +;; You shouldn't manually kill the output buffer; xmtn-automate will take +;; care of it when the `xmtn-automate-with-command' form exits. +;; +;; Example: +;; +;; (xmtn-automate-with-session (session "/path/to/workspace") +;; ;; The variable `session' now holds a session object associated +;; ;; with the workspace. +;; (xmtn-automate-with-command (handle session '("get_base_revision_id")) +;; ;; The variable `handle' now holds a command handle. +;; ;; Check that the command was successful (not described above); +;; ;; generate a default error message otherwise and abort. +;; (xmtn-automate-command-check-for-and-report-error handle) +;; ;; Wait until the entire output of the command has arrived. +;; (xmtn-automate-command-wait-until-finished handle) +;; ;; Process output (in command buffer). +;; (message "Base revision id is %s" +;; (with-current-buffer (xmtn-automate-command-buffer handle) +;; (buffer-substring (point-min) +;; ;; Ignore final newline. +;; (1- (point-max))))))) +;; +;; There are some utility functions built on top of this general +;; interface that help express common uses more concisely; for +;; example, +;; +;; (message "Base revision id is %s" +;; (xmtn-automate-simple-command-output-line +;; "/path/to/workspace" '("get_base_revision_id"))) +;; +;; does the same thing as the above code. +;; +;; If multiple "simple" automate commands are run in succession on the +;; same workspace, it's a good idea to wrap an +;; `xmtn-automate-with-session' form around them so xmtn knows that it +;; should reuse the same process. +;; +;; (xmtn-automate-with-session (nil "/path/to/workspace") +;; (message "Base revision id is %s, current revision is %s" +;; (xmtn-automate-simple-command-output-line +;; "/path/to/workspace" '("get_base_revision_id")) +;; (xmtn-automate-simple-command-output-line +;; "/path/to/workspace" '("get_current_revision_id"))) +;; +;; Here, the session object is not explicitly passed to the functions +;; that actually feed commands to monotone. But, since the containing +;; session is still open after the first command, xmtn knows that it +;; should keep the process alive, and it is smart enough to reuse the +;; process for the second command. +;; +;; The fact that `xmtn-automate-with-command' always forces commands +;; to either happen in sequence or properly nested can be a +;; limitation. For example, it's not possible to write a +;; (non-recursive) loop that runs N automate commands and processes +;; their output, always launching the (k+1)th automate command ahead +;; of time to run in parallel with the kth iteration. (Some of the +;; revlist and cert-parsing code really wants to do this, I think.) +;; (But maybe writing this recursively wouldn't be all that bad... It +;; is asymptotically less (stack-!)space-efficient but makes it +;; impossible to get the cleanup wrong.) Providing the two halves of +;; `xmtn-automate-with-command' as two functions +;; `xmtn-automate-open-command' and `xmtn-automate-close-command' that +;; always need to be called in pairs would be more flexible. (Common +;; Lisp also has with-open-file but also open and close.) + +;;; Code: + +;;; There are some notes on the design of xmtn in +;;; docs/xmtn-readme.txt. + +(eval-and-compile + (require 'cl) + (require 'parse-time) ;for parse-integer + (require 'xmtn-base) + (require 'xmtn-run) + (require 'xmtn-compat)) + +(defun xmtn-automate-command-error-code (command) + (let ((process (xmtn-automate--session-process + (xmtn-automate--command-handle-session command)))) + (while (null (xmtn-automate--command-handle-error-code command)) + (xmtn--assert-for-effect + (accept-process-output process)))) + (xmtn-automate--command-handle-error-code command)) + +(defun xmtn-automate-command-buffer (command) + (xmtn-automate--command-handle-buffer command)) + +(defun xmtn-automate-command-write-marker-position (command) + (marker-position (xmtn-automate--command-handle-write-marker command))) + +(defun xmtn-automate-command-accept-output (command) + (let ((previous-write-marker-position + (marker-position (xmtn-automate--command-handle-write-marker + command)))) + (while (and (= (marker-position (xmtn-automate--command-handle-write-marker + command)) + previous-write-marker-position) + (not (xmtn-automate--command-handle-finished-p command))) + (xmtn--assert-for-effect + (accept-process-output + (xmtn-automate--session-process + (xmtn-automate--command-handle-session command))))) + (> (marker-position (xmtn-automate--command-handle-write-marker + command)) + previous-write-marker-position))) + +(defun xmtn-automate-command-finished-p (command) + (xmtn-automate--command-handle-finished-p command)) + +(defun xmtn-automate-command-wait-until-finished (handle) + (while (not (xmtn-automate-command-finished-p handle)) + (xmtn--assert-for-effect (or (xmtn-automate-command-accept-output handle) + (xmtn-automate-command-finished-p handle)))) + nil) + +(defvar xmtn-automate--*sessions* '()) + +(defmacro* xmtn-automate-with-session ((session-var-or-null root-form &key) + &body body) + "Call BODY, after ensuring an automate session for ROOT-FORM is active." + (declare (indent 1) (debug (sexp body))) + ;; I would prefer to factor out a function + ;; `xmtn-automate--call-with-session' here, but that would make + ;; profiler output unreadable, since every function would only + ;; appear to call `xmtn-automate--call-with-session', and that + ;; function would appear to do all computation. + ;; + ;; mtn automate stdio requires a valid database, so we require a + ;; root directory here. + (let ((session (gensym)) + (session-var (or session-var-or-null (gensym))) + (root (gensym)) + (key (gensym)) + (thunk (gensym))) + `(let* ((,root (file-name-as-directory ,root-form)) + (,key (file-truename ,root)) + (,session (cdr (assoc ,key xmtn-automate--*sessions*))) + (,thunk (lambda () + (let ((,session-var ,session)) + ,@body)))) + (if ,session + (funcall ,thunk) + (unwind-protect + (progn + (setq ,session (xmtn-automate--make-session ,root ,key)) + (let ((xmtn-automate--*sessions* + (acons ,key ,session xmtn-automate--*sessions*))) + (funcall ,thunk))) + (when ,session (xmtn-automate--close-session ,session))))))) + +(defmacro* xmtn-automate-with-command ((handle-var session-form command-form + &key ((:may-kill-p + may-kill-p-form))) + &body body) + "Send COMMAND_FORM (a list of strings, or cons of lists of +strings) to session SESSION_FORM (current if nil). If car +COMMAND_FORM is a list, car COMMAND_FORM is options, cdr is command. +Then execute BODY." + (declare (indent 1) (debug (sexp body))) + (let ((session (gensym)) + (command (gensym)) + (may-kill-p (gensym)) + (handle (gensym))) + `(let ((,session ,session-form) + (,command ,command-form) + (,may-kill-p ,may-kill-p-form) + (,handle nil)) + (unwind-protect + (progn + (setq ,handle (xmtn-automate--new-command ,session + ,command + ,may-kill-p)) + (xmtn--assert-optional (xmtn-automate--command-handle-p ,handle)) + (let ((,handle-var ,handle)) + ,@body)) + (when ,handle + (xmtn-automate--cleanup-command ,handle)))))) + +(defun xmtn-automate--command-output-as-string-ignoring-exit-code (handle) + (xmtn-automate-command-wait-until-finished handle) + (with-current-buffer (xmtn-automate-command-buffer handle) + (buffer-substring-no-properties (point-min) (point-max)))) + +(defun xmtn-automate-command-check-for-and-report-error (handle) + (unless (eql (xmtn-automate-command-error-code handle) 0) + (error "mtn automate command (arguments %S) reported an error (code %s):\n%s" + (xmtn-automate--command-handle-arguments handle) + (xmtn-automate-command-error-code handle) + (xmtn-automate--command-output-as-string-ignoring-exit-code handle))) + nil) + +(defun xmtn-automate-simple-command-output-string (root command) + "Send COMMAND (a list of strings, or cons of lists of strings) +to current session. If car COMMAND is a list, car COMMAND is +options, cdr is command. Return result as a string." + (xmtn-automate-with-session (session root) + (xmtn-automate-with-command (handle session command) + (xmtn-automate-command-check-for-and-report-error handle) + (xmtn-automate--command-output-as-string-ignoring-exit-code handle)))) + +(defun xmtn-automate-simple-command-output-insert-into-buffer + (root buffer command) + "Send COMMAND (a list of strings, or cons of lists of strings) +to current session. If car COMMAND is a list, car COMMAND is +options, cdr is command. Insert result into BUFFER." + (xmtn-automate-with-session (session root) + (xmtn-automate-with-command (handle session command) + (xmtn-automate-command-check-for-and-report-error handle) + (xmtn-automate-command-wait-until-finished handle) + (with-current-buffer buffer + (xmtn--insert-buffer-substring-no-properties + (xmtn-automate-command-buffer handle)))))) + +(defun xmtn-automate-command-output-lines (handle) + ;; Return list of lines of output; first line output is first in + ;; list. + (xmtn-automate-command-check-for-and-report-error handle) + (xmtn-automate-command-wait-until-finished handle) + (save-excursion + (set-buffer (xmtn-automate-command-buffer handle)) + (goto-char (point-min)) + (let (result) + (while (< (point) (point-max)) + (setq result (cons (buffer-substring-no-properties + (point) + (progn (end-of-line) (point))) + result)) + (forward-line 1)) + (nreverse result)))) + +(defun xmtn-automate-simple-command-output-lines (root command) + "Return list of strings containing output of COMMAND, one line per string." + (xmtn-automate-with-session (session root) + (xmtn-automate-with-command (handle session command) + (xmtn-automate-command-output-lines handle)))) + +;; This one is used twice. I think the error checking it provides is +;; a reasonable simplification for its callers. +(defun xmtn-automate-simple-command-output-line (root command) + "Return the one line output from mtn automate as a string. + +Signals an error if output contains zero lines or more than one line." + (let ((lines (xmtn-automate-simple-command-output-lines root command))) + (unless (eql (length lines) 1) + (error "Expected precisely one line of output from mtn automate, got %s: %s %S" + (length lines) + xmtn-executable + command)) + (first lines))) + + +(defun xmtn-automate--set-process-session (process session) + (xmtn--assert-optional (typep session 'xmtn-automate--session) t) + (xmtn--process-put process 'xmtn-automate--session session)) + +(defun xmtn-automate--process-session (process) + (xmtn--assert-optional (processp process) t) + (let ((session (xmtn--process-get process 'xmtn-automate--session))) + ;; This seems to fail sometimes with session being nil. Not sure + ;; why. The problem seems to be reproducible by calling + ;; (dvc-dvc-revision-nth-ancestor `(xmtn (local-tree ,(dvc-tree-root))) 10). + (xmtn--assert-optional (typep session 'xmtn-automate--session) t) + session)) + +(defstruct (xmtn-automate--decoder-state + (:constructor xmtn-automate--%make-raw-decoder-state)) + (read-marker) + (remaining-chars 0) + (last-p nil)) + +(defstruct (xmtn-automate--session + (:constructor xmtn-automate--%make-raw-session) + (:copier xmtn-automate--copy-session)) + (root) + (name) + (buffer nil) + (process nil) + (decoder-state) + (next-mtn-command-number) + (next-session-command-number 0) + (must-not-kill-counter) + (remaining-command-handles) + (sent-kill-p) + (closed-p nil)) + +(defstruct (xmtn-automate--command-handle + (:constructor xmtn-automate--%make-raw-command-handle)) + (arguments) + (mtn-command-number) + (session-command-number) + (session) + (buffer) + (write-marker) + (may-kill-p) + (finished-p nil) + (error-code nil)) + +(defun* xmtn-automate--initialize-session (session &key root name) + (xmtn--assert-optional (equal root (file-name-as-directory root)) t) + (setf (xmtn-automate--session-root session) root + (xmtn-automate--session-name session) name + (xmtn-automate--session-process session) nil + (xmtn-automate--session-closed-p session) nil) + nil) + +(defun xmtn-automate--make-session (root key) + (let* ((name (format "xmtn automate session for %s" key))) + (let ((session (xmtn-automate--%make-raw-session))) + (xmtn-automate--initialize-session session :root root :name name) + session))) + +(defun xmtn-automate--session-send-process-kill (session) + (let ((process (xmtn-automate--session-process session))) + ;; Stop parser. + (setf (xmtn-automate--session-sent-kill-p session) t) + (with-current-buffer (xmtn-automate--session-buffer session) + (let ((inhibit-read-only t) + deactivate-mark) + (save-excursion + (goto-char (process-mark process)) + (insert "\n(killing process)\n") + (set-marker (process-mark process) (point))))) + ;; Maybe this should really be a sigpipe. But let's not get too + ;; fancy (ha!) and non-portable. + ;;(signal-process (xmtn-automate--session-process session) 'PIPE) + ;; This call to `sit-for' is apparently needed in some situations to + ;; make sure the process really gets killed. + (sit-for 0) + (interrupt-process process)) + nil) + +(defun xmtn-automate--close-session (session) + (setf (xmtn-automate--session-closed-p session) t) + (let ((process (xmtn-automate--session-process session))) + (cond + ((null process) + ;; Process died for some reason - most likely 'mtn not found in + ;; path'. Don't warn if buffer hasn't been deleted; that + ;; obscures the real error message + ;; FIXME: if that is the reason, this assert fails. Disable assertions for now, fix later + (xmtn--assert-optional (null (xmtn-automate--session-buffer session)))) + ((ecase (process-status process) + (run nil) + (exit t) + (signal t)) + (unless xmtn-automate--*preserve-buffers-for-debugging* + (kill-buffer (xmtn-automate--session-buffer session)))) + (t + (process-send-eof process) + (if (zerop (xmtn-automate--session-must-not-kill-counter session)) + (xmtn-automate--session-send-process-kill session) + ;; We can't kill the buffer yet. We need to dump mtn's output + ;; in there so we can parse it and determine when the critical + ;; commands are finished so we can then kill mtn. + (dvc-trace + "Not killing process %s yet: %s out of %s remaining commands are critical" + (process-name process) + (xmtn-automate--session-must-not-kill-counter session) + (length (xmtn-automate--session-remaining-command-handles session)))) + (with-current-buffer (xmtn-automate--session-buffer session) + ;; This isn't essential but helps debugging. + (rename-buffer (format "*%s: killed session*" + (xmtn-automate--session-name session)) + t)) + (let ((fake-session (xmtn-automate--copy-session session))) + (xmtn-automate--set-process-session process fake-session))))) + nil) + +(defun xmtn-automate--start-process (session) + (xmtn--check-cached-command-version) + (xmtn--assert-optional (not (xmtn-automate--session-closed-p session))) + (xmtn--assert-optional (typep session 'xmtn-automate--session)) + (let ((name (xmtn-automate--session-name session)) + (buffer (xmtn-automate--new-buffer session)) + (root (xmtn-automate--session-root session))) + (let ((process-connection-type nil) + (default-directory root)) + (let ((process + (xmtn--with-environment-for-subprocess () + (apply #'start-process name buffer xmtn-executable + "automate" "stdio" xmtn-additional-arguments)))) + (xmtn-automate--set-process-session process session) + (set-process-filter process 'xmtn-automate--process-filter) + (set-process-sentinel process 'xmtn-automate--process-sentinel) + (xmtn--set-process-query-on-exit-flag process nil) + ;; Need binary (or no-conversion or maybe raw-text-unix?) + ;; since this is the format in which mtn automate stdio + ;; computes the size of the output. + (set-process-coding-system process 'binary 'binary) + (setf (xmtn-automate--session-process session) process) + (setf (xmtn-automate--session-decoder-state session) + (xmtn-automate--%make-raw-decoder-state + :read-marker (with-current-buffer buffer + (xmtn--assert-optional (eql (point-min) (point)) t) + (set-marker (make-marker) + (point-min))))) + (setf (xmtn-automate--session-next-mtn-command-number session) 0) + (setf (xmtn-automate--session-must-not-kill-counter session) 0) + (setf (xmtn-automate--session-remaining-command-handles session) (list)) + (setf (xmtn-automate--session-sent-kill-p session) nil) + process)))) + +(defun xmtn-automate--ensure-process (session) + (let ((process (xmtn-automate--session-process session))) + (when (or (null process) + (ecase (process-status process) + (run nil) + (exit t) + (signal t))) + (setq process (xmtn-automate--start-process session)) + (setf (xmtn-automate--session-process session) process)) + (xmtn--assert-optional (buffer-live-p (xmtn-automate--session-buffer + session))) + process)) + +(defun xmtn-automate--new-buffer (session) + (let* ((buffer-base-name (format "*%s: session*" + (xmtn-automate--session-name session))) + (buffer (generate-new-buffer buffer-base-name))) + (with-current-buffer buffer + (buffer-disable-undo) + (xmtn--set-buffer-multibyte nil) + (setq buffer-read-only t)) + (setf (xmtn-automate--session-buffer session) buffer) + buffer)) + +(defun xmtn-automate-terminate-processes-in-root (root) + (xmtn-automate-with-session (session root) + (xmtn-automate--close-session session) + (let ((process (xmtn-automate--session-process session))) + (when process + (while (ecase (process-status process) + (run t) + (exit nil) + (signal nil)) + (accept-process-output process)) + ;;(dvc-trace "Process in root %s terminated" root) + )) + (xmtn-automate--initialize-session + session + :root (xmtn-automate--session-root session) + :name (xmtn-automate--session-name session)))) + +(defun xmtn-automate--append-encoded-strings (strings) + "Encode STRINGS (a list of strings or nil) in automate stdio format, +insert into current buffer. Assumes that point is at the end of +the buffer." + (xmtn--assert-optional (eql (point) (point-max))) + (dolist (string strings) + (if string + (progn + (save-excursion (insert string)) + (encode-coding-region (point) (point-max) 'xmtn--monotone-normal-form) + (insert (number-to-string (- (point-max) (point))) ":") + (goto-char (point-max))))) + nil) + +(defun xmtn-automate--send-command-string (session command option-plist + mtn-number session-number) + "Send COMMAND and OPTION-PLIST to SESSION." + (let* ((buffer-name (format "*%s: input for command %s(%s)*" + (xmtn-automate--session-name session) + mtn-number + session-number)) + (buffer nil)) + (unwind-protect + (progn + (when (get-buffer buffer-name) + ;; Make sure the buffer is in a clean state. + (with-current-buffer buffer-name + (let ((inhibit-read-only t)) + (erase-buffer)) + (fundamental-mode))) + (setq buffer (get-buffer-create buffer-name)) + (with-current-buffer buffer + (buffer-disable-undo) + (xmtn--set-buffer-multibyte t) + (setq buffer-read-only t) + (let ((inhibit-read-only t)) + (when option-plist + (insert "o") + (xmtn-automate--append-encoded-strings option-plist) + (insert "e")) + (insert "l") + (xmtn-automate--append-encoded-strings command) + (insert "e\n")) + + (dvc-trace "mtn automate: '%s'" (buffer-substring (point-min) (point-max))) + + (process-send-region (xmtn-automate--session-process session) + (point-min) (point-max)))) + (when buffer + (unless xmtn-automate--*preserve-buffers-for-debugging* + (kill-buffer buffer)))))) + +(defun xmtn-automate--new-command (session command may-kill-p) + "Send COMMAND (a list of strings, or cons of lists of strings) +to the current automate stdio session. If car COMMAND is a list, +car COMMAND is options, cdr is command." + ;; For debugging. + ;;(xmtn-automate-terminate-processes-in-root + ;; (xmtn-automate--session-root session)) + (xmtn-automate--ensure-process session) + (let* ((mtn-number (1- (incf (xmtn-automate--session-next-mtn-command-number + session)))) + (session-number + (1- (incf (xmtn-automate--session-next-session-command-number + session)))) + (buffer-name (format "*%s: output for command %s(%s)*" + (xmtn-automate--session-name session) + mtn-number + session-number)) + (buffer + (progn (when (get-buffer buffer-name) + ;; Make sure no local variables or mode changes + ;; remain from the previous command parser. + (with-current-buffer buffer-name + (let ((inhibit-read-only t)) + (erase-buffer)) + (fundamental-mode))) + (get-buffer-create buffer-name)))) + (if (not (listp (car command))) + (xmtn-automate--send-command-string session command '() + mtn-number session-number) + (xmtn-automate--send-command-string session (cdr command) (car command) + mtn-number session-number)) + (with-current-buffer buffer + (buffer-disable-undo) + (xmtn--set-buffer-multibyte nil) + (setq buffer-read-only t) + (xmtn--assert-optional (and (eql (point) (point-min)) + (eql (point) (point-max)))) + (let ((handle (xmtn-automate--%make-raw-command-handle + :session session + :arguments command + :mtn-command-number mtn-number + :session-command-number session-number + :may-kill-p may-kill-p + :buffer buffer + :write-marker (set-marker (make-marker) (point))))) + (setf + (xmtn-automate--session-remaining-command-handles session) + (nconc (xmtn-automate--session-remaining-command-handles session) + (list handle))) + (when (not may-kill-p) + (incf (xmtn-automate--session-must-not-kill-counter session)) + (xmtn--set-process-query-on-exit-flag + (xmtn-automate--session-process session) + t)) + handle)))) + +(defun xmtn-automate--cleanup-command (handle) + (unless xmtn-automate--*preserve-buffers-for-debugging* + (kill-buffer (xmtn-automate--command-handle-buffer handle)))) + +(defsubst xmtn-automate--process-new-output--copy (session) + (let* ((session-buffer (xmtn-automate--session-buffer session)) + (state (xmtn-automate--session-decoder-state session)) + (read-marker (xmtn-automate--decoder-state-read-marker state)) + (command (first (xmtn-automate--session-remaining-command-handles + session))) + (command-output-buffer + (xmtn-automate--command-handle-buffer command)) + (write-marker + (xmtn-automate--command-handle-write-marker command))) + (xmtn--assert-optional (not (xmtn-automate--session-sent-kill-p session))) + (with-current-buffer session-buffer + (let* ((end (min (+ read-marker + (xmtn-automate--decoder-state-remaining-chars state)) + (point-max))) + (chars-to-read (- end read-marker))) + (cond + ((= chars-to-read 0) + nil) + ((> chars-to-read 0) + (if (not (buffer-live-p command-output-buffer)) + ;; Buffer has already been killed, just discard input. + (progn) + (with-current-buffer command-output-buffer + (save-excursion + (goto-char write-marker) + (let ((inhibit-read-only t) + deactivate-mark) + (xmtn--insert-buffer-substring-no-properties session-buffer + read-marker + end)) + (set-marker write-marker (point)))) + ;;(xmtn--debug-mark-text-processed session-buffer read-marker end nil) + ) + (set-marker read-marker end) + (decf (xmtn-automate--decoder-state-remaining-chars state) + chars-to-read) + t) + (t (xmtn--assert-nil)))))) + ;; Return value matters! + ) + +(defun xmtn--debug-mark-text-processed (buffer start end bold-p) + (xmtn--assert-optional (< start end) t) + (with-current-buffer buffer + (let ((inhibit-read-only t)) + (if bold-p + (xmtn--assert-for-effect + (add-text-properties start end + '(face + (:strike-through + t + :weight semi-bold)))) + (xmtn--assert-for-effect + (add-text-properties start end '(face (:strike-through + t)))))))) + +(defsubst xmtn-automate--process-new-output (session new-string) + (let* ((session-buffer (xmtn-automate--session-buffer session)) + (state (xmtn-automate--session-decoder-state session)) + (read-marker (xmtn-automate--decoder-state-read-marker state)) + (write-marker (process-mark (xmtn-automate--session-process session))) + (tag 'check-for-more)) + (with-current-buffer session-buffer + ;; Why oh why doesn't (require 'cl) provide tagbody... + (loop + for command = (first (xmtn-automate--session-remaining-command-handles + session)) + do + (xmtn--assert-optional (or (eql tag 'exit-loop) + (not (xmtn-automate--session-sent-kill-p + session)))) + (ecase tag + (check-for-more + (xmtn--assert-optional (<= read-marker write-marker) t) + (if (= read-marker write-marker) + (setq tag 'exit-loop) + (setq tag 'again))) + (again + (cond + ((> (xmtn-automate--decoder-state-remaining-chars state) 0) + (if (xmtn-automate--process-new-output--copy session) + (setq tag 'again) + (setq tag 'check-for-more))) + ((and (= (xmtn-automate--decoder-state-remaining-chars state) 0) + (xmtn-automate--decoder-state-last-p state)) + (xmtn--assert-optional command) + (setf (xmtn-automate--command-handle-finished-p command) t) + (xmtn--with-no-warnings + (pop (xmtn-automate--session-remaining-command-handles session))) + (setq tag 'check-for-more) + (when (not (xmtn-automate--command-handle-may-kill-p command)) + (when (zerop (decf (xmtn-automate--session-must-not-kill-counter + session))) + (xmtn--set-process-query-on-exit-flag + (xmtn-automate--session-process session) + nil) + (when (xmtn-automate--session-closed-p session) + (xmtn-automate--session-send-process-kill session) + (setq tag 'exit-loop)))) + (setf (xmtn-automate--decoder-state-last-p state) nil)) + ((and (= (xmtn-automate--decoder-state-remaining-chars state) 0) + (not (xmtn-automate--decoder-state-last-p state))) + (unless command + (error "Unexpected output from mtn: %s" new-string)) + (save-excursion + (goto-char read-marker) + (cond ((looking-at + "\\([0-9]+\\):\\([012]\\):\\([lm]\\):\\([0-9]+\\):") + (let ((command-number (parse-integer (match-string 1))) + (error-code (parse-integer (match-string 2))) + (last-p (cond + ((string= (match-string 3) "l") t) + ((string= (match-string 3) "m") nil) + (t (xmtn--assert-nil)))) + (size (parse-integer (match-string 4)))) + (xmtn--assert-optional (typep command-number + '(integer 0 *)) + t) + (xmtn--assert-optional (typep error-code '(member 0 1 2)) + t) + (xmtn--assert-optional (typep size '(integer 0 *)) t) + (xmtn--assert-optional + (eql + command-number + (xmtn-automate--command-handle-mtn-command-number + command))) + (setf (xmtn-automate--command-handle-error-code command) + error-code) + (setf (xmtn-automate--decoder-state-remaining-chars + state) + size) + (setf (xmtn-automate--decoder-state-last-p state) + last-p) + ;;(xmtn--debug-mark-text-processed session-buffer + ;; read-marker + ;; (match-end 0) + ;; t) + (set-marker read-marker (match-end 0))) + (setq tag 'again)) + ;; This is just a simple heuristic, there are many + ;; kinds of invalid input that it doesn't detect. + ;; FIXME: This can errorneously be triggered by + ;; warnings that mtn prints on stderr; but Emacs + ;; interleaves stdout and stderr (see (elisp) + ;; Output from Processes) with no way to + ;; distinguish between them. We'll probably have + ;; to spawn mtn inside a shell that redirects + ;; stderr to a file. But I don't think that's + ;; possible in a portable way... + ((looking-at "[^0-9]") + (error "Invalid output from mtn: %s" + (buffer-substring-no-properties (point) + (point-max)))) + (t + (xmtn--assert-optional command) + (setq tag 'exit-loop))))) + (t (xmtn--assert-nil)))) + (exit-loop (return)))))) + nil) + + +(defvar xmtn-automate--*preserve-buffers-for-debugging* nil) + +(defun xmtn-automate--process-sentinel (process event-string) + (let ((status (process-status process)) + (session (xmtn-automate--process-session process))) + (let ((buffer (xmtn-automate--session-buffer session))) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (let ((inhibit-read-only t) + deactivate-mark) + (save-excursion + ;; This seems to fail in XEmacs when running the test + ;; `file-diff'. I don't know why. + (xmtn--assert-optional (marker-position (process-mark process)) + t) + (goto-char (process-mark process)) + (insert (format "\n(process exited: %S)\n" + (if (eql (aref event-string + (1- (length event-string))) + ?\n) + (subseq event-string 0 + (1- (length event-string))) + event-string))) + (set-marker (process-mark process) (point)))))) + (flet ((reclaim-buffer () + (unless xmtn-automate--*preserve-buffers-for-debugging* + ;; Maybe it's not such a good idea to kill the buffer + ;; from here since that will run `kill-buffer-hook', + ;; and the functions in there might not be prepared to + ;; run inside a sentinel. But let's wait until someone + ;; actually encounters this problem. + (kill-buffer buffer) + ))) + (ecase status + (exit + (xmtn--assert-optional (eql (process-exit-status process) 0) t) + (reclaim-buffer)) + (signal + (if (xmtn-automate--session-sent-kill-p session) + (reclaim-buffer) + (message "Process %s died due to signal" (process-name process)) + (when (not (zerop (xmtn-automate--session-must-not-kill-counter + session))) + (xmtn--lwarn + 'xmtn ':error + "Process %s died due to signal during a critical operation" + (process-name process)))))))))) + +(defun xmtn-automate--process-filter (process input-string) + (let ((session (xmtn-automate--process-session process))) + (let ((buffer (xmtn-automate--session-buffer session))) + (xmtn--assert-optional (eql (process-buffer process) buffer)) + (xmtn--assert-optional (buffer-live-p buffer)) + (with-current-buffer buffer + (let* ((mark (process-mark process)) + (move-point-p (= (point) mark))) + (save-excursion + (goto-char mark) + (let ((inhibit-read-only t) + deactivate-mark) + (insert input-string)) + (set-marker mark (point))) + (when move-point-p (goto-char mark)))) + ;;(with-local-quit ; For debugging. + ;; Emacs receives a message "mtn: operation canceled: Interrupt" + ;; from mtn after we kill it. Ignore such "input". + (unless (xmtn-automate--session-sent-kill-p session) + (xmtn-automate--process-new-output session input-string)) + ;;) + ))) + +(defun xmtn--map-parsed-certs (xmtn--root xmtn--revision-hash-id xmtn--thunk) + (lexical-let ((root xmtn--root) + (revision-hash-id xmtn--revision-hash-id) + (thunk xmtn--thunk)) + (xmtn--with-automate-command-output-basic-io-parser + (xmtn--next-stanza root `("certs" ,revision-hash-id)) + (loop + for xmtn--stanza = (funcall xmtn--next-stanza) + while xmtn--stanza + do (xmtn-match xmtn--stanza + ((("key" (string $xmtn--key)) + ("signature" (string $xmtn--signature)) + ("name" (string $xmtn--name)) + ("value" (string $xmtn--value)) + ("trust" (string $xmtn--trust))) + (setq xmtn--signature (xmtn-match xmtn--signature + ("ok" 'ok) + ("bad" 'bad) + ("unknown" 'unknown))) + (let ((xmtn--trusted (xmtn-match xmtn--trust + ("trusted" t) + ("untrusted" nil)))) + (macrolet ((decodef (var) + `(setq ,var (decode-coding-string + ,var 'xmtn--monotone-normal-form)))) + (decodef xmtn--key) + (decodef xmtn--name) + ;; I'm not sure this is correct. The documentation + ;; mentions a cert_is_binary hook, but it doesn't + ;; exist; and even if it did, we would have no way of + ;; calling it from here. But, since cert values are + ;; always passed on the command line, and command + ;; line arguments are converted to utf-8, I suspect + ;; certs will also always be in utf-8. + (decodef xmtn--value)) + (funcall thunk + xmtn--key xmtn--signature xmtn--name xmtn--value + xmtn--trusted)))))))) + +(defun xmtn--list-parsed-certs (root revision-hash-id) + "Return a list of the contents of each cert attached to REVISION-HASH-ID. +Each element of the list is a list; key, signature, name, value, trust." + (lexical-let ((accu '())) + (xmtn--map-parsed-certs root revision-hash-id + (lambda (key signature name value trusted) + (push (list key signature name value trusted) + accu))) + (setq accu (nreverse accu)) + accu)) + +(defun xmtn--heads (root branch) + ;; apparently stdio automate doesn't default arguments properly; + ;; this fails if branch is not passed to mtn. + (xmtn-automate-simple-command-output-lines root (list "heads" + (or branch + (xmtn--tree-default-branch root))))) + +(defun xmtn--tree-default-branch (root) + (xmtn-automate-simple-command-output-line root `("get_option" "branch"))) + + +(provide 'xmtn-automate) + +;;; xmtn-automate.el ends here diff --git a/dvc/lisp/xmtn-base.el b/dvc/lisp/xmtn-base.el new file mode 100644 index 0000000..ba61a4f --- /dev/null +++ b/dvc/lisp/xmtn-base.el @@ -0,0 +1,82 @@ +;;; xmtn-base.el --- Basic definitions for accessing monotone + +;; Copyright (C) 2009 Stephen Leake +;; Copyright (C) 2006, 2007, 2009 Christian M. Ohler + +;; Author: Christian M. Ohler +;; 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 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: + +;; This file contains basic definitions for accessing the distributed +;; version control system monotone. + +;;; Code: + +;;; There are some notes on the design of xmtn and its related +;;; files in docs/xmtn-readme.txt. + +(eval-and-compile + (require 'cl)) + +(defvar xmtn-executable "mtn" + "*The monotone executable command. + +After changing the value of this variable, be sure to run +`xmtn-check-command-version' to clear xmtn's command version +cache.") + +(defvar xmtn-additional-arguments '() + "*Additional arguments to pass to monotone. + +A list of strings.") + +(defvar xmtn-confirm-operation t + "May be let-bound to nil to bypass confirmations.") + +(deftype xmtn--hash-id () + `(and string + (satisfies xmtn--hash-id-p))) + +(defun xmtn--hash-id-p (thing) + (and (stringp thing) + ;; This is twenty times faster than an equivalent Elisp loop. + (save-match-data + (string-match "\\`[0-9a-f]\\{40\\}\\'" thing)))) + +(defvar xmtn--*enable-assertions* nil + "Effective at macroexpansion time.") + +;; (setq xmtn--*enable-assertions* t) + +(defmacro xmtn--assert-for-effect (form &rest more-assert-args) + (if xmtn--*enable-assertions* + `(assert ,form ,@more-assert-args) + `(progn ,form nil))) + +(defmacro xmtn--assert-optional (form &rest more-assert-args) + (if xmtn--*enable-assertions* + `(assert ,form ,@more-assert-args) + `nil)) + +(defmacro xmtn--assert-nil () + `(assert nil)) + +(provide 'xmtn-base) + +;;; xmtn-base.el ends here diff --git a/dvc/lisp/xmtn-basic-io.el b/dvc/lisp/xmtn-basic-io.el new file mode 100644 index 0000000..61c3aac --- /dev/null +++ b/dvc/lisp/xmtn-basic-io.el @@ -0,0 +1,342 @@ +;;; xmtn-basic-io.el --- A parser for monotone's basic_io output format + +;; Copyright (C) 2008 Stephen Leake +;; Copyright (C) 2006, 2007 Christian M. Ohler + +;; Author: Christian M. Ohler +;; Maintainer: Stephen Leake stephen_leake@stephe-leake.org +;; Keywords: tools, extensions + +;; 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: + +;; This library helps parse data in monotone's basic_io format. +;; +;; See docstrings for details. + +;;; Code: + +;;; There are some notes on the design of xmtn in +;;; docs/xmtn-readme.txt. + +;;; I haven't seen a specification for monotone's basic_io format. +;;; I'm implementing this parser somewhat defensively. + +;;; Maybe strings in basic_io are always encoded as UTF-8? In that +;;; case, the decoding code for filenames and cert names/values that +;;; is currently spread across several functions could be moved +;;; directly in here. + +;;; `parse-partial-sexp'/`scan-sexps', with an appropriate syntax +;;; table, looks like the best way to do this kind of parsing. It is +;;; very likely faster than anything we can implement by hand in Emacs +;;; Lisp. + +;;; Much of the code in here has been tuned for speed quite a bit. +;;; Careful with refactorings! For example, introducing a variable +;;; binding that the byte-compiler can't optimize away can mean a +;;; major slowdown. + +;;; Using cons cells instead of two-element lists is only a very minor +;;; performance advantage (<.5%). Also, with cons cells, `null-id' +;;; would have to be a bare symbol, while `id' and `string' would be +;;; cons cells; with lists, the representation is more uniform. + +(eval-and-compile + (require 'cl) + (require 'xmtn-base) ; for xmtn--hash-id + ) + +(defvar xmtn-basic-io--*syntax-table* + (let ((table (make-syntax-table))) + (modify-syntax-entry ?_ "_" table) + (modify-syntax-entry ?\[ "(" table) + (modify-syntax-entry ?\] ")" table) + (modify-syntax-entry ?\" "\"" table) + (modify-syntax-entry ?\\ "/" table) + table)) + +(defsubst xmtn-basic-io--unescape-field (string) + (loop with start = 0 + while (string-match "\\\\" string start) + do (setq string (replace-match "" t t string)) + do (setq start (1+ (match-end 0)))) + string) + +(defsubst xmtn-basic-io--read-key () + ;; Calling `xmtn--debug-mark-text-processed' from here is way too + ;; slow. + (let ((start (point))) + (skip-syntax-forward "w_") + (xmtn--assert-optional (> (point) start)) + (xmtn--assert-optional (member (char-after (point)) '(?\ ?\n))) + (let ((key (buffer-substring-no-properties start (point)))) + (xmtn--assert-optional (string-match "\\`[a-z_]+\\'" key) t) + ;;(xmtn--debug-mark-text-processed (current-buffer) start (point) t) + key))) + +(defsubst xmtn-basic-io--read-field () + "Return a list containing the class and value of the field at point. +Possible classes are `string', `null-id', `id', `symbol'." + ;; Calling `xmtn--debug-mark-text-processed' from here is way too + ;; slow. + (let ((end (scan-sexps (point) 1))) + (xmtn--assert-optional end) + (xmtn--assert-optional (> end (point))) + (prog1 + (case (char-after (point)) + (?\" ; a string + (list 'string (xmtn-basic-io--unescape-field + (buffer-substring-no-properties (1+ (point)) + (1- end))))) + (?\[ ; an id + (cond ((eq (1+ (point)) (1- end)) ;see (elisp) Equality Predicates + (list 'null-id)) + (t + (xmtn--assert-optional + (typep (buffer-substring-no-properties (1+ (point)) + (1- end)) + 'xmtn--hash-id)) + (list 'id (buffer-substring-no-properties (1+ (point)) + (1- end)))))) + (t ; a symbol + (list 'symbol (buffer-substring-no-properties (point) end)))) + (goto-char end) + (xmtn--assert-optional (member (char-after) '(?\n ?\ )))))) + +(defsubst xmtn-basic-io--skip-white-space () + ;; Calling `xmtn--debug-mark-text-processed' from here is way too slow. + (skip-chars-forward " ")) + +(defun xmtn-basic-io-skip-blank-lines () + "Skip blank lines (if any), so parser starts on a stanza." + (beginning-of-line) + (while + (case (char-after) + ((?\n) + (forward-char 1) + t) + ((? ) + (skip-chars-forward " ") + t) + (t + nil))) + (beginning-of-line)) + +(defsubst xmtn-basic-io--parse-nonempty-line () + (xmtn-basic-io--skip-white-space) + (prog1 + (list* (xmtn-basic-io--read-key) + (loop while (progn + (xmtn-basic-io--skip-white-space) + (not (eq (char-after) ?\n))) + collect (xmtn-basic-io--read-field))) + (forward-char 1))) + +(defsubst xmtn-basic-io--peek () + (case (char-after) + ((?\n) 'empty) + ((nil) 'eof) + (t t))) + +(defun xmtn-basic-io--next-parsed-line () + (case (char-after) + ((?\n) + (forward-char 1) + 'empty) + ((nil) + 'eof) + (t + (xmtn-basic-io--parse-nonempty-line)))) + +(defun xmtn-basic-io--next-stanza () + (let ((stanza (let ((accu nil) + (line nil)) + (loop do (setq line (xmtn-basic-io--next-parsed-line)) + do (xmtn--assert-optional (not (and (null accu) + (eq line 'empty)))) + until (memq line '(empty eof)) + do + (xmtn--assert-optional (listp line)) + (xmtn--assert-optional (not (endp line))) + (push line accu)) + (nreverse accu)))) + stanza)) + +(defun xmtn-basic-io--next-parsed-line-notinline () + (xmtn-basic-io--next-parsed-line)) + +(eval-and-compile + (defun xmtn-basic-io--generate-body-for-with-parser-form (parser-fn + parser-var + buffer-form body) + (let ((buffer (gensym))) + `(let ((,buffer ,buffer-form)) + (with-current-buffer ,buffer + (set-syntax-table xmtn-basic-io--*syntax-table*) + (goto-char (point-min))) + (let ((,parser-var (lambda () + (with-current-buffer ,buffer + (,parser-fn))))) + ,@body))))) + +(defun xmtn-basic-io-eof () + "Return non-nil if at end of input, nil otherwise." + (eq 'eof (xmtn-basic-io--peek))) + +(defmacro xmtn-basic-io-parse-line (body) + "Read next basic-io line at point. Error if it is `empty' or +`eof'. Otherwise execute BODY with `symbol' bound to key (a +string), `value' bound to list containing parsed rest of line. +List is of form ((category value) ...)." + (declare (indent 1) (debug (sexp body))) + `(let ((line (xmtn-basic-io--next-parsed-line))) + (if (member line '(empty eof)) + (error "expecting a line, found %s" line) + (let ((symbol (car line)) + (value (cdr line))) + ,body)))) + +(defmacro xmtn-basic-io-optional-line (expected-key body-present) + "Read next basic-io line at point. If its key is +EXPECTED-KEY (a string), execute BODY-PRESENT with `value' bound +to list containing parsed rest of line. List is of +form ((category value) ...). Else reset to parse the same line +again." + (declare (indent 1) (debug (sexp body))) + `(let ((line (xmtn-basic-io--next-parsed-line))) + (if (and (not (member line '(empty eof))) + (string= (car line) ,expected-key)) + (let ((value (cdr line))) + ,body-present) + (beginning-of-line 0) + ))) + +(defmacro xmtn-basic-io-check-line (expected-key body) + "Read next basic-io line at point. Error if it is `empty' or +`eof', or if its key is not EXPECTED-KEY (a string). Otherwise +execute BODY with `value' bound to list containing parsed rest of +line. List is of form ((category value) ...)." + (declare (indent 1) (debug (sexp body))) + `(let ((line (xmtn-basic-io--next-parsed-line))) + (if (or (member line '(empty eof)) + (not (string= (car line) ,expected-key))) + (error "expecting \"%s\", found %s" ,expected-key line) + (let ((value (cdr line))) + ,body)))) + +(defun xmtn-basic-io-check-empty () + "Read next basic-io line at point. Error if it is not `empty' or `eof'." + (let ((line (xmtn-basic-io--next-parsed-line))) + (if (not (member line '(empty eof))) + (error "expecting an empty line, found %s" line)))) + +(defmacro* xmtn-basic-io-with-line-parser ((line-parser buffer-form) &body body) + "Run BODY with LINE-PARSER bound to a parser that parses BUFFER-FORM. + +BUFFER-FORM should evaluate to a buffer that contains, between +\(point-min\) and \(point-max\), zero or more lines in monotone's +basic_io format. + +BODY will be evaluated with LINE-PARSER \(a symbol\) bound to a +closure that will, each time it is called, return the next line +in parsed form, or the symbol `eof' if there are no more lines. + +Empty lines are returned as the symbol `empty'. + +Each non-empty line is a list of a key and zero or more fields. +The key is a string. Each field is either a one-element list +\(null-id\) and represents an empty ID field \(what monotone +prints as \[\] in basic_io format\), a two-element list \(id +HASH-ID\), where HASH-ID is a string of forty hexadecimal digits +\(what monotone prints as \[HASH-ID\]\), or a two-element list +\(string STRING\), where STRING is a string (what monotone prints +as \"STRING\"\). + +Lines and their contents are always fresh objects. + +The macro `xmtn-match' is a useful way to process basic_io lines +parsed this way. + +The parser should be assumed to have dynamic extent. If the +contents of the buffer that BUFFER-FORM evaluates to, or the +position of point in that buffer, are modified from within BODY +\(other than by calling the parser\), the parser becomes invalid +and must not be called any more." + (declare (indent 1) (debug (sexp body))) + (xmtn-basic-io--generate-body-for-with-parser-form + ;; Use a notinline variant to avoid copying the full parser into + ;; every user of this macro. The performance advantage of this + ;; would be small. + 'xmtn-basic-io--next-parsed-line-notinline + line-parser buffer-form body)) + +(defmacro* xmtn-basic-io-with-stanza-parser ((stanza-parser buffer-form) + &body body) + "Run BODY with STANZA-PARSER bound to a parser that parses BUFFER-FORM. + +BUFFER-FORM should evaluate to a buffer that contains, +between (point-min) and (point-max), zero or more lines in +monotone's basic_io format. + +BODY will be evaluated with STANZA-PARSER \(a symbol\) bound to a +closure that will, each time it is called, return the next stanza +in parsed form, or the symbol `nil' if there are no more stanzas. + +Each stanza will be returned as a fresh, non-empty list of +so-called lines. See `xmtn-basic-io-with-line-parser' for a +definition of the term \"line\" in this context. + +The macro `xmtn-match' and the function `assoc' are useful to +process basic_io stanzas parsed this way. + +The parser should be assumed to have dynamic extent. If the +contents of the buffer that BUFFER-FORM evaluates to, or the +position of point in that buffer, are modified from within BODY +\(other than by calling the parser\), the parser becomes invalid +and must not be called any more." + (declare (indent 1) (debug (sexp body))) + (xmtn-basic-io--generate-body-for-with-parser-form + 'xmtn-basic-io--next-stanza + stanza-parser buffer-form body)) + +(defun xmtn-basic-io-write-id (key id) + "Write a basic-io line with KEY, hex ID." + (insert key) + (insert " [") + (insert id) + (insert ?\]) + (insert ?\n)) + +(defun xmtn-basic-io-write-str (key str) + "Write a basic-io line with KEY, string STR." + (insert key) + (insert " \"") + (insert str) + (insert ?\") + (insert ?\n)) + +(defun xmtn-basic-io-write-sym (key sym) + "Write a basic-io line with KEY, symbol SYM." + (insert key) + (insert " ") + (insert sym) + (insert ?\n)) + +(provide 'xmtn-basic-io) + +;;; xmtn-basic-io.el ends here diff --git a/dvc/lisp/xmtn-compat.el b/dvc/lisp/xmtn-compat.el new file mode 100644 index 0000000..0cd8b71 --- /dev/null +++ b/dvc/lisp/xmtn-compat.el @@ -0,0 +1,124 @@ +;;; xmtn-compat.el --- xmtn compatibility with different Emacs versions + +;; Copyright (C) 2008 Stephen Leake +;; Copyright (C) 2006, 2007 Christian M. Ohler + +;; Author: Christian M. Ohler +;; Keywords: extensions + +;; 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: + +;; Wrappers and fallback implementations for various Emacs functions +;; needed by xmtn that don't exist in all versions of Emacs. + +;;; Code: + +;;; There are some notes on the design of xmtn in +;;; docs/xmtn-readme.txt. + +(eval-and-compile + (require 'cl)) + +(defun xmtn--temp-directory () + (if (fboundp 'temp-directory) + (temp-directory) + temporary-file-directory)) + +(defun xmtn--make-temp-file (prefix &optional dirp suffix) + ;; Do this in a temp buffer to ensure we use the default file output + ;; encoding. Emacs 21's `make-temp-file' uses the current buffer's + ;; output format function while writing the file with `write-region' + ;; with a string as its first argument, but coding conversion errors + ;; when `write-region' is called in this way. + (with-temp-buffer + ;; XEmacs' `make-temp-file' doesn't automatically use temp + ;; directory. + (setq prefix (expand-file-name prefix (xmtn--temp-directory))) + ;; FIXME: Ignoring suffix for now since Emacs 21 doesn't support it. + (make-temp-file prefix dirp))) + +(defvar xmtn--*process-plists* (make-hash-table :weakness 'key)) + +;;; These should probably use `process-get' and `process-put' if +;;; available, but that's not important. +(defun xmtn--process-put (process propname value) + (setf (getf (gethash process xmtn--*process-plists*) propname) value) + ;; Mimic the return value that `process-put' would yield. + (gethash process xmtn--*process-plists*)) + +(defsubst xmtn--process-get (process propname) + (getf (gethash process xmtn--*process-plists*) propname nil)) + +(defmacro xmtn--set-process-query-on-exit-flag (process value) + (if (fboundp 'set-process-query-on-exit-flag) + `(set-process-query-on-exit-flag ,process ,value) + `(progn + (process-kill-without-query ,process ,value) + ,value))) + +(defmacro xmtn--insert-buffer-substring-no-properties (from-buffer + &optional start end) + (if (fboundp 'insert-buffer-substring-no-properties) + `(insert-buffer-substring-no-properties ,from-buffer ,start ,end) + `(progn + (insert (with-current-buffer ,from-buffer + (buffer-substring-no-properties (or ,start (point-min)) + (or ,end (point-max))))) + nil))) + +(defun xmtn--lwarn (tag level message &rest args) + (if (fboundp 'lwarn) + (apply #'lwarn tag level message args) + (apply #'message message args)) + ;; The return value of `lwarn' seems to be pretty much undefined, so + ;; we don't try to replicate it here. + nil) + +(defmacro* xmtn--with-no-warnings (&body body) + (if (fboundp 'with-no-warnings) + `(with-no-warnings ,@body) + `(progn ,@body))) + +(defmacro* xmtn--with-temp-message (message &body body) + (declare (indent 1) (debug (form body))) + (if (fboundp 'with-temp-message) + `(with-temp-message ,message ,@body) + `(progn ,@body))) + +(defmacro* xmtn--dotimes-with-progress-reporter ((i n-form &optional res-form) + message-form + &body body) + (declare (indent 2) (debug (sexp form body))) + (if (fboundp 'dotimes-with-progress-reporter) + `(dotimes-with-progress-reporter (,i ,n-form ,res-form) + ,message-form ,@body) + (let ((message (gensym))) + `(let ((,message ,message-form)) + (prog1 + (xmtn--with-temp-message ,message + (dotimes (,i ,n-form ,res-form) + ,@body)) + (message "%sdone" ,message)))))) + +(defmacro xmtn--set-buffer-multibyte (flag) + (when (fboundp 'set-buffer-multibyte) + `(set-buffer-multibyte ,flag))) + +(provide 'xmtn-compat) + +;;; xmtn-compat.el ends here diff --git a/dvc/lisp/xmtn-conflicts.el b/dvc/lisp/xmtn-conflicts.el new file mode 100644 index 0000000..8dbcc43 --- /dev/null +++ b/dvc/lisp/xmtn-conflicts.el @@ -0,0 +1,1311 @@ +;;; xmtn-conflicts.el --- conflict resolution for DVC backend for monotone + +;; Copyright (C) 2008 - 2009 Stephen Leake + +;; Author: Stephen Leake +;; 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 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 + ;; these have macros we use + (require 'cl) + (require 'dvc-utils) + (require 'xmtn-automate) + (require 'xmtn-basic-io) + (require 'xmtn-ids) + (require 'xmtn-run)) + +(eval-when-compile + ;; these have functions we use + (require 'dired)) + +(defvar xmtn-conflicts-left-revision "" + "Buffer-local variable holding left revision id.") +(make-variable-buffer-local 'xmtn-conflicts-left-revision) + +(defvar xmtn-conflicts-right-revision "" + "Buffer-local variable holding right revision id.") +(make-variable-buffer-local 'xmtn-conflicts-right-revision) + +(defvar xmtn-conflicts-left-work "" + "Buffer-local variable holding left workspace root.") +(make-variable-buffer-local 'xmtn-conflicts-left-work) +(put 'xmtn-conflicts-left-work 'permanent-local t) + +(defvar xmtn-conflicts-right-work "" + "Buffer-local variable holding right workspace root.") +(make-variable-buffer-local 'xmtn-conflicts-right-work) +(put 'xmtn-conflicts-right-work 'permanent-local t) + +(defvar xmtn-conflicts-left-root "" + "Buffer-local variable holding left resolution root directory + name; relative to workspace root.") +(make-variable-buffer-local 'xmtn-conflicts-left-root) + +(defvar xmtn-conflicts-right-root "" + "Buffer-local variable holding right resolution root directory + name; relative to workspace root.") +(make-variable-buffer-local 'xmtn-conflicts-right-root) + +(defvar xmtn-conflicts-left-branch "" + "Buffer-local variable holding left resolution branch.") +(make-variable-buffer-local 'xmtn-conflicts-left-branch) +(put 'xmtn-conflicts-left-branch 'permanent-local t) + +(defvar xmtn-conflicts-right-branch "" + "Buffer-local variable holding right resolution branch.") +(make-variable-buffer-local 'xmtn-conflicts-right-branch) +(put 'xmtn-conflicts-right-branch 'permanent-local t) + +(defvar xmtn-conflicts-ancestor-revision "" + "Buffer-local variable holding ancestor revision id.") +(make-variable-buffer-local 'xmtn-conflicts-ancestor-revision-spec) + +(defvar xmtn-conflicts-total-count nil + "Total count of conflicts.") +(make-variable-buffer-local 'xmtn-conflicts-total-count) + +(defvar xmtn-conflicts-resolved-count nil + "Count of resolved conflicts.") +(make-variable-buffer-local 'xmtn-conflicts-resolved-count) + +(defvar xmtn-conflicts-resolved-internal-count nil + "Count of resolved-internal conflicts.") +(make-variable-buffer-local 'xmtn-conflicts-resolved-internal-count) + +(defvar xmtn-conflicts-output-buffer nil + "Buffer to write basic-io to, when saving a conflicts buffer.") +(make-variable-buffer-local 'xmtn-conflicts-output-buffer) + +(defvar xmtn-conflicts-current-conflict-buffer nil + "Global variable for use in ediff quit hook.") +;; xmtn-conflicts-current-conflict-buffer cannot be buffer local, +;; because ediff leaves the merge buffer active. + +(defvar xmtn-conflicts-ediff-quit-info nil + "Stuff used by ediff quit hook.") +(make-variable-buffer-local 'xmtn-conflicts-ediff-quit-info) + +(defstruct (xmtn-conflicts-conflict + (:copier nil)) + ;; not worth splitting this into a type hierarchy; differences are + ;; minor some fields are nil for some conflict types + ;; single file conflicts only set left_resolution + + conflict_type ;; 'content | 'duplicate_name | 'orphaned_node + ancestor_name + ancestor_file_id + left_type + left_name + left_file_id + right_type + right_name + right_file_id + left_resolution + right_resolution) + +(defun xmtn-conflicts-printer (conflict) + "Print an ewoc element; CONFLICT must be of type xmtn-conflicts-conflict." + (ecase (xmtn-conflicts-conflict-conflict_type conflict) + ('content + (insert (dvc-face-add "content\n" 'dvc-keyword)) + (insert "ancestor: ") + (insert (xmtn-conflicts-conflict-ancestor_name conflict)) + (insert "\n") + (insert "left: ") + (insert (xmtn-conflicts-conflict-left_name conflict)) + (insert "\n") + (insert "right: ") + (insert (xmtn-conflicts-conflict-right_name conflict)) + (insert "\n") + (insert "resolution: ") + (insert (format "%s" (xmtn-conflicts-conflict-left_resolution conflict))) + (insert "\n") + ) + ('duplicate_name + (insert (dvc-face-add "duplicate_name\n" 'dvc-keyword)) + (insert "left_type: ") + (insert (xmtn-conflicts-conflict-left_type conflict)) + (insert "\n") + (insert "left: ") + (insert (xmtn-conflicts-conflict-left_name conflict)) + (insert "\n") + (insert "right_type: ") + (insert (xmtn-conflicts-conflict-right_type conflict)) + (insert "\n") + (insert "right: ") + (insert (xmtn-conflicts-conflict-right_name conflict)) + (insert "\n") + (insert "left resolution: ") + (insert (format "%s" (xmtn-conflicts-conflict-left_resolution conflict))) + (insert "\n") + (insert "right resolution: ") + (insert (format "%s" (xmtn-conflicts-conflict-right_resolution conflict))) + (insert "\n") + ) + ('orphaned_node + (insert (dvc-face-add "orphaned_node\n" 'dvc-keyword)) + (insert "ancestor: ") + (insert (xmtn-conflicts-conflict-ancestor_name conflict)) + (insert "\n") + (insert "left: ") + (insert (xmtn-conflicts-conflict-left_type conflict)) + (insert " ") + (if (xmtn-conflicts-conflict-left_name conflict) (insert (xmtn-conflicts-conflict-left_name conflict))) + (insert "\n") + (insert "right: ") + (insert (xmtn-conflicts-conflict-right_type conflict)) + (insert " ") + (if (xmtn-conflicts-conflict-right_name conflict) (insert (xmtn-conflicts-conflict-right_name conflict))) + (insert "\n") + (insert "resolution: ") + (insert (format "%s" (xmtn-conflicts-conflict-left_resolution conflict))) + (insert "\n") + ) + )) + +(defvar xmtn-conflicts-ewoc nil + "Buffer-local ewoc for displaying conflicts. +All xmtn-conflicts functions operate on this ewoc. +The elements must all be of type xmtn-conflicts-conflict.") +(make-variable-buffer-local 'xmtn-conflicts-ewoc) + +(defun xmtn-conflicts-parse-header () + "Fill `xmtn-conflicts-left-revision', `xmtn-conflicts-left-root', +`xmtn-conflicts-right-revision', `xmtn-conflicts-right-root' +`xmtn-conflicts-ancestor-revision' with data from conflict +header." + ;; left [9a019f3a364416050a8ff5c05f1e44d67a79e393] + ;; right [426509b2ae07b0da1472ecfd8ecc25f261fd1a88] + ;; ancestor [dc4518d417c47985eb2cfdc2d36c7bd4c450d626] + ;; + ;; ancestor is not output if left is ancestor of right or vice-versa + (setq xmtn-conflicts-ancestor-revision nil) + (xmtn-basic-io-check-line "left" (setq xmtn-conflicts-left-revision (cadar value))) + (xmtn-basic-io-check-line "right" (setq xmtn-conflicts-right-revision (cadar value))) + (xmtn-basic-io-optional-line "ancestor" + (setq xmtn-conflicts-ancestor-revision (cadar value))) + (xmtn-basic-io-check-empty) + + ;; xmtn-conflicts-left-branch xmtn-conflicts-right-branch set by xmtn-conflicts-load-opts + + (if (string= xmtn-conflicts-left-branch xmtn-conflicts-right-branch) + (progn + (setq xmtn-conflicts-left-root "_MTN/resolutions/left") + (setq xmtn-conflicts-right-root "_MTN/resolutions/right")) + (progn + (setq xmtn-conflicts-left-root (concat "_MTN/resolutions/" xmtn-conflicts-left-branch)) + (setq xmtn-conflicts-right-root (concat "_MTN/resolutions/" xmtn-conflicts-right-branch)))) + (setq xmtn-conflicts-total-count 0) + (setq xmtn-conflicts-resolved-count 0) + (setq xmtn-conflicts-resolved-internal-count 0) + ) + +(defun xmtn-conflicts-parse-content-conflict () + "Fill an ewoc entry with data from content conflict stanza." + ;; conflict content + ;; node_type "file" + ;; ancestor_name "1553/gds-hardware-bus_1553-iru_honeywell-user_guide-symbols.tex" + ;; ancestor_file_id [d1eee768379694a59b2b015dd59a61cf67505182] + ;; left_name "1553/gds-hardware-bus_1553-iru_honeywell-user_guide-symbols.tex" + ;; left_file_id [cb3fa7b591baf703d41dc2aaa220c9e3b456c4b3] + ;; right_name "1553/gds-hardware-bus_1553-iru_honeywell-user_guide-symbols.tex" + ;; right_file_id [d1eee768379694a59b2b015dd59a61cf67505182] + ;; + ;; optional resolution: {resolved_internal | resolved_user} + (let ((conflict (make-xmtn-conflicts-conflict))) + (setf (xmtn-conflicts-conflict-conflict_type conflict) 'content) + (xmtn-basic-io-check-line "node_type" + (if (not (string= "file" (cadar value))) (error "expecting \"file\" found %s" (cadar value)))) + (xmtn-basic-io-check-line "ancestor_name" (setf (xmtn-conflicts-conflict-ancestor_name conflict) (cadar value))) + (xmtn-basic-io-check-line "ancestor_file_id" (setf (xmtn-conflicts-conflict-ancestor_file_id conflict) (cadar value))) + (xmtn-basic-io-check-line "left_name" (setf (xmtn-conflicts-conflict-left_name conflict) (cadar value))) + (xmtn-basic-io-check-line "left_file_id" (setf (xmtn-conflicts-conflict-left_file_id conflict) (cadar value))) + (xmtn-basic-io-check-line "right_name" (setf (xmtn-conflicts-conflict-right_name conflict) (cadar value))) + (xmtn-basic-io-check-line "right_file_id" (setf (xmtn-conflicts-conflict-right_file_id conflict) (cadar value))) + + ;; look for a resolution + (case (xmtn-basic-io--peek) + ((empty eof) nil) + (t + (xmtn-basic-io-parse-line + (progn + (setq xmtn-conflicts-resolved-count (+ 1 xmtn-conflicts-resolved-count)) + (cond + ((string= "resolved_internal" symbol) + (setq xmtn-conflicts-resolved-internal-count (+ 1 xmtn-conflicts-resolved-internal-count)) + (setf (xmtn-conflicts-conflict-left_resolution conflict) (list 'resolved_internal))) + + ((string= "resolved_user_left" symbol) + (setf (xmtn-conflicts-conflict-left_resolution conflict) (list 'resolved_left_user (cadar value)))) + + (t + (error "found %s" symbol))))))) + + (setq xmtn-conflicts-total-count (+ 1 xmtn-conflicts-total-count)) + + (xmtn-basic-io-check-empty) + + (ewoc-enter-last xmtn-conflicts-ewoc conflict))) + +(defun xmtn-conflicts-parse-duplicate_name () + "Fill an ewoc entry with data from duplicate_name conflict stanza." + ;; conflict duplicate_name + ;; left_type "added file" + ;; left_name "checkout_left.sh" + ;; left_file_id [ae5fe55181c0307c705d0b05fdc1147fc4afd05c] + ;; right_type "added file" + ;; right_name "checkout_left.sh" + ;; right_file_id [355315653eb77ade4804e42a2ef30c89387e1a2d] + ;; + ;; conflict duplicate_name + ;; left_type "added directory" + ;; left_name "utils" + ;; right_type "added directory" + ;; right_name "utils" + ;; + ;; optional left and right resolutions: + ;; resolved_keep{_left | _right} + ;; resolved_drop{_left | _right} + ;; resolved_rename{_left | _right} + ;; resolved_user{_left | _right} + (let ((conflict (make-xmtn-conflicts-conflict))) + (setf (xmtn-conflicts-conflict-conflict_type conflict) 'duplicate_name) + (xmtn-basic-io-check-line "left_type" (setf (xmtn-conflicts-conflict-left_type conflict) (cadar value))) + (xmtn-basic-io-check-line "left_name" (setf (xmtn-conflicts-conflict-left_name conflict) (cadar value))) + (xmtn-basic-io-parse-line + (cond + ((string= "left_file_id" symbol) + (setf (xmtn-conflicts-conflict-left_file_id conflict) (cadar value)) + (xmtn-basic-io-check-line "right_type" + (setf (xmtn-conflicts-conflict-right_type conflict) (cadar value))) + (xmtn-basic-io-check-line "right_name" + (setf (xmtn-conflicts-conflict-right_name conflict) (cadar value))) + (xmtn-basic-io-check-line "right_file_id" + (setf (xmtn-conflicts-conflict-right_file_id conflict) (cadar value)))) + + ((string= "right_type" symbol) + (setf (xmtn-conflicts-conflict-right_type conflict) (cadar value)) + (xmtn-basic-io-check-line "right_name" + (setf (xmtn-conflicts-conflict-right_name conflict) (cadar value)))) + (t + (error "found %s" symbol)))) + + ;; look for a left resolution + (case (xmtn-basic-io--peek) + ((empty eof) nil) + (t + (xmtn-basic-io-parse-line + (cond + ((string= "resolved_keep_left" symbol) + (setf (xmtn-conflicts-conflict-left_resolution conflict) (list 'resolved_keep))) + ((string= "resolved_drop_left" symbol) + (setf (xmtn-conflicts-conflict-left_resolution conflict) (list 'resolved_drop))) + ((string= "resolved_rename_left" symbol) + (setf (xmtn-conflicts-conflict-left_resolution conflict) (list 'resolved_rename (cadar value)))) + ((string= "resolved_user_left" symbol) + (setf (xmtn-conflicts-conflict-left_resolution conflict) (list 'resolved_user (cadar value)))) + (t + (error "left_resolution found %s" symbol)))))) + + ;; look for a right resolution + (case (xmtn-basic-io--peek) + ((empty eof) nil) + (t + (xmtn-basic-io-parse-line + (cond + ((string= "resolved_keep_right" symbol) + (setf (xmtn-conflicts-conflict-right_resolution conflict) (list 'resolved_keep))) + ((string= "resolved_drop_right" symbol) + (setf (xmtn-conflicts-conflict-right_resolution conflict) (list 'resolved_drop))) + ((string= "resolved_rename_right" symbol) + (setf (xmtn-conflicts-conflict-right_resolution conflict) (list 'resolved_rename (cadar value)))) + ((string= "resolved_user_right" symbol) + (setf (xmtn-conflicts-conflict-right_resolution conflict) (list 'resolved_user (cadar value)))) + (t + (error "right_resolution found %s" symbol)))))) + + (setq xmtn-conflicts-total-count (+ 1 xmtn-conflicts-total-count)) + (if (and (xmtn-conflicts-conflict-left_resolution conflict) + (xmtn-conflicts-conflict-right_resolution conflict)) + (setq xmtn-conflicts-resolved-count (+ 1 xmtn-conflicts-resolved-count))) + + (xmtn-basic-io-check-empty) + + (ewoc-enter-last xmtn-conflicts-ewoc conflict))) + +(defun xmtn-conflicts-parse-orphaned_node () + "Fill an ewoc entry with data from orphaned_node conflict stanza." + ;; conflict orphaned_file + ;; left_type "deleted directory" + ;; ancestor_name "patches" + ;; right_type "added file" + ;; right_name "patches/unrestricted_access.patch" + ;; right_file_id [597fd36ef183b2b8243d6d2a47fc6c2bf9cb585d] + ;; + ;; conflict orphaned_directory + ;; left_type "deleted directory" + ;; ancestor_name "stuff" + ;; right_type "added directory" + ;; right_name "stuff/dir1" + ;; + ;; or swap left/right + ;; + ;; optional resolutions: + ;; resolved_drop_left + ;; resolved_rename_left + (let ((conflict (make-xmtn-conflicts-conflict))) + (setf (xmtn-conflicts-conflict-conflict_type conflict) 'orphaned_node) + (xmtn-basic-io-check-line "left_type" (setf (xmtn-conflicts-conflict-left_type conflict) (cadar value))) + (xmtn-basic-io-parse-line + (cond + ((string= "ancestor_name" symbol) + (setf (xmtn-conflicts-conflict-ancestor_name conflict) (cadar value))) + + ((string= "left_name" symbol) + (setf (xmtn-conflicts-conflict-left_name conflict) (cadar value)) + (xmtn-basic-io-optional-line "left_file_id" + (setf (xmtn-conflicts-conflict-left_file_id conflict) (cadar value)))) + (t + (error "found %s" symbol)))) + + (xmtn-basic-io-check-line "right_type" (setf (xmtn-conflicts-conflict-right_type conflict) (cadar value))) + (xmtn-basic-io-parse-line + (cond + ((string= "ancestor_name" symbol) + (setf (xmtn-conflicts-conflict-ancestor_name conflict) (cadar value))) + + ((string= "right_name" symbol) + (setf (xmtn-conflicts-conflict-right_name conflict) (cadar value)) + (xmtn-basic-io-optional-line "right_file_id" + (setf (xmtn-conflicts-conflict-right_file_id conflict) (cadar value)))) + (t + (error "found %s" symbol)))) + + ;; look for a resolution + (case (xmtn-basic-io--peek) + ((empty eof) nil) + (t + (xmtn-basic-io-parse-line + (cond + ((string= "resolved_drop_left" symbol) + (setf (xmtn-conflicts-conflict-left_resolution conflict) (list 'resolved_drop))) + ((string= "resolved_rename_left" symbol) + (setf (xmtn-conflicts-conflict-left_resolution conflict) (list 'resolved_rename (cadar value)))) + (t + (error "resolution found %s" symbol)))))) + + (setq xmtn-conflicts-total-count (+ 1 xmtn-conflicts-total-count)) + (if (xmtn-conflicts-conflict-left_resolution conflict) + (setq xmtn-conflicts-resolved-count (+ 1 xmtn-conflicts-resolved-count))) + + (xmtn-basic-io-check-empty) + + (ewoc-enter-last xmtn-conflicts-ewoc conflict))) + +(defun xmtn-conflicts-parse-conflicts (end) + "Parse conflict stanzas from point thru END, fill in ewoc." + ;; first line in stanza indicates type of conflict; dispatch on that + ;; ewoc-enter-last puts text in the buffer, after `end', preserving point. + ;; xmtn-basic-io parsing moves point. + (while (< (point) end) + (xmtn-basic-io-check-line + "conflict" + (cond + ((and (eq 1 (length value)) + (eq 'symbol (caar value)) + (string= "content" (cadar value))) + (xmtn-conflicts-parse-content-conflict)) + + ((and (eq 1 (length value)) + (eq 'symbol (caar value)) + (string= "duplicate_name" (cadar value))) + (xmtn-conflicts-parse-duplicate_name)) + + ((and (eq 1 (length value)) + (eq 'symbol (caar value)) + (or (string= "orphaned_file" (cadar value)) + (string= "orphaned_directory" (cadar value)))) + (xmtn-conflicts-parse-orphaned_node)) + + (t + (error "unrecognized conflict type %s" value)))))) + +(defun xmtn-conflicts-set-hf () + "Set ewoc header and footer." + (ewoc-set-hf + xmtn-conflicts-ewoc + (concat + (format " Left branch : %s\n" xmtn-conflicts-left-branch) + (format " Right branch : %s\n" xmtn-conflicts-right-branch) + (format " Total conflicts : %d\n" xmtn-conflicts-total-count) + (format "Resolved conflicts : %d\n" xmtn-conflicts-resolved-count) + ) + "")) + +(defun xmtn-conflicts-read (begin end) + "Parse region BEGIN END in current buffer as basic-io, fill in ewoc, erase BEGIN END." + ;; Matches format-alist requirements. We are not currently using + ;; this in format-alist, but we might someday, and we need these + ;; params anyway. + (set-syntax-table xmtn-basic-io--*syntax-table*) + (goto-char begin) + (xmtn-conflicts-parse-header) + (if xmtn-conflicts-ancestor-revision + (xmtn-conflicts-parse-conflicts (1- end)); off-by-one somewhere. + ;; else no conflicts + ) + (let ((inhibit-read-only t)) (delete-region begin (1- end))) + (xmtn-conflicts-set-hf) + (set-buffer-modified-p nil) + (point-max)) + +(defun xmtn-conflicts-after-insert-file (chars-inserted) + ;; matches after-insert-file-functions requirements + + ;; `xmtn-conflicts-read' creates ewoc entries, which are + ;; inserted into the buffer. Since it is parsing the same + ;; buffer, we need them to be inserted _after_ the text that is + ;; being parsed. `xmtn-conflicts-mode' creates the ewoc at + ;; point, and inserts empty header and footer lines. + (goto-char (point-max)) + (let ((text-end (point))) + (xmtn-conflicts-mode) + (xmtn-conflicts-read (point-min) text-end)) + + (set-buffer-modified-p nil) + (point-max) + (xmtn-conflicts-next nil t)) + +(defun xmtn-conflicts-write-header (ewoc-buffer) + "Write EWOC-BUFFER header info in basic-io format to current buffer." + (xmtn-basic-io-write-id "left" (with-current-buffer ewoc-buffer xmtn-conflicts-left-revision)) + (xmtn-basic-io-write-id "right" (with-current-buffer ewoc-buffer xmtn-conflicts-right-revision)) + (xmtn-basic-io-write-id "ancestor" (with-current-buffer ewoc-buffer xmtn-conflicts-ancestor-revision)) + ) + +(defun xmtn-conflicts-write-content (conflict) + "Write CONFLICT (a content conflict) in basic-io format to current buffer." + (insert ?\n) + (xmtn-basic-io-write-sym "conflict" "content") + (xmtn-basic-io-write-str "node_type" "file") + (xmtn-basic-io-write-str "ancestor_name" (xmtn-conflicts-conflict-ancestor_name conflict)) + (xmtn-basic-io-write-id "ancestor_file_id" (xmtn-conflicts-conflict-ancestor_file_id conflict)) + (xmtn-basic-io-write-str "left_name" (xmtn-conflicts-conflict-left_name conflict)) + (xmtn-basic-io-write-id "left_file_id" (xmtn-conflicts-conflict-left_file_id conflict)) + (xmtn-basic-io-write-str "right_name" (xmtn-conflicts-conflict-right_name conflict)) + (xmtn-basic-io-write-id "right_file_id" (xmtn-conflicts-conflict-right_file_id conflict)) + + (if (xmtn-conflicts-conflict-left_resolution conflict) + (progn + (setq xmtn-conflicts-resolved-count (+ 1 xmtn-conflicts-resolved-count)) + (ecase (car (xmtn-conflicts-conflict-left_resolution conflict)) + (resolved_internal + (setq xmtn-conflicts-resolved-internal-count (+ 1 xmtn-conflicts-resolved-internal-count)) + (insert "resolved_internal \n")) + + (resolved_keep + (insert "resolved_keep_left \n")) + + (resolved_user + (xmtn-basic-io-write-str "resolved_user_left" (cadr (xmtn-conflicts-conflict-left_resolution conflict)))) + )))) + +(defun xmtn-conflicts-write-duplicate_name (conflict) + "Write CONFLICT (a duplicate_name conflict) in basic-io format to current buffer." + (insert ?\n) + (xmtn-basic-io-write-sym "conflict" "duplicate_name") + (xmtn-basic-io-write-str "left_type" (xmtn-conflicts-conflict-left_type conflict)) + (xmtn-basic-io-write-str "left_name" (xmtn-conflicts-conflict-left_name conflict)) + (if (xmtn-conflicts-conflict-left_file_id conflict) + (xmtn-basic-io-write-id "left_file_id" (xmtn-conflicts-conflict-left_file_id conflict))) + (xmtn-basic-io-write-str "right_type" (xmtn-conflicts-conflict-right_type conflict)) + (xmtn-basic-io-write-str "right_name" (xmtn-conflicts-conflict-right_name conflict)) + (if (xmtn-conflicts-conflict-right_file_id conflict) + (xmtn-basic-io-write-id "right_file_id" (xmtn-conflicts-conflict-right_file_id conflict))) + + (if (xmtn-conflicts-conflict-left_resolution conflict) + (ecase (car (xmtn-conflicts-conflict-left_resolution conflict)) + (resolved_keep + (insert "resolved_keep_left \n")) + (resolved_drop + (insert "resolved_drop_left \n")) + (resolved_rename + (xmtn-basic-io-write-str + "resolved_rename_left" + (file-relative-name (cadr (xmtn-conflicts-conflict-left_resolution conflict))))) + (resolved_user + (xmtn-basic-io-write-str + "resolved_user_left" + (file-relative-name (cadr (xmtn-conflicts-conflict-left_resolution conflict))))) + )) + + (if (xmtn-conflicts-conflict-right_resolution conflict) + (ecase (car (xmtn-conflicts-conflict-right_resolution conflict)) + (resolved_keep + (insert "resolved_keep_right \n")) + (resolved_drop + (insert "resolved_drop_right \n")) + (resolved_rename + (xmtn-basic-io-write-str + "resolved_rename_right" + (file-relative-name (cadr (xmtn-conflicts-conflict-right_resolution conflict))))) + (resolved_user + (xmtn-basic-io-write-str + "resolved_user_right" + (file-relative-name (cadr (xmtn-conflicts-conflict-right_resolution conflict))))) + )) + + (if (and (xmtn-conflicts-conflict-left_resolution conflict) + (xmtn-conflicts-conflict-right_resolution conflict)) + (setq xmtn-conflicts-resolved-count (+ 1 xmtn-conflicts-resolved-count))) + ) + +(defun xmtn-conflicts-write-orphaned_node (conflict) + "Write CONFLICT (an orphaned_node conflict) in basic-io format to current buffer." + (insert ?\n) + (cond + ((string= "added directory" (xmtn-conflicts-conflict-left_type conflict)) + (xmtn-basic-io-write-sym "conflict" "orphaned_directory") + (xmtn-basic-io-write-str "left_type" "added directory") + (xmtn-basic-io-write-str "left_name" (xmtn-conflicts-conflict-left_name conflict)) + (xmtn-basic-io-write-str "right_type" (xmtn-conflicts-conflict-right_type conflict)) + (xmtn-basic-io-write-str "ancestor_name" (xmtn-conflicts-conflict-ancestor_name conflict))) + + ((string= "added file" (xmtn-conflicts-conflict-left_type conflict)) + (xmtn-basic-io-write-sym "conflict" "orphaned_file") + (xmtn-basic-io-write-str "left_type" "added file") + (xmtn-basic-io-write-str "left_name" (xmtn-conflicts-conflict-left_name conflict)) + (xmtn-basic-io-write-id "left_file_id" (xmtn-conflicts-conflict-left_file_id conflict)) + (xmtn-basic-io-write-str "right_type" (xmtn-conflicts-conflict-right_type conflict)) + (xmtn-basic-io-write-str "ancestor_name" (xmtn-conflicts-conflict-ancestor_name conflict))) + + ((string= "added directory" (xmtn-conflicts-conflict-right_type conflict)) + (xmtn-basic-io-write-sym "conflict" "orphaned_directory") + (xmtn-basic-io-write-str "left_type" (xmtn-conflicts-conflict-left_type conflict)) + (xmtn-basic-io-write-str "ancestor_name" (xmtn-conflicts-conflict-ancestor_name conflict)) + (xmtn-basic-io-write-str "right_type" "added directory") + (xmtn-basic-io-write-str "right_name" (xmtn-conflicts-conflict-right_name conflict))) + + ((string= "added file" (xmtn-conflicts-conflict-right_type conflict)) + (xmtn-basic-io-write-sym "conflict" "orphaned_file") + (xmtn-basic-io-write-str "left_type" (xmtn-conflicts-conflict-left_type conflict)) + (xmtn-basic-io-write-str "ancestor_name" (xmtn-conflicts-conflict-ancestor_name conflict)) + (xmtn-basic-io-write-str "right_type" (xmtn-conflicts-conflict-right_type conflict)) + (xmtn-basic-io-write-str "right_name" (xmtn-conflicts-conflict-right_name conflict)) + (xmtn-basic-io-write-id "right_file_id" (xmtn-conflicts-conflict-right_file_id conflict))) + ) + + (if (xmtn-conflicts-conflict-left_resolution conflict) + (progn + (setq xmtn-conflicts-resolved-count (+ 1 xmtn-conflicts-resolved-count)) + (ecase (car (xmtn-conflicts-conflict-left_resolution conflict)) + (resolved_drop + (insert "resolved_drop_left \n")) + + (resolved_rename + (xmtn-basic-io-write-str "resolved_rename_left" (cadr (xmtn-conflicts-conflict-left_resolution conflict)))) + )))) + +(defun xmtn-conflicts-write-conflicts (ewoc) + "Write EWOC elements in basic-io format to xmtn-conflicts-output-buffer." + (setq xmtn-conflicts-resolved-count 0) + (setq xmtn-conflicts-resolved-internal-count 0) + (ewoc-map + (lambda (conflict) + (with-current-buffer xmtn-conflicts-output-buffer + (ecase (xmtn-conflicts-conflict-conflict_type conflict) + (content + (xmtn-conflicts-write-content conflict)) + (duplicate_name + (xmtn-conflicts-write-duplicate_name conflict)) + (orphaned_node + (xmtn-conflicts-write-orphaned_node conflict)) + ))) + ewoc)) + +(defun xmtn-conflicts-save (begin end ewoc-buffer) + "Replace region BEGIN END with EWOC-BUFFER ewoc in basic-io format." + (delete-region begin end) + (xmtn-conflicts-write-header ewoc-buffer) + ;; ewoc-map sets current-buffer to ewoc-buffer, so we need a + ;; reference to the current buffer. + (let ((xmtn-conflicts-output-buffer (current-buffer)) + (ewoc (with-current-buffer ewoc-buffer xmtn-conflicts-ewoc))) + (xmtn-conflicts-write-conflicts ewoc) + (with-current-buffer ewoc-buffer (xmtn-conflicts-set-hf)) + )) + +;; Arrange for xmtn-conflicts-save to be called by save-buffer. We do +;; not automatically convert in insert-file-contents, because we don't +;; want to convert _all_ conflict files (consider the monotone test +;; suite!). Instead, we call xmtn-conflicts-read explicitly from +;; xmtn-conflicts-review, and set after-insert-file-functions to a +;; buffer-local value in xmtn-conflicts-mode. +(add-to-list 'format-alist + '(xmtn-conflicts-format + "Save conflicts in basic-io format." + nil + nil + xmtn-conflicts-save + t + nil + nil)) + +(defun xmtn-conflicts-update-counts () + "Update resolved counts." + (setq xmtn-conflicts-resolved-count 0) + (setq xmtn-conflicts-resolved-internal-count 0) + + (ewoc-map + (lambda (conflict) + (ecase (xmtn-conflicts-conflict-conflict_type conflict) + (content + (if (xmtn-conflicts-conflict-left_resolution conflict) + (progn + (setq xmtn-conflicts-resolved-count (+ 1 xmtn-conflicts-resolved-count)) + (if (eq 'resolved_internal (car (xmtn-conflicts-conflict-left_resolution conflict))) + (setq xmtn-conflicts-resolved-internal-count (+ 1 xmtn-conflicts-resolved-internal-count)))))) + + (duplicate_name + (if (and (xmtn-conflicts-conflict-left_resolution conflict) + (xmtn-conflicts-conflict-right_resolution conflict)) + (setq xmtn-conflicts-resolved-count (+ 1 xmtn-conflicts-resolved-count)))) + + (orphaned_node + (if (xmtn-conflicts-conflict-left_resolution conflict) + (setq xmtn-conflicts-resolved-count (+ 1 xmtn-conflicts-resolved-count)))) + + )) + xmtn-conflicts-ewoc)) + +(dvc-make-ewoc-next xmtn-conflicts-next xmtn-conflicts-ewoc) +(dvc-make-ewoc-prev xmtn-conflicts-prev xmtn-conflicts-ewoc) + +(defun xmtn-conflicts-resolvedp (elem) + "Return non-nil if ELEM contains a complete conflict resolution." + (let ((conflict (ewoc-data elem))) + (ecase (xmtn-conflicts-conflict-conflict_type conflict) + ((content orphaned_node) + (xmtn-conflicts-conflict-left_resolution conflict)) + (duplicate_name + (and (xmtn-conflicts-conflict-left_resolution conflict) + (xmtn-conflicts-conflict-right_resolution conflict))) + ))) + +(defun xmtn-conflicts-next-unresolved () + "Move to next unresolved element." + (interactive) + (xmtn-conflicts-next 'xmtn-conflicts-resolvedp)) + +(defun xmtn-conflicts-prev-unresolved () + "Move to prev unresolved element." + (interactive) + (xmtn-conflicts-prev 'xmtn-conflicts-resolvedp)) + +(defun xmtn-conflicts-clear-resolution() + "Remove resolution for current conflict." + (interactive) + (let* ((elem (ewoc-locate xmtn-conflicts-ewoc)) + (conflict (ewoc-data elem))) + (setf (xmtn-conflicts-conflict-left_resolution conflict) nil) + (setf (xmtn-conflicts-conflict-right_resolution conflict) nil) + (ewoc-invalidate xmtn-conflicts-ewoc elem))) + +(defun xmtn-conflicts-resolve-conflict-post-ediff () + "Stuff to do when ediff quits." + (remove-hook 'ediff-quit-merge-hook 'xmtn-conflicts-resolve-conflict-post-ediff) + (add-hook 'ediff-quit-merge-hook 'ediff-maybe-save-and-delete-merge) + + (ediff-dispose-of-variant-according-to-user ediff-buffer-A 'A nil nil) + (ediff-dispose-of-variant-according-to-user ediff-buffer-B 'B nil nil) + (ediff-dispose-of-variant-according-to-user ediff-ancestor-buffer 'Ancestor nil nil) + (save-excursion + (set-buffer ediff-buffer-C) + (save-buffer)) + (ediff-kill-buffer-carefully ediff-buffer-C) + + (let ((control-buffer ediff-control-buffer)) + (pop-to-buffer xmtn-conflicts-current-conflict-buffer) + (setq xmtn-conflicts-current-conflict-buffer nil) + (let ((current (nth 0 xmtn-conflicts-ediff-quit-info)) + (result-file (nth 1 xmtn-conflicts-ediff-quit-info)) + (window-config (nth 2 xmtn-conflicts-ediff-quit-info))) + (let ((conflict (ewoc-data current))) + (ecase (xmtn-conflicts-conflict-conflict_type conflict) + (content + (setf (xmtn-conflicts-conflict-left_resolution conflict) (list 'resolved_user result-file))) + (duplicate_name + (ecase (nth 3 xmtn-conflicts-ediff-quit-info); side + ('left + (setf (xmtn-conflicts-conflict-left_resolution conflict) (list 'resolved_user result-file))) + ('right + (setf (xmtn-conflicts-conflict-right_resolution conflict) (list 'resolved_user result-file))) + )) + ;; can't resolve orphaned_node by ediff + )) + (ewoc-invalidate xmtn-conflicts-ewoc current) + (set-window-configuration window-config) + (set-buffer control-buffer)))) + +(defun xmtn-conflicts-get-file (file-id dir file-name) + "Get contents of FILE-ID into DIR/FILE-NAME. Return full file name." + (let ((file (concat (file-name-as-directory dir) file-name))) + (setq dir (file-name-directory file)) + (unless (file-exists-p dir) + (make-directory dir t)) + (xmtn--get-file-by-id default-directory file-id file) + file)) + +(defun xmtn-conflicts-resolve-ediff (side) + "Resolve the current conflict via ediff SIDE." + (interactive) + (if xmtn-conflicts-current-conflict-buffer + (error "another conflict resolution is already in progress.")) + + (let* ((elem (ewoc-locate xmtn-conflicts-ewoc)) + (conflict (ewoc-data elem)) + (type (xmtn-conflicts-conflict-conflict_type conflict))) + + (if (not (xmtn-conflicts-conflict-left_file_id conflict)) + (error "can't ediff directories from here")) + + ;; Get the ancestor, left, right into files with nice names, so + ;; uniquify gives the buffers nice names. Store the result in + ;; _MTN/*, so a later 'merge --resolve-conflicts-file' can find it. + ;; + ;; duplicate_name conflicts have no ancestor. + (let ((file-ancestor (and (xmtn-conflicts-conflict-ancestor_file_id conflict) + (xmtn-conflicts-get-file (xmtn-conflicts-conflict-ancestor_file_id conflict) + "_MTN/resolutions/ancestor" + (xmtn-conflicts-conflict-ancestor_name conflict)))) + (file-left (xmtn-conflicts-get-file (xmtn-conflicts-conflict-left_file_id conflict) + xmtn-conflicts-left-root + (xmtn-conflicts-conflict-left_name conflict))) + (file-right (xmtn-conflicts-get-file (xmtn-conflicts-conflict-right_file_id conflict) + xmtn-conflicts-right-root + (xmtn-conflicts-conflict-right_name conflict))) + + (result-file (concat "_MTN/resolutions/result/" (xmtn-conflicts-conflict-right_name conflict))) ) + + (unless (file-exists-p (file-name-directory result-file)) + (make-directory (file-name-directory result-file) t)) + + (remove-hook 'ediff-quit-merge-hook 'ediff-maybe-save-and-delete-merge) + (add-hook 'ediff-quit-merge-hook 'xmtn-conflicts-resolve-conflict-post-ediff) + + ;; ediff leaves the merge buffer active; + ;; xmtn-conflicts-resolve-conflict-post-ediff needs to find the + ;; conflict buffer. + (setq xmtn-conflicts-current-conflict-buffer (current-buffer)) + (setq xmtn-conflicts-ediff-quit-info + (list elem result-file (current-window-configuration) side)) + + (if file-ancestor + (ediff-merge-files-with-ancestor file-left file-right file-ancestor nil result-file) + (ediff-merge-files file-left file-right nil result-file)) + ))) + +(defun xmtn-conflicts-resolve-keep_left () + "Resolve the current conflict by keep_left." + (interactive) + (let* ((elem (ewoc-locate xmtn-conflicts-ewoc)) + (conflict (ewoc-data elem))) + (setf (xmtn-conflicts-conflict-left_resolution conflict) (list 'resolved_keep)) + (ewoc-invalidate xmtn-conflicts-ewoc elem))) + +(defun xmtn-conflicts-resolve-keep_right () + "Resolve the current conflict by keep_right." + (interactive) + (let* ((elem (ewoc-locate xmtn-conflicts-ewoc)) + (conflict (ewoc-data elem))) + (setf (xmtn-conflicts-conflict-right_resolution conflict) (list 'resolved_keep)) + (ewoc-invalidate xmtn-conflicts-ewoc elem))) + +(defun xmtn-conflicts-resolve-drop_left () + "Resolve the current conflict by drop_left." + (interactive) + (let* ((elem (ewoc-locate xmtn-conflicts-ewoc)) + (conflict (ewoc-data elem))) + (setf (xmtn-conflicts-conflict-left_resolution conflict) (list 'resolved_drop)) + (ewoc-invalidate xmtn-conflicts-ewoc elem))) + +(defun xmtn-conflicts-resolve-drop_right () + "Resolve the current conflict by drop_right." + (interactive) + (let* ((elem (ewoc-locate xmtn-conflicts-ewoc)) + (conflict (ewoc-data elem))) + (setf (xmtn-conflicts-conflict-right_resolution conflict) (list 'resolved_drop)) + (ewoc-invalidate xmtn-conflicts-ewoc elem))) + +(defun xmtn-conflicts-resolve-user (side) + "Resolve the current conflict by user_SIDE." + (interactive) + ;; Right is the target workspace in a propagate, and also the current + ;; workspace in a merge. So default to right_name. + (let* ((elem (ewoc-locate xmtn-conflicts-ewoc)) + (conflict (ewoc-data elem)) + (result-file (read-file-name "resolution file: " "./" nil t + (xmtn-conflicts-conflict-right_name conflict)))) + (ecase side + ('left + (setf (xmtn-conflicts-conflict-left_resolution conflict) (list 'resolved_user result-file))) + ('right + (setf (xmtn-conflicts-conflict-right_resolution conflict) (list 'resolved_user result-file))) + ) + (ewoc-invalidate xmtn-conflicts-ewoc elem))) + +(defun xmtn-conflicts-resolve-rename (side) + "Resolve the current conflict by rename_SIDE." + (interactive) + ;; Right is the target workspace in a propagate, and also the current + ;; workspace in a merge. So default to right_name. + (let* ((elem (ewoc-locate xmtn-conflicts-ewoc)) + (conflict (ewoc-data elem)) + (result-file + (file-relative-name + (read-file-name "rename file: " "" nil nil + (concat "/" (xmtn-conflicts-conflict-right_name conflict)))))) + (ecase side + ('left + (setf (xmtn-conflicts-conflict-left_resolution conflict) (list 'resolved_rename result-file))) + ('right + (setf (xmtn-conflicts-conflict-right_resolution conflict) (list 'resolved_rename result-file))) + ) + (ewoc-invalidate xmtn-conflicts-ewoc elem))) + +(defun xmtn-conflicts-resolve-user_leftp () + "Non-nil if user_left resolution is appropriate for current conflict." + (let* ((conflict (ewoc-data (ewoc-locate xmtn-conflicts-ewoc))) + (type (xmtn-conflicts-conflict-conflict_type conflict))) + + (and (not (xmtn-conflicts-conflict-left_resolution conflict)) + (or (equal type 'content) + (and (equal type 'duplicate_name) + ;; if no file_id, it's a directory + (xmtn-conflicts-conflict-left_file_id conflict))) ))) + +(defun xmtn-conflicts-resolve-user_rightp () + "Non-nil if user_right resolution is appropriate for current conflict." + (let* ((conflict (ewoc-data (ewoc-locate xmtn-conflicts-ewoc))) + (type (xmtn-conflicts-conflict-conflict_type conflict))) + + ;; duplicate_name is the only conflict type that needs a right resolution + (and (xmtn-conflicts-conflict-left_resolution conflict) + (not (xmtn-conflicts-conflict-right_resolution conflict)) + (equal type 'duplicate_name) + ;; if no file_id, it's a directory + (xmtn-conflicts-conflict-right_file_id conflict) + ;; user_right doesn't change name, so left resolution must change name or drop + (let ((left-res (car (xmtn-conflicts-conflict-left_resolution conflict)))) + (member left-res '(resolved_drop resolved_rename)))))) + +(defun xmtn-conflicts-resolve-keep_leftp () + "Non-nil if keep_left resolution is appropriate for current conflict." + (let* ((conflict (ewoc-data (ewoc-locate xmtn-conflicts-ewoc))) + (type (xmtn-conflicts-conflict-conflict_type conflict))) + + (and (not (xmtn-conflicts-conflict-left_resolution conflict)) + (equal type 'duplicate_name)))) + +(defun xmtn-conflicts-resolve-keep_rightp () + "Non-nil if keep_right resolution is appropriate for current conflict." + (let* ((conflict (ewoc-data (ewoc-locate xmtn-conflicts-ewoc))) + (type (xmtn-conflicts-conflict-conflict_type conflict))) + + ;; duplicate_name is the only conflict type that needs a right resolution + (and (xmtn-conflicts-conflict-left_resolution conflict) + (not (xmtn-conflicts-conflict-right_resolution conflict)) + (equal type 'duplicate_name) + (let ((left-res (car (xmtn-conflicts-conflict-left_resolution conflict)))) + (member left-res '(resolved_drop resolved_rename)))))) + +(defun xmtn-conflicts-resolve-rename_leftp () + "Non-nil if rename_left resolution is appropriate for current conflict." + (let* ((conflict (ewoc-data (ewoc-locate xmtn-conflicts-ewoc))) + (type (xmtn-conflicts-conflict-conflict_type conflict))) + + (and (not (xmtn-conflicts-conflict-left_resolution conflict)) + (member type '(duplicate_name orphaned_node))))) + +(defun xmtn-conflicts-resolve-rename_rightp () + "Non-nil if rename_right resolution is appropriate for current conflict." + (let* ((conflict (ewoc-data (ewoc-locate xmtn-conflicts-ewoc))) + (type (xmtn-conflicts-conflict-conflict_type conflict))) + + ;; duplicate_name is the only conflict type that needs a right resolution + (and (xmtn-conflicts-conflict-left_resolution conflict) + (not (xmtn-conflicts-conflict-right_resolution conflict)) + (equal type 'duplicate_name)))) + +(defun xmtn-conflicts-resolve-drop_leftp () + "Non-nil if drop_left resolution is appropriate for the current conflict." + (let* ((conflict (ewoc-data (ewoc-locate xmtn-conflicts-ewoc))) + (type (xmtn-conflicts-conflict-conflict_type conflict))) + + (and (not (xmtn-conflicts-conflict-left_resolution conflict)) + (or (and (equal type 'duplicate_name) + ;; if no file_id, it's a directory; can't drop if not empty + (xmtn-conflicts-conflict-left_file_id conflict)) + (and (equal type 'orphaned_node) + ;; if no left or right file_id, it's a directory; can't drop if not empty + (or (xmtn-conflicts-conflict-left_file_id conflict) + (xmtn-conflicts-conflict-right_file_id conflict) + )))))) + +(defun xmtn-conflicts-resolve-drop_rightp () + "Non-nil if drop_right resolution is appropriate for the current conflict." + (let* ((conflict (ewoc-data (ewoc-locate xmtn-conflicts-ewoc))) + (type (xmtn-conflicts-conflict-conflict_type conflict))) + + ;; duplicate_name is the only conflict type that needs a right resolution + (and (xmtn-conflicts-conflict-left_resolution conflict) + (not (xmtn-conflicts-conflict-right_resolution conflict)) + (equal type 'duplicate_name) + ;; if no file_id, it's a directory; can't drop if not empty + (xmtn-conflicts-conflict-right_file_id conflict)))) + +(defvar xmtn-conflicts-resolve-map + (let ((map (make-sparse-keymap "resolution"))) + (define-key map [?c] '(menu-item "c) clear resolution" + xmtn-conflicts-clear-resolution)) + + ;; Don't need 'left' or 'right' in menu, since only one is + ;; visible; then this works better for single file conflicts. + + (define-key map [?9] '(menu-item "9) drop" + xmtn-conflicts-resolve-drop_right + :visible (xmtn-conflicts-resolve-drop_rightp))) + (define-key map [?8] '(menu-item "8) rename" + (lambda () + (interactive) + (xmtn-conflicts-resolve-rename 'right)) + :visible (xmtn-conflicts-resolve-rename_rightp))) + (define-key map [?7] '(menu-item "7) file" + (lambda () + (interactive) + (xmtn-conflicts-resolve-user 'right)) + :visible (xmtn-conflicts-resolve-user_rightp))) + (define-key map [?6] '(menu-item "6) keep" + xmtn-conflicts-resolve-keep_right + :visible (xmtn-conflicts-resolve-keep_rightp))) + (define-key map [?5] '(menu-item "5) ediff" + (lambda () + (interactive) + (xmtn-conflicts-resolve-ediff 'right)) + :visible (xmtn-conflicts-resolve-user_rightp))) + + (define-key map [?4] '(menu-item "4) file" + (lambda () + (interactive) + (xmtn-conflicts-resolve-user 'left)) + :visible (xmtn-conflicts-resolve-user_leftp))) + (define-key map [?3] '(menu-item "3) drop" + xmtn-conflicts-resolve-drop_left + :visible (xmtn-conflicts-resolve-drop_leftp))) + (define-key map [?2] '(menu-item "2) rename" + (lambda () + (interactive) + (xmtn-conflicts-resolve-rename 'left)) + :visible (xmtn-conflicts-resolve-rename_leftp))) + (define-key map [?1] '(menu-item "1) keep" + xmtn-conflicts-resolve-keep_left + :visible (xmtn-conflicts-resolve-keep_leftp))) + (define-key map [?0] '(menu-item "0) ediff" + (lambda () + (interactive) + (xmtn-conflicts-resolve-ediff 'left)) + :visible (xmtn-conflicts-resolve-user_leftp))) + map) + "Keyboard menu keymap used to resolve conflicts.") + +(defun xmtn-conflicts-current-conflict () + "Return the conflict (an xmtn-conflicts-root class struct) for +the ewoc element at point. Throws an error if point is not on a +conflict." + (let ((ewoc-entry (ewoc-locate xmtn-conflicts-ewoc))) + (if (not ewoc-entry) + ;; ewoc is empty + (error "not on a conflict")) + (ewoc-data ewoc-entry))) + +(defun xmtn-conflicts-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") + (let ((conflict (xmtn-conflicts-current-conflict))) + (dvc-log-edit other-frame t) + (undo-boundary) + (goto-char (point-max)) + (newline 2) + (insert "* ") + (insert (xmtn-conflicts-conflict-right_name conflict)) + (insert ": ") + )) + +(defun xmtn-conflicts-do-propagate () + "Perform propagate on revisions in current conflict buffer." + (interactive) + (save-some-buffers t); log buffer + (xmtn-propagate-from xmtn-conflicts-left-branch)) + +(defun xmtn-conflicts-do-merge () + "Perform merge on revisions in current conflict buffer." + (interactive) + (save-some-buffers t); log buffer + (xmtn-dvc-merge)) + +(defun xmtn-conflicts-ediff-resolution-ws () + "Ediff current resolution file against workspace." + (interactive) + (let* ((elem (ewoc-locate xmtn-conflicts-ewoc)) + (conflict (ewoc-data elem))) + (if (and (member (xmtn-conflicts-conflict-conflict_type conflict) + '(content orphaned_node)) + (xmtn-conflicts-conflict-left_resolution conflict)) + (ediff (cadr (xmtn-conflicts-conflict-left_resolution conflict)) + ;; propagate target is right + (xmtn-conflicts-conflict-right_name conflict))))) + +(defvar xmtn-conflicts-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [?C] (lambda () (interactive) (xmtn-conflicts-clean xmtn-conflicts-right-work))) + (define-key map [?c] 'xmtn-conflicts-clear-resolution) + (define-key map [?e] 'xmtn-conflicts-ediff-resolution-ws) + (define-key map [?n] 'xmtn-conflicts-next) + (define-key map [?N] 'xmtn-conflicts-next-unresolved) + (define-key map [?p] 'xmtn-conflicts-prev) + (define-key map [?P] 'xmtn-conflicts-prev-unresolved) + (define-key map [?q] 'dvc-buffer-quit) + (define-key map [?r] xmtn-conflicts-resolve-map) + (define-key map [?t] 'xmtn-conflicts-add-log-entry) + (define-key map "\M-d" xmtn-conflicts-resolve-map) + (define-key map "MM" 'xmtn-conflicts-do-merge) + (define-key map "MP" 'xmtn-conflicts-do-propagate) + (define-key map "MU" 'dvc-update) + map) + "Keymap used in `xmtn-conflicts-mode'.") + +(easy-menu-define xmtn-conflicts-mode-menu xmtn-conflicts-mode-map + "`xmtn-conflicts' menu" + `("Mtn-conflicts" + ["Clear resolution" xmtn-conflicts-clear-resolution t] + ["Propagate" xmtn-conflicts-do-propagate t] + ["Merge" xmtn-conflicts-do-merge t] + ["Update" dvc-update t] + ["Clean" xmtn-conflicts-clean t] + )) + +;; derive from nil causes no keymap to be used, but still have self-insert keys +;; derive from fundamental-mode causes self-insert keys +(define-derived-mode xmtn-conflicts-mode fundamental-mode "xmtn-conflicts" + "Major mode to specify conflict resolutions." + (setq dvc-buffer-current-active-dvc 'xmtn) + (setq buffer-read-only nil) + (setq xmtn-conflicts-ewoc (ewoc-create 'xmtn-conflicts-printer)) + (setq dvc-buffer-refresh-function nil) + (add-to-list 'buffer-file-format 'xmtn-conflicts-format) + + ;; Arrange for `revert-buffer' to do the right thing + (set (make-local-variable 'after-insert-file-functions) '(xmtn-conflicts-after-insert-file)) + + ;; don't do normal clean up stuff + (set (make-local-variable 'before-save-hook) nil) + (set (make-local-variable 'write-file-functions) nil) + + (dvc-install-buffer-menu) + (setq buffer-read-only t) + (buffer-disable-undo) + (set-buffer-modified-p nil)) + +(dvc-add-uniquify-directory-mode 'xmtn-conflicts-mode) + +(defconst xmtn-conflicts-opts-file "_MTN/dvc-conflicts-opts") + +(defun xmtn-conflicts-save-opts (left-work right-work) + "Store LEFT-WORK, RIGHT-WORK in `xmtn-conflicts-opts-file', for +retrieval by `xmtn-conflicts-load-opts'." + (let ((xmtn-conflicts-left-work left-work) + (xmtn-conflicts-right-work right-work) + (xmtn-conflicts-left-branch (xmtn--tree-default-branch left-work)) + (xmtn-conflicts-right-branch (xmtn--tree-default-branch right-work))) + + (dvc-save-state (list 'xmtn-conflicts-left-work + 'xmtn-conflicts-left-branch + 'xmtn-conflicts-right-work + 'xmtn-conflicts-right-branch) + (concat (file-name-as-directory right-work) xmtn-conflicts-opts-file)) + )) + +(defun xmtn-conflicts-load-opts () + "Load options saved by +`xmtn-conflicts-save-opts'. `default-directory' must be workspace +root where options file is stored." + (let ((opts-file (concat default-directory xmtn-conflicts-opts-file))) + (if (file-exists-p opts-file) + (load opts-file) + ;; When reviewing conflicts after a merge is complete, the options file is not present + (message "%s options file not found" opts-file)))) + +(defun xmtn-conflicts-1 (left-work left-rev right-work right-rev) + "List conflicts between LEFT-REV and RIGHT-REV +revisions (monotone revision specs; if nil, defaults to heads of +respective workspace branches) in LEFT-WORK and RIGHT-WORK +workspaces (strings). Allow specifying resolutions, propagating +to right. Stores conflict file in RIGHT-WORK/_MTN." + (let ((default-directory right-work)) + (xmtn-conflicts-save-opts left-work right-work) + (dvc-run-dvc-async + 'xmtn + (list "conflicts" "store" left-rev right-rev) + :finished (lambda (output error status arguments) + (xmtn-dvc-log-clean) + (xmtn-conflicts-review default-directory)) + + :error (lambda (output error status arguments) + (xmtn-dvc-log-clean) + (pop-to-buffer error)) + ))) + +(defun xmtn-check-workspace-for-propagate (work) + "Check that workspace WORK is ready for propagate. +It must be merged, and should be at the head revision, and have no local changes." + (let* ((default-directory work) + (heads (xmtn--heads default-directory nil)) + (base (xmtn--get-base-revision-hash-id-or-null default-directory))) + + (message "checking %s for multiple heads, base not head" work) + + (if (> 1 (length heads)) + (error "%s has multiple heads; can't propagate" work)) + + (if (not (string= base (nth 0 heads))) + (error "Aborting due to %s not at head" work)) + + ;; check for local changes + (message "checking %s for local changes" work) + + (dvc-run-dvc-sync + 'xmtn + (list "status") + :finished (lambda (output error status arguments) + ;; we don't get an error status for not up-to-date, + ;; so parse the output. + ;; FIXME: add option to automate inventory to just return status; can return on first change + ;; FIXME: 'patch' may be internationalized. + (set-buffer output) + (goto-char (point-min)) + (if (search-forward "patch" (point-max) t) + (if (not (yes-or-no-p (format "%s has local changes; really show conflicts? " work))) + (error "aborting due to local changes")))) + + :error (lambda (output error status arguments) + (pop-to-buffer error)))) + + ) + +(defun xmtn-check-propagate-needed (left-work right-work) + "Throw error unless branch in workspace LEFT-WORK needs to be propagated to RIGHT-WORK." + ;; We assume xmtn-check-workspace-for-propagate has already been run + ;; on left-work, right-work, so just check if they have the same + ;; base revision, or the target (right) base revision is a + ;; descendant of the source. + (message "checking if propagate needed") + + (let ((left-base (xmtn--get-base-revision-hash-id-or-null left-work)) + (right-base (xmtn--get-base-revision-hash-id-or-null right-work))) + + (if (string= left-base right-base) + (error "don't need to propagate") + ;; check for right descendant of left + (let ((descendents (xmtn-automate-simple-command-output-lines left-work (list "descendents" left-base)))) + (while descendents + (if (string= right-base (car descendents)) + (error "don't need to propagate")) + (setq descendents (cdr descendents))))) + )) + +;;;###autoload +(defun xmtn-conflicts-propagate (left-work right-work) + "List conflicts for a propagate from LEFT-WORK to RIGHT-WORK workspace branch head revisions. +Allow specifying resolutions. LEFT-WORK and RIGHT-WORK are strings giving +workspace directories; prompted if nil. Review is done in RIGHT-WORK +workspace." + (interactive "i\ni") + (setq left-work (dvc-read-project-tree-maybe "Propagate from (workspace directory): " left-work)) + (setq right-work (dvc-read-project-tree-maybe "to (workspace directory): " right-work)) + + (xmtn-check-workspace-for-propagate left-work) + (xmtn-check-workspace-for-propagate right-work) + + (xmtn-check-propagate-needed left-work right-work) + + (message "computing conflicts") + + (xmtn-conflicts-1 left-work + (car (xmtn--heads left-work nil)) + right-work + (car (xmtn--heads right-work nil)))) + +;;;###autoload +(defun xmtn-conflicts-merge () + "List conflicts between current head revisions." + (interactive) + (let ((default-directory + (dvc-read-project-tree-maybe "Review conflicts in (workspace directory): "))) + (xmtn-conflicts-1 default-directory nil default-directory nil))) + +;;;###autoload +(defun xmtn-conflicts-review (&optional workspace) + "Review conflicts for WORKSPACE (a directory; default prompt)." + (interactive) + (let ((default-directory + (dvc-read-project-tree-maybe "Review conflicts for (workspace directory): " + (when workspace (expand-file-name workspace)))) + (file-name "_MTN/conflicts")) + (if (not (file-exists-p file-name)) + (error "conflicts file not found")) + + (let ((conflicts-buffer (dvc-get-buffer-create 'xmtn 'conflicts default-directory))) + (dvc-switch-to-buffer-maybe conflicts-buffer) + (setq buffer-read-only nil) + (xmtn-conflicts-load-opts) + (set (make-local-variable 'after-insert-file-functions) '(xmtn-conflicts-after-insert-file)) + (insert-file-contents "_MTN/conflicts" t nil nil t)))) + +;;;###autoload +(defun xmtn-conflicts-clean (&optional workspace) + "Remove conflicts resolution files from WORKSPACE (a directory; default prompt)." + (interactive) + (let ((default-directory + (dvc-read-project-tree-maybe "Remove conflicts resolutions for (workspace directory): " + (when workspace (expand-file-name workspace))))) + + (if (file-exists-p "_MTN/conflicts") + (delete-file "_MTN/conflicts")) + + (if (file-exists-p xmtn-conflicts-opts-file) + (delete-file xmtn-conflicts-opts-file)) + + (if (file-exists-p "_MTN/resolutions") + (dired-delete-file "_MTN/resolutions" 'always)) + )) + +(provide 'xmtn-conflicts) + +;; end of file diff --git a/dvc/lisp/xmtn-dvc.el b/dvc/lisp/xmtn-dvc.el new file mode 100644 index 0000000..a48bd61 --- /dev/null +++ b/dvc/lisp/xmtn-dvc.el @@ -0,0 +1,1836 @@ +;;; xmtn-dvc.el --- DVC backend for monotone + +;; Copyright (C) 2008 - 2009 Stephen Leake +;; Copyright (C) 2006, 2007, 2008 Christian M. Ohler + +;; Author: Christian M. Ohler +;; 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 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: + +;; This file implements a DVC backend for the distributed version +;; control system monotone. The backend will only work with an +;; appropriate version of the mtn binary installed. + +;;; Code: + +;;; There are some notes on the design of xmtn in +;;; docs/xmtn-readme.txt. + +(eval-and-compile + (require 'cl) + (require 'dvc-unified) + (require 'xmtn-basic-io) + (require 'xmtn-base) + (require 'xmtn-run) + (require 'xmtn-automate) + (require 'xmtn-conflicts) + (require 'xmtn-ids) + (require 'xmtn-match) + (require 'xmtn-minimal) + (require 'dvc-log) + (require 'dvc-diff) + (require 'dvc-status) + (require 'dvc-core) + (require 'ewoc)) + +;; For debugging. +(defun xmtn--load () + (require 'dvc-unified) + (save-some-buffers) + (mapc (lambda (file) + (byte-compile-file file t)) + '("xmtn-minimal.el" + "xmtn-compat.el" + "xmtn-match.el" + "xmtn-base.el" + "xmtn-run.el" + "xmtn-automate.el" + "xmtn-basic-io.el" + "xmtn-ids.el" + "xmtn-dvc.el" + "xmtn-revlist.el"))) +;;; (xmtn--load) + +;;;###autoload +(dvc-register-dvc 'xmtn "monotone") + +(defmacro* xmtn--with-automate-command-output-basic-io-parser + ((parser root-form command-form &key ((:may-kill-p may-kill-p-form))) + &body body) + (declare (indent 1) (debug (sexp body))) + (let ((parser-tmp (gensym)) + (root (gensym)) + (command (gensym)) + (may-kill-p (gensym)) + (session (gensym)) + (handle (gensym))) + `(let ((,root ,root-form) + (,command ,command-form) + (,may-kill-p ,may-kill-p-form)) + (xmtn-automate-with-session (,session ,root) + (xmtn-automate-with-command (,handle + ,session ,command + :may-kill-p ,may-kill-p) + (xmtn-automate-command-check-for-and-report-error ,handle) + (xmtn-automate-command-wait-until-finished ,handle) + (xmtn-basic-io-with-stanza-parser (,parser + (xmtn-automate-command-buffer + ,handle)) + ,@body)))))) + +;;;###autoload +(defun xmtn-dvc-log-edit-file-name-func (&optional root) + (concat (file-name-as-directory (or root (dvc-tree-root))) + "_MTN/log")) + +(defun xmtn--toposort (root revision-hash-ids) + (xmtn-automate-simple-command-output-lines root + `("toposort" + ,@revision-hash-ids))) + +(defun xmtn--insert-log-edit-hints (root branch buffer prefix normalized-files) + (with-current-buffer buffer + (flet ((insert-line (&optional format-string-or-null &rest format-args) + (if format-string-or-null + (let ((line (apply #'format + format-string-or-null format-args))) + (assert (not (position ?\n line))) + (insert prefix line ?\n)) + (assert (endp format-args)) + (insert prefix ?\n)))) + (save-excursion + ;; Launching these mtn processes in parallel is a noticeable + ;; speedup (~14% on some informal benchmarks). At least it + ;; was with the version that I benchmarked, etc. + (xmtn-automate-with-session (nil root) + (let* ((unknown-future (xmtn--unknown-files-future root)) + (missing-future (xmtn--missing-files-future root)) + (consistent-p-future (xmtn--tree-consistent-p-future root)) + (heads (xmtn--heads root branch)) + (inconsistent-p (not (funcall consistent-p-future))) + (revision (if inconsistent-p + nil + (xmtn--get-revision root `(local-tree ,root)))) + (missing (funcall missing-future))) + (when inconsistent-p + (insert-line + "WARNING: Tree is not consistent.") + (insert-line "Commit will fail unless you fix this first.") + (insert-line)) + (when missing + (insert-line "%s missing file(s):" (length missing)) + (dolist (file missing) (insert-line "%s" file)) + (insert-line) + (insert-line)) + (insert-line "Committing on branch:") + (insert-line branch) + (insert-line) + (unless + (let* ((parents (xmtn--revision-old-revision-hash-ids revision)) + (all-parents-are-heads-p + (subsetp parents heads :test #'equal)) + (all-heads-are-parents-p + (subsetp heads parents :test #'equal))) + (cond ((and (not all-heads-are-parents-p) + (not all-parents-are-heads-p)) + (insert-line "This commit will create divergence.") + (insert-line)) + ((not all-heads-are-parents-p) + (insert-line (concat "Divergence will continue to exist" + " after this commit.")) + (insert-line)) + (t + (progn))))) + (case normalized-files + (all + (insert-line "All files selected for commit.")) + (t + (insert-line "File(s) selected for commit:") + ;; Normalized file names are easier to read when coming + ;; from dired buffer, since otherwise, they would contain + ;; the entire path. + (dolist (file + ;; Sort in an attempt to match the order of + ;; "patch" lines, below. + (sort (copy-list normalized-files) #'string<)) + (insert-line "%s" file)))) + ;; Due to the possibility of race conditions, this check + ;; doesn't guarantee the operation will succeed. + (if inconsistent-p + ;; FIXME: Since automate get_revision can't deal with + ;; inconsistent workspaces, we should be using + ;; automate inventory instead. + (progn (insert-line) + (insert-line + (concat "Unable to compute modified files while" + " the tree is inconsistent."))) + (let ((committed-changes (list)) + (other-changes (list))) + (flet ((collect (path message) + (if (or (eql normalized-files 'all) + (member path normalized-files)) + (push message committed-changes) + (push message other-changes)))) + (loop + for (path) in (xmtn--revision-delete revision) + do (collect path (format "delete %s" path))) + (loop + for (from to) in (xmtn--revision-rename revision) + ;; FIXME: collect from or collect to? Monotone + ;; doesn't specify how restrictions work for + ;; renamings. + do (collect to (format "rename %s to %s" from to))) + (loop + for (path) in (xmtn--revision-add-dir revision) + do (collect path (format "add_dir %s" path))) + (loop + for (path contents) + in (xmtn--revision-add-file revision) + do (collect path (format "add_file %s" path))) + (loop + for (path from-contents to-contents) + in (xmtn--revision-patch-file revision) + do (collect path (format "patch %s" path))) + (loop + for (path attr-name) + in (xmtn--revision-clear-attr revision) + do (collect path (format "clear %s %s" + path attr-name))) + (loop + for (path attr-name attr-value) + in (xmtn--revision-set-attr revision) + do (collect path (format "set %s %s %s" + path attr-name attr-value)))) + (setq committed-changes (nreverse committed-changes)) + (setq other-changes (nreverse other-changes)) + (loop + for (lines heading-if heading-if-not) in + `((,committed-changes + ,(format "%s change(s) in selected files:" + (length committed-changes)) + "No changes in selected files.") + (,other-changes + ,(format + "%s change(s) in files not selected for commit:" + (length other-changes)) + "No changes in files not selected for commit.")) + do + (insert-line) + (insert-line "%s" (if lines heading-if heading-if-not)) + (dolist (line lines) (insert-line "%s" line))))) + (let ((unknown (funcall unknown-future))) + (insert-line) + (if (endp unknown) + (insert-line "No unknown files.") + (insert-line "%s unknown file(s):" (length unknown)) + (dolist (file unknown) (insert-line "%s" file)))))))) + (cond ((eql (point) (point-min)) + ;; We take this as an indicator that there is no log message + ;; yet. So insert a blank line. + (insert "\n") + (goto-char (point-min))) + (t + ;; Moving up onto the last line of the log message seems to + ;; be better than having the cursor sit at the ## prefix of + ;; the first line of our hints. + (forward-line -1)))) + nil) + +(add-to-list 'format-alist + '(xmtn--log-file + "This format automatically removes xmtn's log edit hints from +the file before saving." + nil + xmtn--log-file-format-from-fn + xmtn--log-file-format-to-fn + t + nil + nil)) + +(defun xmtn--log-file-format-from-fn (begin end) + (xmtn--assert-nil)) + +(defun xmtn--log-file-format-to-fn (begin end buffer) + (dvc-log-flush-commit-file-list)) + +;;;###autoload +(defun xmtn-dvc-log-edit (root other-frame no-init) + (if no-init + (dvc-dvc-log-edit root other-frame no-init) + (progn + (dvc-dvc-log-edit root other-frame nil) + (setq buffer-file-coding-system 'xmtn--monotone-normal-form) ;; FIXME: move this into dvc-get-buffer-create? + (add-to-list 'buffer-file-format 'xmtn--log-file) ;; FIXME: generalize to dvc--log-file + ))) + +(defun xmtn-dvc-log-message () + "Return --message-file argument string, if any." + (let ((log-edit-file "_MTN/log")) + (if (file-exists-p log-edit-file) + (concat "--message-file=" log-edit-file)))) + +(defun xmtn-dvc-log-clean () + "Delete xmtn log file." + (let ((log-edit-file "_MTN/log")) + (if (file-exists-p log-edit-file) + (delete-file log-edit-file)))) + +;;;###autoload +(defun xmtn-dvc-log-edit-done () + (let* ((root default-directory) + (files (or (with-current-buffer dvc-partner-buffer + (dvc-current-file-list 'nil-if-none-marked)) + 'all)) + (normalized-files + (case files + (all 'all) + (t + ;; Need to normalize in original buffer, since + ;; switching buffers changes default-directory and + ;; therefore the semantics of relative file names. + (with-current-buffer dvc-partner-buffer + (xmtn--normalize-file-names root files))))) + (excluded-files + (with-current-buffer dvc-partner-buffer + (xmtn--normalize-file-names root (dvc-fileinfo-excluded-files)))) + (branch (xmtn--tree-default-branch root))) + ;; Saving the buffer will automatically delete any log edit hints. + (save-buffer) + (dvc-save-some-buffers root) + + ;; check that the first line says something; it should be a summary of the rest + (goto-char (point-min)) + (forward-line) + (if (= (point) (1+ (point-min))) + (error "Please put a summary comment on the first line")) + + ;; We used to check for things that would make commit fail; + ;; missing files, nothing to commit. But that just slows things + ;; down in the typical case; better to just handle the error + ;; message, which is way more informative anyway. + (lexical-let* ((progress-message + (case normalized-files + (all (format "Committing all files in %s" root)) + (t (case (length normalized-files) + (0 (assert nil)) + (1 (format "Committing file %s in %s" + (first normalized-files) root)) + (t + (format "Committing %s files in %s" + (length normalized-files) + root))))))) + (xmtn--run-command-async + root + `("commit" ,(xmtn-dvc-log-message) + ,(concat "--branch=" branch) + ,@(case normalized-files + (all + (if excluded-files + (mapcar (lambda (file) (concat "--exclude=" file)) excluded-files) + '())) + (t (list* + ;; Since we are specifying files explicitly, don't + ;; recurse into specified directories. Also commit + ;; normally excluded files if they are selected. + "--depth=0" + "--" normalized-files)))) + :error (lambda (output error status arguments) + (xmtn-dvc-log-clean) + (dvc-default-error-function output error + status arguments)) + :killed (lambda (output error status arguments) + (xmtn-dvc-log-clean) + (dvc-default-killed-function output error + status arguments)) + :finished (lambda (output error status arguments) + (message "%s... done" progress-message) + ;; Monotone creates an empty log file when the + ;; commit was successful. Let's not interfere with + ;; that. (Calling `dvc-log-close' would.) + (xmtn-dvc-log-clean) + (dvc-diff-clear-buffers 'xmtn + default-directory + "* Just committed! Please refresh buffer" + (xmtn--status-header + default-directory + (xmtn--get-base-revision-hash-id-or-null default-directory))))) + ;; Show message _after_ spawning command to override DVC's + ;; debugging message. + (message "%s... " progress-message)) + (set-window-configuration dvc-pre-commit-window-configuration))) + +;; The term "normalization" here has nothing to do with Unicode +;; normalization. +(defun xmtn--normalize-file-name (root file-name) + (assert root) + (let ((normalized-name (file-relative-name file-name root))) + normalized-name)) + +(defun xmtn--normalize-file-names (root file-names) + (check-type file-names list) + (mapcar (lambda (file-name) (xmtn--normalize-file-name root file-name)) + file-names)) + +(defun xmtn--display-buffer-maybe (buffer dont-switch) + (let ((orig-buffer (current-buffer))) + (if dvc-switch-to-buffer-first + (dvc-switch-to-buffer buffer) + (set-buffer buffer)) + (when dont-switch (pop-to-buffer orig-buffer))) + nil) + +(defun xmtn--status-header (root base-revision) + (let* ((branch (xmtn--tree-default-branch root)) + (head-revisions (xmtn--heads root branch)) + (head-count (length head-revisions))) + + (concat + (format "Status for %s:\n" root) + (if base-revision + (format " base revision %s\n" base-revision) + " tree has no base revision\n") + (format " branch %s\n" branch) + (case head-count + (0 " branch is empty\n") + (1 " branch is merged\n") + (t (dvc-face-add (format " branch has %s heads; need merge\n" head-count) 'dvc-conflict))) + (if (member base-revision head-revisions) + " base revision is a head revision\n" + (dvc-face-add " base revision is not a head revision; need update\n" 'dvc-conflict))))) + +(defun xmtn--refresh-status-header (status-buffer) + (with-current-buffer status-buffer + ;; different modes use different names for the ewoc + ;; FIXME: should have a separate function for each mode + (if dvc-fileinfo-ewoc + (ewoc-set-hf + dvc-fileinfo-ewoc + (xmtn--status-header default-directory (xmtn--get-base-revision-hash-id-or-null default-directory)) + "")))) + +(defun xmtn--parse-diff-for-dvc (changes-buffer) + (let ((excluded-files (dvc-default-excluded-files)) + matched) + (flet ((add-entry + (path status dir &optional orig-path) + (with-current-buffer changes-buffer + (ewoc-enter-last + dvc-fileinfo-ewoc + (if dir + (make-dvc-fileinfo-dir + :mark nil + :exclude (dvc-match-excluded excluded-files path) + :dir (file-name-directory path) + :file (file-name-nondirectory path) + :status status + :more-status "") + (make-dvc-fileinfo-file + :mark nil + :exclude (dvc-match-excluded excluded-files path) + :dir (file-name-directory path) + :file (file-name-nondirectory path) + :status status + :more-status (if orig-path + (if (eq status 'rename-target) + (concat "from " orig-path) + (concat "to " orig-path)) + "")))))) + (likely-dir-p (path) (string-match "/\\'" path))) + + ;; First parse the basic_io contained in dvc-header, if any. + (let ((revision + (with-temp-buffer + (insert dvc-header) + (goto-char (point-min)) + (while (re-search-forward "^# ?" nil t) + (replace-match "")) + (goto-char (point-min)) + (xmtn-basic-io-skip-blank-lines) + (delete-region (point-min) (point)) + (xmtn-basic-io-with-stanza-parser + (parser (current-buffer)) + (xmtn--parse-partial-revision parser))))) + (loop + for (path) in (xmtn--revision-delete revision) + do (add-entry path 'deleted (likely-dir-p path))) + (loop + for (from to) in (xmtn--revision-rename revision) + do (assert (eql (not (likely-dir-p from)) + (not (likely-dir-p to)))) + do (add-entry to 'rename-target (likely-dir-p to) from) + do (add-entry from 'rename-source (likely-dir-p from) to)) + (loop + for (path) in (xmtn--revision-add-dir revision) + do (add-entry path 'added t)) + (loop + for (path contents) + in (xmtn--revision-add-file revision) + do (add-entry path 'added nil)) + (loop + for (path from-contents to-contents) + in (xmtn--revision-patch-file revision) + do (add-entry path 'modified nil)) + ;; Do nothing about clear-attr and set-attr. + )) + + (setq dvc-header + (with-current-buffer changes-buffer + (xmtn--status-header default-directory (xmtn--revision-hash-id dvc-diff-base)))) + nil)) + +;;;###autoload +(defun xmtn-show-base-revision () + "Show the base revision of the current monotone tree in the minibuffer." + (interactive) + (let* ((root (dvc-tree-root)) + (hash-id-or-null (xmtn--get-base-revision-hash-id-or-null root))) + (if hash-id-or-null + (message "Base revision of tree %s is %s" root hash-id-or-null) + (message "Tree %s has no base revision" root)))) + + +;;;###autoload +(defun xmtn-dvc-search-file-in-diff (file) + (re-search-forward + (let ((quoted-file (regexp-quote file))) + (concat "^\\(\\(" + "\\+\\+\\+ " quoted-file + "\\)\\|\\(" + ;; FIXME: What `dvc-diff-diff-or-list' does doesn't work + ;; for this case, since `diff-hunk-next' doesn't recognize + ;; mtn's output for this case as a diff hunk. + "# " quoted-file " is binary" + "\\)\\)$")))) + + +;;;###autoload +(defun xmtn-dvc-diff (&optional rev path dont-switch) + ;; If rev is an ancestor of base-rev of path, then rev is from, path + ;; is 'to', and vice versa. + ;; + ;; Note rev might be a string mtn selector, so we have to use + ;; resolve-revision-id to process it. + (let ((workspace (list 'xmtn (list 'local-tree (xmtn-tree-root path)))) + (base (xmtn--get-base-revision-hash-id-or-null path)) + (rev-string (cadr (xmtn--resolve-revision-id path rev)))) + (if (string= rev-string base) + ;; local changes in workspace are 'to' + (xmtn-dvc-delta rev workspace dont-switch) + (let ((descendents (xmtn-automate-simple-command-output-lines path (list "descendents" base))) + (done nil)) + (while descendents + (if (string= rev-string (car descendents)) + ;; rev is newer than workspace; rev is 'to' + (progn + (xmtn-dvc-delta workspace rev dont-switch) + (setq done t))) + (setq descendents (cdr descendents))) + (if (not done) + ;; rev is ancestor of workspace; workspace is 'to' + (xmtn-dvc-delta rev workspace dont-switch)))))) + +(defvar xmtn-diff-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "CM" 'xmtn-conflicts-merge) + (define-key map "CP" 'xmtn-conflicts-propagate) + (define-key map "CR" 'xmtn-conflicts-review) + (define-key map "CC" 'xmtn-conflicts-clean) + (define-key map "MH" 'xmtn-view-heads-revlist) + (define-key map "MP" 'xmtn-propagate-from) + map)) + +;; items added here should probably also be added to xmtn-revlist-mode-menu, -map in xmtn-revlist.el +(easy-menu-define xmtn-diff-mode-menu xmtn-diff-mode-map + "Mtn specific diff menu." + `("DVC-Mtn" + ["View Heads" xmtn-view-heads-revlist t] + ["Show propagate conflicts" xmtn-conflicts-propagate t] + ["Review conflicts" xmtn-conflicts-review t] + ["Propagate branch" xmtn-propagate-from t] + ["Clean conflicts resolutions" xmtn-conflicts-clean t] + )) + +(define-derived-mode xmtn-diff-mode dvc-diff-mode "xmtn-diff" + "Add back-end-specific commands for dvc-diff.") + +(dvc-add-uniquify-directory-mode 'xmtn-diff-mode) + +(defun xmtn--rev-to-option (resolved from) + "Return a string contaiing the mtn diff command-line option for RESOLVED-REV. +If FROM is non-nil, RESOLVED-REV is assumed older than workspace; +otherwise newer." + (ecase (car resolved) + ('local-tree + (if from + (progn + ;; FIXME: --reverse is not in mtn 0.44; bump overall + ;; required version on new mtn release + (let ((xmtn--minimum-required-command-version '(0 45))) + (xmtn--check-cached-command-version) + "--reverse")) + "")) + ('revision (concat "--revision=" (cadr resolved))))) + +;;;###autoload +(defun xmtn-dvc-delta (from-revision-id to-revision-id &optional dont-switch) + ;; See dvc-unified.el dvc-delta for doc string. If strings, they must be mtn selectors. + (let* ((root (dvc-tree-root)) + (from-resolved (xmtn--resolve-revision-id root from-revision-id)) + (to-resolved (xmtn--resolve-revision-id root to-revision-id))) + (let ((diff-buffer + (dvc-prepare-changes-buffer `(xmtn ,from-resolved) `(xmtn ,to-resolved) 'diff root 'xmtn)) + (rev-specs (list (xmtn--rev-to-option from-resolved t) + (xmtn--rev-to-option to-resolved nil)))) + (buffer-disable-undo diff-buffer) + (dvc-save-some-buffers root) + (lexical-let* ((diff-buffer diff-buffer)) + (xmtn--run-command-async + root `("diff" ,@rev-specs) + :related-buffer diff-buffer + :finished + (lambda (output error status arguments) + (with-current-buffer output + (xmtn--remove-content-hashes-from-diff)) + (dvc-show-changes-buffer output 'xmtn--parse-diff-for-dvc + diff-buffer t "^=")))) + + (xmtn--display-buffer-maybe diff-buffer dont-switch) + + ;; The call site in `dvc-revlist-diff' needs this return value. + diff-buffer))) + +(defvar xmtn-status-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "CM" 'xmtn-conflicts-merge) + (define-key map "CP" 'xmtn-conflicts-propagate) + (define-key map "CR" 'xmtn-conflicts-review) + (define-key map "CC" 'xmtn-conflicts-clean) + (define-key map "MP" 'xmtn-propagate-from) + (define-key map "MH" 'xmtn-view-heads-revlist) + map)) + +(easy-menu-define xmtn-status-mode-menu xmtn-status-mode-map + "Mtn specific status menu." + `("DVC-Mtn" + ["View Heads" xmtn-view-heads-revlist t] + ["Show merge conflicts" xmtn-conflicts-merge t] + ["Show propagate conflicts" xmtn-conflicts-propagate t] + ["Review conflicts" xmtn-conflicts-review t] + ["Propagate branch" xmtn-propagate-from t] + ["Clean conflicts resolutions" xmtn-conflicts-clean t] + )) + +(define-derived-mode xmtn-status-mode dvc-status-mode "xmtn-status" + "Add back-end-specific commands for dvc-status.") + +(add-to-list 'uniquify-list-buffers-directory-modes 'xmtn-status-mode) + +(defun xmtn--remove-content-hashes-from-diff () + ;; Hack: Remove mtn's file content hashes from diff headings since + ;; `dvc-diff-diff-or-list' and `dvc-diff-find-file-name' gets + ;; confused by them. + (save-excursion + (goto-char (point-min)) + (while + (re-search-forward + "^\\(\\+\\+\\+\\|---\\) \\(.*\\)\\(\t[0-9a-z]\\{40\\}\\)$" + nil t) + (replace-match "" t nil nil 3)))) + + +(defun xmtn--simple-finished-notification (buffer) + (lexical-let ((buffer buffer)) + (lambda (output error status arguments) + (message "Process %s finished" buffer)))) + +;;;###autoload +(defun xmtn-dvc-command-version () + (fourth (xmtn--command-version xmtn-executable))) + +(defvar xmtn-dvc-automate-version nil + "Cached value of mtn automate interface version.") + +(defun xmtn-dvc-automate-version () + "Return mtn automate version as a number." + (if xmtn-dvc-automate-version + xmtn-dvc-automate-version + (setq xmtn-dvc-automate-version + (string-to-number (xmtn--command-output-line nil '("automate" "interface_version")))))) + +(defun xmtn--unknown-files-future (root) + (xmtn--command-output-lines-future root '("ls" "unknown"))) + +(defun xmtn--missing-files-future (root) + (xmtn--command-output-lines-future root '("ls" "missing"))) + +(defun xmtn--tree-consistent-p-future (root) + ;; FIXME: Should also check for file/dir mismatches. + (lexical-let ((missing-files-future (xmtn--missing-files-future root))) + (lambda () + (null (funcall missing-files-future))))) + +(defun xmtn--changes-image (change) + (ecase change + (content "content") + (attrs "attrs "))) + +(defun xmtn--status-process-entry (ewoc path status changes old-path new-path + old-type new-type fs-type + excluded-files) + "Create a file entry in ewoc." + ;; Don't display root directory (""); if requested, don't + ;; display known or ignored files. + (if (and (or (not (equal '(known) status)) + (member 'content changes) + dvc-status-display-known) + (or (not (equal '(ignored) status)) + dvc-status-display-ignored) + (not (equal path ""))) + (let ((main-status + (or + (if (member 'added status) 'added) + (if (member 'deleted status) 'deleted) + (if (member 'ignored status) 'ignored) + (if (member 'invalid status) 'invalid) + (if (member 'missing status) 'missing) + (if (member 'rename-source status) 'rename-source) + (if (member 'rename-target status) 'rename-target) + (if (member 'unknown status) 'unknown) + ;; check for known last; almost everything is known + (if (member 'known status) + (if (member 'content changes) + 'modified + 'known)))) + + (indexed (not (eq status 'missing))) ;; in terse mode, missing is represented as "D?" + (more-status "") + basic-need-more-status) + + (setq basic-need-more-status + (or (not (equal status (list main-status))) + (not (eq changes nil)))) + + (case main-status + (added + ;; if the file has been modified since is was marked + ;; 'added', that's still just 'added', so we never need to + ;; do anything here. + nil) + + ((deleted missing) + (if basic-need-more-status + (setq more-status + (concat + (mapconcat 'dvc-fileinfo-status-image-full (delq main-status status) " ") + (mapconcat 'xmtn--changes-image changes " "))))) + + ((ignored invalid) nil) + + + (rename-source + (setq more-status + (concat "to " new-path))) + + (rename-target + (setq more-status + (concat "from " old-path))) + + (modified + (if (and (equal status '(known)) + (equal changes '(content))) + ;; just modified, nothing else + nil + (if basic-need-more-status + (setq more-status + (concat + (mapconcat 'dvc-fileinfo-status-image-full (delq main-status status) " ") + (mapconcat 'xmtn--changes-image changes " ")))))) + + (known + (if basic-need-more-status + (setq more-status + (concat + (mapconcat 'dvc-fileinfo-status-image-full (delq main-status status) " ") + (mapconcat 'xmtn--changes-image changes " "))))) + ) + + (case (if (equal fs-type 'none) + (if (equal old-type 'none) + new-type + old-type) + fs-type) + (directory + (ewoc-enter-last ewoc + (make-dvc-fileinfo-dir + :mark nil + :exclude (dvc-match-excluded excluded-files path) + :dir (file-name-directory path) + :file (file-name-nondirectory path) + :status main-status + :indexed indexed + :more-status more-status))) + ((file none) + ;; 'none' indicates a dropped (deleted) file + (ewoc-enter-last ewoc + (make-dvc-fileinfo-file + :mark nil + :exclude (dvc-match-excluded excluded-files path) + :dir (file-name-directory path) + :file (file-name-nondirectory path) + :status main-status + :indexed indexed + :more-status more-status))) + (t + (error "path %s fs-type %s old-type %s new-type %s" path fs-type old-type new-type)) + )))) + +(defun xmtn--parse-inventory (stanza-parser fn) + (loop for stanza = (funcall stanza-parser) + while stanza do + (xmtn-match stanza + ((("path" (string $path)) + . $rest) + (let* ((status (loop for entry in (cdr (assoc "status" rest)) + collect + (xmtn-match entry + ((string "added") 'added) + ((string "dropped") 'deleted) + ((string "invalid") 'invalid) + ((string "known") 'known) + ((string "missing") 'missing) + ((string "ignored") 'ignored) + ((string "unknown") 'unknown) + ((string "rename_target") 'rename-target) + ((string "rename_source") 'rename-source)))) + (fs-type (xmtn-match (cdr (assoc "fs_type" rest)) + (((string "file")) 'file) + (((string "directory")) 'directory) + (((string "none")) 'none))) + (old-type (xmtn-match (cdr (assoc "new_type" rest)) + (((string "file")) 'file) + (((string "directory")) 'directory) + (nil 'none))) + (new-type (xmtn-match (cdr (assoc "new_type" rest)) + (((string "file")) 'file) + (((string "directory")) 'directory) + (nil 'none))) + (changes (loop for entry in (cdr (assoc "changes" rest)) + collect + (xmtn-match entry + ((string "content") 'content) + ((string "attrs") 'attrs)))) + (old-path-or-null (xmtn-match (cdr (assoc "old_path" rest)) + (((string $old-path)) old-path) + (nil nil))) + (new-path-or-null (xmtn-match (cdr (assoc "new_path" rest)) + (((string $new-path)) new-path) + (nil nil))) + ) + (funcall fn + path + status + changes + old-path-or-null + new-path-or-null + old-type + new-type + fs-type)))))) + +(defun xmtn--status-using-inventory (root) + ;; We don't run automate inventory through xmtn-automate here as + ;; that would block. xmtn-automate doesn't support asynchronous + ;; command execution yet. + (let* + ((base-revision (xmtn--get-base-revision-hash-id-or-null root)) + (branch (xmtn--tree-default-branch root)) + (head-revisions (xmtn--heads root branch)) + (head-count (length head-revisions)) + (status-buffer + (dvc-status-prepare-buffer + 'xmtn + root + ;; FIXME: just pass header + ;; base-revision + (if base-revision (format "%s" base-revision) "none") + ;; branch + (format "%s" branch) + ;; header-more + (lambda () + (concat + (case head-count + (0 " branch is empty\n") + (1 " branch is merged\n") + (t (dvc-face-add (format " branch has %s heads; need merge\n" head-count) 'dvc-conflict))) + (if (member base-revision head-revisions) + " base revision is a head revision\n" + (dvc-face-add " base revision is not a head revision; need update\n" 'dvc-conflict)))) + ;; refresh + 'xmtn-dvc-status))) + (dvc-save-some-buffers root) + (lexical-let* ((status-buffer status-buffer)) + (xmtn--run-command-async + root `("automate" "inventory" + ,@(and (xmtn--have-no-ignore) + (not dvc-status-display-known) + '("--no-unchanged")) + ,@(and (xmtn--have-no-ignore) + (not dvc-status-display-ignored) + '("--no-ignored"))) + :finished (lambda (output error status arguments) + (dvc-status-inventory-done status-buffer) + (with-current-buffer status-buffer + (let ((excluded-files (dvc-default-excluded-files))) + (xmtn-basic-io-with-stanza-parser + (parser output) + (xmtn--parse-inventory + parser + (lambda (path status changes old-path new-path + old-type new-type fs-type) + (xmtn--status-process-entry dvc-fileinfo-ewoc + path status + changes + old-path new-path + old-type new-type + fs-type + excluded-files)))) + (when (not (ewoc-locate dvc-fileinfo-ewoc)) + (ewoc-enter-last dvc-fileinfo-ewoc + (make-dvc-fileinfo-message + :text (concat " no changes in workspace"))) + (ewoc-refresh dvc-fileinfo-ewoc))))) + :error (lambda (output error status arguments) + ;; FIXME: need `dvc-status-error-in-process', or change name. + (dvc-diff-error-in-process + status-buffer + (format "Error running mtn with arguments %S" arguments) + output error)) + :killed (lambda (output error status arguments) + ;; Create an empty buffer as a fake output buffer to + ;; avoid printing all the output so far. + (with-temp-buffer + (dvc-diff-error-in-process + status-buffer + (format "Received signal running mtn with arguments %S" + arguments) + (current-buffer) error))))))) + +;;;###autoload +(defun xmtn-dvc-status () + "Display status of monotone tree at `default-directory'." + (xmtn--status-using-inventory default-directory)) + +;;;###autoload +(defun xmtn-dvc-revision-direct-ancestor (revision-id) + (let* ((root (dvc-tree-root)) + (resolved-id (xmtn--resolve-revision-id root revision-id))) + `(xmtn ,(xmtn--resolve-backend-id root + `(previous-revision ,resolved-id 1))))) + +;;;###autoload +(defun xmtn-dvc-name-construct (backend-revision) + (check-type backend-revision xmtn--hash-id) + backend-revision) + +(defun xmtn--mtnignore-file-name (root) + (concat (file-name-as-directory root) ".mtn-ignore")) + +;;;###autoload +(defun xmtn-dvc-edit-ignore-files () + (find-file-other-window (xmtn--mtnignore-file-name (dvc-tree-root)))) + +(defun xmtn--quote-string-as-partial-perl-regexp (string) + ;; The set of file names/patterns to be ignored by monotone is + ;; customizable by the user through a hook. So we can't guarantee + ;; that writing something to .mtn-ignore really has the desired + ;; effect. However, we implement the correct behavior for the + ;; default hook. + ;; + ;; The default hook uses the function regex.search, which is defined + ;; in lua.cc, which, as of monotone revision + ;; 341e4a18c594cec49896fa97bd4e74de7bee5827, uses Boost.Regex with + ;; the default settings (Perl syntax). + ;; + ;; http://www.boost.org/libs/regex/doc/syntax_perl.html describes + ;; this syntax. This implementation is based on that description. + (let ((special-chars ".[{()\*+?|^$")) + (with-output-to-string + (loop for char across string + do + (when (position char special-chars) (write-char ?\\)) + (write-char char))))) + +(defun xmtn--perl-regexp-for-extension (extension) + (format "\\.%s$" (xmtn--quote-string-as-partial-perl-regexp extension))) + +(defun xmtn--perl-regexp-for-file-name (file-name) + (format "^%s$" (xmtn--quote-string-as-partial-perl-regexp file-name))) + +(defun xmtn--perl-regexp-for-files-in-directory (directory-file-name) + (format "^%s" (xmtn--quote-string-as-partial-perl-regexp + (file-name-as-directory directory-file-name)))) + +(defun xmtn--perl-regexp-for-extension-in-dir (file-name) + (format "^%s.*\\.%s$" + (xmtn--quote-string-as-partial-perl-regexp + (file-name-directory file-name)) + (xmtn--quote-string-as-partial-perl-regexp + (file-name-extension file-name)))) + +(defun xmtn--add-patterns-to-mtnignore (root patterns interactive-p) + (save-window-excursion + ;; use 'find-file-other-window' to preserve current state if + ;; user is already visiting the ignore file. + (find-file-other-window (xmtn--mtnignore-file-name root)) + (save-excursion + (let ((modified-p nil)) + (loop for pattern in patterns + do + (goto-char (point-min)) + (unless (re-search-forward (concat "^" (regexp-quote pattern) + "$") + nil t) + (goto-char (point-max)) + (unless (bolp) (insert "\n")) + (insert pattern "\n") + (setq modified-p t))) + (when modified-p + ;; 'sort-lines' moves all markers, which defeats save-excursion. Oh well! + (sort-lines nil (point-min) (point-max)) + (if (and interactive-p + dvc-confirm-ignore) + (lexical-let ((buffer (current-buffer))) + (save-some-buffers nil (lambda () + (eql (current-buffer) buffer)))) + (save-buffer)))))) + nil) + +;;;###autoload +(defun xmtn-dvc-ignore-files (file-names) + (assert (not (endp file-names))) + (let* ((root (dvc-tree-root)) + (normalized-file-names (xmtn--normalize-file-names root file-names)) + (msg (case (length file-names) + (1 (format "%s" (first normalized-file-names))) + (t (format "%s files/directories" + (length normalized-file-names)))))) + ;; FIXME: confirm should be in upper level DVC code. + (when (or (not dvc-confirm-ignore) + (y-or-n-p (format "Ignore %s in monotone tree %s? " msg root))) + (xmtn--add-patterns-to-mtnignore + root + (let ((default-directory root)) + (mapcan (lambda (file-name) + (if (or (file-symlink-p file-name) + (xmtn--have-no-ignore) + (not (file-directory-p file-name))) + (list (xmtn--perl-regexp-for-file-name file-name)) + + ;; If mtn automate inventory doesn't support + ;; --no-ignore, it also recurses into unknown + ;; directories, so we need to ignore files in + ;; this directory as well as the directory + ;; itself. + (setq file-name (directory-file-name file-name)) + (list + (xmtn--perl-regexp-for-file-name file-name) + (xmtn--perl-regexp-for-files-in-directory file-name)))) + normalized-file-names)) + t)))) + +;;;###autoload +(defun xmtn-dvc-backend-ignore-file-extensions (extensions) + (xmtn--add-patterns-to-mtnignore + (dvc-tree-root) + (mapcar #'xmtn--perl-regexp-for-extension extensions) + t)) + +;;;###autoload +(defun xmtn-dvc-backend-ignore-file-extensions-in-dir (file-list) + (xmtn--add-patterns-to-mtnignore + (dvc-tree-root) + (mapcar #'xmtn--perl-regexp-for-extension-in-dir file-list) + t)) + +(defun xmtn--add-files (root file-names) + (dolist (file-name file-names) + ;; I don't know how mtn handles symlinks (and symlinks to + ;; directories), so forbid them for now. + (assert (not (file-symlink-p file-name)))) + (setq file-names (xmtn--normalize-file-names root file-names)) + (xmtn--run-command-sync root + `("add" "--" ,@file-names))) + +(defun xmtn--file-registered-p (root file-name) + ;; FIXME: need a better way to implement this + (let ((normalized-file-name (xmtn--normalize-file-name root file-name))) + (block parse + (xmtn--with-automate-command-output-basic-io-parser + (parser root `("inventory")) + (xmtn--parse-inventory parser + (lambda (path status changes old-path new-path + old-type new-type fs-type) + (when (equal normalized-file-name path) + (return-from parse + t))))) + nil))) + +;;;###autoload +(defun xmtn-dvc-add-files (&rest files) + (xmtn--add-files (dvc-tree-root) files)) + +;; Appears redundant, given that there is `xmtn-dvc-add-files'. But +;; it's part of the DVC API. FIXME. +;;;###autoload +(defun xmtn-dvc-add (file) + (xmtn--add-files (dvc-tree-root) (list file))) + +(defun xmtn--do-remove (root file-names do-not-execute) + (xmtn--run-command-sync + root `("drop" + ,@(if do-not-execute `("--bookkeep-only") `()) + "--" ,@(xmtn--normalize-file-names root file-names))) + ;; return t to indicate we succeeded + t) + +;;;###autoload +(defun xmtn-dvc-remove-files (&rest files) + (xmtn--do-remove (dvc-tree-root) files nil)) + +;;;###autoload +(defun xmtn-dvc-rename (from-name to-name bookkeep-only) + ;; See `dvc-rename' for doc string. + (let ((root (dvc-tree-root))) + (let ((to-normalized-name (xmtn--normalize-file-name root to-name)) + (from-normalized-name (xmtn--normalize-file-name root from-name))) + (xmtn--run-command-sync + root `("rename" + ,@(if bookkeep-only `("--bookkeep-only") `()) + "--" ,from-normalized-name ,to-normalized-name)))) + ;; FIXME: We should do something analogous to + ;; `dvc-revert-some-buffers' (but for renaming) here. But DVC + ;; doesn't provide a function for that. + ) + +(defun xmtn--insert-hint-into-process-buffer (string) + (let ((inhibit-read-only t) + deactivate-mark) + (save-excursion + (let ((start (point))) + (insert string) + (let ((end (1- (point)))) + (add-text-properties start end '(face (:slant italic)))))))) + +(defun xmtn--run-command-that-might-invoke-merger (root command post-process) + ;; Run async, not sync; it might recursively invoke emacsclient for + ;; merging; and we might need to send an enter keystroke when + ;; finished. + (lexical-let ((post-process post-process)) + (xmtn--run-command-async + root command + :finished + (lambda (output error status arguments) + (with-current-buffer output + (save-excursion + (goto-char (point-max)) + (xmtn--insert-hint-into-process-buffer "[process finished]\n"))) + (if post-process + (funcall post-process))) + :error + (lambda (output error status arguments) + (with-current-buffer output + (save-excursion + (goto-char (point-max)) + (xmtn--insert-hint-into-process-buffer + "[process terminated with an error]\n") + (dvc-show-error-buffer error)))))) + ;; Show process buffer. Monotone might spawn an external merger and + ;; ask the user to hit enter when finished. + (dvc-show-process-buffer) + (goto-char (point-min)) + (xmtn--insert-hint-into-process-buffer + (substitute-command-keys + (concat + "This buffer will show the output of the mtn subprocess, if any." + "\nTo send an \"enter\" keystroke to mtn, use" + " \\[xmtn-send-enter-to-subprocess]" + "\nin this buffer. This might be necessary" + " if mtn launches an external merger." + "\nWhen mtn has finished, just bury this buffer, or kill it." + "\n"))) + (goto-char (point-max)) + ;; I don't think DVC's process filter can deal with read-only + ;; buffers yet. + ;;(setq buffer-read-only t) + ) + +;;;###autoload +(defun xmtn-send-enter-to-subprocess () + "Send an \"enter\" keystroke to a monotone subprocess. + +To be used in an xmtn process buffer. Useful when monotone +spawns an external merger and asks you to hit enter when +finished." + (interactive) + (let ((process (loop for (process nil) in dvc-process-running + when (eql (current-buffer) (process-buffer process)) + return process))) + (unless process + (error "No active process for buffer %s found" (current-buffer))) + (process-send-string process "\n") + (save-excursion + (goto-char (point-max)) + (xmtn--insert-hint-into-process-buffer "[sent enter keystroke]\n")))) + +;;; It's kind of a wart that these "xmtn--do-" functions +;;; don't have the same contract with respect to +;;; synchronousness/asynchronousness, progress messages and return +;;; value. + +(defun xmtn--do-explicit-merge (root left-revision-hash-id right-revision-hash-id + destination-branch-name) + (check-type root string) + (check-type left-revision-hash-id xmtn--hash-id) + (check-type right-revision-hash-id xmtn--hash-id) + (check-type destination-branch-name string) + (xmtn--run-command-that-might-invoke-merger root + `("explicit_merge" + "--" + ,left-revision-hash-id + ,right-revision-hash-id + ,destination-branch-name) + nil) + nil) + +(defun xmtn--do-disapprove-future (root revision-hash-id) + ;; Returns a future so the calling code can block on its completion + ;; if it wants to. + (check-type root string) + (check-type revision-hash-id xmtn--hash-id) + (xmtn--command-output-lines-future root `("disapprove" ,revision-hash-id))) + +(defun xmtn--do-update (root target-revision-hash-id) + (check-type root string) + (check-type target-revision-hash-id xmtn--hash-id) + (lexical-let ((progress-message (format "Updating tree %s to revision %s" + root target-revision-hash-id))) + (let ((command `("update" "--move-conflicting-paths" ,(concat "--revision=" target-revision-hash-id))) + (post-process + (lambda () + (message "%s... done" progress-message) + (dvc-revert-some-buffers default-directory) + (dvc-diff-clear-buffers 'xmtn + default-directory + "* Just updated; please refresh buffer" + (xmtn--status-header + default-directory + (xmtn--get-base-revision-hash-id-or-null default-directory))))) + ) + + (message "%s..." progress-message) + ;; this used to have an option to call '--might-invoke-merger'; could be simplified. + (xmtn--run-command-sync root command) + (funcall post-process)) + nil)) + +(defun xmtn--update (root target-revision-hash-id) + ;; mtn will just give an innocuous message if already updated, which + ;; the user won't see. So check that here - it's fast. + (when (equal (xmtn--get-base-revision-hash-id root) target-revision-hash-id) + (error "Tree %s is already based on target revision %s" + root target-revision-hash-id)) + (dvc-save-some-buffers root) + (xmtn--do-update root target-revision-hash-id)) + +;;;###autoload +(defun xmtn-dvc-update (&optional revision-id) + (let ((root (dvc-tree-root))) + (xmtn-automate-with-session (nil root) + (if revision-id + (xmtn--update root (xmtn--revision-hash-id revision-id)) + + (let* ((branch (xmtn--tree-default-branch root)) + (heads (xmtn--heads root branch))) + (case (length heads) + (0 (assert nil)) + (1 + (xmtn--update root (first heads))) + + (t + ;; User can choose one head from a revlist, or merge them. + (error (substitute-command-keys + (concat "Branch %s is unmerged (%s heads)." + " Try \\[xmtn-view-heads-revlist] and \\[dvc-merge] or \\[dvc-revlist-update]")) + branch (length heads)))))))) + nil) + +(defun xmtn-propagate-from (other) + "Propagate from OTHER branch to local tree branch." + (interactive "MPropagate from branch: ") + (let* + ((root (dvc-tree-root)) + (local-branch (xmtn--tree-default-branch root)) + (resolve-conflicts + (if (file-exists-p (concat root "/_MTN/conflicts")) + (progn + "--resolve-conflicts-file=_MTN/conflicts"))) + (cmd (list "propagate" other local-branch resolve-conflicts + (xmtn-dvc-log-message))) + (prompt + (if resolve-conflicts + (concat "Propagate from " other " to " local-branch " resolving conflicts? ") + (concat "Propagate from " other " to " local-branch "? ")))) + + (save-some-buffers t); conflicts file may be open. + + (if xmtn-confirm-operation + (if (not (yes-or-no-p prompt)) + (error "user abort"))) + + (lexical-let + ((display-buffer (current-buffer)) + (msg (mapconcat (lambda (item) item) cmd " "))) + (message "%s..." msg) + (if xmtn-confirm-operation + (xmtn--run-command-that-might-invoke-merger + root cmd + (lambda () + (xmtn--refresh-status-header display-buffer) + (message "%s... done" msg))) + (xmtn--run-command-sync + root cmd + :finished (lambda (output error status arguments) + (xmtn--refresh-status-header display-buffer) + (message "%s... done" msg))))))) + +;;;###autoload +(defun xmtn-dvc-merge (&optional other) + (if other + (xmtn-propagate-from other) + ;; else merge heads + (let* ((root (dvc-tree-root)) + (resolve-conflicts + (if (file-exists-p (concat root "/_MTN/conflicts")) + (progn + "--resolve-conflicts-file=_MTN/conflicts")))) + (lexical-let + ((display-buffer (current-buffer))) + (xmtn-automate-with-session + (nil root) + (let* ((branch (xmtn--tree-default-branch root)) + (heads (xmtn--heads root branch))) + (case (length heads) + (0 (assert nil)) + (1 + (message "already merged")) + (t + (xmtn--run-command-that-might-invoke-merger + root + (list "merge" resolve-conflicts (xmtn-dvc-log-message)) + (lambda () (xmtn--refresh-status-header display-buffer)))))))))) + nil) + +;;;###autoload +(defun xmtn-dvc-pull (&optional other) + "Implement `dvc-pull' for xmtn." + (lexical-let* + ((root (dvc-tree-root)) + (name (concat "mtn pull " root))) + (message "%s..." name) + ;; mtn progress messages are put to stderr, and there is typically + ;; nothing written to stdout from this command, so put both in the + ;; same buffer. + ;; FIXME: this output is not useful; need to use automation + (xmtn--run-command-async root `("pull" ,other) + :output-buffer name + :error-buffer name + :finished + (lambda (output error status arguments) + (pop-to-buffer output) + (message "%s... done" name))))) + +;;;###autoload +(defun xmtn-dvc-revert-files (&rest file-names) + (when (stringp file-names) (setq file-names (list file-names))) + (let ((root (dvc-tree-root))) + (assert (not (endp file-names))) + (dvc-save-some-buffers root) + (let ((normalized-file-names (xmtn--normalize-file-names root file-names))) + (lexical-let + ((root root) + (progress-message + (if (eql (length file-names) 1) + (format "Reverting file %s" (first file-names)) + (format "Reverting %s files" (length file-names))))) + (message "%s..." progress-message) + (xmtn--run-command-sync root `("revert" "--" + ,@normalized-file-names) + :finished + (lambda (output error status arguments) + (message "%s... done" progress-message))) + (dvc-revert-some-buffers root)))) + nil) + +;;;###autoload +(defun xmtn-revision-get-previous-revision (file revision-id) + (xmtn--revision-get-file-helper file (list 'previous-revision (cadr revision-id)))) + +;;;###autoload +(defun xmtn-revision-get-last-revision (file stuff) + (xmtn--revision-get-file-helper file `(last-revision ,@stuff))) + +;;;###autoload +(defun xmtn-revision-get-file-revision (file stuff) + (xmtn--revision-get-file-helper file `(revision ,@stuff))) + +(defun xmtn--revision-get-file-helper (file backend-id) + "Fill current buffer with the contents of FILE revision BACKEND-ID." + (let ((root (dvc-tree-root))) + (xmtn-automate-with-session (nil root) + (let* ((normalized-file (xmtn--normalize-file-name root file)) + (corresponding-file + (xmtn--get-corresponding-path root normalized-file + `(local-tree ,root) backend-id))) + (if (null corresponding-file) + ;; File doesn't exist. Since this function is (as far + ;; as I know) only called from diff-like functions, a + ;; missing file is not an error but just means the diff + ;; should be computed against an empty file. So just + ;; leave the buffer empty. + (progn) + (let ((temp-dir nil)) + (unwind-protect + (progn + (setq temp-dir (xmtn--make-temp-file + "xmtn--revision-get-file-" t)) + ;; Going through a temporary file and using + ;; `insert-file-contents' in conjunction with as + ;; much of the original file name as possible seems + ;; to be the best way to make sure that Emacs' + ;; entire file coding system detection logic is + ;; applied. Functions like + ;; `find-operation-coding-system' and + ;; `find-file-name-handler' are not a complete + ;; replacement since they don't look at the contents + ;; at all. + (let ((temp-file (concat temp-dir "/" corresponding-file))) + (make-directory (file-name-directory temp-file) t) + (with-temp-file temp-file + (xmtn--set-buffer-multibyte nil) + (setq buffer-file-coding-system 'binary) + (xmtn--insert-file-contents-by-name root backend-id corresponding-file (current-buffer))) + (let ((output-buffer (current-buffer))) + (with-temp-buffer + (insert-file-contents temp-file) + (let ((input-buffer (current-buffer))) + (with-current-buffer output-buffer + (insert-buffer-substring input-buffer))))))) + (when temp-dir + (dvc-delete-recursively temp-dir))))))))) + +(defun xmtn--get-file-by-id (root file-id save-as) + "Store contents of FILE-ID in file SAVE-AS." + (xmtn-automate-with-session + (nil root) + (with-temp-file save-as + (xmtn--set-buffer-multibyte nil) + (setq buffer-file-coding-system 'binary) + (xmtn--insert-file-contents root file-id (current-buffer))))) + +(defun xmtn--revision-parents (root revision-hash-id) + (xmtn-automate-simple-command-output-lines root + `("parents" ,revision-hash-id))) + +(defun xmtn--get-content-changed (root backend-id normalized-file) + (xmtn-automate-with-session (nil root) + (xmtn-match (xmtn--resolve-backend-id root backend-id) + ((local-tree $path) (error "Not implemented")) + ((revision $revision-hash-id) + (xmtn--with-automate-command-output-basic-io-parser + (parser root `("get_content_changed" ,revision-hash-id + ,normalized-file)) + (loop for stanza = (funcall parser) + while stanza + collect (xmtn-match stanza + ((("content_mark" (id $previous-id))) + previous-id)))))))) + +(defun xmtn--limit-length (list n) + (or (null n) (<= (length list) n))) + +(defun xmtn--close-set (fn initial-set last-n) + (let ((new-elements initial-set) + (current-set nil)) + (while (and new-elements (xmtn--limit-length current-set last-n)) + (let ((temp-elements nil) + (next-elements nil) + (new-element nil)) + (while new-elements + (setq new-element (car new-elements)) + (setq temp-elements (funcall fn new-element)) + (setq current-set (append (set-difference temp-elements current-set :test #'equal) current-set)) + (setq next-elements (append temp-elements next-elements)) + (setq new-elements (cdr new-elements))) + (setq new-elements next-elements))) + current-set)) + +(defun xmtn--get-content-changed-closure (root backend-id normalized-file last-n) + (xmtn-automate-with-session (nil root) + (lexical-let ((root root)) + (labels ((changed-self-or-ancestors (entry) + (destructuring-bind (hash-id file-name) entry + (check-type file-name string) + ;; get-content-changed can return one or two revisions + (loop for next-change-id in (xmtn--get-content-changed + root `(revision ,hash-id) + file-name) + for corresponding-path = + (xmtn--get-corresponding-path-raw root file-name + hash-id next-change-id) + when corresponding-path + collect `(,next-change-id ,corresponding-path)))) + (changed-proper-ancestors (entry) + (destructuring-bind (hash-id file-name) entry + (check-type file-name string) + ;; revision-parents can return one or two revisions + (loop for parent-id in (xmtn--revision-parents root hash-id) + for path-in-parent = + (xmtn--get-corresponding-path-raw root file-name + hash-id parent-id) + when path-in-parent + append (changed-self-or-ancestors + `(,parent-id ,path-in-parent)))))) + (xmtn--close-set + #'changed-proper-ancestors + (xmtn-match (xmtn--resolve-backend-id root backend-id) + ((local-tree $path) (error "Not implemented")) + ((revision $id) (changed-self-or-ancestors + `(,id ,normalized-file)))) + last-n))))) + + +(defun xmtn--get-corresponding-path-raw (root normalized-file-name + source-revision-hash-id + target-revision-hash-id) + (check-type normalized-file-name string) + (xmtn--with-automate-command-output-basic-io-parser + (next-stanza root `("get_corresponding_path" + ,source-revision-hash-id + ,normalized-file-name + ,target-revision-hash-id)) + (xmtn-match (funcall next-stanza) + (nil nil) + ((("file" (string $result))) + (assert (null (funcall next-stanza))) + result)))) + + +(defun xmtn--get-corresponding-path (root normalized-file-name + source-revision-backend-id + target-revision-backend-id) + (block get-corresponding-path + (xmtn-automate-with-session (nil root) + (let (source-revision-hash-id + target-revision-hash-id + (file-name-postprocessor #'identity)) + (let ((resolved-source-revision + (xmtn--resolve-backend-id root source-revision-backend-id)) + (resolved-target-revision + (xmtn--resolve-backend-id root target-revision-backend-id))) + (xmtn-match resolved-source-revision + ((revision $hash-id) + (setq source-revision-hash-id hash-id)) + ((local-tree $path) + (assert (xmtn--same-tree-p root path)) + (let ((base-revision-hash-id + (xmtn--get-base-revision-hash-id-or-null path))) + (if (null base-revision-hash-id) + (xmtn-match resolved-target-revision + ((revision $hash-id) + (return-from get-corresponding-path nil)) + ((local-tree $target-path) + (assert (xmtn--same-tree-p path target-path)) + (return-from get-corresponding-path normalized-file-name))) + (setq normalized-file-name (xmtn--get-rename-in-workspace-to + path normalized-file-name)) + (setq source-revision-hash-id base-revision-hash-id))))) + (xmtn-match resolved-target-revision + ((revision $hash-id) + (setq target-revision-hash-id hash-id)) + ((local-tree $path) + (assert (xmtn--same-tree-p root path)) + (let ((base-revision-hash-id + (xmtn--get-base-revision-hash-id-or-null path))) + (if (null base-revision-hash-id) + (return-from get-corresponding-path nil) + (setq target-revision-hash-id base-revision-hash-id + file-name-postprocessor + (lexical-let ((path path)) + (lambda (file-name) + (xmtn--get-rename-in-workspace-from path + file-name))))))))) + (let ((result + (xmtn--get-corresponding-path-raw root normalized-file-name + source-revision-hash-id + target-revision-hash-id))) + (if (null result) + nil + (funcall file-name-postprocessor result))))))) + +(defun xmtn--get-rename-in-workspace-from (root normalized-source-file-name) + ;; FIXME: need a better way to implement this + (check-type normalized-source-file-name string) + (block parse + (xmtn--with-automate-command-output-basic-io-parser + (parser root `("inventory")) + (xmtn--parse-inventory parser + (lambda (path status changes old-path new-path + old-type new-type fs-type) + (when (equal normalized-source-file-name + old-path) + (return-from parse + path))))) + normalized-source-file-name)) + +(defun xmtn--get-rename-in-workspace-to (root normalized-target-file-name) + ;; FIXME: need a better way to implement this + (check-type normalized-target-file-name string) + (block parse + (xmtn--with-automate-command-output-basic-io-parser + (parser root `("inventory" ,normalized-target-file-name)) + (xmtn--parse-inventory parser + (lambda (path status changes old-path new-path + old-type new-type fs-type) + (when (and old-path + (equal normalized-target-file-name + path)) + (return-from parse + old-path))))) + normalized-target-file-name)) + +(defun xmtn--manifest-find-file (root manifest normalized-file-name) + (let ((matches (remove* normalized-file-name + (remove* 'file manifest :key #'first :test-not #'equal) + :key #'second :test-not #'equal))) + (xmtn--assert-optional (member (length matches) '(0 1))) + (first matches))) + +(defun xmtn--revision-manifest-file-entry (root backend-id + normalized-file-name) + (let ((manifest (xmtn--get-manifest root backend-id))) + (xmtn--manifest-find-file root manifest normalized-file-name))) + +(defun xmtn--revision-file-contents-hash (root backend-id normalized-file-name) + (xmtn-match (xmtn--revision-manifest-file-entry root backend-id + normalized-file-name) + ((file $relative-path $file-contents-hash $attrs) + (assert (equal relative-path normalized-file-name)) + file-contents-hash))) + +(defun xmtn--file-contents-as-string (root content-hash-id) + (check-type content-hash-id xmtn--hash-id) + (xmtn-automate-simple-command-output-string + root `("get_file" ,content-hash-id))) + +(defun xmtn--insert-file-contents (root content-hash-id buffer) + (check-type content-hash-id xmtn--hash-id) + (xmtn-automate-simple-command-output-insert-into-buffer + root buffer `("get_file" ,content-hash-id))) + +(defun xmtn--insert-file-contents-by-name (root backend-id normalized-file-name buffer) + (let* ((resolved-id (xmtn--resolve-backend-id root backend-id)) + (hash-id (case (car resolved-id) + (local-tree nil) + (revision (cadr resolved-id)))) + (cmd (if hash-id + (cons (list "revision" hash-id) (list "get_file_of" normalized-file-name)) + (list "get_file_of" normalized-file-name)))) + (xmtn-automate-simple-command-output-insert-into-buffer root buffer cmd))) + +(defun xmtn--same-tree-p (a b) + (equal (file-truename a) (file-truename b))) + +(defun xmtn--get-manifest (root backend-id) + (xmtn-automate-with-session (nil root) + (let ((resolved-id (xmtn--resolve-backend-id root backend-id))) + (xmtn--with-automate-command-output-basic-io-parser + (parser root `("get_manifest_of" + ,@(xmtn-match resolved-id + ((local-tree $path) + ;; FIXME: I don't really know what to do if + ;; PATH is not the same as ROOT. Maybe + ;; revision id resolution needs to return + ;; the proper root, too. + (assert (xmtn--same-tree-p root path)) + (unless (funcall + (xmtn--tree-consistent-p-future root)) + (error "Tree is inconsistent, unable to get manifest")) + '()) + ((revision $hash-id) + `(,hash-id))))) + (assert (equal (funcall parser) '(("format_version" (string "1"))))) + (loop for stanza = (funcall parser) + while stanza + collect (xmtn-match stanza + ((("dir" (string $normalized-path))) + (let ((dir (decode-coding-string + normalized-path + 'xmtn--monotone-normal-form))) + (xmtn--assert-optional + (or (equal dir "") + (not (eql (aref dir (1- (length dir))) ?/)))) + `(dir ,dir))) + ((("file" (string $normalized-path)) + ("content" (id $hash-id)) + . $attrs) + `(file + ,(decode-coding-string + normalized-path 'xmtn--monotone-normal-form) + ,hash-id + ,(mapcar (lambda (attr-entry) + (xmtn-match attr-entry + (("attr" + (string $attr-name) + (string $attr-value)) + (list attr-name attr-value)))) + attrs))))))))) + +(defstruct (xmtn--revision (:constructor xmtn--make-revision)) + ;; matches data output by 'mtn diff' + new-manifest-hash-id + old-revision-hash-ids + delete + rename + add-dir + add-file + patch-file + clear-attr + set-attr + ) + + +(defun xmtn--get-revision (root backend-id) + (xmtn-automate-with-session (nil root) + (let ((resolved-id (xmtn--resolve-backend-id root backend-id))) + (xmtn--with-automate-command-output-basic-io-parser + (parser root `("get_revision" + ,@(xmtn-match resolved-id + ((local-tree $path) + ;; FIXME: I don't really know what to do if + ;; PATH is not the same as ROOT. Maybe + ;; revision id resolution needs to return + ;; the proper root, too. + (assert (xmtn--same-tree-p root path)) + (unless (funcall + (xmtn--tree-consistent-p-future root)) + (error (concat "Tree is inconsistent," + " unable to compute revision"))) + '()) + ((revision $hash-id) + `(,hash-id))))) + (assert (equal (funcall parser) '(("format_version" (string "1"))))) + (let ((new-manifest-hash-id (xmtn-match (funcall parser) + ((("new_manifest" (id $hash-id))) + hash-id)))) + (let ((proto-revision (xmtn--parse-partial-revision parser))) + (setf (xmtn--revision-new-manifest-hash-id proto-revision) + new-manifest-hash-id) + proto-revision)))))) + +(defun xmtn--parse-partial-revision (parser) + "Parse basic_io output from get_revision, starting with the old_revision stanzas." + (let ((old-revision-hash-ids (list)) + (delete (list)) + (rename (list)) + (add-dir (list)) + (add-file (list)) + (patch-file (list)) + (clear-attr (list)) + (set-attr (list))) + (flet ((decode-path (path) + (decode-coding-string path 'xmtn--monotone-normal-form))) + (loop for stanza = (funcall parser) + while stanza + do + (xmtn-match stanza + ;; Most common case, "patch", first. + ((("patch" (string $filename)) + ("from" (id $from-id)) + ("to" (id $to-id))) + (push `(,(decode-path filename) ,from-id ,to-id) + patch-file)) + ((("old_revision" (null-id))) + ;; Why doesn't mtn just skip this stanza? + ) + ((("old_revision" (id $hash-id))) + (push hash-id old-revision-hash-ids)) + ((("delete" (string $path))) + (push `(,(decode-path path)) delete)) + ((("rename" (string $from-path)) + ("to" (string $to-path))) + (push `(,(decode-path from-path) ,(decode-path to-path)) + rename)) + ((("add_dir" (string $path))) + (push `(,(decode-path path)) add-dir)) + ((("add_file" (string $path)) + ("content" (id $file-id))) + (push `(,(decode-path path) ,file-id) + add-file)) + ;; "patch": See above. + ((("clear" (string $path)) + ("attr" (string $attr-name))) + (push `(,(decode-path path) ,attr-name) + clear-attr)) + ((("set" (string $path)) + ("attr" (string $attr-name)) + ("value" (string $attr-value))) + (push `(,(decode-path path) ,attr-name ,attr-value) + set-attr))))) + (setq old-revision-hash-ids (nreverse old-revision-hash-ids) + delete (nreverse delete) + rename (nreverse rename) + add-dir (nreverse add-dir) + add-file (nreverse add-file) + patch-file (nreverse patch-file) + clear-attr (nreverse clear-attr) + set-attr (nreverse set-attr)) + (xmtn--make-revision + :old-revision-hash-ids old-revision-hash-ids + :delete delete + :rename rename + :add-dir add-dir + :add-file add-file + :patch-file patch-file + :clear-attr clear-attr + :set-attr set-attr + ))) + + +;;;###autoload +(defun xmtn-dvc-revision-nth-ancestor (&rest args) + ;; There is a reasonable default implementation to fall back on. It + ;; will just call `xmtn-dvc-revision-direct-ancestor' N times. We + ;; can't do any better than linear-time anyway, since we have to + ;; chase the ancestry links (and check the uniqueness at each step). + (apply #'dvc-dvc-revision-nth-ancestor args)) + +(defalias 'xmtn-dvc-revlist 'xmtn-view-heads-revlist) + +(provide 'xmtn-dvc) + +;;; xmtn-dvc.el ends here diff --git a/dvc/lisp/xmtn-ids.el b/dvc/lisp/xmtn-ids.el new file mode 100644 index 0000000..3da2431 --- /dev/null +++ b/dvc/lisp/xmtn-ids.el @@ -0,0 +1,259 @@ +;;; xmtn-ids.el --- Resolver routines for xmtn revision ids + +;; Copyright (C) 2008, 2009 Stephen Leake +;; Copyright (C) 2006, 2007 Christian M. Ohler + +;; Author: Christian M. Ohler +;; 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 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: + +;; This file is part of xmtn and implements an extension of DVC's +;; REVISION-IDs (see docs/DVC-API) for the monotone backend. +;; +;; We extend DVC's definition of a REVISION-ID for xmtn as follows. +;; This way, previous-revision can contain any nested BACKEND-ID. +;; This simplifies the code and may be useful. +;; +;; REVISION-ID :: (xmtn BACKEND-ID) | "selector" +;; +;; BACKEND-ID :: BACKEND-REVISION +;; | (revision BACKEND-REVISION) +;; ;; An already commited revision +;; | (local-tree PATH) +;; ;; Uncommited revision in the local tree PATH +;; | (last-revision PATH NUM) +;; ;; Last committed revision in tree PATH if NUM = 1 +;; ;; Last but NUM-1 revision in tree PATH if NUM > 1 +;; ;; +;; ;; Note that dvc-dvc-file-diff abuses this syntax and specifies the +;; ;; name of a file inside the tree as PATH. +;; ;; +;; ;; For xmtn, "last committed revision" here refers to the base +;; ;; revision of the tree PATH, not the head in the database. +;; ;; This is because the other backends use `(last-revision ,path +;; ;; 1) as a default base for diffs, and we copy them, so we have +;; ;; to define it this way. +;; | (previous-revision BACKEND-ID NUM) +;; ;; NUMth ancestor of BACKEND-ID. +;; | (previous-revision BACKEND-ID) +;; ;; Parent of BACKEND-ID. (DVC requires this extension but +;; ;; doesn't document it.) +;; +;; PATH :: string +;; +;; NUM :: number +;; +;; BACKEND-REVISION :: a 40-char string containing mtn's hash of 40 hex digits +;; +;; +;; Using the routines below, such IDs can be resolved to +;; RESOLVED-BACKEND-IDs. +;; +;; RESOLVED-BACKEND-ID :: (revision BACKEND-REVISION) +;; | (local-tree PATH) + +;;; Code: + +;;; There are some notes on the design of xmtn in +;;; docs/xmtn-readme.txt. + +(eval-and-compile + (require 'cl) + (require 'xmtn-automate) + (require 'xmtn-match)) + +(defun xmtn--revision-hash-id (revision-id) + "Return the hash-id from a REVISION-ID" + (car (cdadr revision-id))) + +(defun xmtn--resolve-revision-id-1 (root revision-id) + "Resolve dvc REVISION-ID to a RESOLVED-BACKEND-ID." + (ecase (car revision-id) + ('xmtn + (xmtn--resolve-backend-id root (cadr revision-id))))) + +(defun xmtn--resolve-revision-id (root revision-id) + "Resolve REVISION-ID to a RESOLVED-BACKEND-ID. REVISION-ID may +be a dvc revision (list starting with 'xmtn) or a string +containing a mtn selector." + (unless root (setq root (dvc-tree-root))) + (cond + ((listp revision-id) + (xmtn--resolve-revision-id-1 root revision-id)) + ((stringp revision-id) + (xmtn--resolve-revision-id-1 + root + (list 'xmtn (list 'revision (car (xmtn--expand-selector root revision-id)))))) + (t + (error "revision-id must be a list or string")))) + +(defun xmtn--resolve-backend-id (root backend-id) + "Resolve BACKEND-ID to a RESOLVED-BACKEND-ID. + +See file commentary for details." + (let ((resolved-backend-id + (etypecase backend-id + (xmtn--hash-id + (list 'revision backend-id)) + (list + (xmtn-match backend-id + ((revision $backend-revision) + backend-id) + ((local-tree $path) + backend-id) + ((last-revision $path $num) + (xmtn--resolve--last-revision root path num)) + ((previous-revision $base-backend-id . $optional-num) + (destructuring-bind (&optional num) optional-num + (unless num (setq num 1)) + (xmtn--resolve--previous-revision root + base-backend-id + num)))))))) + ;; Small sanity check. Also implicit documentation. + (xmtn-match resolved-backend-id + ((revision $hash-id) (assert (typep hash-id 'xmtn--hash-id))) + ((local-tree $string) (assert (typep string 'string)))) + resolved-backend-id)) + +(defun xmtn--resolve--local-tree (root path) + (check-type path string) + (let ((path-root (xmtn-tree-root path t))) + (unless (and path-root + (equal (file-truename path-root) + (file-truename path))) + (error "Path is not the root of a monotone tree: %S" `(local-tree ,path)))) + `(local-tree ,path)) + +(defun xmtn--resolve--last-revision (root path num) + (check-type path string) + (check-type num (integer 1 *)) + (let ((path-root (xmtn-tree-root path t))) + (unless path-root + (error "Path is not in a monotone tree: %S" `(last-revision ,path ,num))) + (let ((base-revision-hash-id (xmtn--get-base-revision-hash-id path-root))) + (xmtn--resolve-backend-id path-root + `(previous-revision + ,base-revision-hash-id + ,(1- num)))))) + +(defun xmtn--resolve--previous-revision (root backend-id num) + (check-type num (integer 0 *)) + (let ((resolved-id (xmtn--resolve-backend-id root backend-id))) + (if (zerop num) + resolved-id + (ecase (first resolved-id) + (local-tree + (let ((other-root (second resolved-id))) + (xmtn--resolve-backend-id other-root + `(previous-revision + ,(xmtn--get-base-revision-hash-id + other-root) + ,(1- num))))) + (revision + (let ((hash-id (second resolved-id))) + (check-type hash-id xmtn--hash-id) + (loop repeat num + ;; If two parents of this rev, use parent on same branch as rev. + do (setq hash-id (xmtn--get-parent-revision-hash-id root hash-id t))) + `(revision ,hash-id))))))) + +(defun xmtn--error-unless-revision-exists (root hash-id) + (let ((lines (xmtn--expand-selector root (concat "i:" hash-id)))) + (when (endp lines) + (error "Revision %s unknown in workspace %s" hash-id root)) + (assert (eql (length lines) 1)) + (let ((db-hash (first lines))) + (assert (equal db-hash hash-id)))) + nil) + +(defun xmtn--expand-selector (root selector) + (xmtn-automate-simple-command-output-lines root `("select" ,selector))) + +(defun xmtn--branch-of (root hash-id) + (let ((certs (xmtn--list-parsed-certs root hash-id)) + result + cert) + (while (not result) + (setq cert (car certs)) + (if (equal "branch" (nth 2 cert)) + (setq result (nth 3 cert))) + (setq certs (cdr certs))) + result)) + +(defun xmtn--branches-of (hash-id) + "Return list of branch names for HASH-ID. `default-directory' +must be a workspace." + (let (result) + (xmtn-automate-with-session (session default-directory) + (xmtn-automate-with-command (handle session `("certs" ,hash-id)) + (xmtn-automate-command-wait-until-finished handle) + (with-current-buffer (xmtn-automate-command-buffer handle) + ;; now in buffer containing basic_io certs; find the branch certs + (goto-char (point-min)) + (while (not (xmtn-basic-io-eof)) + (xmtn-basic-io-optional-line "name" + (if (and (eq 'string (caar value)) + (string= "branch" (cadar value))) + (xmtn-basic-io-parse-line + (if (string= symbol "value") + (add-to-list 'result (cadar value))))) + ))))) + result)) + +(defun xmtn--get-parent-revision-hash-id (root hash-id &optional multi-parent-use-local-branch) + (check-type hash-id xmtn--hash-id) + (let ((parents (xmtn-automate-simple-command-output-lines root `("parents" + ,hash-id)))) + (case (length parents) + (0 (error "Revision has no parents: %s" hash-id)) + (1 (let ((parent (first parents))) + (assert (typep parent 'xmtn--hash-id)) + parent)) + (t + (if multi-parent-use-local-branch + ;; If this revision is the result of a propagate, there are two parents, one of which is on the local branch + (let ((local-branch (xmtn--tree-default-branch root)) + (first-parent-branch (xmtn--branch-of root (first parents)))) + (if (equal local-branch first-parent-branch) + (first parents) + (second parents))) + ;; Otherwise, just error. Depending on the context, we should + ;; prompt which parent is desired, or operate on all of them. + ;; This function is too low-level to decide what to do, though. + ;; Need to wait for use cases. + (error "Revision has more than one parent (%s): %s" + (length parents) + hash-id)))))) + +(defun xmtn--get-base-revision-hash-id-or-null (root) + (let ((hash-id (xmtn-automate-simple-command-output-line + root `("get_base_revision_id")))) + (when (equal hash-id "") (setq hash-id nil)) + (assert (typep hash-id '(or xmtn--hash-id null))) + hash-id)) + +(defun xmtn--get-base-revision-hash-id (root) + (let ((hash-id-or-null (xmtn--get-base-revision-hash-id-or-null root))) + (unless hash-id-or-null + (error "Tree has no base revision: %S" root)) + hash-id-or-null)) + +(provide 'xmtn-ids) + +;;; xmtn-ids.el ends here diff --git a/dvc/lisp/xmtn-match.el b/dvc/lisp/xmtn-match.el new file mode 100644 index 0000000..45a16f8 --- /dev/null +++ b/dvc/lisp/xmtn-match.el @@ -0,0 +1,223 @@ +;;; xmtn-match.el --- A macro for pattern-matching + +;; Copyright (C) 2006, 2007 Christian M. Ohler + +;; Author: Christian M. Ohler +;; Keywords: extensions + +;; 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: + +;; A pattern-matching macro. See its docstring for details. +;; +;; This was originally implemented for xmtn (and for fun), and is +;; heavily used there, but isn't specific to that context at all. +;; +;; The main difference between this package and Luke Goerrie's +;; patmatch.el, as far as I can see, is that this package attempts to +;; be efficient by analyzing the patterns statically, at +;; macroexpansion time. +;; +;; If this macro causes `max-lisp-eval-depth' or `max-specpdl-size' to +;; be exceeded, it is probably running interpreted. I haven't +;; investigated this; maybe there's a simple fix to reduce nesting +;; significantly. For now, be sure to compile this file. Possibly, +;; functions using this macro also need to be compiled. An +;; alternative is to increase the value of the respective variable. + +;;; Code: + +;;; There are some notes on the design of xmtn in +;;; docs/xmtn-readme.txt. + +(eval-and-compile + (require 'cl)) + +;; Note: +;; (equal (nth-value 0 (read-from-string "(x (`(foo)))")) (nth-value 0 (read-from-string "(x `(foo))"))) ! + +;; Why dollar sign as prefix character? Question mark, customarily +;; used for similar purposes in Common Lisp, is already taken in Emacs +;; Lisp. Dollar sign is used as a prefix character for variables in +;; some shell scripting languages, so it's somewhat familiar. + +;; (pprint (macroexpand '(xmtn-match x ([t $y ($y . t)] y)))) + +(deftype xmtn-match--bool-vector () + (if (fboundp 'bool-vector-p) + ;; For Emacs. + `bool-vector + ;; For XEmacs. + `nil)) + +(deftype xmtn-match--atom () + `(not cons)) + +(defun xmtn-match--match-variable-p (thing var-name-prefix-char) + (and (symbolp thing) + (eql (aref (symbol-name thing) 0) var-name-prefix-char))) + +(defun xmtn-match--contains-match-variable-p (thing var-name-prefix-char) + (labels ((walk (thing) + (or + (xmtn-match--match-variable-p thing var-name-prefix-char) + (etypecase thing + (cons (or (walk (car thing)) + (walk (cdr thing)))) + ((and array (not string) (not xmtn-match--bool-vector)) + (some #'walk thing)) + (xmtn-match--atom nil))))) + (walk thing))) + +;; They say it's bad style if function definitions are too big to fit +;; on a screen. A small font is recommended for this one. +(defun xmtn-match--generate-branch (var-name-prefix-char + match-block object pattern body) + (let ((var-accu (list)) + (pattern-block (gensym "pattern-test-"))) + (let ((test + `(and + ,@(labels + ;; The 'contains variable' check, the way it is + ;; implemented here, is grossly inefficient at + ;; compile-time. + ((walk-part (subsubpattern subsubobject-form) + ;; Be smart and try not to introduce temporary + ;; variables that would be accessed only once. + ;; Since they are dynamic variables, Emacs might + ;; not be able to optimize them away. They also + ;; make the generated code harder to understand + ;; when debugging expansions. + (if (or + (not (xmtn-match--contains-match-variable-p + subsubpattern var-name-prefix-char)) + (etypecase subsubpattern + (cons nil) + (array nil) + (t t))) + (walk subsubobject-form subsubpattern) + (let ((subsubobject (gensym))) + `((let ((,subsubobject ,subsubobject-form)) + (and + ,@(walk subsubobject subsubpattern))))))) + (walk (subobject subpattern) + ;; Returns a list of conditions for an `and' + ;; expression. + (cond + ((xmtn-match--match-variable-p subpattern + var-name-prefix-char) + (let ((var (intern (subseq (symbol-name subpattern) 1)))) + (cond ((member var var-accu) + `((equal ,subobject ,var))) + (t + (push var var-accu) + `((progn (setq ,var ,subobject) t)))))) + ((not (xmtn-match--contains-match-variable-p + subpattern var-name-prefix-char)) + (etypecase subpattern + ;; The byte-compiler doesn't do this + ;; optimization as of GNU Emacs 22.0.50.1. + ;; Maybe that means it's not worth doing... + (symbol + `((eq ,subobject ',subpattern))) + (t + `((equal ,subobject ',subpattern))))) + (t + (etypecase subpattern + (cons + `((consp ,subobject) + ,@(loop for part-reader in '(car cdr) + append (walk-part + (funcall part-reader subpattern) + `(,part-reader ,subobject))))) + ;; I think this will also allow char-tables. + ;; Not sure how useful that is. + ((and array (not string) (not xmtn-match--bool-vector)) + `((typep ,subobject ',(type-of + subpattern)) + (eql (length ,subobject) ,(length subpattern)) + ,@(loop for index below (length subpattern) + append (walk-part + (aref subpattern index) + `(aref ,subobject ,index)))))))))) + (walk object pattern))))) + (setq var-accu (nreverse var-accu)) + `(let (,@var-accu) + (when + ;;(xmtn-match--test (lambda () ,test)) + ,test + (return-from ,match-block (progn ,@body))))))) + +;; Make sure the function is compiled to avoid stack overflows. +;; Without this, DVC fails to build (in my configuration), since it +;; initially loads the elisp file as source. +(byte-compile 'xmtn-match--generate-branch) +;; I think the same may hold for this function (see message from Sam +;; Steingold on the dvc-dev list, 2007-07-09), although I haven't +;; tried very hard to reproduce it. +(byte-compile 'xmtn-match--contains-match-variable-p) + + +;; Factored out for profiling. +;;;###autoload +(defun xmtn-match--test (xmtn--thunk) + (funcall xmtn--thunk)) + + +(defmacro* xmtn-match (object-form &body cases) + "Similar to `ecase', but with pattern matching. + +Eval EXPR, find the first PATTERN that matches its value, execute +the corresponding BODY and return its result. If no PATTERN +matches, an error is signalled. + +The matching is done as with `equal', except that subexpressions +of PATTERN that are symbols whose name starts with $ are treated +specially. Such symbols are free variables that match any +subexpression. If the same variable occurs more than once, each +occurrence must match a similar \(as in `equal'\) subexpression. +During the execution of BODY, each variable, with the leading $ +removed, will be bound to the subexpression that it matched. + +Variables may only occur in conses and arrays except strings and +bool-vectors. + +\(fn EXPR \(PATTERN BODY...\)...\)" + (declare (indent 1) (debug (form &rest (sexp body)))) + ;; It would be interesting (very interesting, in fact, but also + ;; fairly complex) to generate an expansion here that walks the + ;; object only /once/ at run-time, not once for every clause as the + ;; current expansion does. Might also be more efficient, but that's + ;; hard to say for sure, and I don't think the matching currently is + ;; a bottleneck anywhere. But it would allow detecting whether one + ;; clause subsumes a subsequent one and issuing a warning. + (let ((macro-name 'xmtn-match) + (var-name-prefix-char ?$) + (object (gensym "object-")) + (match-block (gensym "match-form-"))) + `(let ((,object ,object-form)) + (block ,match-block + ,@(loop + for (pattern . body) in cases + collect (xmtn-match--generate-branch var-name-prefix-char + match-block object pattern + body)) + (error "Fell through %S: %S" ',macro-name ,object))))) + +(provide 'xmtn-match) + +;;; xmtn-match.el ends here diff --git a/dvc/lisp/xmtn-minimal.el b/dvc/lisp/xmtn-minimal.el new file mode 100644 index 0000000..3545fbf --- /dev/null +++ b/dvc/lisp/xmtn-minimal.el @@ -0,0 +1,47 @@ +;;; xmtn-minimal.el --- Definitions for detecting whether to activate xmtn + +;; Copyright (C) 2006, 2007 Christian M. Ohler + +;; Author: Christian M. Ohler +;; 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 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: + +;; The minimal set of definitions needed to allow DVC to detect +;; whether a given file is under monotone version control. Having +;; them in their own file instead of in xmtn-dvc.el avoids having to +;; load all of xmtn-dvc.el just for this simple check. + +;;; Code: + +;;; There are some notes on the design of xmtn in +;;; docs/xmtn-readme.txt. + +(eval-and-compile + (require 'dvc-register) + (require 'dvc-core)) + +;;;###autoload +(defun xmtn-tree-root (&optional location no-error) + (dvc-tree-root-helper "_MTN/" (interactive-p) + "%s is not in a monotone-managed tree" + location no-error)) + +(provide 'xmtn-minimal) + +;;; xmtn-minimal.el ends here diff --git a/dvc/lisp/xmtn-propagate.el b/dvc/lisp/xmtn-propagate.el new file mode 100644 index 0000000..6ccbf75 --- /dev/null +++ b/dvc/lisp/xmtn-propagate.el @@ -0,0 +1,653 @@ +;;; xmtn-propagate.el --- manage multiple propagations for DVC backend for monotone + +;; Copyright (C) 2009 Stephen Leake + +;; Author: Stephen Leake +;; 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 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 + ;; these have macros we use + (require 'xmtn-ids)) + +(eval-when-compile + ;; these have functions we use + (require 'xmtn-conflicts)) + +(defvar xmtn-propagate-from-root "" + "Buffer-local variable holding `from' root directory.") +(make-variable-buffer-local 'xmtn-propagate-from-root) + +(defvar xmtn-propagate-to-root "" + "Buffer-local variable holding `to' root directory.") +(make-variable-buffer-local 'xmtn-propagate-to-root) + +(defstruct (xmtn-propagate-data (:copier nil)) + from-work ; directory name relative to xmtn-propagate-from-root + to-work ; directory name relative to xmtn-propagate-to-root + need-refresh ; nil | t; if an async process was started that invalidates state data + from-head-rev ; nil | mtn rev string; current head revision; nil if multiple heads + to-head-rev ; + conflicts-buffer ; *xmtn-conflicts* buffer for this propagation + propagate-needed ; nil | t + from-heads ; 'at-head | 'need-update | 'need-merge) + to-heads ; + (from-local-changes + 'need-scan) ; 'need-scan | 'need-status | 'ok + (to-local-changes + 'need-scan) ; once these are changed from 'need-scan, no action changes it . + (conflicts + 'need-scan) ; 'need-scan | 'need-resolve | 'need-review-resolve-internal | 'ok + ) + +(defun xmtn-propagate-from-work (data) + (concat xmtn-propagate-from-root (xmtn-propagate-data-from-work data))) + +(defun xmtn-propagate-to-work (data) + (concat xmtn-propagate-to-root (xmtn-propagate-data-to-work data))) + +(defun xmtn-propagate-need-refresh (elem data) + (setf (xmtn-propagate-data-need-refresh data) t) + (ewoc-invalidate xmtn-propagate-ewoc elem)) + +(defun xmtn-propagate-printer (data) + "Print an ewoc element." + (if (string= (xmtn-propagate-data-from-work data) + (xmtn-propagate-data-to-work data)) + (insert (dvc-face-add (format "%s\n" (xmtn-propagate-data-from-work data)) 'dvc-keyword)) + (insert (dvc-face-add (format "%s -> %s\n" + (xmtn-propagate-data-from-work data) + (xmtn-propagate-data-to-work data)) + 'dvc-keyword))) + + (if (xmtn-propagate-data-need-refresh data) + (insert (dvc-face-add " need refresh\n" 'dvc-conflict)) + + (if (xmtn-propagate-data-propagate-needed data) + (progn + (ecase (xmtn-propagate-data-from-local-changes data) + (need-scan (insert " from local changes unknown\n")) + (need-status (insert (dvc-face-add " need dvc-status from\n" 'dvc-header))) + (ok nil)) + + (ecase (xmtn-propagate-data-to-local-changes data) + (need-scan (insert " to local changes unknown\n")) + (need-status (insert (dvc-face-add " need dvc-status to\n" 'dvc-header))) + (ok nil)) + + (ecase (xmtn-propagate-data-from-heads data) + (at-head nil) + (need-update (insert (dvc-face-add " need dvc-missing from\n" 'dvc-conflict))) + (need-merge (insert (dvc-face-add " need xmtn-heads from\n" 'dvc-conflict)))) + + (ecase (xmtn-propagate-data-to-heads data) + (at-head nil) + (need-update (insert (dvc-face-add " need dvc-missing to\n" 'dvc-conflict))) + (need-merge (insert (dvc-face-add " need xmtn-heads to\n" 'dvc-conflict)))) + + + (if (and (eq 'at-head (xmtn-propagate-data-from-heads data)) + (eq 'at-head (xmtn-propagate-data-to-heads data))) + (ecase (xmtn-propagate-data-conflicts data) + (need-scan + (insert "conflicts need scan\n")) + (need-resolve + (insert (dvc-face-add " need resolve conflicts\n" 'dvc-conflict))) + (need-review-resolve-internal + (insert (dvc-face-add " need review resolve internal\n" 'dvc-header)) + (insert (dvc-face-add " need propagate\n" 'dvc-conflict))) + (ok + (insert (dvc-face-add " need propagate\n" 'dvc-conflict))))) + ) + + ;; propagate not needed + (ecase (xmtn-propagate-data-from-local-changes data) + (need-scan (insert " from local changes unknown\n")) + (need-status (insert (dvc-face-add " need dvc-status from\n" 'dvc-header))) + (ok nil)) + + (ecase (xmtn-propagate-data-to-local-changes data) + (need-scan (insert " to local changes unknown\n")) + (need-status (insert (dvc-face-add " need dvc-status to\n" 'dvc-header))) + (ok nil)) + + (ecase (xmtn-propagate-data-to-heads data) + (at-head nil) + (need-update (insert (dvc-face-add " need dvc-update to\n" 'dvc-conflict))) + (need-merge (insert (dvc-face-add " programmer error!\n" 'dvc-conflict)))) + ))) + +(defvar xmtn-propagate-ewoc nil + "Buffer-local ewoc for displaying propagations. +All xmtn-propagate functions operate on this ewoc. +The elements must all be of class xmtn-propagate-data.") +(make-variable-buffer-local 'xmtn-propagate-ewoc) + +(defun xmtn-propagate-clean () + "Clean current workspace, delete from ewoc" + (interactive) + (let* ((elem (ewoc-locate xmtn-propagate-ewoc)) + (data (ewoc-data elem))) + (with-current-buffer (xmtn-propagate-data-conflicts-buffer data) + (xmtn-conflicts-clean (xmtn-propagate-from-work data))) + (let ((inhibit-read-only t)) + (ewoc-delete xmtn-propagate-ewoc elem)))) + +(defun xmtn-propagate-cleanp () + "Non-nil if clean is appropriate for current workspace." + (let ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc)))) + (and (not (xmtn-propagate-data-need-refresh data)) + (not (xmtn-propagate-data-propagate-needed data)) + (eq 'at-head (xmtn-propagate-data-to-heads data))))) + +(defun xmtn-propagate-do-refresh-one () + (interactive) + (let* ((elem (ewoc-locate xmtn-propagate-ewoc)) + (data (ewoc-data elem))) + (xmtn-propagate-refresh-one data) + (ewoc-invalidate xmtn-propagate-ewoc elem))) + +(defun xmtn-propagate-refreshp () + "Non-nil if refresh is appropriate for current workspace." + (let ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc)))) + (xmtn-propagate-data-need-refresh data))) + +(defun xmtn-propagate-update () + "Update current workspace." + (interactive) + (let* ((elem (ewoc-locate xmtn-propagate-ewoc)) + (data (ewoc-data elem))) + (xmtn-propagate-need-refresh elem data) + (with-current-buffer (xmtn-propagate-data-conflicts-buffer data) + (xmtn-dvc-update)) + (xmtn-propagate-refresh-one data) + (ewoc-invalidate xmtn-propagate-ewoc elem))) + +(defun xmtn-propagate-updatep () + "Non-nil if update is appropriate for current workspace." + (let ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc)))) + (and (not (xmtn-propagate-data-need-refresh data)) + (not (xmtn-propagate-data-propagate-needed data)) + (eq 'need-update (xmtn-propagate-data-to-heads data))))) + +(defun xmtn-propagate-propagate () + "Propagate current workspace." + (interactive) + (let* ((elem (ewoc-locate xmtn-propagate-ewoc)) + (data (ewoc-data elem))) + (xmtn-propagate-need-refresh elem data) + (with-current-buffer (xmtn-propagate-data-conflicts-buffer data) + (let ((xmtn-confirm-operation nil)) + (xmtn-conflicts-do-propagate))) + (xmtn-propagate-refresh-one data) + (ewoc-invalidate xmtn-propagate-ewoc elem))) + +(defun xmtn-propagate-propagatep () + "Non-nil if propagate is appropriate for current workspace." + (let* ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc)))) + (and (not (xmtn-propagate-data-need-refresh data)) + (xmtn-propagate-data-propagate-needed data) + (eq 'at-head (xmtn-propagate-data-from-heads data)) + (eq 'at-head (xmtn-propagate-data-to-heads data)) + (member (xmtn-propagate-data-conflicts data) + '(ok need-review-resolve-internal))))) + +(defun xmtn-propagate-resolve-conflicts () + "Resolve conflicts for current workspace." + (interactive) + (let* ((elem (ewoc-locate xmtn-propagate-ewoc)) + (data (ewoc-data elem))) + (xmtn-propagate-need-refresh elem data) + (pop-to-buffer (xmtn-propagate-data-conflicts-buffer data)))) + +(defun xmtn-propagate-resolve-conflictsp () + "Non-nil if resolve conflicts is appropriate for current workspace." + (let* ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc)))) + (and (not (xmtn-propagate-data-need-refresh data)) + (xmtn-propagate-data-propagate-needed data) + (eq 'at-head (xmtn-propagate-data-from-heads data)) + (eq 'at-head (xmtn-propagate-data-to-heads data)) + (member (xmtn-propagate-data-conflicts data) + '(need-resolve need-review-resolve-internal))))) + +(defun xmtn-propagate-status-to () + "Run xmtn-status on current `to' workspace." + (interactive) + (let* ((elem (ewoc-locate xmtn-propagate-ewoc)) + (data (ewoc-data elem))) + (xmtn-propagate-need-refresh elem data) + (setf (xmtn-propagate-data-to-local-changes data) 'ok) + (xmtn-status (xmtn-propagate-to-work data)))) + +(defun xmtn-propagate-status-to-ok () + "Ignore local changes in current `to' workspace." + (interactive) + (let* ((elem (ewoc-locate xmtn-propagate-ewoc)) + (data (ewoc-data elem))) + (setf (xmtn-propagate-data-to-local-changes data) 'ok) + (ewoc-invalidate xmtn-propagate-ewoc elem))) + +(defun xmtn-propagate-status-top () + "Non-nil if xmtn-status is appropriate for current `to' workspace." + (let* ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc)))) + (and (not (xmtn-propagate-data-need-refresh data)) + (member (xmtn-propagate-data-to-local-changes data) + '(need-scan need-status))))) + +(defun xmtn-propagate-status-from () + "Run xmtn-status on current `from' workspace." + (interactive) + (let* ((elem (ewoc-locate xmtn-propagate-ewoc)) + (data (ewoc-data elem))) + (xmtn-propagate-need-refresh elem data) + (setf (xmtn-propagate-data-from-local-changes data) 'ok) + (xmtn-status (xmtn-propagate-from-work data)))) + +(defun xmtn-propagate-status-from-ok () + "Ignore local changes in current `from' workspace." + (interactive) + (let* ((elem (ewoc-locate xmtn-propagate-ewoc)) + (data (ewoc-data elem))) + (setf (xmtn-propagate-data-from-local-changes data) 'ok) + (ewoc-invalidate xmtn-propagate-ewoc elem))) + +(defun xmtn-propagate-status-fromp () + "Non-nil if xmtn-status is appropriate for current `from' workspace." + (let* ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc)))) + (and (not (xmtn-propagate-data-need-refresh data)) + (member (xmtn-propagate-data-from-local-changes data) + '(need-scan need-status))))) + +(defun xmtn-propagate-missing-to () + "Run xmtn-missing on current `to' workspace." + (interactive) + (let* ((elem (ewoc-locate xmtn-propagate-ewoc)) + (data (ewoc-data elem))) + (xmtn-propagate-need-refresh elem data) + (xmtn-missing nil (xmtn-propagate-to-work data)))) + +(defun xmtn-propagate-missing-top () + "Non-nil if xmtn-missing is appropriate for current `to' workspace." + (let* ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc)))) + (and (not (xmtn-propagate-data-need-refresh data)) + (xmtn-propagate-data-propagate-needed data) + (eq 'need-update (xmtn-propagate-data-to-heads data))))) + +(defun xmtn-propagate-missing-from () + "Run xmtn-missing on current `from' workspace." + (interactive) + (let* ((elem (ewoc-locate xmtn-propagate-ewoc)) + (data (ewoc-data elem))) + (xmtn-propagate-need-refresh elem data) + (xmtn-missing nil (xmtn-propagate-from-work data)))) + +(defun xmtn-propagate-missing-fromp () + "Non-nil if xmtn-missing is appropriate for current `from' workspace." + (let* ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc)))) + (and (not (xmtn-propagate-data-need-refresh data)) + (xmtn-propagate-data-propagate-needed data) + (eq 'need-update (xmtn-propagate-data-from-heads data))))) + +(defun xmtn-propagate-heads-to () + "Run xmtn-heads on current `to' workspace." + (interactive) + (let* ((elem (ewoc-locate xmtn-propagate-ewoc)) + (data (ewoc-data elem)) + (default-directory (xmtn-propagate-to-work data))) + (xmtn-propagate-need-refresh elem data) + (xmtn-view-heads-revlist))) + +(defun xmtn-propagate-heads-top () + "Non-nil if xmtn-heads is appropriate for current `to' workspace." + (let* ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc)))) + (and (not (xmtn-propagate-data-need-refresh data)) + (xmtn-propagate-data-propagate-needed data) + (eq 'need-merge (xmtn-propagate-data-to-heads data))))) + +(defun xmtn-propagate-heads-from () + "Run xmtn-heads on current `from' workspace." + (interactive) + (let* ((elem (ewoc-locate xmtn-propagate-ewoc)) + (data (ewoc-data elem)) + (default-directory (xmtn-propagate-from-work data))) + (xmtn-propagate-need-refresh elem data) + (xmtn-view-heads-revlist))) + +(defun xmtn-propagate-heads-fromp () + "Non-nil if xmtn-heads is appropriate for current `from' workspace." + (let* ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc)))) + (and (not (xmtn-propagate-data-need-refresh data)) + (xmtn-propagate-data-propagate-needed data) + (eq 'need-merge (xmtn-propagate-data-from-heads data))))) + +(defvar xmtn-propagate-actions-map + (let ((map (make-sparse-keymap "actions"))) + (define-key map [?c] '(menu-item "c) clean/delete" + xmtn-propagate-clean + :visible (xmtn-propagate-cleanp))) + (define-key map [?g] '(menu-item "g) refresh" + xmtn-propagate-do-refresh-one + :visible (xmtn-propagate-refreshp))) + (define-key map [?a] '(menu-item "a) update" + xmtn-propagate-update + :visible (xmtn-propagate-updatep))) + (define-key map [?9] '(menu-item "9) propagate" + xmtn-propagate-propagate + :visible (xmtn-propagate-propagatep))) + (define-key map [?8] '(menu-item "8) resolve conflicts" + xmtn-propagate-resolve-conflicts + :visible (xmtn-propagate-resolve-conflictsp))) + (define-key map [?7] '(menu-item "7) ignore local changes to" + xmtn-propagate-status-to-ok + :visible (xmtn-propagate-status-top))) + (define-key map [?6] '(menu-item "6) ignore local changes from" + xmtn-propagate-status-from-ok + :visible (xmtn-propagate-status-fromp))) + (define-key map [?5] '(menu-item "5) status to" + xmtn-propagate-status-to + :visible (xmtn-propagate-status-top))) + (define-key map [?4] '(menu-item "4) status from" + xmtn-propagate-status-from + :visible (xmtn-propagate-status-fromp))) + (define-key map [?3] '(menu-item "3) dvc-missing to" + xmtn-propagate-missing-to + :visible (xmtn-propagate-missing-top))) + (define-key map [?2] '(menu-item "2) dvc-missing from" + xmtn-propagate-missing-from + :visible (xmtn-propagate-missing-fromp))) + (define-key map [?1] '(menu-item "1) xmtn-heads to" + xmtn-propagate-heads-to + :visible (xmtn-propagate-heads-top))) + (define-key map [?0] '(menu-item "0) xmtn-heads from" + xmtn-propagate-heads-from + :visible (xmtn-propagate-heads-fromp))) + map) + "Keyboard menu keymap used to manage propagates.") + +(dvc-make-ewoc-next xmtn-propagate-next xmtn-propagate-ewoc) +(dvc-make-ewoc-prev xmtn-propagate-prev xmtn-propagate-ewoc) + +(defvar xmtn-propagate-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "\M-d" xmtn-propagate-actions-map) + (define-key map [?g] 'xmtn-propagate-refresh) + (define-key map [?n] 'xmtn-propagate-next) + (define-key map [?p] 'xmtn-propagate-prev) + (define-key map [?q] (lambda () (interactive) (kill-buffer (current-buffer)))) + map) + "Keymap used in `xmtn-propagate-mode'.") + +(define-derived-mode xmtn-propagate-mode nil "xmtn-propagate" + "Major mode to propagate multiple workspaces." + (setq dvc-buffer-current-active-dvc 'xmtn) + (setq buffer-read-only nil) + (setq xmtn-propagate-ewoc (ewoc-create 'xmtn-propagate-printer)) + + ;; don't do normal clean up stuff + (set (make-local-variable 'before-save-hook) nil) + (set (make-local-variable 'write-file-functions) nil) + + (dvc-install-buffer-menu) + (setq buffer-read-only t) + (buffer-disable-undo) + (set-buffer-modified-p nil)) + +(defun xmtn-propagate-local-changes (work) + "Value for xmtn-propagate-data-local-changes for WORK." + (message "checking %s for local changes" work) + (let ((default-directory work)) + + (dvc-run-dvc-sync + 'xmtn + (list "status") + :finished (lambda (output error status arguments) + ;; we don't get an error status for not up-to-date, + ;; so parse the output. + ;; FIXME: add option to automate inventory to just return status; can return on first change + ;; FIXME: 'patch' may be internationalized. + + (message "") ; clear minibuffer + (set-buffer output) + (goto-char (point-min)) + (if (search-forward "patch" (point-max) t) + 'need-status + 'ok)) + + :error (lambda (output error status arguments) + (pop-to-buffer error)))) + ) + +(defun xmtn-propagate-needed (data) + "t if DATA needs propagate." + (let ((result t) + (from-work (xmtn-propagate-from-work data)) + (from-head-rev (xmtn-propagate-data-from-head-rev data)) + (to-head-rev (xmtn-propagate-data-to-head-rev data))) + + ;; If from has no descendants, then: + ;; 1) to branched off earlier, and propagate is needed + ;; 2) propagate was just done but required no changes; no propagate needed + ;; + (if (string= from-head-rev to-head-rev) + ;; case 2 + (setq result nil) + (let ((descendents (xmtn-automate-simple-command-output-lines from-work (list "descendents" from-head-rev))) + done) + (if (not descendents) + ;; case 1 + (setq result t) + (while (and descendents (not done)) + (if (string= to-head-rev (car descendents)) + (progn + (setq result nil) + (setq done t))) + (setq descendents (cdr descendents)))))) + result + )) + +(defun xmtn-propagate-conflicts-buffer (from-work from-head-rev to-work to-head-rev) + "Return a conflicts buffer for FROM-WORK, TO-WORK (absolute paths)." + (let ((conflicts-buffer (dvc-get-buffer 'xmtn 'conflicts to-work))) + + (or conflicts-buffer + (let ((default-directory to-work)) + (if (not (file-exists-p "_MTN/conflicts")) + (progn + ;; create conflicts file + (xmtn-conflicts-save-opts from-work to-work) + (dvc-run-dvc-sync + 'xmtn + (list "conflicts" "store" from-head-rev to-head-rev) + :finished (lambda (output error status arguments) + (xmtn-dvc-log-clean) + + :error (lambda (output error status arguments) + (xmtn-dvc-log-clean) + (pop-to-buffer error)))))) + ;; create conflicts buffer + (save-excursion + (let ((dvc-switch-to-buffer-first nil)) + (xmtn-conflicts-review default-directory) + (current-buffer))))))) + +(defun xmtn-propagate-conflicts (data) + "Return value for xmtn-propagate-data-conflicts for DATA." + ;; if conflicts-buffer is nil, this does the right thing. + (let ((revs-current + (and (buffer-live-p (xmtn-propagate-data-conflicts-buffer data)) + (with-current-buffer (xmtn-propagate-data-conflicts-buffer data) + (and (string= (xmtn-propagate-data-from-head-rev data) xmtn-conflicts-left-revision) + (string= (xmtn-propagate-data-to-head-rev data) xmtn-conflicts-right-revision)))))) + (if revs-current + (with-current-buffer (xmtn-propagate-data-conflicts-buffer data) + (xmtn-conflicts-update-counts)) + + ;; recreate conflicts + (if (buffer-live-p (xmtn-propagate-data-conflicts-buffer data)) + (kill-buffer (xmtn-propagate-data-conflicts-buffer data))) + + (xmtn-conflicts-clean (xmtn-propagate-to-work data)) + + (setf (xmtn-propagate-data-conflicts-buffer data) + (xmtn-propagate-conflicts-buffer + (xmtn-propagate-from-work data) + (xmtn-propagate-data-from-head-rev data) + (xmtn-propagate-to-work data) + (xmtn-propagate-data-to-head-rev data))) + ) + + (with-current-buffer (xmtn-propagate-data-conflicts-buffer data) + (if (= xmtn-conflicts-total-count xmtn-conflicts-resolved-count) + (if (< 0 xmtn-conflicts-resolved-internal-count) + 'need-review-resolve-internal + 'ok) + 'need-resolve)))) + +(defun xmtn-propagate-refresh-one (data) + "Refresh DATA." + (let ((from-work (xmtn-propagate-from-work data)) + (to-work (xmtn-propagate-to-work data))) + + (let ((heads (xmtn--heads from-work nil)) + (from-base-rev (xmtn--get-base-revision-hash-id-or-null from-work))) + (case (length heads) + (1 + (setf (xmtn-propagate-data-from-head-rev data) (nth 0 heads)) + (if (string= (xmtn-propagate-data-from-head-rev data) from-base-rev) + (setf (xmtn-propagate-data-from-heads data) 'at-head) + (setf (xmtn-propagate-data-from-heads data) 'need-update))) + (t + (setf (xmtn-propagate-data-from-head-rev data) nil) + (setf (xmtn-propagate-data-from-heads data) 'need-merge)))) + + (let ((heads (xmtn--heads to-work nil)) + (to-base-rev (xmtn--get-base-revision-hash-id-or-null to-work))) + (case (length heads) + (1 + (setf (xmtn-propagate-data-to-head-rev data) (nth 0 heads)) + (if (string= (xmtn-propagate-data-to-head-rev data) to-base-rev) + (setf (xmtn-propagate-data-to-heads data) 'at-head) + (setf (xmtn-propagate-data-to-heads data) 'need-update))) + (t + (setf (xmtn-propagate-data-to-head-rev data) nil) + (setf (xmtn-propagate-data-to-heads data) 'need-merge)))) + + (setf (xmtn-propagate-data-propagate-needed data) + (xmtn-propagate-needed data)) + + (if (xmtn-propagate-data-propagate-needed data) + ;; these checks are slow, so don't do them if they probably are not needed. + (progn + (ecase (xmtn-propagate-data-from-local-changes data) + ((need-scan need-status) + (setf (xmtn-propagate-data-from-local-changes data) (xmtn-propagate-local-changes from-work))) + (ok nil)) + + (ecase (xmtn-propagate-data-to-local-changes data) + ((need-scan need-status) + (setf (xmtn-propagate-data-to-local-changes data) (xmtn-propagate-local-changes to-work))) + (ok nil)) + + (setf (xmtn-propagate-data-conflicts data) + (xmtn-propagate-conflicts data))) + + ;; propagate not needed + (setf (xmtn-propagate-data-conflicts data) 'need-scan)) + + (setf (xmtn-propagate-data-need-refresh data) nil)) + + ;; return non-nil to refresh display as we go along + t) + +(defun xmtn-propagate-refresh () + "Refresh status of each ewoc element." + (interactive) + (ewoc-map 'xmtn-propagate-refresh-one xmtn-propagate-ewoc) + (message "done")) + +(defun xmtn--filter-non-dir (dir) + "Return list of all directories in DIR, excluding '.', '..'." + (let ((default-directory dir) + (subdirs (directory-files dir))) + (setq subdirs + (mapcar (lambda (filename) + (if (and (file-directory-p filename) + (not (string= "." filename)) + (not (string= ".." filename))) + filename)) + subdirs)) + (delq nil subdirs))) + +;;;###autoload +(defun xmtn-propagate-multiple (from-dir to-dir) + "Show all actions needed to propagate all projects under FROM-DIR to TO-DIR." + (interactive "DPropagate all from (root directory): \nDto (root directory): ") + (let ((from-workspaces (xmtn--filter-non-dir from-dir)) + (to-workspaces (xmtn--filter-non-dir to-dir))) + + (pop-to-buffer (get-buffer-create "*xmtn-propagate*")) + (xmtn-propagate-mode) + (setq xmtn-propagate-from-root (file-name-as-directory from-dir)) + (setq xmtn-propagate-to-root (file-name-as-directory to-dir)) + (let ((inhibit-read-only t)) (delete-region (point-min) (point-max))) + (ewoc-set-hf + xmtn-propagate-ewoc + (concat + (format "From root : %s\n" xmtn-propagate-from-root) + (format " To root : %s\n" xmtn-propagate-to-root) + ) + "") + (dolist (workspace from-workspaces) + (if (member workspace to-workspaces) + (ewoc-enter-last xmtn-propagate-ewoc + (make-xmtn-propagate-data + :to-work workspace + :from-work workspace + :need-refresh t)))) + + (xmtn-propagate-refresh) + (xmtn-propagate-next))) + +;;;###autoload +(defun xmtn-propagate-one (from-work to-work) + "Show all actions needed to propagate FROM-WORK to TO-WORK." + (interactive "DPropagate all from (workspace): \nDto (workspace): ") + (pop-to-buffer (get-buffer-create "*xmtn-propagate*")) + (xmtn-propagate-mode) + (setq xmtn-propagate-from-root (expand-file-name (concat (file-name-as-directory from-work) "../"))) + (setq xmtn-propagate-to-root (expand-file-name (concat (file-name-as-directory to-work) "../"))) + + (let ((inhibit-read-only t)) (delete-region (point-min) (point-max))) + (ewoc-set-hf + xmtn-propagate-ewoc + (concat + (format "From root : %s\n" xmtn-propagate-from-root) + (format " To root : %s\n" xmtn-propagate-to-root) + ) + "") + (ewoc-enter-last xmtn-propagate-ewoc + (make-xmtn-propagate-data + :from-work (file-name-nondirectory from-work) + :to-work (file-name-nondirectory to-work) + :need-refresh t)) + + (xmtn-propagate-refresh) + (xmtn-propagate-next)) + +(provide 'xmtn-propagate) + +;; end of file diff --git a/dvc/lisp/xmtn-revlist.el b/dvc/lisp/xmtn-revlist.el new file mode 100644 index 0000000..27f1ffd --- /dev/null +++ b/dvc/lisp/xmtn-revlist.el @@ -0,0 +1,629 @@ +;;; xmtn-revlist.el --- Interactive display of revision histories for monotone + +;; Copyright (C) 2008, 2009 Stephen Leake +;; Copyright (C) 2006, 2007 Christian M. Ohler + +;; Author: Christian M. Ohler +;; 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 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: + +;; This file is part of xmtn and implements an interactive display of +;; revision histories. + +;;; Code: + +;;; There are some notes on the design of xmtn in +;;; docs/xmtn-readme.txt. + +(eval-and-compile + (require 'cl) + (require 'dvc-unified) + (require 'dvc-revlist) + (require 'xmtn-ids) + (require 'xmtn-basic-io) + (require 'xmtn-automate) + (require 'xmtn-match) + (require 'xmtn-dvc)) + + +(defvar xmtn--revlist-*info-generator-fn* nil) +"Buffer-local variable pointing to a function that generates a +list of revisions to display in a revlist buffer. Called with one +arg; root. Result is of the form: + (branch + (header-lines) + (footer-lines) + (revisions))" +(make-variable-buffer-local 'xmtn--revlist-*info-generator-fn*) + +(defvar xmtn--revlist-*merge-destination-branch* nil) +(make-variable-buffer-local 'xmtn--revlist-*merge-destination-branch*) + +(defun xmtn--escape-branch-name-for-selector (branch-name) + ;; FIXME. The monotone manual refers to "shell wildcards" but + ;; doesn't define what they are, or how to escape them. So just a + ;; heuristic here. + (assert (not (position ?* branch-name))) + (assert (not (position ?? branch-name))) + (assert (not (position ?\\ branch-name))) + (assert (not (position ?{ branch-name))) + (assert (not (position ?} branch-name))) + (assert (not (position ?[ branch-name))) + (assert (not (position ?] branch-name))) + branch-name) + +(defstruct (xmtn--revlist-entry (:constructor xmtn--make-revlist-entry)) + revision-hash-id + branches + authors + dates + changelogs + tags + parent-hash-ids + child-hash-ids) + +;;;###autoload +(defun xmtn-revision-refresh-maybe () + ;; This is called to notify us whenever `dvc-revisions-shows-date', + ;; `dvc-revisions-shows-creator' or `dvc-revisions-shows-summary' + ;; change. + ;; + ;; There is nothing we need to do in response to this, though. + nil) + +;;;###autoload +(defun xmtn-revision-list-entry-patch-printer (patch) + (let ((entry (dvc-revlist-entry-patch-struct patch))) + (assert (typep entry 'xmtn--revlist-entry)) + (insert (format " %s %s%s\n" + (if (dvc-revlist-entry-patch-marked patch) "*" " ") + (xmtn--revlist-entry-revision-hash-id entry) + (let ((head-p + (endp (xmtn--revlist-entry-child-hash-ids entry))) + (root-p + (endp (xmtn--revlist-entry-parent-hash-ids entry)))) + (cond ((and head-p root-p) " (head, root)") + (head-p " (head)") + (root-p " (root)") + (t ""))))) + (dolist (tag (xmtn--revlist-entry-tags entry)) + (insert (format " Tag: %s\n" tag))) + (let ((authors (xmtn--revlist-entry-authors entry)) + (dates (xmtn--revlist-entry-dates entry)) + (changelogs (xmtn--revlist-entry-changelogs entry))) + (let ((len (max (length authors) (length dates) (length changelogs)))) + (macrolet ((fillf (x) + `(setq ,x (append ,x (make-list (- len (length ,x)) nil))))) + (fillf authors) + (fillf dates) + (fillf changelogs)) + (assert (eql (length authors) len) + (eql (length dates) len) + (eql (length changelogs) len))) + (loop + ;; FIXME: Matching the k-th author cert with the k-th date cert + ;; and the k-th changelog cert, like we do here, is unlikely to + ;; be correct in general. That the relationship between date, + ;; message and author of a commit is lost appears to be a + ;; limitation of monotone's current design. + for author in authors + for date in dates + for changelog in changelogs + do + (cond ((and dvc-revisions-shows-date dvc-revisions-shows-creator) + (insert (format " %s %s\n" + (or date "date unknown") + (or author "author unknown")))) + (dvc-revisions-shows-date + (insert (format " %s\n" (or date "date unknown")))) + (dvc-revisions-shows-creator + (insert (format " %s\n" (or author "author unknown")))) + (t (progn))) + (when dvc-revisions-shows-summary + (if (null changelog) + (insert (format " No changelog")) + (let ((lines (split-string changelog "\n"))) + (dolist (line (if dvc-revlist-brief + (and lines (list (first lines))) + lines)) + (insert (format " %s\n" line)))))))))) + +(defun xmtn--revlist-setup-ewoc (root ewoc header footer revision-hash-ids last-n) + (assert (every (lambda (x) (typep x 'xmtn--hash-id)) revision-hash-ids)) + (ewoc-set-hf ewoc header footer) + (ewoc-filter ewoc (lambda (x) nil)) ; Clear it. + (xmtn-automate-with-session (session root) + (setq revision-hash-ids (xmtn--toposort root revision-hash-ids)) + (if last-n + (let ((len (length revision-hash-ids))) + (if (> len last-n) + (setq revision-hash-ids (nthcdr (- len last-n) revision-hash-ids))))) + (setq revision-hash-ids (coerce revision-hash-ids 'vector)) + (xmtn--dotimes-with-progress-reporter (i (length revision-hash-ids)) + (case (length revision-hash-ids) + (1 "Setting up revlist buffer (1 revision)...") + (t (format "Setting up revlist buffer (%s revisions)..." + (length revision-hash-ids)))) + ;; Maybe also show parents and children? (Could add toggle + ;; commands to show/hide these.) + (lexical-let ((rev (aref revision-hash-ids i)) + (branches (list)) + (authors (list)) + (dates (list)) + (changelogs (list)) + (tags (list))) + (xmtn--map-parsed-certs + root rev + (lambda (key signature name value trusted) + (declare (ignore key)) + (unless (not trusted) + (cond ((equal name "author") + (push value authors)) + ((equal name "date") + (push value dates)) + ((equal name "changelog") + (push value changelogs)) + ((equal name "branch") + (push value branches)) + ((equal name "tag") + (push value tags)) + (t + (progn)))))) + (setq authors (nreverse authors) + dates (nreverse dates) + changelogs (nreverse changelogs) + branches (nreverse branches) + tags (nreverse tags)) + (let ((parent-hash-ids + (xmtn-automate-simple-command-output-lines root `("parents" + ,rev))) + (child-hash-ids + (xmtn-automate-simple-command-output-lines root `("children" + ,rev)))) + (xmtn--assert-optional (every #'stringp authors)) + (xmtn--assert-optional (every #'stringp dates)) + (xmtn--assert-optional (every #'stringp changelogs)) + (xmtn--assert-optional (every #'stringp branches)) + (xmtn--assert-optional (every #'stringp tags)) + (xmtn--assert-optional (every #'xmtn--hash-id-p parent-hash-ids)) + (xmtn--assert-optional (every #'xmtn--hash-id-p child-hash-ids)) + (ewoc-enter-last ewoc + ;; Creating a list `(entry-patch + ;; ,instance-of-dvc-revlist-entry-patch) seems + ;; to be part of DVC's API. + `(entry-patch + ,(make-dvc-revlist-entry-patch + :dvc 'xmtn + :rev-id `(xmtn (revision ,rev)) + :struct (xmtn--make-revlist-entry + :revision-hash-id rev + :branches branches + :authors authors + :dates dates + :changelogs changelogs + :tags tags + :parent-hash-ids parent-hash-ids + :child-hash-ids child-hash-ids)))))))) + nil) + +(defun xmtn-revision-st-message (entry) + (mapconcat #'identity (xmtn--revlist-entry-changelogs entry) "\n")) + +(defun xmtn--revlist-refresh () + (let ((root default-directory)) + (destructuring-bind (merge-destination-branch + header-lines footer-lines revision-hash-ids) + (funcall xmtn--revlist-*info-generator-fn* root) + (setq xmtn--revlist-*merge-destination-branch* merge-destination-branch) + (let ((ewoc dvc-revlist-cookie)) + (xmtn--revlist-setup-ewoc root ewoc + (with-temp-buffer + (dolist (line header-lines) + (if (null line) + (insert ?\n) + (insert line ?\n))) + (when header-lines (insert ?\n)) + (buffer-string)) + (with-temp-buffer + (when footer-lines (insert ?\n)) + (dolist (line footer-lines) + (if (null line) + (insert ?\n) + (insert line ?\n))) + (buffer-string)) + revision-hash-ids + dvc-revlist-last-n) + (if (null (ewoc-nth ewoc 0)) + (goto-char (point-max)) + (ewoc-goto-node ewoc (ewoc-nth ewoc 0)))))) + nil) + +(defun xmtn--setup-revlist (root info-generator-fn first-line-only-p last-n) + ;; Adapted from `dvc-build-revision-list'. + ;; info-generator-fn must return a list of back-end revision ids (strings) + (xmtn-automate-with-session (nil root) + (let ((dvc-temp-current-active-dvc 'xmtn) + (buffer (dvc-revlist-create-buffer + 'xmtn 'log root 'xmtn--revlist-refresh first-line-only-p last-n))) + (with-current-buffer buffer + (setq xmtn--revlist-*info-generator-fn* info-generator-fn) + (xmtn--revlist-refresh)) + (xmtn--display-buffer-maybe buffer nil))) + nil) + +;;;###autoload +(defun xmtn-dvc-log (path last-n) + ;; path may be nil or a file. The front-end ensures that + ;; 'default-directory' is set to a tree root. + (xmtn--log-helper default-directory path t last-n)) + +;;;###autoload +(defun xmtn-log (&optional path last-n) + ;; This could be generated by dvc-back-end-wrappers, but xhg, xgit + ;; versions of dvc-log are too different. + (interactive) + (let ((dvc-temp-current-active-dvc 'xmtn)) + (if (interactive-p) + (call-interactively 'dvc-log) + (funcall 'dvc-log path last-n)))) + +;;;###autoload +(defun xmtn-dvc-changelog (&optional path) + (xmtn--log-helper (dvc-tree-root) path nil nil)) + +(defun xmtn--log-helper (root path first-line-only-p last-n) + (if path + (xmtn-list-revisions-modifying-file path nil first-line-only-p last-n) + (xmtn--setup-revlist + root + (lambda (root) + (xmtn-automate-with-session + (nil root) + (let ((branch (xmtn--tree-default-branch root))) + (list branch + (list + (if dvc-revlist-last-n + (format "Log for branch %s (last %d entries):" branch dvc-revlist-last-n) + (format "Log for branch %s (all entries):" branch))) + '() + (xmtn--expand-selector + root + ;; This restriction to current branch is completely + ;; arbitrary. + (concat + "b:" ;; returns all revs for current branch + (xmtn--escape-branch-name-for-selector + branch))))))) + first-line-only-p + last-n))) + +(defun xmtn--revlist--missing-get-info (root) + (xmtn-automate-with-session (nil root) + (let* ((branch (xmtn--tree-default-branch root)) + (heads (xmtn--heads root branch)) + (base-revision-hash-id (xmtn--get-base-revision-hash-id root)) + (difference + (delete-duplicates + (mapcan + (lambda (head) + (xmtn-automate-simple-command-output-lines + root + `("ancestry_difference" + ,head ,base-revision-hash-id))) + heads)))) + (list + branch + `(,(format "Tree %s" root) + ,(format "Branch %s" branch) + ,(format "Base %s" base-revision-hash-id) + ,(case (length heads) + (1 "branch is merged") + (t (dvc-face-add (format "branch has %s heads; need merge" (length heads)) 'dvc-conflict))) + nil + ,(case (length difference) + (0 "No revisions that are not in base revision") + (1 "1 revision that is not in base revision:") + (t (format + "%s revisions that are not in base revision:" + (length difference))))) + '() + difference)))) + +(defun xmtn-revlist-show-conflicts () + "If point is on a revision that has two parents, show conflicts +from the merge." + ;; IMPROVEME: We just use the xmtn conflicts machinery for now. It + ;; would be better if we had a read-only version of it. And a way to + ;; compare to the actual result. + (interactive) + (let ((changelog (car (xmtn--revlist-entry-changelogs (dvc-revlist-entry-patch-struct (dvc-revlist-current-patch))))) + left-start left-end left-rev right-start right-end right-rev) + ;; string-match does _not_ set up match-strings properly, so we do this instead + (cond + ((string= (substring changelog 0 9) "propagate") + (setq left-start (+ 6 (string-match "(head" changelog))) + (setq left-end (string-match ")" changelog left-start)) + (setq right-start (+ 6 (string-match "(head .*)" changelog left-start))) + (setq right-end (string-match ")" changelog right-start))) + + ((string= (substring changelog 0 5) "merge") + (setq left-start (+ 4 (string-match "of" changelog))) + (setq left-end (string-match "'" changelog left-start)) + (setq right-start (+ 5 (string-match "and" changelog left-start))) + (setq right-end (string-match "'" changelog right-start))) + + (t + (error "not on a two parent revision"))) + + (setq left-rev (substring changelog left-start (1- left-end))) + (setq right-rev (substring changelog right-start (1- right-end))) + + (dvc-run-dvc-async + 'xmtn + (list "conflicts" "store" left-rev right-rev) + :finished (lambda (output error status arguments) + (let ((conflicts-buffer (dvc-get-buffer-create 'xmtn 'conflicts default-directory))) + (pop-to-buffer conflicts-buffer) + (set (make-local-variable 'after-insert-file-functions) '(xmtn-conflicts-after-insert-file)) + (insert-file-contents "_MTN/conflicts" t))) + + :error (lambda (output error status arguments) + (xmtn-dvc-log-clean) + (pop-to-buffer error))))) + +;;;###autoload +(defvar xmtn-revlist-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "CM" 'xmtn-conflicts-merge) + (define-key map "CP" 'xmtn-conflicts-propagate) + (define-key map "CR" 'xmtn-conflicts-review) + (define-key map "CC" 'xmtn-conflicts-clean) + (define-key map "MH" 'xmtn-view-heads-revlist) + (define-key map "MP" 'xmtn-propagate-from) + (define-key map "MC" 'xmtn-revlist-show-conflicts) + map)) + +;; items added here should probably also be added to xmtn-diff-mode-menu, -map in xmtn-dvc.el +(easy-menu-define xmtn-revlist-mode-menu xmtn-revlist-mode-map + "Mtn specific revlist menu." + `("DVC-Mtn" + ["View Heads" xmtn-view-heads-revlist t] + ["Show merge conflicts before merge" xmtn-conflicts-merge t] + ["Show merge conflicts after merge" xmtn-revlist-show-conflicts t] + ["Show propagate conflicts" xmtn-conflicts-propagate t] + ["Review conflicts" xmtn-conflicts-review t] + ["Propagate branch" xmtn-propagate-from t] + ["Clean conflicts resolutions" xmtn-conflicts-clean t] + )) + +(define-derived-mode xmtn-revlist-mode dvc-revlist-mode "xmtn-revlist" + "Add back-end-specific commands for dvc-revlist.") + +(dvc-add-uniquify-directory-mode 'xmtn-revlist-mode) + +;;;###autoload +(defun xmtn-dvc-missing (&optional other) + ;; `other', if non-nil, designates a remote repository (see bzr); mtn doesn't support that. + (let ((root (dvc-tree-root))) + (xmtn--setup-revlist + root + 'xmtn--revlist--missing-get-info + ;; Passing nil as first-line-only-p is arbitrary here. + ;; + ;; When the missing revs are due to a propagate, there can be a + ;; lot of them, but we only really need to see the revs since the + ;; propagate. So dvc-log-last-n is appropriate. We use + ;; dvc-log-last-n, not dvc-revlist-last-n, because -log is user + ;; customizable. + nil dvc-log-last-n)) + nil) + +;;;###autoload +(defun xmtn-view-heads-revlist () + "Display a revlist buffer showing the heads of the current branch." + (interactive) + (let ((root (dvc-tree-root))) + (xmtn--setup-revlist + root + (lambda (root) + (xmtn-automate-with-session (nil root) + (let* ((branch (xmtn--tree-default-branch root)) + (head-revision-hash-ids (xmtn--heads root branch)) + (head-count (length head-revision-hash-ids))) + (list + branch + (list (format "Tree %s" root) + (format "Branch %s" branch) + (case head-count + (0 "No head revisions (branch empty (or circular ;))") + (1 "1 head revision:") + (t (format "%s head revisions: " head-count)))) + '() + head-revision-hash-ids)))) + ;; Passing nil as first-line-only-p, last-n is arbitrary here. + nil nil)) + nil) + +;;;###autoload +;; This function doesn't quite offer the interface I really want: From +;; the resulting revlist buffer, there's no way to request a diff +;; restricted to the file in question. But it's still handy. +(defun xmtn-list-revisions-modifying-file (file &optional last-backend-id first-line-only-p last-n) + "Display a revlist buffer showing the revisions that modify FILE. + +Only ancestors of revision LAST-BACKEND-ID will be considered. +FILE is a file name in revision LAST-BACKEND-ID, which defaults +to the base revision of the current tree." + (interactive "FList revisions modifying file: ") + (let* ((root (dvc-tree-root)) + (normalized-file (xmtn--normalize-file-name root file))) + (unless last-backend-id + (setq last-backend-id `(last-revision ,root 1))) + (lexical-let ((last-backend-id last-backend-id) + (file file) + (normalized-file normalized-file)) + (xmtn--setup-revlist + root + (lambda (root) + (xmtn-automate-with-session (nil root) + (let ((branch (xmtn--tree-default-branch root)) + (revision-hash-ids + (mapcar #'first + (xmtn--get-content-changed-closure + root last-backend-id normalized-file dvc-revlist-last-n)))) + (list + branch + (list + (if dvc-revlist-last-n + (format "Log for %s (last %d entries)" file dvc-revlist-last-n) + (format "Log for %s" file))) + '() + revision-hash-ids)))) + first-line-only-p + last-n)))) + +(defvar xmtn--*selector-history* nil) + +;;;###autoload +(defun xmtn-view-revlist-for-selector (selector) + "Display a revlist buffer showing the revisions matching SELECTOR." + (interactive (list (read-string "View revlist for selector: " + nil + 'xmtn--*selector-history* + nil))) + (check-type selector string) + (let ((root (dvc-tree-root))) + (lexical-let ((selector selector)) + (xmtn--setup-revlist + root + (lambda (root) + (xmtn-automate-with-session (nil root) + (let* ((branch (xmtn--tree-default-branch root)) + (revision-hash-ids (xmtn--expand-selector root selector)) + (count (length revision-hash-ids))) + (list + branch + (list (format "Tree %s" root) + (format "Default branch %s" branch) + (if (with-syntax-table (standard-syntax-table) + (string-match "\\`\\s *\\'" selector)) + "Blank selector" + (format "Selector %s" selector)) + (case count + (0 "No revisions matching selector") + (1 "1 revision matching selector:") + (t (format "%s revisions matching selector: " + count)))) + '() + revision-hash-ids)))) + ;; Passing nil as first-line-only-p is arbitrary here. + nil + ;; FIXME: it might be useful to specify last-n here + nil))) + nil) + +;; This generates the output shown when the user hits RET on a +;; revision in the revlist buffer. +;;;###autoload +(defun xmtn-dvc-revlog-get-revision (revision-id) + (let ((root (dvc-tree-root))) + (xmtn-automate-with-session (nil root) + (let ((backend-id (xmtn--resolve-revision-id root revision-id))) + (xmtn-match backend-id + ((local-tree $path) (error "Not implemented")) + ((revision $revision-hash-id) + (with-output-to-string + (flet ((write-line (format &rest args) + (princ (apply #'format format args)) + (terpri))) + (write-line "Revision %s" revision-hash-id) + ;; FIXME: It would be good to sort the standard certs + ;; like author, date, branch, tag and changelog into + ;; some canonical order and format changelog specially + ;; since it usually spans multiple lines. + (xmtn--map-parsed-certs + root revision-hash-id + (lambda (key signature name value trusted) + (declare (ignore key)) + (if (not trusted) + (write-line "Untrusted cert, name=%s" name) + (write-line "%s: %s" name value)))))))))))) + + +(defun xmtn-revlist-explicit-merge () + "Run mtn explicit_merge on the two marked revisions. + +To be invoked from an xmtn revlist buffer." + (interactive) + (let ((entries (dvc-revision-marked-revisions)) + (root (dvc-tree-root))) + (unless (eql (length entries) 2) + (error "Precisely 2 revisions must be marked for merge, not %s" + (length entries))) + (let ((hash-ids (mapcar #'xmtn--revlist-entry-revision-hash-id entries)) + (destination-branch-name xmtn--revlist-*merge-destination-branch*)) + ;; FIXME: Does it make any difference which one we choose as + ;; "left" and which one we choose as "right"? (If it does, we + ;; should also make their selection in the UI asymmetrical: For + ;; example, require precisely one marked revision and use the + ;; one at point as the other.) + (destructuring-bind (left right) hash-ids + (unless (yes-or-no-p + (format "Merge revisions %s and %s onto branch %s? " + left right destination-branch-name)) + (error "Aborted merge")) + (xmtn--do-explicit-merge root left right destination-branch-name)))) + nil) + +(defun xmtn-revlist-update () + "Update current tree to the revision at point. + +To be invoked from an xmtn revlist buffer." + (interactive) + (let* ((root (dvc-tree-root)) + (entry (dvc-revlist-current-patch-struct)) + (target-hash-id (xmtn--revlist-entry-revision-hash-id entry))) + (xmtn--update root target-hash-id))) + +;; Being able to conveniently disapprove whole batches of revisions +;; is going to be a lot of fun. +(defun xmtn-revlist-disapprove () + "Disapprove the marked revisions, or the revision at point if none marked. + +To be invoked from an xmtn revlist buffer." + (interactive) + (let* ((root (dvc-tree-root)) + (entries (or (dvc-revision-marked-revisions) + (list (dvc-revlist-current-patch-struct)))) + (hash-ids (map 'vector #'xmtn--revlist-entry-revision-hash-id entries)) + (description (case (length hash-ids) + (0 (xmtn--assert-nil)) + (1 (format "revision %s" (elt hash-ids 0))) + (t (format "%s revisions" (length hash-ids)))))) + (assert (every #'xmtn--hash-id-p hash-ids)) + (unless (yes-or-no-p (format "Disapprove %s? " description)) + (error "Aborted disapprove")) + (xmtn--dotimes-with-progress-reporter (i (length hash-ids)) + (format "Disapproving %s..." description) + (let ((hash-id (aref hash-ids i))) + (funcall (xmtn--do-disapprove-future root hash-id)))))) + +(provide 'xmtn-revlist) + +;;; xmtn-revlist.el ends here diff --git a/dvc/lisp/xmtn-run.el b/dvc/lisp/xmtn-run.el new file mode 100644 index 0000000..a8ec62c --- /dev/null +++ b/dvc/lisp/xmtn-run.el @@ -0,0 +1,408 @@ +;;; xmtn-run.el --- Functions for runnning monotone commands + +;; Copyright (C) 2008 - 2009 Stephen Leake +;; Copyright (C) 2006, 2007 Christian M. Ohler + +;; Author: Christian M. Ohler +;; 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 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: + +;; This file provides functions for running monotone commands. See +;; xmtn-automate.el for more sophisticated access to monotone's +;; automate interface. + +;;; Code: + +;;; There are some notes on the design of xmtn in +;;; docs/xmtn-readme.txt. + +(eval-and-compile + (require 'cl) + (require 'dvc-unified) + (when (featurep 'xemacs) + (condition-case nil + (require 'un-define) + (error nil))) + (require 'xmtn-base)) + +(define-coding-system-alias 'xmtn--monotone-normal-form 'utf-8-unix) + +(defun xmtn--call-with-environment-for-subprocess (xmtn--thunk) + (let ((process-environment (list* "LC_ALL=" + "LC_CTYPE=en_US.UTF-8" + "LC_MESSAGES=C" + process-environment))) + (funcall xmtn--thunk))) + +(defmacro* xmtn--with-environment-for-subprocess (() &body body) + (declare (indent 1) (debug (sexp body))) + `(xmtn--call-with-environment-for-subprocess (lambda () ,@body))) + +(defun* xmtn--run-command-sync (root arguments &rest dvc-run-keys &key) + (xmtn--check-cached-command-version) + (let ((default-directory (file-truename (or root default-directory)))) + (let ((coding-system-for-write 'xmtn--monotone-normal-form)) + (xmtn--with-environment-for-subprocess () + (apply #'dvc-run-dvc-sync + 'xmtn + `(,@xmtn-additional-arguments + ;; We don't pass the --root argument here; it is not + ;; necessary since default-directory is set, and it + ;; confuses the Cygwin version of mtn when run with a + ;; non-Cygwin Emacs. + ,@arguments) + dvc-run-keys))))) + +;;; The `dvc-run-dvc-*' functions use `call-process', which, for some +;;; reason, spawns the subprocess with a working directory with all +;;; symlinks expanded. (Or maybe it's the shell that expands the +;;; symlinks.) If the path to the root directory looks different from +;;; the current working directory, monotone rejects it even if it is +;;; the same via symlinks. Therefore, we need to resolve symlinks +;;; here in strategic places. Hence the calls to `file-truename'. + +(defun* xmtn--run-command-async (root arguments &rest dvc-run-keys &key) + (xmtn--check-cached-command-version) + (let ((default-directory (file-truename (or root default-directory)))) + (let ((coding-system-for-write 'xmtn--monotone-normal-form)) + (xmtn--with-environment-for-subprocess () + (apply #'dvc-run-dvc-async + 'xmtn + `(,@xmtn-additional-arguments + ;; We don't pass the --root argument here; it is not + ;; necessary since default-directory is set, and it + ;; confuses the Cygwin version of mtn when run with a + ;; non-Cygwin Emacs. + ,@arguments) + dvc-run-keys))))) + +(defun* xmtn--command-append-to-buffer-async (buffer root arguments + &rest dvc-run-keys + &key finished) + (xmtn--check-cached-command-version) + (let ((default-directory (file-truename (or root default-directory)))) + (let ((coding-system-for-write 'xmtn--monotone-normal-form)) + (xmtn--with-environment-for-subprocess () + (apply #'dvc-run-dvc-async + 'xmtn + `(,@xmtn-additional-arguments + ,@(if root `(,(concat "--root=" (file-truename root)))) + ,@arguments) + :finished (lexical-let ((buffer buffer) + (finished finished)) + (lambda (output error status arguments) + (with-current-buffer buffer + (save-excursion + (goto-char (point-max)) + (let ((inhibit-read-only t)) + (insert-buffer-substring output)))) + (funcall (or finished #'dvc-default-finish-function) + output error status arguments))) + :related-buffer buffer + dvc-run-keys))))) + +(defun* xmtn--command-lines-future (root which-buffer arguments) + (xmtn--check-cached-command-version) + (lexical-let ((got-output-p nil) + lines) + (lexical-let + ((process + (let ((default-directory (file-truename (or root + default-directory)))) + (let ((coding-system-for-write 'xmtn--monotone-normal-form)) + (xmtn--with-environment-for-subprocess () + (dvc-run-dvc-async + 'xmtn + `(,@xmtn-additional-arguments + ,@(if root `(,(concat "--root=" (file-truename root)))) + ,@arguments) + :finished + (lexical-let ((which-buffer which-buffer)) + (lambda (output error status arguments) + (with-current-buffer (ecase which-buffer + (output output) + (error error)) + (save-excursion + (goto-char (point-min)) + (setq lines + (loop until (eobp) + collect + (buffer-substring-no-properties + (point) + (progn (end-of-line) (point))) + do (forward-line 1))) + (setq got-output-p t))) + nil)))))))) + (lambda () + (assert (member (process-status process) '(run exit signal)) t) + (while (and (eql (process-status process) 'run) + (accept-process-output process))) + (assert (member (process-status process) '(exit signal)) t) + ;; This (including discarding input) is needed to allow the + ;; sentinel to run, at least on GNU Emacs 21.4.2 and on GNU + ;; Emacs 22.0.50.1 of 2006-06-13. Sentinels are supposed to + ;; be run when `accept-process-output' is called, but they + ;; apparently aren't reliably. I haven't investigated this + ;; further. + ;; + ;; Problems with the sentinel not running mostly seem to be + ;; reproducible (after commenting out the code below) by + ;; pressing C-x V c immediately followed by a few other keys, + ;; or by pressing C-x V c not followed by any further input, + ;; or by editing a file in the tree without saving it, then + ;; pressing C-x V c, waiting for the "Save buffer?" prompt and + ;; then pressing y immediately followed by a few other keys. + ;; + ;; I hate having to discard the input because it interferes + ;; with typing ahead while Emacs is still busy. But hanging + ;; indefinitely waiting for `got-output-p' from a sentinel + ;; that never runs is even worse. + (while (and (eql (process-status process) 'exit) + (eql (process-exit-status process) 0) + (not got-output-p)) + (discard-input) + (sit-for .01)) + (unless got-output-p + (assert (not (and (eql (process-status process) 'exit) + (eql (process-exit-status process) 0)))) + (error "Process %s terminated abnormally, status=%s, exit code=%s" + (process-name process) + (process-status process) + (process-exit-status process))) + lines)))) + +(defun* xmtn--command-output-lines-future (root arguments) + (xmtn--command-lines-future root 'output arguments)) + +(defun* xmtn--command-error-output-lines-future (root arguments) + (xmtn--command-lines-future root 'error arguments)) + +(defun xmtn--command-output-lines (root arguments) + "Run mtn in ROOT with ARGUMENTS and return its output as a list of strings." + (xmtn--check-cached-command-version) + (let ((accu (list))) + (let ((default-directory (file-truename (or root default-directory)))) + (let ((coding-system-for-write 'xmtn--monotone-normal-form)) + (xmtn--with-environment-for-subprocess () + (dvc-run-dvc-sync + 'xmtn + `(,@xmtn-additional-arguments + ,@(if root `(,(concat "--root=" (file-truename root)))) + ,@arguments) + :finished (lambda (output error status arguments) + (with-current-buffer output + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (push (buffer-substring-no-properties + (point) + (progn (end-of-line) (point))) + accu) + (forward-line 1))))))))) + (setq accu (nreverse accu)) + accu)) + +(defun xmtn--command-output-line (root arguments) + "Run mtn in ROOT with ARGUMENTS and return the one line of output as string. + +Signals an error if more (or fewer) than one line is output." + (let ((lines (xmtn--command-output-lines root arguments))) + (unless (eql (length lines) 1) + (error "Expected precisely one line of output from monotone, got %s: %s %S" + (length lines) + xmtn-executable + arguments)) + (first lines))) + +(defconst xmtn--minimum-required-command-version '(0 45)) + +(defun xmtn--have-no-ignore () + "Non-nil if mtn automate inventory supports --no-ignore, --no-unknown, --no-unchanged options." + (>= (xmtn-dvc-automate-version) 7.0)) + +(defvar xmtn--*cached-command-version* nil) +(defvar xmtn--*command-version-cached-for-executable* nil) + +(defun xmtn--clear-command-version-cache () + (setq xmtn--*command-version-cached-for-executable* nil + ;; This is redundant but neater. + xmtn--*cached-command-version* nil)) + +(defun xmtn--cached-command-version () + (if (equal xmtn--*command-version-cached-for-executable* xmtn-executable) + xmtn--*cached-command-version* + (let ((executable xmtn-executable)) + (prog1 (setq xmtn--*cached-command-version* (xmtn--command-version + executable)) + (setq xmtn--*command-version-cached-for-executable* executable) + (xmtn--check-cached-command-version))))) + +(defun xmtn--command-version (executable) + "Return EXECUTABLE's version as a list (MAJOR MINOR REVISION VERSION-STRING). + +VERSION-STRING is the string printed by mtn --version (with no +trailing newline). MAJOR and MINOR are integers, a parsed +representation of the version number. REVISION is the revision +id." + (let ( + ;; Cache a fake version number to avoid infinite mutual + ;; recursion. + (xmtn--*cached-command-version* + (append xmtn--minimum-required-command-version + '("xmtn-dummy" "xmtn-dummy"))) + (xmtn--*command-version-cached-for-executable* executable) + (xmtn-executable executable)) + (let ((string (xmtn--command-output-line nil '("--version")))) + (unless (string-match + (concat "\\`monotone \\([0-9]+\\)\\.\\([0-9]+\\)\\(dev\\)?" + " (base revision: \\(unknown\\|\\([0-9a-f]\\{40\\}\\)\\))\\'") + string) + (error (concat "Version output from monotone --version" + " did not match expected pattern: %S") + string)) + (let ((major (parse-integer string (match-beginning 1) (match-end 1))) + (minor (parse-integer string (match-beginning 2) (match-end 2))) + (revision (match-string 4 string))) + (list major minor revision string))))) + +(defun xmtn--check-cached-command-version () + (let ((minimum-version xmtn--minimum-required-command-version)) + (destructuring-bind (major minor revision string) + (xmtn--cached-command-version) + (unless (or (> major (car minimum-version)) + (and (= major (car minimum-version)) + (>= minor (cadr minimum-version)))) + ;; Clear cache now since the user is somewhat likely to + ;; upgrade mtn (or change the value of `xmtn-executable') + ;; after this message. + (xmtn--clear-command-version-cache) + (error (concat "xmtn does not work with mtn versions below %s.%s" + " (%s is %s)") + (car minimum-version) (cadr minimum-version) + xmtn-executable string))) + nil)) + +;;;###autoload +(defun xmtn-check-command-version () + "Check and display the version identifier of the mtn command. + +This command resets xmtn's command version cache." + (interactive) + (xmtn--clear-command-version-cache) + (destructuring-bind (major minor revision version-string) + (xmtn--cached-command-version) + (let* ((latest (xmtn--latest-mtn-release)) + (latest-major (first latest)) + (latest-minor (second latest))) + (if (eval `(xmtn--version-case + ((and (= ,latest-major latest-minor) + (mainline> latest-major latest-minor)) + t) + (t + nil))) + (message "%s (xmtn considers this version newer than %s.%s)" + version-string major minor) + (message "%s" version-string)))) + nil) + +(defun xmtn--make-version-check-form (version-var condition) + ;; The expression (mainline> X Y) matches all command versions + ;; strictly newer than X.Y, and, if X.Y is the latest version + ;; according to (xmtn--latest-mtn-release), command versions that + ;; report version X.Y with a revision ID different from what + ;; (xmtn--latest-mtn-release) returns. This is a kludge to attempt + ;; to distinguish the latest mtn release from the current + ;; bleeding-edge ("mainline") version. (Bleeding-edge mtn versions + ;; always report a version equal to the last release, while they + ;; generally have syntax and semantics that match the upcoming + ;; release; i.e., their syntax and semantics don't match the version + ;; number they report.) + (case condition + ((t) `t) + ((nil) `nil) + (t + (let ((operator (car condition)) + (arguments (cdr condition))) + (ecase operator + ((< <= > >= = /= mainline>) + (let ((target-version arguments)) + (assert (eql (length arguments) 2)) + (ecase operator + ((=) + `(and (= (car ,version-var) ,(car target-version)) + (= (cadr ,version-var) ,(cadr target-version)))) + ((< >) + `(or (,operator (car ,version-var) ,(car target-version)) + (and + (= (car ,version-var) ,(car target-version)) + (,operator (cadr ,version-var) ,(cadr target-version))))) + ((mainline>) + `(or (> (car ,version-var) ,(car target-version)) + (and (= (car ,version-var) ,(car target-version)) + (or (> (cadr ,version-var) ,(cadr target-version)) + (and (= (cadr ,version-var) ,(cadr target-version)) + (let ((-latest- (xmtn--latest-mtn-release))) + (and (= (car -latest-) ,(car target-version)) + (= (cadr -latest-) + ,(cadr target-version)) + (not (equal (caddr ,version-var) + (caddr -latest-)))))))))) + ((/= <= >=) + (let ((negated-operator (ecase operator + (/= '=) + (<= '>) + (>= '<)))) + `(not ,(xmtn--make-version-check-form version-var + `(,negated-operator + ,@arguments)))))))) + ((not) + (assert (eql (length arguments) 1)) + `(not ,(xmtn--make-version-check-form version-var (first arguments)))) + ((and or) + `(,operator + ,@(loop for subform in arguments + collect + (xmtn--make-version-check-form version-var subform))))))))) + +(defun xmtn--signal-unsupported-version (version supported-conditions) + (error "Operation only implemented for monotone versions matching %S" + ;; This message is probably not very helpful to users who + ;; don't know xmtn's internals. + `(or ,@supported-conditions))) + +(defmacro* xmtn--version-case (&body clauses) + (let ((version (gensym))) + `(let ((,version (xmtn--cached-command-version))) + (cond ,@(loop for (condition . body) in clauses + collect `(,(xmtn--make-version-check-form version + condition) + ,@body)) + (t (xmtn--signal-unsupported-version + ,version + ',(loop for (condition . nil) in clauses + collect condition))))))) + +(defun xmtn--latest-mtn-release () + ;; Version number and revision id of the latest mtn release at the + ;; time of this xmtn release. + '(0 35 "f92dd754bf5c1e6eddc9c462b8d68691cfeb7f8b")) + +(provide 'xmtn-run) + +;;; xmtn-run.el ends here diff --git a/dvc/scripts/dvc-cron.sh b/dvc/scripts/dvc-cron.sh new file mode 100644 index 0000000..c6585b5 --- /dev/null +++ b/dvc/scripts/dvc-cron.sh @@ -0,0 +1,29 @@ +#! /bin/bash + +# Generates the tarball and html documentation, upload it to gna.org +# This file is currently used only by Matthieu MOY, and is provided +# here only as an example. Copy it and modify it if you wish to use it. + +export PATH=${HOME}/bin/local/verimag:${PATH} + +cd `dirname $0`/.. +mkdir -p tmp + +echo "Executing $0 on $(date)." + +rm -f dvc-snapshot.tar.gz +make MKDIR_P='mkdir -p' tarball || rm -f dvc-snapshot.tar.gz +if [ ! -f dvc-snapshot.tar.gz ]; then + echo "Error creating tarball" + exit 1 +fi +mkdir -p www/download/ +cp dvc-snapshot.tar.gz www/download/ +make MKDIR_P='mkdir -p' -C texinfo dvc.html +mkdir -p www/docs/ +cp texinfo/dvc.html www/docs/dvc-snapshot.html + +# upload source and non-source at the same time +rsync -av www/ moy@download.gna.org:/upload/dvc/ + +echo "Finished $0 on $(date)" diff --git a/dvc/scripts/make-deb-pkg.sh b/dvc/scripts/make-deb-pkg.sh new file mode 100644 index 0000000..9f3ffbb --- /dev/null +++ b/dvc/scripts/make-deb-pkg.sh @@ -0,0 +1,40 @@ +#!/bin/sh + +upload=no + +while test $# -ne 0; do + case "$1" in + "--upload") + shift + upload="yes" + ;; + *) + break + ;; + esac +done + + +echo "building package ..." +dpkg-buildpackage -rfakeroot -d +echo "building package ... done" + +mkdir -p ++apt-repository +cd ++apt-repository +rsync -avr moy@download.gna.org:/upload/xtla-el/apt . +mv ../../*.deb apt/unstable +if which lintian > /dev/null; then + lintian -c -vi apt/unstable/*.deb +fi + +cd apt +apt-ftparchive packages . | gzip > unstable/Packages.gz +if [ "x$upload" = "xyes" ] ; then + rsync -avr . moy@download.gna.org:/upload/xtla-el/apt + echo + echo + echo "Files uploaded:" + find . +else + echo "No file uploaded (use --upload to upload)" +fi diff --git a/dvc/scripts/rename-tla-dvc.sh b/dvc/scripts/rename-tla-dvc.sh new file mode 100644 index 0000000..07a1449 --- /dev/null +++ b/dvc/scripts/rename-tla-dvc.sh @@ -0,0 +1,9 @@ +#! /bin/sh + +if [ $# -ne 1 ] +then + echo "usage: $(basename $0) string" + exit 1 +fi + +perl -pi -e "s/tla-($1)/dvc-\$1/g" *.el diff --git a/dvc/scripts/tla-tree-revision.sh b/dvc/scripts/tla-tree-revision.sh new file mode 100644 index 0000000..0a1cdbd --- /dev/null +++ b/dvc/scripts/tla-tree-revision.sh @@ -0,0 +1,4 @@ +#! /bin/sh + +tla logs --full | tail -1 + diff --git a/dvc/tests/changes-nochange.txt b/dvc/tests/changes-nochange.txt new file mode 100644 index 0000000..18dc80d --- /dev/null +++ b/dvc/tests/changes-nochange.txt @@ -0,0 +1,5 @@ + +* No changes in $HOME/xtla--test--1.0/. + + + diff --git a/dvc/tests/make-archive-archives.txt b/dvc/tests/make-archive-archives.txt new file mode 100644 index 0000000..a0401ff --- /dev/null +++ b/dvc/tests/make-archive-archives.txt @@ -0,0 +1,2 @@ + foo@bar.com--2004 + $HOME/archive diff --git a/dvc/texinfo/Makefile.in b/dvc/texinfo/Makefile.in new file mode 100644 index 0000000..3995cb2 --- /dev/null +++ b/dvc/texinfo/Makefile.in @@ -0,0 +1,86 @@ +@SET_MAKE@ + +srcdir = @srcdir@ +top_srcdir = @top_srcdir@ +PACKAGE_VERSION = @PACKAGE_VERSION@ + +############################################################################## +# location of required programms +RM = @RM@ +MKDIR_P = @MKDIR_P@ +INSTALL = @INSTALL@ +INSTALL_DATA = @INSTALL_DATA@ +MAKEINFO = makeinfo +TEXI2DVI = texi2dvi + +# Other settings +datarootdir = @datarootdir@ +prefix = @prefix@ +info_dir = @info_dir@ + +############################################################################## +all: info dvc.dvi dvc.html dvc.pdf + +dvi: dvc.dvi + +pdf: dvc.pdf + +html: dvc.html + +Makefile: $(srcdir)/Makefile.in ../config.status + cd ..; ./config.status + +ii = install-info + +install: uninstall info + $(MKDIR_P) -m 0755 $(info_dir) + @for i in dvc.info* ; do \ + echo Installing $$i ; \ + $(INSTALL_DATA) $$i $(info_dir) ; \ + done + @if ($(ii) --version && \ + $(ii) --version 2>&1 | sed 1q | grep -i -v debian) \ + >/dev/null 2>&1 ; then \ + $(ii) --info-dir="$(info_dir)" "$(info_dir)/dvc.info" \ + || : ; else : ; \ + fi + +uninstall: + rm -f $(info_dir)/dvc.info* + +info: dvc.info + +alldeps = $(srcdir)/dvc.texinfo dvc-version.texinfo + +dvc.info: $(alldeps) + $(MAKEINFO) $(srcdir)/dvc.texinfo + +dvc.html: $(alldeps) + $(MAKEINFO) --html --no-split $(srcdir)/dvc.texinfo + +dvc.dvi: $(alldeps) + $(TEXI2DVI) -o $@ $(srcdir)/dvc.texinfo + +dvc.pdf: $(alldeps) + $(TEXI2DVI) -o $@ -p $(srcdir)/dvc.texinfo + +clean: + rm -f *.aux *.cp *.cps *.dvi *.pdf *.fn *.fns *.ky *.log *.pg \ + *.toc *.tp *.vr *.vrs *.html *.info + +distclean: clean + rm -f Makefile + +maintainer-clean: + rm -f dvc-version.texinfo + +.PHONY: pdf dvi html info clean distclean install-pkg uninstall-pkg all + +dvc-version.texinfo: $(top_srcdir)/configure + @echo Creating $@ + @( echo @set VERSION $(PACKAGE_VERSION) ; \ + date '+@set UPDATED %F' -r $< ) > $@ + +.PHONY: all dvi pdf html info \ + install uninstall \ + clean distclean maintainer-clean diff --git a/dvc/texinfo/dvc.texinfo b/dvc/texinfo/dvc.texinfo new file mode 100644 index 0000000..66dfcd0 --- /dev/null +++ b/dvc/texinfo/dvc.texinfo @@ -0,0 +1,965 @@ +\input texinfo @c -*-texinfo-*- -*- coding: iso-latin-1 -*- +@c %**start of header +@setfilename dvc.info +@settitle DVC - The Emacs interface to Distributed Version Control Systems +@c If this is set, show images in the HTML version +@c @set SHOW_IMAGES +@c %**end of header + +@ifinfo +@dircategory Emacs +@direntry +* DVC: (dvc). The Emacs interface to Distributed Version + Control Systems. +@end direntry + +Copyright (c) 2004-2005, 2007, 2008 The DVC Development Team +@end ifinfo + +@include dvc-version.texinfo + +@titlepage +@title DVC User Manual +@subtitle The Emacs interface to Distributed Version Control Systems + +@author The DVC Development Team +@page +Copyright @copyright{} 2004-2005 The DVC Development Team + +@sp 2 +This is the @value{UPDATED} edition +of the User Manual for @cite{DVC} @value{VERSION}. + +@sp 2 + +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. + +@end titlepage +@page + +@c ============================================================================ +@node Top, Installation, (dir), (dir) +@chapter DVC + +@b{DVC} is an Emacs front end for various Decentralized Version Control +systems. It is the successor of Xtla, which was the Emacs front-end to +tla (GNU Arch). + +The main features are: + +@itemize @bullet +@item dvc-status: Intuitive interface for viewing the status of a +working directory. +@item dvc-log: Log viewer. Perform actions on specific commits, such as +viewing them and emailing them. +@item dvc-diff: View uncommitted changes in your working directory and +use them to prepare a commit log entry. +@item dvc-bookmarks: Bookmark manager. Keep your most frequently used +repositories and working directories in your bookmark buffer. Also, +specify "partner" branches or repositories, whose changes can be +compared with your work. +@item Integration with ediff, which is an excellent visual interface for +changes between multiple files/versions. This Emacs mode is useful for: +@itemize @bullet +@item Viewing changes made in a local tree. +@item Viewing and resolving conflicts after a merge. +@end itemize +@item dvc-missing: Interface to view missing patches from all your +partners with a single command +@item Send/receive/apply patches via the Gnus email client. +@item Run many version control commands from Emacs (such as init and pull). +@end itemize + +Backends supported: + + @table @dfn + @item Bazaar (bzr) +@url{http://bazaar-vcs.org/} + @item Darcs +@url{http://darcs.net/} + @item Git +@url{http://git.or.cz/} + @item Mercurial (hg) +@url{http://www.selenic.com/mercurial/} + @item Monotone (mtn) +@url{http://www.venge.net/monotone/} + @item GNU Arch (tla) +@url{http://www.gnu.org/software/gnu-arch/} + + @end table + +@c ============================================================================ +@menu +* Installation:: +* DVC Tla Tour:: +* Use cases:: +* Trouble Shooting:: +* Customization:: +* Internals:: +* Mailing Lists:: +* Wiki:: +* Changes:: +* The Latest Version:: +* The Future:: +* Thanks:: +* Concept Index:: +* Variable Index:: +@end menu + +@node Installation, DVC Tla Tour, Top, Top +@section Installation +@cindex Installation +@cindex Makefile + +This program consists of several groups of files, organized by directory: + +@ifinfo +@example + lisp - the main program code + texinfo - the documentation files + docs - text documents for hacking DVC +@end example +@end ifinfo + +@menu +* Dependencies:: +* MS Windows:: +* Hooking into GNU Emacs:: +@end menu + +@c ---------------------------------------------------------------------------- +@node Dependencies, MS Windows, Installation, Installation +@subsection Dependencies + +Various parts of the @b{DVC} require extra packages to be available. +Currently there are the following dependencies: + +@itemize @bullet + +@item @code{ewoc.el}: a utility to maintain a view of a list of objects +in a buffer. This is essential for dvc and a version of @code{ewoc.el} +is included in the distribution until available by an stable version of +XEmacs. It is already included in GNU Emacs 21. + +@item @code{tree-widget.el} is required for @code{xtla-browse.el}. +The CVS version of GNU Emacs includes @code{tree-widget.el}. XEmacs +users should install the latest @b{@code{jde}} package which includes +@code{tree-widget.el}. + +You can also install it as a standalone package. The latest version of +@code{tree-widget.el} can be found at +@url{http://savannah.gnu.org/cgi-bin/viewcvs/emacs/emacs/lisp/tree-widget.el} + +If @code{tree-widget.el} is not in your default @code{load-path}, you +should provide its location with the argument @code{--with-other-dirs} +of the @code{configure} script. + +@item @code{smerge-mode.el}: Minor mode to resolve diff3 conflicts. It +is not essential, but reduces resolving of conflicts to deciding which +version to keep. + +The latest version of @code{smerge-mode.el} can be found at +@url{http://savannah.gnu.org/cgi-bin/viewcvs/emacs/emacs/lisp/smerge-mode.el} + +@end itemize + +@node MS Windows, Hooking into GNU Emacs, Dependencies, Installation +@subsection MS Windows +DVC requires a POSIX shell, used to run the backends. On Unix-like +systems, @file{/bin/sh} should be good. On MS Windows, you will need +to install one. MinGW and Cygwin both work; other POSIX shells are +also available. + +For MinGW, see @url{http://mingw.org/}, and see +@url{http://www.venge.net/mtn-wiki/BuildingOnWindows} for excellent +installation instructions. + +For Cygwin, see @url{http://cygwin.com/}. + +Both MinGW and Cygwin work better with native MS Windows Emacs if +installed to @file{c:/} instead of @file{c:/MinGW} or +@file{c:/Cygwin}. This is because of the way they mount filesystems, +and refer to files not under a mounted directory. + +For example, if Cygwin is installed at @file{c:/Cygwin}, it mounts +@file{/} at @file{c:/Cygwin}. Then the file known to Emacs as +@file{c:/Cygwin/bin/make.exe} is known to Cygwin applications as +@file{/bin/make.exe}. Also, the file known to Emacs as +@file{c:/Projects/my_file.text} is known to Cygwin as +@file{/cygdrive/c/Projects/my_file.text}. This causes problems when +using Cygwin make with native Emacs; Emacs can't find the files make +is reporting in error messages. + +However, if Cygwin is installed at @file{c:/}, then it mounts @file{/} +at @file{c:/}. Then the file known to Emacs as @file{c:/bin/make.exe} +is known to Cygwin applications as @file{/bin/make.exe}. Also, the +file known to Emacs as @file{c:/Projects/my_file.text} is known to +Cygwin as @file{/Projects/my_file.text}. The only difference is the +leading drive letter, which is unnecessary, as long as all files are +on the same drive, which is typical of MS Windows boxes these days. + +MinGW has similar file naming conventions. + +The Cygwin installer warns that installing Cygwin at @file{c:/} is not +recommended. But if you read the rationale for that in the Cygwin +docs, it is because ``you might have other things installed there that +conflict''. While true, that is up to you to control. For example, you +certainly cannot install @emph{both} Cygwin and MinGW at @file{c:/}. + +In general, a backend used by DVC should be run by invoking a Windows +executable, not a DOS batch file or other script. The Emacs variable +@code{explicit-shell-file-name} may help in resolving shell issues. + +@c ---------------------------------------------------------------------------- +@node Hooking into GNU Emacs, , MS Windows, Installation +@subsection Hooking into GNU Emacs +@cindex Hooking into GNU Emacs + +(There is nothing to do for XEmacs users here, just start using +@b{DVC}, i.e. goto @pxref{DVC Tla Tour}) + +If you are reading this document the installation of files and setting +up the @code{load-path} and @code{Info-directory-list} was already +successful and you just need to load @b{DVC} now. + +If auto-loading was built correctly you may start with @code{M-x +tla-archives RET}. + +In order to load @b{DVC} on Emacs start up you should include the following +form in your Emacs configuration file, e.g. @code{~/.emacs.el}: + +@example +@code{(load-file "/path/to/dvc/builddir/dvc-load.el")} +@end example + +Alternatively, you can set your load-path and load the autoload files +manually with + +@example +@code{(require 'dvc-autoloads)} +@code{(add-to-list 'load-path "/path/to/dvc/lisp/")} +@end example + +This will set up @b{DVC}. + +@c ============================================================================ +@node DVC Tla Tour, Use cases, Installation, Top +@section DVC Tla Tour + +This section discusses the basics of @b{DVC} - an overview of the +available commands. + +@menu +* A tutorial guide to DVC:: +* First contact:: DVC is self documented +* Tla Archive Browsing:: The basics of tla archive browsing +* Editing Files:: Inserting tags, adding change logs +* Committing Files:: How to commit your changes +* Using Bookmarks:: Working in a team +* Transmit patches via email:: Send/apply patches via Gnus +@end menu + + +@c ---------------------------------------------------------------------------- + +@node A tutorial guide to DVC, First contact, DVC Tla Tour, DVC Tla Tour +@subsection A tutorial guide to DVC + +The following sections present a step-by-step tutorial guide to using +DVC for some common tasks: registering an archive, bookmarking an +existing project, creating your own local branch, getting a working +tree, merging patches from the main branch and committing changes to +your tree. + +For the purposes of this tutorial, we will use the DVC project as an +example of a project you might like to track (humour me). + +@menu +* Register an tla archive:: +* Bookmarking a project:: +* Creating a branch of a project and getting a project tree:: +* Finding and merging missing patches:: +* Reviewing and committing your changes:: +@end menu + +@node Register an tla archive, Bookmarking a project, A tutorial guide to DVC, A tutorial guide to DVC +@subsubsection Register an tla archive + +The first step in tracking a project's development is to register its +archive in your archive list. You can do this by starting the archive +browser (@kbd{C-x V A}) and typing @kbd{a r} to register a new archive. +DVC's archive location is currently +@url{http://www-verimag.imag.fr/~moy/arch/public/}, and the default +value for the archive name will be fine. Having done this, you should +now see the newly-registered archive listed. + +@ifhtml +@ifset SHOW_IMAGES +@html + +@end html +@end ifset +@end ifhtml + +@node Bookmarking a project, Creating a branch of a project and getting a project tree, Register an tla archive, A tutorial guide to DVC +@subsubsection Bookmarking a project + +The normal usage of DVC is to create a bookmark for each version of a +project you are currently interested in. Much of the arch's +functionality is available from the bookmarks buffer, and it is one of +the primary entry points for DVC. + +To track DVC's development, you will most likely want to add a bookmark +for its main development line. You can do this by entering the +bookmarks buffer (@kbd{C-x V b}) and adding a new bookmark with (@kbd{a +b}, or ``add bookmark''). You should be prompted for a version name, +and you can use tab completion to enter +@code{Matthieu.Moy@@imag.fr--public/dvc--main--0}. You can give your +bookmark any name you like. + +Pressing @kbd{RET} on your newly-added bookmark will show you a revision +list for that version. You can use this list to browse archive logs +(@kbd{RET} again), view changesets (@kbd{=}) and various other tasks. + + +@node Creating a branch of a project and getting a project tree, Finding and merging missing patches, Bookmarking a project, A tutorial guide to DVC +@subsubsection Creating a branch of a project and getting a project tree + +Having created a bookmark for the DVC project, you are ready to create +your own branch. Again from the bookmarks buffer (@kbd{C-x V b}), move +the point to your bookmark for DVC and hit @kbd{M T}. You will be +prompted for the tag version to be created for your new branch. Put the +branch somewhere in your default archive (I put mine in +@code{mark@@dishevelled.net--2003-mst/dvc--main--0.1}.) This will +create a tag of the main DVC project in your own archive and add a +bookmark for it. + +Your newly-added bookmark will be marked as a ``partner'' of your main +DVC bookmark. This records the fact that the two projects are related +so that DVC can show you which patches from the DVC mainline are +missing from your local tree, and other useful stuff (more on this +later). + +At this point, you will probably want to get a project tree for your new +branch. You can do this by moving your point to its bookmark in the +bookmark buffer, and hitting @kbd{>}. You will be prompted for a +directory in which to place the project tree, and the revision to get +(the default is fine in this case). Once the project tree has been +fetched, it will be automatically opened in dired. + +@ifhtml +@ifset SHOW_IMAGES +@html + +@end html +@end ifset +@end ifhtml + + +@node Finding and merging missing patches, Reviewing and committing your changes, Creating a branch of a project and getting a project tree, A tutorial guide to DVC +@subsubsection Finding and merging missing patches + +Before you start making changes, it is a good idea to see if any new +patches have been added to the mainline since you last checked. DVC is +particularly good at doing this. + +Start by entering the bookmarks buffer (@kbd{C-x V b}), move your point +to the bookmark of your DVC branch and hit @kbd{M m}. A +@code{*tla-missing*} buffer should appear, and show any patches that are +in the mainline but not in your tree. + +@ifhtml +@ifset SHOW_IMAGES +@html + +@end html +@end ifset +@end ifhtml + +To merge all missing patches from the DVC mainline into your project +tree, move your point to the DVC mainline partner entry and hit @kbd{M +s}. You will be prompted for the path of your local project tree, and +after the patches have been merged a changes buffer should be displayed. + +If you don't want to merge all the missing patches, you can leave off +the @kbd{M} prefix. For example, @kbd{r} will replay only the revision +under the point (allowing you to cherry-pick patches), and @kbd{s} will +star-merge all missing patches up to the patch under the point. + + +@node Reviewing and committing your changes, , Finding and merging missing patches, A tutorial guide to DVC +@subsubsection Reviewing and committing your changes + +After making changes to your project tree, you are ready to commit. You +can review your changes by typing @kbd{C-x V =} from within your project +tree, and a @code{*tla-changes*} buffer should appear with diff output. +Before committing, you might also like to tree-lint your local tree by +hitting @kbd{C-x V l} (but this is done automatically if @code{tla +changes} fails and suggests a @code{tree-lint}). + +@ifhtml +@ifset SHOW_IMAGES +@html + +@end html +@end ifset +@end ifhtml + +Once you are satisfied with your changes, you can create a log file by +hitting @kbd{C-x V c} (or simply @kbd{c} from your @code{*tla-changes*} +buffer). Many users prefer to write their log file incrementally, and +you can always save this file and hit @kbd{C-x V c} to return to it +later. You can also add a ChangeLog-style entry by hitting @kbd{C-x V +a} from the project tree file you are currently visiting. + +@ifhtml +@ifset SHOW_IMAGES +@html + +@end html +@end ifset +@end ifhtml + +To commit your changes, type @kbd{C-c C-c} from your log buffer. + + +@node First contact, Tla Archive Browsing, A tutorial guide to DVC, DVC Tla Tour +@subsection First contact + +@b{DVC} is self documented, so this manual will be very short. We suppose +you understand tla basics. + +There is a @b{DVC} entry in the tools menu which is a good starting +point, and an "Tla-..." menu in most @b{DVC}-related modes. Once you +have learnt the keyboard shortcuts, you will not need the menus anymore. + +The most important commands have global keybindings. The prefix is +@kbd{C-x V} by default. Type @kbd{C-x V C-h} for a list. In each +@b{DVC} specific buffer, other (shorter) keyboard shortcuts are +available. @kbd{C-h m} will give you a list. + +To get help about a tla command, @kbd{C-x V h command RET} will show +you the output of @code{tla command -H}. Since DVC is nothing more +than a wrapper around tla, this is a very good way to get help ! + +Before starting, you will need to set your ID if you have not already +done so. + +You can execute the following command to set your id: + +@kbd{C-u M-x tla-my-id} (or @kbd{M-x tla-set-my-id RET}) + +To check your id, call the same command without a prefix argument: + +@kbd{M-x tla-my-id} + +@c ---------------------------------------------------------------------------- +@node Tla Archive Browsing, Editing Files, First contact, DVC Tla Tour +@subsection Tla Archive Browsing + +It is pretty intuitive, just type @kbd{C-x V A} and investigate the +menu bar (Hmm, many people usually deactivate the menu bar, but please, +enable it while learning DVC ;-) You'll remove it afterwards) and the +mode help by @kbd{C-h m}. + +If you have no archives registered yet, type @kbd{a r} and provide the +location of an archive. + +@c ---------------------------------------------------------------------------- +@node Editing Files, Committing Files, Tla Archive Browsing, DVC Tla Tour +@subsection Editing Files + +Adding new files can be done in two ways: + +@enumerate + +@item Add an arch-tag to the file, by typing @kbd{C-x V t}. Attention, +files used as templates (@code{Makefile.in}) should be added explicitly +instead of using arch-tag lines. + +@item Explicitly add it from the inventory view. Type @kbd{C-x V i}, +mark the new files by typing @code{m} and finally add them by typing +@kbd{a}. + +@end enumerate + +You are encouraged to add log entries while you are editing. Type +@kbd{C-x V a} add your notes. + +@c ---------------------------------------------------------------------------- +@node Committing Files, Using Bookmarks, Editing Files, DVC Tla Tour +@subsection Committing Files + +@enumerate +@item First review your changes by typing @kbd{C-x V =}. + +If your tree contains nested trees, then DVC will display the list of +nested trees at the top of the changes buffer. They are marked with a +@kbd{T} so that you can distinguish them from the modified files. +While computing, they have the status @code{?}, and this becomes +@code{M} (resp. @code{-}) when the recursively called @code{tla} +process exits if there are some changes (resp. no changes) in the +nested tree. + +To view the details of the changes, type @kbd{RET} on a nested tree +entry to open the corresponding changes buffer. To come back to the +root of the project, type @code{^}. + +@item Then review the log message by typing @kbd{c} within the +*tla-changes* buffer and edit it when needed. + +@item Finally commit by typing @kbd{C-c C-c}. +@end enumerate + + +If you want to commit only changes made to a given number of files, +select them with @kbd{m} in the *tla-changes* buffer (this also works from +the *tla-inventory* buffer) before typing @kbd{c}. The list of files used +for the selected files commit is the list of selected files in the +buffer in which you typed @kbd{c}, at the time you press @kbd{C-c C-c} to +commit. So, if you change your mind, you can go back and select/unselect +some files before committing. + +@c ---------------------------------------------------------------------------- +@node Using Bookmarks, Transmit patches via email, Committing Files, DVC Tla Tour +@subsection Using Bookmarks + +@cindex Working in a project +@cindex Finding missing patches + +@menu +* Bookmarks basics:: +* Using bookmarks for distributed development:: +* Bookmarks groups:: +@end menu + +@node Bookmarks basics, Using bookmarks for distributed development, Using Bookmarks, Using Bookmarks +@subsubsection Bookmarks basics + +Bookmarks are primarily used to keep a list of the most visited arch +locations. Type @kbd{C-x V b} will show you the bookmarks +buffer. It should be empty for now, but you can add some by typing @kbd{a}. + +Ah, it's a pain, you have to type the full location, like +@code{Matthieu.Moy@@imag.fr--public/dvc--main--0.1}, or just +@code{Matthieu.Moy@@imag.fr--public/dvc--main}. No, let's do it the +easy way: Go back to your archive list (@kbd{M-x tla-archives RET}), +select the archive you want, then the category, branch, version. Now, +just select Set a bookmark here in the menu, type the name, and that's +it! + +You can view the details of bookmarks with @kbd{t}. + +@node Using bookmarks for distributed development, Bookmarks groups, Bookmarks basics, Using Bookmarks +@subsubsection Using bookmarks for distributed development + +Arch makes distributed development easy. Once you know that someone +has a patch for you in their archive, you can very easily merge it +with tla star-merge, or tla apply-changeset. But when several +developers are working on the same project, it's a pain to check +manually the missing patches in each archive. + +OK, we've got what you need! + +Add your own projects, and your contributors' projects too. Select +several related projects with @kbd{m} (unselect with @kbd{u} or +@kbd{M-del}). Make them partners with @kbd{M-p}. Now, with your cursor on +a bookmark, view the uncommited changes, the missing patches from your +archive and from your contributors with @kbd{M}. From this list, you +will usually want to update your tree if some changesets are missing +from your own archive (This is the @kbd{M u} keybinding), or star-merge +from your contributors' archives (This is the @kbd{. S} keybinding). + +In this list, DVC will also highlight revisions not merged by other +revisions. You can navigate through them with @kbd{N} and @kbd{P}. It +is recommended to merge these patches first, because merging a +revision A, and later merging a revision B which is a merge of A often +results in conflicts. + +Note that if you want to share your list of partners with all the +people having access to the project, you can just type @kbd{f w} to +write the list of parthers to the file +@code{@{arch@}/=partner-versions}, and your partners will just have to +type @kbd{f r} to read the list from this file. Note that using this +file, you will also be able to share your partner list with @code{aba} +users, and potentially others in the future. + +If you are managing several projects at the same time (or one real +project and several personal configuration directory), select several +bookmarks with @kbd{m}, and type @kbd{M} to view all the missing +patches from all contributors. + +The idea is that you will usually want to leave your office in the +evening with an empty list here, and check for new items when you come +back in the morning. + +@node Bookmarks groups, , Using bookmarks for distributed development, Using Bookmarks +@subsubsection Bookmarks groups + +Each bookmark can belong to a group of bookmarks. To make a group, +select some bookmarks, and hit @kbd{a g}. Enter a group name. The +selected bookmarks now belong to this group. To select a group, hit +@kbd{* g} and enter the group you want to select. + +Developers will typically have one group for all the projects he or she +has write access to (for example, group @code{mine}), and one group of +bookmarks for each projects, including his partners' projects (I have a +group @code{dvc}). Then, pressing @kbd{* g mine RET M} will show me all +the missing patches for my projects. @kbd{* g dvc RET M} will tell me if my +partners for @code{dvc} are up-to-date with my archive. + +@c ---------------------------------------------------------------------------- +@node Transmit patches via email, , Using Bookmarks, DVC Tla Tour +@subsection Transmit patches via email + +This section discusses a way to send/receive patches via email. That way +you can create patches for a project without the need to create a branch +for your contribution. + +@menu +* Send patches via Gnus:: +* Receive/Apply patches via Gnus:: +@end menu + +@node Send patches via Gnus, Receive/Apply patches via Gnus, Transmit patches via email, Transmit patches via email +@comment node-name, next, previous, up +@subsubsection Send patches via Gnus + +When you are tracking a project via GNU Arch, you can just edit your +checked out working copy. When you have done that, just do @kbd{M-x +tla-submit-patch RET}. + +That command calculates a changeset for your changes. That changeset is +archived in a tarball and attached to a new created email. + +You can add a description of the changeset to the prepared email. After +you have entered your description, just send the mail. + +The variable tla-submit-patch-mapping allows you to specify a list of +rules to preselect the destination email address. + +The default setting for tla-submit-patch-mapping is here: +@code{(((nil "dvc" nil nil nil) ("dvc-el-dev@@gna.org" "dvc")))} + +It defines, that every branch of the dvc project should submit patches +to @code{dvc-el-dev@@gna.org}. The entry @code{"dvc"} just specifies, +that the filename for the patch should start with @code{dvc}. + +@node Receive/Apply patches via Gnus, , Send patches via Gnus, Transmit patches via email +@comment node-name, next, previous, up +@subsubsection Receive/Apply patches via Gnus + +To hook DVC to Gnus, put the following in your .emacs: +@code{(tla-insinuate-gnus)} + +Now the @kbd{K t} binding is available as prefix key in Gnus summary +buffers. This will also buttonize archives, categories, branches, +version and revision names in the @code{*article*} buffer. + +The two important commands are: +@enumerate +@item @kbd{K t v}: View the changeset +@item @kbd{K t a}: Apply the changeset to one of your working trees +@end enumerate + +You can predefine the working tree, where you want to apply certain kind +of patches via tla-apply-patch-mapping. + +The follwing code specifies @code{"~/work/myprg/dvc-dev/"} as default +working tree for patches for the DVC project: + +@code{(setq tla-apply-patch-mapping + '(((nil "dvc" nil nil nil) "~/work/myprg/dvc-dev/")))} + +When you have applied the patch, you can commit the patch as usual. The +new keybinding @kbd{C-c C-p} inserts a log message that is extracted +from the received mail: +@enumerate +@item The subject is used as the patch summary line +@item The text between the log-start and the log-end markers in the mail specify the rest of the log message +@end enumerate + + +@node Use cases, Trouble Shooting, DVC Tla Tour, Top +@comment node-name, next, previous, up +@section How to use DVC depending on your role + +@menu +* Anarchic development:: +* Star-shaped development:: +@end menu + + +@node Anarchic development, Star-shaped development, Use cases, Use cases +@comment node-name, next, previous, up +@subsection Using DVC for anarchy-style development + +@comment TODO + +@node Star-shaped development, , Anarchic development, Use cases +@comment node-name, next, previous, up +@subsection Using DVC for star-shaped development + +By ``star-shaped development'', we mean a patch flow in which each +contributor only submit his patches to one version. This can be a +completely centralized solution, with one master version, or a +completely decentralized solution, with one master version for each +subprojects (potentially hierarchic), the main version for the full +project merging from the versions of the subprojects. + +@menu +* Maintainer:: +* Missing patches:: +* Reviewing patches:: +* Patch-log Generation:: +* Contributor:: +@end menu + +@node Maintainer, Missing patches, Star-shaped development, Star-shaped development +@comment node-name, next, previous, up +@subsubsection Being a maintainer in a star-shaped development + +We call ``maintainer'' the person in charge of merging patches from +contributors in his archive. In the case of a subproject, the +maintainer for a subproject is also a contributor for the main project. + +DVC can help you in this task: + +@menu +* Missing patches:: +* Reviewing patches:: +@end menu + +@node Missing patches, Reviewing patches, Maintainer, Star-shaped development +@comment node-name, next, previous, up +@subsubsection Getting the list of missing patches + +Unless merge requests are processed only on-demand, it is very usefull +to know the list of patches committed by your contributors that you +didn't merge already. This is done with the command @code{tla +missing}. Usually, there is a list of regular contributors from which +you often merge, and you may want to keep this list somewhere. In +DVC, the best way to do it is probably through bookmarks @xref{Using +bookmarks for distributed development}, but you can also use the +@code{@{arch@}/=partner-versions} (or the precious version +@code{@{arch@}/+partner-versions}) file for that: It is a list of +newline separated versions from which you often merge. The advantage +of this solution is that it is also implemented by aba and potentially +other tla front-ends in the future. Fortunately, you can keep it in +sync with your bookmarks from the bookmark buffer, with the key +sequences @kbd{f w} and @kbd{f r} (for respectively +@code{tla-bookmarks-write-partners-to-file} and +@code{tla-bookmarks-add-partners-from-file}). + +You can also run @kbd{C-u M-x tla-missing RET} to view manually the +list of missing patches for a given version, off course, and you can +use the keybindings available in the name reading engine (Get the list +with @kbd{C-h}) to get quickly the fully qualified version name of a +contributor. + +@node Reviewing patches, Patch-log Generation, Missing patches, Star-shaped development +@comment node-name, next, previous, up +@subsubsection Reviewing patches before merging them + +A good maintainer should never merge patches blindly. + +From a revision list buffer, @kbd{RET} will open the log file, +@kbd{=} will display the changeset. + +If you are unsure about something, or whish to reject the patch, type +@kbd{M-x tla-revision-send-comments RET} to send a mail to the author +of the patch. + +The usual way to merge is to put your cursor on the patch up to which +you want to merge, and type @kbd{. s} to ``star-merge'' the patches +from the common ancestor to this one. Other merge operators are +available. @kbd{C-h m} and the menubar will give you a list. + +You can use ``sync-tree'' to reject a patch: After merging patches up +to the direct ancestor of the patch to be rejected, type @kbd{M-x +tla-revision-sync-tree RET}. + +@node Patch-log Generation, Contributor, Reviewing patches, Star-shaped development +@comment node-name, next, previous, up +@subsubsection Generating patch-logs after merging + +DVC can generate the log file automatically after a merge. Just try +@kbd{C-c C-m} in the log buffer. This will generate the body (using +@code{tla log-for-merge}), and a summary line is also generated. The +default format for the summary line should be good for a simple +contributor, but it is highy recommanded to change it if you are the +maintainer: The simplest way to do it is to set the +@code{summary-format} field for the bookmark corresponding to the +version you're managing (just type @kbd{s} on the bookmark of your +choice in the bookmark buffer). A typical value would be @code{" [%s]"}: +The generated summary line will then look like + +@verbatim +Summary: [mark@dishevelled.net--2003-mst (patch 6-8)] +@end verbatim + +That you can complete manually to something like + +@verbatim +Summary: Bugfix for regression tests [mark@dishevelled.net--2003-mst (patch 6-8)] +@end verbatim + +More customization can be done: see the docstring for the variable + +@node Contributor, , Patch-log Generation, Star-shaped development +@comment node-name, next, previous, up +@subsubsection Being a contributor in a star-shaped development + +@comment TODO + +@c ============================================================================ +@node Trouble Shooting, Customization, Use cases, Top +@section Trouble Shooting + +Due to some reasons TLA might fail. In order to investigate the reason +you can switch to the buffers containing TLA output. Switch to the +@code{ *tla-logs} buffer (you can do that with +@code{tla-open-internal-log-buffer}). You get the list of processes +that have been ran since Emacs was started. Navigate with @kbd{n} and +@kbd{p}, and swith to the corresponding process buffer with @kbd{RET}, +to the error buffer with @kbd{e}, and to the buffer from which the +process was started with @kbd{r}. Note that the process and output +buffers are killed after some time if the variable +@code{tla-number-of-dead-process-buffer} is non-nil. You also have a +@code{Tla-Buffers} menu item in the @code{DVC} menu, on in your +menu-bar on arch-related buffers to navigate between those. + +If you encounter an internal lisp error, enable backtrace generation by +@kbd{M-x toggle-debug-on-error} and reproduce the error. Now submit a +bug report with @kbd{M-x dvc-submit-bug-report} and ensure the content +of the buffer @code{*Backtrace*} is included. + +@c ============================================================================ +@node Customization, Internals, Trouble Shooting, Top +@section Customization + +Do a @kbd{M-x customize-group RET dvc RET} and browse the available +options and modify them to suite your needs. + +@c ============================================================================ +@node Internals, Mailing Lists, Customization, Top +@section Internals + +There is a @code{docs} sub-directory in the archive of @b{DVC} +containing information for developers. + +@c ============================================================================ +@node Mailing Lists, Wiki, Internals, Top +@section Mailing Lists + +There is one mailing list for @b{DVC}. + +@code{dvc-dev@@gna.org} intended for the discussion of development +versions of @b{DVC}. Users of development versions of @b{DVC} should +subscribe to this list. Bugs should also be reported to this list. + +See @xref{Known Bugs}. for instructions on submitting bug reports or +feature requests. + +@c ============================================================================ +@node Wiki, Changes, Mailing Lists, Top +@section The DVC Wiki + +A wiki for DVC can be found at + +@url{http://www.emacswiki.org/emacs/DistributedVersionControl}. + +@c ============================================================================ +@node Changes, The Latest Version, Wiki, Top +@section Changes in this Version + +Development of DVC used to be very active, but has slowed down as the +users seem happy with the current version. The mailing list is a good +place learn about new features, but see also the docs/ANNOUNCEMENT file +in the DVC distribution. + +@c ============================================================================ +@node The Latest Version, The Future, Changes, Top +@section The Latest Version + +@noindent + +Get the bzr repository for @b{DVC}: + +@code{# bzr get http://bzr.xsteve.at/dvc} + +Users of development versions of @b{DVC} @b{should subscribe} to the +@code{dvc-el-dev} mailing list. @xref{Mailing Lists}. + +@c ============================================================================ +@node The Future, Thanks, The Latest Version, Top +@section The Future + +The future consists of Bugs and Features. + +@menu +* Known Bugs:: Known Bugs, and how to submit new ones +* TODO List:: The TODO List +@end menu + +@c ---------------------------------------------------------------------------- +@node Known Bugs, TODO List, The Future, The Future +@subsection Known Bugs + +@enumerate +@item Please file one, that should be listed here! +@end enumerate + +Bugs should be submitted to the @code{dvc-el-dev} mailing list +(@pxref{Mailing Lists}). To assist the developers, please include the +version numbers of DVC and tla and how to reproduce the bug. Further +the content of process buffers or in case of a lisp error a backtrace +might be helpful, see @xref{Trouble Shooting}. on how to get it. + +Please use @kbd{M-x dvc-submit-bug-report RET} for submitting or at least +to get a template for the report which you copy to your favorite MUA. + +@c ---------------------------------------------------------------------------- +@node TODO List, , Known Bugs, The Future +@subsection TODO List + +@subsubheading Near Future + +@itemize @bullet +@item many bug fixes +@end itemize + +@subsubheading Not-So-Near Future + +@itemize @bullet +@item no need for a command line invocation of @code{tla}. +@end itemize + +@c ============================================================================ +@node Thanks, Concept Index, The Future, Top +@section Thanks + +@c ============================================================================ +@node Concept Index, Variable Index, Thanks, Top +@section Concept Index +@printindex cp + +@c ============================================================================ +@node Variable Index, , Concept Index, Top +@section Variable Index +@printindex vr + +@contents +@bye diff --git a/dvc/www/dvc-logo.svg b/dvc/www/dvc-logo.svg new file mode 100644 index 0000000..9acb0ce --- /dev/null +++ b/dvc/www/dvc-logo.svg @@ -0,0 +1,249 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + image/svg+xml + + + + + + + + + + + + + + + + + + + + + diff --git a/dvc/www/index.html b/dvc/www/index.html new file mode 100644 index 0000000..1c7ac6a --- /dev/null +++ b/dvc/www/index.html @@ -0,0 +1,267 @@ + + + + + + + + + + + + + DVC: Distributed Version Control for Emacs + + + + + + + + DVC logo + +

DVC: Distributed Version Control for Emacs

+ +

DVC is a common Emacs front-end for a number of distributed + version control systems. +

+ +

It currently supports GNU Arch, Bazaar, git, Mercurial, and + Monotone. Support for Darcs is being worked on but still lacks + some features. See the table below for + details. +

+ +

DVC is available as + a Bazaar branch. To get a + local copy of the main branch, just do: +

+ + 
+      bzr get http://bzr.xsteve.at/dvc/
+
+ +

You can also find Matthieu's branch (not always up-to-date at + the moment) here: +

+ + 
+      bzr get http://www-verimag.imag.fr/~moy/bzr/dvc/moy/
+
+ +

A nightly snapshot of Matthieu's branch is available here: + dvc-snapshot.tar.gz

+ + +

Background

+ +

For modern version control systems (VCS), + the VC + package that ships with Emacs is insufficient. It has a + file-centric view that does not match the tree-centric model of + modern VCSs (hacks + like vc-arch.el + and vc-git.el + notwithstanding). Also, it is too generic to take advantage of + features that are specific to each VCS. +

+ +

DVC is the successor of and + includes Xtla, which is + an Emacs front-end to GNU Arch (tla and baz). Xtla supports both + tla and baz, and uses a simple "autoconf" mechanism to adapt + itself to different versions of tla and baz (e.g., call "merge" if + available, "star-merge" otherwise). However, Xtla is specific to + GNU Arch and can not easily support other VCSs like bzr, + Mercurial, Git, etc. +

+ +

DVC remedies this by providing VCS-independent infrastructure + and defining a common interface to be implemented by VCS-specific + back-ends. +

+ +

DVC supersedes Xtla. There is no new feature plan in Xtla + after the release of Xtla 1.2. +

+ +

Architecture

+ +

DVC's architecture looks like this:

+ + 
+      +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +
+      :      Optional common UI (which autodetects the back-end)       :<----.
+      +---------------+-------------------+------------------+---------+     |
+      | tla (Xtla)    |  Mercurial (xhg)  |  Bazaar (bzr)    |         |     v
+      |+-------------+|+-----------------+|+----------------+|   ...   |    \O/
+      ||  Xtla core  |||    xhg core     |||    bzr core    ||         |<--> |
+      |+-------------+|+-----------------+|+----------------+|         |    / \
+      +---------------+-------------------+------------------+---------+
+      |                            DVC core                            |
+      +----------------------------------------------------------------+
+
+ +

The user can use the common UI layer as well as the back-end + specific parts directly. +

+ +

Draft Roadmap

+ +

The roadmap currently looks like this: +

+ + 
+      Create dvc-xxx.el files (initially empty)
+      while (! satisfied) {
+        See what has to be done to implement feature X in VCS Y
+        See what code can be reused from Xtla to do this
+        Based upon this, create a generic API in DVC
+        Port the Xtla code to this API
+        Implement the feature X in other back-ends
+      }
+
+ +

We should avoid introducing quick and dirty hacks in DVC as + much as possible. Try to get a correct foundation before + implementing features in the back-ends. +

+ +

Comments and contributions are welcome. +

+ +

Back-ends and their status

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+ FunctionsMaintainersNotes
statusdifflogpullcommit
Back-endGNU Arch (tla) and Bazaar (baz)+++++Matthieu, Stefan
Bazaar (bzr)+++++Matthieu, Stefan
Git+++++Michael, Stefan
Mercurial (hg)+++++StefanAlso contains support for Mercurial Queues (MQ).
Monotone (mtn)+++-+Christian. Stephen
Darcs+----StefanNot usable yet.
+ + +

Mailing List

+ + There is a mailing list for DVC related stuff: + + + +

Other Emacs modes related to version control

+ + + +