-;;; xetla.el --- Arch (tla) interface for XEmacs
-
-;; Copyright (C) 2003-2004 by Stefan Reichoer (GPL)
-;; Copyright (C) 2004 2005 Steve Youngs (BSD)
-
-;; Author: Steve Youngs <steve@eicq.org>
-;; Maintainer: Steve Youngs <steve@eicq.org>
-;; Created: 2004-11-25
-;; Keywords: arch archive tla
-
-;; Based on xtla.el by: Stefan Reichoer, <stefan@xsteve.at>
-
-;; 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@imag.fr>
-;; Masatake YAMATO <jet@gyve.org>
-;; Milan Zamazal <pdm@zamazal.org>
-;; Martin Pool <mbp@sourcefrog.net>
-;; Robert Widhopf-Fenk <hack@robf.de>
-;; Mark Triggs <mst@dishevelled.net>
-
-
-;; 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:
-
-;;; XEtla/Xtla safety code
-;; You can run into some problems if you have both XEtla and Xtla
-;; installed at the same time. The following attempts to guard
-;; against it by warning the user and giving them a couple of
-;; functions for disabling one of XEtla or Xtla in their current
-;; session. Dangerous stuff!!
-(defvar xetla-dont-warn-about-xtla nil)
-
-(when (and (featurep 'xtla)
- (not xetla-dont-warn-about-xtla))
- (xetla-warn-about-xtla))
-
-(defconst xetla-warn-about-xtla-text
- "We have detected that you have both XEtla and Xtla installed.
-
-This is never a very good idea (unless you _really_ know what you are
-doing) because both packages share similar key bindings and install
-similar hooks.
-
-Our suggestion is that you remove either XEtla or Xtla and just use the
-other. For your convenience there is `xetla-attempt-xetla-removal' and
-`xetla-attempt-xtla-removal', which will attempt to disable one of the
-packages for the current session only.
-
-Use those functions at your own risk. The best answer is to not load
-one of XEtla or Xtla in the first place.
-
-To disable this warning: (setq xetla-dont-warn-about-xtla t).")
-
-(defun xetla-warn-about-xtla ()
- "Pop up a big fat warning about trying to use XEtla and xtla together."
- (get-buffer-create "*XEtla/Xtla Warning*")
- (with-current-buffer "*XEtla/Xtla Warning*"
- (erase-buffer)
- (insert xetla-warn-about-xtla-text))
- (pop-to-buffer "*XEtla/Xtla Warning*"))
-
-(defun xetla-attempt-xetla-removal ()
- "Attempt to disable xetla.
-
-**** This is dangerous, use at your own risk. ****
-
-This function attempts to unload all the XEtla features, remove the
-`xetla-find-file-hook', remove entries from `auto-mode-alist', and
-finally, remove the XEtla lisp directory from the `load-path'. After
-all of this has happened, Xtla should run without problems. Please
-note that we do _NOT_ guarantee that this will work perfectly and you
-really should physically remove either XEtla or Xtla.
-
-Use of this function is only valid in the current session, in other
-words, it ain't saved."
- (interactive)
- ;; unload the features
- (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))
- ;; remove the hooks
- (remove-hook 'find-file-hooks 'xetla-find-file-hook)
- ;; clean out auto-mode-alist
- (setq auto-mode-alist
- (delete '("\\+\\+log\\." . xetla-log-edit-mode) auto-mode-alist))
- (setq auto-mode-alist
- (delete '("/\\(=tagging-method\\|\\.arch-inventory\\)$" . xetla-inventory-file-mode)
- auto-mode-alist))
- ;; clean out the load-path
- (setq load-path
- (remove (file-name-directory (locate-library "xetla")) load-path))
- ;; did I miss anything?
- ;; what can we do about key bindings?
-
- (message "To ensure correct key bindings, please reload Xtla"))
-
-(defun xetla-attempt-xtla-removal ()
- "Attempt to disable Xtla.
-
-**** This is dangerous, use at your own risk. ****
-
-This function attempts to unload all the Xtla features, remove the
-`tla-find-file-hook', remove entries from `auto-mode-alist', and
-finally, remove the XEtla lisp directory from the `load-path'. After
-all of this has happened, XEtla should run without problems. Please
-note that we do _NOT_ guarantee that this will work perfectly and you
-really should physically remove either XEtla or Xtla.
-
-Use of this function is only valid in the current session, in other
-words, it ain't saved."
- (interactive)
- ;; unload the features
- (when (featurep 'xtla-tips) (unload-feature 'xtla-tips t))
- (when (featurep 'xtla-browse) (unload-feature 'xtla-browse t))
- (when (featurep 'xtla) (unload-feature 'xtla t))
- (when (featurep 'xtla-core) (unload-feature 'xtla-core t))
- (when (featurep 'xtla-defs) (unload-feature 'xtla-defs t))
- (when (featurep 'xtla-emacs) (unload-feature 'xtla-emacs t))
- (when (featurep 'xtla-xemacs) (unload-feature 'xtla-xemacs t))
- (when (featurep 'xtla-autoloads) (unload-feature 'xtla-autoloads t))
- ;; remove the hooks
- (remove-hook 'find-file-hooks 'tla-find-file-hook)
- ;; clean out auto-mode-alist
- (setq auto-mode-alist
- (delete '("\\+\\+log\\." . tla-log-edit-mode) auto-mode-alist))
- (setq auto-mode-alist
- (delete '("/\\(=tagging-method\\|\\.arch-inventory\\)$" . tla-inventory-file-mode)
- auto-mode-alist))
- ;; clean out the load-path
- (setq load-path
- (remove (file-name-directory (locate-library "xtla")) load-path))
- ;; did I miss anything?
- ;; what can we do about key bindings?
- (message "To ensure correct key bindings, please reload XEtla"))
-
-;;; End XEtls/Xtla safety 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@eicq.org>, "
- "Sebastian Freundt <freundt@math.tu-berlin.de> "
- " --- 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@xsteve.at>, "
-;; "Contributions from: "
-;; "Matthieu Moy <Matthieu.Moy@imag.fr>, "
-;; "Masatake YAMATO <jet@gyve.org>, "
-;; "Milan Zamazal <pdm@zamazal.org>, "
-;; "Martin Pool <mbp@sourcefrog.net>, "
-;; "Robert Widhopf-Fenk <hack@robf.de>, "
-;; "Mark Triggs <mst@dishevelled.net>"))
-;; (xetla-message-with-rolling
-;; (concat "Author: Stefan Reichoer <stefan@xsteve.at>, "
-;; "Contributions from: "
-;; "Matthieu Moy <Matthieu.Moy@imag.fr>, "
-;; "Masatake YAMATO <jet@gyve.org>, "
-;; "Milan Zamazal <pdm@zamazal.org>, "
-;; "Martin Pool <mbp@sourcefrog.net>, "
-;; "Robert Widhopf-Fenk <hack@robf.de>, "
-;; "Mark Triggs <mst@dishevelled.net>"))
-(defvar 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
-\"John.Smith@rt.fm-arch/xetla-revolutionary-1.0\". Completion is
-available with TAB. Only the item being entered is proposed for
-completion, which means that if you're typing the archive name,
-pressing TAB will give you the list of archives. If you started to
-type the category name, you'll get the list of category for this
-archive.
-
-Here's a list of other interesting bindings available in the
-minibuffer:
-
-")
- (let ((interesting (mapcar (lambda (pair) (cdr pair))
- 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
- >>>>>>> MERGE-SOURCE
-
-Priority is given to your file by default. (This means all conflicts
-will be rejected if you do nothing)."
- (interactive (list (find-file (read-file-name "View conflicts in: "))))
- (let ((mine-buffer buffer)
- (his-buffer (get-buffer-create "*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)))
-
-(defcustom xetla-warn-about-conflict-files t
- "*When non-`nil' ask whether to commit if conflict files are present.
-When `nil' commit anyway."
- :group 'xetla)
-
-(defun xetla-commit-find-conflict-files (dir)
- "Searches for conflict files in the current working directory."
- (when (file-readable-p dir)
- (let* ((dirs (directory-files dir t "^[^.]+$" nil 'subdirs))
- (cur (directory-files dir t "\\.rej"))
- (sub (mapcar #'xetla-commit-find-conflict-files dirs)))
- (setq cur (delete nil cur))
- (setq sub (delete nil sub))
- (if sub
- (append cur sub)
- cur))))
-
-(defun xetla-commit-seal (&optional force)
- "Commit a `version-0' revision to seal a repo.
-
-This calls `tla commit --seal'. With optional argument FORCE, don't
-prompt for confirmation."
- (interactive)
- (when (or force
- (y-or-n-p
- (format "Do you really want to seal `%s'? "
- (xetla-tree-version))))
- (if (string-match "--version\\(-\\|fix-\\)+"
- (xetla-get-current-revision default-directory))
- (error "Revision already sealed, use `xetla-commit-fix' instead")
- (xetla-commit
- (lambda (output error status args)
- (xetla-tips-popup-maybe))
- 'seal))))
-
-(defun xetla-commit-fix (&optional force)
- "Commit a `versionfix' revision.
-
-This calls `tla commit --fix'. With optional argument FORCE, don't
-prompt for confirmation."
- (interactive)
- (when (or force
- (y-or-n-p
- (format "Do you really want to versionfix `%s'? "
- (xetla-tree-version))))
- (if (not (string-match "--version\\(-\\|fix-\\)+"
- (xetla-get-current-revision default-directory)))
- (error "Revision not sealed")
- (xetla-commit
- (lambda (output error status args)
- (xetla-tips-popup-maybe))
- 'fix))))
-
-;;;###autoload
-(defun xetla-commit (&optional handler version-flag)
- "Run tla commit.
-
-Optional argument HANDLER is the process handler for the commit
-command.
-
-Optional argument VERSION-FLAG may be one of the symbols
-'seal to commit a sealed version
-'fix to commit a fix version
-If omitted it defaults to a normal commit.
-
-When the commit finishes successful, `tla-commit-done-hook' is called."
- (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"))
- (and xetla-warn-about-conflict-files
- ;; fsck it, actually we dont need all the .rej files (yet), so
- ;; speed up would be to unwind the recursion after the first
- ;; occurrence of a .rej
- (xetla-commit-find-conflict-files ".")
- (or (y-or-n-p
- (concat
- "Commit with unresolved conflicts 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")
- (cons (cond
- ((eq version-flag 'fix) "--fix")
- ((eq version-flag 'seal) "--seal")
- ((eq version-flag nil) nil)
- (t (error "Wrong version flag: %s" version-flag)))
- (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 (&optional version)
- "Run \"tla changelog\".
-
-Display the result in an improved ChangeLog mode.
-With prefix arg, VERSION, display that version's changelog."
- (interactive "p")
- (let ((default-directory (xetla-read-project-tree-maybe))
- (version (when current-prefix-arg
- (xetla-name-construct
- (xetla-name-read "ChangeLog for version: "
- 'prompt 'prompt 'prompt 'prompt)))))
- (xetla-run-tla-sync (list "changelog" version)
- :finished 'xetla-null-handler)
- (xetla-show-last-process-buffer 'changelog 'xetla-changelog-mode)
- (goto-char (point-min))
- (view-mode nil (lambda (&rest args)
- (xetla-buffer-quit)))))
-
-;;;###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))))))
-
-(defun xetla-help-via-keyb ()
- (interactive)
- (let ((ext (extent-string (extent-at (point)))))
- (xetla-help ext)))
-
-(defun xetla-help-via-mouse (event)
- (interactive "e")
- (goto-char (event-point event))
- (let ((ext (extent-string (extent-at (point)))))
- (xetla-help ext)))
-
-(defconst xetla-help-extent-map
- (let* ((map (make-sparse-keymap 'xetla-help-extent-map)))
- (define-key map [button2] 'xetla-help-via-mouse)
- (define-key map [return] 'xetla-help-via-keyb)
- map)
- "A keymap for the extents in output from `tla help'.")
-
-(defun xetla-display-global-help (buffer &rest args)
- (switch-to-buffer buffer)
- (xetla-process-buffer-mode)
- (goto-char (point-min))
- (save-excursion
- (while (re-search-forward "\\(\\w+.*\\) : " nil t)
- (let ((extent (make-extent (match-beginning 1) (match-end 1)))
- (echo "RET or button2 for help on this command."))
- (set-extent-property extent 'face 'widget-button-face)
- (set-extent-property extent 'mouse-face 'highlight)
- (set-extent-property extent 'keymap xetla-help-extent-map)
- (set-extent-property extent 'help-echo echo)
- (set-extent-property extent 'balloon-help echo)
- (set-extent-property extent 'duplicable t)))))
-
-;;;###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)))))))
- (if (string= command "")
- (xetla-run-tla-sync
- '("help")
- :finished 'xetla-display-global-help)
- (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@email.address>"
- (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."
- (interactive (list (xetla-name-construct
- (xetla-name-read "Star merge from (version or revision): "
- 'prompt 'prompt 'prompt 'prompt 'maybe))
- (read-directory-name "In 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 (&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."
- (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)))
-
-(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 "Wrong buffer, run: `%s' and try again"
- (substitute-command-keys "\\[xetla-bookmarks]")))
- (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.
-
-With a prefix arg, prompt for a local tree to use."
- (interactive)
- (let ((x-dired (if (eq xetla-switch-to-buffer-mode 'single-window)
- 'dired
- 'dired-other-window))
- (open (if current-prefix-arg
- (xetla-bookmarks-read-local-tree nil 'ask)
- (xetla-bookmarks-read-local-tree))))
- (funcall x-dired open)))
-
-(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.
-
-With a prefix arg, prompt for the local tree to use."
- (interactive)
- (let ((default-directory (xetla-uniquify-file-name
- (if current-prefix-arg
- (xetla-bookmarks-read-local-tree nil 'ask)
- (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 "Not in bookmarks buffer, run: `%s' and try again"
- (substitute-command-keys "\\[xetla-bookmarks]")))
- (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 (if current-prefix-arg
- (xetla-bookmarks-read-local-tree nil 'ask)
- (xetla-bookmarks-read-local-tree))))
- (xetla-inventory nil
- (unless (eq xetla-switch-to-buffer-mode 'single-window)
- t))))
-
-(defun xetla-bookmarks-changes (arg)
- "Run `xetla-changes' on a local tree.
-
-Prefix argument, ARG, determines whether or not to use a full format or
-summary format and if it should prompt for the local tree to use.
-
- No prefix arg -- full format, default tree.
- One prefix arg -- summary format, default tree.
- Two prefix args -- full format, prompt for tree.
- Three prefix args -- summary format, prompt for tree."
- (interactive "p")
- (let* ((arg (car current-prefix-arg))
- (default-directory (if (or (eq arg 16) (eq arg 64))
- (xetla-bookmarks-read-local-tree nil 'ask)
- (xetla-bookmarks-read-local-tree))))
- (if (or (eq arg 4) (eq arg 64))
- (xetla-changes t)
- (xetla-changes))))
-
-(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)
- (if (eq xetla-switch-to-buffer-mode 'single-window)
- (switch-to-buffer (get-buffer-create "*xetla-bookmarks*"))
- (pop-to-buffer (get-buffer-create "*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.
-
-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@flups.com--public
-foo.bar@flups.com--public-2004
-
-If SIGNED is non-nil, the archive will be created with -signed.
-If LISTING is non-nil, the archive will be created with -listing
- (Usefull for http mirrors)."
- (interactive
- (list (read-string "Archive name: ")
- (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 "xsteve@nit.at-public")
-
-(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-get-current-revision (&optional directory)
- "Return the current revision in DIRECTORY."
- (interactive)
- (let* ((directory (or directory
- (xetla-read-project-tree-maybe
- "Get current revision in: ")))
- (revision (shell-command-to-string
- (concat "tla revisions --full "
- (xetla-tree-version directory)
- "|tail -n1"))))
- (if (interactive-p)
- (message revision)
- revision)))
-
-(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 (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))
- (let* ((arch-ver (or xetla-arch-version-number
- (xetla-arch-version-number)))
- (add-id-string
- (cond ((> 2 (or (cdr-safe (assoc 'minor arch-ver)) 0))
- "add")
- (t "add-id"))))
- (if id
- (xetla-run-tla-sync `(,add-id-string "--id" ,id . ,files)
- :finished 'xetla-null-handler)
- (xetla-run-tla-sync `(,add-id-string . ,files)
- :finished 'xetla-null-handler))))
-
-(defalias 'xetla-add 'xetla-add-id)
-
-;;
-;; 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@foo.bar-public/xetla-main-0.1"
- (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-id 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]*: $"
-\0 (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 version-flag)
- "Save the current log edit.
-
-When optional argument COMMIT is non-nil, run `tla commit'.
-
-Optional argument VERSION-FLAG is for specifying either a `seal'
-commit or a `fix' commit. It is a symbol and can be either `seal' or
-`fix'.
-
-Both COMMIT and VERSION-FLAG are really meant for non-interactive
-use. When this function is called interactively the same thing can
-be achieved through prefix arguments...
-
-With a single prefix arg, run `tla commit'.
-With 2 prefix args, run `tla commit --seal'.
-With 3 prefix args, run `tla commit --fix'."
- (interactive "p")
- (save-buffer)
- (let ((log-buffer (current-buffer))
- (commit (car current-prefix-arg))
- (type version-flag)
- (dir default-directory))
- (pop-window-configuration)
- (when (interactive-p)
- (cond ((eq commit 4)
- (setq type nil))
- ((eq commit 16)
- (setq type 'seal))
- ((eq commit 64)
- (setq type 'fix))
- (t
- (setq type nil))))
- (if (not commit)
- (bury-buffer log-buffer)
- (if type
- (funcall (intern (format "xetla-commit-%s" type)))
- (if (string-match "--version\\(-\\|fix-\\)+"
- (xetla-get-current-revision dir))
- (error "Can't commit to sealed archive without --fix")
- (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@y.z-a, the result is x@y.z.
-If SHORTER is non-nil, the result is x."
- (if (string-match "\\(\\(.+\\)@.+\\)--.+" archive)
- (if shorter
- (match-string 2 archive)
- (match-string 1 archive))))
-
-(defun 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))))
-
-
-(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-id 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-id 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-id 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 the underlying tla binary.")
-
-(defvar xetla-arch-version-number nil
- "Version _number_ of the underlying tla binary.
-It is stored in an alist in the form
-\(\(major . <major>\)
- \(minor . <minor>\)
- \(minor-minor . <minor-minor>\)
- \(fix . <fix>\)\)")
-
-(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)
-
-(defun xetla-arch-version-number ()
- "Return the TLA (arch) version number.
-This is extremely mandatory since tla 1.3 parameters differ from
-those used in tla 1.2 for example."
- (interactive)
- (unless xetla-arch-version
- (xetla-arch-version))
- (setq xetla-arch-version-number
- (when (string-match
- (concat "([^0-9]+"
- "\\([0-9]\\)"
- "\\.\\([0-9]\\)"
- "\\.?\\([0-9]\\)?"
- ".*\\(?:fix-?\\)?\\([0-9]\\)?.*)")
- xetla-arch-version)
- (mapcar* #'cons
- '(major minor minor-minor fix)
- (mapcar #'string-to-number
- (list (match-string 1 xetla-arch-version)
- (match-string 2 xetla-arch-version)
- (or (match-string 3 xetla-arch-version)
- "")
- (or (match-string 4 xetla-arch-version)
- ""))))))
- (if (interactive-p)
- (message "%S" xetla-arch-version-number))
- xetla-arch-version-number)
-
-
-;;;###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)))
- "xetla-devel@youngs.au.com"
- 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
- "xetla-devel@youngs.au.com"
- (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