diff --git a/Makefile b/Makefile index d794b9a..e9f10bc 100755 --- a/Makefile +++ b/Makefile @@ -6,7 +6,7 @@ endif all: elisp-all -elisp-all: org-mode auctex sunrise-commander +elisp-all: org-mode sunrise-commander #elisp-all: ess #apel flim semi wanderlust @@ -27,8 +27,8 @@ post_clone_cmd-emacswiki :=\ GIT_DIRS += use-package URL-use-package := https://github.com/jwiegley/use-package.git -GIT_DIRS += yaml-mode -URL-yaml-mode := https://github.com/yoshiki/yaml-mode.git +# GIT_DIRS += yaml-mode +# URL-yaml-mode := https://github.com/yoshiki/yaml-mode.git #GIT_DIRS += apel #URL-apel := http://github.com/wanderlust/apel.git @@ -56,20 +56,20 @@ endif #GIT_DIRS += w3 #URL-w3 := http://git.savannah.gnu.org/r/w3.git -GIT_DIRS += bbdb -URL-bbdb := http://git.savannah.gnu.org/r/bbdb.git +# GIT_DIRS += bbdb +# URL-bbdb := http://git.savannah.gnu.org/r/bbdb.git -GIT_DIRS += auctex -URL-auctex := http://git.savannah.gnu.org/r/auctex.git +# git_DIRS += auctex +# URL-auctex := http://git.savannah.gnu.org/r/auctex.git -GIT_DIRS += emacs-jabber -URL-emacs-jabber := http://git.code.sf.net/p/emacs-jabber/git +# GIT_DIRS += emacs-jabber +# URL-emacs-jabber := http://git.code.sf.net/p/emacs-jabber/git GIT_DIRS += doxymacs URL-doxymacs := git://doxymacs.git.sourceforge.net/gitroot/doxymacs/doxymacs -GIT_DIRS += htmlize -URL-htmlize := http://github.com/emacsmirror/htmlize.git +# GIT_DIRS += htmlize +# URL-htmlize := http://github.com/emacsmirror/htmlize.git #GIT_DIRS += ess #URL-ess := https://github.com/emacs-ess/ESS.git diff --git a/dvc/COPYING b/dvc/COPYING deleted file mode 100644 index b7b5f53..0000000 --- a/dvc/COPYING +++ /dev/null @@ -1,340 +0,0 @@ - GNU GENERAL PUBLIC LICENSE - Version 2, June 1991 - - Copyright (C) 1989, 1991 Free Software Foundation, Inc. - 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - - Preamble - - The licenses for most software are designed to take away your -freedom to share and change it. By contrast, the GNU General Public -License is intended to guarantee your freedom to share and change free -software--to make sure the software is free for all its users. This -General Public License applies to most of the Free Software -Foundation's software and to any other program whose authors commit to -using it. (Some other Free Software Foundation software is covered by -the GNU Library General Public License instead.) You can apply it to -your programs, too. - - When we speak of free software, we are referring to freedom, not -price. Our General Public Licenses are designed to make sure that you -have the freedom to distribute copies of free software (and charge for -this service if you wish), that you receive source code or can get it -if you want it, that you can change the software or use pieces of it -in new free programs; and that you know you can do these things. - - To protect your rights, we need to make restrictions that forbid -anyone to deny you these rights or to ask you to surrender the rights. -These restrictions translate to certain responsibilities for you if you -distribute copies of the software, or if you modify it. - - For example, if you distribute copies of such a program, whether -gratis or for a fee, you must give the recipients all the rights that -you have. You must make sure that they, too, receive or can get the -source code. And you must show them these terms so they know their -rights. - - We protect your rights with two steps: (1) copyright the software, and -(2) offer you this license which gives you legal permission to copy, -distribute and/or modify the software. - - Also, for each author's protection and ours, we want to make certain -that everyone understands that there is no warranty for this free -software. If the software is modified by someone else and passed on, we -want its recipients to know that what they have is not the original, so -that any problems introduced by others will not reflect on the original -authors' reputations. - - Finally, any free program is threatened constantly by software -patents. We wish to avoid the danger that redistributors of a free -program will individually obtain patent licenses, in effect making the -program proprietary. To prevent this, we have made it clear that any -patent must be licensed for everyone's free use or not licensed at all. - - The precise terms and conditions for copying, distribution and -modification follow. - - GNU GENERAL PUBLIC LICENSE - TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION - - 0. This License applies to any program or other work which contains -a notice placed by the copyright holder saying it may be distributed -under the terms of this General Public License. The "Program", below, -refers to any such program or work, and a "work based on the Program" -means either the Program or any derivative work under copyright law: -that is to say, a work containing the Program or a portion of it, -either verbatim or with modifications and/or translated into another -language. (Hereinafter, translation is included without limitation in -the term "modification".) Each licensee is addressed as "you". - -Activities other than copying, distribution and modification are not -covered by this License; they are outside its scope. The act of -running the Program is not restricted, and the output from the Program -is covered only if its contents constitute a work based on the -Program (independent of having been made by running the Program). -Whether that is true depends on what the Program does. - - 1. You may copy and distribute verbatim copies of the Program's -source code as you receive it, in any medium, provided that you -conspicuously and appropriately publish on each copy an appropriate -copyright notice and disclaimer of warranty; keep intact all the -notices that refer to this License and to the absence of any warranty; -and give any other recipients of the Program a copy of this License -along with the Program. - -You may charge a fee for the physical act of transferring a copy, and -you may at your option offer warranty protection in exchange for a fee. - - 2. You may modify your copy or copies of the Program or any portion -of it, thus forming a work based on the Program, and copy and -distribute such modifications or work under the terms of Section 1 -above, provided that you also meet all of these conditions: - - a) You must cause the modified files to carry prominent notices - stating that you changed the files and the date of any change. - - b) You must cause any work that you distribute or publish, that in - whole or in part contains or is derived from the Program or any - part thereof, to be licensed as a whole at no charge to all third - parties under the terms of this License. - - c) If the modified program normally reads commands interactively - when run, you must cause it, when started running for such - interactive use in the most ordinary way, to print or display an - announcement including an appropriate copyright notice and a - notice that there is no warranty (or else, saying that you provide - a warranty) and that users may redistribute the program under - these conditions, and telling the user how to view a copy of this - License. (Exception: if the Program itself is interactive but - does not normally print such an announcement, your work based on - the Program is not required to print an announcement.) - -These requirements apply to the modified work as a whole. If -identifiable sections of that work are not derived from the Program, -and can be reasonably considered independent and separate works in -themselves, then this License, and its terms, do not apply to those -sections when you distribute them as separate works. But when you -distribute the same sections as part of a whole which is a work based -on the Program, the distribution of the whole must be on the terms of -this License, whose permissions for other licensees extend to the -entire whole, and thus to each and every part regardless of who wrote it. - -Thus, it is not the intent of this section to claim rights or contest -your rights to work written entirely by you; rather, the intent is to -exercise the right to control the distribution of derivative or -collective works based on the Program. - -In addition, mere aggregation of another work not based on the Program -with the Program (or with a work based on the Program) on a volume of -a storage or distribution medium does not bring the other work under -the scope of this License. - - 3. You may copy and distribute the Program (or a work based on it, -under Section 2) in object code or executable form under the terms of -Sections 1 and 2 above provided that you also do one of the following: - - a) Accompany it with the complete corresponding machine-readable - source code, which must be distributed under the terms of Sections - 1 and 2 above on a medium customarily used for software interchange; or, - - b) Accompany it with a written offer, valid for at least three - years, to give any third party, for a charge no more than your - cost of physically performing source distribution, a complete - machine-readable copy of the corresponding source code, to be - distributed under the terms of Sections 1 and 2 above on a medium - customarily used for software interchange; or, - - c) Accompany it with the information you received as to the offer - to distribute corresponding source code. (This alternative is - allowed only for noncommercial distribution and only if you - received the program in object code or executable form with such - an offer, in accord with Subsection b above.) - -The source code for a work means the preferred form of the work for -making modifications to it. For an executable work, complete source -code means all the source code for all modules it contains, plus any -associated interface definition files, plus the scripts used to -control compilation and installation of the executable. However, as a -special exception, the source code distributed need not include -anything that is normally distributed (in either source or binary -form) with the major components (compiler, kernel, and so on) of the -operating system on which the executable runs, unless that component -itself accompanies the executable. - -If distribution of executable or object code is made by offering -access to copy from a designated place, then offering equivalent -access to copy the source code from the same place counts as -distribution of the source code, even though third parties are not -compelled to copy the source along with the object code. - - 4. You may not copy, modify, sublicense, or distribute the Program -except as expressly provided under this License. Any attempt -otherwise to copy, modify, sublicense or distribute the Program is -void, and will automatically terminate your rights under this License. -However, parties who have received copies, or rights, from you under -this License will not have their licenses terminated so long as such -parties remain in full compliance. - - 5. You are not required to accept this License, since you have not -signed it. However, nothing else grants you permission to modify or -distribute the Program or its derivative works. These actions are -prohibited by law if you do not accept this License. Therefore, by -modifying or distributing the Program (or any work based on the -Program), you indicate your acceptance of this License to do so, and -all its terms and conditions for copying, distributing or modifying -the Program or works based on it. - - 6. Each time you redistribute the Program (or any work based on the -Program), the recipient automatically receives a license from the -original licensor to copy, distribute or modify the Program subject to -these terms and conditions. You may not impose any further -restrictions on the recipients' exercise of the rights granted herein. -You are not responsible for enforcing compliance by third parties to -this License. - - 7. If, as a consequence of a court judgment or allegation of patent -infringement or for any other reason (not limited to patent issues), -conditions are imposed on you (whether by court order, agreement or -otherwise) that contradict the conditions of this License, they do not -excuse you from the conditions of this License. If you cannot -distribute so as to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a consequence you -may not distribute the Program at all. For example, if a patent -license would not permit royalty-free redistribution of the Program by -all those who receive copies directly or indirectly through you, then -the only way you could satisfy both it and this License would be to -refrain entirely from distribution of the Program. - -If any portion of this section is held invalid or unenforceable under -any particular circumstance, the balance of the section is intended to -apply and the section as a whole is intended to apply in other -circumstances. - -It is not the purpose of this section to induce you to infringe any -patents or other property right claims or to contest validity of any -such claims; this section has the sole purpose of protecting the -integrity of the free software distribution system, which is -implemented by public license practices. Many people have made -generous contributions to the wide range of software distributed -through that system in reliance on consistent application of that -system; it is up to the author/donor to decide if he or she is willing -to distribute software through any other system and a licensee cannot -impose that choice. - -This section is intended to make thoroughly clear what is believed to -be a consequence of the rest of this License. - - 8. If the distribution and/or use of the Program is restricted in -certain countries either by patents or by copyrighted interfaces, the -original copyright holder who places the Program under this License -may add an explicit geographical distribution limitation excluding -those countries, so that distribution is permitted only in or among -countries not thus excluded. In such case, this License incorporates -the limitation as if written in the body of this License. - - 9. The Free Software Foundation may publish revised and/or new versions -of the General Public License from time to time. Such new versions will -be similar in spirit to the present version, but may differ in detail to -address new problems or concerns. - -Each version is given a distinguishing version number. If the Program -specifies a version number of this License which applies to it and "any -later version", you have the option of following the terms and conditions -either of that version or of any later version published by the Free -Software Foundation. If the Program does not specify a version number of -this License, you may choose any version ever published by the Free Software -Foundation. - - 10. If you wish to incorporate parts of the Program into other free -programs whose distribution conditions are different, write to the author -to ask for permission. For software which is copyrighted by the Free -Software Foundation, write to the Free Software Foundation; we sometimes -make exceptions for this. Our decision will be guided by the two goals -of preserving the free status of all derivatives of our free software and -of promoting the sharing and reuse of software generally. - - NO WARRANTY - - 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY -FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN -OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES -PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED -OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF -MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS -TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE -PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, -REPAIR OR CORRECTION. - - 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING -WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR -REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, -INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING -OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED -TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY -YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER -PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE -POSSIBILITY OF SUCH DAMAGES. - - END OF TERMS AND CONDITIONS - - How to Apply These Terms to Your New Programs - - If you develop a new program, and you want it to be of the greatest -possible use to the public, the best way to achieve this is to make it -free software which everyone can redistribute and change under these terms. - - To do so, attach the following notices to the program. It is safest -to attach them to the start of each source file to most effectively -convey the exclusion of warranty; and each file should have at least -the "copyright" line and a pointer to where the full notice is found. - - - 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 deleted file mode 100644 index c6e25c6..0000000 --- a/dvc/INSTALL +++ /dev/null @@ -1,136 +0,0 @@ -THE VERY QUICK INSTALLATION GUIDE -================================= - -Since nobody reads long documentation, here's a very short -installation guide: - -$ autoconf # only needed when the configure script is not present -$ cd dvc/ -$ mkdir ++build/ -$ cd ++build/ -$ ../configure -$ make -[ possibly make install ] - -And add - -(load-file "/path/to/dvc/++build/dvc-load.el") - -to your ~/.emacs.el - -For the details, see below. - - -USING CONFIGURE -=============== - -0) If you get DVC from the revision control, the ./configure script is - not included. You have to run "autoreconf" or "autoconf" to recreate it. - -1) Select your emacs flavor, this is the option --with-emacs and its - default is emacs (GNU Emacs). Choose a prefix for the installation - with --prefix, by default /usr/local. - - The default locations are as follows: - - a) GNU Emacs: lisp files goto ${prefix}/share/emacs/site-lisp and - info files to ${prefix}/info (overridable with --with-lispdir=... - and --infodir=...) - - b) XEmacs: lisp files goto ${prefix}/lib/xemacs/site-packages/lisp/xtla and info - files to ${prefix}/lib/xemacs/site-packages/info, (overridable - with --with-infodir=... and --infodir=...) - - ATTENTION: Files byte-compiled with GNU Emacs are NOT COMPATIBLE with the - XEmacs and you may experience strange problems during startup when doing - so. Thus ensure you are configuring with --with-emacs=xemacs when - installing DVC for XEmacs! - - a) GNU Emacs users run: - ./configure - - b) XEmacs users run: - ./configure --with-emacs=xemacs - - It is possible to build DVC in a separate directory. For instance, type - - mkdir emacs_build; cd emacs_build; - ../configure --with-emacs=emacs - -2) Compile the lisp files and info by running: - make - -3) Installing the files - - Run the following command: - make install - - a) The easy way - - The files dvc.el generated in the build directory and in - the install directory do everything for you: Manually, you can - run - - M-x load-file RET /path/to/install/share/emacs/site-lisp/dvc/dvc-load.el RET - - (usefull when you want to load DVC after starting "emacs -q"!), - or add - - (load-file "/path/to/install/share/emacs/site-lisp/dvc/dvc-load.el") - - to your ~/.emacs.el - - - The manual way - - GNU Emacs: Put the lisp/info path as chosen above into your load-path, - i.e. add the following to your ~/.emacs.el (if you don't already have an - equivalent) - (add-to-list 'load-path "/path/to/install/share/emacs/site-lisp/dvc/lisp/") - (add-to-list 'Info-default-directory-list "/path/to/install/share/info/")) - - Now, GNU Emacs knows where to find DVC, tell it to load it, by adding - (require 'dvc-autoloads) - to your ~/.emacs.el. - - - b) XEmacs: You are lucky nothing to do for you! - - That's it! Restart Emacs and read the info or start using DVC. For - example, look at the DVC submenu in the Tools menu. - - If you would prefer to run DVC from its source directory rather - than installing it, then add the following to your .xemacs/init.el - file. - - (load-file "/path/to/dvc/dvc-load.el") - -4) Integration of Xtla with Gnus - - If you use Gnus and Xtla (support for tla and baz in DVC), you - probably want to add - - (tla-insinuate-gnus) - - to your ~/.gnus.el - -INSTALLING BY HAND (for GNU Emacs) -================== - -Basically you need to copy all the *.el files into a directory that is listed -in your `load-path' and the info file into a directory listed in your -`Info-directory-list'. - -Then perform the steps from 3a) in the last section. - -NOTES -===== - -- XEmacs users will require the file ewoc.el which is also installed in the - package dir. It's provided in the contrib/ directory of DVC. -- xtla-browse.el is an add-on package for xtla.el. xtla-browse.el requires - tree-widget.el 2.0 or higher written by David Ponce. XEmacs users should - install the "jde" package. GNU Emacs in subversions.gnu.org CVS repository - contains tree-widget.el. If you are using older GNU Emacs or XEmacs, you can - get it from http://sourceforge.net/projects/emhacks/. xtla.el doesn't - require xtla-browse.el. xtla-browse.el is an option. diff --git a/dvc/INSTALL.windows b/dvc/INSTALL.windows deleted file mode 100644 index 6fc88cd..0000000 --- a/dvc/INSTALL.windows +++ /dev/null @@ -1,26 +0,0 @@ -* A poor mans installation guide -- The following files are generated by linux build scripts: - dvc-version.el - dvc-site.el - dvc-autoloads.el -- Copy these files from a working linux version to the dvc/lisp directory - -- DVC.el needs a sh executable. Using cygwin should be a working option - If sh is not in the search PATH, set it via: - (setq dvc-sh-executable "c:/cygwin/bin/sh.exe") - -- Add the following to your .emacs: -(add-to-list 'load-path "c:/emacs/site-lisp/dvc/lisp") -(require 'dvc-autoloads) - -- The following tip shows how to configure the windows keys as super/hyper - Put these lines before the (require 'dvc-autoloads) in your .emacs - -(setq w32-pass-lwindow-to-system nil - w32-pass-rwindow-to-system nil) - -(setq w32-lwindow-modifier 'super) ; lwindow acts as super -(setq w32-rwindow-modifier 'hyper) ; rwindow acts as hyper -(defvar dvc-prefix-key '[(super t)]) - - diff --git a/dvc/Makefile.in b/dvc/Makefile.in deleted file mode 100644 index 207d68d..0000000 --- a/dvc/Makefile.in +++ /dev/null @@ -1,123 +0,0 @@ -@SET_MAKE@ - -PACKAGE_TARNAME = @PACKAGE_TARNAME@ -PACKAGE_VERSION = @PACKAGE_VERSION@ - -# location of required programms -AUTOCONF = autoconf -TAR = tar -RM = @RM@ -prefix = @prefix@ -datarootdir= @datarootdir@ -info_dir = @info_dir@ -srcdir = @srcdir@ -lispdir= @lispdir@ - -SUBDIRS = lisp texinfo - -MKDIR_P = @MKDIR_P@ - -############################################################################## -all: dvc info dvc-load.el - -Makefile: config.status $(srcdir)/Makefile.in - ./config.status $@ - -dvc-load.el: config.status $(srcdir)/dvc-load.el.in - ./config.status $@ - -$(srcdir)/configure: $(srcdir)/configure.ac - cd $(srcdir) ; $(AUTOCONF) - ./config.status --recheck - -config.status: $(srcdir)/configure - ./config.status --recheck - -info pdf dvi html: - cd texinfo; $(MAKE) $@ - -dvc: - cd lisp; $(MAKE) - -dvc-verbose: - cd lisp; $(MAKE) all-verbose - -dvc-pkg.el: $(srcdir)/config.status - @echo Creating $@ - @( echo ';;; $@ (ELPA generated installer file -- do not edit!)' ; \ - echo '(define-package "dvc" "$(PACKAGE_VERSION)"' \ - ' "The Emacs interface to Distributed Version Control Systems")' ) \ - > $@ - -lisp/dvc-version.el: - cd lisp; $(MAKE) dvc-version.el - -%-recursive: - @for dir in $(SUBDIRS) ; do ( cd $$dir; $(MAKE) $* ) ; done - -install: dvc-load.el install-recursive - sed -e 's|@''lispdir''@|'"$(lispdir)"'|' \ - -e 's|@''info_dir''@|'"$(info_dir)"'|' \ - $(srcdir)/dvc-load-install.el.in \ - > $(lispdir)/dvc-load.el - -uninstall: uninstall-recursive - rmdir $(lispdir) || true - -clean: clean-recursive - rm -f dvc-load.el dvc-load-install.el - -distclean: clean distclean-recursive - rm -rf configure config.status config.log autom4te.cache/ Makefile $(distdir) $(distdir).tar* - -maintainer-clean: maintainer-clean-recursive - -############################################################################## -distdir = $(PACKAGE_TARNAME)-$(PACKAGE_VERSION) - -lispfiles = lisp/Makefile.in lisp/dvc-site.el.in \ - lisp/contrib/*.el lisp/tests/*.el lisp/*.el -docfiles = texinfo/Makefile.in texinfo/dvc.texinfo texinfo/dvc.info -miscfiles = Makefile.in COPYING INSTALL* install-sh \ - dvc-load.el.in dvc-load-install.el.in \ - lisp/dvc-version.el \ - texinfo/dvc-version.texinfo \ - texinfo/dvc-intro.texinfo \ - texinfo/fdl.texinfo \ - configure.ac configure -extradist = - -distfiles = $(lispfiles) $(docfiles) $(miscfiles) $(extradist) - -dist: - rm -rf $(distdir) $(distdir).tar.gz - mkdir $(distdir) - build=`pwd` ; dd=$$build/$(distdir) ; cd $(srcdir) ; \ - for f in $(distfiles) ; do d='.' ; \ - if [ -f $$build/$$f ] ; then d=$$build ; fi ; \ - e=`dirname $$f` ; f=`basename $$f` ; \ - test -d $$dd/$$e || $(MKDIR_P) $$dd/$$e ; \ - cp -p $$d/$$e/$$f $$dd/$$e/$$f ; done - $(TAR) cf - $(distdir) | gzip --best > $(distdir).tar.gz - rm -rf $(distdir) - -tarball: - $(MAKE) dist \ - distdir=$(PACKAGE_TARNAME)-snapshot \ - extradist='debian/* docs/* scripts/*' - -package: dvc-pkg.el info lisp/dvc-version.el - rm -rf $(distdir) $(distdir).tar - mkdir $(distdir) - cp -r docs $(distdir) - cp COPYING $(distdir) - cp dvc-pkg.el lisp/*el texinfo/dvc.info $(distdir) - install-info --info-dir=$(distdir) $(distdir)/dvc.info - $(TAR) cf $(distdir).tar $(distdir) - -.INTERMEDIATE: dvc-pkg.el - -.PHONY: all info pdf dvi html dvc dvc-verbose \ - install uninstall \ - clean distclean maintainer-clean \ - dist tarball package diff --git a/dvc/configure.ac b/dvc/configure.ac deleted file mode 100644 index 0d013a6..0000000 --- a/dvc/configure.ac +++ /dev/null @@ -1,185 +0,0 @@ -# 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_MSG_CHECKING([for the date utility flavor]) -if date --version 2>/dev/null | grep GNU ; then - DATE_FLAVOR="GNU" -else - DATE_FLAVOR="BSD" -fi -AC_MSG_RESULT([${DATE_FLAVOR}]) -AC_SUBST([DATE_FLAVOR]) - -AC_OUTPUT - -# configure.ac ends here diff --git a/dvc/debian/README.Debian b/dvc/debian/README.Debian deleted file mode 100644 index d400ca9..0000000 --- a/dvc/debian/README.Debian +++ /dev/null @@ -1,6 +0,0 @@ -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 deleted file mode 100644 index 7c80957..0000000 --- a/dvc/debian/changelog +++ /dev/null @@ -1,7 +0,0 @@ -dvc (0r20100420-1) unstable; urgency=low - - * New snapshot. - * Add dvc.texinfo license to debian/copyright. - * Julien Danjou is the sponsor for DVC (Closes: #496930). - - -- Daniel Dehennin Tue, 20 Apr 2010 09:43:34 +0200 diff --git a/dvc/debian/compat b/dvc/debian/compat deleted file mode 100644 index 7f8f011..0000000 --- a/dvc/debian/compat +++ /dev/null @@ -1 +0,0 @@ -7 diff --git a/dvc/debian/control b/dvc/debian/control deleted file mode 100644 index 78890d9..0000000 --- a/dvc/debian/control +++ /dev/null @@ -1,30 +0,0 @@ -Source: dvc -Section: devel -Priority: optional -Maintainer: Daniel Dehennin -Build-Depends: cdbs (>= 0.4.50), debhelper (>= 7) -Build-Depends-Indep: autoconf, emacs23 | emacs22 | emacs21 | xemacs21 | emacs-snapshot, texinfo -Standards-Version: 3.8.4 -Vcs-Bzr: http://bzr.xsteve.at/dvc/ -Homepage: http://download.gna.org/dvc/ - -Package: dvc -Architecture: all -Depends: emacs23 | emacs22 | emacs21 | xemacs21 | emacs-snapshot, dpkg (>= 1.15.4) | install-info, ${misc:Depends} -Recommends: tla | bazaar | bzr | git | mercurial | darcs | monotone -Description: Emacs front-end to distributed version control systems - DVC is an attempt to build a common infrastructure for various - distributed revision control systems. Actually supported are tla, - bazaar, bzr, git, mercurial, darcs and monotone. - . - DVC main features are: - * dvc-status: Intuitive interface for status viewing. - * dvc-log: Log viewer. - * dvc-diff: View uncommitted changes in your working directory. - * dvc-bookmarks: Bookmark manager with partner support. - * Integration with ediff, Emacs's graphical diff tool. - * dvc-missing: Interface to view missing patches from all your - partners with a single command. - * Send/receive/apply patches via the Gnus email client. - * Run many version control commands from Emacs (such as init and - pull). diff --git a/dvc/debian/copyright b/dvc/debian/copyright deleted file mode 100644 index 2f43314..0000000 --- a/dvc/debian/copyright +++ /dev/null @@ -1,70 +0,0 @@ -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, or - (at your option) any later version. - - This package is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this package; if not, write to the Free Software - Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA - 02110-1301, USA. - -On Debian systems, the complete text of the GNU General -Public License can be found in `/usr/share/common-licenses/GPL'. - -License for dvc.texinfo: - - Permission is granted to make and distribute verbatim copies of this - manual provided the copyright notice and this permission notice are - preserved on all copies. - - Permission is granted to copy and distribute modified versions of - this manual under the conditions for verbatim copying, provided that - the entire resulting derived work is distributed under the terms of a - permission notice identical to this one. - - Permission is granted to copy and distribute translations of this - manual into another language, under the above conditions for modified - versions, except that this permission notice may be stated in a - translation approved by the author. diff --git a/dvc/debian/dvc.dirs b/dvc/debian/dvc.dirs deleted file mode 100644 index e47b9a2..0000000 --- a/dvc/debian/dvc.dirs +++ /dev/null @@ -1,5 +0,0 @@ -usr/share/doc/dvc -usr/share/emacs/site-lisp/dvc -usr/share/emacs/site-lisp/dvc/lisp -usr/share/emacs/site-lisp/dvc/lisp/contrib - diff --git a/dvc/debian/dvc.docs b/dvc/debian/dvc.docs deleted file mode 100644 index 631369c..0000000 --- a/dvc/debian/dvc.docs +++ /dev/null @@ -1,10 +0,0 @@ -debian/copyright -docs/ANNOUNCEMENTS -docs/ARCHIVES -docs/BINDINGS -docs/CONTRIBUTORS -docs/DVC-API -docs/FEATURES -docs/HACKING -docs/TODO -docs/xmtn-readme.txt diff --git a/dvc/debian/dvc.emacsen-install b/dvc/debian/dvc.emacsen-install deleted file mode 100644 index 0eb5eae..0000000 --- a/dvc/debian/dvc.emacsen-install +++ /dev/null @@ -1,81 +0,0 @@ -#! /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 deleted file mode 100644 index ac242ad..0000000 --- a/dvc/debian/dvc.emacsen-remove +++ /dev/null @@ -1,29 +0,0 @@ -#!/bin/sh -e -# /usr/lib/emacsen-common/packages/remove/dvc - -FLAVOR=$1 -PACKAGE=dvc - -if [ "x$FLAVOR" = "x" ]; then - echo Need argument to determin FLAVOR of emacs; - exit 1 -fi - -if [ "x$PACKAGE" = "x" ]; then - echo Internal error: need package name; - exit 1; -fi - -case "$FLAVOR" in - emacs | emacs20) - echo "Ignoring flavour ${FLAVOR}" - ;; - *) - - echo "remove/${PACKAGE}: purging byte-compiled files for ${FLAVOR}" - rm -rf /usr/share/${FLAVOR}/site-lisp/${PACKAGE} - ;; -esac - -exit 0 - diff --git a/dvc/debian/dvc.emacsen-startup b/dvc/debian/dvc.emacsen-startup deleted file mode 100644 index 7e9ec3a..0000000 --- a/dvc/debian/dvc.emacsen-startup +++ /dev/null @@ -1,36 +0,0 @@ -;; -*-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 deleted file mode 100644 index 89b568f..0000000 --- a/dvc/debian/dvc.info +++ /dev/null @@ -1 +0,0 @@ -texinfo/dvc.info diff --git a/dvc/debian/dvc.install b/dvc/debian/dvc.install deleted file mode 100644 index b465112..0000000 --- a/dvc/debian/dvc.install +++ /dev/null @@ -1,7 +0,0 @@ -config.status /usr/share/emacs/site-lisp/dvc -Makefile* /usr/share/emacs/site-lisp/dvc -lisp/Makefile* /usr/share/emacs/site-lisp/dvc/lisp/ -lisp/Makefile* /usr/share/emacs/site-lisp/dvc/lisp/ -lisp/*.el /usr/share/emacs/site-lisp/dvc/lisp/ -lisp/dvc-site.el.in /usr/share/emacs/site-lisp/dvc/lisp/ -lisp/contrib/*.el /usr/share/emacs/site-lisp/dvc/lisp/contrib/ diff --git a/dvc/debian/rules b/dvc/debian/rules deleted file mode 100755 index 60e8054..0000000 --- a/dvc/debian/rules +++ /dev/null @@ -1,17 +0,0 @@ -#!/usr/bin/make -f - -# Uncomment this to turn on verbose mode. -export DH_VERBOSE=0 - -PREFIX := /usr -LISPDIR := /usr/share/emacs/site-lisp/dvc - -include /usr/share/cdbs/1/rules/debhelper.mk - -clean:: - [ ! -f Makefile ] || $(MAKE) distclean - -configure/dvc:: - autoconf -f -i - ./configure PACKAGE_VERSION=$(DEB_VERSION) --prefix=$(PREFIX) --with-lispdir=$(LISPDIR) - $(MAKE) info diff --git a/dvc/debian/source/format b/dvc/debian/source/format deleted file mode 100644 index 163aaf8..0000000 --- a/dvc/debian/source/format +++ /dev/null @@ -1 +0,0 @@ -3.0 (quilt) diff --git a/dvc/docs/ANNOUNCEMENTS b/dvc/docs/ANNOUNCEMENTS deleted file mode 100644 index aff7fe9..0000000 --- a/dvc/docs/ANNOUNCEMENTS +++ /dev/null @@ -1,99 +0,0 @@ -; -*- mode: text -*- - -Subject: Xtla 1.2 is out!! - -The Xtla development team is proud to announce the release of Xtla, -version 1.2. - -Xtla is the Emacs front-end to GNU Arch client (either tla or bazaar -branch, at your option). It mainly provides user-friendly wrappers for -native commands. - -The 1.2 version of Xtla will most probably be the last version of Xtla -to contain new features. We are currently moving to a more generic -architecture, that we called DVC, which will support other RCS as -back-ends. We already have preliminary support for Mercurial and -Bazaar 2. - -The main features are: - - * PCL-CVS like interface for tla inventory and tla changes - - * Archive browser - navigate painlessly through archives, categories, - branches, versions, etc. - - * Good integration in Emacs - almost everything can be done from - within the editor - - * Bookmark manager - keep the most frequently used arch locations in - your bookmark buffer - - * Integration with ediff, Emacs's graphical diff tool - - to view changes made in a local tree. - - to view and resolve conflicts after a merge. - - * Interface to view missing patches from all your partners with a - single command - - * An Emacs mode for arch-related files (log files, =tagging-method, - "build-config" files) - - * Support for baz, and for baz added commands like "switch", - "annotate", "status", "resolved" - - * Integraton with Gnus. - -The main new features for the 1.2 version are: - - * M-x baz-update RET can use either merge, replay, or update - - * changelog buffer, cat-log-mode buffers, and *Article* buffers (in - Gnus) show clickable buttons for revision names (and other Arch - names). - - * A mail notification is available from the Changelog buffer (bound - to "M") - - * Several bazaaz 1.5 compatibility issues solved - - * Many bugfixes - -Information about Xtla can be found here: - - http://wiki.gnuarch.org/xtla - -We also have a project page on http://gna.org (savannah.gnu.org-like), -where you can find information about the mailing list, the online -manual, the download area, and the bug tracker (also used for feature -requests): - - https://gna.org/projects/xtla-el - -You can install Xtla is from the archive found here: - - https://www-verimag.imag.fr/~moy/arch/public - -The version is - - Matthieu.Moy@imag.fr--public/xtla--main--1.2 - -Xtla can also be downloaded as a tarball from here - - http://download.gna.org/xtla-el/ - -Or installed as a Debian package. The package is now in Debian -unstable. You can also get it by adding - - deb http://download.gna.org/xtla-el/apt/ unstable/ - -to your sources.list file if you use another .deb-based distribution. - - -Many thanks to all contributors and testers, in particular, for this -version: - - Stefan Reichör, Original author of Xtla and integrator - Masatake Yamato, GNU Emacs hacker -; Robert Widhopf-Fenk, XEmacs integration and testing - Milan Zamazal, Debian developer - Mark Triggs diff --git a/dvc/docs/ARCHIVES b/dvc/docs/ARCHIVES deleted file mode 100644 index 562935d..0000000 --- a/dvc/docs/ARCHIVES +++ /dev/null @@ -1,36 +0,0 @@ -To test DVC backends quickly here I enumerate some -interesting(completely my subjective view - Masatake) archives or repositories: -Add archives(or repository) you are interested in. - -* tla/baz - -** dvc itself - - $ bzr get http://bzr.xsteve.at/dvc/ - -* bzr - -** bless binary editor - - $ bzr branch http://download.gna.org/bless/bless.dev - -* cg - -** linux kernel - - $ cg-clone git://git.kernel.org/pub/scm/linux/kernel/git/torvalds/linux-2.6.git - -* hg - -** Xen and linux related codes - - $ hg clone http://xenbits.xensource.com/linux-2.6-xen.hg - $ hg clone http://xenbits.xensource.com/xen-3.0-testing.hg - -* darcs - -** Ion-3 window manager - - $ darcs get --partial http://modeemi.fi/~tuomov/repos/ion-3 - - diff --git a/dvc/docs/BINDINGS b/dvc/docs/BINDINGS deleted file mode 100644 index 61c24ef..0000000 --- a/dvc/docs/BINDINGS +++ /dev/null @@ -1,210 +0,0 @@ -Some possible keybindings: - -;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Bookmarks key bindings -;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(when (not tla-bookmarks-mode-map) - (setq tla-bookmarks-mode-map (make-sparse-keymap)) - - ;;; Commands for merging (M) - (define-key tla-bookmarks-mode-map [?M ?s] 'tla-bookmarks-star-merge) - (define-key tla-bookmarks-mode-map [?M ?m] 'tla-bookmarks-missing) - (define-key tla-bookmarks-mode-map [?M ?r] 'tla-bookmarks-replay) - - - ;;; Commands for marking (*) - (define-key tla-bookmarks-mode-map "\M-\C-?" 'tla-bookmarks-unmark-all) - (define-key tla-bookmarks-mode-map [?* ?!] 'tla-bookmarks-unmark-all) - (define-key tla-bookmarks-mode-map [?* ?u] 'tla-bookmarks-unmark) - (define-key tla-bookmarks-mode-map [?* ?m] 'tla-bookmarks-mark) - - - ;;; Navigation - (define-key tla-bookmarks-mode-map [?n] 'tla-bookmarks-next) - (define-key tla-bookmarks-mode-map [?p] 'tla-bookmarks-previous) - - - ;;; Bookmark specific commands - (define-key tla-bookmarks-mode-map "\C-m" 'tla-bookmarks-goto) - (define-key tla-bookmarks-mode-map [?a] 'tla-bookmarks-add) - (define-key tla-bookmarks-mode-map [?e] 'tla-bookmarks-edit) - (define-key tla-bookmarks-mode-map [?d] 'tla-bookmarks-delete) - (define-key tla-bookmarks-mode-map [?o] 'tla-bookmarks-open-tree) - (define-key tla-bookmarks-mode-map [?i] 'tla-bookmarks-inventory) - (define-key tla-bookmarks-mode-map [?q] 'tla-buffer-quit) - (define-key tla-bookmarks-mode-map [?+ ?b] 'tla-bookmarks-add) - (define-key tla-bookmarks-mode-map [?+ ?t] 'tla-bookmarks-add-tree-interactive) - (define-key tla-bookmarks-mode-map [?- ?t] 'tla-bookmarks-delete-tree-interactive) - (define-key tla-bookmarks-mode-map [?+ ?p] 'tla-bookmarks-add-partner-interactive) - (define-key tla-bookmarks-mode-map [?- ?p] 'tla-bookmarks-delete-partner-interactive) - (define-key tla-bookmarks-mode-map [?+ ?g] 'tla-bookmarks-add-group-interactive) - (define-key tla-bookmarks-mode-map [?- ?g] 'tla-bookmarks-delete-group-interactive) - (define-key tla-bookmarks-mode-map [?* ?g] 'tla-bookmarks-select-by-group) - (define-key tla-bookmarks-mode-map [?N] 'tla-bookmarks-move-down) - (define-key tla-bookmarks-mode-map [?P] 'tla-bookmarks-move-up) - - - ;;; Archive commands (A) - (define-key tla-bookmarks-mode-map [?>] 'tla-bookmarks-get) - (define-key tla-bookmarks-mode-map [?A ?g] 'tla-bookmarks-get) - - - ;;; Toggle commands (T) - (define-key tla-bookmarks-mode-map [?T t] 'tla-bookmarks-toggle-details) - - - ;;; Debugging commands (D) - (define-key tla-bookmarks-mode-map [?D p] 'tla-show-process-buffer) - ;; Add me! - ;; (define-key tla-bookmarks-mode-map [?D l] 'tla-show-tla-log) - - - ;;; Misc - (define-key tla-bookmarks-mode-map [??] 'describe-mode) - (define-key tla-bookmarks-mode-map [(meta p)] - 'tla-bookmarks-marked-are-partners) - ) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Inventory key bindings -;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(when (not tla-inventory-mode-map) - (setq tla-inventory-mode-map (make-sparse-keymap)) - - ;;; Commands for merging (M) - (define-key tla-inventory-mode-map [?M ?s] 'tla-inventory-star-merge) - (define-key tla-inventory-mode-map [?M ?r] 'tla-inventory-replay) - - - ;;; Commands for marking (*) - (define-key tla-inventory-mode-map "\M-\C-?" 'tla-inventory-unmark-all) - (define-key tla-inventory-mode-map [?* ?m] 'tla-inventory-mark-file) - (define-key tla-inventory-mode-map [?* ?u] 'tla-inventory-unmark-file) - (define-key tla-inventory-mode-map [?* ?!] 'tla-inventory-unmark-all) - - - ;;; Navigation - (define-key tla-inventory-mode-map [?n] 'tla-inventory-next) - (define-key tla-inventory-mode-map [?p] 'tla-inventory-previous) - (define-key tla-inventory-mode-map [?^] 'tla-inventory-parent-directory) - (define-key tla-inventory-mode-map [left] 'tla-inventory-parent-directory) - - - ;;; Inventory specific commands - (define-key tla-inventory-mode-map [?+ ?f] 'tla-inventory-add) - (define-key tla-inventory-mode-map [?- ?f] 'tla-inventory-remove) - (define-key tla-inventory-mode-map [?R] 'tla-inventory-move) - (define-key tla-inventory-mode-map [?e] 'tla-inventory-file-ediff) - (define-key tla-inventory-mode-map [?c] 'tla-inventory-edit-log) ;; mnemonic for commit - (define-key tla-inventory-mode-map [?f] 'tla-inventory-find-file) - (define-key tla-inventory-mode-map [return] 'tla-inventory-find-file) - (define-key tla-inventory-mode-map [right] 'tla-inventory-find-file) - (define-key tla-inventory-mode-map "\C-m" 'tla-inventory-find-file) - (define-key tla-inventory-mode-map [?o] 'tla-inventory-find-file-other-window) - (define-key tla-inventory-mode-map [?v] 'tla-inventory-view-file) - ;; (define-key tla-inventory-mode-map [?d ?e] 'tla-inventory-file-ediff) - (define-key tla-inventory-mode-map [?d ?m] 'tla-inventory-missing) - (define-key tla-inventory-mode-map [?=] 'tla-changes) - (define-key tla-inventory-mode-map [?l] 'tla-changelog) - (define-key tla-inventory-mode-map [?L] 'tla-logs) - - - ;;; Archive commands (A) - (define-key tla-inventory-mode-map [?A ?m] 'tla-inventory-mirror) - - - ;;; Toggle commands (T) - (dolist (type-arg tla-inventory-file-types-manipulators) - (define-key tla-inventory-mode-map `[?T ,(cadddr type-arg)] (caddr type-arg))) - (define-key tla-inventory-mode-map [?T ?+] 'tla-inventory-set-all-toggle-variables) - (define-key tla-inventory-mode-map [?T ?-] 'tla-inventory-reset-all-toggle-variables) - (define-key tla-inventory-mode-map [?T ?~] 'tla-inventory-toggle-all-toggle-variables) - - ;;; Debugging commands (D) - (define-key tla-inventory-mode-map [?D p] 'tla-show-process-buffer) - ;; Add me! - ;; (define-key tla-inventory-mode-map [?D l] 'tla-show-tla-log) - - ;;; Misc - (define-key tla-inventory-mode-map [??] 'describe-mode) - (define-key tla-inventory-mode-map [?g] 'tla-generic-refresh) - (define-key tla-inventory-mode-map [?q] 'tla-buffer-quit) -) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Revision key bindings -;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(when (not tla-revision-list-mode-map) - (setq tla-revision-list-mode-map (make-sparse-keymap)) - - ;;; Commands for merging/branching (M) - (define-key tla-revision-list-mode-map [?M ?s] 'tla-revision-star-merge) - (define-key tla-revision-list-mode-map [?M ?t] 'tla-revision-tag) - (define-key tla-revision-list-mode-map [?M ?r] 'tla-revision-replay) - - - ;;; Commands for marking (*) - (define-key tla-revision-list-mode-map [?* ?m] 'tla-revision-mark-revision) - ;; Add me! - ;; (define-key tla-revision-list-mode-map [?* ?u] - ;; 'tla-revision-unmark-revision) - - - ;;; Navigation - (define-key tla-revision-list-mode-map [?^] - 'tla-revision-list-parent-version) - (define-key tla-revision-list-mode-map [left] - 'tla-revision-list-parent-version) - (define-key tla-revision-list-mode-map [down] 'tla-bookmarks-missing-next) - (define-key tla-revision-list-mode-map [up] 'tla-bookmarks-missing-prev) - (define-key tla-revision-list-mode-map [?n] 'tla-bookmarks-missing-next) - (define-key tla-revision-list-mode-map [?p] 'tla-bookmarks-missing-prev) - - - ;;; Archive commands (A) - (define-key tla-revision-list-mode-map [?> ?g] 'tla-revision-get-revision) - (define-key tla-revision-list-mode-map [?> ?C] 'tla-revision-cache-revision) - (define-key tla-revision-list-mode-map [?> ?L] 'tla-revision-add-to-library) - (define-key tla-revision-list-mode-map [?A ?g] 'tla-revision-get-revision) - (define-key tla-revision-list-mode-map [?A ?c] 'tla-revision-cache-revision) - (define-key tla-revision-list-mode-map [?A ?l] 'tla-revision-add-to-library) - - - ;;; Toggle commands (T) - (define-key tla-revision-list-mode-map [?T ?d] 'tla-revision-toggle-date) - (define-key tla-revision-list-mode-map [?T ?c] 'tla-revision-toggle-creator) - (define-key tla-revision-list-mode-map [?T ?s] 'tla-revision-toggle-summary) - (define-key tla-revision-list-mode-map [?T ?r] 'tla-revision-toggle-reverse) - ;; ?t ?? is reserved. Not implemented yet. - (define-key tla-revision-list-mode-map [?T ??] 'tla-revision-list-toggles) - - - ;;; Debugging commands (D) - (define-key tla-revision-list-mode-map [?D p] 'tla-show-process-buffer) - ;; Add me! - ;; (define-key tla-revision-mode-map [?D l] 'tla-show-tla-log) - - - ;;; Revision specific commands - (define-key tla-revision-list-mode-map [?l] 'tla-revision-cat-log) - (define-key tla-revision-list-mode-map [?u] 'tla-revision-update) - (define-key tla-revision-list-mode-map "\C-m" 'tla-revision-return) - (define-key tla-revision-list-mode-map [return] 'tla-revision-return) - (define-key tla-revision-list-mode-map [right] 'tla-revision-return) - (define-key tla-revision-list-mode-map [?d] 'tla-revision-delta) - (define-key tla-revision-list-mode-map [?=] 'tla-revision-changeset) - (define-key tla-revision-list-mode-map [?i] 'tla-pop-to-inventory) - (define-key tla-revision-list-mode-map [?.] 'tla-revision-bookmarks-add) - - - ;;; Misc - (define-key tla-revision-list-mode-map [?g] 'tla-generic-refresh) - (define-key tla-revision-list-mode-map [?q] 'tla-buffer-quit) -) diff --git a/dvc/docs/CONTRIBUTORS b/dvc/docs/CONTRIBUTORS deleted file mode 100755 index 621abbd..0000000 --- a/dvc/docs/CONTRIBUTORS +++ /dev/null @@ -1,165 +0,0 @@ -#!/bin/sh -#| -*- scheme -*- |# -:; exec gosh -- $0 "$@" -;; -;; We want to merge dvc tree to GNU Emacs. Thus, every contributor -;; must assign copyright for this changes to the FSF. This file -;; tracks contributors and their copyright assignment status. -;; -;; Before reporting your patch for merging DVC official source tree, -;; add your name to this file. The entry format is as follows: -;; -;; (contributor :name "yourname" -;; :signed done--or--not-yet--or--tiny-change -;; :mail-addresses "addr1@example1.com") -;; -;; or -;; -;; (contributor :name "yourname" -;; :signed done--or--not-yet--or--tiny-change -;; :mail-addresses ("addr1@example1.com" "addr2@example2.com" ...)) -;; -;; You can use # instead of @ for circumventing the email-gathering -;; web spiders that spammers use. If you use a list for the -;; :mail-addresses field, the car is used for contacting the FSF. -;; -;; The first time :signed field may be `not-yet'. Then we will contact -;; you via email and send a copyright assignment templalte, which is -;; to be emailed to the FSF (at this point, :signed is changed to -;; `in-progress'). They will then send you the papers to sign. After -;; completing a paper work for it and getting the notification from -;; FSF, the :signed field will be changed to `done'. - -;; -;; *The order is not meaningful.* -;; -(define contributors - '( - (contributor :name "Stefan Reichoer" - :signed done - :mail-addresses ("stefan#xsteve.at" - "stefan#pyramide" - "xsteve#nit.at")) - (contributor :name "Matthieu MOY" - :signed done - :mail-addresses ("Matthieu.Moy#imag.fr" - "matthieu.moy#imag.fr" - "moy#ecrins" - "moy#moy")) - (contributor :name "Miles Bader" - :signed done - :mail-addresses "miles#gnu.org") - (contributor :name "Andre Kuehne" - :signed done - :mail-addresses "andre.kuehne#gmx.net") - (contributor :name "Vincent LADEUIL" - :signed done) - (contributor :name "Stephen Leake" - :signed done - :mail-addresses ("stephen_leake#stephe-leake.org" - "stephe#ACS1100007992" - "stephe#LM000850872")) - (contributor :name "Takuzo O'hara" - :signed done - :mail-addresses "takuzo.ohara#gmail.com") - (contributor :name "Michael Olson" - :signed done - :mail-addresses ("mwolson#member.fsf.org" - "mwolson#gnu.org" - "mwolson#exabyte")) - (contributor :name "Martin Brett Pool" - :signed done) - (contributor :name "Andrea Russo" - :signed done - :mail-addresses ("rastandy#inventati.org" - "rast4ndy#gmail.com")) - (contributor :name "Alan Shutko" - :signed done-emacs-only - :mail-addresses "ats#acm.org") - (contributor :name "Sam Steingold" - :signed done - :mail-addresses "sds#gnu.org") - (contributor :name "Mark Triggs" - :signed done - :mail-addresses "mark#dishevelled.net") - (contributor :name "Robert Widhopf-Fenk" - :signed done - :mail-addresses "hack#robf.de") - (contributor :name "Sascha Wilde" - :signed done-emacs-only - :mail-addresses "wilde#sha-bang.de") - (contributor :name "Masatake YAMATO" - :signed done - :mail-addresses ("jet#gyve.org" - "jet#gps06")) - (contributor :name "Steve Youngs" - :signed done-emacs-only - :mail-addresses "steve#sxemacs.org") - (contributor :name "Milan Zamazal" - :signed done - :mail-addresses ("pdm#zamazal.org" "pdm#debian.org")) - - ;; - ;; Assignment in progress - ;; - - ;; - ;; Does not need assignment yet - ;; - (contributor :name "Daniel Dehennin" - :contacted yes - :changed-elisp no - :signed not-yet - :mail-addresses "daniel.dehennin@baby-gnu.org") - - ;; - ;; Needs assignment (or investigation into changes made) - ;; - (contributor :name "Christian Ohler" - :signed not-yet - :contacted yes - :mail-addresses "ohler+mtn#fastmail.net") - (contributor :signed "Chris Gray" - :signed not-yet - :contacted email-invalid - :mail-addresses "christopher.grayb#mail.mcgill.ca") - (contributor :signed "Bojan Nikolic" - :signed in-progress - :contacted yes - :mail-addresses "bojan#bnikolic.co.uk") - (contributor :name "James LewisMoss" - :signed tiny-change - :mail-addresses "jim@lewismoss.org") - ;; - ;; ADD YOUR NAME HERE. - ;; - )) - - -;; -;; This is a program to pick something like mail addresses from the output of -;; tla and bzr. The contributors mail address listed above are removed from the -;; picked addresses. -;; -;; tla changelog | docs/CONTRIBUTORS | sort | uniq -;; bzr log | docs/CONTRIBUTORS | sort | uniq -;; -(use srfi-1) -(let* ((droplist '("dvc-dev#gna.org")) - (addresses (map - (cute regexp-replace #/#/ <> "@") - (apply append droplist - (map (lambda (c) - (let1 addrs (get-keyword :mail-addresses (cdr c) (list)) - (if (string? addrs) (list addrs) addrs))) - contributors)))) - (registered? (lambda (line) - (any (lambda (a) - (string-scan line a)) - addresses)))) - (let loop ((line (read-line))) - (unless (eof-object? line) - (when (string-scan line "@") - (unless (registered? line) - (print line))) - (loop (read-line))))) diff --git a/dvc/docs/DVC-API b/dvc/docs/DVC-API deleted file mode 100644 index 8565598..0000000 --- a/dvc/docs/DVC-API +++ /dev/null @@ -1,179 +0,0 @@ -That file contains the documentation to build support for a different dvc, -using the dvc layer: - -Conventions used in the document: -* 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 deleted file mode 100644 index 3333c0a..0000000 --- a/dvc/docs/FEATURES +++ /dev/null @@ -1,204 +0,0 @@ -This file is a annotated version of the output of tla help. - -It should help us to identify the missing features of xtla regarding -tla itself. Don't forget that xtla is more than a "wrapper" around -tla, so, xtla should also have features not listed here to have a real -added value (the bookmarks feature is probably the best example). - -There are currently 3 sections : - -* TODO : Nothing was done for that - -* DONE : Something was already done for that command. Probably it's - still not perfect yet. - -* NOT NEEDED : Nothing was done, and nothing will be done for this - feature since it's meaningless in xtla. - -After some time, there should be a fourth section : - -* FINISHED : We consider this feature is fully implemented. At least - we mean that, additions to this feature are lowest - priority. - -Moving an item from DONE to FINISHED or from TODO to NOT NEEDED should -be discussed on the mailing list. - - tla sub-commands - ---------------- - -* help - -[DONE] help : provide help with arch - - -* User Commands - -[DONE] my-id : print or change your id - -[DONE] my-default-archive : print or change your default archive -[DONE] register-archive : change an archive location registration -[DONE] whereis-archive : print an archive location registration -[DONE] archives : Report registered archives and their locations. - - -* Project Tree Commands - -[DONE] init-tree : initialize a new project tree -[DONE] tree-root : find and print the root of a project tree - -[DONE] tree-version : print the default version for a project tree -[DONE] set-tree-version : set the default version for a project tree - -[DONE] undo : undo and save changes in a project tree -[DONE] redo : redo changes in project tree - -[DONE] changes : report about local changes in a project tree -[DONE] file-diffs : show local changes to a file - - -* Project Tree Inventory Commands - -[DONE] inventory : inventory a source tree -[DONE] tree-lint : audit a source tree -[DONE] id : report the inventory id for a file - -[DONE] id-tagging-method : print or change a project tree id tagging method - -[DONE] add-id : add an explicit inventory id -[DONE] delete-id : remove an explicit inventory id -[DONE] rm : remove a file (or dir, or symlink) and its explicit inventory tag (if any) -[DONE] move-id : move an explicit inventory id -[DONE] mv : move a file (or dir, or symlink) and it's explicit inventory tag (if any) -[TODO] explicit-default : print or modify default ids - -[TODO] id-tagging-defaults : print the default =tagging-method contents - - -* Patch Set Commands - -[TODO] changeset : compute a whole-tree changeset -[DONE] apply-changeset : apply a whole-tree changeset -[DONE] show-changeset : generate a report from a changeset - - -* Archive Transaction Commands - -[DONE] make-archive : create a new archive directory -[NOT NEEDED] archive-setup : create new categories, branches and versions - -[DONE] make-category : create a new archive category -[DONE] make-branch : create a new archive branch -[DONE] make-version : create a new archive version - -[DONE] import : archive a full-source base-0 revision -[DONE] commit : archive a changeset-based revision - -[DONE] get : construct a project tree for a revision -[DONE] get-changeset : retrieve a changeset from an archive - -[TODO] lock-revision : lock (or unlock) an archive revision -[DONE] archive-mirror : update an archive mirror - - -* Archive Commands - -[DONE] abrowse : print an outline describing archive contents -[DONE] rbrowse : print an outline describing an archive's contents -[DONE] categories : list the categories in an archive -[DONE] branches : list the branches in an archive category -[DONE] versions : list the versions in an archive branch -[DONE] revisions : list the revisions in an archive version -[TODO] ancestry : display the ancestory of a revision -[TODO] ancestry-graph : display the ancestory of a revision - -[DONE] cat-archive-log : print the contents of an archived log entry - -[DONE] cacherev : cache a full source tree in an archive -[TODO] cachedrevs : list cached revisions in an archive -[TODO] uncacherev : remove a cached full source tree from an archive - -[TODO] archive-meta-info : report meta-info from an archive -[TODO] archive-snapshot : update an archive snapshot -[TODO] archive-version : list the archive-version in an archive - -[DONE] archive-fixup : fix ancillary files (e.g. .listing files) in an archive - - -* Patch Log Commands - -[DONE] make-log : initialize a new log file entry -[TODO] log-versions : list patch log versions in a project tree -[TODO] add-log-version : add a patch log version to a project tree -[TODO] remove-log-version : remove a version's patch log from a project tree -[DONE] logs : list patch logs for a version in a project tree -[DONE] cat-log : print the contents of a project tree log entry - -[DONE] changelog : generate a ChangeLog from a patch log - -[DONE] log-for-merge : generate a log entry body for a merge -[TODO] merges : report where two branches have been merged -[TODO] new-merges : list tree patches new to a version - - -* Multi-project Configuration Commands - -[DONE] build-config : instantiate a multi-project config -[DONE] cat-config : output information about a multi-project config - - -* Commands for Branching and Merging - -[DONE] tag : create a continuation revision (aka tag or branch) - -[DONE] update : update a project tree to reflect recent archived changes -[DONE] replay : apply revision changesets to a project tree -[DONE] star-merge : merge mutually merged branches -[TODO] apply-delta : Compute a changeset between any two trees or revisions and apply it to a project tree -[DONE] missing : print patches missing from a project tree - -[TODO] join-branch : construct a project tree for a version -[DONE] sync-tree : unify a project tree's patch-log with a given revision - -[DONE] delta : Compute a changeset (or diff) between any two trees or revisions - - -* Local Cache Commands - -[DONE] changes : report about local changes in a project tree -[DONE] file-diffs : show local changes to a file -[DONE] file-find : find given version of file - -[DONE] pristines : list pristine trees in a project tree -[TODO] lock-pristine : lock (or unlock) a pristine tree -[TODO] add-pristine : ensure that a project tree has a particular pristine revision -[TODO] find-pristine : find and print the path to a pristine revision - - -* Revision Library Commands - -[DONE] my-revision-library : print or change your revision library path -[DONE] library-config : configure parameters of a revision library -[DONE] library-find : find and print the location of a revision in the revision library -[DONE] library-add : add a revision to the revision library -[TODO] library-remove : remove a revision from the revision library -[DONE] library-archives : list the archives in your revision library -[DONE] library-categories : list the categories in your revision library -[DONE] library-branches : list the branches in a library category -[DONE] library-versions : list the versions in a library branch -[DONE] library-revisions : list the revisions in a library version -[TODO] library-log : output a log message from the revision library -[TODO] library-file : find a file in a revision library - - -* Published Revisions Commands - -[TODO] grab : grab a published revision - - -* Miscellaneous Scripting Support - -[NOT NEEDED] parse-package-name : parse a package name -[NOT NEEDED] valid-package-name : test a package name for validity - - diff --git a/dvc/docs/HACKING b/dvc/docs/HACKING deleted file mode 100644 index d43a603..0000000 --- a/dvc/docs/HACKING +++ /dev/null @@ -1,263 +0,0 @@ --*- mode: text -*- - -Developers -========== - -DVC will be merged to GNU Emacs(we hope). -So the developers should be able to sign to FSF about -copyright assignment. In other words, we can accept -only patches whose author agrees to sign to FSF. -CONTRIBUTORS file is for tracking the contributors -and their copyright assignments. - -CONTRIBUTORS file is maintained by Michael Olson. - -GNU Emacs, XEmacs and its version -================================= - -We will support both Emacs and XEmacs. The developers are using: - -Stefan Reichoer : 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 deleted file mode 100644 index 9a064c9..0000000 --- a/dvc/docs/TODO +++ /dev/null @@ -1,285 +0,0 @@ --*- mode: text -*- - -TODO/Wish list for xtla.el -========================== - -Mostly DONE section: -==================== - -* Some like file-diff-rev from the aba which gives you the changes to a - file between two specified revisions using the following: - diff -u $(tla file-find file.cpp $(tla tree-version)--patch-X) - $(tla file-find file.cpp $(tla tree-version)--patch-Y) - => This is the function tla-file-ediff-rev. There should also be a - version without ediff, just showing the diff output with - diff-mode. - -* Integration with ediff, which I usually prefer to diff-mode. - - This is done for M-x tla-ediff-buffer, `e' in *tla-changes*, 'd - e' in *tla-inventory* - - There is more to do from the *tla-revisions* buffer for example - (retrieve any two revisions and ediff them) - - a 3 way merge with ediff3 would be perfect. (Actually, ediff3 - isn't sufficient because it shows you the differences even in the - absence of conflict.). smerge-mode, integrated in Emacs 21, - already does a very good job for this - -* En entry "Branch from version" to create a symbolic tag from the - *tla-versions* buffer. - - Done for *tla-revisions*. - -* Code cleaning. There are a lot of duplicates. - => Some big code cleaning have been carried out, but such item can - never go to the "completely DONE" section ;-) - -DONE section: -============= - -* One line log from minibuffer to commit. - => This should be handled in vc-arch.el? - -* Add good doc strings for the functions - => Most functions have one now. - -* Recursive commands for projects using configurations. - => implemented for tla-changes and tla-update - -* Name reader should support complete location notation like: - - Location: Matthieu.Moy@imag.fr--public/xtla--main--0.1 - - Current partial and incremental location reading is supported - like: - - Archive: Matthieu.Moy@imag.fr--public - Category: xtla - Branch: main - Version: 0.1 - - => The engine is implemented. Apply it to interactive functions. - -* Add a texinfo file - - What should be the structure of this file? - => Very short. Just a starting point for the users, but xtla should - be self-documented. Menus and docstrings should be sufficient - most of the time. - A demo with screenshots would be nice too. (to let people get - an idea of what xtla is in less than a minute.) - - Should we guide through the tla tutorial? - (Be carefull. I don't like people to learn a tool from the - front-end. I prefer let them understand the concepts with the - command line, and learn the front-end after. It takes a bit more - time but is much more pedagogical) - -* M-x xtla should provide the buttons to jump tla-inventory, - tla-bookmarks and so on. This should be integrated with the command central? - -* Optimize tla-archive-tree manipulator when it is updated. - I think using rbrowse and/or abrowse output is better than current - implementation.[Masatake] Not so much, because browsing a small - branch in a big archive would be slow (discussed on the ML) - [Matthieu] - -* tla log font-lock (like ChangeLog) - -* A "revert file" feature. Most of the code is already in - tla-file-ediff. (done in tla-file-revert) - -* Archive mirroring. - [Matthieu Moy: I'm taking care of this] - -* Prompt for saving buffer visiting files of the current tree for most - operations: commit, update, changes, ... (Which other ones ?) - -* M-x xtla-update. Possibility to update from the bookmarks buffer. - -* Merge xtla-fully-qualified-revision and xtla-name-construct. - [Masatake YAMATO] - -* M-x tla-missing RET should be merged with tla-bookmarks-missing - -* Bridge between smerge-mode and xtla.el. - [Masatake YAMATO - (Should completely replace my code -- Matthieu) - (No, I shouldn't. Each function has each necessity.) - -* When there are no changes anymore, the `g' command in the - *tla-changes* buffer just prints a message in the echo area, and - doesn't update the buffer, which can be confusing; it would be - better to erase the buffer and perhaps insert the "No changes" - description to make it clear what's going on (so work slightly - differently than `M-x tla-changes' invoked from another buffer -- in - that case, just a message is good). - => tla-changes now clears the *tla-changes* buffer before doing - anything else. - -* More diff-mode commands should be bound in the *tla-changes* buffer, - e.g., `P', and `N'; maybe it can just inherit from the diff-mode - keymap? - => We are already inheriting from diff-mode. However, the way the keymap - is managed in diff-mode is really strange, and you're right, - we're not inheriting `N' and `P'. But still, diff-file-next is - available with M-N for example. Strange ... - => initializing tla-changes-mode-map from diff-mode-shared-map - did it. - -* It would be nice if the `g' command in a *tla-changes* buffer would - would retain any existing marks (I often want to check the changes - just one last time before committing). - -* Perhaps when `tla-make-log-function' is non-nil, `tla-make-log' should - check the return value, and if nil, make a normal log file. That way - the user's special version can only worry about special cases. - - => I (Matthieu MOY) did something a bit different. - tla-make-log-function now defaults to - tla-default-make-log-function, which calls "tla make-log". The - user can just write a wrapper around this function. - -* Wrapper for tla import. - - - From the working directory, M-x tla-start-project RET should run - . tla init-tree - . tla import --setup - . call tla-edit-log - [Mark Triggs: This is pretty much what I have done, except I have - used tla-inventory instead of tla-edit-log.] - - - From the archive browser, there should be an option to offer the - user to create a new project, as you can already create new empty - categories, branches, and versions. - -* There could be a menu to navigate buffers based on the variable - tla--buffers-tree. This could also be included in tla-browse.el - using tree-widget. - => pulldown/popup menu is implemented. Maybe enough -- Masatake. - -* undo modifications in local copy at tla-inventory buffer - Matthieu gave hit in the mailing list: - - What I meant by "undo" was - - cp `tla file-find foo.c` . - -* Run missing, replay and star-merge against specified version. - -* Eliminate all occurence of tla--run-arch. - -* If not in a project tree, `tla-changes' should prompt for the tree - name similar to tla-inventory -- often I'd rather start out with - `changes' and skip `inventory' entirely. - -* Modeline : I'd like to see something like the "compiling" item in - the modeline while compiling with M-x compile RET. - -* An interface to tla help, giving the list of commands, and running - "tla -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 deleted file mode 100644 index 3f51ab5..0000000 --- a/dvc/docs/xmtn-readme.txt +++ /dev/null @@ -1,348 +0,0 @@ -* General - -xmtn is an Emacs Lisp package that provides a DVC backend for monotone -(the distributed version control system) as well as general facilities -for interacting with monotone from Emacs Lisp. - -For more information about monotone, see http://monotone.ca/ . - -xmtn's facilities for interacting with monotone are meant to be -reusable by code that is unrelated to DVC, even though they currently -depend on the subprocess handling utilities that DVC provides. - -xmtn should work on GNU Emacs 21 or newer. Work on supporting XEmacs -has started but is unfinished; patches welcome. On XEmacs, xmtn -requires MULE. - - -* Download and installation - -Follow the download and installation instructions for DVC. xmtn is -part of DVC. - -In addition, the variable `xmtn-executable' needs to point to the -monotone executable. It defaults to "mtn", which will be sufficient -if mtn is in your PATH. Depending on your configuration, the PATH -that Emacs sees can differ from the PATH that you see in your shell. -Try M-x getenv RET PATH RET if in doubt. - -You may wish to set `dvc-debug' to nil; DVC tends to be a bit chatty. - - - -* Brief tutorial - -(DVC's tutorial does not apply to xmtn, it seems to be specific to -tla.) - -Start Emacs. Visit a file that is under version control by monotone. -Modify the file. While in the file's buffer, press C-x V d to see the -diff for this file. - -Pressing C-x V = will bring up the tree diff buffer. (What monotone -calls a "workspace" is called a "tree" in DVC.) This buffer shows the -list of all modified files in the tree as well as the diffs for those -files. Use j to jump back and forth between the name of a file in the -list and the diffs for that file. Use RET with point inside a diff -hunk to go to the corresponding file at the corresponding position. - -Like many other DVC buffers, the contents of the tree diff buffer can -be refreshed using g. - -In the tree diff buffer, files to commit can be marked and unmarked -with m and u. Pressing c lets you commit the selected files; it will -bring up a log edit buffer where you can enter a commit message. - -In the log edit buffer, the commit can be executed by pressing C-c -C-c. To abort the commit, simply don't press C-c C-c -- just switch -away from the buffer or kill it. The log edit buffer edits the file -_MTN/log. - -To bring up the log edit buffer without going through the tree diff -buffer, use C-x V c. - -To view the revision history, use C-x V l or C-x V L. The former -shows the full commit message for each revision, while the latter only -shows the first line. The resulting buffer is a so-called revlist -buffer. In revlist buffers, use cursor up/down to move between -revisions, RET to show details on the revision at point, = to show its -diff from its parent. Revisions can be marked and unmarked with m and -u. - -M-x xmtn-view-heads-revlist shows a revlist buffer with just the heads -of the default branch of your tree. To update your tree to one of the -revisions in a revlist buffer, move point to it and use M-x -xmtn-revlist-update. To merge two head revisions, mark them and use -M-x xmtn-revlist-explicit-merge. - -M-x xmtn-view-revlist-for-selector prompts for a monotone selector and -shows a revlist buffer with all matching revisions. - -C-x V u performs mtn update. C-x V m shows a revlist buffer with the -revisions that mtn update would apply to your tree. - -C-x V f a performs mtn add. M-x dvc-ignore-files and M-x -dvc-ignore-file-extensions can be used to add entries to .mt-ignore. -These commands can also be used from dired buffers. - -C-x V s shows the status buffer. This currently shows modified, -renamed and unknown files. It's supposed to allow operations like -diff, commit, revert etc. (like pcl-cvs), but that's not implemented -yet. C-x V = is preferable at the moment, although it doesn't show -unknown files. - -C-x V a can be used to add a ChangeLog entry to _MTN/log. - -There are other useful operations, but these should be enough to get -started. - - - -* Known limitations - -xmtn currently just bails out when it needs to operate on a head of a -branch and notices that the branch is unmerged. It should prompt the -user to select a head instead. To update to a head of an unmerged -revision graph, use M-x xmtn-view-heads-revlist and M-x -xmtn-revlist-update. - -`xmtn-dvc-diff' breaks when called in a workspace that has no base -revision (e.g. a newly created project). mtn diff works in this case. - -Building a revlist buffer is currently a bit slow (or maybe very slow -for long histories?), and the revlist display is not very pretty. - -For `dvc-ignore-files' and `dvc-ignore-file-extensions', xmtn operates -on the file .mtn-ignore. This may fail to have the intended effect if -the user has customized monotone's ignore_file hook in a way that -changes the meaning of this file. - -The ability to perform operations such as diff and commit from the -status buffer is missing. For now, use the tree diff buffer for this. - -xmtn doesn't define any key bindings for monotone-specific commands. -Only the backend-independent key bindings defined by DVC are available. - -For now, I don't see the point of checking automate interface_version: -Many of xmtn's operations rely on non-automate commands, so a -compatible automate interface_version doesn't guarantee actual -compatibility; we have to check for a compatible command version -anyway, and that check subsumes the check of interface_version. And -declaring incompatibility whenever we see an automate -interface_version that is too high for us yields false positives too -easily to be useful. - -xmtn currently uses mtn automate get_revision in places where it -should be using mtn automate inventory. This is because I was trying -to avoid having to implement a parser for mtn automate inventory, and -get_revision seemed to return almost the same information. However, -get_revision fails if there are missing files -- I discovered this too -late. This is part of the reason why many operations first check -whether files are missing from the tree, and abort if this is the -case. - -DVC REVISION-IDs that refer to the "Nth ancestor" such as `(xmtn -(last-revision ...))' or `(xmtn (previous-revision ...))' are -ill-defined for non-linear history in monotone. xmtn currently -throws an error when it encounters a node that has multiple parents -while trying to resolve such IDs. - -The support for international character sets/coding systems is partly -based on guesswork but works for my tests. - -xmtn does not entirely follow DVC's philosophy: It only implements -DVC's protocols, but doesn't provide its own UI that parallels DVC's. -Hence, much of xmtn's functionality is only available through DVC. -This is because xmtn currently provides only few features beyond what -DVC requires, and implementing a redundant UI was not a high priority -for me. - -Currently, the following parts of the DVC protocol are not implemented -by xmtn: - - * xmtn-dvc-send-commit-notification, xmtn-dvc-submit-patch: These - commands send an e-mail. Probably useful to people who use a - certain work flow, but not to me right now. These will have to - wait until someone comes along who actually has a use for them. - - * xmtn-insinuate-gnus: Need to find out what, precisely, this is - supposed to do. I don't use Gnus myself. - - * xmtn-dvc-save-diff: xhg seems to be the only backend that - implements this. It really seems this could be moved into the - common part of DVC anyway. Won't bother implementing it right - now. - - * xmtn-dvc-pull: Should be easy. But syncing via command line is - acceptable to me at the moment. The docstring looks like this - needs to do both mtn pull and mtn update -- but I doubt that this - is a good idea for monotone. - - - -* Internals - -This section describes some of the internals of xmtn and some of the -design decisions behind it. - - - -** Conventions - -monotone.el (from montone's contrib/ directory) already uses the -prefix mtn-. monotone- is already taken by Wim Oudshoorn's e-monotone -package. So this package is named xmtn. xhg, xcg, xdarcs seem to be -in similar situations. - -The prefix xmtn- is for definitions exported for the user or for DVC, -the prefix xmtn-- is for internal definitions. Similarly, -xmtn-automate uses xmtn-automate- and xmtn-automate--, etc. - -It seems like "monotone" is usually written in small letters. The -manual capitalizes it at the beginnings of sentences, but e.g. the web -page or mtn --version never capitalize it at all -- then again, the -web page doesn't capitalize much at all. In xmtn, we capitalize it -like a noun. xmtn and mtn (as a command name) are always in lower -case. - -Monotone uses the term "workspace", DVC uses the term "tree". In our -UI, we use "tree" for consistency with DVC. The idea behind this -decision was that consistency with DVC (and other aspects of Emacs' -UI) is more important than consistency with other monotone front-ends. -But I'm not so sure about this any more; the term "workspace" is so -much more clear... But I guess it makes little sense for version -control systems that don't distinguish between workspaces and -branches. - - - -** Architecture - -This section is unlikely to stay fully up-to-date as xmtn's -implementation evolves, but should remain useful as a general -introduction to xmtn's architecture. - -xmtn consists of several modules. One way of understanding their -relationship is to group them into layers. - - - User-visible functionality: xmtn-dvc.el, xmtn-revlist.el - - Domain-specific utilities: xmtn-ids.el - - High-level interface to mtn: xmtn-automate.el, xmtn-basic-io.el - - Low-level interface to mtn: xmtn-run.el - - Monotone-related definitions: xmtn-base.el - - Support libraries: xmtn-compat.el - - Language extensions: xmtn-match.el - - -Each module should only depend on modules at layers beneath it. (At -least, that's the idea; the code might not satisfy this perfectly.) - -xmtn-dvc.el implements the protocols required by DVC, except for -functionality related to interactive display and manipulation of -revision history, which is in xmtn-revlist.el. - -xmtn-ids.el contains code to resolve symbolic revision ids in a -certain syntax to explicit hash ids. DVC needs this, but xmtn -provides some useful extensions. For example, a symbolic id `(xmtn -(previous-revision (previous-revision (revision -"75da2575dfc565f6976ed5dd1997bc7afc0ce908"))))' resolves to `(revision -"721c3ab9b5099d3ed7d8b807e08382f3c95badec")'; i.e. the parent of the -parent of revision 75da2575dfc565f6976ed5dd1997bc7afc0ce908 is -revision 721c3ab9b5099d3ed7d8b807e08382f3c95badec. - -xmtn-automate.el and xmtn-basic-io.el implement an interface to -monotone's automate functionality and a parser for monotone's basic_io -output format. These modules aren't specific to DVC and should be -reusable by other Emacs Lisp code that wants to use monotone. - -xmtn-run.el provides functions for running individual (non-automate) -monotone commands and checking the version of the monotone executable. -The functionality of xmtn-run.el isn't specific to DVC, either, but -its current implementation depends on DVC's process handling -functions, so it's fairly heavyweight. - -xmtn-base.el was supposed to contain definitions related to monotone -that are common to xmtn-run.el, xmtn-automate.el and/or -xmtn-basic-io.el, to avoid having to have dependencies on xmtn-run.el -in xmtn-automate.el or xmtn-basic-io.el. This refactoring is not -complete (yet?), though. - -xmtn-compat.el contains compatibility wrappers for some Emacs Lisp -functions that are not fully portable across Emacs versions. - -xmtn-match.el provides a pattern-matching facility for Emacs Lisp that -is very useful for destructuring DVC REVISION-IDs and processing -basic_io stanzas the way xmtn-basic-io.el parses them. But it is -rather generic and could also be useful for code entirely unrelated to -montone and DVC. - -There are a few automated regression tests in -lisp/tests/xmtn-tests.el. - - - - -** Implementation details - - - -*** Futures - -For some subprocess interactions, xmtn uses a concept called -"futures". In this context, a future is a concurrent computation -represented by a zero-argument anonymous function that, when called, -blocks until the concurrent computation finishes, and returns its -result. - -For example, the function `xmtn--unknown-files-future' returns a -future for the list of unknown files instead of returning the list of -unknown files directly. This allows Emacs Lisp code to ask monotone -for the list of unknown files, but then do something different while -monotone computes the list. Only when Emacs actually needs the list -in order to continue, it calls the future and waits for monotone to -finish (if it hasn't finished already). - -If a future is called a second time or more often, it will just keep -returning the same result. (What a future does if the concurrent -computation terminates unsuccessfully isn't currently very -well-defined. It should probably signal an error when it is called.) - -Spawning computations in parallel has yielded tremendous speed-ups for -certain parts of xmtn (at least in some versions -- I haven't profiled -it recently). Futures make this type of parallelism simple to deal -with. - - - - -*** Notes on variable names and dynamic bindings - -In higher-order functions (functions that take functions as -arguments), xmtn attempts to avoid introducing spurious dynamic -bindings because they might shadow bindings that the caller wants to -provide to the argument function. xmtn uses `lexical-let' for this -purpose. Unfortunately, function arguments are always dynamic -bindings in Emacs Lisp. That's why the argument names of higher-order -functions in xmtn always have the prefix xmtn-- and are immediately -re-bound to (pseudo-)lexical variables using `lexical-let'. This -makes it unlikely that the arguments will collide with the caller's -variables. - -The alternative would be to always use `lexical-let' for bindings that -should be passed through higher-order functions to closures. This is -the most reliable approach, and xmtn also follows it. But errors -resulting from accidental violations of this convention can be very -hard to debug, so the above is still useful for additional safety. - - - - - LocalWords: DVC minibuffer UI montone xmtn revlist unmerged docstring backend - LocalWords: backends destructuring mtn diff --git a/dvc/dvc-load-install.el.in b/dvc/dvc-load-install.el.in deleted file mode 100644 index e78b50e..0000000 --- a/dvc/dvc-load-install.el.in +++ /dev/null @@ -1,24 +0,0 @@ -; -*- mode: emacs-lisp -*- -;; -;; Load DVC easily ... -;; -;; Manually, you can run -;; -;; M-x load-file RET /path/to/dvc-load.el RET -;; -;; (usefull when you want to load DVC after starting "emacs -q"!), or -;; add -;; -;; (load-file "/path/to/this/file/in/installdir/dvc-load.el") -;; -;; to your ~/.emacs.el - -(add-to-list 'load-path "@lispdir@/") -(add-to-list 'Info-default-directory-list "@info_dir@") - -(if (featurep 'dvc-core) - (dvc-reload) - (if (featurep 'xemacs) - (require 'auto-autoloads) - (require 'dvc-autoloads))) - diff --git a/dvc/dvc-load.el.in b/dvc/dvc-load.el.in deleted file mode 100644 index 3bb2716..0000000 --- a/dvc/dvc-load.el.in +++ /dev/null @@ -1,26 +0,0 @@ -; -*- mode: emacs-lisp -*- -;; -;; Load DVC easily ... -;; -;; Manually, you can run -;; -;; M-x load-file RET /path/to/dvc-load.el RET -;; -;; (usefull when you want to load DVC after starting "emacs -q"!), or -;; add -;; -;; (load-file "/path/to/this/file/in/builddir/dvc-load.el") -;; -;; to your ~/.emacs.el - -(add-to-list 'load-path "@abs_top_builddir@/lisp") -(unless (locate-library "ewoc") - (add-to-list 'load-path "@abs_top_builddir@/lisp/contrib")) -(add-to-list 'Info-default-directory-list "@abs_top_builddir@/texinfo") - -(if (featurep 'dvc-core) - (dvc-reload) - (if (featurep 'xemacs) - (require 'dvc-autoloads "@abs_top_builddir@/lisp/auto-autoloads.elc") - (require 'dvc-autoloads))) - diff --git a/dvc/install-sh b/dvc/install-sh deleted file mode 100755 index e9de238..0000000 --- a/dvc/install-sh +++ /dev/null @@ -1,251 +0,0 @@ -#!/bin/sh -# -# install - install a program, script, or datafile -# This comes from X11R5 (mit/util/scripts/install.sh). -# -# Copyright 1991 by the Massachusetts Institute of Technology -# -# Permission to use, copy, modify, distribute, and sell this software and its -# documentation for any purpose is hereby granted without fee, provided that -# the above copyright notice appear in all copies and that both that -# copyright notice and this permission notice appear in supporting -# documentation, and that the name of M.I.T. not be used in advertising or -# publicity pertaining to distribution of the software without specific, -# written prior permission. M.I.T. makes no representations about the -# suitability of this software for any purpose. It is provided "as is" -# without express or implied warranty. -# -# Calling this script install-sh is preferred over install.sh, to prevent -# `make' implicit rules from creating a file called install from it -# when there is no Makefile. -# -# This script is compatible with the BSD install script, but was written -# from scratch. It can only install one file at a time, a restriction -# shared with many OS's install programs. - - -# set DOITPROG to echo to test this script - -# Don't use :- since 4.3BSD and earlier shells don't like it. -doit="${DOITPROG-}" - - -# put in absolute paths if you don't have them in your path; or use env. vars. - -mvprog="${MVPROG-mv}" -cpprog="${CPPROG-cp}" -chmodprog="${CHMODPROG-chmod}" -chownprog="${CHOWNPROG-chown}" -chgrpprog="${CHGRPPROG-chgrp}" -stripprog="${STRIPPROG-strip}" -rmprog="${RMPROG-rm}" -mkdirprog="${MKDIRPROG-mkdir}" - -transformbasename="" -transform_arg="" -instcmd="$mvprog" -chmodcmd="$chmodprog 0755" -chowncmd="" -chgrpcmd="" -stripcmd="" -rmcmd="$rmprog -f" -mvcmd="$mvprog" -src="" -dst="" -dir_arg="" - -while [ x"$1" != x ]; do - case $1 in - -c) instcmd="$cpprog" - shift - continue;; - - -d) dir_arg=true - shift - continue;; - - -m) chmodcmd="$chmodprog $2" - shift - shift - continue;; - - -o) chowncmd="$chownprog $2" - shift - shift - continue;; - - -g) chgrpcmd="$chgrpprog $2" - shift - shift - continue;; - - -s) stripcmd="$stripprog" - shift - continue;; - - -t=*) transformarg=`echo $1 | sed 's/-t=//'` - shift - continue;; - - -b=*) transformbasename=`echo $1 | sed 's/-b=//'` - shift - continue;; - - *) if [ x"$src" = x ] - then - src=$1 - else - # this colon is to work around a 386BSD /bin/sh bug - : - dst=$1 - fi - shift - continue;; - esac -done - -if [ x"$src" = x ] -then - echo "install: no input file specified" - exit 1 -else - true -fi - -if [ x"$dir_arg" != x ]; then - dst=$src - src="" - - if [ -d $dst ]; then - instcmd=: - chmodcmd="" - else - instcmd=mkdir - fi -else - -# Waiting for this to be detected by the "$instcmd $src $dsttmp" command -# might cause directories to be created, which would be especially bad -# if $src (and thus $dsttmp) contains '*'. - - if [ -f $src -o -d $src ] - then - true - else - echo "install: $src does not exist" - exit 1 - fi - - if [ x"$dst" = x ] - then - echo "install: no destination specified" - exit 1 - else - true - fi - -# If destination is a directory, append the input filename; if your system -# does not like double slashes in filenames, you may need to add some logic - - if [ -d $dst ] - then - dst="$dst"/`basename $src` - else - true - fi -fi - -## this sed command emulates the dirname command -dstdir=`echo $dst | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'` - -# Make sure that the destination directory exists. -# this part is taken from Noah Friedman's mkinstalldirs script - -# Skip lots of stat calls in the usual case. -if [ ! -d "$dstdir" ]; then -defaultIFS=' -' -IFS="${IFS-${defaultIFS}}" - -oIFS="${IFS}" -# Some sh's can't handle IFS=/ for some reason. -IFS='%' -set - `echo ${dstdir} | sed -e 's@/@%@g' -e 's@^%@/@'` -IFS="${oIFS}" - -pathcomp='' - -while [ $# -ne 0 ] ; do - pathcomp="${pathcomp}${1}" - shift - - if [ ! -d "${pathcomp}" ] ; - then - $mkdirprog "${pathcomp}" - else - true - fi - - pathcomp="${pathcomp}/" -done -fi - -if [ x"$dir_arg" != x ] -then - $doit $instcmd $dst && - - if [ x"$chowncmd" != x ]; then $doit $chowncmd $dst; else true ; fi && - if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dst; else true ; fi && - if [ x"$stripcmd" != x ]; then $doit $stripcmd $dst; else true ; fi && - if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dst; else true ; fi -else - -# If we're going to rename the final executable, determine the name now. - - if [ x"$transformarg" = x ] - then - dstfile=`basename $dst` - else - dstfile=`basename $dst $transformbasename | - sed $transformarg`$transformbasename - fi - -# don't allow the sed command to completely eliminate the filename - - if [ x"$dstfile" = x ] - then - dstfile=`basename $dst` - else - true - fi - -# Make a temp file name in the proper directory. - - dsttmp=$dstdir/#inst.$$# - -# Move or copy the file name to the temp name - - $doit $instcmd $src $dsttmp && - - trap "rm -f ${dsttmp}" 0 && - -# and set any options; do chmod last to preserve setuid bits - -# If any of these fail, we abort the whole thing. If we want to -# ignore errors from any of these, just make sure not to ignore -# errors from the above "$doit $instcmd $src $dsttmp" command. - - if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; else true;fi && - if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; else true;fi && - if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; else true;fi && - if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; else true;fi && - -# Now rename the file to the real destination. - - $doit $rmcmd -f $dstdir/$dstfile && - $doit $mvcmd $dsttmp $dstdir/$dstfile - -fi && - - -exit 0 diff --git a/dvc/lisp/Makefile.in b/dvc/lisp/Makefile.in deleted file mode 100644 index 4c5da3f..0000000 --- a/dvc/lisp/Makefile.in +++ /dev/null @@ -1,97 +0,0 @@ -@SET_MAKE@ - -PACKAGE_VERSION = @PACKAGE_VERSION@ -PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ - -############################################################################## -# location of required programms -prefix = @prefix@ -RM = @RM@ -ETAGS = etags -MKDIR_P = @MKDIR_P@ -INSTALL = @INSTALL@ -INSTALL_DATA = @INSTALL_DATA@ - -top_srcdir = @top_srcdir@ -srcdir = @srcdir@ - -datarootdir= @datarootdir@ -lispdir = @lispdir@ - -EMACS_PROG = @EMACS_PROG@ - -FLAGS = @FLAGS@ - -# Other settings - -OTHERDIRS = @OTHERDIRS@ - -ebatch = srcdir=$(srcdir) otherdirs="$(OTHERDIRS)" \ - $(EMACS_PROG) -batch -q $(FLAGS) -l $(srcdir)/dvc-build.el -f - -alldeps = dvc-version.el dvc-site.el - -all: $(alldeps) - $(ebatch) dvc-build-all - -all-verbose: $(alldeps) - $(ebatch) dvc-build-all verbose - -# We install foo.el only if there is also foo.elc. -install: all - $(MKDIR_P) -m 0755 "$(lispdir)" - @dlist='$(srcdir) $(srcdir)/contrib' ; \ - test '$(srcdir)' = '.' || dlist=". $$dlist" ; \ - for elc in *.elc ; do \ - el=`echo $$elc | sed 's/.$$//'` ; orig= ; \ - for d in $$dlist ; do \ - if [ -r "$$d/$$el" ] ; then \ - orig="$$d/$$el" ; break ; fi ; done ; \ - test "$$orig" || continue ; \ - echo Installing $$el ; \ - $(INSTALL_DATA) "$$orig" "$(lispdir)" ; \ - echo Installing $$elc ; \ - $(INSTALL_DATA) $$elc "$(lispdir)" ; \ - done - $(INSTALL_DATA) $(srcdir)/xmtn-hooks.lua $(lispdir) - -clean: - rm -f *.elc dvc-site.el \ - dvc-autoloads.el auto-autoloads.el custom-load.el - -Makefile: $(srcdir)/Makefile.in ../config.status - cd ..; ./config.status - -distclean: clean - rm -f Makefile - -maintainer-clean: - rm -f dvc-version.el - -TAGS: $(SRCS) - @if test "x$(ETAGS)" = "x" ; then \ - echo "Sorry, no \`etags' program available." ; \ - else \ - $(ETAGS) */*.el ; \ - fi - -############################################################################## -autoloads: - $(ebatch) dvc-build-autoloads $(srcdir) - - -############################################################################## -dvc-version.el: ../config.status - @echo Creating $@ - @( echo ';;; $@ (generated file -- do not edit!)' ; \ - echo '(defconst dvc-version "$(PACKAGE_VERSION)"' ; \ - echo ' "Version of DVC loaded.' ; \ - echo 'Please send bug reports to <$(PACKAGE_BUGREPORT)>.")' ; \ - echo "(provide 'dvc-version)" ) \ - > $@ - -dvc-site.el: ../config.status $(srcdir)/dvc-site.el.in - (cd .. ; ./config.status lisp/$@) - -.PHONY: all all-verbose install \ - clean distclean maintainer-clean diff --git a/dvc/lisp/baz-dvc.el b/dvc/lisp/baz-dvc.el deleted file mode 100644 index b273015..0000000 --- a/dvc/lisp/baz-dvc.el +++ /dev/null @@ -1,54 +0,0 @@ -;;; 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 deleted file mode 100644 index 294a4a1..0000000 --- a/dvc/lisp/baz.el +++ /dev/null @@ -1,337 +0,0 @@ -;;; 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 deleted file mode 100644 index 93525c1..0000000 --- a/dvc/lisp/bzr-core.el +++ /dev/null @@ -1,98 +0,0 @@ -;;; bzr-core.el --- Core of support for Bazaar 2 in DVC - -;; Copyright (C) 2005-2008 by all contributors - -;; Author: Matthieu Moy -;; 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 deleted file mode 100644 index a51d1f1..0000000 --- a/dvc/lisp/bzr-dvc.el +++ /dev/null @@ -1,135 +0,0 @@ -;;; bzr-dvc.el --- Support for Bazaar 2 in DVC's unification layer - -;; Copyright (C) 2005-2008 by all contributors - -;; Author: Matthieu Moy -;; 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 deleted file mode 100644 index 7ac038b..0000000 --- a/dvc/lisp/bzr-gnus.el +++ /dev/null @@ -1,158 +0,0 @@ -;;; 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 deleted file mode 100644 index a35e3e2..0000000 --- a/dvc/lisp/bzr-revision.el +++ /dev/null @@ -1,221 +0,0 @@ -;;; 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 deleted file mode 100644 index 596d699..0000000 --- a/dvc/lisp/bzr-revlog.el +++ /dev/null @@ -1,69 +0,0 @@ -;;; 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 deleted file mode 100644 index c1c611e..0000000 --- a/dvc/lisp/bzr-submit.el +++ /dev/null @@ -1,272 +0,0 @@ -;;; 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 deleted file mode 100644 index 86e7dfa..0000000 --- a/dvc/lisp/bzr.el +++ /dev/null @@ -1,1363 +0,0 @@ -;;; bzr.el --- Support for Bazaar 2 in DVC - -;; Copyright (C) 2005-2012 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-upload (&optional repo-path) - "Run bzr upload. This command requires the bzr-upload plugin -When called with a prefix argument, add the --remember option" - (interactive (list (read-string (format "Upload %sto bzr working copy: " - (if current-prefix-arg "--remember " ""))))) - (when (string= repo-path "") - (setq repo-path nil)) - (dvc-run-dvc-async 'bzr (list "upload" repo-path (when current-prefix-arg "--remember")) - :finished - (dvc-capturing-lambda - (output error status arguments) - (message "bzr upload 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 1))) - (with-current-buffer changes-buffer - (ewoc-enter-last dvc-fileinfo-ewoc - (make-dvc-fileinfo-file - :mark nil - :dir nil - :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 deleted file mode 100644 index b8498fc..0000000 --- a/dvc/lisp/contrib/elunit.el +++ /dev/null @@ -1,167 +0,0 @@ -;;; elunit.el --- Emacs Lisp Unit Testing framework - -;; Copyright (C) 2006 Phil Hagelberg - -;; Adapted-By: Christian M. Ohler - -;; Inspired by regress.el by Wayne Mesard and Tom Breton, Test::Unit -;; by Nathaniel Talbott, and xUnit by Kent Beck - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; A copy of the GNU General Public License can be obtained from the -;; Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -;; See http://dev.technomancy.us/phil/wiki/ElUnit for usage details. - -(require 'cl) -(require 'compile) - -(defvar *elunit-suites* - '() - "A list of unit test suites") - -(defvar *elunit-default-suite* nil - "Choice to use for default suite to run (gets updated to last suite run)") - -(defun elunit-suite (name) - (cdr (assoc name *elunit-suites*))) - -(defun elunit-get-test (name suite) - (when (symbolp suite) (setq suite (elunit-suite suite))) - (assoc name suite)) - - -;;; Defining tests - -(defmacro defsuite (suite-name &rest tests) - "This is what you use to set things up." - (dolist (test tests) - (elunit-add-to-suite (make-test test) suite-name))) - -(defun make-test (body) - (let ((name (pop body))) - (list name body buffer-file-name - (save-excursion - (condition-case var - (progn (search-backward (symbol-name name)) - (if (fboundp 'line-number-at-pos) - (line-number-at-pos) - 'unknown)) ; not a foolproof heuristic to get line number, but good enough. - (error 'unknown)))))) - -(defun elunit-add-to-suite (test suite) - (unless (elunit-suite suite) (elunit-make-suite suite)) - (elunit-delete-test (car test) suite) - (push test (cdr (assoc suite *elunit-suites*)))) - -(defun elunit-make-suite (suite) - (push (list suite) *elunit-suites*)) - -(defun elunit-delete-test (name suite) - (when (elunit-get-test name suite) - (setf (cdr (assoc suite *elunit-suites*)) (assq-delete-all name (elunit-suite suite))))) - -(defun elunit-clear-suites () - (setq *elunit-suites* '((default-suite ())))) - - -;;; Running the unit tests - -(defun elunit (suite &optional force-prompt) - "Run all tests in SUITE (a string), and display the results. - -Prompt for a suite if FORCE-PROMPT is non-nil, or if both SUITE -and `*elunit-default-suite*' are nil." - (interactive "i\nP") - (unless suite (setq suite *elunit-default-suite*)) - (cond ((null suite) - (setq suite - (completing-read - "Run test suite: " - (mapcar (lambda (suite) (cons (symbol-name (car suite)) - (symbol-name (car suite)))) - *elunit-suites*) - nil t))) - (force-prompt - (setq suite - (completing-read - (format "Run test suite (default %s): " suite) - (mapcar (lambda (suite) (cons (symbol-name (car suite)) - (symbol-name (car suite)))) - *elunit-suites*) - nil t nil nil suite))) - (t (progn))) - (setq *elunit-default-suite* suite) - (setq *elunit-fail-count* 0) - (run-hooks (intern (concat suite "-setup-hook"))) - (with-output-to-temp-buffer "*elunit*" - (princ (concat "Loaded suite: " suite "\n\n")) - (let* ((tests (elunit-suite (intern suite))) - (start-time (cadr (current-time))) - (total (length tests))) - (let ((results (loop for test-id from 1 - for test in (reverse tests) - ;; This used to be `with-temp-message', but - ;; writing the boundaries between test cases - ;; into the *Messages* buffer can be - ;; helpful. - do (message "Running test \"%s\" (%s of %s)..." - (first test) test-id total) - collect (apply #'elunit-run-test test)))) - (message "Ran %s tests; %s failed" total *elunit-fail-count*) - (elunit-report-results results)) - (princ (format " in %d seconds." (- (cadr (current-time)) start-time))))) - (run-hooks (intern (concat suite "-teardown-hook")))) - -(defun elunit-run-test (name body file-name line-number) - (let* ((passed nil) - (docstring (if (stringp (car body)) (pop body) "")) - (result (condition-case err - (save-excursion (eval (cons 'progn body)) (setq passed t)) - (error err)))) - (elunit-status passed) - (if passed t - (list name docstring result body file-name line-number *elunit-fail-count*)))) - - -;;; Showing the results - -(defun elunit-status (pass) - "Output status while the tests are running" - (princ (if pass "." "F")) - (unless pass (incf *elunit-fail-count*) - (switch-to-buffer "*elunit*") - ;; This doesn't work in XEmacs. -;; (overlay-put (make-overlay (point) (- (point) 1)) 'face '(foreground-color . "red")) - (switch-to-buffer nil))) - -(defun elunit-report-results (tests) - "For when the tests are finished and we want details" - (dolist (test tests) - (unless (eq t test) - (apply 'elunit-report-result test))) - (princ (format "\n\n\n%d tests total, %d failures" (length tests) *elunit-fail-count*))) - -(defun elunit-report-result (name docstring result body file-name line-number index) - "Report a single test failure" - (princ (format "\n\n%d) Failure: %s [%s:%s] - %s - Result: %s - Form: %s" index name file-name line-number docstring result (car body)))) - -;(add-hook 'temp-buffer-show-hook 'compilation-minor-mode) -;(add-to-list 'compilation-error-regexp-alist '("\\[\\([^:]*\\):\\([0-9]+\\)" 1 2)) -;;(add-to-list 'compilation-error-regexp-alist '("\\[\\([^\]]*\\):\\([0-9]+\\)\\]" 1 2)) - -(provide 'elunit) - -;; end of file diff --git a/dvc/lisp/contrib/ewoc.el b/dvc/lisp/contrib/ewoc.el deleted file mode 100644 index 555dd05..0000000 --- a/dvc/lisp/contrib/ewoc.el +++ /dev/null @@ -1,609 +0,0 @@ -;;; ewoc.el --- utility to maintain a view of a list of objects in a buffer - -;; Copyright (C) 1991, 92, 93, 94, 95, 96, 97, 98, 99, 2000 Free Software Foundation - -;; Author: Per Cederqvist -;; 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 deleted file mode 100644 index 00b5e25..0000000 --- a/dvc/lisp/dvc-about.el +++ /dev/null @@ -1,165 +0,0 @@ -;;; dvc-about.el --- "About DVC" message - -;; Copyright (C) 2006 by all contributors - -;; This file is part of DVC. -;; -;; DVC is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; DVC is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;; Eye cather displaying about DVC - -;;; Code: - -(eval-when-compile (require 'cl)) -(require 'dvc-buffers) -(require 'dvc-version) - -;; Test cases -;; (dvc-about-message-with-bouncing -;; (concat "Author: Stefan Reichoer , " -;; "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 deleted file mode 100644 index dd05152..0000000 --- a/dvc/lisp/dvc-annotate.el +++ /dev/null @@ -1,279 +0,0 @@ -;; dvc-annotate.el -;; (Copyed from vc.el --- drive a version-control system from within Emacs) -;; - -;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 2000, -;; 2001, 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. - -;; Author: FSF (see below for full credits) -;; Maintainer: Andre Spiegel -;; 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 deleted file mode 100644 index cc28985..0000000 --- a/dvc/lisp/dvc-be.el +++ /dev/null @@ -1,70 +0,0 @@ -;;; 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 deleted file mode 100644 index 794978f..0000000 --- a/dvc/lisp/dvc-bookmarks.el +++ /dev/null @@ -1,1607 +0,0 @@ -;;; 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 "Hs" 'dvc-bookmarks-show-or-hide-subtree) - (define-key map "Ha" 'dvc-bookmarks-show-or-hide-all-subtrees) - (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 () - "Toggle subtree visibility." - (interactive) - (let ((current-tree (aref (dvc-bookmarks-current-bookmark) 1)) - (pos (point)) - parent) - (when (member (assoc current-tree dvc-bookmark-alist) - dvc-bookmark-alist) ; Check if we are really on a tree. - (if (member current-tree dvc-bookmarks-hidden-subtree) - (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)))) - (goto-char pos))) - -(defun dvc-bookmarks-show-or-hide-all-subtrees () - "Toggle visibility of all subtrees." - (interactive) - (with-current-buffer "*dvc-bookmarks*" - (goto-char (point-min)) - (save-excursion - (while (re-search-forward "^[^ ].+" nil t) - (dvc-bookmarks-show-or-hide-subtree) - (end-of-line))) - (forward-line 1))) - - -(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 deleted file mode 100644 index c474b76..0000000 --- a/dvc/lisp/dvc-buffers.el +++ /dev/null @@ -1,759 +0,0 @@ -;;; dvc-buffers.el --- Buffer management for DVC - -;; Copyright (C) 2005-2011 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 (default `default-directory'). - -Maybe reuse one if it exists, according to the value of -`dvc-buffer-type-alist' (see its docstring), or, call -`generate-new-buffer' to create the buffer. - -See also `dvc-get-buffer'" - ;; Inspired from `cvs-get-buffer-create' - ;; - ;; For 'root buffers, make sure we don't create two buffers to the - ;; same absolute path, even in the presence of symlinks. - (let ((return-buffer - (let* ((elem (assoc type dvc-buffer-type-alist)) - (mode (car (cddr elem))) - (path (if (eq mode 'root) - (dvc-tree-root (dvc-uniquify-file-name (or path default-directory) t)) - (or path default-directory)))) - - (or (dvc-get-buffer dvc type path mode) - ;; Buffer couldn't be reused. Create one - (let ((name (concat "*" (symbol-name dvc) "-" - (cadr (assoc type dvc-buffer-type-alist))))) - (let ((buffer - (if (or (eq mode 'string) - (eq mode 'string-multiple)) - (generate-new-buffer (format name path)) - (let ((default-directory - (if (file-name-directory path) - (expand-file-name (file-name-directory path)) - default-directory))) - (dvc-create-buffer name))))) - (with-current-buffer buffer - (if (featurep 'xemacs) - (dvc-install-buffer-menu)) - (dvc-buffers-tree-add dvc type path buffer) - buffer))))))) - (with-current-buffer return-buffer - ;; We do not set dvc-buffer-current-active-dvc here, because any - ;; subsequent mode function will call kill-all-local-variables. - (dvc-trace "create buffer %S with back-end %S in %S" - return-buffer dvc default-directory) - return-buffer))) - -(defun dvc-get-matching-buffers (dvc type path) - "Return the list of all dvc-buffers-tree entries matching DVC, TYPE, PATH. - -If DVC is nil, it matches any back-end. TYPE must match exactly. -PATH matches if the entry in dvc-buffers-tree is a prefix of -PATH." - (let ((result nil) - (true-path (dvc-uniquify-file-name path)) - tree) - - (if dvc - (setq tree (cdr (assoc type (cdr (assoc dvc dvc-buffers-tree))))) - ;; flatten tree to cover all back-ends - (let ((temp dvc-buffers-tree) - buffers) - (while temp - (setq buffers (cdr (assoc type (cdar temp)))) - (setq tree (append tree buffers)) - (setq temp (cdr temp))))) - - ;; Filter for path - (while tree - (let* ((root (caar tree)) - (index (string-match (regexp-quote root) true-path))) - (if (and index (= 0 index)) - (setq result (cons (car tree) result))) - (setq tree (cdr tree)))) - result)) - -(defun dvc-get-buffer (dvc type &optional path mode) - "Get a buffer of type TYPE for the path PATH. - -Maybe reuse one if it exists, depending on the value of MODE (see -`dvc-buffer-type-alist' 's third element), otherwise, return nil. See -also `dvc-get-buffer-create'." - (let ((mode (or mode (car (cddr (assoc type dvc-buffer-type-alist))))) - (path (or path default-directory)) - (subtree (cdr (assoc dvc dvc-buffers-tree)))) - (if (eq mode 'single) - ;; nothing to do about PATH. Reuse anyway - (let* ((dvc-path subtree) - (list-path (cdr (assoc type dvc-path))) - (first-elem (car list-path))) - (if list-path - (if (string= (buffer-name (cadr first-elem)) - (car (cddr first-elem))) - (cadr first-elem) - (setcdr (assoc type subtree) nil) - nil) - nil)) - ;; not 'single - (let ((path (and path - (cond - ((eq mode 'root) - (dvc-uniquify-file-name - (dvc-tree-root path))) - ((or (eq mode 'string) - (eq mode 'string-multiple)) - path) - (t (dvc-uniquify-file-name path)))))) - (if (or (eq mode 'multiple) - (eq mode 'string-multiple)) - ;; no need to search an existing buffer - nil - (let* ((list-path (assoc type subtree)) - (elem (assoc path (cdr list-path))) - (buffer (cadr elem))) - (when buffer - (if (buffer-live-p buffer) - ;; This used to check for buffer not renamed, but - ;; that conflicts with uniquify. - buffer - ;; remove the buffer and try again - (setcdr list-path - (delq (assoc path (cdr list-path)) - (cdr list-path))) - (dvc-get-buffer type path mode))))))))) - -(defun dvc-add-buffer-type (type name) - "Define a new TYPE of buffer whose buffer will be named NAME." - (unless (assoc type dvc-buffer-type-alist) - (push (list type name) dvc-buffer-type-alist))) - -;; ---------------------------------------------------------------------------- -;; Process buffers -;; ---------------------------------------------------------------------------- - -;; TODO unify with above alist. -(defcustom dvc-process-buffer " *%s-process*" - "*Name of the process buffer." - :type 'string - :group 'dvc-internal) - -(defcustom dvc-error-buffer " *%s-errors*" - "*Name of the buffer to which the process's stderr is redirected." - :type 'string - :group 'dvc-internal) - -(defcustom dvc-number-of-dead-process-buffer 0 - "*Number of process buffers to keep after process termination. -When the number of process buffers exceeds this number, the most ancient -is killed. This includes both the process buffer and the error -buffer (to which stderr is redirected). - -A nil value here means \"Never kill any process buffer\". Useful for -debugging, but this will eat the memory of your computer ;-)" - :type 'integer - :group 'dvc-internal) - -(defcustom dvc-show-internal-buffers-on-menu nil - "Toggle display of dead process buffers in the buffer menu." - :type 'boolean - :group 'dvc-internal) - -(defcustom dvc-other-frame-width 80 - "Width of frame created by `dvc-switch-to-buffer' when `other-frame' arg is non-nil." - :type 'integer - :group 'dvc) - -(defcustom dvc-other-frame-height 20 - "Height of frame created by `dvc-switch-to-buffer' when `other-frame' arg is non-nil." - :type 'integer - :group 'dvc) - -(defvar dvc-dead-process-buffer-queue nil - "List of process buffers belonging to terminated processes. -When the list is greater than `dvc-number-of-dead-process-buffer', the last -ones are killed.") - -(defun dvc-kill-process-buffer (buffer) - "Don't actually kill BUFFER, but add it to `dvc-dead-process-buffer-queue'. -It will eventually be killed when the number of buffers in -`dvc-dead-process-buffer-queue'exceeds `dvc-number-of-dead-process-buffer'." - (dvc-add-to-list 'dvc-dead-process-buffer-queue buffer t) - (when dvc-number-of-dead-process-buffer - (while (> (length dvc-dead-process-buffer-queue) - (max 2 dvc-number-of-dead-process-buffer)) - (let ((buf (car dvc-dead-process-buffer-queue))) - (when (buffer-live-p buf) (kill-buffer buf))) - (setq dvc-dead-process-buffer-queue - (cdr dvc-dead-process-buffer-queue))))) - -(defvar dvc-last-process-buffer nil - "The last created process buffer.") - -(defvar dvc-last-error-buffer nil - "The last created process buffer.") - -(defun dvc-new-process-buffer (to-be-deleted back-end) - "Create a new process buffer. -If TO-BE-DELETED is non-nil, make this buffer a candidate for eventually -being deleted." - (let ((buffer (generate-new-buffer - (format dvc-process-buffer - back-end)))) - (setq dvc-last-process-buffer buffer) - (when to-be-deleted (dvc-kill-process-buffer buffer)) - buffer)) - -(defun dvc-new-error-buffer (to-be-deleted back-end) - "Create a new error buffer. -If TO-BE-DELETED is non-nil, make this buffer a candidate for eventually -being deleted." - (let ((buffer (generate-new-buffer - (format dvc-error-buffer - back-end)))) - (setq dvc-last-error-buffer buffer) - (when to-be-deleted (dvc-kill-process-buffer buffer)) - buffer)) - -;; -;; Process buffer mode section -;; -(defvar dvc-process-buffer-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (dvc-prefix-buffer ?L) 'dvc-open-internal-log-buffer) - (define-key map dvc-keyvec-quit 'dvc-buffer-quit) - map) - "Keymap used in dvc's log buffer.") - -(define-derived-mode dvc-process-buffer-mode fundamental-mode - "DVC Process" - "Major mode for process buffers. Mainly defines \\[bury-buffer] -to quit the buffer" - (dvc-install-buffer-menu) - (toggle-read-only 1)) - - -(defvar dvc-switched-buffer nil) -(defvar dvc-switched-from-buffer nil) - -(defun dvc-switch-to-buffer (buffer &optional other-frame) - "Switch to BUFFER using the user's preferred method. -See `dvc-switch-to-buffer-mode' for possible settings." - (setq dvc-switched-from-buffer (current-buffer)) - (cond - (other-frame - (let ((display-reuse-frames t) - (pop-up-frames t) - (pop-up-frame-alist `((width . ,dvc-other-frame-width) - (height . ,dvc-other-frame-height) - (minibuffer . nil)))) - (pop-to-buffer buffer))) - ((eq dvc-switch-to-buffer-mode 'pop-to-buffer) - (pop-to-buffer buffer)) - ((eq dvc-switch-to-buffer-mode 'single-window) - (switch-to-buffer buffer)) - ((eq dvc-switch-to-buffer-mode 'show-in-other-window) - (pop-to-buffer buffer) - (setq dvc-switched-buffer (current-buffer)) - (pop-to-buffer dvc-switched-from-buffer)) - (t - (error "Switch mode %s not implemented" dvc-switch-to-buffer-mode)))) - -(defun dvc-switch-to-buffer-maybe (buffer &optional setup-as-partner) - "Either switch to buffer BUFFER or just set-buffer. -Depends on the value of `dvc-switch-to-buffer-first'. - -When SETUP-AS-PARTNER, set the `dvc-partner-buffer' variable in BUFFER to current-buffer and vice versa." - ;; (message "dvc-switch-to-buffer-maybe, curr-buff: %s switch-to: %s" (current-buffer) buffer) - (when setup-as-partner - (setq dvc-partner-buffer buffer) - (let ((cur-buff (current-buffer))) - (with-current-buffer buffer - (setq dvc-partner-buffer cur-buff)))) - (if dvc-switch-to-buffer-first - (dvc-switch-to-buffer buffer) - (set-buffer buffer))) - -(defun dvc-post-switch-to-buffer () - "Executed when showing a changeset. - -If `dvc-switched-buffer' is non-nil, show this buffer, but keep -cursor position in previous buffer." - (when dvc-switched-buffer - (pop-to-buffer dvc-switched-buffer) - (setq dvc-switched-buffer nil) - (goto-char (point-min)) - (pop-to-buffer dvc-switched-from-buffer))) - - -(defun dvc-show-process-buffer () - "Show the process buffer of the last started DVC command." - (interactive) - (dvc-switch-to-buffer dvc-last-process-buffer) - (unless (member dvc-last-process-buffer - (mapcar (lambda (p) - (process-buffer (car p))) - dvc-process-running)) - (dvc-process-buffer-mode))) - -(defun dvc-show-last-error-buffer () - "Show the error buffer of the last started DVC command." - (interactive) - (dvc-switch-to-buffer dvc-last-error-buffer) - (dvc-process-buffer-mode)) - -(defun dvc-show-last-process-buffer (&optional type mode path) - "Switch to the last used process buffer in a new buffer of TYPE. -If MODE is specified, it is a function that will be run in the -new buffer. Otherwise, the buffer will remain in fundamental mode, in -read-only. - -If PATH is specified, it will be passed to `dvc-get-buffer-create'." - (when (buffer-live-p dvc-last-process-buffer) - (let ((content (with-current-buffer dvc-last-process-buffer - (buffer-string)))) - (dvc-switch-to-buffer (dvc-get-buffer-create - 'dvc (or type 'generic) path)) - (let ((inhibit-read-only t)) - (erase-buffer) - (insert content))) - (if mode - (funcall mode) - (dvc-process-buffer-mode)))) - -(defun dvc-show-error-buffer (buffer &optional type mode) - "Pops up a new buffer displaying contents of BUFFER. -New buffer has type TYPE (default 'errors), mode MODE (default -`dvc-process-buffer-mode')." - (when (buffer-live-p buffer) - (let ((content (with-current-buffer buffer - (buffer-string)))) - (dvc-switch-to-buffer (dvc-get-buffer-create - 'dvc (or type 'errors))) - (let ((inhibit-read-only t)) - (erase-buffer) - (insert content))) - (if mode - (funcall mode) - (dvc-process-buffer-mode)))) - -;; ---------------------------------------------------------------------------- -;; Buffers menu -;; ---------------------------------------------------------------------------- -(defun dvc-buffers-menu () - "Return menus for buffers managed in DVC." - (let ((menu (make-sparse-keymap (concat "DVC-Buffers"))) - (submenu (make-sparse-keymap "Queue")) - (i dvc-number-of-dead-process-buffer)) - ;; Debug QUEUE - (mapcar - (lambda (buffer) - (when (buffer-live-p buffer) - (define-key submenu (vector (make-symbol (buffer-name buffer))) - `(menu-item ,(format "%d: %s%s" - i - (if (zerop (buffer-size buffer)) "[empty] " "") - (buffer-name buffer)) - (lambda () (interactive) (switch-to-buffer ,buffer)) - :enable t))) - (setq i (1- i))) - dvc-dead-process-buffer-queue) - (define-key menu [queue] - `(menu-item "Queue(DEBUG)" - ,submenu - :enable dvc-show-internal-buffers-on-menu)) - (mapcar - (lambda (item) - (let* ((dvc (car item)) - (type-list (cdr item)) - (dvc-label (capitalize (symbol-name dvc))) - (submenu (make-sparse-keymap dvc-label))) - (mapcar - (lambda (type-list) - (let* ((type-label - (concat dvc-label "-" - (capitalize (symbol-name (car type-list))))) - (type-submenu (make-sparse-keymap type-label))) - (mapcar - (lambda (subitem) - (let ((path (car subitem)) - (buffer (cadr subitem))) - (when (buffer-live-p buffer) - (unless path - (setq path (buffer-name buffer))) - (define-key type-submenu (vector (make-symbol path)) - `(menu-item ,path - (lambda () (interactive) - (switch-to-buffer ,buffer)) - :enable t))))) - (cdr type-list)) - (define-key submenu (vector (car type-list)) - `(menu-item ,type-label - ,type-submenu - :enable t)))) - type-list) - (when type-list - (define-key menu (vector dvc) - `(menu-item ,dvc-label - ,submenu - :enable t)) - ))) - dvc-buffers-tree) - (define-key menu [list-separator] - '(menu-item "--")) - (define-key menu [process-buffer] - '(menu-item "Show Process Bufffer" dvc-show-process-buffer)) - (define-key menu [error-buffer] - '(menu-item "Show Error Bufffer" dvc-show-last-error-buffer)) - (define-key menu [log-buffer] - '(menu-item "Open Log Bufffer" dvc-open-internal-log-buffer)) - menu)) - -(eval-when-compile - (unless (functionp 'add-submenu) - (defun add-submenu (&rest arg) - "Avoids a byte-compiler warning for GNU Emacs"))) - -(defun dvc-install-buffer-menu () - "Install the buffer menu." - (if (featurep 'xemacs) - ;; See dvc-xemacs-buffers-menu in dvc-xemacs.el - (dvc-do-in-xemacs - (add-submenu nil (list "DVC-Buffers" - :filter 'dvc-xemacs-buffers-menu) nil)) - ;; GNU Emacs - (dvc-do-in-gnu-emacs - (let ((dvc-menu (or (lookup-key global-map [menu-bar tools dvc]) - (lookup-key global-map [menu-bar tools DVC])))) - (when (and dvc-menu (not (integerp dvc-menu))) - (define-key-after - dvc-menu - [dvc-buffers] - (cons "DVC-Buffers" - (dvc-buffers-menu))))) - (let ((map (and - (current-local-map) - (or (lookup-key (current-local-map) [menu-bar]) - (define-key (current-local-map) [menu-bar] - (make-keymap)))))) - (when map - (apply (if (functionp 'define-key-after) - 'define-key-after - 'define-key) - map - [dvc-buffers] - (cons "DVC-Buffers" - (dvc-buffers-menu)) - nil))) - (add-hook 'menu-bar-update-hook 'dvc-install-buffer-menu nil t)))) - -(defvar dvc-buffer-previous-window-config nil - "Window-configuration to return to on buffer quit. - -If nil, nothing is done special. Otherwise, must be a -window-configuration. `dvc-buffer-quit' will restore this -window-configuration.") - -(make-variable-buffer-local 'dvc-buffer-previous-window-config) - -;; TODO: eventually implement dvc-buffer-previous-window-config as list -;; That does not work at the moment, because it is buffer local. -;; I (Stefan) will play a bit with a global list -(defun dvc-buffer-push-previous-window-config (&optional window-config) - "Store WINDOW-CONFIG in `dvc-buffer-previous-window-config'. -When WINDOW-CONFIG is nil, store `current-window-configuration' instead." - (setq dvc-buffer-previous-window-config (or window-config (current-window-configuration)))) - -(defun dvc-buffer-quit () - "Quit the current buffer. - -If `dvc-buffer-quit-mode' is 'kill, then kill the buffer. Otherwise, -just bury it." - (interactive) - ;; Value is buffer local => keep it before killing the buffer! - (let ((prev-wind-conf dvc-buffer-previous-window-config)) - (if (eq dvc-buffer-quit-mode 'kill) - (kill-buffer (current-buffer)) - (bury-buffer)) - (when prev-wind-conf - (set-window-configuration prev-wind-conf)))) - -(defun dvc-kill-all-buffers () - "Kill all dvc buffers." - (interactive) - (let ((number 0)) - (dolist (dvc-kind dvc-buffers-tree) - (dolist (type-cons (cdr dvc-kind)) - (dolist (path-buffer (cdr type-cons)) - (setq number (1+ number)) - (kill-buffer (cadr path-buffer))))) - (message "Killed %d buffer%s" number - (if (> number 1) "s" ""))) - (setq dvc-buffers-tree nil)) - -(defun dvc-kill-all-type (type) - "Kill all buffers of type TYPE." - (let ((number 0)) - (dolist (dvc-kind dvc-buffers-tree) - (dolist (type-cons (cdr dvc-kind)) - (if (equal type (car type-cons)) - (dolist (path-buffer (cdr type-cons)) - (setq number (1+ number)) - (kill-buffer (cadr path-buffer)))))) - (message "Killed %d buffer%s" number - (if (> number 1) "s" "")))) - -(defun dvc-kill-all-review () - "Kill all buffers used in reviews; showing previous revisions." - (interactive) - (dvc-kill-all-type 'revision) - (dvc-kill-all-type 'last-revision)) - -(defun dvc-kill-all-workspace (workspace) - "Kill all buffers whose files are in the WORKSPACE tree." - (interactive "Dkill buffers in workspace: ") - (let ((workspace (expand-file-name workspace)) - (count 0)) - (dolist (buffer (buffer-list)) - (let ((file-name (buffer-file-name buffer))) - (and file-name ;; some buffers don't have a file name - (string= workspace (substring file-name 0 (min (length file-name) (length workspace)))) - (kill-buffer buffer) - (setq count (+ 1 count))))) - (message "killed %d buffers" count))) - -(defvar dvc-save-some-buffers-ignored-modes '(dvc-log-edit-mode)) -(defun dvc-save-some-buffers (&optional tree) - "Save all buffers visiting a file in TREE." - (interactive) - (let ((ok t) - (tree (or (dvc-tree-root tree t) - tree))) - (unless tree - (error "Not in a project tree")) - (dolist (buffer (buffer-list)) - (with-current-buffer buffer - (when (and (buffer-modified-p) (not (member major-mode dvc-save-some-buffers-ignored-modes))) - (let ((file (buffer-file-name))) - (when file - (let ((root (dvc-uniquify-file-name - (dvc-tree-root (file-name-directory file) t))) - (tree-exp (dvc-uniquify-file-name tree))) - (when (and root - (string= root tree-exp) - ;; buffer is modified and in the tree TREE. - (or dvc-do-not-prompt-for-save - (y-or-n-p (concat "Save buffer " - (buffer-name) - "? ")) - (setq ok nil))) - (save-buffer)))))))) - ok)) - -(defun dvc-revert-some-buffers (&optional tree) - "Reverts all buffers visiting a file in TREE that aren't modified. -To be run after an update or a merge." - (interactive) - (let ((tree (dvc-tree-root tree))) - (dolist (buffer (buffer-list)) - (with-current-buffer buffer - (when (not (buffer-modified-p)) - (let ((file (buffer-file-name))) - (when file - (let ((root (dvc-uniquify-file-name - (dvc-tree-root (file-name-directory file) t))) - (tree-exp (dvc-uniquify-file-name - (expand-file-name tree)))) - (when (and (string= root tree-exp) - ;; buffer is not modified and in the tree TREE. - dvc-automatically-revert-buffers) - ;; Keep the buffer if the file doesn't exist - (if (file-exists-p file) - (revert-buffer t t t))))))))))) - -(defun dvc-buffer-visible-p (buffer) - "Return non-nil if BUFFER is visible in frame." - (save-window-excursion - (let ((buf (current-buffer)) - (window-conf (current-window-configuration))) - (pop-to-buffer buffer) - (pop-to-buffer buf) - (dvc-do-in-xemacs - (and (setq window-conf (get-buffer-window buffer)) - window-conf ;; we use window-conf only to get rid of warnings - (equal (window-frame (get-buffer-window buffer)) - (selected-frame)))) - (dvc-do-in-gnu-emacs - (compare-window-configurations window-conf - (current-window-configuration)))))) - -(defun dvc-buffer-show-or-scroll (buffer &optional down) - "If BUFFER is visible, scroll it. Otherwise, show it. - -if DOWN is non-nil, scroll down, otherwise, scroll up." - (if (dvc-buffer-visible-p buffer) - (progn - (pop-to-buffer buffer) - (condition-case nil - (if down - (scroll-down 2) - (save-excursion - (move-to-window-line -1) - (if (> (point-max) (point)) - (scroll-up 2) - (message "end of buffer")))) - (error (message "Can't scroll anymore.")) - )) - (dvc-switch-to-buffer buffer))) - -(provide 'dvc-buffers) -;;; dvc-buffers.el ends here diff --git a/dvc/lisp/dvc-bug.el b/dvc/lisp/dvc-bug.el deleted file mode 100644 index 6853250..0000000 --- a/dvc/lisp/dvc-bug.el +++ /dev/null @@ -1,87 +0,0 @@ -;;; dvc-bug.el --- Reporting bugs to Xtla-el-dev list - -;; Copyright (C) 2006-2007 by all contributors - -;; This file is part of DVC. -;; -;; DVC is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; DVC is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;;; Code: -(require 'dvc-version) -(require 'dvc-register) - -;;;###autoload -(defun dvc-submit-bug-report () - "Submit a bug report, with pertinent information to the dvc-dev list." - (interactive) - (require 'reporter) - (delete-other-windows) - ;; (dvc-version) - (dvc-command-version) - (reporter-submit-bug-report - "dvc-dev@gna.org" - (concat "Dvc " dvc-version) - (append - ;; non user variables - '(emacs-version - dvc-version - dvc-command-version - ) - ;; user variables - (sort (apropos-internal (concat "^\\(" - (mapconcat (lambda (name) - (concat (regexp-quote (symbol-name name)) "-")) - dvc-registered-backends - "\\|") - "\\)") - 'user-variable-p) - (lambda (v1 v2) (string-lessp (format "%s" v1) (format "%s" v2)))) - ;; see what the user had loaded - (list 'features) - ) - nil - nil - (concat - "Please change the Subject header to a concise bug description or feature request.\n" - "In this report, remember to cover the basics, that is, what you \n" - "expected to happen and what in fact did happen.\n" - "Please remove these instructions from your message.")) - ;; insert the backtrace buffer content if present - (let ((backtrace (get-buffer "*Backtrace*"))) - (when backtrace - (goto-char (point-max)) - (insert "\n\n") - (insert-buffer-substring backtrace))) - - (goto-char (point-min)) - (mail-position-on-field "Subject") - (insert "[BUG/FEATURE] ")) - -;; For people used to Debian's reportbug -(defalias 'dvc-report-bug 'vc-submit-bug-report) -;; For people used to Gnus M-x gnus-bug RET -(defalias 'dvc-bug 'dvc-submit-bug-report) -;; (reporting bugs should be easy ;-) - - -(provide 'dvc-bug) - -;; Local Variables: -;; End: - -;;; dvc-bug.el ends here diff --git a/dvc/lisp/dvc-build.el b/dvc/lisp/dvc-build.el deleted file mode 100644 index bd04723..0000000 --- a/dvc/lisp/dvc-build.el +++ /dev/null @@ -1,414 +0,0 @@ -;;; 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) - ;; Prevent "changed on disk query" - (if (not (null (find-buffer-visiting --autoloads-filename))) - (kill-buffer (find-buffer-visiting --autoloads-filename))) - (let ((blurb ";;; DVC PRELOAD\n")) - (unless (save-excursion - ;; The preload forms are not guaranteed to be at beginning - ;; of buffer; they might be prefixed by cus-load munging. - ;; So search for them. (Previously, we used `looking-at'.) - (search-forward blurb nil t)) - (insert blurb) - (dolist (form '((require 'dvc-core) - (eval-when-compile - (require 'dvc-unified) - (require 'dvc-utils)))) - (pp form (current-buffer)))))) - - ;; Merge custom load and autoloads for GNU Emacs and compile the result. - (let ((tail-blurb (concat "\n\n" - "(provide 'dvc-autoloads)\n\n" - ";;; Local Variables:\n" - ";;; version-control: never\n" - ";;; no-update-autoloads: t\n" - ";;; End:\n" - ";;; dvc-autoloads.el ends here\n"))) - (when (or (not (file-exists-p --autoloads-filename)) - changed) - (unless (featurep 'xemacs) - (message "Merging %s into %s ..." - --custom-autoloads-filename - --autoloads-filename) - (with-temp-file --autoloads-filename - (insert-file-contents --custom-autoloads-filename) - (delete-file --custom-autoloads-filename) - (search-forward ";;; Code:\n") - (delete-region (point-min) (point)) - (insert ";;; dvc-autoloads.el\n\n" - ";;; Code:\n") - (goto-char (point-max)) - ;; ??? What do we have against this innocent var? --ttn - (when (search-backward "custom-versions-load-alist" nil t) - (forward-line -1)) - (delete-region (point) (point-max)) - (insert-file-contents --autoloads-filename) - (goto-char (point-max)) - (when (search-backward "\n(provide " nil t) - (delete-region (1- (point)) (point-max))) - (insert tail-blurb))) - (message "Compiling %s..." --autoloads-filename) - (byte-compile-file --autoloads-filename) - (when (featurep 'xemacs) - (message (concat "Creating dummy dvc-autoloads.el...")) - (with-temp-file "dvc-autoloads.el" - (insert tail-blurb))))) - - ;; Compile `--to-compile' files. - (when changed - (dolist (file --to-compile) - (load (srcdir/ file) nil nil t)) - ;; We compute full fanout, not just root-set one-level-downstream. - ;; In this way we err on the safe side. - (let (todo) - (while changed - (nconc changed (f-set-difference - (f-intersection - (mapcar 'file-name-nondirectory - (file-dependents - (srcdir/ (car changed)))) - --to-compile) - todo)) - (pushnew (pop changed) todo :test 'string=)) - (mapc 'zonk-file (mapcar 'byte-compile-dest-file todo)) - (mapc 'byte-compile-file (mapcar 'srcdir/ todo))))) - - ;; All done. TODO: Summarize. - (bye-bye)) - -;;; dvc-build.el ends here diff --git a/dvc/lisp/dvc-cmenu.el b/dvc/lisp/dvc-cmenu.el deleted file mode 100644 index 96ade46..0000000 --- a/dvc/lisp/dvc-cmenu.el +++ /dev/null @@ -1,121 +0,0 @@ -;;; dvc-cmenu.el --- code implementing a context menu with keyboard - -;; Copyright (C) 2006 by all contributors - -;; This file is part of DVC. -;; -;; DVC is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; DVC is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;; Generally context menu is supported only mouse pressing(or clicking). -;; In Xtla, I proposed a context menu supporting operation by keyboard: -;; an user can type C-j to pop the context menu under the point up. -;; I think it is quite useful, so I decide to separate the code from -;; xtla.el. -;; In addition dvc-cmenu supports target item highlighting during popup. -;; So during popup, a user can recognize the context of menu popup now. - -;;; Code: -(eval-when-compile (require 'dvc-utils)) - -(defvar dvc-cmenu 'dvc-cmenu - "Name of property for embedding a context menu to text.") - -(defun dvc-cmenu-beginning (point) - "Search backward the position where `dvc-cmenu' property is changed." - (previous-single-property-change point dvc-cmenu)) - -(defun dvc-cmenu-end (point) - "Search forward the position where `dvc-cmenu' property is changed." - (next-single-property-change point dvc-cmenu)) - -(defun dvc-cmenu-popup-by-mouse (event prefix) - "Generic function to popup a menu. - -The menu is defined in the text property under the point which is -given by mouse. EVENT is the mouse event that called the function. -PREFIX is passed to `dvc-cmenu-popup'." - (interactive "e\nP") - (mouse-set-point event) - (dvc-cmenu-popup prefix)) - -;; Copied from avoid.el. -(defun dvc-cmenu-mouse-avoidance-point-position (point) - "Return the position of POINT as (FRAME X . Y). -Analogous to `mouse-position'. Copied from avoid.el." - (dvc-do-in-gnu-emacs - (let* ((w (selected-window)) - (edges (window-edges w)) - (list - (compute-motion (max (window-start w) (point-min)) ; start pos - ;; window-start can be < point-min if the - ;; latter has changed since the last redisplay - '(0 . 0) ; start XY - point ; stop pos - (cons (window-width) (window-height)) ; stop XY: none - (1- (window-width)) ; width - (cons (window-hscroll w) 0) ; 0 may not be right? - (selected-window)))) - ;; compute-motion returns (pos HPOS VPOS prevhpos contin) - ;; we want: (frame hpos . vpos) - (cons (selected-frame) - (cons (+ (car edges) (car (cdr list))) - (+ (car (cdr edges)) (car (cdr (cdr list))))))))) - -(defun dvc-cmenu-popup (prefix) - "Popup a menu defined in the text property under the point. - -PREFIX is passed to `popup-menu'." - (interactive "P") - (if (get-text-property (point) dvc-cmenu) - (let* ((menu (get-text-property (point) dvc-cmenu)) - (p (previous-single-property-change (point) dvc-cmenu nil - (line-beginning-position))) - (n (next-single-property-change (point) dvc-cmenu nil - (line-end-position))) - (b (if (and p (get-text-property p dvc-cmenu)) p (point))) - (e (if n n (point)))) - (if (and (not (featurep 'xemacs)) (interactive-p)) - (let* ((pos (dvc-cmenu-mouse-avoidance-point-position e)) - (object (car pos)) - (x (cadr pos)) - (y (cddr pos))) - (set-mouse-position object x y))) - (dvc-cmenu-popup-with-highlight 'dvc-highlight - b e - menu - prefix)) - (error "No context-menu under the point"))) - -(defun dvc-cmenu-popup-with-highlight (face begin end menu &optional prefix) - "Put FACE on BEGIN and END in the buffer during Popup MENU. -PREFIX is passed to `popup-menu'." - (let (o) - (unwind-protect - (progn - (setq o (make-overlay begin end)) - (overlay-put o 'face face) - (sit-for 0) - (popup-menu menu prefix)) - (delete-overlay o)))) - -(provide 'dvc-cmenu) - -;; Local Variables: -;; End: - -;;; dvc-cmenu.el ends here diff --git a/dvc/lisp/dvc-config.el b/dvc/lisp/dvc-config.el deleted file mode 100644 index af02de3..0000000 --- a/dvc/lisp/dvc-config.el +++ /dev/null @@ -1,54 +0,0 @@ -;;; dvc-config.el --- dvc configuration directory - -;; Copyright (C) 2006 by all contributors - -;; This file is part of DVC. -;; -;; DVC is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; DVC is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;;; Code: -(require 'dvc-utils) -(require 'dvc-defs) - -(defcustom dvc-config-directory "~/.dvc/" - "*Directory in which the DVC config files will be stored." - :type 'directory - :group 'dvc) - -(defun dvc-config-file-full-path (file &optional create-config-dir) - "Return the full path for the config file FILE. -FILE will be stored in the `dvc-config-directory'. -If CREATE-CONFIG-DIR is non nil, ensure that the `dvc-config-directory' -does exist." - (let ((full-name (dvc-uniquify-file-name - (concat dvc-config-directory file)))) - (unless (file-exists-p dvc-config-directory) - (when create-config-dir - (make-directory dvc-config-directory t) - (message "The config files of DVC will be stored in %s!" - dvc-config-directory) - (sit-for 5))) - ;; return full-name - full-name)) - -(provide 'dvc-config) - -;; Local Variables: -;; End: - -;;; dvc-config.el ends here diff --git a/dvc/lisp/dvc-core.el b/dvc/lisp/dvc-core.el deleted file mode 100644 index a13032c..0000000 --- a/dvc/lisp/dvc-core.el +++ /dev/null @@ -1,1208 +0,0 @@ -;;; dvc-core.el --- Core functions for distributed version control - -;; Copyright (C) 2005-2010 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, `default-directory' is used instead. - -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* ((name (dvc-variable dvc "executable")) - (executable (executable-find name))) - ;; 'executable-find' allows leading ~ - (if (not executable) - (error "executable %s for %s not found" name (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 deleted file mode 100644 index c10edd6..0000000 --- a/dvc/lisp/dvc-defs.el +++ /dev/null @@ -1,630 +0,0 @@ -;;; 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 deleted file mode 100644 index 656d1fd..0000000 --- a/dvc/lisp/dvc-diff.el +++ /dev/null @@ -1,898 +0,0 @@ -;;; dvc-diff.el --- A generic diff mode for DVC - -;; Copyright (C) 2005-2010 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 ((modified-file (dvc-get-file-info-at-point)) - (loc (point))) - - (if (and modified-file - (dvc-diff-in-ewoc-p)) - ;; on ewoc item; just ediff - (dvc-file-ediff-revisions modified-file - dvc-diff-base - dvc-diff-modified - (dvc-fileinfo-base-file)) - - ;; in diff section; find hunk index, so we can jump to it in the ediff. - (end-of-line) - (dvc-trace "loc=%S" loc) - (let ((hunk 1)) - (re-search-backward "^--- ") - (re-search-forward "^--- ") - (diff-hunk-next) - (while (<= (re-search-forward "\\(^[\\+-].*\n\\)+" nil t) loc) - (dvc-trace "hunk=%S" hunk) - (setq hunk (1+ hunk))) - (goto-char loc) - (with-current-buffer - (dvc-file-ediff-revisions modified-file - dvc-diff-base - dvc-diff-modified) - (ediff-jump-to-difference hunk)))))) - -(defun dvc-diff-log-single (&optional last-n) - "Show log for current file, LAST-N entries. (default -`dvc-log-last-n'; all if nil). LAST-N may be specified -interactively." - (interactive (list (if current-prefix-arg (prefix-numeric-value current-prefix-arg) dvc-log-last-n))) - (dvc-log (dvc-get-file-info-at-point) last-n)) - -(defun dvc-diff-log-tree (&optional last-n) - "Show log for current tree, LAST-N entries (default -`dvc-log-last-n'; all if nil). LAST-N may be specified -interactively." - (interactive (list (if current-prefix-arg (prefix-numeric-value current-prefix-arg) dvc-log-last-n))) - (dvc-log nil last-n)) - -(defun dvc-diff-find-file-name () - "Same as `diff-find-file-name', but works in more cases." - (cond ((re-search-backward "^\\+\\+\\+ \\(mod/\\|b/\\|new-[^/\n]+/\\)?\\([^\n]*?\\)\\([ \t].*\\)?$" nil t) - (match-string-no-properties 2)) - ((not (ewoc-locate dvc-fileinfo-ewoc (point))) ;; the buffer contains no diff - "") - (t - (diff-find-file-name)))) - -(defun dvc-diff-get-file-at-point () - "Return filename for file at point. -Throw an error when not on a file. If file is renamed, this is -the modified name." - (if (dvc-diff-in-ewoc-p) - (dvc-fileinfo-current-file) - (save-excursion - (expand-file-name (concat (file-name-as-directory - default-directory) - (dvc-diff-find-file-name)))))) - -(defun dvc-diff-add-log-entry (&optional other-frame) - "Add a log entry for file or diff hunk at point." - (interactive "P") - (if (dvc-diff-in-ewoc-p) - (dvc-fileinfo-add-log-entry other-frame) - (dvc-add-log-entry other-frame))) - -(defvar dvc-header nil - "Free variable used to pass info from the parser to -`dvc-show-changes-buffer' (defined with a (let ...) in -dvc-show-changes-buffer, and altered by called functions). - -This is just a lint trap.") - -(defun dvc-show-changes-buffer (buffer parser &optional - output-buffer no-switch - header-end-regexp cmd) - "Show the *{dvc}-diff* buffer built from the *{dvc}-process* BUFFER. -default-directory of process buffer must be a tree root. - -PARSER is a function to parse the diff and fill in the -dvc-fileinfo-ewoc list; it will be called with one arg, -OUTPUT-BUFFER. Data to be parsed will be in current buffer. -dvc-header will have been set as described below. After PARSER is -called, dvc-header is set as the dvc-fileinfo-ewoc header, and -OUTPUT-BUFFER contents are set as the dvc-fileinfo-ewoc footer. - -Display changes in OUTPUT-BUFFER (must be non-nil; create with -dvc-prepare-changes-buffer). - -If NO-SWITCH is nil, don't switch to the created buffer. - -If non-nil, HEADER-END-REGEXP is a regexp matching the first line -which is not part of the diff header. Lines preceding -HEADER-END-REGEXP are copied into dvc-header. - -CMD, if non-nil, is prepended to dvc-header." - ;; We assume default-directory is correct, rather than calling - ;; dvc-tree-root, because dvc-tree-root might prompt if there is - ;; more than one back-end present. Similarly, we assume - ;; output-buffer is created, to avoid calling dvc-current-active-dvc - ;; for dvc-get-buffer-create. - (let* ((root (with-current-buffer buffer default-directory)) - (dvc (dvc-current-active-dvc)) - (changes-buffer output-buffer) - (dvc-header "")) - (if (or no-switch dvc-switch-to-buffer-first) - (set-buffer changes-buffer) - (dvc-switch-to-buffer changes-buffer)) - (let (buffer-read-only) - (dvc-fileinfo-delete-messages) - (with-current-buffer buffer - (goto-char (point-min)) - (when cmd - (setq dvc-header - (concat (dvc-face-add cmd 'dvc-header) "\n" - (dvc-face-add (make-string 72 ?\ ) 'dvc-separator)))) - (when header-end-regexp - (setq dvc-header - (concat dvc-header - (buffer-substring-no-properties - (goto-char (point-min)) - (progn (re-search-forward header-end-regexp nil t) ;; "^[^*\\.]" - (beginning-of-line) - (point)))))) - (beginning-of-line) - (funcall parser changes-buffer) - ;; Footer is back-end output from point to end-of-buffer; should be the diff output. - (let ((footer (concat - (dvc-face-add (make-string 72 ?\ ) 'dvc-separator) - "\n\n" - (buffer-substring-no-properties - (point) (point-max))))) - (with-current-buffer changes-buffer - (ewoc-set-hf dvc-fileinfo-ewoc dvc-header footer) - (if root (cd root))))))) - (setq buffer-read-only t) - (if (progn (goto-char (point-min)) - (re-search-forward "^---" nil t)) - (when (or global-font-lock-mode font-lock-mode) - (let ((font-lock-verbose nil)) - (font-lock-fontify-buffer))) - ;; Disabling font-lock mode (it's useless and it removes other - ;; faces with Emacs 21) - (setq font-lock-keywords nil) - (font-lock-mode -1) - (ewoc-refresh dvc-fileinfo-ewoc)) - (if (ewoc-nth dvc-fileinfo-ewoc 0) - (goto-char (ewoc-location (ewoc-nth dvc-fileinfo-ewoc 0))))) - -(defun dvc-diff-no-changes (diff-buffer msg dir) - "Function to call from diff parser when there are no changes in a tree. - -Inserts a message in the changes buffer, and in the minibuffer. - -DIFF-BUFFER is the buffer prepared by dvc-prepare-changes-buffer. -MSG is a format string for a message to the user. -DIR is a string, passed to `format' with MSG." - (with-current-buffer diff-buffer - (let ((inhibit-read-only t)) - (dvc-fileinfo-delete-messages) - (ewoc-enter-last dvc-fileinfo-ewoc - (make-dvc-fileinfo-message - :text (concat "* " (format msg dir) ".\n\n"))) - (ewoc-refresh dvc-fileinfo-ewoc) - (recenter '(4)))) - (message msg dir)) - -(defun dvc-diff-error-in-process (diff-buffer msg output error) - "Enter a message in DIFF-BUFFER (created by -dvc-prepare-changes-buffer), consisting of MSG and the contents of -OUTPUT and ERROR. Should be called by the error handler in the -diff parser." - (with-current-buffer diff-buffer - (let ((inhibit-read-only t)) - (dvc-fileinfo-delete-messages) - (ewoc-enter-last dvc-fileinfo-ewoc - (make-dvc-fileinfo-message - :text (concat "* " msg ":\n" - (dvc-buffer-content output) - (dvc-buffer-content error)))) - (ewoc-refresh dvc-fileinfo-ewoc) - (recenter))) - (message msg)) - -(defun dvc-diff-clear-buffers (dvc root msg &optional header) - "Clears all DVC diff and status buffers with root ROOT, insert MSG and optional HEADER. -Useful to clear diff buffers after a commit." - (dvc-trace "dvc-diff-clear-buffers (%S %S)" root msg) - ;; Don't need to clear 'revision-diff; that is not changed by a commit - (dolist (buffer (list (dvc-get-buffer dvc 'diff root) - (dvc-get-buffer dvc 'status root))) - (when buffer - (dvc-trace "buffer=%S" buffer) - (with-current-buffer buffer - (let ((inhibit-read-only t)) - (ewoc-filter - dvc-fileinfo-ewoc - (lambda (fileinfo) - (and (dvc-fileinfo-legacy-p fileinfo) - (eq (car (dvc-fileinfo-legacy-data fileinfo)) 'subtree)))) - (if header - (ewoc-set-hf dvc-fileinfo-ewoc header "") - (ewoc-set-hf dvc-fileinfo-ewoc "" "")) - (ewoc-enter-first dvc-fileinfo-ewoc (make-dvc-fileinfo-message :text msg)) - (ewoc-refresh dvc-fileinfo-ewoc)))))) - -(defun dvc-diff-dtrt (prefix) - "Do The Right Thing in a dvc-diff buffer." - (interactive "P") - - (let* ((marked-elems (dvc-fileinfo-marked-elems)) - (length-marked-elems (length marked-elems)) - (fileinfo - (if (< 1 length-marked-elems) - (ewoc-data (car marked-elems)) - (save-excursion - (unless (dvc-diff-in-ewoc-p) (dvc-diff-diff-or-list)) - (dvc-fileinfo-current-fileinfo)))) - (status (dvc-fileinfo-file-status fileinfo))) - - (ecase status - (added - (if (< 1 length-marked-elems) - (error "cannot Do The Right Thing on more than one 'added' file")) - (dvc-fileinfo-add-log-entry-1 fileinfo prefix)) - - (deleted - ;; typically nothing to do; just need commit - (ding) - (dvc-fileinfo-next)) - - (missing - ;; File is in database, but not in workspace - (cond - ((dvc-fileinfo-rename-possible marked-elems) - (dvc-fileinfo-rename)) - - (t - (dvc-fileinfo-same-status marked-elems) - (ding) - (dvc-offer-choices (concat (dvc-fileinfo-current-file) " does not exist in working directory") - '((dvc-fileinfo-revert-files "revert") - (dvc-fileinfo-remove-files "remove") - (dvc-fileinfo-rename "rename")))))) - - (modified - ;; Don't offer undo here; not a common action - (if (dvc-diff-in-ewoc-p) - (if (< 1 length-marked-elems) - (error "cannot ediff more than one file") - (dvc-diff-ediff)) - (if (< 1 length-marked-elems) - (error "cannot add a log entry for more than one file") - (dvc-diff-add-log-entry)))) - - ((copy-source copy-target rename-source rename-target) - ;; typically nothing to do; just need commit - (ding) - (dvc-fileinfo-next)) - - (unknown - (cond - ((dvc-fileinfo-rename-possible marked-elems) - (dvc-fileinfo-rename)) - - (t - (dvc-fileinfo-same-status marked-elems) - (dvc-offer-choices nil - '((dvc-fileinfo-add-files "add") - (dvc-fileinfo-ignore-files "ignore") - (dvc-fileinfo-remove-files "remove") - (dvc-fileinfo-rename "rename")))))) - ))) - -;;;###autoload -(defun dvc-file-ediff (file) - "Run ediff of FILE (default current buffer file) against last revision." - (interactive (list (buffer-file-name))) - ;; Setting `enable-local-variables' nil here is something of a - ;; trade-off. In some buffers (Makefiles), the local variables may - ;; include expressions that parse project files, which can take a - ;; long time and confuse Emacs, so we don't want to process them. On - ;; the other hand, they may set fontification style, which we do - ;; want in ediff. The only general solution is to define a subset of - ;; local variables that are desireable for ediff; we can't do that - ;; just in DVC. - (let ((enable-local-variables nil)) - (let ((file-buffer (find-file-noselect file)) - (pristine-buffer - (dvc-revision-get-file-in-buffer - file `(,(dvc-current-active-dvc) - (last-revision - ,(dvc-tree-root file t) - 1))))) - (with-current-buffer pristine-buffer - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (let ((buffer-file-name file)) - (set-auto-mode t))) - (dvc-ediff-buffers pristine-buffer file-buffer)))) - -(defun dvc-file-ediff-revisions (file base-rev modified-rev &optional base-file) - "View changes in FILE between BASE-REV and MODIFIED-REV using ediff. -Optional BASE-FILE is filename in BASE-REV if different from FILE." - (dvc-ediff-buffers - (dvc-revision-get-file-in-buffer (or base-file file) base-rev) - (dvc-revision-get-file-in-buffer file modified-rev))) - -;;;###autoload -(defun dvc-dvc-file-diff (file &optional base modified dont-switch) - "Default for back-end-specific file diff. View changes in FILE -between BASE (default last-revision) and MODIFIED (default -workspace version)." - (let* ((dvc (or (car base) (dvc-current-active-dvc))) - (base (or base `(,dvc (last-revision ,file 1)))) - (modified (or modified `(,dvc (local-tree ,file)))) - (diff-buffer (dvc-prepare-changes-buffer - base - modified - 'file-diff file dvc)) - (base-buffer - (dvc-revision-get-file-in-buffer file base)) - (modified-buffer - (dvc-revision-get-file-in-buffer file modified)) - (base-file (make-temp-file "DVC-file-diff-base")) - (modified-file (make-temp-file "DVC-file-diff-mod"))) - (with-temp-file base-file - (insert (with-current-buffer base-buffer (buffer-string))) - (setq buffer-file-coding-system (with-current-buffer base-buffer - buffer-file-coding-system))) - (with-temp-file modified-file - (insert (with-current-buffer modified-buffer (buffer-string))) - (setq buffer-file-coding-system (with-current-buffer modified-buffer - buffer-file-coding-system))) - (dvc-switch-to-buffer diff-buffer) - (let ((inhibit-read-only t) - (slash (unless (file-name-absolute-p file) "/"))) - (erase-buffer) - (call-process dvc-diff-executable nil diff-buffer nil - "-u" - ;; FIXME: If the file has been renamed between - ;; BASE and MODIFIED, the file names as - ;; displayed here may be incorrect. The - ;; protocol needs to be extended to allow the - ;; backend to supply the correct file names. - (concat "-La" slash file) - (concat "-Lb" slash file) - base-file modified-file)) - (delete-file base-file) - (delete-file modified-file) - (message "") - (goto-char (point-min)) - (setq buffer-read-only t))) - -(defun dvc-ediff-startup-hook () - "Passed as a startup hook for ediff. - -Programs ediff to return to the current window configuration after -quitting." - ;; ediff-after-quit-hook-internal is local to an ediff session. - (add-hook 'ediff-after-quit-hook-internal - (dvc-capturing-lambda () - (set-window-configuration (capture dvc-window-config))) - nil 'local) - - ;; Set dvc-buffer-current-active-dvc for dvc-ediff-add-log-entry. - ;; When this hook is called, current buffer is the ediff control - ;; buffer, default-directory is the tree root. - (setq dvc-buffer-current-active-dvc (dvc-current-active-dvc))) - -(defvar dvc-window-config nil - "Keep byte-compiler happy; declare let-bound variable used by dvc-ediff-startup-hook.") - -(defun dvc-ediff-buffers (bufferA bufferB) - "Wrapper around `ediff-buffers'. - -Calls `ediff-buffers' on BUFFERA and BUFFERB." - (let ((dvc-window-config (current-window-configuration)) - (dvc-temp-current-active-dvc (dvc-current-active-dvc))) - (ediff-buffers bufferA bufferB - '(dvc-ediff-startup-hook) 'dvc-ediff))) - -(provide 'dvc-diff) -;;; dvc-diff.el ends here diff --git a/dvc/lisp/dvc-emacs.el b/dvc/lisp/dvc-emacs.el deleted file mode 100644 index 5d407cd..0000000 --- a/dvc/lisp/dvc-emacs.el +++ /dev/null @@ -1,186 +0,0 @@ -;;; dvc-emacs.el --- Compatibility stuff for old versions of GNU Emacs -;;; and for XEmacs. -;;; -;;; This file should be loaded when using Gnu Emacs; load -;;; dvc-xemacs.el when using XEmacs. - -;; Copyright (C) 2004, 2007 - 2008 by all contributors - -;; This file is part of DVC. -;; -;; DVC is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; DVC is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Policy: -;; -;; The DVC baseline environment is the current release of Gnu Emacs. -;; However, we also support at least one previous release of Gnu -;; Emacs, and the current release of XEmacs. -;; -;; There is current Gnu Emacs code used in DVC that is not present in -;; XEmacs or previous releases of Gnu Emacs. -;; -;; This file provides versions of that code that work with previous -;; versions of Gnu Emacs. dvc-xemacs.el provides versions of that code -;; that work with XEmacs. -;; -;; There are also functions in Gnu Emacs code used in DVC that have -;; different names in XEmacs. This file and dvc-xemacs.el provide -;; common names for those functions. -;; -;; There may also be functions in Gnu Emacs that have the same name as -;; functions in XEmacs, in which case this file provides a common name -;; to sort things out. -;; -;; In all cases, the code provided here should use names prefixed with -;; `dvc-'. This is to allow for the possibility that other packages -;; also provide the same function, but the code is broken in some way. -;; Our version will work with DVC; theirs will work with their -;; package. DVC code must use the dvc- prefixed name. -;; -;; It might be that some code is truly _not_ broken, but it's much -;; easier to just use the dvc- prefix than to prove that. -;; -;; Some implementations will be duplicated here and in dvc-xemacs.el. -;; That is ok; they may need to diverge if bugs are discovered, and -;; they will most likely be reduced to aliases at different times. - -;; DVC developers should normally use Gnu Emacs 22 or XEmacs. In -;; addition, they should occasionally compile with Gnu Emacs 21, or -;; earlier versions of XEmacs, to verify compatibility. -;; -;; As the current release of Gnu Emacs ages, it may be that there are -;; features in the development head of Emacs that would be useful in -;; DVC. Such features can also be provided here. - -;; In the future, when we drop support for Gnu Emacs 21, some of the -;; functions provided here can be deleted, and the DVC code that uses -;; it changed to use the Gnu Emacs release name. That will make that -;; code somewhat clearer. - -;;; Code: - -(unless (fboundp 'minibufferp) - (defun minibufferp () - "Return non-nil if within a minibuffer." - (equal (selected-window) - (active-minibuffer-window)))) - -;; These have different names in Gnu Emacs and XEmacs; see dvc-xemacs.el -(defalias 'dvc-make-overlay 'make-overlay) -(defalias 'dvc-delete-overlay 'delete-overlay) -(defalias 'dvc-overlay-put 'overlay-put) -(defalias 'dvc-move-overlay 'move-overlay) -(defalias 'dvc-overlay-buffer 'overlay-buffer) -(defalias 'dvc-overlay-start 'overlay-start) -(defalias 'dvc-overlay-end 'overlay-end) -(defalias 'dvc-extent-detached-p 'ignore) -(defalias 'dvc-extent-start-open 'ignore) -(defalias 'dvc-mail-strip-quoted-names 'mail-strip-quoted-names) -(defalias 'dvc-character-to-event 'identity) -(defalias 'dvc-assq-delete-all 'assq-delete-all) -(defalias 'dvc-add-text-properties 'add-text-properties) -(defalias 'dvc-put-text-property 'put-text-property) -(defconst dvc-mouse-face-prop 'mouse-face) - -;; Provide features from Emacs 22 for Emacs 21 -;; alphabetical by symbol name - -(if (fboundp 'derived-mode-p) - (defalias 'dvc-derived-mode-p 'derived-mode-p) - (defun dvc-derived-mode-p (&rest modes) - "Non-nil if the current major mode is derived from one of MODES. -Uses the `derived-mode-parent' property of the symbol to trace backwards." - (let ((parent major-mode)) - (while (and (not (memq parent modes)) - (setq parent (get parent 'derived-mode-parent)))) - parent))) - -(if (fboundp 'ewoc-delete) - (defalias 'dvc-ewoc-delete 'ewoc-delete) - (defun dvc-ewoc-delete (ewoc &rest nodes) - "Delete NODES from EWOC." - (ewoc--set-buffer-bind-dll-let* ewoc - ((L nil) (R nil) (last (ewoc--last-node ewoc))) - (dolist (node nodes) - ;; If we are about to delete the node pointed at by last-node, - ;; set last-node to nil. - (when (eq last node) - (setf last nil (ewoc--last-node ewoc) nil)) - (delete-region (ewoc--node-start-marker node) - (ewoc--node-start-marker (ewoc--node-next dll node))) - (set-marker (ewoc--node-start-marker node) nil) - (setf L (ewoc--node-left node) - R (ewoc--node-right node) - ;; Link neighbors to each other. - (ewoc--node-right L) R - (ewoc--node-left R) L - ;; Forget neighbors. - (ewoc--node-left node) nil - (ewoc--node-right node) nil))))) - -;; In Emacs 22, (expand-file-name "c:/..") returns "c:/". But in Emacs -;; 21, it returns "c:/..". So fix that here. We don't use -;; dvc-expand-file-name everywhere in DVC, to simplify deleting it -;; later. We only use it when this case is likely to be encountered. -(if (and (memq system-type '(ms-dos windows-nt)) - (< emacs-major-version 22)) - (defun dvc-expand-file-name (name &optional default-directory) - (let ((result (expand-file-name name default-directory))) - (if (equal (substring result -2 (length result)) "..") - (setq result (substring result 0 -2))) - result)) - (defalias 'dvc-expand-file-name 'expand-file-name)) - -(if (fboundp 'line-number-at-pos) - (defalias 'dvc-line-number-at-pos 'line-number-at-pos) - (defun dvc-line-number-at-pos (&optional pos) - "Return (narrowed) buffer line number at position POS. -If POS is nil, use current buffer location." - (let ((opoint (or pos (point))) start) - (save-excursion - (goto-char (point-min)) - (setq start (point)) - (goto-char opoint) - (forward-line 0) - (1+ (count-lines start (point))))))) - -(if (fboundp 'redisplay) - (defalias 'dvc-redisplay 'redisplay) - (defun dvc-redisplay (&optional force) - (if force - (let ((redisplay-dont-pause t)) - (sit-for 0)) - (sit-for 0)))) - -(if (fboundp 'window-body-height) - (defalias 'dvc-window-body-height 'window-body-height) - (defalias 'dvc-window-body-height 'window-height)) - - -;; FIXME: move to dvc-utils? -(defun dvc-emacs-make-temp-dir (prefix) - "Make a temporary directory using PREFIX. -Return the name of the directory." - (let ((dir (make-temp-name - (expand-file-name prefix temporary-file-directory)))) - (make-directory dir) - dir)) - -(defalias 'dvc-make-temp-dir 'dvc-emacs-make-temp-dir) - -(provide 'dvc-emacs) -;;; dvc-emacs.el ends here - diff --git a/dvc/lisp/dvc-fileinfo.el b/dvc/lisp/dvc-fileinfo.el deleted file mode 100644 index 88e1473..0000000 --- a/dvc/lisp/dvc-fileinfo.el +++ /dev/null @@ -1,831 +0,0 @@ -;;; dvc-fileinfo.el --- An ewoc structure for displaying file information -;;; for DVC - -;; Copyright (C) 2007 - 2011 by all contributors - -;; Author: Stephen Leake, - -;; This file is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3, or (at your option) -;; any later version. - -;; This file is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;; - -;;; Code: - -(require 'dvc-defs) -(require 'dvc-core) -(require 'ewoc) -(eval-when-compile (require 'cl)) - -(defstruct (dvc-fileinfo-root - (:constructor nil) - (:copier nil)) - ;; no slots; root of class for ewoc entries. - ) - -(defvar dvc-fileinfo-ewoc nil - "Buffer-local ewoc for displaying workspace file status. - -All dvc-fileinfo functions operate on this ewoc. -The elements must all be of class dvc-fileinfo-root.") -;; We could have each mode that uses fileinfo declare their own -;; buffer-local ewoc variable (ie dvc-diff-cookie). However, then the -;; interactive functions declared here (like dvc-fileinfo-next) would -;; take an ewoc argument, making them harder to bind directly to keys. -;; -;; We assume there will only be one ewoc structure of interest in a -;; given buffer. -(make-variable-buffer-local 'dvc-fileinfo-ewoc) - -(defstruct (dvc-fileinfo-file - (:include dvc-fileinfo-root) - (:copier nil)) - mark ;; t/nil. - exclude ;; t/nil. If t, don't commit unless also mark = t. - dir ;; Directory the file resides in, relative to dvc-root. - file ;; File name sans directory. - ;; (concat dir file) gives a valid path. - status ;; Symbol; see dvc-fileinfo-status-image-full for list - (indexed t) ;; Whether changes made to the file have been recorded - ;; in the index. Use t if the back-end does not - ;; support an index. - more-status ;; String. If status is rename-*, this is the other name. - ;; Otherwise whatever else the backend has to say - ) - -(defun dvc-fileinfo-status-image-full (status) - "String image of STATUS. -This is used by `dvc-fileinfo-printer-full'." - (ecase status - (added "added ") - (conflict "conflict ") - (deleted "deleted ") - (ignored "ignored ") - (invalid "invalid ") - (known "known ") - (missing "missing ") - (modified "modified ") - (copy-source "copy ") - (copy-target " ==> ") - (rename-source "rename-source") - (rename-target "rename-target") - (unknown "unknown "))) - -(defun dvc-fileinfo-status-image-terse (status) - "String image of STATUS. -This is used by `dvc-fileinfo-printer-terse'." - (ecase status - (added "A") - (conflict "X") - (deleted "D") - (ignored "G") - (invalid "I") - (known "-") - (missing "D") - (modified "M") - (copy-source "C") - (copy-target 'target) - (rename-source "R") - (rename-target 'target) - (unknown "?"))) - -(defun dvc-fileinfo-choose-face-full (status) - "Return a face appropriate for STATUS. -This is used by `dvc-fileinfo-printer-full'." - (ecase status - (added 'dvc-added) - (conflict 'dvc-conflict) - (deleted 'dvc-deleted) - (ignored 'dvc-ignored) - (invalid 'dvc-unrecognized) - (known 'dvc-source) - (missing 'dvc-move) - (modified 'dvc-modified) - (copy-source 'dvc-copy) - (copy-target 'dvc-copy) - (rename-source 'dvc-move) - (rename-target 'dvc-move) - (unknown 'dvc-unknown))) - -(defalias 'dvc-fileinfo-choose-face-terse 'dvc-fileinfo-choose-face-full) - -(defstruct (dvc-fileinfo-dir - (:include dvc-fileinfo-file) - (:copier nil)) - ;; no extra slots - ) - -(defstruct (dvc-fileinfo-message - (:include dvc-fileinfo-root) - (:copier nil)) - text ;; String - ) - -(defstruct (dvc-fileinfo-legacy - (:include dvc-fileinfo-root) - (:copier nil)) - ;; This type has the same form as the old dvc-diff-cookie ewoc - ;; element. It is provided to ease the transition to the new - ;; structure; current parsing code needs very few changes to use - ;; this, and can be more gradually changed to use a dvc-fileinfo - ;; struct. - - data - ;; one of: - ;; (file \"filename\" \"[CRADP?]\" \"M\" \"/\" \"origname\") - ;; (subtree \"name\" related-buffer changes?) - ;; (searching-subtree \"\" ) - ) - -(defun dvc-fileinfo-printer (fileinfo) - "Ewoc pretty-printer for dvc-fileinfo types. Actual pretty-printer -is specified by `dvc-fileinfo-printer-interface'." - (let* ((interface (or dvc-fileinfo-printer-interface 'full)) - (fun (intern (concat "dvc-fileinfo-printer-" - (symbol-name interface))))) - ;; Allow people to use a complete function name if they like - (when (and (not (fboundp fun)) - (fboundp interface)) - (setq fun interface)) - (funcall fun fileinfo))) - -(defun dvc-fileinfo-printer-full (fileinfo) - "Ewoc pretty-printer for dvc-fileinfo types which uses full text to -indicate statuses." - (etypecase fileinfo - (dvc-fileinfo-file ;; also matches dvc-fileinfo-dir - (let ((line (concat - (dvc-fileinfo-status-image-full - (dvc-fileinfo-file-status fileinfo)) - " " - (dvc-fileinfo-file-dir fileinfo) - (dvc-fileinfo-file-file fileinfo))) - (face (cond - ((dvc-fileinfo-file-mark fileinfo) 'dvc-marked) - ((dvc-fileinfo-file-exclude fileinfo) 'dvc-excluded) - (t (dvc-fileinfo-choose-face-full - (dvc-fileinfo-file-status fileinfo)))))) - (insert " ") - (cond - ((dvc-fileinfo-file-mark fileinfo) (insert dvc-mark)) - ((dvc-fileinfo-file-exclude fileinfo) (insert dvc-exclude)) - (t (insert " "))) - - (insert " ") - (insert (dvc-face-add line face)) - (if (> (length (dvc-fileinfo-file-more-status fileinfo)) 0) - (progn - (newline) - (insert " ") - (case (dvc-fileinfo-file-status fileinfo) - (rename-source - (insert "to ")) - (rename-target - (insert "from ")) - (t nil)) - (insert (dvc-fileinfo-file-more-status fileinfo)))))) - - (dvc-fileinfo-legacy - (dvc-diff-printer (dvc-fileinfo-legacy-data fileinfo)) ) - - (dvc-fileinfo-message - (insert (dvc-fileinfo-message-text fileinfo))))) - -(defun dvc-fileinfo-printer-terse (fileinfo) - "Ewoc pretty-printer for dvc-fileinfo types which uses a single letter -to indicate statuses." - (let ((inhibit-read-only t)) - (etypecase fileinfo - (dvc-fileinfo-file ;; also matches dvc-fileinfo-dir - (let* ((image (dvc-fileinfo-status-image-terse - (dvc-fileinfo-file-status fileinfo))) - (indexed (if (or (dvc-fileinfo-file-indexed fileinfo) - (eq (dvc-fileinfo-file-status fileinfo) - 'unknown)) - " " "?")) - (line (if (stringp image) - (concat image indexed " " - (dvc-fileinfo-file-dir fileinfo) - (dvc-fileinfo-file-file fileinfo)) - (concat " ==> " - (dvc-fileinfo-file-dir fileinfo) - (dvc-fileinfo-file-file fileinfo)))) - (face (cond - ((dvc-fileinfo-file-mark fileinfo) 'dvc-marked) - ((dvc-fileinfo-file-exclude fileinfo) 'dvc-excluded) - (t (dvc-fileinfo-choose-face-terse - (dvc-fileinfo-file-status fileinfo)))))) - (cond - ((dvc-fileinfo-file-mark fileinfo) (insert dvc-mark)) - ((dvc-fileinfo-file-exclude fileinfo) (insert dvc-exclude)) - (t (insert " "))) - - (insert " ") - (insert (dvc-face-add line face)) - (if (> (length (dvc-fileinfo-file-more-status fileinfo)) 0) - (progn - (newline) - (insert " ") - (insert (dvc-fileinfo-file-more-status fileinfo)))))) - - (dvc-fileinfo-legacy - (dvc-diff-printer (dvc-fileinfo-legacy-data fileinfo)) ) - - (dvc-fileinfo-message - (insert (dvc-fileinfo-message-text fileinfo)))))) - -(defun dvc-fileinfo-current-fileinfo () - "Return the fileinfo (a dvc-fileinfo-file, or -dvc-fileinfo-legacy) for the ewoc element at point. Throws an -error if point is not on a file or directory." - (let ((ewoc-entry (ewoc-locate dvc-fileinfo-ewoc))) - (if (not ewoc-entry) - ;; ewoc is empty - (error "not on a file or directory")) - (let ((fileinfo (ewoc-data ewoc-entry))) - (etypecase fileinfo - (dvc-fileinfo-file ; also matches dvc-fileinfo-dir - fileinfo) - - (dvc-fileinfo-legacy - (let ((data (dvc-fileinfo-legacy-data fileinfo))) - (cond - ((eq (car data) 'file) - fileinfo) - - (t - (error "not on a file or directory"))))) - - (dvc-fileinfo-message - (error "not on a file or directory")))))) - -(defun dvc-fileinfo-file-or-legacy-file-p (fileinfo) - "Return t if FILEINFO is a dvc-fileinfo-file, or a dvc-fileinfo-legacy -containing a 'file." - (or (dvc-fileinfo-file-p fileinfo) - (and (dvc-fileinfo-legacy-p fileinfo) - (eq 'file (car (dvc-fileinfo-legacy-data fileinfo)))))) - -(defun dvc-fileinfo-path (fileinfo) - "Return directory and file from fileinfo, as a string." - (etypecase fileinfo - (dvc-fileinfo-file - (concat (dvc-fileinfo-file-dir fileinfo) - (dvc-fileinfo-file-file fileinfo))) - - (dvc-fileinfo-legacy - (let ((data (dvc-fileinfo-legacy-data fileinfo))) - (if (eq 'file (car data)) - (cadr data) - (error "Not on a file entry")))))) - -(defun dvc-fileinfo-current-file () - "Return a string giving the filename (including path from root) -of the file element on the line at point. Throws an error if -point is not on a file element line. If file status is -`rename-*', this is the modified (or target) name." - (let ((fileinfo (dvc-fileinfo-current-fileinfo))) - (etypecase fileinfo - (dvc-fileinfo-file ; also matches dvc-fileinfo-dir - (case (dvc-fileinfo-file-status fileinfo) - (rename-source - ;; target name is in more-status - (dvc-fileinfo-file-more-status fileinfo)) - (t - (concat (dvc-fileinfo-file-dir fileinfo) - (dvc-fileinfo-file-file fileinfo))))) - - (dvc-fileinfo-legacy - (cadr (dvc-fileinfo-legacy-data fileinfo)))))) - -(defun dvc-fileinfo-base-file () - "Return a string giving the filename in the base revision. -Includes path from root). Different from -dvc-fileinfo-current-file only for renamed files." - (let ((fileinfo (dvc-fileinfo-current-fileinfo))) - (etypecase fileinfo ; also matches dvc-fileinfo-dir - (dvc-fileinfo-file - (case (dvc-fileinfo-file-status fileinfo) - (rename-target - ;; source name is in more-status, and it includes the path - (dvc-fileinfo-file-more-status fileinfo)) - (t - ;; see if there is a rename for this file in the ewoc - (let ((found-data - (ewoc-collect - dvc-fileinfo-ewoc - (lambda (data) - (etypecase data - (dvc-fileinfo-file - (and (eq 'rename-target (dvc-fileinfo-file-status data)) - (string= (dvc-fileinfo-file-dir fileinfo) - (dvc-fileinfo-file-dir data)) - (string= (dvc-fileinfo-file-file fileinfo) - (dvc-fileinfo-file-file data)))) - (t nil)))))) - (if found-data - (dvc-fileinfo-file-more-status (car found-data)) - (concat (dvc-fileinfo-file-dir fileinfo) - (dvc-fileinfo-file-file fileinfo))))))) - - (dvc-fileinfo-legacy - (cadr (dvc-fileinfo-legacy-data fileinfo)))))) - -(defun dvc-fileinfo-all-files () - "Return list of all files (as strings) in file list" - (let (result) - (ewoc-map - (lambda (fileinfo) - (when (dvc-fileinfo-file-or-legacy-file-p fileinfo) - ;; we use 'add-to-list', because some back-ends put files in - ;; the ewoc more than once - (add-to-list 'result (dvc-fileinfo-path fileinfo))) - nil) - dvc-fileinfo-ewoc) - result)) - -(defun dvc-fileinfo-delete-messages () - "Remove all message elements from the ewoc." - (ewoc-filter dvc-fileinfo-ewoc - (lambda (fileinfo) - (not (dvc-fileinfo-message-p fileinfo))))) - -(defun dvc-fileinfo-kill () - "Remove the current element(s) from the ewoc. Does nothing for -marked legacy fileinfos." - (interactive) - - (if (and (= 0 (length (dvc-fileinfo-marked-files))) - (= 0 (length dvc-buffer-marked-file-list))) - ;; no marked files - (progn - ;; binding inhibit-read-only doesn't seem to work here - (toggle-read-only 0) - (dvc-ewoc-delete dvc-fileinfo-ewoc (ewoc-locate dvc-fileinfo-ewoc)) - (toggle-read-only 1)) - ;; marked files - (if (= 0 (length dvc-buffer-marked-file-list)) - ;; non-legacy files - (ewoc-filter dvc-fileinfo-ewoc - (lambda (fileinfo) - (not (dvc-fileinfo-file-mark fileinfo))) - ) - ;; legacy files - nil))) - -(defun dvc-fileinfo-mark-dir-1 (fileinfo mark dir-compare) - ;; Note that fileinfo will only be fileinfo-file or fileinfo-dir - (if (string-equal dir-compare (dvc-fileinfo-file-dir fileinfo)) - (let ((file (dvc-fileinfo-path fileinfo))) - (etypecase fileinfo - (dvc-fileinfo-dir - (if (dvc-fileinfo-file-exclude fileinfo) - (if mark - (message "not marking %s; excluded" file)) - (dvc-fileinfo-mark-dir file mark)) - ;; return non-nil so this element is refreshed - t) - - (dvc-fileinfo-file - (if (dvc-fileinfo-file-exclude fileinfo) - (if mark - (message "not marking %s; excluded" file)) - (setf (dvc-fileinfo-file-mark fileinfo) mark)) - ;; return non-nil so this element is refreshed - t) - - )))) - -(defun dvc-fileinfo-mark-dir (dir mark) - "Set the mark for all files in DIR to MARK, recursively." - (ewoc-map (lambda (fileinfo dir-compare) - (etypecase fileinfo - (dvc-fileinfo-file ; also matches dvc-fileinfo-dir - (dvc-fileinfo-mark-dir-1 fileinfo mark dir-compare)) - - (dvc-fileinfo-message nil) - - (dvc-fileinfo-legacy - (error "dvc-fileinfo-mark-dir not implemented for legacy back-ends")))) - dvc-fileinfo-ewoc - (file-name-as-directory dir))) - -(defun dvc-fileinfo-mark-file-1 (mark) - "Set the mark for file under point to MARK. If a directory, mark all files -in that directory." - (let* ((current (ewoc-locate dvc-fileinfo-ewoc)) - (fileinfo (ewoc-data current))) - (etypecase fileinfo - (dvc-fileinfo-dir - (let ((file (dvc-fileinfo-path fileinfo))) - (if (dvc-fileinfo-file-exclude fileinfo) - (if mark - (progn - ;; we don't throw an error here, because we might - ;; be marking a higher-level directory, and we - ;; don't want to skip the rest of it. - (ding) - (message "not marking %s; excluded" file))) - ;; not excluded - (setf (dvc-fileinfo-file-mark fileinfo) mark) - (ewoc-invalidate dvc-fileinfo-ewoc current) - (dvc-fileinfo-mark-dir file mark)))) - - (dvc-fileinfo-file - (let ((file (dvc-fileinfo-path fileinfo))) - (if (dvc-fileinfo-file-exclude fileinfo) - (if mark - (progn - ;; we don't throw an error here, because we might - ;; be marking a higher-level directory, and we - ;; don't want to skip the rest of it. - (ding) - (message "not marking %s; excluded" file))) - ;; not excluded - (setf (dvc-fileinfo-file-mark fileinfo) mark) - (ewoc-invalidate dvc-fileinfo-ewoc current)))) - - (dvc-fileinfo-legacy - (error "mark not supported for legacy systems")) - - (dvc-fileinfo-message - (error "not on a file or directory"))))) - -(defun dvc-fileinfo-mark-file () - "Mark the file under point. If a directory, mark all files in -that directory. Then move to next ewoc entry." - (interactive) - (dvc-fileinfo-mark-file-1 t) - (dvc-fileinfo-next)) - -(defun dvc-fileinfo-unmark-file (&optional prev) - "Unmark the file under point. If a directory, unmark all files -in that directory. If PREV non-nil, move to previous ewoc entry; -otherwise move to next." - (interactive) - (dvc-fileinfo-mark-file-1 nil) - (if prev - (dvc-fileinfo-prev) - (dvc-fileinfo-next))) - -(defun dvc-fileinfo-unmark-file-up () - "Unmark the file under point. If a directory, unmark all files -in that directory. Then move to previous ewoc entry." - (interactive) - (dvc-fileinfo-unmark-file t)) - -(defun dvc-fileinfo-mark-all () - "Mark all files and directories." - (interactive) - (ewoc-map (lambda (fileinfo) - (etypecase fileinfo - (dvc-fileinfo-file ; also matches dvc-fileinfo-dir - (if (dvc-fileinfo-file-exclude fileinfo) - (progn - (message "not marking %s; excluded" (dvc-fileinfo-path fileinfo)) - ;; don't need to refresh - nil) - (setf (dvc-fileinfo-file-mark fileinfo) t) - ;; return non-nil so this element is refreshed - t)) - - (dvc-fileinfo-legacy - (error "mark not supported for legacy backends")) - - (dvc-fileinfo-message - nil))) - dvc-fileinfo-ewoc)) - -(defun dvc-fileinfo-unmark-all () - "Unmark all files and directories." - (interactive) - (ewoc-map (lambda (fileinfo) - (etypecase fileinfo - (dvc-fileinfo-file ; also matches dvc-fileinfo-dir - (if (dvc-fileinfo-file-mark fileinfo) - (progn - (setf (dvc-fileinfo-file-mark fileinfo) nil) - ;; return non-nil so this element is refreshed - t))) - - (dvc-fileinfo-legacy - (error "mark not supported for legacy backends")) - - (dvc-fileinfo-message - nil))) - dvc-fileinfo-ewoc)) - -(defun dvc-fileinfo-toggle-exclude () - "Toggle exclude for file under point. Does not edit default exclude file." - (interactive) - (let* ((current (ewoc-locate dvc-fileinfo-ewoc)) - (fileinfo (ewoc-data current))) - (typecase fileinfo - (dvc-fileinfo-file - (if (dvc-fileinfo-file-mark fileinfo) - (error "Cannot exclude marked file")) - - (setf (dvc-fileinfo-file-exclude fileinfo) - (not (dvc-fileinfo-file-exclude fileinfo))) - (ewoc-invalidate dvc-fileinfo-ewoc current)) - - (otherwise - (error "not on a file or directory"))))) - -(dvc-make-ewoc-next dvc-fileinfo-next dvc-fileinfo-ewoc) -(dvc-make-ewoc-prev dvc-fileinfo-prev dvc-fileinfo-ewoc) - -(defun dvc-fileinfo-find-file (file) - "Return ewoc element for FILE (full path)." - (let ((elem (ewoc-nth dvc-fileinfo-ewoc 0))) - (while - (and elem - (let ((fileinfo (ewoc-data elem))) - (not (and - (dvc-fileinfo-file-or-legacy-file-p fileinfo) - (string= (expand-file-name (dvc-fileinfo-path fileinfo)) - file))))) - ;; not found yet - (setq elem (ewoc-next dvc-fileinfo-ewoc elem))) - (if elem - elem - (error "Can't find file %s in list" file)))) - -(defun dvc-fileinfo-marked-elems () - "Return list of ewoc elements that are marked files." - ;; This does _not_ include legacy fileinfo structs; they do not - ;; contain a mark field. We are planning to eventually eliminate - ;; dvc-buffer-marked-file-list and legacy fileinfos. - (let ((elem (ewoc-nth dvc-fileinfo-ewoc 0)) - result) - (while elem - (let ((fi (ewoc-data elem))) - (if (and (dvc-fileinfo-file-p fi) - (dvc-fileinfo-file-mark fi)) - (setq result (append result (list elem)))) - (setq elem (ewoc-next dvc-fileinfo-ewoc elem)))) - result)) - -(defun dvc-fileinfo-marked-files () - "Return list of files that are marked." - ;; This does _not_ include legacy fileinfo structs; they do not - ;; contain a mark field. We are planning to eventually eliminate - ;; dvc-buffer-marked-file-list and legacy fileinfos. - (let ((elem (ewoc-nth dvc-fileinfo-ewoc 0)) - result) - (while elem - (let ((fi (ewoc-data elem))) - (if (and (dvc-fileinfo-file-p fi) - (dvc-fileinfo-file-mark fi)) - (setq result (append result (list (dvc-fileinfo-path fi))))) - (setq elem (ewoc-next dvc-fileinfo-ewoc elem)))) - result)) - -(defun dvc-fileinfo-excluded-files () - "Return list of filenames that are excluded files." - ;; This does _not_ include legacy fileinfo structs; they do not - ;; contain an excluded field. - (let ((elem (ewoc-nth dvc-fileinfo-ewoc 0)) - result) - (while elem - (let ((fi (ewoc-data elem))) - (if (and (dvc-fileinfo-file-p fi) - (dvc-fileinfo-file-exclude fi)) - (setq result (append result (list (dvc-fileinfo-path fi))))) - (setq elem (ewoc-next dvc-fileinfo-ewoc elem)))) - result)) - -(defun dvc-fileinfo-same-status (elems) - "If all ELEMS (list of ewoc elements with data of class - dvc-fileinfo-file) have same status, return t. Otherwise - throw an error." - (if (null elems) - t - (let (status) - (dolist (elem elems) - (let ((fileinfo (ewoc-data elem))) - (if status - (if (not (equal status (dvc-fileinfo-file-status fileinfo))) - (error (concat "cannot Do The Right Thing on files with" - " different status"))) - (setq status (dvc-fileinfo-file-status fileinfo))))) - status))) - -;;; actions -(defun dvc-fileinfo-set-status (status) - "Set status of current file(s) to STATUS. This avoids the need -to run the backend again. Does nothing for legacy fileinfos." - (if (= 0 (length (dvc-fileinfo-marked-files))) - (if dvc-buffer-marked-file-list - ;; marked legacy fileinfos - nil - - ;; no marked files - (let ((fileinfo (dvc-fileinfo-current-fileinfo))) - (etypecase fileinfo - (dvc-fileinfo-message - nil) - - (dvc-fileinfo-file ; also matches dvc-fileinfo-dir - (setf (dvc-fileinfo-file-status fileinfo) status)) - - (dvc-fileinfo-legacy - nil)) - (ewoc-invalidate dvc-fileinfo-ewoc (ewoc-locate dvc-fileinfo-ewoc)))) - - ;; marked files - (ewoc-map (lambda (fileinfo) - (etypecase fileinfo - (dvc-fileinfo-message - nil) - - (dvc-fileinfo-file ; also matches dvc-fileinfo-dir - (if (dvc-fileinfo-file-mark fileinfo) (setf (dvc-fileinfo-file-status fileinfo) status))))) - dvc-fileinfo-ewoc))) - -(defun dvc-fileinfo-add-files () - "Add current file(s) to the database. Directories are also added, -but not recursively." - (interactive) - (apply 'dvc-add-files (dvc-current-file-list)) - - (dvc-fileinfo-set-status 'added)) - -(defun dvc-fileinfo-add-log-entry-1 (fileinfo other-frame) - "Add an entry in the current log-edit buffer for FILEINFO. -If OTHER-FRAME (default prefix) xor `dvc-log-edit-other-frame' is -non-nil, show log-edit buffer in other frame." - (dvc-log-edit other-frame t) - (undo-boundary) - (goto-char (point-max)) - (newline 2) - (insert "* ") - (insert (dvc-fileinfo-path fileinfo)) - (insert ": ") - - (if (typep fileinfo 'dvc-fileinfo-file) - (ecase (dvc-fileinfo-file-status fileinfo) - (added - (insert "New file.") - (newline)) - - ((copy-source copy-target) - (insert "copied") - (newline)) - - ((rename-source rename-target) - (insert "renamed") - (newline)) - - ((conflict - deleted - ignored - invalid - known - missing - modified - unknown) - nil)))) - -(defun dvc-fileinfo-add-log-entry (&optional other-frame) - "Add an entry in the current log-edit buffer for the current file. -If OTHER-FRAME (default prefix) xor `dvc-log-edit-other-frame' is -non-nil, show log-edit buffer in other frame." - (interactive "P") - (dvc-fileinfo-add-log-entry-1 (dvc-fileinfo-current-fileinfo) other-frame)) - -(defun dvc-fileinfo-ignore-files () - "Ignore current files." - (interactive) - (dvc-ignore-files (dvc-current-file-list)) - - (dvc-fileinfo-kill)) - -(defun dvc-fileinfo-remove-files () - "Remove current files. If status `unknown', delete from -workspace. Otherwise, call `dvc-remove-files'. For marked legacy -fileinfos, just call `dvc-remove-files'." - (interactive) - (if dvc-buffer-marked-file-list - (dvc-remove-files) - ;; not legacy - (let ((elems (or (dvc-fileinfo-marked-elems) - (list (ewoc-locate dvc-fileinfo-ewoc)))) - (inhibit-read-only t) - known-files unknown-files) - - (while elems - (let ((fileinfo (ewoc-data (car elems)))) - (typecase fileinfo - (dvc-fileinfo-file - (if (equal 'unknown (dvc-fileinfo-file-status fileinfo)) - (progn - (push (car elems) unknown-files)) - ;; `add-to-list' gets a stack overflow here - (setq known-files (cons (car elems) known-files)))) - - (dvc-fileinfo-legacy - ;; Assume files are known - (add-to-list 'known-files (car elems))) - - (otherwise - ;; just ignore - nil)) - (setq elems (cdr elems)))) - - (if known-files - (progn - (apply 'dvc-remove-files - (mapcar (lambda (elem) - (dvc-fileinfo-path (ewoc-data elem))) - known-files)) - (mapc - (lambda (elem) - (let ((fileinfo (ewoc-data elem))) - (etypecase fileinfo - (dvc-fileinfo-file - (setf (dvc-fileinfo-file-status fileinfo) 'deleted) - (ewoc-invalidate dvc-fileinfo-ewoc elem)) - - (dvc-fileinfo-legacy - ;; Don't have enough info to update this - nil)))) - known-files))) - (when unknown-files - (let ((names (mapcar (lambda (x) (dvc-fileinfo-path (ewoc-data x))) - unknown-files))) - (when (dvc-confirm-file-op "remove unknown" names t) - (mapcar 'delete-file names) - (apply 'ewoc-delete dvc-fileinfo-ewoc unknown-files))))))) - -(defun dvc-fileinfo-revert-files () - "Revert current files." - (interactive) - (apply 'dvc-revert-files (dvc-current-file-list)) - - (dvc-fileinfo-kill)) - -(defun dvc-fileinfo--do-rename (fi-source fi-target elems) - (dvc-rename (dvc-fileinfo-path fi-source) - (dvc-fileinfo-path fi-target)) - (setf (dvc-fileinfo-file-status fi-source) 'rename-source) - (setf (dvc-fileinfo-file-status fi-target) 'rename-target) - (setf (dvc-fileinfo-file-mark fi-source) nil) - (setf (dvc-fileinfo-file-mark fi-target) nil) - (apply 'ewoc-invalidate dvc-fileinfo-ewoc elems)) - -(defun dvc-fileinfo-rename () - "Record a rename for two currently marked files. -One file must have status `missing', the other `unknown'." - (interactive) - (let* ((elems (dvc-fileinfo-marked-elems)) - (fis (mapcar 'ewoc-data elems)) - (stati (mapcar 'dvc-fileinfo-file-status fis))) - - (if (not (= 2 (length stati))) - (error "rename requires exactly 2 marked files")) - - (cond - ((and (eq 'missing (nth 0 stati)) - (eq 'unknown (nth 1 stati))) - (dvc-fileinfo--do-rename (nth 0 fis) (nth 1 fis) elems)) - - ((and (eq 'missing (nth 1 stati)) - (eq 'unknown (nth 0 stati))) - (dvc-fileinfo--do-rename (nth 1 fis) (nth 0 fis) elems)) - - (t - (error (concat "must rename from a file with status `missing' to a" - " file with status `unknown'")))))) - -(defun dvc-fileinfo-rename-possible (marked-elems) - "Return nil if `dvc-fileinfo-rename' will throw an error for -MARKED-ELEMS, non-nil otherwise." - (and - marked-elems - (= 2 (length marked-elems)) - (let* ((fis (mapcar 'ewoc-data marked-elems)) - (stati (mapcar 'dvc-fileinfo-file-status fis))) - (or - (and (eq 'missing (nth 0 stati)) - (eq 'unknown (nth 1 stati))) - - (and (eq 'missing (nth 1 stati)) - (eq 'unknown (nth 0 stati))))))) - -(provide 'dvc-fileinfo) -;;; end of file diff --git a/dvc/lisp/dvc-gnus.el b/dvc/lisp/dvc-gnus.el deleted file mode 100644 index 159f17b..0000000 --- a/dvc/lisp/dvc-gnus.el +++ /dev/null @@ -1,334 +0,0 @@ -;;; 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 deleted file mode 100644 index fb12c12..0000000 --- a/dvc/lisp/dvc-lisp.el +++ /dev/null @@ -1,214 +0,0 @@ -;;; 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 deleted file mode 100644 index 931624f..0000000 --- a/dvc/lisp/dvc-log.el +++ /dev/null @@ -1,409 +0,0 @@ -;;; dvc-log.el --- Manipulation of the log before committing - -;; Copyright (C) 2005-2008, 2010 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 root) - other-frame) - ;; `no-init' is somewhat misleading here. It is set to t in - ;; dvc-add-log-entry, and nil in dvc-log-edit. That prevents - ;; changing dvc-partner-buffer when we shouldn't. But the user - ;; might call dvc-log-edit multiple times from the same diff or - ;; status buffer, and expect edits in the log-edit buffer to be - ;; preserved. - (unless no-init - (let ((buffer-name (buffer-name)) - (file-name (dvc-log-edit-file-name))) - (set-visited-file-name file-name t t) - ;; `set-visited-file-name' modifies default-directory - (setq default-directory root) - ;; Read in the current log file, unless the user has already - ;; edited the buffer. - (when (and (= (point-min) (point-max)) (file-readable-p file-name)) - (insert-file-contents file-name) - (set-buffer-modified-p nil)) - (rename-buffer buffer-name) - (setq dvc-partner-buffer start-buffer) - (dvc-call "log-edit-mode"))))) - -(defun dvc-log-edit-abort () - "Abort the current log edit." - (interactive) - (bury-buffer) - (set-window-configuration dvc-pre-commit-window-configuration)) - -(defun dvc-log-close (buffer) - "Close the log buffer, and delete the file." - (if vc-delete-logbuf-window - (kill-buffer buffer) - (quit-window)) - (delete-file (dvc-log-edit-file-name))) - -(defun dvc-log-flush-commit-file-list () - "Remove the list of the files to commit. -All lines starting with `dvc-log-edit-flush-prefix' are deleted." - (interactive) - (save-excursion - (goto-char (point-min)) - (flush-lines (concat "^" dvc-log-edit-flush-prefix)))) - -(defun dvc-log-fill-paragraph (&optional justify) - "Fill the paragraph, but preserve open parentheses at beginning of lines. -Prefix arg means justify as well." - (interactive "P") - (let ((end (progn (forward-paragraph) (point))) - (beg (progn (backward-paragraph) (point))) - (paragraph-start (concat paragraph-start "\\|\\s *\\s("))) - (fill-region beg end justify) - t)) - -(defun dvc-log-insert-commit-file-list (arg) - "Insert the file list that will be committed. -With a negative prefix argument just remove the file list -by calling `dvc-log-flush-commit-file-list'." - (interactive "p") - (if (< arg 0) - (dvc-log-flush-commit-file-list) - (let ((file-list (funcall (dvc-function (dvc-current-active-dvc) "dvc-files-to-commit"))) - (mark)) - (dvc-trace "Files to commit: %S" file-list) - (save-excursion - (goto-char (point-min)) - (dvc-log-flush-commit-file-list) - (insert dvc-log-edit-flush-prefix) - (insert (format "Lines beginning with '%s' will be deleted from this buffer before committing\n" dvc-log-edit-flush-prefix)) - (insert dvc-log-edit-flush-prefix) - (insert "Files to commit:\n") - (dolist (f file-list) - (setq mark (cdr (assoc (car f) '( (dvc-modified . "M ") (dvc-added . "A ") (dvc-deleted . "R ") )))) - (insert dvc-log-edit-flush-prefix) - (insert (dvc-face-add (concat mark (cdr f)) (car f))) - (newline)))))) - -(defun dvc-log-edit-insert-memorized-log () - "Insert a memorized log message." - (interactive) - (when dvc-memorized-log-header - (goto-char (point-min)) - (delete-region (point) (line-end-position)) - (insert dvc-memorized-log-header)) - (when dvc-memorized-log-message - (goto-char (point-min)) - (end-of-line) - (newline) - (newline) - (when dvc-memorized-patch-sender - (if (looking-at "Patch from ") - (forward-line 1) - (progn - (undo-boundary) - (insert (format "Patch from %s\n" dvc-memorized-patch-sender))))) - (when (looking-at "\* .+: ") ;; e.g.: "* lisp/dvc.el: " - (end-of-line) - (newline)) - (insert dvc-memorized-log-message))) - -;;;###autoload -(defun dvc-add-log-entry (&optional other-frame) - "Add new ChangeLog style entry to the current DVC log-edit buffer. -If OTHER-FRAME xor `dvc-log-edit-other-frame' is non-nil, -show log-edit buffer in other frame." - (interactive "P") - (save-restriction - (dvc-add-log-entry-internal other-frame))) - -(defun dvc-add-log-file-name (buffer-file) - "Return a file name for a log entry for BUFFER-FILE; including path from tree root. -For use as add-log-file-name-function." - ;; This is better than the default algorithm in add-log-file-name, - ;; when the log file is not in the workspace root (as is true for - ;; monotone) - (if (string-match - (concat "^" (regexp-quote (dvc-tree-root))) - buffer-file) - (substring buffer-file (match-end 0)) - (file-name-nondirectory buffer-file))) - -(defun dvc-ediff-add-log-entry (&optional other-frame) - "Add new DVC log ChangeLog style entry; intended to be invoked -from the ediff control buffer." - (interactive "P") - (let ((dvc-temp-current-active-dvc dvc-buffer-current-active-dvc)) - (set-buffer ediff-buffer-B) ; DVC puts workspace version here - (dvc-add-log-entry-internal other-frame))) - -(defun dvc-ediff-setup () - (define-key 'ediff-mode-map "t" 'dvc-ediff-add-log-entry)) ; matches dvc-diff-mode-map - -;; ediff hooks that run after ediff-mode-map is created: -;; ediff-prepare-buffer-hook, ediff-startup-hook -(add-hook 'ediff-startup-hook 'dvc-ediff-setup) - -(defun dvc-add-log-entry-internal (other-frame) - "Similar to `add-change-log-entry'. - -Inserts the entry in the dvc log-edit buffer instead of the ChangeLog." - ;; This is mostly copied from add-log.el. Perhaps it would be better to - ;; split add-change-log-entry into several functions and then use them, but - ;; that wouldn't work with older versions of Emacs. - ;; - ;; We don't set add-log-file-name-function globally because - ;; dvc-diff-mode needs a different one. - (if (not (featurep 'add-log)) (require 'add-log)) - (let* ((dvc-temp-current-active-dvc (dvc-current-active-dvc)) - (add-log-file-name-function 'dvc-add-log-file-name) - (defun (add-log-current-defun)) - (buf-file-name (if (and (boundp 'add-log-buffer-file-name-function) - add-log-buffer-file-name-function) - (funcall add-log-buffer-file-name-function) - buffer-file-name)) - (buffer-file (if buf-file-name (expand-file-name buf-file-name))) - (file-name (dvc-log-edit-file-name)) - ;; Set ENTRY to the file name to use in the new entry. - (entry (add-log-file-name buffer-file file-name)) - beg - bound - narrowing) - - (dvc-log-edit other-frame t) - - (undo-boundary) - (goto-char (point-min)) - (when (re-search-forward (regexp-opt - (list "^Patches applied:" - (regexp-quote - ;; TODO - dvc-log-edit-file-list-marker))) - nil t) - (narrow-to-region (point-min) (match-beginning 0)) - (setq narrowing t) - (goto-char (point-min))) - (re-search-forward "\n\n\\|\\'") - (setq beg (point)) - (if (looking-at "\n*[^\n* \t]") - (progn - (skip-chars-forward "\n") - (setq bound (point))) - (goto-char (point-max)) - (setq bound (point)) - (unless (and (boundp 'add-log-keep-changes-together) - add-log-keep-changes-together) - (backward-paragraph) ; paragraph delimits entries for file - (forward-line 1) - (setq beg (point)))) - (goto-char beg) - (forward-line -1) - ;; Now insert the new line for this entry. - (cond ((re-search-forward "^\\s *\\*\\s *$" bound t) - ;; Put this file name into the existing empty entry. - (if entry - (insert entry))) - ((let (case-fold-search) - (re-search-forward - (concat (regexp-quote (concat "* " entry)) - ;; Don't accept `foo.bar' when - ;; looking for `foo': - "\\(\\s \\|[(),:]\\)") - bound t)) - ;; Add to the existing entry for the same file. - (if (re-search-forward "^\\s *$\\|^\\s \\*" nil t) - (goto-char (match-beginning 0)) - (goto-char (point-max)) - (insert-char ?\n 1)) - ;; Delete excess empty lines; make just 2. - (while (and (not (eobp)) (looking-at "^\\s *$")) - (delete-region (point) (line-beginning-position 2))) - (insert-char ?\n 2) - (forward-line -2) - (indent-relative)) - (t - ;; Make a new entry. - (if dvc-log-insert-last - (progn - (goto-char (point-max)) - (re-search-backward "^." nil t) - (end-of-line) - (insert "\n\n* ") - ) - (forward-line 1) - (while (looking-at "\\sW") - (forward-line 1)) - (while (and (not (eobp)) (looking-at "^\\s *$")) - (delete-region (point) (line-beginning-position 2))) - (insert-char ?\n 3) - (forward-line -2) - (indent-to left-margin) - (insert "* ")) - (if entry (insert entry)))) - (if narrowing (widen)) - ;; Now insert the function name, if we have one. - ;; Point is at the entry for this file, - ;; either at the end of the line or at the first blank line. - (if defun - (progn - ;; Make it easy to get rid of the function name. - (undo-boundary) - (unless (save-excursion - (beginning-of-line 1) - (looking-at "\\s *$")) - (insert ?\ )) - ;; See if the prev function name has a message yet or not - ;; If not, merge the two entries. - (let ((pos (point-marker))) - (if (and (skip-syntax-backward " ") - (skip-chars-backward "):") - (looking-at "):") - (progn (delete-region (+ 1 (point)) (+ 2 (point))) t) - (> fill-column (+ (current-column) (length defun) 3))) - (progn (delete-region (point) pos) - (insert ", ")) - (goto-char pos) - (insert "(")) - (set-marker pos nil)) - ;; Check for previous function name using re-search-backward - ;; instead of looking-back, because looking-back is not - ;; implemented in all variants of (X)Emacs. We could create - ;; a compatibility function for it, but nobody else seems to - ;; use it yet, so there is no point. - (when (re-search-backward (concat (regexp-quote defun) ",\\s *\\=") nil t) - (replace-match "")) - (insert defun "): ")) - ;; No function name, so put in a colon unless we have just a star. - (unless (save-excursion - (beginning-of-line 1) - (looking-at "\\s *\\(\\*\\s *\\)?$")) - (insert ": "))))) - -(defun dvc-log-edit-register-initial-content-function (working-copy-root the-function) - "Register a mapping from a work directory root to a function that provide the initial content for a commit." - (puthash (dvc-uniquify-file-name working-copy-root) the-function dvc-log-edit-init-functions)) - -(defun dvc-log-edit-insert-initial-commit-message () - "Insert the initial commit message at point. -See `dvc-log-edit-register-initial-content-function' to register functions that provide the message text." - (interactive) - (let ((initial-content-function (gethash (dvc-uniquify-file-name (dvc-tree-root)) dvc-log-edit-init-functions))) - (when initial-content-function - (insert (funcall initial-content-function))))) - - -(provide 'dvc-log) -;;; dvc-log.el ends here diff --git a/dvc/lisp/dvc-register.el b/dvc/lisp/dvc-register.el deleted file mode 100644 index b2ce39e..0000000 --- a/dvc/lisp/dvc-register.el +++ /dev/null @@ -1,301 +0,0 @@ -;;; 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 deleted file mode 100644 index dfdae2b..0000000 --- a/dvc/lisp/dvc-revlist.el +++ /dev/null @@ -1,477 +0,0 @@ -;;; 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 deleted file mode 100644 index 0ab7a2d..0000000 --- a/dvc/lisp/dvc-revlog.el +++ /dev/null @@ -1,98 +0,0 @@ -;;; 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 deleted file mode 100644 index 4f46bba..0000000 --- a/dvc/lisp/dvc-site.el.in +++ /dev/null @@ -1,39 +0,0 @@ -;;; 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 deleted file mode 100644 index aaeea73..0000000 --- a/dvc/lisp/dvc-state.el +++ /dev/null @@ -1,95 +0,0 @@ -;;; dvc-state.el --- saving and loading state variables between Emacs sessions - -;; Copyright (C) 2006-2008 by all contributors - -;; This file is part of DVC. -;; -;; DVC is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; DVC is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: -;; `dvc-save-state' is for saving to a state file. -;; `dvc-load-state' is for loading from a state file. - -;;; Code: -(require 'dvc-utils) -(require 'dvc-defs) -(require 'dvc-config) - -(defgroup dvc-state nil - "Saving DVC's state between Emacs sessions." - :group 'dvc) - -(defcustom dvc-state-file-name "state.el" - "*File in which DVC saves state variables between Emacs sessions. -The file is stored in the `dvc-config-directory'" - :type 'file - :group 'dvc-state) - -(defcustom dvc-state-variables-list '(dvc-tips-number) - "*List of variables to store in the state file `dvc-state-file-name'." - :type '(repeat (symbol)) - :group 'dvc-state) - -;;;###autoload -(defun dvc-save-state (&optional vars state-file pp) - "Save variables from VARS list to file STATE-FILE. -The default for VARS is `dvc-state-variables-list' -The default for STATE-FILE is `dvc-state-file-name'. -If PP is non-nil use `dvc-pp-to-string' to format object. - -The file will contain a setq setting the vars during loading by -`dvc-load-state'." - (let ((state-file (or state-file - (expand-file-name dvc-state-file-name - dvc-config-directory))) - (vars (or vars dvc-state-variables-list)) - v) - (if (not (file-exists-p (file-name-directory state-file))) - (make-directory (file-name-directory state-file) t)) - (save-excursion - (set-buffer (get-buffer-create " *dvc-state*")) - (erase-buffer) - (insert ";; Generated file. Do not edit!!!\n(setq\n") - (if pp - (while vars - (setq v (car vars) vars (cdr vars)) - (insert (format "%s\n'%s" - (symbol-name v) - (dvc-pp-to-string (symbol-value v))))) - (while vars - (setq v (car vars) vars (cdr vars)) - (insert (format " %s '%S\n" - (symbol-name v) - (symbol-value v))))) - (insert " )") - (write-region (point-min) (point-max) state-file)))) - -;;;###autoload -(defun dvc-load-state (&optional state-file) - "Load STATE-FILE (default `dvc-state-file-name`), i.e. evaluate its content." - (let ((state-file (or state-file - (expand-file-name dvc-state-file-name - dvc-config-directory)))) - (if (file-exists-p state-file) - (load state-file nil t t)))) - - -(provide 'dvc-state) - -;; Local Variables: -;; End: - -;;; dvc-state.el ends here diff --git a/dvc/lisp/dvc-status.el b/dvc/lisp/dvc-status.el deleted file mode 100644 index 35a7916..0000000 --- a/dvc/lisp/dvc-status.el +++ /dev/null @@ -1,249 +0,0 @@ -;;; dvc-status.el --- A generic status mode for DVC - -;; Copyright (C) 2007 - 2009, 2011 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 dvc-status buffer." - :type 'boolean - :group 'dvc) - -(defcustom dvc-status-display-ignored nil - "If non-nil, display files with 'ignored' status in dvc-status buffer." - :type 'boolean - :group 'dvc) - -(defvar dvc-status-mode-map - (let ((map (make-sparse-keymap))) - ;; grouped by major function, then alphabetical by dvc-keyvec name - ;; workspace operations - (define-key map dvc-keyvec-add 'dvc-fileinfo-add-files) - (define-key map dvc-keyvec-commit 'dvc-log-edit) - (define-key map [?=] 'dvc-diff-diff) - (define-key map "E" 'dvc-fileinfo-toggle-exclude) - (define-key map "\M-e" 'dvc-edit-exclude) - (define-key map dvc-keyvec-ediff 'dvc-status-ediff) - (define-key map dvc-keyvec-help 'describe-mode) - (define-key map dvc-keyvec-logs 'dvc-log) - (define-key map "l" 'dvc-diff-log-single) - (define-key map "R" 'dvc-fileinfo-rename) - (define-key map "t" 'dvc-fileinfo-add-log-entry) - (define-key map dvc-keyvec-mark 'dvc-fileinfo-mark-file) - (define-key map dvc-keyvec-mark-all 'dvc-fileinfo-mark-all) - (define-key map dvc-keyvec-next 'dvc-fileinfo-next) - (define-key map dvc-keyvec-previous 'dvc-fileinfo-prev) - (define-key map dvc-keyvec-quit 'dvc-buffer-quit) - (define-key map dvc-keyvec-refresh 'dvc-generic-refresh) - (define-key map dvc-keyvec-revert 'dvc-fileinfo-revert-files) - (define-key map dvc-keyvec-unmark 'dvc-fileinfo-unmark-file) - (define-key map dvc-keyvec-unmark-all 'dvc-fileinfo-unmark-all) - (define-key map [?i] 'dvc-fileinfo-ignore-files) - (define-key map [?I] 'dvc-ignore-file-extensions-in-dir) - (define-key map "\M-I" 'dvc-ignore-file-extensions) - (define-key map (dvc-prefix-tagging-method ?e) 'dvc-edit-ignore-files) - (define-key map [?k] 'dvc-fileinfo-kill) - (define-key map dvc-keyvec-remove 'dvc-fileinfo-remove-files) - (define-key map "\r" 'dvc-find-file-other-window) - (define-key map "\M-d" 'dvc-status-dtrt) - - ;; database operations - (define-key map (dvc-prefix-merge ?u) 'dvc-update) - (define-key map (dvc-prefix-merge ?m) 'dvc-missing) - (define-key map (dvc-prefix-merge ?M) 'dvc-merge) - - map) - "Keymap used in `dvc-status-mode'.") - -(easy-menu-define dvc-status-mode-menu dvc-status-mode-map - "`dvc-status' menu" - `("DVC" - ["Refresh Buffer" dvc-generic-refresh t] - ["Edit log before commit" dvc-log-edit t] - ["Quit" dvc-buffer-quit t] - ("Merge/Update" - ["Update" dvc-update t] - ["Show missing" dvc-missing t] - ["Merge" dvc-merge t] - ) - ("Mark" - ["Mark File" dvc-fileinfo-mark-file t] - ["Mark all" dvc-fileinfo-mark-all t] - ["Unmark File" dvc-fileinfo-unmark-file t] - ["Unmark all" dvc-fileinfo-unmark-all t] - ) - ("Ignore" - ["Ignore Files" dvc-fileinfo-ignore-files t] - ["Ignore Extensions in dir" dvc-ignore-file-extensions-in-dir t] - ["Ignore Extensions globally" dvc-ignore-file-extensions t] - ["Edit Ignore File" dvc-edit-ignore-files t] - ) - ("Exclude" - ["Exclude File" dvc-fileinfo-toggle-exclude t] - ["Edit Exclude File" dvc-edit-exclude t] - ) - ["Do the Right Thing" dvc-status-dtrt t] - ["Add File" dvc-fileinfo-add-files t] - ["Ediff File" dvc-status-ediff t] - ["diff File" dvc-diff-diff t] - ["Delete File" dvc-fileinfo-remove-files t] - ["Kill File" dvc-fileinfo-kill t] - ["Rename File" dvc-fileinfo-rename t] - ["Revert File" dvc-fileinfo-revert-files t] - ["Edit File" dvc-find-file-other-window t] - ["Add log entry" dvc-fileinfo-add-log-entry t] - ["Log (single file)" dvc-diff-log-single t] - ["Log (full tree)" dvc-log t] - )) - -;; "-status-mode", if defined, will be used instead of this -;; one. If so, it should be derived from dvc-status-mode (via -;; `define-derived-mode'), and rely on it for as many features as -;; possible (one can, for example, extend the menu and keymap). -;; Remember to add the new mode to uniquify-list-buffers-directory-modes -(define-derived-mode dvc-status-mode fundamental-mode "dvc-status" - "Major mode to display workspace status." - (setq dvc-buffer-current-active-dvc (dvc-current-active-dvc)) - (setq dvc-fileinfo-ewoc (ewoc-create 'dvc-fileinfo-printer)) - (set (make-local-variable 'dvc-get-file-info-at-point-function) 'dvc-fileinfo-current-file) - (use-local-map dvc-status-mode-map) - (easy-menu-add dvc-status-mode-menu) - (dvc-install-buffer-menu) - (setq buffer-read-only t) - (buffer-disable-undo) - (set-buffer-modified-p nil)) - -(when (boundp 'uniquify-list-buffers-directory-modes) - (add-to-list 'uniquify-list-buffers-directory-modes 'dvc-status-mode)) - -(defun dvc-status-prepare-buffer (dvc root base-revision branch header-more refresh) - "Prepare and return a status buffer. Should be called by -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) - (dvc-status-ediff)) - - (missing - ;; File is in database, but not in workspace - (ding) - (dvc-offer-choices (concat (dvc-fileinfo-current-file) " does not exist in working directory") - '((dvc-fileinfo-revert-files "revert") - (dvc-fileinfo-remove-files "remove") - (dvc-fileinfo-rename "rename")))) - - (modified - ;; Don't offer undo here; not a common action - ;; Assume user has started the commit log frame - (if (< 1 (length (dvc-fileinfo-marked-files))) - (error "cannot diff more than one file")) - (dvc-status-ediff)) - - (unknown - (dvc-offer-choices nil - '((dvc-fileinfo-add-files "add") - (dvc-fileinfo-ignore-files "ignore") - (dvc-fileinfo-remove-files "remove") - (dvc-fileinfo-rename "rename")))) - ))) - -(defun dvc-status-inventory-done (status-buffer) - (with-current-buffer status-buffer - (ewoc-enter-last dvc-fileinfo-ewoc (make-dvc-fileinfo-message :text "Parsing inventory...")) - (ewoc-refresh dvc-fileinfo-ewoc) - (dvc-redisplay) - ;; delete "running", "parsing" from the ewoc now, but don't - ;; refresh until the status is displayed - (dvc-fileinfo-delete-messages))) - -(defun dvc-status-ediff () - "Run ediff on the current workspace file, against the database version." - (interactive) - ;; FIXME: need user interface to specify other revision to diff - ;; against. At least BASE and HEAD. - (let ((dvc-temp-current-active-dvc dvc-buffer-current-active-dvc)) - (dvc-file-ediff (dvc-fileinfo-current-file)))) - -(provide 'dvc-status) -;;; end of file diff --git a/dvc/lisp/dvc-tips.el b/dvc/lisp/dvc-tips.el deleted file mode 100644 index abfe7fd..0000000 --- a/dvc/lisp/dvc-tips.el +++ /dev/null @@ -1,290 +0,0 @@ -;;; 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 deleted file mode 100644 index 9120642..0000000 --- a/dvc/lisp/dvc-ui.el +++ /dev/null @@ -1,506 +0,0 @@ -;;; 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 deleted file mode 100644 index 65182ee..0000000 --- a/dvc/lisp/dvc-unified.el +++ /dev/null @@ -1,677 +0,0 @@ -;;; dvc-unified.el --- The unification layer for dvc - -;; Copyright (C) 2005-2010 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: - -(condition-case nil - (require 'dired-x) - (error nil)) -(require 'ffap) -(require 'dvc-register) -(require 'dvc-core) -(require 'dvc-defs) -(require 'dvc-tips) -(require 'dvc-utils) - -;; -------------------------------------------------------------------------------- -;; unified functions -;; -------------------------------------------------------------------------------- - -;;;###autoload -(defun dvc-init () - "Initialize a new repository. -It currently supports the initialization for bzr, xhg, xgit, tla. -Note: this function is only useful when called interactively." - (interactive) - (when (interactive-p) - (let ((supported-variants (map t 'symbol-name dvc-registered-backends)) - (working-dir (dvc-uniquify-file-name default-directory)) - (dvc)) - ;; hide backends that don't provide an init function - (mapc '(lambda (elem) - (setq supported-variants (delete elem supported-variants))) - '("xdarcs" "xmtn" "baz")) - (add-to-list 'supported-variants "bzr-repo") - (setq dvc (intern (dvc-completing-read - (format "Init a repository for '%s', using dvc: " working-dir) - (sort supported-variants 'string-lessp)))) - (cond ((string= dvc "bzr-repo") - (call-interactively 'bzr-init-repository)) - (t - (funcall (dvc-function dvc "dvc-init") working-dir)))))) - -;;;###autoload -(defun dvc-add-files (&rest files) - "Add FILES to the currently active dvc. FILES is a list of -strings including path from root; interactive defaults -to (dvc-current-file-list)." - (interactive (dvc-current-file-list)) - (when (setq files (dvc-confirm-file-op "add" files dvc-confirm-add)) - (dvc-apply "dvc-add-files" files))) - -;;;###autoload -(defun dvc-revert-files (&rest files) - "Revert FILES for the currently active dvc." - (interactive (dvc-current-file-list)) - (when (setq files (dvc-confirm-file-op "revert" files t)) - (dvc-apply "dvc-revert-files" files))) - -;;;###autoload -(defun dvc-remove-files (&rest files) - "Remove FILES for the currently active dvc. -Return t if files removed, nil if not (due to user confirm or error)." - (interactive (dvc-current-file-list)) - (when (setq files (dvc-confirm-file-op "remove" files t)) - (dvc-apply "dvc-remove-files" files))) - -(defun dvc-remove-optional-args (spec &rest args) - "Process ARGS, removing those that come after the &optional keyword -in SPEC if they are nil, returning the result." - (let ((orig args) - new) - (if (not (catch 'found - (while (and spec args) - (if (eq (car spec) '&optional) - (throw 'found t) - (setq new (cons (car args) new) - args (cdr args) - spec (cdr spec)))) - nil)) - orig - ;; an &optional keyword was found: process it - (let ((acc (reverse args))) - (while (and acc (null (car acc))) - (setq acc (cdr acc))) - (when acc - (setq new (nconc acc new))) - (nreverse new))))) - -;;;###autoload -(defmacro define-dvc-unified-command (name args comment &optional interactive) - "Define a DVC unified command. &optional arguments are permitted, but -not &rest." - (declare (indent 2) - (debug (&define name lambda-list stringp - [&optional interactive]))) - `(defun ,name ,args - ,comment - ,@(when interactive (list interactive)) - (dvc-apply ,(symbol-name name) - (dvc-remove-optional-args ',args - ,@(remove '&optional args))))) - -;;;###autoload -(defun dvc-clone (&optional dvc source-path dest-path rev) - "Ask for the DVC to use and clone SOURCE-PATH." - (interactive "P") - (when (interactive-p) - (let* ((ffap-url-regexp - (concat - "\\`\\(" - "\\(ftp\\|https?\\|git\\|www\\)://" ; needs host - "\\)." ; require one more character - )) - (url-at-point (ffap-url-at-point)) - (all-candidates (map t 'symbol-name dvc-registered-backends)) - (git-is-candidate (re-search-backward "git clone .+" (line-beginning-position) t)) - (hg-is-candidate (re-search-backward "hg clone .+" (line-beginning-position) t)) - (bzr-is-candidate (re-search-backward "bzr get .+" (line-beginning-position) t))) - (setq dvc (intern (dvc-completing-read - "Clone, using dvc: " - all-candidates - nil t - (cond (git-is-candidate "xgit") - (bzr-is-candidate "bzr") - (hg-is-candidate "xhg") - (t nil))))) - (setq source-path (read-string (format "%S-clone from path: " dvc) url-at-point)) - (setq dest-path (expand-file-name (dvc-read-directory-name - (format "Destination Directory for %S-clone: " dvc) - nil nil nil ""))) - (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)) (not current-prefix-arg)))) - ;; Since we have bound default-directory, we don't need to pass - ;; `path' to the back-end. - (dvc-save-some-buffers default-directory) - (dvc-call "dvc-status")) - nil) - -(define-dvc-unified-command dvc-name-construct (back-end-revision) - "Returns a string representation of BACK-END-REVISION.") - -;;;###autoload -(defun dvc-log (&optional path last-n) - "Display the brief log for PATH (a file-name; default current -buffer file name; nil means entire tree; negative prefix arg -means prompt for tree depending on value of -dvc-read-project-tree-mode), LAST-N entries (default -`dvc-log-last-n'; all if nil, prefix value means that -many entries (absolute value)). Use `dvc-changelog' for the full log." - (interactive "i\nP") - (let* ((path (if (and last-n (< (prefix-numeric-value last-n) 0)) - nil (buffer-file-name))) - (last-n (if last-n - (abs (prefix-numeric-value last-n)) - dvc-log-last-n)) - (default-directory - (dvc-read-project-tree-maybe "DVC tree root (directory): " - (when path (expand-file-name path)) - path))) - ;; Since we have bound default-directory, we don't need to pass - ;; 'root' to the back-end. - (dvc-call "dvc-log" path last-n)) - nil) - -(defun dvc-apply-patch (patch-name) - "Apply patch `patch-name' on current-tree." - (interactive (list (read-from-minibuffer "Patch: " - nil nil nil nil - (dired-filename-at-point)))) - (let ((current-dvc (dvc-current-active-dvc))) - (case current-dvc - ('xgit (xgit-apply-patch patch-name)) - ('xhg (xhg-import patch-name)) - ;; TODO ==>Please add here appropriate commands for your backend - (t - (if (y-or-n-p (format "[%s] don't know how to apply patch, do you want to run a generic command instead?" - current-dvc)) - (shell-command (format "cat %s | patch -p1" patch-name)) - (message "I don't known yet how to patch on %s" current-dvc)))))) - -;;;###autoload -(define-dvc-unified-command dvc-changelog (&optional arg) - "Display the full changelog in this tree for the actual dvc. -Use `dvc-log' for the brief log." - (interactive)) - -;;;###autoload -(define-dvc-unified-command dvc-add (file) - "Adds FILE to the repository." - (interactive "fFile: ")) - -(define-dvc-unified-command dvc-revision-direct-ancestor (revision) - "Computes the direct ancestor of a revision.") - -(define-dvc-unified-command dvc-revision-nth-ancestor (revision n) - "Computes the direct ancestor of a revision.") - -(define-dvc-unified-command dvc-resolved (file) - "Mark FILE as resolved" - (interactive (list (buffer-file-name)))) - -;; Look at `xhg-ediff-file-at-rev' and `xhg-dvc-ediff-file-revisions' -;; to build backend functions. -(define-dvc-unified-command dvc-ediff-file-revisions () - "Ediff rev1 of file against rev2." - (interactive)) - -(defun dvc-rename (from-name to-name) - "Rename file FROM-NAME to TO-NAME; TO-NAME may be a directory. -When called non-interactively, if from-file-name does not exist, -but to-file-name does, just record the rename in the back-end" - ;; back-end function -dvc-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 deleted file mode 100644 index a8a7e56..0000000 --- a/dvc/lisp/dvc-utils.el +++ /dev/null @@ -1,826 +0,0 @@ -;;; dvc-utils.el --- Utility functions for DVC - -;; Copyright (C) 2005 - 2010 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 &optional resolve-symlinks) - "Return a string containing an absolute path to PATH, which is relative to `default-directory'. -If PATH is a directory,the returned contains one and exactly one trailing -slash. If PATH is nil, then nil is returned. -If RESOLVE-SYMLINKS is non-nil (default nil), resolve symlinks in path." - ;; We normally _don'_ want 'file-truename' here, since that - ;; eliminates symlinks. We assume the user has configured symlinks - ;; the way they want within the workspace, so the view from the - ;; current default directory is correct. - ;; - ;; This may cause problems with the path to the workspace root; - ;; `call-process' spawns the backend process with symlinks in the - ;; working directory expanded. Most backends get the workspace root - ;; from the working directory; if DVC passes the workspace root - ;; explicitly to the backend explicitly, it must resolve symlinks at - ;; that point. - ;; - ;; Another case is DVC status buffers (and similar buffers); we - ;; don't want to create two buffers to the same workspace with - ;; different paths. - ;; - ;; In these cases, set resolve-symlinks t at the call point. - (and path - (let ((expanded (expand-file-name - (if (file-directory-p path) - (file-name-as-directory path) - path)))) - (if resolve-symlinks - (setq expanded (file-truename expanded))) - (if (featurep 'xemacs) - (replace-regexp-in-string "/+$" "/" expanded) - expanded)))) - -(defun dvc-add-uniquify-directory-mode (mode) - "Add MODE to `uniquify-list-buffers-directory-modes'." - (require 'uniquify) - (when (boundp 'uniquify-list-buffers-directory-modes) - (add-to-list 'uniquify-list-buffers-directory-modes mode))) - -(defvar dvc-temp-directory "/tmp" - "Temporary directory for some DVC operations.") - -(defun dvc-make-temp-name (file) - "Generate a temporary file name based on FILE. -The path for the file name can be set via `dvc-temp-directory'." - (make-temp-name (concat (dvc-uniquify-file-name dvc-temp-directory) file))) - -(defun dvc-buffer-content (buffer) - "Return the content of BUFFER as a string. -Strips the final newline if there is one." - (with-current-buffer buffer - (buffer-substring-no-properties - (point-min) - (progn (goto-char (point-max)) - (if (eq (char-before) ?\n) - (- (point) 1) - (point)))))) - -;; this is no longer needed, because ewoc-create takes now the argument nosep: -;; (defun ewoc-create (pretty-printer &optional header footer nosep) -;; If you need that behaviour: set dvc-ewoc-create-needs-newline to t -(defvar dvc-ewoc-create-needs-newline nil) -(defun dvc-ewoc-create-api-select (pretty-printer) - "Possibly insert a trailing newline after PRETTY-PRINTER call. -Work around `ewoc-create' interface change: oldest versions automatically -added a trailing newline, whereas newest versions do not." - (if dvc-ewoc-create-needs-newline - ;; if `ewoc-set-data' is defined, the pretty printer should insert a - ;; trailing newline (new `ewoc-create' interface; there is no - ;; `ewoc-version', therefore we test on `ewoc-set-data') - `(lambda (elem) (,pretty-printer elem) (insert "\n")) - pretty-printer)) - -;; ---------------------------------------------------------------------------- -;; Face manipulators -;; ---------------------------------------------------------------------------- -(defsubst dvc-face-add (str face &optional keymap menu help) - "Add to string STR the face FACE. -Optionally, also add the text properties KEYMAP, MENU and HELP. - -If KEYMAP is a symbol, (symbol-value KEYMAP) is used -as a keymap; and `substitute-command-keys' result -against (format \"\\{%s}\" (symbol-name keymap)) is appended to HELP. - -If HELP is nil and if MENU is non nil, the MENU title is used as HELP." - (if dvc-highlight - (let* ((strcpy (copy-sequence str)) - (key-help (when (symbolp keymap) - (substitute-command-keys (format "\\{%s}" (symbol-name keymap))))) - (prefix-help (if help help (when (and menu (stringp (cadr menu))) (cadr menu)))) - (long-help (if key-help - (if prefix-help (concat prefix-help "\n" - ;; Sigh. Font used on tooltips in GNU Emacs with Gtk+ - ;; is a proportional. - ;; (make-string (length help) ?=) "\n" - "================" "\n" - key-help) key-help) - help)) - (keymap (if (symbolp keymap) (symbol-value keymap) keymap))) - (add-text-properties 0 (length strcpy) - `(face ,face -;;; Even if we define a face in a buffer, it seems that -;;; font-lock mode just ignore it or remove the face property. -;;; I don't know the detail but in tla-inventory buffer, -;;; I cannot make both font-lock keywords and faces put by dvc-face-add -;;; highlight at once. When font-lock-face is defined, I can do. -;;; See "Special Properties" subsection in the emacs lisp reference manual. -;;; `font-lock-face' property is new in Emacs 21.4. However, I guess there is -;;; no wrong side effect if I define font-lock-face property here. - font-lock-face ,face - ,@(when keymap - `(mouse-face highlight - keymap ,keymap - help-echo ,long-help)) - ,@(when menu - `(dvc-cmenu ,menu)) - ) - strcpy) - strcpy) - str)) - -(defun dvc-face-add-with-condition (condition text face1 face2) - "If CONDITION then add TEXT the face FACE1, else add FACE2." - (if condition - (dvc-face-add text face1) - (dvc-face-add text face2))) - -(defun dvc-flash-line-on () - "Turn on highline mode or equivalent." - (or (dvc-funcall-if-exists hl-line-mode) - (dvc-funcall-if-exists highline-on))) - -(defun dvc-flash-line-off () - "Turn off highline mode or equivalent." - (or (dvc-funcall-if-exists hl-line-mode) - (dvc-funcall-if-exists highline-off))) - -(defun dvc-flash-line () - "Flash the current line." - (let ((buffer (current-buffer))) - (dvc-flash-line-on) - (sit-for 1000) - ;; Avoid to switching buffer by asynchronously running - ;; processes. - ;; TODO: This is adhoc solution. Something guard-mechanism to avoid - ;; buffer switching may be needed. - (set-buffer buffer) - (dvc-flash-line-off))) - -;; ---------------------------------------------------------------------------- -;; Debugging facilities -;; ---------------------------------------------------------------------------- -(defvar dvc-debug nil - "*Indicate whether debugging messages should be printed by `dvc-trace'.") - -;;;###autoload -(defun dvc-trace (&rest msg) - "Display the trace message MSG. -Same as `message' if `dvc-debug' is non-nil. -Does nothing otherwise. Please use it for your debug messages." - (when dvc-debug - (apply 'message (concat "dvc: " (car msg)) (cdr msg)))) - -(defun dvc-trace-current-line () - "Display the line the cursor is in." - (dvc-trace "Current-line(%s)=%s[_]%s" - (save-restriction (widen) (dvc-line-number-at-pos)) - (buffer-substring-no-properties - (line-beginning-position) - (point)) - (buffer-substring-no-properties - (point) - (line-end-position)))) - -(defmacro dvc-features-list () - "Topological sort of the dependancy graph. Root comes last. - -It's a macro so that it remains available after (unload-feature ...)." - (quote '( - ;; DVC - dvc-site - dvc-version - dvc-tips - dvc-buffers - dvc-core - dvc-defs - dvc-diff - dvc-emacs - dvc-lisp - dvc-revlog - dvc-revlist - dvc-log - dvc-register - dvc-ui - dvc-unified - dvc-utils - dvc-xemacs - ;; xhg - xhg-core - xhg-dvc - xhg-gnus - xhg - ;; tla - tla-dvc - tla-bconfig - tla-browse - tla-tests - tla - tla-core - tla-autoconf - tla-defs - tla-gnus - ;; baz - baz-dvc - baz - ;; bzr - bzr-core - bzr-dvc - bzr-revlist - bzr-revision - bzr - ;; xgit - xgit-annotate - xgit-dvc - xgit-gnus - xgit-log - xgit-revision - xgit-core - xgit - ))) - -(defun dvc-unload () - "Unloads DVC. - -run `unload-feature' for each DVC feature. - -TODO: should also remove the hooks setup by DVC -\(`file-find-hook', ...)." - (interactive) - (dolist (feature (dvc-features-list)) - (when (featurep feature) (unload-feature feature t))) - (when (featurep 'dvc-autoloads) - (unload-feature 'dvc-autoloads t))) - -;;;###autoload -(defun dvc-reload (&optional directory) - "Reload DVC (usually for debugging purpose). - -With prefix arg, prompts for the DIRECTORY in which DVC should be -loaded. Useful to switch from one branch to the other. - -If a Makefile is present in the directory where DVC is to be loaded, -run \"make\"." - (interactive - (list (when current-prefix-arg - (let* ((other (dvc-read-directory-name - "Load DVC from: ")) - (lispdir (concat (file-name-as-directory other) - "lisp"))) - (if (file-directory-p lispdir) - lispdir - other))))) - (when directory - (let ((current-path (file-name-directory (locate-library - "dvc-core")))) - (setq load-path - (cons directory (remove current-path load-path))))) - (let ((default-directory (file-name-directory (locate-library "dvc-core")))) - (when (file-exists-p - "Makefile") - (shell-command "make"))) - (dvc-unload) - (require 'dvc-autoloads)) - -(defun dvc-regexp-quote (string) - "Return a regexp string which matches exactly STRING and nothing else. -Special characters are escaped to leave STRING in a suitable form for -Arch." - (let ((quoted (regexp-quote string))) - (replace-regexp-in-string - "\\([{}()|]\\)" - (concat "\\\\" ; leading slash - "\\1") ; quoted character - quoted))) - -(defun dvc-pp-to-string (sexp) - "Return sexp pretty printed by `pp-to-string'." - (let ((print-readably t) - print-level print-length) - (pp-to-string sexp))) - -(defvar dvc-buffer-refresh-function nil - "Variable should be local to each buffer. -Function used to refresh the current buffer") -(make-variable-buffer-local 'dvc-buffer-refresh-function) - -(defun dvc-read-project-tree-maybe (&optional prompt directory prefer-current) - "Return a directory name which is the root of some project tree. -Either prompt from the user or use the current directory. -The behavior can be changed according to the value of -`dvc-read-project-tree-mode'. - -PROMPT is used as a user prompt, and DIRECTORY is the starting point -of the project search. - -When `dvc-read-project-tree-mode' is `unless-specified', -PREFER-CURRENT non-nil means use current `default-directory' if -it is a valid project tree." - (let* ((root (dvc-tree-root (or directory default-directory) t)) - (default-directory (or root - directory - default-directory)) - (prompt (or prompt "Use directory: "))) - (case dvc-read-project-tree-mode - (always (dvc-tree-root (dvc-read-directory-name prompt))) - - (unless-specified - (if (or directory (and prefer-current root)) - (if root - root - (dvc-read-directory-name prompt)) - (dvc-read-directory-name prompt))) - - (sometimes (or root - (dvc-tree-root (dvc-read-directory-name prompt)))) - - (never (or root - (error "%s directory is not a DVC managed directory" directory))) - - (t (error "`%s': wrong value for dvc-read-project-tree-mode" dvc-read-project-tree-mode))))) - -(defun dvc-generic-refresh () - "Call the function specified by `dvc-buffer-refresh-function'." - (interactive) - (let ((dvc-read-directory-mode 'never) - (dvc-read-project-tree-mode 'never)) - (if dvc-buffer-refresh-function - (let ((dvc-temp-current-active-dvc dvc-buffer-current-active-dvc)) - (funcall dvc-buffer-refresh-function)) - (message "I don't know how to refresh this buffer")))) - -(defmacro dvc-make-move-fn (ewoc-direction function cookie - &optional only-unmerged) - "Create function to move up or down in `dvc-revlist-cookie'. - -EWOC-DIRECTION is either `ewoc-next' or `ewoc-prev'. -FUNCTION is the name of the function to declare. -COOKIE is the ewoc to navigate in. -if ONLY-UNMERGED is non-nil, then, navigate only through revisions not -merged by another revision in the same list." - (declare (indent 2) (debug (&define functionp name symbolp booleanp))) - `(defun ,function () - (interactive) - (let* ((elem (ewoc-locate ,cookie)) - (next (or (,ewoc-direction ,cookie elem) elem))) - (while (and next - (if ,only-unmerged - (not (and (eq (car (ewoc-data next)) - 'entry-patch) - (eq (nth 4 (ewoc-data next)) - 'nobody))) - (eq (car (ewoc-data next)) 'separator)) - (,ewoc-direction ,cookie next)) - (setq next (,ewoc-direction ,cookie next))) - (while (and next - (if ,only-unmerged - (not (and (eq (car (ewoc-data next)) - 'entry-patch) - (eq (nth 4 (ewoc-data next)) - 'nobody))) - (eq (car (ewoc-data next)) 'separator))) - (setq next (,(if (eq ewoc-direction 'ewoc-next) - 'ewoc-prev - 'ewoc-next) ,cookie next))) - (when next (goto-char (ewoc-location next)))))) - -(defun dvc-ewoc-maybe-scroll (ewoc node) - "If display of NODE goes off the bottom of the window, recenter." - (let* ((next-node (ewoc-next ewoc node)) - (next-loc (if next-node - (ewoc-location next-node) - (ewoc-location (ewoc--footer ewoc))))) - (if (> next-loc (window-end)) - ;; we tried scroll-up here, but it screws up sometimes - (recenter)) - )) - -(defmacro dvc-make-ewoc-next (function-name ewoc) - "Declare a function FUNCTION-NAME to move to the next EWOC entry." - (declare (indent 2) (debug (&define functionp function-name symbolp))) - `(defun ,function-name (&optional filter no-ding) - (interactive) - "Move to the next ewoc entry. -If optional FILTER is non-nil, skip elements for which FILTER -returns non-nil. FILTER is called with one argument, the ewoc -element. If optional NO-DING, don't ding if there is no next." - (let ((current (ewoc-locate ,ewoc))) - (if current - (let ((cur-location (ewoc-location current)) - (next (ewoc-next ,ewoc current))) - (cond - ((> cur-location (point)) - ;; not exactly at an element; move there - (goto-char cur-location) - (dvc-ewoc-maybe-scroll ,ewoc current)) - - (next - (if filter - (progn - (while (and next - (funcall filter next)) - (setq next (ewoc-next ,ewoc next))) - (if next - (goto-char (ewoc-location next)) - (unless no-ding (ding)))) - (goto-char (ewoc-location next)) - (dvc-ewoc-maybe-scroll ,ewoc next))) - - (t - ;; at last element - (unless no-ding (ding))))) - ;; no elements - (unless no-ding (ding)))))) - -(defmacro dvc-make-ewoc-prev (function-name ewoc) - "Declare a function FUNCTION-NAME to move to the previous EWOC entry." - (declare (indent 2) (debug (&define functionp function-name symbolp))) - `(defun ,function-name (&optional filter no-ding) - "Move to the previous ewoc entry. -If optional FILTER is non-nil, skip elements for which FILTER -returns non-nil. FILTER is called with one argument, the ewoc -element. If optional NO-DING, don't ding if there is no next." - (interactive) - (let ((current (ewoc-locate ,ewoc))) - (if current - (let ((cur-location (ewoc-location current)) - (prev (ewoc-prev ,ewoc current))) - (cond - ((> (point) cur-location) - (goto-char cur-location)) - - (prev - (if filter - (progn - (while (and prev - (funcall filter prev)) - (setq prev (ewoc-prev ,ewoc prev))) - (if prev - (goto-char (ewoc-location prev)) - (unless no-ding (ding)))) - (goto-char (ewoc-location prev)))) - - (t - ;; at first element - (unless no-ding (ding))))) - ;; no elements - (unless no-ding (ding)))))) - -(defun dvc-scroll-maybe (buffer up-or-down) - "If BUFFER exists, show it, scroll and return non-nil. -Otherwise, return nil." - (interactive) - (when (buffer-live-p buffer) - (let ((visible (dvc-buffer-visible-p buffer)) - (buf (current-buffer))) - (pop-to-buffer buffer) - (when visible - (condition-case nil - (funcall up-or-down 2) - (error (message "Can't scroll anymore.")))) - (pop-to-buffer buf)))) - -(defun dvc-offer-choices (comment choices) - "Present user with a choice of actions, labeled by COMMENT. CHOICES is a list of pairs -containing (symbol description)." - ;; Could use "keyboard menu"; see elisp info 22.17.3 Menus and the Keyboard - (let ((msg "use ") - choice) - (dolist (choice choices) - (setq msg (concat msg - (key-description (car (where-is-internal (car choice)))) - " (" (cadr choice) ") "))) - (error (if comment - (concat comment "; " msg) - msg)))) - -(defun dvc-completing-read (&rest args) - "Read a string in the minibuffer, with completion. -Set `dvc-completing-read-function' to determine which function to use. - -See `completing-read' for a description of ARGS." - ;; Initialize dvc-completing-read-function on the first invocation of dvc-completing-read - ;; This allows to enable ido-mode after loading DVC - (when (eq dvc-completing-read-function 'auto) - (setq dvc-completing-read-function (if (and (boundp 'ido-mode) ido-mode) - 'ido-completing-read - 'completing-read))) - (apply dvc-completing-read-function args)) - -(defun dvc-default-excluded-files () - "Return a list of strings (normally file names relative to tree -root) from the file \".dvc-exclude\" in `default-directory'. -Shell wildcards are converted to regexp, for use with -`dvc-match-excluded'." - (if (file-readable-p ".dvc-exclude") - (with-temp-buffer - (insert-file-contents ".dvc-exclude") - (let (result) - (while (< (point) (point-max)) - (setq result (append result (list (wildcard-to-regexp (buffer-substring (point) (point-at-eol)))))) - (forward-line 1)) - result)))) - -(defun dvc-match-excluded (excluded-files file) - "Non-nil if any element of EXCLUDED-FILES matches FILE, -according to `string-match'." - (let (matched) - (dolist (file-regexp excluded-files matched) - (setq matched - (or matched - (string-match file-regexp file)))) - (not (null matched)))) - -(defun dvc-edit-exclude () - "Edit the file \".dvc-exclude\" in `default-directory'." - (interactive) - (find-file ".dvc-exclude")) - -(defsubst dvc-xor (a b) - (or (and a (not b)) (and (not a) b))) - -(defun dvc-message-replace-header (header new-value &optional after force) - "Remove HEADER and insert the NEW-VALUE. -If AFTER, insert after this header. If FORCE, insert new field -even if NEW-VALUE is empty." - ;; Similar to `nnheader-replace-header' but for message buffers. - (require 'message) - (save-excursion - (save-restriction - (message-narrow-to-headers) - (message-remove-header header)) - (when (or force (> (length new-value) 0)) - (if after - (message-position-on-field header after) - (message-position-on-field header)) - (insert new-value)))) - -(provide 'dvc-utils) -;;; dvc-utils.el ends here diff --git a/dvc/lisp/dvc-xemacs.el b/dvc/lisp/dvc-xemacs.el deleted file mode 100644 index f8bf2a8..0000000 --- a/dvc/lisp/dvc-xemacs.el +++ /dev/null @@ -1,426 +0,0 @@ -;;; dvc-xemacs.el --- Compatibility stuff for XEmacs -;;; -;;; This file should be loaded when using XEmacs; load -;;; dvc-emacs.el when using Gnu Emacs. - -;; Copyright (C) 2004-2006, 2008 by all contributors - -;; Author: Robert Widhopf-Fenk - -;; 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 deleted file mode 100644 index d4247fe..0000000 --- a/dvc/lisp/tests/bzr-tests.el +++ /dev/null @@ -1,136 +0,0 @@ -;;; bzr-tests.el --- Automated regression tests for bzr - -;; Copyright (C) 2007, 2008 Stephen Leake - -;; Author: Stephen Leake - -;; adapted from xmtn-tests.el - -;; This file is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2 of the License, or -;; (at your option) any later version. -;; -;; This file is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this file; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, -;; Boston, MA 02110-1301 USA. - -;;; Commentary: - -;; Automated regression tests for bzr-dvc. - -;;; Code: - -;; These tests require elunit.el from dvc/lisp/contrib, originally -;; from http://dev.technomancy.us/phil/wiki/ElUnit - -(require 'bzr-dvc) -(require 'cl) -(require 'dvc-tests-utils "tests/dvc-tests-utils.el") -(require 'elunit) - -;;; This is preferable over separate set-up and tear-down functions -;;; since it allows us to make use of `unwind-protect' and dynamic -;;; bindings. - -(defun bzr-tests--call-with-test-environment (bzr--body) - "Initialize a bzr workspace, call BODY" - (lexical-let ((body bzr--body) - (temp-dir nil)) - (unwind-protect - (progn - (setq temp-dir (file-name-as-directory (make-temp-file "bzr-tests-" t))) - (let ((default-directory temp-dir)) - (dvc-run-dvc-sync 'bzr '("init")) - (funcall body) - (dvc-tests-wait-async))) - (if temp-dir - ;; If this delete doesn't succeed, there is a real problem, - ;; so we don't try to handle the error. - (dired-delete-file temp-dir 'always))))) - -(defun bzr-tests--call-with-test-history (bzr--body) - "Create a test environment with one file with some change -history. Call BODY with one key arg :file-name; the file name of -the test file." - (lexical-let ((body bzr--body)) - (bzr-tests--call-with-test-environment - (function* - (lambda () - (lexical-let ((file-name "file-1")) - (with-temp-file file-name (insert "a\n")) - (bzr-add file-name) - (dvc-run-dvc-sync 'bzr '("commit" "--message" "\"commit 1\"")) - (with-temp-file file-name (insert "b\n")) - (dvc-run-dvc-sync 'bzr '("commit" "--message" "\"commit 2\"")) - (funcall body - :file-name file-name))))))) - -(defmacro* bzr-tests--with-test-environment ((&rest keys) &body body) - (declare (indent 1) (debug sexp body)) - `(bzr-tests--call-with-test-environment (function* (lambda (,@keys) ,@body)))) - -(defmacro* bzr-tests--with-test-history ((&rest keys) &body body) - (declare (indent 1) (debug sexp body)) - `(bzr-tests--call-with-test-history (function* (lambda (,@keys) ,@body)))) - - -(defsuite bzr - (log - (save-window-excursion - (bzr-tests--with-test-history (&key &allow-other-keys) - ;; The test is simply that this doesn't crash. - (dvc-log) - (dvc-tests-wait-async) ; let log display - (dvc-revlist-show-item)))) - - (file-diff - ;; The test is simply that this doesn't crash. - (save-window-excursion - (bzr-tests--with-test-history (&key file-name &allow-other-keys) - (find-file file-name) - (unwind-protect - (progn - (insert "x") - (save-excursion - (call-interactively #'dvc-file-diff))) - (revert-buffer t t))))) - - (diff - ;; The test is simply that this doesn't crash. - (save-window-excursion - (bzr-tests--with-test-history (&key file-name &allow-other-keys) - (find-file file-name) - (insert "x") - (write-file file-name) - (call-interactively #'dvc-diff)))) - - (diff-from-revlog - ;; The test is simply that this doesn't crash. - (save-window-excursion - (bzr-tests--with-test-history (&key &allow-other-keys) - (dvc-changelog) - (dvc-tests-wait-async) ; let log display - (dvc-revision-next) - (dvc-revlist-diff)))) - - ) -;;(elunit "bzr") - -(defsuite bzr-one - (log - (save-window-excursion - (bzr-tests--with-test-history - (&key &allow-other-keys) - (dvc-diff)))) - ) -;;(elunit "bzr-one") - -(provide 'bzr-tests) -;;; bzr-tests.el ends here diff --git a/dvc/lisp/tests/dvc-tests-utils.el b/dvc/lisp/tests/dvc-tests-utils.el deleted file mode 100644 index 6544e4d..0000000 --- a/dvc/lisp/tests/dvc-tests-utils.el +++ /dev/null @@ -1,43 +0,0 @@ -;;; dvc-tests-utils.el --- Utilities for automated regression tests - -;; Copyright (C) 2007 Stephen Leake - -;; Author: Stephen Leake - -;; This file is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2 of the License, or -;; (at your option) any later version. -;; -;; This file is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this file; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, -;; Boston, MA 02110-1301 USA. - -(eval-and-compile - (require 'cl)) - -(defun dvc-tests-wait-async () - "Waits for all asynchronous dvc processes to terminate." - (let* ((delay 0.2) - (seconds-before-message 2) - (iterations-before-message (/ seconds-before-message delay)) - (iterations 0)) - (while dvc-process-running - (when (>= iterations iterations-before-message) - (setq iterations 0) - (message "Waiting for processes: %S" - (mapcar (lambda (entry) - (dvc-event-command (second entry))) - dvc-process-running))) - (incf iterations-before-message) - (sit-for delay)))) - -(provide 'dvc-tests-utils) - -;; end of file diff --git a/dvc/lisp/tests/xmtn-tests.el b/dvc/lisp/tests/xmtn-tests.el deleted file mode 100644 index db8a44b..0000000 --- a/dvc/lisp/tests/xmtn-tests.el +++ /dev/null @@ -1,657 +0,0 @@ -;;; xmtn-tests.el --- Automated regression tests for xmtn - -;; Copyright (C) 2006, 2007 Christian M. Ohler - -;; Author: Christian M. Ohler - -;; This file is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2 of the License, or -;; (at your option) any later version. -;; -;; This file is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this file; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, -;; Boston, MA 02110-1301 USA. - -;;; Commentary: - -;; Automated regression tests for xmtn. - -;;; Code: - -;;; There are some notes on the design of xmtn in -;;; docs/xmtn-readme.txt. - -;; These tests require elunit.el from -;; http://dev.technomancy.us/phil/wiki/ElUnit . - -(eval-and-compile - (require 'cl) - (require 'elunit) - (require 'elp) ;; elp-elapsed-time is a 'defsubst', so we require elp at load time, not run time. - (require 'xmtn-match) - (require 'xmtn-dvc) - (require 'dvc-tests-utils "tests/dvc-tests-utils.el")) - -(defun xmtn-tests--keypair-string () - "[keypair xmtn-test] -MIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQDFE8/sRvdvN5+F5aFVpXeJpz0eKAzhYdWB -uW3L0C1tWnLk+HzYV13ewKMtFzwkoTeITTX5q372zH2XSIcUR2jBCArQf8Ru40886nLwG7zU -G1cI3B86akQknDUn3t9C1jEHXlBJiPLwaWrcmMFhoA+PnE49gopudw4q6Yhg1YCOqwIDAQAB# -MIICyTBDBgkqhkiG9w0BBQ0wNjAeBgkqhkiG9w0BBQwwEQQIccoCNMR2fIYCAggAAgEYMBQG -CCqGSIb3DQMHBAgjnJz0whELeQSCAoDEzuBbQf7hf43ULUZR7gFBrXilg+KBgItlA0Mz6jmI -0+LzoHhJiU3rnyR1MsXkf7uCBFje5Uqj53vUrnrBbxgGBFHwOw1Kic+lbDtvAKlNLPPPl9h8 -W9QrQYhEg9VsmYBUvxZnyw5Kmafpmh1wC/fRSchDmWyhUeJHtkZhnUgcG9OFi6z8JT64/VGw -ZhB46Q2dGLrygjHRArA8FIOX5dlGzyRNfa0w5dVWZED7IcQVCoBLwLiEb9woK+fyEuK12fM+ -23U8/sAO74MMOoyvs+OoloPtgniHuRdc/1RV9CS9k64mnzJdOnhR/GxQIL36LZcNrHvnM9Nn -xrK2yDkuk39JcLDJlFPZok7vluEn1GCKKGce3Z2LP6VPTJAqBHgt1fTMBAT5bc7rbVQxzVEU -56anNOMR1T9MRnbX5u5Hpj5mNIqbWX+g3YCIgKIJXbtD57GixPP4s/mP2EcAAeZvWiGeTF6Z -GyNq8USmlEjXpMrIWqLk+f6OzDyvk05sTQByRlKwOGzgbyNnWsetKC97wFfsBExNKhKeFFTV -6HOehUEPHIrikNaLed52czpqaKcQ67uVfdWXs3drwS7V0RRtTdcAzy0u95bERPrRpCY3tq/a -CGp3K4RF00eJQLBa94D9LYIEMBk4evfKCijcId0b4kzIQS1SI1sytnt+P1zPQaV5yAetOOD/ -fuHfnYU27Mqis5V23xo1ibjDS1fa3/E6XK2P+Y3rHuyjQ/QbFlcBwj0vjv8yqwRWOe5y6Msd -f6S7jhNd76i/o3K/DmnpnI1N8RODAd77uejpe8K0xthzk2q02VtrBXA7jpY7oSaIaKJPov6v -YPFoLxe1V5oOyoe3ap0H -[end]") - -(defun xmtn-tests--default-rc-file () - ;; Monotone versions up to and including 0.33 don't allow empty - ;; passphrases. - "function get_passphrase(keypair_id) return \"a\" end") - -;;; This is preferable over seperate set-up and tear-down functions -;;; since it allows us to make use of `unwind-protect' and dynamic -;;; bindings. - -(defun xmtn-tests--call-with-test-environment (xmtn--body) - (lexical-let ((body xmtn--body)) - (lexical-let ((temp-dir nil)) - (unwind-protect - (progn - (setq temp-dir (file-name-as-directory - (xmtn--make-temp-file "xmtn-tests-" t))) - (lexical-let ((key-dir (concat temp-dir "keys/")) - (rc-file (concat temp-dir "rc"))) - (let* ((default-directory temp-dir) - (dvc-test-mode t) - (xmtn-additional-arguments - `("--db" ,(concat temp-dir "a.mtn") - "--keydir" ,key-dir - "--norc" - "--rcfile" ,rc-file))) - (make-directory key-dir) - (with-temp-file (concat key-dir "xmtn-tests") - (insert (xmtn-tests--keypair-string) ?\n)) - (with-temp-file rc-file - (insert (xmtn-tests--default-rc-file) ?\n)) - (xmtn--run-command-sync nil '("db" "init")) - (xmtn--run-command-sync nil '("setup" - "--branch" "invalid.xmtn-tests" - "workspace")) - (let ((default-directory (concat temp-dir "workspace/"))) - (funcall body - :root default-directory))))) - (when temp-dir - (dired-delete-file temp-dir 'always)))))) - -(defun xmtn-tests--call-with-test-history (xmtn--body) - (lexical-let ((body xmtn--body)) - (xmtn-tests--call-with-test-environment - (function* - (lambda (&key ((:root xmtn--root))) - (lexical-let ((root xmtn--root) - (file-name "file-1") - revision-1 - revision-2) - (with-temp-file file-name (insert "a\n")) - (xmtn--add-files root (list file-name)) - (xmtn--run-command-sync root `("commit" "--message=commit 1")) - (setq revision-1 (xmtn--get-base-revision-hash-id root)) - (with-temp-file file-name (insert "b\n")) - (xmtn--run-command-sync root `("commit" "--message=commit 2")) - (setq revision-2 (xmtn--get-base-revision-hash-id root)) - (funcall body - :root root - :file-name file-name - :revision-1 revision-1 - :revision-2 revision-2))))))) - -(defmacro* xmtn-tests--with-test-environment ((&rest keys) &body body) - (declare (indent 1) (debug (sexp body))) - `(xmtn-tests--call-with-test-environment (function* (lambda (,@keys) ,@body)))) - -(defmacro* xmtn-tests--with-test-history ((&rest keys) &body body) - (declare (indent 1) (debug (sexp body))) - `(xmtn-tests--call-with-test-history (function* (lambda (,@keys) ,@body)))) - - -(defsuite xmtn - (xmtn--match - (progn - (assert (xmtn-match--match-variable-p '$x ?$)) - (assert (xmtn-match--match-variable-p '@x ?@)) - (assert (not (xmtn-match--match-variable-p "$x" ?$))) - (assert (not (xmtn-match--match-variable-p 'x ?$))) - (assert (xmtn-match--contains-match-variable-p '$x ?$)) - (assert (xmtn-match--contains-match-variable-p '(a b $x c) ?$)) - (assert (xmtn-match--contains-match-variable-p '[a $y $z c] ?$)) - (assert (xmtn-match--contains-match-variable-p '(nil . $y) ?$)) - (assert (xmtn-match--contains-match-variable-p '((() $a)) ?$)) - (assert (not (xmtn-match--contains-match-variable-p 'x ?$))) - (assert (not (xmtn-match--contains-match-variable-p '(a . b) ?$))) - (assert (not (xmtn-match--contains-match-variable-p nil ?$))) - (assert (not (xmtn-match--contains-match-variable-p '((() ())) ?$))) - (assert (not (xmtn-match--contains-match-variable-p nil ?$))) - (assert (equal (xmtn-match '(a b) - (($y $y) nil) - ($z z)) - '(a b))) - (assert (equal (xmtn-match '(a a) - (($y $y) y)) - 'a)) - (assert (equal (xmtn-match '(a b) - ($z z) - ($z nil)) - '(a b))) - (assert (xmtn-match nil ([t $y] y) ($z t))) - (assert (xmtn-match [foo bar] ([foo $y] y))) - (assert (xmtn-match [foo bar] ((a . b) nil) ([foo bar] t))) - (assert (xmtn-match nil (nil t))))) - (xmtn--version-case - (flet ((xmtn--latest-mtn-release () ;flet has dynamic scope in Emacs Lisp - '(2 5 "y"))) - (let* ((xmtn-executable 'xmtn-dummy) - (xmtn--*command-version-cached-for-executable* xmtn-executable)) - (let ((xmtn--*cached-command-version* '(2 5 "x"))) - (assert - (xmtn--version-case - ((and (= 2 5) (>= 2 5) (or (= 2 4) (<= 3 0)) - (<= 2 6) (/= 1 5) (not (/= 2 5)) - (not (>= 2 6)) - (not (<= 2 4)) - (not (< 2 5)) - (not (< 2 4))) t) - (t nil))) - (assert - (not (ignore-errors - (xmtn--version-case - (nil t))))) - (assert (xmtn--version-case ((mainline> 2 4) t) (t nil))) - (assert (xmtn--version-case ((mainline> 2 5) t) (t nil))) - (assert (xmtn--version-case ((mainline> 2 6) nil) (t t)))) - (let ((xmtn--*cached-command-version* '(2 5 "y"))) - (assert (xmtn--version-case ((mainline> 2 4) t) (t nil))) - (assert (xmtn--version-case ((mainline> 2 5) nil) (t t))) - (assert (xmtn--version-case ((mainline> 2 6) nil) (t t)))) - (let ((xmtn--*cached-command-version* '(1 5 "w"))) - (assert (xmtn--version-case ((mainline> 2 4) nil) (t t))) - (assert (xmtn--version-case ((mainline> 2 5) nil) (t t))) - (assert (xmtn--version-case ((mainline> 1 4) t) (t nil))) - (assert (xmtn--version-case ((mainline> 1 5) nil) (t t)))) - (let ((xmtn--*cached-command-version* '(2 6 "z"))) - (assert (xmtn--version-case ((mainline> 2 4) t) (t nil))) - (assert (xmtn--version-case ((mainline> 2 5) t) (t nil))) - (assert (xmtn--version-case ((mainline> 2 6) nil) (t t))))))) - (log - (save-window-excursion - (xmtn-tests--with-test-history (&key &allow-other-keys) - ;; The test is simply that this doesn't crash. - (dvc-log) - (dvc-revlist-show-item)))) - (file-diff - ;; The test is simply that this doesn't crash. - (save-window-excursion - (xmtn-tests--with-test-history (&key file-name &allow-other-keys) - (find-file file-name) - (unwind-protect - (progn - (insert "x") - (save-excursion - (call-interactively #'dvc-file-diff))) - (revert-buffer t t))))) - (diff - ;; The test is simply that this doesn't crash. - (save-window-excursion - (xmtn-tests--with-test-history (&key file-name &allow-other-keys) - (find-file file-name) - (let ((buffer (current-buffer))) - (unwind-protect - (progn - (insert "x") - (write-region (point-min) (point-max) - file-name nil 'no-message nil nil) - (set-buffer-modified-p nil) - (call-interactively #'dvc-diff)) - (dvc-tests-wait-async) - (with-current-buffer buffer - (set-buffer-modified-p nil) - (kill-buffer buffer))))))) - (automate-buffer-numbering - (xmtn-tests--with-test-history (&key root &allow-other-keys) - (xmtn-automate-with-session (session root) - (xmtn-automate-with-command (handle-1 session '("graph") :may-kill-p t) - (sleep-for 0.5) - (xmtn-automate-terminate-processes-in-root root) - (xmtn-automate-with-command (handle-2 session '("graph") - :may-kill-p nil) - (assert (not (equal (xmtn-automate-command-buffer handle-1) - (xmtn-automate-command-buffer handle-2)))) - (xmtn-automate-command-wait-until-finished handle-2)))))) - (automate-several-commands - (xmtn-tests--with-test-history (&key root &allow-other-keys) - ;; The test is simply that this doesn't crash. - (xmtn-automate-with-session (session root) - (xmtn-automate-with-command (cmd session '("graph") :may-kill-p nil)) - (xmtn-automate-with-command (cmd session '("graph") :may-kill-p nil)) - (xmtn-automate-with-command (cmd session '("graph") :may-kill-p nil)) - (xmtn-automate-with-command (cmd session '("graph") :may-kill-p nil)) - (xmtn-automate-with-command (cmd session '("graph") :may-kill-p t)) - (xmtn-automate-with-command (cmd session '("graph") :may-kill-p t) - ;;(xmtn-automate-command-wait-until-finished cmd) - )) - ;; Try to delay deletion of our temp workspace until process has - ;; terminated. - (sleep-for 1))) - (non-ascii-file-name - (let ((umlaut (string (make-char 'latin-iso8859-1 #xe4)))) ; umlaut a - (xmtn-tests--with-test-environment (&key root) - (let ((file-name umlaut)) - (let ((file-name-coding-system 'utf-8)) ; not sure about this... - (with-temp-file file-name ; create empty file - (progn))) - (xmtn--add-files root (list file-name)) - (let ((manifest (xmtn--get-manifest root `(local-tree ,root)))) - (xmtn-match manifest - (((dir "") (file $file-name-here $hash-id $attributes)) - (assert (equal file-name-here file-name) t) - (assert (endp attributes))))) - ;; Check whether xmtn-automate encodes the file name - ;; correctly when passing it to monotone. The actual command - ;; doesn't matter as much as the fact that monotone receives - ;; it correctly. - (xmtn--with-automate-command-output-basic-io-parser - (next-stanza root (xmtn--version-case - ((mainline> 0 35) `("get_attributes" ,file-name)) - (t `("attributes" ,file-name)))) - (xmtn-match (funcall next-stanza) - ((("format_version" (string "1"))))) - (assert (null (funcall next-stanza)) t)))))) - (non-ascii-file-contents - (let ((umlaut (string (make-char 'latin-iso8859-1 #xe4)))) ; umlaut a - (xmtn-tests--with-test-environment (&key root) - (let ((file-name "foo") - (contents (concat umlaut "\n")) - (coding-system 'iso-8859-1-unix)) - (with-temp-file file-name - (setq buffer-file-coding-system coding-system) - (insert contents)) - (xmtn--add-files root (list file-name)) - (xmtn--run-command-sync root (list "commit" "--message=commit foo")) - (let ((content-id "77785e6fd883a5e27a62bc6f26365e1b37e1900f")) - (assert (equal (xmtn--file-contents-as-string root content-id) - (encode-coding-string contents coding-system)) - t)))))) - (non-ascii-cert-value - (let ((umlaut (string (make-char 'latin-iso8859-1 #xe4)))) ; umlaut a - (xmtn-tests--with-test-history (&key root revision-2 &allow-other-keys) - (let ((cert-name "test-cert") - (cert-value umlaut)) - (xmtn--run-command-sync root `("cert" "--" - ,revision-2 - ,cert-name ,cert-value)) - (let ((certs (xmtn--list-parsed-certs root revision-2))) - (let ((matching-certs (remove* cert-name certs - :key #'third - :test-not #'equal))) - (xmtn-match matching-certs - ((($email ok $cert-name-here $cert-value-here t)) - (assert (equal cert-name-here cert-name) t) - (assert (equal cert-value-here cert-value) t))))))))) - (dvc-file-diff-with-non-ascii-contents - (save-window-excursion - (let ((umlaut (string (make-char 'latin-iso8859-1 #xe4)))) ; umlaut a - (xmtn-tests--with-test-environment (&key root) - (let ((file-name "foo") - (contents (concat umlaut "\n")) - (coding-system 'utf-8-unix)) - (with-temp-file file-name - (setq buffer-file-coding-system coding-system) - (insert contents)) - (xmtn--add-files root (list file-name)) - (xmtn--run-command-sync root (list "commit" "--message=commit foo")) - (with-temp-buffer - (let ((coding-system-for-read coding-system)) - (insert-file-contents file-name t)) - (dvc-file-diff file-name) - (assert (eql (point-min) (point-max))))))))) - (buffer-file-coding-system-in-dvc-dvc-file-diff - (save-window-excursion - (let ((umlaut (string (make-char 'latin-iso8859-1 #xe4)))) ; umlaut a - (xmtn-tests--with-test-environment (&key root) - (let ((file-name "foo") - (contents (concat umlaut "\n")) - (coding-system-1 'utf-8-unix) - (coding-system-2 'iso-8859-1-unix)) - (with-temp-file file-name - (setq buffer-file-coding-system coding-system-1) - (insert contents)) - (xmtn--add-files root (list file-name)) - (xmtn--run-command-sync root (list "commit" "--message=commit foo")) - (with-temp-buffer - (insert-file-contents file-name t) - (setq buffer-file-coding-system coding-system-2) - (let ((coding-system-for-read coding-system-1)) - (dvc-file-diff file-name)) - (assert (not (eql (point-min) (point-max)))))))))) - (file-diff-after-rename - (xmtn-tests--with-test-history (&key root ((:file-name file-name-1)) - revision-2 - &allow-other-keys) - (let ((file-name-2 "bar")) - (xmtn--run-command-sync root - (xmtn--version-case - ((>= 0 34) - `("mv" "--" ,file-name-1 ,file-name-2)) - (t - `("mv" "-e" "--" ,file-name-1 ,file-name-2)))) - (with-temp-buffer - (xmtn--revision-get-file-helper file-name-2 revision-2) - (assert (equal (buffer-substring (point-min) (point-max)) - "b\n") - t))))) - (diff-from-revlog - (save-window-excursion - (xmtn-tests--with-test-history (&key &allow-other-keys) - (unwind-protect - (progn - (dvc-changelog) - (dvc-revision-next) - (dvc-revlist-diff)) - (dvc-tests-wait-async))))) - (stdio-command-options - (xmtn--version-case - ((>= 0 31) - (xmtn-tests--with-test-history (&key root file-name - revision-1 revision-2 - &allow-other-keys) - (let ((root default-directory)) - (assert - (equal - (xmtn-automate-simple-command-output-lines - root `(("revision" ,revision-1 - "revision" ,revision-2) - "content_diff" ,file-name)) - '("============================================================" - "--- file-1 3f786850e387550fdab836ed7e6dc881de23001b" - "+++ file-1 89e6c98d92887913cadf06b2adb97f26cde4849b" - "@@ -1 +1 @@" - "-a" - "+b")) - t)))) - (t - (xmtn-tests--with-test-history (&key root file-name - revision-1 revision-2) - (assert (not (ignore-errors - (message "%S" (xmtn-automate-simple-command-output-lines - root `(("revision" ,revision-1 - "revision" ,revision-2) - "content_diff" ,file-name))) - t))))))) - (xmtn-dvc-command-version - ;; Should not error. - (xmtn-dvc-command-version)) - (dvc-file-diff-write-file-hooks - (save-window-excursion - (xmtn-tests--with-test-history (&key file-name &allow-other-keys) - (find-file file-name) - (unwind-protect - (progn - (let ((write-file-hooks (list (lambda () - (assert nil))))) - (insert "x") - (save-excursion - (call-interactively #'dvc-file-diff)))) - (revert-buffer t t))))) - (get-content-changed-closure - (save-window-excursion - (xmtn-tests--with-test-history (&key root file-name revision-1 revision-2 - &allow-other-keys) - (let ((other-file-name (concat file-name "2")) - (renamed-file-name (concat file-name "x")) - revision-3 revision-4 revision-5) - (progn - (with-temp-file other-file-name (insert "a\n")) - (xmtn--add-files root (list other-file-name)) - (xmtn--run-command-sync root `("commit" "--message=commit")) - (setq revision-3 (xmtn--get-base-revision-hash-id root))) - (progn - (xmtn--run-command-sync root - (xmtn--version-case - ((>= 0 34) - `("mv" "--" ,file-name ,renamed-file-name)) - (t - `("mv" "-e" "--" ,file-name - ,renamed-file-name)))) - (xmtn--run-command-sync root `("commit" "--message=commit")) - (setq revision-4 (xmtn--get-base-revision-hash-id root))) - (progn - (with-temp-file renamed-file-name (insert "c\n")) - (xmtn--run-command-sync root `("commit" "--message=commit")) - (setq revision-5 (xmtn--get-base-revision-hash-id root))) - (flet ((check (file start-rev expected-results) - (let ((actual (xmtn--get-content-changed-closure - root `(revision ,start-rev) file))) - (unless (null (set-exclusive-or expected-results - actual - :test #'equal)) - (error "file=%S start-rev=%s expected=%S actual=%S; revisions=%S" - file start-rev expected-results actual - (list revision-1 revision-2 revision-3 revision-4 - revision-5)))))) - (check file-name revision-1 `((,revision-1 ,file-name))) - ;; Some of these checks fail with mtn 0.30; not - ;; investigated further. - ;; - ;; 0.30 reports ((1 file)) - (check file-name revision-2 `((,revision-1 ,file-name) - (,revision-2 ,file-name))) - - ;; 0.30 reports ((1 file)) - (check file-name revision-3 `((,revision-1 ,file-name) - (,revision-2 ,file-name))) - ;; 0.30 reports ((1 file) (4 renamed)) - (check renamed-file-name revision-4 `((,revision-1 ,file-name) - (,revision-2 ,file-name))) - ;; 0.30 reports ((1 file) (4 renamed)) - (check renamed-file-name revision-5 `((,revision-1 ,file-name) - (,revision-2 ,file-name) - (,revision-5 - ,renamed-file-name))) - (check other-file-name revision-3 `((,revision-3 ,other-file-name))) - (check other-file-name revision-4 `((,revision-3 ,other-file-name))) - (check other-file-name revision-5 `((,revision-3 ,other-file-name))) - ))))) - (locale - ;; The test is simply that this doesn't crash. - (let ((process-environment (list* "LC_MESSAGES=de_DE" process-environment)) - (xmtn--*cached-command-version* nil)) - ;; Unfortunately, in my configuration, I don't seem to be able to - ;; get monotone to print non-English messages at all. So, for - ;; me, this doesn't actually fail even without the appropriate - ;; changes to `xmtn--call-with-environment-for-subprocess'. - (xmtn-check-command-version))) - - (xmtn--file-registered-p - (xmtn-tests--with-test-history (&key root file-name &allow-other-keys) - (assert (xmtn--file-registered-p root file-name)) - (assert (not (xmtn--file-registered-p root "nonexistent-file"))))) - - (dvc-status-add - (save-window-excursion - (xmtn-tests--with-test-environment - (&key &allow-other-keys) - ;; add and commit an unknown file, using dvc-status keystrokes - (with-temp-file "unknown" (insert "unknown - to be added\n")) - (with-temp-file "unknown-marked" (insert "unknown, marked\n")) - (dvc-status) - (dvc-tests-wait-async) - (assert (looking-at " unknown unknown")) - (execute-kbd-macro (vector dvc-key-add)) - (dvc-tests-wait-async) - (assert (looking-at " added unknown")) - (forward-line) - (assert (looking-at " unknown unknown-marked")) - (execute-kbd-macro (vector dvc-key-mark dvc-key-add)) - ;; FIXME: checking for the mark doesn't work; something about the fontification of the line. - (dvc-tests-wait-async) - (execute-kbd-macro (vector dvc-key-unmark)) - (assert (looking-at " added unknown-marked")) - ;; FIXME: commit hangs when run from this test, in xmtn--insert-log-edit-hints, which runs stuff asynchronously - ;; (execute-kbd-macro (vector dvc-key-commit)) - ;; (dvc-tests-wait-async) - ;; (debug) - ;; (execute-kbd-macro (vector "C-c" "C-c")) - ;; this works - (dvc-log-edit) - (dvc-tests-wait-async) - (dvc-log-edit-done) - (dvc-tests-wait-async) - - ;; currently need dvc-status-refresh to see results of the - ;; commit; eventually dvc-status will edit the ewoc directly - (dvc-status-refresh) - (dvc-tests-wait-async) - (assert (looking-at "$")) - ))) - ) - -(defvar xmtn-tests--profile-history (list)) - -(defun xmtn-tests--profile () - (interactive) - (unless (not xmtn--*enable-assertions*) - (unless (y-or-n-p "Assertions appear to be enabled. Continue anyway? ") - (error "Aborted"))) - (let ((command - (read-from-minibuffer "Profile xmtn command: " - nil read-expression-map t - 'xmtn-tests--profile-history)) - (reps 20)) - (elp-instrument-package "xmtn-") - (elp-instrument-package "dvc-") - (elp-instrument-package "process-") - (elp-instrument-package "ewoc-") - (elp-instrument-function 'accept-process-output) - (elp-instrument-function 'buffer-substring-no-properties) - (elp-reset-all) - (setq elp-reset-after-results nil) - ;; FIXME: Maybe use benchmark.el. - (let ((gc-cons-threshold (max gc-cons-threshold 100000000)) - (run-time 0) - (gc-time 0)) - (assert (garbage-collect)) - (loop for rep from 1 - repeat reps - do - (with-temp-message (format "Profiling, repetition %s of %s..." - rep reps) - (save-excursion - (save-window-excursion - (let ((start-time (current-time))) - (eval command) - (let ((end-time (current-time))) - (incf run-time (elp-elapsed-time start-time - end-time)))))) - (assert (let ((start-time (current-time))) - (prog1 - (garbage-collect) - (let ((end-time (current-time))) - (incf gc-time (elp-elapsed-time start-time - end-time)))))))) - (elp-results) - (setq truncate-lines t) - (goto-char (point-min)) - (insert (format "Command: %S\n" command)) - (insert (format "Repetitions: %s\n" reps)) - (insert "\n") - (insert (format "Wall time (excluding gc): %s\n" run-time)) - (insert (format "GC time (bogus): %s\n" gc-time)) - (insert "\n")) - (elp-restore-all)) - (message "Profiling finished")) - -(defun xmtn-tests--time () - (interactive) - (unless (not xmtn--*enable-assertions*) - (unless (y-or-n-p "Assertions appear to be enabled. Continue anyway? ") - (error "Aborted"))) - (let ((command - (read-from-minibuffer "Time xmtn command: " - nil read-expression-map t - 'xmtn-tests--profile-history)) - (reps 10)) ;; FIXME: dies on rep 30 on Windows MinGW - ;; Run command once before starting timing to get everything in cache - (eval command) - (let ((run-time 0)) - (assert (garbage-collect)) - (loop for rep from 1 - repeat reps - do - (with-temp-message (format "Timing, repetition %s of %s..." - rep reps) - (save-excursion - (save-window-excursion - (let ((start-time (current-time))) - (eval command) - (let ((end-time (current-time))) - (incf run-time (elp-elapsed-time start-time - end-time)))))))) - (switch-to-buffer-other-window (get-buffer-create - "*xmtn timing results*")) - (erase-buffer) - (setq truncate-lines t) - (goto-char (point-min)) - (insert (format "Command: %S\n" command)) - (insert (format "Repetitions: %s\n" reps)) - (insert "\n") - (insert (format "Wall time (including gc): %s\n" run-time)) - (insert "\n"))) - (message "Timing finished")) - -(defun xmtn-tests--parse-basic-io-inventory-benchmark (mtn-executable tree) - (let ((default-directory tree) - (xmtn-executable mtn-executable) - (xmtn--*cached-command-version* nil)) - (xmtn-automate-with-session (session (dvc-tree-root)) - (xmtn-automate-with-command (handle session '("inventory")) - (xmtn-automate-command-wait-until-finished handle) - (xmtn-automate-command-check-for-and-report-error handle) - (xmtn-basic-io-with-stanza-parser (parser (xmtn-automate-command-buffer - handle)) - (let ((changed 0) - (total 0) - (unknown 0) - (ignored 0)) - (loop for stanza = (funcall parser) - while stanza - do (incf total) - do (let ((status (second (assoc "status" stanza)))) - (xmtn-match status - ((string "known")) - ((string "missing")) - ((string "unknown") (incf unknown)) - ((string "ignored") (incf ignored))) - (let ((changes (second (assoc "changes" stanza)))) - (unless (null changes) - (incf changed))))) - (message "total=%s changed=%s ignored=%s unknown=%s" - total changed ignored unknown))))))) - -(provide 'xmtn-tests) -;;; xmtn-tests.el ends here diff --git a/dvc/lisp/tla-autoconf.el b/dvc/lisp/tla-autoconf.el deleted file mode 100644 index 9ef1473..0000000 --- a/dvc/lisp/tla-autoconf.el +++ /dev/null @@ -1,226 +0,0 @@ -;;; 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 deleted file mode 100644 index f50e30d..0000000 --- a/dvc/lisp/tla-bconfig.el +++ /dev/null @@ -1,151 +0,0 @@ -;;; tla-bconfig.el --- mode for input file of GNU arch's build-config - -;; Copyright (C) 2005 Free Software Foundation, Inc. - -;; Author: Masatake YAMATO -;; 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 deleted file mode 100644 index b295859..0000000 --- a/dvc/lisp/tla-browse.el +++ /dev/null @@ -1,1500 +0,0 @@ -;;; 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 deleted file mode 100644 index 724ae27..0000000 --- a/dvc/lisp/tla-core.el +++ /dev/null @@ -1,1906 +0,0 @@ -;;; 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]\\|$\\)") - (forward-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 deleted file mode 100644 index e96b55d..0000000 --- a/dvc/lisp/tla-defs.el +++ /dev/null @@ -1,2040 +0,0 @@ -;;; 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 deleted file mode 100644 index 95e9499..0000000 --- a/dvc/lisp/tla-dvc.el +++ /dev/null @@ -1,141 +0,0 @@ -;;; 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 deleted file mode 100644 index 535c5e0..0000000 --- a/dvc/lisp/tla-gnus.el +++ /dev/null @@ -1,168 +0,0 @@ -;;; 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 deleted file mode 100644 index e1a8d22..0000000 --- a/dvc/lisp/tla-tests.el +++ /dev/null @@ -1,537 +0,0 @@ -;;; 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)) - (forward-line -1)) - list-cmds - )) - -(defvar tla-tests-nonreg-dir - (expand-file-name - (concat (file-name-directory (locate-library "tla")) - "../tests")) - "Directory where non-regression tests should be stored.") - -(defun tla-tests-buffer-nonreg (buffer id) - "Perform a non-regression script on BUFFER. - -When called for the first time, stores the content of BUFFER in -`tla-tests-nonreg-dir'/ID.txt. Afterwards, compares the content of -BUFFER with the previously archived one. Raise an error when there is -a difference." - (make-directory tla-tests-nonreg-dir t) - (let ((filename (concat (file-name-as-directory - tla-tests-nonreg-dir) - id ".txt"))) - (with-current-buffer buffer - (if (file-exists-p filename) - (progn - (let ((old (concat - (dvc-strip-final-newline - (with-current-buffer (find-file-noselect - filename) - (buffer-string))) - "\n")) - (new (concat - (dvc-strip-final-newline - (replace-regexp-in-string - (regexp-quote (getenv "HOME")) "$HOME" - (buffer-string))) - "\n"))) - (if (string= old new) - (progn (tla-tests-log "non-reg %s OK" id)) - (tla-tests-log "Non regression failed for %s failed" id) - (tla-tests-log "Expected:\n\"%s\"\n" old) - (tla-tests-log "Got:\n\"%s\"\n" new) - (error "Non regression failed")))) - (let ((content (buffer-string))) - (with-current-buffer (get-buffer-create " *tla-tmp*") - (erase-buffer) - (insert content) - (goto-char (point-min)) - (while (search-forward (getenv "HOME") nil t) - (replace-match "$HOME" nil t)) - (tla-tests-log "Archiving %s for non-regression." id) - (tla-tests-log "please check %s for errors." filename) - (write-file filename) - (kill-buffer (current-buffer)) - t)))))) - - -;; -;; Testcases -;; - -(defun tla-test-my-id () - "Test that my-id works correctly." - (ignore-errors (tla-my-id)) - (flet ((read-string (prompt x y z) - "John Smith ")) - (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 deleted file mode 100644 index 7a4c4fe..0000000 --- a/dvc/lisp/tla.el +++ /dev/null @@ -1,9790 +0,0 @@ -;;; 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)) - (forward-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))) - (mapc '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))) - (mapc '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." - (mapc - (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 deleted file mode 100644 index 74289b8..0000000 --- a/dvc/lisp/xdarcs-core.el +++ /dev/null @@ -1,61 +0,0 @@ -;;; 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 deleted file mode 100644 index 4ac3ad4..0000000 --- a/dvc/lisp/xdarcs-dvc.el +++ /dev/null @@ -1,80 +0,0 @@ -;;; 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 deleted file mode 100644 index a205ddc..0000000 --- a/dvc/lisp/xdarcs.el +++ /dev/null @@ -1,383 +0,0 @@ -;;; 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 deleted file mode 100644 index 6965aa1..0000000 --- a/dvc/lisp/xgit-annotate.el +++ /dev/null @@ -1,138 +0,0 @@ -;;; xgit-annotate.el --- Git interface for dvc: mode for git-annotate style output - -;; Copyright (C) 2007-2009 by all contributors - -;; Author: Takuzo O'hara, - -;; 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 deleted file mode 100644 index 9eba232..0000000 --- a/dvc/lisp/xgit-core.el +++ /dev/null @@ -1,127 +0,0 @@ -;;; 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 deleted file mode 100644 index 6922f9a..0000000 --- a/dvc/lisp/xgit-dvc.el +++ /dev/null @@ -1,167 +0,0 @@ -;;; 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 deleted file mode 100644 index e5f19b2..0000000 --- a/dvc/lisp/xgit-gnus.el +++ /dev/null @@ -1,294 +0,0 @@ -;;; 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 deleted file mode 100644 index 1e9cba7..0000000 --- a/dvc/lisp/xgit-log-edit.el +++ /dev/null @@ -1,72 +0,0 @@ -;;; 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 deleted file mode 100644 index 0032b5e..0000000 --- a/dvc/lisp/xgit-log.el +++ /dev/null @@ -1,390 +0,0 @@ -;;; xgit-log.el --- git interface for dvc: mode for git log style output - -;; Copyright (C) 2006-2009 by all contributors - -;; Author: Stefan Reichoer, - -;; 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 deleted file mode 100644 index d4f5aa9..0000000 --- a/dvc/lisp/xgit-rebase-todo.el +++ /dev/null @@ -1,91 +0,0 @@ -;;; 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 deleted file mode 100644 index bd8f523..0000000 --- a/dvc/lisp/xgit-revision.el +++ /dev/null @@ -1,116 +0,0 @@ -;;; 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 deleted file mode 100644 index a10cf9f..0000000 --- a/dvc/lisp/xgit.el +++ /dev/null @@ -1,1004 +0,0 @@ -;;; 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 deleted file mode 100644 index 18d0bda..0000000 --- a/dvc/lisp/xhg-annotate.el +++ /dev/null @@ -1,143 +0,0 @@ -;;; 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 (buffer-file-name xhg-annotate-current-buffer))) - (save-excursion - (xhg-log rev-number rev-number t fname) - (other-window 1)))) - -;;;###autoload -(defun xhg-annotate-show-prec-rev-number-log () - "Go to precedent line in xhg-annotate buffer and display -corresponding xhg-log output." - (interactive) - (forward-line -1) - (xhg-annotate-show-rev-number-log)) - -;;;###autoload -(defun xhg-annotate-show-next-rev-number-log () - "Go to next line in xhg-annotate buffer and display -corresponding xhg-log output." - (interactive) - (forward-line) - (xhg-annotate-show-rev-number-log)) - -;;;###autoload -(defun xhg-annotate () - "Run hg annotate and display xhg-log in other-window." - (interactive) - (setq xhg-annotate-current-buffer (current-buffer)) - (let ((line-num (line-number-at-pos))) - (dvc-run-dvc-display-as-info 'xhg (append '("annotate") (dvc-current-file-list))) - (switch-to-buffer "*xhg-info*") - (goto-line line-num) - (xhg-annotate-mode) - (xhg-annotate-show-rev-number-log))) - -;;;###autoload -(defun xhg-annotate-quit () - "Quit and restore precedent window config." - (interactive) - (dvc-buffer-quit) - (other-window 1) - (dvc-buffer-quit) - (switch-to-buffer xhg-annotate-current-buffer) - (setq xhg-annotate-current-buffer nil) - (delete-other-windows)) - -(provide 'xhg-annotate) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; xhg-annotate.el ends here diff --git a/dvc/lisp/xhg-be.el b/dvc/lisp/xhg-be.el deleted file mode 100644 index 0df6890..0000000 --- a/dvc/lisp/xhg-be.el +++ /dev/null @@ -1,57 +0,0 @@ -;;; 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 deleted file mode 100644 index e1d98ce..0000000 --- a/dvc/lisp/xhg-core.el +++ /dev/null @@ -1,70 +0,0 @@ -;;; xhg-core.el --- Common definitions for mercurial support in DVC - -;; Copyright (C) 2005-2012 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))) - -(defun xhg-prepare-environment (env) - "Prepare the environment to run hg." - ;; DVC expects hg messages in the C locale - (cons "LC_MESSAGES=C" env)) - -(provide 'xhg-core) -;;; xhg-core.el ends here diff --git a/dvc/lisp/xhg-dvc.el b/dvc/lisp/xhg-dvc.el deleted file mode 100644 index 8036dd5..0000000 --- a/dvc/lisp/xhg-dvc.el +++ /dev/null @@ -1,220 +0,0 @@ -;;; xhg-dvc.el --- The dvc layer for xhg - -;; Copyright (C) 2005-2012 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)) - -(defalias 'xhg-dvc-prepare-environment 'xhg-prepare-environment) - -;; deactivated at them moment, use dvc-dvc-files-to-commit to allow selecting files to commit -;; (defun xhg-dvc-files-to-commit () -;; ;; -mar: modified+added+removed -;; (dvc-run-dvc-sync 'xhg (list "status" "-mar") -;; :finished (dvc-capturing-lambda -;; (output error status arguments) -;; (let ((file-list) -;; (modif) -;; (file-name)) -;; (set-buffer output) -;; (goto-char (point-min)) -;; (while (> (point-max) (point)) -;; (cond ((looking-at "M ") -;; (setq modif 'dvc-modified)) -;; ((looking-at "A ") -;; (setq modif 'dvc-added)) -;; ((looking-at "R ") -;; (setq modif 'dvc-move)) -;; (t -;; (setq modif nil))) -;; (setq file-name (buffer-substring-no-properties (+ (point) 2) (line-end-position))) -;; (add-to-list 'file-list (cons modif file-name)) -;; (forward-line 1)) -;; file-list)))) - -(defun xhg-dvc-edit-ignore-files () - (interactive) - (find-file-other-window (concat (xhg-tree-root) ".hgignore"))) - -(defun xhg-dvc-ignore-files (file-list) - (interactive (list (dvc-current-file-list))) - (when (y-or-n-p (format "Ignore %S for %s? " file-list (xhg-tree-root))) - (with-current-buffer - (find-file-noselect (concat (xhg-tree-root) ".hgignore")) - (goto-char (point-max)) - (dolist (f-name file-list) - (insert (format "^%s$\n" (regexp-quote f-name)))) - (save-buffer)))) - -(defun xhg-dvc-backend-ignore-file-extensions (extension-list) - (with-current-buffer - (find-file-noselect (concat (xhg-tree-root) ".hgignore")) - (goto-char (point-max)) - (dolist (ext-name extension-list) - (insert (format "\\.%s$\n" (regexp-quote ext-name)))) - (save-buffer))) - -(defun xhg-dvc-missing (&optional other) - "Run hg incoming to show the missing patches for this tree. -When `last-command' was `dvc-pull', run `xhg-missing'." - (interactive) - (if (eq last-command 'dvc-pull) - (xhg-missing-1) - (xhg-incoming other t))) - -(defun xhg-dvc-update () - (interactive) - (xhg-update)) - -(defvar xhg-dvc-pull-runs-update t - "Whether `xhg-dvc-pull' should call hg pull with the --update flag.") - -(defun xhg-dvc-pull (&optional other) - "Run hg pull, when `xhg-dvc-pull-runs-update' is t, use the --update flag." - (interactive) - (let ((source-path - (or other - (let* ((completions (xhg-paths 'both)) - (initial-input (car (member "default" completions)))) - (if (string= initial-input "default") initial-input - (dvc-completing-read - "Pull from hg repository: " - completions nil nil initial-input)))))) - (xhg-pull source-path xhg-dvc-pull-runs-update))) - -(defun xhg-dvc-create-branch (new-name) - "Run xhg-branch." - (interactive "sNewBranchName: ") - (xhg-branch new-name)) - -(defun xhg-dvc-select-branch () - "Switch to a named branch." - (interactive) - (xhg-update nil t)) - -(defun xhg-dvc-ediff-file-revisions () - "Layer function for `xhg-ediff-file-at-rev'." - (interactive) - (call-interactively #'xhg-ediff-file-at-rev)) - -(defalias 'xhg-dvc-revlog-get-revision 'xhg-revlog-get-revision) - -(defalias 'xhg-dvc-name-construct 'xhg-name-construct) - -(defalias 'xhg-dvc-delta 'xhg-delta) - -(defalias 'xhg-dvc-clone 'xhg-clone) - -(defalias 'xhg-dvc-init 'xhg-init) - -(defalias 'xhg-dvc-push 'xhg-push) - -(provide 'xhg-dvc) -;;; xhg-dvc.el ends here diff --git a/dvc/lisp/xhg-gnus.el b/dvc/lisp/xhg-gnus.el deleted file mode 100644 index 00dbc2d..0000000 --- a/dvc/lisp/xhg-gnus.el +++ /dev/null @@ -1,144 +0,0 @@ -;;; xhg-gnus.el --- dvc integration to gnus - -;; Copyright (C) 2003-2012 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 "Unknown backend in xhg-gnus-import-patch: %s" current-dvc))))) - (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 deleted file mode 100644 index ed5b9fe..0000000 --- a/dvc/lisp/xhg-log.el +++ /dev/null @@ -1,237 +0,0 @@ -;;; 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 deleted file mode 100644 index eb4da97..0000000 --- a/dvc/lisp/xhg-mq.el +++ /dev/null @@ -1,711 +0,0 @@ -;;; 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 deleted file mode 100644 index af9863f..0000000 --- a/dvc/lisp/xhg-revision.el +++ /dev/null @@ -1,126 +0,0 @@ -;;; 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 deleted file mode 100644 index 221b05b..0000000 --- a/dvc/lisp/xhg.el +++ /dev/null @@ -1,1370 +0,0 @@ -;;; 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: - -(condition-case nil - (require 'dired-x) - (error nil)) -(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) - (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)) - - (setf file (expand-file-name (or file (buffer-file-name) default-directory))) - (setq command-list (append command-list (list file))) - (setq xhg-log-remember-func-args (list r1 r2 show-patch file)) - - (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)) - (root default-directory) ;; default-directory is setup by the caller... - (buffer (dvc-prepare-changes-buffer - `(xhg (last-revision ,root 1)) - `(xhg (local-tree ,root)) - 'status root 'xhg))) - ;; (message "xhg-dvc-status root: %s" root) - (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 &optional revnum) - "Convert a foreign SCM repository to a Mercurial one. -With prefix arg prompt for REVNUM. - 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: ") - (let* ((src (expand-file-name source)) - (tget (expand-file-name target)) - (rev (if current-prefix-arg (read-string "Revision: ") revnum)) - (arg-list (if rev (list "convert" src tget "-r" rev) (list "convert" src tget)))) - (message "HG conversion of `%s' to `%s' ..." source target) - (dvc-run-dvc-async 'xhg arg-list - :finished (dvc-capturing-lambda (output error status arguments) - (let ((default-directory (capture target))) - (xhg-update)) - (message "HG conversion of `%s' to `%s' ... done." - (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 deleted file mode 100644 index 1360429..0000000 --- a/dvc/lisp/xmtn-automate.el +++ /dev/null @@ -1,885 +0,0 @@ -;;; xmtn-automate.el --- Interface to monotone's "automate" functionality - -;; Copyright (C) 2008 - 2011 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. -;; -;; see http://www.monotone.ca/docs/Automation.html#Automation for -;; details of the monotone automate command. -;; -;; mtn automate allows sending several commands to a single mtn -;; process, and provides the results in a form that is easy to -;; parse. It does some caching between command, and will do more in -;; the future, so this is a significant speed-up over spawning a new -;; subprocess for each command. -;; -;; To allow xmtn-automate to track how long an automate stdio process -;; needs to be kept around, and to store meta data, 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. A session can be -;; obtained using `xmtn-automate-cache-session'. Note that -;; `xmtn-automate-cache-session' doesn't necessarily start a fresh -;; monotone process, if a session with that root already exists. The -;; process must be killed with `xmtn-automate-kill-session'. -;; -;; Once you have a session object, you can use -;; `xmtn-automate--new-command' to send commands to monotone. -;; -;; A COMMAND is a list of strings (the command and its arguments), or -;; a cons of lists of strings. If car COMMAND is a list, car COMMAND -;; is options, cdr is the command and arguments. Options are always -;; specified as pairs of keyword and value, and without the leading -;; "--". If an option has no value, use ""; see -;; xmtn--status-inventory-sync in xmtn-dvc for an example. -;; -;; `xmtn-automate--new-command' returns a command handle. You 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 is -;; the main reason for introducing command handles. -;; -;; There are some notes on the design of xmtn in -;; docs/xmtn-readme.txt. - -;;; Code: - -(eval-and-compile - (require 'cl) - (require 'parse-time) ;for parse-integer - (require 'xmtn-base) - (require 'xmtn-run) - (require 'xmtn-compat)) - -(defconst xmtn-automate-arguments nil - "Arguments and options for 'mtn automate stdio' sessions.") - -(defconst xmtn-sync-session-root "sync" - "Name for unique automate session used for sync commands.") - -(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-wait-until-finished (handle) - (let ((session (xmtn-automate--command-handle-session handle))) - (while (not (xmtn-automate--command-handle-finished-p handle)) - ;; We use a timeout here to allow debugging, and incremental - ;; processing of tickers. We don't use a process filter, because - ;; they are very hard to debug. - (accept-process-output (xmtn-automate--session-process session) 0.01) - (xmtn-automate--process-new-output session)) - (unless (eql (xmtn-automate--command-handle-error-code handle) 0) - (xmtn-automate--cleanup-command handle) - (pop-to-buffer (format dvc-error-buffer 'xmtn)) - (goto-char (point-max)) - (newline) - (insert (format "command: %s" (xmtn-automate--command-handle-command handle))) - (when (xmtn-automate--session-error-file session) - (insert-file-contents (xmtn-automate--session-error-file session))) - (error "mtn error %s" (xmtn-automate--command-handle-error-code handle))) - (if (xmtn-automate--command-handle-warnings handle) - (display-buffer (format dvc-error-buffer 'xmtn) t)) - ) - nil) - -(defvar xmtn-automate--*sessions* '() - "Assoc list of sessions, indexed by uniquified root directory.") - -(defun xmtn-automate-cache-session (root) - "If necessary, create a mtn automate session for workspace -ROOT, store it in session cache. Return session." - ;; we require an explicit root argument here, rather than relying on - ;; default-directory, because one application is to create several - ;; sessions for several workspaces, and operate on them as a group - ;; (see xmtn-multi-status.el, for example). - (let* ((default-directory (dvc-uniquify-file-name root)) - (session (xmtn-automate-get-cached-session default-directory))) - (or session - (progn - (setq session (xmtn-automate--make-session default-directory default-directory)) - (setq xmtn-automate--*sessions* - (acons default-directory session xmtn-automate--*sessions*)) - session)))) - -(defun xmtn-automate-get-cached-session (key) - "Return a session from the cache, or nil. KEY is uniquified -workspace root." - (cdr (assoc key xmtn-automate--*sessions*))) - -(defun xmtn-automate--command-output-as-string (handle) - (with-current-buffer (xmtn-automate-command-buffer handle) - (prog1 - (buffer-substring-no-properties (point-min) (point-max)) - (xmtn-automate--cleanup-command handle)))) - -(defun xmtn-automate-command-output-string (root command) - "Send COMMAND to session for ROOT. Return result as a string." - (let* ((session (xmtn-automate-cache-session root)) - (command-handle (xmtn-automate--new-command session command))) - (xmtn-automate-command-wait-until-finished command-handle) - (xmtn-automate--command-output-as-string command-handle))) - -(defun xmtn-automate-command-output-buffer (root buffer command &optional display-tickers) - "Send COMMAND to session for ROOT, insert result into BUFFER. -Optionally DISPLAY-TICKERS in mode-line of BUFFER." - (let* ((session (xmtn-automate-cache-session root)) - (command-handle (xmtn-automate--new-command session command display-tickers buffer))) - (xmtn-automate-command-wait-until-finished command-handle) - (with-current-buffer buffer - (insert-buffer-substring-no-properties - (xmtn-automate-command-buffer command-handle))) - (xmtn-automate--cleanup-command command-handle))) - -(defun xmtn-automate-command-output-file (root file command) - "Send COMMAND to session for ROOT, store result in FILE." - (let* ((session (xmtn-automate-cache-session root)) - (command-handle (xmtn-automate--new-command session command nil nil))) - (xmtn-automate-command-wait-until-finished command-handle) - (with-current-buffer (xmtn-automate-command-buffer command-handle) - (write-region nil nil file)) - (xmtn-automate--cleanup-command command-handle))) - -(defun xmtn-automate-command-output-lines (root command) - "Return list of strings containing output of COMMAND, one line per -string." - (let* ((session (xmtn-automate-cache-session root)) - (handle (xmtn-automate--new-command session command))) - (xmtn-automate-command-wait-until-finished handle) - (with-current-buffer (xmtn-automate-command-buffer handle) - (goto-char (point-max)) - (let (result) - (while (= 0 (forward-line -1)) - (setq result (cons (buffer-substring-no-properties - (point) - (progn (end-of-line) (point))) - result))) - (xmtn-automate--cleanup-command handle) - result)))) - -(defun xmtn-automate-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-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) - (process-put process 'xmtn-automate--session session)) - -(defun xmtn-automate--process-session (process) - (process-get process 'xmtn-automate--session)) - -(defstruct (xmtn-automate--decoder-state - (:constructor xmtn-automate--%make-raw-decoder-state)) - ;; State for decoding stdio output packets. - (read-marker) - ;; char position (not marker) of last character read. We use a - ;; position, not a marker, because text gets inserted in front of - ;; the marker, and it moves. - - (remaining-chars 0) ;; until end of packet - (stream 0); determines output buffer - ) - -(defstruct (xmtn-automate--session - (:constructor xmtn-automate--%make-raw-session) - (:copier xmtn-automate--copy-session)) - (root) - (name) - (buffer nil) - (error-file nil) - (process nil) - (decoder-state) - (next-command-number 0) - (remaining-command-handles) - (sent-kill-p) - (closed-p nil)) - -(defstruct (xmtn-automate--command-handle - (:constructor xmtn-automate--%make-raw-command-handle)) - (command) - (mtn-command-number) - (session-command-number) - (session) - (buffer) - (write-marker) - (finished-p nil) - (error-code nil) - (warnings nil) - (tickers nil) ; alist of xmtn-automate--ticker by short name; nil if none active - (display-tickers nil) ; list of long names of tickers to display - (display-buffer nil) ; buffer in which to display tickers - ) - -(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) - (dvc-trace "new session %s" 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))) - (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))))) - - (signal-process process 'KILL) - - ;; This call to `sit-for' is apparently needed in some situations to - ;; make sure the process really gets killed. - (sit-for 0)) - nil) - -(defun xmtn-automate--close-session (session) - "Kill session process, buffer." - (setf (xmtn-automate--session-closed-p session) t) - (let ((process (xmtn-automate--session-process session))) - (cond - ((null process) - ;; Process was never created or was killed - most likely 'mtn - ;; not found in path'. Don't warn if buffer hasn't been deleted; - ;; that obscures the real error message - nil) - (t - (ecase (process-status process) - (run - (process-send-eof process) - (xmtn-automate--session-send-process-kill session) - (sleep-for 1.0); let process die before deleting associated buffers - ) - (exit t) - (signal t)))) - - (unless xmtn-automate--*preserve-buffers-for-debugging* - (if (buffer-live-p (xmtn-automate--session-buffer session)) - (kill-buffer (xmtn-automate--session-buffer session))))) - nil) - -(defun xmtn-automate-kill-session (root) - "Kill session for ROOT." - (interactive) - (let ((session (assoc (dvc-uniquify-file-name root) xmtn-automate--*sessions*))) - ;; session may have already been killed - (when session - (when (xmtn-automate--session-error-file (cdr session)) - (delete-file (xmtn-automate--session-error-file session))) - (xmtn-automate--close-session (cdr session)) - (setq xmtn-automate--*sessions* - (delete session xmtn-automate--*sessions*))))) - -(defun xmtn-kill-all-sessions () - "Kill all xmtn-automate sessions." - (interactive) - (let ((count 0) - (key " *xmtn automate session for")) - (dolist (session xmtn-automate--*sessions*) - (xmtn-automate--close-session (cdr session)) - (setq count (+ 1 count))) - (setq xmtn-automate--*sessions* nil) - (message "killed %d sessions" count))) - -(defun xmtn-automate--start-process (session) - (xmtn--check-cached-command-version) - (let ((name (xmtn-automate--session-name session)) - (buffer (xmtn-automate--new-buffer session)) - (root (xmtn-automate--session-root session))) - (let ((process-connection-type nil); use a pipe, not a tty - (default-directory root) - ;; start-process merges stderr and stdout from the child, - ;; but stderr messages are not packetized, so they confuse - ;; the packet parser. This is only a problem when the - ;; session will run 'sync ssh:' or 'sync file:', since those - ;; spawn new mtn processes that can report errors on - ;; stderr. All other errors will be reported properly thru - ;; the stdout packetized error stream. xmtn-sync uses the - ;; unique xmtn-sync-session-root for the session root, so we - ;; treat that specially. - (cmd (if (string= xmtn-sync-session-root (file-name-nondirectory root)) - (progn - (setf (xmtn-automate--session-error-file session) - (dvc-make-temp-name (concat xmtn-sync-session-root "-errors"))) - (list dvc-sh-executable - "-c" - (mapconcat - 'concat - (append (list xmtn-executable "--db=:memory:" "automate" "stdio") - xmtn-automate-arguments - (list "2>" - (xmtn-automate--session-error-file session))) - " "))) - ;; not the sync session - (append (list xmtn-executable "automate" "stdio") - xmtn-automate-arguments)))) - (let ((process (apply 'start-process name buffer cmd))) - (ecase (process-status process) - (run - ;; If the process started ok, it outputs the stdio - ;; header. If there was an error (like default_directory is - ;; not a mtn workspace), it outputs an error message and - ;; exits. - (accept-process-output process) - (with-current-buffer buffer - ;; If the format version changes, we probably need to - ;; adapt. So we insist on an exact match. - (goto-char (point-min)) - (if (looking-at "format-version: \\([0-9]+\\)\n\n") - (if (not (string-equal (match-string 1) xmtn--required-automate-format-version)) - (error "unexpected mtn automate stdio format version %s" (match-string 0))) - ;; Some error. Display the session buffer to show the error - (pop-to-buffer buffer) - (let ((inhibit-read-only t)) - (when (xmtn-automate--session-error-file session) - (insert-file-contents (xmtn-automate--session-error-file session)))) - (error "unexpected header from mtn automate process")))) - ((exit signal) - (pop-to-buffer buffer) - (error "failed to create mtn automate process"))) - - (setf (xmtn-automate--session-decoder-state session) - (xmtn-automate--%make-raw-decoder-state - :read-marker (with-current-buffer buffer (match-end 0)))) - - (xmtn-automate--set-process-session process session) - (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-remaining-command-handles session) (list)) - (setf (xmtn-automate--session-sent-kill-p session) nil) - process)))) - -(defun xmtn-automate--ensure-process (session) - "Ensure SESSION has an active process; restart it if it died." - (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) - (set-buffer-multibyte nil) - (setq buffer-read-only t)) - (setf (xmtn-automate--session-buffer session) buffer) - buffer)) - -(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-pairs session-number) - "Send COMMAND and OPTION-PAIRS to SESSION." - (let* ((buffer-name (format "*%s: input for command %s*" - (xmtn-automate--session-name session) - 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) - (set-buffer-multibyte t) - (setq buffer-read-only t) - (let ((inhibit-read-only t)) - (when option-pairs - (insert "o") - (xmtn-automate--append-encoded-strings option-pairs) - (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 &optional display-tickers display-buffer) - "Send COMMAND to SESSION. Optionally DISPLAY-TICKERS in DISPLAY-BUFFER mode-line. -DISPLAY-TICKERS is a list of strings; names of tickers to display." - (xmtn-automate--ensure-process session) - (let* ((command-number - (1- (incf (xmtn-automate--session-next-command-number - session)))) - (buffer-name (format " *%s: output for command %s*" - (xmtn-automate--session-name session) - command-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 '() command-number) - (xmtn-automate--send-command-string session (cdr command) (car command) command-number)) - (with-current-buffer buffer - (buffer-disable-undo) - (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 - :command command - :session-command-number command-number - :buffer buffer - :write-marker (set-marker (make-marker) (point)) - :display-tickers display-tickers - :display-buffer display-buffer))) - (setf - (xmtn-automate--session-remaining-command-handles session) - (nconc (xmtn-automate--session-remaining-command-handles session) - (list handle))) - handle)))) - -(defun xmtn-automate--cleanup-command (handle) - (unless xmtn-automate--*preserve-buffers-for-debugging* - (kill-buffer (xmtn-automate--command-handle-buffer handle)))) - -(defstruct (xmtn-automate--ticker) - (long-name) - (display nil) - (current 0) - (total 0)) - -(defun xmtn-automate--ticker-process (ticker-string tickers display-tickers) - "Process TICKER-STRING, updating tickers in alist TICKERS. -DISPLAY-TICKERS is list of ticker names to display. -Return updated value of TICKERS." - ;; ticker-string is contents of one stdio ticker packet: - ;; c:certificates;k:keys;r:revisions; declare short and long names - ;; c=0;k=0;r=0; set total values - ;; c#7;k#1;r#2; set current values - ;; c;k;r; close ticker - (while (< 0 (length ticker-string)) - (let* ((tick (substring ticker-string 0 (search ";" ticker-string))) - (name (aref tick 0)) - (ticker (cadr (assoc name tickers)))) - (if ticker - (cond - ((= 1 (length tick)) - (setq tickers (assq-delete-all name tickers))) - ((= ?= (aref tick 1)) - (setf (xmtn-automate--ticker-total ticker) (string-to-number (substring tick 2)))) - ((= ?# (aref tick 1)) - (setf (xmtn-automate--ticker-current ticker) (string-to-number (substring tick 2)))) - ) - ;; else create new ticker - (setq tickers - (add-to-list - 'tickers - (list name - (make-xmtn-automate--ticker - :long-name (substring tick 2) - :display (not (null (member (substring tick 2) display-tickers))) - )))) - ) - (setq ticker-string (substring ticker-string (+ 1 (length tick)))) - )) - tickers) - -(defun xmtn-automate--ticker-mode-line (tickers buffer) - "Display TICKERS alist in BUFFER mode-line-process" - (with-current-buffer buffer - (setq mode-line-process nil) - (loop for item in tickers do - (let ((ticker (cadr item))) - (if (xmtn-automate--ticker-display ticker) - (progn - (setq mode-line-process - (concat mode-line-process - (format " %s %d/%d" - (xmtn-automate--ticker-long-name ticker) - (xmtn-automate--ticker-current ticker) - (xmtn-automate--ticker-total ticker)))) - (force-mode-line-update))))))) - -(defun xmtn-automate--process-new-output--copy (session) - "Copy SESSION current packet output to command output or error buffer. -Return non-nil if some text copied." - ;; We often get here with only a partial packet; the main channel - ;; outputs very large packets. - (let* ((session-buffer (xmtn-automate--session-buffer session)) - (state (xmtn-automate--session-decoder-state session)) - (command (first (xmtn-automate--session-remaining-command-handles - session))) - (output-buffer - (ecase (xmtn-automate--decoder-state-stream state) - (?m - (xmtn-automate--command-handle-buffer command)) - (?t - ;; Display ticker in mode line of display buffer for - ;; current command. - (xmtn-automate--command-handle-display-buffer command)) - ((?e ?w ?p) - (if (equal ?w (xmtn-automate--decoder-state-stream state)) - (setf (xmtn-automate--command-handle-warnings command) t)) - ;; probably ought to do something else with p, but - ;; this is good enough for now. - (get-buffer-create (format dvc-error-buffer 'xmtn))))) - (write-marker - (xmtn-automate--command-handle-write-marker command))) - - (with-current-buffer session-buffer - (let* ((end (min (+ (xmtn-automate--decoder-state-read-marker state) - (xmtn-automate--decoder-state-remaining-chars state)) - (point-max))) - (chars-to-read (- end (xmtn-automate--decoder-state-read-marker state)))) - (cond - ((= chars-to-read 0) - nil) - ((> chars-to-read 0) - (if (not (buffer-live-p output-buffer)) - ;; Buffer has already been killed, just discard input. - t - (ecase (xmtn-automate--decoder-state-stream state) - (?t - ;; Display ticker in mode line of display buffer for - ;; current command. But only if we have the whole packet - (if (= chars-to-read (xmtn-automate--decoder-state-remaining-chars state)) - (progn - (setf (xmtn-automate--command-handle-tickers command) - (xmtn-automate--ticker-process - (buffer-substring-no-properties (xmtn-automate--decoder-state-read-marker state) - end) - (xmtn-automate--command-handle-tickers command) - (xmtn-automate--command-handle-display-tickers command))) - (xmtn-automate--ticker-mode-line - (xmtn-automate--command-handle-tickers command) - output-buffer) - (setf (xmtn-automate--decoder-state-read-marker state) end) - (decf (xmtn-automate--decoder-state-remaining-chars state) - chars-to-read)) - ;; not a whole packet; no text copied - nil)) - - ((?m ?e ?w ?p) - (with-current-buffer output-buffer - (save-excursion - (goto-char write-marker) - (let ((inhibit-read-only t) - deactivate-mark) - (insert-buffer-substring-no-properties session-buffer - (xmtn-automate--decoder-state-read-marker state) - end)) - (set-marker write-marker (point)))) - (setf (xmtn-automate--decoder-state-read-marker state) end) - (decf (xmtn-automate--decoder-state-remaining-chars state) - chars-to-read) - t))) - )))))) - -(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)))))))) - -(defun xmtn-automate--process-new-output (session) - (let* ((state (xmtn-automate--session-decoder-state session)) - (write-marker (process-mark (xmtn-automate--session-process session))) - (tag 'check-for-more)) - (with-current-buffer (xmtn-automate--session-buffer session) - (loop - for command = (first (xmtn-automate--session-remaining-command-handles - session)) - do - (ecase tag - (check-for-more - (if (= (xmtn-automate--decoder-state-read-marker state) write-marker) - (setq tag 'exit-loop) - (setq tag 'again))) - - (again - (cond - ((> (xmtn-automate--decoder-state-remaining-chars state) 0) - (if (= ?l (xmtn-automate--decoder-state-stream state)) - ;; got the rest of the last packet; process in t branch next loop - (setf (xmtn-automate--decoder-state-remaining-chars state) 0) - (if (xmtn-automate--process-new-output--copy session) - (setq tag 'again) - (setq tag 'check-for-more)))) - - (t - ;; new packet, or final packet - (goto-char (xmtn-automate--decoder-state-read-marker state)) - ;; A packet has the structure: - ;; ::: - ;; Streams are: - ;; m main - ;; e error - ;; w warning - ;; p progress - ;; t ticker - ;; l last - (cond - ((looking-at "\\([0-9]+\\):\\([mewptl]\\):\\([0-9]+\\):") - (let ((stream (aref (match-string 2) 0)) - (size (parse-integer (match-string 3)))) - (setf (xmtn-automate--decoder-state-remaining-chars state) size) - (setf (xmtn-automate--decoder-state-stream state) stream) - (ecase stream - ((?m ?e ?w ?t ?p) - (setf (xmtn-automate--decoder-state-read-marker state) (match-end 0)) - (setq tag 'again) ) - - (?l - (if (> (+ size (match-end 0)) (point-max)) - ;; do not have the error code yet - (setq tag 'exit-loop) - (setf (xmtn-automate--decoder-state-read-marker state) (+ size (match-end 0))) - (setf (xmtn-automate--command-handle-error-code command) - (parse-integer - (buffer-substring-no-properties - (match-end 0) (xmtn-automate--decoder-state-read-marker state)) )) - (setf (xmtn-automate--command-handle-finished-p command) t) - (with-no-warnings - ;; suppress compiler warning about discarding result - (pop (xmtn-automate--session-remaining-command-handles session))) - (if (xmtn-automate--session-closed-p session) - (setq tag 'exit-loop) - (setq tag 'check-for-more))) - ) - ))) - - (t - ;; Not a packet yet, or garbage in the stream from some - ;; Lua hook. Most likely we are at the end of the - ;; buffer, don't have a complete header, and there is - ;; more output coming soon. A packet header has at least - ;; 6 bytes; allowing 4 digits per integer takes that to - ;; 12. - (if (> 12 (- (point-max) (point))) - (setq tag 'exit-loop) - (error "Unexpected output from mtn at '%s':%d:'%s'" - (current-buffer) - (point) - (buffer-substring (point) (min (point-max) (+ (point) 100)))) - )))))) - - (exit-loop (return)))))) - nil) - -(defvar xmtn-automate--*preserve-buffers-for-debugging* nil) - -(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" (id $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) - (xmtn-automate-command-output-lines - root - (list "heads" - (or branch - (xmtn--tree-default-branch root))))) - -(defun xmtn--rev-author (root rev) - "Return first author of REV" - (let (cert-name - result) - (with-temp-buffer - (xmtn-automate-command-output-buffer root (current-buffer) (list "certs" rev)) - (goto-char (point-min)) - ;; key [46ec58576f9e4f34a9eede521422aa5fd299dc50] - ;; signature "ok" - ;; name "author" - ;; value "beth" - ;; trust "trusted" - ;; - ;; ... - (while (not result) - (xmtn-basic-io-skip-line "key") - (xmtn-basic-io-skip-line "signature") - (xmtn-basic-io-check-line "name" (setq cert-name (cadar value))) - (xmtn-basic-io-check-line "value" - (if (string= cert-name "author") - (setq result (cadar value)))) - (xmtn-basic-io-skip-line "trust") - (xmtn-basic-io-check-empty))) - result)) - -(defun xmtn--tree-default-branch (root) - (xmtn-automate-command-output-line root `("get_option" "branch"))) - -(defun xmtn--get-corresponding-path-raw (root normalized-file-name - source-revision-hash-id - target-revision-hash-id) - "Given NORMALIZED-FILE-NAME in SOURCE-REVISION-HASH-ID, return file name in 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--insert-file-contents (root content-hash-id buffer) - (check-type content-hash-id xmtn--hash-id) - (xmtn-automate-command-output-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))))) - (case (car backend-id) - ((local-tree last-revision) - ;; file may have been renamed but not committed - (setq normalized-file-name (xmtn--get-rename-in-workspace-to root normalized-file-name))) - (t nil)) - - (let ((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-command-output-buffer root buffer cmd)))) - -(defun xmtn--get-file-by-id (root file-id save-as) - "Store contents of FILE-ID in file SAVE-AS." - (with-temp-file save-as - (set-buffer-multibyte nil) - (setq buffer-file-coding-system 'binary) - (xmtn--insert-file-contents root file-id (current-buffer)))) - -(provide 'xmtn-automate) - -;;; xmtn-automate.el ends here diff --git a/dvc/lisp/xmtn-base.el b/dvc/lisp/xmtn-base.el deleted file mode 100644 index 042d63a..0000000 --- a/dvc/lisp/xmtn-base.el +++ /dev/null @@ -1,90 +0,0 @@ -;;; xmtn-base.el --- Basic definitions for accessing monotone - -;; Copyright (C) 2009, 2010 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.") - -(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)))) - -(defun xmtn--filter-non-ws (dir) - "Return list of all mtn workspaces in DIR." - (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)) - (file-directory-p (concat filename "/_MTN"))) - filename)) - subdirs)) - (delq nil subdirs))) - -(defvar xmtn--*enable-assertions* nil - "Effective at macroexpansion time.") - -(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 deleted file mode 100644 index e6494fe..0000000 --- a/dvc/lisp/xmtn-basic-io.el +++ /dev/null @@ -1,378 +0,0 @@ -;;; xmtn-basic-io.el --- A parser for monotone's basic_io output format - -;; Copyright (C) 2008, 2010 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-skip-stanza () - "Skip to end of stanza at point." - (while (not (memq (xmtn-basic-io--next-parsed-line) '(empty eof))))) - -(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 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 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, and return t. List is of -form ((category value) ...). Else reset to parse the same line -again, and return nil." - (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 - t) - (beginning-of-line 0) ;; returns nil - ))) - -(defmacro xmtn-basic-io-optional-line-2 (expected body-present) - "Read basic-io line at point. If its contents equal EXPECTED (a -list of (category value) pairs), execute BODY-PRESENT, and return -t. Else reset to parse the same line again, and return nil." - (declare (indent 1) (debug (sexp body))) - `(let ((line (xmtn-basic-io--next-parsed-line))) - (if (and (not (member line '(empty eof))) - (equal line ,expected)) - (progn - ,body-present - t) - (beginning-of-line 0) ;; returns nil - ))) - -(defmacro xmtn-basic-io-check-line (expected-key body) - "Read 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-skip-line (expected-key) - "Read basic-io line at point. Error if it is `empty' or -`eof', or if its key is not EXPECTED-KEY (a string). Otherwise -skip do nothing." - (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)))) - -(defun xmtn-basic-io-optional-skip-line (expected-key) - "Read basic-io line at point. If its key is EXPECTED-KEY (a -string) return t. Else reset to parse the same line again, and -return nil." - (let ((line (xmtn-basic-io--next-parsed-line))) - (if (and (not (member line '(empty eof))) - (string= (car line) expected-key)) - t - (beginning-of-line 0) ;; returns nil - ))) - -(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 - 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 deleted file mode 100644 index c528f15..0000000 --- a/dvc/lisp/xmtn-compat.el +++ /dev/null @@ -1,48 +0,0 @@ -;;; xmtn-compat.el --- xmtn compatibility with different Emacs versions - -;; Copyright (C) 2008, 2009 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)) - -(defmacro xmtn--set-process-query-on-exit-flag (process value) - (if (fboundp 'set-process-query-on-exit-flag) - ;; emacs 22.2 and greater - `(set-process-query-on-exit-flag ,process ,value) - `(progn - ;; emacs 22.1 - (process-kill-without-query ,process ,value) - ,value))) - -(provide 'xmtn-compat) - -;;; xmtn-compat.el ends here diff --git a/dvc/lisp/xmtn-conflicts.el b/dvc/lisp/xmtn-conflicts.el deleted file mode 100644 index 2476299..0000000 --- a/dvc/lisp/xmtn-conflicts.el +++ /dev/null @@ -1,1352 +0,0 @@ -;;; xmtn-conflicts.el --- conflict resolution for DVC backend for monotone - -;; Copyright (C) 2008 - 2011 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-when-compile - ;; these have macros we use - (require 'cl) - (require 'dvc-utils)) - -(eval-and-compile - ;; these have functions we use - (require 'dired) - (require 'xmtn-automate) - (require 'xmtn-basic-io) - (require 'xmtn-run) - (require 'xmtn-ids)) - -(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) - -(defvar xmtn-conflicts-right-work "" - "Buffer-local variable holding right workspace root.") -(make-variable-buffer-local 'xmtn-conflicts-right-work) - -(defvar xmtn-conflicts-left-resolution-root "" - "Buffer-local variable holding left resolution root directory - name; relative to workspace root.") -(make-variable-buffer-local 'xmtn-conflicts-left-resolution-root) - -(defvar xmtn-conflicts-right-resolution-root "" - "Buffer-local variable holding right resolution root directory - name; relative to workspace root.") -(make-variable-buffer-local 'xmtn-conflicts-right-resolution-root) - -(defvar xmtn-conflicts-left-branch "" - "Buffer-local variable holding left branch.") -(make-variable-buffer-local 'xmtn-conflicts-left-branch) - -(defvar xmtn-conflicts-right-branch "" - "Buffer-local variable holding right branch.") -(make-variable-buffer-local 'xmtn-conflicts-right-branch) - -(defvar xmtn-conflicts-left-author "" - "Buffer-local variable holding left author.") -(make-variable-buffer-local 'xmtn-conflicts-left-author) - -(defvar xmtn-conflicts-right-author "" - "Buffer-local variable holding right branch.") -(make-variable-buffer-local 'xmtn-conflicts-right-author) - -(defvar xmtn-conflicts-ancestor-revision nil - "Buffer-local variable holding ancestor revision id.") -(make-variable-buffer-local 'xmtn-conflicts-ancestor-revision) - -(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-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-resolution-root', -`xmtn-conflicts-right-revision', `xmtn-conflicts-right-resolution-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, -right-branch, -left-author, - ;; -right-author set by xmtn-conflicts-load-opts - - (if (string= xmtn-conflicts-left-branch xmtn-conflicts-right-branch) - (progn - (setq xmtn-conflicts-left-resolution-root "_MTN/resolutions/left") - (setq xmtn-conflicts-right-resolution-root "_MTN/resolutions/right")) - (progn - (setq xmtn-conflicts-left-resolution-root (concat "_MTN/resolutions/" xmtn-conflicts-left-branch)) - (setq xmtn-conflicts-right-resolution-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_left} - (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_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" - ;; - ;; conflict duplicate_name - ;; left_type "added file" - ;; left_name "build/x86_gnu_windows_release/gds_mms_test.gpr" - ;; left_file_id [8d5d8fd099442bfb5d636d6435c241c8cd83f4f9] - ;; right_type "renamed file" - ;; ancestor_name "build/x86_gnu_windows_release/gds_test.gpr" - ;; ancestor_file_id [e2eb7393d9cda23a467622744a392adde63fc850] - ;; right_name "build/x86_gnu_windows_release/gds_mms_test.gpr" - ;; right_file_id [cec70e80402418bb95dcdeb6abe1356084ff5ece] - ;; - ;; 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))) - (cond - ((string= "added file" (xmtn-conflicts-conflict-left_type conflict)) - (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)))) - - ((string= "added directory" (xmtn-conflicts-conflict-left_type conflict)) - (xmtn-basic-io-check-line "left_name" (setf (xmtn-conflicts-conflict-left_name conflict) (cadar value)))) - - ((string= "renamed file" (xmtn-conflicts-conflict-left_type conflict)) - (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)))) - - (t - (error "unsupported left_type %s" (xmtn-conflicts-conflict-left_type conflict)))) - - (xmtn-basic-io-check-line "right_type" (setf (xmtn-conflicts-conflict-right_type conflict) (cadar value))) - (cond - ((string= "added file" (xmtn-conflicts-conflict-right_type conflict)) - (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= "added directory" (xmtn-conflicts-conflict-right_type conflict)) - (xmtn-basic-io-check-line "right_name" (setf (xmtn-conflicts-conflict-right_name conflict) (cadar value)))) - - ((string= "renamed file" (xmtn-conflicts-conflict-right_type conflict)) - (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 "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)))) - (t - (error "unsupported right_type %s" (xmtn-conflicts-conflict-right_type conflict)))) - - ;; 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 " Left author : %s\n" xmtn-conflicts-left-author) - (format " Right branch : %s\n" xmtn-conflicts-right-branch) - (format " Right author : %s\n" xmtn-conflicts-right-author) - (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 - ;; if there is no ancestor revision, then left is ancestor of - ;; right or vice versa, and there can be no conflicts. - (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-load-opts) - (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) ;; kills non-permanent buffer-local variables - (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 revisions from 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)) - (if (with-current-buffer ewoc-buffer xmtn-conflicts-ancestor-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)) - ;; ancestor can be null if this is a new file - (if (xmtn-conflicts-conflict-ancestor_file_id conflict) - (xmtn-basic-io-write-id "ancestor_file_id" (xmtn-conflicts-conflict-ancestor_file_id conflict)) - (xmtn-basic-io-write-id "ancestor_file_id" "")) - (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)) - (cond - ((string= "added file" (xmtn-conflicts-conflict-left_type 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))) - - ((string= "added directory" (xmtn-conflicts-conflict-left_type conflict)) - (xmtn-basic-io-write-str "left_name" (xmtn-conflicts-conflict-left_name conflict))) - - ((string= "renamed file" (xmtn-conflicts-conflict-left_type conflict)) - (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))) - (t - (error "unsupported left_type %s" (xmtn-conflicts-conflict-left_type conflict)))) - - (xmtn-basic-io-write-str "right_type" (xmtn-conflicts-conflict-right_type conflict)) - (cond - ((string= "added file" (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))) - - ((string= "added directory" (xmtn-conflicts-conflict-right_type conflict)) - (xmtn-basic-io-write-str "right_name" (xmtn-conflicts-conflict-right_name conflict))) - - ((string= "renamed file" (xmtn-conflicts-conflict-right_type conflict)) - (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 "right_name" (xmtn-conflicts-conflict-right_name conflict)) - (xmtn-basic-io-write-id "right_file_id" (xmtn-conflicts-conflict-right_file_id conflict))) - (t - (error "unsupported right_type %s" (xmtn-conflicts-conflict-right_type 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 buffer) - "Write EWOC elements in basic-io format to BUFFER." - (setq xmtn-conflicts-resolved-count 0) - (setq xmtn-conflicts-resolved-internal-count 0) - (ewoc-map - (lambda (conflict) - (with-current-buffer 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) - (let ((ewoc (with-current-buffer ewoc-buffer xmtn-conflicts-ewoc))) - (xmtn-conflicts-write-conflicts ewoc (current-buffer)) - - ;; 'update' not needed for save, but it's nice for the user - (with-current-buffer ewoc-buffer (xmtn-conflicts-update-counts)) - )) - -;; Arrange for xmtn-conflicts-save to be called by save-buffer. We -;; also 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." - (interactive) - (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) - (xmtn-conflicts-set-hf)) - -(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) - (with-current-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 (work 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 work file-id file) - file)) - -(defun xmtn-conflicts-resolve-ediff (side) - "Resolve the current conflict via ediff SIDE." - (interactive) - (if (buffer-live-p 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 default-directory - (xmtn-conflicts-conflict-ancestor_file_id conflict) - "_MTN/resolutions/ancestor" - (xmtn-conflicts-conflict-ancestor_name conflict)))) - (file-left (xmtn-conflicts-get-file xmtn-conflicts-left-work - (xmtn-conflicts-conflict-left_file_id conflict) - xmtn-conflicts-left-resolution-root - (xmtn-conflicts-conflict-left_name conflict))) - (file-right (xmtn-conflicts-get-file xmtn-conflicts-right-work - (xmtn-conflicts-conflict-right_file_id conflict) - xmtn-conflicts-right-resolution-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 (resolve-side default-side) - "Resolve the current conflict by user_RESOLVE-SIDE. Default to file from DEFAULT-SIDE." - (interactive) - (let* ((elem (ewoc-locate xmtn-conflicts-ewoc)) - (conflict (ewoc-data elem)) - (result-file - (expand-file-name - (read-file-name "resolution file: " - (ecase default-side - (left (file-name-as-directory xmtn-conflicts-left-work)) - (right (file-name-as-directory xmtn-conflicts-right-work))) - nil t - (ecase default-side - (left (xmtn-conflicts-conflict-left_name conflict)) - (right (xmtn-conflicts-conflict-right_name conflict))))))) - (ecase resolve-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-left_resolution-needed (conflict) - (let ((res (xmtn-conflicts-conflict-left_resolution conflict))) - (or (not res) - (eq (car res) 'resolved_internal)))) - -(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 (xmtn-conflicts-left_resolution-needed 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-right_resolution-needed (conflict) - (let ((res (xmtn-conflicts-conflict-right_resolution conflict))) - (or (not res) - (eq (car res) 'resolved_internal)))) - -(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-right_resolution-needed 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)))) - -(defun xmtn-conflicts-left-label () - "Return 'left: ' or '' as 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 thus a 'left' label - (if (equal type 'duplicate_name) - "left: " - ""))) - -(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 [?b] '(menu-item "b) right: drop" - xmtn-conflicts-resolve-drop_right - :visible (xmtn-conflicts-resolve-drop_rightp))) - (define-key map [?a] '(menu-item "a) right: rename" - (lambda () - (interactive) - (xmtn-conflicts-resolve-rename 'right)) - :visible (xmtn-conflicts-resolve-rename_rightp))) - (define-key map [?9] '(menu-item "9) right: right file" - (lambda () - (interactive) - (xmtn-conflicts-resolve-user 'right 'right)) - :visible (xmtn-conflicts-resolve-user_rightp))) - (define-key map [?8] '(menu-item "8) right: left file" - (lambda () - (interactive) - (xmtn-conflicts-resolve-user 'right 'left)) - :visible (xmtn-conflicts-resolve-user_rightp))) - (define-key map [?7] '(menu-item "7) right: keep" - xmtn-conflicts-resolve-keep_right - :visible (xmtn-conflicts-resolve-keep_rightp))) - (define-key map [?6] '(menu-item "6) right: ediff" - (lambda () - (interactive) - (xmtn-conflicts-resolve-ediff 'right)) - :visible (xmtn-conflicts-resolve-user_rightp))) - - (define-key map [?5] '(menu-item (concat "5) " (xmtn-conflicts-left-label) "right file") - (lambda () - (interactive) - (xmtn-conflicts-resolve-user 'left 'right)) - :visible (xmtn-conflicts-resolve-user_leftp))) - (define-key map [?4] '(menu-item (concat "4) " (xmtn-conflicts-left-label) "left file") - (lambda () - (interactive) - (xmtn-conflicts-resolve-user 'left 'left)) - :visible (xmtn-conflicts-resolve-user_leftp))) - (define-key map [?3] '(menu-item (concat "3) " (xmtn-conflicts-left-label) "drop") - xmtn-conflicts-resolve-drop_left - :visible (xmtn-conflicts-resolve-drop_leftp))) - (define-key map [?2] '(menu-item (concat "2) " (xmtn-conflicts-left-label) "rename") - (lambda () - (interactive) - (xmtn-conflicts-resolve-rename 'left)) - :visible (xmtn-conflicts-resolve-rename_leftp))) - (define-key map [?1] '(menu-item (concat "1) " (xmtn-conflicts-left-label) "keep") - xmtn-conflicts-resolve-keep_left - :visible (xmtn-conflicts-resolve-keep_leftp))) - (define-key map [?0] '(menu-item (concat "0) " (xmtn-conflicts-left-label) "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-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 [?u] 'xmtn-conflicts-update-counts) - (define-key map "\M-d" xmtn-conflicts-resolve-map) - 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] - ["Ediff resolution to ws" xmtn-conflicts-ediff-resolution-ws t] - ["Add log entry" xmtn-conflicts-add-log-entry 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)) - - (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 left-branch right-branch left-rev right-rev) - "Store LEFT-*, RIGHT-* in `xmtn-conflicts-opts-file', for -retrieval by `xmtn-conflicts-load-opts'." - ;; need correct buffer-local variable names for load-opts - (let ((xmtn-conflicts-left-work left-work) - (xmtn-conflicts-right-work right-work) - (xmtn-conflicts-left-branch left-branch) - (xmtn-conflicts-right-branch right-branch) - (xmtn-conflicts-left-author (xmtn--rev-author left-work left-rev)) - (xmtn-conflicts-right-author (xmtn--rev-author right-work right-rev))) - - (dvc-save-state (list 'xmtn-conflicts-left-work - 'xmtn-conflicts-left-branch - 'xmtn-conflicts-left-author - 'xmtn-conflicts-right-work - 'xmtn-conflicts-right-branch - 'xmtn-conflicts-right-author) - (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-load-file () - "Load _MTN/conflicts for default-directory." - (dvc-switch-to-buffer-maybe (dvc-get-buffer-create 'xmtn 'conflicts default-directory)) - (setq buffer-read-only nil) - (set (make-local-variable 'after-insert-file-functions) '(xmtn-conflicts-after-insert-file)) - (insert-file-contents "_MTN/conflicts" t nil nil t)) - -(defun xmtn-conflicts-1 (left-work left-rev right-work right-rev &optional left-branch right-branch) - "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 left-branch right-branch left-rev right-rev) - (xmtn-automate-command-output-file - default-directory - "_MTN/conflicts" - (list "show_conflicts" left-rev right-rev)) - (xmtn-conflicts-load-file))) - -(defun xmtn-conflicts-review (left-work left-rev right-work right-rev left-branch right-branch show) - "Review conflicts between LEFT-WORK (a directory), rev LEFT-REV, -and RIGHT-WORK, rev RIGHT-REV. If LEFT_WORK/_MTN/conflicts -exists and is current, display it. Otherwise generate a new -RIGHT_WORK/_MTN/conflicts file and display that. Return the -conflicts buffer." - (let ((default-directory right-work) - (dvc-switch-to-buffer-first show)) - (if (file-exists-p "_MTN/conflicts") - (progn - (xmtn-conflicts-load-file) - (if (not (and (string-equal xmtn-conflicts-left-revision left-rev) - (string-equal xmtn-conflicts-left-work left-work) - (string-equal xmtn-conflicts-right-revision right-rev) - (string-equal xmtn-conflicts-right-work right-work))) - ;; file not current; regenerate - (xmtn-conflicts-1 left-work left-rev right-work right-rev left-branch right-branch))) - - ;; else generate new file - (xmtn-conflicts-1 left-work left-rev right-work right-rev left-branch right-branch))) - (current-buffer)) - -(defun xmtn-conflicts-status (buffer left-work left-rev right-work right-rev left-branch right-branch) - "Return '(status buffer), where status is one of 'need-resolve -| 'need-review-resolve-internal | 'resolved | 'none for -BUFFER. Regenerate conflicts if not current. Conflicts stored in -RIGHT-WORK." - (if (buffer-live-p buffer) - ;; check if buffer still current - (with-current-buffer buffer - (let ((revs-current - (and (string= left-rev xmtn-conflicts-left-revision) - (string= right-rev xmtn-conflicts-right-revision)))) - (if revs-current - (progn - (xmtn-conflicts-update-counts) - (save-buffer)) - ;; else reload or regenerate - (save-excursion - (setq buffer - (xmtn-conflicts-review - left-work left-rev right-work right-rev left-branch right-branch nil)))))) - - ;; else reload or regenerate - (save-excursion - (setq buffer - (xmtn-conflicts-review - left-work left-rev right-work right-rev left-branch right-branch nil)))) - - ;; compute status - (with-current-buffer buffer - (case xmtn-conflicts-total-count - (0 (list buffer 'none)) - (t - (cond - ((= xmtn-conflicts-total-count xmtn-conflicts-resolved-count) - (if (> xmtn-conflicts-resolved-internal-count 0) - (list buffer 'need-review-resolve-internal) - (list buffer 'resolved))) - (t - (list buffer 'need-resolve))))))) - -;;;###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)) - - (message "conflicts cleaned") - )) - -(provide 'xmtn-conflicts) - -;; end of file diff --git a/dvc/lisp/xmtn-dvc.el b/dvc/lisp/xmtn-dvc.el deleted file mode 100644 index b10a0e8..0000000 --- a/dvc/lisp/xmtn-dvc.el +++ /dev/null @@ -1,1434 +0,0 @@ -;;; xmtn-dvc.el --- DVC backend for monotone - -;; Copyright (C) 2008 - 2011 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) ;; yes, we are using cl at runtime; we're working towards eliminating that. - (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) - &body body) - (declare (indent 1) (debug (sexp body))) - (let ((root (gensym)) - (command (gensym)) - (session (gensym)) - (handle (gensym))) - `(let ((,root ,root-form) - (,command ,command-form)) - (let* ((,session (xmtn-automate-cache-session ,root)) - (,handle (xmtn-automate--new-command ,session ,command))) - (xmtn-automate-command-wait-until-finished ,handle) - (prog1 - (xmtn-basic-io-with-stanza-parser - (,parser (xmtn-automate-command-buffer ,handle)) - ,@body) - (xmtn-automate--cleanup-command ,handle)))))) - -;;;###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-command-output-lines root - `("toposort" - ,@revision-hash-ids))) - -;;;###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) - ))) - -(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)))) - -;;;###autoload -(defun xmtn-dvc-log-edit-done (&optional prompt-branch) - (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 (if prompt-branch - (progn - ;; an automate session caches the original - ;; options, and will not use the new branch. - (let ((session (xmtn-automate-get-cached-session (dvc-uniquify-file-name root)))) - (if session (xmtn-automate--close-session session))) - (read-from-minibuffer "branch: " (xmtn--tree-default-branch root))) - (xmtn--tree-default-branch root)))) - (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 nicely 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) - "--non-interactive" - ,@(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) - (dvc-default-error-function output error - status arguments)) - :killed (lambda (output error status arguments) - (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.) - - ;; we'd like to delete log-edit-buffer here, but we - ;; can't do that from a process sentinel. And we'd - ;; have to find it; it may not be current buffer, - ;; if log-edit-done was invoked from the ediff - ;; window. - - (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))) - -(defun xmtn-show-commit () - "Show commit command for use on command line" - (interactive) - (let ((excluded-files - (with-current-buffer dvc-partner-buffer - (xmtn--normalize-file-names default-directory (dvc-fileinfo-excluded-files))))) - - (save-buffer) - (dvc-save-some-buffers default-directory) - - ;; 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")) - - (message - (concat - "mtn commit " - (xmtn-dvc-log-message) - " " - (if excluded-files - (mapconcat (lambda (file) (concat "--exclude=" file)) excluded-files " ")))) - (pop-to-buffer "*Messages*"))) - -;; Add xmtn-show-commit to dvc-log-edit menu -(defvar xmtn-log-edit-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [(control ?c) (control ?s)] 'xmtn-show-commit) - map)) - -(easy-menu-define xmtn-log-edit-mode-menu xmtn-log-edit-mode-map - "Mtn specific log-edit menu." - `("DVC-Mtn" - ["Show commit command" xmtn-show-commit t] - )) - -(define-derived-mode xmtn-log-edit-mode dvc-log-edit-mode "xmtn-log-edit" - "Add back-end-specific commands for dvc-log-edit.") - -(dvc-add-uniquify-directory-mode 'xmtn-log-edit-mode) - -;; 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 (or 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-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-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)))))) - -(defun xmtn--rev-to-option (resolved from) - "Return a string contaiing the mtn diff command-line option for RESOLVED. -If FROM is non-nil, RESOLVED is assumed older than workspace; -otherwise newer." - (ecase (car resolved) - ('local-tree - (if from - "--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))) - -(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))) - -(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 new-path)) - - (rename-target - (setq more-status 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 - ;; 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 (list "automate" "inventory" "--no-unchanged" "--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) - (dvc-diff-error-in-process ;; correct for status-mode as well - 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))))))) - -(defun xmtn--status-inventory-sync (root) - "Create or reuse a status buffer for ROOT; return `(buffer status)', -where `status' is 'ok or 'need-commit." - (let* - ((orig-buffer (current-buffer)) - (msg (concat "running inventory for " root " ...")) - (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)) - (output-buffer (generate-new-buffer " *xmtn-inventory*")) - status - (dvc-switch-to-buffer-first nil) - (status-buffer - (dvc-status-prepare-buffer - 'xmtn - root - ;; 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) - (message msg) - (xmtn-automate-command-output-buffer - root output-buffer - (list (list "no-unchanged" "" "no-ignored" "") - "inventory")) - (with-current-buffer output-buffer - (setq status - (if (> (point-max) (point-min)) - 'need-commit - 'ok))) - (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-buffer) - (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)))) - (kill-buffer output-buffer) - (set-buffer orig-buffer) - (message (concat msg " done")) - (list status-buffer status))) - -;;;###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)))))) - (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) - (list (xmtn--perl-regexp-for-file-name 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))) - -;;;###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. -;;;###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-update (root target-revision-hash-id post-update-p) - (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)) - (post-update-p post-update-p)) - (let ((command `("update" "--move-conflicting-paths" ,(concat "--revision=" target-revision-hash-id))) - (post-process - (lambda () - (message "%s... done" progress-message) - (if post-update-p - (progn - (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 check-id-p no-ding) - ;; mtn will just give an innocuous message if already updated, which - ;; the user won't see. So check that here - it's fast. - ;; Don't throw an error; upper level might be doing other directories as well. - (if (and check-id-p - (equal (xmtn--get-base-revision-hash-id-or-null root) target-revision-hash-id)) - (progn - (unless no-ding (ding)) - (message "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 check-id-p))) - -;;;###autoload -(defun xmtn-dvc-update (&optional revision-id no-ding) - (let ((root (dvc-tree-root))) - (if revision-id - (xmtn--update root (xmtn--revision-hash-id revision-id) t no-ding) - - (let* ((branch (xmtn--tree-default-branch root)) - (heads (xmtn--heads root branch))) - (case (length heads) - (0 - (error "branch %s has no revisions" branch)) - - (1 - (xmtn--update root (first heads) t no-ding)) - - (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 &optional cached-branch) - "Propagate from OTHER branch to CACHED-BRANCH (default local tree branch). -Conflict resolution taken from `default-directory', which must be -a workspace for CACHED-BRANCH." - (interactive "MPropagate from branch: ") - (let* - ((root (dvc-tree-root)) - (local-branch (or cached-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 - ;; may be resurrecting a suspended branch; doesn't hurt otherwise. - "--ignore-suspend-certs" - (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) - (xmtn--refresh-status-header display-buffer) - (message "%s... done" msg))))) - -(defun xmtn-dvc-merge-1 (root refresh-status) - (xmtn--run-command-sync - root - (list - "merge" - (if (file-exists-p (concat root "/_MTN/conflicts")) - "--resolve-conflicts-file=_MTN/conflicts") - (xmtn-dvc-log-message))) - (if refresh-status - (xmtn--refresh-status-header (current-buffer)))) - -;;;###autoload -(defun xmtn-dvc-merge (&optional other) - (if other - (xmtn-propagate-from other) - ;; else merge heads - (let* ((root (dvc-tree-root)) - (branch (xmtn--tree-default-branch root)) - (heads (xmtn--heads root branch))) - (case (length heads) - (0 (assert nil)) - (1 - (message "already merged")) - (t - (xmtn-dvc-merge-1 root t))))) - 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. - ;; This output is not useful; xmtn-sync, xmtn-sync-review is much better - (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)) - (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)) - (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 in revision BACKEND-ID." - (let ((root (dvc-tree-root))) - (let ((normalized-file (xmtn--normalize-file-name root file)) - (temp-dir nil)) - (unwind-protect - (progn - (setq temp-dir (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 "/" normalized-file))) - (make-directory (file-name-directory temp-file) t) - (with-temp-file temp-file - (set-buffer-multibyte nil) - (setq buffer-file-coding-system 'binary) - (xmtn--insert-file-contents-by-name root backend-id normalized-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." - (with-temp-file save-as - (set-buffer-multibyte nil) - (setq buffer-file-coding-system 'binary) - (xmtn--insert-file-contents root file-id (current-buffer)))) - -(defun xmtn--limit-length (list n) - (or (null n) (<= (length list) n))) - -(defun xmtn--get-corresponding-path (root normalized-file-name - source-revision-backend-id - target-revision-backend-id) - ;; normalized-file-name is a file in - ;; source-revision-backend-id. Return its name in - ;; target-revision-backend-id. - (block get-corresponding-path - (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) - (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) - (return-from get-corresponding-path normalized-file-name))) - ;; Handle an uncommitted rename in the current workspace - (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) - (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) - ;; Handle an uncommitted rename in the current workspace - (setq 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) - ;; Given a workspace ROOT and a file name - ;; NORMALIZED-SOURCE-FILE-NAME in the base revision of the - ;; workspace, return the current name of that file in the workspace. - ;; 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) - ;; Given a workspace ROOT and a file name - ;; NORMALIZED-TARGET-FILE-NAME in the current revision of the - ;; workspace, return the name of that file in the base revision of - ;; the workspace. - ;; 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--file-contents-as-string (root content-hash-id) - (check-type content-hash-id xmtn--hash-id) - (xmtn-automate-command-output-string - root `("get_file" ,content-hash-id))) - -(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--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-hooks.lua b/dvc/lisp/xmtn-hooks.lua deleted file mode 100644 index fd68bf1..0000000 --- a/dvc/lisp/xmtn-hooks.lua +++ /dev/null @@ -1,99 +0,0 @@ --- xmtn-hooks.lua --- mtn Lua hook functions used in all xmtn automate --- stdio sessions --- --- Copyright (C) 2010 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. - -function get_netsync_connect_command(uri, args) - - local argv = nil - - if uri["scheme"] == "ssh" then - argv = { "ssh" } - - if uri["user"] then - table.insert(argv, "-l") - table.insert(argv, uri["user"]) - end - if uri["port"] then - table.insert(argv, "-p") - table.insert(argv, uri["port"]) - end - - table.insert(argv, uri["host"]) - - if xmtn_sync_ssh_exec then - if xmtn_sync_ssh_exec [uri["host"]] then - table.insert(argv, xmtn_sync_ssh_exec [uri["host"]]) - else - table.insert(argv, "mtn") - end - else - table.insert(argv, "mtn") - end - - if args["debug"] then - table.insert(argv, "--verbose") - else - table.insert(argv, "--quiet") - end - - table.insert(argv, "--db") - table.insert(argv, uri["path"]) - table.insert(argv, "serve") - table.insert(argv, "--stdio") - table.insert(argv, "--no-transport-auth") - - - elseif uri["scheme"] == "file" then - if xmtn_sync_file_exec then - argv = { xmtn_sync_file_exec } - else - if string.sub(get_ostype(), 1, 6) == "CYGWIN" then - -- assume Cygwin mtn is not first in path - argv = { "c:/bin/mtn" } - else - -- otherwise assume first mtn in path is correct - argv = { "mtn" } - end - end - - if args["debug"] then - table.insert(argv, "--verbose") - else - table.insert(argv, "--quiet") - end - - table.insert(argv, "--db") - table.insert(argv, uri["path"]) - table.insert(argv, "serve") - table.insert(argv, "--stdio") - table.insert(argv, "--no-transport-auth") - - elseif uri["scheme"] == "mtn" then - argv = {} - - else - error(uri["scheme"] .. " not supported") - end - return argv -end - --- end of file diff --git a/dvc/lisp/xmtn-ids.el b/dvc/lisp/xmtn-ids.el deleted file mode 100644 index 44a8d57..0000000 --- a/dvc/lisp/xmtn-ids.el +++ /dev/null @@ -1,244 +0,0 @@ -;;; xmtn-ids.el --- Resolver routines for xmtn revision ids - -;; Copyright (C) 2008 - 2011 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--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--get-parent-revision-hash-id (root hash-id local-branch) - (check-type hash-id xmtn--hash-id) - (let ((parents (xmtn-automate-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 this revision is the result of a propagate, there are two parents, one of which is on the local branch - (let ((first-parent-branch (xmtn--branch-of root (first parents)))) - (if (equal local-branch first-parent-branch) - (first parents) - (second parents))) - )))) - -(defun xmtn--resolve--previous-revision (root backend-id num) - (check-type num (integer 0 *)) - (let ((local-branch (xmtn--tree-default-branch root)) - (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 local-branch))) - `(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-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 - (session (xmtn-automate-cache-session default-directory)) - (handle (xmtn-automate--new-command 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))))) - ))) - (xmtn-automate--cleanup-command handle) - result)) - -(defun xmtn--get-base-revision-hash-id-or-null (root) - (let ((hash-id (xmtn-automate-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 deleted file mode 100644 index 45a16f8..0000000 --- a/dvc/lisp/xmtn-match.el +++ /dev/null @@ -1,223 +0,0 @@ -;;; 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 deleted file mode 100644 index 3545fbf..0000000 --- a/dvc/lisp/xmtn-minimal.el +++ /dev/null @@ -1,47 +0,0 @@ -;;; 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-multi-status.el b/dvc/lisp/xmtn-multi-status.el deleted file mode 100644 index 3a10e79..0000000 --- a/dvc/lisp/xmtn-multi-status.el +++ /dev/null @@ -1,529 +0,0 @@ -;;; xmtn-status.el --- manage actions for multiple projects - -;; Copyright (C) 2009 - 2011 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-when-compile - ;; these have macros we use - (require 'xmtn-ids)) - -(eval-and-compile - ;; these have functions we use - (require 'xmtn-base) - (require 'xmtn-conflicts) - (require 'xmtn-revlist)) - -(defvar xmtn-status-root "" - "Buffer-local variable holding multi-workspace root directory.") -(make-variable-buffer-local 'xmtn-status-root) -(put 'xmtn-status-root 'permanent-local t) - -(defvar xmtn-status-ewoc nil - "Buffer-local ewoc for displaying multi-workspace status. -All xmtn-status functions operate on this ewoc. -The elements must all be of class xmtn-status-data.") -(make-variable-buffer-local 'xmtn-status-ewoc) -(put 'xmtn-status-ewoc 'permanent-local t) - -(defstruct (xmtn-status-data (:copier nil)) - work ; workspace directory name relative to xmtn-status-root - branch ; GDS branch name (all workspaces have same branch; assumed never changes) - need-refresh ; nil | t : if an async process was started that invalidates state data - head-revs ; either current head revision or (left, right) if multiple heads - conflicts-buffer ; *xmtn-conflicts* buffer for merge - status-buffer ; *xmtn-status* buffer for commit - heads ; 'need-scan | 'at-head | 'need-update | 'need-merge - (update-review - 'pending) ; 'pending | 'need-review | 'done - (local-changes - 'need-scan) ; 'need-scan | 'need-commit | 'ok - (conflicts - 'need-scan) ; 'need-scan | 'need-resolve | 'need-review-resolve-internal | 'resolved | 'none - ) - -(defun xmtn-status-work (data) - (concat xmtn-status-root (xmtn-status-data-work data))) - -(defun xmtn-status-need-refresh (elem data local-changes) - ;; The user has selected an action that will change the state of the - ;; workspace via mtn actions; set our data to reflect that. If - ;; local-changes is non-nil, xmtn-status-data-local-changes is set - ;; to that value. - (setf (xmtn-status-data-need-refresh data) t) - (setf (xmtn-status-data-heads data) 'need-scan) - (setf (xmtn-status-data-conflicts data) 'need-scan) - (if local-changes (setf (xmtn-status-data-local-changes data) local-changes)) - (ewoc-invalidate xmtn-status-ewoc elem)) - -(defun xmtn-status-printer (data) - "Print an ewoc element." - (insert (dvc-face-add (format "%s\n" (xmtn-status-data-work data)) 'dvc-keyword)) - - (if (xmtn-status-data-need-refresh data) - (insert (dvc-face-add " need refresh\n" 'dvc-conflict)) - - (ecase (xmtn-status-data-local-changes data) - (need-scan (insert " local changes not checked\n")) - (need-commit (insert (dvc-face-add " need commit\n" 'dvc-header))) - (ok nil)) - - (ecase (xmtn-status-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))) - (resolved - (insert " conflicts resolved\n")) - ((resolved none) nil)) - - (ecase (xmtn-status-data-heads data) - (at-head nil) - (need-update - (insert (dvc-face-add " need update\n" 'dvc-conflict))) - (need-merge - (insert (dvc-face-add " need merge\n" 'dvc-conflict)))) - - (ecase (xmtn-status-data-update-review data) - (pending nil) - (need-review (insert " need update review\n")) - (done nil)) - )) - -(defun xmtn-status-kill-conflicts-buffer (data) - (if (buffer-live-p (xmtn-status-data-conflicts-buffer data)) - (let ((buffer (xmtn-status-data-conflicts-buffer data))) - (with-current-buffer buffer (save-buffer)) - (kill-buffer buffer)))) - -(defun xmtn-status-kill-status-buffer (data) - (if (buffer-live-p (xmtn-status-data-status-buffer data)) - (kill-buffer (xmtn-status-data-status-buffer data)))) - -(defun xmtn-status-save-conflicts-buffer (data) - (if (buffer-live-p (xmtn-status-data-conflicts-buffer data)) - (with-current-buffer (xmtn-status-data-conflicts-buffer data) (save-buffer)))) - -(defun xmtn-status-clean-1 (data save-conflicts) - "Clean DATA workspace, kill associated automate session. -If SAVE-CONFLICTS non-nil, don't delete conflicts files." - (xmtn-automate-kill-session (xmtn-status-work data)) - (xmtn-status-kill-conflicts-buffer data) - (xmtn-status-kill-status-buffer data) - (unless save-conflicts - (xmtn-conflicts-clean (xmtn-status-work data)))) - -(defun xmtn-status-clean () - "Clean current workspace, delete from ewoc" - (interactive) - (let* ((elem (ewoc-locate xmtn-status-ewoc)) - (data (ewoc-data elem)) - (inhibit-read-only t)) - (xmtn-status-clean-1 data nil) - (ewoc-delete xmtn-status-ewoc elem))) - -(defun xmtn-status-clean-all (&optional save-conflicts) - "Clean all remaining workspaces." - (interactive) - (ewoc-map 'xmtn-status-clean-1 xmtn-status-ewoc save-conflicts)) - -(defun xmtn-status-cleanp () - "Non-nil if clean & quit is appropriate for current workspace." - (let ((data (ewoc-data (ewoc-locate xmtn-status-ewoc)))) - ;; don't check need-refresh here; allow deleting after just doing - ;; final required action in another buffer. - (and (member (xmtn-status-data-local-changes data) '(need-scan ok)) - (member (xmtn-status-data-heads data) '(need-scan at-head))))) - -(defun xmtn-status-do-refresh-one () - (interactive) - (let* ((elem (ewoc-locate xmtn-status-ewoc)) - (data (ewoc-data elem))) - (xmtn-status-refresh-one data current-prefix-arg) - (ewoc-invalidate xmtn-status-ewoc elem))) - -(defun xmtn-status-refreshp () - "Non-nil if refresh is appropriate for current workspace." - (let ((data (ewoc-data (ewoc-locate xmtn-status-ewoc)))) - (or (xmtn-status-data-need-refresh data) - ;; everything's done, but the user just did mtn sync, and more - ;; stuff showed up - (eq 'ok (xmtn-status-data-local-changes data)) - (eq 'at-head (xmtn-status-data-heads data))))) - -(defun xmtn-status-update () - "Update current workspace." - (interactive) - (let* ((elem (ewoc-locate xmtn-status-ewoc)) - (data (ewoc-data elem))) - (xmtn-status-need-refresh elem data nil) - (setf (xmtn-status-data-update-review data) 'need-review) - (let ((default-directory (xmtn-status-work data))) - (xmtn-dvc-update)) - (xmtn-status-refresh-one data nil) - (ewoc-invalidate xmtn-status-ewoc elem))) - -(defun xmtn-status-updatep () - "Non-nil if update is appropriate for current workspace." - (let ((data (ewoc-data (ewoc-locate xmtn-status-ewoc)))) - (and (not (xmtn-status-data-need-refresh data)) - (eq 'need-update (xmtn-status-data-heads data))))) - -(defun xmtn-status-update-preview () - "Preview update for current workspace." - (interactive) - (let* ((elem (ewoc-locate xmtn-status-ewoc)) - (data (ewoc-data elem)) - (default-directory (xmtn-status-work data))) - (xmtn-dvc-missing))) - -(defun xmtn-status-resolve-conflicts () - "Resolve conflicts for current workspace." - (interactive) - (let* ((elem (ewoc-locate xmtn-status-ewoc)) - (data (ewoc-data elem))) - (xmtn-status-need-refresh elem data nil) - (setf (xmtn-status-data-conflicts data) 'need-scan) - (pop-to-buffer (xmtn-status-data-conflicts-buffer data)))) - -(defun xmtn-status-resolve-conflictsp () - "Non-nil if resolve conflicts is appropriate for current workspace." - (let* ((data (ewoc-data (ewoc-locate xmtn-status-ewoc)))) - (and (not (xmtn-status-data-need-refresh data)) - (member (xmtn-status-data-conflicts data) - '(need-resolve need-review-resolve-internal))))) - -(defun xmtn-status-status () - "Show status buffer for current workspace." - (interactive) - (let* ((elem (ewoc-locate xmtn-status-ewoc)) - (data (ewoc-data elem))) - ;; assume they are doing a checkin - (xmtn-status-need-refresh elem data 'ok) - (pop-to-buffer (xmtn-status-data-status-buffer data)) - ;; IMPROVEME: create a log-edit buffer now, since we have both a - ;; status and conflict buffer, and that confuses dvc-log-edit - )) - -(defun xmtn-status-status-ok () - "Ignore local changes in current workspace." - (interactive) - (let* ((elem (ewoc-locate xmtn-status-ewoc)) - (data (ewoc-data elem))) - (setf (xmtn-status-data-local-changes data) 'ok) - (ewoc-invalidate xmtn-status-ewoc elem))) - -(defun xmtn-status-statusp () - "Non-nil if xmtn-status is appropriate for current workspace." - (let* ((data (ewoc-data (ewoc-locate xmtn-status-ewoc)))) - (and (not (xmtn-status-data-need-refresh data)) - (member (xmtn-status-data-local-changes data) - '(need-scan need-commit))))) - -(defun xmtn-status-update-review () - "Review last update for current workspace." - (interactive) - (let* ((elem (ewoc-locate xmtn-status-ewoc)) - (data (ewoc-data elem))) - ;; assume they are adding fixmes - (xmtn-status-need-refresh elem data 'need-scan) - (setf (xmtn-status-data-update-review data) 'done) - (xmtn-update-review (xmtn-status-work data)))) - -(defun xmtn-status-update-reviewp () - "Non-nil if xmtn-status-update-review is appropriate for current workspace." - (let* ((data (ewoc-data (ewoc-locate xmtn-status-ewoc)))) - (and (not (xmtn-status-data-need-refresh data)) - (eq 'need-review (xmtn-status-data-update-review data))))) - -(defun xmtn-status-merge () - "Run merge on current workspace." - (interactive) - (let* ((elem (ewoc-locate xmtn-status-ewoc)) - (data (ewoc-data elem)) - (default-directory (xmtn-status-work data))) - (xmtn-status-save-conflicts-buffer data) - (xmtn--run-command-sync - default-directory - (list - "explicit_merge" - (nth 0 (xmtn-status-data-head-revs data)) - (nth 1 (xmtn-status-data-head-revs data)) - (xmtn--tree-default-branch default-directory) - (if (file-exists-p "_MTN/conflicts") - "--resolve-conflicts-file=_MTN/conflicts") - (xmtn-dvc-log-message))) - (xmtn-status-refresh-one data nil) - (ewoc-invalidate xmtn-status-ewoc elem))) - -(defun xmtn-status-heads () - "Show heads for current workspace." - (interactive) - (let* ((elem (ewoc-locate xmtn-status-ewoc)) - (data (ewoc-data elem)) - (default-directory (xmtn-status-work data))) - (xmtn-status-need-refresh elem data nil) - (xmtn-view-heads-revlist))) - -(defun xmtn-status-headsp () - "Non-nil if xmtn-heads is appropriate for current workspace." - (let* ((data (ewoc-data (ewoc-locate xmtn-status-ewoc)))) - (and (not (xmtn-status-data-need-refresh data)) - (eq 'need-merge (xmtn-status-data-heads data))))) - -(defun xmtn-status-quit-save () - "Quit, but save conflicts files for later resume." - (interactive) - (remove-hook 'kill-buffer-hook 'xmtn-status-clean-all t) - (xmtn-status-clean-all t) - (kill-buffer)) - -(defvar xmtn-status-actions-map - (let ((map (make-sparse-keymap "actions"))) - (define-key map [?c] '(menu-item "c) clean/delete" - xmtn-status-clean - :visible (xmtn-status-cleanp))) - (define-key map [?g] '(menu-item "g) refresh" - xmtn-status-do-refresh-one - :visible (xmtn-status-refreshp))) - (define-key map [?i] '(menu-item "i) ignore local changes" - xmtn-status-status-ok - :visible (xmtn-status-statusp))) - (define-key map [?6] '(menu-item "6) preview update" - xmtn-status-update-preview - :visible (xmtn-status-updatep))) - (define-key map [?5] '(menu-item "5) update review" - xmtn-status-update-review - :visible (xmtn-status-update-reviewp))) - (define-key map [?4] '(menu-item "4) update" - xmtn-status-update - :visible (xmtn-status-updatep))) - (define-key map [?3] '(menu-item "3) merge" - xmtn-status-merge - :visible (xmtn-status-headsp))) - (define-key map [?2] '(menu-item "2) show heads" - xmtn-status-heads - :visible (xmtn-status-headsp))) - (define-key map [?1] '(menu-item "1) resolve conflicts" - xmtn-status-resolve-conflicts - :visible (xmtn-status-resolve-conflictsp))) - (define-key map [?0] '(menu-item "0) commit" - xmtn-status-status - :visible (xmtn-status-statusp))) - map) - "Keyboard menu keymap used in multiple-status mode.") - -(dvc-make-ewoc-next xmtn-status-next xmtn-status-ewoc) -(dvc-make-ewoc-prev xmtn-status-prev xmtn-status-ewoc) - -(defvar xmtn-multiple-status-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\M-d" xmtn-status-actions-map) - (define-key map [?g] 'xmtn-status-refresh) - (define-key map [?m] 'xmtn-status-update-preview) - (define-key map [?n] 'xmtn-status-next) - (define-key map [?p] 'xmtn-status-prev) - (define-key map [?r] 'xmtn-status-update-review) - (define-key map [?s] 'xmtn-status-quit-save) - (define-key map [?q] 'dvc-buffer-quit) - map) - "Keymap used in `xmtn-multiple-status-mode'.") - -(easy-menu-define xmtn-multiple-status-mode-menu xmtn-multiple-status-mode-map - "Mtn specific status menu." - `("DVC-Mtn" - ["Do the right thing" xmtn-status-actions-map t] - ["Quit, clean conflicts" dvc-buffer-quit t] - ["Quit, save conflicts" xmtn-status-quit-save t] - ["Preview update" xmtn-status-update-preview t] - ["Review update" xmtn-status-update-review t] - )) - -(define-derived-mode xmtn-multiple-status-mode nil "xmtn-multiple-status" - "Major mode to show status of multiple workspaces." - (setq dvc-buffer-current-active-dvc 'xmtn) - (setq buffer-read-only nil) - - ;; 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) - (add-hook 'kill-buffer-hook 'xmtn-status-clean-all nil t) - (setq buffer-read-only t) - (buffer-disable-undo) - - (set-buffer-modified-p nil)) - -(defun xmtn-status-conflicts (data) - "Return value for xmtn-status-data-conflicts for DATA." - ;; only called if need merge; two items in head-revs - (let ((result (xmtn-conflicts-status - (xmtn-status-data-conflicts-buffer data) ; buffer - (xmtn-status-work data) ; left-work - (car (xmtn-status-data-head-revs data)) ; left-rev - (xmtn-status-work data) ; right-work - (cadr (xmtn-status-data-head-revs data)) ; right-rev - (xmtn-status-data-branch data) ; left-branch - (xmtn-status-data-branch data) ; right-branch - ))) - (setf (xmtn-status-data-conflicts-buffer data) (car result)) - (cadr result))) - -(defun xmtn-status-refresh-one (data refresh-local-changes) - "Refresh DATA." - (let ((work (xmtn-status-work data))) - - (message "checking heads for %s " work) - - (let ((heads (xmtn--heads work (xmtn-status-data-branch data))) - (base-rev (xmtn--get-base-revision-hash-id-or-null work))) - (case (length heads) - (1 - (setf (xmtn-status-data-head-revs data) (nth 0 heads)) - (setf (xmtn-status-data-conflicts data) 'none) - (if (string= (xmtn-status-data-head-revs data) base-rev) - (setf (xmtn-status-data-heads data) 'at-head) - (setf (xmtn-status-data-heads data) 'need-update))) - (t - (setf (xmtn-status-data-head-revs data) (list (nth 0 heads) (nth 1 heads))) - (setf (xmtn-status-data-heads data) 'need-merge)))) - - (message "") - - (if refresh-local-changes - (progn - (setf (xmtn-status-data-local-changes data) 'need-scan) - (setf (xmtn-status-data-update-review data) 'need-review))) - - (case (xmtn-status-data-local-changes data) - (need-scan - (let ((result (xmtn--status-inventory-sync (xmtn-status-work data)))) - (setf (xmtn-status-data-status-buffer data) (car result) - (xmtn-status-data-local-changes data) (cadr result))) ) - (t nil)) - - (case (xmtn-status-data-heads data) - (need-merge - (setf (xmtn-status-data-conflicts data) - (xmtn-status-conflicts data))) - (t - (xmtn-status-kill-conflicts-buffer data) - (xmtn-conflicts-clean (xmtn-status-work data)) - (setf (xmtn-status-data-conflicts data) 'none))) - - (setf (xmtn-status-data-need-refresh data) nil)) - - ;; return non-nil to refresh display as we go along - t) - -(defun xmtn-status-refresh () - "Refresh status of each ewoc element. With prefix arg, re-scan for local changes." - (interactive) - (ewoc-map 'xmtn-status-refresh-one xmtn-status-ewoc current-prefix-arg) - (message "done")) - -;;;###autoload -(defun xmtn-update-multiple (dir &optional workspaces) - "Update all projects under DIR." - (interactive "DUpdate all in (root directory): ") - (let ((root (file-name-as-directory (expand-file-name (substitute-in-file-name dir))))) - - (if (not workspaces) (setq workspaces (xmtn--filter-non-ws root))) - - (dolist (workspace workspaces) - (let ((default-directory (concat root workspace))) - (xmtn-dvc-update nil t))) - (message "Update %s done" root))) - -;;;###autoload -(defun xmtn-status-multiple (dir &optional workspaces skip-initial-scan) - "Show actions to update all projects under DIR." - (interactive "DStatus for all (root directory): \ni\nP") - (pop-to-buffer (get-buffer-create "*xmtn-multi-status*")) - (setq default-directory (file-name-as-directory (expand-file-name (substitute-in-file-name dir)))) - (if (not workspaces) (setq workspaces (xmtn--filter-non-ws default-directory))) - (setq xmtn-status-root (file-name-as-directory default-directory)) - (setq xmtn-status-ewoc (ewoc-create 'xmtn-status-printer)) - (let ((inhibit-read-only t)) (delete-region (point-min) (point-max))) - (ewoc-set-hf xmtn-status-ewoc (format "Root : %s\n" xmtn-status-root) "") - (dolist (workspace workspaces) - (ewoc-enter-last xmtn-status-ewoc - (make-xmtn-status-data - :work workspace - :branch (xmtn--tree-default-branch (concat xmtn-status-root workspace)) - :need-refresh t - :heads 'need-scan))) - (xmtn-multiple-status-mode) - (when (not skip-initial-scan) - (progn - (xmtn-status-refresh) - (xmtn-status-next)))) - -;;;###autoload -(defun xmtn-status-one (work) - "Show actions to update WORK." - (interactive "DStatus for (workspace): ") - (pop-to-buffer (get-buffer-create "*xmtn-multi-status*")) - ;; allow WORK to be relative, and ensure it is a workspace root - (setq default-directory (xmtn-tree-root (expand-file-name (substitute-in-file-name work)))) - (setq xmtn-status-root (expand-file-name (concat (file-name-as-directory default-directory) "../"))) - (setq xmtn-status-ewoc (ewoc-create 'xmtn-status-printer)) - ;; FIXME: sometimes, this causes problems for ewoc-set-hf (deletes bad region) - ;; But otherwise it is necessary to clean out old ewoc before creating new one. - (let ((inhibit-read-only t)) (delete-region (point-min) (point-max))) - (ewoc-set-hf xmtn-status-ewoc (format "Root : %s\n" xmtn-status-root) "") - (ewoc-enter-last xmtn-status-ewoc - (make-xmtn-status-data - :work (file-name-nondirectory (directory-file-name default-directory)) - :branch (xmtn--tree-default-branch default-directory) - :need-refresh t - :heads 'need-scan)) - (xmtn-multiple-status-mode) - (xmtn-status-refresh) - (xmtn-status-next)) - -;;;###autoload -(defun xmtn-status-one-1 (root name head-revs status-buffer heads local-changes) - "Create an xmtn-multi-status buffer from xmtn-propagate." - (pop-to-buffer (get-buffer-create "*xmtn-multi-status*")) - (setq default-directory (concat root "/" name)) - (setq xmtn-status-root root) - (setq xmtn-status-ewoc (ewoc-create 'xmtn-status-printer)) - (let ((inhibit-read-only t)) (delete-region (point-min) (point-max))) - (ewoc-set-hf xmtn-status-ewoc (format "Root : %s\n" xmtn-status-root) "") - (ewoc-enter-last xmtn-status-ewoc - (make-xmtn-status-data - :work (file-name-nondirectory (directory-file-name default-directory)) - :branch (xmtn--tree-default-branch default-directory) - :need-refresh nil - :head-revs head-revs - :conflicts-buffer nil - :status-buffer status-buffer - :heads heads - :local-changes local-changes - :conflicts 'need-scan)) - (xmtn-multiple-status-mode) - (xmtn-status-refresh)) - -(provide 'xmtn-multi-status) - -;; end of file diff --git a/dvc/lisp/xmtn-propagate.el b/dvc/lisp/xmtn-propagate.el deleted file mode 100644 index 906b4db..0000000 --- a/dvc/lisp/xmtn-propagate.el +++ /dev/null @@ -1,744 +0,0 @@ -;;; xmtn-propagate.el --- manage multiple propagations for DVC backend for monotone - -;; Copyright (C) 2009 - 2011 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-when-compile - ;; these have macros we use - (require 'xmtn-ids)) - -(eval-and-compile - ;; these have functions we use - (require 'xmtn-automate) - (require 'xmtn-base) - (require 'xmtn-conflicts)) - -(defvar xmtn-propagate-from-root "" - "Buffer-local variable holding `from' root directory.") -(make-variable-buffer-local 'xmtn-propagate-from-root) -(put 'xmtn-propagate-from-root 'permanent-local t) - -(defvar xmtn-propagate-to-root "" - "Buffer-local variable holding `to' root directory.") -(make-variable-buffer-local 'xmtn-propagate-to-root) -(put 'xmtn-propagate-to-root 'permanent-local t) - -(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) -(put 'xmtn-propagate-ewoc 'permanent-local t) - -(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 - ; from-work is often the same as to-work - from-name ; display name, in buffer and menus; usually root dir name - to-name ; - from-branch ; branch name (assumed never changes) - to-branch ; - need-refresh ; nil | t; if an async process was started that invalidates state data - from-head-revs ; mtn rev string; current head revision or (left right) if multiple heads - to-head-revs ; - conflicts-buffer ; *xmtn-conflicts* buffer for this propagation - from-status-buffer ; *xmtn-status* buffer for commit in from - to-status-buffer ; *xmtn-status* buffer for commit in to - propagate-needed ; nil | t - from-heads ; 'at-head | 'need-update | 'need-merge) - to-heads ; - (from-local-changes - 'need-scan) ; 'need-scan | 'need-commit | 'ok - (to-local-changes - 'need-scan) ; - (conflicts - 'need-scan) ; 'need-scan | 'need-resolve | 'need-review-resolve-internal | 'resolved | 'none - ; for propagate - ) - -(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-from-name () - "Display name for current `from' workspace." - (xmtn-propagate-data-from-name (ewoc-data (ewoc-locate xmtn-propagate-ewoc)))) - -(defun xmtn-propagate-to-name () - "Display name for current `to' workspace." - (xmtn-propagate-data-to-name (ewoc-data (ewoc-locate xmtn-propagate-ewoc)))) - -(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)) - - (ecase (xmtn-propagate-data-from-local-changes data) - (need-scan (insert " local changes not checked " (xmtn-propagate-data-from-name data) "\n")) - (need-commit - (insert (dvc-face-add (concat " need commit " (xmtn-propagate-data-from-name data) "\n") - 'dvc-header))) - (ok nil)) - - (ecase (xmtn-propagate-data-to-local-changes data) - (need-scan (insert " local changes not checked " (xmtn-propagate-data-to-name data) "\n")) - (need-commit - (insert (dvc-face-add (concat " need commit " (xmtn-propagate-data-to-name data) "\n") - 'dvc-header))) - (ok nil)) - - (ecase (xmtn-propagate-data-from-heads data) - (at-head nil) - (need-update - (insert (dvc-face-add (concat " need update " (xmtn-propagate-data-from-name data) "\n") - 'dvc-conflict))) - (need-merge - (insert (dvc-face-add (concat " need status for merge " (xmtn-propagate-data-from-name data) "\n") - 'dvc-conflict)))) - - (ecase (xmtn-propagate-data-to-heads data) - (at-head nil) - (need-update - (insert (dvc-face-add (concat " need update " (xmtn-propagate-data-to-name data) "\n") - 'dvc-conflict))) - (need-merge - (insert (dvc-face-add (concat " need status for merge " (xmtn-propagate-data-to-name data) "\n") - 'dvc-conflict)))) - - (if (xmtn-propagate-data-propagate-needed data) - - (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))) - ((resolved none) - (insert (dvc-face-add " need propagate\n" 'dvc-conflict))))) - - (if (eq 'at-head (xmtn-propagate-data-to-heads data)) - (insert (dvc-face-add " need clean\n" 'dvc-conflict))) - )) - ;; ewoc ought to do this, but it doesn't - (redisplay)) - -(defun xmtn-propagate-kill-conflicts-buffer (data) - (if (buffer-live-p (xmtn-propagate-data-conflicts-buffer data)) - (let ((buffer (xmtn-propagate-data-conflicts-buffer data))) - (with-current-buffer buffer (save-buffer)) - (kill-buffer buffer)))) - -(defun xmtn-propagate-save-conflicts-buffer (data) - (if (buffer-live-p (xmtn-propagate-data-conflicts-buffer data)) - (with-current-buffer (xmtn-propagate-data-conflicts-buffer data) (save-buffer)))) - -(defun xmtn-propagate-create-to-status-buffer (data) - "Create to-status buffer for DATA" - (let ((result (xmtn--status-inventory-sync (xmtn-propagate-to-work data)))) - (setf (xmtn-propagate-data-to-status-buffer data) (car result) - (xmtn-propagate-data-to-local-changes data) (cadr result)))) - -(defun xmtn-propagate-create-from-status-buffer (data) - "Create from-status buffer for DATA" - (let ((result (xmtn--status-inventory-sync (xmtn-propagate-from-work data)))) - (setf (xmtn-propagate-data-from-status-buffer data) (car result) - (xmtn-propagate-data-from-local-changes data) (cadr result)))) - -(defun xmtn-propagate-kill-status-buffers (data) - (if (buffer-live-p (xmtn-propagate-data-from-status-buffer data)) - (kill-buffer (xmtn-propagate-data-from-status-buffer data))) - (if (buffer-live-p (xmtn-propagate-data-to-status-buffer data)) - (kill-buffer (xmtn-propagate-data-to-status-buffer data)))) - -(defun xmtn-propagate-clean-1 (data save-conflicts) - "Clean DATA workspace, kill associated automate session. -If SAVE-CONFLICTS non-nil, don't delete conflicts files." - (xmtn-automate-kill-session (xmtn-propagate-from-work data)) - (xmtn-automate-kill-session (xmtn-propagate-to-work data)) - (xmtn-propagate-kill-conflicts-buffer data) - (xmtn-propagate-kill-status-buffers data) - (unless save-conflicts - (xmtn-conflicts-clean (xmtn-propagate-to-work data)))) - -(defun xmtn-propagate-clean () - "Clean current workspace, delete from ewoc." - (interactive) - (let* ((elem (ewoc-locate xmtn-propagate-ewoc)) - (data (ewoc-data elem))) - - (xmtn-propagate-clean-1 data nil) - (let ((inhibit-read-only t)) - (ewoc-delete xmtn-propagate-ewoc elem)))) - -(defun xmtn-propagate-clean-all (&optional save-conflicts) - "Clean all remaining workspaces." - (interactive) - (ewoc-map 'xmtn-propagate-clean-1 xmtn-propagate-ewoc save-conflicts)) - -(defun xmtn-propagate-cleanp () - "Non-nil if clean is appropriate for current workspace." - (let ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc)))) - ;; don't check need-refresh here; allow deleting after just doing - ;; final required action in another buffer. Or we've just started, - ;; but the user knows it's ok. - (and (member (xmtn-propagate-data-from-local-changes data) '(need-scan ok)) - (member (xmtn-propagate-data-to-local-changes data) '(need-scan ok)) - (not (xmtn-propagate-data-propagate-needed data)) - (member (xmtn-propagate-data-to-heads data) '(need-scan at-head))))) - -(defun xmtn-propagate-do-refresh-one () - (interactive) - (let* ((elem (ewoc-locate xmtn-propagate-ewoc)) - (data (ewoc-data elem))) - (xmtn-propagate-refresh-one data (or current-prefix-arg - (not (xmtn-propagate-data-need-refresh 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)))) - (or (xmtn-propagate-data-need-refresh data) - (eq 'need-scan (xmtn-propagate-data-from-local-changes data)) - (eq 'need-scan (xmtn-propagate-data-to-local-changes data))))) - -(defun xmtn-propagate-commit-to () - "Show commit buffer for `to' workspace, so it can be committed, updated, or merged." - (interactive) - (let* ((elem (ewoc-locate xmtn-propagate-ewoc)) - (data (ewoc-data elem))) - (xmtn-propagate-need-refresh elem data) - ;; assume the commit is successful - (setf (xmtn-propagate-data-to-local-changes data) 'ok) - (if (not (buffer-live-p (xmtn-propagate-data-to-status-buffer data))) - (xmtn-propagate-create-to-status-buffer data)) - (pop-to-buffer (xmtn-propagate-data-to-status-buffer data)))) - -(defun xmtn-propagate-commit-top () - "Non-nil if commit 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-commit need-scan))))) - -(defun xmtn-propagate-commit-from () - "Show commit buffer for `from' workspace, so it can be committed, updated, or merged." - (interactive) - (let* ((elem (ewoc-locate xmtn-propagate-ewoc)) - (data (ewoc-data elem))) - (xmtn-propagate-need-refresh elem data) - ;; assume the commit is successful - (setf (xmtn-propagate-data-from-local-changes data) 'ok) - (if (not (buffer-live-p (xmtn-propagate-data-from-status-buffer data))) - (xmtn-propagate-create-from-status-buffer data)) - (pop-to-buffer (xmtn-propagate-data-from-status-buffer data)))) - -(defun xmtn-propagate-commit-fromp () - "Non-nil if commit 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-commit need-scan))))) - -(defun xmtn-propagate-update-to () - "Update current `to' workspace." - (interactive) - (let* ((elem (ewoc-locate xmtn-propagate-ewoc)) - (data (ewoc-data elem))) - (xmtn-propagate-need-refresh elem data) - (xmtn--update (xmtn-propagate-to-work data) - (xmtn-propagate-data-to-head-revs data) - nil t) - (xmtn-propagate-refresh-one data nil) - (ewoc-invalidate xmtn-propagate-ewoc elem))) - -(defun xmtn-propagate-update-top () - "Non-nil if update is appropriate for current `to' workspace." - (let* ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc)))) - (and (not (xmtn-propagate-data-need-refresh data)) - (eq (xmtn-propagate-data-to-heads data) - 'need-update)))) - -(defun xmtn-propagate-update-from () - "Update current `from' workspace." - (interactive) - (let* ((elem (ewoc-locate xmtn-propagate-ewoc)) - (data (ewoc-data elem))) - (xmtn-propagate-need-refresh elem data) - (xmtn--update (xmtn-propagate-from-work data) - (xmtn-propagate-data-from-head-revs data) - nil t) - (xmtn-propagate-refresh-one data nil) - (ewoc-invalidate xmtn-propagate-ewoc elem))) - -(defun xmtn-propagate-update-fromp () - "Non-nil if update is appropriate for current `from' workspace." - (let* ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc)))) - (and (not (xmtn-propagate-data-need-refresh data)) - (eq (xmtn-propagate-data-from-heads data) - 'need-update)))) - -(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) - - (if (not (buffer-live-p (xmtn-propagate-data-conflicts-buffer data))) - ;; user deleted conflicts buffer after resolving conflicts; get it back - (xmtn-propagate-conflicts data)) - - (with-current-buffer (xmtn-propagate-data-conflicts-buffer data) - (let ((xmtn-confirm-operation nil)) - (save-some-buffers t); log buffer - ;; save-some-buffers does not save the conflicts buffer, which is the current buffer - (save-buffer) - (xmtn-propagate-from - (xmtn-propagate-data-from-branch data) ; = left - (xmtn-propagate-data-to-branch data) ; = right - ))) - (xmtn-propagate-refresh-one data nil) - (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) - '(need-review-resolve-internal resolved none))))) - -(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) - (setf (xmtn-propagate-data-conflicts data) 'ok) - (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-local-changes-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-local-changes-top () - "Non-nil if local-changes-to-ok 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-commit))))) - -(defun xmtn-propagate-local-changes-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-local-changes-fromp () - "Non-nil if local-changes-from-ok 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-commit))))) - -(defun xmtn-propagate-status-to () - "Show status buffer for `to' workspace, so it can be committed, updated, or merged." - (interactive) - (let* ((elem (ewoc-locate xmtn-propagate-ewoc)) - (data (ewoc-data elem))) - (xmtn-propagate-need-refresh elem data) - (xmtn-status-one-1 - xmtn-propagate-to-root - (xmtn-propagate-data-to-work data) - (xmtn-propagate-data-to-head-revs data) - (xmtn-propagate-data-to-status-buffer data) - (xmtn-propagate-data-to-heads data) - (xmtn-propagate-data-to-local-changes data)) - - ;; Assume the user completely handles the local changes in the - ;; status buffer, so they are now ok - (setf (xmtn-propagate-data-to-local-changes data) 'ok))) - -(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)) - (or - (member (xmtn-propagate-data-to-heads data) - '(need-update need-merge)) - (eq (xmtn-propagate-data-to-local-changes data) 'need-commit))))) - -(defun xmtn-propagate-status-from () - "Show status buffer for `from' workspace, so it can be committed, updated, or merged." - (interactive) - (let* ((elem (ewoc-locate xmtn-propagate-ewoc)) - (data (ewoc-data elem))) - (xmtn-propagate-need-refresh elem data) - (xmtn-status-one-1 - xmtn-propagate-from-root - (xmtn-propagate-data-from-work data) - (xmtn-propagate-data-from-head-revs data) - (xmtn-propagate-data-from-status-buffer data) - (xmtn-propagate-data-from-heads data) - (xmtn-propagate-data-from-local-changes data)) - (setf (xmtn-propagate-data-from-local-changes data) 'ok))) - -(defun xmtn-propagate-status-fromp () - "Non-nil if xmtn-status-one is appropriate for current `from' workspace." - (let* ((data (ewoc-data (ewoc-locate xmtn-propagate-ewoc)))) - (and (not (xmtn-propagate-data-need-refresh data)) - (or - (member (xmtn-propagate-data-from-heads data) - '(need-update need-merge)) - (eq (xmtn-propagate-data-from-local-changes data) 'need-commit))))) - -(defun xmtn-propagate-quit-save () - "Quit, but save conflicts files for later resume." - (interactive) - (remove-hook 'kill-buffer-hook 'xmtn-propagate-clean-all t) - (xmtn-propagate-clean-all t) - (kill-buffer)) - -(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 [?9] '(menu-item (concat "9) status " (xmtn-propagate-to-name)) - xmtn-propagate-status-to - :visible (xmtn-propagate-status-top))) - (define-key map [?8] '(menu-item (concat "8) status " (xmtn-propagate-from-name)) - xmtn-propagate-status-from - :visible (xmtn-propagate-status-fromp))) - (define-key map [?7] '(menu-item (concat "7) update " (xmtn-propagate-to-name)) - xmtn-propagate-update-to - :visible (xmtn-propagate-update-top))) - (define-key map [?6] '(menu-item (concat "6) update " (xmtn-propagate-from-name)) - xmtn-propagate-update-from - :visible (xmtn-propagate-update-fromp))) - (define-key map [?5] '(menu-item "5) propagate" - xmtn-propagate-propagate - :visible (xmtn-propagate-propagatep))) - (define-key map [?4] '(menu-item "4) resolve conflicts" - xmtn-propagate-resolve-conflicts - :visible (xmtn-propagate-resolve-conflictsp))) - (define-key map [?3] '(menu-item (concat "3) ignore local changes " (xmtn-propagate-to-name)) - xmtn-propagate-local-changes-to-ok - :visible (xmtn-propagate-local-changes-top))) - (define-key map [?2] '(menu-item (concat "2) ignore local changes " (xmtn-propagate-from-name)) - xmtn-propagate-local-changes-from-ok - :visible (xmtn-propagate-local-changes-fromp))) - (define-key map [?1] '(menu-item (concat "1) commit " (xmtn-propagate-to-name)) - xmtn-propagate-commit-to - :visible (xmtn-propagate-commit-top))) - (define-key map [?0] '(menu-item (concat "0) commit " (xmtn-propagate-from-name)) - xmtn-propagate-commit-from - :visible (xmtn-propagate-commit-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 [?s] 'xmtn-propagate-quit-save) - (define-key map [?q] 'dvc-buffer-quit) - map) - "Keymap used in `xmtn-propagate-mode'.") - -(easy-menu-define xmtn-propagate-mode-menu xmtn-propagate-mode-map - "Mtn specific status menu." - `("DVC-Mtn" - ["Do the right thing" xmtn-status-actions-map t] - ["Quit, clean conflicts" dvc-buffer-quit t] - ["Quit, save conflicts" xmtn-propagate-quit-save t] - )) - -(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) - - ;; 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) - (add-hook 'kill-buffer-hook 'xmtn-propagate-clean-all nil t) - (setq buffer-read-only t) - (buffer-disable-undo) - (set-buffer-modified-p nil) - (xmtn-propagate-refresh) - (xmtn-propagate-next nil t)) - -(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-revs data)) - (to-head-rev (xmtn-propagate-data-to-head-revs data))) - - (if (or (listp from-head-rev) - (listp to-head-rev)) - ;; multiple heads; can't propagate - (setq result nil) - - ;; cases: - ;; 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-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 (data) - "Return value for xmtn-propagate-data-conflicts for DATA." - ;; Only called if neither side needs merge. See - ;; xmtn-propagate-propagate for assignment of 'left' = 'from'. - (let ((result (xmtn-conflicts-status - (xmtn-propagate-data-conflicts-buffer data) ; buffer - (xmtn-propagate-from-work data) ; left-work - (xmtn-propagate-data-from-head-revs data) ; left-rev - (xmtn-propagate-to-work data) ; right-work - (xmtn-propagate-data-to-head-revs data) ; right-rev - (xmtn-propagate-data-from-branch data) ; left-branch - (xmtn-propagate-data-to-branch data) ; right-branch - ))) - (setf (xmtn-propagate-data-conflicts-buffer data) (car result)) - (cadr result))) - -(defun xmtn-propagate-refresh-one (data refresh-local-changes) - "Refresh DATA." - (let ((from-work (xmtn-propagate-from-work data)) - (to-work (xmtn-propagate-to-work data))) - - (dvc-trace "xmtn-propagate-refresh-one: %s" from-work) - - (let ((heads (xmtn--heads from-work (xmtn-propagate-data-from-branch data))) - (from-base-rev (xmtn--get-base-revision-hash-id-or-null from-work))) - (case (length heads) - (1 - (setf (xmtn-propagate-data-from-head-revs data) (nth 0 heads)) - (if (string= (xmtn-propagate-data-from-head-revs 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-revs data) (list (nth 0 heads) (nth 1 heads))) - (setf (xmtn-propagate-data-from-heads data) 'need-merge)))) - - (let ((heads (xmtn--heads to-work (xmtn-propagate-data-to-branch data))) - (to-base-rev (xmtn--get-base-revision-hash-id-or-null to-work))) - (case (length heads) - (1 - (setf (xmtn-propagate-data-to-head-revs data) (nth 0 heads)) - (if (string= (xmtn-propagate-data-to-head-revs 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-revs data) (list (nth 0 heads) (nth 1 heads))) - (setf (xmtn-propagate-data-to-heads data) 'need-merge)))) - - (setf (xmtn-propagate-data-propagate-needed data) - (xmtn-propagate-needed data)) - - (if refresh-local-changes - (progn - (setf (xmtn-propagate-data-from-local-changes data) 'need-scan) - (setf (xmtn-propagate-data-to-local-changes data) 'need-scan))) - - (case (xmtn-propagate-data-from-local-changes data) - (need-scan - (xmtn-propagate-create-from-status-buffer data)) - (t nil)) - - (case (xmtn-propagate-data-to-local-changes data) - (need-scan - (xmtn-propagate-create-to-status-buffer data)) - (t nil)) - - (if (xmtn-propagate-data-propagate-needed data) - (progn - (if refresh-local-changes - (progn - (xmtn-propagate-kill-conflicts-buffer data) - (xmtn-conflicts-clean (xmtn-propagate-to-work data)))) - - (setf (xmtn-propagate-data-conflicts data) - (xmtn-propagate-conflicts data))) - - ;; can't compute conflicts if 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. With prefix arg, reset local changes status to `unknown'." - (interactive) - (ewoc-map 'xmtn-propagate-refresh-one xmtn-propagate-ewoc current-prefix-arg) - ;; leaves point at (point-min) - (xmtn-propagate-next nil t) - (message "done")) - -(defun xmtn-propagate-make-data (from-workspace to-workspace from-name to-name) - "FROM-WORKSPACE, TO-WORKSPACE are relative names, FROM-NAME, TO_NAME should be root dir names." - (let* ((from-work (concat xmtn-propagate-from-root from-workspace)) - (to-work (concat xmtn-propagate-to-root to-workspace)) - ) - - (ewoc-enter-last - xmtn-propagate-ewoc - (make-xmtn-propagate-data - :from-work from-workspace - :to-work to-workspace - :from-name from-name - :to-name to-name - :from-branch (xmtn--tree-default-branch from-work) - :to-branch (xmtn--tree-default-branch to-work) - :need-refresh t)))) - -;;;###autoload -(defun xmtn-propagate-multiple (from-dir to-dir &optional workspaces) - "Show all actions needed to propagate projects under FROM-DIR -to TO-DIR. WORKSPACES (default nil) is a list of workspaces -common to from-dir and to-dir; if nil, the directories are -scanned and all common ones found are used." - (interactive "DPropagate all from (root directory): \nDto (root directory): ") - (pop-to-buffer (get-buffer-create "*xmtn-propagate*")) - ;; xmtn-propagate-*-root are buffer-local. Note that we don't care - ;; what 'default-directory' is for xmtn-propagate buffer. - (setq xmtn-propagate-from-root (file-name-as-directory (expand-file-name (substitute-in-file-name from-dir)))) - (setq xmtn-propagate-to-root (file-name-as-directory (expand-file-name (substitute-in-file-name to-dir)))) - (let ((from-workspaces (or workspaces - (xmtn--filter-non-ws xmtn-propagate-from-root))) - (to-workspaces (or workspaces - (xmtn--filter-non-ws xmtn-propagate-to-root)))) - - (setq xmtn-propagate-ewoc (ewoc-create 'xmtn-propagate-printer)) - (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) - (xmtn-propagate-make-data - workspace - workspace - (file-name-nondirectory (directory-file-name xmtn-propagate-from-root)) - (file-name-nondirectory (directory-file-name xmtn-propagate-to-root))))) - (redisplay) - (xmtn-propagate-mode))) - -;;;###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): ") - (setq from-work (file-name-as-directory (expand-file-name (substitute-in-file-name from-work)))) - (setq to-work (file-name-as-directory (expand-file-name (substitute-in-file-name to-work)))) - (pop-to-buffer (get-buffer-create "*xmtn-propagate*")) - (setq default-directory to-work) - (setq xmtn-propagate-from-root (expand-file-name (concat from-work "../"))) - (setq xmtn-propagate-to-root (expand-file-name (concat to-work "../"))) - (setq xmtn-propagate-ewoc (ewoc-create 'xmtn-propagate-printer)) - (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) - ) - "") - (let ((from-name (file-name-nondirectory (directory-file-name from-work))) - (to-name (file-name-nondirectory (directory-file-name to-work)))) - (if (string-equal from-name to-name) - (progn - (setq from-name (file-name-nondirectory (directory-file-name xmtn-propagate-from-root))) - (setq to-name (file-name-nondirectory (directory-file-name xmtn-propagate-to-root))))) - (xmtn-propagate-make-data - (file-name-nondirectory (directory-file-name from-work)) - (file-name-nondirectory (directory-file-name to-work)) - from-name - to-name)) - (xmtn-propagate-mode)) - -(provide 'xmtn-propagate) - -;; end of file diff --git a/dvc/lisp/xmtn-revlist.el b/dvc/lisp/xmtn-revlist.el deleted file mode 100644 index c4f2aa8..0000000 --- a/dvc/lisp/xmtn-revlist.el +++ /dev/null @@ -1,518 +0,0 @@ -;;; xmtn-revlist.el --- Interactive display of revision histories for monotone - -;; Copyright (C) 2008 - 2011 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) ;; yes, we are using cl at runtime; we're working towards eliminating that. - (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: - ((header-lines) - (footer-lines) - (revisions))" -(make-variable-buffer-local 'xmtn--revlist-*info-generator-fn*) - -(defvar xmtn--revlist-*path* nil) -"Buffer-local variable containing path argument for log" -(make-variable-buffer-local 'xmtn--revlist-*path*) - -(defstruct (xmtn--revlist-entry (:constructor xmtn--make-revlist-entry)) - revision-hash-id - branches - authors - dates - changelogs - tags) - -;;;###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\n" - (if (dvc-revlist-entry-patch-marked patch) "*" " ") - (xmtn--revlist-entry-revision-hash-id entry))) - (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 - ;; 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) - (ewoc-set-hf ewoc header footer) - (ewoc-filter ewoc (lambda (x) nil)) ; Clear it. - ;; FIXME: setup should not modify order; this should be a waste of - ;; time or wrong. This was here historically; see - ;; xmtn--log-generator for comment on why I have not removed it. I - ;; have not investigated order problems with other revlists. - (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)) - (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)))) - (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)) - (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)))))) - 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 (header-lines footer-lines revs) - (funcall xmtn--revlist-*info-generator-fn* root) - (let ((ewoc dvc-revlist-cookie) - (count (length revs)) - (last-n dvc-revlist-last-n)) - (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)) - (insert - (cond - ((= 0 count) "No revisions") - ((= 1 count) "1 revision:") - ((or (null last-n) - (> last-n count)) - (format "%d of %d revisions:" count count)) - (t (format "%d of %d revisions:" last-n count)))) - (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)) - revs - 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 path first-line-only-p last-n) - ;; Adapted from `dvc-build-revision-list'. - ;; See xmtn--revlist-*info-generator-fn* - (xmtn-automate-cache-session 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) - (setq xmtn--revlist-*path* (when path (file-relative-name path root))) - (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--setup-revlist - default-directory - 'xmtn--log-generator - path - t ;; first-line-only-p - 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--setup-revlist - (dvc-tree-root) - 'xmtn--log-generator - path - nil ;; first-line-only-p - nil ;; last-n - )) - -(defun xmtn--log-generator (root) - (let ((branch (xmtn--tree-default-branch root))) - (let - ((header - (list (format "Log for branch %s" branch))) - (options - ;; FIXME: this gives most the recent date first, we want - ;; that last. See mtn issue 118 for why we can't fix that - ;; with more options. The 'toposort' in - ;; xmtn--revlist-setup-ewoc puts it in the desired date - ;; order. In general, it would be better if revlist-setup - ;; did not alter the order. - (if dvc-revlist-last-n - (list "last" (format "%d" dvc-revlist-last-n)))) - (command - (if xmtn--revlist-*path* - (list "log" xmtn--revlist-*path*) - (list "log"))) - ) - ;; See xmtn--revlist-*info-generator-fn* for result format - (list header - '() ;; footer - (xmtn-automate-command-output-lines ;; revisions - root - (cons options command)))))) - -(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. - (interactive) - (let ((changelog (car (xmtn--revlist-entry-changelogs (dvc-revlist-entry-patch-struct (dvc-revlist-current-patch))))) - start end left-branch left-rev right-branch right-rev) - ;; string-match does _not_ set up match-strings properly, so we do this instead - (cond - ((string= (substring changelog 0 9) "propagate") - (setq start (+ 1 (string-match "'" changelog))) - (setq end (string-match "'" changelog start)) - (setq left-branch (substring changelog start end)) - - (setq start (+ 6 (string-match "(head" changelog end))) - (setq end (string-match ")" changelog start)) - (setq left-rev (substring changelog start end)) - - (setq start (+ 1 (string-match "'" changelog end))) - (setq end (string-match "'" changelog start)) - (setq right-branch (substring changelog start end)) - - (setq start (+ 6 (string-match "(head .*)" changelog end))) - (setq end (string-match ")" changelog start)) - (setq right-rev (substring changelog start end))) - - - ((or - (string= (substring changelog 0 5) "merge") - (string= (substring changelog 0 14) "explicit merge")) - (setq start (+ 4 (string-match "of" changelog))) - (setq end (string-match "'" changelog start)) - (setq left-rev (substring changelog start end)) - - (setq start (+ 5 (string-match "and" changelog start))) - (setq end (string-match "'" changelog start)) - (setq right-rev (substring changelog start end))) - - (t - (error "not on a two parent revision"))) - - (xmtn-conflicts-review - default-directory ; left-work - left-rev - default-directory ; right-work - right-rev - left-branch - right-branch - t))) - -;;;###autoload -(defvar xmtn-revlist-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "MC" 'xmtn-revlist-show-conflicts) - (define-key map "CC" 'xmtn-conflicts-clean) - map)) - -(easy-menu-define xmtn-revlist-mode-menu xmtn-revlist-mode-map - "Mtn specific revlist menu." - `("DVC-Mtn" - ["Show merge conflicts after merge" xmtn-revlist-show-conflicts 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)) - (branch (xmtn--tree-default-branch root)) - (heads (xmtn--heads root branch))) - (if (/= 1 (length heads)) - (error "%d heads, need merge; use `xmtn-status-one'" (length heads))) - - (xmtn--setup-revlist - root - (lambda (root) - (let ((revs - (xmtn-automate-command-output-lines - root - (cons (list "from" "h:" "to" "w:") (list "log"))))) - (list - (list ;; header - (format "workspace %s" root) - nil ;; blank line - "Revisions that are not in base revision") - '() ;; footer - revs))) - nil ;; path - nil ;; first-line-only-p - ;; 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. - dvc-log-last-n)) - nil) - -;;;###autoload -(defun xmtn-update-review (root) - "Review revisions in last update of ROOT workspace." - (interactive "D") - (xmtn--setup-revlist - root - (lambda (root) - (let ((revs - (xmtn-automate-command-output-lines - root - (cons (list "from" "w:" "to" "u:") (list "log"))))) - (list - (list ;; header - (format "workspace %s" root) - nil ;; blank line - "Revisions in last update") - '() ;; footer - revs))) - nil ;; path - nil ;; first-line-only-p - 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) - (let* ((branch (xmtn--tree-default-branch root)) - (head-revision-hash-ids (xmtn--heads root branch))) - (list - (list ; header - (format "workspace %s" root) - "Head revisions") - '() ; footer - head-revision-hash-ids))) - nil ;; path - nil ;; first-line-only-p - nil ;; last-n - )) - nil) - -(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) - (let* ((revision-hash-ids (xmtn--expand-selector root selector)) - (count (length revision-hash-ids))) - (list - (list ; header - (format "workspace %s" root) - (if (with-syntax-table (standard-syntax-table) - (string-match "\\`\\s *\\'" selector)) - "Blank selector" - (format "Selector %s" selector)) - "Revisions matching selector") - '() ; footer - revision-hash-ids))) - nil ;; path - nil ;; first-line-only-p - nil ;; last-n - ))) - 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))) - (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-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 nil nil))) - -(provide 'xmtn-revlist) - -;;; xmtn-revlist.el ends here diff --git a/dvc/lisp/xmtn-run.el b/dvc/lisp/xmtn-run.el deleted file mode 100644 index e124b88..0000000 --- a/dvc/lisp/xmtn-run.el +++ /dev/null @@ -1,154 +0,0 @@ -;;; xmtn-run.el --- Functions for runnning monotone commands - -;; Copyright (C) 2008 - 2011 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-dvc-prepare-environment (env) - "Prepare the environment to run mtn." - ;; DVC expects monotone messages in the C locale - (cons "LC_MESSAGES=C" env)) - -(defun* xmtn--run-command-sync (root arguments) - (xmtn--check-cached-command-version) - (let ((default-directory (file-truename (or root default-directory)))) - (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)))) - -(defun* xmtn--run-command-async (root arguments &rest dvc-run-keys &key) - (xmtn--check-cached-command-version) - (let ((default-directory (or root default-directory))) - (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. It also confuses other versions of - ;; mtn when there are symlinks in the path to the root; - ;; `call-process' spawns the subprocess with a working - ;; directory with all symlinks expanded. - ,@arguments) - dvc-run-keys))) - -(defconst xmtn--minimum-required-command-version '(0 99)) -;; see also xmtn-sync.el xmtn-sync-required-command-version -(defconst xmtn--required-automate-format-version "2") - -(defvar xmtn--*cached-command-version* nil - ;; compare with (xmtn-version-<= required) - "(MAJOR MINOR REVISION VERSION-STRING).") - -(defvar xmtn--*command-version-cached-for-executable* nil) - -(defun xmtn-version-<= (required) - "Nonnil if REQUIRED (list of major, minor) is <= cached version." - (version-list-<= required (butlast (xmtn--cached-command-version) 2))) - -(defun xmtn--clear-command-version-cache () - (interactive) - (setq xmtn--*command-version-cached-for-executable* nil - ;; This is redundant but neater. - xmtn--*cached-command-version* nil)) - -(defun xmtn--cached-command-version () - "Return mtn version as a list (MAJOR MINOR REVISION VERSION-STRING). -Sets cache if not already set." - (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 ((version-string)) - (dvc-run-dvc-sync - 'xmtn - '("version") - :finished - (lambda (output error status arguments) - (with-current-buffer output - (setq version-string (buffer-substring-no-properties (point-min) (1- (point-max))))))) - - (unless (string-match - (concat "\\`monotone \\([0-9]+\\)\\.\\([0-9]+\\)\\(\\.[0-9]+\\)?\\(dev\\)?" - " (base revision: \\(unknown\\|\\([0-9a-f]\\{40\\}\\)\\))\\'") - version-string) - (error (concat "Version output from monotone version" - " did not match expected pattern: %S") - version-string)) - (let ((major (parse-integer version-string (match-beginning 1) (match-end 1))) - (minor (parse-integer version-string (match-beginning 2) (match-end 2))) - (revision (match-string 4 version-string))) - (list major minor revision version-string)))) - -(defun xmtn--check-cached-command-version () - (let ((minimum-version xmtn--minimum-required-command-version) - (string (nth 3 (xmtn--cached-command-version)))) - (unless (xmtn-version-<= xmtn--minimum-required-command-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) - -(provide 'xmtn-run) - -;;; xmtn-run.el ends here diff --git a/dvc/lisp/xmtn-sync.el b/dvc/lisp/xmtn-sync.el deleted file mode 100644 index d8b01d0..0000000 --- a/dvc/lisp/xmtn-sync.el +++ /dev/null @@ -1,618 +0,0 @@ -;;; xmtn-sync.el --- database sync handling for DVC backend for monotone -;; -;; Copyright (C) 2010, 2011 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-when-compile - ;; these have macros we use - ) - -(eval-and-compile - ;; these have functions (and possibly macros) we use - (require 'dvc-config) - (require 'xmtn-automate) - (require 'xmtn-basic-io) - ) - -;;; User variables -(defvar xmtn-sync-executable - (cond - ((equal system-type 'windows-nt) - ;; Native MinGW does not support file: or ssh: - assume Cygwin is - ;; installed, but not first in path - "c:/bin/mtn") - (t - ;; Unix or Cygwin; assume mtn is in path - "mtn")) - "Executable for running sync command on local db; overrides xmtn-executable.") - -(defvar xmtn-sync-automate-args - (cond - ((equal system-type 'windows-nt) - ;; Assume using Cygwin, which looks for .monotone/keys in a different place. - (list "--keydir" "~/.monotone/keys")) - (t - ;; Unix or Cygwin - nil)) - "Extra arguments (list of strings) used when starting a sync automate process; -overrides xmtn-automate-arguments.") - -(defvar xmtn-sync-guess-workspace nil - "User-supplied function to guess workspace location given branch. -Called with a string containing the mtn branch name; return a workspace root or nil.") - -(defvar xmtn-sync-sort nil - "User-supplied function to sort branches. -Called with a string containing the mtn branch name; return -'(node key) where node is the ewoc node to insert before (nil to -insert at end), key is the sort-key. Sync buffer is current.") - -;;; Internal variables -(defconst xmtn-sync-save-file "sync" - "File to save sync review state for later; relative to `dvc-config-directory'.") - -(defconst xmtn-sync-review-file "sync.basic_io" - "File to save shell sync basic_io output for input by `xmtn-sync-review'; relative to `dvc-config-directory'.") - -(defconst xmtn-sync-branch-file "branches" - "File associating branch name with workspace root; relative to `dvc-config-directory'.") - -(defconst xmtn-sync-config "xmtn-sync-config" - "File to store `xmtn-sync-branch-alist'; relative to `dvc-config-directory'.") - -(defconst xmtn-sync-required-command-version '(0 99) - ;; Sometimes the Cygwin version lags behind the MinGW version; this allows that. - "Minimum version for `xmtn-sync-executable'; overrides xmtn--minimum-required-command-version. -Must support file:, ssh:, automate sync.") - -;; loaded from xmtn-sync-config -(defvar xmtn-sync-branch-alist nil - "Alist associating branch name with workspace root") - -(defvar xmtn-sync-remote-exec-alist nil - "Alist of host and remote command. Overrides `xmtn-sync-remote-exec-default'.") - -;; buffer-local -(defvar xmtn-sync-local-db nil - "Absolute path to local database.") -(make-variable-buffer-local 'xmtn-sync-local-db) - -(defvar xmtn-sync-remote-db nil - "Absolute path to remote database.") -(make-variable-buffer-local 'xmtn-sync-remote-db) - -(defvar xmtn-sync-ewoc nil - "Buffer-local ewoc for displaying sync. -All xmtn-sync functions operate on this ewoc. -The elements must all be of type xmtn-sync-sync.") -(make-variable-buffer-local 'xmtn-sync-ewoc) - -(defstruct (xmtn-sync-branch - (:copier nil)) - ;; ewoc element; data for a branch that was received - name ;; monotone branch name - rev-alist ;; alist of '(revid (date author changelog)) for received revs - send-count ;; integer count of sent revs - print-mode ;; 'summary | 'brief | 'full | 'started - sort-key ;; for use by xmtn-sync-sort - ) - -(defun xmtn-sync-print-rev (rev print-mode) - "Print a REV (element of branch rev-alist) according to PRINT-MODE ('brief or 'full)." - (let ((date (nth 0 (cadr rev))) - (author (nth 1 (cadr rev))) - (changelog (nth 2 (cadr rev)))) - (insert (dvc-face-add (format "\n %s %s\n" date author) 'dvc-header)) - (ecase print-mode - (brief - (insert (substring changelog 0 (string-match "\n" changelog)))) - (full - (insert changelog))))) - -(defun xmtn-sync-printer (branch) - "Print an ewoc element; BRANCH must be of type xmtn-sync-branch." - ;; sometimes mtn will allow a revision with no branch! - (if (xmtn-sync-branch-name branch) - (insert (dvc-face-add (xmtn-sync-branch-name branch) 'dvc-keyword)) - (insert (dvc-face-add "" 'dvc-keyword))) - (insert (format " rx %d tx %d\n" - (length (xmtn-sync-branch-rev-alist branch)) - (xmtn-sync-branch-send-count branch))) - (ecase (xmtn-sync-branch-print-mode branch) - (summary nil) - - ((brief full) - (loop for rev in (xmtn-sync-branch-rev-alist branch) do - (xmtn-sync-print-rev rev (xmtn-sync-branch-print-mode branch)))) - - (started - (insert " started\n"))) - ) - -(defun xmtn-sync-brief () - "Set display mode for current item to brief." - (interactive) - (let* ((elem (ewoc-locate xmtn-sync-ewoc)) - (data (ewoc-data elem))) - (setf (xmtn-sync-branch-print-mode data) 'brief) - (ewoc-invalidate xmtn-sync-ewoc elem))) - -(defun xmtn-sync-full () - "Set display mode for current item to full." - (interactive) - (let* ((elem (ewoc-locate xmtn-sync-ewoc)) - (data (ewoc-data elem))) - (setf (xmtn-sync-branch-print-mode data) 'full) - (ewoc-invalidate xmtn-sync-ewoc elem))) - -(defun xmtn-sync-summary () - "Set display mode for current item to summary." - (interactive) - (let* ((elem (ewoc-locate xmtn-sync-ewoc)) - (data (ewoc-data elem))) - (setf (xmtn-sync-branch-print-mode data) 'summary) - (ewoc-invalidate xmtn-sync-ewoc elem))) - -(defun xmtn-sync-status () - "Start xmtn-status-one for current ewoc element." - (interactive) - (let* ((elem (ewoc-locate xmtn-sync-ewoc)) - (data (ewoc-data elem)) - (branch (xmtn-sync-branch-name data)) - save-work - (work (or - (cadr (assoc branch xmtn-sync-branch-alist)) - (if (functionp xmtn-sync-guess-workspace) - (funcall xmtn-sync-guess-workspace branch)) - (prog1 - (read-directory-name (format "workspace root for %s: " branch)) - (setq save-work t)) - ))) - (setf (xmtn-sync-branch-print-mode data) 'started) ; indicate we've started work on it - (ewoc-invalidate xmtn-sync-ewoc elem) - - (condition-case err - (xmtn-status-one work) - ('error - (if (and (not save-work) (functionp xmtn-sync-guess-workspace)) - ;; xmtn-sync-guess-workspace guessed wrong; prompt and try again - (progn - (setq work (read-directory-name (format "workspace root for %s: " branch))) - (setq save-work t) - (xmtn-status-one work))))) - - ;; don't save the workspace association until it is validated by xmtn-status-one - (if save-work - (progn - (push (list branch work) xmtn-sync-branch-alist) - (dvc-save-state - (list 'xmtn-sync-branch-alist) - (expand-file-name xmtn-sync-branch-file dvc-config-directory)))))) - -(defun xmtn-sync-update () - "Start xmtn-status-on for current ewoc element, do update if possible." - (interactive) - (xmtn-sync-status) - (if (xmtn-status-updatep) - (xmtn-status-update))) - -(defun xmtn-sync-clean () - "Clean and delete current ewoc element." - (interactive) - (let* ((elem (ewoc-locate xmtn-sync-ewoc)) - (status-buffer (get-buffer-create "*xmtn-multi-status*")) - (inhibit-read-only t)) - (if (buffer-live-p status-buffer) - (kill-buffer status-buffer)) - (ewoc-delete xmtn-sync-ewoc elem))) - -(dvc-make-ewoc-next xmtn-sync-next xmtn-sync-ewoc) -(dvc-make-ewoc-prev xmtn-sync-prev xmtn-sync-ewoc) - -(defvar xmtn-sync-kbd-map - (let ((map (make-sparse-keymap "action"))) - ;; last defined is first in displayed menu - (define-key map [?c] '(menu-item "c) clean" xmtn-sync-clean)) - (define-key map [?f] '(menu-item "f) full" xmtn-sync-full)) - (define-key map [?b] '(menu-item "b) brief" xmtn-sync-brief)) - (define-key map [?s] '(menu-item "s) status" xmtn-sync-status)) - (define-key map [?u] '(menu-item "u) update" xmtn-sync-update)) - map) - "Keyboard menu keymap used in `xmtn-sync-mode'.") - -(defvar xmtn-sync-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\M-d" xmtn-sync-kbd-map) - (define-key map [?b] 'xmtn-sync-brief) - (define-key map [?c] 'xmtn-sync-clean) - (define-key map [?f] 'xmtn-sync-full) - (define-key map [?n] 'xmtn-sync-next) - (define-key map [?p] 'xmtn-sync-prev) - (define-key map [?q] 'dvc-buffer-quit) - (define-key map [?s] 'xmtn-sync-status) - (define-key map [?u] 'xmtn-sync-update) - (define-key map [?S] 'xmtn-sync-save) - map) - "Keymap used in `xmtn-sync-mode'.") - -(easy-menu-define xmtn-sync-mode-menu xmtn-sync-mode-map - "`xmtn-sync' menu" - `("Xmtn-sync" - ;; first item is top in display - ["Status" xmtn-sync-status t] - ["Update" xmtn-sync-update t] - ["Brief display" xmtn-sync-brief t] - ["Full display" xmtn-sync-full t] - ["Clean/delete" xmtn-sync-clean t] - ["Save" xmtn-sync-save t] - ["Save and Quit" (lambda () (kill-buffer (current-buffer))) t] - )) - -(define-derived-mode xmtn-sync-mode fundamental-mode "xmtn-sync" - "Major mode to specify conflict resolutions." - (setq dvc-buffer-current-active-dvc 'xmtn) - (setq xmtn-sync-ewoc (ewoc-create 'xmtn-sync-printer)) - (setq dvc-buffer-refresh-function nil) - (dvc-install-buffer-menu) - (add-hook 'kill-buffer-hook 'xmtn-sync-save nil t) - (buffer-disable-undo) - (unless xmtn-sync-branch-alist - (let ((branch-file (expand-file-name xmtn-sync-branch-file dvc-config-directory))) - (if (file-exists-p branch-file) - (load branch-file))))) - -(defun xmtn-sync-parse-revision-certs (direction) - "Parse certs associated with a revision; return (branch changelog date author)." - (let ((keyword (ecase direction - ('receive "receive_cert") - ('send "send_cert"))) - cert-label branch date author changelog old-branch) - (while (xmtn-basic-io-optional-line keyword (setq cert-label (cadar value))) - (cond - ((string= cert-label "branch") - (xmtn-basic-io-check-line "value" (setq branch (cadar value))) - (xmtn-basic-io-skip-line "key") - (xmtn-basic-io-skip-line "revision")) - - ((string= cert-label "changelog") - (xmtn-basic-io-check-line "value" (setq changelog (cadar value))) - (xmtn-basic-io-skip-line "key") - (xmtn-basic-io-skip-line "revision")) - - ((string= cert-label "date") - (xmtn-basic-io-check-line "value" (setq date (cadar value))) - (xmtn-basic-io-skip-line "key") - (xmtn-basic-io-skip-line "revision")) - - ((string= cert-label "author") - (xmtn-basic-io-check-line "value" (setq author (cadar value))) - (xmtn-basic-io-skip-line "key") - (xmtn-basic-io-skip-line "revision")) - - (t - ;; ignore other certs - (xmtn-basic-io-skip-stanza)) - ) - (xmtn-basic-io-skip-blank-lines) ;; might be at end of parsing region - ) ;; end while cert - - (list branch changelog date author))) - -(defun xmtn-sync-enter-rev (revid branch date author changelog direction) - "Enter data for REVID into ewoc." - (let (old-branch) - (ewoc-map - (lambda (data) - (if (string= branch (xmtn-sync-branch-name data)) - ;; already some data for branch - (let ((rev-alist (xmtn-sync-branch-rev-alist data))) - (ecase direction - ('receive - (setf (xmtn-sync-branch-rev-alist data) - ;; sync sends revs newest first, we want newest - ;; displayed last, so append to head of list - (push (list revid (list date author changelog)) rev-alist))) - ('send - (setf (xmtn-sync-branch-send-count data) (+ 1 (xmtn-sync-branch-send-count data))))) - (setq old-branch t) - t; update ewoc - ))) - xmtn-sync-ewoc) - - (if (not old-branch) - (let* - ((node-key (and (functionp xmtn-sync-sort) - (funcall xmtn-sync-sort branch))) - (data - (ecase direction - ('receive - (make-xmtn-sync-branch - :name branch - :rev-alist (list (list revid (list date author changelog))) - :send-count 0 - :print-mode 'summary - :sort-key (nth 1 node-key))) - ('send - (make-xmtn-sync-branch - :name branch - :rev-alist nil - :send-count 1 - :print-mode 'summary - :sort-key (nth 1 node-key)))))) - (if (nth 0 node-key) - (ewoc-enter-before xmtn-sync-ewoc (nth 0 node-key) data) - (ewoc-enter-last xmtn-sync-ewoc data)) - )))) - -(defun xmtn-sync-parse-revisions (direction) - "Parse revisions with associated certs." - (let ((keyword (ecase direction - ('receive "receive_revision") - ('send "send_revision"))) - revid) - (while (xmtn-basic-io-optional-line keyword (setq revid (cadar value))) - (xmtn-basic-io-skip-blank-lines) - (let* ((cert-values (xmtn-sync-parse-revision-certs direction)) - (branch (nth 0 cert-values)) - (changelog (nth 1 cert-values)) - (date (nth 2 cert-values)) - (author (nth 3 cert-values))) - - (xmtn-sync-enter-rev revid branch date author changelog direction))))) - -(defun xmtn-sync-parse-certs (direction) - "Parse certs not associated with revisions." - (let ((keyword (ecase direction - ('receive "receive_cert") - ('send "send_cert"))) - revid - cert-label - branch - (date "") - (author "") - (changelog "create or propagate branch\n") - old-branch) - - (while (xmtn-basic-io-optional-line keyword (setq cert-label (cadar value))) - (cond - ((string= cert-label "branch") - ;; This happens when a new branch is created, or a branch is - ;; propagated without any conflicts. - (xmtn-basic-io-check-line "value" (setq branch (cadar value))) - (xmtn-basic-io-skip-line "key") - (xmtn-basic-io-check-line "revision" (setq revid (cadar value))) - - (xmtn-sync-enter-rev revid branch date author changelog direction)) - - (t - ;; ignore other certs - (xmtn-basic-io-skip-stanza)) - ) - - ;; move to next stanza or end of parsing region - (xmtn-basic-io-skip-blank-lines) - - ))) - -(defun xmtn-sync-parse-keys (direction) - ;; just ignore all keys - (let ((keyword (ecase direction - ('receive "receive_key") - ('send "send_key")))) - (xmtn-basic-io-skip-blank-lines) - (while (xmtn-basic-io-optional-skip-line keyword)))) - -(defun xmtn-sync-parse (begin) - "Parse current buffer starting at BEGIN, fill in `xmtn-sync-ewoc' in current buffer, erase parsed text. -Return non-nil if anything parsed." - (set-syntax-table xmtn-basic-io--*syntax-table*) - (goto-char begin) - - ;; receive_cert "branch" - ;; value "foo2" - ;; key [46ec58576f9e4f34a9eede521422aa5fd299dc50] - ;; revision [e4352c1d28b38e87b5040f770a66be2ec9b2362d] - ;; - ;; ... more unattached certs - ;; - ;; receive_revision [e4352c1d28b38e87b5040f770a66be2ec9b2362d] - ;; - ;; receive_cert "branch" - ;; value "foo2" - ;; key [46ec58576f9e4f34a9eede521422aa5fd299dc50] - ;; revision [...] - ;; - ;; receive_cert "changelog" - ;; value "more - ;; " - ;; key [46ec58576f9e4f34a9eede521422aa5fd299dc50] - ;; revision [...] - ;; - ;; receive_cert "date" - ;; value "2010-09-21T08:29:11" - ;; key [46ec58576f9e4f34a9eede521422aa5fd299dc50] - ;; revision [...] - ;; - ;; receive_cert "author" - ;; value "tester@test.net" - ;; key [46ec58576f9e4f34a9eede521422aa5fd299dc50] - ;; revision [...] - ;; - ;; ... more certs - ;; - ;; ... more revisions with certs - ;; - ;; receive_key - ;; - ;; key [46ec58576f9e4f34a9eede521422aa5fd299dc50] - ;; key [46ec58576f9e4f34a9eede521422aa5fd299dc50] - ;; ... more keys - ;; - ;; send_cert ... (unattached) - ;; - ;; send_revision [...] - ;; send_cert ... - ;; - ;; send_key ... - - (xmtn-sync-parse-certs 'receive) - (xmtn-sync-parse-revisions 'receive) - (xmtn-sync-parse-keys 'receive) - (xmtn-sync-parse-certs 'send) - (xmtn-sync-parse-revisions 'send) - (xmtn-sync-parse-keys 'send) - - (let ((result (not (= begin (point))))) - (delete-region begin (point)) - result) - ) - -(defun xmtn-sync-load-file (&optional noerror) - "Add contents of `xmtn-sync-save-file' to current ewoc." - (let ((save-file (expand-file-name xmtn-sync-save-file dvc-config-directory)) - stuff) - (if (file-exists-p save-file) - (progn - (load save-file) - (setq buffer-read-only nil) - (dolist (data stuff) (ewoc-enter-last xmtn-sync-ewoc data)) - (setq buffer-read-only t) - (set-buffer-modified-p nil))))) - -;;;###autoload -(defun xmtn-sync-sync (local-db scheme remote-host remote-db) - "Sync LOCAL-DB with using SCHEME to connect to REMOTE-HOST REMOTE-DB, display sent and received branches. -Remote-db should include branch pattern in URI syntax. Uses `xmtn-sync-executable' to run sync." - (interactive "flocal db: \nMscheme: \nMremote-host: \nMremote-db: ") - - (pop-to-buffer (get-buffer-create "*xmtn-sync*")) - (setq buffer-read-only nil) - (delete-region (point-min) (point-max)) - - ;; `xmtn-sync-parse' creates ewoc entries, which are inserted into - ;; the xmtn-sync buffer. Since it is parsing the same buffer, we - ;; need them to be inserted _after_ the text that is being - ;; parsed. `xmtn-sync-mode' creates the ewoc at point. - - (let ((opts xmtn-sync-automate-args) - (remote-uri (concat scheme "://" remote-host remote-db)) - (msg "Running mtn sync ...")) - - (message msg) - (redisplay) ;; show tickers in mode-line - - ;; Remote command (if needed by scheme) is determined by a custom - ;; version of get_netsync_connect_command; see xmtn-hooks.lua. - - (if (eq system-type 'windows-nt) - (add-to-list 'opts - (concat "--rcfile=" (substring (locate-library "xmtn-hooks.lua") 2))) - (add-to-list 'opts - (concat "--rcfile=" (locate-library "xmtn-hooks.lua")))) - - ;; Always use mtn executable that supports file and ssh, so we - ;; only need one session for all syncs. - (let ((xmtn-executable xmtn-sync-executable) - (xmtn--minimum-required-command-version xmtn-sync-required-command-version) - (xmtn-automate-arguments opts)) - (xmtn-automate-command-output-buffer - (expand-file-name "~/sync") ; root - one session for all syncs - (current-buffer) ; output-buffer - (list - (list "db" local-db) ;; options - "sync" remote-uri) ;; command, args - '("revisions" "revs in" "revs out") ;; display-tickers - )) - - (message (concat msg " done")) - - (goto-char (point-max)) - - ;; don't lose what was saved from last sync; may not have been reviewed yet - (xmtn-sync-mode) - (xmtn-sync-load-file t) - - (setq buffer-read-only nil) - (ewoc-set-hf - xmtn-sync-ewoc - (concat ;; header - (format " local db: %s\n" local-db) - (format "remote db: %s\n" remote-uri)) - "") ;; footer - - (xmtn-sync-parse (point-min)) - (setq buffer-read-only t) - (set-buffer-modified-p nil) - (xmtn-sync-save) - )) - -(defun xmtn-sync-save () - "Save current sync results in `xmtn-sync-save-file' for later review." - (interactive) - (let ((save-file (expand-file-name xmtn-sync-save-file dvc-config-directory)) - stuff) - ;; Directly saving the ewoc doesn't work; too complicated for - ;; pp-to-string. So we turn the ewoc into a simpler list of data - ;; items - (ewoc-map - (lambda (data) - (setq stuff (add-to-list 'stuff data t)) - nil) - xmtn-sync-ewoc) - - (dvc-save-state - (list 'stuff) - (expand-file-name xmtn-sync-save-file dvc-config-directory)))) - -;;;###autoload -(defun xmtn-sync-review (&optional file) - "Display sync results in FILE (defaults to `xmtn-sync-review-file'), appended to content of `xmtn-sync-save-file'. -FILE should be output of 'automate sync'. (external sync handles tickers better)." - (interactive) - (if (buffer-live-p (get-buffer "*xmtn-sync*")) - (progn - (pop-to-buffer "*xmtn-sync*") - (xmtn-sync-save)) - ;; else create - (pop-to-buffer (get-buffer-create "*xmtn-sync*")) - (setq buffer-read-only nil) - (delete-region (point-min) (point-max)) - (xmtn-sync-mode) - (xmtn-sync-load-file file)) - - ;; now add FILE - (setq file (or file - (expand-file-name xmtn-sync-review-file dvc-config-directory))) - (if (file-exists-p file) - (progn - (goto-char (point-min)) - (setq buffer-read-only nil) - (insert-file-contents-literally file) - - ;; user may have run several syncs, dumping each output into FILE; loop thru each. - (while (xmtn-sync-parse (point-min))) - (setq buffer-read-only t) - (set-buffer-modified-p nil) - (xmtn-sync-save) - (delete-file file)))) - -(provide 'xmtn-sync) - -;; end of file diff --git a/dvc/scripts/dvc-cron.sh b/dvc/scripts/dvc-cron.sh deleted file mode 100755 index c6585b5..0000000 --- a/dvc/scripts/dvc-cron.sh +++ /dev/null @@ -1,29 +0,0 @@ -#! /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 deleted file mode 100755 index 9f3ffbb..0000000 --- a/dvc/scripts/make-deb-pkg.sh +++ /dev/null @@ -1,40 +0,0 @@ -#!/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 deleted file mode 100755 index 07a1449..0000000 --- a/dvc/scripts/rename-tla-dvc.sh +++ /dev/null @@ -1,9 +0,0 @@ -#! /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 deleted file mode 100755 index 0a1cdbd..0000000 --- a/dvc/scripts/tla-tree-revision.sh +++ /dev/null @@ -1,4 +0,0 @@ -#! /bin/sh - -tla logs --full | tail -1 - diff --git a/dvc/tests/changes-nochange.txt b/dvc/tests/changes-nochange.txt deleted file mode 100644 index 18dc80d..0000000 --- a/dvc/tests/changes-nochange.txt +++ /dev/null @@ -1,5 +0,0 @@ - -* No changes in $HOME/xtla--test--1.0/. - - - diff --git a/dvc/tests/make-archive-archives.txt b/dvc/tests/make-archive-archives.txt deleted file mode 100644 index a0401ff..0000000 --- a/dvc/tests/make-archive-archives.txt +++ /dev/null @@ -1,2 +0,0 @@ - foo@bar.com--2004 - $HOME/archive diff --git a/dvc/texinfo/Makefile.in b/dvc/texinfo/Makefile.in deleted file mode 100644 index 7143aed..0000000 --- a/dvc/texinfo/Makefile.in +++ /dev/null @@ -1,103 +0,0 @@ -@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@ -DATE_FLAVOR = @DATE_FLAVOR@ - -############################################################################## -all: info dvc.dvi dvc.html dvc-intro.html dvc.pdf - -dvi: dvc.dvi - -pdf: dvc.pdf - -html: dvc.html dvc-intro.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* dvc-intro.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 dvc-intro.info - -alldeps = $(srcdir)/dvc.texinfo dvc-version.texinfo $(srcdir)/dvc-intro.texinfo - -dvc.info: $(alldeps) - $(MAKEINFO) $(srcdir)/dvc.texinfo - -dvc-intro.info: $(alldeps) - $(MAKEINFO) $(srcdir)/dvc-intro.texinfo - -dvc.html: $(alldeps) - $(MAKEINFO) --html --no-split $(srcdir)/dvc.texinfo - -dvc-intro.html: $(alldeps) - $(MAKEINFO) --html --no-split $(srcdir)/dvc-intro.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 $@ - @if test "${DATE_FLAVOR}" = "GNU"; then \ - ( echo @set VERSION $(PACKAGE_VERSION) ; \ - date '+@set UPDATED %F' -r $< ) > $@ ; \ - elif test "${DATE_FLAVOR}" = "BSD"; then \ - ( echo @set VERSION $(PACKAGE_VERSION) ; \ - stat -t'%F' -f'@set UPDATED %Sm' $< ) > $@; \ - else \ - echo "Uknown date flavor: ${DATE_FLAVOR}"; \ - false; \ - fi - - - -.PHONY: all dvi pdf html info \ - install uninstall \ - clean distclean maintainer-clean diff --git a/dvc/texinfo/dvc-intro.texinfo b/dvc/texinfo/dvc-intro.texinfo deleted file mode 100644 index e9b2dda..0000000 --- a/dvc/texinfo/dvc-intro.texinfo +++ /dev/null @@ -1,1026 +0,0 @@ -\input texinfo - -@c Author : Stephen Leake -@c Web : http://www.stephe-leake.org/ - -@setfilename dvc-intro.info -@settitle DVC: Introduction to the GNU Emacs interface to -distributed version control systems. - -@setchapternewpage off - -@node Top -@top DVC Intro - -@smallexample -@group - Copyright (C) 2007 - 2011 Stephen Leake - Permission is granted to copy, distribute and/or modify this document - under the terms of the GNU Free Documentation License, Version 1.2 - or any later version published by the Free Software Foundation; - with no Invariant Sections, with no Front-Cover Texts, and with no - Back-Cover Texts. A copy of the license is included in the section - entitled ``GNU Free Documentation License''. -@end group -@end smallexample - -@menu -* Overview:: -* Installing:: -* Invoking:: -* Status Display:: -* Key bindings:: -* Previewing updates:: -* Merging:: -* mtn command line:: -* Common Errors and Solutions:: -* GNU Free Documentation License:: - -@detailmenu - --- The Detailed Node Listing --- - -Overview - -* Basic DVC:: -* Compare to CVS:: - -Invoking - -* xmtn-status-one:: -* xmtn-propagate-one:: -* xmtn-sync-review:: - -Key bindings - -* status buffer keys:: -* Ediff keys:: -* Log edit keys:: -* DVC log keys:: -* DVC diff keys:: -* mtn conflicts keys:: - -Common Errors and Solutions - -* Attach blocked by unversioned path:: -* Revision id does not match conflict file:: - -@end detailmenu -@end menu - -@node Overview -@chapter Overview - -DVC is a common interface to several extremely powerful and flexible -version control systems, such as Gnu arch, monotone, bzr, and others -(known as 'backends' to DVC). - -DVC provides the same (or at least similar) user interface for each -backend, making it easier to use multiple backends in related -projects. It also automates some tasks, and provides guidance to the -user as to what needs to be done. - -DVC is not included with the standard Gnu emacs distribution. It is -provided in source form via a bzr repository (see @ref{Installing}). - -If you are not already familiar with version control systems, please -read @ref{Basic DVC}. - -One of the most important features of the DVC user interface is that -it identifies what files in a project need attention of some sort; you -have changed them in your working directory, or someone else has -changed them in the repository, or they've been deleted or are new, -etc. DVC presents a list of all such files, and makes it easy to see -what needs to be done for each file. - -When committing files, ediff is used to allow reviewing the changes, -so an appropriate change comment can be written. - -DVC replaces the command-line interface to the backends for the most -common operations, but it is still necessary to use the command line -at times. Creating a repository, starting a project in a repository, -and managing branches require command line operations. - -This manual describes the DVC user interface, and gives examples of -some required command line operations, using the monotone backend. - -It also describes some DVC extensions that are specific to the -monotone backend. - -@menu -* Basic DVC:: -* Compare to CVS:: -@end menu - -@node Basic DVC -@section Basic DVC - -Here we give a brief introduction to general concepts of distributed -version control systems, focusing on the concepts that are needed to -use DVC, and providing common terminology. - -Each backend will have its own documentation, and terminology that -differs from this. The terms here are taken mostly from the monotone -backend. - -Let's start with some definitions: - -@table @dfn -@item workspace -Each user has a workspace, containing a copy of the files she is -working on. This is typically a directory tree. In the root directory -of the tree there is typically a directory containing backend control -files, used only by the backend. - -@item database -The database stores copies of all files in the workspace (and typically -more than one workspace), together with all of the change history and -other meta-information. The database is never edited directly; only -the backends modify it. - -@item local database -A database on the user's machine. This database is used to -control all workspaces on the user's machine. - -@item remote database -A database on a remote machine. This may be another user's local -database, or a central database set up specifically for sharing files. -The user interacts with the remote database in order to retrieve other -user's files, or deliver files to them. - -@item revision -The state of the entire workspace, usually including the set of -changes to the workspace that transform it from the previous -revision. Most operations on the database involve revisions, and all -changes to files are part of a revision. - -@item branch -A label for distinct trees of revisions. There are two main uses for -branches; parallel development on a single project, and completely -separate projects. Branches of a single project are typically merged -back together (this is called ``propagating''), while completely -separate projects are not. - -A database can store any number of branches. - -@item heads -The revisions that are the leaves of the history tree on a single -branch. In monotone, there can be any number of heads on a branch (see -@ref{Merging}). - -@item merge -The process of combining multiple heads of a branch into one -head. This can encounter conflicts that require user resolution; see -@ref{Merging}. - -@item propagate -One branch can be ``propagated'' to another. This is a form of -merging; it merges all the changes from one branch into another, -starting from their common ancestor (which is usually the previous -propagate between the two branches). - -This is how changes in a development branch are promoted to the main -branch. - -Since propagating is a form of merging, it can encounter all of the -same conflicts that merging can. - -@item *dvc-status* buffer -A main user interface buffer. It shows all files in the workspace that -need attention. Single keystrokes invoke various operations. -@xref{Status Display}, for more details. - -The name of the buffer is not literally @dfn{*dvc-status*}; instead, -@dfn{dvc} is replaced by the backend name; @dfn{xmtn} for monotone, -@dfn{bzr} for bzr, etc. But in this document, we will use the name -@dfn{*dvc-status*}. - -@item *dvc-diff* buffer -Another main user interface buffer. It shows the files changed in a -particular revision, together with the diffs of the changes. Single -keystrokes invoke various operations. - -@end table - -Users edit files in their workspace, then use DVC to synchronize the -workspace with the local database. Later, they use the command line to -synchronize their local database with a remote database. This allows -each user to make changes locally but still under change control, -without affecting other users until they each choose to synchronize. - -@node Compare to CVS -@section Compare to CVS -Since many people are familiar with the CVS version control system, we -compare that with DVC, and monotone in particular. - -In CVS, each file is committed separately; in DVC, all files in a -workspace are committed together. This makes sure that all changes -that are related are committed together. - -This means the commit log message mentions all files that have -changes; it is a much longer message, but there are fewer of them, and -the message can more easily describe changes that affect more than one -file. - -In CVS, you must always have access to the remote server. In DVC, you -work with a local database, then separately sync that database with a -remote server. Thus DVC is useful when not on a network; monotone can -even sync via USB disk rather than a network connection. - -This means there are two steps to syncing a workspace with the central -server, which can be annoying. On the other hand, the sync process -syncs all projects in the database at once; with monotone, it lets you -know what projects have changes. - -Otherwise the primary Emacs interface to CVS and DVC are very similar, -although DVC has many secondary interfaces that CVS does not have. - -@node Installing -@chapter Installing -Install bzr; see @url{http://bazaar.canonical.com/en/}. - -Retrieve the DCV source; see -@url{https://gna.org/projects/dvc#options} for general information. - -In a bash shell: -@example -cd ~ -bzr get http://bzr.xsteve.at/dvc/ -cd ~/dvc -autoconf -./configure -make -@end example - -In your @file{.emacs}, add @code{(load-file (expand-file-name "~/dvc/dvc-load.el"))} - -@node Invoking -@chapter Invoking - -Before invoking DVC, you may want to ensure that the local database is -synchronized with the central database, via a backend-specific -command line. - -You typically invoke DVC with the Emacs command @command{dvc-status} -or @command{dvc-diff}. This prompts for a workspace; it should be the -top level directory in your working directory tree. - -You can also create shortcuts in text files to invoke dvc: - -@example -(dvc-status (expand-file-name "~/dvc")) -(dvc-diff nil (expand-file-name "~/dvc")) -@end example - -These can be executed with @key{C-x C-e}, and are a handy way of -keeping track of several workspaces. - -@command{dvc-status} or @command{dvc-diff} run the corresponding -backend command, comparing the workspace against the local database, -and presenting the information in the @dfn{*dvc-status*} or -@dfn{*dvc-diff*} buffer. - -For monotone, there are higher-level starting points: -@table @command -@item xmtn-status-one -Summarizes the status of one workspace. - -@item xmtn-status-multiple -Similar to @command{xmtn-status-one}, but shows all workspaces -immediately under a root directory. - -@item xmtn-propagate-one -Supervises propagating one workspace. - -@item xmtn-propagate-multiple -Supervises propagating several workspaces. - -@item xmtn-sync-sync -Syncs the local database with a remote database, then runs -xmtn-sync-review. - -@item xmtn-sync-review -Reviews saved output of a command-line @command{mtn automate sync}, -displays branches that have been transferred. This is useful for syncs -that take a long time, because the command-line displays progress -tickers. -@end table - -@menu -* xmtn-status-one:: -* xmtn-propagate-one:: -* xmtn-sync-review:: -@end menu - -@node xmtn-status-one -@section xmtn-status-one -Summarizes the status of one workspace, in a @dfn{xmtn-multi-status} -buffer. The branch name is shown, followed by possible appropriate -actions. As each action is performed, it is replaced by the next -action, until there are none left. - -Similarly, @command{xmtn-status-multiple} shows the status of all -workspaces immediately under a root directory. - -Actions are invoked with @key{M-d}. - -The possible actions are: -@table @dfn -@item need-refresh -Shown while the backend is computing, or the user is performing -operations in an associated @dfn{*xmtn-multi-status*} buffer. - -@item commit -Open an @dfn{*xmtn-status*} buffer to commit changes. - -@item resolve conflicts -Open an @dfn{*xmtn-conflicts*} buffer to resolve conflicts; see @ref{Merging}. - -@item show heads -Open an @dfn{*xmtn-revlist*} buffer to show the current head revisions. - -@item merge -Perform the merge, using the conflict resolutions. - -@item update -Update the workspace to the current head revision (must be merged). - -@item update preview -Open an @dfn{*xmtn-revlist*} buffer to review the revisions that will -be included in the next update. - -@item update review -Open an @dfn{*xmtn-revlist*} buffer to review the revisions that were -included in the most recent update. - -@item ignore local changes -Don't show @dfn{commit}. - -@item refresh -Recompute the @dfn{*xmtn-multi-status*} display. - -@item clean/delete -Delete conflicts and conflict resolution files, and delete -the workspace from the display. - -@end table - -@node xmtn-propagate-one -@section xmtn-propagate-one -@command{xmtn-propagate-one} supervises the process of propagating -from one workspace to another, in an @dfn{xmtn-propagate} buffer. - -The display shows one source and destination branch pair, and possible -appropriate actions. As each action is performed, it is replaced by -the next action, until there are none left. - -Similarly, @command{xmtn-propagate-multiple} supervises the -propagation of all workspaces immediately under two root -directories. This is useful when several related projects branch -together. - -In the list of actions, ``from'' stands for the name of the source -branch, ``to'' the name of the destination branch. - -Actions are invoked with @key{M-d}. - -The possible actions are: -@table @command -@item status ``from'' -@itemx status ``to'' -Start an @dfn{xmtn-multi-status} buffer for the specified workspace, -to allow commit, update preview, or merge with -conflict resolution. - -@itemx update ``to'' -Update the specified workspace to the current head revision (must be -merged). This bypasses the @dfn{xmtn-multi-status} buffer, and -therefore does not provide for update preview. It does allow for -update review. - -@item ignore local changes ``from'' -@item ignore local changes ``to'' -Don't show @dfn{need commit}; assume the workspace is -committed. Useful when you know that any local changes won't interfere -with the propagate. - -@item resolve conflicts -Open an @dfn{*xmtn-conflicts*} buffer in the destination workspace to -resolve propagate conflicts; see @ref{Merging}. - -@item propagate -Propagate the branch pair, using the conflict resolutions. - -@item refresh -Recompute the display. If prefixed with @key{C-u}, force examining -workspaces for local changes. - -@item clean/delete -Delete conflicts and conflict resolution files, and delete -the workspace from the display. - -@end table - -@node xmtn-sync-review -@section xmtn-sync-review -@command{xmtn-sync-review} supervises the process of updating local -workspaces after a command line operation that synchronizes the local -and remote databases. - -The command line operation should redirect stdout to -@file{~/.dvc/sync.basic_io}. Most users will want to define shell -functions to invoke common syncs. For example: - -@example - mtn --db ~/monotone-dbs/gds.db automate sync --ticker=count "ssh:user@@host/gds.db?*" >> ~/.dvc/sync.basic_io -@end example - -The @command{xmtn-sync-review} display shows each branch that was -transferred, with a count of how many revisions were sent and -received. - -The user may set the variable @code{xmtn-sync-sort} to a function that -indicates how to order the branches in the display. - -Actions on branches are invoked with @key{M-d}. - -The possible branch actions are: -@table @command -@item status -Start an @dfn{xmtn-multi-status} buffer for the workspace assoicated -with the specified branch, to allow commit, update preview, update -followed by update review, or merge with conflict resolution. - -The user may set the variable @code{xmtn-sync-guess-workspace} to a -function that returns a workspace given a branch. Otherwise, the user -is prompted for the workspace location; the location is cached for -future use. - -@item update -Start an @dfn{xmtn-multi-status} buffer for the workspace assoicated -with the specified branch, then perform @command{update} (if -appropriate). This is often convenient when you know the workspace has -no local changes. - -@itemx brief -Show the first line of the changelog for each revision received. - -@itemx full -Show the complete changelog for each revision received. - -@item clean -Delete the branch from the display. - -Branches that are not cleaned are cached; they will reappear the next -time @code{xmtn-sync-review} is run. - -@end table - -In addition, there are global actions: -@table @command -@item next -Move to the next branch - -@item prev -Move to the previous branch - -@item save-quit -Save the displayed branches, quit. - -@item save -Save the displayed branches. - -@end table - -@node Status Display -@chapter Status Display - -After invoking @command{dvc-status}, you are presented with the -@dfn{*dvc-status*} buffer. - -The detailed format differs depending on the backend. This -presentation is close to the bzr and mtn formats. - -The buffer contains a header, such as: - -@example -Status for c:/Projects/GDS/common/main/: - base revision : e946839c833b15e6bf12bd1536764e1106c41924 - branch : common.main - branch is merged - base revision is a head revision -@end example - -The last two lines are important; either may have ``not'' in it. - -If the branch is not merged, it must be merged before an update can be -done; see @ref{Merging}. However, commits can be done when the branch -is not merged; this allows saving work before attempting the merge. - -If the base revision is not a head revision, there are updates that -need to be applied to the workspace. The updates may be reviewed first -using @key{M m}; they may be applied using @key{M u}. - -In the main body of the buffer, there is one line for each file in the -workspace that needs attention. For example: - -@example - * modified hardware/gds-hardware-pmrd_wrapper.adb - unknown build/ip1k110_quartus/serv_req_info.txt - E modified hardware/test/test_hardware-one_harness.adb -@end example - -Each line has three fields: - -@table @dfn -@item Mark -Either blank (not marked), '*' (marked), or 'E' (excluded). Most -commands can apply to a group of marked files, but some cannot (they -warn if a group is marked). - -Excluded files are under configuration management, but are excluded -from commits. This is used for files that each user modifies, such as -development test drivers. - -@item Status -A phrase indicating the status of the file; see the table below. - -@item File name -Gives the file name of the working file, with a path relative to the -root directory. - -@end table - -In addition, some files will have extra status information that -appears on the next line, indented. - -The following table defines each status phrase, and gives the set of -actions that can be taken for each. The action shown is from the DVC -menu; the equivalent key is also given. - -Other actions (such as commit) apply to all files; they are discussed -later. - -@table @samp -@c the list of status phrases is in -@c /Gnu/dvc/lisp/dvc-fileinfo.el dvc-fileinfo-status-image -@c keep this list in the same order -@item Added - Working file has been added, but not committed. - @table @samp - @item @key{r} Delete - Remove the file from the workspace, do not commit it. -Do this if you've changed your mind. - @end table - -@item Conflict -A conflict was detected while merging. -The same lines have been edited differently by different people. - -This status does not appear with the monotone back-end. - -@table @samp -@item @key{} Edit the file. -Either resolve the conflict -manually, or use @code{M-x smerge-ediff}. Execute @code{M-x -dvc-resolve} when finished to inform the back-end that the -conflict is resolved. -@item @key{U} Revert -Delete the working copy, replace it with the database copy. Do -this if you decide the changes are not correct. -@end table - -@item Deleted - Working file has been marked for deletion, but not committed. - @table @samp - @item @key{a} Add - Undo the removal. - @end table - -@item Ignored - Working file is ignored by the back-end. Files with this status -are not typically shown - ignored files are ignored by DVC as well. -They can be enabled by setting @code{dvc-status-display-ignored} to -nil. - @table @samp - @item @key{# e} -Edit the back-end ignore file. - @end table - -@item Known - Working file is known to the back-end, and unchanged. Files with -this status are not typically shown. They can be enabled by setting -@code{dvc-status-display-known} to nil. There are no appropriate -actions. - -@item Missing - A previously known file has been deleted from the workspace, but - not marked for deletion. - @table @samp - @key{U} Revert -Restore the file to the workspace from the database. - @item @key{r} Delete -Mark the file for deletion. - @end table - -@item Modified - A changed file in the workspace. - @table @samp - @item @key{e} ediff -Review differences and collect a change comment. - @item @key{U} Revert -Delete the working copy, replace it with the database copy. Do -this if you decide your changes are not correct. - @end table - -@item Rename-source - Working file has been marked as renamed but not committed. No - appropriate actions. - -@item Rename-target - Working file has been marked as renamed but not committed. No - appropriate actions. - -@item Unknown - Working file is unknown. - @table @samp - @item @key{a} Add - The file is a new source file; add it to the current revision. This will -change the status to 'Added'. - @item @key{i} Ignore - The file is an output file of some sort (ie object file, test output). -Ignore it in all future DVC sessions. - @item @key{I} Ignore extension in dir - Ignore all files with this extension in this directory. - @item @key{M-I} Ignore extension - Ignore all files with this extension in all directories. - @item @key{r} Delete - The file is a scratch file, or was created by mistake. Remove it from -the workspace. - @end table -@end table - -Changes are committed all at once; the set of changes to the entire -workspace is called a ``revision''. @key{c} opens the -@code{*dvc-log-edit*} buffer, where you can write a change comment. -Then @key{C-c C-c} commits all changes. - -The key @key{M-d} invokes a function called ``Do the Right Thing''. If -there is only a single choice (or an extremely common choice) in the -table above, it does that action. Otherwise, it presents a short list -of the actions, in the message buffer, reminding the user of the -appropriate options. Note that @key{M-d} means meta-d (alt-d on most -PC keyboards)) - -@node Key bindings -@chapter Key bindings - -Here is a summary of the most useful key bindings in the various -buffers associated with DVC. - -@menu -* status buffer keys:: -* Ediff keys:: -* Log edit keys:: -* DVC log keys:: -* DVC diff keys:: -* mtn conflicts keys:: -@end menu - -@node status buffer keys -@section status buffer keys -In a @code{*dvc-status*} buffer: - -@table @key -@item M-d -Do the right thing for the current file. - -@item c -Open a @code{*dvc-log-edit*} buffer to accumulate comments for a -commit. - -@item M m -Show missing revisions; changes that will be applied by update. - -@item M M -Merge current heads; see @ref{Merging}. - -@item M u -Update to the current head. - -@item R -Rename a missing to an unknown file. The two files must be marked -first, and they must be the only files marked. - -@item t -Create an entry in the @code{*dvc-log-edit*} for the current diff. - -@end table - -@node Ediff keys -@section Ediff keys -In an Ediff control buffer (the small window with Ediff in the title bar): - -@table @key -@item a -Copy from buffer A to buffer B. - -@item b -Copy from buffer B to buffer A. - -@item n -Move to next diff. - -@item p -Move to previous diff. - -@item q -Quit Ediff. - -@item t -Create an entry in the @code{*dvc-log-edit*} for the current diff. - -@item $$ -Focus on conflicts in a merge. - -@item ? -Show the help summary for Ediff. @key{?} hides it again. - -@end table - -@node Log edit keys -@section log edit keys -In the @code{*dvc-log-edit*} buffer: - -@table @key -@item C-c C-c -Commit. Note that this is the only way to actually commit. - -@end table - -@node DVC log keys -@section DVC log keys -In a @code{*xmtn-log*} buffer: - -@table @key -@item n -move to the next revision - -@item p -move to the previous revision - -@item = -show a diff of the changes in a single revision - -@item C-= -show a diff between the revision and the workspace - -@end table - -@node DVC diff keys -@section DVC diff keys -In a @code{*dvc-diff*} buffer: - -@table @key -@item e -show ediff for current file - -@item j -jump between file list and diff hunks - -@item n -move to the next diff hunk - -@item p -move to the previous diff hunk - -@end table - -@node mtn conflicts keys -@section mtn conflicts keys -In a @code{*xmtn-conflicts*} buffer: - -@table @key -@item C -Delete conflicts file and any resolution files. - -@item c -Clear the current resolution, so you can specify a different one. - -@item n -Move to the next conflict. - -@item N -Move to the next unresolved conflict. - -@item p -Move to the previous conflict. - -@item P -Move to the previous unresolved conflict. - -@item q -Quit the @code{*xmtn-conflicts*} buffer. The conflicts file and -associated resolution files are saved. - -@item r -Specify a resolution for the current conflict. This prompts with a -choice of resolutions appropriate for the current conflict; select the -appropriate resolution by number. See @ref{Merging}, for information -on the possible resolutions. - -@item M-d -Same as @key{r} - -@end table - -@node Previewing updates -@chapter Previewing updates -To preview updates before applying them to your workspace, use the -@code{dvc-missing} command; it's on the status buffer menu at -@code{DVC | Merge/Update | show missing}. - -@code{dvc-missing} can also be invoked via the Emacs command line -(@key{M-x}); that prompts for a local tree. - -Invoking @code{dvc-missing} brings up an @code{*dvc-log*} window, -showing revisions that are in your local database but not yet applied -to the workspace. - -The revisions are listed oldest first. - -You can view the changes made in a single revision, or from that -revision to the current workspace. - -See @xref{Log edit keys}, for key bindings. - -@key{=} and @key{C-=} bring up a @code{*dvc-diff*} buffer for the -revision selected. The diffs are shown in Gnu diff format; all files -in one @code{*dvc-diff*} buffer. There is a list of the files at the -top of the buffer. See @xref{DVC diff keys}, for key bindings. - -Note that you can also review updates after they have been -applied. This is often more useful, because you can edit the workspace -file to fix problems caused by the update, or just to see the final -state after all revisions have been applied. - -@node Merging -@chapter Merging -Monotone allows multiple people to each commit to their local -database. Then when the databases are synced, there are multiple heads -for the branch; one head for each developer that commited since the -last sync. - -These multiple heads must be merged before a local workspace can be -updated to the head of the branch; there must be only one head to -update to. The monotone command line allows updating to one head of an -unmerged branch, but DVC does not support this. - -When the changes in the different heads are to different files, or to -different parts of the same file, monotone can perform the merge -itself. However, when there are changes to the same parts of one file, -it needs help; this is called a content conflict. - -An @code{*xmtn-conflicts*} buffer shows all conflicts in a merge or -propagate. You can work thru the list one a time, using @key{M-d} -to specify conflict resolutions. The list is saved in a file, so you -can come back to it later. - -The conflicts that monotone knows how to resolve internally have -resolutions of @code{resolved-internal}; the others have no -resolutions. - -The conflicts file and associated resolution files are stored in the -monotone bookkeeping area. They must be deleted when you are done with -them; use @key{C C} for that. - -@key{M-d} prompts with a list of appropriate resolutions for the -current conflict; select the appropriate resolution by number. The -possible resolutions are: - -@table @asis -@item right: drop -@itemx left: drop -Resolve one side of a duplicate name conflict by dropping it. - -@itemx drop -Resolve an orphaned node conflict by dropping it. - -@item right: rename -@itemx left: rename -Resolve one side of a duplicate name conflict by specifying a new name. - -@item rename -Resolve an orphaned node conflict by specifying a new name. - -@item right: right file -@itemx right: left file -@itemx left: right file -@itemx left: left file -Resolve one side of a duplicate name conflict by specifying a file. - -The other side must be dropped or renamed. - -@itemx left file -Resolve a content conflict by specifying a file. The file defaults to -the current workspace file. - -@item right: keep -@itemx left: keep -Resolve one side of a duplicate name conflict by keeping it as is. - -The other side must be dropped or renamed. - -@item right: ediff -@itemx left: ediff -Resolve one side of a duplicate name conflict by ediff. This brings up -an ediff merge of the two files, and saves the result in the -resolution file area. - -The other side must be dropped or renamed. - -@item ediff -Resolve a content conflict via ediff. This brings up an ediff merge of -the two files, and saves the result in the resolution file area. - -@end table - -See @xref{mtn conflicts keys}, for a summary of key bindings. - -@node mtn command line -@chapter mtn command line -Sometimes, especially over NFS, the Emacs DVC interface can be -painfully slow, and it is appropriate to use the mtn command line -instead. - -Other times, the mtn command line is just simpler. - -So we list the most useful mtn commands here. See the monotone command -line help or manual for more information. - -@table @code -@item status -@code{mtn status} - -@item commit -@code{mtn commit --message=""} - -@code{mtn commit --message-file=_MTN/log} - -@item rename -@code{mtn rename } - -@item update -@code{mtn update --move-conflicting-paths} - -@end table - -@node Common Errors and Solutions -@chapter Common Errors and Solutions - -@menu -* Attach blocked by unversioned path:: -* Revision id does not match conflict file:: -@end menu - -@node Attach blocked by unversioned path -@section Attach blocked by unversioned path -Problem: When attempting to update a directory, this warning appears: - -@example -$ mtn update - ... -mtn: warning: attach node 2147486644 blocked by unversioned path '' -mtn: misuse: 1 workspace conflict -@end example - -Explanation: "Unversioned path" means the indicated file is not in the -current revision, however the file already exists on the disk. The -revision you are updating to contains the file, but it can't be -updated because it would overwrite the unknown file on the disk - -Solution: Delete the indicated files from the disk and retry the -update, or specify the @command{--move-conflicting-paths} option. - -@node Revision id does not match conflict file -@section Revision id does not match conflict file -Problem: When attempting to propagate from one branch to another, this message appears: - -@example -$ mtn: propagating common.main -> common.work_user - mtn: [left] 48b675060af47a02bc6f773bd63647726f96cbd5 - mtn: [right] 94ffd0b529dfb44c3ab122fe6c514b5f2e857104 - mtn: misuse: left revision id does not match conflict file -@end example - -Explanation: It means you have some conflict files left over from a -previous propagation or merge. - -Solution: In a buffer showing the ``from'' workspace, run: M-x -xmtn-conflicts-clean. Repeat in the ``to'' workspace, then propagate -again. - -@node GNU Free Documentation License, , Common Errors and Solutions, Top -@appendix GNU Free Documentation License - -@include fdl.texinfo -@bye diff --git a/dvc/texinfo/dvc.texinfo b/dvc/texinfo/dvc.texinfo deleted file mode 100644 index 66dfcd0..0000000 --- a/dvc/texinfo/dvc.texinfo +++ /dev/null @@ -1,965 +0,0 @@ -\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/texinfo/fdl.texinfo b/dvc/texinfo/fdl.texinfo deleted file mode 100644 index ad332af..0000000 --- a/dvc/texinfo/fdl.texinfo +++ /dev/null @@ -1,409 +0,0 @@ -@c This file is derived from the GNU file fdl.texi, by deleting the -@c addendum "How to use this License for your documents" and by deleting -@c the @node and @appendixsec commands. The later need to be in the main -@c texinfo file for the Emacs automatic menu-building commands to work. - -@cindex FDL, GNU Free Documentation License -@center Version 1.2, November 2002 - -@display -Copyright @copyright{} 2000,2001,2002 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. -@end display - -@enumerate 0 -@item -PREAMBLE - -The purpose of this License is to make a manual, textbook, or other -functional and useful document @dfn{free} in the sense of freedom: to -assure everyone the effective freedom to copy and redistribute it, -with or without modifying it, either commercially or noncommercially. -Secondarily, this License preserves for the author and publisher a way -to get credit for their work, while not being considered responsible -for modifications made by others. - -This License is a kind of ``copyleft'', which means that derivative -works of the document must themselves be free in the same sense. It -complements the GNU General Public License, which is a copyleft -license designed for free software. - -We have designed this License in order to use it for manuals for free -software, because free software needs free documentation: a free -program should come with manuals providing the same freedoms that the -software does. But this License is not limited to software manuals; -it can be used for any textual work, regardless of subject matter or -whether it is published as a printed book. We recommend this License -principally for works whose purpose is instruction or reference. - -@item -APPLICABILITY AND DEFINITIONS - -This License applies to any manual or other work, in any medium, that -contains a notice placed by the copyright holder saying it can be -distributed under the terms of this License. Such a notice grants a -world-wide, royalty-free license, unlimited in duration, to use that -work under the conditions stated herein. The ``Document'', below, -refers to any such manual or work. Any member of the public is a -licensee, and is addressed as ``you''. You accept the license if you -copy, modify or distribute the work in a way requiring permission -under copyright law. - -A ``Modified Version'' of the Document means any work containing the -Document or a portion of it, either copied verbatim, or with -modifications and/or translated into another language. - -A ``Secondary Section'' is a named appendix or a front-matter section -of the Document that deals exclusively with the relationship of the -publishers or authors of the Document to the Document's overall -subject (or to related matters) and contains nothing that could fall -directly within that overall subject. (Thus, if the Document is in -part a textbook of mathematics, a Secondary Section may not explain -any mathematics.) The relationship could be a matter of historical -connection with the subject or with related matters, or of legal, -commercial, philosophical, ethical or political position regarding -them. - -The ``Invariant Sections'' are certain Secondary Sections whose titles -are designated, as being those of Invariant Sections, in the notice -that says that the Document is released under this License. If a -section does not fit the above definition of Secondary then it is not -allowed to be designated as Invariant. The Document may contain zero -Invariant Sections. If the Document does not identify any Invariant -Sections then there are none. - -The ``Cover Texts'' are certain short passages of text that are listed, -as Front-Cover Texts or Back-Cover Texts, in the notice that says that -the Document is released under this License. A Front-Cover Text may -be at most 5 words, and a Back-Cover Text may be at most 25 words. - -A ``Transparent'' copy of the Document means a machine-readable copy, -represented in a format whose specification is available to the -general public, that is suitable for revising the document -straightforwardly with generic text editors or (for images composed of -pixels) generic paint programs or (for drawings) some widely available -drawing editor, and that is suitable for input to text formatters or -for automatic translation to a variety of formats suitable for input -to text formatters. A copy made in an otherwise Transparent file -format whose markup, or absence of markup, has been arranged to thwart -or discourage subsequent modification by readers is not Transparent. -An image format is not Transparent if used for any substantial amount -of text. A copy that is not ``Transparent'' is called ``Opaque''. - -Examples of suitable formats for Transparent copies include plain -@sc{ascii} without markup, Texinfo input format, La@TeX{} input -format, @acronym{SGML} or @acronym{XML} using a publicly available -@acronym{DTD}, and standard-conforming simple @acronym{HTML}, -PostScript or @acronym{PDF} designed for human modification. Examples -of transparent image formats include @acronym{PNG}, @acronym{XCF} and -@acronym{JPG}. Opaque formats include proprietary formats that can be -read and edited only by proprietary word processors, @acronym{SGML} or -@acronym{XML} for which the @acronym{DTD} and/or processing tools are -not generally available, and the machine-generated @acronym{HTML}, -PostScript or @acronym{PDF} produced by some word processors for -output purposes only. - -The ``Title Page'' means, for a printed book, the title page itself, -plus such following pages as are needed to hold, legibly, the material -this License requires to appear in the title page. For works in -formats which do not have any title page as such, ``Title Page'' means -the text near the most prominent appearance of the work's title, -preceding the beginning of the body of the text. - -A section ``Entitled XYZ'' means a named subunit of the Document whose -title either is precisely XYZ or contains XYZ in parentheses following -text that translates XYZ in another language. (Here XYZ stands for a -specific section name mentioned below, such as ``Acknowledgements'', -``Dedications'', ``Endorsements'', or ``History''.) To ``Preserve the Title'' -of such a section when you modify the Document means that it remains a -section ``Entitled XYZ'' according to this definition. - -The Document may include Warranty Disclaimers next to the notice which -states that this License applies to the Document. These Warranty -Disclaimers are considered to be included by reference in this -License, but only as regards disclaiming warranties: any other -implication that these Warranty Disclaimers may have is void and has -no effect on the meaning of this License. - -@item -VERBATIM COPYING - -You may copy and distribute the Document in any medium, either -commercially or noncommercially, provided that this License, the -copyright notices, and the license notice saying this License applies -to the Document are reproduced in all copies, and that you add no other -conditions whatsoever to those of this License. You may not use -technical measures to obstruct or control the reading or further -copying of the copies you make or distribute. However, you may accept -compensation in exchange for copies. If you distribute a large enough -number of copies you must also follow the conditions in section 3. - -You may also lend copies, under the same conditions stated above, and -you may publicly display copies. - -@item -COPYING IN QUANTITY - -If you publish printed copies (or copies in media that commonly have -printed covers) of the Document, numbering more than 100, and the -Document's license notice requires Cover Texts, you must enclose the -copies in covers that carry, clearly and legibly, all these Cover -Texts: Front-Cover Texts on the front cover, and Back-Cover Texts on -the back cover. Both covers must also clearly and legibly identify -you as the publisher of these copies. The front cover must present -the full title with all words of the title equally prominent and -visible. You may add other material on the covers in addition. -Copying with changes limited to the covers, as long as they preserve -the title of the Document and satisfy these conditions, can be treated -as verbatim copying in other respects. - -If the required texts for either cover are too voluminous to fit -legibly, you should put the first ones listed (as many as fit -reasonably) on the actual cover, and continue the rest onto adjacent -pages. - -If you publish or distribute Opaque copies of the Document numbering -more than 100, you must either include a machine-readable Transparent -copy along with each Opaque copy, or state in or with each Opaque copy -a computer-network location from which the general network-using -public has access to download using public-standard network protocols -a complete Transparent copy of the Document, free of added material. -If you use the latter option, you must take reasonably prudent steps, -when you begin distribution of Opaque copies in quantity, to ensure -that this Transparent copy will remain thus accessible at the stated -location until at least one year after the last time you distribute an -Opaque copy (directly or through your agents or retailers) of that -edition to the public. - -It is requested, but not required, that you contact the authors of the -Document well before redistributing any large number of copies, to give -them a chance to provide you with an updated version of the Document. - -@item -MODIFICATIONS - -You may copy and distribute a Modified Version of the Document under -the conditions of sections 2 and 3 above, provided that you release -the Modified Version under precisely this License, with the Modified -Version filling the role of the Document, thus licensing distribution -and modification of the Modified Version to whoever possesses a copy -of it. In addition, you must do these things in the Modified Version: - -@enumerate A -@item -Use in the Title Page (and on the covers, if any) a title distinct -from that of the Document, and from those of previous versions -(which should, if there were any, be listed in the History section -of the Document). You may use the same title as a previous version -if the original publisher of that version gives permission. - -@item -List on the Title Page, as authors, one or more persons or entities -responsible for authorship of the modifications in the Modified -Version, together with at least five of the principal authors of the -Document (all of its principal authors, if it has fewer than five), -unless they release you from this requirement. - -@item -State on the Title page the name of the publisher of the -Modified Version, as the publisher. - -@item -Preserve all the copyright notices of the Document. - -@item -Add an appropriate copyright notice for your modifications -adjacent to the other copyright notices. - -@item -Include, immediately after the copyright notices, a license notice -giving the public permission to use the Modified Version under the -terms of this License, in the form shown in the Addendum below. - -@item -Preserve in that license notice the full lists of Invariant Sections -and required Cover Texts given in the Document's license notice. - -@item -Include an unaltered copy of this License. - -@item -Preserve the section Entitled ``History'', Preserve its Title, and add -to it an item stating at least the title, year, new authors, and -publisher of the Modified Version as given on the Title Page. If -there is no section Entitled ``History'' in the Document, create one -stating the title, year, authors, and publisher of the Document as -given on its Title Page, then add an item describing the Modified -Version as stated in the previous sentence. - -@item -Preserve the network location, if any, given in the Document for -public access to a Transparent copy of the Document, and likewise -the network locations given in the Document for previous versions -it was based on. These may be placed in the ``History'' section. -You may omit a network location for a work that was published at -least four years before the Document itself, or if the original -publisher of the version it refers to gives permission. - -@item -For any section Entitled ``Acknowledgements'' or ``Dedications'', Preserve -the Title of the section, and preserve in the section all the -substance and tone of each of the contributor acknowledgements and/or -dedications given therein. - -@item -Preserve all the Invariant Sections of the Document, -unaltered in their text and in their titles. Section numbers -or the equivalent are not considered part of the section titles. - -@item -Delete any section Entitled ``Endorsements''. Such a section -may not be included in the Modified Version. - -@item -Do not retitle any existing section to be Entitled ``Endorsements'' or -to conflict in title with any Invariant Section. - -@item -Preserve any Warranty Disclaimers. -@end enumerate - -If the Modified Version includes new front-matter sections or -appendices that qualify as Secondary Sections and contain no material -copied from the Document, you may at your option designate some or all -of these sections as invariant. To do this, add their titles to the -list of Invariant Sections in the Modified Version's license notice. -These titles must be distinct from any other section titles. - -You may add a section Entitled ``Endorsements'', provided it contains -nothing but endorsements of your Modified Version by various -parties---for example, statements of peer review or that the text has -been approved by an organization as the authoritative definition of a -standard. - -You may add a passage of up to five words as a Front-Cover Text, and a -passage of up to 25 words as a Back-Cover Text, to the end of the list -of Cover Texts in the Modified Version. Only one passage of -Front-Cover Text and one of Back-Cover Text may be added by (or -through arrangements made by) any one entity. If the Document already -includes a cover text for the same cover, previously added by you or -by arrangement made by the same entity you are acting on behalf of, -you may not add another; but you may replace the old one, on explicit -permission from the previous publisher that added the old one. - -The author(s) and publisher(s) of the Document do not by this License -give permission to use their names for publicity for or to assert or -imply endorsement of any Modified Version. - -@item -COMBINING DOCUMENTS - -You may combine the Document with other documents released under this -License, under the terms defined in section 4 above for modified -versions, provided that you include in the combination all of the -Invariant Sections of all of the original documents, unmodified, and -list them all as Invariant Sections of your combined work in its -license notice, and that you preserve all their Warranty Disclaimers. - -The combined work need only contain one copy of this License, and -multiple identical Invariant Sections may be replaced with a single -copy. If there are multiple Invariant Sections with the same name but -different contents, make the title of each such section unique by -adding at the end of it, in parentheses, the name of the original -author or publisher of that section if known, or else a unique number. -Make the same adjustment to the section titles in the list of -Invariant Sections in the license notice of the combined work. - -In the combination, you must combine any sections Entitled ``History'' -in the various original documents, forming one section Entitled -``History''; likewise combine any sections Entitled ``Acknowledgements'', -and any sections Entitled ``Dedications''. You must delete all -sections Entitled ``Endorsements.'' - -@item -COLLECTIONS OF DOCUMENTS - -You may make a collection consisting of the Document and other documents -released under this License, and replace the individual copies of this -License in the various documents with a single copy that is included in -the collection, provided that you follow the rules of this License for -verbatim copying of each of the documents in all other respects. - -You may extract a single document from such a collection, and distribute -it individually under this License, provided you insert a copy of this -License into the extracted document, and follow this License in all -other respects regarding verbatim copying of that document. - -@item -AGGREGATION WITH INDEPENDENT WORKS - -A compilation of the Document or its derivatives with other separate -and independent documents or works, in or on a volume of a storage or -distribution medium, is called an ``aggregate'' if the copyright -resulting from the compilation is not used to limit the legal rights -of the compilation's users beyond what the individual works permit. -When the Document is included in an aggregate, this License does not -apply to the other works in the aggregate which are not themselves -derivative works of the Document. - -If the Cover Text requirement of section 3 is applicable to these -copies of the Document, then if the Document is less than one half of -the entire aggregate, the Document's Cover Texts may be placed on -covers that bracket the Document within the aggregate, or the -electronic equivalent of covers if the Document is in electronic form. -Otherwise they must appear on printed covers that bracket the whole -aggregate. - -@item -TRANSLATION - -Translation is considered a kind of modification, so you may -distribute translations of the Document under the terms of section 4. -Replacing Invariant Sections with translations requires special -permission from their copyright holders, but you may include -translations of some or all Invariant Sections in addition to the -original versions of these Invariant Sections. You may include a -translation of this License, and all the license notices in the -Document, and any Warranty Disclaimers, provided that you also include -the original English version of this License and the original versions -of those notices and disclaimers. In case of a disagreement between -the translation and the original version of this License or a notice -or disclaimer, the original version will prevail. - -If a section in the Document is Entitled ``Acknowledgements'', -``Dedications'', or ``History'', the requirement (section 4) to Preserve -its Title (section 1) will typically require changing the actual -title. - -@item -TERMINATION - -You may not copy, modify, sublicense, or distribute the Document except -as expressly provided for under this License. Any other attempt to -copy, modify, sublicense or distribute the Document 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. - -@item -FUTURE REVISIONS OF THIS LICENSE - -The Free Software Foundation may publish new, revised versions -of the GNU Free Documentation 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. See -@uref{http://www.gnu.org/copyleft/}. - -Each version of the License is given a distinguishing version number. -If the Document specifies that a particular numbered version of this -License ``or any later version'' applies to it, you have the option of -following the terms and conditions either of that specified version or -of any later version that has been published (not as a draft) by the -Free Software Foundation. If the Document does not specify a version -number of this License, you may choose any version ever published (not -as a draft) by the Free Software Foundation. -@end enumerate diff --git a/dvc/www/dvc-logo.svg b/dvc/www/dvc-logo.svg deleted file mode 100644 index 9acb0ce..0000000 --- a/dvc/www/dvc-logo.svg +++ /dev/null @@ -1,249 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - image/svg+xml - - - - - - - - - - - - - - - - - - - - - diff --git a/dvc/www/index.html b/dvc/www/index.html deleted file mode 100644 index 1c7ac6a..0000000 --- a/dvc/www/index.html +++ /dev/null @@ -1,267 +0,0 @@ - - - - - - - - - - - - - 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

- - - -