User: youngs Date: 05/04/04 15:27:24 Added: packages/xemacs-packages/xetla ChangeLog Makefile ewoc.el package-info.in smerge.el xetla-browse.el xetla-core.el xetla-defs.el xetla-tips.el xetla-version.el xetla.el Log: New package -- XEtla Revision Changes Path 1.516 +6 -0 XEmacs/packages/ChangeLog Index: ChangeLog =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/ChangeLog,v retrieving revision 1.515 retrieving revision 1.516 diff -u -p -r1.515 -r1.516 --- ChangeLog 2005/04/03 12:14:05 1.515 +++ ChangeLog 2005/04/04 13:27:15 1.516 ＠＠ -1,3 +1,9 ＠＠ +2005-04-04 Steve Youngs <steve(a)sxemacs.org&gt; + + * package-compile.el (package-directory-map): Add xetla. + + * xemacs-packages/Makefile (PACKAGES): Add xetla. + 2005-04-03 Norbert Koch <viteno(a)xemacs.org&gt; * Packages released: latin-euro-standards. 1.68 +1 -0 XEmacs/packages/package-compile.el Index: package-compile.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/package-compile.el,v retrieving revision 1.67 retrieving revision 1.68 diff -u -p -r1.67 -r1.68 --- package-compile.el 2005/03/09 20:19:23 1.67 +++ package-compile.el 2005/04/04 13:27:15 1.68 ＠＠ -198,6 +198,7 ＠＠ ("x-symbol" . "xemacs-packages") ("xemacs-base" . "xemacs-packages") ("xemacs-devel" . "xemacs-packages") + ("xetla" . "xemacs-packages") ("xlib" . "xemacs-packages") ("xslide" . "xemacs-packages") ("xslt-process" . "xemacs-packages") 1.38 +1 -1 XEmacs/packages/xemacs-packages/Makefile Index: Makefile =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/Makefile,v retrieving revision 1.37 retrieving revision 1.38 diff -u -p -r1.37 -r1.38 --- Makefile 2005/03/09 20:19:26 1.37 +++ Makefile 2005/04/04 13:27:18 1.38 ＠＠ -55,7 +55,7 ＠＠ PACKAGES := xemacs-base fsf-compat mail- sieve slider sml-mode sounds-au sounds-wav speedbar strokes \ supercite textools time tm tooltalk tpu tramp \ vc vc-cc vhdl view-process viper vm w3 x-symbol \ - xslide xslt-process xwem zenirc + xetla xslide xslt-process xwem zenirc else PACKAGES := $(NONMULE_PACKAGES) endif 1.1 XEmacs/packages/xemacs-packages/xetla/ChangeLog Index: ChangeLog =================================================================== 2005-04-04 Steve Youngs <steve(a)sxemacs.org&gt; * New package 1.1 XEmacs/packages/xemacs-packages/xetla/Makefile Index: Makefile =================================================================== # Makefile for XEtla # This file is part of XEmacs. # XEmacs is free software; you can 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. # XEmacs is distributed in the hope that it will be useful, but WITHOUT # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or # FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License # for more details. # You should have received a copy of the GNU General Public License # along with XEmacs; see the file COPYING. If not, write to # the Free Software Foundation, Inc., 59 Temple Place - Suite 330, # Boston, MA 02111-1307, USA. VERSION = 0.99 AUTHOR_VERSION = steve(a)eicq.org--2005/xetla--main--1.0--version-0 MAINTAINER = Steve Youngs <steve(a)youngs.au.com&gt; PACKAGE = xetla PKG_TYPE = regular REQUIRES = ediff xemacs-base jde mail-lib dired prog-modes CATEGORY = standard ELCS = \ ewoc.elc \ smerge.elc \ xetla-version.elc \ xetla-browse.elc \ xetla-core.elc \ xetla-defs.elc \ xetla-tips.elc \ xetla.elc # XEtla can use Gnus, but it is optional. So instead of making Gnus a # dependency of XEtla, just put the Gnus directory into the load-path # to avoid byte-compiler warnings. --SY. PRELOADS = -eval \("push \"../gnus/lisp\" load-path"\) include ../../XEmacs.rules 1.1 XEmacs/packages/xemacs-packages/xetla/ewoc.el Index: ewoc.el =================================================================== ;;; ewoc.el --- utility to maintain a view of a list of objects in a buffer ;; Copyright (C) 1991, 92, 93, 94, 95, 96, 97, 98, 99, 2000 Free Software Foundation ;; Author: Per Cederqvist <ceder(a)lysator.liu.se&gt; ;; Inge Wallin <inge(a)lysator.liu.se&gt; ;; Maintainer: monnier(a)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., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, 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) (eval-when-compile (defvar dll)) (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 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 () ;; ((footer (ewoc--footer 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 1.1 XEmacs/packages/xemacs-packages/xetla/package-info.in Index: package-info.in =================================================================== (xetla (standards-version 1.1 version VERSION author-version AUTHOR_VERSION date DATE build-date BUILD_DATE maintainer MAINTAINER distribution xemacs priority low category CATEGORY dump nil description "Frontend to GNU/arch (tla)." filename FILENAME md5sum MD5SUM size SIZE provides (ewoc smerge xetla-browse xetla-core xetla-defs xetla-tips xetla-version xetla) requires (REQUIRES) type regular )) 1.1 XEmacs/packages/xemacs-packages/xetla/smerge.el Index: smerge.el =================================================================== ;;; smerge.el --- SAM's Merge layer on top of ediff ;; Copyright (C) 2002,2003 Sean MacLennan ;; $Revision: 1.1 $ $Date: 2005/04/04 13:27:20 $ ;; XEmacs ;; 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. ;; 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., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. ;; TODO: ;; - keymap for buffer! ;; - ediff needs a list of args ;; - add more documentation!!! ;; smerge marks the file with the `smerge-merged-face' when the files ;; are merged. In the case of "only in" files, merged means you copied ;; the file over to the other directory. However, for ediffed files, ;; merged means you ran ediff on the files. This does not mean the ;; files are identical. And you are allowed to run ediff on the files ;; again. It is really just a marker that you looked at the file. (require 'ediff) (defmacro smerge-do-in-gnu-emacs (&rest body) "Execute BODY if in GNU/Emacs." (unless running-xemacs `(progn ,＠body))) (put 'smerge-do-in-gnu-emacs 'lisp-indent-hook 'defun) (defmacro smerge-do-in-xemacs (&rest body) "Execute BODY if in XEmacs." (when running-xemacs `(progn ,＠body))) (put 'smerge-do-in-xemacs 'lisp-indent-hook 'defun) (smerge-do-in-xemacs (defalias 'smerge-dirlist 'directory-files)) (smerge-do-in-gnu-emacs (require 'extent) (defun smerge-dirlist (directory &optional full match nosort files-only) (if (eq files-only nil) (directory-files directory full match nosort) (let ((rawlist (directory-files-and-attributes directory full match nosort)) dirlist) (setq files-only (if (eq files-only t) nil t)) (dolist (entry rawlist) (when (eq (nth 1 entry) files-only) (setq dirlist (cons (car entry) dirlist)))) dirlist))) (defun temp-directory () (let ((tmp (getenv "TMPDIR"))) (if tmp tmp "/tmp"))) (defun read-directory-name (prompt &optional dir default mustmatch) (let* ((dir (read-file-name prompt dir default mustmatch)) (attr (file-attributes dir))) (unless (eq (car attr) t) (error "Must be a directory")) dir)) (defun kill-entire-line (&optional arg) (let ((kill-whole-line t)) (beginning-of-line) (kill-line arg))) ) (defvar smerge-diff-program ediff-diff-program "*Program to use to diff the directories. Must support --brief option.") (defvar smerge-diff-options ediff-diff-options "*See `ediff-diff-options'.") (defvar smerge-diff-excludes '("*.o" "*.obj" "*.a" "*.lib" "*~" ".#*" "CVS") "*List of patterns of files and subdirectories to ignore. smerge builds a temprorary file (`smerge-exclude-file') based on this list and passes it to `smerge-diff-program' with the --exclude-from option. Note: These excludes are wildcard expressions as used by diff, not lisp regular expressions.") (defvar smerge-preserve-modes t "*When copying files, preserver the mode of the destination file.") (defvar smerge-exclude-file (concat (temp-directory) "/smerge-excludes") "*Temporary file to hold the `smerge-excludes'.") (defface smerge-only1-face '((((class color)) (:foreground "purple")) (t (:underline t))) "Face for files/directories only in directory 1.") (defface smerge-only2-face '((((class color)) (:foreground "blue")) (t (:underline t))) "Face for files/directories only in directory 2.") (defface smerge-diff-face '((((class color)) (:foreground "red")) (t (:bold t))) "Face for files that are different.") (defface smerge-merged-face '((((class color)) (:foreground "black")) (t (:bold t))) "Face for files that are merged.") (defvar smerge-buffer "*smerge-output*" "*Name of smerge output buffer.") (defvar smerge-keymap nil "*Keymap used by smerge.") (defvar smerge-cvsignore nil "*If non-nil, use the .cvsignore files in `dir1' to ignore files.") ;; For debugging (defvar smerge-raw-diff-output nil "*If non-nil, filename to write the raw diff output to. (dbg)") (defvar smerge-keep-cvsignore-buffer nil "*If non-nil, keep the raw cvsignore buffer. (dbg)") ;; Internals ;; SAM This should be a list? (defvar smerge-flags nil) (defvar smerge-dir1 nil) (defvar smerge-dir2 nil) (defvar smerge-file nil) (defvar smerge-extent nil) (defconst smerge-copy-menu (list "Copy to ..." [(concat smerge-dir1 smerge-file) (smerge-copy 1) (smerge-allow-dir 1)] [(concat smerge-dir2 smerge-file) (smerge-copy 2) (smerge-allow-dir 2)] )) (defun smerge-init () "This creates the keymap." (unless smerge-keymap (setq smerge-keymap (make-sparse-keymap "smerge")) (if running-xemacs (progn (define-key smerge-keymap 'button1 'smerge-mousable) (define-key smerge-keymap 'button2 'smerge-mousable) (define-key smerge-keymap 'button3 'smerge-menu)) (define-key smerge-keymap [mouse-1] 'smerge-mousable) (define-key smerge-keymap [mouse-2] 'smerge-mousable) (define-key smerge-keymap [mouse-3] 'smerge-menu)) (define-key smerge-keymap "\C-m" 'smerge-ediff-or-copy) (define-key smerge-keymap "g" 'smerge-reload) (define-key smerge-keymap "r" 'smerge-reload) (define-key smerge-keymap "n" 'smerge-next) (define-key smerge-keymap "p" 'smerge-prev) )) ;;;###autoload (defun smerge (flags &optional dir1 dir2) "Merge two directories recursively." (interactive "p") (smerge-init) (unless dir1 (setq dir1 (read-directory-name "Directory 1: " nil nil t))) (unless dir2 (setq dir2 (read-directory-name "Directory 2: " nil nil t))) (switch-to-buffer smerge-buffer) ;; Yes I want to be in the output buffer (toggle-read-only 0) ;; writable (setq smerge-flags flags) (setq smerge-dir1 (file-name-as-directory (expand-file-name dir1))) (setq smerge-dir2 (file-name-as-directory (expand-file-name dir2))) (smerge-recursive-diff) (smerge-fixup-filenames) (when smerge-cvsignore (smerge-cvsignore smerge-dir1)) (smerge-post-process flags) (toggle-read-only 1) ;; read-only ) (defun smerge-reload () "Rediff two directories recursively." (interactive) (smerge smerge-flags smerge-dir1 smerge-dir2)) (defun smerge-recursive-diff () (let (rc) (erase-buffer) (dolist (exclude smerge-diff-excludes) (insert (concat exclude "\n"))) (write-region (point-min) (point-max) smerge-exclude-file nil 'no-message) (erase-buffer) (let ((diff-options (concat "--exclude-from=" smerge-exclude-file " -r" " --brief " smerge-diff-options))) ;; Since we are tightly coupled with ediff, use their program! ;; This erases the diff buffer automatically. (ediff-exec-process smerge-diff-program (current-buffer) 'synchronize diff-options smerge-dir1 smerge-dir2)) (delete-file smerge-exclude-file) (when smerge-raw-diff-output (write-region (point-min) (point-max) smerge-raw-diff-output)) (and (numberp rc) (eq rc 0)))) (defun smerge-fixup-filenames () "Diff splits the `Only in' files into directory and filename. Top level directories end in /, subdirs do not." (goto-char (point-min)) (while (re-search-forward "^\\(Only in [^:]*\\)\\(.\\): " nil t) (if (string= (match-string 2) "/") (replace-match "\\1/" nil nil) (replace-match "\\1\\2/" nil nil)))) (defun smerge-post-process (flags) (let (match extent file start) (goto-char (point-min)) (insert (format "Diff %s and %s\n\n" smerge-dir1 smerge-dir2)) (setq start (point)) (cond ((> flags 4) ;; c-u c-u ;; Remove different files (while (re-search-forward "^Files .*\n" nil t) (replace-match ""))) ((> flags 1) ;; c-u ;; Remove the unique files (while (re-search-forward "^Only in .*\n" nil t) (replace-match "")))) ;; Only in 1 (setq match (format "^Only in %s\\(.*\\)$" smerge-dir1)) (goto-char (point-min)) (while (re-search-forward match nil t) (setq file (match-string 1)) (setq extent (smerge-make-extent (match-beginning 0) (match-end 0) 'smerge-only1-face)) (set-extent-property extent 'type 2) (replace-match file) ) ;; Only in 2 (setq match (format "^Only in %s\\(.*\\)$" smerge-dir2)) (goto-char (point-min)) (while (re-search-forward match nil t) (setq file (match-string 1)) (setq extent (smerge-make-extent (match-beginning 0) (match-end 0) 'smerge-only2-face)) (set-extent-property extent 'type 1) (replace-match (concat "\t\t\t\t" file)) ) ;; Both (setq match (format "^Files %s\\(.+\\) and %s.+ differ$" smerge-dir1 smerge-dir2)) (goto-char (point-min)) (while (re-search-forward match nil t) (setq file (match-string 1)) (setq extent (smerge-make-extent (match-beginning 0) (match-end 0) 'smerge-diff-face)) (set-extent-property extent 'type 3) (replace-match (concat "\t\t" file)) ) ;; Back to start (goto-char start) (if (re-search-forward "\\w" nil t) (forward-char -1)) )) (autoload 'defadvice "advice" nil nil 'macro) (defadvice ediff-quit (after smerge activate) (when (extentp smerge-extent) (set-extent-property smerge-extent 'face 'smerge-merged-face) ;; SAM (delete-other-windows) (switch-to-buffer smerge-buffer) (let ((next (next-extent smerge-extent)) start) (when next (setq start (extent-start-position next)) (goto-char start) (if (re-search-forward "\\w" nil t) (forward-char -1)) )) (setq smerge-extent nil) ;; done )) (defun smerge-file (extent) "Given a smerge extent, return the file name." (let ((file (buffer-substring (extent-start-position extent) (extent-end-position extent)))) (string-match "\t*\\(.*\\)" file) (match-string 1 file))) (defun smerge-menu (event) "This is called on a right mouse click in the display window. Pops up a menu that allows copying the file to directory one or two." (interactive "e") (let ((extent (extent-at (event-point event)))) (unless extent (error "No extent at point")) (setq smerge-file (smerge-file extent)) (setq smerge-extent extent) (popup-menu smerge-copy-menu))) (defun smerge-mousable (event) "This is called on a left or middle mouse click in the display window." (interactive "e") (smerge-ediff (extent-at (event-point event)))) (defun smerge-ediff-or-copy () "Ediff or copy the file." (interactive) (let* ((extent (extent-at (point))) (type (extent-property extent 'type))) (unless extent (error "No extent at point")) (cond ((or (eq type 1) (eq type 2)) (setq smerge-file (smerge-file extent)) (smerge-copy 1 t)) ((eq type 3) (smerge-ediff extent)) (t (beep))))) (defun smerge-ediff (&optional extent) "Ediff the two files." (interactive) (let (file) (unless extent (setq extent (extent-at (point))) (unless extent (error "No extent at point"))) (if (eq (extent-property extent 'type) 3) (progn (setq smerge-extent extent) (setq file (smerge-file extent)) (ediff-files (concat smerge-dir1 file) (concat smerge-dir2 file))) (beep)))) (defun smerge-allow-dir (dir) "Are we allowed to copy to this directory." (let ((type (extent-property smerge-extent 'type))) (if type (> (logand (extent-property smerge-extent 'type) dir) 0) (message "WARNING: No type for extent!") 0))) ;; Copy file preserving the destination modes if necessary (defun smerge-copy-file (src dst &optional ok-if-already-exists keep-time) (let ((modes (file-modes dst))) (copy-file src dst ok-if-already-exists keep-time) (and smerge-preserve-modes modes (set-file-modes dst modes)))) (defun smerge-copy (dir &optional ask) "Do the copy to the directory specified." (let ((file1 (concat smerge-dir1 smerge-file)) (file2 (concat smerge-dir2 smerge-file)) src dst) (cond ((eq dir 1) (setq src file2 dst file1)) ((eq dir 2) (setq src file1 dst file2)) (t (error "Huh?"))) (when (or (not ask) (yes-or-no-p (format "Copy to %s? " dst))) (smerge-copy-file src dst t t) ;; Mark as merged (set-extent-property smerge-extent 'face 'smerge-merged-face) ;; If this is an "only" mark as copied (when (< (extent-property smerge-extent 'type) 3) (set-extent-property smerge-extent 'type 0)) (setq smerge-extent nil) ))) (defun smerge-make-extent (start end face) (let (extent) (setq end (1+ end)) ;; include the NL (setq extent (make-extent start end)) (set-extent-face extent face) (set-extent-mouse-face extent 'highlight) (set-extent-keymap extent smerge-keymap) extent )) ;; .cvsignore code (defun smerge-find-ignores (dir) "Find all the .cvsignore files recursively from `dir'. `dir' must end in /." (let ((dirlist (smerge-dirlist dir nil "^[^.].*" nil 'dirs)) (file (concat dir ".cvsignore")) filelist) (if (file-exists-p file) (setq filelist (list file))) (dolist (subdir dirlist) (unless (string= subdir "CVS") (setq filelist (append filelist (smerge-find-ignores (concat dir subdir "/")))))) filelist)) (defun smerge-build-ignore-list (dir) "Build a list of files/directories to ignore. `dir' must end in /." (let ((list (smerge-find-ignores dir)) (buff (get-buffer-create "*smerge-cvsignores*")) start) (save-excursion (set-buffer buff) (erase-buffer) (dolist (file list) (setq start (point)) (insert-file-contents file) (goto-char start) (while (re-search-forward "^" nil t) (insert file))) (goto-char (point-min)) (while (re-search-forward ".cvsignore" nil t) (replace-match "")) ;; Protect . from regexp (goto-char (point-min)) (while (search-forward "." nil t) (replace-match "\\\\.")) ;; Convert * -> .* (goto-char (point-min)) (while (search-forward "*" nil t) (replace-match ".*")) ;; Build the list (setq list nil) (goto-char (point-min)) (while (re-search-forward "^.+$" nil t) (setq list (cons (match-string 0) list)))) (unless smerge-keep-cvsignore-buffer (kill-buffer buff)) list)) (defun smerge-cvsignore (dir) "smerge internal function to remove the .cvsignore matches" (let ((list (smerge-build-ignore-list dir)) match) (dolist (ignore list) (goto-char (point-min)) ;; Only match complete matches ;; We cannot use \b here since we are matching filenames (setq match (concat ignore "\\s-")) (while (re-search-forward match nil t) ;; Since we match the \n at the end of some lines... (goto-char (match-beginning 0)) (kill-entire-line) )))) ;; .cvsignore code ends (provide 'smerge) 1.1 XEmacs/packages/xemacs-packages/xetla/xetla-browse.el Index: xetla-browse.el =================================================================== ;;; xetla-browse.el --- Arch archives/library browser ;; Copyright (C) 2004 by Stefan Reichoer (GPL) ;; Copyright (C) 2004 Steve Youngs (BSD) ;; Author: Steve Youngs <steve(a)eicq.org&gt; ;; Maintainer: Steve Youngs <steve(a)eicq.org&gt; ;; Created: 2004-11-25 ;; Keywords: archive arch tla ;; Based on xtla-browse.el by: Masatake YAMATO <jet(a)gyve.org&gt; ;; This file is part of XEtla. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; ;; 3. Neither the name of the author nor the names of any contributors ;; may be used to endorse or promote products derived from this ;; software without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR ;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE ;; DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE ;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF ;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR ;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN ;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; Commentary: ;; ;; Contributions from: ;; Stefan Reichoer, <stefan(a)xsteve.at&gt; ;; Matthieu Moy <Matthieu.Moy(a)imag.fr&gt; ;; Masatake YAMATO <jet(a)gyve.org&gt; ;; Milan Zamazal <pdm(a)zamazal.org&gt; ;; Martin Pool <mbp(a)sourcefrog.net&gt; ;; Robert Widhopf-Fenk <hack(a)robf.de&gt; ;; Mark Triggs <mst(a)dishevelled.net&gt; ;; 1. Load xetla-browse.el ;; 2. M-x xetla-browse RET ;;; TODO: ;; - Generic refresh ;; ;;; History: ;; ;;; Code: (eval-when-compile (require 'cl) (autoload 'easy-mmode-define-keymap "easy-mmode")) (require 'tree-widget) (require 'xetla) (defvar xetla-browse-buffer-name "*xetla-browse*") (defvar xetla-browse-buffer-type 'browse) (xetla-add-buffer-type xetla-browse-buffer-type xetla-browse-buffer-name) ;; -------------------------------------- ;; Open node tracking ;; -------------------------------------- (defvar xetla-browse-open-list '() "List holding the name of open nodes.") (defun xetla-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 xetla-browse-open-list))) (defun xetla-browse-open-list-add (archive &optional category branch version) "Add a node specified by the arguments to 'xetla-browse-open-list'. ARCHIVE/CATEGORY-BRANCH-VERSION, ARCHIVE/CATEGORY-BRANCH, ARCHIVE/CATEGORY, ARCHIVE are added. CATEGORY, BRANCH, VERSION are optional." (xetla-browse-open-list-add-internal (list archive category branch version nil)) (xetla-browse-open-list-add-internal (list archive category branch nil nil)) (xetla-browse-open-list-add-internal (list archive category nil nil nil)) (xetla-browse-open-list-add-internal (list archive nil nil nil nil)) (xetla-browse-open-list-add-internal (list nil nil nil nil nil))) (defun xetla-browse-open-list-add-internal (name) "Add NAME to `xetla-browse-open-list'." (unless (xetla-browse-open-list-member (xetla-name-archive name) (xetla-name-category name) (xetla-name-branch name) (xetla-name-version name)) (push name xetla-browse-open-list))) (defun xetla-browse-open-list-remove (archive &optional category branch version) "Remove ARCHIVE/CATEGORY-BRANCH-VERSION from `xetla-browse-open-list'. CATEGORY, BRANCH and VERSION are optional." (let ((name (list archive category branch version nil))) (setq xetla-browse-open-list (delete name xetla-browse-open-list)))) (defun xetla-browse-open-tracker (tree) "Add or remove a node represented by TREE to/from `xetla-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) (xetla-browse-open-list-add a c b v) (xetla-browse-open-list-remove a c b v)))) (defun xetla-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) (xetla-widget-node-get-at))) (defun xetla-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)) (index (position name args :test (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)))))) (tree (when index (nth index (widget-get parent :children)))) (node (when tree (save-excursion (goto-char (widget-get tree :from)) (goto-char (next-single-property-change (point) 'widget)) (xetla-widget-node-get-at))))) node)) (defun xetla-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 `xetla-widget-root-node'. archive is the widget representing ARCHIVE, of type `xetla-widget-archive-node'. The last items are potentially nil if CATEGORY, BRANCH or VERSION is nil. Otherwise, they are respectively of type `xetla-widget-category-node', `xetla-widget-revision-node' and `xetla-widget-version-node'." (let* ((root (xetla-browse-find-archives-root-widget)) (a (xetla-browse-find-named-widget (widget-get root :parent) archive :archive)) (c (and a category (xetla-browse-find-named-widget (widget-get a :parent) category :category))) (b (and c branch (xetla-browse-find-named-widget (widget-get c :parent) branch :branch))) (v (and b version (xetla-browse-find-named-widget (widget-get b :parent) version :version)))) (list root a c b v))) (defun xetla-browse-find-single-widget (archive &optional category branch version) "Similar to `xetla-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 `xetla-browse-find-widget'." (let ((widgets (xetla-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 xetla-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 xetla-widget-*-node." (case (widget-type widget) (xetla-widget-archive-node (xetla-browse-find-single-widget (widget-get widget :archive))) (xetla-widget-category-node (xetla-browse-find-single-widget (widget-get widget :archive) (widget-get widget :category))) (xetla-widget-branch-node (xetla-browse-find-single-widget (widget-get widget :archive) (widget-get widget :category) (widget-get widget :branch))) (xetla-widget-version-node (xetla-browse-find-single-widget (widget-get widget :archive) (widget-get widget :category) (widget-get widget :version))))) (defun* xetla-browse-open (flash archive &optional category branch version) (let (widgets root a c b v) (unless archive (return-from xetla-browse-open nil)) (setq widgets (xetla-browse-find-widget archive category branch nil)) (setq root (nth 0 widgets)) (unless root (error "Cannot find root archives node")) (xetla-widget-node-toggle-subtree-internal root 'open) (setq widgets (xetla-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)) (xetla-flash-line)) (return-from xetla-browse-open nil)) (error "Cannot find archive node for: %s" archive))) (xetla-widget-node-toggle-subtree-internal a 'open) (setq widgets (xetla-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)) (xetla-flash-line)) (return-from xetla-browse-open nil)) (error "Cannot find category node for: %s/%s" archive category))) (xetla-widget-node-toggle-subtree-internal c 'open) (setq widgets (xetla-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)) (xetla-flash-line)) (return-from xetla-browse-open nil)) (error "Cannot find branch node for: %s/%s-%s" archive category branch))) (xetla-widget-node-toggle-subtree-internal b 'open) (setq widgets (xetla-browse-find-widget archive category branch version)) (setq v (nth 4 widgets)) (if v (progn (when flash (goto-char (widget-get v :from)) (xetla-flash-line)) (return-from xetla-browse-open nil)) (error "Cannot find branch node for: %s/%s-%s-%s" archive category branch version))) ) ;; -------------------------------------- ;; Abstract Super Widget ;; -------------------------------------- (define-widget 'xetla-widget-node 'item "Abstract super widget for xetla-widget-*-node." :xetla-type nil :format "%[ %t%]%{%v%}\n" :face nil :keymap nil :menu nil :marks " " :keep '(:marks :open) :open-subtree (if (fboundp 'tree-widget-open-node) 'tree-widget-open-node 'xetla-tree-widget-node-toggle-subtree-for-tree-widget-v1) :close-subtree (if (fboundp 'tree-widget-open-node) 'tree-widget-close-node 'xetla-tree-widget-node-toggle-subtree-for-tree-widget-v1)) (defvar xetla-widget-node-map (let ((map (copy-keymap xetla-context-map-template))) (define-key map [return] 'xetla-widget-node-toggle-subtree) (define-key map [button2] 'xetla-widget-node-toggle-subtree-by-mouse) (define-key map "\C-m" 'xetla-widget-node-toggle-subtree) (define-key map (xetla-prefix-buffer ?p) 'xetla-show-process-buffer) (define-key map (xetla-prefix-buffer ?L) 'xetla-open-internal-log-buffer) (define-key map (xetla-prefix-buffer xetla-key-show-bookmark) 'xetla-bookmarks) (define-key map xetla-keyvec-kill-ring 'xetla-widget-node-save-name-to-kill-ring) (define-key map xetla-keyvec-add-bookmark 'xetla-widget-node-add-bookmark) map) "Keymap commonly used in xetla-widget-*-node.") (defun xetla-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 (xetla-widget-node-install-ui-element widget (if (string= string "") "<empty>" string)))) (concat marks value)))) (defun xetla-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 (xetla-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 xetla-widget-node-get-at (&optional point) "Get widget at POINT." (get-text-property (if point point (point)) 'widget)) (defun xetla-widget-node-get-name (&optional point) "Get name list associated widget under the POINT." (let ((widget (xetla-widget-node-get-at point))) (list (widget-get widget :archive) (widget-get widget :category) (widget-get widget :branch) (widget-get widget :version) nil))) (defun xetla-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 (xetla-widget-node-get-at point))) (widget-get widget :xetla-type))) (defun xetla-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 xetla-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." (interactive) (unless level (setq level 1)) (unless point (setq point (point))) (if branch (xetla-archive-tree-build-versions archive category branch nil t) (if category (xetla-archive-tree-build-branches archive category nil t) (if archive (xetla-archive-tree-build-categories archive nil t) (xetla-archive-tree-build-archives nil t)))) (let* ((widget (xetla-widget-node-get-at point)) (tree (xetla-widget-get-ancestor widget level))) (widget-put tree :args nil) (widget-value-set tree (widget-value tree)) (widget-setup))) (defun xetla-widget-node-synchronize-mirror-to-remote () "Synchronizes the mirror for the archive at point to remote from local." (interactive) (let* ((name (xetla-widget-node-get-name)) (archive (xetla-name-archive name)) (type (xetla-archive-type archive)) mirror source) (cond ((eq type 'normal) (setq mirror (xetla-archive-name-mirror archive t)) (unless mirror (error "No mirror archive for `%s'" archive))) ((eq type 'mirror) (setq source (xetla-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))) (xetla-archive-mirror archive (xetla-name-category name) (xetla-name-branch name) (xetla-name-version name) nil))) (defun xetla-widget-node-synchronize-mirror-to-local () "Synchronizes the mirror for the archive at point to local from remote." (interactive) ;; TODO ) (defun xetla-widget-node-save-name-to-kill-ring () "Save the name under point to `kill-ring'." (interactive) (let ((name (xetla-name-construct (xetla-widget-node-get-name)))) (when (equal "" name) (error "No widget under the point")) (kill-new name) (message "Name: %s" name))) (defun xetla-widget-node-add-bookmark () "Add a name associated with a widget at point to xetla's bookmarks." (interactive) (let* ((target (xetla-widget-node-get-name)) (target-fq (xetla-name-construct target)) (bookmark (read-from-minibuffer (format "Name of Bookmark for `%s': " target-fq)))) (xetla-bookmarks-add bookmark target) (when (y-or-n-p "View bookmarks? ") (xetla-bookmarks)) (message "bookmark %s(=> %s) added." bookmark target-fq))) (defun xetla-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) (xetla-widget-node-toggle-subtree-internal (xetla-widget-node-get-at point) force)) (defun xetla-widget-node-toggle-subtree-recursive (&optional point force) "Same as `xetla-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 `xetla-widget-node-toggle-subtree'." (interactive) (xetla-widget-node-toggle-subtree-internal (xetla-widget-node-get-at point) force t)) (defun xetla-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 (xetla-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)) (xetla-widget-node-toggle-subtree-recursion widget 'close)) (when close-subtree (funcall close-subtree widget)))))) (defun xetla-widget-node-toggle-subtree-recursion (widget force) "A helper function for 'xetla-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 (xetla-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 (xetla-widget-node-toggle-subtree-internal full-widget force t)))))) (defun xetla-tree-widget-node-toggle-subtree-for-tree-widget-v1 (widget) "Toggle tree node function used in `xetla-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))) (xetla-make-bymouse-function xetla-widget-node-toggle-subtree) ;; -------------------------------------- ;; My-id ;; -------------------------------------- (define-widget 'xetla-widget-my-id 'push-button "Widget to control xetla's my-id." :format "%{My-id:%} %[%t%]" :sample-face 'bold :button-face 'widget-field-face :notify 'xetla-widget-my-id-set :help-echo "Click here to change my-id") (defun xetla-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 (xetla-my-id t))) (widget-value-set changed new-id) (widget-setup))) ;; -------------------------------------- ;; Root node ;; -------------------------------------- (define-widget 'xetla-widget-root-node 'xetla-widget-node "Root node widget for trees in xetla-browse buffer." :value-create 'xetla-widget-root-node-value-create :format " %v\n" :face 'bold) (defun xetla-widget-root-node-value-create (widget) "Create a value for root node represented by WIDGET." (insert (xetla-widget-node-install-ui-element widget (widget-get widget :tag)))) (defvar xetla-widget-archives-root-node-map (let ((map (copy-keymap xetla-widget-node-map))) (define-key map xetla-keyvec-refresh 'xetla-widget-node-refresh) (define-key map (xetla-prefix-add ?a) 'xetla-widget-archives-root-node-make-archive) (define-key map (xetla-prefix-add ?r) 'xetla-widget-archives-root-node-register-archive) map) "Keymap used on the archives root node.") (easy-menu-define xetla-widget-archives-root-node-menu nil "Menu used on the root archives item in `xetla-browse-mode' buffer." '("Archives Root" ["Update Archives List" xetla-widget-node-refresh t] ["Make New Archive..." xetla-widget-archives-root-node-make-archive t] ["Register Archive" xetla-widget-archives-root-node-register-archive t])) (defun xetla-widget-archives-root-node-make-archive () "Call `xetla-make-archive-internal' interactively then update the tree of `xetla-browse'." (interactive) (call-interactively 'xetla-make-archive-internal) (xetla-widget-node-refresh 1)) (defun xetla-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 xetla-widget-archives-root-node-register-archive () "Call `xetla-register-archive-internal' interactively ; then update the tree of `xetla-browse'." (interactive) (let* ((result (call-interactively 'xetla-register-archive-internal)) (archive-registered (nth 0 result)) (archive (nth 1 result)) (xetla-response (nth 3 result))) (when archive-registered (xetla-widget-node-refresh 1) (message xetla-response) (xetla-widget-archives-root-node-goto (if (string-match ".+: \\(.+\\)" xetla-response) (match-string 1 xetla-response) archive)) (xetla-flash-line)))) ;; -------------------------------------- ;; Archive ;; -------------------------------------- (defface xetla-location '((((class color) (background dark)) (:foreground "gray")) (((class color) (background light)) (:foreground "gray")) (t (:bold t))) "Face to highlight xetla's archive location." :group 'xetla-faces) (make-face 'xetla-location-ftp "Face to highlight xetla's archive ftp location.") (set-face-parent 'xetla-location-ftp 'xetla-location) (make-face 'xetla-location-sftp "Face to highlight xetla's archive sftp location.") (set-face-parent 'xetla-location-sftp 'xetla-location) (set-face-foreground 'xetla-location-sftp "gray50") (make-face 'xetla-location-http "Face to highlight xetla's archive sftp location.") (set-face-parent 'xetla-location-http 'xetla-location) (set-face-foreground 'xetla-location-http "gray60") (make-face 'xetla-location-local "Face to highlight xetla's local archive.") (set-face-parent 'xetla-location-local 'xetla-location) (set-face-foreground 'xetla-location-local "gray30") (defvar xetla-widget-archive-node-map (let ((map (copy-keymap xetla-widget-node-map))) (define-key map xetla-keyvec-refresh 'xetla-widget-archive-node-refresh) (define-key map "*" 'xetla-widget-archive-node-select-default) (define-key map xetla-keyvec-remove 'xetla-widget-archive-node-unregister-archive) (define-key map (xetla-prefix-add ?c) 'xetla-widget-archive-node-make-category) (define-key map (xetla-prefix-apply-from-here xetla-key-reflect) 'xetla-widget-archive-node-start-project) (define-key map xetla-keyvec-reflect 'xetla-widget-node-synchronize-mirror-to-remote) (define-key map xetla-keyvec-get 'xetla-widget-node-synchronize-mirror-to-local) (define-key map (xetla-prefix-add xetla-key-reflect) 'xetla-widget-archive-node-make-mirror-at-remote) (define-key map (xetla-prefix-add xetla-key-get) 'xetla-widget-archive-node-make-mirror-at-local) map) "Keymap used on xetla-widget-archive-node.") (easy-menu-define xetla-widget-archive-node-menu nil "Menu used on a archive item in `xetla-browse-mode' buffer." '("Archive" ["Update Categories List" xetla-widget-archive-node-refresh t] ["Set Default Archive" xetla-widget-archive-node-select-default t] ["Remove Archive Registration" xetla-widget-archive-node-unregister-archive t] ["Make New Category..." xetla-widget-archive-node-make-category t] ["Start Project from Here" xetla-widget-archive-node-start-project t] ["Add a Bookmark" xetla-widget-node-add-bookmark t] ("Remote Mirror" ["Synchronize Mirror to Remote From Local" xetla-widget-node-synchronize-mirror-to-remote (let* ((archive (xetla-name-archive (xetla-widget-node-get-name))) (type (xetla-archive-type archive))) (or (and (eq type 'normal) (xetla-archive-name-mirror archive t)) (and (eq type 'mirror) (xetla-archive-name-source archive t))))] ["Create a Mirror at Remote" xetla-widget-archive-node-make-mirror-at-remote (eq (xetla-archive-type (xetla-name-archive (xetla-widget-node-get-name))) 'normal)]) ("Local Mirror" ["Synchronize Mirror to Local[TODO]" ;; TODO xetla-widget-node-synchronize-mirror-to-local nil] ["Create a Mirror at Local" xetla-widget-archive-node-make-mirror-at-local (eq (xetla-archive-type (xetla-name-archive (xetla-widget-node-get-name))) 'source)] "-" ["Convert to SOURCE archive" xetla-widget-archive-node-convert-to-source (eq (xetla-archive-type (xetla-name-archive (xetla-widget-node-get-name))) 'normal)]) ["Save Name to Kill Ring" xetla-widget-node-save-name-to-kill-ring t])) (defconst xetla-widget-archive-node-tag "a") (defconst xetla-widget-archive-node-default-tag "A") (define-widget 'xetla-widget-archive-node 'xetla-widget-node "Archive node in xetla-browse." :tag xetla-widget-archive-node-tag :value-create 'xetla-widget-archive-node-value-create :xetla-type 'archive :face 'xetla-archive-name :keymap 'xetla-widget-archive-node-map :menu xetla-widget-archive-node-menu :archive nil :archive-location nil :archive-defaultp nil) (defvar xetla-widget-archive-node-list nil) (defun xetla-browse-expand-archives (root) "Expand ROOT widget." (or (and (not current-prefix-arg) (widget-get root :args)) (let ((default-archive (xetla-my-default-archive))) (setq xetla-widget-archive-node-list nil) (mapcar (lambda (archive) (let ((res `(tree-widget :open ,(xetla-browse-open-list-member (car archive)) :has-children t :dynargs xetla-browse-expand-categories :node (xetla-widget-archive-node :tag ,(if (equal default-archive (car archive)) xetla-widget-archive-node-default-tag xetla-widget-archive-node-tag) :archive ,(car archive) :archive-location ,(cadr archive) :archive-defaultp ,(equal default-archive (car archive)))))) (widget-put (widget-get res :node) :parent res) res)) (let* ((l xetla-archive-tree)) (when (or (null l) current-prefix-arg) (xetla-archive-tree-build-archives nil t)) xetla-archive-tree))))) (defun xetla-widget-archive-node-value-create (widget) "Create values for WIDGET." (push widget xetla-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 (xetla-archive-type archive) (mirror (widget-put widget :face 'xetla-mirror-archive-name)) (source (widget-put widget :face 'xetla-source-archive-name))) ;; ;; It seems that XEmacs's format hides text properties. ;; (concat marks (xetla-widget-node-install-ui-element widget archive (when defaultp 'xetla-marked)) " => " (xetla-widget-archive-put-face-on-location location))))) value))) (defun xetla-widget-archive-put-face-on-location (location) "Set face to LOCATION based on the location type(ftp, sftp, http or local)." (let ((face (case (xetla-location-type location) (ftp 'xetla-location-ftp) (sftp 'xetla-location-sftp) (http 'xetla-location-http) (local 'xetla-location-local))) (location (copy-sequence location))) (put-text-property 0 (length location) 'face face location) location)) (defun xetla-widget-archive-node-refresh () "Refresh an archive node under the point." (interactive) (xetla-widget-node-refresh 1 nil (xetla-name-archive (xetla-widget-node-get-name)))) (defun xetla-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 xetla-widget-archive-node-default-tag (widget-get widget :tag)) (widget-put widget :tag xetla-widget-archive-node-tag) (widget-put widget :archive-defaultp nil) (widget-value-set widget (widget-value widget)))) xetla-widget-archive-node-list) (let* ((widget (xetla-widget-node-get-at)) (archive (xetla-name-archive (xetla-widget-node-get-name) ))) (xetla-my-default-archive archive) (widget-put widget :tag xetla-widget-archive-node-default-tag) (widget-put widget :archive-defaultp t) (widget-value-set widget (widget-value widget)))) (defun xetla-widget-archive-node-unregister-archive () "Delete the registration of the archive under the point." (interactive) (let ((archive (xetla-name-archive (xetla-widget-node-get-name)))) (if archive (progn (xetla-unregister-archive archive t) (xetla-widget-node-refresh 2)) (error "No archive under the point")))) (defun xetla-widget-archive-node-make-category () "Make new category in the archive under the point." (interactive) (let* ((name (xetla-widget-node-get-name)) (archive (xetla-name-archive name)) (l (xetla-name-read "New Category: " archive 'prompt))) (xetla-make-category (xetla-name-archive l) (xetla-name-category l)) (xetla-widget-node-refresh 1 nil (xetla-name-archive l)) (xetla-browse-open t (xetla-name-archive l) (xetla-name-category l)) )) (defun xetla-widget-archive-node-convert-to-source () "Convert the archive under the point to a source archive." (interactive) (let* ((widget (xetla-widget-node-get-at)) (archive (widget-get widget :archive)) (location (widget-get widget :archive-location)) (result (xetla-archive-convert-to-source-archive archive location))) (let ((archive-registered (nth 0 result)) (archive (nth 1 result)) (xetla-response (nth 3 result))) (when archive-registered (xetla-widget-node-refresh 2) (message xetla-response) (xetla-widget-archives-root-node-goto (if (string-match ".+: \\(.+\\)" xetla-response) (match-string 1 xetla-response) archive)) (xetla-flash-line))))) (defun xetla-widget-archive-node-start-project () "Start new project in the archive unde the point." (interactive) (let* ((archive (xetla-name-archive (xetla-widget-node-get-name))) (buffer (current-buffer)) (p (point)) (result (xetla-start-project archive 'synchronously)) (category (xetla-name-category (car result))) (branch (xetla-name-branch (car result))) (version (xetla-name-version (car result))) ) (with-current-buffer buffer (xetla-widget-node-refresh 1 p archive) (xetla-browse-open t archive category branch version)))) (defun xetla-widget-archive-node-make-mirror-at-remote () "Create a mirror for the local archive under the point at somewhere remote." (interactive) (let ((archive (xetla-name-archive (xetla-widget-node-get-name)))) (unless archive (error "No archive under the point")) (xetla-mirror-archive archive nil nil nil nil) (xetla-widget-node-refresh 2) (xetla-widget-archives-root-node-goto (format "%s-MIRROR" archive)) (xetla-flash-line))) (defun xetla-widget-archive-node-make-mirror-at-local () "Create a mirror for the remote archive under the point to local." (interactive) (let ((archive (xetla-name-archive (xetla-widget-node-get-name)))) (unless archive (error "No archive under the point")) (xetla-mirror-from-archive archive nil) (xetla-widget-node-refresh 2) (string-match "\\(.*\\)-SOURCE$" archive) (xetla-widget-archives-root-node-goto ;; Adding a space not to match SOURCE archive. (concat (match-string 1 archive) " ")) (xetla-flash-line))) ;; -------------------------------------- ;; Categories ;; -------------------------------------- (defvar xetla-widget-category-node-map (let ((map (copy-keymap xetla-widget-node-map))) (define-key map xetla-keyvec-refresh 'xetla-widget-category-node-refresh) (define-key map (xetla-prefix-add ?b) 'xetla-widget-category-node-make-branch) map) "Keymap used on xetla-widget-category-node.") (easy-menu-define xetla-widget-category-node-menu nil "Menu used on a archive item in `xetla-browse-mode' buffer." '("Category" ["Update Branches List" xetla-widget-category-node-refresh t] ["Remove Category[NOT IMPLEMENTED]" nil t] ["Make New Branch..." xetla-widget-category-node-make-branch t] ["Add a Bookmark" xetla-widget-node-add-bookmark t] ["Synchronize Mirror to Remote" xetla-widget-node-synchronize-mirror-to-remote t] ["Save Name to Kill Ring" xetla-widget-node-save-name-to-kill-ring t])) (define-widget 'xetla-widget-category-node 'xetla-widget-node "Category node in xetla-browse." :tag "c" :value-create 'xetla-widget-category-node-value-create :xetla-type 'category :face 'xetla-category-name :keymap 'xetla-widget-category-node-map :menu xetla-widget-category-node-menu :archive nil :category nil) (defun xetla-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 ,(xetla-browse-open-list-member archive-name (car category)) :has-children t :dynargs xetla-browse-expand-branches :node (xetla-widget-category-node :archive ,archive-name :category ,(car category))))) (widget-put (widget-get res :node) :parent res) res)) (let* ((l (cddr (xetla-archive-tree-get-archive archive-name)))) (when (or (null l) current-prefix-arg) (xetla-archive-tree-build-categories archive-name nil t)) (cddr (xetla-archive-tree-get-archive archive-name))))))) (defun xetla-widget-category-node-value-create (widget) "Create values for category WIDGET." (xetla-widget-node-value-create widget :category)) (defun xetla-widget-category-node-refresh () "Refresh a category widget at the point." (interactive) (let ((name (xetla-widget-node-get-name))) (xetla-widget-node-refresh 1 nil (xetla-name-archive name) (xetla-name-category name)))) (defun xetla-widget-category-node-make-branch () "Make new branch in the category under the point." (interactive) (let* ((name (xetla-widget-node-get-name)) (archive (xetla-name-archive name)) (category (xetla-name-category name)) (l (xetla-name-read "New Branch: " archive category 'prompt))) (xetla-make-branch (xetla-name-archive l) (xetla-name-category l) (xetla-name-branch l)) (xetla-widget-node-refresh 1 nil (xetla-name-archive l) (xetla-name-category l)) (xetla-browse-open t (xetla-name-archive l) (xetla-name-category l) (xetla-name-branch l)))) ;; -------------------------------------- ;; Branch ;; -------------------------------------- (defvar xetla-widget-branch-node-map (let ((map (copy-keymap xetla-widget-node-map))) (define-key map xetla-keyvec-refresh 'xetla-widget-branch-node-refresh) (define-key map (xetla-prefix-add ?v) 'xetla-widget-branch-node-make-version) (define-key map xetla-keyvec-get 'xetla-widget-branch-node-get-branch) map) "Keymap used on xetla-widget-branch-node.") (easy-menu-define xetla-widget-branch-node-menu nil "Menu used on a archive item in `xetla-browse-mode' buffer." '("Branch" ["Update Version List" xetla-widget-branch-node-refresh t] ["Remove Branch Registration[NOT IMPLEMENTED]" nil t] ["Make New Version..." xetla-widget-branch-node-make-version t] ["Get..." xetla-widget-branch-node-get-branch t] ["Add a Bookmark" xetla-widget-node-add-bookmark t] ["Synchronize Mirror to Remote" xetla-widget-node-synchronize-mirror-to-remote t] ["Save Name to Kill Ring" xetla-widget-node-save-name-to-kill-ring t])) (define-widget 'xetla-widget-branch-node 'xetla-widget-node "Branch node in xetla-browse." :tag "b" :value-create 'xetla-widget-branch-node-value-create :xetla-type 'branch :face 'xetla-branch-name :keymap 'xetla-widget-branch-node-map :menu xetla-widget-branch-node-menu :archive nil :category nil :branch nil) (defun xetla-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 ,(xetla-browse-open-list-member archive-name category-name (car branch)) :has-children t :leaf-control xetla-widget-version-control :dynargs xetla-browse-expand-versions :node (xetla-widget-branch-node :archive ,archive-name :category ,category-name :branch ,(car branch))))) (widget-put (widget-get res :node) :parent res) res)) (let* ((l (cdr (xetla-archive-tree-get-category archive-name category-name)))) (when (or (null l) current-prefix-arg) (xetla-archive-tree-build-branches archive-name category-name nil t)) (cdr (xetla-archive-tree-get-category archive-name category-name))))))) (defun xetla-widget-branch-node-value-create (widget) "Create values for branch WIDGET." (xetla-widget-node-value-create widget :branch)) (defun xetla-widget-branch-node-refresh () "Refresh a branch widget at the point." (interactive) (let ((name (xetla-widget-node-get-name))) (xetla-widget-node-refresh 1 nil (xetla-name-archive name) (xetla-name-category name) (xetla-name-branch name)))) (defun xetla-widget-branch-node-make-version () "Make new version in the branch under the point." (interactive) (let* ((name (xetla-widget-node-get-name)) (archive (xetla-name-archive name)) (category (xetla-name-category name)) (branch (xetla-name-category name)) (l (xetla-name-read "New Version: " archive category branch 'prompt))) (xetla-make-version (xetla-name-archive l) (xetla-name-category l) (xetla-name-branch l) (xetla-name-version l)) (xetla-widget-node-refresh 1 nil (xetla-name-archive l) (xetla-name-category l) (xetla-name-branch l)) (xetla-browse-open t (xetla-name-archive l) (xetla-name-category l) (xetla-name-branch l) (xetla-name-version l)))) (defun xetla-widget-branch-node-get-branch () "Run `tla get' against the branch at point." (interactive) (let* ((name (xetla-widget-node-get-name)) (archive (xetla-name-archive name)) (category (xetla-name-category name)) (branch (xetla-name-branch name)) (directory (expand-file-name (read-directory-name (format "Restore \"%s\" to: " (progn (unless branch (error "No branch under the point")) (xetla-name-construct archive category branch))))))) (if branch (xetla-get directory 'ask archive category branch) (error "No branch under the point")))) ;; -------------------------------------- ;; Version ;; -------------------------------------- (defvar xetla-widget-version-node-map (let ((map (copy-keymap xetla-widget-node-map))) (define-key map xetla-keyvec-refresh 'xetla-widget-version-node-show-revisions) (define-key map xetla-keyvec-get 'xetla-widget-version-node-get-version) (define-key map xetla-keyvec-tag 'xetla-widget-version-node-tag) map) "Keymap used on xetla-widget-version-node.") (easy-menu-define xetla-widget-version-node-menu nil "Menu used on a archive item in `xetla-browse-mode' buffer." '("Version" ["Show Revisions" xetla-widget-version-node-show-revisions t] ["Remove Version Registration[NOT IMPLEMENTED]" nil t] ["Get..." xetla-widget-version-node-get-version t] ["Add a Bookmark" xetla-widget-node-add-bookmark t] ["Synchronize Mirror to Remote" xetla-widget-node-synchronize-mirror-to-remote t] ["Put Tag..." xetla-widget-version-node-tag t] ["Save Name to Kill Ring" xetla-widget-node-save-name-to-kill-ring t])) (define-widget 'xetla-widget-version-node 'xetla-widget-node "Version node in xetla-browse." :tag "v" :value-create 'xetla-widget-version-node-value-create :xetla-type 'version :face 'xetla-version-name :keymap 'xetla-widget-version-node-map :menu xetla-widget-version-node-menu :archive nil :category nil :branch nil :version nil :open-subtree 'xetla-widget-version-node-open-subtree :close-subtree 'xetla-widget-version-node-open-subtree) (define-widget 'xetla-widget-version-control 'tree-widget-empty-control "Control widget that represents a leaf version node." :tag "[->]" :format "%[%t%]" :action 'xetla-widget-version-control-show-revisions) (defun xetla-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) (point-at-eol)))) (when pos (xetla-widget-version-node-show-revisions pos)))) (defun xetla-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) `(xetla-widget-version-node :archive ,archive-name :category ,category-name :branch ,branch-name :version ,(car version))) (let* ((l (cdr (xetla-archive-tree-get-branch archive-name category-name branch-name)))) (when (or (null l) current-prefix-arg) (xetla-archive-tree-build-versions archive-name category-name branch-name nil t)) (cdr (xetla-archive-tree-get-branch archive-name category-name branch-name))))))) (defun xetla-widget-version-node-value-create (widget) "Create values for version WIDGET." (xetla-widget-node-value-create widget :version)) (defun xetla-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 (xetla-widget-node-get-name (or point (point))))) (xetla-revisions (xetla-name-archive name) (xetla-name-category name) (xetla-name-branch name) (xetla-name-version name) nil nil))) (defun xetla-widget-version-node-get-version () "Run \"tla get\" against the version at point." (interactive) (let* ((name (xetla-widget-node-get-name)) (archive (xetla-name-archive name)) (category (xetla-name-category name)) (branch (xetla-name-branch name)) (version (xetla-name-version name)) (directory (expand-file-name (read-directory-name (format "Restore \"%s\" to: " (progn (unless version (error "No version under the point")) (xetla-name-construct archive category branch version))))))) (if version (xetla-get directory 'ask archive category branch version) (error "No version under the point")))) (defun xetla-widget-version-node-tag () "Run tla tag from the version under the point." (interactive) (let* ((from (xetla-widget-node-get-name)) (from-fq (xetla-name-construct from)) (to (xetla-name-read (format "Tag from `%s' to: " from-fq) 'prompt 'prompt 'prompt 'prompt)) (to-fq (xetla-name-construct to))) (unless from (error "No version under the point")) (unless to-fq (error "Wrong version tagged to is given")) (save-excursion (xetla-version-tag-internal from-fq to-fq 'synchronously)) (xetla-widget-node-refresh 1 nil (xetla-name-archive to-fq) (xetla-name-category to-fq) (xetla-name-branch to-fq)) (xetla-browse-open t (xetla-name-archive to-fq) (xetla-name-category to-fq) (xetla-name-branch to-fq) (xetla-name-version to-fq)))) (defun xetla-widget-version-node-open-subtree (widget) "List revisions in the version associated with WIDGET." (xetla-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 xetla-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 (xetla-get-buffer-create xetla-browse-buffer-type)) (make-local-variable 'xetla-browse-open-list) (setq truncate-lines t) (let (building) (if (zerop (buffer-size)) (progn (setq building t) (xetla-browse-set-initial-open-list initial-open-list t)) (if append (progn (setq building nil) (xetla-browse-set-initial-open-list initial-open-list nil)) (if (y-or-n-p (format "Remove old %s? " (buffer-name))) (progn (setq building t) (xetla-browse-set-initial-open-list initial-open-list nil)) (setq building nil) (xetla-browse-set-initial-open-list initial-open-list t)))) (if building (progn (xetla-browse-erase-buffer) (xetla-browse-build-buffer)) (mapc (lambda (elt) (xetla-browse-open nil (xetla-name-archive elt) (xetla-name-category elt) (xetla-name-branch elt) (xetla-name-version elt))) xetla-browse-open-list))) (goto-char (point-min)) (xetla-browse-mode)) (defun xetla-browse-set-initial-open-list (list clearp) "Insert LIST to `xetla-browse-open-list'. If CLEARP is set, clear `xetla-browse-open-list' before insertion. This is a helper function for `xetla-browse'." (when clearp (setq xetla-browse-open-list nil)) (mapc (lambda (elt) (xetla-browse-open-list-add (xetla-name-archive elt) (xetla-name-category elt) (xetla-name-branch elt) (xetla-name-version elt))) list)) (defun xetla-browse-erase-buffer () "Erase *xetla-browse* buffer." (let ((inhibit-read-only t)) (erase-buffer)) ;; remove-extent is not portable enough. (mapc #'delete-extent (mapcar-extents #'identity nil nil (point-min) (point-max) 'all-extents-closed-open))) (defun xetla-browse-build-buffer () "Insert contents of *xetla-buffer*." ;; Xetla config (widget-create 'tree-widget :open t :node '(item :format "%[%t%]\n" :tag "Personal Configuration") :has-chidren t `(xetla-widget-my-id ,(xetla-my-id))) (widget-insert "\n") ;; Archives (add-hook 'tree-widget-after-toggle-functions 'xetla-browse-open-tracker) (widget-create 'tree-widget :open t :node `(xetla-widget-root-node :xetla-type archives-root :tag "Archives" :keymap xetla-widget-archives-root-node-map :menu ,xetla-widget-archives-root-node-menu) :has-children t :dynargs 'xetla-browse-expand-archives) ;; Libraries ;; TODO (widget-setup)) (defun xetla-browse-toggle-subtree-maybe () "Run `xetla-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 (point-at-bol) 'widget nil (point-at-eol)))) (if (and p (xetla-widget-node-get-type p)) (xetla-widget-node-toggle-subtree p) (widget-button-press (point))))) (defun xetla-browse-dash () "Move the point to the place where a widget is in the current line." (interactive) (let ((p (next-single-property-change (point-at-bol) 'widget nil (point-at-eol)))) (when (and p (xetla-widget-node-get-type p)) (goto-char p) (xetla-flash-line)))) (defvar xetla-browse-map (let ((map (copy-keymap widget-keymap))) (define-key map xetla-keyvec-help 'describe-mode) (define-key map (xetla-prefix-buffer ?p) 'xetla-show-process-buffer) (define-key map (xetla-prefix-buffer ?L) 'xetla-open-internal-log-buffer) (define-key map (xetla-prefix-buffer xetla-key-show-bookmark) 'xetla-bookmarks) (define-key map [return] 'xetla-browse-toggle-subtree-maybe) (define-key map "\C-m" 'xetla-browse-toggle-subtree-maybe) (define-key map " " 'xetla-browse-dash) (define-key map xetla-keyvec-next 'next-line) (define-key map xetla-keyvec-previous 'previous-line) (define-key map xetla-keyvec-quit 'kill-this-buffer) (define-key map [?+] 'xetla-widget-node-toggle-subtree-recursive) map) "Keymap used in `xetla-browse-mode'.") (defun xetla-browse-mode () "Mode for browsing xetla's archives. Don't use this function. Instead call `xetla-browse'." (setq major-mode 'xetla-browse-mode mode-name "xetla-browse") (use-local-map xetla-browse-map) (set-buffer-modified-p nil) (run-hooks 'xetla-browse-mode-hook)) (provide 'xetla-browse) ;;; xetla-browse.el ends here 1.1 XEmacs/packages/xemacs-packages/xetla/xetla-core.el Index: xetla-core.el =================================================================== ;;; xetla-core.el --- Core of xetla ;; Copyright (C) 2003-2004 by Stefan Reichoer (GPL) ;; Copyright (C) 2004 Steve Youngs (BSD) ;; Author: Steve Youngs <steve(a)eicq.org&gt; ;; Maintainer: Steve Youngs <steve(a)eicq.org&gt; ;; Created: 2004-11-25 ;; Keywords: arch archive tla ;; Based on xtla-core.el by: Stefan Reichoer, <stefan(a)xsteve.at&gt; ;; This file is part of XEtla. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; ;; 3. Neither the name of the author nor the names of any contributors ;; may be used to endorse or promote products derived from this ;; software without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR ;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE ;; DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE ;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF ;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR ;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN ;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; Commentary: ;; Contributions from: ;; Matthieu Moy <Matthieu.Moy(a)imag.fr&gt; ;; Masatake YAMATO <jet(a)gyve.org&gt; ;; Milan Zamazal <pdm(a)zamazal.org&gt; ;; Martin Pool <mbp(a)sourcefrog.net&gt; ;; Robert Widhopf-Fenk <hack(a)robf.de&gt; ;; Mark Triggs <mst(a)dishevelled.net&gt; ;; This file provides the low-level functions used by xetla.el ;;; Code: (require 'xetla-defs) (require 'ewoc) ;; -------------------------------------- ;; Compatibility stuff ;; -------------------------------------- (eval-when-compile (require 'cl) (autoload 'read-passwd "passwd")) (require 'pp) (defvar xetla-buffer-type-alist '((changes "*xetla-changes*" root) (inventory "*xetla-inventory*" path) (missing "*xetla-missing*" single) (cat-log "*xetla-cat-log(%s)*" string) (file-diff "*xetla-file-diff*" path) (changelog "*xetla-changelog*" root) (tree-lint "*xetla-tree-lint*" root) (logs "*xetla-logs*" root) (errors "*xetla-error*" multiple) (generic "*xetla-process*" multiple) (browse "*xetla-browse*" single) (changeset "*xetla-changeset(%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 `xetla-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. For 'root and 'path, `xetla-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).") (defvar xetla-buffers-tree nil "Tree containing all xetla buffers. Must be of the form ((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\"))) Used to keep track of all the xetla related buffers.") (defun xetla-buffers-tree-remove (buffer) "Remove BUFFER from the buffers tree." (dolist (type-cons xetla-buffers-tree) (dolist (path-buffer (cdr type-cons)) (when (eq (cadr path-buffer) buffer) (setcdr type-cons (delete path-buffer (cdr type-cons))))))) (defun xetla-buffers-tree-add (type path buffer) "Add a buffer of TYPE visiting PATH to the buffers tree. BUFFER should be the buffer to add." (let ((current-assoc (assoc type xetla-buffers-tree))) (if current-assoc (setcdr current-assoc (cons (list path buffer (buffer-name buffer)) (cdr current-assoc))) (setq xetla-buffers-tree (cons `(,type (,path ,buffer ,(buffer-name buffer))) xetla-buffers-tree))))) (defvar xetla-temp-directory (temp-directory) "Temporary directory for some xetla operations.") (defun xetla-make-temp-name (file) "Generate a temporary file name based on FILE. The path for the file name can be set via `xetla-temp-directory'." (make-temp-name (concat (xetla-uniquify-file-name xetla-temp-directory) file))) (defun xetla-uniquify-file-name (path) "Return a unique string designating PATH. If PATH is a directory,the returned contains one and exactly one trailing slash. If PATH is nil, then nil is returned." (and path (let ((expanded (expand-file-name (if (file-directory-p path) (file-name-as-directory path) path)))) (if (featurep 'xemacs) (replace-regexp-in-string "/+$" "/" expanded) expanded)))) (defun xetla-config-file-full-path (file &optional create-config-dir) "Return the full path for the config file FILE. FILE will be stored in the `xetla-config-directory'. If CREATE-CONFIG-DIR is non nil, ensure that the `xetla-config-directory' does exist." (let ((full-name (xetla-uniquify-file-name (concat xetla-config-directory file)))) (unless (file-exists-p xetla-config-directory) (when create-config-dir (make-directory xetla-config-directory t) (message "The config files of Xetla will be stored in %s!" xetla-config-directory) (sit-for 5))) ;; TODO remove migration code as some time in the future (unless (file-exists-p (expand-file-name xetla-bookmarks-file-name xetla-config-directory)) (let ((old-ones (list (list (expand-file-name xetla-bookmarks-file-name xetla-config-directory) "~/.xetla-bookmarks.el" "~/.xetla/.xetla-bookmarks.el"))) o olds n) (while old-ones (setq olds (car old-ones) old-ones (cdr old-ones)) (if olds (setq n (car olds) olds (cdr olds))) (while olds (setq o (expand-file-name (car olds)) olds (cdr olds)) (if (file-exists-p o) (if (yes-or-no-p (format "Migrate %s to %s? " o n)) (rename-file o n) (if (yes-or-no-p (format "Delete %s? " o)) (delete-file o)))))))) ;; return full-name full-name)) (defun xetla-stringise (uberstring &rest args) "Create a string from UBERSTRING. I.e. you can pass - a string which evals to itself - a variable whose value is a string - a function which is called and should eval to a string - a form which is evaluated and should return a string. All results are run against `xetla-stringise' again until finally a string is produced." (cond ((stringp uberstring) uberstring) ((and (symbolp uberstring) (boundp uberstring)) (xetla-stringise (symbol-value uberstring))) ((and (symbolp uberstring) (fboundp uberstring)) (xetla-stringise (apply uberstring args))) ((ignore-errors (xetla-stringise (eval uberstring)))) ((ignore-errors (xetla-stringise (eval (cons 'progn uberstring))))) (t nil))) ;; this is useful since i can now have something like: ;; ;; (set-alist 'xetla-buffer-type-alist ;; 'inventory ;; '((format "*xetla-inventory%s*" ;; (let ((dir (replace-regexp-in-string ;; "^.+/\\([^/]+\\).?$" ;; "\\1" ;; (expand-file-name path)))) ;; (if dir (format " (%s)" dir) ;; ""))))) ;; ;; to always have the path in the buffer name of the inventory (defun xetla-get-buffer-type (type) "Get entry in `xetla-buffer-type-alist' for given TYPE." (assoc type xetla-buffer-type-alist)) (defun xetla-get-buffer-name (type) "Get name part of `xetla-buffer-type-alist' for given TYPE." (let ((name (cadr (xetla-get-buffer-type type)))) (xetla-stringise name))) (defun xetla-get-buffer-mode (type) "Get name part of `xetla-buffer-type-alist' for given TYPE." (let ((mode (caddr (xetla-get-buffer-type type)))) mode)) (eval-when-compile (autoload 'xetla-tree-root "xetla")) (defun xetla-get-buffer-create (type &optional path) "Get a buffer of type TYPE for the path PATH. Maybe reuse one if it exists, according to the value of `xetla-buffer-type-alist' (see its docstring), or, call `create-file-buffer' to create the buffer. See also `xetla-get-buffer'" ;; Inspired from `cvs-get-buffer-create' (let* ((path (or path default-directory)) (elem (assoc type xetla-buffer-type-alist)) (mode (caddr elem))) (or (xetla-get-buffer type path mode) ;; Buffer couldn't be reused. Create one (let ((path (case mode (root (xetla-uniquify-file-name (xetla-tree-root path))) (string path) (t (xetla-uniquify-file-name path)))) (name (xetla-get-buffer-name type))) (let ((buffer (if (eq mode 'string) (get-buffer-create (format name path)) (let ((default-directory (or path default-directory))) (create-file-buffer (or name "*xetla-buffer*")))))) (with-current-buffer buffer (xetla-buffers-tree-add type path buffer) buffer)))))) (add-hook 'kill-buffer-hook 'xetla-kill-buffer-function) (defun xetla-kill-buffer-function () "Function run when a buffer is killed." (xetla-buffers-tree-remove (current-buffer)) (xetla-kill-process-maybe (current-buffer))) (defun xetla-get-buffer (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 `xetla-buffer-type-alist' 's third element), otherwise, return nil. See also `xetla-get-buffer-create'." (let ((mode (or mode (xetla-get-buffer-mode type))) (path (or path default-directory))) (if (eq mode 'single) ;; nothing to do about PATH. Reuse anyway (let* ((list-path (cdr (assoc type xetla-buffers-tree))) (first-elem (car list-path))) (if list-path (if (string= (buffer-name (cadr first-elem)) (caddr first-elem)) (cadr first-elem) (setcdr (assoc type xetla-buffers-tree) nil) nil) nil)) (let ((path (and path (case mode (root (xetla-uniquify-file-name (xetla-tree-root path))) (string path) (t (xetla-uniquify-file-name path)))))) (if (eq mode 'multiple) ;; no need to search an existing buffer nil (let* ((list-path (assoc type xetla-buffers-tree)) (elem (assoc path (cdr list-path))) (buffer (cadr elem))) (when buffer (if (and (buffer-live-p buffer) ;; the buffer has not been renamed (string= (buffer-name buffer) (caddr elem))) buffer ;; remove the buffer and try again (setcdr list-path (delq (assoc path (cdr list-path)) (cdr list-path))) (xetla-get-buffer type path mode))))))))) (defun xetla-add-buffer-type (type name) "Define a new TYPE of buffer whose buffer will be named NAME." (unless (assoc type xetla-buffer-type-alist) (push (list type name) xetla-buffer-type-alist))) (defun xetla-position (item seq) "Position of ITEM in list, or nil if not found. Return 0 if ITEM is the first element of SEQ" (let ((pos 0) (seq-int seq)) (while (and seq-int (not (eq (car seq-int) item))) (setq seq-int (cdr seq-int)) (setq pos (1+ pos))) (when seq-int pos))) (defun xetla-last-visited-inventory-buffer () "Return the last visited xetla's inventory buffer." (let ((inventories (remove nil (mapcar (lambda (elt) (when (buffer-live-p (cadr elt)) elt)) (cdr (assoc 'inventory xetla-buffers-tree))))) (bl (buffer-list))) (cadr (car (sort inventories (lambda (a b) (let ((aindex (xetla-position (cadr a) bl)) (bindex (xetla-position (cadr b) bl))) (< aindex bindex)))))))) (defun xetla-show-inventory-buffer () "Switch to the last visited inventory buffer." (interactive) (xetla-switch-to-buffer (xetla-last-visited-inventory-buffer))) ;; -------------------------------------- ;; Process buffers ;; -------------------------------------- (defcustom xetla-process-buffer " *xetla-process*" "*Name of the process buffer." :type 'string :group 'xetla-internal) (defcustom xetla-error-buffer " *xetla-errors*" "*Name of the buffer to which xetla's stderr is redirected." :type 'string :group 'xetla-internal) (defcustom xetla-number-of-dead-process-buffer 20 "*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 'xetla-internal) (defcustom xetla-show-internal-buffers-on-menu nil "Toggle display of dead process buffers in the buffer menu." :type 'boolean :group 'xetla-internal) (defvar xetla-dead-process-buffer-queue nil "List of process buffers belonging to terminated processes. When the list is greater than `xetla-number-of-dead-process-buffer', the last ones are killed.") (defun xetla-kill-process-buffer (buffer) "Don't actually kill BUFFER, but add it to `xetla-dead-process-buffer-queue'. It will eventually be killed when the number of buffers in `xetla-dead-process-buffer-queue'exceeds `xetla-number-of-dead-process-buffer'." (add-to-list 'xetla-dead-process-buffer-queue buffer t) (when xetla-number-of-dead-process-buffer (while (> (length xetla-dead-process-buffer-queue) (max 2 xetla-number-of-dead-process-buffer)) (kill-buffer (car xetla-dead-process-buffer-queue)) (setq xetla-dead-process-buffer-queue (cdr xetla-dead-process-buffer-queue))))) (defvar xetla-last-process-buffer nil "The last created process buffer.") (defvar xetla-last-error-buffer nil "The last created process buffer.") (defun xetla-new-process-buffer (to-be-deleted) "Create a new process buffer. If TO-BE-DELETED is non-nil, make this buffer a candidate for eventually being deleted." (let ((buffer (create-file-buffer xetla-process-buffer))) (setq xetla-last-process-buffer buffer) (when to-be-deleted (xetla-kill-process-buffer buffer)) buffer)) (defun xetla-new-error-buffer (to-be-deleted) "Create a new error buffer. If TO-BE-DELETED is non-nil, make this buffer a candidate for eventually being deleted." (let ((buffer (create-file-buffer xetla-error-buffer))) (setq xetla-last-error-buffer buffer) (when to-be-deleted (xetla-kill-process-buffer buffer)) buffer)) ;; -------------------------------------- ;; Process management ;; -------------------------------------- ;; Candidates for process handlers (defun xetla-default-error-function (output error status arguments) "Default function called when a xetla 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) (xetla-show-error-buffer error) (if (> (with-current-buffer output (point-max)) 1) (xetla-show-error-buffer output) (error "`tla %s' failed with code %d and no output!" (mapconcat 'identity arguments " ") status))) (error "`tla %s' failed with code %d" (mapconcat 'identity arguments " ") status)) (defvar xetla-default-killed-function-noerror 0 "The number of killed processes we will ignore until throwing an error. If the value is 0, `xetla-default-killed-function' will throw an error. See `xetla-default-killed-function'.") (defun xetla-default-killed-function (output error status arguments) "Default function called when a xetla 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 (> xetla-default-killed-function-noerror 0) (setq xetla-default-killed-function-noerror (- xetla-default-killed-function-noerror 1)) (xetla-switch-to-buffer error) (error "`tla %s' process killed !" (mapconcat 'identity arguments " ")))) (defun xetla-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 `xetla-run-tla-sync' or `xetla-run-tla-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 xetla-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 `xetla-run-tla-sync' or `xetla-run-tla-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-int (match-string 1))) (t (error status)))) (defun xetla-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." (xetla-buffer-content output)) (defun xetla-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 (xetla-buffer-content output) "\n")) (defun xetla-default-finish-function (output error status arguments) "Default function called when a xetla 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." (with-current-buffer output (xetla-process-buffer-mode)) (xetla-switch-to-buffer output) (message "`tla %s' process finished !" (mapconcat 'identity arguments " ")) status) (defun xetla-finish-function-without-buffer-switch (output error status arguments) "Similar to `xetla-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." (message "`tla %s' process finished !" (mapconcat 'identity arguments " ")) status) (defvar xetla-log-cookie nil) (defstruct (xetla-event) output-buffer error-buffer related-buffer command tree event time) (defun xetla-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)) (defsubst xetla-log-printer-print-buffer (buffer function) "Helper function for `xetla-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." (xetla-face-add (or (buffer-name buffer) (pp-to-string buffer)) 'xetla-buffer (when (buffer-live-p buffer) (let ((map (make-sparse-keymap))) (define-key map [button2] function) map)) nil "Show the buffer")) (defun xetla-log-printer (elem) "XEtla event printer which prints ELEM." (let ((event (xetla-event-event elem)) (p (point))) (insert "Command: " (xetla-event-command elem) "\nDirectory: " (xetla-face-add (xetla-event-tree elem) 'xetla-local-directory) "\nDate: " (format-time-string "%c" (xetla-event-time elem)) "\nRelated Buffer: " (xetla-log-printer-print-buffer (xetla-event-related-buffer elem) 'xetla-switch-to-related-buffer-by-mouse) "\nOutput Buffer: " (xetla-log-printer-print-buffer (xetla-event-output-buffer elem) 'xetla-switch-to-output-buffer-by-mouse) "\nError Buffer: " (xetla-log-printer-print-buffer (xetla-event-error-buffer elem) 'xetla-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 (xetla-event-tree (ewoc-data (ewoc-locate xetla-log-cookie)))))) )) (defvar xetla-process-running nil "List of xetla 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.") (defmacro xetla-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 `xetla-event'structure." `(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 xetla-log-cookie))))) (cond ((buffer-live-p buffer) (xetla-switch-to-buffer buffer) (unless (member buffer (mapcar (lambda (p) (process-buffer (car p))) xetla-process-running)) (xetla-process-buffer-mode))) (t (error "Buffer has been killed")))))) (xetla-switch-to-buffer-macro xetla-switch-to-output-buffer xetla-event-output-buffer) (xetla-switch-to-buffer-macro xetla-switch-to-error-buffer xetla-event-error-buffer) (xetla-switch-to-buffer-macro xetla-switch-to-related-buffer xetla-event-related-buffer) (defmacro xetla-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." `(defun ,(intern (concat (symbol-name function) "-by-mouse")) (event) ,(concat "`" (symbol-name function) "'" " with mouse interface.") (interactive "e") (mouse-set-point event) (,function))) (xetla-make-bymouse-function xetla-switch-to-output-buffer) (xetla-make-bymouse-function xetla-switch-to-error-buffer) (xetla-make-bymouse-function xetla-switch-to-related-buffer) (defun xetla-log-event (output error command tree event) "Log an event in the `xetla-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 xetla-log-cookie (buffer-live-p (ewoc-buffer xetla-log-cookie))) (with-current-buffer (get-buffer-create xetla-log-buffer) (setq xetla-log-cookie (ewoc-create 'xetla-log-printer)) (xetla-log-buffer-mode))) (let ((related-buffer (current-buffer))) (with-current-buffer (ewoc-buffer xetla-log-cookie) (let ((elem (make-xetla-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 xetla-log-cookie elem) (ewoc-refresh xetla-log-cookie) elem)))) (defun xetla-log-next () "Move to the next log entry." (interactive) (let ((next (ewoc-next xetla-log-cookie (ewoc-locate xetla-log-cookie)))) (when next (goto-char (ewoc-location next))))) (defun xetla-log-prev () "Move to the previous log entry." (interactive) (let ((prev (ewoc-prev xetla-log-cookie (ewoc-locate xetla-log-cookie)))) (when prev (goto-char (ewoc-location prev))))) (define-derived-mode xetla-log-buffer-mode fundamental-mode "XEtla Log" "Major mode for Xetla's internal log buffer. You can open this buffer with `xetla-open-internal-log-buffer'." (toggle-read-only 1)) (define-derived-mode xetla-process-buffer-mode fundamental-mode "Xetla Process" "Major mode for process buffers. Mainly defines \\[bury-buffer] to quit the buffer" (toggle-read-only 1)) (defmacro xetla-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." (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)))) (put 'xetla-with-keywords 'lisp-indent-function 1) (defun xetla-build-xetla-command (list-args) "Build a shell command to run tla with args LIST-ARGS." (mapconcat 'shell-quote-argument (cons xetla-tla-executable (delq nil list-args)) " ")) (defcustom xetla-password-prompt-regexp "[Pp]ass\\(word\\|phrase\\).*:\\s *\\'" "*Regexp matching prompts for passwords in the inferior process. This is used by `eshell-watch-for-password-prompt'." :type 'regexp :group 'xetla) (defun xetla-process-filter (proc string) "Filter PROC's STRING. Prompt for password with `read-passwd' if the output of PROC matches `xetla-password-prompt-regexp'." (with-current-buffer (process-buffer proc) (insert (replace-regexp-in-string "\015" "\n" string)) (when (string-match xetla-password-prompt-regexp string) (string-match "^\\([^\n]+\\)\n*\\'" string) (let ((passwd (read-passwd (match-string 1 string)))) (process-send-string proc (concat passwd "\n")))))) (defun xetla-run-tla-async (arguments &rest keys) "Run tla asynchronously. 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, `xetla-default-finish-function' is run. :killed ......... Function run when the process is killed. If none specified, `xetla-default-killed-function' is run. :error .......... Function run when the process exits with a non 0 status. If none specified, `xetla-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\") `xetla-null-handler' can be used here if there's nothing to do. :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 `xetla-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. Example: (xetla-run-tla-async `(\"changes\" ,(unless arg \"-diffs\")) :finished (lambda (output error status arguments) (message \"No changes in this working copy\")) :error (lambda (output error status arguments) (xetla-show-changes-buffer output)))" (xetla-with-keywords (:finished :killed :error :output-buffer :error-buffer :related-buffer) keys (let* ((output-buf (or (and output-buffer (get-buffer-create output-buffer)) (xetla-new-process-buffer nil))) (error-buf (or (and error-buffer (get-buffer-create error-buffer)) (xetla-new-error-buffer nil))) (error-file (xetla-make-temp-name "arch-errors")) (command (xetla-build-xetla-command arguments)) ;; Make the `default-directory' unique. The trailing slash ;; may be necessary in some cases. (default-directory (xetla-uniquify-file-name default-directory)) (process (start-process xetla-tla-executable output-buf "sh" "-c" (format "%s 2> %s" command error-file))) (process-event (list process (xetla-log-event output-buf error-buf command default-directory "started")))) (with-current-buffer (or related-buffer (current-buffer)) (message "running process `%s' in `%s'" command default-directory) (add-to-list 'xetla-process-running process-event) (set-process-filter process 'xetla-process-filter) (set-process-sentinel process `(lambda (process event) (let ((default-directory ,default-directory)) (xetla-log-event ,output-buf ,error-buf ,command ,default-directory (xetla-strip-final-newline event)) (setq xetla-process-running (delq ',process-event xetla-process-running)) (when (file-exists-p ,error-file) (with-current-buffer ,error-buf (insert-file-contents ,error-file)) (delete-file ,error-file)) (let ((state (process-status process)) (status (process-exit-status process))) (unwind-protect (cond ((and (eq state 'exit) (= status 0)) (funcall (or (quote ,finished) 'xetla-default-finish-function) ,output-buf ,error-buf status (quote ,arguments))) ((eq state 'signal) (funcall (or (quote ,killed) 'xetla-default-killed-function) ,output-buf ,error-buf status (quote ,arguments))) ((eq state 'exit) ;; status != 0 (funcall (or (quote ,error) 'xetla-default-error-function) ,output-buf ,error-buf status (quote ,arguments))))) ;; Schedule any buffers we created for killing (unless ,output-buffer (xetla-kill-process-buffer ,output-buf)) (unless ,error-buffer (xetla-kill-process-buffer ,error-buf)))))) process)))) (defun xetla-run-tla-sync (arguments &rest keys) "Run tla synchronously. See `xetla-run-tla-async' for details on possible ARGUMENTS and KEYS." (xetla-with-keywords (:finished :killed :error :output-buffer :error-buffer :related-buffer) keys (let ((output-buf (or (and output-buffer (get-buffer-create output-buffer)) (xetla-new-process-buffer t))) (error-buf (or (and error-buffer (get-buffer-create error-buffer)) (xetla-new-error-buffer t))) (command (xetla-build-xetla-command arguments)) (error-file (xetla-make-temp-name "arch-errors")) ;; Make the `default-directory' unique. The trailing slash ;; may be necessary in some cases. (default-directory (xetla-uniquify-file-name default-directory))) (with-current-buffer (or related-buffer (current-buffer)) (xetla-log-event output-buf error-buf command default-directory "started") (let ((status (call-process "sh" 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 (cond ((stringp status) (when (string= status "Terminated") (funcall (or killed 'xetla-default-killed-function) output-buf error-buf status arguments))) ((numberp status) (if (zerop status) (funcall (or finished 'xetla-default-finish-function) output-buf error-buf status arguments) (funcall (or error 'xetla-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 (xetla-kill-process-buffer output-buf)) (unless error-buffer (xetla-kill-process-buffer error-buf)))))))) (defun xetla-kill-process-maybe (buffer) "Prompts and possibly kill process whose related buffer is BUFFER." (let ((process-list nil)) (dolist (process-buffer xetla-process-running) (when (eq (xetla-event-related-buffer (cadr process-buffer)) buffer) (add-to-list 'process-list (car process-buffer)))) (let ((l (length process-list))) (when (and process-list (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) "Them" "it")))) (dolist (process process-list) (setq xetla-default-killed-function-noerror (1+ xetla-default-killed-function-noerror)) (if (eq (process-status process) 'run) (kill-process process))))))) ;;;###autoload (add-to-list 'minor-mode-alist '(xetla-process-running (:eval (if (equal (length xetla-process-running) 1) " tla running" (concat " tla running(" (int-to-string (length xetla-process-running)) ")"))))) (eval-when-compile (autoload 'xetla-flash-line "xetla")) (defun xetla-open-internal-log-buffer () "Switch to the XEtla's internal log buffer. This buffer contains a list of all the tla commands previously executed. The buffer uses the mode `xetla-log-buffer-mode'" (interactive) (let ((buffer-name (buffer-name))) (xetla-switch-to-buffer xetla-log-buffer) (goto-char (point-max)) (when (re-search-backward (concat " Buffer: " (regexp-quote buffer-name) "$") nil t) (xetla-flash-line)))) (defun xetla-clear-log-buffer () "Kill the log buffer." (when (bufferp (get-buffer xetla-log-buffer)) (kill-buffer xetla-log-buffer))) (defun xetla-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)))))) (defun xetla-get-process-output () "Return the content of the last process buffer. Strips the final newline if there is one." (xetla-buffer-content xetla-last-process-buffer)) (defun xetla-get-error-output () "Return the content of the last error buffer. Strips the final newline if there is one." (xetla-buffer-content xetla-last-error-buffer)) (defvar xetla-switched-buffer nil) (defvar xetla-switched-from-buffer nil) (defun xetla-switch-to-buffer (buffer) "Switch to BUFFER using the user's preferred method. See `xetla-switch-to-buffer-mode' for possible settings." (setq xetla-switched-from-buffer (current-buffer)) (cond ((eq xetla-switch-to-buffer-mode 'pop-to-buffer) (pop-to-buffer buffer)) ((eq xetla-switch-to-buffer-mode 'single-window) (switch-to-buffer buffer)) ((eq xetla-switch-to-buffer-mode 'show-in-other-window) (pop-to-buffer buffer) (setq xetla-switched-buffer (current-buffer)) (pop-to-buffer xetla-switched-from-buffer)) ;; TODO : dedicated frame. (t (error "Switch mode %s not implemented" xetla-switch-to-buffer-mode)))) (defun xetla-post-switch-to-buffer () "Executed when showing a changeset. If `xetla-switched-buffer' is non-nil, show this buffer, but keep cursor position in previous buffer." (when xetla-switched-buffer (pop-to-buffer xetla-switched-buffer) (setq xetla-switched-buffer nil) (goto-char (point-min)) (pop-to-buffer xetla-switched-from-buffer))) (defun xetla-show-process-buffer () "Show the process buffer of the last started xetla command." (interactive) (xetla-switch-to-buffer xetla-last-process-buffer) (unless (member xetla-last-process-buffer (mapcar (lambda (p) (process-buffer (car p))) xetla-process-running)) (xetla-process-buffer-mode))) (defun xetla-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 `xetla-get-buffer-create'." (when (buffer-live-p xetla-last-process-buffer) (let ((content (with-current-buffer xetla-last-process-buffer (buffer-string)))) (xetla-switch-to-buffer (xetla-get-buffer-create (or type 'generic) path)) (let ((inhibit-read-only t)) (erase-buffer) (insert content))) (if mode (funcall mode) (xetla-process-buffer-mode)))) (defun xetla-show-error-buffer (buffer &optional type mode) "Pops up the error buffer. Works like `xetla-show-last-process-buffer', but displays BUFFER, of type 'errors if TYPE is not specified. If MODE is specified, the buffer will use that mode." (when (buffer-live-p buffer) (let ((content (with-current-buffer buffer (buffer-string)))) (xetla-switch-to-buffer (xetla-get-buffer-create (or type 'errors))) (let ((inhibit-read-only t)) (erase-buffer) (insert content))) (if mode (funcall mode) (xetla-process-buffer-mode)))) ;; -------------------------------------- ;; Arch name manipulators ;; ====================== ;; ;; Normally in XEtla, 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. ;; ;; * xetla-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". ;; `xetla-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". ;; `xetla-name-split' expects a name string including archive. ;; ;; * xetla-name-construct-* is for converting from a list ;; representation to a string representation. The functions accept ;; arguments two ways. ;; ;; - normal passing: (xetla-name-construct "archive" "category"...) ;; - packed passing: (xetla-name-construct '("archive" "category"...)) ;; ;; There are semi-qualified version and fully-qualified version. ;; - semi-qualified: `xetla-name-construct-semi-qualified' connects ;; arguments with "-". ;; - fully-qualified: `xetla-name-construct" connects the first argument ;; and the rest with "/". About the rest, ;; `xetla-name-construct-semi-qualified' is applied. ;; ;; * xetla-name-{archive|category|branch|version|revision} is for ;; extracting a component from a name. The both representations are ;; acceptable. ;; ;; * xetla-name-mask is for replace a component in the name list with nil. ;; ;; -------------------------------------- ;; ;; String representation -> List representation ;; (defun xetla-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> (xetla-name-split-semi-qualified \"branch--category--version--revision\" \"archive\") (\"archive\" \"branch\" \"category\" \"version\" \"revision\") ELISP> (xetla-name-split-semi-qualified \"branch--category--version--revision\") (nil \"branch\" \"category\" \"version\" \"revision\") ELISP> (xetla-name-split-semi-qualified \"branch--category--version\") (nil \"branch\" \"category\" \"version\" nil) ELISP> (xetla-name-split-semi-qualified \"branch--category--version\" \"archive\") (\"archive\" \"branch\" \"category\" \"version\" nil) ELISP> (xetla-name-split-semi-qualified \"branch--category\" \"archive\") (\"archive\" \"branch\" \"category\" nil nil) ELISP> (xetla-name-split-semi-qualified \"branch--category\"nil) (nil \"branch\" \"category\" nil nil) ELISP> (xetla-name-split-semi-qualified \"branch--category--\" nil) (nil \"branch\" \"category\" \"\" nil)" (let ((list (xetla-name-split-semi-qualified-internal name))) (while (> 4 (length list)) (setq list (cons nil list))) (let ((result (cons archive (nreverse list)))) (when (xetla-is-version-string (caddr result)) (setq result (list (car result) (cadr result) "" (caddr result) (cadddr result)))) result))) (defun xetla-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 xetla, but must verify \(xetla-is-version-string string) => string can't be a branch name." (and string (string-match "^[0-9\.]+$" string))) (defun xetla-name-split-semi-qualified-internal (name) "Helper function for `xetla-name-split-semi-qualified'. Splits a semi-qualified NAME." (if (string-match "^\\(.+\\)--\\(\\([^-]\\|-[^-]\\)*\\)" name) (cons (match-string 2 name) (xetla-name-split-semi-qualified-internal (match-string 1 name))) (cons name nil))) (defun xetla-name-split (name) "Parse a fully qualified revision NAME, but possibly incomplete. email(a)address.com--arch/cat--branch--ver -> (\&quot;email(a)address.com--arch\&quot; \"cat\" \"branch\" \"ver\" nil) email(a)address.com--arch/cat -> (\&quot;email(a)address.com--arch\&quot; \"cat\" nil nil nil) email(a)address.com--arch -> (\&quot;email(a)address.com-arch\&quot; nil nil nil nil)" (if (string-match "\\(.*\\)/\\(.*\\)" name) (xetla-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 xetla-name-construct-semi-qualified (&rest comp) "Concatenate COMP with \"-\". This function can accept strings or a list which contains strings. ELISP> (xetla-name-construct-semi-qualified \"a\" \"b\" \"c\") \"a--b--c\" ELISP> (xetla-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 xetla-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 (xetla-name-category archive) branch (xetla-name-branch archive) version (xetla-name-version archive) revision (xetla-name-revision archive) ;; archive must be last archive (xetla-name-archive archive))) (let ((semi (xetla-name-construct-semi-qualified category branch version revision))) (concat (and archive (not (string= archive "")) (concat archive (when category "/"))) semi))) ;; ;; Get a component from a list or string. ;; (defun xetla-name-archive (target) "Get archive component from TARGET. Both representation of TARGET, a string and a list is acceptable." (when (stringp target) (setq target (xetla-name-split target))) (car target)) (defun xetla-name-category (target) "Get category component from TARGET. Both representation of TARGET, a string and a list is acceptable." (when (stringp target) (setq target (xetla-name-split target))) (cadr target)) (defun xetla-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 (xetla-name-split target))) (caddr target)) (defun xetla-name-version (target) "Get version component from TARGET. Both representation of TARGET, a string and a list is acceptable." (when (stringp target) (setq target (xetla-name-split target))) (cadddr target)) (defun xetla-name-revision (target) "Get revision component from TARGET. Both representation of TARGET, a string and a list is acceptable." (when (stringp target) (setq target (xetla-name-split target))) (cadddr (cdr target))) ;; ;; Utilities ;; Mask a specified component in the name. ;; (defun xetla-name-mask (original do-construct-p &optional archive-mask category-mask branch-mask version-mask revision-mask) "Mask ORIGINAL, a xetla revision name by masks; and return the masked value. If DO-CONSTRUCT-P is given, the result is converted to a string by `xetla-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> (xetla-name-mask '(\"a\" \"c\" \"b\" \"v\" \"r\") nil t t t t nil) (\"a\" \"c\" \"b\" \"v\" nil) ELISP> (xetla-name-mask '(\"a\" \"c\" \"b\" \"v\" \"r\") nil t t t nil nil) (\"a\" \"c\" \"b\" nil nil) ELISP> (xetla-name-mask '(\"a\" \"c\" \"b\" \"v\" \"r\") t t t t nil nil) \"a/c-b\" ELISP> (xetla-name-mask '(\"a\" \"c\" \"b\" \"v\" \"r\") t nil nil nil nil t) \"r\" ELISP> (xetla-name-mask '(\"a\" \"c\" \"b\" \"v\" \"r\") t nil nil nil t t) \"v-r\" ELISP>" (when (consp original) (let ((masked (list (if archive-mask (if (stringp archive-mask) archive-mask (xetla-name-archive original))) (if category-mask (if (stringp category-mask) category-mask (xetla-name-category original))) (if branch-mask (if (stringp branch-mask) branch-mask (xetla-name-branch original))) (if version-mask (if (stringp version-mask) version-mask (xetla-name-version original))) (if revision-mask (if (stringp revision-mask) revision-mask (xetla-name-revision original)))))) (if do-construct-p (xetla-name-construct masked) masked)))) (defun xetla-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: \(xetla-name-match &#39;(\&quot;xsteve(a)nit.at-public\&quot; \"xetla\" \"main\" \"0.1\" \"patch-116\") '(nil \"xt.*\" \"main\" nil nil)) => t \(xetla-name-match &#39;(\&quot;xsteve(a)nit.at-public\&quot; \"xetla\" \"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 xetla-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 (cadar ml)) (message "match: %s, data: %s" match data) (setq result (when (xetla-name-match target match) data)) (setq ml (cdr ml))) result)) ;; TODO: Use xetla-archive-tree. (defun xetla-version-head (archive category branch version) "Return the newest revision for ARCHIVE/CATEGORY-BRANCH-VERSION." (xetla-run-tla-sync (list "revisions" (xetla-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) (point-at-eol)))))) ;; -------------------------------------- ;; Archive tree manipulators ;; -------------------------------------- (defvar xetla-archive-tree nil "Arch archive/category/branch/version/revision are stored in assoc list: ((\&quot;xsteve(a)nit.at-public\&quot; \"http://arch.xsteve.at/2004\") [...] (\&quot;mbp(a)sourcefrog.net-2004\&quot; \"http://sourcefrog.net/arch/mbp＠sourcefrog.net-2004\" (\"xetla\") (\"tilly\") [...] (\"dupes\" (\"mainline\" (\"0.1\"))) [...] (\"archzoom\")) (\&quot;mark(a)dishevelled.net-2003-mst\&quot; \"http://members.iinet.net.au/~mtriggs/arch/\") (\&quot;lord(a)emf.net-2004\&quot; \"http://regexps.srparish.net/{archives}/lord＠emf.net-2004\") [...] (\&quot;Matthieu.Moy(a)imag.fr-public\&quot; \"http://www-verimag.imag.fr/webdav/moy/public\" (\"xetla\" (\"main\" (\"0.1\" (\"patch-228\" \"Merged from Robert (patch8-9), Milan (patch21-22), Stefan (patch5-8)\" \"Matthieu Moy <Matthieu.Moy(a)imag.fr&gt;\&quot; \"2004-06-03 20:13:11 GMT\") (\"patch-227\" \"Fix default-directory in xetla-run-tla-sync, fix in xetla-changes-ediff\" \"Matthieu Moy <Matthieu.Moy(a)imag.fr&gt;\&quot; \"2004-06-03 15:26:15 GMT\") [...] (\"patch-1\" \"typo\" \"Matthieu Moy <Matthieu.Moy(a)imag.fr&gt;\&quot; \"2004-04-07 22:57:00 GMT\") (\"base-0\" \"tag of xsteve(a)nit.at-public/xetla-main-0.1-patch-5\&quot; \"Matthieu Moy <Matthieu.Moy(a)imag.fr&gt;\&quot; \"2004-04-07 22:52:39 GMT\"))))) [...] ) This list is initially empty, and is built/rebuilt on demand.") ;; Utilities (defun xetla-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 xetla-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 xetla-archive-tree-add-archive (archive location &optional old) "Add ARCHIVE at LOCATION 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 (xetla-archive-tree-get-archive archive) (let* ((a (xetla-archive-tree-get-archive archive)) (val (cdr a)) (oldlocation (car val)) (category (cdr val))) (setcdr a (cons (or location oldlocation) category))) (let ((oldinfo (xetla-archive-tree-get-archive archive old)) (newinfo (list archive location))) (when oldinfo (setcdr (cdr newinfo) (cddr oldinfo))) ;; list of versions. (setq xetla-archive-tree (cons newinfo xetla-archive-tree))))) (defun xetla-archive-tree-get-archive (archive &optional archive-tree) "Get the value of ARCHIVE from ARCHIVE-TREE. If ARCHIVE-TREE is not given, `xetla-archive-tree' is used." (assoc archive (or archive-tree xetla-archive-tree))) ;; Category (defun xetla-archive-tree-add-category (archive category) "Add a new category to ARCHIVE named CATEGORY." (xetla-archive-tree-add-archive archive nil) (xetla-archive-tree-setcddr (xetla-archive-tree-get-archive archive) category)) (defun xetla-archive-tree-get-category (archive category) "From ARCHIVE, get CATEGORY." (assoc category (cdr (cdr (xetla-archive-tree-get-archive archive))))) ;; Branch (defun xetla-archive-tree-add-branch (archive category branch) "Add a new branch to ARCHIVE's CATEGORY named BRANCH." (xetla-archive-tree-add-category archive category) (xetla-archive-tree-setcdr (xetla-archive-tree-get-category archive category) branch)) (defun xetla-archive-tree-get-branch (archive category branch) "Get a branch from ARCHIVE's CATEGORY named BRANCH." (assoc branch (cdr (xetla-archive-tree-get-category archive category)))) ;; Version (defun xetla-archive-tree-add-version (archive category branch version) "Add a new version to ARCHIVE CATEGORY BRANCH named VERSION." (xetla-archive-tree-add-branch archive category branch) (xetla-archive-tree-setcdr (xetla-archive-tree-get-branch archive category branch ) version)) (defun xetla-archive-tree-get-version (archive category branch version) "Get a version from ARCHIVE CATEGORY BRANCH named VERSION." (assoc version (cdr (xetla-archive-tree-get-branch archive category branch)))) ;; Revision (defun xetla-archive-tree-add-revision (archive category branch version revision &optional summary creator date) "Add a new revision to ARCHIVE CATEGORY BRANCH VERSION named REVISION." (xetla-archive-tree-add-version archive category branch version) (xetla-archive-tree-setcdr (xetla-archive-tree-get-version archive category branch version) revision (list summary creator date))) (defun xetla-archive-tree-get-revision (archive category branch version revision) "Get a revision from ARCHIVE CATEGORY BRANCH VERSION named REVISION." (assoc revision (cdr (xetla-archive-tree-get-version archive category branch version)))) ;; Archive tree builders (defun xetla-archive-tree-build (basename &optional use-cache ignore-error) "Generic version of xetla-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 (xetla-name-split basename))) (let ((archive (xetla-name-archive basename)) (category (xetla-name-category basename)) (branch (xetla-name-branch basename)) (version (xetla-name-version basename))) (cond (version (xetla-archive-tree-build-revisions archive category branch version use-cache ignore-error)) (branch (xetla-archive-tree-build-versions archive category branch use-cache ignore-error)) (category (xetla-archive-tree-build-branches archive category use-cache ignore-error)) (archive (xetla-archive-tree-build-categories archive use-cache ignore-error)) (t (xetla-archive-tree-build-archives use-cache ignore-error))))) (defun xetla-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 xetla-archive-tree)) (xetla-run-tla-sync '("archives") :finished 'xetla-null-handler :error (if ignore-error 'xetla-null-handler 'xetla-default-error-function)) (let ((old-archive-tree xetla-archive-tree)) (setq xetla-archive-tree nil) (save-excursion (let ((archive-name) (archive-location)) (set-buffer xetla-last-process-buffer) (goto-char (point-min)) (while (> (point-at-eol) (point-at-bol)) (setq archive-name (buffer-substring-no-properties (point-at-bol) (point-at-eol))) (beginning-of-line-text 2) (setq archive-location (buffer-substring-no-properties (point) (point-at-eol))) (forward-line 1) (xetla-archive-tree-add-archive archive-name archive-location old-archive-tree))))))) (defun xetla-archive-tree-build-categories (archive &optional use-cache ignore-error) "Build the list of categories for ARCHIVE in `xetla-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." (when (or (not use-cache) (not (cddr (xetla-archive-tree-get-archive archive)))) (let ((basename archive)) (message "building categories for `%s'..." basename) (xetla-run-tla-sync (list "categories" "-A" basename) :finished 'xetla-null-handler :error (if ignore-error 'xetla-null-handler 'xetla-default-error-function)) (message "building categories for `%s'...done" basename) (sit-for 0) (message nil)) (with-current-buffer xetla-last-process-buffer (let (category) (goto-char (point-min)) (while (> (point-at-eol) (point-at-bol)) (setq category (buffer-substring-no-properties (point-at-bol) (point-at-eol))) (forward-line 1) (xetla-archive-tree-add-category archive category) ))))) (defun xetla-archive-tree-build-branches (archive category &optional use-cache ignore-error) "Build the list of branches for ARCHIVE/CATEGORY in `xetla-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." (when (or (not use-cache) (not (cdr (xetla-archive-tree-get-category archive category)))) (let ((basename (xetla-name-construct archive category))) (message "building branches for `%s'..." basename) (xetla-run-tla-sync (list "branches" basename) :finished 'xetla-null-handler :error (if ignore-error 'xetla-null-handler 'xetla-default-error-function)) (message "building branches for `%s'...done" basename) (sit-for 0) (message nil)) (with-current-buffer xetla-last-process-buffer (let (branch) (goto-char (point-min)) (while (> (point-at-eol) (point-at-bol)) (setq branch (buffer-substring-no-properties (point-at-bol) (point-at-eol))) (xetla-archive-tree-add-branch archive category (if (looking-at ".*-") (xetla-name-branch (xetla-name-split-semi-qualified branch)) ;; unnamed branch "")) (forward-line 1)))))) (defun xetla-archive-tree-build-versions (archive category branch &optional use-cache ignore-error) "Build the version list in ARCHIVE/CATEGORY-BRANCH in `xetla-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." (when (or (not use-cache) (not (cdr (xetla-archive-tree-get-branch archive category branch)))) (let ((basename (xetla-name-construct archive category branch))) (message "building versions for `%s'..." basename) (xetla-run-tla-sync (list "versions" basename) :finished 'xetla-null-handler :error (if ignore-error 'xetla-null-handler 'xetla-default-error-function)) (message "building versions for `%s'...done" basename) (sit-for 0) (message nil)) (with-current-buffer xetla-last-process-buffer (let (version) (goto-char (point-min)) (while (> (point-at-eol) (point-at-bol)) (setq version (buffer-substring-no-properties (point-at-bol) (point-at-eol))) (forward-line 1) (xetla-archive-tree-add-version archive category branch (xetla-name-version (xetla-name-split-semi-qualified version)))))))) (defun xetla-archive-tree-build-revisions (archive category branch version &optional use-cache ignore-error) "Build the revision list in ARCHIVE/CATEGORY-BRANCH-VERSION. Updates `xetla-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." (when (or (not use-cache) (not (cdr (xetla-archive-tree-get-version archive category branch version)))) (let ((details (or xetla-revisions-shows-summary xetla-revisions-shows-date xetla-revisions-shows-creator)) (basename (xetla-name-construct archive category branch version))) (message "building revisions for `%s'..." basename) (if details (progn (xetla-run-tla-sync (list "revisions" "--summary" "--date" "--creator" basename) :finished 'xetla-null-handler :error (if ignore-error 'xetla-null-handler 'xetla-default-error-function))) (progn (xetla-run-tla-sync (list "revisions" basename) :finished 'xetla-null-handler :error (if ignore-error 'xetla-null-handler 'xetla-default-error-function)))) (message "building revisions for `%s'...done" basename) (sit-for 0) (message nil) (with-current-buffer xetla-last-process-buffer (let (revision date creator summary) (goto-char (point-min)) (while (> (point-at-eol) (point-at-bol)) (setq revision (buffer-substring-no-properties (point-at-bol) (point-at-eol))) (forward-line 1) (when details (skip-chars-forward " ") (setq date (buffer-substring-no-properties (point) (point-at-eol))) (forward-line 1) (skip-chars-forward " ") (setq creator (buffer-substring-no-properties (point) (point-at-eol))) (forward-line 1) (skip-chars-forward " ") (setq summary (buffer-substring-no-properties (point) (progn (re-search-forward "^\\([^ \t]\\|$\\)") (previous-line 1) (end-of-line) (point)))) (forward-line 1)) (xetla-archive-tree-add-revision archive category branch version revision summary creator date))))))) (defun xetla-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 (xetla-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 xetla-revlib-tree nil) (defun xetla-revlib-tree-get-archive (archive &optional archive-tree) "Get ARCHIVE from ARCHIVE-TREE. If ARCHIVE-TREE is not given, `xetla-revlib-tree' is used instead." (assoc archive (or archive-tree xetla-revlib-tree))) (defun xetla-revlib-tree-build-archives (&optional use-cache ignore-error) "Build the list of archives in `xetla-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 xetla-revlib-tree)) (xetla-run-tla-sync '("library-archives") :finished 'xetla-null-handler :error (if ignore-error 'xetla-null-handler 'xetla-default-error-function)) (let ((old-revlib-tree xetla-revlib-tree) ) (setq xetla-revlib-tree nil) (save-excursion (let ((archive-name) (tmp xetla-archive-tree) (xetla-archive-tree xetla-revlib-tree) result) (set-buffer xetla-last-process-buffer) (goto-char (point-min)) (while (> (point-at-eol) (point-at-bol)) (setq result t) (setq archive-name (buffer-substring-no-properties (point-at-bol) (point-at-eol))) (forward-line 1) (xetla-archive-tree-add-archive archive-name nil old-revlib-tree)) (setq xetla-revlib-tree xetla-archive-tree xetla-archive-tree tmp) result))))) (defun xetla-revlib-tree-get-category (archive category) "Get a category from ARCHIVE named CATEGORY." (assoc category (cdr (cdr (xetla-revlib-tree-get-archive archive))))) (defun xetla-revlib-tree-build-categories (archive &optional use-cache ignore-error) "Builds the list of categories for an ARCHIVE in `xetla-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 (xetla-revlib-tree-get-archive archive)))) (xetla-run-tla-sync (list "library-categories" "-A" archive) :finished 'xetla-null-handler :error (if ignore-error 'xetla-null-handler 'xetla-default-error-function)) (with-current-buffer xetla-last-process-buffer (let (category (tmp xetla-archive-tree) (xetla-archive-tree xetla-revlib-tree) result) (goto-char (point-min)) (while (> (point-at-eol) (point-at-bol)) (setq result t) (setq category (buffer-substring-no-properties (point-at-bol) (point-at-eol))) (forward-line 1) (xetla-archive-tree-add-category archive category)) (setq xetla-revlib-tree xetla-archive-tree xetla-archive-tree tmp) result)))) (defun xetla-revlib-tree-get-branch (archive category branch) "From ARCHIVE/CATEGORY, get BRANCH." (assoc branch (cdr (xetla-revlib-tree-get-category archive category)))) (defun xetla-revlib-tree-build-branches (archive category &optional use-cache ignore-error) "Build the list of branches for ARCHIVE/CATEGORY in `xetla-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 (xetla-revlib-tree-get-category archive category)))) (xetla-run-tla-sync (list "library-branches" "-A" archive category) :finished 'xetla-null-handler :error (if ignore-error 'xetla-null-handler 'xetla-default-error-function)) (with-current-buffer xetla-last-process-buffer (let (branch (tmp xetla-archive-tree) (xetla-archive-tree xetla-revlib-tree) result) (goto-char (point-min)) (while (> (point-at-eol) (point-at-bol)) (setq result t) (setq branch (buffer-substring-no-properties (point-at-bol) (point-at-eol))) (forward-line 1) (xetla-archive-tree-add-branch archive category (xetla-name-branch (xetla-name-split-semi-qualified branch)))) (setq xetla-revlib-tree xetla-archive-tree xetla-archive-tree tmp) result)))) (defun xetla-revlib-tree-get-version (archive category branch version) "Get ARCHIVE/CATEGORY-BRANCH-VERSION from the revlib tree." (assoc version (cdr (xetla-revlib-tree-get-branch archive category branch)))) (defun xetla-revlib-tree-build-versions (archive category branch &optional use-cache ignore-error) "Build the versions list in ARCHIVE/CATEGORY/BRANCH in `xetla-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 (xetla-revlib-tree-get-branch archive category branch)))) (xetla-run-tla-sync (list "library-versions" (xetla-name-construct archive category branch)) :finished 'xetla-null-handler :error (if ignore-error 'xetla-null-handler 'xetla-default-error-function)) (with-current-buffer xetla-last-process-buffer (let (version (tmp xetla-archive-tree) (xetla-archive-tree xetla-revlib-tree) result) (goto-char (point-min)) (while (> (point-at-eol) (point-at-bol)) (setq result t) (setq version (buffer-substring-no-properties (point-at-bol) (point-at-eol))) (forward-line 1) (xetla-archive-tree-add-version archive category branch (xetla-name-version (xetla-name-split-semi-qualified version)))) (setq xetla-revlib-tree xetla-archive-tree xetla-archive-tree tmp) result)))) (defun xetla-revlib-tree-get-revision (archive category branch version revision) "Get ARCHIVE/CATEGORY-BRANCH-VERSION-REVISION from the revlib tree." (assoc revision (cdr (xetla-revlib-tree-get-version archive category branch version)))) (defun xetla-revlib-tree-build-revisions (archive category branch version &optional use-cache ignore-error) "Build the revision list of ARCHIVE/CATEGORY-BRANCH-VERSION. Updates `xetla-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 (xetla-revlib-tree-get-version archive category branch version)))) (xetla-run-tla-sync (list "library-revisions" "--summary" "--date" "--creator" (xetla-name-construct archive category branch version)) :finished 'xetla-null-handler :error (if ignore-error 'xetla-null-handler 'xetla-default-error-function)) (with-current-buffer xetla-last-process-buffer (let (revision date creator summary (tmp xetla-archive-tree) (xetla-archive-tree xetla-revlib-tree) result) (goto-char (point-min)) (while (> (point-at-eol) (point-at-bol)) (setq result t) (setq revision (buffer-substring-no-properties (point-at-bol) (point-at-eol))) (forward-line 1) (skip-chars-forward " ") (setq date (buffer-substring-no-properties (point) (point-at-eol))) (forward-line 1) (skip-chars-forward " ") (setq creator (buffer-substring-no-properties (point) (point-at-eol))) (forward-line 1) (skip-chars-forward " ") (setq summary (buffer-substring-no-properties (point) (progn (re-search-forward "^\\([^ \t]\\|$\\)") (previous-line 1) (end-of-line) (point)))) (forward-line 1) (xetla-archive-tree-add-revision archive category branch version revision summary creator date)) (setq xetla-revlib-tree xetla-archive-tree xetla-archive-tree tmp) result )))) ;; -------------------------------------- ;; Name reading engine ;; -------------------------------------- ;;Currently only able to read a full revision starting from nothing. (defun xetla-name-read-refresh-cache () "Function to be called from the minibuffer while reading a name." (interactive) (xetla-archive-tree-build (xetla-name-construct (butlast (delete nil (xetla-name-split (buffer-substring)))))) (setq xetla-archive-tree nil)) (defvar xetla-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 `xetla-name-read-arguments' should be bound in `let'. Variable `xetla-name-read-arguments' is used for passing information from `xetla-name-read' to functions called internally from `xetla-name-read'. Use function `xetla-name-read-arguments' to get the information") (defun xetla-name-read-arguments (key) "Get `xetla-name-read' context information associated to KEY. `xetla-name-read' calls some functions to read a xetla name. In the functions, the arguments passed to `xetla-name-read'(context information) are needed to know. However, `xetla-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, `xetla-name-read-arguments', defined in let. Symbol `archive', `category', `branch', `version', or `revision' are acceptable as KEY." (cdr (assoc key xetla-name-read-arguments))) (defun xetla-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 (xetla-name-split string)) (archive-loc (xetla-name-archive splited)) (category-loc (xetla-name-category splited)) (branch-loc (xetla-name-branch splited)) (version-loc (xetla-name-version splited)) (revision-loc (xetla-name-revision splited)) (suffix (cond ((and (xetla-name-read-arguments 'category) (not category-loc) "/")) ((and (xetla-name-read-arguments 'branch) (not branch-loc) "--")) ((and (xetla-name-read-arguments 'version) (not version-loc) "--")) ((and (xetla-name-read-arguments 'revision) (not revision-loc) "--")) (t nil))) (maybep (cond ((eq 'maybe (xetla-name-read-arguments 'category)) t) ((and (eq 'maybe (xetla-name-read-arguments 'branch)) archive-loc category-loc) t) ((and (eq 'maybe (xetla-name-read-arguments 'version)) archive-loc category-loc branch-loc) t) ((and (eq 'maybe (xetla-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 (xetla-name-read-arguments 'revision) (let ((xetla-revisions-shows-summary nil) (xetla-revisions-shows-date nil) (xetla-revisions-shows-creator nil)) (xetla-archive-tree-build-revisions archive-loc category-loc branch-loc version-loc use-cache t)) (cdr (xetla-archive-tree-get-version archive-loc category-loc branch-loc version-loc)))) (version-loc (when (xetla-name-read-arguments 'version) (xetla-archive-tree-build-versions archive-loc category-loc branch-loc use-cache t) (cdr (xetla-archive-tree-get-branch archive-loc category-loc branch-loc)))) ;; If the user started a branch ... (branch-loc ;; And a branch is needed (when (xetla-name-read-arguments 'branch) (xetla-archive-tree-build-branches archive-loc category-loc use-cache t) (let ((result (cdr (xetla-archive-tree-get-category archive-loc category-loc)))) (when (and (string= branch-loc "") (xetla-name-read-arguments 'version) (let ((empty-br-exists nil)) (dolist (branch (cdr (xetla-archive-tree-get-category archive-loc category-loc))) (when (string= (car branch) "") (setq empty-br-exists t))) empty-br-exists)) (xetla-archive-tree-build-versions archive-loc category-loc "") (setq empty-branch (xetla-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 (xetla-name-read-arguments 'category) (xetla-archive-tree-build-categories archive-loc use-cache t) (cddr (xetla-archive-tree-get-archive archive-loc)))) (t (when (xetla-name-read-arguments 'archive) (xetla-archive-tree-build-archives use-cache t) xetla-archive-tree))))) (let* ((base (mapcar (lambda (x) (xetla-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) (xetla-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))))))) ;; (xetla-trace "string=%s predicate=%S what=%s ==> result=%S\ncompletions=%S" ;; string predicate what result completions) result))))) ;; Test cases ;; (xetla-name-read "enter category: " &quot;Matthieu.Moy(a)imag.fr--public&quot; 'prompt) ;; (xetla-name-read "branch: " &quot;lord(a)emf.net--2004&quot; 'prompt 'prompt) ;; (xetla-name-read "revision: " 'prompt 'prompt 'prompt 'prompt 'prompt) ;; (xetla-name-read "revision or version: " 'prompt 'prompt 'prompt 'prompt 'maybe) ;; (xetla-name-read "revision or version: " &quot;jet(a)gyve.org--xetla&quot; "xetla" "jet" 'prompt 'maybe) ;; (defvar xetla-name-read-history nil) ; TODO: multiple history list? (defvar xetla-name-read-debug nil "If non-nil, `condition-case' in `xetla-name-read' is made disabled.") (defun xetla-name-read (&optional prompt archive category branch version revision) "Read a name. To get help on the user interface of `xetla-name-read', please type M-x xetla-name-read-help RET. Function reading an archive location from keyboard. Read name is expressed in a list built by `xetla-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 \&quot;Matthieu.Moy(a)imag.fr--public\&quot;: (xetla-name-read \"enter category: \" \&quot;Matthieu.Moy(a)imag.fr--public\&quot; 'prompt) - Read a revision, anywhere: (xetla-name-read \"revision: \" 'prompt 'prompt 'prompt 'prompt 'prompt) - Read either a revision or a version: (xetla-name-read \"revision: \" 'prompt 'prompt 'prompt 'prompt 'maybe) While prompting, a menu \"Xetla\" is added to the menubar. The following commands are available: \\{xetla-name-read-minibuf-map}" (let ((xetla-name-read-arguments `((archive . ,archive) (category . ,category) (branch . ,branch) (version . ,version) (revision . ,revision)))) (if xetla-name-read-debug (xetla-name-read-internal prompt archive category branch version revision) (condition-case reason (xetla-name-read-internal prompt archive category branch version revision) ((quit error) (run-hooks 'xetla-name-read-error-hook) (signal (car reason) (cdr reason))))))) (defun xetla-name-read-internal (prompt archive category branch version revision) "See `xetla-name-read'." (run-hooks 'xetla-name-read-init-hook) (let* ((minibuffer-local-completion-map xetla-name-read-minibuf-map) (result (xetla-name-construct (delete 'maybe (delete 'prompt (list archive category branch version))))) (first-try t) not-finished too-long last-empty) ;; Without in some case 'maybe is ignored by xetla-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 (xetla-name-read-required-input archive category branch version revision)) (sit-for 2) (message nil))) (setq result (completing-read (or prompt "Location: ") 'xetla-name-read-complete nil nil result 'xetla-name-read-history) first-try nil) (setq not-finished (xetla-prompt-not-finished result archive category branch version revision)) (setq too-long (xetla-prompt-too-long result archive category branch version revision)) (setq last-empty (xetla-prompt-last-empty result))) (when result (setq result (xetla-name-split result))) (run-hook-with-args 'xetla-name-read-final-hook result) result)) (defun xetla-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 (xetla-name-split result))) (or (and (eq archive 'prompt) ;; archive required (not (xetla-name-archive res-split))) ;; but not provided (and (eq category 'prompt) (not (xetla-name-category res-split))) (and (eq branch 'prompt) (not (xetla-name-branch res-split))) (and (eq version 'prompt) (not (xetla-name-version res-split))) (and (eq revision 'prompt) (not (xetla-name-revision res-split)))))) (defun xetla-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/xetla-main while prompted only for a category." (let ((res-split (xetla-name-split result))) (or (and (not revision) ;; revision not needed (xetla-name-revision res-split)) ;; but provided (and (not version) (xetla-name-version res-split)) (and (not branch) (xetla-name-branch res-split)) (and (not category) (xetla-name-category res-split)) (and (not archive) (xetla-name-archive res-split))))) (defun xetla-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 (xetla-name-split result))) (cond ((equal (xetla-name-archive res-split) "") "archive" ) ((equal (xetla-name-category res-split) "") "category") ((and (equal (xetla-name-branch res-split) "") (not (xetla-name-version res-split))) "branch" ) ((equal (xetla-name-version res-split) "") "version" ) ((equal (xetla-name-revision res-split) "") "revision") (t nil)))) (defun xetla-name-read-required-input (archive category branch version revision) "Return string which represents the elements to be readin `xetla-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 xetla-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 xetla-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))) ;; (xetla-archive-name-source "a") ;; (xetla-archive-name-source "a-SOURCE") ;; (xetla-archive-name-source "a-MIRROR") (defun xetla-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> (xetla-archive-name-source \&quot;jet(a)gyve.org-xetla\&quot;) \&quot;jet(a)gyve.org-xetla-SOURCE\&quot; ELISP> (xetla-archive-name-source \&quot;jet(a)gyve.org-xetla-MIRROR\&quot;) \&quot;jet(a)gyve.org-xetla\&quot; ELISP> (xetla-archive-name-source \&quot;jet(a)gyve.org-xetla-SOURCE\&quot;) nil" (let* ((type (xetla-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 (xetla-archive-tree-build-archives t) (when (and source (xetla-archive-tree-get-archive source)) source)) source))) ;; (xetla-archive-name-mirror "a") ;; (xetla-archive-name-mirror "a-SOURCE") ;; (xetla-archive-name-mirror "a-MIRROR") (defun xetla-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> (xetla-archive-name-mirror \&quot;jet(a)gyve.org--xetla\&quot;) \&quot;jet(a)gyve.org--xetla-MIRROR\&quot; ELISP> (xetla-archive-name-mirror \&quot;jet(a)gyve.org--xetla-SOURCE\&quot;) \&quot;jet(a)gyve.org--xetla\&quot; ELISP> (xetla-archive-name-mirror \&quot;jet(a)gyve.org--xetla-MIRROR\&quot;) nil" (let* ((type (xetla-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 (xetla-archive-tree-build-archives t) (when (and mirror (xetla-archive-tree-get-archive mirror)) mirror)) mirror))) (defun xetla-compute-direct-ancestor (&optional revision) "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 (xetla-name-read "Compute direct ancestor of: " 'prompt 'prompt 'prompt 'prompt 'prompt))) (let ((ancestor (xetla-run-tla-sync (list "ancestry-graph" "--immediate" (and revision (xetla-name-construct revision))) :finished (lambda (output error status arguments) (xetla-name-split (xetla-buffer-content output)))))) (when (interactive-p) (message "Ancestor of: %s\n is: %s" (xetla-name-construct ancestor) (xetla-name-construct revision))) ancestor)) ;; 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 xetla-mouse-event-p (event) "Return true if EVENT is a mouse-related event." (if (featurep 'xemacs) (xetla-do-in-xemacs (button-event-p event)) (xetla-do-in-gnu-emacs (string-match "mouse" (format "%S" (event-basic-type event)))))) ;; -------------------------------------- ;; Face manipulators ;; -------------------------------------- (defun xetla-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 xetla-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 xetla-inventory buffer, ;;; I cannot make both font-lock keywords and faces put by tl-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 `(menu ,menu)) ) strcpy) strcpy) str)) ;; -------------------------------------- ;; Debugging facilities ;; -------------------------------------- (defvar xetla-debug t) (defun xetla-trace (&rest msg) "Display the trace message MSG. Same as `message' if `xetla-debug' is non-nil. Does nothing otherwise. Please use it for your debug messages." (when xetla-debug (apply 'message (concat "xetla: " (car msg)) (cdr msg)))) (defun xetla-reload (directory) "Reloads xetla \(usually for debugging purpose\). With prefix arg, prompts for the DIRECTORY in which xetla should be loaded. Useful to switch from one branch to the other. If a Makefile is present in the directory where xetla is to be loaded, run \"make\"." (interactive (list (when current-prefix-arg (let* ((other (read-directory-name "Load XEtla 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 "xetla")))) (setq load-path (cons directory (remove current-path load-path))))) (let ((default-directory (file-name-directory (locate-library "xetla")))) (when (file-exists-p "Makefile") (shell-command "make"))) (when (featurep 'xetla-tips) (unload-feature 'xetla-tips t)) (when (featurep 'xetla-browse) (unload-feature 'xetla-browse t)) (when (featurep 'xetla) (unload-feature 'xetla t)) (when (featurep 'xetla-core) (unload-feature 'xetla-core t)) (when (featurep 'xetla-defs) (unload-feature 'xetla-defs t)) (when (featurep 'xetla-autoloads) (unload-feature 'xetla-autoloads t)) (ignore-errors (require 'xetla-autoloads)) (require 'xetla)) ;; -------------------------------------- ;; Supports spaces in filenames ;; -------------------------------------- (defvar xetla-supports-spaces-in-filenames nil "Wether xetla supports spaces in filenames. Possible values are nil (don't know), 'yes, or 'no. Don't use this variable directly. Use `xetla-supports-spaces-in-filenames' instead.") (defun xetla-supports-spaces-in-filenames () "Wether xetla supports spaces in filenames. Returns 't or nil. If `xetla-supports-spaces' is non-nil, use its value. Otherwise, test if \"escape\" is listed by \"xetla help\", and memorize the result in `xetla-supports-spaces-in-filenames'" (interactive) (let ((answer (cond ((eq xetla-supports-spaces-in-filenames 'yes) t) ((eq xetla-supports-spaces-in-filenames 'no) nil) (t (xetla-run-tla-sync '("help") :finished (lambda (output error status arguments) (with-current-buffer output (goto-char (point-min)) (search-forward "escape :" nil t)))))))) (when (interactive-p) (message (if answer "Yes" "No"))) (setq xetla-supports-spaces-in-filenames (if answer 'yes 'no)) answer)) (defun xetla-escape (string &optional unescape message) "Return the pika escaped value of STRING. If pika escaping is not supported by xetla, 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) ;; We need to do the (un)escaping (xetla-supports-spaces-in-filenames)) (xetla-run-tla-sync (list "escape" (when unescape "--unescaped") string) :finished (lambda (output error status arguments) (xetla-buffer-content output))) string))) (when (or (interactive-p) message) (message res)) res)) (defun xetla-unescape (string) "Run \"tla escape -unescaped\" on STRING. Return STRING if \"tla escape\" is not available." (interactive "sString to unescape: ") (xetla-escape string t (interactive-p))) (defun xetla-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))) ;; -------------------------------------- ;; Saving and loading state variables ;; -------------------------------------- (defun xetla-pp-to-string (sexp) "Return sexp pretty printed by `pp-to-string'." (let ((print-readably t) print-level print-length) (pp-to-string sexp))) (defun xetla-save-state (&optional vars state-file pp) "Save variables from VARS list to file STATE-FILE. The default for VARS is `xetla-state-variables-list' The default for STATE-FILE is `xetla-state-file-name'. If PP is non-nil use `xetla-pp-to-string' to format object. The file will contain a setq setting the vars during loading by `xetla-load-state'." (let ((state-file (or state-file (expand-file-name xetla-state-file-name xetla-config-directory))) (vars (or vars xetla-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 " *xetla-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) (xetla-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)))) (defun xetla-load-state (&optional state-file) "Load `xetla-state-file-name`, i.e. evaluate its content." (let ((state-file (or state-file (expand-file-name xetla-state-file-name xetla-config-directory)))) (if (file-exists-p state-file) (load state-file nil t t)))) ;; (setq xetla-archive-tree nil) ;; (setq xetla-revlib-tree nil) (provide 'xetla-core) ;;; xetla-core.el ends here 1.1 XEmacs/packages/xemacs-packages/xetla/xetla-defs.el Index: xetla-defs.el =================================================================== ;;; xetla-defs.el --- UI XEtla's element definitions ;; Copyright (C) 2003-2004 by Stefan Reichoer (GPL) ;; Copyright (C) 2004 Steve Youngs (BSD) ;; Author: Steve Youngs <steve(a)eicq.org&gt; ;; Maintainer: Steve Youngs <steve(a)eicq.org&gt; ;; Created: 2004-11-25 ;; Keywords: arch archive tla ;; Based on xtla-defs.el by: Stefan Reichoer, <stefan(a)xsteve.at&gt; ;; This file is part of XEtla. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; ;; 3. Neither the name of the author nor the names of any contributors ;; may be used to endorse or promote products derived from this ;; software without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR ;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE ;; DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE ;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF ;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR ;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN ;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; Commentary: ;; Contributions from: ;; Matthieu Moy <Matthieu.Moy(a)imag.fr&gt; ;; Masatake YAMATO <jet(a)gyve.org&gt; ;; Milan Zamazal <pdm(a)zamazal.org&gt; ;; Martin Pool <mbp(a)sourcefrog.net&gt; ;; Robert Widhopf-Fenk <hack(a)robf.de&gt; ;; Mark Triggs <mst(a)dishevelled.net&gt; ;; 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 'easymenu)) ;; Macros to generate correct code for different emacs variants ;; This doesn't really belong here, but then again it doesn't "fit" ;; anywhere else. ;;;###autoload (defmacro xetla-do-in-gnu-emacs (&rest body) "Execute BODY if in GNU/Emacs." (unless running-xemacs `(progn ,＠body))) (put 'xetla-do-in-gnu-emacs 'lisp-indent-hook 'defun) ;;;###autoload (defmacro xetla-do-in-xemacs (&rest body) "Execute BODY if in XEmacs." (when running-xemacs `(progn ,＠body))) (put 'xetla-do-in-xemacs 'lisp-indent-hook 'defun) (defmacro xetla-funcall-if-exists (function &rest args) "Call FUNCTION with ARGS as parameters if it exists." (if (fboundp function) `(funcall ',function ,＠args))) (defun xetla-clone-process (process &optional newname) "Create a twin copy of PROCESS. If NEWNAME is nil, it defaults to PROCESS' name; NEWNAME is modified by adding or incrementing <N> at the end as necessary. If PROCESS is associated with a buffer, the new process will be associated with the current buffer instead. Returns nil if PROCESS has already terminated." (setq newname (or newname (process-name process))) (if (string-match "<[0-9]+>\\'" newname) (setq newname (substring newname 0 (match-beginning 0)))) (when (memq (process-status process) '(run stop open)) (let* ((process-connection-type (process-tty-name process)) (old-kwoq (process-kill-without-query process nil)) (new-process (if (memq (process-status process) '(open)) (apply 'open-network-stream newname (if (process-buffer process) (current-buffer))) (apply 'start-process newname (if (process-buffer process) (current-buffer)) (process-command process))))) (process-kill-without-query new-process old-kwoq) (process-kill-without-query process old-kwoq) (set-process-filter new-process (process-filter process)) (set-process-sentinel new-process (process-sentinel process)) new-process))) (defun-when-void clone-buffer (&optional newname display-flag) "Create a twin copy of the current buffer. If NEWNAME is nil, it defaults to the current buffer's name; NEWNAME is modified by adding or incrementing <N> at the end as necessary. If DISPLAY-FLAG is non-nil, the new buffer is shown with `pop-to-buffer'. This runs the normal hook `clone-buffer-hook' in the new buffer after it has been set up properly in other respects." (interactive (list (if current-prefix-arg (read-string "Name: ")) t)) (if buffer-file-name (error "Cannot clone a file-visiting buffer")) (if (get major-mode 'no-clone) (error "Cannot clone a buffer in %s mode" mode-name)) (setq newname (or newname (buffer-name))) (if (string-match "<[0-9]+>\\'" newname) (setq newname (substring newname 0 (match-beginning 0)))) (let ((buf (current-buffer)) (ptmin (point-min)) (ptmax (point-max)) (pt (point)) (mk (mark t)) (modified (buffer-modified-p)) (mode major-mode) (lvars (buffer-local-variables)) (process (get-buffer-process (current-buffer))) (new (generate-new-buffer (or newname (buffer-name))))) (save-restriction (widen) (with-current-buffer new (insert-buffer-substring buf))) (with-current-buffer new (narrow-to-region ptmin ptmax) (goto-char pt) (if mk (set-mark mk)) (set-buffer-modified-p modified) ;; Clone the old buffer's process, if any. (when process (xetla-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)) ;; -------------------------------------- ;; Key bindings ;; -------------------------------------- ;; ;; Conventions ;; ;; - Meta Rules: ;; 0. If you feel a binding odd more than 3 times, report it to xetla 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. xetla-inventory should have similar key bindings to pcl-cvs. ;; If a pcl-cvs's binding is too odd, talk it in xetla 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 xetla-edit-log ;; RET Open the thing at point ;; ;; ;; Definitions for key concrete rules ;; ;; common keys (defvar xetla-key-help ??) ; help (defvar xetla-key-mark-prefix ?*) ; other mark related command prefix (defvar xetla-key-apply-from-here ?.) ; apply something from here (defvar xetla-key-add-bookmark ?b) ; add this to bookmark (defvar xetla-key-get ?>) ; prefix for getting something (defvar xetla-key-reflect ?<) ; mirror, apply, install... (defvar xetla-key-parent ?^) ; visit uppper XX. e.g. directory (defvar xetla-key-apply-from-head ?＠) ; Do something head revision (defvar xetla-key-diff ?=) ; one shot (defvar xetla-key-add ?a) ; prefix for adding something (defvar xetla-key-show-bookmark ?b) ; show bookmark (defvar xetla-key-diff-prefix ?d) (defvar xetla-key-file-diff ?d) (defvar xetla-key-tree-lint ?l) (defvar xetla-key-logs ?L) (defvar xetla-key-ediff ?e) (defvar xetla-key-log-entry ?a) (defvar xetla-key-refresh ?g) ; refresh buffer (defvar xetla-key-inventory ?i) ; inventory (defvar xetla-key-mark ?m) ; mark (defvar xetla-key-next ?n) ; next item (defvar xetla-key-previous ?p) ; previous item (defvar xetla-key-quit ?q) ; quit (defvar xetla-key-remove ?r) ; prefix for remove something (defvar xetla-key-move ?R) ; prefix for move/rename something (defvar xetla-key-toggle ?t) ; prefix for toggle (defvar xetla-key-unmark ?u) ; unmark (defvar xetla-key-popup-menu ?\C-j) (defvar xetla-key-kill-ring-prefix ?w) (defvar xetla-key-commit ?c) ; actually edit-log, but ; that's what you do when you ; want to commit. (defvar xetla-key-update ?u) ; to run tla update (defvar xetla-key-replay ?r) ; to run tla replay (defvar xetla-key-star-merge ?s) ; to run tla star-merge (defvar xetla-key-missing ?m) ; to run tla missing (defvar xetla-key-buffer-prefix ?B) ; perfix for switching XX buffer (defvar xetla-key-directory-prefix ?D) (defvar xetla-key-merge-prefix ?M) (defvar xetla-key-tag ?T) (defvar xetla-key-revert ?U) (defvar xetla-key-working-copy ?W) ; Affecting on working copy (defvar xetla-key-partner-file-prefix ?f) (defvar xetla-key-tagging-method-prefix ?#) (defvar xetla-key-id ?i) ;; functions for creating key groups (defun xetla-key-group (prefix &rest keys) (apply 'vector prefix keys)) (defun xetla-prefix-toggle (&rest keys) (xetla-key-group xetla-key-toggle keys)) (defun xetla-prefix-add (&rest keys) (xetla-key-group xetla-key-add keys)) (defun xetla-prefix-remove (&rest keys) (xetla-key-group xetla-key-remove keys)) (defun xetla-prefix-move (&rest keys) (xetla-key-group xetla-key-move keys)) (defun xetla-prefix-apply-from-here (&rest keys) (xetla-key-group xetla-key-apply-from-here keys)) (defun xetla-prefix-apply-from-head (&rest keys) (xetla-key-group xetla-key-apply-from-head keys)) (defun xetla-prefix-mark (&rest keys) (xetla-key-group xetla-key-mark-prefix keys)) (defun xetla-prefix-diff (&rest keys) (xetla-key-group xetla-key-diff-prefix keys)) (defun xetla-prefix-merge (&rest keys) (xetla-key-group xetla-key-merge-prefix keys)) (defun xetla-prefix-directory (&rest keys) (xetla-key-group xetla-key-directory-prefix keys)) (defun xetla-prefix-kill-ring (&rest keys) (xetla-key-group xetla-key-kill-ring-prefix keys)) (defun xetla-prefix-buffer (&rest keys) (xetla-key-group xetla-key-buffer-prefix keys)) (defun xetla-prefix-working-copy (&rest keys) (xetla-key-group xetla-key-working-copy keys)) (defun xetla-prefix-partner-file (&rest keys) (xetla-key-group xetla-key-partner-file-prefix keys)) (defun xetla-prefix-tag (&rest keys) (xetla-key-group xetla-key-tag keys)) (defun xetla-prefix-tagging-method (&rest keys) (xetla-key-group xetla-key-tagging-method-prefix keys)) ;; predefined key vectors (defvar xetla-keyvec-toggle-set (xetla-prefix-toggle ?+)) (defvar xetla-keyvec-toggle-reset (xetla-prefix-toggle ?-)) (defvar xetla-keyvec-toggle-invert (xetla-prefix-toggle ?~)) (defvar xetla-keyvec-help (vector xetla-key-help)) (defvar xetla-keyvec-parent (vector xetla-key-parent)) (defvar xetla-keyvec-add (vector xetla-key-add)) (defvar xetla-keyvec-remove (vector xetla-key-remove)) (defvar xetla-keyvec-get (vector xetla-key-get)) (defvar xetla-keyvec-refresh (vector xetla-key-refresh)) (defvar xetla-keyvec-next (vector xetla-key-next)) (defvar xetla-keyvec-previous (vector xetla-key-previous)) (defvar xetla-keyvec-mark (vector xetla-key-mark)) (defvar xetla-keyvec-unmark (vector xetla-key-unmark)) (defvar xetla-keyvec-mark-all (xetla-prefix-mark ?*)) (defvar xetla-keyvec-unmark-all (xetla-prefix-mark ?!)) (defvar xetla-keyvec-quit (vector xetla-key-quit)) (defvar xetla-keyvec-popup-menu (vector xetla-key-popup-menu)) (defvar xetla-keyvec-ediff (vector xetla-key-ediff)) (defvar xetla-keyvec-tree-lint (vector xetla-key-tree-lint)) (defvar xetla-keyvec-logs (vector xetla-key-logs)) (defvar xetla-keyvec-log-entry (vector xetla-key-log-entry)) (defvar xetla-keyvec-diff (vector xetla-key-diff)) (defvar xetla-keyvec-file-diff (vector xetla-key-file-diff)) (defvar xetla-keyvec-file-diff (vector xetla-key-file-diff)) (defvar xetla-keyvec-commit (vector xetla-key-commit)) (defvar xetla-keyvec-update (vector xetla-key-update)) (defvar xetla-keyvec-replay (vector xetla-key-replay)) (defvar xetla-keyvec-star-merge (vector xetla-key-star-merge)) (defvar xetla-keyvec-reflect (vector xetla-key-reflect)) (defvar xetla-keyvec-revert (vector xetla-key-revert)) (defvar xetla-keyvec-inventory (vector xetla-key-inventory)) (defvar xetla-keyvec-show-bookmark (vector xetla-key-show-bookmark)) (defvar xetla-keyvec-add-bookmark (vector xetla-key-add-bookmark)) (defvar xetla-keyvec-tag (vector xetla-key-tag)) (defvar xetla-keyvec-kill-ring (vector xetla-key-kill-ring-prefix)) (defvar xetla-keyvec-id (vector xetla-key-id)) (defvar xetla-keyvec-toggle (vector xetla-key-toggle)) ;; ;; Global ;; (defvar xetla-global-keymap (let ((map (make-sparse-keymap))) (define-key map xetla-keyvec-log-entry 'xetla-add-log-entry) (define-key map [?A] 'xetla-archives) (define-key map xetla-keyvec-show-bookmark 'xetla-bookmarks) (define-key map xetla-keyvec-file-diff 'xetla-file-diff) (define-key map xetla-keyvec-ediff 'xetla-file-ediff) (define-key map [?o] 'xetla-file-view-original) (define-key map xetla-keyvec-diff 'xetla-changes) (define-key map xetla-keyvec-commit 'xetla-edit-log) (define-key map [?t] 'xetla-tag-insert) (define-key map xetla-keyvec-inventory 'xetla-inventory) (define-key map [?r] 'xetla-tree-revisions) (define-key map xetla-keyvec-logs 'xetla-logs) (define-key map xetla-keyvec-tree-lint 'xetla-tree-lint) (define-key map xetla-keyvec-update 'xetla-update) (define-key map xetla-keyvec-help 'xetla-help) map) "Global keymap used by Xetla.") (define-key ctl-x-4-map [?T] 'xetla-add-log-entry) ;; ;; Minibuffer(for reading engine) ;; (defvar xetla-name-read-partner-menu (cons "Insert Partner Version" nil)) (fset 'xetla-name-read-partner-menu (cons 'keymap xetla-name-read-partner-menu)) (defvar xetla-name-read-bookmark-menu (cons "Insert Version in Bookmarks" nil)) (fset 'xetla-name-read-bookmark-menu (cons 'keymap xetla-name-read-bookmark-menu)) (defvar xetla-name-read-extension-keydefs '(([(control r)] . xetla-name-read-refresh-cache) ([(meta *)] . xetla-name-read-insert-default-archive) ([(meta \.)] . xetla-name-read-insert-info-at-point) ([(meta \;)] . xetla-name-read-insert-version-associated-with-default-directory) ([(control n)] . xetla-name-read-insert-partner-next) ([(control p)] . xetla-name-read-insert-partner-previous) ([(control v)] . xetla-name-read-insert-bookmark-next) ([(meta v)] . xetla-name-read-insert-bookmark-previous) ([(meta ^)] . xetla-name-read-insert-ancestor) ([(control h)] . xetla-name-read-help) ([(meta \?)] . xetla-name-read-inline-help)) "Key definitions table for `xetla-name-read-minibuf-map'. The reason these definitions are defined separately from `xetla-name-read-minibuf-map' is that to reuse these definitions in `xetla-name-read-help'. Don't forget to evalute `xetla-name-read-minibuf-map' again after updating this value.") (defvar xetla-name-read-minibuf-map (let ((map (copy-keymap minibuffer-local-completion-map))) ;; Keys (mapc (lambda (pair) (let ((key (car pair)) (func (cdr pair))) (define-key map key func))) xetla-name-read-extension-keydefs) ;; Menus (define-key map [menu-bar xetla] (cons "XEtla" (make-sparse-keymap "XEtla"))) (define-key map [menu-bar xetla refresh] (list 'menu-item "Refresh Completion Cache" 'xetla-name-read-refresh-cache)) (define-key map [menu-bar xetla ancestor] (list 'menu-item "Insert Ancestor" 'xetla-name-read-insert-ancestor :enable '(and (window-minibuffer-p) (equal "" (buffer-substring)) (member archive '(prompt maybe)) (not (eq this-command 'xetla-compute-direct-ancestor)) ))) (define-key map [menu-bar xetla default] (list 'menu-item "Insert Default Archive" 'xetla-name-read-insert-default-archive :enable '(and (window-minibuffer-p) (equal "" (buffer-substring)) (member archive '(prompt maybe))))) (define-key map [menu-bar xetla here] (list 'menu-item "Insert Thing at Point" 'xetla-name-read-insert-info-at-point :enable '(and (window-minibuffer-p) (equal "" (buffer-substring)) xetla-name-read-insert-info-at-point))) (define-key map [menu-bar xetla bookmark] (list 'menu-item "Insert Version in Bookmark" 'xetla-name-read-bookmark-menu :enable '(let* ((l (condition-case nil (let ((default-version (xetla-tree-version-list default-directory))) (xetla-bookmarks-get-partner-versions default-version)) (error nil)))) (and l (< 0 (length l)))))) (define-key map [menu-bar xetla partner] (list 'menu-item "Insert Partner Version" 'xetla-name-read-partner-menu :enable '(let* ((l (condition-case nil (xetla-partner-list) (error nil)))) (and l (< 0 (length l)))))) map) "Keymap to input a gnuarch revision at the minibuffer.") ;; ;; Context keymap template ;; (defvar xetla-context-map-template (let ((map (make-sparse-keymap))) ;; TODO: [return[, "\C-m" => xetla-generic-context-action (define-key map (xetla-prefix-apply-from-here xetla-key-help) 'describe-bindings) (define-key map xetla-keyvec-help 'describe-mode) (define-key map [button3] 'xetla-generic-popup-menu) (define-key map xetla-keyvec-popup-menu 'xetla-generic-popup-menu-by-keyboard) map) "Template for keymaps used in items, files, changes, etc.") ;; ;; Bookmarks mode ;; (defvar xetla-bookmarks-mode-map (let ((map (make-sparse-keymap))) (define-key map xetla-keyvec-help 'describe-mode) ;; Move (define-key map xetla-keyvec-next 'xetla-bookmarks-next) (define-key map xetla-keyvec-previous 'xetla-bookmarks-previous) (define-key map [?N] 'xetla-bookmarks-move-down) (define-key map [?P] 'xetla-bookmarks-move-up) ;; Actions (define-key map (xetla-prefix-merge xetla-key-star-merge) 'xetla-bookmarks-star-merge) (define-key map (xetla-prefix-merge xetla-key-replay) 'xetla-bookmarks-replay) (define-key map (xetla-prefix-merge xetla-key-update) 'xetla-bookmarks-update) (define-key map (xetla-prefix-merge xetla-key-missing) 'xetla-bookmarks-missing) (define-key map (xetla-prefix-merge xetla-key-tag) 'xetla-bookmarks-tag) (define-key map [?o] 'xetla-bookmarks-open-tree) (define-key map [(control x) (control f)] 'xetla-bookmarks-find-file) (define-key map xetla-keyvec-diff 'xetla-bookmarks-changes) (define-key map xetla-keyvec-get 'xetla-bookmarks-get) (define-key map "\C-m" 'xetla-bookmarks-goto) ;; Marks (define-key map xetla-keyvec-mark 'xetla-bookmarks-mark) (define-key map xetla-keyvec-unmark 'xetla-bookmarks-unmark) (define-key map xetla-keyvec-unmark-all 'xetla-bookmarks-unmark-all) (define-key map (xetla-prefix-mark ?g) 'xetla-bookmarks-select-by-group) ;; Partners (define-key map [(meta p)] 'xetla-bookmarks-marked-are-partners) (define-key map (xetla-prefix-add ?p) 'xetla-bookmarks-add-partner-interactive) (define-key map (xetla-prefix-remove ?p) 'xetla-bookmarks-delete-partner-interactive) (define-key map (xetla-prefix-partner-file ?r) 'xetla-bookmarks-add-partners-from-file) (define-key map (xetla-prefix-partner-file ?w) 'xetla-bookmarks-write-partners-to-file) ;; Bookmark manipulation (define-key map (xetla-prefix-add ?b) 'xetla-bookmarks-add) (define-key map (xetla-prefix-remove ?b) 'xetla-bookmarks-delete) (define-key map [?e] 'xetla-bookmarks-edit) (define-key map xetla-keyvec-toggle 'xetla-bookmarks-toggle-details) ;; Fields (define-key map (xetla-prefix-add ?t) 'xetla-bookmarks-add-tree-interactive) (define-key map (xetla-prefix-remove ?t) 'xetla-bookmarks-delete-tree-interactive) (define-key map (xetla-prefix-add ?g) 'xetla-bookmarks-add-group-interactive) (define-key map (xetla-prefix-remove ?g) 'xetla-bookmarks-delete-group-interactive) (define-key map (xetla-prefix-add ?n) 'xetla-bookmarks-add-nickname-interactive) (define-key map (xetla-prefix-remove ?n) 'xetla-bookmarks-delete-nickname-interactive) ;; Switch to other buffers (define-key map xetla-keyvec-inventory 'xetla-bookmarks-inventory) (define-key map (xetla-prefix-buffer ?p) 'xetla-show-process-buffer) (define-key map (xetla-prefix-buffer ?L) 'xetla-open-internal-log-buffer) (define-key map xetla-keyvec-quit 'xetla-buffer-quit) map) "Keymap used in `xetla-bookmarks-mode' buffers.") (defvar xetla-bookmarks-entry-map (let ((map (copy-keymap xetla-context-map-template))) (define-key map [button2] 'xetla-bookmarks-goto-by-mouse) map) "Keymap used on entries in `xetla-bookmarks-mode' buffers.") ;; ;; Inventory mode ;; (defvar xetla-inventory-mode-map (let ((map (make-sparse-keymap))) (define-key map xetla-keyvec-help 'describe-mode) (define-key map xetla-keyvec-refresh 'xetla-generic-refresh) (define-key map xetla-keyvec-add 'xetla-inventory-add-files) (define-key map xetla-keyvec-remove 'xetla-inventory-remove-files) (define-key map xetla-keyvec-quit 'xetla-buffer-quit) (define-key map xetla-keyvec-next 'xetla-inventory-next) (define-key map xetla-keyvec-previous 'xetla-inventory-previous) (define-key map xetla-keyvec-parent 'xetla-inventory-parent-directory) ;; ;; ;; (define-key map [?X] 'xetla-inventory-delete-files) (define-key map (xetla-prefix-move xetla-key-move) 'xetla-inventory-move) (define-key map xetla-keyvec-commit 'xetla-inventory-edit-log) ;; mnemonic for commit (define-key map [?l] 'xetla-changelog) (define-key map xetla-keyvec-logs 'xetla-logs) ;; ;; Find file group ;; (define-key map [?f] 'xetla-inventory-find-file) (define-key map [return] 'xetla-inventory-find-file) (define-key map "\C-m" 'xetla-inventory-find-file) (define-key map [?o] 'xetla-generic-find-file-other-window) (define-key map [?v] 'xetla-generic-view-file) ;; ;; Diffs group ;; (define-key map (xetla-prefix-merge xetla-key-missing) 'xetla-inventory-missing) (define-key map (xetla-prefix-diff xetla-key-diff) 'xetla-inventory-changes) (define-key map (xetla-prefix-diff ?l) 'xetla-changes-last-revision) (define-key map (xetla-prefix-diff xetla-key-ediff) 'xetla-inventory-file-ediff) (define-key map (xetla-prefix-diff xetla-key-get) 'xetla-inventory-delta) ;; Alias for above bindings (define-key map xetla-keyvec-diff 'xetla-inventory-changes) (define-key map xetla-keyvec-ediff 'xetla-inventory-file-ediff) ;; (define-key map xetla-keyvec-reflect 'xetla-inventory-mirror) ;; ;; Merge group ;; (define-key map (xetla-prefix-merge xetla-key-star-merge) 'xetla-inventory-star-merge) (define-key map (xetla-prefix-merge xetla-key-replay) 'xetla-inventory-replay) (define-key map (xetla-prefix-merge xetla-key-update) 'xetla-inventory-update) (define-key map (xetla-prefix-merge xetla-key-reflect) 'xetla-inventory-apply-changeset) ;; ;; Buffers group ;; (define-key map (xetla-prefix-buffer ?p) 'xetla-show-process-buffer) (define-key map (xetla-prefix-buffer ?L) 'xetla-open-internal-log-buffer) (define-key map (xetla-prefix-buffer xetla-key-show-bookmark) 'xetla-bookmarks) ;; ;; Undo and redo group ;; (define-key map xetla-keyvec-revert 'xetla-inventory-revert) (define-key map (xetla-prefix-working-copy xetla-key-revert) 'xetla-inventory-undo) (define-key map (xetla-prefix-working-copy ?R) 'xetla-inventory-redo) ;; ;; Patches group ;; (define-key map (xetla-prefix-working-copy ?S) 'xetla-changes-save) (define-key map (xetla-prefix-working-copy ?s) 'xetla-changes-save-as-tgz) (define-key map (xetla-prefix-working-copy ?V) 'xetla-show-changeset) (define-key map (xetla-prefix-working-copy ?v) 'xetla-show-changeset-from-tgz) (define-key map (xetla-prefix-working-copy ?A) 'xetla-inventory-apply-changeset) (define-key map (xetla-prefix-working-copy ?a) 'xetla-inventory-apply-changeset-from-tgz) ;; ;; Kill ring group ;; (define-key map (xetla-prefix-kill-ring ?a) 'xetla-save-archive-to-kill-ring) ;; ;; Tree lint ;; (define-key map (xetla-prefix-working-copy xetla-key-tree-lint) 'xetla-tree-lint) ;; ;; Mark group ;; (define-key map (xetla-prefix-mark xetla-key-mark) 'xetla-inventory-mark-file) (define-key map (xetla-prefix-mark xetla-key-unmark) 'xetla-inventory-unmark-file) ;; (define-key map xetla-keyvec-mark-all 'xetla-inventory-mark-all) (define-key map xetla-keyvec-unmark-all 'xetla-inventory-unmark-all) ;; Alias for above bindings (define-key map xetla-keyvec-mark 'xetla-inventory-mark-file) (define-key map xetla-keyvec-unmark 'xetla-inventory-unmark-file) ;; ;; Tagging method ;; (define-key map (xetla-prefix-tagging-method ?=) 'xetla-edit-=tagging-method-file) (define-key map (xetla-prefix-tagging-method ?.) 'xetla-edit-.arch-inventory-file) ;; ;; Exclude, junk, precious, unrecognized... ;; (define-key map (xetla-prefix-move ?j) 'xetla-inventory-make-junk) (define-key map (xetla-prefix-move ?,) 'xetla-inventory-make-junk) (define-key map (xetla-prefix-move ?p) 'xetla-inventory-make-precious) (define-key map (xetla-prefix-move ?+) 'xetla-inventory-make-precious) (define-key map (xetla-prefix-tagging-method ?M) 'xetla-generic-set-id-tagging-method) (define-key map (xetla-prefix-tagging-method ?V) 'xetla-generic-set-tree-version) (define-key map (xetla-prefix-tagging-method ?x) 'xetla-generic-add-to-exclude) ; alias (define-key map (xetla-prefix-tagging-method ?e) 'xetla-generic-add-to-exclude) ; alias (define-key map (xetla-prefix-tagging-method ?j) 'xetla-generic-add-to-junk) (define-key map (xetla-prefix-tagging-method ?b) 'xetla-generic-add-to-backup) (define-key map (xetla-prefix-tagging-method ?~) 'xetla-generic-add-to-backup) ; alias (define-key map (xetla-prefix-tagging-method ?p) 'xetla-generic-add-to-precious) (define-key map (xetla-prefix-tagging-method ?u) 'xetla-generic-add-to-unrecognized) ;; ;; Toggles ;; (define-key map xetla-keyvec-toggle-set 'xetla-inventory-set-all-toggle-variables) (define-key map xetla-keyvec-toggle-reset 'xetla-inventory-reset-all-toggle-variables) (define-key map xetla-keyvec-toggle-invert 'xetla-inventory-toggle-all-toggle-variables) map) "Keymap used in `xetla-inventory-mode' buffers.") (defvar xetla-inventory-item-map (let ((map (copy-keymap xetla-context-map-template))) (define-key map [button2] 'xetla-inventory-find-file-by-mouse) map) "Keymap used on items in `xetla-inventory-mode' buffers.") (defvar xetla-inventory-default-version-map (let ((map (copy-keymap xetla-context-map-template))) (define-key map [return] 'xetla-generic-set-tree-version) (define-key map "\C-m" 'xetla-generic-set-tree-version) map) "Keymap used on the default version field in `xetla-inventory-mode' buffers.") (defvar xetla-inventory-tagging-method-map (let ((map (copy-keymap xetla-context-map-template))) (define-key map [button2] 'xetla-generic-set-id-tagging-method-by-mouse) (define-key map [return] 'xetla-generic-set-id-tagging-method) (define-key map "\C-m" 'xetla-inventory-id-tagging-method) map) "Keymap used on the tagging method field in `xetla-inventory-mode' buffers.") (defconst xetla-inventory-file-types-manipulators '((?S xetla-inventory-display-source xetla-inventory-toggle-source ?s "source") (?P xetla-inventory-display-precious xetla-inventory-toggle-precious ?p "precious") (?J xetla-inventory-display-junk xetla-inventory-toggle-junk ?j "junk") (?B xetla-inventory-display-backup xetla-inventory-toggle-backup ?b "backup") (?T xetla-inventory-display-tree xetla-inventory-toggle-tree ?t "tree root") (?U xetla-inventory-display-unrecognized xetla-inventory-toggle-unrecognized ?u "unrecognized")) "List of possible file types in inventory.") (dolist (type-arg xetla-inventory-file-types-manipulators) (define-key xetla-inventory-mode-map `[?t ,(cadddr type-arg)] (caddr type-arg))) (dolist (type-arg xetla-inventory-file-types-manipulators) (eval `(defcustom ,(cadr type-arg) t ,(concat "Whether " (nth 4 type-arg) " should be printed in inventory") :group 'xetla-inventory :type 'boolean))) (defvar xetla-tree-lint-mode-map (let ((map (make-sparse-keymap))) (define-key map xetla-keyvec-help 'describe-mode) (define-key map xetla-keyvec-refresh 'xetla-generic-refresh) (define-key map xetla-keyvec-add 'xetla-tree-lint-add-files) (define-key map xetla-keyvec-remove 'xetla-tree-lint-delete-files) (define-key map xetla-keyvec-quit 'xetla-buffer-quit) (define-key map xetla-keyvec-next 'xetla-tree-lint-next) (define-key map xetla-keyvec-previous 'xetla-tree-lint-previous) (define-key map [down] 'xetla-tree-lint-next) (define-key map [up] 'xetla-tree-lint-previous) (define-key map xetla-keyvec-id 'xetla-tree-lint-regenerate-id) (define-key map (xetla-prefix-move ?j) 'xetla-tree-lint-make-junk) (define-key map (xetla-prefix-move ?,) 'xetla-tree-lint-make-junk) (define-key map (xetla-prefix-move ?p) 'xetla-tree-lint-make-precious) (define-key map (xetla-prefix-move ?+) 'xetla-tree-lint-make-precious) ;; (define-key map (xetla-prefix-tagging-method ?=) 'xetla-edit-=tagging-method-file) (define-key map (xetla-prefix-tagging-method ?.) 'xetla-edit-.arch-inventory-file) (define-key map (xetla-prefix-tagging-method ?M) 'xetla-generic-set-id-tagging-method) (define-key map (xetla-prefix-tagging-method ?V) 'xetla-generic-set-tree-version) (define-key map (xetla-prefix-tagging-method ?x) 'xetla-generic-add-to-exclude) ; alias (define-key map (xetla-prefix-tagging-method ?e) 'xetla-generic-add-to-exclude) ; alias (define-key map (xetla-prefix-tagging-method ?j) 'xetla-generic-add-to-junk) (define-key map (xetla-prefix-tagging-method ?b) 'xetla-generic-add-to-backup) (define-key map (xetla-prefix-tagging-method ?~) 'xetla-generic-add-to-backup) ; alias (define-key map (xetla-prefix-tagging-method ?p) 'xetla-generic-add-to-precious) (define-key map (xetla-prefix-tagging-method ?u) 'xetla-generic-add-to-unrecognized) ;; (define-key map [return] 'xetla-generic-find-file-at-point) (define-key map "\C-m" 'xetla-generic-find-file-at-point) (define-key map [?o] 'xetla-generic-find-file-other-window) (define-key map [?v] 'xetla-generic-view-file) ;; ;; Mark group ;; (define-key map (xetla-prefix-mark xetla-key-mark) 'xetla-tree-lint-mark-file) (define-key map (xetla-prefix-mark xetla-key-unmark) 'xetla-tree-lint-unmark-file) ;; TODO ;; (define-key map xetla-keyvec-mark-all 'xetla-tree-lint-mark-all) (define-key map xetla-keyvec-unmark-all 'xetla-tree-lint-unmark-all) ;; Alias for above bindings (define-key map xetla-keyvec-mark 'xetla-tree-lint-mark-file) (define-key map xetla-keyvec-unmark 'xetla-tree-lint-unmark-file) ;; ;; Buffers group ;; (define-key map (xetla-prefix-buffer ?p) 'xetla-show-process-buffer) (define-key map (xetla-prefix-buffer ?L) 'xetla-open-internal-log-buffer) (define-key map (xetla-prefix-buffer xetla-key-show-bookmark) 'xetla-bookmarks) map) "Keymap used in `xetla-tree-lint-mode' buffers.") (defvar xetla-tree-lint-file-map (let ((map (copy-keymap xetla-context-map-template))) (define-key map [button2] 'xetla-generic-find-file-at-point-by-mouse) map) "Keymap used on files in xetla-lint-mode buffers.") ;; ;; Cat-Log mdoe ;; (defvar xetla-cat-log-mode-map (let ((map (make-sparse-keymap))) (define-key map xetla-keyvec-help 'describe-mode) (define-key map xetla-keyvec-inventory 'xetla-pop-to-inventory) (define-key map xetla-keyvec-quit 'xetla-buffer-quit) map) "Keymap used in `xetla-cat-log-mode' buffers.") ;; ;; Log edit mode ;; (defvar xetla-log-edit-mode-map (let ((map (make-sparse-keymap))) (define-key map [(control ?c) (control ?c)] 'xetla-log-edit-done) (define-key map [(control ?c) (control ?d)] 'xetla-changes) (define-key map [(control ?c) (control ?l)] 'xetla-changelog) (define-key map [(control ?c) (control ?m)] 'xetla-log-edit-insert-log-for-merge) (define-key map [(control ?c) ?m ] 'xetla-log-edit-insert-log-for-merge-and-headers) (define-key map [(control ?c) (control ?p)] 'xetla-log-edit-insert-memorized-log) (define-key map [(control ?c) (control ?q)] 'xetla-log-edit-abort) (define-key map [(control ?c) (control ?s)] 'xetla-log-goto-summary) (define-key map [(control ?c) (control ?b)] 'xetla-log-goto-body) (define-key map [(control ?c) (control ?k)] 'xetla-log-edit-keywords) (define-key map "\t" 'xetla-log-edit-next-field) map) "Keymap used in `xetla-log-edit-mode' buffers.") ;; ;; Archive list mode ;; (defvar xetla-archive-list-mode-map (let ((map (make-sparse-keymap))) (define-key map xetla-keyvec-help 'describe-mode) (define-key map (xetla-prefix-kill-ring ?a) 'xetla-save-archive-to-kill-ring) (define-key map "\C-m" 'xetla-archive-list-categories) (define-key map [return] 'xetla-archive-list-categories) ;; Buffers group (define-key map (xetla-prefix-buffer ?p) 'xetla-show-process-buffer) (define-key map (xetla-prefix-buffer ?L) 'xetla-open-internal-log-buffer) (define-key map (xetla-prefix-buffer xetla-key-show-bookmark) 'xetla-bookmarks) (define-key map xetla-keyvec-add-bookmark 'xetla-bookmarks-add) (define-key map [?o] 'xetla-archive-browse-archive) (define-key map [?*] 'xetla-archive-select-default) (define-key map (xetla-prefix-add ?r) 'xetla-register-archive) (define-key map (xetla-prefix-add ?a) 'xetla-make-archive) (define-key map (xetla-prefix-add ?m) 'xetla-archive-mirror-archive) (define-key map xetla-keyvec-remove 'xetla-archive-unregister-archive) (define-key map [?g] 'xetla-archives) (define-key map [?s] 'xetla-archive-synchronize-archive) (define-key map [?e] 'xetla-archive-edit-archive-location) (define-key map [down] 'xetla-archive-next) (define-key map [up] 'xetla-archive-previous) (define-key map [?n] 'xetla-archive-next) (define-key map [?p] 'xetla-archive-previous) (define-key map xetla-keyvec-quit 'xetla-buffer-quit) map) "Keymap used in `xetla-archive-list-mode' buffers.") (defvar xetla-archive-archive-map (let ((map (make-sparse-keymap))) (define-key map [button2] 'xetla-archive-list-categories-by-mouse) map) "Keymap used archives in `xetla-archive-list-mode' buffers.") ;; ;; Category list mode ;; (defvar xetla-category-list-mode-map (let ((map (make-sparse-keymap))) (define-key map xetla-keyvec-help 'describe-mode) (define-key map "\C-m" 'xetla-category-list-branches) (define-key map [return] 'xetla-category-list-branches) ;; Buffers group (define-key map (xetla-prefix-buffer ?p) 'xetla-show-process-buffer) (define-key map (xetla-prefix-buffer ?L) 'xetla-open-internal-log-buffer) (define-key map (xetla-prefix-buffer xetla-key-show-bookmark) 'xetla-bookmarks) (define-key map xetla-keyvec-add-bookmark 'xetla-category-bookmarks-add) (define-key map (xetla-prefix-apply-from-here xetla-key-add-bookmark) 'xetla-category-bookmarks-add-here) (define-key map [?^] 'xetla-archives) (define-key map (xetla-prefix-add ?c) 'xetla-category-make-category) (define-key map [?g] 'xetla-category-refresh) (define-key map [?s] 'xetla-category-mirror-archive) (define-key map [down] 'xetla-category-next) (define-key map [up] 'xetla-category-previous) (define-key map [?n] 'xetla-category-next) (define-key map [?p] 'xetla-category-previous) (define-key map xetla-keyvec-quit 'xetla-buffer-quit) map) "Keymap used in `xetla-category-list-mode' buffers.") (defvar xetla-category-category-map (let ((map (make-sparse-keymap))) (define-key map [button2] 'xetla-category-list-branches-by-mouse) map) "Keymap used categories in `xetla-category-list-mode' buffers.") ;; ;; Branch list mode section ;; (defvar xetla-branch-list-mode-map (let ((map (make-sparse-keymap))) (define-key map xetla-keyvec-help 'describe-mode) (define-key map "\C-m" 'xetla-branch-list-versions) (define-key map [return] 'xetla-branch-list-versions) ;; Buffers group (define-key map (xetla-prefix-buffer ?p) 'xetla-show-process-buffer) (define-key map (xetla-prefix-buffer ?L) 'xetla-open-internal-log-buffer) (define-key map (xetla-prefix-buffer xetla-key-show-bookmark) 'xetla-bookmarks) (define-key map xetla-keyvec-parent 'xetla-branch-list-parent-category) (define-key map (xetla-prefix-add ?b) 'xetla-branch-make-branch) (define-key map [?>] 'xetla-branch-get-branch) (define-key map [?g] 'xetla-branch-refresh) (define-key map [?s] 'xetla-branch-mirror-archive) (define-key map [down] 'xetla-category-next) (define-key map [up] 'xetla-category-previous) (define-key map [?n] 'xetla-category-next) (define-key map [?p] 'xetla-category-previous) (define-key map xetla-keyvec-quit 'xetla-buffer-quit) (define-key map (xetla-prefix-apply-from-here xetla-key-add-bookmark) 'xetla-branch-bookmarks-add-here) (define-key map xetla-keyvec-add-bookmark 'xetla-branch-bookmarks-add) map) "Keymap used in `xetla-branch-list-mode' buffers.") (defvar xetla-branch-branch-map (let ((map (make-sparse-keymap))) (define-key map [button2] 'xetla-branch-list-versions-by-mouse) map) "Keymap used branches in `xetla-branch-list-mode' buffers.") ;; ;; Version list mode ;; (defvar xetla-version-list-mode-map (let ((map (make-sparse-keymap))) (define-key map xetla-keyvec-help 'describe-mode) (define-key map "\C-m" 'xetla-version-list-revisions) (define-key map [return] 'xetla-version-list-revisions) ;; Buffers group (define-key map (xetla-prefix-buffer ?p) 'xetla-show-process-buffer) (define-key map (xetla-prefix-buffer ?L) 'xetla-open-internal-log-buffer) (define-key map (xetla-prefix-buffer xetla-key-show-bookmark) 'xetla-bookmarks) (define-key map xetla-keyvec-parent 'xetla-version-list-parent-branch) (define-key map (xetla-prefix-add ?v) 'xetla-version-make-version) (define-key map [?>] 'xetla-version-get-version) (define-key map [?g] 'xetla-version-refresh) (define-key map [?s] 'xetla-version-mirror-archive) (define-key map [down] 'xetla-category-next) (define-key map [up] 'xetla-category-previous) (define-key map [?n] 'xetla-category-next) (define-key map [?p] 'xetla-category-previous) (define-key map xetla-keyvec-quit 'xetla-buffer-quit) (define-key map (xetla-prefix-apply-from-here xetla-key-add-bookmark) 'xetla-version-bookmarks-add-here) (define-key map xetla-keyvec-add-bookmark 'xetla-version-bookmarks-add) (define-key map xetla-keyvec-tag 'xetla-version-tag) map) "Keymap used in `xetla-version-list-mode' buffers.") (defvar xetla-version-version-map (let ((map (make-sparse-keymap))) (define-key map [button2] 'xetla-version-list-revisions-by-mouse) map) "Keymap used versions in `xetla-version-list-mode' buffers.") ;; ;; Revision list mode ;; (defvar xetla-revision-list-mode-map (let ((map (make-sparse-keymap))) (define-key map xetla-keyvec-help 'describe-mode) (define-key map xetla-keyvec-parent 'xetla-revision-list-parent-version) (define-key map [?> ?g] 'xetla-revision-get-revision) (define-key map [?> ?C] 'xetla-revision-cache-revision) (define-key map [?> ?L] 'xetla-revision-add-to-library) ;; Buffers group (define-key map (xetla-prefix-buffer ?p) 'xetla-show-process-buffer) (define-key map (xetla-prefix-buffer ?L) 'xetla-open-internal-log-buffer) (define-key map (xetla-prefix-buffer xetla-key-show-bookmark) 'xetla-bookmarks) (define-key map [?b] 'xetla-bookmarks-add) (define-key map (xetla-prefix-toggle ??) 'xetla-revision-toggle-help) (define-key map (xetla-prefix-toggle ?d) 'xetla-revision-toggle-date) (define-key map (xetla-prefix-toggle ?c) 'xetla-revision-toggle-creator) (define-key map (xetla-prefix-toggle ?s) 'xetla-revision-toggle-summary) (define-key map (xetla-prefix-toggle ?l) 'xetla-revision-toggle-library) (define-key map (xetla-prefix-toggle ?m) 'xetla-revision-toggle-merges) (define-key map (xetla-prefix-toggle ?b) 'xetla-revision-toggle-merged-by) (define-key map (xetla-prefix-toggle ?r) 'xetla-revision-toggle-reverse) ;; ;; Star merge ;; from here (define-key map (xetla-prefix-apply-from-here xetla-key-star-merge) 'xetla-revision-star-merge) ;; from head (define-key map (xetla-prefix-apply-from-head xetla-key-star-merge) 'xetla-revision-star-merge-version) (define-key map (xetla-prefix-merge xetla-key-star-merge) 'xetla-revision-star-merge-version) (define-key map xetla-keyvec-star-merge 'xetla-revision-star-merge-version) ;; ;; Replay ;; from here (define-key map (xetla-prefix-apply-from-here xetla-key-replay) 'xetla-revision-replay) ;; from head (define-key map (xetla-prefix-apply-from-head xetla-key-replay) 'xetla-revision-replay-version) (define-key map xetla-keyvec-replay 'xetla-revision-replay-version) (define-key map (xetla-prefix-apply-from-here ?y) 'xetla-revision-sync-tree) ;; ;; Update (define-key map (xetla-prefix-merge xetla-key-update) 'xetla-revision-update) ;; ;; Tag ;; from here (define-key map (xetla-prefix-apply-from-here xetla-key-tag) 'xetla-revision-tag-from-here) (define-key map (xetla-prefix-tag xetla-key-apply-from-here) 'xetla-revision-tag-from-here) ;; from head (define-key map (xetla-prefix-apply-from-head xetla-key-tag) 'xetla-revision-tag-from-head) (define-key map (xetla-prefix-tag xetla-key-apply-from-head) 'xetla-revision-tag-from-head) (define-key map [?g] 'xetla-generic-refresh) (define-key map [down] 'xetla-revision-next) (define-key map [up] 'xetla-revision-prev) (define-key map [?n] 'xetla-revision-next) (define-key map [?p] 'xetla-revision-prev) (define-key map [?N] 'xetla-revision-next-unmerged) (define-key map [?P] 'xetla-revision-prev-unmerged) (define-key map [?l] 'xetla-revision-cat-log) (define-key map "\C-m" 'xetla-revision-show-changeset) (define-key map [return] 'xetla-revision-show-changeset) (define-key map xetla-keyvec-mark 'xetla-revision-mark-revision) (define-key map xetla-keyvec-unmark 'xetla-revision-unmark-revision) (define-key map (xetla-prefix-diff xetla-key-diff) 'xetla-revision-delta) (define-key map (xetla-prefix-diff xetla-key-get) 'xetla-revision-store-delta) (define-key map [?=] 'xetla-revision-changeset) (define-key map (xetla-prefix-buffer ?p) 'xetla-show-process-buffer) (define-key map (xetla-prefix-buffer ?L) 'xetla-open-internal-log-buffer) (define-key map (xetla-prefix-buffer xetla-key-show-bookmark) 'xetla-bookmarks) (define-key map xetla-keyvec-inventory 'xetla-pop-to-inventory) (define-key map xetla-keyvec-quit 'xetla-buffer-quit) (define-key map xetla-keyvec-add-bookmark 'xetla-revision-bookmarks-add) map) "Keymap used in `xetla-revision-list-mode' buffers.") (defstruct (xetla-revision) revision ;; The revision, as a list summary creator date merges ;; List of patches merged by this revision merged-by ;; List of patches merging this revision ) (defvar xetla-revision-revision-map (let ((map (copy-keymap xetla-context-map-template))) (define-key map [button2] 'xetla-revision-show-changeset-by-mouse) map) "Keymap used on revisions in `xetla-revision-list-mode' buffers.") ;; ;; Changes mode ;; (defvar xetla-changes-mode-map (let ((map (copy-keymap diff-mode-shared-map))) (define-key map xetla-keyvec-help 'describe-mode) (define-key map "\C-m" 'xetla-changes-jump-to-change) (define-key map [return] 'xetla-changes-jump-to-change) (define-key map [?=] 'xetla-changes-diff) (define-key map xetla-keyvec-ediff 'xetla-changes-ediff) (define-key map xetla-keyvec-refresh 'xetla-generic-refresh) (define-key map xetla-keyvec-commit 'xetla-changes-edit-log) (define-key map [?I] 'xetla-inventory) (define-key map xetla-keyvec-inventory 'xetla-pop-to-inventory) (define-key map xetla-keyvec-next 'xetla-changes-next) (define-key map xetla-keyvec-previous 'xetla-changes-prev) (define-key map xetla-keyvec-revert 'xetla-changes-revert) (define-key map xetla-keyvec-quit 'xetla-buffer-quit) (define-key map [?d] 'xetla-changes-rm) (define-key map xetla-keyvec-mark 'xetla-changes-mark-file) (define-key map xetla-keyvec-unmark 'xetla-changes-unmark-file) (define-key map [?v] 'xetla-changes-view-source) (define-key map xetla-keyvec-parent 'xetla-changes-master-buffer) (define-key map [?j] 'xetla-changes-diff-or-list) ;; Buffers group (define-key map (xetla-prefix-buffer ?p) 'xetla-show-process-buffer) (define-key map (xetla-prefix-buffer ?L) 'xetla-open-internal-log-buffer) (define-key map (xetla-prefix-buffer xetla-key-show-bookmark) 'xetla-bookmarks) map) "Keymap used in `xetla-changes-mode'.") (defvar xetla-changes-file-map (let ((map (copy-keymap xetla-context-map-template))) (define-key map [button2] 'xetla-changes-jump-to-change-by-mouse) map) "Keymap used on files in `xetla-changes-mode' buffers.") ;; ;; ChangeLog mode section ;; (defvar xetla-changelog-mode-map (let ((map (copy-keymap change-log-mode-map))) (define-key map xetla-keyvec-quit 'xetla-buffer-quit) map) "Keymap used in `xetla-changelog-mode'.") ;; ;; Log buffer mode section ;; (defvar xetla-log-buffer-mode-map (let ((map (make-sparse-keymap))) (define-key map xetla-keyvec-help 'describe-mode) (define-key map [?o] 'xetla-switch-to-output-buffer) (define-key map "\C-m" 'xetla-switch-to-output-buffer) (define-key map [?e] 'xetla-switch-to-error-buffer) (define-key map [?r] 'xetla-switch-to-related-buffer) (define-key map [?n] 'xetla-log-next) (define-key map [?p] 'xetla-log-prev) (define-key map xetla-keyvec-quit 'xetla-buffer-quit) map) "Keymap used in XEtla's log buffer.") ;; ;; Process buffer mode section ;; (defvar xetla-process-buffer-mode-map (let ((map (make-sparse-keymap))) (define-key map (xetla-prefix-buffer ?L) 'xetla-open-internal-log-buffer) (define-key map xetla-keyvec-inventory 'xetla-show-inventory-buffer) (define-key map xetla-keyvec-quit 'xetla-buffer-quit) map) "Keymap used in XEtla's log buffer.") ;; ;; Log edit buffer mode section ;; (defvar xetla-log-edit-keywords-mode-map (let ((map (make-sparse-keymap))) (define-key map [?n] 'xetla-log-edit-keywords-next) (define-key map [?p] 'xetla-log-edit-keywords-previous) (define-key map [?m] 'xetla-log-edit-keywords-mark) (define-key map [?u] 'xetla-log-edit-keywords-unmark) (define-key map [?t] 'xetla-log-edit-keywords-toggle-mark) (define-key map [?* ?!] 'xetla-log-edit-keywords-unmark-all) (define-key map [?* ?*] 'xetla-log-edit-keywords-mark-all) (define-key map "\C-c\C-c" 'xetla-log-edit-keywords-insert) map) "Keymap used in xetla-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 xetla-.arch-inventory-menu-list '("Put to .arch-inventory" ["Junk" xetla-generic-add-to-junk t] ["Backup" xetla-generic-add-to-backup t] ["Precious" xetla-generic-add-to-precious t] ["Unrecognized" xetla-generic-add-to-unrecognized t])) (defconst xetla-=tagging-method-menu-list '("Put to =tagging-method" ["Junk" (xetla-generic-add-to-junk t) t] ["Backup" (xetla-generic-add-to-backup t) t] ["Precious" (xetla-generic-add-to-precious t) t] ["Unrecognized" (xetla-generic-add-to-junk t) t])) ;; ;; Global ;; (easy-menu-add-item (or (xetla-do-in-gnu-emacs menu-bar-tools-menu) nil) (or (xetla-do-in-xemacs '("Tools")) nil) '("XEtla" ["Browse Archives" xetla-archives t] ["Show Bookmarks" xetla-bookmarks t] ["Start New Project" xetla-start-project t] "--" "Tree Commands:" ["View Changes" xetla-changes t] ["View Inventory" xetla-inventory t] ["View Tree Lint" xetla-tree-lint t] ["Show Tree Revisions" xetla-tree-revisions t] ["Edit Arch Log" xetla-edit-log t] "--" "File Commands:" ["Insert Arch Tag" xetla-tag-insert t] ["Add Log Entry" xetla-add-log-entry t] ["View File Diff" xetla-file-diff t] ["View File Ediff" xetla-file-ediff t] ["View Original" xetla-file-view-original t] ["View Conflicts" xetla-view-conflicts t] "--" ("Quick Configuration" ["Three Way Merge" xetla-toggle-three-way-merge :style toggle :selected xetla-three-way-merge] ["Use --forward" xetla-toggle-use-forward-option :style toggle :selected xetla-use-forward-option] ["Use --skip-present" xetla-toggle-use-skip-present-option :style toggle :selected xetla-use-skip-present-option] ) ) "PCL-CVS") ;; ;; Bookmarks mode ;; (defconst xetla-bookmarks-entry-menu-list '("Bookmark Entry" ["Delete" xetla-bookmarks-delete t] ["Goto Location" xetla-bookmarks-goto t] ("File Tree" ["Find File" xetla-bookmarks-find-file t] ["Run Dired" xetla-bookmarks-open-tree t] ["Run Inventory" xetla-bookmarks-inventory t] ["View Changes" xetla-bookmarks-changes t] ) ("Merge" ["View Missing Patches" xetla-bookmarks-missing t] ["Replay" xetla-bookmarks-replay t] ["Update" xetla-bookmarks-update t] ["Star-merge" xetla-bookmarks-star-merge t] ) ("Edit" ["Edit Bookmark" xetla-bookmarks-edit t] ["Add Nickname" xetla-bookmarks-add-nickname-interactive t] ["Remove Nickname" xetla-bookmarks-delete-nickname-interactive t] ["Add Local Tree" xetla-bookmarks-add-tree-interactive t] ["Remove Local Tree" xetla-bookmarks-delete-tree-interactive t] ["Add Group" xetla-bookmarks-add-group-interactive t] ["Remove Group" xetla-bookmarks-delete-group-interactive t] ["Add Partner" xetla-bookmarks-add-partner-interactive t] ["Remove Partner" xetla-bookmarks-delete-partner-interactive t] ) ("Partners" ["Add Partner" xetla-bookmarks-add-partner-interactive t] ["Remove Partner" xetla-bookmarks-delete-partner-interactive t] ["Write to Partner File" xetla-bookmarks-write-partners-to-file t] ["Load from Partner File" xetla-bookmarks-add-partners-from-file t] ["View Missing Patches" xetla-bookmarks-missing t] )) "Used both for the local and the global menu." ) (easy-menu-define xetla-bookmarks-mode-menu xetla-bookmarks-mode-map "`xetla-bookmarks-mode' menu" `("XEtla-Bookmarks" ["Add Bookmark" xetla-bookmarks-add t] ["Show Details" xetla-bookmarks-toggle-details :style toggle :selected xetla-bookmarks-show-details] ["Select by Group" xetla-bookmarks-select-by-group t] ["Cleanup 'local-tree fields" xetla-bookmarks-cleanup-local-trees t] ,xetla-bookmarks-entry-menu-list )) (easy-menu-define xetla-bookmarks-entry-menu nil "Menu used on a xetla bookmark entry." xetla-bookmarks-entry-menu-list) ;; ;; Inventory mode ;; (easy-menu-define xetla-inventory-mode-partners-menu xetla-inventory-mode-map "`xetla-inventory-mode' partners menu" '("Partners" ["Add Partner..." xetla-partner-add t] ("Set Tree Version" :filter (lambda (x) (xetla-partner-create-menu 'xetla-generic-set-tree-version))) "--" ("Show Changes" :filter (lambda (x) (xetla-partner-create-menu '(lambda (x) (xetla-changes current-prefix-arg (list 'revision (xetla-name-split x))))))) ("Show Missing" :filter (lambda (x) (xetla-partner-create-menu '(lambda (x) (xetla-missing default-directory x))))) "--" ("Replay" :filter (lambda (x) (xetla-partner-create-menu 'xetla-inventory-replay))) ("Star-merge" :filter (lambda (x) (xetla-partner-create-menu 'xetla-inventory-star-merge))))) (defconst xetla-inventory-item-menu-list `("Inventory Item" ["Open File" xetla-inventory-find-file t] ["Redo" xetla-inventory-redo (xetla-inventory-maybe-undo-directory)] "--" ["Add" xetla-inventory-add-files t] ["Move" xetla-inventory-move t] ["Remove" xetla-inventory-remove-files t] ["Delete" xetla-inventory-delete-files t] "--" ["Make Junk" xetla-inventory-make-junk t] ["Make Precious" xetla-inventory-make-precious t] ,xetla-.arch-inventory-menu-list ,xetla-=tagging-method-menu-list) "Used both in the context and the global menu for inventory.") (easy-menu-define xetla-inventory-mode-menu xetla-inventory-mode-map "`xetla-inventory-mode' menu" `("Inventory" ["Edit Log" xetla-inventory-edit-log t] "--" ["Show Changes" xetla-inventory-changes t] ["Show Changelog" xetla-changelog t] ["Show Logs" xetla-logs t] ["Show Missing" xetla-inventory-missing t] "--" ,xetla-inventory-item-menu-list "--" ["Update" xetla-inventory-update t] ["Replay" xetla-inventory-replay t] ["Star-merge" xetla-inventory-star-merge t] ("Changesets" ["Save actual changes in directory" xetla-changes-save t] ["Save actual changes in tarball" xetla-changes-save-as-tgz t] ["View changeset from directory" xetla-show-changeset t] ["View changeset from tarball" xetla-show-changeset-from-tgz t] ["Apply changeset from directory" xetla-inventory-apply-changeset t] ["Apply changeset from tarball" xetla-inventory-apply-changeset-from-tgz t] ) "--" ["Undo" xetla-inventory-undo t] ["Redo" xetla-inventory-redo t] "--" ["Synchronize Mirror" xetla-inventory-mirror t] ("Taging Method" ["Edit .arch-inventory" xetla-edit-.arch-inventory-file t] ["Edit =tagging-method" xetla-edit-=tagging-method-file t] ["Set Tagging Method" xetla-generic-set-id-tagging-method t] ["Set Tree Version From Scratch" xetla-generic-set-tree-version t] ) ["Tree-lint" xetla-tree-lint t] "--" ("Toggles" ["Set All Toggle Variables" xetla-inventory-set-all-toggle-variables t] ["Reset All Toggle Variables" xetla-inventory-reset-all-toggle-variables t] ["Toggle All Toggle Variables" xetla-inventory-toggle-all-toggle-variables t] . ,(mapcar '(lambda (elem) `[,(concat "Toggle " (car (cddddr elem))) ,(caddr elem) :style toggle :selected ,(cadr elem)]) xetla-inventory-file-types-manipulators)))) (easy-menu-define xetla-inventory-item-menu nil "Menu used on a inventory item." xetla-inventory-item-menu-list) (easy-menu-define xetla-inventory-tagging-method-menu nil "Menu used on the taggine method line in a inventory buffer." '("Switch Taggine Method" ["Tagline" (xetla-generic-set-id-tagging-method "tagline") t] ["Explicit" (xetla-generic-set-id-tagging-method "explicit") t] ["Names" (xetla-generic-set-id-tagging-method "names") t] ["Implicit" (xetla-generic-set-id-tagging-method "implicit") t])) ;; ;; Cat-log mode ;; (easy-menu-define xetla-cat-log-mode-menu xetla-cat-log-mode-map "'xetla-cat-log-mode' menu" '("Cat-Log" ["Inventory" xetla-pop-to-inventory t] ["Quit" xetla-buffer-quit t] )) ;; ;; Log edit mode ;; (easy-menu-define xetla-log-edit-mode-menu xetla-log-edit-mode-map "`xetla-log-edit-mode' menu" '("Log" ["Insert xetla log-for-merge" xetla-log-edit-insert-log-for-merge t] ["log-for-merge and headers" xetla-log-edit-insert-log-for-merge-and-headers t] ["Insert memorized log" xetla-log-edit-insert-memorized-log t] ["Show changes" xetla-changes t] ["Commit" xetla-log-edit-done t] ["Show Changelog" xetla-changelog t] ["Goto Summary Field" xetla-log-goto-summary t] ["Goto Body" xetla-log-goto-body t] ["Edit Keywords Field" xetla-log-edit-keywords t] ["Kill Body" xetla-log-kill-body t] ["Tree Lint" xetla-tree-lint t] ["Abort" xetla-log-edit-abort t])) ;; ;; Archive list mode ;; (easy-menu-define xetla-archive-list-mode-menu xetla-archive-list-mode-map "`xetla-archive-list-mode' menu" '("Archives" ["Register New Archive" xetla-register-archive t] ["Add a Bookmark" xetla-bookmarks-add t] ["Update Archives List" xetla-archives t] ["Set Default Archive" xetla-archive-select-default t] ["Remove Archive Registration" xetla-archive-unregister-archive t] ["Edit Archive Location" xetla-archive-edit-archive-location t] ["Make New Archive..." xetla-make-archive t] ["Create a Mirror" xetla-archive-mirror-archive t] ["Use as default Mirror" xetla-archive-use-as-default-mirror t] ["Synchronize Mirror" xetla-archive-synchronize-archive t] )) ;; ;; Category list mode ;; (easy-menu-define xetla-category-list-mode-menu xetla-category-list-mode-map "`xetla-category-list-mode' menu" '("Categories" ["List Archives" xetla-archives t] ["Update Categories List" xetla-category-refresh t] ["Make New Category..." xetla-category-make-category t] ["Add a Bookmark" xetla-bookmarks-add t] ["Synchronize Mirror" xetla-category-mirror-archive t] )) ;; ;; Branch list mode ;; (easy-menu-define xetla-branch-list-mode-menu xetla-branch-list-mode-map "`xetla-branch-list-mode' menu" '("Branches" ["Update Branches List" xetla-branch-refresh t] ["List Parent Category" xetla-branch-list-parent-category t] ["Make New Branch..." xetla-branch-make-branch t] ["Synchronize Mirror" xetla-branch-mirror-archive t] ["Bookmark Branch under Point" xetla-branch-bookmarks-add t] ["Get..." xetla-branch-get-branch t] )) ;; ;; Version list mode ;; (easy-menu-define xetla-version-list-mode-menu xetla-version-list-mode-map "`xetla-version-list-mode' menu" '("Versions" ["Update Versions List" xetla-version-refresh t] ["Get..." xetla-version-get-version t] ["Make New Version..." xetla-version-make-version t] ["List Parent Branch" xetla-version-list-parent-branch t] ["Synchronize Mirror" xetla-version-mirror-archive t] ["Bookmark Version under Point" xetla-version-bookmarks-add t] ["Tag This Version" xetla-version-tag t])) ;; ;; Revision list mode ;; (easy-menu-define xetla-revision-list-mode-menu xetla-revision-list-mode-map "`xetla-revision-list-mode' menu" '("Revisions" ["Refresh Revisions List" xetla-generic-refresh t] ["List Parent Version" xetla-revision-list-parent-version t] "--" ["Bookmark Revision under Point" xetla-revision-bookmarks-add t] ("Mark" ["Mark Revision" xetla-revision-mark-revision t] ["Unmark Revision" xetla-revision-unmark-revision t]) "--" ["Show Log" xetla-revision-cat-log t] ["Unify Patch Logs with This Revision" xetla-revision-sync-tree t] ["View changeset" xetla-revision-changeset t] ("Delta" ["View" (xetla-revision-delta t) t] ["Store to Directory" (xetla-revision-store-delta t) t]) "--" ["Update" xetla-revision-update t] ("Replay" ["From Head Revision" xetla-revision-replay-version t] ["From Revision under Point" xetla-revision-replay t]) ("Star-Merge" ["From Head Revision" xetla-revision-star-merge-version t] ["From Revision under Point" xetla-revision-star-merge t]) ("Get" ["Get a Local Copy" xetla-revision-get-revision t] ["Make Cache" xetla-revision-cache-revision t] ["Add to Library" xetla-revision-add-to-library t]) ("Tag " ["From Head Revision" xetla-revision-tag-from-head t] ["From Revision under Point" xetla-revision-tag-from-here t]) ["Send comment to author" xetla-revision-send-comments t] "--" ("Filter Display" ["Date" xetla-revision-toggle-date :style toggle :selected xetla-revisions-shows-date] ["Creator" xetla-revision-toggle-creator :style toggle :selected xetla-revisions-shows-creator] ["Summary" xetla-revision-toggle-summary :style toggle :selected xetla-revisions-shows-summary] ["Presence in Revlib" xetla-revision-toggle-library :style toggle :selected xetla-revisions-shows-library] ["Merged Patches" xetla-revision-toggle-merges :style toggle :selected xetla-revisions-shows-merges] ["Patches Merging ..." xetla-revision-toggle-merged-by :style toggle :selected xetla-revisions-shows-merged-by]))) (easy-menu-define xetla-revision-revision-menu nil "Menu used on a revision item in `xetla-revision-list-mode' buffer" '("Revision" ["Show Log" xetla-revision-cat-log t] ["Unify Patch Logs with This Revision" xetla-revision-sync-tree t] ["View changeset" xetla-revision-changeset t] ["Set Bookmark" xetla-revision-bookmarks-add t] ("Mark" ["Mark Revision" xetla-revision-mark-revision t] ["Unmark Revision" xetla-revision-unmark-revision t]) ("Delta" ["In This Version" xetla-revision-delta t] ["With Revision in Another Archive" xetla-revision-store-delta t]) ("Merge" ["Star-Merge" xetla-revision-star-merge t] ["Replay" xetla-revision-replay t]) ("Get" ["Get a Local Copy" xetla-revision-get-revision t] ["Make Cache" xetla-revision-cache-revision t] ["Add to Library" xetla-revision-add-to-library t]) ["Send comment to author" xetla-revision-send-comments t] ["Tag from Here" xetla-revision-tag-from-here])) ;; ;; Changes mode ;; (defconst xetla-changes-file-menu-list '("File Changes" ["Jump to File" xetla-changes-jump-to-change t] ["Jump to Diffs" xetla-changes-diff-or-list t] ["View Diff in Separate Buffer" xetla-changes-diff t] ["View Diff with Ediff" xetla-changes-ediff t] "--" ["Delete File" xetla-changes-rm t] ["Revert File" xetla-changes-revert t] ) "Used both in the global and the context menu of `xetla-changes-mode'.") (easy-menu-define xetla-changes-mode-menu xetla-changes-mode-map "`xetla-changes' menu" `("Changes" ["Refresh Buffer" xetla-generic-refresh t] ["Edit log before commit" xetla-changes-edit-log t] ["View other revisions" xetla-tree-revisions t] ,xetla-changes-file-menu-list )) (easy-menu-define xetla-changes-file-menu nil "Menu used on a `xetla-changes' file" xetla-changes-file-menu-list) ;; ;; Lint mode ;; (defconst xetla-tree-lint-file-menu-list `("File" ["Jump to File" xetla-generic-find-file-at-point t] ("Mark" ["Mark File" xetla-tree-lint-mark-file t] ["Unmark File" xetla-tree-lint-unmark-file t]) "--" ["Add File" xetla-tree-lint-add-files t] ["Delete File" xetla-tree-lint-delete-files t] ["Regenerate ID" xetla-tree-lint-regenerate-id t] "--" ["Make Junk" xetla-tree-lint-make-junk t] ["Make Precious" xetla-tree-lint-make-precious t] ,xetla-.arch-inventory-menu-list ,xetla-=tagging-method-menu-list ) "Used both for context and global menu.") (easy-menu-define xetla-tree-lint-file-menu nil "Menu used on files listed in `xetla-tree-lint'" xetla-tree-lint-file-menu-list ) (easy-menu-define xetla-tree-lint-mode-menu xetla-tree-lint-mode-map "`xetla-tree-lint' menu" `("Tree Lint" ["Refresh Buffer" xetla-generic-refresh t] ,xetla-tree-lint-file-menu-list )) ;; ;; Event Log buffer ;; (easy-menu-define xetla-log-buffer-mode-menu xetla-log-buffer-mode-map "`xetla-log-buffer' menu" '("Logs" ["Show Related Buffer" xetla-switch-to-related-buffer t] ["Show Output Buffer" xetla-switch-to-output-buffer t] ["Show Error Buffer" xetla-switch-to-error-buffer t] ))  ;; -------------------------------------- ;; User customization section ;; -------------------------------------- (defgroup xetla nil "Arch interface for emacs." :group 'tools :prefix "xetla-") (defgroup xetla-inventory nil "This group contains items used in inventory mode." :group 'xetla) (defgroup xetla-revisions nil "This group contains items used in revisions mode." :group 'xetla) (defgroup xetla-file-actions nil "This group contains items manipulating finding, saving and reverting files." :group 'xetla) (defgroup xetla-bindings nil "This group contains items related to key bindings." :group 'xetla) (defgroup xetla-faces nil "This group contains faces defined for Xetla." :group 'xetla) (defcustom xetla-prefix-key [(control x) ?T] "Prefix key for most xetla commands." :type '(choice (const [(control x) ?T]) (const [(control x) ?t]) (const [(control x) ?v]) (const [(control x) ?V]) (const [(control x) ?v ?t]) (sexp)) :group 'xetla-bindings :set (lambda (var value) (if (boundp var) (global-unset-key (symbol-value var))) (set var value) (global-set-key (symbol-value var) xetla-global-keymap))) (global-set-key xetla-prefix-key xetla-global-keymap) (defcustom xetla-tla-executable "tla" "*The name of the xetla executable." :type 'string :group 'xetla) (defcustom xetla-diff-executable "diff" "*The name of the diff executable." :type 'string :group 'xetla) (defcustom xetla-patch-executable "patch" "*The name of the patch executable." :type 'string :group 'xetla) (defcustom xetla-highlight t "*Use highlighting for XEtla buffers." :type 'boolean :group 'xetla) (defcustom xetla-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 'xetla) (defcustom xetla-do-not-prompt-for-save nil "*Whether or not xetla will prompt before saving. If non nil, xetla will not prompt you before saving buffers of the working local tree." :type 'boolean :group 'xetla-file-actions) (defcustom xetla-automatically-revert-buffers t "*Whether or not xetla will automatically revert buffers. If non nil, xetla will automatically revert unmodified buffers after an arch operation modifying the file." :type 'boolean :group 'xetla-file-actions) (defcustom xetla-changes-recursive t "*Whether or not xetla will compute changes recursively. If non nil, `xetla-changes' will be applied recursively to subprojects of the current tree" :type 'boolean :group 'xetla) (defcustom xetla-strict-commits nil "*If non-nil, commit operations are invoked with the -strict option." :type 'boolean :group 'xetla) (defcustom xetla-commit-check-log-buffer-functions '(xetla-commit-check-empty-headers xetla-commit-check-empty-line xetla-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 'xetla) (defcustom xetla-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 'xetla) (defcustom xetla-commit-fix-missing-space t "*Whether or not xetla 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 'xetla) (defcustom xetla-three-way-merge t "*If non-nil, star-merge operations are invoked with -three-way." :type 'boolean :group 'xetla) (defcustom xetla-use-forward-option nil "*If non-nil, use the -forward option with commands that allow it." :type 'boolean :group 'xetla) (defcustom xetla-use-skip-present-option nil "*If non-nil, use -skip-present with commands that allow it." :type 'boolean :group 'xetla) (defun xetla-toggle-use-forward-option () "Toggle the value of `xetla-use-forward-option'." (interactive) (setq xetla-use-forward-option (not xetla-use-forward-option))) (defun xetla-toggle-use-skip-present-option () "Toggle the value of `xetla-use-skip-present-option'." (interactive) (setq xetla-use-skip-present-option (not xetla-use-skip-present-option))) (defun xetla-toggle-three-way-merge () "Toggle the value of `xetla-three-way-merge'." (interactive) (setq xetla-three-way-merge (not xetla-three-way-merge))) (defgroup xetla-bookmarks nil "xetla bookmarks allows you to save places (archive, category, branch, version) in the archive that you use often. Try M-x xetla-bookmarks RET to see." :group 'xetla) (defcustom xetla-bookmarks-file-name "bookmarks.el" "*File in which xetla bookmarks will be saved. The bookmark file is stored in the `xetla-config-directory'" :type 'file :group 'xetla-bookmarks) (defcustom xetla-tag-function 'xetla-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 xetla-tag-uuid) (const xetla-tag-name-date-filename) function) :group 'xetla) (defcustom xetla-config-directory "~/.xetla/" "*Directory in which the xetla config files will be stored." :type 'directory :group 'xetla) (defcustom xetla-log-library "~/.arch-log-library/" "*Directory in which the log library will be stored." :type 'directory :group 'xetla-internal) (defcustom xetla-log-library-greedy t "*Whether log files are automatically saved in the log library. If non-nil, then, whenever xetla needs to access a log file, this file will be copied to the log library." :type 'boolean :group 'xetla-internal) (defcustom xetla-cache-xetla-get-changeset 2 "*Cache `xetla-get-changeset' calls. When nil, don't cache. When a number, cache only if the `xetla-get-changeset' call takes more seconds than the number. Otherwise don't cache the results. The cache is kept only in RAM." :type 'integer :group 'xetla) (defcustom xetla-bookmarks-cleanup-dont-prompt nil "*Whether xetla should prompt before cleaning a local tree. non nil means `xetla-bookmarks-cleanup-local-trees' shouldn't prompt before removing a local-tree" :type 'boolean :group 'xetla-bookmarks) (defgroup xetla-internal nil "This group contains items used mainly for debugging." :group 'xetla) (defcustom xetla-log-commands t "*Non nil means log all xetla commands in the buffer *xetla-log*." :type 'boolean :group 'xetla-internal) (defcustom xetla-log-buffer " *xetla-log*" "*Name of the buffer in which xetla logs main events." :type 'string :group 'xetla-internal) (defcustom xetla-switch-to-buffer-mode 'pop-to-buffer "*Mode for switching to xetla 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 'xetla) (defcustom xetla-switch-to-changes-buffer nil "Switch to the changes buffer or stay in the current buffer." :type 'boolean :group 'xetla) (defcustom xetla-read-project-tree-mode 'sometimes "*Mode for prompting project tree directories. Possible values are: - always: When running a tla command requiring a tree, always prompt for it. - sometimes: If a command is ran 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. Othwise, raise an error." :type '(choice (const always) (const sometimes) (const never)) :group 'xetla) (defcustom xetla-read-directory-mode 'sometimes "*How prompting project directories should be done. Works similarly to `xetla-read-project-tree-mode', but this one is used for commands like `xetla-inventory' for which a subdirectory of a project tree is accepted." :type '(choice (const always) (const sometimes) (const never)) :group 'xetla) (defcustom xetla-switch-to-buffer-first t "*Switch to newly created buffer on creation of buffers? If non-nil, xetla 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, xetla will switch to the new buffer on command completion." :type 'boolean :group 'xetla) (defcustom xetla-buffer-quit-mode 'kill "*How *xetla-...* buffer should be killed. If the value is 'kill, buffers are actually killed. Otherwise, just burry them." :type '(choice (const kill) (const burry)) :group 'xetla) (defcustom xetla-log-insert-last t "*If non-nil, insert changelog entries at the end of the log file." :type 'boolean :group 'xetla) (defgroup xetla-hooks nil "This group contains hooks into xetla." :prefix "xetla-" :group 'xetla) (defcustom xetla-archive-list-mode-hook nil "*Hooks run after switching to `xetla-archive-list-mode'." :type 'hook :group 'xetla-hooks) (defcustom xetla-bookmarks-mode-hook nil "*Hooks run after switching to `xetla-bookmarks-mode'." :type 'hook :group 'xetla-hooks) (defcustom xetla-branch-list-mode-hook nil "*Hooks run after switching to `xetla-branch-list-mode'." :type 'hook :group 'xetla-hooks) (defcustom xetla-cat-log-mode-hook nil "*Hooks run after switching to `xetla-cat-log-mode'." :type 'hook :group 'xetla-hooks) (defcustom xetla-category-list-mode-hook nil "*Hooks run after switching to `xetla-category-list-mode'." :type 'hook :group 'xetla-hooks) (defcustom xetla-inventory-file-mode-hook nil "*Hooks run after switching to `xetla-inventory-file-mode'." :type 'hook :group 'xetla-hooks) (defcustom xetla-inventory-mode-hook nil "*Hooks run after switching to `xetla-inventory-mode'." :type 'hook :group 'xetla-hooks) (defcustom xetla-log-edit-mode-hook nil "*Hooks run after switching to `xetla-log-edit-mode'." :type 'hook :group 'xetla-hooks) (defcustom xetla-logs-mode-hook nil "*Hooks run after switching to `xetla-logs-mode'." :type 'hook :group 'xetla-hooks) (defcustom xetla-revision-list-mode-hook nil "*Hooks run after switching to `xetla-revision-list-mode'." :type 'hook :group 'xetla-hooks) (defcustom xetla-version-list-mode-hook nil "*Hooks run after switching to `xetla-version-list-mode'." :type 'hook :group 'xetla-hooks) (defcustom xetla-make-branch-hook nil "*Hooks run after making a branch." :type 'hook :group 'xetla-hooks) (defcustom xetla-make-category-hook nil "*Hooks run after making a category." :type 'hook :group 'xetla-hooks) (defcustom xetla-make-version-hook nil "*Hooks run after making a version." :type 'hook :group 'xetla-hooks) (defcustom xetla-make-archive-hook nil "*Hooks run after creating a new archive." :type 'hook :group 'xetla-hooks) (defcustom xetla-name-read-init-hook nil "*Hooks run when the control enters to `xetla-name-read'." :type 'hook :group 'xetla-hooks) (defcustom xetla-name-read-final-hook nil "*Hooks run when the control leaves `xetla-name-read'. The name read by `xetla-name-read' is passed to functions connected to this hook as an argument." :type 'hook :group 'xetla-hooks) (defcustom xetla-name-read-error-hook nil "*Hooks run when an error is occurred in `xetla-name-read'." :type 'hook :group 'xetla-hooks) (defcustom xetla-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 'xetla-file-actions) (defcustom xetla-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 'xetla-file-actions) (defcustom xetla-use-arrow-keys-for-navigation nil "*Enable left/right for navigation. This works best if `xetla-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 `xetla-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 'xetla-bindings) (defcustom xetla-revisions-shows-summary t "*Whether summary should be displayed for `xetla-revisions'." :type 'boolean :group 'xetla-revisions) (defcustom xetla-revisions-shows-creator t "*Whether creator should be displayed for `xetla-revisions'." :type 'boolean :group 'xetla-revisions) (defcustom xetla-revisions-shows-date t "*Whether date should be displayed for `xetla-revisions'." :type 'boolean :group 'xetla-revisions) (defcustom xetla-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 `xetla-revisions'" :type 'boolean :group 'xetla-revisions) (defcustom xetla-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 `xetla-revisions'" :type 'boolean :group 'xetla-revisions) (defcustom xetla-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 `xetla-revisions'" :type 'boolean :group 'xetla-revisions) ;;; FIXME: This should be an alist of keyword . description, and ;;; both the keyword and its description should display in the ;;; *xetla-log-keywords* buffer. (defcustom xetla-log-edit-keywords '("admin" ; Administrative changes "audit" ; Code clean up/audit "bugfix" ; The good ol' bug fix "build/compile" ; Compile-time related "compat" ; Compatibility changes "delete" ; File/dir deletion "docfix" ; More that just a typo "documentation" ; Writing documentation "enhancement" ; Extending existing features "internal" ; Changes that don't affect the user "linting" ; aka "admin", "audit", "whitespace" "merge" ; Merging in changes from other repo "newfeature" ; New features "newfile" ; New file/dir added to the repo "release" ; Changes involved with releases "rename" ; Rename file/dir/function/var etc "revert" ; Revert some previous changes "security" ; Security fixes "sync" ; Synching code (eg GNU/Emacs -> XEmacs) "trivial" ; Tiny fixes/changes "typo" ; Typographic changes "update" ; General updates "ui" ; User-interface related changes "user-visible" ; User-visible changes "warnfix" ; Build or run-time warning fixes "whitespace" ; Whitespace changes ) "A list of keywords for the Keywords field of a log message." :type '(repeat (string)) :group 'xetla) (defcustom xetla-apply-patch-mapping nil "*Tree in which patches should be applied. An alist of rules to match fully qualified revision names to target directories. That variable is used to offer a directory in `xetla-gnus-apply-patch'. Example setting: '(((nil \"xetla\" nil nil nil) \"~/work/xetla/xetla\")))" :type '(repeat (cons :tag "Rule" (cons :tag "Full revision (regexps)" (choice (const nil) (regexp :tag "Archive")) (cons (choice (const nil) (regexp :tag "Category")) (cons (choice (const nil) (regexp :tag "Branch")) (cons (choice (const nil) (regexp :tag "Version")) (cons (choice (const nil) (string :tag "Revision")) (const nil)))))) (cons (string :tag "tree") (const nil)))) :group 'xetla) ;; ;; Tips ;; (defgroup xetla-tips nil "\"Tip of the day\" feature for XEtla" :prefix "xetla-" :group 'xetla) (defcustom xetla-tips-enabled t "*Set this to nil to disable tips." :type 'boolean :group 'xetla-tips) ;; ;; State ;; (defgroup xetla-state nil "Saving XEtla's state between Emacs sessions." :prefix "xetla-" :group 'xetla) (defcustom xetla-state-file-name "state.el" "*File in which xetla saves state variables between Emacs sessions. The file is stored in the `xetla-config-directory'" :type 'file :group 'xetla-state) (defcustom xetla-state-variables-list '(xetla-tips-number) "*List of variables to store in the state file `xetla-state-file-name'." :type '(repeat (symbol)) :group 'xetla-state)  ;; -------------------------------------- ;; Face ;; -------------------------------------- (defface xetla-marked '((((class color) (background dark)) (:foreground "yellow")) (((class color) (background light)) (:foreground "magenta")) (t (:bold t))) "Face to highlight a marked entry in xetla buffers" :group 'xetla-faces) (defface xetla-archive-name '((((class color) (background dark)) (:foreground "lightskyblue1")) (((class color) (background light)) (:foreground "blue4")) (t (:bold t))) "Face to highlight xetla archive names." :group 'xetla-faces) (make-face 'xetla-source-archive-name "Face to highlight xetla source archive names.") (set-face-parent 'xetla-source-archive-name 'xetla-archive-name) (make-face 'xetla-mirror-archive-name "Face to highlight xetla mirror archive names.") (set-face-parent 'xetla-mirror-archive-name 'xetla-archive-name) (make-face 'xetla-category-name "Face to highlight xetla category names.") (set-face-parent 'xetla-category-name 'xetla-archive-name) (make-face 'xetla-branch-name "Face to highlight xetla branch names.") (set-face-parent 'xetla-branch-name 'xetla-archive-name) (make-face 'xetla-version-name "Face to highlight xetla version names.") (set-face-parent 'xetla-version-name 'xetla-archive-name) (make-face 'xetla-revision-name "Face to highlight xetla revision names.") (set-face-parent 'xetla-revision-name 'xetla-archive-name) (make-face 'xetla-local-directory "Face to highlight xetla local directory.") (set-face-parent 'xetla-local-directory 'xetla-archive-name) (make-face 'xetla-buffer "Face to highlight buffer names printed in xetla's buffer.") (set-face-parent 'xetla-buffer 'xetla-archive-name) (make-face 'xetla-tagging-method "Face to highlight taggine methods.") (set-face-parent 'xetla-tagging-method 'xetla-archive-name) (make-face 'xetla-id "Face to highlight an arch id.") (set-face-parent 'xetla-id 'font-lock-keyword-face) (defface xetla-separator '((((class color) (background dark)) (:underline t :bold t)) (((class color) (background light)) (:underline t :bold t))) "Face to highlight separators." :group 'xetla-faces) (make-face 'xetla-keyword "Face to highlight keywords.") (set-face-parent 'xetla-keyword 'font-lock-keyword-face) (make-face 'xetla-comment "Face to highlight comments.") (set-face-parent 'xetla-comment 'font-lock-comment-face) (make-face 'xetla-precious "Face to highlight precious entries") (set-face-parent 'xetla-precious 'font-lock-comment-face) (make-face 'xetla-unrecognized "Face to highlight unrecognized entries") (set-face-parent 'xetla-unrecognized 'font-lock-warning-face) (make-face 'xetla-duplicate "Face to highlight files with duplicate IDs") (set-face-parent 'xetla-duplicate 'font-lock-warning-face) (make-face 'xetla-source "Face to highlight source code entries") (set-face-parent 'xetla-source 'font-lock-string-face) (make-face 'xetla-junk "Face to highlight junk entries") (set-face-parent 'xetla-junk 'font-lock-function-name-face) (make-face 'xetla-nested-tree "Face to highlight nested trees") (set-face-parent 'xetla-nested-tree 'font-lock-type-face) (make-face 'xetla-to-add "Face to highlight a file that should probably be added to the archive.") (set-face-parent 'xetla-to-add 'font-lock-comment-face) (make-face 'xetla-broken-link "Face to highlight a broken link") (set-face-parent 'xetla-broken-link 'font-lock-warning-face) (make-face 'xetla-unmerged "Face to highlight unmerged patches") (set-face-parent 'xetla-unmerged 'font-lock-keyword-face) (make-face 'xetla-header "Face to highlight header in log mode for example") (set-face-parent 'xetla-header 'font-lock-function-name-face) (make-face 'xetla-conflict "Face to highlight conflicts") (set-face-parent 'xetla-conflict 'font-lock-warning-face) (make-face 'xetla-modified "Face to highlight modified files") (set-face-parent 'xetla-modified 'font-lock-function-name-face) (make-face 'xetla-move "Face to highlight moved files/directory") (set-face-parent 'xetla-move 'font-lock-function-name-face) (make-face 'xetla-deleted "Face to highlight deleted files") (set-face-parent 'xetla-deleted 'font-lock-warning-face) (make-face 'xetla-added "Face to highlight added files") (set-face-parent 'xetla-added 'font-lock-warning-face) (make-face 'xetla-meta-info "Face to highlight files with meta-info changes") (set-face-parent 'xetla-meta-info 'font-lock-comment-face) (make-face 'xetla-messages "Face to highlight messages in xetla buffers") (set-face-parent 'xetla-messages 'font-lock-function-name-face) (defface xetla-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 'xetla-faces) (defface xetla-mark '((((class color) (background dark)) (:foreground "green" :bold t)) (((class color) (background light)) (:foreground "green3" :bold t)) (t (:bold t))) "Xetla face used to highlight marked file indicator." :group 'xetla-faces)  ;; -------------------------------------- ;; Font lock keywords ;; -------------------------------------- ;; ;; Inventory file mode ;; (defvar xetla-inventory-file-font-lock-keywords '( ("^#.*$" . xetla-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 xetla-inventory-file mode.") ;; ;; Logs mode ;; (defvar xetla-logs-font-lock-keywords '(("^[^ \t]*\\(base\\|patch\\|version\\(fix\\)?\\)-[0-9]+" . font-lock-function-name-face)) "Keywords in xetla-logs-mode.") ;; ;; Changes mode ;; (defvar xetla-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) ("^ +-?-/ .*$" . xetla-meta-info) ("^ +- .*$" . xetla-meta-info) ("^ *T. .*$" . xetla-nested-tree)) diff-font-lock-keywords) "Keywords in `xetla-changes' mode.") ;; ;; ChangeLog mode ;; (defvar xetla-changelog-font-lock-keywords '((" \\([^ ].+:\\)\n\\(.*$\\)" (1 'xetla-keyword) (2 'change-log-acknowledgement-face)) ("\t\\(patch-[0-9]+\\)" (1 'xetla-keyword)) ("^#.*$" . xetla-comment) ("^\\sw.........[0-9:+ ]* GMT" (0 'change-log-date-face) ("\\([^<(]+?\\)[ \t]*[(&lt;]\\([A-Za-z0-9_.-]+(a)[A-Za-z0-9_.-]+\\)[&gt;)]&quot; nil nil (1 'change-log-name-face) (2 'change-log-email-face))) ("^.*\\* \\([^ ,:([\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))) ("^.*(\\([^) ,:\n]+\\)" (1 'change-log-list-face) ("\\=, *\\([^) ,:\n]+\\)" nil nil (1 'change-log-list-face))) ("\\[!?\\([^]\n]+\\)\\]\\(:\\| (\\)" (1 'change-log-conditionals-face)) ("<\\([^>\n]+\\)>\\(:\\| (\\)" (1 'change-log-function-face)) ("\\(^.*\\| \\)\\(From\\|Patch\\(es\\)? by\\|Report\\(ed by\\| from\\)\\|Suggest\\(ed by\\|ion from\\)\\)" 2 'change-log-acknowledgement-face)) "Keywords in `xetla-changelog' mode.") ;; ;; Log edit mode ;; (defvar xetla-log-edit-font-lock-keywords (append '(("^\\(Summary\\|Keywords\\): \\(.*$\\)" (1 'xetla-header) (2 'change-log-conditionals-face))) xetla-changelog-font-lock-keywords) "Keywords in xetla-log-edit mode.") ;; ;; Cat-Log mode ;; (defvar xetla-cat-log-font-lock-keywords (append '(("^\\(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\\): \\(.*$\\)" (1 'xetla-header) (2 'change-log-conditionals-face))) xetla-changelog-font-lock-keywords) "Keywords in `xetla-cat-log-mode'.") ;; ;; Tips mode ;; (defvar xetla-tips-mode-map (let ((map (make-sparse-keymap))) (define-key map xetla-keyvec-quit 'xetla-buffer-quit) (define-key map xetla-keyvec-next 'xetla-tips-next-tip) (define-key map xetla-keyvec-previous 'xetla-tips-previous-tip) (define-key map [?c] 'xetla-tips-customize) map))  ;; -------------------------------------- ;; Auto-mode-alist entries ;; -------------------------------------- ;;;###autoload(add-to-list 'auto-mode-alist '("/\\(=tagging-method\\|\\.arch-inventory\\)$" . xetla-inventory-file-mode)) ;; -------------------------------------- ;; Hooks into other packages and/or functions ;; -------------------------------------- ;; ;; ediff ;; (defvar xetla-ediff-keymap (copy-keymap xetla-global-keymap) "Global keymap used by XEtla in the ediff control buffer.") (define-key xetla-ediff-keymap xetla-keyvec-log-entry 'xetla-ediff-add-log-entry) (add-hook 'ediff-keymap-setup-hook #'(lambda () (define-key ediff-mode-map xetla-prefix-key xetla-ediff-keymap))) ;; ;; find-file ;; (add-hook 'find-file-hooks 'xetla-find-file-hook) ;; -------------------------------------- ;; Enables arrow key navigation for left/right ;; -------------------------------------- (defvar xetla-use-arrow-keys-for-navigation-list '((xetla-inventory-mode-map right 'xetla-inventory-find-file) (xetla-inventory-mode-map left 'xetla-inventory-parent-directory) (xetla-archive-list-mode-map right 'xetla-archive-list-categories) (xetla-archive-list-mode-map left 'xetla-buffer-quit) (xetla-category-list-mode-map right 'xetla-category-list-branches) (xetla-category-list-mode-map left 'xetla-archives) (xetla-branch-list-mode-map right 'xetla-branch-list-versions) (xetla-branch-list-mode-map left 'xetla-branch-list-parent-category) (xetla-version-list-mode-map right 'xetla-version-list-revisions) (xetla-version-list-mode-map left 'xetla-version-list-parent-branch) (xetla-revision-list-mode-map left 'xetla-revision-list-parent-version) (xetla-revision-list-mode-map right 'xetla-revision-show-changeset) (xetla-changes-mode-map left 'xetla-changes-jump-to-change) (xetla-changes-mode-map right 'xetla-changes-view-source) (xetla-changelog-mode-map left 'xetla-buffer-quit) (xetla-process-buffer-mode-map left 'xetla-buffer-quit) (xetla-bookmarks-mode-map right 'xetla-bookmarks-inventory) )) (defun xetla-use-arrow-keys-for-navigation (&optional uninstall) "Bind the left/right keys for navigation. This function will be called automatically if variable `xetla-use-arrow-keys-for-navigation' is non-nil. If argument UNINSTALL is non-nil, undefine the keys instead of defining it." (interactive "P") (let ((bl xetla-use-arrow-keys-for-navigation-list) b (m xetla-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))) (caddr b)))) ((eq t m) (if uninstall (list (vector (cadr b)) nil) (list (vector (cadr b)) (caddr b)))))))) (if uninstall (message "%sleft/right bindings for xetla have been removed." (if (eq 'shift m) "Shifted " "")) (message "%sleft/right bindings for xetla have been installed." (if (eq 'shift m) "Shifted " ""))))) ;; install them if customized (if xetla-use-arrow-keys-for-navigation (xetla-use-arrow-keys-for-navigation)) (provide 'xetla-defs) ;;; xetla-defs.el ends here 1.1 XEmacs/packages/xemacs-packages/xetla/xetla-tips.el Index: xetla-tips.el =================================================================== ;;; xetla-tips.el --- "Tip of the day" feature for XEtla. ;; Copyright (C) 2004 Free Software Foundation, Inc. (GPL) ;; Copyright (C) 2004 Steve Youngs (BSD) ;; Author: Steve Youngs <steve(a)eicq.org&gt; ;; Maintainer: Steve Youngs <steve(a)eicq.org&gt; ;; Created: 2004-11-25 ;; Keywords: arch archive tla ;; Based on xtla-tips.el by: Matthieu Moy <Matthieu.Moy(a)imag.fr&gt; ;; This file is part of XEtla. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; ;; 3. Neither the name of the author nor the names of any contributors ;; may be used to endorse or promote products derived from this ;; software without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR ;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE ;; DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE ;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF ;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR ;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN ;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; Commentary: ;; To raise the learning curve for xetla.el users. Some commands can ;; (optionaly) pop-up a buffer with a tip. Currently, `xetla-commit' ;; does this. ;;; Code: (eval-and-compile (require 'xetla-defs) (require 'xetla)) (defconst xetla-tips-array [ "Welcome to XEtla. 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 `xetla-tips-enabled' to nil. Press q to exit, n to view next tip, p to view previous tip." "For the available xetla commands Xetla provides a corresponding interactive function. Some examples: M-x xetla-inventory ... runs tla inventory M-x xetla-undo ... runs tla undo M-x xetla-changes ... runs tla changes XEtla prompts for the needed parameters." "Most interesting commands are available through a global keyboard shortcut. Try \"C-x T C-h\" to get a list" "XEtla provides several major modes for different buffers. Each mode has its own keybindings. Get help with \"C-h m\"" "When XEtla is loaded, C-M-h in a minibuffer prompt gives you help about the command being run." "When you are prompted for an archive, category, branch, version or revision name, lots of keybindings are available. Get a list with \"C-h\"." "XEtla allows you to manage a list of bookmarks. Try \"C-x T 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 xetla-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 add changelog style comments to your commit log by \"C-x T a\"." "You can enable ispell, flyspell or other useful mode for editing log files by \"M-x customize-variable RET xetla-log-edit-mode-hook RET\"." "By default, XEtla caches any log file you retrieve with `xetla-cat-log' or `xetla-cat-archive-log' in ~/.arch-log-library. This speeds up many XEtla operations. You can disable this by setting `xetla-log-library-greedy' to nil." "XEtla is highly customizable. Start it by \"M-x customize-group RET xetla RET\"." "In an *xetla-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 *xetla-changes* buffer, you can quickly jump from the list of files to the corresponding patch hunk, and come back with \"j\"" "After committing, you can review the last committed patch with \"M-x xetla-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." "Report bugs using M-x xetla-submit-bug-report RET" "You've got a nice, graphical, archive browser one M-x xetla-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. XEtla will enter this mode automatically when you open a file with conflicts. Type M-x xetla-conflicts-finish RET to exit smerge mode and delete the corresponding .rej file." "\"C-x T 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." ] "List of tips. Add more !") (defvar xetla-tips-number 0 "Number of the last tip viewed. Will be saved in state.el") (defun xetla-tips-message-number (number) "Return the message number NUMBER, as a string." (let ((number (mod number (length xetla-tips-array)))) (aref xetla-tips-array number))) (define-derived-mode xetla-tips-mode fundamental-mode "xetla-tips" "Major mode for buffers displaying tip of the day. Commands: \\{xetla-tips-mode-map}" (toggle-read-only 1)) (defun xetla-tips-popup-number (number) "Pops up tip number NUMBER." (let ((message (xetla-tips-message-number number))) (switch-to-buffer (get-buffer-create "*xetla-tip*")) (xetla-tips-mode) (let ((inhibit-read-only t)) (erase-buffer) (insert (xetla-face-add "************************* Did you know? *************************" 'xetla-messages) "\n\n") (insert message) (newline 2) (insert (xetla-face-add "*********************************************************************" 'xetla-messages)) (goto-char (point-min))))) (defun xetla-tips-popup-maybe () "Pop up a buffer with a tip if tips are enabled. see `xetla-tips-enabled'." (when xetla-tips-enabled (xetla-tips-popup))) (defun xetla-tips-popup (&optional direction) "Pop up a buffer with a tip message. Don't use this function from XEtla. Use `xetla-tips-popup-maybe' instead." (interactive) (xetla-load-state) (xetla-tips-popup-number xetla-tips-number) (setq xetla-tips-number (mod (+ xetla-tips-number (or direction 1)) (length xetla-tips-array))) (xetla-save-state)) (defun xetla-tips-next-tip () "Show next tip." (interactive) (xetla-tips-popup 1)) (defun xetla-tips-previous-tip () "Show previous tip." (interactive) (xetla-tips-popup -1)) (eval-when-compile (autoload 'customize-group "cus-edit" nil t)) (defun xetla-tips-customize () "Run customize group for xetla-tips." (interactive) (customize-group 'xetla-tips)) (provide 'xetla-tips) ;;; xetla-tips.el ends here 1.1 XEmacs/packages/xemacs-packages/xetla/xetla-version.el Index: xetla-version.el =================================================================== ;;; Automatically generated file -- DO NOT EDIT OR DELETE ;;;###autoload (defconst xetla-version &quot;steve(a)eicq.org--2005/xetla--main--1.0--version-0&quot;) (provide 'xetla-version) 1.1 XEmacs/packages/xemacs-packages/xetla/xetla.el Index: xetla.el =================================================================== ;;; xetla.el --- Arch (tla) interface for XEmacs ;; Copyright (C) 2003-2004 by Stefan Reichoer (GPL) ;; Copyright (C) 2004 Steve Youngs (BSD) ;; Author: Steve Youngs <steve(a)eicq.org&gt; ;; Maintainer: Steve Youngs <steve(a)eicq.org&gt; ;; Created: 2004-11-25 ;; Keywords: arch archive tla ;; Based on xtla.el by: Stefan Reichoer, <stefan(a)xsteve.at&gt; ;; This file is part of XEtla. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; ;; 3. Neither the name of the author nor the names of any contributors ;; may be used to endorse or promote products derived from this ;; software without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR ;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE ;; DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE ;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF ;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR ;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN ;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; Commentary: ;; Contributions from: ;; Matthieu Moy <Matthieu.Moy(a)imag.fr&gt; ;; Masatake YAMATO <jet(a)gyve.org&gt; ;; Milan Zamazal <pdm(a)zamazal.org&gt; ;; Martin Pool <mbp(a)sourcefrog.net&gt; ;; Robert Widhopf-Fenk <hack(a)robf.de&gt; ;; Mark Triggs <mst(a)dishevelled.net&gt; ;; The main commands are available with the prefix key C-x T. ;; Type C-x T C-h for a list. ;; M-x xetla-inventory shows a xetla inventory ;; In this inventory buffer the following commands are available: ;; e ... xetla-edit-log ;; = ... xetla-changes ;; l ... xetla-changelog ;; L ... xetla-logs ;; To Edit a logfile issue: M-x xetla-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 xetla-commit (bound to C-c C-c) to commit the files ;; M-x xetla-archives starts the interactive archive browser ;; M-x xetla-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 xetla-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 xetla-file-ediff RET ;; Is an wrapper to xetla file-diff, ediff to view the changes ;; interactively. ;; Misc commands: ;; xetla-tag-insert inserts a arch-tag entry generated with uuidgen ;; If you find xetla.el useful, and you have some ideas to improve it ;; please share them with us (Patches are preferred :-)) ;;; Code: (eval-and-compile (when (locate-library "xetla-version") (require 'xetla-version))) (eval-when-compile (require 'cl)) ;; gnus is optional. Load it at compile-time to avoid warnings. (eval-when-compile (autoload 'gnus-article-part-wrapper "gnus-art") (autoload 'gnus-article-show-summary "gnus-art" nil t) (autoload 'gnus-summary-select-article-buffer "gnus-sum" nil t) (autoload 'mm-save-part-to-file "mm-decode") (autoload 'mml-attach-file "mml" nil t)) (eval-and-compile (require 'ediff) (require 'font-lock)) (require 'sendmail) (require 'pp) (require 'ewoc) (require 'diff) (require 'diff-mode) (eval-and-compile (require 'xetla-defs) (require 'xetla-core)) (eval-when-compile (when (locate-library "smerge-mode") (require 'smerge-mode)) (when (locate-library "hl-line") (require 'hl-line))) (eval-when-compile (autoload 'dired "dired" nil t) (autoload 'dired-make-relative "dired") (autoload 'dired-other-window "dired" nil t) (autoload 'minibuffer-prompt-end "completer") (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")) ;; -------------------------------------- ;; Internal variables ;; -------------------------------------- (defvar xetla-edit-arch-command nil) (defvar xetla-pre-commit-window-configuration nil) (defvar xetla-log-edit-file-name nil) (defvar xetla-log-edit-file-buffer nil) (defvar xetla-my-id-history nil) (defvar xetla-memorized-log-header nil) (defvar xetla-memorized-log-message nil) (defvar xetla-memorized-version nil) (defvar xetla-buffer-archive-name nil) (defvar xetla-buffer-category-name nil) (defvar xetla-buffer-branch-name nil) (defvar xetla-buffer-version-name nil) (defvar xetla-buffer-refresh-function nil "Variable should be local to each buffer. Function used to refresh the current buffer") (defvar xetla-buffer-marked-file-list nil "List of marked files in the current buffer.") (defvar xetla-get-revision-info-at-point-function nil "Variable should be local to each buffer. Function used to get the revision info at point") (defvar xetla-mode-line-process "") (defvar xetla-mode-line-process-status "") ;; Extent category (put 'xetla-default-button 'mouse-face 'highlight) (put 'xetla-default-button 'evaporate t) ;;(put 'xetla-default-button 'rear-nonsticky t) ;;(put 'xetla-default-button 'front-nonsticky t) ;;;###autoload (defun xetla () "Displays a welcome message." (interactive) (let* ((name "*xetla-welcome*") (buffer (get-buffer name))) (if buffer (xetla-switch-to-buffer buffer) (xetla-switch-to-buffer (setq buffer (get-buffer-create name))) (insert " *** Welcome to XEtla ! *** XEtla is the XEmacs frontend to the revision control system GNU/arch (tla). As a starting point, you should look at the \"Tools\" menu, there is a \"XEtla\" entry with a lot of interesting commands. There is also a manual for XEtla. It should be available using the Info system, however it is still just a skeleton file with no information in it yet. Well, you know how much hackers just love doing documentation. :-) Hope you'll enjoy it ! ") (insert "\n" "" "[" (xetla-insert-button "Bookmarks" 'xetla-bookmarks) "]" "[" (xetla-insert-button "Inventory" 'xetla-inventory) "]" "[" (xetla-insert-button "Browse Archives" (if (fboundp 'xetla-browse) 'xetla-browse 'xetla-archives)) "]" "[" (xetla-insert-button "Browse Revisions" 'xetla-revisions) "]" "[" (xetla-insert-button "Report Bug" 'xetla-submit-bug-report) "]" "\n") (toggle-read-only t) (local-set-key [?q] (lambda () (interactive) (kill-buffer (current-buffer))))) (xetla-message-with-bouncing (concat "XEtla core development team: " "Steve Youngs <steve(a)eicq.org&gt;, " "Sebastian Freundt <freundt(a)math.tu-berlin.de&gt; " " --- We hope you have as much fun using XEtla " "as we have had in hacking it for you.")))) (defun xetla-insert-button (label function) "Insert a button labeled with LABEL and launching FUNCTION. Helper function for `xetla'." (xetla-face-add label 'bold (let ((map (make-sparse-keymap))) (define-key map [return] function) (define-key map "\C-m" function) (define-key map [button2] function) map) nil)) (defun xetla-face-add-with-condition (condition text face1 face2) "If CONDITION then add TEXT the face FACE1, else add FACE2." (if condition (xetla-face-add text face1) (xetla-face-add text face2))) (defun xetla-face-set-temporary-during-popup (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-extent begin end)) (set-extent-face o face) (sit-for 0) (popup-menu menu prefix)) (delete-extent o)))) (defconst xetla-mark (xetla-face-add "*" 'xetla-mark) "Fontified string used for marking.") ;; -------------------------------------- ;; Macros ;; -------------------------------------- (defmacro xetla-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 xetla modes ;; -------------------------------------- (defun xetla-kill-all-buffers () "Kill all xetla buffers." (interactive) (let ((number 0)) (dolist (type-cons xetla-buffers-tree) (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 xetla-buffers-tree nil)) (defvar xetla-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. `xetla-buffer-quit' will restore this window-configuration.") (make-variable-buffer-local 'xetla-buffer-previous-window-config) (defun xetla-buffer-quit () "Quit the current buffer. If `xetla-buffer-quit-mode' is 'kill, then kill the buffer. Otherwise, just burry it." (interactive) ;; Value is buffer local => keep it before killing the buffer! (let ((prev-wind-conf xetla-buffer-previous-window-config)) (if (eq xetla-buffer-quit-mode 'kill) (kill-buffer (current-buffer)) (bury-buffer)) (when prev-wind-conf (set-window-configuration prev-wind-conf)))) (defun xetla-edit-=tagging-method-file () "Edit the {arch}/=tagging-method file." (interactive) (find-file (expand-file-name "{arch}/=tagging-method" (xetla-tree-root)))) (defun xetla-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 `read-directory-name'." (interactive (list (if (not (interactive-p)) default-directory (let ((file (xetla-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 (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))) (xetla-tag-insert))))) (defun xetla-ewoc-delete (cookie elem) "Remove element from COOKIE the element ELEM." (ewoc-filter cookie '(lambda (x) (not (eq x (ewoc-data elem)))))) (defun xetla-generic-refresh () "Call the function specified by `xetla-buffer-refresh-function'." (interactive) (let ((xetla-read-directory-mode 'never) (xetla-read-project-tree-mode 'never)) (funcall xetla-buffer-refresh-function))) (defun xetla-get-info-at-point () "Get the version information that point is on." (when (fboundp xetla-get-revision-info-at-point-function) (funcall xetla-get-revision-info-at-point-function))) (defvar xetla-window-config nil "Used for inter-function communication.") (defun xetla-ediff-buffers (bufferA bufferB) "Wrapper around `ediff-buffers'. Calls `ediff-buffers' on BUFFERA and BUFFERB." (let ((xetla-window-config (current-window-configuration))) (ediff-buffers bufferA bufferB '(xetla-ediff-startup-hook) 'xetla-ediff))) (defun xetla-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 (xetla-face-add string face) string)) ) (defun xetla-generic-popup-menu (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 `xetla-generic-popup-menu-by-keyboard'." (interactive "e\nP") (mouse-set-point event) (xetla-generic-popup-menu-by-keyboard prefix)) (defun xetla-generic-popup-menu-by-keyboard (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) 'menu) (let* ((menu (get-text-property (point) 'menu)) (p (previous-single-property-change (point) 'menu nil (point-at-bol))) (n (next-single-property-change (point) 'menu nil (point-at-eol))) (b (if (and p (get-text-property p 'menu)) p (point))) (e (if n n (point)))) (xetla-face-set-temporary-during-popup 'xetla-highlight b e menu prefix)) (error "No context-menu under the point"))) ;; Test cases ;; (xetla-message-with-bouncing ;; (concat "Author: Stefan Reichoer <stefan(a)xsteve.at&gt;, " ;; "Contributions from: " ;; "Matthieu Moy <Matthieu.Moy(a)imag.fr&gt;, " ;; "Masatake YAMATO <jet(a)gyve.org&gt;, " ;; "Milan Zamazal <pdm(a)zamazal.org&gt;, " ;; "Martin Pool <mbp(a)sourcefrog.net&gt;, " ;; "Robert Widhopf-Fenk <hack(a)robf.de&gt;, " ;; "Mark Triggs <mst(a)dishevelled.net&gt;&quot;)) ;; (xetla-message-with-rolling ;; (concat "Author: Stefan Reichoer <stefan(a)xsteve.at&gt;, " ;; "Contributions from: " ;; "Matthieu Moy <Matthieu.Moy(a)imag.fr&gt;, " ;; "Masatake YAMATO <jet(a)gyve.org&gt;, " ;; "Milan Zamazal <pdm(a)zamazal.org&gt;, " ;; "Martin Pool <mbp(a)sourcefrog.net&gt;, " ;; "Robert Widhopf-Fenk <hack(a)robf.de&gt;, " ;; "Mark Triggs <mst(a)dishevelled.net&gt;&quot;)) (defvar xetla-message-long-default-interval 0.2 "Default animation step interval. Used in `xetla-message-with-bouncing' and `xetla-message-with-rolling'") (defvar xetla-message-long-border-interval 1.0 "Animation step interval when bouncing in `xetla-message-with-bouncing'.") (defun* xetla-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) xetla-message-long-border-interval) (t xetla-message-long-default-interval))) (return-from xetla-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) xetla-message-long-border-interval) (t xetla-message-long-default-interval))) (return-from xetla-message-with-bouncing))) (garbage-collect))))) (defun* xetla-message-with-rolling (&rest msg) "Similar to `message' but display the message in rolling animation to show long line." (setq msg (concat " <MESSAGE>: " (apply 'format msg) " ")) (let* ((width (- (window-width (minibuffer-window)) (+ 1 (length "[<] ")))) (msglen (length msg)) submsg (normal-range (- msglen width))) (if (< msglen width) (message "%s" msg) (while t (dotimes (i msglen) (setq submsg (if (< i normal-range) (substring msg i (+ i width)) ;; Rolling is needed. (concat (substring msg i) (substring msg 0 (- (+ i width) msglen))))) (message "[<] %s" submsg) (unless (sit-for (cond ((eq i 0) xetla-message-long-border-interval) (t xetla-message-long-default-interval))) (return-from xetla-message-with-rolling))) (garbage-collect))))) ;; -------------------------------------- ;; Name read engine helpers ;; -------------------------------------- ;; ;; Extended version of xetla-read-name ;; (defun xetla-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 xetla You are prompted for a fully qualified archive, category, branch, version, or revision, which means a string like \&quot;John.Smith(a)rt.fm-arch/xetla-revolutionary-1.0\&quot;. 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)) xetla-name-read-extension-keydefs))) (dolist (func interesting) (let* ((keys (where-is-internal func xetla-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)) (xetla-funcall-if-exists help-setup-xref (list 'xetla-name-read-help) (interactive-p))) (display-buffer (current-buffer)) (toggle-read-only 1)) (defun xetla-name-read-inline-help () "Displays a help message in echo area." (interactive) (let ((interesting (mapcar (lambda (pair) (cdr pair)) xetla-name-read-extension-keydefs)) (line "")) (dolist (func interesting) (let* ((keys (where-is-internal func xetla-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 "xetla-name-read-\\(.+\\)" func) (match-string 1 func))) (setq line (concat line (format "%s => `%s'" keys1 func) " ")))) (xetla-message-with-rolling line) )) (defun xetla-read-revision-with-default-tree (&optional prompt tree) "Read revision name with `xetla-name-read'. PROMPT is passed to `xetla-name-read' without changing. Default version associated with TREE, a directory is used as default arguments for`xetla-name-read'." (setq tree (xetla-tree-root (or tree default-directory) t)) (let ((tree-rev (xetla-tree-version-list tree))) (xetla-name-read prompt (if tree-rev (xetla-name-archive tree-rev) 'prompt) (if tree-rev (xetla-name-category tree-rev) 'prompt) (if tree-rev (xetla-name-branch tree-rev) 'prompt) (if tree-rev (xetla-name-version tree-rev) 'prompt) 'prompt))) ;; ;; Version for the tree of default directory ;; (defvar xetla-name-read-insert-version-associated-with-default-directory nil) (defun xetla-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 (xetla-name-mask (xetla-tree-version-list (if xetla-name-read-insert-version-associated-with-default-directory xetla-name-read-insert-version-associated-with-default-directory default-directory)) t (xetla-name-read-arguments 'archive) (xetla-name-read-arguments 'category) (xetla-name-read-arguments 'branch) (xetla-name-read-arguments 'version)))) (if (and (window-minibuffer-p (selected-window)) (or force (equal "" (buffer-substring)))) (insert version-for-tree)))) ;; ;; Default archive ;; (defun xetla-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 "" (buffer-substring)) force) (member (xetla-name-read-arguments 'archive) '(prompt maybe))) (insert (xetla-my-default-archive)))) ;; ;; Info at point ;; (defvar xetla-name-read-insert-info-at-point nil) (defvar xetla-name-read-insert-info-at-point-extent nil) (defun xetla-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 xetla-name-read-insert-info-at-point (xetla-name-read-insert-version-associated-with-default-directory)))) (when (and (window-minibuffer-p (selected-window)) (or (equal "" (buffer-substring)) force) info-at-point) (insert info-at-point)))) (defun xetla-name-read-insert-info-at-point-init () "This function retrieves the info at point. Further call to `xetla-name-read-insert-info-at-point-final' will actuall insert the value computed here." (setq xetla-name-read-insert-info-at-point (let ((raw-info (cadr (xetla-get-info-at-point))) (b (previous-single-property-change (point) 'menu)) (e (next-single-property-change (point) 'menu))) (when raw-info (when (and b e) (setq xetla-name-read-insert-info-at-point-extent (make-extent (1- b) e)) (set-extent-property xetla-name-read-insert-info-at-point-extent 'face 'xetla-highlight)) (xetla-name-mask (xetla-name-split raw-info) t (xetla-name-read-arguments 'archive) (xetla-name-read-arguments 'category) (xetla-name-read-arguments 'branch) (xetla-name-read-arguments 'version) (xetla-name-read-arguments 'revision)))))) (defun xetla-name-read-insert-info-at-point-final (&optional no-use) "Called when exitting the minibuffer prompt. Cancels the effect of `xetla-name-read-insert-info-at-point-init'. Argument NO-USE is ignored." (when xetla-name-read-insert-info-at-point-extent (delete-extent xetla-name-read-insert-info-at-point-extent) (setq xetla-name-read-insert-info-at-point-extent nil))) ;; ;; Partner file ;; (defvar xetla-name-read-insert-partner-ring-position nil) (defun xetla-name-read-insert-partner-init () "Initialize \"Insert Partner Version\" menu used in `xetla-name-read'." (setq xetla-name-read-insert-partner-ring-position nil) ;; Create menu items (setq xetla-name-read-partner-menu (cons "Insert Partner Version" nil)) (let ((partners (reverse (xetla-partner-list)))) (mapc (lambda (p) (setq p (xetla-name-mask (xetla-name-split p) t (xetla-name-read-arguments 'archive) (xetla-name-read-arguments 'category) (xetla-name-read-arguments 'branch) (xetla-name-read-arguments 'version) (xetla-name-read-arguments 'revision))) (setcdr xetla-name-read-partner-menu (cons (cons p (cons p `(lambda () (interactive) (delete-region (minibuffer-prompt-end) (point-max)) (insert ,p)))) (cdr xetla-name-read-partner-menu)))) partners)) (fset 'xetla-name-read-partner-menu (cons 'keymap xetla-name-read-partner-menu))) (defun xetla-name-read-insert-partner-previous () "Insert the previous partner version into miniffer." (interactive) (let* ((partners (xetla-partner-list)) (plen (length partners)) (pos (if xetla-name-read-insert-partner-ring-position (if (eq xetla-name-read-insert-partner-ring-position 0) (1- plen) (1- xetla-name-read-insert-partner-ring-position)) 0)) (pversion (when partners (xetla-name-mask (xetla-name-split (nth pos partners)) t (xetla-name-read-arguments 'archive) (xetla-name-read-arguments 'category) (xetla-name-read-arguments 'branch) (xetla-name-read-arguments 'version) (xetla-name-read-arguments 'revision))))) (when (and (window-minibuffer-p (selected-window)) partners pversion) (delete-region (minibuffer-prompt-end) (point-max)) (insert pversion) (setq xetla-name-read-insert-partner-ring-position pos)))) (defun xetla-name-read-insert-partner-next () "Insert the next partner version into the miniffer." (interactive) (let* ((partners (xetla-partner-list)) (plen (length partners)) (pos (if xetla-name-read-insert-partner-ring-position (if (eq xetla-name-read-insert-partner-ring-position (1- plen)) 0 (1+ xetla-name-read-insert-partner-ring-position)) 0)) (pversion (when partners (xetla-name-mask (xetla-name-split (nth pos partners)) t (xetla-name-read-arguments 'archive) (xetla-name-read-arguments 'category) (xetla-name-read-arguments 'branch) (xetla-name-read-arguments 'version) (xetla-name-read-arguments 'revision))))) (when (and (window-minibuffer-p (selected-window)) partners pversion) (delete-region (minibuffer-prompt-end) (point-max)) (insert pversion) (setq xetla-name-read-insert-partner-ring-position pos)))) ;; ;; Ancestor ;; (defun xetla-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 (xetla-tree-version-list default-directory)) (ancestor (when (and version (not (eq this-command 'xetla-compute-direct-ancestor))) (xetla-compute-direct-ancestor (xetla-name-mask version nil t t t t "base-0"))))) (when (and ancestor (window-minibuffer-p (selected-window)) (or (equal "" (buffer-substring)) force) (member (xetla-name-read-arguments 'archive) '(prompt maybe))) (insert (xetla-name-mask ancestor t t (member (xetla-name-read-arguments 'category) '(prompt maybe)) (member (xetla-name-read-arguments 'branch) '(prompt maybe)) (member (xetla-name-read-arguments 'version) '(prompt maybe)) (member (xetla-name-read-arguments 'revision) '(prompt maybe))))))) ;; ;; Partners in Bookmark ;; (defvar xetla-name-read-insert-bookmark-ring-position nil) (defun xetla-name-read-insert-bookmark-init () "Initialize \"Insert Version in Bookmark\" menu used in `xetla-name-read'." (setq xetla-name-read-insert-bookmark-ring-position nil) ;; Create menu items (setq xetla-name-read-bookmark-menu (cons "Insert Version in Bookmark" nil)) (let* ((default-version (xetla-tree-version-list default-directory 'no-error)) (bookmarks (when default-version (nreverse (xetla-bookmarks-get-partner-versions default-version))))) (mapc (lambda (p) (setq p (xetla-name-mask p t (xetla-name-read-arguments 'archive) (xetla-name-read-arguments 'category) (xetla-name-read-arguments 'branch) (xetla-name-read-arguments 'version) (xetla-name-read-arguments 'revision))) (setcdr xetla-name-read-bookmark-menu (cons (cons p (cons p `(lambda () (interactive) (delete-region (minibuffer-prompt-end) (point-max)) (insert ,p)))) (cdr xetla-name-read-bookmark-menu)))) bookmarks)) (fset 'xetla-name-read-bookmark-menu (cons 'keymap xetla-name-read-bookmark-menu))) (defun xetla-name-read-insert-bookmark-previous () "Insert the previous partner version in the bookmark into minibuffer." (interactive) (let* ((default-version (xetla-tree-version-list default-directory)) (bookmarks (when default-version (nreverse (xetla-bookmarks-get-partner-versions default-version)))) (plen (length bookmarks)) (pos (if xetla-name-read-insert-bookmark-ring-position (if (eq xetla-name-read-insert-bookmark-ring-position 0) (1- plen) (1- xetla-name-read-insert-bookmark-ring-position)) 0)) (pversion (when bookmarks (xetla-name-mask (nth pos bookmarks) t (xetla-name-read-arguments 'archive) (xetla-name-read-arguments 'category) (xetla-name-read-arguments 'branch) (xetla-name-read-arguments 'version) (xetla-name-read-arguments 'revision))))) (when (and (window-minibuffer-p (selected-window)) bookmarks pversion) (delete-region (minibuffer-prompt-end) (point-max)) (insert pversion) (setq xetla-name-read-insert-bookmark-ring-position pos)))) (defun xetla-name-read-insert-bookmark-next () "Insert the next partner version in the bookmark into the miniffer." (interactive) (let* ((default-version (xetla-tree-version-list default-directory)) (bookmarks (when default-version (nreverse (xetla-bookmarks-get-partner-versions default-version)))) (plen (length bookmarks)) (pos (if xetla-name-read-insert-bookmark-ring-position (if (eq xetla-name-read-insert-bookmark-ring-position (1- plen)) 0 (1+ xetla-name-read-insert-bookmark-ring-position)) 0)) (pversion (when bookmarks (xetla-name-mask (nth pos bookmarks) t (xetla-name-read-arguments 'archive) (xetla-name-read-arguments 'category) (xetla-name-read-arguments 'branch) (xetla-name-read-arguments 'version) (xetla-name-read-arguments 'revision))))) (when (and (window-minibuffer-p (selected-window)) bookmarks pversion) (delete-region (minibuffer-prompt-end) (point-max)) (insert pversion) (setq xetla-name-read-insert-bookmark-ring-position pos)))) (add-hook 'xetla-name-read-init-hook 'xetla-name-read-insert-info-at-point-init) (add-hook 'xetla-name-read-final-hook 'xetla-name-read-insert-info-at-point-final) (add-hook 'xetla-name-read-error-hook 'xetla-name-read-insert-info-at-point-final) (add-hook 'xetla-name-read-init-hook 'xetla-name-read-insert-partner-init) (add-hook 'xetla-name-read-init-hook 'xetla-name-read-insert-bookmark-init) (defun xetla-tree-root (&optional location no-error) "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 NO-ERROR is non-nil, don't raise an error if LOCATION is not an arch managed tree (but return nil)." (setq location (or location default-directory)) (let ((pwd location)) (while (not (or (string= pwd "/") (file-exists-p (concat (file-name-as-directory pwd) "{arch}")))) (setq pwd (expand-file-name (concat (file-name-as-directory pwd) "..")))) (if (file-exists-p (concat pwd "/{arch}/=tagging-method")) (expand-file-name (replace-regexp-in-string "/+$" "/" pwd)) (if no-error nil (error "%S is not in an arch-managed tree!" location))))) (defun xetla-read-project-tree-maybe (&optional prompt directory) "Return a directory name which is the root of some project tree. Either prompt from the user or use the current directory. The recommended usage is (defun xetla-some-feature (...) (let ((default-directory (xetla-read-project-tree-maybe \"Run some feature in\"))) (code-for-some-feature)) The behavior can be changed according to the value of `xetla-read-project-tree-mode'. PROMPT is used as a user prompt, and DIRECTORY is the default directory." (let ((root (xetla-tree-root (or directory default-directory) t)) (default-directory (or (xetla-tree-root (or directory default-directory) t) directory default-directory)) (prompt (or prompt "Use directory: "))) (case xetla-read-project-tree-mode (always (xetla-tree-root (read-directory-name prompt))) (sometimes (or root (xetla-tree-root (read-directory-name prompt)))) (never (or root (error "Not in a project tree"))) (t (error "Wrong value for xetla-prompt-for-directory"))))) (defun xetla-read-directory-maybe (&optional prompt directory force) "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 `xetla-read-project-tree-maybe', but is customized with the variable `xetla-read-directory-mode'. PROMPT is the user prompt, and DIRECTORY is the default directory." (let ((root (xetla-tree-root (or directory default-directory) t)) (default-directory (or directory default-directory)) (prompt (or prompt "Use directory: "))) (case xetla-read-directory-mode (always (read-directory-name prompt)) (sometimes (cond (force (read-directory-name prompt)) (root default-directory) (t (read-directory-name prompt)))) (never (if root (or directory default-directory) (error "Not in a project tree"))) (t (error "Wrong value for xetla-read-directory-mode"))))) (defun xetla-save-some-buffers (&optional tree) "Save all buffers visiting a file in TREE." (let ((ok t) (tree (or (xetla-tree-root tree t) tree))) (unless tree (error "Not in a project tree")) (dolist (buffer (buffer-list)) (with-current-buffer buffer (when (buffer-modified-p) (let ((file (buffer-file-name))) (when file (let ((root (xetla-tree-root (file-name-directory file) t)) (tree-exp (expand-file-name tree))) (when (and root (string= (file-name-as-directory root) tree-exp) ;; buffer is modified and in the tree TREE. (or xetla-do-not-prompt-for-save (y-or-n-p (concat "Save buffer " (buffer-name) "? ")) (setq ok nil))) (save-buffer)))))))) ok)) (defun xetla-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." (let ((tree (xetla-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 (xetla-uniquify-file-name (xetla-tree-root (file-name-directory file) t))) (tree-exp (xetla-uniquify-file-name (expand-file-name tree)))) (when (and (string= root tree-exp) ;; buffer is modified and in the tree TREE. xetla-automatically-revert-buffers) ;; Keep the buffer if the file doesn't exist (if (file-exists-p file) (revert-buffer t t))))))))))) ;; -------------------------------------- ;; xetla 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 xetla-display-command-help (command) "Help system for commands that get input via the minibuffer. This is an internal function called by `xetla-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))))) " *xetla-command-help*")) (defvar xetla-command-stack nil) (defun xetla-minibuffer-setup () "Function called in `minibuffer-setup-hook'. Memorize last command run." (push this-command xetla-command-stack)) (defun xetla-minibuffer-exit () "Function called in `minibuffer-exit-hook'. Cancels the effect of `xetla-minibuffer-setup'." (pop xetla-command-stack)) (defun xetla-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 \\<minibuffer-local-map>\\[xetla-show-command-help]. This functionality is not only for xetla commands available it is available for all Emacs commands." (interactive) (xetla-display-command-help (car xetla-command-stack))) (when xetla-install-command-help-system (define-key minibuffer-local-map [f1] 'xetla-show-command-help) (define-key minibuffer-local-completion-map [f1] 'xetla-show-command-help) (define-key minibuffer-local-must-match-map [f1] 'xetla-show-command-help) (define-key minibuffer-local-map [(control meta ?h)] 'xetla-show-command-help) (define-key minibuffer-local-completion-map [(control meta ?h)] 'xetla-show-command-help) (define-key minibuffer-local-must-match-map [(control meta ?h)] 'xetla-show-command-help) (add-hook 'minibuffer-setup-hook 'xetla-minibuffer-setup) (add-hook 'minibuffer-exit-hook 'xetla-minibuffer-exit)) ;; -------------------------------------- ;; Top level xetla commands ;; -------------------------------------- (defcustom xetla-make-log-function 'xetla-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 `xetla-default-make-log-function', which just calls \"xetla make-log\". If you want to override this function, you may just write a wrapper around `xetla-default-make-log-function'." :type 'function :group 'xetla) (defun xetla-make-log () "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 `xetla-make-log-function', which, by default, calls \"xetla make-log\"." (interactive) (let* ((version (xetla-tree-version-list)) (file (concat (xetla-tree-root) "++log." (xetla-name-category version) "--" (xetla-name-branch version) "--" (xetla-name-version version) "--" (xetla-name-archive version)))) (if (file-exists-p file) file (funcall xetla-make-log-function)))) (defun xetla-default-make-log-function () "Candidate (and default value) for `xetla-make-log-function'. Calls \"xetla make-log\" to generate the log file." (xetla-run-tla-sync '("make-log") :finished (lambda (output error status arguments) (xetla-buffer-content output)))) (defun xetla-pop-to-inventory () "Call `xetla-inventory' with a prefix arg." (interactive) (xetla-inventory nil t)) (defvar xetla-inventory-cookie nil) (defvar xetla-inventory-list nil "Full list for the inventory.") (defun xetla-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 xetla-inventory-cookie))) (while (and current (not (string= (caddr (ewoc-data current)) file))) (setq current (ewoc-next xetla-inventory-cookie current))) (when current (xetla-inventory-cursor-goto current)) current)) (defun xetla-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)) (xetla-inventory-redisplay)))) (dolist (type-arg xetla-inventory-file-types-manipulators) (xetla-inventory-make-toggle-fn-and-var (cadr type-arg) (caddr type-arg))) (defun xetla-inventory-redisplay () "Refresh *xetla-inventory* buffer." (let* ((elem (ewoc-locate xetla-inventory-cookie)) (file (when elem (caddr (ewoc-data elem)))) (pos (point))) (xetla-inventory-display) (or (and file (xetla-inventory-goto-file file)) (goto-char pos)) (xetla-inventory-cursor-goto (ewoc-locate xetla-inventory-cookie)))) (defun xetla-inventory-set-toggle-variables (new-value) "Set all xetla-inventory-display-* variables. If NEW-VALUE is 'toggle set the values to (not xetla-inventory-display-* Otherwise set it to NEW-VALUE." (dolist (type-arg xetla-inventory-file-types-manipulators) (eval `(setq ,(cadr type-arg) (if (eq new-value 'toggle) (not ,(cadr type-arg)) new-value))))) (defun xetla-inventory-set-all-toggle-variables () "Set all inventory toggle variables to t." (interactive) (xetla-inventory-set-toggle-variables t) (xetla-inventory-redisplay)) (defun xetla-inventory-reset-all-toggle-variables () "Set all inventory toggle variables to nil." (interactive) (xetla-inventory-set-toggle-variables nil) (xetla-inventory-redisplay)) (defun xetla-inventory-toggle-all-toggle-variables () "Toggle the value of all inventory toggle variables." (interactive) (xetla-inventory-set-toggle-variables 'toggle) (xetla-inventory-redisplay)) ;;;###autoload (defun xetla-inventory (&optional directory arg) "Show a xetla 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 (xetla-read-directory-maybe "Run inventory in (directory): " nil current-prefix-arg) current-prefix-arg)) (let ((default-directory (or directory default-directory))) (if arg (pop-to-buffer (xetla-get-buffer-create 'inventory directory)) (switch-to-buffer (xetla-get-buffer-create 'inventory directory)))) (xetla-inventory-mode) (xetla-run-tla-sync ;; We have to provide all file types or xetla inventory won't display ;; junk files '("inventory" "--both" "--kind" "--source" "--backups" "--junk" "--unrecognized" "--precious") :finished (lambda (output error status arguments) (let ((list (split-string (xetla-buffer-content output) "\n")) (inventory-list '())) (mapc (lambda (item) (when (string-match "\\([A-Z]\\)\\([\\? ]\\) +\\([^ ]\\) \\(.*\\)" item) (let ((xetla-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 xetla-type question (xetla-unescape escaped-filename) type) inventory-list)))) list) (setq inventory-list (reverse inventory-list)) (set (make-local-variable 'xetla-inventory-list) inventory-list) (xetla-inventory-display))))) (defun xetla-inventory-display () "Display the inventory. This function creates the ewoc from the variable `xetla-inventory-list', selecting only files to print." (interactive) (let (buffer-read-only) (erase-buffer) (set (make-local-variable 'xetla-inventory-cookie) (ewoc-create 'xetla-inventory-printer)) (xetla-inventory-insert-headers) (dolist (elem xetla-inventory-list) (let ((type (car elem))) (if (eval (cadr (assoc type xetla-inventory-file-types-manipulators))) (ewoc-enter-last xetla-inventory-cookie elem))))) (goto-char (point-min))) (defun xetla-inventory-chose-face (type) "Return a face adapted to TYPE, which can be J, S, P, T or U." (case type (?P 'xetla-precious) (?U 'xetla-unrecognized) (?S 'xetla-source) (?J 'xetla-junk) (?T 'xetla-nested-tree))) (defun xetla-inventory-printer (elem) "Ewoc printer for `xetla-inventory-cookie'. Pretty print ELEM." (let* ((type (nth 0 elem)) (question (nth 1 elem)) (file (nth 2 elem)) (file-type (nth 3 elem)) (face (xetla-inventory-chose-face type))) (insert (if (member file xetla-buffer-marked-file-list) (concat " " xetla-mark " ") " ")) (insert (xetla-face-add (format "%c%s " type (if question "?" " ")) face) (xetla-face-add (format "%s%s" file (case file-type (?d "/") (?> "＠") (t ""))) face 'xetla-inventory-item-map xetla-inventory-item-menu)))) (defun xetla-inventory-mark-file () "Mark file at point in inventory mode. Adds it to the variable `xetla-buffer-marked-file-list', and move cursor to the next entry." (interactive) (let ((current (ewoc-locate xetla-inventory-cookie)) (file (xetla-get-file-info-at-point))) (add-to-list 'xetla-buffer-marked-file-list file) (ewoc-refresh xetla-inventory-cookie) (xetla-inventory-cursor-goto (or (ewoc-next xetla-inventory-cookie current) current)))) (defun xetla-inventory-unmark-file () "Unmark file at point in inventory mode." (interactive) (let ((current (ewoc-locate xetla-inventory-cookie)) (file (xetla-get-file-info-at-point))) (setq xetla-buffer-marked-file-list (delete file xetla-buffer-marked-file-list)) (ewoc-refresh xetla-inventory-cookie) (xetla-inventory-cursor-goto (or (ewoc-next xetla-inventory-cookie current) current)))) (defun xetla-inventory-unmark-all () "Unmark all files in inventory mode." (interactive) (let ((current (ewoc-locate xetla-inventory-cookie))) (setq xetla-buffer-marked-file-list nil) (ewoc-refresh xetla-inventory-cookie) (xetla-inventory-cursor-goto current))) (defvar xetla-get-file-info-at-point-function nil "Function used to get the file at point, anywhere.") (defun xetla-get-file-info-at-point () "Gets the filename at point, according to mode. Actually calls the function `xetla-get-file-info-at-point-function'." (when xetla-get-file-info-at-point-function (funcall xetla-get-file-info-at-point-function))) (defvar xetla-generic-select-files-function nil "Function called by `xetla-generic-select-files'. Must be local to each buffer.") (defun xetla-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 `xetla-generic-select-files-function', defined locally for each xetla 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. `xetla-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 xetla-generic-select-files-function (funcall xetla-generic-select-files-function msg-singular msg-plural msg-err msg-prompt no-group ignore-marked no-prompt y-or-n))) (defun xetla-generic-find-file-at-point () "Opens the file at point. The filename is obtained with `xetla-get-file-info-at-point', so, this function should be useable in all modes seting `xetla-get-file-info-at-point-function'" (interactive) (let* ((file (xetla-get-file-info-at-point))) (cond ((not file) (error "No file at point")) (t (find-file file))))) (xetla-make-bymouse-function xetla-generic-find-file-at-point) (defun xetla-generic-find-file-other-window () "Visit the current inventory file in the other window." (interactive) (let ((file (xetla-get-file-info-at-point))) (if file (progn (find-file-other-window file)) (error "No file at point")))) (defun xetla-generic-view-file () "Visit the current inventory file in view mode." (interactive) (let ((file (xetla-get-file-info-at-point))) (if file (view-file-other-window file) (error "No file at point")))) (defun xetla-inventory-get-file-info-at-point () "Gets the file at point in inventory mode." (caddr (ewoc-data (ewoc-locate xetla-inventory-cookie)))) (defun xetla-inventory-insert-headers () "Insert the header (top of buffer) for *xetla-inventory*." (let* ((tree-version (xetla-name-construct (xetla-tree-version-list nil 'no-error))) (tagging-method (xetla-id-tagging-method nil)) (separator (xetla-face-add (make-string (max (+ (length "Directory: ") (length default-directory)) (+ (length "Default Tree Version: ") (length tree-version)) (+ (length "ID Tagging Method: ") (length tagging-method))) ?\ ) 'xetla-separator))) (ewoc-set-hf xetla-inventory-cookie (concat "Directory: " (xetla-face-add default-directory 'xetla-local-directory (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 [button2] func) map) nil "Run Dired Here") "\n" "Default Tree Version: " (xetla-face-add tree-version 'xetla-archive-name 'xetla-inventory-default-version-map (xetla-partner-create-menu 'xetla-generic-set-tree-version "Change the Default Tree Version")) "\n" "ID Tagging Method: " (xetla-face-add tagging-method 'xetla-tagging-method 'xetla-inventory-tagging-method-map xetla-inventory-tagging-method-menu) "\n" separator "\n") (concat "\n" separator)))) (defvar xetla-buffer-source-buffer nil "Buffer from where a command was called.") ;;;###autoload (defun xetla-edit-log (&optional insert-changelog source-buffer) "Edit the xetla 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 xetla-pre-commit-window-configuration (current-window-configuration)) (setq xetla-log-edit-file-name (xetla-make-log)) (xetla-switch-to-buffer (find-file-noselect xetla-log-edit-file-name)) (when insert-changelog (goto-char (point-max)) (let ((buf (find-file-noselect (find-change-log)))) (insert-buffer buf)) (when (re-search-forward "^2" nil t) (delete-region (point-at-bol) (point-at-bol 3))) (when (re-search-forward "^2" nil t) (delete-region (point-at-bol) (point-max))) (goto-char (point-min))) (xetla-log-edit-mode) (set (make-local-variable 'xetla-buffer-source-buffer) source-buffer) (end-of-line)) ;;;###autoload (defun xetla-add-log-entry () "Add new xetla log ChangeLog style entry." (interactive) (save-restriction (xetla-add-log-entry-internal))) (defun xetla-add-log-entry-internal () "Similar to `add-change-log-entry'. Inserts the entry in the arch log file 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. (require 'add-log) (let* ((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 (xetla-make-log)) ;; Set ENTRY to the file name to use in the new entry. (entry (add-log-file-name buffer-file file-name)) beg bound narrowing) (xetla-edit-log) (undo-boundary) (goto-char (point-min)) (when (re-search-forward "^Patches applied:" 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)) (setq bound (progn (if (looking-at "\n*[^\n* \t]") (skip-chars-forward "\n") (if (and (boundp 'add-log-keep-changes-together) add-log-keep-changes-together) (goto-char (point-max)) (forward-paragraph))) ; paragraph delimits entries for file (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. (re-search-forward "^\\s *$\\|^\\s \\*") (goto-char (match-beginning 0)) ;; Delete excess empty lines; make just 2. (while (and (not (eobp)) (looking-at "^\\s *$")) (delete-region (point) (point-at-bol 2))) (insert-char ?\n 2) (forward-line -2) (indent-relative-maybe)) (t ;; Make a new entry. (if xetla-log-insert-last (progn (goto-char (point-max)) (re-search-backward "^.") (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) (point-at-bol 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)) (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 ": "))))) (defvar xetla-changes-cookie nil "Ewoc cookie for the changes buffer. Element should look like (file \"filename\" \"M\" \"/\") (file \"newname\" \"M\" \"/\" \"filename\") (subtree \"name\" related-buffer changes?) (message \"doing such or such thing\")") (defun xetla-changes-delete-messages (&optional immediate) "Remove messages from the ewoc list of modifications. if IMMEDIATE is non-nil, refresh the display too." (when xetla-changes-cookie (ewoc-filter xetla-changes-cookie (lambda (elem) (not (eq (car elem) 'message)))))) (defvar xetla-changes-summary nil "Wether the current buffer display only a summary or a full diff.") (defvar xetla-changes-buffer-master-buffer nil "Master buffer for a nested *xetla-changes* buffer.") (defvar xetla-changes-summary nil "Wether the current buffer display only a summary or a full diff.") ;;;###autoload (defun xetla-changes (&optional summary against) "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." (interactive "P") (let* ((root (xetla-read-project-tree-maybe "Run tla changes in: ")) (default-directory root) (buffer (xetla-prepare-changes-buffer (or against (list 'last-revision root)) (list 'local-tree root) 'changes default-directory))) (with-current-buffer buffer (set (make-local-variable 'xetla-changes-summary) summary)) (when xetla-switch-to-buffer-first (xetla-switch-to-buffer buffer)) (xetla-save-some-buffers) (xetla-run-tla-async '("inventory" "--nested" "--trees") :related-buffer buffer :finished `(lambda (output error status arguments) (let ((subtrees (delete "" (split-string (with-current-buffer output (buffer-string)) "\n")))) (with-current-buffer ,buffer (let ((inhibit-read-only t)) (ewoc-enter-last xetla-changes-cookie (list 'message (concat "* running tla changes in tree " ,root "...\n\n"))) (ewoc-refresh xetla-changes-cookie)) (dolist (subtree subtrees) (let ((buffer-sub (xetla-get-buffer-create 'changes subtree))) (with-current-buffer buffer-sub (let ((inhibit-read-only t)) (erase-buffer)) (xetla-changes-mode) (set (make-local-variable 'xetla-changes-buffer-master-buffer) ,buffer)) (ewoc-enter-last xetla-changes-cookie (list 'subtree buffer-sub subtree nil)) (xetla-changes-internal ,(not summary) nil ;; TODO "against" what for a nested tree? subtree buffer-sub ,buffer))) (xetla-changes-internal ,(not summary) (quote ,against) ,root ,buffer nil))))))) ;;;###autoload (defun xetla-changes-against (&optional summary against) "Wrapper for `xetla-changes'. When called interactively, SUMMARY is the prefix arg, and AGAINST is read from the user." (interactive (list current-prefix-arg (list 'revision (xetla-name-read "Compute changes against: " 'prompt 'prompt 'prompt 'prompt 'maybe)))) (xetla-changes summary against)) ;;;###autoload (defun xetla-changes-last-revision (&optional summary) "Run `xetla-changes' against the last but one revision. The idea is that running this command just after a commit should be equivalent to running `xetla-changes' just before the commit. SUMMARY is passed to `xetla-changes'." (interactive "P") (let ((default-directory (xetla-read-project-tree-maybe "Review last patch in directory: "))) (xetla-changes summary (list 'revision (xetla-name-construct (xetla-compute-direct-ancestor)))))) (defvar xetla-changes-modified nil "MODIFIED revision for the changes currently displayed. Must be buffer-local. This variable has the form (type location), and can be either '(revision (\"archive\" \"category\" \"branch\" \"version\" \"revision\")) or '(local-tree \"/path/to/local/tree\") The value nil means we have no information about which local tree or revision is used.") (defvar xetla-changes-base nil "BASE revision for the changes currently displayed. Must be buffer-local. The values for this variable can be the same as for `xetla-changes-modified', plus the values '(last-revision \"/path/to/tree\"), used by `xetla-changes' to mean \"revision on which this local tree is based\". and '(previous-revision (\"archive\" \"category\" \"branch\" \"version\" \"revision\")), used by commands like xetla-get-changeset, and means that the changes are against the previous revision.") (defun xetla-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 (xetla-run-tla-async `("changes" ,(when diffs "--diffs") ,(case (car against) (local-tree (error "Can not run tla changes against a local tree")) (previous-revision (xetla-compute-direct-ancestor (cadr against))) (last-revision (if (string= (xetla-uniquify-file-name (cadr against)) (xetla-uniquify-file-name (xetla-tree-root))) nil (error "tla changes against last %s %s" "revision of local tree not" "implemented."))) (revision (xetla-name-construct (cadr against))))) :finished `(lambda (output error status arguments) (if ,master-buffer (message "No changes in subtree %s" ,root) (message "No changes in %s" ,root)) (with-current-buffer ,(current-buffer) (let ((inhibit-read-only t)) (xetla-changes-delete-messages) (ewoc-enter-last xetla-changes-cookie (list 'message (concat "* No changes in " ,root ".\n\n"))) (when ,master-buffer (with-current-buffer ,master-buffer (ewoc-map (lambda (x) (when (and (eq (car x) 'subtree) (eq (cadr x) ,buffer)) (setcar (cdddr x) 'no-changes)) ) ;; (ewoc-refresh xetla-changes-cookie))) xetla-changes-cookie))) (ewoc-refresh xetla-changes-cookie)))) :error `(lambda (output error status arguments) (if (/= 1 status) (progn (xetla-show-error-buffer error) (goto-char (point-min)) (when (search-forward "try tree-lint" nil t) (xetla-tree-lint ,root))) (xetla-show-changes-buffer output nil ,buffer ,master-buffer) (when ,master-buffer (with-current-buffer ,master-buffer (ewoc-map (lambda (x) (when (and (eq (car x) 'subtree) (eq (cadr x) ,buffer)) (setcar (cdddr x) 'changes)) ) xetla-changes-cookie))))) ))) (defun xetla-changes-chose-face (modif) "Return a face adapted to MODIF, a string, which can be A, M, C, or D." (cond ((string-match "A" modif) 'xetla-added) ((string-match "M" modif) 'xetla-modified) ((string-match "-" modif) 'xetla-modified) ((string-match "C" modif) 'xetla-conflict) ((string-match "D" modif) 'xetla-conflict) ((string-match "/" modif) 'xetla-move) ((string-match "=" modif) 'xetla-move) (t (xetla-trace "unknown modif: \"%s\"" modif) 'default))) (defun xetla-changes-printer (elem) "Ewoc pretty-printer for `xetla-changes-cookie'. Pretty-print ELEM." (cond ((eq (car elem) 'file) (let* ((empty-mark " ") (mark (when (member (cadr elem) xetla-buffer-marked-file-list) (concat xetla-mark " "))) (file (cadr elem)) (modif (caddr elem)) (dir (cadddr elem)) (basename (nth 4 elem)) (line (concat modif dir " " (when basename (concat basename "\t")) file)) (face (if mark 'xetla-marked (xetla-changes-chose-face modif)))) (if mark (insert mark) (insert empty-mark)) (insert (xetla-face-add line face 'xetla-changes-file-map xetla-changes-file-menu)))) ((eq (car elem) 'subtree) (insert " T" (cond ((not (cadddr elem)) "?") ((eq (cadddr elem) 'changes) "M") ((eq (cadddr elem) 'no-changes) "-")) " " (caddr elem))) ((eq (car elem) 'message) (insert (cadr elem)))) ) (defconst xetla-verbose-format-spec '(("added files" "A" " ") ("modified files" "M" " ") ("removed files" "D" " ")) "Internal variable used to parse the output of xetla show-changeset." ) (defun xetla-show-changes-buffer (buffer &optional verbose-format output-buffer no-switch) "Show the *xetla-changes* buffer built from the *xetla-process* BUFFER. If VERBOSE-FORMAT is non-nil, the format of the *xetla-process* buffer should be the one of xetla show-changeset. Use OUTPUT-BUFFER to display changes if provided. That buffer must already be in changes mode. If NO-SWITCH is nil, don't switch to the created buffer." (let* ((root (with-current-buffer buffer (xetla-tree-root default-directory t))) (changes-buffer (or output-buffer (xetla-get-buffer-create 'changes root))) (header "")) (if (or no-switch xetla-switch-to-buffer-first) (set-buffer changes-buffer) (xetla-switch-to-buffer changes-buffer)) (let (buffer-read-only) (xetla-changes-delete-messages) (unless output-buffer (erase-buffer) (xetla-changes-mode)) (with-current-buffer buffer (if verbose-format (progn (goto-char (point-min)) (while (re-search-forward (concat "^\\* \\(" (regexp-opt (mapcar 'car xetla-verbose-format-spec)) "\\)\n") nil t) (let* ((elem (assoc (match-string 1) xetla-verbose-format-spec)) (modif (cadr elem)) (dir (caddr elem))) (if (string= modif "M") (while (re-search-forward "^--- orig/\\(.*\\)$" nil t) (let ((file (match-string 1))) (with-current-buffer changes-buffer (ewoc-enter-last xetla-changes-cookie (list 'file (xetla-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 xetla-changes-cookie (list 'file (xetla-unescape file) modif dir))) (forward-line 1)))))) (goto-char (point-min)) (if (re-search-forward "^---" nil t) (forward-line -1) (beginning-of-line))) (setq header (buffer-substring-no-properties (goto-char (point-min)) (progn (re-search-forward "^[^*]" nil t) (beginning-of-line) (point)))) (beginning-of-line) (while (or (eq (char-after) ?*) (looking-at "^\\(.\\)\\([ /bfl>-]?\\) +\\([^\t\n]*\\)\\(\t\\(.*\\)\\)?$")) (if (eq (char-after) ?*) (let ((msg (buffer-substring-no-properties (point) (point-at-eol)))) (with-current-buffer changes-buffer (ewoc-enter-last xetla-changes-cookie (list 'message msg)))) (let ((file (match-string 3)) (modif (match-string 1)) (dir (match-string 2)) (newname (match-string 5))) (with-current-buffer changes-buffer (if newname (ewoc-enter-last xetla-changes-cookie (list 'file (xetla-unescape newname) modif dir (xetla-unescape file))) (ewoc-enter-last xetla-changes-cookie (list 'file (xetla-unescape file) modif dir)))))) (forward-line 1))) (let ((footer (concat (xetla-face-add (make-string 72 ?\ ) 'xetla-separator) "\n\n" (buffer-substring-no-properties (point) (point-max))))) (with-current-buffer changes-buffer (ewoc-set-hf xetla-changes-cookie header footer) (if root (cd root))))) )) (toggle-read-only 1) (when font-lock-mode (let ((font-lock-verbose nil)) (font-lock-fontify-buffer))) (if (ewoc-nth xetla-changes-cookie 0) (goto-char (ewoc-location (ewoc-nth xetla-changes-cookie 0))))) (defun xetla-changes-save (directory) "Run \"tla changes -o\" to create a changeset. The changeset is stored in DIRECTORY." (interactive "FDirectory to store the changeset: ") (xetla-run-tla-sync (list "changes" "-o" directory) :error `(lambda (output error status arguments) (case status (0 (message "xetla-changes-save: 0")) (1 (message (format "xetla-changes-save to %s finished" ,directory))) (otherwise (xetla-default-error-function output error status arguments)))))) (defun xetla-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)) (xetla-changes-save changeset-dir) ;;create the archive: tar cfz ,,cset.tar.gz ,,cset (let ((default-directory (file-name-directory changeset-dir))) ;;(message "Calling tar cfz %s %s" tgz-file-name (file-name-nondirectory changeset-dir)) (call-process "tar" nil nil nil "cfz" tgz-file-name (file-name-nondirectory changeset-dir))) (call-process "rm" nil nil nil "-rf" changeset-dir) (message "Created changeset tarball %s" tgz-file-name))) ;;;###autoload (defun xetla-delta (base modified &optional directory) "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 (xetla-name-construct (xetla-name-read "Base: " 'prompt 'prompt 'prompt 'prompt 'prompt)) (xetla-name-construct (xetla-name-read "Modified: " 'prompt 'prompt 'prompt 'prompt 'prompt)) (when current-prefix-arg 'ask))) (when (eq directory 'ask) (setq directory (read-directory-name "Stored to: " (xetla-tree-root default-directory t) (xetla-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))) (xetla-run-tla-async args :finished `(lambda (output error status arguments) (if ,directory (xetla-delta-show-directory ,directory ',run-dired-p) (xetla-delta-show-diff-on-buffer output ,base ,modified)))))) (defun xetla-delta-show-diff-on-buffer (output base modified) "Show the result of \"delta -diffs\". OUTPUT is the output buffer of the xetla process. BASE is the name of the base revision, and MODIFIED is the name of the modified revision, (then command being run is tla delta BASE MODIFIED)." (with-current-buffer output (let ((no-changes ;; There were no changes if the last line of ;; the buffer is "* changeset report" (save-excursion (goto-char (point-max)) (previous-line 1) (beginning-of-line) (looking-at "^* changeset report"))) buffer) (if no-changes (message (concat "tla delta finished: " "No changes in this arch working copy")) (setq buffer (xetla-prepare-changes-buffer (list 'revision (xetla-name-split base)) (list 'revision (xetla-name-split modified)) 'delta default-directory)) (xetla-show-changes-buffer output nil buffer) (xetla-switch-to-buffer buffer) (message "tla delta finished"))))) (defun xetla-delta-show-directory (directory run-dired-p) "Called by `xetla-delta' to show a changeset in DIRECTORY. If RUN-DIRED-P is non-nil, run dired in the parent directory of the changeset." (xetla-show-changeset directory nil) (when (xetla-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)) (xetla-flash-line))) ;; (defvar xetla-get-changeset-start-time nil) ;; (defvar xetla-changeset-cache (make-hash-table :test 'equal) ;; "The cache for `xetla-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 xetla-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 (xetla-tree-version nil t))) (xetla-name-construct (apply 'xetla-name-read "Revision to view: " (if current-version (append (delete nil (xetla-name-split current-version)) '(prompt)) (list 'prompt 'prompt 'prompt 'prompt 'prompt))))) (not current-prefix-arg))) (let ((buffer (xetla-get-buffer 'changeset revision))) (if buffer (save-selected-window (xetla-switch-to-buffer buffer)) (let* ((dest (or destination (xetla-make-temp-name "xetla-changeset"))) (rev-list (xetla-name-split revision)) (buffer (and justshow (xetla-prepare-changes-buffer (list 'previous-revision rev-list) (list 'revision rev-list) 'changeset revision))) (xetla-switch-to-buffer-mode (if xetla-switch-to-changes-buffer xetla-switch-to-buffer-mode 'show-in-other-window))) (when (and justshow xetla-switch-to-buffer-first) (xetla-switch-to-buffer buffer)) ;; (if (gethash revision xetla-changeset-cache) ;; (progn ;; (message (format "Using changes for revision %S from cache." revision)) ;; (with-current-buffer buffer ;; (let ((buffer-read-only nil)) ;; (insert (cadr (gethash revision xetla-changeset-cache)))))) ;; (setq xetla-get-changeset-start-time (current-time)) (xetla-run-tla-async (list "get-changeset" revision dest) :finished `(lambda (output error status arguments) ;; (let* ((xetla-run-time (time-to-seconds (time-since xetla-get-changeset-start-time))) ;; (cache-revision (or (and (numberp xetla-cache-xetla-get-changeset) ;; (> xetla-run-time xetla-cache-xetla-get-changeset)) ;; (and (not (numberp xetla-cache-xetla-get-changeset)) ;; xetla-cache-xetla-get-changeset))) ;; ) (when ,justshow (xetla-show-changeset ,dest ,without-diff ,buffer) ;; (when cache-revision ;; (message (format "caching result from xetla-get-changeset, xetla-run-time=%S" ;; xetla-run-time)) ;; (with-current-buffer ,buffer ;; (puthash ,revision ;; (list (current-time) ;; (buffer-substring-no-properties (point-min) (point-max))) ;; xetla-changeset-cache))) (call-process "rm" nil nil nil "-rf" ,dest)))))))) ;; )) (defun xetla-prepare-changes-buffer (base modified type path) "Create and return a buffer to run \"tla changes\" or equivalent. Sets the local-variables `xetla-changes-base' and `xetla-changes-modified' are set according to BASE and MODIFIED. TYPE and PATH are passed to `xetla-get-buffer-create'." (with-current-buffer (xetla-get-buffer-create type path) (let ((inhibit-read-only t)) (erase-buffer)) (xetla-changes-mode) (set (make-local-variable 'xetla-changes-base) base) (set (make-local-variable 'xetla-changes-modified) modified) (current-buffer))) (defun xetla-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 `xetla-changes-base' and `xetla-changes-modified'." (interactive (list (let ((changeset-dir (or (xetla-get-file-info-at-point) ""))) (unless (file-directory-p (expand-file-name changeset-dir)) (setq changeset-dir "")) (xetla-uniquify-file-name (read-directory-name "Changeset directory to view: " changeset-dir changeset-dir))))) (unless buffer (setq buffer (xetla-prepare-changes-buffer base modified 'changeset directory)) (if xetla-switch-to-buffer-first (xetla-switch-to-buffer buffer))) (xetla-run-tla-sync (list "show-changeset" (unless without-diff "--diffs") directory) :finished `(lambda (output error status arguments) (xetla-show-changes-buffer output (not ',without-diff) ,buffer ,xetla-switch-to-buffer-first) (xetla-post-switch-to-buffer)))) (defun xetla-show-changeset-from-tgz (file) "Show the archived changeset from a tar.gz FILE. Such a changeset can be created via `xetla-changes-save-as-tgz'." (interactive (list (let ((changeset-tarball (or (xetla-get-file-info-at-point) ""))) (read-file-name "Changeset tarball to view: " nil changeset-tarball t changeset-tarball)))) (let ((temp-dir (xetla-make-temp-name "xetla-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))))) (xetla-show-changeset (concat (xetla-uniquify-file-name temp-dir) changeset-dir)) (call-process "rm" nil nil nil "-rf" temp-dir))) ;;;###autoload (defun xetla-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 (xetla-save-some-buffers target) (y-or-n-p "Apply-change may delete unsaved changes. Continue anyway? ") (error "Not applying")) (xetla-apply-changeset-internal changeset target reverse) (when (y-or-n-p (format "Run inventory at `%s'? " target)) (xetla-inventory target))) (defun xetla-apply-changeset-internal (changeset target reverse) "Actually call \"tla apply-changeset CHANGESET TARGET\". If REVERSE is non-nil, use --reverse too." (xetla-run-tla-sync (list "apply-changeset" (when reverse "--reverse") (when xetla-use-forward-option "--forward") changeset target) :finished `(lambda (output error status arguments) ;; (xetla-show-last-process-buffer) (xetla-show-changes-buffer output) (message "tla apply-changeset finished") (xetla-revert-some-buffers ,target)))) (defun xetla-apply-changeset-from-tgz (file tree) "Apply changeset in FILE to TREE." (interactive "fApply changeset from tarball: \nDApply to tree: ") (let ((target (xetla-tree-root tree)) (temp-dir (xetla-make-temp-name "xetla-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 (xetla-uniquify-file-name temp-dir) (car (delete "." (delete ".." (directory-files temp-dir)))))) (xetla-show-changeset changeset-dir) (when (yes-or-no-p "Apply the changeset? ") (xetla-apply-changeset changeset-dir target)) (call-process "rm" nil nil nil "-rf" temp-dir))) ;;;###autoload (defun xetla-file-ediff-revisions (file &optional base modified) "View changes in FILE between BASE and MODIFIED using ediff." (interactive (let ((version-list (xetla-tree-version-list))) (list (buffer-file-name) (list 'revision (xetla-name-read "Base revision: " (xetla-name-archive version-list) (xetla-name-category version-list) (xetla-name-branch version-list) (xetla-name-version version-list) 'prompt)) (list 'revision (xetla-name-read "Modified revision: " (xetla-name-archive version-list) (xetla-name-category version-list) (xetla-name-branch version-list) (xetla-name-version version-list) 'prompt))))) (xetla-ediff-buffers (xetla-file-get-revision-in-buffer file base) (xetla-file-get-revision-in-buffer file modified))) ;;;###autoload (defun xetla-file-diff (file &optional revision) "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 () (xetla-run-tla-async (list "file-diffs" file revision) :finished (lambda (output error status arguments) (message "No changes in this arch working copy")) :error (lambda (output error status arguments) (if (= 1 status) (xetla-show-last-process-buffer 'file-diff 'diff-mode) (xetla-default-error-function output error status arguments)))))) (defvar xetla-mine-string "TREE") (defvar xetla-his-string "MERGE-SOURCE") (eval-when-compile (defvar smerge-mode)) ;;;###autoload (defun xetla-conflicts-finish () "Command to delete .rej file after conflicts resolution. Asks confirmation if the file still has diff3 markers." (interactive) (if (and (boundp 'smerge-mode) smerge-mode) (progn (when (and (save-excursion (goto-char (point-min)) (xetla-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")) (xetla-funcall-if-exists smerge-mode -1)) (when (not (y-or-n-p (concat "Buffer is not in in smerge-mode. " "Delete .rej file anyway? "))) (error "Not deleting .rej file"))) (let ((rejfile (concat (buffer-file-name) ".rej"))) (if (file-exists-p rejfile) (progn (delete-file rejfile) (message "deleted file %s" rejfile)) (error (format "%s: no such file" rejfile))))) ;;;###autoload (defun xetla-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 xetla 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 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 "*xetla-his*"))) (with-current-buffer his-buffer (erase-buffer) (insert-buffer mine-buffer) (goto-char (point-min)) (while (re-search-forward (concat "^<<<<<<< " (regexp-quote xetla-mine-string) "$") nil t) (beginning-of-line) (delete-region (point) (progn (re-search-forward "^=======\n"))) (re-search-forward (concat "^>>>>>>> " (regexp-quote xetla-his-string) "$")) (beginning-of-line) (delete-region (point) (1+ (point-at-eol))) ) ) (with-current-buffer mine-buffer (goto-char (point-min)) (while (re-search-forward (concat "^<<<<<<< " (regexp-quote xetla-mine-string) "$") nil t) (beginning-of-line) (delete-region (point) (1+ (point-at-eol))) (re-search-forward "^=======$") (beginning-of-line) (delete-region (point) (progn (re-search-forward (concat "^>>>>>>> " (regexp-quote xetla-his-string) "\n")))) )) (xetla-ediff-buffers mine-buffer his-buffer) )) (defun xetla-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 (xetla-file-get-revision-in-file file (list 'revision (xetla-compute-direct-ancestor (cadr revision))))) ((last-revision revision) (let* ((default-directory (if (eq (car revision) 'last-revision) (cadr revision) (xetla-tree-root file))) (revision (if (eq (car revision) 'revision) (xetla-name-construct (cadr revision)))) (original (progn (xetla-run-tla-sync (list "file-find" file revision) :finished 'xetla-null-handler) (with-current-buffer xetla-last-process-buffer (goto-char (point-min)) (re-search-forward "^[^*]") (buffer-substring-no-properties (point-at-bol) (point-at-eol))))) (original-to-be-removed nil) file-unmodified-p) (unless (file-exists-p original) ;; Probably xetla is ran remotely or whatever. Well, get the ;; file using the old good tla file-diff | patch -R -o ... (setq original (xetla-make-temp-name "xetla-ediff") original-to-be-removed t) (xetla-run-tla-sync (list "file-diffs" file revision) :finished 'xetla-null-handler :error (lambda (output error status arguments) (if (not (eq status 1)) (xetla-default-error-function output error status arguments)))) (with-current-buffer xetla-last-process-buffer (if (= (point-min) (point-max)) (setq file-unmodified-p t)) (call-process-region (point-min) (point-max) xetla-patch-executable nil nil nil "-R" "-o" original file))) (list original file-unmodified-p original-to-be-removed))))) (defun xetla-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 `xetla-file-ediff' instead, and undo the changes one by one with the key `b', then save your buffer. As a last chance, `xetla-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 xetla-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 (copy-file file (car (find-backup-file-name file)) t) ;; display diff (xetla-run-tla-sync (list "file-diffs" file revision) :finished (lambda (output error status arguments) (error "File %s is not modified!" (cadr arguments))) :error (lambda (output error status arguments) (if (/= 1 status) (xetla-default-error-function output error status arguments) (xetla-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 xetla-highlight (font-lock-fontify-buffer))) (diff-mode)))))) (let* ((file-unmo-temp (xetla-file-get-revision-in-file file (if revision (list 'revision revision) (list 'last-revision (xetla-tree-root))))) (original (car file-unmo-temp))) (unless (yes-or-no-p (format "Really revert %s? " file)) (bury-buffer) (error "Not reverting file %s!" file)) (bury-buffer) (copy-file original file t) (let ((buf (get-file-buffer file))) (when buf (with-current-buffer buf (revert-buffer)))))) (defun xetla-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." (interactive (if (and (not current-prefix-arg) (y-or-n-p "Use default revision to undo? ")) (list default-directory nil nil nil nil nil) (cons default-directory (xetla-read-revision-with-default-tree "Undo against archive: " default-directory)))) (xetla-undo-internal tree archive category branch version revision)) (defun xetla-undo-internal (tree &optional archive category branch version revision) ; checkdoc-params: (tree archive category branch version revision) "Internal function used by `xetla-undo'." (save-excursion (if archive (xetla-changes nil (xetla-name-construct archive category branch version revision)) (xetla-changes))) (sit-for 1) ;;xetla-changes should start before the yes-or-no-p query (when (yes-or-no-p (if archive (format "Revert whole local tree (%s) from `%s'? " tree (xetla-name-construct archive category branch version revision)) (format "Revert whole local tree (%s) from default revision? " tree))) (let ((default-directory tree)) (xetla-run-tla-sync (if archive (list "undo" (xetla-name-construct archive category branch version revision)) (list "undo")) ;; 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 )) (xetla-revert-some-buffers tree))) (defun xetla-get-undo-changeset-names () "Get the list of directories starting with \",,undo-\". This is used by xetla-redo to get the list of candidates for an undo changeset." (interactive) (directory-files (xetla-tree-root default-directory t) t ",,undo-")) (defun xetla-select-changeset (dir-list) "Select a changeset. DIR-LIST is intended to be the result of `xetla-get-undo-changeset-names'." (completing-read "Select changeset: " (mapcar 'list dir-list) nil nil (car dir-list))) (defun xetla-redo (&optional target) "Run tla redo. If TARGET directroy is given, TARGET should hold undo data generated by `xetla undo'." (interactive) (let* ((undo-changesets (xetla-get-undo-changeset-names)) (undo-changeset (or target (when (= (length undo-changesets) 1) (car undo-changesets)) (xetla-select-changeset undo-changesets)))) (xetla-show-changeset undo-changeset) (when (yes-or-no-p (format "Redo the %s changeset? " undo-changeset)) (xetla-run-tla-sync (list "redo" undo-changeset))))) ;;;###autoload (defun xetla-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 (xetla-file-get-revision-in-buffer file (or revision (list 'last-revision (xetla-tree-root)))))) (when (string= (with-current-buffer original (buffer-string)) (buffer-string)) (error "No modification in this file")) (xetla-ediff-buffers (or (get-file-buffer file) (find-file-noselect file)) original))) ;;;###autoload (defun xetla-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 (xetla-file-get-revision-in-buffer file (or revision (list 'last-revision (xetla-tree-root)))))) (when (string= (with-current-buffer original (buffer-string)) (buffer-string)) (message "No modification in this file")) (xetla-switch-to-buffer original))) (defun xetla-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 `xetla-changes-modified' or `xetla-changes-base'." (let ((name (concat (file-name-nondirectory file) "(" (cond ((eq (car revision) 'revision) (xetla-name-construct (cadr revision))) ((eq (car revision) 'local-tree) (cadr revision)) ((eq (car revision) 'last-revision) "original") ((eq (car revision) 'previous-revision) (xetla-name-construct-semi-qualified (xetla-compute-direct-ancestor (cadr revision)))) (t "")) ")"))) (get-buffer-create (create-file-buffer name)))) (defun xetla-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 `xetla-changes-base' and `xetla-changes-modified'" (let* ((default-directory (xetla-tree-root)) (file-unmo-temp (xetla-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 (xetla-buffer-for-rev file revision))) (with-current-buffer buffer-orig (erase-buffer) (insert-file-contents original) (when original-to-be-removed (delete-file original))) buffer-orig)))) (defun xetla-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 `(lambda () (set-window-configuration ,xetla-window-config)) nil 'local)) (defun xetla-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 xetla-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 xetla-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 xetla-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 xetla-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 xetla-commit-check-log-buffer () "Function to call from the ++log... buffer, before comitting. \(`xetla-commit' calls it automatically). This runs the tests listed in `xetla-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 xetla-commit-check-log-buffer-functions) (funcall function))) ;;;###autoload (defun xetla-commit (&optional handler) "Run tla commit." (interactive) (with-current-buffer (find-file-noselect (xetla-make-log)) (condition-case x (xetla-commit-check-log-buffer) (error (progn (switch-to-buffer (current-buffer)) (eval x)))) (or (xetla-save-some-buffers) (y-or-n-p "Commit with unsaved changes is a bad idea. Continue anyway? ") (error "Not committing")) (let* ((file-list (and (buffer-live-p xetla-buffer-source-buffer) (with-current-buffer xetla-buffer-source-buffer xetla-buffer-marked-file-list))) arglist) (when file-list (setq arglist (append arglist (cons "--" file-list)))) ;; raises an error if commit isn't possible (xetla-run-tla-async (cons "commit" (cons (when xetla-strict-commits "--strict") (when file-list (cons "--" file-list)))) :finished handler)))) (defun xetla-import () "Run tla import." (interactive) (with-current-buffer (find-file-noselect (xetla-make-log))) (xetla-run-tla-sync (list "import") :finished 'xetla-null-handler)) ;;;###autoload (defun xetla-rm (file) "Call tla rm on file FILE. Prompts for confirmation before." (interactive) (when (yes-or-no-p (format "Delete file %s? " file)) (xetla-run-tla-sync (list "rm" file) :finished 'xetla-null-handler))) (defun xetla-pristines () "Run \"tla pristine\"." (interactive) (xetla-run-tla-sync '("pristines"))) ;;;###autoload (defun xetla-changelog () "Run \"tla changelog\". display the result in an improved ChangeLog mode." (interactive) (let ((default-directory (xetla-read-project-tree-maybe))) (xetla-run-tla-sync '("changelog") :finished 'xetla-null-handler) (xetla-show-last-process-buffer 'changelog 'xetla-changelog-mode) (goto-char (point-min)))) ;;;###autoload (defun xetla-logs () "Run tla logs." (interactive) (let ((default-directory (xetla-read-project-tree-maybe)) ; (details (or xetla-revisions-shows-date ; xetla-revisions-shows-creator ; xetla-revisions-shows-summary)) ) (xetla-run-tla-async (list "logs" "--full" ; (when details "-date") ; (when details "-creator") ; (when details "-summary")) ) :finished `(lambda (output error status arguments) (let ((buffer (xetla-get-buffer-create 'logs (xetla-tree-root)))) (xetla-switch-to-buffer buffer) (xetla-revision-list-mode) (xetla-revisions-parse-list 'logs nil ;;,details nil ;; TODO (merges) output nil xetla-revision-list-cookie) (set (make-local-variable 'xetla-buffer-refresh-function) 'xetla-logs)))))) ;;;###autoload (defun xetla-help (command) "Run tla COMMAND -H." (interactive (list (completing-read "Get help for: " (xetla-run-tla-sync '("help") :finished `(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))))))) (xetla-run-tla-sync (list command "-H"))) (defun xetla-tree-version-list-tla () "Return the tree version, or nil if not in a project tree." (xetla-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 xetla-tree-version-list (&optional location no-error) "Elisp implementation of `xetla-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 (xetla-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 xetla-tree-root-xetla () "Run tla tree-root." (interactive) (xetla-run-tla-sync '("tree-root") :finished `(lambda (output error status arguments) (let ((result (xetla-buffer-content output))) (when ,(interactive-p) (message "tla tree-root is: %s" result)) result)))) ;;;###autoload (defun xetla-tree-version (&optional location no-error) "Equivalent of xetla 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 (xetla-tree-root location no-error)) (default-version-file (when tree-root (expand-file-name "{arch}/++default-version" tree-root))) (version (and (boundp 'xetla-buffer-version-name) xetla-buffer-version-name))) (if (and (null 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) (if (eq (char-before (point-max)) ?\n) (1- (point-max)) (point-max)))))) (when (interactive-p) (message "%s" version)) version)) ;;;###autoload (defun xetla-my-id (&optional arg my-id) "Run tla my-id. When called without a prefix argument ARG, just print the my-id from xetla 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 <jane.hacker(a)email.address&gt;&quot; (interactive "P") (let ((id (xetla-run-tla-sync '("my-id") :finished (lambda (output error status arguments) (xetla-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 xetla-my-id-history id)))) (if (string= id new-id) (message "Id unchanged! Id = %s" new-id) (message "Setting id to: %s" new-id) (xetla-run-tla-sync (list "my-id" new-id) :finished (lambda (output error status arguments) (message "Id changed")) :error (lambda (output error status arguments) (message "Could not change Id") (xetla-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.") "xetla-set-my-id")) ""))))) (defun xetla-set-my-id () "Set xetla's my-id." (interactive) (xetla-my-id 1)) ;; ;; Library ;; ;;;###autoload (defun xetla-my-revision-library (&optional arg) "Run tla my-revision-library. When called without a prefix argument ARG, just print the my-revision-library from xetla. 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 `xetla-library-config'." (interactive "P") (let ((result (xetla-run-tla-sync '("my-revision-library") :finished 'xetla-status-handler :error 'xetla-null-handler)) (rev-lib (xetla-get-process-output))) (when (eq 0 result) (if arg (xetla-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 xetla-library-add-interactive (&optional old-rev-lib) "Prompts for argument and run `xetla-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 (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) (xetla-library-add-internal new-rev-lib)) old-rev-lib))) (defun xetla-library-delete (rev-lib) "Unregister revision library REV-LIB." (interactive (list (xetla-read-revision-library))) (xetla-run-tla-sync (list "my-revision-library" "--delete" rev-lib) :finished (lambda (output error status arguments) (message "Library %s removed." rev-lib)))) (defun xetla-library-add-internal (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)) (xetla-run-tla-sync (list "my-revision-library" new-rev-lib) :finished (lambda (output error status arguments) (message (xetla-buffer-content output)))) new-rev-lib)) (defun xetla-revision-library-list () "Parse `xetla my-revision-library' into a list of revision libraries." (xetla-run-tla-sync '("my-revision-library") :finished 'xetla-output-buffer-split-handler)) (defvar xetla-library-history nil) (defun xetla-read-revision-library (&optional prompt) "Read a revision library from keyboard. Prompt the user with PROMPT if given." (let ((list-lib (xetla-revision-library-list))) (if (null (cdr list-lib)) (car list-lib) (completing-read (or prompt (format "Revision library (default %s): " (car list-lib))) (mapcar 'list (xetla-revision-library-list)) nil t nil xetla-library-history (car list-lib))))) (defun xetla-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 (xetla-read-revision-library)) (config-param (when arg (completing-read "tla library config " (mapcar 'list '("--greedy" "--sparse" "--non-greedy" "--non-sparse")) nil t "--")))) (xetla-run-tla-sync (list "library-config" config-param rev-lib) :finished 'xetla-null-handler) (message (xetla-get-process-output)))) (defun xetla-library-add (archive category branch version revision) "Add ARCHIVE-CATEGORY-BRANCH-VERSION-REVISION to the revision library." (xetla-show-last-process-buffer) (xetla-run-tla-async `("library-add" ,(xetla-name-construct archive category branch version revision)))) (defun xetla-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 (xetla-run-tla-sync (list "library-find" (when silent "--silent") (xetla-name-construct archive category branch version revision)) :finished 'xetla-status-handler :error 'xetla-status-handler)) (xetla-get-process-output))) ;; completing-read: tagline, explicit, names, implicit (defvar xetla-id-tagging-method-history nil) ;;;###autoload (defun xetla-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 (xetla-run-tla-sync '("id-tagging-method") :finished (lambda (output error status arguments) (xetla-buffer-content output))))) (new-tagging-method)) (if arg (progn (setq new-tagging-method (xetla-id-tagging-method-read tm)) (when (not (string= tm new-tagging-method)) (xetla-id-tagging-method-set new-tagging-method))) (when (interactive-p) (message "Arch id tagging method: %s" tm)) tm ))) (defun xetla-id-tagging-method-read (old-method) "Read id tagging method. If OLD-METHOD is given, use it as the default method." (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 xetla-id-tagging-method-history old-method)) (defun xetla-id-tagging-method-set (method) "Set the tagging method to METHOD." (message "Setting tagging method to: %s" method) (xetla-run-tla-sync (list "id-tagging-method" method) :finished 'xetla-null-handler)) (defun xetla-archive-mirror (archive &optional category branch version from) "Synchronize the mirror for ARCHIVE. Limit to CATEGORY-BRANCH-VERSION. If FROM is provided, mirror from it." (interactive (xetla-name-read nil 'prompt)) (let ((name (xetla-name-construct-semi-qualified category branch version))) (when (string= name "") (setq name nil)) (xetla-run-tla-async (list "archive-mirror" archive name from) :finished `(lambda (output error status arguments) (message "tla archive-mirror finished")) ))) (defun xetla-archive-fixup (archive) "Run tla archive-fixup for ARCHIVE." (interactive (list (car (xetla-name-read "Archive to fixup: " 'prompt)))) (xetla-run-tla-async (list "archive-fixup" "-A" archive) :finished `(lambda (output error status arguments) (message "tla archive-fixup %s finished" ,archive)) )) (defun xetla-star-merge (from &optional to-tree) "Star merge from version/revision FROM to local tree TO-TREE." (let ((to-tree (when to-tree (expand-file-name to-tree)))) (or (xetla-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)) (arglist '()) (buffer (xetla-prepare-changes-buffer (list 'last-revision default-directory) (list 'local-tree default-directory) ;; TODO using xetla-changes here makes it simpler. ;; The user can just type `g' and get the real ;; changes. Maybe a 'star-merge would be better ;; here ... 'changes default-directory))) (when xetla-switch-to-buffer-first (xetla-switch-to-buffer buffer)) (when xetla-three-way-merge (add-to-list 'arglist "--three-way")) (when xetla-use-forward-option (add-to-list 'arglist "--forward")) (xetla-run-tla-async `("star-merge" ,＠arglist ,from) :finished `(lambda (output error status arguments) ;; (xetla-show-last-process-buffer) (xetla-show-changes-buffer output nil ,buffer) (message "tla star-merge finished") (xetla-revert-some-buffers ,to-tree)) :error `(lambda (output error status arguments) (case status ;; 2 stands for an error. (2 (xetla-default-error-function output error status arguments)) ;; How about other status? (otherwise (xetla-show-changes-buffer output) output nil ,buffer))))))) (defun xetla-replay-arguments () "Build an argument list for the replay command. Used to factorize the code of (interactive ...) between `xetla-replay-reverse' and `xetla-replay'." (list (xetla-name-construct (xetla-name-read "Relay version or revision: " 'prompt 'prompt 'prompt 'prompt 'maybe)) (read-directory-name "Replay in tree: ") current-prefix-arg)) (defun xetla-replay-reverse (from &optional to-tree arg) "Call `xetla-replay' with the REVERSE option." (interactive (xetla-replay-arguments)) (xetla-replay from to-tree arg t)) (defun xetla-replay (from &optional to-tree arg 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 ARG is non-nil, replay all the version instead of the revision only. If REVERSE is non-nil, reverse the requested revision." (interactive (xetla-replay-arguments)) (let ((default-directory (or to-tree default-directory))) (or (xetla-save-some-buffers) (y-or-n-p "Replay may delete unsaved changes. Continue anyway? ") (error "Not replaying")) (xetla-show-last-process-buffer) (let ((buffer (xetla-prepare-changes-buffer (list 'last-revision default-directory) (list 'local-tree default-directory) 'changes default-directory))) (when xetla-switch-to-buffer-first (xetla-switch-to-buffer buffer)) (xetla-run-tla-async `("replay" ,(when xetla-use-forward-option "--forward") ,(when reverse "--reverse") ,(when xetla-use-skip-present-option "--skip-present") ,＠(if (listp from) from (list from))) :finished `(lambda (output error status arguments) (xetla-show-changes-buffer output nil ,buffer) (message "tla replay finished") (xetla-revert-some-buffers ,to-tree)) :error (lambda (output error status arguments) (xetla-show-error-buffer error) (xetla-show-last-process-buffer)))))) (defun xetla-sync-tree (from &optional to-tree) "Synchronize the patch logs of revision FROM and tree TO-TREE." (interactive (list (xetla-name-construct (xetla-name-read "Sync tree with revision: " 'prompt 'prompt 'prompt 'prompt 'prompt)) (read-directory-name "Sync tree: "))) (let ((default-directory (or to-tree default-directory))) (or (xetla-save-some-buffers) (y-or-n-p "Update may delete unsaved changes. Continue anyway? ") (error "Not updating")) (xetla-show-last-process-buffer) (xetla-run-tla-async `("sync-tree" ,from) :finished `(lambda (output error status arguments) (xetla-show-last-process-buffer) (message "tla sync-tree finished") (xetla-revert-some-buffers ,to-tree)) :error (lambda (output error status arguments) (xetla-show-changes-buffer output))))) (defun xetla-tag (source-revision tag-version) "Create a tag from SOURCE-REVISION to TAG-VERSION. Run tla tag --setup." (interactive (list (xetla-name-construct (xetla-name-read "Source revision (or version): " 'prompt 'prompt 'prompt 'prompt 'maybe)) (xetla-name-construct (xetla-name-read "Tag version: " 'prompt 'prompt 'prompt 'prompt)))) (xetla-run-tla-async (list "tag" "--setup" source-revision tag-version))) (defun xetla-set-tree-version (version) "Run tla set-tree-version VERSION." (interactive (list (xetla-name-read "Set tree version to: " 'prompt 'prompt 'prompt 'prompt))) (let ((new-version (xetla-name-construct version)) (old-version (xetla-tree-version))) (when (y-or-n-p (format "Switch tree version from `%s' to `%s'? " old-version new-version)) (xetla-run-tla-sync (list "set-tree-version" new-version))))) ;; -------------------------------------- ;; Xetla bookmarks ;; -------------------------------------- (make-face 'xetla-bookmark-name "Face used for bookmark names.") (set-face-foreground 'xetla-bookmark-name "magenta") (defvar xetla-bookmarks-loaded nil "Whether `xetla-bookmarks' have been loaded from file.") (defvar xetla-bookmarks-alist nil "Alist containing Xetla bookmarks.") (defvar xetla-bookmarks-show-details nil "Whether `xetla-bookmarks' should show bookmark details.") (defvar xetla-bookmarks-cookie nil "Ewoc dll.") (defvar xetla-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 xetla-bookmarks-marked-list nil "A list of marked bookmarks.") (defun xetla-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 xetla-bookmarks-loaded)) (let ((file (xetla-config-file-full-path xetla-bookmarks-file-name t))) (save-excursion (unless (file-exists-p file) (with-temp-buffer (insert "()") (write-file file))) (unless (file-readable-p file) (error "Xetla bookmark file not readable")) (with-temp-buffer (insert-file-contents file) (setq xetla-bookmarks-alist (read (current-buffer)) xetla-bookmarks-loaded t)))))) (defun xetla-bookmarks-load-from-file (&optional force) "Load bookmarks from the file `xetla-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 xetla-bookmarks-loaded)) (xetla-load-state (xetla-config-file-full-path xetla-bookmarks-file-name t)) (setq xetla-bookmarks-loaded t)) (error (progn (xetla-bookmarks-load-from-file-OBSOLETE force))))) (defun xetla-bookmarks-save-to-file () "Save `xetla-bookmarks-alist' to the file `xetla-bookmarks-file-name'." (xetla-save-state '(xetla-bookmarks-alist) (xetla-config-file-full-path xetla-bookmarks-file-name t) t)) (defun xetla-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 xetla-bookmarks-cookie))) (setq xetla-bookmarks-show-details (if val (if (> val 0) t (if (< val 0) nil (not xetla-bookmarks-show-details))) (not xetla-bookmarks-show-details))) (ewoc-refresh xetla-bookmarks-cookie) (xetla-bookmarks-cursor-goto current-bookmark))) (defvar xetla-bookmarks-align 19 "Position, in chars, of the `:' when displaying the bookmarks buffer.") (defun xetla-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 xetla-bookmarks-marked-list) (concat " " xetla-mark " ") " ")) (xetla-insert-right-justified (concat (car element) ": ") (- xetla-bookmarks-align 3) 'xetla-bookmark-name) (insert (xetla-face-add (xetla-name-construct (cdr (assoc 'location (cdr element)))) 'xetla-revision-name 'xetla-bookmarks-entry-map xetla-bookmarks-entry-menu )) (when xetla-bookmarks-show-details (newline) (insert-char ?\ xetla-bookmarks-align) (insert (cdr (assoc 'timestamp (cdr element)))) (newline) (let ((notes (assoc 'notes (cdr element)))) (when notes (insert-char ?\ xetla-bookmarks-align) (insert (cdr notes)) (newline))) (let ((nickname (assoc 'nickname (cdr element)))) (when nickname (xetla-insert-right-justified "nickname: " xetla-bookmarks-align) (insert (cadr nickname)) (newline))) (let ((partners (assoc 'partners (cdr element)))) (when partners (xetla-insert-right-justified "partners: " xetla-bookmarks-align) (insert (cadr partners)) (dolist (x (cddr partners)) (insert ",\n") (insert-char ?\ xetla-bookmarks-align) (insert x)) (newline))) (let ((local-tree (assoc 'local-tree (cdr element)))) (when local-tree (xetla-insert-right-justified "local trees: " xetla-bookmarks-align) (insert (cadr local-tree)) (dolist (x (cddr local-tree)) (insert ", " x )) (newline))) (let ((groups (assoc 'groups (cdr element)))) (when groups (xetla-insert-right-justified "Groups: " xetla-bookmarks-align) (insert (cadr groups)) (dolist (x (cddr groups)) (insert ", " x )) (newline))) (let ((summary-format (assoc 'summary-format (cdr element)))) (when summary-format (xetla-insert-right-justified "Summary format: " xetla-bookmarks-align) (insert "\"" (cadr summary-format) "\"") (newline))))) (defvar xetla-revision-list-cookie nil "Ewoc cookie for xetla-bookmark-missing.") (defun xetla-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* ((bookmark (or bookmark (ewoc-data (ewoc-locate xetla-bookmarks-cookie)))) (local-trees (assoc 'local-tree (cdr bookmark)))) (cond ((not local-trees) (let ((dir (read-directory-name (format "Local tree for \"%s\": " (car bookmark))))) (when (y-or-n-p "Add this tree in your bookmarks? ") (xetla-bookmarks-add-tree bookmark dir)) dir)) (arg ;; multiple local trees. (let ((dir (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? ")) (xetla-bookmarks-add-tree bookmark dir)) (when (and (not (string= dir (cadr local-trees))) (y-or-n-p "Make this the default? ")) (xetla-bookmarks-delete-tree bookmark dir) (xetla-bookmarks-add-tree bookmark dir)) dir)) (t (cadr local-trees))))) (defun xetla-bookmarks-missing (&optional arg) "Show the missing patches from your partners. The missing patches are received via xetla 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 xetla-bookmarks-cookie (error "Please, run this command from the bookmarks buffer%s" " (M-x xetla-bookmarks RET)")) (let ((list (or xetla-bookmarks-marked-list (list (ewoc-data (ewoc-locate xetla-bookmarks-cookie)))))) (set-buffer (xetla-get-buffer-create 'missing)) (xetla-revision-list-mode) (set (make-local-variable 'xetla-buffer-refresh-function) 'xetla-missing-refresh) (let ((xetla-bookmarks-missing-buffer-list-elem (mapcar #'(lambda (elem) (cons elem (xetla-bookmarks-read-local-tree elem arg))) list))) (set (make-local-variable 'xetla-missing-buffer-todolist) (reverse (apply 'append (mapcar (lambda (elem) (xetla-bookmarks-missing-elem (car elem) arg (cdr elem) t t)) xetla-bookmarks-missing-buffer-list-elem)))) (xetla-missing-refresh)))) (defvar xetla-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 xetla-missing-refresh () "Refreshed a *xetla-missing* buffer. Process the variable `xetla-missing-buffer-todolist' and launches the xetla processes with the appropriate handlers to fill in the ewoc." (interactive) (set (make-local-variable 'xetla-nb-active-processes) 1) (let ((buffer-read-only nil)) (erase-buffer) (set (make-local-variable 'xetla-revision-list-cookie) (ewoc-create 'xetla-revision-list-printer)) (xetla-kill-process-maybe (current-buffer)) (dolist (item xetla-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 <local tree> <fully qualified version> [bookmark name]) (let* ((local-tree (nth 1 item)) (version (nth 2 item)) (bookmark-name (nth 3 item)) (text (if bookmark-name (format "Missing patches from partner %s:" bookmark-name) (concat "Missing patches from archive " version))) (node (ewoc-enter-last xetla-revision-list-cookie (list 'separator (concat text) 'partner)))) (ewoc-enter-last xetla-revision-list-cookie '(message "Checking for missing patches...")) (let ((default-directory local-tree)) ;; Set the default-directory for the *xetla-missing* buffer. (cd default-directory) (setq xetla-nb-active-processes (+ xetla-nb-active-processes 1)) (xetla-run-tla-async `("missing" "--full" ,(when xetla-use-skip-present-option "--skip-present");;"-summary" "-creator" "-date" ,version) :finished `(lambda (output error status arguments) (when (and (xetla-get-buffer 'missing) (buffer-live-p (xetla-get-buffer 'missing))) (with-current-buffer (xetla-get-buffer-create 'missing) (when (ewoc-p xetla-revision-list-cookie) (let* ((cookie xetla-revision-list-cookie) (to-delete (ewoc-next cookie ,node)) (prev (ewoc-prev xetla-revision-list-cookie to-delete)) (cur (ewoc-locate xetla-revision-list-cookie)) (deleted (eq cur to-delete))) (xetla-revisions-parse-list 'missing nil nil output ,node cookie 'xetla-revision-compute-merged-by ) (ewoc--node-delete to-delete) (ewoc-refresh xetla-revision-list-cookie) (let ((loc (if deleted (ewoc-next xetla-revision-list-cookie prev) cur))) (when loc (goto-char (ewoc-location loc))))))))) :error `(lambda (output error status arguments) (when (and (xetla-get-buffer 'missing) (buffer-live-p (xetla-get-buffer 'missing))) (with-current-buffer (xetla-get-buffer-create 'missing) (when (ewoc-p xetla-revision-list-cookie) (let* ((cookie xetla-revision-list-cookie) (to-delete (ewoc-next cookie ,node))) (setcdr (ewoc-data to-delete) '("Error in xetla process")))))) (message "Abnormal exit with code %d!\n%s" status (xetla-buffer-content error))))))) (separator ;; This item is a separator - the name of a bookmark. ;; ITEM is of the form: ;; (separator <text> bookmark <local tree>) (let* ((text (nth 1 item)) (local-tree (nth 3 item))) (ewoc-enter-last xetla-revision-list-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 <local tree>) (let ((to-delete (ewoc-enter-last xetla-revision-list-cookie '(message "Checking for local changes...")))) (let ((default-directory (nth 1 item))) (xetla-run-tla-async '("changes") :error `(lambda (output error status arguments) (with-current-buffer ,(current-buffer) (let* ((prev (ewoc-prev xetla-revision-list-cookie ,to-delete)) (cur (ewoc-locate xetla-revision-list-cookie)) (deleted (eq cur ,to-delete))) (xetla-bookmarks-missing-parse-changes output ,(ewoc-nth xetla-revision-list-cookie -1)) (ewoc--node-delete ,to-delete) (ewoc-refresh xetla-revision-list-cookie) (let ((loc (if deleted (ewoc-next xetla-revision-list-cookie prev) cur))) (when loc (goto-char (ewoc-location loc))))))) :finished `(lambda (output error status arguments) (with-current-buffer ,(current-buffer) (let* ((prev (ewoc-prev xetla-revision-list-cookie ,to-delete)) (cur (ewoc-locate xetla-revision-list-cookie)) (deleted (eq cur ,to-delete))) (ewoc--node-delete ,to-delete) (ewoc-refresh xetla-revision-list-cookie) (let ((loc (if deleted (ewoc-next xetla-revision-list-cookie prev) cur))) (when loc (goto-char (ewoc-location loc))))))) ))))) (ewoc-set-hf xetla-revision-list-cookie "" (concat "\n" (xetla-face-add "end." 'xetla-separator))))) (goto-char (point-min)) ;; If all processes have been run synchronously, ;; xetla-nb-active-processes is 1 now, and we should run the ;; callback. (setq xetla-nb-active-processes (- xetla-nb-active-processes 1)) (when (zerop xetla-nb-active-processes) (xetla-revision-compute-merged-by)) ) (defun xetla-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 a struct of type xetla-revisions." (ewoc-map (lambda (elem) (when (eq (car elem) 'entry-patch) (funcall function (caddr elem)))) ewoc-list)) (defvar xetla-revision-merge-by-computed nil "Non-nil when the \"merged-by\" field have been computed.") (defun xetla-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) (xetla-revision-ewoc-map (lambda (elem) (setf (xetla-revision-merged-by elem) nil)) xetla-revision-list-cookie) (xetla-revision-ewoc-map 'xetla-set-merged-patches xetla-revision-list-cookie) (xetla-revision-ewoc-map (lambda (elem) (unless (xetla-revision-merged-by elem) (setf (xetla-revision-merged-by elem) 'nobody))) xetla-revision-list-cookie) (set (make-local-variable 'xetla-revision-merge-by-computed) t) ) (eval-when-compile (defvar xetla-merged-rev)) (defun xetla-set-merged-patches (rev) "Set the \"merged-by\" field for other revisions according to REV. Adds REV to the list of all patches merged by REV." (dolist (merged-rev (xetla-revision-merges rev)) (setq xetla-merged-rev merged-rev) (xetla-revision-ewoc-map `(lambda (rev-to-fill) (when (equal (xetla-name-construct (xetla-revision-revision rev-to-fill)) xetla-merged-rev) (setf (xetla-revision-merged-by rev-to-fill) (cons ,(xetla-name-construct (xetla-revision-revision rev)) (xetla-revision-merged-by rev-to-fill))))) xetla-revision-list-cookie))) (defun xetla-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))))) (xetla-switch-to-buffer (xetla-get-buffer-create '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) (xetla-name-construct location)) bookmark ,local-tree)) (when changes-too (add-to-list 'item `(changes ,local-tree))) (dolist (partner (cons (xetla-name-construct (cdr (assoc 'location (cdr data)))) ; Me (cdr partners))) ; and my partners (let* ((bookmark-list (mapcar (lambda (bookmark) (and (string= partner (xetla-name-construct (cdr (assoc 'location bookmark)))) (car bookmark))) xetla-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 xetla-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 xetla-revisions-parse-list (type details merges buffer parent-node cookie &optional callback) "Parse a list of revisions. TYPE can be either 'logs, '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 'xetla-revision-merge-by-computed) nil)) (let ((last-node parent-node) revision) (with-current-buffer (with-current-buffer buffer (clone-buffer)) (goto-char (point-min)) (re-search-forward ".*/.*--.*--.*--.*" nil t) (beginning-of-line) (while (progn (> (point-max) (point))) (setq revision (buffer-substring-no-properties (point) (point-at-eol))) (forward-line 1) (let* ((rev-struct (make-xetla-revision :revision (xetla-name-split revision))) (elem (list 'entry-patch nil rev-struct))) (when (or xetla-revisions-shows-summary xetla-revisions-shows-creator xetla-revisions-shows-date xetla-revisions-shows-merges xetla-revisions-shows-merged-by) (with-current-buffer (ewoc-buffer cookie) (setq xetla-nb-active-processes (+ xetla-nb-active-processes 1)) (xetla-cat-log-any (xetla-name-split revision) nil `(lambda (output error status arguments) (with-current-buffer output (setf (xetla-revision-date ,rev-struct) (xetla-read-field "Standard-date")) (setf (xetla-revision-creator ,rev-struct) (xetla-read-field "Creator")) (setf (xetla-revision-summary ,rev-struct) (xetla-read-field "Summary")) (setf (xetla-revision-merges ,rev-struct) (remove ,revision (split-string (xetla-read-field "New-patches"))))) (with-current-buffer ,(ewoc-buffer cookie) (setq xetla-nb-active-processes (- xetla-nb-active-processes 1)) (when (and ',callback (zerop xetla-nb-active-processes)) (funcall ',callback))) (let* ((cur (ewoc-locate xetla-revision-list-cookie))) (ewoc-refresh ,cookie) (when cur (goto-char (ewoc-location cur)))))))) (if last-node (setq last-node (ewoc-enter-after cookie last-node elem)) (ewoc-enter-last cookie elem)))) (kill-buffer (current-buffer))) (with-current-buffer (ewoc-buffer cookie) (setq xetla-nb-active-processes (- xetla-nb-active-processes 1)) (when (and callback (zerop xetla-nb-active-processes)) (funcall callback)))) (ewoc-refresh cookie)) (defun xetla-bookmarks-missing-parse-changes (buffer parent-node) "Parse the output of `xetla 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 (point-at-bol) (point-max))))) (local-tree default-directory)) (when changes (with-current-buffer (xetla-get-buffer-create 'missing) (ewoc-enter-after xetla-revision-list-cookie parent-node (list 'entry-change changes local-tree))))))) (defun xetla-bookmarks-open-tree () "Open a local tree in a dired buffer." (interactive) (dired-other-window (xetla-bookmarks-read-local-tree))) (defun xetla-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 (xetla-uniquify-file-name (xetla-bookmarks-read-local-tree)))) (call-interactively 'find-file))) (defun xetla-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 xetla-bookmarks-cookie (error "Please, run this command from the bookmarks buffer%s" " (M-x xetla-bookmarks RET)")) (let ((list (or xetla-bookmarks-marked-list (list (ewoc-data (ewoc-locate xetla-bookmarks-cookie)))))) (let ((tags (mapcar (lambda (bookmark) (let ((location (xetla-name-construct (if arg (apply 'xetla-name-read "Tag from revision: " (append (cdr (assoc 'location bookmark)) '(prompt))) (cdr (assoc 'location bookmark)))))) (list location (xetla-name-construct (xetla-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 (xetla-run-tla-async (list "tag" "--setup" src destination) :finished `(lambda (output error status arguments) (xetla-bookmarks-add ,name (xetla-name-split ,destination)) (xetla-bookmarks-add-partner (assoc ,name xetla-bookmarks-alist) ,src t)) :error `(lambda (output error status arguments) (error "Fail to create a tag for %s" ,src)))))) (setq xetla-bookmarks-marked-list nil) (ewoc-refresh xetla-bookmarks-cookie))) (defun xetla-bookmarks-inventory () "Run `tla inventory' on a local tree." (interactive) (let ((default-directory (xetla-bookmarks-read-local-tree))) (xetla-inventory nil t))) (defun xetla-bookmarks-changes () "Run `xetla-changes' on a local tree." (interactive) (let ((default-directory (xetla-bookmarks-read-local-tree))) (xetla-changes nil nil))) (defmacro xetla-make-move-fn (ewoc-direction function cookie &optional only-unmerged) "Create function to move up or down in `xetla-revision-list-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." `(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 (xetla-revision-merged-by (caddr (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 (xetla-revision-merged-by (caddr (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))))) ) (xetla-make-move-fn ewoc-next xetla-revision-next xetla-revision-list-cookie) (xetla-make-move-fn ewoc-prev xetla-revision-prev xetla-revision-list-cookie) (xetla-make-move-fn ewoc-next xetla-revision-next-unmerged xetla-revision-list-cookie t) (xetla-make-move-fn ewoc-prev xetla-revision-prev-unmerged xetla-revision-list-cookie t) ;;;###autoload (defun xetla-bookmarks (&optional arg) "Display xetla bookmarks in a buffer. With prefix argument ARG, reload the bookmarks file from disk." (interactive "P") (xetla-bookmarks-load-from-file arg) (pop-to-buffer "*xetla-bookmarks*") (let ((pos (point))) (toggle-read-only -1) (erase-buffer) (set (make-local-variable 'xetla-bookmarks-cookie) (ewoc-create 'xetla-bookmarks-printer)) (set (make-local-variable 'xetla-bookmarks-marked-list) nil) (dolist (elem xetla-bookmarks-alist) (ewoc-enter-last xetla-bookmarks-cookie elem)) (xetla-bookmarks-mode) (if (equal pos (point-min)) (if (ewoc-nth xetla-bookmarks-cookie 0) (xetla-bookmarks-cursor-goto (ewoc-nth xetla-bookmarks-cookie 0)) (message "You have no bookmarks, create some in the other buffers")) (goto-char pos)))) (defun xetla-bookmarks-mode () "Major mode to show xetla bookmarks. You can add a bookmark with '\\<xetla-bookmarks-mode-map>\\[xetla-bookmarks-add]', and remove one with '\\[xetla-bookmarks-delete]'. After marking a set of files with '\\[xetla-bookmarks-mark]', make them partners with '\\[xetla-bookmarks-marked-are-partners]', and you will then be able to use '\\[xetla-bookmarks-missing]' to view the missing patches. Commands: \\{xetla-bookmarks-mode-map}" (interactive) (use-local-map xetla-bookmarks-mode-map) (setq major-mode 'xetla-bookmarks-mode) (setq mode-name "xetla-bookmarks") (toggle-read-only 1) (run-hooks 'xetla-bookmarks-mode-hook)) (defun xetla-bookmarks-cursor-goto (ewoc-bookmark) "Move cursor to the ewoc location of EWOC-BOOKMARK." (interactive) (goto-char (ewoc-location ewoc-bookmark)) (search-forward ":")) (defun xetla-bookmarks-next () "Move the cursor to the next bookmark." (interactive) (let* ((cookie xetla-bookmarks-cookie) (elem (ewoc-locate cookie)) (next (or (ewoc-next cookie elem) elem))) (xetla-bookmarks-cursor-goto next))) (defun xetla-bookmarks-previous () "Move the cursor to the previous bookmark." (interactive) (let* ((cookie xetla-bookmarks-cookie) (elem (ewoc-locate cookie)) (previous (or (ewoc-prev cookie elem) elem))) (xetla-bookmarks-cursor-goto previous))) (defun xetla-bookmarks-move-down () "Move the current bookmark down." (interactive) (let* ((cookie xetla-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")) (xetla-ewoc-delete cookie elem) (goto-char (ewoc-location (ewoc-enter-after cookie next data))) (let ((list xetla-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 xetla-bookmarks-alist (reverse newlist))) (search-forward ":"))) (defun xetla-bookmarks-move-up () "Move the current bookmark up." (interactive) (let* ((cookie xetla-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")) (xetla-ewoc-delete cookie elem) (goto-char (ewoc-location (ewoc-enter-before cookie previous data))) (let ((list xetla-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 xetla-bookmarks-alist (reverse newlist))) (search-forward ":"))) (defun xetla-get-location-as-string () "Construct an a/c-b-v-r string from the current bookmark." (let* ((elem (ewoc-data (ewoc-locate xetla-bookmarks-cookie))) (location (cdr (assoc 'location elem)))) (xetla-name-construct location))) (defun xetla-bookmarks-get (directory) "Run `tla get' on the bookmark under point, placing the tree in DIRECTORY." (interactive (list (expand-file-name (read-directory-name (format "Get %s in directory: " (xetla-get-location-as-string)))))) (let* ((elem (ewoc-data (ewoc-locate xetla-bookmarks-cookie))) (location (cdr (assoc 'location elem)))) (xetla-get directory t (xetla-name-archive location) (xetla-name-category location) (xetla-name-branch location) (xetla-name-version location)))) (defun xetla-bookmarks-goto () "Browse the archive of the current bookmark." (interactive) (let* ((elem (ewoc-data (ewoc-locate xetla-bookmarks-cookie))) (location (cdr (assoc 'location elem))) (archive (xetla-name-archive location)) (category (xetla-name-category location)) (branch (xetla-name-branch location)) (version (xetla-name-version location))) (cond (version (xetla-revisions archive category branch version)) (branch (xetla-versions archive category branch)) (category (xetla-branches archive category)) (archive (xetla-categories archive)) (t (error "Nothing specified for this bookmark"))))) (xetla-make-bymouse-function xetla-bookmarks-goto) (defun xetla-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 xetla-bookmarks-cookie))) (location (cdr (assoc 'location elem))) (local-tree (read-directory-name "Star-merge into: "))) (xetla-star-merge (xetla-name-construct location) local-tree))) (defun xetla-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 xetla-bookmarks-cookie))) (location (xetla-name-construct (cdr (assoc 'location elem)))) (local-tree (read-directory-name (format "Replay %s into: " location)))) (xetla-replay location local-tree))) (defun xetla-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 xetla-bookmarks-marked-list (list (ewoc-data (ewoc-locate xetla-bookmarks-cookie))))) (update-trees (mapcar (lambda (bookmark) (let ((local-trees (cdr (assoc 'local-tree bookmark)))) (xetla-uniquify-file-name (cond ((null local-trees) (read-directory-name (format "Local tree for '%s'?: " (car bookmark)) nil nil t)) ((not (null (cdr local-trees))) (completing-read (format "Local tree for '%s'?: " (car bookmark)) local-trees nil t)) (t (car local-trees)))))) work-list))) (mapc 'xetla-update update-trees) (with-current-buffer buf (setq xetla-bookmarks-marked-list '()) (ewoc-refresh xetla-bookmarks-cookie)))) (defun xetla-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 xetla-bookmarks-alist) (error (concat "Already got a bookmark " name))) (let ((elem (cons name info))) (add-to-list 'xetla-bookmarks-alist elem t) (xetla-bookmarks-save-to-file) (ewoc-enter-last xetla-bookmarks-cookie elem) )) (defun xetla-bookmarks-add (name revision-spec) "Add a bookmark named NAME for REVISION-SPEC." (interactive (let* ((fq (xetla-name-read "Version: " 'prompt 'prompt 'prompt 'prompt)) (n (read-string (format "Name of the bookmark for `%s': " (xetla-name-construct fq))))) (list n fq))) (unless (get-buffer "*xetla-bookmarks*") (xetla-bookmarks)) (with-current-buffer "*xetla-bookmarks*" (let* ((info (list (cons 'location revision-spec) (cons 'timestamp (current-time-string))))) (xetla-bookmarks-add-elem name info)))) (defun xetla-bookmarks-mark () "Mark the bookmark at point." (interactive) (let ((pos (point))) (add-to-list 'xetla-bookmarks-marked-list (ewoc-data (ewoc-locate xetla-bookmarks-cookie))) (ewoc-refresh xetla-bookmarks-cookie) (goto-char pos)) (xetla-bookmarks-next)) (defun xetla-bookmarks-unmark () "Unmark the bookmark at point." (interactive) (let ((pos (point))) (setq xetla-bookmarks-marked-list (delq (ewoc-data (ewoc-locate xetla-bookmarks-cookie)) xetla-bookmarks-marked-list)) (ewoc-refresh xetla-bookmarks-cookie) (goto-char pos)) (xetla-bookmarks-next)) (defun xetla-bookmarks-unmark-all () "Unmark all bookmarks in current buffer." (interactive) (let ((pos (point))) (setq xetla-bookmarks-marked-list nil) (ewoc-refresh xetla-bookmarks-cookie) (goto-char pos))) (defun xetla-bookmarks-marked-are-partners () "Make marked bookmarks mutual partners." (interactive) (let ((list-arch (mapcar #'(lambda (x) (format "%s" (xetla-name-construct (cdr (assoc 'location x))))) xetla-bookmarks-marked-list))) (dolist (book xetla-bookmarks-marked-list) (let ((myloc (xetla-name-construct (cdr (assoc 'location book))))) (message myloc) (dolist (arch list-arch) (unless (string= myloc arch) (xetla-bookmarks-add-partner book arch t)))))) (xetla-bookmarks-save-to-file) (save-window-excursion (xetla-bookmarks))) (defun xetla-bookmarks-cleanup-local-trees () "Remove LOCAL-TREE field from bookmarks if they don't exist." (interactive) (dolist (book xetla-bookmarks-alist) (let () (dolist (local-tree (cdr (assoc 'local-tree book))) (when (and (not (file-exists-p local-tree)) (or xetla-bookmarks-cleanup-dont-prompt (y-or-n-p (format "Remove tree %s from bookmarks %s? " local-tree (car book))))) (xetla-bookmarks-delete-tree book local-tree t))))) (xetla-bookmarks-save-to-file) (save-window-excursion (xetla-bookmarks))) (defun xetla-bookmarks-delete (elem &optional force) "Delete the bookmark entry ELEM. If FORCE is non-nil, don't ask for confirmation." (interactive (list (ewoc-locate xetla-bookmarks-cookie))) (let* ((data (ewoc-data elem))) (when (or force (yes-or-no-p (format "Delete bookmark \"%s\"? " (car data)))) (xetla-ewoc-delete xetla-bookmarks-cookie elem) (let ((list xetla-bookmarks-alist) newlist) (while list (unless (string= (caar list) (car data)) (setq newlist (cons (car list) newlist))) (setq list (cdr list))) (setq xetla-bookmarks-alist (reverse newlist))) ;; TODO could be optimized (xetla-bookmarks-save-to-file) ))) (defun xetla-bookmarks-find-bookmark (location) "Find the bookmark whose location is LOCATION (a string)." (let ((list xetla-bookmarks-alist) result) (while list (when (string= (xetla-name-construct (cdr (assoc 'location (cdar list)))) location) (setq result (car list)) (setq list nil)) (setq list (cdr list))) result)) (defun xetla-bookmarks-get-field (version field default) "Return VERSION'S value of FIELD, or DEFAULT if there is no value." (xetla-bookmarks-load-from-file) (block dolist (dolist (elem xetla-bookmarks-alist) (let ((location (cdr (assoc 'location elem)))) (when (and (string= (xetla-name-archive location) (xetla-name-archive version)) (string= (xetla-name-category location) (xetla-name-category version)) (string= (xetla-name-branch location) (xetla-name-branch version)) (string= (xetla-name-version location) (xetla-name-version version))) (return-from dolist (or (cadr (assoc field (cdr elem))) default))))) default)) (defmacro xetla-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." `(defun ,name (bookmark value &optional dont-save) "Adds the directory VALUE to the list of local trees of bookmark BOOKMARK." (let ((local-trees (assoc ,field (cdr bookmark)))) (if local-trees (if (member value (cdr local-trees)) (message ,message-already) (progn (message ,message-add) (setcdr local-trees (cons value (cdr local-trees))))) (progn (message ,message-add) (setcdr bookmark (cons (list ,field value) (cdr bookmark))))) (unless dont-save (xetla-bookmarks-save-to-file) (save-window-excursion (xetla-bookmarks))))) ) (xetla-bookmarks-make-add-fn xetla-bookmarks-add-tree 'local-tree "Local tree already in the list" "Local tree added to your bookmarks") (xetla-bookmarks-make-add-fn xetla-bookmarks-add-partner 'partners "Partner already in the list" "Partner added to your bookmarks") (xetla-bookmarks-make-add-fn xetla-bookmarks-add-group 'groups "Group already in the list" "Group added to your bookmarks") (xetla-bookmarks-make-add-fn xetla-bookmarks-add-nickname 'nickname "Nickname already in the list" "Nickname added to your bookmark") (defmacro xetla-bookmarks-make-delete-fn (name field) "Define a function called NAME for removing FIELD from bookmark entries." `(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 (xetla-bookmarks-save-to-file) (save-window-excursion (xetla-bookmarks))))) ) (xetla-bookmarks-make-delete-fn xetla-bookmarks-delete-tree 'local-tree) (xetla-bookmarks-make-delete-fn xetla-bookmarks-delete-partner 'partners) (xetla-bookmarks-make-delete-fn xetla-bookmarks-delete-group 'groups) (xetla-bookmarks-make-delete-fn xetla-bookmarks-delete-nickname 'nickname) (defun xetla-bookmarks-add-partner-interactive () "Add a partner to the current or marked bookmarks." (interactive) (let ((bookmarks (or xetla-bookmarks-marked-list (list (ewoc-data (ewoc-locate xetla-bookmarks-cookie))))) (partner (xetla-name-construct (xetla-name-read "Version: " 'prompt 'prompt 'prompt 'prompt)))) (dolist (bookmark bookmarks) (xetla-bookmarks-add-partner bookmark partner t)) (xetla-bookmarks-save-to-file) (save-window-excursion (xetla-bookmarks)))) (defun xetla-bookmarks-add-partners-from-file () "Add a partner to the current or marked bookmarks." (interactive) (let ((bookmarks (or xetla-bookmarks-marked-list (list (ewoc-data (ewoc-locate xetla-bookmarks-cookie)))))) (dolist (bookmark bookmarks) (let ((partners (xetla-partner-list (xetla-bookmarks-read-local-tree bookmark)))) (dolist (partner partners) (xetla-bookmarks-add-partner bookmark partner t)))) (xetla-bookmarks-save-to-file) (save-window-excursion (xetla-bookmarks)))) (defun xetla-bookmarks-write-partners-to-file () "Add the partners recorded in the bookmarks to the partner file." (interactive) (let ((bookmarks (or xetla-bookmarks-marked-list (list (ewoc-data (ewoc-locate xetla-bookmarks-cookie)))))) (dolist (bookmark bookmarks) (let* ((local-tree (xetla-bookmarks-read-local-tree bookmark)) (partners (xetla-partner-list local-tree))) (with-current-buffer (xetla-partner-find-partner-file local-tree) (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)))) (save-buffer))))))) (defun xetla-bookmarks-delete-partner-interactive () "Delete a partner from the current or marked bookmarks." (interactive) (let* ((bookmarks (or xetla-bookmarks-marked-list (list (ewoc-data (ewoc-locate xetla-bookmarks-cookie))))) (choices (apply 'append (mapcar #'(lambda (x) (cdr (assoc 'partners (cdr x)))) bookmarks))) (choices-alist (mapcar #'(lambda (x) (list x)) choices)) (partner (completing-read "Partner to remove: " choices-alist))) (dolist (bookmark bookmarks) (xetla-bookmarks-delete-partner bookmark partner t)) (xetla-bookmarks-save-to-file) (save-window-excursion (xetla-bookmarks)))) (defun xetla-bookmarks-add-tree-interactive () "Add a local tree to the current or marked bookmarks." (interactive) (let ((bookmarks (or xetla-bookmarks-marked-list (list (ewoc-data (ewoc-locate xetla-bookmarks-cookie))))) (local-tree (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) (xetla-bookmarks-add-tree bookmark local-tree t)) (xetla-bookmarks-save-to-file) (save-window-excursion (xetla-bookmarks)))) (defun xetla-bookmarks-delete-tree-interactive () "Add a local tree to the current or marked bookmarks." (interactive) (let* ((bookmarks (or xetla-bookmarks-marked-list (list (ewoc-data (ewoc-locate xetla-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 (completing-read "Local tree to remove: " choices-alist))) (dolist (bookmark bookmarks) (xetla-bookmarks-delete-tree bookmark local-tree t)) (xetla-bookmarks-save-to-file) (save-window-excursion (xetla-bookmarks)))) (defun xetla-bookmarks-list-groups () "Return the list of groups currently used by bookmarks." (let ((list (apply 'append (mapcar #'(lambda (x) (cdr (assoc 'groups (cdr x)))) xetla-bookmarks-alist))) result) ;; Make elements unique (dolist (elem list) (add-to-list 'result elem)) result)) (defun xetla-bookmarks-add-group-interactive () "Add a group entry in the current or marked bookmarks." (interactive) (let* ((bookmarks (or xetla-bookmarks-marked-list (list (ewoc-data (ewoc-locate xetla-bookmarks-cookie))))) (group (completing-read "Group of bookmarks: " (mapcar #'(lambda (x) (list x)) (xetla-bookmarks-list-groups))))) (dolist (bookmark bookmarks) (xetla-bookmarks-add-group bookmark group t))) (xetla-bookmarks-save-to-file) (save-window-excursion (xetla-bookmarks))) (defun xetla-bookmarks-delete-group-interactive () "Delete a group of bookmark entry from the current or marked bookmarks." (interactive) (let* ((bookmarks (or xetla-bookmarks-marked-list (list (ewoc-data (ewoc-locate xetla-bookmarks-cookie))))) (choices (apply 'append (mapcar #'(lambda (x) (cdr (assoc 'groups (cdr x)))) bookmarks))) (choices-alist (mapcar #'(lambda (x) (list x)) choices)) (group (completing-read "Group to remove: " choices-alist))) (dolist (bookmark bookmarks) (xetla-bookmarks-delete-group bookmark group t))) (xetla-bookmarks-save-to-file) (save-window-excursion (xetla-bookmarks))) (defun xetla-bookmarks-select-by-group (group) "Select all bookmarks in GROUP." (interactive (list (completing-read "Group to select: " (mapcar #'(lambda (x) (list x)) (xetla-bookmarks-list-groups))))) (dolist (bookmark xetla-bookmarks-alist) (when (member group (cdr (assoc 'groups bookmark))) (add-to-list 'xetla-bookmarks-marked-list bookmark)) ) (ewoc-refresh xetla-bookmarks-cookie)) (defun xetla-bookmarks-add-nickname-interactive () "Add a nickname to the current bookmark." (interactive) (let* ((bookmark (ewoc-data (ewoc-locate xetla-bookmarks-cookie))) (prompt (format "Nickname for %s: " (xetla-name-construct (cdr (assoc 'location bookmark)))))) (xetla-bookmarks-add-nickname bookmark (read-string prompt) t) (xetla-bookmarks-save-to-file) (save-window-excursion (xetla-bookmarks)))) (defun xetla-bookmarks-delete-nickname-interactive () "Delete the nickname of the current bookmark." (interactive) (let* ((bookmark (ewoc-data (ewoc-locate xetla-bookmarks-cookie))) (nickname (cadr (assoc 'nickname bookmark)))) (xetla-bookmarks-delete-nickname bookmark nickname t) (xetla-bookmarks-save-to-file) (save-window-excursion (xetla-bookmarks)))) (defvar xetla-buffer-bookmark nil "The bookmark manipulated in the current buffer.") (defun xetla-bookmarks-edit () "Edit the bookmark at point." (interactive) (let* ((elem (ewoc-locate xetla-bookmarks-cookie)) (data (ewoc-data elem))) (pop-to-buffer (concat "*xetla bookmark " (car data) "*")) (erase-buffer) (emacs-lisp-mode) (make-local-variable 'xetla-buffer-bookmark) (setq xetla-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 xetla-buffer-bookmark) (oldname (car (ewoc-data elem)))) (kill-buffer (current-buffer)) (pop-to-buffer "*xetla-bookmarks*") (setcar (ewoc-data elem) (car newval)) (setcdr (ewoc-data elem) (cdr newval)) (let ((list xetla-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 xetla-bookmarks-alist (reverse newlist))) (xetla-bookmarks-save-to-file) (save-excursion (xetla-bookmarks)) ))))) (defun xetla-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." (xetla-bookmarks-load-from-file) (when (consp version) (setq version (xetla-name-mask version t t t t t))) (let* ((bookmark (xetla-bookmarks-find-bookmark version)) (groups (cdr (assoc 'groups bookmark))) (partners (delete nil (mapcar (lambda (b) (when (intersection groups (cdr (assoc 'groups b)) :test 'string=) (cdr (assoc 'location b)) )) xetla-bookmarks-alist)))) partners)) ;; ;; Archives ;; ;;;###autoload (defun xetla-archives () "Start the archive browser." (interactive) (xetla-archive-tree-build-archives) (xetla-switch-to-buffer "*xetla-archives*") (let ((a-list xetla-archive-tree) (my-default-archive (xetla-my-default-archive)) defaultp archive-name archive-location p) (toggle-read-only -1) (erase-buffer) (while a-list (setq archive-name (caar a-list) archive-location (cadar a-list) a-list (cdr a-list) defaultp (string= archive-name my-default-archive)) (if defaultp (setq p (point))) (xetla-archives-insert-item archive-name archive-location defaultp)) (if (> (point) (point-min)) (delete-backward-char 1)) (when p (goto-char p)) (xetla-archive-list-mode))) (defun xetla-archives-insert-item (archive location defaultp) "Add an entry for ARCHIVE at LOCATION to the archive list. If DEFAULTP is non-nil, this item will be rendered as the default archive." (let ((start-pos (point)) extent) (insert (if defaultp xetla-mark " ") " " (xetla-face-add-with-condition defaultp archive 'xetla-marked 'xetla-archive-name)) (newline) (insert " " location) (newline) (setq extent (make-extent start-pos (point))) (set-extent-property extent 'category 'xetla-default-button) (set-extent-property extent 'keymap xetla-archive-archive-map) (set-extent-property extent 'xetla-archive-info archive))) (defun xetla-archives-goto-archive-by-name (name) "Jump to the archive named NAME." (unless (string= (buffer-name) "*xetla-archives*") (error "`xetla-archives-goto-archive-by-name' can only be called in *xetla-archives* buffer")) (goto-char (point-min)) (search-forward name) (beginning-of-line)) (defun xetla-get-archive-info (&optional property) "Get some PROPERTY of the archive at point in an archive list buffer." (unless property (setq property 'xetla-archive-info)) (let ((extent (car (extents-at (point))))) (when extent (extent-property extent property)))) (defun xetla-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 (xetla-name-read nil 'prompt)))) (cond ((stringp new-default) (message "Setting arch default archive to: %s" new-default) (xetla-run-tla-sync (list "my-default-archive" new-default) :finished 'xetla-null-handler)) (t (xetla-run-tla-sync '("my-default-archive") :finished `(lambda (output error status arguments) (let ((result (xetla-buffer-content output))) (when ,(interactive-p) (message "Default arch archive: %s" result)) result)) :error `(lambda (output error status arguments) (if (eq status 1) (if ,(interactive-p) (message "default archive not set") "") (xetla-default-error-function output error status arguments))))))) (defun xetla-whereis-archive (&optional archive) "Call xetla whereis-archive on ARCHIVE." (interactive "P") (let (location) (unless archive (setq archive (xetla-name-mask (xetla-name-read "Archive: " 'prompt) t :archive))) (setq location (xetla-run-tla-sync (list "whereis-archive" archive) :finished (lambda (output error status arguments) (xetla-buffer-content output)))) (when (interactive-p) (message "archive location for %s: %s" archive location)) location)) (defun xetla-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" (read-string prompt (ffap-url-at-point))) (defun xetla-register-archive () "Call `xetla-register-archive-internal' interactively and `xetla-archives' on success." (interactive) (let* ((result (call-interactively 'xetla-register-archive-internal)) (archive-registered (nth 0 result)) (archive (nth 1 result)) (xetla-response (nth 3 result))) (when archive-registered (xetla-archives) (xetla-archives-goto-archive-by-name (progn (message xetla-response) ; inform the user about the response from xetla (if (string-match ".+: \\(.+\\)" xetla-response) (match-string 1 xetla-response) archive))) (xetla-flash-line)))) (defun xetla-register-archive-internal (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 (xetla-read-location "Location: ") (read-string "Archive (empty for default): "))) (if (and archive (eq 0 (length archive))) (setq archive nil)) (let ((archive-registered nil) (xetla-response nil)) (xetla-run-tla-sync (list "register-archive" archive location) :finished (lambda (output error status arguments) (setq xetla-response (xetla-get-process-output)) (setq archive-registered t) (message "Registered archive %s (=> %s)" archive location)) :error (lambda (output error status arguments) (setq xetla-response (xetla-get-error-output)) (when (eq status 2) ;; already registered (setq archive-registered 'already)))) (list archive-registered archive location xetla-response))) (defun xetla-unregister-archive (archive ask-for-confirmation) "Delete the registration of ARCHIVE. When ASK-FOR-CONFIRMATION is non nil, ask the user for confirmation." (unless (xetla-archive-tree-get-archive archive) (xetla-archive-tree-build-archives)) (let ((location (cadr (xetla-archive-tree-get-archive archive)))) (when (or (not ask-for-confirmation) (yes-or-no-p (format "Delete the registration of %s(=> %s)? " archive location))) (xetla-run-tla-sync (list "register-archive" "--delete" archive) :finished (lambda (output error status arguments) (message "Deleted the registration of %s (=> %s)" archive location)))))) (defun xetla-edit-archive-location (archive) "Edit the location of ARCHIVE." (let* ((old-location (xetla-whereis-archive archive)) (new-location (read-string (format "New location for %s: " archive) old-location))) (unless (string= old-location new-location) (xetla-unregister-archive archive nil) (xetla-register-archive-internal new-location archive)))) ;;;###autoload (defun xetla-make-archive () "Call `xetla-make-archive-internal' interactively then call `xetla-archives'." (interactive) (call-interactively 'xetla-make-archive-internal) (xetla-archives)) (defun xetla-make-archive-internal (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(a)flups.com--public foo.bar(a)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: ") (let ((path-ok nil) location) (while (not path-ok) (setq location (xetla-read-location "Location: ")) (setq path-ok t) (when (eq 'local (xetla-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) (y-or-n-p "Sign the archive? ") (y-or-n-p "Create .listing files? "))) (xetla-run-tla-sync (list "make-archive" (when listing "--listing") (when signed "--signed") name location) :error (lambda (output error status arguments) (xetla-show-error-buffer error) (xetla-show-last-process-buffer) (error (format "xetla failed: exits-status=%s" status))))) (defun xetla-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 (xetla-name-read "Archive to mirror: " 'prompt)))) (location (or location (xetla-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 (xetla-get-mirrors-for-archive archive)) (mirror (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? ")))) (xetla-run-tla-sync (list "make-archive" (when listing "--listing") (when signed "--signed") "--mirror" archive mirror location)))) (defun xetla-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 (xetla-name-read "Mirror from archive: " 'prompt)))) (location (or location (read-string (format "Location of the mirror for %s : " from-archive))))) (unless (eq (xetla-archive-type from-archive) 'source) (error "%s is not SOURCE archive" from-archive)) (xetla-run-tla-sync (list "make-archive" "--mirror-from" from-archive location)))) (defun xetla-get-mirrors-for-archive (archive) "Get a list of all mirrors for the given ARCHIVE." (xetla-archive-tree-build-archives) (delete nil (mapcar '(lambda (elem) (let ((a-name (car elem))) (when (and (eq (xetla-archive-type a-name) 'mirror) (string= archive (substring a-name 0 (length archive)))) a-name))) xetla-archive-tree))) ;; in xetla-browse use: (xetla-name-archive (xetla-widget-node-get-name)) ;; to get the name of an archive. ;; in xetla-archives: use (xetla-get-archive-info) ;; (xetla-get-mirrors-for-archive (xetla-get-archive-info)) ;; (xetla-get-mirrors-for-archive &quot;xsteve(a)nit.at-public&quot;) (defun xetla-mirror-base-name (archive) "Return the base name of the mirror ARCHIVE." (when (eq (xetla-archive-type archive) 'mirror) (substring archive 0 (string-match "-MIRROR.*$" archive)))) (defun xetla-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 (xetla-name-archive (xetla-name-read "Mirror archive name: " 'prompt)))) (unless (eq (xetla-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 (xetla-mirror-base-name archive)) (mirror-list (xetla-get-mirrors-for-archive archive-base-name)) (default-mirror (concat archive-base-name "-MIRROR")) (default-mirror-present (member default-mirror mirror-list)) (archive-location (xetla-whereis-archive archive)) (default-mirror-location (and default-mirror-present (xetla-whereis-archive default-mirror)))) (if default-mirror-present (message "swapping mirrors %s <-> %s." archive default-mirror) (message "using %s as default mirror." archive)) (xetla-unregister-archive archive nil) (when default-mirror-present (xetla-unregister-archive default-mirror nil)) (xetla-register-archive-internal archive-location default-mirror) (when default-mirror-present (xetla-register-archive-internal default-mirror-location archive))))) (defun xetla-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 (xetla-archive-tree-get-archive archive)))) (unless location (error "Location for `%s' is unknown" archive)) (when (eq 'source (xetla-archive-type archive)) (error "%s is already source" archive)) ; (unless (eq 'http (xetla-location-type location)) ; (error "Read only archive is supported in xetla: " location)) (xetla-unregister-archive archive nil) (xetla-register-archive-internal location (concat archive "-SOURCE"))) ;; ;; Categories ;; (defun xetla-categories (archive) "List the categories of ARCHIVE." (interactive (list (xetla-name-archive (xetla-name-read nil 'prompt)))) (unless archive (setq archive (xetla-my-default-archive))) (xetla-archive-tree-build-categories archive) (xetla-switch-to-buffer "*xetla-categories*") (let ((list (cddr (xetla-archive-tree-get-archive archive))) category start-pos extent) (toggle-read-only -1) (erase-buffer) ;; TODO: button to invoke xetla-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 " " (xetla-face-add category 'xetla-category-name)) (newline) (setq extent (make-extent start-pos (point))) (set-extent-property extent 'category 'xetla-default-button) (set-extent-property extent 'keymap xetla-category-category-map) (set-extent-property extent 'xetla-category-info category) ) (delete-backward-char 1))) (xetla-category-list-mode) (set (make-local-variable 'xetla-buffer-archive-name) archive)) (defun xetla-make-category (archive category) "In ARCHIVE, create CATEGORY." (interactive (let ((l (xetla-name-read "New Category: " 'prompt 'prompt))) (list (xetla-name-archive l) (xetla-name-category l)))) (xetla-run-tla-sync (list "make-category" "-A" archive category)) (let ((xetla-buffer-archive-name archive)) (run-hooks 'xetla-make-category-hook))) ;; ;; Branches ;; (defun xetla-branches (archive category) "Display the branches of ARCHIVE/CATEGORY." (interactive (let ((l (xetla-name-read nil 'prompt 'prompt))) (list (xetla-name-archive l) (xetla-name-category l)))) (xetla-archive-tree-build-branches archive category) (xetla-switch-to-buffer "*xetla-branches*") (let ((list (cdr (xetla-archive-tree-get-category archive category))) alength clength branch start-pos extent) (toggle-read-only -1) (erase-buffer) ;; TODO: button to invoke xetla-categories and xetla-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 " " (xetla-face-add (if (string= branch "") "<empty>" branch) 'xetla-branch-name)) (newline) (setq extent (make-extent start-pos (point))) (set-extent-property extent 'category 'xetla-default-button) (set-extent-property extent 'keymap xetla-branch-branch-map) (set-extent-property extent 'xetla-branch-info branch)) (delete-backward-char 1))) (xetla-branch-list-mode) (set (make-local-variable 'xetla-buffer-archive-name) archive) (set (make-local-variable 'xetla-buffer-category-name) category)) (defun xetla-make-branch (archive category branch) "Make a new branch in ARCHIVE/CATEGORY called BRANCH." (interactive (let ((l (xetla-name-read "New Branch: " 'prompt 'prompt 'prompt))) (list (xetla-name-archive l) (xetla-name-category l) (xetla-name-branch l)))) (xetla-run-tla-sync (list "make-branch" (xetla-name-construct archive category branch))) (let ((xetla-buffer-archive-name archive) (xetla-buffer-category-name category)) (run-hooks 'xetla-make-branch-hook))) ;; ;; Versions ;; (defun xetla-versions (archive category branch) "Display the versions of ARCHIVE/CATEGORY in BRANCH." (interactive (let ((l (xetla-name-read nil 'prompt 'prompt 'prompt))) (list (xetla-name-archive l) (xetla-name-category l) (xetla-name-branch l)))) (xetla-archive-tree-build-versions archive category branch) (xetla-switch-to-buffer "*xetla-versions*") (let ((list (cdr (xetla-archive-tree-get-branch archive category branch))) alength clength blength version start-pos extent) (toggle-read-only -1) (erase-buffer) ;; TODO: button to invoke xetla-categories and xetla-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 " " (xetla-face-add version 'xetla-version-name)) (newline) (setq extent (make-extent start-pos (point))) (set-extent-property extent 'category 'xetla-default-button) (set-extent-property extent 'keymap xetla-version-version-map) (set-extent-property extent 'xetla-version-info version)) (delete-backward-char 1))) (xetla-version-list-mode) (set (make-local-variable 'xetla-buffer-archive-name) archive) (set (make-local-variable 'xetla-buffer-category-name) category) (set (make-local-variable 'xetla-buffer-branch-name) branch)) (defun xetla-make-version (archive category branch version) "In ARCHIVE/CATEGORY, add a version to BRANCH called VERSION." (interactive (let ((l (xetla-name-read "Version: " 'prompt 'prompt 'prompt 'prompt))) (list (xetla-name-archive l) (xetla-name-category l) (xetla-name-branch l) (xetla-name-version l)))) (xetla-run-tla-sync (list "make-version" (xetla-name-construct archive category branch version))) (let ((xetla-buffer-archive-name archive) (xetla-buffer-category-name category) (xetla-buffer-branch-name branch)) (run-hooks 'xetla-make-version-hook))) ;; ;; Revisions ;; ;; elem should be ;; ('separator "string" kind) ;; or ;; ('entry-patch nil revision) Where "revision" is of xetla-revision ;; struct type. ;; ('entry-change "changes") ;; The second element tells if the element is marked or not. (defun xetla-revision-list-printer (elem) "Print an element ELEM of the revision list." (let () (case (car elem) (entry-patch (let* ((struct (caddr elem)) (merged-by (xetla-revision-merged-by struct)) (unmerged (eq merged-by 'nobody))) (insert (if (cadr elem) (concat " " xetla-mark) " ") ;; The revision is in library? (if (and xetla-revisions-shows-library (apply 'xetla-revlib-tree-get-revision (xetla-revision-revision struct))) ;; ;; (apply 'xetla-library-find ;; (append (caddr elem) '(t)) "L " " ") (xetla-face-add (xetla-name-construct (xetla-revision-revision struct)) (if unmerged 'xetla-unmerged 'xetla-revision-name) 'xetla-revision-revision-map xetla-revision-revision-menu) (if unmerged (xetla-face-add " [NOT MERGED]" 'xetla-unmerged) "")) (let ((summary (xetla-revision-summary struct)) (creator (xetla-revision-creator struct)) (date (xetla-revision-date struct))) (when (and summary xetla-revisions-shows-summary) (insert "\n " summary)) (when (and creator xetla-revisions-shows-creator) (insert "\n " creator)) (when (and date xetla-revisions-shows-date) (insert "\n " date))) (when (and xetla-revisions-shows-merges (xetla-revision-merges struct) (not (null (car (xetla-revision-merges struct))))) (insert "\n Merges:") (dolist (elem (xetla-revision-merges struct)) (insert "\n " elem))) (when xetla-revisions-shows-merged-by (cond ((null merged-by) nil) ((listp merged-by) (insert "\n Merged-by:") (dolist (elem merged-by) (insert "\n " elem))))))) (entry-change (insert (cadr elem))) (message (insert (xetla-face-add (cadr elem) 'xetla-messages))) (separator (case (caddr elem) (partner (insert "\n" (xetla-face-add (cadr elem) 'xetla-separator))) (bookmark (insert "\n" (xetla-face-add (concat "*** " (cadr elem) " ***") 'xetla-separator) "\n"))))))) (defun xetla-tree-revisions () "Call `xetla-revisions' in the current tree." (interactive) (let* ((default-directory (xetla-read-project-tree-maybe "Run tla revisions in: ")) (version (xetla-tree-version-list))) (unless version (error "Not in a project tree")) (apply 'xetla-revisions version))) ;;;###autoload (defun xetla-revisions (archive category branch version &optional update-display from-revlib) "List the revisions of ARCHIVE/CATEGORY-BRANCH-VERSION." (interactive (let ((l (xetla-name-read "Version: " 'prompt 'prompt 'prompt 'prompt))) (list (xetla-name-archive l) (xetla-name-category l) (xetla-name-branch l) (xetla-name-version l)))) ;; TODO: Consdider the case where (and update-display from-revlib) is t. (unless (and update-display (or (xetla-revisions-tree-contains-details archive category branch version) (not (or xetla-revisions-shows-summary xetla-revisions-shows-creator xetla-revisions-shows-date)))) (if from-revlib (xetla-revlib-tree-build-revisions archive category branch version) (xetla-archive-tree-build-revisions archive category branch version))) (xetla-switch-to-buffer "*xetla-revisions*") (let ((list (cdr (if from-revlib (xetla-revlib-tree-get-version archive category branch version) (xetla-archive-tree-get-version archive category branch version)))) first separator revision summary creator date) (xetla-revision-list-mode) (toggle-read-only -1) (set (make-local-variable 'xetla-buffer-refresh-function) 'xetla-revision-refresh) (setq separator (xetla-face-add (make-string (max (+ (length archive) (length "Archive: ")) (+ (length category) (length "Category: ")) (+ (length branch) (length "Branch: ")) (+ (length version) (length "Version: "))) ?\ ) 'xetla-separator)) (ewoc-set-hf xetla-revision-list-cookie (xetla-revisions-header archive category branch version from-revlib separator) (concat "\n" separator)) (if xetla-revisions-shows-library (xetla-revlib-tree-build-revisions archive category branch version nil t)) (while list (setq revision (car (car list)) summary (car (cdr (car list))) creator (car (cddr (car list))) date (car (cdddr (car list))) list (cdr list)) (ewoc-enter-last xetla-revision-list-cookie (list 'entry-patch nil (make-xetla-revision :revision (list archive category branch version revision) :summary summary :creator creator :date date))) (if first (goto-char first) (goto-char (point-min)) (re-search-forward "^$") (forward-line 1) (setq first (point))) (sit-for 0))) (set (make-local-variable 'xetla-buffer-archive-name) archive) (set (make-local-variable 'xetla-buffer-category-name) category) (set (make-local-variable 'xetla-buffer-branch-name) branch) (set (make-local-variable 'xetla-buffer-version-name) version) (toggle-read-only t)) (defun xetla-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: " (xetla-face-add archive 'xetla-archive-name) "/" (xetla-face-add category 'xetla-category-name) "--" (xetla-face-add branch 'xetla-branch-name) "--" (xetla-face-add version 'xetla-version-name) "\n" "In Revision Library: " (xetla-face-add (if from-revlib "Yes" "No") 'bold) "\n" separator "\n")) ;;;###autoload (defun xetla-missing (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) (xetla-tree-root nil t)) (expand-file-name (read-directory-name "Search missing patches in directory: " default-directory default-directory t nil))))) (list dir (let ((default-directory dir)) (if current-prefix-arg (xetla-name-read "From location: " 'prompt 'prompt 'prompt 'prompt) (xetla-tree-version)))))) (let ((dir (xetla-tree-root))) (pop-to-buffer (xetla-get-buffer-create 'missing)) (cd dir)) (xetla-revision-list-mode) (set (make-local-variable 'xetla-buffer-refresh-function) 'xetla-missing-refresh) (set (make-local-variable 'xetla-missing-buffer-todolist) `((missing ,local-tree ,(xetla-name-construct location) nil))) (xetla-missing-refresh)) ;; ;; Rbrowse interface ;; (defun xetla-browse-archive (archive) "Browse ARCHIVE. The interface is rather poor, but xetla-browse does a better job anyway ..." (interactive (let ((l (xetla-name-read nil 'prompt))) (list (xetla-name-archive l)))) (unless archive (setq archive (xetla-my-default-archive))) (xetla-run-tla-sync (list "rbrowse" "-A" archive))) (defun xetla-read-config-file (prompt-tree prompt-file) "Interactively read the arguments of `xetla-build-config'and `xetla-cat-config'. The string PROMPT-TREE will be used when prompting the user for a tree. The string PROMPT-FILE will be used when prompting the user for a file." (let* ((tree-root (xetla-uniquify-file-name (xetla-read-project-tree-maybe prompt-tree))) (current-file-name (and buffer-file-name (replace-regexp-in-string (concat "^" (regexp-quote tree-root)) "" buffer-file-name))) (relative-conf-file (replace-regexp-in-string (concat "^" (regexp-quote tree-root)) "" (expand-file-name (read-file-name prompt-file tree-root nil t current-file-name))))) (when (file-name-absolute-p relative-conf-file) ;; The replace-regexp-in-string failed. (error "Configuration file must be in a %s" "subdirectory of tree-root")) (list tree-root relative-conf-file))) (defun xetla-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 `xetla-read-project-tree-maybe'." (interactive (xetla-read-config-file "Build configuration in directory: " "Build configuration: ")) (let ((default-directory tree-root)) (xetla-run-tla-async (list "build-config" config-file)))) (defun xetla-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 `xetla-read-project-tree-maybe'." (interactive (append (xetla-read-config-file "Cat configuration in directory: " "Cat configuration: ") (list (y-or-n-p "Include revision number? ")))) (let ((default-directory tree-root)) (xetla-run-tla-async (list "cat-config" (when snap "--snap") config-file)))) ;; ;; Get ;; (defun xetla-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 (xetla-name-read "Get: " 'prompt 'prompt 'prompt 'maybe 'maybe)) (name (xetla-name-construct l)) (d (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 (xetla-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) (xetla-name-read "Version-Revision for Get(if necessary): " archive category branch (if version version 'maybe) 'maybe))))) (funcall (if synchronously 'xetla-run-tla-sync 'xetla-run-tla-async) (list "get" "-A" archive name directory) :finished `(lambda (output error status arguments) (let ((i (xetla-status-handler output error status arguments))) (when (zerop i) (xetla-get-do-bookmark ,directory ,archive ,category ,branch ,version) (xetla-do-dired ,directory ',run-dired-p))))))) (defun xetla-get-do-bookmark (directory archive category branch version) "Add DIRECTORY to the bookmark for ARCHIVE/CATEGORY-BRANCH-VERSION." (let ((bookmark (xetla-bookmarks-find-bookmark (xetla-name-construct archive category branch version)))) (when bookmark (xetla-bookmarks-add-tree bookmark directory)))) (defun xetla-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 xetla-cache-revision (archive category branch version revision) "Cache the revision named by ARCHIVE/CATEGORY-BRANCH-VERSION-REVISION." (interactive (xetla-name-read "Revision to cache: " 'prompt 'prompt 'prompt 'prompt 'prompt)) (let ((result (xetla-run-tla-async (list "cacherev" (xetla-name-construct archive category branch version revision))))) ;; (xetla-show-last-process-buffer) result)) ;; ;; Add ;; (defun xetla-add (id &rest files) "Using ID, add FILES to this tree." (interactive (let ((name (read-file-name "Add file as source: " nil nil t (file-name-nondirectory (or (buffer-file-name) "")))) (id (read-string "id (empty for default): "))) (list id name))) (if (and id (string= id "")) (setq id nil)) (setq files (mapcar 'expand-file-name files)) (if id (xetla-run-tla-sync `("add" "--id" ,id . ,files) :finished 'xetla-null-handler) (xetla-run-tla-sync `("add" . ,files) :finished 'xetla-null-handler))) ;; ;; Remove ;; (defun xetla-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: " 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 (xetla-run-tla-sync (list "id" "--explicit" f) :finished 'xetla-status-handler :error 'xetla-status-handler)) (xetla-run-tla-sync (list "delete-id" f) :finished 'xetla-status-handler)) (unless only-id (delete-file f)))) ;; ;; Move ;; (defun xetla-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 (buffer-file-name) ""))) 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))) (xetla-run-tla-sync (list cmd from to) :finished `(lambda (output error status arguments) (let ((buf (find-buffer-visiting ,from))) (when buf (with-current-buffer buf (rename-buffer (file-name-nondirectory ,to)) (set-visited-file-name ,to)))) status)))) (defalias 'xetla-mv 'xetla-move) ;; ;; Update ;; (defun xetla-update (tree &optional handle) "Run tla update in TREE. After running update, execute HANDLE (function taking no argument)." (interactive (list (expand-file-name (read-directory-name "Update tree: " nil nil nil "")))) (or (xetla-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 (xetla-prepare-changes-buffer (list 'last-revision default-directory) (list 'local-tree default-directory) 'changes default-directory))) (when xetla-switch-to-buffer-first (xetla-switch-to-buffer buffer)) (xetla-run-tla-async `("update") :finished `(lambda (output error status arguments) ;; (xetla-show-last-process-buffer) (xetla-show-changes-buffer output nil ,buffer) (message "`tla update' finished") (xetla-revert-some-buffers ,tree) (when ,handle (funcall ,handle))) :error (lambda (output error status arguments) (xetla-show-error-buffer error) (xetla-show-last-process-buffer) )) (xetla-revert-some-buffers tree))) ;; ;; Import ;; ;;;###autoload (defun xetla-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 (read-directory-name "Directory containing files to import: " (or default-directory (getenv "HOME")))) (l (xetla-name-read (format "Import `%s' to: " base) (if archive archive (xetla-my-default-archive)) 'prompt 'prompt 'prompt)) (project (xetla-name-construct l))) (let ((default-directory (file-name-as-directory base))) (xetla-run-tla-sync (list "init-tree" project)) (save-excursion (xetla-inventory default-directory) (message "Type %s when ready to import" (substitute-command-keys "\\[exit-recursive-edit]")) (recursive-edit)) (funcall (if synchronously 'xetla-run-tla-sync 'xetla-run-tla-async) (list "import" "--setup") :finished `(lambda (output error status arguments) (xetla-inventory ,base t))) (cons project default-directory)))) (defvar xetla-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 xetla front-ends like Aba.") (defvar xetla-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 xetla front-ends like Aba.") ;; -------------------------------------- ;; xetla partner stuff ;; -------------------------------------- (defun xetla-partner-find-partner-file (&optional local-tree) "Do `find-file' xetla-partners file and return the buffer. If the file `xetla-partner-file-precious' exists, it is used in priority. Otherwise,use `xetla-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 (xetla-tree-root default-directory t)))) (let* ((partner-file (cond ((not default-directory) nil) ((file-exists-p (concat (xetla-tree-root) xetla-partner-file-precious)) (concat (xetla-tree-root) xetla-partner-file-precious)) (t (concat (xetla-tree-root) xetla-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 xetla-partner-add (partner &optional local-tree) "Add a partner for this xetla working copy. Return nil if PARTNER is alerady in partners file. Look for the parners file in LOCAL-TREE. For example: Franz.Lustig(a)foo.bar-public/xetla-main-0.1&quot; (interactive (list (xetla-name-construct (xetla-name-read "Version to Add Partner File: " 'prompt 'prompt 'prompt 'prompt)))) (let ((list (xetla-partner-list local-tree))) (if (member partner list) nil (with-current-buffer (xetla-partner-find-partner-file) (goto-char (point-min)) (insert partner) (newline) (save-buffer)) partner))) (defun xetla-partner-list (&optional local-tree) "Read the partner list from partner files in LOCAL-TREE. If LOCAL-TREE is nil, use the `xetla-tree-root' of `default-directory' instead. If LOCAL-TREE is not managed by arch, return nil." (let ((buffer (xetla-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 xetla-partner-member (version &optional local-tree) "Predicate to check whether VERSION is in the partners file in LOCAL-TREE." (let ((list (xetla-partner-list local-tree))) (member version list))) (defun xetla-partner-read-version (&optional prompt including-self) "Specialized version for `xetla-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 Xetla Partner: ")) (if (and including-self (y-or-n-p "Select `self' as partner? ")) 'self (let ((version (xetla-name-construct (xetla-name-read prompt 'prompt 'prompt 'prompt 'prompt)))) (when (and (not (xetla-partner-member version)) (y-or-n-p (format "Add `%s' to Partner File? " version))) (xetla-partner-add version)) version))) ;; FIXME: Currently does nothing in XEmacs. (defun xetla-partner-create-menu (action &optional prompt) "Create the partner menu with ACTION using PROMPT as the menu name." (let ((list (xetla-partner-list))) (xetla-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)))) ;; -------------------------------------- ;; xetla-inventory-mode: ;; -------------------------------------- (defun xetla-inventory-mode () "Major Mode to show the inventory of a xetla 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: '\\<xetla-inventory-mode-map>\\[xetla-inventory-toggle-source]' to toggle show sources, '\\[xetla-inventory-toggle-precious]' to toggle show precious, ... Use '\\[xetla-inventory-mark-file]' to mark files, and '\\[xetla-inventory-unmark-file]' to unmark. If you commit from this buffer (with '\\[xetla-inventory-edit-log]'), then, the list of selected files in this buffer at the time you actually commit with \\<xetla-log-edit-mode-map>\\[xetla-log-edit-done]. Commands: \\{xetla-inventory-mode-map}" (interactive) ;; don't kill all local variables : this would clear the values of ;; xetla-inventory-display-*, and refresh wouldn't work well anymore. ;; (kill-all-local-variables) (use-local-map xetla-inventory-mode-map) (set (make-local-variable 'xetla-buffer-refresh-function) 'xetla-inventory) (make-local-variable 'xetla-buffer-marked-file-list) (easy-menu-add xetla-inventory-mode-menu) (setq major-mode 'xetla-inventory-mode) (setq mode-name "xetla-inventory") (setq mode-line-process 'xetla-mode-line-process) (set (make-local-variable 'xetla-get-file-info-at-point-function) 'xetla-inventory-get-file-info-at-point) (set (make-local-variable 'xetla-generic-select-files-function) 'xetla-inventory-select-files) (toggle-read-only 1) (run-hooks 'xetla-inventory-mode-hook)) (defun xetla-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 xetla-inventory-next () "Go to the next inventory item." (interactive) (let* ((cookie xetla-inventory-cookie) (elem (ewoc-locate cookie)) (next (or (ewoc-next cookie elem) elem))) (xetla-inventory-cursor-goto next))) (defun xetla-inventory-previous () "Go to the previous inventory item." (interactive) (let* ((cookie xetla-inventory-cookie) (elem (ewoc-locate cookie)) (previous (or (ewoc-prev cookie elem) elem))) (xetla-inventory-cursor-goto previous))) (defun xetla-inventory-edit-log (&optional insert-changelog) "Wrapper around `xetla-edit-log', setting the source buffer to current buffer. If INSERT-CHANGELOG is non-nil, insert a changelog too." (interactive "P") (xetla-edit-log insert-changelog (current-buffer))) (defun xetla-inventory-add-files (files) "Create explicit inventory ids for FILES." (interactive (list (if xetla-buffer-marked-file-list (progn (unless (y-or-n-p (if (eq 1 (length xetla-buffer-marked-file-list)) (format "Add %s? " (car xetla-buffer-marked-file-list)) (format "Add %s files? " (length xetla-buffer-marked-file-list)))) (error "Not adding any file")) xetla-buffer-marked-file-list) (list (read-file-name "Add file: " default-directory nil nil (xetla-get-file-info-at-point)))))) (apply 'xetla-add nil files) (xetla-inventory)) (defun xetla-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 xetla-buffer-marked-file-list (progn (unless (yes-or-no-p (format "Remove %d MARKED file%s? " (length xetla-buffer-marked-file-list) (if (< (length xetla-buffer-marked-file-list) 2) "" "s"))) (error "Not removing any file")) xetla-buffer-marked-file-list) (list (let ((file (xetla-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 xetla-buffer-marked-file-list "MARKED " "") (if (< (length read-files) 2) "" "s"))))))) (apply 'xetla-remove id-only files) (xetla-inventory)) (defun xetla-delete-file (file &optional recursive) "Delete FILE or directory, recursively if optional RECURSIVE is non-nil. 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 "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*")) ; 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). (xetla-delete-file (car files) recursive) (setq files (cdr files)))) (delete-directory file)))) (defun xetla-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 xetla managed files, i.e. files with IDs will be passed to `xetla-inventory-remove-files'! When called with a prefix arg NO-QUESTIONS, just delete the files." (interactive (list (if xetla-buffer-marked-file-list (progn (or current-prefix-arg (unless (yes-or-no-p (format "Delete %d files permanently? " (length xetla-buffer-marked-file-list))) (error "Not deleting any files"))) xetla-buffer-marked-file-list) (if (or current-prefix-arg (yes-or-no-p (format "Delete file %S permanently? " (xetla-get-file-info-at-point)))) (list (xetla-get-file-info-at-point)))) current-prefix-arg)) (while files (let ((f (car files))) (if (= 0 (xetla-run-tla-sync (list "id" f) :finished 'xetla-status-handler :error 'xetla-status-handler)) (if (or no-questions (y-or-n-p (format (concat "File %s is arch managed! " "Delete it with its id?") f))) (xetla-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))) (xetla-delete-file f 'always)))) (delete-file f)))) (setq files (cdr files))) (if xetla-buffer-marked-file-list (setq xetla-buffer-marked-file-list nil)) (xetla-inventory)) (defun xetla-inventory-move () "Rename file at the current point and update its inventory id if present." (interactive) (if (eq 0 (xetla-move (xetla-get-file-info-at-point) nil 'ask)) (xetla-generic-refresh) (xetla-show-last-process-buffer))) (defun xetla-inventory-revert () "Reverts file at point." (interactive) (let* ((file (xetla-get-file-info-at-point)) (absolute (if (file-name-absolute-p file) file (expand-file-name (concat (file-name-as-directory default-directory) file))))) (xetla-file-revert absolute))) (defun xetla-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 `xetla-inventory-redo'." (interactive "P") (let* ((tree (xetla-tree-root default-directory t)) (revision (if specify-revision (xetla-read-revision-with-default-tree "Undo against archive: " tree) (list nil nil nil nil nil)))) (apply 'xetla-undo-internal (cons tree revision)))) (defun xetla-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 (xetla-get-file-info-at-point)) (xetla-get-undo-changeset-names)))) (defun xetla-inventory-redo () "Redo whole local tree associated with the current inventory buffer. This function restores the saved changes from `xetla-inventory-undo'." (interactive) (xetla-redo (xetla-inventory-maybe-undo-directory))) (defun xetla-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 xetla-inventory-find-file () "Visit the current inventory file." (interactive) (let* ((file (xetla-get-file-info-at-point))) (cond ((not file) (error "No file at point")) ((eq t (car (file-attributes file))) ; file is a directory (xetla-inventory (expand-file-name file))) (t (find-file file))))) (defun xetla-inventory-parent-directory () "Go to parent directory in inventory mode." (interactive) (xetla-inventory (expand-file-name ".."))) (defun xetla-inventory-mirror () "Create a mirror of version of the current tree." (interactive) (let ((tree-version (xetla-tree-version-list))) (xetla-archive-mirror (xetla-name-archive tree-version) (xetla-name-category tree-version) (xetla-name-branch tree-version) (xetla-name-version tree-version)))) (defun xetla-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 (xetla-partner-read-version "Star-merge with: "))) (when (y-or-n-p (format "Star-merge with %s ? " merge-partner)) (xetla-star-merge merge-partner))) (defun xetla-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 `xetla-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 (xetla-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 (xetla-name-split compare-partner)))) (when (listp summary) (setq summary (car summary))) (xetla-changes summary compare-partner))) (defun xetla-inventory-replay (&optional merge-partner) "Run tla replay. Either use a partner in the tree's ++xetla-partners file, or ask the user for MERGE-PARTNER." (interactive (list (xetla-partner-read-version "Replay from: "))) (when (y-or-n-p (format "Replay from %s ? " merge-partner)) (xetla-replay merge-partner))) (defun xetla-inventory-update () "Run tla update." (interactive) (xetla-update default-directory)) (defun xetla-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 (xetla-partner-read-version "Check missing against: "))) (when (y-or-n-p (format "Check missing against %s ? " missing-partner)) (xetla-missing default-directory missing-partner))) (xetla-missing default-directory (xetla-tree-version)))) (defun xetla-inventory-file-ediff (&optional file) "Run `ediff' on FILE." (interactive (list (caddr (ewoc-data (ewoc-locate xetla-inventory-cookie))))) (xetla-file-ediff file)) (xetla-make-bymouse-function xetla-inventory-find-file) (defun xetla-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 (xetla-tree-version-list)) (modified-revision (apply 'xetla-version-head modified)) (modified-fq (xetla-name-construct (xetla-name-archive modified) (xetla-name-category modified) (xetla-name-branch modified) (xetla-name-version modified) modified-revision)) (base (xetla-name-read (format "Revision for delta to %s(HEAD) from: " modified-fq) 'prompt 'prompt 'prompt 'prompt 'prompt)) (base-fq (xetla-name-construct base))) (xetla-delta base-fq modified-fq 'ask))) (defun xetla-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 (xetla-tree-root)) (changeset (let ((changeset-dir (or (xetla-get-file-info-at-point) ""))) (unless (file-directory-p (expand-file-name changeset-dir)) (setq changeset-dir "")) (xetla-uniquify-file-name (read-directory-name "Changeset directory: " changeset-dir changeset-dir))))) (xetla-show-changeset changeset nil) (when (yes-or-no-p (format "Apply the changeset%s? " (if reverse " in REVERSE" ""))) (xetla-apply-changeset changeset target reverse) (with-current-buffer inventory-buffer (xetla-generic-refresh))))) (defun xetla-inventory-apply-changeset-from-tgz (file) "Apply the changeset in FILE to the currently visited tree." (interactive (list (let ((changeset-tarball (or (xetla-get-file-info-at-point) ""))) (read-file-name "Apply changeset from tarball: " nil changeset-tarball t changeset-tarball)))) (let ((inventory-buffer (current-buffer)) (target (xetla-tree-root))) (xetla-apply-changeset-from-tgz file target) (with-current-buffer inventory-buffer (xetla-generic-refresh)))) ;; TODO: Use `xetla-inventory-select-file' in other xetla-inventory-*. ;; TODO: Mouse event check like `xetla-tree-lint-select-files'. ;; TODO: Unify with `xetla-tree-lint-select-files'. (defun xetla-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 xetla-buffer-marked-file-list xetla-buffer-marked-file-list (list (xetla-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 xetla-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 (xetla-inventory-select-files "Make `%s' junk? " "Make %s files junk? " "Not making any file junk"))) (xetla-generic-file-prefix files ",,")) (defun xetla-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 (xetla-inventory-select-files "Make `%s' precious? " "Make %s files precious? " "Not making any file precious"))) (xetla-generic-file-prefix files "++")) (defun xetla-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." (interactive "P") (xetla-generic-add-to-* "exclude" =tagging-method)) (defun xetla-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." (interactive "P") (xetla-generic-add-to-* "junk" =tagging-method)) (defun xetla-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." (interactive "P") (xetla-generic-add-to-* "backup" =tagging-method)) (defun xetla-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." (interactive "P") (xetla-generic-add-to-* "precious" =tagging-method)) (defun xetla-generic-add-to-unrecognized (=tagging-method) "Add the file/directory under the point as a precious entry of .arch-inventory or =tagging-method file." (interactive "P") (xetla-generic-add-to-* "unrecognized" =tagging-method)) (defun xetla-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." (xetla-generic-add-files-to-* category =tagging-method (xetla-generic-select-files (format "Make `%%s' %s? " category) (format "Make %%s files %s? " category) (format "Not making any file %s? " category) (format "Make file %s: " category)))) (defun xetla-generic-add-files-to-* (category =tagging-method files) "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\"." (let ((point (point)) (basedir (expand-file-name default-directory))) ;; Write down (save-excursion (mapc (lambda (file) (if =tagging-method (xetla-edit-=tagging-method-file) (xetla-edit-.arch-inventory-file (concat basedir (file-name-directory file)))) (xetla-inventory-file-add-file category (xetla-regexp-quote (file-name-nondirectory file))) (save-buffer)) files)) ;; Keep the position (prog1 (xetla-generic-refresh) (if (< point (point-max)) (goto-char point))))) (defun xetla-generic-set-id-tagging-method (method) "Set the id tagging method of the current tree to METHOD." (interactive (list (xetla-id-tagging-method-read (xetla-id-tagging-method nil)))) (xetla-id-tagging-method-set method) (xetla-generic-refresh)) (defun xetla-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 'xetla-generic-set-id-tagging-method)) (defun xetla-generic-set-tree-version (&optional version) "Run tla set-tree-version, setting the tree to VERSION." (interactive) (if version (xetla-set-tree-version version) (call-interactively 'xetla-set-tree-version)) (xetla-generic-refresh)) ;; -------------------------------------- ;; xetla-cat-log-mode: ;; -------------------------------------- (defun xetla-cat-log-mode () "Major Mode to show a specific log message. Commands: \\{xetla-cat-log-mode-map}" (interactive) (kill-all-local-variables) (use-local-map xetla-cat-log-mode-map) (set (make-local-variable 'font-lock-defaults) '(xetla-cat-log-font-lock-keywords t)) (font-lock-mode) (setq major-mode 'xetla-cat-log-mode) (setq mode-name "xetla-cat-log") (toggle-read-only 1) (run-hooks 'xetla-cat-log-mode-hook)) (defun xetla-cat-log (revision-spec) "Show the log for REVISION-SPEC." (interactive (list (xetla-name-construct (xetla-name-read "Revision spec: " 'prompt 'prompt 'prompt 'prompt 'prompt)))) (xetla-run-tla-sync (list "cat-log" revision-spec) :finished 'xetla-finish-function-without-buffer-switch) (xetla-show-last-process-buffer 'cat-log 'xetla-cat-log-mode revision-spec)) (defun xetla-cat-archive-log (revision-spec) "Run cat-archive-log for REVISION-SPEC." (interactive (list (xetla-name-construct (xetla-name-read "Revision spec: " 'prompt 'prompt 'prompt 'prompt 'prompt)))) (xetla-run-tla-sync (list "cat-archive-log" revision-spec) :finished 'xetla-finish-function-without-buffer-switch) (xetla-show-last-process-buffer 'cat-log 'xetla-cat-log-mode revision-spec)) (defun xetla-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 `xetla-log-library-greedy' is non-nil." (if xetla-log-library-greedy (let ((dir (expand-file-name (concat (file-name-as-directory xetla-log-library) (car revision)))) (file (xetla-name-construct-semi-qualified (cdr revision)))) (unless (file-directory-p dir) (make-directory dir)) (let ((name (concat " *xetla-log-rev-" (xetla-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 xetla-cat-log-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 "xetla-cat-log-any %S" revision) ;; See if the log is in the log library (when xetla-log-library-greedy (if (not (file-directory-p xetla-log-library)) (make-directory xetla-log-library))) (let* ((lib-log (concat (file-name-as-directory xetla-log-library) (xetla-name-construct revision))) (buffer (or (get-file-buffer lib-log) (when (file-exists-p lib-log) (let* ((name (concat " *xetla-log(" (xetla-name-construct revision) ")*"))) (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 cat-log (let* ((revision-string (xetla-name-construct revision))) (let ((run-mode (if async-handler 'xetla-run-tla-async 'xetla-run-tla-sync)) (handler (if async-handler `(lambda (output error status arguments) (with-current-buffer output (xetla-maybe-save-log ',revision)) (funcall ,async-handler output error status arguments)) `(lambda (output error status arguments) (with-current-buffer output (xetla-maybe-save-log ',revision)))))) (xetla-run-tla-sync ;; Anyway, tla cat-log is fast, so, no ;; need for an asynchronous process. For some reason, ;; running it asynchronously caused a random bug when ;; running tla remotely. (list "cat-log" revision-string) :finished handler ;; cat-log failed: cat-archive-log is needed :error `(lambda (output error status arguments) (funcall ',run-mode (list "cat-archive-log" ,revision-string) :finished ',handler)))))))) ;; Obsolete (defun xetla-log-merges (revision &optional callback) "Return a list that will contain patches merged by REVISION. When the list has been filled in, CALLBACK is called with no arguments." (let ((merges (list ""))) (xetla-cat-log-any revision nil `(lambda (output error status args) (with-current-buffer output (goto-char (point-min)) (unwind-protect (let ((list (split-string (buffer-substring-no-properties (re-search-forward "^New-patches: ") (progn (re-search-forward "^[^\t ]") (beginning-of-line) (point)))))) (setq list (remove (xetla-name-construct ',revision) list)) (setcar ',merges (car list)) (setcdr ',merges (cdr list))) (when ',callback (funcall ',callback)) (kill-buffer nil))))) merges)) ;; -------------------------------------- ;; xetla-log-edit-mode: ;; -------------------------------------- (defun xetla-log-edit-next-field () "Go to next field in a log edition." (interactive) (let ((in-field (string-match "^\\([A-Z][A-Za-z]*\\(: ?\\)?\\)?$" (buffer-substring (point-at-bol) (point))))) (if (and in-field (string-match "^[A-Z][A-Za-z]*: $" (buffer-substring (point-at-bol) (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)) (goto-char (point-max))))) (defun xetla-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 xetla-log-goto-summary () "Go to the Summary field in a log file." (interactive) (xetla-log-goto-field "^Summary:")) (defun xetla-log-goto-keywords () "Go to the Keywords field in a log file." (interactive) (xetla-log-goto-field "^Keywords:")) (defun xetla-log-goto-body () "Go to the Body in a log file." (interactive) (goto-char (point-min)) (forward-line 3)) (defun xetla-log-kill-body () "Kill the content of the log file body." (interactive) (xetla-log-goto-body) (kill-region (point) (point-max))) ;;;###autoload(add-to-list 'auto-mode-alist '("\\+\\+log\\." . xetla-log-edit-mode)) ;;;###autoload (define-derived-mode xetla-log-edit-mode text-mode "xetla-log-edit" "Major Mode to edit xetla log messages. Commands: \\{xetla-log-edit-mode-map} " (use-local-map xetla-log-edit-mode-map) (easy-menu-add xetla-log-edit-mode-menu) (set (make-local-variable 'font-lock-defaults) '(xetla-log-edit-font-lock-keywords t)) (font-lock-mode) (setq fill-column 73) (run-hooks 'xetla-log-edit-mode-hook)) (defun xetla-log-edit-abort () "Abort the current log edit." (interactive) (bury-buffer) (set-window-configuration xetla-pre-commit-window-configuration)) (autoload (quote xetla-tips-popup-maybe) "xetla-tips" "\ Pops up a buffer with a tip if tips are enabled (see `xetla-tips-enabled')" nil nil) (defun xetla-log-edit-done (&optional commit) "Finish the current log edit. With optional prefix arg, COMMIT, also run `tla commit'." (interactive "P") (save-buffer) (let ((log-buffer (current-buffer)) (commit (or current-prefix-arg commit))) (pop-window-configuration) (if (not commit) (bury-buffer log-buffer) (kill-buffer log-buffer) (xetla-commit (lambda (output error status args) (xetla-tips-popup-maybe)))))) (defun xetla-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 the archive name for VERSION." (xetla-bookmarks-get-field version 'nickname (xetla-name-archive version))) (defun xetla-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(a)y.z-a, the result is x(a)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 xetla-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 (xetla-archive-maintainer-name version) (xetla-archive-maintainer-id (xetla-name-archive version) t))) (defun xetla-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 xetla-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 (xetla-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 (xetla-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 xetla-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 (xetla-bookmarks-get-field (xetla-tree-version-list) 'summary-format "Merged from %s"))) (format format-string string))) (defun xetla-merge-summary-line-for-log (&optional version-to-name-function generate-line-function format-line-function) "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 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 `xetla-merge-summary-line', which can be overridden by GENERATE-LINE-FUNCTION. Then, the function FORMAT-LINE-FUNCTION is called with this string S as an argument. If FORMAT-LINE-FUNCTION is nil, then, `xetla-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 (xetla-name-split (match-string 1))) (setq maintainer (funcall (or version-to-name-function 'xetla-archive-default-maintainer-name) rev-list)) (setq rev (cadr (split-string (xetla-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 format-line-function 'xetla-merge-summary-default-format-function) (funcall (or generate-line-function 'xetla-merge-summary-line) alist)))))) (defun xetla-log-edit-insert-log-for-merge-and-headers () "Call `xetla-log-edit-insert-log-for-merge' with a prefix arg." (interactive) (xetla-log-edit-insert-log-for-merge t)) (defun xetla-log-edit-insert-log-for-merge (arg) "Insert the output of xetla log-for-merge at POINT. When called with a prefix argument ARG, create a standard Merged from line as Summary with `xetla-merge-summary-line-for-log'." (interactive "P") (xetla-run-tla-sync '("log-for-merge") :finished `(lambda (output error status arguments) (let ((content (xetla-buffer-content output))) (if (= 0 (length content)) (error "There was no merge!")) (with-current-buffer ,(current-buffer) (let ((on-summary-line (= 1 (count-lines (point-min) (point)))) (old-pos (point))) (if on-summary-line (xetla-log-goto-body) (goto-char old-pos)) (insert content))) (when arg (xetla-log-goto-summary) (delete-region (point) (point-at-eol)) (insert (with-current-buffer output (xetla-merge-summary-line-for-log))) (xetla-log-goto-keywords) (delete-region (point) (point-at-eol)) (insert "merge") (xetla-log-goto-summary)))))) (defun xetla-log-edit-insert-memorized-log () "Insert a memorized log message." (interactive) (when xetla-memorized-log-header (xetla-log-goto-summary) (delete-region (point) (point-at-eol)) (insert xetla-memorized-log-header)) (when xetla-memorized-log-message (xetla-log-goto-body) (insert xetla-memorized-log-message))) ;; -------------------------------------- ;; xetla-log-edit-insert-keywords: ;; -------------------------------------- (defvar xetla-log-edit-keywords-marked-list) (defvar xetla-log-edit-keywords-cookie) (defvar xetla-log-edit-keywords-log-buffer) (defun xetla-log-edit-keywords-printer (elem) "If ELEM is a keyword, print it differently." (insert (if (member elem xetla-log-edit-keywords-marked-list) (concat xetla-mark " ") " ") elem)) (defun xetla-log-edit-keywords (arg) "Add keywords listed in variable `xetla-log-edit-keywords'. When called with a prefix argument ARG, delete all current keywords." (interactive "P") (let ((current-keywords (save-excursion (xetla-log-goto-keywords) (buffer-substring (point) (point-at-eol)))) (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 " *xetla-log-keywords*") (toggle-read-only 0) (erase-buffer) (make-local-variable 'xetla-log-edit-keywords) (make-local-variable 'xetla-log-edit-keywords-marked-list) (make-local-variable 'xetla-log-edit-keywords-cookie) (make-local-variable 'xetla-log-edit-keywords-log-buffer) (setq xetla-log-edit-keywords-log-buffer log-buffer xetla-log-edit-keywords-marked-list current-keywords xetla-log-edit-keywords-cookie (ewoc-create 'xetla-log-edit-keywords-printer "List of keywords from `xetla-log-edit-keywords':" (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 'xetla-log-edit-keywords (car current-keywords)) (setq current-keywords (cdr current-keywords))) (setq keywords xetla-log-edit-keywords) (while keywords (add-to-list 'xetla-log-edit-keywords (car keywords)) (ewoc-enter-last xetla-log-edit-keywords-cookie (car keywords)) (setq keywords (cdr keywords)))) (use-local-map xetla-log-edit-keywords-mode-map) (setq major-mode 'xetla-log-edit-keywords-mode) (setq mode-name "xetla-log-keywords") (toggle-read-only 1) (message "Type C-c C-c to finish.") (goto-char (point-min)) (forward-line 1)) (defun xetla-log-edit-keywords-cursor-goto (elem) "Jump to the location of ELEM." (interactive) (goto-char (ewoc-location elem)) (re-search-forward "^")) (defun xetla-log-edit-keywords-next () "Go to the next keyword." (interactive) (let* ((cookie xetla-log-edit-keywords-cookie) (elem (ewoc-locate cookie)) (next (or (ewoc-next cookie elem) elem))) (xetla-log-edit-keywords-cursor-goto next))) (defun xetla-log-edit-keywords-previous () "Go to the previous keyword." (interactive) (let* ((cookie xetla-log-edit-keywords-cookie) (elem (ewoc-locate cookie)) (previous (or (ewoc-prev cookie elem) elem))) (xetla-log-edit-keywords-cursor-goto previous))) (defun xetla-log-edit-keywords-mark () "Mark the current keyword." (interactive) (let ((pos (point))) (add-to-list 'xetla-log-edit-keywords-marked-list (ewoc-data (ewoc-locate xetla-log-edit-keywords-cookie))) (ewoc-refresh xetla-log-edit-keywords-cookie) (goto-char pos)) (xetla-log-edit-keywords-next)) (defun xetla-log-edit-keywords-unmark () "Unmark the current keyword." (interactive) (let ((pos (point))) (setq xetla-log-edit-keywords-marked-list (delete (ewoc-data (ewoc-locate xetla-log-edit-keywords-cookie)) xetla-log-edit-keywords-marked-list)) (ewoc-refresh xetla-log-edit-keywords-cookie) (goto-char pos)) (xetla-log-edit-keywords-next)) (defun xetla-log-edit-keywords-unmark-all () "Unmark all marked keywords." (interactive) (let ((pos (point))) (setq xetla-log-edit-keywords-marked-list nil) (ewoc-refresh xetla-log-edit-keywords-cookie) (goto-char pos))) (defun xetla-log-edit-keywords-mark-all () "Mark all keywords." (interactive) (let ((pos (point))) (setq xetla-log-edit-keywords-marked-list xetla-log-edit-keywords) (ewoc-refresh xetla-log-edit-keywords-cookie) (goto-char pos))) (defun xetla-log-edit-keywords-toggle-mark () "Toggle marking of the current keyword." (interactive) (let ((pos (point))) (if (member (ewoc-data (ewoc-locate xetla-log-edit-keywords-cookie)) xetla-log-edit-keywords-marked-list) (xetla-log-edit-keywords-unmark) (xetla-log-edit-keywords-mark)) (ewoc-refresh xetla-log-edit-keywords-cookie) (goto-char pos))) (defun xetla-log-edit-keywords-insert () "Insert marked keywords into log buffer." (interactive) (let ((keywords xetla-log-edit-keywords-marked-list)) (switch-to-buffer xetla-log-edit-keywords-log-buffer) (kill-buffer " *xetla-log-keywords*") (save-excursion (xetla-log-goto-keywords) (delete-region (point) (point-at-eol)) (insert (mapconcat 'identity (reverse keywords) ", "))))) ;; -------------------------------------- ;; xetla-archive-list-mode: ;; -------------------------------------- (defun xetla-archive-mirror-archive () "Mirror the archive at point." (interactive) (let ((archive-info (xetla-get-archive-info))) (when archive-info (xetla-mirror-archive archive-info) (xetla-archives)))) (defun xetla-archive-synchronize-archive () "Synchronizes the mirror for the archive at point." (interactive) (let ((archive-info (xetla-get-archive-info))) (when archive-info (xetla-archive-mirror archive-info)))) (defun xetla-archive-list-mode () "Major Mode to show arch archives: \\{xetla-archive-list-mode-map}" (interactive) (kill-all-local-variables) (use-local-map xetla-archive-list-mode-map) (easy-menu-add xetla-archive-list-mode-menu) (setq major-mode 'xetla-archive-list-mode) (setq mode-name "xetla-archives") (toggle-read-only 1) (set-buffer-modified-p nil) (set (make-local-variable 'xetla-get-revision-info-at-point-function) 'xetla-get-archive-info-at-point) (run-hooks 'xetla-archive-list-mode-hook)) (defun xetla-get-archive-info-at-point () "Get archive information." (list 'archive (xetla-get-archive-info))) (defun xetla-archive-select-default () "Select the default archive." (interactive) (when (xetla-get-archive-info) (let ((pos (point))) (xetla-my-default-archive (xetla-get-archive-info)) (xetla-archives) (goto-char pos)))) (defun xetla-archive-unregister-archive () "Delete the registration of the selected archive." (interactive) (let ((archive (xetla-get-archive-info))) (if archive (progn (xetla-unregister-archive archive t) (xetla-archives)) (error "No archive under the point")))) (defun xetla-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 (xetla-get-archive-info))) (xetla-edit-archive-location archive) (save-excursion (xetla-archives)))) (defun xetla-archive-use-as-default-mirror () "Use the mirror archive as default mirror." (interactive) (let ((archive (xetla-get-archive-info))) (xetla-use-as-default-mirror archive) (save-excursion (xetla-archives)))) (defun xetla-archive-list-categories () "List the categories for the current archive." (interactive) (let ((archive (xetla-get-archive-info))) (if archive (xetla-categories archive) (error "No archive under the point")))) (xetla-make-bymouse-function xetla-archive-list-categories) (defun xetla-archive-browse-archive () "Browse the current archive." (interactive) (let ((archive (xetla-get-archive-info))) (if archive (xetla-browse-archive archive) (error "No archive under the point")))) (defun xetla-archive-next () "Go to the next archive." (interactive) (forward-line 2) (beginning-of-line)) (defun xetla-archive-previous () "Go to the previous archive." (interactive) (forward-line -2) (beginning-of-line)) (defun xetla-save-archive-to-kill-ring () "Save the name of the current archive to the kill ring." (interactive) (let ((archive (or (xetla-get-archive-info) xetla-buffer-archive-name (xetla-name-archive (xetla-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)) ;; -------------------------------------- ;; xetla-category-list-mode: ;; -------------------------------------- (defun xetla-category-list-mode () "Major Mode to show arch categories: \\{xetla-category-list-mode-map}" (interactive) (kill-all-local-variables) (use-local-map xetla-category-list-mode-map) (easy-menu-add xetla-category-list-mode-menu) (setq major-mode 'xetla-category-list-mode) (setq mode-name "xetla-category") (add-hook 'xetla-make-category-hook 'xetla-category-refresh) (toggle-read-only 1) (set-buffer-modified-p nil) (set (make-local-variable 'xetla-get-revision-info-at-point-function) 'xetla-get-category-info-at-point) (run-hooks 'xetla-category-list-mode-hook)) (defun xetla-get-category-info-at-point () "Get archive/category-branch information." (let ((buffer-version (xetla-name-construct xetla-buffer-archive-name (xetla-get-archive-info 'xetla-category-info)))) (list 'category buffer-version))) (defun xetla-category-list-branches () "List branches of the current category." (interactive) (let ((category (xetla-get-archive-info 'xetla-category-info))) (if category (xetla-branches xetla-buffer-archive-name category) (error "No category under the point")))) (xetla-make-bymouse-function xetla-category-list-branches) (defun xetla-category-make-category (category) "Create a new category named CATEGORY." (interactive "sCategory name: ") (xetla-make-category xetla-buffer-archive-name category)) (defun xetla-category-refresh () "Refresh the current category list." (interactive) (xetla-categories xetla-buffer-archive-name)) (defun xetla-category-next () "Move to the next category." (interactive) (forward-line 1) (beginning-of-line)) (defun xetla-category-previous () "Move to the previous category." (interactive) (forward-line -1) (beginning-of-line) (unless (looking-at "^ ") (forward-line 1))) (defun xetla-category-mirror-archive () "Mirror the current category." (interactive) (let ((category (xetla-get-archive-info 'xetla-category-info))) (unless category (error "No category at point")) (xetla-archive-mirror xetla-buffer-archive-name category))) (defun xetla-category-bookmarks-add-here (name) "Add a bookmark named NAME for this category." (interactive "sBookmark name: ") (xetla-bookmarks-add name (list xetla-buffer-archive-name (xetla-get-archive-info 'xetla-category-info) nil nil nil)) (message "bookmark %s added." name)) (defun xetla-category-bookmarks-add (name) "Add a bookmark named NAME for this category." (interactive "sBookmark name: ") (xetla-bookmarks-add name (list xetla-buffer-archive-name nil nil nil)) (message "bookmark %s added." name)) ;; -------------------------------------- ;; xetla-branch-list-mode ;; -------------------------------------- (defun xetla-branch-list-mode () "Major Mode to show arch branches: \\{xetla-branch-list-mode-map}" (interactive) (kill-all-local-variables) (use-local-map xetla-branch-list-mode-map) (easy-menu-add xetla-branch-list-mode-menu) (setq major-mode 'xetla-branch-list-mode) (setq mode-name "xetla-branch") (add-hook 'xetla-make-branch-hook 'xetla-branch-refresh) (toggle-read-only 1) (set-buffer-modified-p nil) (set (make-local-variable 'xetla-get-revision-info-at-point-function) 'xetla-get-branch-info-at-point) (run-hooks 'xetla-branch-list-mode-hook)) (defun xetla-get-branch-info-at-point () "Get archive/category-branch-version information." (let ((buffer-version (xetla-name-construct xetla-buffer-archive-name xetla-buffer-category-name (xetla-get-archive-info 'xetla-branch-info)))) (list 'branch buffer-version))) (defun xetla-branch-make-branch (branch) "Create a new branch named BRANCH." (interactive "sBranch name: ") (xetla-make-branch xetla-buffer-archive-name xetla-buffer-category-name branch)) (defun xetla-branch-refresh () "Refresh the current branch list." (interactive) (xetla-branches xetla-buffer-archive-name xetla-buffer-category-name)) (defun xetla-branch-list-parent-category () "List the parent category of the current branch." (interactive) (xetla-categories xetla-buffer-archive-name)) (defun xetla-branch-list-versions () "List the versions of the current branch." (interactive) (let ((branch (xetla-get-archive-info 'xetla-branch-info))) (if branch (xetla-versions xetla-buffer-archive-name xetla-buffer-category-name branch) (error "No branch under the point")))) (xetla-make-bymouse-function xetla-branch-list-versions) (defun xetla-branch-mirror-archive () "Mirror the current branch." (interactive) (let ((branch (xetla-get-archive-info 'xetla-branch-info))) (unless branch (error "No branch under the point")) (xetla-archive-mirror xetla-buffer-archive-name xetla-buffer-category-name branch))) (defun xetla-branch-get-branch (directory) "Get the current branch and place it in DIRECTORY." (interactive (list (expand-file-name (read-directory-name (format "Restore \"%s\" to: " (let ((branch (xetla-get-archive-info 'xetla-branch-info))) (unless branch (error "No branch under the point")) (xetla-name-construct xetla-buffer-archive-name xetla-buffer-category-name branch))))))) (let ((branch (xetla-get-archive-info 'xetla-branch-info))) (if branch (xetla-get directory t xetla-buffer-archive-name xetla-buffer-category-name branch) (error "No branch under the point")))) (defun xetla-branch-bookmarks-add-here (name) "Add a bookmark named NAME for the current branch." (interactive "sBookmark name: ") (xetla-bookmarks-add name (list xetla-buffer-archive-name xetla-buffer-category-name (xetla-get-archive-info 'xetla-branch-info) nil nil)) (message "bookmark %s added." name)) (defun xetla-branch-bookmarks-add (name) "Add a bookmark named NAME for the current branch." (interactive "sBookmark name: ") (xetla-bookmarks-add name (list xetla-buffer-archive-name xetla-buffer-category-name nil nil nil)) (message "bookmark %s added." name)) ;; -------------------------------------- ;; xetla-version-list-mode ;; -------------------------------------- (defun xetla-version-list-mode () "Major Mode to show arch versions: \\{xetla-version-list-mode-map}" (interactive) (kill-all-local-variables) (use-local-map xetla-version-list-mode-map) (easy-menu-add xetla-version-list-mode-menu) (setq major-mode 'xetla-version-list-mode) (setq mode-name "xetla-version") (add-hook 'xetla-make-version-hook 'xetla-version-refresh) (toggle-read-only 1) (set-buffer-modified-p nil) (set (make-local-variable 'xetla-get-revision-info-at-point-function) 'xetla-get-version-info-at-point) (run-hooks 'xetla-version-list-mode-hook)) (defun xetla-get-version-info-at-point () "Get archive/category-branch-version-revision information." (let ((buffer-version (xetla-name-construct xetla-buffer-archive-name xetla-buffer-category-name xetla-buffer-branch-name (xetla-get-archive-info 'xetla-version-info)))) (list 'version buffer-version))) (defun xetla-version-refresh () "Refresh the current version list." (interactive) (xetla-versions xetla-buffer-archive-name xetla-buffer-category-name xetla-buffer-branch-name)) (defun xetla-version-list-parent-branch () "List the parent branch of this version." (interactive) (xetla-branches xetla-buffer-archive-name xetla-buffer-category-name)) (defun xetla-version-list-revisions () "List the revisions of this version." (interactive) (let ((version (xetla-get-archive-info 'xetla-version-info))) (if version (xetla-revisions xetla-buffer-archive-name xetla-buffer-category-name xetla-buffer-branch-name version) (error "No version under the point")))) (xetla-make-bymouse-function xetla-version-list-revisions) (defun xetla-version-make-version (version) "Create a new version named VERSION." (interactive "sVersion name: ") (xetla-make-version xetla-buffer-archive-name xetla-buffer-category-name xetla-buffer-branch-name version)) (defun xetla-version-bookmarks-add-here (name) "Add a bookmark named NAME for the current version." (interactive "sBookmark name: ") (xetla-bookmarks-add name (list xetla-buffer-archive-name xetla-buffer-category-name xetla-buffer-branch-name (xetla-get-archive-info 'xetla-version-info) nil)) (message "bookmark %s added." name)) (defun xetla-version-bookmarks-add (name) "Add a bookmark named NAME for the current version." (interactive "sBookmark name: ") (xetla-bookmarks-add name (list xetla-buffer-archive-name xetla-buffer-category-name xetla-buffer-branch-name nil nil)) (message "bookmark %s added." name)) (defun xetla-version-get-version (directory) "Get a version and place it in DIRECTORY." (interactive (list (expand-file-name (read-directory-name (format "Restore \"%s\" to: " (let ((version (xetla-get-archive-info 'xetla-version-info))) (unless version (error "No version under the point")) (xetla-name-construct xetla-buffer-archive-name xetla-buffer-category-name xetla-buffer-branch-name version))))))) (let ((version (xetla-get-archive-info 'xetla-version-info))) (if version (xetla-get directory t xetla-buffer-archive-name xetla-buffer-category-name xetla-buffer-branch-name version) (error "No version under the point")))) (defun xetla-version-mirror-archive () "Mirror the current version." (interactive) (let ((version (xetla-get-archive-info 'xetla-version-info))) (if version (xetla-archive-mirror xetla-buffer-archive-name xetla-buffer-category-name xetla-buffer-branch-name version)))) (defun xetla-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 (xetla-name-read "Tag to: " 'prompt 'prompt 'prompt 'prompt))) (list (xetla-name-archive l) (xetla-name-category l) (xetla-name-branch l) (xetla-name-version l)))) (let ((to-fq (xetla-name-construct to-archive to-category to-branch to-version)) from-fq (from-version (xetla-get-archive-info 'xetla-version-info))) (unless from-version (error "No version under the point")) (setq from-fq (xetla-name-construct xetla-buffer-archive-name xetla-buffer-category-name xetla-buffer-branch-name from-version)) (xetla-version-tag-internal from-fq to-fq))) (defun xetla-version-tag-internal (from-fq to-fq &optional synchronously) "Create a tag from FROM-FQ to TO-FQ. If SYNCHRONOUSLY is non-nil, internal `xetla-get' runs synchronously. Else it runs asynchronously." (when (yes-or-no-p (format "Create a tag from `%s' to `%s'? " from-fq to-fq)) (unless (xetla-tag from-fq to-fq) (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 (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 (xetla-name-split to-fq)) (xetla-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))))) ;; -------------------------------------- ;; xetla-revision-list-mode ;; -------------------------------------- (defun xetla-revision-list-mode () "Major Mode to show arch revisions: \\{xetla-revision-list-mode-map}" (interactive) (kill-all-local-variables) (toggle-read-only -1) (use-local-map xetla-revision-list-mode-map) (easy-menu-add xetla-revision-list-mode-menu) (setq major-mode 'xetla-revision-list-mode) (setq mode-name "xetla-revision") (add-hook 'xetla-make-revision-hook 'xetla-revision-refresh) (erase-buffer) (set (make-local-variable 'xetla-revision-list-cookie) (ewoc-create 'xetla-revision-list-printer)) (toggle-read-only 1) (set-buffer-modified-p nil) (set (make-local-variable 'xetla-get-revision-info-at-point-function) 'xetla-get-revision-info-at-point) (setq mode-line-process 'xetla-mode-line-process) (run-hooks 'xetla-revision-list-mode-hook)) (defun xetla-get-revision-info-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 xetla-revision-list-cookie)))) (when (eq (car elem) 'entry-patch) (let* ((full (xetla-revision-revision (caddr elem))) (buffer-revision (xetla-name-construct full))) (list 'revision buffer-revision))))) (defun xetla-revision-refresh () "Refresh the current list of revisions." (interactive) (xetla-revisions xetla-buffer-archive-name xetla-buffer-category-name xetla-buffer-branch-name xetla-buffer-version-name)) (defun xetla-revision-list-parent-version () "List the versions of the parent of this revision." (interactive) (xetla-versions xetla-buffer-archive-name xetla-buffer-category-name xetla-buffer-branch-name)) (defun xetla-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 xetla-revision-list-cookie))) (full (xetla-revision-revision (caddr elem))) (revision (xetla-name-revision full)) (archive (xetla-name-archive full)) (category (xetla-name-category full)) (branch (xetla-name-branch full)) (version (xetla-name-version full)) dir) (unless revision (error "No revision under the point")) (setq dir (expand-file-name (read-directory-name (format "Restore \"%s\" to: " (xetla-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 (xetla-get directory t archive category branch version revision) (error "No revision under the point"))) (defun xetla-revision-cache-revision (archive category branch version revision) "Create a cached revision for the revision at point." (interactive (let* ((elem (ewoc-data (ewoc-locate xetla-revision-list-cookie))) (full (xetla-revision-revision (caddr elem))) (archive (xetla-name-archive full)) (category (xetla-name-category full)) (branch (xetla-name-branch full)) (version (xetla-name-version full)) (revision (xetla-name-revision full))) (unless revision (error "No revision under the point")) (list archive category branch version revision))) (if revision (xetla-cache-revision archive category branch version revision) (error "No revision under the point"))) (defun xetla-revision-add-to-library (archive category branch version revision) "Add the revision at point to library." (interactive (let* ((elem (ewoc-data (ewoc-locate xetla-revision-list-cookie))) (full (xetla-revision-revision (caddr elem))) (archive (xetla-name-archive full)) (category (xetla-name-category full)) (branch (xetla-name-branch full)) (version (xetla-name-version full)) (revision (xetla-name-revision full))) (unless revision (error "No revision under the point")) (list archive category branch version revision))) (if revision (xetla-library-add archive category branch version revision) (error "No revision under the point"))) (defun xetla-revision-maybe-refresh () "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 xetla-revisions-shows-date xetla-revisions-shows-creator xetla-revisions-shows-summary xetla-revisions-shows-merges xetla-revisions-shows-merged-by) (let ((stop nil) (ewoc-elem (ewoc-nth xetla-revision-list-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 xetla-revision-list-cookie ewoc-elem))))) (when (and ewoc-elem (null (xetla-revision-summary (caddr (ewoc-data ewoc-elem))))) (xetla-generic-refresh))))) (defun xetla-revision-toggle-date () "Toggle display of the date in the revision list." (interactive) (setq xetla-revisions-shows-date (not xetla-revisions-shows-date)) (xetla-revision-maybe-refresh) (ewoc-refresh xetla-revision-list-cookie)) (defun xetla-revision-toggle-summary () "Toggle display of the summary information in the revision list." (interactive) (setq xetla-revisions-shows-summary (not xetla-revisions-shows-summary)) (xetla-revision-maybe-refresh) (ewoc-refresh xetla-revision-list-cookie)) (defun xetla-revision-toggle-creator () "Toggle display of the creator in the revision list." (interactive) (setq xetla-revisions-shows-creator (not xetla-revisions-shows-creator)) (xetla-revision-maybe-refresh) (ewoc-refresh xetla-revision-list-cookie)) (defun xetla-revision-toggle-library () "Toggle display of the revision library in the revision list." (interactive) (setq xetla-revisions-shows-library (not xetla-revisions-shows-library)) (ewoc-refresh xetla-revision-list-cookie)) (defun xetla-revision-toggle-merges () "Toggle display of the merges in the revision list." (interactive) (setq xetla-revisions-shows-merges (not xetla-revisions-shows-merges)) (xetla-revision-maybe-refresh) (ewoc-refresh xetla-revision-list-cookie)) (defun xetla-revision-toggle-merged-by () "Toggle display of merged-by in the revision list." (interactive) (setq xetla-revisions-shows-merged-by (not xetla-revisions-shows-merged-by)) (when (and (not xetla-revision-merge-by-computed) xetla-revisions-shows-merged-by) (xetla-revision-maybe-refresh) (xetla-revision-compute-merged-by)) (ewoc-refresh xetla-revision-list-cookie)) (defun xetla-revision-changeset (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") (let* ((cookie xetla-revision-list-cookie) (full (xetla-revision-revision (caddr (ewoc-data (ewoc-locate cookie))))) (revision (xetla-name-construct full))) (xetla-get-changeset revision t nil arg))) (defun xetla-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") (xetla-revision-delta across-versions t)) (defun xetla-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 (xetla-revision-revision (caddr (ewoc-data (ewoc-locate xetla-revision-list-cookie))))) (modified-fq (xetla-name-construct modified)) (base (let ((marked (xetla-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 ;; (xetla-revision-unmark-all) (xetla-revision-revision (car marked))) (t (xetla-name-read (format "Revision for delta to %s from: " (if across-versions modified-fq (xetla-name-revision modified))) (if across-versions 'prompt (xetla-name-archive modified)) (if across-versions 'prompt (xetla-name-category modified)) (if across-versions 'prompt (xetla-name-branch modified)) (if across-versions 'prompt (xetla-name-version modified)) 'maybe)))))) (unless (xetla-name-archive base) (error "Archive for the base is not specified")) (unless (xetla-name-category base) (error "Cateogory for the base is not specified")) (unless (xetla-name-branch base) (error "Branch for the base is not specified")) (unless (xetla-name-version base) (error "Version for the base is not specified")) (unless (xetla-name-revision base) ;; No revision for modified is specified. ;; Use HEAD revision. (setcar (nthcdr 4 base) (xetla-version-head (xetla-name-archive base) (xetla-name-category base) (xetla-name-branch base) (xetla-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)) (xetla-delta (xetla-name-construct base) modified-fq stored-to-directory))) (defun xetla-revision-bookmarks-add (name) "Add a bookmark named NAME for the current revision." (interactive "sBookmark name: ") (xetla-bookmarks-add name (list xetla-buffer-archive-name xetla-buffer-category-name xetla-buffer-branch-name xetla-buffer-version-name nil)) (message "bookmark %s added." name)) (defun xetla-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 (xetla-last-visited-inventory-buffer)) (local-tree (or (if last-inventory (with-current-buffer last-inventory default-directory) default-directory))) (current (ewoc-locate xetla-revision-list-cookie))) (while (and current (not (and (eq (car (ewoc-data current)) 'separator) (eq (caddr (ewoc-data current)) 'bookmark)))) (setq current (ewoc-prev xetla-revision-list-cookie current))) (when (and current (eq (car (ewoc-data current)) 'separator) (eq (caddr (ewoc-data current)) 'bookmark)) (setq local-tree (cadddr (ewoc-data current)))) (let ((to-tree (read-directory-name "Sync with tree: " local-tree))) (let* ((elem (ewoc-data (ewoc-locate xetla-revision-list-cookie))) (full (xetla-revision-revision (caddr elem)))) (xetla-sync-tree (xetla-name-construct (if arg (butlast full) full)) to-tree))))) (defun xetla-revision-star-merge-version () "Run star-merge for the version at point." (interactive) (xetla-revision-star-merge t)) (defun xetla-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 (xetla-last-visited-inventory-buffer)) (local-tree (or (if last-inventory (with-current-buffer last-inventory default-directory) default-directory))) (current (ewoc-locate xetla-revision-list-cookie))) (while (and current (not (and (eq (car (ewoc-data current)) 'separator) (eq (caddr (ewoc-data current)) 'bookmark)))) (setq current (ewoc-prev xetla-revision-list-cookie current))) (when (and current (eq (car (ewoc-data current)) 'separator) (eq (caddr (ewoc-data current)) 'bookmark)) (setq local-tree (cadddr (ewoc-data current)))) (let ((to-tree (read-directory-name "Merge to tree: " local-tree))) (let* ((elem (ewoc-data (ewoc-locate xetla-revision-list-cookie))) (full (xetla-revision-revision (caddr elem)))) (xetla-star-merge (xetla-name-construct (if arg (butlast full) full)) to-tree))))) (defun xetla-revision-replay-version () "Call `xetla-revision-replay' with a prefix arg." (interactive) (xetla-revision-replay t)) (defun xetla-revision-replay (arg) "Run replay from the current location. If there are marked revisions, these are replayed. Otherwise, if an argument ARG is given, all missing revisions from this version are replayed. If there are no marked revisions and no argument is given, the revision under the point is replayed." (interactive "P") (let* ((last-inventory (xetla-last-visited-inventory-buffer)) (local-tree (or (if last-inventory (with-current-buffer last-inventory default-directory) default-directory))) (current (ewoc-locate xetla-revision-list-cookie))) (while (and current (not (and (eq (car (ewoc-data current)) 'separator) (eq (caddr (ewoc-data current)) 'bookmark)))) (setq current (ewoc-prev xetla-revision-list-cookie current))) (when (and current (eq (car (ewoc-data current)) 'separator) (eq (caddr (ewoc-data current)) 'bookmark)) (setq local-tree (cadddr (ewoc-data current)))) (let ((to-tree (read-directory-name "Replay to tree: " local-tree))) (if (xetla-revision-marked-revisions) (let ((revisions (mapcar 'xetla-revision-revision (xetla-revision-marked-revisions)))) (xetla-replay (sort (mapcar (lambda (revision) (xetla-name-construct revision)) revisions) 'string<) to-tree)) (let* ((elem (ewoc-data (ewoc-locate xetla-revision-list-cookie))) (full (xetla-revision-revision (caddr elem)))) (xetla-replay (xetla-name-construct (if arg (butlast full) full)) to-tree)))))) (defun xetla-revision-mark-revision () "Mark revision at point." (interactive) (let ((pos (point)) (data (ewoc-data (ewoc-locate xetla-revision-list-cookie)))) (setcar (cdr data) t) (ewoc-refresh xetla-revision-list-cookie) (goto-char pos) (xetla-revision-next))) (defun xetla-revision-marked-revisions () "Return the revisions that are currently marked." (let ((acc '())) (ewoc-map #'(lambda (x) (when (and (eq (car x) 'entry-patch) (cadr x)) (push (caddr x) acc))) xetla-revision-list-cookie) (nreverse acc))) (defun xetla-revision-unmark-revision () "Unmark the revision at point." (interactive) (let ((pos (point)) (data (ewoc-data (ewoc-locate xetla-revision-list-cookie)))) (setcar (cdr data) nil) (ewoc-refresh xetla-revision-list-cookie) (goto-char pos) (xetla-revision-next))) (defun xetla-revision-unmark-all () "Unmark all revisions." (interactive) (let ((pos (point))) (ewoc-map #'(lambda (x) (when (and (eq (car x) 'entry-patch) (cadr x)) (setcar (cdr x) nil))) xetla-revision-list-cookie) (ewoc-refresh xetla-revision-list-cookie) (goto-char pos))) (defun xetla-revision-tag-from-head () "Run tla tag from the newest revision in revision buffer." (interactive) (let* ((from (when xetla-buffer-archive-name (xetla-name-construct xetla-buffer-archive-name xetla-buffer-category-name xetla-buffer-branch-name xetla-buffer-version-name)))) (unless from (error "No head revision")) (xetla-revision-tag-internal from))) (defun xetla-revision-tag-from-here () "Run tla tag from the current location in revision buffer." (interactive) (let ((from (when xetla-revision-list-cookie (let* ((elem (ewoc-data (ewoc-locate xetla-revision-list-cookie)))) (apply 'xetla-name-construct (aref (caddr elem) 1)))))) (unless from (error "No revision here")) (xetla-revision-tag-internal from))) (defun xetla-revision-tag-internal (from-fq) "Tag from FROM-FQ to some destination." (let* ((to (xetla-name-read "Tag to: " 'prompt 'prompt 'prompt 'prompt)) (to-fq (xetla-name-construct to))) (xetla-version-tag-internal from-fq to-fq))) (defun xetla-revision-show-changeset () "Show a changeset for the current revision." (interactive) (let ((elem (ewoc-data (ewoc-locate xetla-revision-list-cookie)))) (case (car elem) (entry-patch (xetla-revision-cat-log)) (entry-change (let ((default-directory (caddr elem))) (xetla-changes)))))) (xetla-make-bymouse-function xetla-revision-show-changeset) (defun xetla-revision-cat-log () "Show the log entry for the revision at point." (interactive) (let* ((elem (ewoc-data (ewoc-locate xetla-revision-list-cookie))) (full (xetla-revision-revision (caddr elem))) (cur-buf (current-buffer)) (log-buf (xetla-cat-log-any full)) (display-buf (xetla-get-buffer-create 'cat-log (xetla-name-construct full)))) (xetla-switch-to-buffer display-buf) (let ((inhibit-read-only t)) (erase-buffer) (insert (with-current-buffer log-buf (buffer-string))) (goto-char (point-min))) (xetla-cat-log-mode) (when (eq xetla-switch-to-buffer-mode 'pop-to-buffer) (pop-to-buffer cur-buf)))) (defun xetla-revision-update () "Run tla update for this revision." (interactive) (let ((local-tree default-directory) ;; Default value (current (ewoc-locate xetla-revision-list-cookie))) (while (and current (not (and (eq (car (ewoc-data current)) 'separator) (eq (caddr (ewoc-data current)) 'bookmark)))) (setq current (ewoc-prev xetla-revision-list-cookie current))) (when (and current (eq (car (ewoc-data current)) 'separator) (eq (caddr (ewoc-data current)) 'bookmark)) (setq local-tree (cadddr (ewoc-data current)))) (let ((buffer (current-buffer))) (xetla-update (read-directory-name "Update tree: " local-tree) `(lambda () (pop-to-buffer ,buffer) (xetla-generic-refresh)))))) (defcustom xetla-send-comments-width 25 "*Max length for the summary line when using %t in `xetla-send-comments-format'.") (defcustom xetla-send-comments-format "Your patch %c--%b--%v--%r (%t)" "Format for the Subject line for `xetla-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 `xetla-send-comments-width' characters.") (defun xetla-revision-send-comments (revision) "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 `xetla-revision-list-cookie'. When called interactively, REVISION is the revision at point." (interactive (list (caddr (ewoc-data (ewoc-locate xetla-revision-list-cookie))))) (let* ((full-rev (xetla-revision-revision revision)) (archive (xetla-name-archive full-rev)) (email (progn (string-match "\\(.*\\)--\\([^-]\\|-[^-]\\)" archive) (match-string 1 archive))) (summary (xetla-revision-summary revision)) (subject xetla-send-comments-format)) (dolist (pair '(("%f" . (xetla-name-construct full-rev)) ("%a" . archive) ("%c" . (xetla-name-category full-rev)) ("%b" . (xetla-name-branch full-rev)) ("%v" . (xetla-name-version full-rev)) ("%r" . (xetla-name-revision full-rev)) ("%s" . summary) ("%t" . (if (> (string-width summary) xetla-send-comments-width) (concat (truncate-string summary 25) "...") summary)))) (setq subject (replace-regexp-in-string (car pair) (eval (cdr pair)) subject))) (compose-mail email subject) (save-excursion (insert "\n\n" (xetla-name-construct full-rev) "\n" " " summary "\n" " " (xetla-revision-date revision) "\n" " " (xetla-revision-creator revision) "\n")))) ;; -------------------------------------- ;; xetla-changes-mode ;; -------------------------------------- (define-derived-mode xetla-changes-mode fundamental-mode "xetla-changes" "Major mode to display changesets. Derives from `diff-mode'. Use '\\<xetla-changes-mode-map>\\[xetla-changes-mark-file]' to mark files, and '\\[xetla-changes-unmark-file]' to unmark. If you commit from this buffer (with '\\[xetla-changes-edit-log]'), then, the list of selected files in this buffer at the time you actually commit with \\<xetla-log-edit-mode-map>\\[xetla-log-edit-done]. Commands: \\{xetla-changes-mode-map} " (let ((diff-mode-shared-map (copy-keymap xetla-changes-mode-map)) major-mode mode-name) (diff-mode)) (set (make-local-variable 'font-lock-defaults) (list 'xetla-changes-font-lock-keywords t nil nil)) (font-lock-mode) (set (make-local-variable 'xetla-get-file-info-at-point-function) 'xetla-changes-get-file-at-point) (set (make-local-variable 'xetla-buffer-refresh-function) 'xetla-changes-generic-refresh) (set (make-local-variable 'xetla-changes-cookie) (ewoc-create 'xetla-changes-printer)) (make-local-variable 'xetla-buffer-marked-file-list) (easy-menu-add xetla-changes-mode-menu) (toggle-read-only 1) (set-buffer-modified-p nil)) (defun xetla-changes-generic-refresh () "Refresh the changes buffer." (interactive) (if (eq (car xetla-changes-modified) 'local-tree) (xetla-changes xetla-changes-summary xetla-changes-base))) (defun xetla-changes-jump-to-change (&optional other-file) "Jump to the corresponding file and location of the change. The prefix argument OTHER-FILE controls whether the original or new file is visited." (interactive "P") (let* ((elem (ewoc-locate xetla-changes-cookie)) (data (ewoc-data elem))) (cond ((< (ewoc-location elem) (point-at-bol)) (xetla-changes-diff-goto-source other-file)) ((eq (car data) 'file) (find-file (cadr data))) ((eq (car data) 'subtree) (xetla-switch-to-buffer (cadr data))) (t (error "Not on a recognized location"))))) (defun xetla-changes-diff-goto-source (other-file) "Almost the same as `diff-goto-source'. But the target file is transformed by `xetla-changes-what-changed-original-file' to handle files in what-changed directory. OTHER-FILE controls whether the original or new file is visited." (let ((xetla-original-file-exists-p (symbol-function 'file-exists-p)) (xetla-original-find-file-noselect (symbol-function 'find-file-noselect))) (flet ((file-exists-p (file) (unless (string= "/dev/null" file) (funcall xetla-original-file-exists-p (xetla-changes-what-changed-original-file file)))) (find-file-noselect (file &optional nowarn rawfile wildcards) (if (featurep 'xemacs) (funcall xetla-original-find-file-noselect (xetla-changes-what-changed-original-file file) nowarn rawfile) (funcall xetla-original-find-file-noselect (xetla-changes-what-changed-original-file file) nowarn rawfile wildcards)))) (diff-goto-source other-file)))) (defun xetla-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 xetla-changes-diff-or-list () "Move around the changes buffer. When in the list part of the buffer, jump to the corresponding patch. When on a patch, jump to the corresponding entry in the list of files." (interactive) (let* ((elem (ewoc-locate xetla-changes-cookie)) (data (ewoc-data elem))) (cond ((< (ewoc-location elem) (point-at-bol)) (let ((file (xetla-changes-get-file-at-point)) (elem (ewoc-nth xetla-changes-cookie 0))) (while (and elem (or (not (eq (car (ewoc-data elem)) 'file)) (not (string= (expand-file-name (cadr (ewoc-data elem))) file)))) (setq elem (ewoc-next xetla-changes-cookie elem))) (if elem (goto-char (ewoc-location elem)) (error (format "Can't find file %s in list" file))) )) ((eq (car data) 'file) (re-search-forward (concat "^--- orig/" (cadr data))) (diff-hunk-next)) ((eq (car data) 'subtree) (xetla-switch-to-buffer (cadr data))) (t (error "Not on a recognized location"))))) (defun xetla-changes-master-buffer () "Jump to the master *xetla-changes* buffer for a nested changes buffer." (interactive) (unless xetla-changes-buffer-master-buffer (error "No master buffer")) (xetla-switch-to-buffer xetla-changes-buffer-master-buffer)) (defun xetla-flash-line-on () "Turn on highline mode or equivalent." (or (xetla-funcall-if-exists hl-line-mode) (xetla-funcall-if-exists highline-on))) (defun xetla-flash-line-off () "Turn off highline mode or equivalent." (or (xetla-funcall-if-exists hl-line-mode) (xetla-funcall-if-exists highline-off))) (defun xetla-flash-line () "Flash the current line." (let ((buffer (current-buffer))) (xetla-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) (xetla-flash-line-off))) (defun xetla-changes-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) (xetla-flash-line) (select-window diff-window)))) (defun xetla-changes-edit-log (&optional insert-changelog) "Wrapper around `xetla-edit-log', setting the source buffer to current buffer." (interactive "P") (xetla-edit-log insert-changelog (current-buffer))) (defun xetla-changes-rm () "Remove the file under point." (interactive) (let ((file (xetla-get-file-info-at-point))) (unless file (error "No file at point")) (xetla-rm file))) (defun xetla-changes-mark-file () "Mark the file under point." (interactive) (let ((current (ewoc-locate xetla-changes-cookie)) (file (xetla-get-file-info-at-point))) (add-to-list 'xetla-buffer-marked-file-list file) (ewoc-refresh xetla-changes-cookie) (goto-char (ewoc-location (or (ewoc-next xetla-changes-cookie current) current))))) (defun xetla-changes-unmark-file () "Unmark the file under point." (interactive) (let ((current (ewoc-locate xetla-changes-cookie)) (file (xetla-get-file-info-at-point))) (setq xetla-buffer-marked-file-list (delete file xetla-buffer-marked-file-list)) (ewoc-refresh xetla-changes-cookie) (goto-char (ewoc-location (or (ewoc-next xetla-changes-cookie current) current))))) (defun xetla-changes-diff () "Run tla file-diff on the file at point in *xetla-changes*." (interactive) (let ((on-modified-file (xetla-get-file-info-at-point))) (if on-modified-file (xetla-file-diff on-modified-file) (error "Not on a modified file")))) (defun xetla-changes-next () "Move to the next changes." (interactive) (let ((cur-location (ewoc-location (ewoc-locate xetla-changes-cookie))) (next (ewoc-next xetla-changes-cookie (ewoc-locate xetla-changes-cookie)))) (cond ((> cur-location (point)) (goto-char cur-location)) (next (goto-char (ewoc-location next))) (t (diff-hunk-next))))) (defun xetla-changes-prev () "Move to the previous changes." (interactive) (let* ((current (ewoc-locate xetla-changes-cookie)) (cur-location (ewoc-location current)) (prev (ewoc-prev xetla-changes-cookie current)) (next (ewoc-next xetla-changes-cookie current))) (cond (next (if prev (goto-char (ewoc-location prev)) (goto-char cur-location))) ((condition-case nil (progn (diff-hunk-prev) t) (error nil))) ((> (point-at-bol) cur-location) (goto-char cur-location)) (prev (goto-char (ewoc-location prev))) (t (goto-char cur-location))) )) (defun xetla-changes-in-diff () "Return t if cursor is in the diffs section of the changes buffer." (save-excursion (re-search-backward "^--- orig" nil t))) (defun xetla-changes-ediff (&optional other-file) "Run ediff on the current changes. The prefix argument OTHER-FILE controls whether the original or new file is visited." (interactive "P") (unless (and (car xetla-changes-base) (car xetla-changes-base)) (error "No revision information to base ediff on")) (let ((on-modified-file (xetla-get-file-info-at-point)) (loc (point))) (if (and on-modified-file (not (xetla-changes-in-diff))) (xetla-file-ediff-revisions on-modified-file xetla-changes-base xetla-changes-modified) (re-search-backward "^--- orig/") (re-search-forward "^--- orig/") (let ((file (expand-file-name (concat (file-name-as-directory default-directory) (buffer-substring-no-properties (point) (point-at-eol))))) (hunk 1)) (diff-hunk-next) (while (<= (re-search-forward "\\(^[\\+-].*\n\\)+" nil t) loc) (setq hunk (1+ hunk))) (goto-char loc) (with-current-buffer (xetla-file-ediff-revisions file xetla-changes-base xetla-changes-modified) (ediff-jump-to-difference hunk)))))) (defun xetla-changes-get-file-at-point () "Find file at point in *xetla-changes*. Throw an error when not on a file." (let ((elem (ewoc-locate xetla-changes-cookie (point)))) (or (when (and elem (eq (car (ewoc-data elem)) 'file) (>= (ewoc-location elem) (point-at-bol))) (cadr (ewoc-data elem))) (expand-file-name (concat (file-name-as-directory default-directory) (diff-find-file-name)))))) (defun xetla-changes-jump-to-change-by-mouse (event &optional other-file) "Jump to the changes." (interactive "e\nP") (mouse-set-point event) (xetla-changes-jump-to-change other-file)) (defun xetla-changes-revert () "Reverts file at point." (interactive) (let* ((file (xetla-get-file-info-at-point)) (absolute (if (file-name-absolute-p file) file (expand-file-name (concat (file-name-as-directory default-directory) file))))) (xetla-file-revert absolute))) ;; -------------------------------------- ;; xetla-changelog-mode ;; -------------------------------------- (define-derived-mode xetla-changelog-mode change-log-mode "xetla-changelog" (set (make-local-variable 'font-lock-defaults) (list 'xetla-changelog-font-lock-keywords t nil nil 'backward-paragraph)) (font-lock-mode) (use-local-map xetla-changelog-mode-map) (toggle-read-only 1) (set-buffer-modified-p nil)) ;; -------------------------------------- ;; xetla-inventory-file-mode ;; -------------------------------------- ;;;###autoload (defun xetla-inventory-file-mode () "Major mode to edit xetla inventory files (=tagging-method, .arch-inventory)." (interactive) (kill-all-local-variables) (set (make-local-variable 'font-lock-defaults) '(xetla-inventory-file-font-lock-keywords t)) (set (make-local-variable 'comment-start) "# ") (setq major-mode 'xetla-inventory-file-mode mode-name "xetla-inventory-file") (run-hooks 'xetla-inventory-file-mode-hook)) (defun xetla-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 xetla-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 xetla-inventory-file-add-file (category file) "Added FILE to CATEGORY." (unless (xetla-inventory-file-jump-from-tail category) (goto-char (point-min))) (save-excursion (open-line 1)) ;; TODO regexp quote FILE (insert (format "%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 xetla-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)))) (eval-when-compile (defvar vc-ignore-vc-files)) ;;;###autoload (defun xetla-find-file-hook () "Hook executed when opening a file. Follow symlinked files/directories to the actual location of a file. Enter smerge mode if the file has conflicts (detected by the presence of a .rej file)." (when (xetla-file-has-conflict-p (buffer-file-name)) (xetla-funcall-if-exists smerge-mode 1)) (let (link file result) (when (and (not vc-ignore-vc-files) xetla-follow-symlinks (setq file buffer-file-name) (not (string= (setq link (file-truename file)) file))) (setq file link result (cond ((equal xetla-follow-symlinks 'tree) (xetla-tree-root file t)) ((equal xetla-follow-symlinks 'id) (= 0 (xetla-run-tla-sync (list "id" file) :finished 'xetla-status-handler :error 'xetla-status-handler))))) (if result (cond ((eq xetla-follow-symlinks-mode 'warn) (message "Warning: symbolic link to arch-controlled source file: %s" file)) ((or (eq xetla-follow-symlinks-mode 'follow) (find-buffer-visiting file)) (xetla-follow-link) (message "Followed link to arch-controlled %s" buffer-file-name)) ((eq xetla-follow-symlinks-mode 'ask) (if (y-or-n-p "Follow symbolic link to arch-controlled source file? ") (progn (xetla-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 xetla-follow-symlinks-mode=%s" xetla-follow-symlinks-mode))) )))) ;; -------------------------------------- ;; Misc functions ;; -------------------------------------- (defvar xetla-insert-arch-tag-functions '((autoconf-mode . xetla-insert-arch-tag-for-autoconf-mode) (makefile-mode . xetla-insert-arch-tag-for-makefile-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 xetla-arch-tag-string (concat "arch-ta" "g: ") "To avoid having the string a-r-c-h-t-a-g: in this buffer ;-).") (defun xetla-tag-uuid () "Candidate for `xetla-tag-function'. Returns a unique string using uuidgen" (xetla-strip-final-newline (shell-command-to-string "uuidgen"))) (defun xetla-tag-name-date-filename () "Candidate for `xetla-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 `xetla-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 xetla-tag-string () "Return a suitable string for an arch-tag. Actually calls `xetla-tag-function', which defaults to `xetla-tag-uuid' to generate string (and possibly add a comment-end after). Interactively, you should call `xetla-tag-insert', but this function can be usefull to write template files." (funcall xetla-tag-function)) ;;;###autoload (defun xetla-tag-insert () "Insert a unique arch-tag in the current file. Actually calls `xetla-tag-function', which defaults to `xetla-tag-uuid' to generate string (and possibly add a comment-end after)" (interactive) (let ((the-tag-itself (xetla-tag-string)) (in-comment-p (nth 4 (parse-partial-sexp (point) (point-min)))) (header "") (footer "") (handler (assoc major-mode xetla-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 xetla-arch-tag-string the-tag-itself footer))))) ;;;###autoload (defun xetla-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 xetla-arch-tag-string nil t) (error "No arch tag in this buffer")) (delete-region (point) (progn (end-of-line) (point))) (insert (funcall xetla-tag-function)) (if (search-forward xetla-arch-tag-string nil t) (point) nil)))) (when second-tag (goto-char second-tag) (beginning-of-line) (error "Multiple tag in this buffer")))) (defun xetla-regenerate-id-for-file (file) "Create a new id for the file FILE. Does roughly $ xetla delete file $ xetla 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") (if (file-directory-p file) (progn (delete-file (concat (file-name-as-directory file) ".arch-ids/=id")) (xetla-add nil file)) (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) (xetla-add nil file)) (with-current-buffer (find-file-noselect file) (let ((modif (buffer-modified-p))) (xetla-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 xetla-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 " " xetla-arch-tag-string uuid footer)))) (defun xetla-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 ((xetla-insert-arch-tag-functions (assq-delete-all 'makefile-mode (copy-sequence xetla-insert-arch-tag-functions))) (comment-start (if (and (buffer-file-name) (string-match "Makefile.am$" (buffer-file-name))) "##" comment-start))) (xetla-tag-insert))) ;;;###autoload (defun xetla-ediff-add-log-entry () "Add a log entry." (interactive) (pop-to-buffer ediff-buffer-A) (xetla-add-log-entry)) ;; ;; Tree-lint mode ;; (defvar xetla-tree-lint-cookie nil "Ewoc cookie used in tree-lint mode.") (define-derived-mode xetla-tree-lint-mode fundamental-mode "xetla-tree-lint" "Major mode to view tree-lint warnings. Commands: \\{xetla-tree-lint-mode-map} " (let ((inhibit-read-only t)) (erase-buffer)) (set (make-local-variable 'xetla-buffer-refresh-function) `(lambda () (interactive) (xetla-tree-lint ,default-directory))) (set (make-local-variable 'xetla-tree-lint-cookie) (ewoc-create 'xetla-tree-lint-printer)) (set (make-local-variable 'xetla-get-file-info-at-point-function) 'xetla-tree-lint-get-file-at-point) (set (make-local-variable 'xetla-buffer-marked-file-list) nil) (set (make-local-variable 'xetla-generic-select-files-function) 'xetla-tree-lint-select-files) (toggle-read-only t)) (defun xetla-tree-lint-get-file-at-point () "Find file at point in *xetla-tree-lint*. Error when not on a file." (let ((data (ewoc-data (ewoc-locate xetla-tree-lint-cookie)))) (if (eq (car data) 'message) nil (cadr data)))) (defun xetla-tree-lint-prepare-buffer (root) "Prepare the buffer to display the tree-lint warnings for tree ROOT." (let ((buffer (xetla-get-buffer-create 'tree-lint root))) (with-current-buffer buffer (xetla-tree-lint-mode) (ewoc-enter-last xetla-tree-lint-cookie (list 'message (format "Running tree-lint in %s ..." root))) buffer))) ;;;###autoload (defun xetla-tree-lint (root) "Run tla tree-lint in directory ROOT." (interactive (list (xetla-read-project-tree-maybe "Run tla tree-lint in: "))) (let ((default-directory root) (buffer (xetla-tree-lint-prepare-buffer root))) (when xetla-switch-to-buffer-first (xetla-switch-to-buffer buffer)) (xetla-run-tla-async '("tree-lint") :related-buffer buffer :finished `(lambda (output error status arguments) (if (> (buffer-size output) 0) (progn (save-excursion (xetla-tree-lint-parse-buffer output ,buffer)) (with-current-buffer ,buffer (xetla-tree-lint-cursor-goto (ewoc-nth xetla-tree-lint-cookie 0)))) (message "No tree-lint warnings for %s." ,default-directory) (with-current-buffer ,buffer (let ((inhibit-read-only t)) (erase-buffer) (ewoc-enter-last xetla-tree-lint-cookie (list 'message (format "No tree-lint warnings for %s." ,default-directory))))))) :error `(lambda (output error status arguments) (save-excursion (xetla-tree-lint-parse-buffer output ,buffer)) (with-current-buffer ,buffer (xetla-tree-lint-cursor-goto (ewoc-nth xetla-tree-lint-cookie 0))))))) (defconst xetla-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 xetla-tree-lint-message-type (message) "Return a symbol saying which type of message the string MESSAGE is." (let ((result nil) (iterator xetla-tree-lint-message-alist)) (while (and iterator (not result)) (when (string-match (caar iterator) message) (setq result (cadar iterator))) (setq iterator (cdr iterator))) (or result 'unknown))) (defun xetla-tree-lint-parse-buffer (buffer output-buffer) "Parse the output of xetla 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 (xetla-face-add (format "Tree lint warnings in %s\n" default-directory) 'xetla-messages))) (setq xetla-tree-lint-cookie (ewoc-create 'xetla-tree-lint-printer))) (with-current-buffer buffer (goto-char (point-min)) (let ((cookie (with-current-buffer output-buffer xetla-tree-lint-cookie))) (while (re-search-forward "^." nil t) (goto-char (point-at-bol)) (let* ((message (buffer-substring-no-properties (point) (point-at-eol))) (type (xetla-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 (xetla-unescape file) id t nil)) (forward-line 1) (while (not (eq (char-after) ?\n)) (let ((file (buffer-substring-no-properties (point) (point-at-eol)))) (forward-line 1) (ewoc-enter-last cookie (list 'duplicate-id (xetla-unescape file) id nil (eq (char-after) ?\n))))) (forward-line 1) ))) (while (not (eq (char-after) ?\n)) (ewoc-enter-last cookie (list type (xetla-unescape (buffer-substring-no-properties (point) (point-at-eol))))) (forward-line 1))))) (let ((inhibit-read-only t)) (ewoc-refresh cookie))))) (defvar xetla-tree-lint-printer-first-duplicate nil "Internal variable. non-nil when the ewoc printer is printing the first group of duplicate ID's") (defun xetla-tree-lint-printer (elem) "Ewoc printer for the tree-lint buffer. Displays ELEM." (when (not (eq (car elem) 'message)) (insert (if (member (cadr elem) xetla-buffer-marked-file-list) (concat " " xetla-mark " ") " "))) (case (car elem) (message (insert "\n" (xetla-face-add (cadr elem) 'xetla-messages) "\n") (setq xetla-tree-lint-printer-first-duplicate t)) (missing-file (insert (xetla-face-add (cadr elem) 'xetla-to-add 'xetla-tree-lint-file-map xetla-tree-lint-file-menu))) (id-without-file (insert (xetla-face-add (cadr elem) 'xetla-to-add 'xetla-tree-lint-file-map xetla-tree-lint-file-menu))) (unrecognized (insert (xetla-face-add (cadr elem) 'xetla-unrecognized 'xetla-tree-lint-file-map xetla-tree-lint-file-menu))) (broken-link (insert (xetla-face-add (cadr elem) 'xetla-broken-link 'xetla-tree-lint-file-map xetla-tree-lint-file-menu))) (unknown (insert (xetla-face-add (cadr elem) 'xetla-unrecognized 'xetla-tree-lint-file-map xetla-tree-lint-file-menu))) (duplicate-id (insert (xetla-face-add (cadr elem) 'xetla-duplicate 'xetla-tree-lint-file-map xetla-tree-lint-file-menu)) (when (nth 3 elem) (insert "\t" (xetla-face-add (caddr elem) 'xetla-id))) (when (nth 4 elem) (insert "\n"))) (t (error "Unimplemented type of tree-lint error"))) ) (defun xetla-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 xetla-tree-lint-next () "Move to the next tree lint item." (interactive) (let* ((cookie xetla-tree-lint-cookie) (elem (ewoc-locate cookie)) (next (or (ewoc-next cookie elem) elem))) (xetla-tree-lint-cursor-goto next))) (defun xetla-tree-lint-previous () "Move to the previous tree lint item." (interactive) (let* ((cookie xetla-tree-lint-cookie) (elem (ewoc-locate cookie)) (previous (or (ewoc-prev cookie elem) elem))) (xetla-tree-lint-cursor-goto previous))) (defun xetla-tree-lint-mark-file () "Mark the current tree-lint file." (interactive) (let ((current (ewoc-locate xetla-tree-lint-cookie)) (files (xetla-tree-lint-select-files nil nil nil nil nil t t))) (when files (dolist (file files) (add-to-list 'xetla-buffer-marked-file-list file)) (ewoc-refresh xetla-tree-lint-cookie)) (xetla-tree-lint-cursor-goto (if (eq (car (ewoc-data current)) 'message) current (ewoc-next xetla-tree-lint-cookie current))))) (defun xetla-tree-lint-unmark-file () "Unmark the current tree-lint file." (interactive) (let ((current (ewoc-locate xetla-tree-lint-cookie)) (files (xetla-tree-lint-select-files nil nil nil nil nil t t))) (when files (dolist (file files) (setq xetla-buffer-marked-file-list (delete file xetla-buffer-marked-file-list))) (ewoc-refresh xetla-tree-lint-cookie)) (xetla-tree-lint-cursor-goto (if (eq (car (ewoc-data current)) 'message) current (ewoc-next xetla-tree-lint-cookie current))))) (defun xetla-tree-lint-unmark-all () "Unmark all tree-lint files." (interactive) (let ((current (ewoc-locate xetla-tree-lint-cookie))) (setq xetla-buffer-marked-file-list nil) (ewoc-refresh xetla-tree-lint-cookie) (xetla-tree-lint-cursor-goto current))) (defun xetla-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. `xetla-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 xetla-buffer-marked-file-list (not ignore-marked) (not (xetla-mouse-event-p last-input-event))) (let ((list xetla-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 xetla-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 xetla-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 xetla-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 xetla-tree-lint-add-files (files) "Prompts and add FILES. If on a message field, add all the files below this message." (interactive (list (xetla-tree-lint-select-files "Add %s? " "Add %s files? " "Not adding any file" "Add file: "))) (apply 'xetla-add nil files) (xetla-tree-lint default-directory)) (defun xetla-tree-lint-delete-files (files) "Prompts and delete FILES. If on a message field, delete all the files below this message." (interactive (list (xetla-tree-lint-select-files "Delete %s? " "Delete %s files? " "Not deleting any file" "Delete file: " nil nil nil 'yes-or-no-p))) (mapcar 'delete-file files) (xetla-tree-lint default-directory)) (defun xetla-tree-lint-regenerate-id (files) "Prompts and regenerate an ID (either explicit or tagline) for FILES." (interactive (list (xetla-tree-lint-select-files "Regenerate ID for %s? " "Regenerate ID for %s files? " "Not regenerating ID for any file" "Regenerate ID for file: " t))) (mapcar 'xetla-regenerate-id-for-file files) (xetla-tree-lint default-directory)) (defun xetla-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 (xetla-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))) (xetla-generic-file-prefix files ",,")) (defun xetla-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 (xetla-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))) (xetla-generic-file-prefix files "++")) (defun xetla-generic-file-prefix (files prefix) "Rename FILES with adding prefix PREFIX. Visited buffer associations also updated." (mapcar (lambda (from) (let* ((buf (find-buffer-visiting from)) (to (concat (file-name-directory from) prefix (file-name-nondirectory from)))) (rename-file from to) (when buf (with-current-buffer buf (rename-buffer to) (set-visited-file-name to))))) files) (xetla-generic-refresh)) ;; end tree-lint-mode (defvar xetla-arch-version nil "Version of xetla version.") (defun xetla-arch-version () "Return the TLA (arch) version." (interactive) (setq xetla-arch-version (xetla-run-tla-sync '("-V") :finished (lambda (output error status arguments) (xetla-buffer-content output)))) (if (interactive-p) (message xetla-arch-version)) xetla-arch-version) ;;;###autoload (defun xetla-version () "Return the XEtla version." (interactive) (let ((version (or (when (locate-library "xetla-version") (load-library "xetla-version") (when (boundp 'xetla-version) xetla-version)) (let ((default-directory (file-name-directory (locate-library "xetla")))) (defvar xetla-version nil "Version of xetla") (xetla-run-tla-sync '("logs" "-f" "-r") :finished (lambda (output error status arguments) (set-buffer output) (goto-char (point-min)) (setq xetla-version (buffer-substring-no-properties (point) (point-at-eol)))) :error (lambda (output error status arguments) (setq xetla-version "unknown"))))))) (if (not version) (progn (message "We did not find xetla-version.el nor the arch-tree containing xetla.el!") (sit-for 2) (message "Are you using a developer version of XEtla?") (sit-for 2)) (if (interactive-p) (message xetla-version)) xetla-version))) ;;;###autoload (defun xetla-prepare-patch-submission (xetla-tree-root tarball-base-name email version-string &optional description subject) "Submit a patch to a xetla working copy (at XETLA-TREE-ROOT) via email. With this feature it is not necessary to tag an xetla 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 xetla 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: `xetla-submit-patch'." (interactive) ;; create the patch (let* ((default-directory xetla-tree-root) (tarball-full-base-name (concat default-directory tarball-base-name)) (tarball-full-name (concat tarball-full-base-name ".tar.gz"))) (xetla-changes-save-as-tgz tarball-full-base-name) (require 'reporter) (delete-other-windows) (reporter-submit-bug-report email nil nil nil nil description) (insert "[VERSION] " version-string) (goto-char (point-max)) (mml-attach-file tarball-full-name "application/octet-stream") (xetla-show-changeset-from-tgz tarball-full-name) (other-window 1) (goto-char (point-min)) (mail-position-on-field "Subject") (insert (or subject "[PATCH] ")))) (defvar xetla-package-root-directory nil) (defun xetla-submit-patch () "Submit a patch to the XEtla devel list. With this feature it is not necessary to tag an xetla.el archive. You simply edit your checked out copy from xetla.el and call this function. The function will create a patch as *.tar.gz file and send it to the xetla-el-dev list." (interactive) (xetla-version) (xetla-arch-version) (xetla-prepare-patch-submission (xetla-tree-root (file-name-directory (or xetla-package-root-directory (locate-library "xetla")))) (concat ",,xetla-patch-" (format-time-string "%Y-%m-%d_%H-%M-%S" (current-time))) &quot;xetla-devel(a)youngs.au.com&quot; xetla-version (concat "Please change the Subject header to a concise description of your patch.\n" "Please describe your patch between the LOG-START and LOG-END markers:\n" "<<LOG-START>>\n" "\n" "<<LOG-END>>\n" "\n" ))) ;; Integration into gnus (defvar gnus-summary-xetla-submap nil "Key mapping added to gnus summary.") (eval-when-compile (defvar gnus-summary-mode-map)) (defun xetla-insinuate-gnus () "Integrate xetla to gnus. The following keybindings are installed for gnus-summary: K t v `xetla-gnus-article-view-patch' K t a `xetla-gnus-article-apply-patch' K t l `xetla-gnus-article-extract-log-message'" (interactive) (setq gnus-summary-xetla-submap (make-sparse-keymap)) (define-key gnus-summary-xetla-submap [?v] 'xetla-gnus-article-view-patch) (define-key gnus-summary-xetla-submap [?a] 'xetla-gnus-article-apply-patch) (define-key gnus-summary-xetla-submap [?l] 'xetla-gnus-article-extract-log-message) (define-key gnus-summary-mode-map [?K ?t] gnus-summary-xetla-submap)) (defun xetla-gnus-article-view-patch (n) "View MIME part N, as xetla patchset. Note, N is forced to 2 at the moment!" (interactive "p") (setq n 2) (gnus-article-part-wrapper n 'xetla-gnus-view-patch)) (defun xetla-gnus-view-patch (handle) "View a patch within gnus. HANDLE should be the handle of the part." (let ((archive-name (xetla-make-temp-name "gnus-patch-tgz"))) (mm-save-part-to-file handle archive-name) (gnus-summary-select-article-buffer) (split-window-vertically) (xetla-show-changeset-from-tgz archive-name) (delete-file archive-name))) (defun xetla-gnus-article-apply-patch (n) "Apply MIME part N, as xetla patchset. Note, N is forced to 2 at the moment!" (interactive "p") (setq n 2) (gnus-article-part-wrapper n 'xetla-gnus-apply-patch)) (defun xetla-gnus-apply-patch (handle) "Apply the patch corresponding to HANDLE." (let ((archive-name (xetla-make-temp-name "gnus-patch-tgz")) (tree)) (xetla-gnus-article-extract-log-message) (mm-save-part-to-file handle archive-name) (gnus-summary-select-article-buffer) (split-window-vertically) (xetla-show-changeset-from-tgz archive-name) (setq tree (read-directory-name "Apply to tree: " (xetla-name-match-from-list (when xetla-memorized-version (xetla-name-split xetla-memorized-version)) xetla-apply-patch-mapping))) (xetla-apply-changeset-from-tgz archive-name tree) (delete-file archive-name))) (defun xetla-gnus-article-extract-log-message () "Parse the mail and extract the log information. Save it to `xetla-memorized-log-header', `xetla-memorized-log-message' and `xetla-memorized-version'." (interactive) (gnus-summary-select-article-buffer) (save-excursion (goto-char (point-min)) (let* ((start-pos (search-forward "[PATCH] ")) (end-pos (point-at-eol)) (log-header (buffer-substring-no-properties start-pos end-pos))) (setq xetla-memorized-log-header log-header)) (goto-char (point-min)) (let* ((start-pos (search-forward "[VERSION] " nil t)) (end-pos (point-at-eol)) (version (when start-pos (buffer-substring-no-properties start-pos end-pos)))) (setq xetla-memorized-version (and start-pos version))) (goto-char (point-min)) (let* ((start-pos (+ (search-forward "<<LOG-START>>") 1)) (end-pos (- (progn (search-forward "<LOG-END>>") (point-at-bol)) 1)) (log-message (buffer-substring-no-properties start-pos end-pos))) (setq xetla-memorized-log-message log-message) (message "Extracted the xetla log message from '%s'" xetla-memorized-log-header))) (gnus-article-show-summary)) ;;;###autoload (defun xetla-submit-bug-report () "Submit a bug report, with pertinent information to the XEtla Devel list." (interactive) (require 'reporter) (delete-other-windows) (xetla-version) (xetla-arch-version) (reporter-submit-bug-report &quot;xetla-devel(a)youngs.au.com&quot; (concat "XEtla " xetla-version) (append ;; non user variables '(emacs-version xetla-version xetla-arch-version ) ;; user variables (sort (apropos-internal "^xetla-" '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 'xetla-report-bug 'xetla-submit-bug-report) ;; For people used to Gnus M-x gnus-bug RET (defalias 'xetla-bug 'xetla-submit-bug-report) ;; (reporting bugs should be easy ;-) (provide 'xetla) ;;; xetla.el ends here