+++ /dev/null
-;;; xetla-core.el --- Core of xetla
-
-;; Copyright (C) 2003-2004 by Stefan Reichoer (GPL)
-;; Copyright (C) 2004 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-core.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>
-
-
-;; This file provides the low-level functions used by xetla.el
-
-
-;;; Code:
-
-(require 'xetla-defs)
-(require 'ewoc)
-
-;; --------------------------------------
-;; Compatibility stuff
-;; --------------------------------------
-(eval-when-compile
- (require 'cl)
- (autoload 'read-passwd "passwd"))
-
-(require 'pp)
-
-(defvar xetla-buffer-type-alist
- '((changes "*xetla-changes*" root)
- (inventory "*xetla-inventory*" path)
- (missing "*xetla-missing*" single)
- (cat-log "*xetla-cat-log(%s)*" string)
- (file-diff "*xetla-file-diff*" path)
- (changelog "*xetla-changelog*" root)
- (tree-lint "*xetla-tree-lint*" root)
- (logs "*xetla-logs*" root)
- (errors "*xetla-error*" multiple)
- (generic "*xetla-process*" multiple)
- (browse "*xetla-browse*" single)
- (changeset "*xetla-changeset(%s)*" string))
- "List of (type name mode) used to generate a name for a buffer.
-
-TYPE is the type of buffer to create, passed as the first argument to
-`xetla-get-buffer-create'.
-
-NAME is a string, used as a name for the returned buffer.
-
-MODE is a symbol defining the way to manage (value of
-`default-directory' in the created buffer) paths for this type of
-buffers. It can have the following values:
-
- * 'root: `default-directory' will be the tree-root of the specified
- directory.
-
- * 'path: `default-directory' will be the path specified.
-
-For 'root and 'path, `xetla-get-buffer-create' will return the existing
-buffer for this type and this path if it exists, or create a new one
-otherwise.
-
- * 'single: There is only one buffer of this type for each Emacs
- instance. If a path is provided, `default-directory' is set to that
- path. Otherwise, the path is left unchanged when a buffer is
- reused, and set to the current directory on buffer creation.
-
- * 'multiple: `default-directory' is set to the path specified. A new
- buffer is returned anyway. (No buffer reuse).
-
- * 'string: The path specified is actually a string. It won't be used
- to set `default-directory'. The name of the created buffer will be
- (format name string).")
-
-(defvar xetla-buffers-tree nil
- "Tree containing all xetla buffers.
-
-Must be of the form
- ((type1 (\"path1\" buffer \"original name of buffer\")
- (\"path2\" buffer2 \"original name of buffer2\"))
- (type2 (\"path1\" buffer3 \"original name of buffer3\")
- (\"path3\" buffer4 \"original name of buffer4\")))
-Used to keep track of all the xetla related buffers.")
-
-(defun xetla-buffers-tree-remove (buffer)
- "Remove BUFFER from the buffers tree."
- (dolist (type-cons xetla-buffers-tree)
- (dolist (path-buffer (cdr type-cons))
- (when (eq (cadr path-buffer) buffer)
- (setcdr type-cons (delete path-buffer (cdr type-cons)))))))
-
-(defun xetla-buffers-tree-add (type path buffer)
- "Add a buffer of TYPE visiting PATH to the buffers tree.
-BUFFER should be the buffer to add."
- (let ((current-assoc (assoc type xetla-buffers-tree)))
- (if current-assoc
- (setcdr current-assoc
- (cons (list path buffer (buffer-name buffer))
- (cdr current-assoc)))
- (setq xetla-buffers-tree
- (cons `(,type (,path ,buffer ,(buffer-name buffer))) xetla-buffers-tree)))))
-
-(defvar xetla-temp-directory (temp-directory)
- "Temporary directory for some xetla operations.")
-
-(defun xetla-make-temp-name (file)
- "Generate a temporary file name based on FILE.
-The path for the file name can be set via `xetla-temp-directory'."
- (make-temp-name (concat (xetla-uniquify-file-name xetla-temp-directory) file)))
-
-(defun xetla-uniquify-file-name (path)
- "Return a unique string designating PATH.
-If PATH is a directory,the returned contains one and exactly one trailing
-slash. If PATH is nil, then nil is returned."
- (and path
- (let ((expanded (expand-file-name
- (if (file-directory-p path)
- (file-name-as-directory path)
- path))))
- (if (featurep 'xemacs)
- (replace-regexp-in-string "/+$" "/" expanded)
- expanded))))
-
-(defun xetla-config-file-full-path (file &optional create-config-dir)
- "Return the full path for the config file FILE.
-FILE will be stored in the `xetla-config-directory'.
-If CREATE-CONFIG-DIR is non nil, ensure that the `xetla-config-directory'
-does exist."
- (let ((full-name (xetla-uniquify-file-name
- (concat xetla-config-directory file))))
- (unless (file-exists-p xetla-config-directory)
- (when create-config-dir
- (make-directory xetla-config-directory t)
- (message "The config files of Xetla will be stored in %s!"
- xetla-config-directory)
- (sit-for 5)))
- ;; TODO remove migration code as some time in the future
- (unless (file-exists-p (expand-file-name xetla-bookmarks-file-name
- xetla-config-directory))
- (let ((old-ones (list (list (expand-file-name xetla-bookmarks-file-name
- xetla-config-directory)
- "~/.xetla-bookmarks.el"
- "~/.xetla/.xetla-bookmarks.el")))
- o olds n)
- (while old-ones
- (setq olds (car old-ones) old-ones (cdr old-ones))
- (if olds (setq n (car olds) olds (cdr olds)))
- (while olds
- (setq o (expand-file-name (car olds)) olds (cdr olds))
- (if (file-exists-p o)
- (if (yes-or-no-p (format "Migrate %s to %s? " o n))
- (rename-file o n)
- (if (yes-or-no-p (format "Delete %s? " o))
- (delete-file o))))))))
- ;; return full-name
- full-name))
-
-(defun xetla-stringise (uberstring &rest args)
- "Create a string from UBERSTRING.
-I.e. you can pass
-- a string which evals to itself
-- a variable whose value is a string
-- a function which is called and should eval to a string
-- a form which is evaluated and should return a string.
-
-All results are run against `xetla-stringise' again
-until finally a string is produced."
- (cond ((stringp uberstring)
- uberstring)
- ((and (symbolp uberstring)
- (boundp uberstring))
- (xetla-stringise (symbol-value uberstring)))
- ((and (symbolp uberstring)
- (fboundp uberstring))
- (xetla-stringise (apply uberstring args)))
- ((ignore-errors (xetla-stringise (eval uberstring))))
- ((ignore-errors (xetla-stringise (eval (cons 'progn uberstring)))))
- (t nil)))
-
-;; this is useful since i can now have something like:
-;;
-;; (set-alist 'xetla-buffer-type-alist
-;; 'inventory
-;; '((format "*xetla-inventory%s*"
-;; (let ((dir (replace-regexp-in-string
-;; "^.+/\\([^/]+\\).?$"
-;; "\\1"
-;; (expand-file-name path))))
-;; (if dir (format " (%s)" dir)
-;; "")))))
-;;
-;; to always have the path in the buffer name of the inventory
-
-(defun xetla-get-buffer-type (type)
- "Get entry in `xetla-buffer-type-alist' for given TYPE."
- (assoc type xetla-buffer-type-alist))
-
-(defun xetla-get-buffer-name (type)
- "Get name part of `xetla-buffer-type-alist' for given TYPE."
- (let ((name (cadr (xetla-get-buffer-type type))))
- (xetla-stringise name)))
-
-(defun xetla-get-buffer-mode (type)
- "Get name part of `xetla-buffer-type-alist' for given TYPE."
- (let ((mode (caddr (xetla-get-buffer-type type))))
- mode))
-
-(eval-when-compile
- (autoload 'xetla-tree-root "xetla"))
-
-(defun xetla-get-buffer-create (type &optional path)
- "Get a buffer of type TYPE for the path PATH.
-
-Maybe reuse one if it exists, according to the value of
-`xetla-buffer-type-alist' (see its docstring), or, call
-`create-file-buffer' to create the buffer.
-
-See also `xetla-get-buffer'"
- ;; Inspired from `cvs-get-buffer-create'
- (let* ((path (or path default-directory))
- (elem (assoc type xetla-buffer-type-alist))
- (mode (caddr elem)))
- (or (xetla-get-buffer type path mode)
- ;; Buffer couldn't be reused. Create one
- (let ((path (case mode
- (root (xetla-uniquify-file-name
- (xetla-tree-root path)))
- (string path)
- (t (xetla-uniquify-file-name path))))
- (name (xetla-get-buffer-name type)))
- (let ((buffer
- (if (eq mode 'string)
- (get-buffer-create (format name path))
- (let ((default-directory (or path default-directory)))
- (create-file-buffer (or name "*xetla-buffer*"))))))
- (with-current-buffer buffer
- (xetla-buffers-tree-add type path buffer)
- buffer))))))
-
-(add-hook 'kill-buffer-hook 'xetla-kill-buffer-function)
-
-(defun xetla-kill-buffer-function ()
- "Function run when a buffer is killed."
- (xetla-buffers-tree-remove (current-buffer))
- (xetla-kill-process-maybe (current-buffer)))
-
-(defun xetla-get-buffer (type &optional path mode)
- "Get a buffer of type TYPE for the path PATH.
-
-Maybe reuse one if it exists, depending on the value of MODE (see
-`xetla-buffer-type-alist' 's third element), otherwise, return nil. See
-also `xetla-get-buffer-create'."
- (let ((mode (or mode (xetla-get-buffer-mode type)))
- (path (or path default-directory)))
- (if (eq mode 'single)
- ;; nothing to do about PATH. Reuse anyway
- (let* ((list-path (cdr (assoc type xetla-buffers-tree)))
- (first-elem (car list-path)))
- (if list-path
- (if (string= (buffer-name (cadr first-elem))
- (caddr first-elem))
- (cadr first-elem)
- (setcdr (assoc type xetla-buffers-tree) nil)
- nil)
- nil))
- (let ((path (and path
- (case mode
- (root (xetla-uniquify-file-name
- (xetla-tree-root path)))
- (string path)
- (t (xetla-uniquify-file-name path))))))
- (if (eq mode 'multiple)
- ;; no need to search an existing buffer
- nil
- (let* ((list-path (assoc type xetla-buffers-tree))
- (elem (assoc path (cdr list-path)))
- (buffer (cadr elem)))
- (when buffer
- (if (and (buffer-live-p buffer)
- ;; the buffer has not been renamed
- (string= (buffer-name buffer)
- (caddr elem)))
- buffer
- ;; remove the buffer and try again
- (setcdr list-path
- (delq (assoc path (cdr list-path))
- (cdr list-path)))
- (xetla-get-buffer type path mode)))))))))
-
-(defun xetla-add-buffer-type (type name)
- "Define a new TYPE of buffer whose buffer will be named NAME."
- (unless (assoc type xetla-buffer-type-alist)
- (push (list type name) xetla-buffer-type-alist)))
-
-(defun xetla-position (item seq)
- "Position of ITEM in list, or nil if not found.
-Return 0 if ITEM is the first element of SEQ"
- (let ((pos 0)
- (seq-int seq))
- (while (and seq-int
- (not (eq (car seq-int) item)))
- (setq seq-int (cdr seq-int))
- (setq pos (1+ pos)))
- (when seq-int pos)))
-
-
-(defun xetla-last-visited-inventory-buffer ()
- "Return the last visited xetla's inventory buffer."
- (let ((inventories (remove nil (mapcar
- (lambda (elt)
- (when (buffer-live-p (cadr elt))
- elt))
- (cdr (assoc 'inventory xetla-buffers-tree)))))
- (bl (buffer-list)))
- (cadr (car (sort inventories (lambda (a b)
- (let ((aindex (xetla-position (cadr a) bl))
- (bindex (xetla-position (cadr b) bl)))
- (< aindex bindex))))))))
-
-(defun xetla-show-inventory-buffer ()
- "Switch to the last visited inventory buffer."
- (interactive)
- (xetla-switch-to-buffer (xetla-last-visited-inventory-buffer)))
-
-;; --------------------------------------
-;; Process buffers
-;; --------------------------------------
-
-(defcustom xetla-process-buffer " *xetla-process*"
- "*Name of the process buffer."
- :type 'string
- :group 'xetla-internal)
-
-(defcustom xetla-error-buffer " *xetla-errors*"
- "*Name of the buffer to which xetla's stderr is redirected."
- :type 'string
- :group 'xetla-internal)
-
-(defcustom xetla-number-of-dead-process-buffer 20
- "*Number of process buffers to keep after process termination.
-When the number of process buffers exceeds this number, the most ancient
-is killed. This includes both the process buffer and the error
-buffer (to which stderr is redirected).
-
-A nil value here means \"Never kill any process buffer\". Useful for
-debugging, but this will eat the memory of your computer ;-)"
- :type 'integer
- :group 'xetla-internal)
-
-(defcustom xetla-show-internal-buffers-on-menu nil
- "Toggle display of dead process buffers in the buffer menu."
- :type 'boolean
- :group 'xetla-internal)
-
-(defvar xetla-dead-process-buffer-queue nil
- "List of process buffers belonging to terminated processes.
-When the list is greater than `xetla-number-of-dead-process-buffer', the last
-ones are killed.")
-
-(defun xetla-kill-process-buffer (buffer)
- "Don't actually kill BUFFER, but add it to `xetla-dead-process-buffer-queue'.
-It will eventually be killed when the number of buffers in
-`xetla-dead-process-buffer-queue'exceeds `xetla-number-of-dead-process-buffer'."
- (add-to-list 'xetla-dead-process-buffer-queue buffer t)
- (setq xetla-dead-process-buffer-queue
- (remove-if-not #'buffer-live-p xetla-dead-process-buffer-queue))
- (when xetla-number-of-dead-process-buffer
- (while (> (length xetla-dead-process-buffer-queue)
- (max 2 xetla-number-of-dead-process-buffer))
- (let ((currbuf (car xetla-dead-process-buffer-queue)))
- ;; just to be completely certain
- (when (buffer-live-p currbuf)
- (kill-buffer currbuf))
- ;; now remove that killed buffer
- (setq xetla-dead-process-buffer-queue
- (cdr xetla-dead-process-buffer-queue))))))
-
-(defvar xetla-last-process-buffer nil
- "The last created process buffer.")
-
-(defvar xetla-last-error-buffer nil
- "The last created process buffer.")
-
-(defun xetla-new-process-buffer (to-be-deleted)
- "Create a new process buffer.
-If TO-BE-DELETED is non-nil, make this buffer a candidate for eventually
-being deleted."
- (let ((buffer (create-file-buffer xetla-process-buffer)))
- (setq xetla-last-process-buffer buffer)
- (when to-be-deleted (xetla-kill-process-buffer buffer))
- buffer))
-
-(defun xetla-new-error-buffer (to-be-deleted)
- "Create a new error buffer.
-If TO-BE-DELETED is non-nil, make this buffer a candidate for eventually
-being deleted."
- (let ((buffer (create-file-buffer xetla-error-buffer)))
- (setq xetla-last-error-buffer buffer)
- (when to-be-deleted (xetla-kill-process-buffer buffer))
- buffer))
-
-;; --------------------------------------
-;; Process management
-;; --------------------------------------
-
-;; Candidates for process handlers
-(defun xetla-default-error-function (output error status arguments)
- "Default function called when a xetla process ends with a non-zero status.
-OUTPUT is the buffer containing process standard output.
-ERROR is the buffer containing process error output.
-STATUS indicates the return status of the program.
-ARGUMENTS is a list of the arguments that the process was called with."
- (if (> (with-current-buffer error (point-max)) 1)
- (xetla-show-error-buffer error)
- (if (> (with-current-buffer output (point-max)) 1)
- (xetla-show-error-buffer output)
- (error "`tla %s' failed with code %d and no output!"
- (mapconcat 'identity arguments " ")
- status)))
- (error "`tla %s' failed with code %d"
- (mapconcat 'identity arguments " ")
- status))
-
-(defvar xetla-default-killed-function-noerror 0
- "The number of killed processes we will ignore until throwing an error.
-If the value is 0, `xetla-default-killed-function' will throw an error.
-See `xetla-default-killed-function'.")
-
-(defun xetla-default-killed-function (output error status arguments)
- "Default function called when a xetla process is killed.
-OUTPUT is the buffer containing process standard output.
-ERROR is the buffer containing process error output.
-STATUS indicates the return status of the program.
-ARGUMENTS is a list of the arguments that the process was called with."
- (if (> xetla-default-killed-function-noerror 0)
- (setq xetla-default-killed-function-noerror
- (- xetla-default-killed-function-noerror 1))
- (xetla-switch-to-buffer error)
- (error "`tla %s' process killed !"
- (mapconcat 'identity arguments " "))))
-
-(defun xetla-null-handler (output error status arguments)
- "Handle a finished process without doing anything.
-Candidate as an argument for one of the keywords :finished, :error or :killed
-in `xetla-run-tla-sync' or `xetla-run-tla-async'.
-OUTPUT is the buffer containing process standard output.
-ERROR is the buffer containing process error output.
-STATUS indicates the return status of the program.
-ARGUMENTS is a list of the arguments that the process was called with."
- nil)
-
-(defun xetla-status-handler (output error status arguments)
- "Return an integer value that reflects the process status.
-Candidate as an argument for one of the keywords :finished, :error or :killed
-in `xetla-run-tla-sync' or `xetla-run-tla-async'.
-OUTPUT is the buffer containing process standard output.
-ERROR is the buffer containing process error output.
-STATUS indicates the return status of the program.
-ARGUMENTS is a list of the arguments that the process was called with."
- (cond ((numberp status) status)
- ((string-match "^exited abnormally with code \\(.*\\)" status)
- (string-to-int (match-string 1)))
- (t (error status))))
-
-(defun xetla-output-buffer-handler (output error status arguments)
- "Return the output of a finished process, stripping any trailing newline.
-OUTPUT is the buffer containing process standard output.
-ERROR is the buffer containing process error output.
-STATUS indicates the return status of the program.
-ARGUMENTS is a list of the arguments that the process was called with."
- (xetla-buffer-content output))
-
-(defun xetla-output-buffer-split-handler (output error status arguments)
- "Return the output of a finished process as a list of lines.
-OUTPUT is the buffer containing process standard output.
-ERROR is the buffer containing process error output.
-STATUS indicates the return status of the program.
-ARGUMENTS is a list of the arguments that the process was called with."
- (split-string (xetla-buffer-content output) "\n"))
-
-(defun xetla-default-finish-function (output error status arguments)
- "Default function called when a xetla process terminates.
-OUTPUT is the buffer containing process standard output.
-ERROR is the buffer containing process error output.
-STATUS indicates the return status of the program.
-ARGUMENTS is a list of the arguments that the process was called with."
- (with-current-buffer output
- (xetla-process-buffer-mode))
- (xetla-switch-to-buffer output)
- (message "`tla %s' process finished !"
- (mapconcat 'identity arguments " "))
- status)
-
-(defun xetla-finish-function-without-buffer-switch (output error status arguments)
- "Similar to `xetla-default-finish-function' but no buffer switch.
-OUTPUT is the buffer containing process standard output.
-ERROR is the buffer containing process error output.
-STATUS indicates the return status of the program.
-ARGUMENTS is a list of the arguments that the process was called with."
- (message "`tla %s' process finished !"
- (mapconcat 'identity arguments " "))
- status)
-
-(defvar xetla-log-cookie nil)
-
-(defstruct (xetla-event) output-buffer error-buffer related-buffer
- command tree event time)
-
-(defun xetla-strip-final-newline (string)
- "Strip the final newline from STRING if there's one."
- (if (eq (aref string (- (length string) 1)) ?\n)
- (substring string 0 (- (length string) 1))
- string))
-
-(defsubst xetla-log-printer-print-buffer (buffer function)
- "Helper function for `xetla-log-printer'.
-Print a buffer filed for BUFFER during printing a log event.
-The printed name of BUFFER is mouse sensitive. If the user
-clicks it, FUNCTION is invoked."
- (xetla-face-add
- (or (buffer-name buffer)
- (pp-to-string buffer))
- 'xetla-buffer
- (when (buffer-live-p buffer)
- (let ((map (make-sparse-keymap)))
- (define-key map [button2] function)
- map))
- nil
- "Show the buffer"))
-
-(defun xetla-log-printer (elem)
- "XEtla event printer which prints ELEM."
- (let ((event (xetla-event-event elem))
- (p (point)))
- (insert
- "Command: " (xetla-event-command elem)
- "\nDirectory: " (xetla-face-add (xetla-event-tree elem)
- 'xetla-local-directory)
- "\nDate: " (format-time-string "%c" (xetla-event-time elem))
- "\nRelated Buffer: " (xetla-log-printer-print-buffer
- (xetla-event-related-buffer elem)
- 'xetla-switch-to-related-buffer-by-mouse)
- "\nOutput Buffer: " (xetla-log-printer-print-buffer
- (xetla-event-output-buffer elem)
- 'xetla-switch-to-output-buffer-by-mouse)
- "\nError Buffer: " (xetla-log-printer-print-buffer
- (xetla-event-error-buffer elem)
- 'xetla-switch-to-error-buffer-by-mouse)
- (if (not (string= event "started"))
- (concat "\nEvent: " event)
- "")
- "\n")
- ;; Reflect the point to `default-directory'.
- ;; NOTE: XEmacs doesn't have `point-entered' special text property.
- (put-text-property
- p (point)
- 'point-entered (lambda (old new)
- (setq default-directory
- (xetla-event-tree
- (ewoc-data
- (ewoc-locate xetla-log-cookie))))))
- ))
-
-(defvar xetla-process-running nil
- "List of xetla processes running.
-A value of nil indicates no processes are running.
-
-The list is a list of pairs (process event) where EVENT is the event
-corresponding to the beginning of the execution of process. It can be
-used to get more info about the process.")
-
-(defmacro xetla-switch-to-buffer-macro (function accessor)
- "Define a FUNCTION for switching to the buffer associated with some event.
-ACCESSOR is a function for retrieving the appropriate buffer from a
-`xetla-event'structure."
- `(defun ,function ()
- "In a log buffer, pops to the output or error buffer corresponding to the
-process at point"
- (interactive)
- (let ((buffer (,accessor
- (ewoc-data (ewoc-locate xetla-log-cookie)))))
- (cond ((buffer-live-p buffer)
- (xetla-switch-to-buffer buffer)
- (unless (member buffer
- (mapcar (lambda (p)
- (process-buffer (car p)))
- xetla-process-running))
- (xetla-process-buffer-mode)))
- (t (error "Buffer has been killed"))))))
-
-(xetla-switch-to-buffer-macro xetla-switch-to-output-buffer
- xetla-event-output-buffer)
-
-(xetla-switch-to-buffer-macro xetla-switch-to-error-buffer
- xetla-event-error-buffer)
-
-(xetla-switch-to-buffer-macro xetla-switch-to-related-buffer
- xetla-event-related-buffer)
-
-(defmacro xetla-make-bymouse-function (function)
- "Create a new function by adding mouse interface to FUNCTION.
-The new function is named FUNCTION-by-mouse; and takes one argument,
-a mouse click event.
-Thew new function moves the point to the place where mouse is clicked
-then invoke FUNCTION."
- `(defun ,(intern (concat (symbol-name function) "-by-mouse")) (event)
- ,(concat "`" (symbol-name function) "'" " with mouse interface.")
- (interactive "e")
- (mouse-set-point event)
- (,function)))
-
-(xetla-make-bymouse-function xetla-switch-to-output-buffer)
-(xetla-make-bymouse-function xetla-switch-to-error-buffer)
-(xetla-make-bymouse-function xetla-switch-to-related-buffer)
-
-(defun xetla-log-event (output error command tree event)
- "Log an event in the `xetla-log-buffer' buffer.
-OUTPUT is the buffer containing process standard output.
-ERROR is the buffer containing process error output.
-COMMAND is the command that was executed.
-TREE is the process's working directory.
-EVENT is the event that occurred.
-Returns that event."
- (unless (and xetla-log-cookie
- (buffer-live-p (ewoc-buffer xetla-log-cookie)))
- (with-current-buffer (get-buffer-create xetla-log-buffer)
- (setq xetla-log-cookie
- (ewoc-create 'xetla-log-printer))
- (xetla-log-buffer-mode)))
- (let ((related-buffer (current-buffer)))
- (with-current-buffer (ewoc-buffer xetla-log-cookie)
- (let ((elem (make-xetla-event :output-buffer output
- :error-buffer error
- :related-buffer related-buffer
- :command command
- :tree tree
- :event event
- :time (current-time)))
- buffer-read-only)
- (ewoc-enter-last xetla-log-cookie elem)
- (ewoc-refresh xetla-log-cookie)
- elem))))
-
-(defun xetla-log-next ()
- "Move to the next log entry."
- (interactive)
- (let ((next (ewoc-next xetla-log-cookie
- (ewoc-locate xetla-log-cookie))))
- (when next (goto-char (ewoc-location next)))))
-
-(defun xetla-log-prev ()
- "Move to the previous log entry."
- (interactive)
- (let ((prev (ewoc-prev xetla-log-cookie
- (ewoc-locate xetla-log-cookie))))
- (when prev (goto-char (ewoc-location prev)))))
-
-(define-derived-mode xetla-log-buffer-mode fundamental-mode "XEtla Log"
- "Major mode for Xetla's internal log buffer. You can open this buffer
-with `xetla-open-internal-log-buffer'."
- (toggle-read-only 1))
-
-(define-derived-mode xetla-process-buffer-mode fundamental-mode
- "XEtla Process"
- "Major mode for process buffers. Mainly defines \\[bury-buffer]
-to quit the buffer"
- (toggle-read-only 1))
-
-(defmacro xetla-with-keywords (keywords plist &rest body)
- "Execute a body of code with keywords bound.
-Each keyword listed in KEYWORDS is bound to its value from PLIST, then
-BODY is evaluated."
- (flet ((keyword-to-symbol (keyword)
- (intern (substring (symbol-name keyword) 1))))
- (let ((keyword (make-symbol "keyword"))
- (default (make-symbol "default")))
- `(let ,(mapcar (lambda (keyword-entry)
- (keyword-to-symbol (if (consp keyword-entry)
- (car keyword-entry)
- keyword-entry)))
- keywords)
- (dolist (keyword-entry ',keywords)
- (let ((,keyword (if (consp keyword-entry)
- (car keyword-entry)
- keyword-entry))
- (,default (if (consp keyword-entry)
- (cadr keyword-entry)
- nil)))
- (set (intern (substring (symbol-name ,keyword) 1))
- (or (cadr (member ,keyword ,plist))
- ,default))))
- ,@body))))
-(put 'xetla-with-keywords 'lisp-indent-function 1)
-
-(defun xetla-build-xetla-command (list-args)
- "Build a shell command to run tla with args LIST-ARGS."
- (mapconcat 'shell-quote-argument
- (cons xetla-tla-executable
- (delq nil list-args))
- " "))
-
-
-(defcustom xetla-password-prompt-regexp
- "[Pp]ass\\(word\\|phrase\\).*:\\s *\\'"
- "*Regexp matching prompts for passwords in the inferior process.
-This is used by `eshell-watch-for-password-prompt'."
- :type 'regexp
- :group 'xetla)
-
-(defun xetla-process-filter (proc string)
- "Filter PROC's STRING.
-Prompt for password with `read-passwd' if the output of PROC matches
-`xetla-password-prompt-regexp'."
- (with-current-buffer (process-buffer proc)
- (insert (replace-regexp-in-string "\015" "\n" string))
- (when (string-match xetla-password-prompt-regexp string)
- (string-match "^\\([^\n]+\\)\n*\\'" string)
- (let ((passwd (read-passwd (match-string 1 string))))
- (process-send-string proc (concat passwd "\n"))))))
-
-(defun xetla-run-tla-async (arguments &rest keys)
- "Run tla asynchronously.
-ARGUMENTS is a list of arguments. nil values in this list are removed.
-KEYS is a list of keywords and values. Possible keywords are:
-
- :finished ....... Function run when the process finishes. If none
- specified, `xetla-default-finish-function' is run.
-
- :killed ......... Function run when the process is killed. If none
- specified, `xetla-default-killed-function' is run.
-
- :error .......... Function run when the process exits with a non 0
- status. If none specified,
- `xetla-default-error-function' is run.
-
-All these functions take 4 arguments : output, error, status, and
-arguments.
-
- - \"output\" is the output buffer
- - \"error\" is the buffer where standard error is redirected
- - \"status\" is the numeric exit-status or the signal number
- - \"arguments\" is the list of arguments, as a list of strings,
- like '(\"changes\" \"-diffs\")
-
- `xetla-null-handler' can be used here if there's nothing to do.
-
- :output-buffer .. Buffer where the output of the process should be
- redirected. If none specified, a new one is
- created, and will be entered in
- `xetla-dead-process-buffer-queue' to be killed
- later.
-
- :error-buffer ... Buffer where the standard error of the process
- should be redirected.
-
- :related-buffer . Defaults to `current-buffer'. This is the buffer
- where the result of the process will be used. If
- this buffer is killed before the end of the
- execution, the user is prompted if he wants to kill
- the process.
-
-Example:
- (xetla-run-tla-async `(\"changes\" ,(unless arg \"-diffs\"))
- :finished
- (lambda (output error status arguments)
- (message \"No changes in this working copy\"))
- :error
- (lambda (output error status arguments)
- (xetla-show-changes-buffer output)))"
- (xetla-with-keywords
- (:finished :killed :error :output-buffer :error-buffer :related-buffer)
- keys
- (let* ((output-buf (or (and output-buffer (get-buffer-create output-buffer))
- (xetla-new-process-buffer nil)))
- (error-buf (or (and error-buffer (get-buffer-create error-buffer))
- (xetla-new-error-buffer nil)))
- (error-file (xetla-make-temp-name "arch-errors"))
- (command (xetla-build-xetla-command arguments))
- ;; Make the `default-directory' unique. The trailing slash
- ;; may be necessary in some cases.
- (default-directory (xetla-uniquify-file-name default-directory))
- (process (start-process
- xetla-tla-executable output-buf
- "sh" "-c"
- (format "%s 2> %s"
- command error-file)))
- (process-event
- (list process
- (xetla-log-event output-buf
- error-buf
- command
- default-directory "started"))))
- (with-current-buffer (or related-buffer (current-buffer))
- (message "running process `%s' in `%s'" command default-directory)
- (add-to-list 'xetla-process-running process-event)
- (set-process-filter process 'xetla-process-filter)
- (set-process-sentinel
- process
- `(lambda (process event)
- (let ((default-directory ,default-directory))
- (xetla-log-event ,output-buf ,error-buf ,command
- ,default-directory
- (xetla-strip-final-newline event))
- (setq xetla-process-running
- (delq ',process-event xetla-process-running))
- (when (file-exists-p ,error-file)
- (with-current-buffer ,error-buf
- (insert-file-contents ,error-file))
- (delete-file ,error-file))
- (let ((state (process-status process))
- (status (process-exit-status process)))
- (unwind-protect
- (cond ((and (eq state 'exit) (= status 0))
- (funcall (or (quote ,finished)
- 'xetla-default-finish-function)
- ,output-buf ,error-buf
- status (quote ,arguments)))
- ((eq state 'signal)
- (funcall (or (quote ,killed)
- 'xetla-default-killed-function)
- ,output-buf ,error-buf status
- (quote ,arguments)))
- ((eq state 'exit) ;; status != 0
- (funcall (or (quote ,error)
- 'xetla-default-error-function)
- ,output-buf ,error-buf status
- (quote ,arguments)))))
- ;; Schedule any buffers we created for killing
- (unless ,output-buffer (xetla-kill-process-buffer ,output-buf))
- (unless ,error-buffer (xetla-kill-process-buffer ,error-buf))))))
- process))))
-
-(defun xetla-run-tla-sync (arguments &rest keys)
- "Run tla synchronously.
-See `xetla-run-tla-async' for details on possible ARGUMENTS and KEYS."
- (xetla-with-keywords
- (:finished :killed :error :output-buffer :error-buffer :related-buffer)
- keys
- (let ((output-buf (or (and output-buffer (get-buffer-create output-buffer))
- (xetla-new-process-buffer t)))
- (error-buf (or (and error-buffer (get-buffer-create error-buffer))
- (xetla-new-error-buffer t)))
- (command (xetla-build-xetla-command arguments))
- (error-file (xetla-make-temp-name "arch-errors"))
- ;; Make the `default-directory' unique. The trailing slash
- ;; may be necessary in some cases.
- (default-directory (xetla-uniquify-file-name default-directory)))
- (with-current-buffer (or related-buffer (current-buffer))
- (xetla-log-event output-buf error-buf command default-directory "started")
- (let ((status (call-process "sh" nil output-buf nil "-c"
- (format "%s 2> %s"
- command
- error-file))))
- (when (file-exists-p error-file)
- (with-current-buffer error-buf
- (insert-file-contents error-file))
- (delete-file error-file))
- (unwind-protect
- (cond ((stringp status)
- (when (string= status "Terminated")
- (funcall (or killed 'xetla-default-killed-function)
- output-buf error-buf status arguments)))
- ((numberp status)
- (if (zerop status)
- (funcall (or finished 'xetla-default-finish-function)
- output-buf error-buf status arguments)
- (funcall (or error 'xetla-default-error-function)
- output-buf error-buf status arguments)))
- (t (message "Unknown status - %s" status)))
- ;; Schedule any buffers we created for killing
- (unless output-buffer (xetla-kill-process-buffer output-buf))
- (unless error-buffer (xetla-kill-process-buffer error-buf))))))))
-
-(defun xetla-kill-process-maybe (buffer)
- "Prompts and possibly kill process whose related buffer is BUFFER."
- (let ((process-list nil))
- (dolist (process-buffer xetla-process-running)
- (when (eq (xetla-event-related-buffer (cadr process-buffer))
- buffer)
- (add-to-list 'process-list (car process-buffer))))
- (let ((l (length process-list)))
- (when (and process-list
- (y-or-n-p (format "%s process%s running in buffer %s. Kill %s? "
- l (if (> l 1) "es" "")
- (buffer-name buffer)
- (if (> l 1) "Them" "it"))))
- (dolist (process process-list)
- (setq xetla-default-killed-function-noerror
- (1+ xetla-default-killed-function-noerror))
- (if (eq (process-status process) 'run)
- (kill-process process)))))))
-
-;;;###autoload
-(add-to-list 'minor-mode-alist
- '(xetla-process-running
- (:eval (if (equal (length xetla-process-running) 1)
- " tla running"
- (concat " tla running("
- (int-to-string (length xetla-process-running))
- ")")))))
-
-(eval-when-compile
- (autoload 'xetla-flash-line "xetla"))
-
-(defun xetla-open-internal-log-buffer ()
- "Switch to the XEtla's internal log buffer.
-This buffer contains a list of all the tla commands previously executed.
-The buffer uses the mode `xetla-log-buffer-mode'"
- (interactive)
- (let ((buffer-name (buffer-name)))
- (xetla-switch-to-buffer xetla-log-buffer)
- (goto-char (point-max))
- (when (re-search-backward (concat " Buffer: "
- (regexp-quote buffer-name)
- "$")
- nil t)
- (xetla-flash-line))))
-
-(defun xetla-clear-log-buffer ()
- "Kill the log buffer."
- (when (bufferp (get-buffer xetla-log-buffer))
- (kill-buffer xetla-log-buffer)))
-
-(defun xetla-buffer-content (buffer)
- "Return the content of BUFFER as a string.
-Strips the final newline if there is one."
- (with-current-buffer buffer
- (buffer-substring-no-properties
- (point-min)
- (progn (goto-char (point-max))
- (if (eq (char-before) ?\n)
- (- (point) 1)
- (point))))))
-
-(defun xetla-get-process-output ()
- "Return the content of the last process buffer.
-Strips the final newline if there is one."
- (xetla-buffer-content xetla-last-process-buffer))
-
-(defun xetla-get-error-output ()
- "Return the content of the last error buffer.
-Strips the final newline if there is one."
- (xetla-buffer-content xetla-last-error-buffer))
-
-(defvar xetla-switched-buffer nil)
-(defvar xetla-switched-from-buffer nil)
-
-(defun xetla-switch-to-buffer (buffer)
- "Switch to BUFFER using the user's preferred method.
-See `xetla-switch-to-buffer-mode' for possible settings."
- (setq xetla-switched-from-buffer (current-buffer))
- (cond ((eq xetla-switch-to-buffer-mode 'pop-to-buffer)
- (pop-to-buffer buffer))
- ((eq xetla-switch-to-buffer-mode 'single-window)
- (switch-to-buffer buffer))
- ((eq xetla-switch-to-buffer-mode 'show-in-other-window)
- (pop-to-buffer buffer)
- (setq xetla-switched-buffer (current-buffer))
- (pop-to-buffer xetla-switched-from-buffer))
- ;; TODO : dedicated frame.
- (t
- (error "Switch mode %s not implemented" xetla-switch-to-buffer-mode))))
-
-(defun xetla-post-switch-to-buffer ()
- "Executed when showing a changeset.
-
-If `xetla-switched-buffer' is non-nil, show this buffer, but keep
-cursor position in previous buffer."
- (when xetla-switched-buffer
- (pop-to-buffer xetla-switched-buffer)
- (setq xetla-switched-buffer nil)
- (goto-char (point-min))
- (pop-to-buffer xetla-switched-from-buffer)))
-
-
-(defun xetla-show-process-buffer ()
- "Show the process buffer of the last started xetla command."
- (interactive)
- (xetla-switch-to-buffer xetla-last-process-buffer)
- (unless (member xetla-last-process-buffer
- (mapcar (lambda (p)
- (process-buffer (car p)))
- xetla-process-running))
- (xetla-process-buffer-mode)))
-
-(defun xetla-show-last-process-buffer (&optional type mode path)
- "Switch to the last used process buffer in a new buffer of TYPE.
-If MODE is specified, it is a function that will be run in the
-new buffer. Otherwise, the buffer will remain in fundamental mode, in
-read-only.
-
-If PATH is specified, it will be passed to `xetla-get-buffer-create'."
- (when (buffer-live-p xetla-last-process-buffer)
- (let ((content (with-current-buffer xetla-last-process-buffer
- (buffer-string))))
- (xetla-switch-to-buffer (xetla-get-buffer-create
- (or type 'generic) path))
- (let ((inhibit-read-only t))
- (erase-buffer)
- (insert content)))
- (if mode
- (funcall mode)
- (xetla-process-buffer-mode))))
-
-(defun xetla-show-error-buffer (buffer &optional type mode)
- "Pops up the error buffer.
-Works like `xetla-show-last-process-buffer', but displays BUFFER, of type
-'errors if TYPE is not specified.
-If MODE is specified, the buffer will use that mode."
- (when (buffer-live-p buffer)
- (let ((content (with-current-buffer buffer
- (buffer-string))))
- (xetla-switch-to-buffer (xetla-get-buffer-create
- (or type 'errors)))
- (let ((inhibit-read-only t))
- (erase-buffer)
- (insert content)))
- (if mode
- (funcall mode)
- (xetla-process-buffer-mode))))
-
-;; --------------------------------------
-;; Arch name manipulators
-;; ======================
-;;
-;; Normally in XEtla, a name, a revision specifier is represented as a
-;; list like:
-;;
-;; ("archive" "category" "branch" "version" "revision")
-;;
-;; Nil is permitted as the element. However the list length must be 5
-;; like:
-;;
-;; (nil "category" "branch" nil nil)
-;;
-;; In other hand, in tla command, the name must be represented as a
-;; string like:
-;;
-;; "archive/category-branch-version-revision"
-;;
-;; So we have to convert a name in different representation in many
-;; cases.
-;;
-;; * xetla-name-split-* is for converting from a string representation
-;; to a list representation. There are semi-qualified version and
-;; fully-qualified version.
-;;
-;; - semi-qualified: "category-branch-version-revision".
-;; `xetla-name-split-semi-qualified' expects a name string without
-;; archive component. The archive field of returned list is filled
-;; with nil.
-;;
-;; - fully-qualified: "archive/category-branch-version-revision".
-;; `xetla-name-split' expects a name string including archive.
-;;
-;; * xetla-name-construct-* is for converting from a list
-;; representation to a string representation. The functions accept
-;; arguments two ways.
-;;
-;; - normal passing: (xetla-name-construct "archive" "category"...)
-;; - packed passing: (xetla-name-construct '("archive" "category"...))
-;;
-;; There are semi-qualified version and fully-qualified version.
-;; - semi-qualified: `xetla-name-construct-semi-qualified' connects
-;; arguments with "-".
-;; - fully-qualified: `xetla-name-construct" connects the first argument
-;; and the rest with "/". About the rest,
-;; `xetla-name-construct-semi-qualified' is applied.
-;;
-;; * xetla-name-{archive|category|branch|version|revision} is for
-;; extracting a component from a name. The both representations are
-;; acceptable.
-;;
-;; * xetla-name-mask is for replace a component in the name list with nil.
-;;
-;; --------------------------------------
-
-;;
-;; String representation -> List representation
-;;
-(defun xetla-name-split-semi-qualified (name &optional archive)
- "Split \"--\" connected string NAME into 5 elements list.
-The first element is always nil if ARCHIVE is not given.
-If ARCHIVE is given, use it as the first.
-Even if the elements in name are less than 5, the list is filled by nil
-to make the length 5.
-
- ELISP> (xetla-name-split-semi-qualified \"branch--category--version--revision\"
- \"archive\")
- (\"archive\" \"branch\" \"category\" \"version\" \"revision\")
-
- ELISP> (xetla-name-split-semi-qualified
- \"branch--category--version--revision\")
- (nil \"branch\" \"category\" \"version\" \"revision\")
-
- ELISP> (xetla-name-split-semi-qualified \"branch--category--version\")
- (nil \"branch\" \"category\" \"version\" nil)
-
- ELISP> (xetla-name-split-semi-qualified
- \"branch--category--version\" \"archive\")
- (\"archive\" \"branch\" \"category\" \"version\" nil)
-
- ELISP> (xetla-name-split-semi-qualified \"branch--category\" \"archive\")
- (\"archive\" \"branch\" \"category\" nil nil)
-
- ELISP> (xetla-name-split-semi-qualified \"branch--category\"nil)
- (nil \"branch\" \"category\" nil nil)
-
- ELISP> (xetla-name-split-semi-qualified \"branch--category--\" nil)
- (nil \"branch\" \"category\" \"\" nil)"
- (let ((list (xetla-name-split-semi-qualified-internal name)))
- (while (> 4 (length list))
- (setq list (cons nil list)))
- (let ((result (cons archive (nreverse list))))
- (when (xetla-is-version-string (caddr result))
- (setq result (list (car result)
- (cadr result)
- ""
- (caddr result)
- (cadddr result))))
- result)))
-
-(defun xetla-is-version-string (string)
- "Non-nil if STRING is a candidate for a version name.
-That is, if it contains only digits and dots.
-The regexp here is less strict than the one of xetla, but must verify
-\(xetla-is-version-string string) => string can't be a branch name."
- (and string (string-match "^[0-9\.]+$" string)))
-
-(defun xetla-name-split-semi-qualified-internal (name)
- "Helper function for `xetla-name-split-semi-qualified'.
-Splits a semi-qualified NAME."
- (if (string-match "^\\(.+\\)--\\(\\([^-]\\|-[^-]\\)*\\)" name)
- (cons (match-string 2 name)
- (xetla-name-split-semi-qualified-internal
- (match-string 1 name)))
- (cons name nil)))
-
-(defun xetla-name-split (name)
- "Parse a fully qualified revision NAME, but possibly incomplete.
-email@address.com--arch/cat--branch--ver ->
- (\"email@address.com--arch\" \"cat\" \"branch\" \"ver\" nil)
-email@address.com--arch/cat ->
- (\"email@address.com--arch\" \"cat\" nil nil nil)
-email@address.com--arch ->
- (\"email@address.com-arch\" nil nil nil nil)"
- (if (string-match "\\(.*\\)/\\(.*\\)" name)
- (xetla-name-split-semi-qualified (match-string 2 name) (match-string 1 name))
- (if (string= name "")
- (list nil nil nil nil nil)
- (list name nil nil nil nil))))
-
-
-;;
-;; List representation -> string
-;;
-(defun xetla-name-construct-semi-qualified (&rest comp)
- "Concatenate COMP with \"-\".
-This function can accept strings or a list which contains strings.
-
- ELISP> (xetla-name-construct-semi-qualified \"a\" \"b\" \"c\")
- \"a--b--c\"
- ELISP> (xetla-name-construct-semi-qualified (list \"a\" \"b\" \"c\"))
- \"a--b--c\""
- (if (consp (car comp)) (setq comp (car comp)))
- (if (string= (cadr comp) "")
- ;; Unnamed branch.
- (concat (car comp) "--"
- (mapconcat 'identity (remove nil (cddr comp)) "--"))
- (mapconcat 'identity (remove nil comp) "--")))
-
-(defun xetla-name-construct (archive &optional
- category
- branch
- version
- revision)
- "Create the revision name ARCHIVE/CATEGORY-BRANCH-VERSION-REVISION.
-The arguments may be nil. If ARCHIVE is a revision name list like
- (archive category branch version revision), the list element is mapped
-to arguments before creating the fully qualified revision name.
-
-If the branch name is the empty string and the version is defined,
-then, we have an unnamed branch. The full name is
-archive/category-version."
- (when (consp archive)
- (setq category (xetla-name-category archive)
- branch (xetla-name-branch archive)
- version (xetla-name-version archive)
- revision (xetla-name-revision archive)
- ;; archive must be last
- archive (xetla-name-archive archive)))
- (let ((semi (xetla-name-construct-semi-qualified
- category branch version revision)))
- (concat
- (and archive (not (string= archive ""))
- (concat archive (when category "/")))
- semi)))
-
-;;
-;; Get a component from a list or string.
-;;
-(defun xetla-name-archive (target)
- "Get archive component from TARGET.
-Both representation of TARGET, a string and a list is acceptable."
- (when (stringp target)
- (setq target (xetla-name-split target)))
- (car target))
-
-(defun xetla-name-category (target)
- "Get category component from TARGET.
-Both representation of TARGET, a string and a list is acceptable."
- (when (stringp target)
- (setq target (xetla-name-split target)))
- (cadr target))
-
-(defun xetla-name-branch (target)
- "Get branch component from a TARGET.
-Both representation of TARGET, a string and a list is acceptable."
- (when (stringp target)
- (setq target (xetla-name-split target)))
- (caddr target))
-
-(defun xetla-name-version (target)
- "Get version component from TARGET.
-Both representation of TARGET, a string and a list is acceptable."
- (when (stringp target)
- (setq target (xetla-name-split target)))
- (cadddr target))
-
-(defun xetla-name-revision (target)
- "Get revision component from TARGET.
-Both representation of TARGET, a string and a list is acceptable."
- (when (stringp target)
- (setq target (xetla-name-split target)))
- (cadddr (cdr target)))
-
-;;
-;; Utilities
-;; Mask a specified component in the name.
-;;
-(defun xetla-name-mask (original do-construct-p
- &optional
- archive-mask
- category-mask
- branch-mask
- version-mask
- revision-mask)
- "Mask ORIGINAL, a xetla revision name by masks; and return the masked value.
-
-If DO-CONSTRUCT-P is given, the result is converted to a string by
-`xetla-name-construct'.
-
-ARCHIVE-MASK, CATEGORY-MASK, BRANCH-MASK, VERSION-MASK and REVISION-MASK should
-be either nil or t, and indicate whether that field should be masked.
-
-If a mask value is nil, the associated element in ORIGINAL is set to nil.
-Else If a mask value is a string, the associated element in ORIGINAL is set
-to the string.
-Else the associated element in ORIGINAL is not changed.
-
-Examples:
- ELISP> (xetla-name-mask '(\"a\" \"c\" \"b\" \"v\" \"r\") nil t t t t nil)
- (\"a\" \"c\" \"b\" \"v\" nil)
-
- ELISP> (xetla-name-mask '(\"a\" \"c\" \"b\" \"v\" \"r\") nil t t t nil nil)
- (\"a\" \"c\" \"b\" nil nil)
-
- ELISP> (xetla-name-mask '(\"a\" \"c\" \"b\" \"v\" \"r\") t t t t nil nil)
- \"a/c-b\"
- ELISP> (xetla-name-mask '(\"a\" \"c\" \"b\" \"v\" \"r\") t nil nil nil nil t)
- \"r\"
- ELISP> (xetla-name-mask '(\"a\" \"c\" \"b\" \"v\" \"r\") t nil nil nil t t)
- \"v-r\"
- ELISP>"
- (when (consp original)
- (let ((masked (list
- (if archive-mask
- (if (stringp archive-mask)
- archive-mask
- (xetla-name-archive original)))
- (if category-mask
- (if (stringp category-mask)
- category-mask
- (xetla-name-category original)))
- (if branch-mask
- (if (stringp branch-mask)
- branch-mask
- (xetla-name-branch original)))
- (if version-mask
- (if (stringp version-mask)
- version-mask
- (xetla-name-version original)))
- (if revision-mask
- (if (stringp revision-mask)
- revision-mask
- (xetla-name-revision original))))))
- (if do-construct-p
- (xetla-name-construct masked)
- masked))))
-
-(defun xetla-name-match (target mask)
-"Compare the fully qualified revision list TARGET with a MASK.
-Each parameter is a list. The elements of the both lists are compared
-via a regexp match. When the mask part of a component is nil, this
-comparision is skipped.
-Here are some examples:
-\(xetla-name-match
- '(\"xsteve@nit.at-public\" \"xetla\" \"main\" \"0.1\" \"patch-116\")
- '(nil \"xt.*\" \"main\" nil nil)) => t
-\(xetla-name-match
- '(\"xsteve@nit.at-public\" \"xetla\" \"main\" \"0.1\" \"patch-116\")
- '(nil \"xt.*\" \"devel\" nil nil)) => nil" ;"
- (let ((tl target)
- (ml mask)
- (t-part)
- (m-part)
- (matching t))
- (while tl
- (setq t-part (car tl))
- (setq m-part (car ml))
- (when m-part
- (setq matching (string-match m-part t-part)))
- (if matching
- (progn
- (setq tl (cdr tl))
- (setq ml (cdr ml)))
- (setq tl nil)))
- (if matching t nil)))
-
-
-(defun xetla-name-match-from-list (target match-list)
- "Match TARGET against a list of possible matches.
-Every entry of MATCH-LIST is a list that contains a
-match element and a possible result.
-The target is matched against the elements in the match-list.
-If a match is found return the corresponding result,
-otherwise return nil."
- (let ((ml match-list)
- (match)
- (data)
- (result))
- (while (and (not result) ml)
- (setq match (caar ml))
- (setq data (cadar ml))
- (message "match: %s, data: %s" match data)
- (setq result (when (xetla-name-match target match) data))
- (setq ml (cdr ml)))
- result))
-
-;; TODO: Use xetla-archive-tree.
-(defun xetla-version-head (archive category branch version)
- "Return the newest revision for ARCHIVE/CATEGORY-BRANCH-VERSION."
- (xetla-run-tla-sync (list "revisions"
- (xetla-name-construct
- archive
- category
- branch
- version))
- :finished (lambda (output error status arguments)
- (with-current-buffer output
- (goto-char (point-max))
- (re-search-backward "^.")
- (buffer-substring-no-properties
- (point) (point-at-eol))))))
-
-;; --------------------------------------
-;; Archive tree manipulators
-;; --------------------------------------
-
-(defvar xetla-archive-tree nil
- "Arch archive/category/branch/version/revision are stored in assoc list:
-
- ((\"xsteve@nit.at-public\" \"http://arch.xsteve.at/2004\")
- [...]
- (\"mbp@sourcefrog.net-2004\"
- \"http://sourcefrog.net/arch/mbp@sourcefrog.net-2004\"
- (\"xetla\")
- (\"tilly\")
- [...]
- (\"dupes\"
- (\"mainline\"
- (\"0.1\")))
- [...]
- (\"archzoom\"))
- (\"mark@dishevelled.net-2003-mst\"
- \"http://members.iinet.net.au/~mtriggs/arch/\")
- (\"lord@emf.net-2004\"
- \"http://regexps.srparish.net/{archives}/lord@emf.net-2004\")
- [...]
- (\"Matthieu.Moy@imag.fr-public\"
- \"http://www-verimag.imag.fr/webdav/moy/public\"
- (\"xetla\"
- (\"main\"
- (\"0.1\"
- (\"patch-228\"
- \"Merged from Robert (patch8-9), Milan (patch21-22), Stefan (patch5-8)\"
- \"Matthieu Moy <Matthieu.Moy@imag.fr>\"
- \"2004-06-03 20:13:11 GMT\")
- (\"patch-227\"
- \"Fix default-directory in xetla-run-tla-sync, fix in xetla-changes-ediff\"
- \"Matthieu Moy <Matthieu.Moy@imag.fr>\"
- \"2004-06-03 15:26:15 GMT\")
- [...]
- (\"patch-1\"
- \"typo\"
- \"Matthieu Moy <Matthieu.Moy@imag.fr>\"
- \"2004-04-07 22:57:00 GMT\")
- (\"base-0\"
- \"tag of xsteve@nit.at-public/xetla-main-0.1-patch-5\"
- \"Matthieu Moy <Matthieu.Moy@imag.fr>\" \"2004-04-07 22:52:39 GMT\")))))
- [...]
- )
-
-This list is initially empty, and is built/rebuilt on demand.")
-
-;; Utilities
-(defun xetla-archive-tree-setcdr (parent value &optional rest)
- "In PARENT, update VALUE.
-REST are the items that are already present."
- (let* ((current (cdr parent))
- (list-details (assoc value current)))
- (if (or (null current) (null list-details))
- ;; rest is '("summary" "creator" "date") when value is "patch-N"
- (setcdr parent (cons (cons value rest) current))
- (if (and list-details rest)
- ;; Field already there. update details.
- (setcdr list-details rest)))))
-
-(defun xetla-archive-tree-setcddr (parent value)
- "In PARENT, update VALUE."
- (let ((current (cddr parent)))
- (if (or (null current) (null (assoc value current)))
- (setcdr (cdr parent) (cons (cons value nil) current)))))
-
-;; Archive
-(defun xetla-archive-tree-add-archive (archive location &optional old)
- "Add ARCHIVE at LOCATION to the archive tree.
-If OLD is provided, it is an old archive tree from which some
-information can be found (this is useful to keep the category/branch/version
-info for existing archives)."
- (if (xetla-archive-tree-get-archive archive)
- (let* ((a (xetla-archive-tree-get-archive archive))
- (val (cdr a))
- (oldlocation (car val))
- (category (cdr val)))
- (setcdr a (cons (or location oldlocation) category)))
- (let ((oldinfo (xetla-archive-tree-get-archive archive old))
- (newinfo (list archive location)))
- (when oldinfo
- (setcdr (cdr newinfo) (cddr oldinfo))) ;; list of versions.
- (setq xetla-archive-tree (cons newinfo
- xetla-archive-tree)))))
-
-(defun xetla-archive-tree-get-archive (archive &optional archive-tree)
- "Get the value of ARCHIVE from ARCHIVE-TREE.
-If ARCHIVE-TREE is not given, `xetla-archive-tree' is used."
- (assoc archive (or archive-tree xetla-archive-tree)))
-
-;; Category
-(defun xetla-archive-tree-add-category (archive category)
- "Add a new category to ARCHIVE named CATEGORY."
- (xetla-archive-tree-add-archive archive nil)
- (xetla-archive-tree-setcddr
- (xetla-archive-tree-get-archive archive)
- category))
-
-(defun xetla-archive-tree-get-category (archive category)
- "From ARCHIVE, get CATEGORY."
- (assoc category (cdr (cdr (xetla-archive-tree-get-archive archive)))))
-
-;; Branch
-(defun xetla-archive-tree-add-branch (archive category branch)
- "Add a new branch to ARCHIVE's CATEGORY named BRANCH."
- (xetla-archive-tree-add-category archive category)
- (xetla-archive-tree-setcdr
- (xetla-archive-tree-get-category archive category)
- branch))
-
-(defun xetla-archive-tree-get-branch (archive category branch)
- "Get a branch from ARCHIVE's CATEGORY named BRANCH."
- (assoc branch (cdr (xetla-archive-tree-get-category
- archive category))))
-
-;; Version
-(defun xetla-archive-tree-add-version (archive category branch version)
- "Add a new version to ARCHIVE CATEGORY BRANCH named VERSION."
- (xetla-archive-tree-add-branch archive category branch)
- (xetla-archive-tree-setcdr
- (xetla-archive-tree-get-branch archive category branch )
- version))
-
-(defun xetla-archive-tree-get-version (archive category branch version)
- "Get a version from ARCHIVE CATEGORY BRANCH named VERSION."
- (assoc version (cdr (xetla-archive-tree-get-branch
- archive category branch))))
-
-;; Revision
-(defun xetla-archive-tree-add-revision (archive category branch version revision
- &optional summary creator date)
- "Add a new revision to ARCHIVE CATEGORY BRANCH VERSION named REVISION."
- (xetla-archive-tree-add-version archive category branch version)
- (xetla-archive-tree-setcdr
- (xetla-archive-tree-get-version archive category branch version)
- revision (list summary creator date)))
-
-(defun xetla-archive-tree-get-revision (archive category branch version revision)
- "Get a revision from ARCHIVE CATEGORY BRANCH VERSION named REVISION."
- (assoc revision (cdr (xetla-archive-tree-get-version
- archive category branch version))))
-
-;; Archive tree builders
-(defun xetla-archive-tree-build (basename &optional use-cache ignore-error)
- "Generic version of xetla-archive-tree-build-*.
-BASENAME is used as a base for this tree.
-If USE-CACHE is non-nil, load details from the cache where possible.
-If IGNORE-ERROR is non-nil, don't throw errors."
- (when (stringp basename)
- (setq basename (xetla-name-split basename)))
- (let ((archive (xetla-name-archive basename))
- (category (xetla-name-category basename))
- (branch (xetla-name-branch basename))
- (version (xetla-name-version basename)))
- (cond
- (version
- (xetla-archive-tree-build-revisions archive
- category
- branch
- version
- use-cache
- ignore-error))
- (branch
- (xetla-archive-tree-build-versions archive
- category
- branch
- use-cache
- ignore-error))
- (category
- (xetla-archive-tree-build-branches archive
- category
- use-cache
- ignore-error))
- (archive
- (xetla-archive-tree-build-categories archive
- use-cache
- ignore-error))
- (t
- (xetla-archive-tree-build-archives use-cache
- ignore-error)))))
-
-(defun xetla-archive-tree-build-archives (&optional use-cache ignore-error)
- "Builds the list of archives.
-If USE-CACHE is non-nil, load details from the cache where possible.
-If IGNORE-ERROR is non-nil, don't throw errors."
- (when (or (not use-cache)
- (not xetla-archive-tree))
- (xetla-run-tla-sync '("archives")
- :finished 'xetla-null-handler
- :error
- (if ignore-error
- 'xetla-null-handler
- 'xetla-default-error-function))
- (let ((old-archive-tree xetla-archive-tree))
- (setq xetla-archive-tree nil)
- (save-excursion
- (let ((archive-name)
- (archive-location))
- (set-buffer xetla-last-process-buffer)
- (goto-char (point-min))
- (while (> (point-at-eol) (point-at-bol))
- (setq archive-name (buffer-substring-no-properties
- (point-at-bol)
- (point-at-eol)))
- (beginning-of-line-text 2)
- (setq archive-location (buffer-substring-no-properties
- (point) (point-at-eol)))
- (forward-line 1)
- (xetla-archive-tree-add-archive archive-name
- archive-location
- old-archive-tree)))))))
-
-(defun xetla-archive-tree-build-categories (archive &optional
- use-cache
- ignore-error)
- "Build the list of categories for ARCHIVE in `xetla-archive-tree'.
-If USE-CACHE is non-nil, load details from the cache where possible.
-If IGNORE-ERROR is non-nil, don't throw errors."
- (when (or (not use-cache)
- (not (cddr (xetla-archive-tree-get-archive archive))))
- (let ((basename archive))
- (message "building categories for `%s'..." basename)
- (xetla-run-tla-sync (list "categories" "-A" basename)
- :finished 'xetla-null-handler
- :error
- (if ignore-error
- 'xetla-null-handler
- 'xetla-default-error-function))
- (message "building categories for `%s'...done" basename)
- (sit-for 0)
- (message nil))
- (with-current-buffer xetla-last-process-buffer
- (let (category)
- (goto-char (point-min))
- (while (> (point-at-eol) (point-at-bol))
- (setq category (buffer-substring-no-properties
- (point-at-bol)
- (point-at-eol)))
- (forward-line 1)
- (xetla-archive-tree-add-category archive category)
- )))))
-
-(defun xetla-archive-tree-build-branches (archive category
- &optional
- use-cache
- ignore-error)
- "Build the list of branches for ARCHIVE/CATEGORY in `xetla-archive-tree'.
-If USE-CACHE is non-nil, load details from the cache where possible.
-If IGNORE-ERROR is non-nil, don't throw errors."
- (when (or (not use-cache)
- (not (cdr (xetla-archive-tree-get-category archive category))))
- (let ((basename (xetla-name-construct archive category)))
- (message "building branches for `%s'..." basename)
- (xetla-run-tla-sync (list "branches" basename)
- :finished 'xetla-null-handler
- :error
- (if ignore-error
- 'xetla-null-handler
- 'xetla-default-error-function))
- (message "building branches for `%s'...done" basename)
- (sit-for 0)
- (message nil))
- (with-current-buffer xetla-last-process-buffer
- (let (branch)
- (goto-char (point-min))
- (while (> (point-at-eol) (point-at-bol))
- (setq branch (buffer-substring-no-properties
- (point-at-bol)
- (point-at-eol)))
- (xetla-archive-tree-add-branch
- archive
- category
- (if (looking-at ".*-")
- (xetla-name-branch (xetla-name-split-semi-qualified
- branch))
- ;; unnamed branch
- ""))
- (forward-line 1))))))
-
-(defun xetla-archive-tree-build-versions (archive category branch
- &optional
- use-cache
- ignore-error)
- "Build the version list in ARCHIVE/CATEGORY-BRANCH in `xetla-archive-tree'.
-If USE-CACHE is non-nil, load details from the cache where possible.
-If IGNORE-ERROR is non-nil, don't throw errors."
- (when (or (not use-cache)
- (not (cdr (xetla-archive-tree-get-branch archive category
- branch))))
- (let ((basename (xetla-name-construct archive category branch)))
- (message "building versions for `%s'..." basename)
- (xetla-run-tla-sync (list "versions" basename)
- :finished 'xetla-null-handler
- :error
- (if ignore-error
- 'xetla-null-handler
- 'xetla-default-error-function))
- (message "building versions for `%s'...done" basename)
- (sit-for 0)
- (message nil))
- (with-current-buffer xetla-last-process-buffer
- (let (version)
- (goto-char (point-min))
- (while (> (point-at-eol) (point-at-bol))
- (setq version (buffer-substring-no-properties
- (point-at-bol)
- (point-at-eol)))
- (forward-line 1)
- (xetla-archive-tree-add-version
- archive
- category
- branch
- (xetla-name-version (xetla-name-split-semi-qualified version))))))))
-
-(defun xetla-archive-tree-build-revisions (archive category branch version
- &optional
- use-cache
- ignore-error)
-
- "Build the revision list in ARCHIVE/CATEGORY-BRANCH-VERSION.
-Updates `xetla-archive-tree'.
-If USE-CACHE is non-nil, load details from the cache where possible.
-If IGNORE-ERROR is non-nil, don't throw errors."
- (when (or (not use-cache)
- (not (cdr (xetla-archive-tree-get-version archive category branch
- version))))
- (let ((details (or xetla-revisions-shows-summary
- xetla-revisions-shows-date
- xetla-revisions-shows-creator))
- (basename (xetla-name-construct
- archive category branch version)))
- (message "building revisions for `%s'..." basename)
- (if details
- (progn
- (xetla-run-tla-sync (list "revisions"
- "--summary" "--date" "--creator"
- basename)
- :finished 'xetla-null-handler
- :error (if ignore-error
- 'xetla-null-handler
- 'xetla-default-error-function)))
- (progn
- (xetla-run-tla-sync (list "revisions" basename)
- :finished 'xetla-null-handler
- :error (if ignore-error
- 'xetla-null-handler
- 'xetla-default-error-function))))
- (message "building revisions for `%s'...done" basename)
- (sit-for 0)
- (message nil)
- (with-current-buffer xetla-last-process-buffer
- (let (revision date creator summary)
- (goto-char (point-min))
- (while (> (point-at-eol) (point-at-bol))
- (setq revision (buffer-substring-no-properties
- (point-at-bol)
- (point-at-eol)))
- (forward-line 1)
- (when details
- (skip-chars-forward " ")
- (setq date (buffer-substring-no-properties (point)
- (point-at-eol)))
- (forward-line 1)
- (skip-chars-forward " ")
- (setq creator (buffer-substring-no-properties (point)
- (point-at-eol)))
- (forward-line 1)
- (skip-chars-forward " ")
- (setq summary (buffer-substring-no-properties
- (point)
- (progn (re-search-forward "^\\([^ \t]\\|$\\)")
- (previous-line 1)
- (end-of-line)
- (point))))
- (forward-line 1))
- (xetla-archive-tree-add-revision
- archive
- category
- branch
- version
- revision
- summary
- creator
- date)))))))
-
-
-(defun xetla-revisions-tree-contains-details
- (archive category branch version)
- "Whether VERSION has already been listed full details.
-Details include summary lines, dates, and creator in the archive tree."
- (let ((vtree (xetla-archive-tree-get-version archive category branch
- version)))
- (and (cdr vtree) ;; revision list is here
- (cadr (cadr vtree))))) ;; summary line also
-
-;; --------------------------------------
-;; Revlib tree manipulators
-;; --------------------------------------
-(defvar xetla-revlib-tree nil)
-(defun xetla-revlib-tree-get-archive (archive &optional archive-tree)
- "Get ARCHIVE from ARCHIVE-TREE.
-If ARCHIVE-TREE is not given, `xetla-revlib-tree' is used instead."
- (assoc archive (or archive-tree xetla-revlib-tree)))
-
-(defun xetla-revlib-tree-build-archives (&optional use-cache ignore-error)
- "Build the list of archives in `xetla-revlib-tree'.
-If USE-CACHE is non-nil, load from the cache where possible.
-If IGNORE-ERROR is non-nil, error is not reported.
-Return non-nil if the tree entry for archives are updated."
- (when (or (not use-cache)
- (not xetla-revlib-tree))
- (xetla-run-tla-sync '("library-archives")
- :finished 'xetla-null-handler
- :error
- (if ignore-error
- 'xetla-null-handler
- 'xetla-default-error-function))
- (let ((old-revlib-tree xetla-revlib-tree) )
- (setq xetla-revlib-tree nil)
- (save-excursion
- (let ((archive-name)
- (tmp xetla-archive-tree)
- (xetla-archive-tree xetla-revlib-tree)
- result)
- (set-buffer xetla-last-process-buffer)
- (goto-char (point-min))
- (while (> (point-at-eol) (point-at-bol))
- (setq result t)
- (setq archive-name (buffer-substring-no-properties
- (point-at-bol)
- (point-at-eol)))
- (forward-line 1)
- (xetla-archive-tree-add-archive archive-name
- nil
- old-revlib-tree))
- (setq xetla-revlib-tree xetla-archive-tree
- xetla-archive-tree tmp)
- result)))))
-
-(defun xetla-revlib-tree-get-category (archive category)
- "Get a category from ARCHIVE named CATEGORY."
- (assoc category (cdr (cdr (xetla-revlib-tree-get-archive archive)))))
-
-(defun xetla-revlib-tree-build-categories (archive &optional
- use-cache
- ignore-error)
- "Builds the list of categories for an ARCHIVE in `xetla-revlib-tree'.
-If USE-CACHE is non-nil, load from the cache where possible.
-If IGNORE-ERROR is non-nil, error is not reported.
-Return non-nil if the tree entry for categories are updated."
- (when (or (not use-cache)
- (not (cddr (xetla-revlib-tree-get-archive archive))))
- (xetla-run-tla-sync (list "library-categories" "-A" archive)
- :finished 'xetla-null-handler
- :error
- (if ignore-error
- 'xetla-null-handler
- 'xetla-default-error-function))
- (with-current-buffer xetla-last-process-buffer
- (let (category
- (tmp xetla-archive-tree)
- (xetla-archive-tree xetla-revlib-tree)
- result)
- (goto-char (point-min))
- (while (> (point-at-eol) (point-at-bol))
- (setq result t)
- (setq category (buffer-substring-no-properties
- (point-at-bol)
- (point-at-eol)))
- (forward-line 1)
- (xetla-archive-tree-add-category archive category))
- (setq xetla-revlib-tree xetla-archive-tree
- xetla-archive-tree tmp)
- result))))
-
-(defun xetla-revlib-tree-get-branch (archive category branch)
- "From ARCHIVE/CATEGORY, get BRANCH."
- (assoc branch (cdr (xetla-revlib-tree-get-category
- archive category))))
-
-(defun xetla-revlib-tree-build-branches (archive category
- &optional
- use-cache
- ignore-error)
- "Build the list of branches for ARCHIVE/CATEGORY in `xetla-revlib-tree'.
-If USE-CACHE is non-nil, load from the cache where possible.
-If IGNORE-ERROR is non-nil, error is not reported.
-Return non-nil if the tree entry for branches are updated."
- (when (or (not use-cache)
- (not (cdr (xetla-revlib-tree-get-category archive category))))
- (xetla-run-tla-sync (list "library-branches" "-A" archive category)
- :finished 'xetla-null-handler
- :error
- (if ignore-error
- 'xetla-null-handler
- 'xetla-default-error-function))
- (with-current-buffer xetla-last-process-buffer
- (let (branch
- (tmp xetla-archive-tree)
- (xetla-archive-tree xetla-revlib-tree)
- result)
- (goto-char (point-min))
- (while (> (point-at-eol) (point-at-bol))
- (setq result t)
- (setq branch (buffer-substring-no-properties
- (point-at-bol)
- (point-at-eol)))
- (forward-line 1)
- (xetla-archive-tree-add-branch
- archive
- category
- (xetla-name-branch (xetla-name-split-semi-qualified branch))))
- (setq xetla-revlib-tree xetla-archive-tree
- xetla-archive-tree tmp)
- result))))
-
-(defun xetla-revlib-tree-get-version (archive category branch version)
- "Get ARCHIVE/CATEGORY-BRANCH-VERSION from the revlib tree."
- (assoc version (cdr (xetla-revlib-tree-get-branch
- archive category branch))))
-
-(defun xetla-revlib-tree-build-versions (archive category branch
- &optional
- use-cache
- ignore-error)
- "Build the versions list in ARCHIVE/CATEGORY/BRANCH in `xetla-archive-tree'.
-If USE-CACHE is non-nil, load from the cache where possible.
-If IGNORE-ERROR is non-nil, error is not reported.
-Return non-nil if the tree entry for versions are updated."
- (when (or (not use-cache)
- (not (cdr (xetla-revlib-tree-get-branch archive category
- branch))))
- (xetla-run-tla-sync (list "library-versions"
- (xetla-name-construct
- archive category branch))
- :finished 'xetla-null-handler
- :error
- (if ignore-error
- 'xetla-null-handler
- 'xetla-default-error-function))
- (with-current-buffer xetla-last-process-buffer
- (let (version
- (tmp xetla-archive-tree)
- (xetla-archive-tree xetla-revlib-tree)
- result)
- (goto-char (point-min))
- (while (> (point-at-eol) (point-at-bol))
- (setq result t)
- (setq version (buffer-substring-no-properties
- (point-at-bol)
- (point-at-eol)))
- (forward-line 1)
- (xetla-archive-tree-add-version
- archive
- category
- branch
- (xetla-name-version (xetla-name-split-semi-qualified version))))
- (setq xetla-revlib-tree xetla-archive-tree
- xetla-archive-tree tmp)
- result))))
-
-(defun xetla-revlib-tree-get-revision (archive category branch version revision)
- "Get ARCHIVE/CATEGORY-BRANCH-VERSION-REVISION from the revlib tree."
- (assoc revision (cdr (xetla-revlib-tree-get-version
- archive category branch version))))
-
-(defun xetla-revlib-tree-build-revisions (archive category branch version
- &optional
- use-cache
- ignore-error)
-
- "Build the revision list of ARCHIVE/CATEGORY-BRANCH-VERSION.
-Updates `xetla-revlib-tree'.
-If IGNORE-ERROR is non-nil, error is not reported.
-Return non-nil if the tree entry for revisions are updated."
- (when (or (not use-cache)
- (not (cdr (xetla-revlib-tree-get-version archive category branch
- version))))
- (xetla-run-tla-sync (list "library-revisions"
- "--summary" "--date" "--creator"
- (xetla-name-construct
- archive category branch version))
- :finished 'xetla-null-handler
- :error (if ignore-error
- 'xetla-null-handler
- 'xetla-default-error-function))
- (with-current-buffer xetla-last-process-buffer
- (let (revision
- date
- creator
- summary
- (tmp xetla-archive-tree)
- (xetla-archive-tree xetla-revlib-tree)
- result)
-
- (goto-char (point-min))
- (while (> (point-at-eol) (point-at-bol))
- (setq result t)
- (setq revision (buffer-substring-no-properties
- (point-at-bol)
- (point-at-eol)))
- (forward-line 1)
- (skip-chars-forward " ")
- (setq date (buffer-substring-no-properties (point)
- (point-at-eol)))
- (forward-line 1)
- (skip-chars-forward " ")
- (setq creator (buffer-substring-no-properties (point)
- (point-at-eol)))
- (forward-line 1)
- (skip-chars-forward " ")
- (setq summary (buffer-substring-no-properties
- (point)
- (progn (re-search-forward "^\\([^ \t]\\|$\\)")
- (previous-line 1)
- (end-of-line)
- (point))))
- (forward-line 1)
- (xetla-archive-tree-add-revision
- archive
- category
- branch
- version
- revision
- summary
- creator
- date))
- (setq xetla-revlib-tree xetla-archive-tree
- xetla-archive-tree tmp)
- result
- ))))
-
-;; --------------------------------------
-;; Name reading engine
-;; --------------------------------------
-;;Currently only able to read a full revision starting from nothing.
-(defun xetla-name-read-refresh-cache ()
- "Function to be called from the minibuffer while reading a name."
- (interactive)
- (xetla-archive-tree-build
- (xetla-name-construct
- (butlast (delete nil (xetla-name-split (buffer-substring))))))
- (setq xetla-archive-tree nil))
-
-(defvar xetla-name-read-arguments "This value should not be refereed."
- "Used to suppress warnings from the byte code compiler.
-This variable is a just placeholder introduced to suppress the
-warnings from byte code compiler. Variable `xetla-name-read-arguments'
-should be bound in `let'. Variable `xetla-name-read-arguments' is used
-for passing information from `xetla-name-read' to functions called internally
-from `xetla-name-read'. Use function `xetla-name-read-arguments' to get the
-information")
-
-(defun xetla-name-read-arguments (key)
- "Get `xetla-name-read' context information associated to KEY.
-`xetla-name-read' calls some functions to read a xetla name.
-In the functions, the arguments passed to `xetla-name-read'(context information)
-are needed to know. However, `xetla-name-read' cannot pass the context
-information directly to the functions because the functions are something to do
-with Emacs's completion mechanism; and the mechanism specifies the number
-of arguments of the functions. So the context information is passed via
-a local variable, `xetla-name-read-arguments', defined in let.
-
-Symbol `archive', `category', `branch', `version', or `revision' are
-acceptable as KEY."
- (cdr (assoc key xetla-name-read-arguments)))
-
-
-(defun xetla-name-read-complete (string predicate what)
- "Completion function for name reading.
-
-Displays STRING and prompts for something satisfying PREDICATE.
-
-This function uses the free variables archive, category, branch,
-version, and revision. If one of these variables is non-nil, it means
-the corresponding value must be read from keyboard.
-
-REMINDER: this function may be called several times, with different
-values for WHAT:
-
- - nil : The function must return the longest prefix
- - t : The function must return the list of completions
- - 'lambda : The function must return t if the completion correspond
- to an exact match, nil otherwise. (so that Emacs can distinguish
- between \"sole completion\" and \"complete, but not unique\"."
- (if (and (eq what 'lambda)
- (string-match "/\\(.*--\\)?$" string))
- ;; The caller just want to know whether this is a full
- ;; completion. This can not be the case with such suffix.
- nil
- (let* ((empty-branch nil)
- (use-cache (not current-prefix-arg))
- (splited (xetla-name-split string))
- (archive-loc (xetla-name-archive splited))
- (category-loc (xetla-name-category splited))
- (branch-loc (xetla-name-branch splited))
- (version-loc (xetla-name-version splited))
- (revision-loc (xetla-name-revision splited))
- (suffix (cond
- ((and (xetla-name-read-arguments 'category)
- (not category-loc) "/"))
- ((and (xetla-name-read-arguments 'branch)
- (not branch-loc) "--"))
- ((and (xetla-name-read-arguments 'version)
- (not version-loc) "--"))
- ((and (xetla-name-read-arguments 'revision)
- (not revision-loc) "--"))
- (t nil)))
- (maybep (cond
- ((eq 'maybe (xetla-name-read-arguments 'category))
- t)
- ((and (eq 'maybe (xetla-name-read-arguments 'branch))
- archive-loc category-loc)
- t)
- ((and (eq 'maybe (xetla-name-read-arguments 'version))
- archive-loc category-loc branch-loc)
- t)
- ((and (eq 'maybe (xetla-name-read-arguments 'revision))
- archive-loc category-loc branch-loc version-loc)
- t)
- (t nil)))
- (completions
- (cond
- ;; If the user started to write a revision ...
- (revision-loc
- ;; ... and if the user is supposed to be prompted a
- ;; revision
- (when (xetla-name-read-arguments 'revision)
- (let ((xetla-revisions-shows-summary nil)
- (xetla-revisions-shows-date nil)
- (xetla-revisions-shows-creator nil))
- (xetla-archive-tree-build-revisions
- archive-loc category-loc branch-loc version-loc use-cache t))
- (cdr (xetla-archive-tree-get-version
- archive-loc category-loc branch-loc version-loc))))
- (version-loc
- (when (xetla-name-read-arguments 'version)
- (xetla-archive-tree-build-versions
- archive-loc category-loc branch-loc use-cache t)
- (cdr (xetla-archive-tree-get-branch
- archive-loc category-loc branch-loc))))
- ;; If the user started a branch ...
- (branch-loc
- ;; And a branch is needed
- (when (xetla-name-read-arguments 'branch)
- (xetla-archive-tree-build-branches
- archive-loc category-loc use-cache t)
- (let ((result (cdr (xetla-archive-tree-get-category
- archive-loc category-loc))))
- (when (and (string= branch-loc "")
- (xetla-name-read-arguments 'version)
- (let ((empty-br-exists nil))
- (dolist (branch
- (cdr (xetla-archive-tree-get-category
- archive-loc category-loc)))
- (when (string= (car branch) "")
- (setq empty-br-exists t)))
- empty-br-exists))
- (xetla-archive-tree-build-versions
- archive-loc category-loc "")
- (setq empty-branch (xetla-archive-tree-get-branch
- archive-loc category-loc ""))
- (when empty-branch
- ;; Remove the "" branch to avoid the --
- ;; completion.
- (let ((tmp result))
- (setq result nil)
- (while tmp
- (when (not (string= (caar tmp) ""))
- (setq result (cons (car tmp) result)))
- (setq tmp (cdr tmp))))))
- result)))
- (category-loc
- (when (xetla-name-read-arguments 'category)
- (xetla-archive-tree-build-categories archive-loc use-cache t)
- (cddr (xetla-archive-tree-get-archive archive-loc))))
- (t
- (when (xetla-name-read-arguments 'archive)
- (xetla-archive-tree-build-archives use-cache t)
- xetla-archive-tree)))))
- (let* ((base (mapcar (lambda (x)
- (xetla-name-construct
- (delete
- nil
- (list
- (when category-loc archive-loc)
- (when branch-loc category-loc)
- (when version-loc branch-loc)
- (when revision-loc version-loc)
- (car x)))))
- completions))
- (sans-suffix
- (and maybep suffix))
- (empty-branch-versions
- (and empty-branch
- (mapcar (lambda (x)
- (xetla-name-construct
- archive-loc category-loc "" (car x)))
- (cdr empty-branch))))
- (completions (funcall 'all-completions
- string
- (nconc (mapcar
- (lambda (x)
- (list (concat x suffix)))
- base)
- (when sans-suffix
- (mapcar
- (lambda (x) (list x))
- base))
- (when empty-branch
- (mapcar
- (lambda (x) (list x))
- empty-branch-versions)))
- predicate)))
- (let ((result
- (cond ((eq what t)
- ;; We just want the list of completions
- completions)
- ((eq (length completions) 1)
- ;; There's only one completion
- (if (eq what 'lambda)
- (string= (car completions) string)
- (cond ((string= (car completions) string) t)
- (t (car completions)))))
- ;; there are several possible completions
- (t (if (eq what 'lambda)
- ;; complete, but not unique ?
- (member string completions)
- (try-completion string (mapcar 'list
- completions)))))))
-;; (xetla-trace "string=%s predicate=%S what=%s ==> result=%S\ncompletions=%S"
-;; string predicate what result completions)
- result)))))
-
-;; Test cases
-;; (xetla-name-read "enter category: " "Matthieu.Moy@imag.fr--public" 'prompt)
-;; (xetla-name-read "branch: " "lord@emf.net--2004" 'prompt 'prompt)
-;; (xetla-name-read "revision: " 'prompt 'prompt 'prompt 'prompt 'prompt)
-;; (xetla-name-read "revision or version: " 'prompt 'prompt 'prompt 'prompt 'maybe)
-;; (xetla-name-read "revision or version: " "jet@gyve.org--xetla" "xetla" "jet" 'prompt 'maybe)
-;;
-(defvar xetla-name-read-history nil) ; TODO: multiple history list?
-(defvar xetla-name-read-debug nil
- "If non-nil, `condition-case' in `xetla-name-read' is made disabled.")
-(defun xetla-name-read (&optional prompt archive category
- branch version revision)
- "Read a name.
-To get help on the user interface of `xetla-name-read', please type
-M-x xetla-name-read-help RET.
-
-Function reading an archive location from keyboard.
-Read name is expressed in a list built by `xetla-name-split'.
-
-First argument PROMPT is the prompt the user will get. Next arguments
-ARCHIVE CATEGORY BRANCH VERSION and REVISION are either the default
-value, or a request for a value. They can take four values:
-
- - A string means the default value, and will be used as an initial
- input.
-
- - The symbol 'prompt means the value will be prompted from the user.
- The user will HAVE to give this value.
-
- - The symbol 'maybe means the value will be prompted, but is optional
- for the user.
-
- - nil means the value won't be prompted.
-
-They should appear in the same order as above.
-
-Example:
-- Read a category in archive \"Matthieu.Moy@imag.fr--public\":
- (xetla-name-read \"enter category: \" \"Matthieu.Moy@imag.fr--public\" 'prompt)
-- Read a revision, anywhere:
- (xetla-name-read \"revision: \" 'prompt 'prompt 'prompt 'prompt 'prompt)
-- Read either a revision or a version:
- (xetla-name-read \"revision: \" 'prompt 'prompt 'prompt 'prompt 'maybe)
-
-While prompting, a menu \"Xetla\" is added to the menubar. The
-following commands are available:
-
-\\{xetla-name-read-minibuf-map}"
- (let ((xetla-name-read-arguments `((archive . ,archive)
- (category . ,category)
- (branch . ,branch)
- (version . ,version)
- (revision . ,revision))))
- (if xetla-name-read-debug
- (xetla-name-read-internal prompt archive category branch version revision)
- (condition-case reason
- (xetla-name-read-internal prompt archive category branch version revision)
- ((quit error)
- (run-hooks 'xetla-name-read-error-hook)
- (signal (car reason) (cdr reason)))))))
-
-(defun xetla-name-read-internal (prompt archive category branch version revision)
- "See `xetla-name-read'."
- (run-hooks 'xetla-name-read-init-hook)
- (let* ((minibuffer-local-completion-map xetla-name-read-minibuf-map)
- (result (xetla-name-construct
- (delete
- 'maybe
- (delete 'prompt (list archive category
- branch version)))))
- (first-try t)
- not-finished too-long last-empty)
- ;; Without in some case 'maybe is ignored by xetla-prompt-not-finished
- ;; and never the control flow enters the while loop.
- ;; We need C language's do-while loop.
- (while (or first-try
- not-finished
- too-long
- last-empty)
- (unless first-try
- (unless (eq this-command 'choose-completion)
- (ding)
- (message (cond (not-finished "%s%s [incomplete input: %s]")
- (too-long "%s%s [too long input for: %s]")
- (last-empty (concat "%s%s [empty " last-empty
- " name]"))
- (t (error
- (concat "case not managed."
- " Please submit a bug report"))))
- prompt result
- (xetla-name-read-required-input archive
- category
- branch
- version
- revision))
- (sit-for 2)
- (message nil)))
-
- (setq result (completing-read
- (or prompt "Location: ")
- 'xetla-name-read-complete
- nil nil result
- 'xetla-name-read-history)
- first-try nil)
- (setq not-finished (xetla-prompt-not-finished
- result archive category branch
- version revision))
- (setq too-long (xetla-prompt-too-long
- result archive category branch
- version revision))
- (setq last-empty (xetla-prompt-last-empty result)))
-
- (when result
- (setq result (xetla-name-split result)))
- (run-hook-with-args 'xetla-name-read-final-hook result)
- result))
-
-(defun xetla-prompt-not-finished (result archive category branch
- version revision)
- "Check whether user input is complete.
-True if RESULT (a string) is not sufficient when the user is
-prompted for ARCHIVE CATEGORY BRANCH VERSION REVISION."
- (let ((res-split (xetla-name-split result)))
- (or (and (eq archive 'prompt) ;; archive required
- (not (xetla-name-archive res-split))) ;; but not provided
- (and (eq category 'prompt)
- (not (xetla-name-category res-split)))
- (and (eq branch 'prompt)
- (not (xetla-name-branch res-split)))
- (and (eq version 'prompt)
- (not (xetla-name-version res-split)))
- (and (eq revision 'prompt)
- (not (xetla-name-revision res-split))))))
-
-(defun xetla-prompt-too-long (result archive category branch
- version revision)
- "Check whether the user has entered too many elements.
-True if RESULT (a string) contains too many elements when the user
-is prompted for ARCHIVE CATEGORY BRANCH VERSION REVISION.
-
-For example, will return true if the user entered
-foo@bar-2004/xetla-main while prompted only for a category."
- (let ((res-split (xetla-name-split result)))
- (or (and (not revision) ;; revision not needed
- (xetla-name-revision res-split)) ;; but provided
- (and (not version)
- (xetla-name-version res-split))
- (and (not branch)
- (xetla-name-branch res-split))
- (and (not category)
- (xetla-name-category res-split))
- (and (not archive)
- (xetla-name-archive res-split)))))
-
-(defun xetla-prompt-last-empty (result)
- "Check whether the last field is empty.
-Non-nil if RESULT (a string) is terminated by \"--\" or \"/\". This
-means the user entered a delimiter but not the element after.
-
-When non-nil, the returned value is a string giving the name of the
-item that is currently empty. (eg: archive, category, ...)"
- (let ((res-split (xetla-name-split result)))
- (cond ((equal (xetla-name-archive res-split) "") "archive" )
- ((equal (xetla-name-category res-split) "") "category")
- ((and (equal (xetla-name-branch res-split) "")
- (not (xetla-name-version res-split))) "branch" )
- ((equal (xetla-name-version res-split) "") "version" )
- ((equal (xetla-name-revision res-split) "") "revision")
- (t nil))))
-
-
-(defun xetla-name-read-required-input (archive
- category
- branch
- version
- revision)
- "Return string which represents the elements to be readin `xetla-name-read'.
-If ARCHIVE, CATEGORY, BRANCH, VERSION or REVISION are equal to 'maybe, the
-corresponding element will be optionally read.
-If any of these are non-nil (but not 'maybe), the corresponding element will be
-required.
-If any of these are nil, the correpsonding element is not required."
- (concat
- (cond ((eq archive 'maybe) "[A]")
- (archive "A")
- (t ""))
- (cond ((eq category 'maybe) "[/C]")
- (category "/C")
- (t ""))
- (cond ((eq branch 'maybe) "[--B]")
- (branch "--B")
- (t ""))
- (cond ((eq version 'maybe) "[--V]")
- (version "--V")
- (t ""))
- (cond ((eq revision 'maybe) "[--R]")
- (revision "--R")
- (t ""))))
-
-
-
-(defun xetla-location-type (location)
- "Return the type of LOCATION."
- (cond
- ((string-match "^ftp://" location) 'ftp)
- ((string-match "^sftp://" location) 'sftp)
- ((string-match "^http://" location) 'http)
- (t 'local)))
-
-(defun xetla-archive-type (archive)
- "Return the type of ARCHIVE."
- (cond
- ((string-match "SOURCE$" archive) 'source)
- ;; archive-MIRROR, archive-MIRROR-2 should be treated as mirror
- ((string-match ".+-MIRROR" archive) 'mirror)
- (t 'normal)))
-
-;; (xetla-archive-name-source "a")
-;; (xetla-archive-name-source "a-SOURCE")
-;; (xetla-archive-name-source "a-MIRROR")
-(defun xetla-archive-name-source (archive &optional existence-check)
- "Make source archive name from ARCHIVE.
-If EXISTENCE-CHECK is non-nil, check whether the made source archive name
-already exists or not; return nil if it doesn't exists.
-Example:
-ELISP> (xetla-archive-name-source \"jet@gyve.org-xetla\")
-\"jet@gyve.org-xetla-SOURCE\"
-ELISP> (xetla-archive-name-source \"jet@gyve.org-xetla-MIRROR\")
-\"jet@gyve.org-xetla\"
-ELISP> (xetla-archive-name-source \"jet@gyve.org-xetla-SOURCE\")
-nil"
- (let* ((type (xetla-archive-type archive))
- (source (cond
- ((eq 'normal type)
- (concat archive "-SOURCE"))
- ((eq 'mirror type)
- (string-match "\\(.*\\)-MIRROR$" archive)
- (match-string 1 archive))
- (t nil))))
- (if existence-check
- (progn
- (xetla-archive-tree-build-archives t)
- (when (and source (xetla-archive-tree-get-archive source))
- source))
- source)))
-
-;; (xetla-archive-name-mirror "a")
-;; (xetla-archive-name-mirror "a-SOURCE")
-;; (xetla-archive-name-mirror "a-MIRROR")
-(defun xetla-archive-name-mirror (archive &optional existence-check)
- "Make mirror archive name from ARCHIVE.
-If EXISTENCE-CHECK is non-nil, check whether the made mirror archive name
-already exists or not; return nil if it doesn't exists.
-Example:
-ELISP> (xetla-archive-name-mirror \"jet@gyve.org--xetla\")
-\"jet@gyve.org--xetla-MIRROR\"
-ELISP> (xetla-archive-name-mirror \"jet@gyve.org--xetla-SOURCE\")
-\"jet@gyve.org--xetla\"
-ELISP> (xetla-archive-name-mirror \"jet@gyve.org--xetla-MIRROR\")
-nil"
- (let* ((type (xetla-archive-type archive))
- (mirror (cond
- ((eq 'normal type)
- (concat archive "-MIRROR"))
- ((eq 'source type)
- (string-match "\\(.*\\)-SOURCE" archive)
- (match-string 1 archive))
- (t nil))))
- (if existence-check
- (progn
- (xetla-archive-tree-build-archives t)
- (when (and mirror (xetla-archive-tree-get-archive mirror))
- mirror))
- mirror)))
-
-(defun xetla-compute-direct-ancestor (&optional revision)
- "Compute the direct ancestor of REVISION.
-REVISION must be provided as a list, and a list is returned.
-If revision is nil, return the ancestor of the last revision
-of the local tree."
- (interactive
- (list (xetla-name-read "Compute direct ancestor of: "
- 'prompt 'prompt 'prompt 'prompt 'prompt)))
- (let ((ancestor
- (xetla-run-tla-sync (list "ancestry-graph" "--immediate"
- (and revision
- (xetla-name-construct revision)))
- :finished (lambda (output error status arguments)
- (xetla-name-split
- (xetla-buffer-content
- output))))))
- (when (interactive-p)
- (message "Ancestor of: %s\n is: %s"
- (xetla-name-construct ancestor)
- (xetla-name-construct revision)))
- ancestor))
-
-;; Copied from ediff-mouse-event-p. I prefer keeping this duplication
-;; to avoid one more dependancy on ediff.el (whose interface may
-;; change one day ...)
-(defsubst xetla-mouse-event-p (event)
- "Return true if EVENT is a mouse-related event."
- (if (featurep 'xemacs)
- (xetla-do-in-xemacs (button-event-p event))
- (xetla-do-in-gnu-emacs
- (string-match "mouse" (format "%S" (event-basic-type event))))))
-
-;; --------------------------------------
-;; Face manipulators
-;; --------------------------------------
-(defun xetla-face-add (str face &optional keymap menu help)
- "Add to string STR the face FACE.
-Optionally, also add the text properties KEYMAP, MENU and HELP.
-
-If KEYMAP is a symbol, (symbol-value KEYMAP) is used
-as a keymap; and `substitute-command-keys' result
-against (format \"\\{%s}\" (symbol-name keymap)) is appended to HELP.
-
-If HELP is nil and if MENU is non nil, the MENU title is used as HELP."
- (if xetla-highlight
- (let* ((strcpy (copy-sequence str))
- (key-help (when (symbolp keymap)
- (substitute-command-keys (format "\\{%s}" (symbol-name keymap)))))
- (prefix-help (if help help (when (and menu (stringp (cadr menu))) (cadr menu))))
- (long-help (if key-help
- (if prefix-help (concat prefix-help "\n"
- ;; Sigh. Font used on tooltips in GNU Emacs with Gtk+
- ;; is a proportional.
- ;; (make-string (length help) ?=) "\n"
- "================" "\n"
- key-help) key-help)
- help))
- (keymap (if (symbolp keymap) (symbol-value keymap) keymap)))
- (add-text-properties 0 (length strcpy)
- `(face ,face
-;;; Even if we define a face in a buffer, it seems that
-;;; font-lock mode just ignore it or remove the face property.
-;;; I don't know the detail but in xetla-inventory buffer,
-;;; I cannot make both font-lock keywords and faces put by tl-face-add
-;;; highlight at once. When font-lock-face is defined, I can do.
-;;; See "Special Properties" subsection in the emacs lisp reference manual.
-;;; `font-lock-face' property is new in Emacs 21.4. However, I guess there is
-;;; no wrong side effect if I define font-lock-face property here.
- font-lock-face ,face
- ,@(when keymap
- `(mouse-face highlight
- keymap ,keymap
- help-echo ,long-help))
- ,@(when menu
- `(menu ,menu))
- )
- strcpy)
- strcpy)
- str))
-
-;; --------------------------------------
-;; Debugging facilities
-;; --------------------------------------
-(defvar xetla-debug t)
-
-(defun xetla-trace (&rest msg)
- "Display the trace message MSG.
-Same as `message' if `xetla-debug' is non-nil.
-Does nothing otherwise. Please use it for your debug messages."
- (when xetla-debug
- (apply 'message (concat "xetla: " (car msg)) (cdr msg))))
-
-(defun xetla-reload (directory)
- "Reloads xetla \(usually for debugging purpose\).
-
-With prefix arg, prompts for the DIRECTORY in which xetla should be
-loaded. Useful to switch from one branch to the other.
-
-If a Makefile is present in the directory where xetla is to be loaded,
-run \"make\"."
- (interactive
- (list (when current-prefix-arg
- (let* ((other (read-directory-name
- "Load XEtla from: "))
- (lispdir (concat (file-name-as-directory other)
- "lisp")))
- (if (file-directory-p lispdir)
- lispdir
- other)))))
- (when directory
- (let ((current-path (file-name-directory (locate-library
- "xetla"))))
- (setq load-path
- (cons directory (remove current-path load-path)))))
- (let ((default-directory (file-name-directory (locate-library "xetla"))))
- (when (file-exists-p
- "Makefile")
- (shell-command "make")))
- (when (featurep 'xetla-tips) (unload-feature 'xetla-tips t))
- (when (featurep 'xetla-browse) (unload-feature 'xetla-browse t))
- (when (featurep 'xetla) (unload-feature 'xetla t))
- (when (featurep 'xetla-core) (unload-feature 'xetla-core t))
- (when (featurep 'xetla-defs) (unload-feature 'xetla-defs t))
- (when (featurep 'xetla-autoloads) (unload-feature 'xetla-autoloads t))
- (ignore-errors (require 'xetla-autoloads))
- (require 'xetla))
-
-;; --------------------------------------
-;; Supports spaces in filenames
-;; --------------------------------------
-(defvar xetla-supports-spaces-in-filenames nil
- "Wether xetla supports spaces in filenames.
-
-Possible values are nil (don't know), 'yes, or 'no. Don't use this
-variable directly. Use `xetla-supports-spaces-in-filenames' instead.")
-
-(defun xetla-supports-spaces-in-filenames ()
- "Wether xetla supports spaces in filenames.
-
-Returns 't or nil.
-
-If `xetla-supports-spaces' is non-nil, use its value. Otherwise, test
-if \"escape\" is listed by \"xetla help\", and memorize the result in
-`xetla-supports-spaces-in-filenames'"
- (interactive)
- (let ((answer
- (cond ((eq xetla-supports-spaces-in-filenames 'yes) t)
- ((eq xetla-supports-spaces-in-filenames 'no) nil)
- (t (xetla-run-tla-sync
- '("help")
- :finished (lambda (output error status arguments)
- (with-current-buffer output
- (goto-char (point-min))
- (search-forward "escape :"
- nil t))))))))
- (when (interactive-p)
- (message (if answer "Yes" "No")))
- (setq xetla-supports-spaces-in-filenames
- (if answer 'yes 'no))
- answer))
-
-(defun xetla-escape (string &optional unescape message)
- "Return the pika escaped value of STRING.
-If pika escaping is not supported by xetla, return STRING.
-If UNESCAPE is non-nil, returns the unescaped version of string.
-If MESSAGE is non-nil or if run interactively, also display the value
-as a message."
- (interactive "sString to escape: ")
- (let ((res (if (and (string-match (if unescape "\\\\"
- "[^a-zA-Z._+,{}-]") string)
- ;; We need to do the (un)escaping
- (xetla-supports-spaces-in-filenames))
- (xetla-run-tla-sync
- (list "escape" (when unescape "--unescaped") string)
- :finished (lambda (output error status arguments)
- (xetla-buffer-content output)))
- string)))
- (when (or (interactive-p) message)
- (message res))
- res))
-
-(defun xetla-unescape (string)
- "Run \"tla escape -unescaped\" on STRING.
-
-Return STRING if \"tla escape\" is not available."
- (interactive "sString to unescape: ")
- (xetla-escape string t (interactive-p)))
-
-(defun xetla-regexp-quote (string)
- "Return a regexp string which matches exactly STRING and nothing else.
-Special characters are escaped to leave STRING in a suitable form for
-Arch."
- (let ((quoted (regexp-quote string)))
- (replace-regexp-in-string
- "\\([{}()|]\\)"
- (concat "\\\\" ; leading slash
- "\\1") ; quoted character
- quoted)))
-
-;; --------------------------------------
-;; Saving and loading state variables
-;; --------------------------------------
-(defun xetla-pp-to-string (sexp)
- "Return sexp pretty printed by `pp-to-string'."
- (let ((print-readably t)
- print-level print-length)
- (pp-to-string sexp)))
-
-(defun xetla-save-state (&optional vars state-file pp)
- "Save variables from VARS list to file STATE-FILE.
-The default for VARS is `xetla-state-variables-list'
-The default for STATE-FILE is `xetla-state-file-name'.
-If PP is non-nil use `xetla-pp-to-string' to format object.
-
-The file will contain a setq setting the vars during loading by
-`xetla-load-state'."
- (let ((state-file (or state-file
- (expand-file-name xetla-state-file-name
- xetla-config-directory)))
- (vars (or vars xetla-state-variables-list))
- v)
- (if (not (file-exists-p (file-name-directory state-file)))
- (make-directory (file-name-directory state-file) t))
- (save-excursion
- (set-buffer (get-buffer-create " *xetla-state*"))
- (erase-buffer)
- (insert ";; Generated file. Do not edit!!!\n(setq\n")
- (if pp
- (while vars
- (setq v (car vars) vars (cdr vars))
- (insert (format "%s\n'%s"
- (symbol-name v)
- (xetla-pp-to-string (symbol-value v)))))
- (while vars
- (setq v (car vars) vars (cdr vars))
- (insert (format " %s '%S\n"
- (symbol-name v)
- (symbol-value v)))))
- (insert " )")
- (write-region (point-min) (point-max) state-file))))
-
-(defun xetla-load-state (&optional state-file)
- "Load `xetla-state-file-name`, i.e. evaluate its content."
- (let ((state-file (or state-file
- (expand-file-name xetla-state-file-name
- xetla-config-directory))))
- (if (file-exists-p state-file)
- (load state-file nil t t))))
-
-;; (setq xetla-archive-tree nil)
-;; (setq xetla-revlib-tree nil)
-
-(provide 'xetla-core)
-;;; xetla-core.el ends here
+++ /dev/null
-;;; xetla-defs.el --- UI XEtla's element definitions
-
-;; Copyright (C) 2003-2004 by Stefan Reichoer (GPL)
-;; Copyright (C) 2004 Steve Youngs (BSD)
-
-;; Author: Steve Youngs <steve@eicq.org>
-;; Maintainer: Steve Youngs <steve@eicq.org>
-;; Created: 2004-11-25
-;; Keywords: arch archive tla
-
-;; Based on xtla-defs.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>
-
-;; In order to keep UI consistency, especially about key binding,
-;; we gather all UI definition in this separated file.
-;;
-
-
-;;; History:
-;;
-
-;;; Code:
-
-(eval-when-compile
- (require 'cl))
-
-(eval-and-compile
- (autoload 'ad-add-advice "advice")
- (require 'ediff)
- (require 'diff-mode)
- (require 'font-lock)
- (require 'add-log)
- (require 'ffap)
- (require 'easymenu))
-
-;; Macros to generate correct code for different emacs variants
-;; This doesn't really belong here, but then again it doesn't "fit"
-;; anywhere else.
-;;;###autoload
-(defmacro xetla-do-in-gnu-emacs (&rest body)
- "Execute BODY if in GNU/Emacs."
- (unless running-xemacs `(progn ,@body)))
-(put 'xetla-do-in-gnu-emacs 'lisp-indent-hook 'defun)
-
-;;;###autoload
-(defmacro xetla-do-in-xemacs (&rest body)
- "Execute BODY if in XEmacs."
- (when running-xemacs `(progn ,@body)))
-(put 'xetla-do-in-xemacs 'lisp-indent-hook 'defun)
-
-(defmacro xetla-funcall-if-exists (function &rest args)
- "Call FUNCTION with ARGS as parameters if it exists."
- (if (fboundp function)
- `(funcall ',function ,@args)))
-
-(defun xetla-clone-process (process &optional newname)
- "Create a twin copy of PROCESS.
-If NEWNAME is nil, it defaults to PROCESS' name;
-NEWNAME is modified by adding or incrementing <N> at the end as necessary.
-If PROCESS is associated with a buffer, the new process will be associated
- with the current buffer instead.
-Returns nil if PROCESS has already terminated."
- (setq newname (or newname (process-name process)))
- (if (string-match "<[0-9]+>\\'" newname)
- (setq newname (substring newname 0 (match-beginning 0))))
- (when (memq (process-status process) '(run stop open))
- (let* ((process-connection-type (process-tty-name process))
- (old-kwoq (process-kill-without-query process nil))
- (new-process
- (if (memq (process-status process) '(open))
- (apply 'open-network-stream newname
- (if (process-buffer process) (current-buffer)))
- (apply 'start-process newname
- (if (process-buffer process) (current-buffer))
- (process-command process)))))
- (process-kill-without-query new-process old-kwoq)
- (process-kill-without-query process old-kwoq)
- (set-process-filter new-process (process-filter process))
- (set-process-sentinel new-process (process-sentinel process))
- new-process)))
-
-(defun-when-void clone-buffer (&optional newname display-flag)
- "Create a twin copy of the current buffer.
-If NEWNAME is nil, it defaults to the current buffer's name;
-NEWNAME is modified by adding or incrementing <N> at the end as necessary.
-
-If DISPLAY-FLAG is non-nil, the new buffer is shown with `pop-to-buffer'.
-This runs the normal hook `clone-buffer-hook' in the new buffer
-after it has been set up properly in other respects."
- (interactive (list (if current-prefix-arg (read-string "Name: "))
- t))
- (if buffer-file-name
- (error "Cannot clone a file-visiting buffer"))
- (if (get major-mode 'no-clone)
- (error "Cannot clone a buffer in %s mode" mode-name))
- (setq newname (or newname (buffer-name)))
- (if (string-match "<[0-9]+>\\'" newname)
- (setq newname (substring newname 0 (match-beginning 0))))
- (let ((buf (current-buffer))
- (ptmin (point-min))
- (ptmax (point-max))
- (pt (point))
- (mk (mark t))
- (modified (buffer-modified-p))
- (mode major-mode)
- (lvars (buffer-local-variables))
- (process (get-buffer-process (current-buffer)))
- (new (generate-new-buffer (or newname (buffer-name)))))
- (save-restriction
- (widen)
- (with-current-buffer new
- (insert-buffer-substring buf)))
- (with-current-buffer new
- (narrow-to-region ptmin ptmax)
- (goto-char pt)
- (if mk (set-mark mk))
- (set-buffer-modified-p modified)
-
- ;; Clone the old buffer's process, if any.
- (when process (xetla-clone-process process))
-
- ;; Now set up the major mode.
- (funcall mode)
-
- ;; Set up other local variables.
- (mapcar (lambda (v)
- (condition-case () ;in case var is read-only
- (if (symbolp v)
- (makunbound v)
- (set (make-local-variable (car v)) (cdr v)))
- (error nil)))
- lvars)
-
- ;; Run any hooks (typically set up by the major mode
- ;; for cloning to work properly).
- (run-hooks 'clone-buffer-hook))
- (if display-flag (pop-to-buffer new))
- new))
-
-
-;; --------------------------------------
-;; Key bindings
-;; --------------------------------------
-;;
-;; Conventions
-;;
-;; - Meta Rules:
-;; 0. If you feel a binding odd more than 3 times, report it to xetla dev mailing
-;; list. Especially about some danger functions like undo, merge; and functions
-;; taking longer time to be executed.
-;;
-;; 1. Our key binding should not surprise "general users" even if the
-;; binding is convenience. Instead, provide hooks for customization.
-;; We know it is difficult to define "general users".
-;;
-;; 2. Write the result of discussion here.
-;;
-;; 3. See http://mail.gnu.org/archive/html/emacs-devel/2004-03/msg00608.html
-;;
-;;
-;; - Generic Rules:
-;;
-;; 1. xetla-inventory should have similar key bindings to pcl-cvs.
-;; If a pcl-cvs's binding is too odd, talk it in xetla dev mailing list.
-;;
-;; 2. Define common prefix for command groups like '>'.
-;; So a key binding for a grouped command has following structure:
-;;
-;; ?{prefix} ?{suffix}
-;;
-;; e.g. `get something commands' should have `>' as prefix.
-;;
-;; About suffix part, ? should show the help for the groups.
-;;
-;; e.g. `help for `get something commands'' is >?.
-;;
-;; BTW, The prefix ? is for help related command.
-;; So `? >' can stand for "show the help for get-something related
-;; command". In other word, prefix and suffix is swappable if
-;; prefix or suffix is `?'.
-;;
-;; 3. Upper case for commands taking longer time to be executed.
-;; 4. Lower case for commands taking shorter time to be executed.
-;; 5. dired's binding is also helpful.
-;;
-;;
-;; - Concrete Rules:
-;;
-
-;; t ? list all toggles
-;; c xetla-edit-log
-;; RET Open the thing at point
-;;
-
-;;
-;; Definitions for key concrete rules
-;;
-
-;; common keys
-(defvar xetla-key-help ??) ; help
-(defvar xetla-key-mark-prefix ?*) ; other mark related command prefix
-(defvar xetla-key-apply-from-here ?.) ; apply something from here
-(defvar xetla-key-add-bookmark ?b) ; add this to bookmark
-(defvar xetla-key-get ?>) ; prefix for getting something
-(defvar xetla-key-reflect ?<) ; mirror, apply, install...
-(defvar xetla-key-parent ?^) ; visit uppper XX. e.g. directory
-(defvar xetla-key-apply-from-head ?@) ; Do something head revision
-(defvar xetla-key-diff ?=) ; one shot
-
-(defvar xetla-key-add ?a) ; prefix for adding something
-(defvar xetla-key-show-bookmark ?b) ; show bookmark
-(defvar xetla-key-diff-prefix ?d)
-(defvar xetla-key-file-diff ?d)
-(defvar xetla-key-tree-lint ?l)
-(defvar xetla-key-logs ?L)
-(defvar xetla-key-ediff ?e)
-(defvar xetla-key-log-entry ?a)
-(defvar xetla-key-refresh ?g) ; refresh buffer
-(defvar xetla-key-inventory ?i) ; inventory
-(defvar xetla-key-mark ?m) ; mark
-(defvar xetla-key-next ?n) ; next item
-(defvar xetla-key-previous ?p) ; previous item
-(defvar xetla-key-quit ?q) ; quit
-(defvar xetla-key-remove ?r) ; prefix for remove something
-(defvar xetla-key-move ?R) ; prefix for move/rename something
-(defvar xetla-key-toggle ?t) ; prefix for toggle
-(defvar xetla-key-unmark ?u) ; unmark
-(defvar xetla-key-popup-menu ?\C-j)
-(defvar xetla-key-kill-ring-prefix ?w)
-(defvar xetla-key-commit ?c) ; actually edit-log, but
- ; that's what you do when you
- ; want to commit.
-(defvar xetla-key-update ?u) ; to run tla update
-(defvar xetla-key-replay ?r) ; to run tla replay
-(defvar xetla-key-star-merge ?s) ; to run tla star-merge
-(defvar xetla-key-missing ?m) ; to run tla missing
-
-(defvar xetla-key-buffer-prefix ?B) ; perfix for switching XX buffer
-(defvar xetla-key-directory-prefix ?D)
-(defvar xetla-key-merge-prefix ?M)
-(defvar xetla-key-tag ?T)
-(defvar xetla-key-revert ?U)
-(defvar xetla-key-working-copy ?W) ; Affecting on working copy
-(defvar xetla-key-partner-file-prefix ?f)
-(defvar xetla-key-tagging-method-prefix ?#)
-(defvar xetla-key-id ?i)
-
-;; functions for creating key groups
-(defun xetla-key-group (prefix &rest keys)
- (apply 'vector prefix keys))
-
-(defun xetla-prefix-toggle (&rest keys)
- (xetla-key-group xetla-key-toggle keys))
-
-(defun xetla-prefix-add (&rest keys)
- (xetla-key-group xetla-key-add keys))
-
-(defun xetla-prefix-remove (&rest keys)
- (xetla-key-group xetla-key-remove keys))
-
-(defun xetla-prefix-move (&rest keys)
- (xetla-key-group xetla-key-move keys))
-
-(defun xetla-prefix-apply-from-here (&rest keys)
- (xetla-key-group xetla-key-apply-from-here keys))
-
-(defun xetla-prefix-apply-from-head (&rest keys)
- (xetla-key-group xetla-key-apply-from-head keys))
-
-(defun xetla-prefix-mark (&rest keys)
- (xetla-key-group xetla-key-mark-prefix keys))
-
-(defun xetla-prefix-diff (&rest keys)
- (xetla-key-group xetla-key-diff-prefix keys))
-
-(defun xetla-prefix-merge (&rest keys)
- (xetla-key-group xetla-key-merge-prefix keys))
-
-(defun xetla-prefix-directory (&rest keys)
- (xetla-key-group xetla-key-directory-prefix keys))
-
-(defun xetla-prefix-kill-ring (&rest keys)
- (xetla-key-group xetla-key-kill-ring-prefix keys))
-
-(defun xetla-prefix-buffer (&rest keys)
- (xetla-key-group xetla-key-buffer-prefix keys))
-
-(defun xetla-prefix-working-copy (&rest keys)
- (xetla-key-group xetla-key-working-copy keys))
-
-(defun xetla-prefix-partner-file (&rest keys)
- (xetla-key-group xetla-key-partner-file-prefix keys))
-
-(defun xetla-prefix-tag (&rest keys)
- (xetla-key-group xetla-key-tag keys))
-
-(defun xetla-prefix-tagging-method (&rest keys)
- (xetla-key-group xetla-key-tagging-method-prefix keys))
-
-;; predefined key vectors
-(defvar xetla-keyvec-toggle-set (xetla-prefix-toggle ?+))
-(defvar xetla-keyvec-toggle-reset (xetla-prefix-toggle ?-))
-(defvar xetla-keyvec-toggle-invert (xetla-prefix-toggle ?~))
-
-
-(defvar xetla-keyvec-help (vector xetla-key-help))
-(defvar xetla-keyvec-parent (vector xetla-key-parent))
-(defvar xetla-keyvec-add (vector xetla-key-add))
-(defvar xetla-keyvec-remove (vector xetla-key-remove))
-(defvar xetla-keyvec-get (vector xetla-key-get))
-(defvar xetla-keyvec-refresh (vector xetla-key-refresh))
-
-(defvar xetla-keyvec-next (vector xetla-key-next))
-(defvar xetla-keyvec-previous (vector xetla-key-previous))
-
-(defvar xetla-keyvec-mark (vector xetla-key-mark))
-(defvar xetla-keyvec-unmark (vector xetla-key-unmark))
-(defvar xetla-keyvec-mark-all (xetla-prefix-mark ?*))
-(defvar xetla-keyvec-unmark-all (xetla-prefix-mark ?!))
-(defvar xetla-keyvec-quit (vector xetla-key-quit))
-(defvar xetla-keyvec-popup-menu (vector xetla-key-popup-menu))
-
-
-
-(defvar xetla-keyvec-ediff (vector xetla-key-ediff))
-
-(defvar xetla-keyvec-tree-lint (vector xetla-key-tree-lint))
-
-(defvar xetla-keyvec-logs (vector xetla-key-logs))
-
-(defvar xetla-keyvec-log-entry (vector xetla-key-log-entry))
-
-(defvar xetla-keyvec-diff (vector xetla-key-diff))
-
-(defvar xetla-keyvec-file-diff (vector xetla-key-file-diff))
-
-(defvar xetla-keyvec-file-diff (vector xetla-key-file-diff))
-
-(defvar xetla-keyvec-commit (vector xetla-key-commit))
-
-(defvar xetla-keyvec-update (vector xetla-key-update))
-(defvar xetla-keyvec-replay (vector xetla-key-replay))
-(defvar xetla-keyvec-star-merge (vector xetla-key-star-merge))
-
-(defvar xetla-keyvec-reflect (vector xetla-key-reflect))
-(defvar xetla-keyvec-revert (vector xetla-key-revert))
-
-
-(defvar xetla-keyvec-inventory (vector xetla-key-inventory))
-
-
-(defvar xetla-keyvec-show-bookmark (vector xetla-key-show-bookmark))
-(defvar xetla-keyvec-add-bookmark (vector xetla-key-add-bookmark))
-
-(defvar xetla-keyvec-tag (vector xetla-key-tag))
-(defvar xetla-keyvec-kill-ring (vector xetla-key-kill-ring-prefix))
-
-(defvar xetla-keyvec-id (vector xetla-key-id))
-(defvar xetla-keyvec-toggle (vector xetla-key-toggle))
-;;
-;; Global
-;;
-
-(defvar xetla-global-keymap
- (let ((map (make-sparse-keymap)))
- (define-key map xetla-keyvec-log-entry 'xetla-add-log-entry)
- (define-key map [?A] 'xetla-archives)
- (define-key map xetla-keyvec-show-bookmark 'xetla-bookmarks)
- (define-key map xetla-keyvec-file-diff 'xetla-file-diff)
- (define-key map xetla-keyvec-ediff 'xetla-file-ediff)
- (define-key map [?o] 'xetla-file-view-original)
- (define-key map xetla-keyvec-diff 'xetla-changes)
- (define-key map xetla-keyvec-commit 'xetla-edit-log)
- (define-key map [?t] 'xetla-tag-insert)
- (define-key map xetla-keyvec-inventory 'xetla-inventory)
- (define-key map [?r] 'xetla-tree-revisions)
- (define-key map xetla-keyvec-logs 'xetla-logs)
- (define-key map xetla-keyvec-tree-lint 'xetla-tree-lint)
- (define-key map xetla-keyvec-update 'xetla-update)
- (define-key map xetla-keyvec-help 'xetla-help)
- map)
- "Global keymap used by Xetla.")
-
-
-(define-key ctl-x-4-map [?T] 'xetla-add-log-entry)
-
-;;
-;; Minibuffer(for reading engine)
-;;
-(defvar xetla-name-read-partner-menu (cons "Insert Partner Version" nil))
-(fset 'xetla-name-read-partner-menu (cons 'keymap xetla-name-read-partner-menu))
-(defvar xetla-name-read-bookmark-menu (cons "Insert Version in Bookmarks" nil))
-(fset 'xetla-name-read-bookmark-menu (cons 'keymap xetla-name-read-bookmark-menu))
-
-
-(defvar xetla-name-read-extension-keydefs
- '(([(control r)] . xetla-name-read-refresh-cache)
- ([(meta *)] . xetla-name-read-insert-default-archive)
- ([(meta \.)] . xetla-name-read-insert-info-at-point)
- ([(meta \;)] . xetla-name-read-insert-version-associated-with-default-directory)
- ([(control n)] . xetla-name-read-insert-partner-next)
- ([(control p)] . xetla-name-read-insert-partner-previous)
- ([(control v)] . xetla-name-read-insert-bookmark-next)
- ([(meta v)] . xetla-name-read-insert-bookmark-previous)
- ([(meta ^)] . xetla-name-read-insert-ancestor)
- ([(control h)] . xetla-name-read-help)
- ([(meta \?)] . xetla-name-read-inline-help))
- "Key definitions table for `xetla-name-read-minibuf-map'.
-The reason these definitions are defined separately from
-`xetla-name-read-minibuf-map' is that to reuse these definitions
-in `xetla-name-read-help'. Don't forget to evalute
-`xetla-name-read-minibuf-map' again after updating this value.")
-
-
-(defvar xetla-name-read-minibuf-map
- (let ((map (copy-keymap minibuffer-local-completion-map)))
- ;; Keys
- (mapc
- (lambda (pair)
- (let ((key (car pair))
- (func (cdr pair)))
- (define-key map key func)))
- xetla-name-read-extension-keydefs)
- ;; Menus
- (define-key map [menu-bar xetla]
- (cons "XEtla" (make-sparse-keymap "XEtla")))
- (define-key map [menu-bar xetla refresh]
- (list 'menu-item "Refresh Completion Cache"
- 'xetla-name-read-refresh-cache))
- (define-key map [menu-bar xetla ancestor]
- (list 'menu-item "Insert Ancestor"
- 'xetla-name-read-insert-ancestor
- :enable '(and
- (window-minibuffer-p)
- (equal "" (buffer-substring))
- (member archive '(prompt maybe))
- (not (eq this-command 'xetla-compute-direct-ancestor))
- )))
- (define-key map [menu-bar xetla default]
- (list 'menu-item "Insert Default Archive"
- 'xetla-name-read-insert-default-archive
- :enable '(and
- (window-minibuffer-p)
- (equal "" (buffer-substring))
- (member archive '(prompt maybe)))))
- (define-key map [menu-bar xetla here]
- (list 'menu-item "Insert Thing at Point"
- 'xetla-name-read-insert-info-at-point
- :enable '(and (window-minibuffer-p)
- (equal "" (buffer-substring))
- xetla-name-read-insert-info-at-point)))
- (define-key map [menu-bar xetla bookmark]
- (list 'menu-item "Insert Version in Bookmark" 'xetla-name-read-bookmark-menu
- :enable '(let* ((l (condition-case nil
- (let ((default-version (xetla-tree-version-list default-directory)))
- (xetla-bookmarks-get-partner-versions default-version))
- (error nil))))
- (and l (< 0 (length l))))))
- (define-key map [menu-bar xetla partner]
- (list 'menu-item "Insert Partner Version" 'xetla-name-read-partner-menu
- :enable '(let* ((l (condition-case nil (xetla-partner-list)
- (error nil))))
- (and l (< 0 (length l))))))
- map)
- "Keymap to input a gnuarch revision at the minibuffer.")
-
-;;
-;; Context keymap template
-;;
-(defvar xetla-context-map-template
- (let ((map (make-sparse-keymap)))
- ;; TODO: [return[, "\C-m" => xetla-generic-context-action
- (define-key map (xetla-prefix-apply-from-here xetla-key-help) 'describe-bindings)
- (define-key map xetla-keyvec-help 'describe-mode)
- (define-key map [button3] 'xetla-generic-popup-menu)
- (define-key map xetla-keyvec-popup-menu 'xetla-generic-popup-menu-by-keyboard)
- map)
- "Template for keymaps used in items, files, changes, etc.")
-
-;;
-;; Bookmarks mode
-;;
-(defvar xetla-bookmarks-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map xetla-keyvec-help 'describe-mode)
- ;; Move
- (define-key map xetla-keyvec-next 'xetla-bookmarks-next)
- (define-key map xetla-keyvec-previous 'xetla-bookmarks-previous)
- (define-key map [?N] 'xetla-bookmarks-move-down)
- (define-key map [?P] 'xetla-bookmarks-move-up)
- ;; Actions
- (define-key map (xetla-prefix-merge xetla-key-star-merge)
- 'xetla-bookmarks-star-merge)
- (define-key map (xetla-prefix-merge xetla-key-replay)
- 'xetla-bookmarks-replay)
- (define-key map (xetla-prefix-merge xetla-key-update)
- 'xetla-bookmarks-update)
- (define-key map (xetla-prefix-merge xetla-key-missing)
- 'xetla-bookmarks-missing)
- (define-key map (xetla-prefix-merge xetla-key-tag)
- 'xetla-bookmarks-tag)
- (define-key map [?o] 'xetla-bookmarks-open-tree)
- (define-key map [(control x) (control f)] 'xetla-bookmarks-find-file)
- (define-key map xetla-keyvec-diff 'xetla-bookmarks-changes)
- (define-key map xetla-keyvec-get 'xetla-bookmarks-get)
- (define-key map "\C-m" 'xetla-bookmarks-goto)
- ;; Marks
- (define-key map xetla-keyvec-mark 'xetla-bookmarks-mark)
- (define-key map xetla-keyvec-unmark 'xetla-bookmarks-unmark)
- (define-key map xetla-keyvec-unmark-all 'xetla-bookmarks-unmark-all)
- (define-key map (xetla-prefix-mark ?g) 'xetla-bookmarks-select-by-group)
- ;; Partners
- (define-key map [(meta p)] 'xetla-bookmarks-marked-are-partners)
- (define-key map (xetla-prefix-add ?p)
- 'xetla-bookmarks-add-partner-interactive)
- (define-key map (xetla-prefix-remove ?p)
- 'xetla-bookmarks-delete-partner-interactive)
- (define-key map (xetla-prefix-partner-file ?r)
- 'xetla-bookmarks-add-partners-from-file)
- (define-key map (xetla-prefix-partner-file ?w)
- 'xetla-bookmarks-write-partners-to-file)
- ;; Bookmark manipulation
- (define-key map (xetla-prefix-add ?b) 'xetla-bookmarks-add)
- (define-key map (xetla-prefix-remove ?b) 'xetla-bookmarks-delete)
- (define-key map [?e] 'xetla-bookmarks-edit)
- (define-key map xetla-keyvec-toggle 'xetla-bookmarks-toggle-details)
- ;; Fields
- (define-key map (xetla-prefix-add ?t) 'xetla-bookmarks-add-tree-interactive)
- (define-key map (xetla-prefix-remove ?t) 'xetla-bookmarks-delete-tree-interactive)
- (define-key map (xetla-prefix-add ?g) 'xetla-bookmarks-add-group-interactive)
- (define-key map (xetla-prefix-remove ?g) 'xetla-bookmarks-delete-group-interactive)
- (define-key map (xetla-prefix-add ?n) 'xetla-bookmarks-add-nickname-interactive)
- (define-key map (xetla-prefix-remove ?n) 'xetla-bookmarks-delete-nickname-interactive)
- ;; Switch to other buffers
- (define-key map xetla-keyvec-inventory 'xetla-bookmarks-inventory)
- (define-key map (xetla-prefix-buffer ?p) 'xetla-show-process-buffer)
- (define-key map (xetla-prefix-buffer ?L) 'xetla-open-internal-log-buffer)
- (define-key map xetla-keyvec-quit 'xetla-buffer-quit)
- map)
- "Keymap used in `xetla-bookmarks-mode' buffers.")
-
-(defvar xetla-bookmarks-entry-map
- (let ((map (copy-keymap xetla-context-map-template)))
- (define-key map [button2] 'xetla-bookmarks-goto-by-mouse)
- map)
- "Keymap used on entries in `xetla-bookmarks-mode' buffers.")
-
-;;
-;; Inventory mode
-;;
-(defvar xetla-inventory-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map xetla-keyvec-help 'describe-mode)
- (define-key map xetla-keyvec-refresh 'xetla-generic-refresh)
- (define-key map xetla-keyvec-add 'xetla-inventory-add-files)
- (define-key map xetla-keyvec-remove 'xetla-inventory-remove-files)
- (define-key map xetla-keyvec-quit 'xetla-buffer-quit)
- (define-key map xetla-keyvec-next 'xetla-inventory-next)
- (define-key map xetla-keyvec-previous 'xetla-inventory-previous)
- (define-key map xetla-keyvec-parent 'xetla-inventory-parent-directory)
- ;;
- ;;
- ;;
- (define-key map [?X] 'xetla-inventory-delete-files)
- (define-key map (xetla-prefix-move xetla-key-move) 'xetla-inventory-move)
- (define-key map xetla-keyvec-commit 'xetla-inventory-edit-log) ;; mnemonic for commit
- (define-key map [?l] 'xetla-changelog)
- (define-key map xetla-keyvec-logs 'xetla-logs)
- ;;
- ;; Find file group
- ;;
- (define-key map [?f] 'xetla-inventory-find-file)
- (define-key map [return] 'xetla-inventory-find-file)
- (define-key map "\C-m" 'xetla-inventory-find-file)
- (define-key map [?o] 'xetla-generic-find-file-other-window)
- (define-key map [?v] 'xetla-generic-view-file)
- ;;
- ;; Diffs group
- ;;
- (define-key map (xetla-prefix-merge xetla-key-missing)
- 'xetla-inventory-missing)
- (define-key map (xetla-prefix-diff xetla-key-diff)
- 'xetla-inventory-changes)
- (define-key map (xetla-prefix-diff ?l) 'xetla-changes-last-revision)
- (define-key map (xetla-prefix-diff xetla-key-ediff)
- 'xetla-inventory-file-ediff)
- (define-key map (xetla-prefix-diff xetla-key-get)
- 'xetla-inventory-delta)
- ;; Alias for above bindings
- (define-key map xetla-keyvec-diff 'xetla-inventory-changes)
- (define-key map xetla-keyvec-ediff 'xetla-inventory-file-ediff)
- ;;
- (define-key map xetla-keyvec-reflect 'xetla-inventory-mirror)
- ;;
- ;; Merge group
- ;;
- (define-key map (xetla-prefix-merge xetla-key-star-merge)
- 'xetla-inventory-star-merge)
- (define-key map (xetla-prefix-merge xetla-key-replay)
- 'xetla-inventory-replay)
- (define-key map (xetla-prefix-merge xetla-key-update)
- 'xetla-inventory-update)
- (define-key map (xetla-prefix-merge xetla-key-reflect)
- 'xetla-inventory-apply-changeset)
- ;;
- ;; Buffers group
- ;;
- (define-key map (xetla-prefix-buffer ?p) 'xetla-show-process-buffer)
- (define-key map (xetla-prefix-buffer ?L) 'xetla-open-internal-log-buffer)
- (define-key map (xetla-prefix-buffer xetla-key-show-bookmark) 'xetla-bookmarks)
- ;;
- ;; Undo and redo group
- ;;
- (define-key map xetla-keyvec-revert 'xetla-inventory-revert)
- (define-key map (xetla-prefix-working-copy xetla-key-revert) 'xetla-inventory-undo)
- (define-key map (xetla-prefix-working-copy ?R) 'xetla-inventory-redo)
- ;;
- ;; Patches group
- ;;
- (define-key map (xetla-prefix-working-copy ?S) 'xetla-changes-save)
- (define-key map (xetla-prefix-working-copy ?s) 'xetla-changes-save-as-tgz)
- (define-key map (xetla-prefix-working-copy ?V) 'xetla-show-changeset)
- (define-key map (xetla-prefix-working-copy ?v) 'xetla-show-changeset-from-tgz)
- (define-key map (xetla-prefix-working-copy ?A) 'xetla-inventory-apply-changeset)
- (define-key map (xetla-prefix-working-copy ?a) 'xetla-inventory-apply-changeset-from-tgz)
- ;;
- ;; Kill ring group
- ;;
- (define-key map (xetla-prefix-kill-ring ?a) 'xetla-save-archive-to-kill-ring)
- ;;
- ;; Tree lint
- ;;
- (define-key map (xetla-prefix-working-copy xetla-key-tree-lint)
- 'xetla-tree-lint)
- ;;
- ;; Mark group
- ;;
- (define-key map (xetla-prefix-mark xetla-key-mark) 'xetla-inventory-mark-file)
- (define-key map (xetla-prefix-mark xetla-key-unmark) 'xetla-inventory-unmark-file)
- ;; (define-key map xetla-keyvec-mark-all 'xetla-inventory-mark-all)
- (define-key map xetla-keyvec-unmark-all 'xetla-inventory-unmark-all)
- ;; Alias for above bindings
- (define-key map xetla-keyvec-mark 'xetla-inventory-mark-file)
- (define-key map xetla-keyvec-unmark 'xetla-inventory-unmark-file)
- ;;
- ;; Tagging method
- ;;
- (define-key map (xetla-prefix-tagging-method ?=) 'xetla-edit-=tagging-method-file)
- (define-key map (xetla-prefix-tagging-method ?.) 'xetla-edit-.arch-inventory-file)
- ;;
- ;; Exclude, junk, precious, unrecognized...
- ;;
- (define-key map (xetla-prefix-move ?j) 'xetla-inventory-make-junk)
- (define-key map (xetla-prefix-move ?,) 'xetla-inventory-make-junk)
- (define-key map (xetla-prefix-move ?p) 'xetla-inventory-make-precious)
- (define-key map (xetla-prefix-move ?+) 'xetla-inventory-make-precious)
- (define-key map (xetla-prefix-tagging-method ?M) 'xetla-generic-set-id-tagging-method)
- (define-key map (xetla-prefix-tagging-method ?V) 'xetla-generic-set-tree-version)
- (define-key map (xetla-prefix-tagging-method ?x) 'xetla-generic-add-to-exclude) ; alias
- (define-key map (xetla-prefix-tagging-method ?e) 'xetla-generic-add-to-exclude) ; alias
- (define-key map (xetla-prefix-tagging-method ?j) 'xetla-generic-add-to-junk)
- (define-key map (xetla-prefix-tagging-method ?b) 'xetla-generic-add-to-backup)
- (define-key map (xetla-prefix-tagging-method ?~) 'xetla-generic-add-to-backup) ; alias
- (define-key map (xetla-prefix-tagging-method ?p) 'xetla-generic-add-to-precious)
- (define-key map (xetla-prefix-tagging-method ?u) 'xetla-generic-add-to-unrecognized)
- ;;
- ;; Toggles
- ;;
- (define-key map xetla-keyvec-toggle-set 'xetla-inventory-set-all-toggle-variables)
- (define-key map xetla-keyvec-toggle-reset 'xetla-inventory-reset-all-toggle-variables)
- (define-key map xetla-keyvec-toggle-invert 'xetla-inventory-toggle-all-toggle-variables)
- map)
- "Keymap used in `xetla-inventory-mode' buffers.")
-
-(defvar xetla-inventory-item-map
- (let ((map (copy-keymap xetla-context-map-template)))
- (define-key map [button2] 'xetla-inventory-find-file-by-mouse)
- map)
- "Keymap used on items in `xetla-inventory-mode' buffers.")
-
-(defvar xetla-inventory-default-version-map
- (let ((map (copy-keymap xetla-context-map-template)))
- (define-key map [return] 'xetla-generic-set-tree-version)
- (define-key map "\C-m" 'xetla-generic-set-tree-version)
- map)
- "Keymap used on the default version field in `xetla-inventory-mode' buffers.")
-
-(defvar xetla-inventory-tagging-method-map
- (let ((map (copy-keymap xetla-context-map-template)))
- (define-key map [button2] 'xetla-generic-set-id-tagging-method-by-mouse)
- (define-key map [return] 'xetla-generic-set-id-tagging-method)
- (define-key map "\C-m" 'xetla-inventory-id-tagging-method)
- map)
- "Keymap used on the tagging method field in `xetla-inventory-mode' buffers.")
-
-
-(defconst xetla-inventory-file-types-manipulators
- '((?S xetla-inventory-display-source
- xetla-inventory-toggle-source ?s "source")
- (?P xetla-inventory-display-precious
- xetla-inventory-toggle-precious ?p "precious")
- (?J xetla-inventory-display-junk
- xetla-inventory-toggle-junk ?j "junk")
- (?B xetla-inventory-display-backup
- xetla-inventory-toggle-backup ?b "backup")
- (?T xetla-inventory-display-tree
- xetla-inventory-toggle-tree ?t "tree root")
- (?U xetla-inventory-display-unrecognized
- xetla-inventory-toggle-unrecognized ?u "unrecognized"))
- "List of possible file types in inventory.")
-
-(dolist (type-arg xetla-inventory-file-types-manipulators)
- (define-key xetla-inventory-mode-map `[?t ,(cadddr type-arg)] (caddr type-arg)))
-
-
-(dolist (type-arg xetla-inventory-file-types-manipulators)
- (eval `(defcustom ,(cadr type-arg) t
- ,(concat "Whether " (nth 4 type-arg)
- " should be printed in inventory")
- :group 'xetla-inventory
- :type 'boolean)))
-
-(defvar xetla-tree-lint-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map xetla-keyvec-help 'describe-mode)
- (define-key map xetla-keyvec-refresh 'xetla-generic-refresh)
- (define-key map xetla-keyvec-add 'xetla-tree-lint-add-files)
- (define-key map xetla-keyvec-remove 'xetla-tree-lint-delete-files)
- (define-key map xetla-keyvec-quit 'xetla-buffer-quit)
- (define-key map xetla-keyvec-next 'xetla-tree-lint-next)
- (define-key map xetla-keyvec-previous 'xetla-tree-lint-previous)
- (define-key map [down] 'xetla-tree-lint-next)
- (define-key map [up] 'xetla-tree-lint-previous)
- (define-key map xetla-keyvec-id 'xetla-tree-lint-regenerate-id)
- (define-key map (xetla-prefix-move ?j) 'xetla-tree-lint-make-junk)
- (define-key map (xetla-prefix-move ?,) 'xetla-tree-lint-make-junk)
- (define-key map (xetla-prefix-move ?p) 'xetla-tree-lint-make-precious)
- (define-key map (xetla-prefix-move ?+) 'xetla-tree-lint-make-precious)
- ;;
- (define-key map (xetla-prefix-tagging-method ?=) 'xetla-edit-=tagging-method-file)
- (define-key map (xetla-prefix-tagging-method ?.) 'xetla-edit-.arch-inventory-file)
- (define-key map (xetla-prefix-tagging-method ?M) 'xetla-generic-set-id-tagging-method)
- (define-key map (xetla-prefix-tagging-method ?V) 'xetla-generic-set-tree-version)
- (define-key map (xetla-prefix-tagging-method ?x) 'xetla-generic-add-to-exclude) ; alias
- (define-key map (xetla-prefix-tagging-method ?e) 'xetla-generic-add-to-exclude) ; alias
- (define-key map (xetla-prefix-tagging-method ?j) 'xetla-generic-add-to-junk)
- (define-key map (xetla-prefix-tagging-method ?b) 'xetla-generic-add-to-backup)
- (define-key map (xetla-prefix-tagging-method ?~) 'xetla-generic-add-to-backup) ; alias
- (define-key map (xetla-prefix-tagging-method ?p) 'xetla-generic-add-to-precious)
- (define-key map (xetla-prefix-tagging-method ?u) 'xetla-generic-add-to-unrecognized)
- ;;
- (define-key map [return] 'xetla-generic-find-file-at-point)
- (define-key map "\C-m" 'xetla-generic-find-file-at-point)
- (define-key map [?o] 'xetla-generic-find-file-other-window)
- (define-key map [?v] 'xetla-generic-view-file)
- ;;
- ;; Mark group
- ;;
- (define-key map (xetla-prefix-mark xetla-key-mark) 'xetla-tree-lint-mark-file)
- (define-key map (xetla-prefix-mark xetla-key-unmark) 'xetla-tree-lint-unmark-file)
- ;; TODO
- ;; (define-key map xetla-keyvec-mark-all 'xetla-tree-lint-mark-all)
- (define-key map xetla-keyvec-unmark-all 'xetla-tree-lint-unmark-all)
- ;; Alias for above bindings
- (define-key map xetla-keyvec-mark 'xetla-tree-lint-mark-file)
- (define-key map xetla-keyvec-unmark 'xetla-tree-lint-unmark-file)
- ;;
- ;; Buffers group
- ;;
- (define-key map (xetla-prefix-buffer ?p) 'xetla-show-process-buffer)
- (define-key map (xetla-prefix-buffer ?L) 'xetla-open-internal-log-buffer)
- (define-key map (xetla-prefix-buffer xetla-key-show-bookmark) 'xetla-bookmarks)
- map)
- "Keymap used in `xetla-tree-lint-mode' buffers.")
-
-(defvar xetla-tree-lint-file-map
- (let ((map (copy-keymap xetla-context-map-template)))
- (define-key map [button2] 'xetla-generic-find-file-at-point-by-mouse)
- map)
- "Keymap used on files in xetla-lint-mode buffers.")
-
-;;
-;; Cat-Log mdoe
-;;
-(defvar xetla-cat-log-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map xetla-keyvec-help 'describe-mode)
- (define-key map xetla-keyvec-inventory 'xetla-pop-to-inventory)
- (define-key map xetla-keyvec-quit 'xetla-buffer-quit)
- map)
- "Keymap used in `xetla-cat-log-mode' buffers.")
-
-;;
-;; Log edit mode
-;;
-(defvar xetla-log-edit-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map [(control ?c) (control ?c)] 'xetla-log-edit-done)
- (define-key map [(control ?c) (control ?d)] 'xetla-changes)
- (define-key map [(control ?c) (control ?l)] 'xetla-changelog)
- (define-key map [(control ?c) (control ?m)] 'xetla-log-edit-insert-log-for-merge)
- (define-key map [(control ?c) ?m ]
- 'xetla-log-edit-insert-log-for-merge-and-headers)
- (define-key map [(control ?c) (control ?p)] 'xetla-log-edit-insert-memorized-log)
- (define-key map [(control ?c) (control ?q)] 'xetla-log-edit-abort)
- (define-key map [(control ?c) (control ?s)] 'xetla-log-goto-summary)
- (define-key map [(control ?c) (control ?b)] 'xetla-log-goto-body)
- (define-key map [(control ?c) (control ?k)] 'xetla-log-edit-keywords)
- (define-key map "\t" 'xetla-log-edit-next-field)
- map)
- "Keymap used in `xetla-log-edit-mode' buffers.")
-
-;;
-;; Archive list mode
-;;
-(defvar xetla-archive-list-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map xetla-keyvec-help 'describe-mode)
- (define-key map (xetla-prefix-kill-ring ?a) 'xetla-save-archive-to-kill-ring)
- (define-key map "\C-m" 'xetla-archive-list-categories)
- (define-key map [return] 'xetla-archive-list-categories)
-
- ;; Buffers group
- (define-key map (xetla-prefix-buffer ?p) 'xetla-show-process-buffer)
- (define-key map (xetla-prefix-buffer ?L) 'xetla-open-internal-log-buffer)
- (define-key map (xetla-prefix-buffer xetla-key-show-bookmark) 'xetla-bookmarks)
-
- (define-key map xetla-keyvec-add-bookmark 'xetla-bookmarks-add)
- (define-key map [?o] 'xetla-archive-browse-archive)
- (define-key map [?*] 'xetla-archive-select-default)
- (define-key map (xetla-prefix-add ?r) 'xetla-register-archive)
- (define-key map (xetla-prefix-add ?a) 'xetla-make-archive)
- (define-key map (xetla-prefix-add ?m) 'xetla-archive-mirror-archive)
- (define-key map xetla-keyvec-remove 'xetla-archive-unregister-archive)
- (define-key map [?g] 'xetla-archives)
- (define-key map [?s] 'xetla-archive-synchronize-archive)
- (define-key map [?e] 'xetla-archive-edit-archive-location)
- (define-key map [down] 'xetla-archive-next)
- (define-key map [up] 'xetla-archive-previous)
- (define-key map [?n] 'xetla-archive-next)
- (define-key map [?p] 'xetla-archive-previous)
- (define-key map xetla-keyvec-quit 'xetla-buffer-quit)
- map)
- "Keymap used in `xetla-archive-list-mode' buffers.")
-
-(defvar xetla-archive-archive-map
- (let ((map (make-sparse-keymap)))
- (define-key map [button2] 'xetla-archive-list-categories-by-mouse)
- map)
- "Keymap used archives in `xetla-archive-list-mode' buffers.")
-
-;;
-;; Category list mode
-;;
-(defvar xetla-category-list-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map xetla-keyvec-help 'describe-mode)
- (define-key map "\C-m" 'xetla-category-list-branches)
- (define-key map [return] 'xetla-category-list-branches)
-
- ;; Buffers group
- (define-key map (xetla-prefix-buffer ?p) 'xetla-show-process-buffer)
- (define-key map (xetla-prefix-buffer ?L) 'xetla-open-internal-log-buffer)
- (define-key map (xetla-prefix-buffer xetla-key-show-bookmark) 'xetla-bookmarks)
-
- (define-key map xetla-keyvec-add-bookmark 'xetla-category-bookmarks-add)
- (define-key map (xetla-prefix-apply-from-here
- xetla-key-add-bookmark) 'xetla-category-bookmarks-add-here)
- (define-key map [?^] 'xetla-archives)
- (define-key map (xetla-prefix-add ?c) 'xetla-category-make-category)
- (define-key map [?g] 'xetla-category-refresh)
- (define-key map [?s] 'xetla-category-mirror-archive)
- (define-key map [down] 'xetla-category-next)
- (define-key map [up] 'xetla-category-previous)
- (define-key map [?n] 'xetla-category-next)
- (define-key map [?p] 'xetla-category-previous)
- (define-key map xetla-keyvec-quit 'xetla-buffer-quit)
- map)
- "Keymap used in `xetla-category-list-mode' buffers.")
-
-(defvar xetla-category-category-map
- (let ((map (make-sparse-keymap)))
- (define-key map [button2] 'xetla-category-list-branches-by-mouse)
- map)
- "Keymap used categories in `xetla-category-list-mode' buffers.")
-
-;;
-;; Branch list mode section
-;;
-(defvar xetla-branch-list-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map xetla-keyvec-help 'describe-mode)
- (define-key map "\C-m" 'xetla-branch-list-versions)
- (define-key map [return] 'xetla-branch-list-versions)
-
- ;; Buffers group
- (define-key map (xetla-prefix-buffer ?p) 'xetla-show-process-buffer)
- (define-key map (xetla-prefix-buffer ?L) 'xetla-open-internal-log-buffer)
- (define-key map (xetla-prefix-buffer xetla-key-show-bookmark) 'xetla-bookmarks)
-
- (define-key map xetla-keyvec-parent 'xetla-branch-list-parent-category)
- (define-key map (xetla-prefix-add ?b) 'xetla-branch-make-branch)
- (define-key map [?>] 'xetla-branch-get-branch)
- (define-key map [?g] 'xetla-branch-refresh)
- (define-key map [?s] 'xetla-branch-mirror-archive)
- (define-key map [down] 'xetla-category-next)
- (define-key map [up] 'xetla-category-previous)
- (define-key map [?n] 'xetla-category-next)
- (define-key map [?p] 'xetla-category-previous)
- (define-key map xetla-keyvec-quit 'xetla-buffer-quit)
- (define-key map (xetla-prefix-apply-from-here
- xetla-key-add-bookmark) 'xetla-branch-bookmarks-add-here)
- (define-key map xetla-keyvec-add-bookmark 'xetla-branch-bookmarks-add)
- map)
- "Keymap used in `xetla-branch-list-mode' buffers.")
-
-(defvar xetla-branch-branch-map
- (let ((map (make-sparse-keymap)))
- (define-key map [button2] 'xetla-branch-list-versions-by-mouse)
- map)
- "Keymap used branches in `xetla-branch-list-mode' buffers.")
-
-;;
-;; Version list mode
-;;
-(defvar xetla-version-list-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map xetla-keyvec-help 'describe-mode)
- (define-key map "\C-m" 'xetla-version-list-revisions)
- (define-key map [return] 'xetla-version-list-revisions)
-
- ;; Buffers group
- (define-key map (xetla-prefix-buffer ?p) 'xetla-show-process-buffer)
- (define-key map (xetla-prefix-buffer ?L) 'xetla-open-internal-log-buffer)
- (define-key map (xetla-prefix-buffer xetla-key-show-bookmark) 'xetla-bookmarks)
-
- (define-key map xetla-keyvec-parent 'xetla-version-list-parent-branch)
- (define-key map (xetla-prefix-add ?v) 'xetla-version-make-version)
- (define-key map [?>] 'xetla-version-get-version)
- (define-key map [?g] 'xetla-version-refresh)
- (define-key map [?s] 'xetla-version-mirror-archive)
- (define-key map [down] 'xetla-category-next)
- (define-key map [up] 'xetla-category-previous)
- (define-key map [?n] 'xetla-category-next)
- (define-key map [?p] 'xetla-category-previous)
- (define-key map xetla-keyvec-quit 'xetla-buffer-quit)
- (define-key map (xetla-prefix-apply-from-here
- xetla-key-add-bookmark) 'xetla-version-bookmarks-add-here)
- (define-key map xetla-keyvec-add-bookmark 'xetla-version-bookmarks-add)
- (define-key map xetla-keyvec-tag 'xetla-version-tag)
- map)
- "Keymap used in `xetla-version-list-mode' buffers.")
-
-(defvar xetla-version-version-map
- (let ((map (make-sparse-keymap)))
- (define-key map [button2] 'xetla-version-list-revisions-by-mouse)
- map)
- "Keymap used versions in `xetla-version-list-mode' buffers.")
-
-;;
-;; Revision list mode
-;;
-(defvar xetla-revision-list-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map xetla-keyvec-help 'describe-mode)
- (define-key map xetla-keyvec-parent 'xetla-revision-list-parent-version)
- (define-key map [?> ?g] 'xetla-revision-get-revision)
- (define-key map [?> ?C] 'xetla-revision-cache-revision)
- (define-key map [?> ?L] 'xetla-revision-add-to-library)
-
- ;; Buffers group
- (define-key map (xetla-prefix-buffer ?p) 'xetla-show-process-buffer)
- (define-key map (xetla-prefix-buffer ?L) 'xetla-open-internal-log-buffer)
- (define-key map (xetla-prefix-buffer xetla-key-show-bookmark) 'xetla-bookmarks)
-
- (define-key map [?b] 'xetla-bookmarks-add)
- (define-key map (xetla-prefix-toggle ??) 'xetla-revision-toggle-help)
- (define-key map (xetla-prefix-toggle ?d) 'xetla-revision-toggle-date)
- (define-key map (xetla-prefix-toggle ?c) 'xetla-revision-toggle-creator)
- (define-key map (xetla-prefix-toggle ?s) 'xetla-revision-toggle-summary)
- (define-key map (xetla-prefix-toggle ?l) 'xetla-revision-toggle-library)
- (define-key map (xetla-prefix-toggle ?m) 'xetla-revision-toggle-merges)
- (define-key map (xetla-prefix-toggle ?b) 'xetla-revision-toggle-merged-by)
- (define-key map (xetla-prefix-toggle ?r) 'xetla-revision-toggle-reverse)
-
- ;;
- ;; Star merge
- ;; from here
- (define-key map (xetla-prefix-apply-from-here
- xetla-key-star-merge) 'xetla-revision-star-merge)
- ;; from head
- (define-key map (xetla-prefix-apply-from-head xetla-key-star-merge)
- 'xetla-revision-star-merge-version)
- (define-key map (xetla-prefix-merge xetla-key-star-merge)
- 'xetla-revision-star-merge-version)
- (define-key map xetla-keyvec-star-merge 'xetla-revision-star-merge-version)
-
- ;;
- ;; Replay
- ;; from here
- (define-key map (xetla-prefix-apply-from-here xetla-key-replay)
- 'xetla-revision-replay)
- ;; from head
- (define-key map (xetla-prefix-apply-from-head xetla-key-replay)
- 'xetla-revision-replay-version)
- (define-key map xetla-keyvec-replay 'xetla-revision-replay-version)
-
- (define-key map (xetla-prefix-apply-from-here ?y)
- 'xetla-revision-sync-tree)
- ;;
- ;; Update
- (define-key map (xetla-prefix-merge xetla-key-update)
- 'xetla-revision-update)
- ;;
- ;; Tag
- ;; from here
- (define-key map (xetla-prefix-apply-from-here
- xetla-key-tag) 'xetla-revision-tag-from-here)
-
- (define-key map (xetla-prefix-tag
- xetla-key-apply-from-here) 'xetla-revision-tag-from-here)
- ;; from head
- (define-key map (xetla-prefix-apply-from-head
- xetla-key-tag) 'xetla-revision-tag-from-head)
- (define-key map (xetla-prefix-tag
- xetla-key-apply-from-head) 'xetla-revision-tag-from-head)
-
- (define-key map [?g] 'xetla-generic-refresh)
- (define-key map [down] 'xetla-revision-next)
- (define-key map [up] 'xetla-revision-prev)
- (define-key map [?n] 'xetla-revision-next)
- (define-key map [?p] 'xetla-revision-prev)
- (define-key map [?N] 'xetla-revision-next-unmerged)
- (define-key map [?P] 'xetla-revision-prev-unmerged)
- (define-key map [?l] 'xetla-revision-cat-log)
- (define-key map "\C-m" 'xetla-revision-show-changeset)
- (define-key map [return] 'xetla-revision-show-changeset)
- (define-key map xetla-keyvec-mark 'xetla-revision-mark-revision)
- (define-key map xetla-keyvec-unmark 'xetla-revision-unmark-revision)
- (define-key map (xetla-prefix-diff xetla-key-diff) 'xetla-revision-delta)
- (define-key map (xetla-prefix-diff xetla-key-get) 'xetla-revision-store-delta)
- (define-key map [?=] 'xetla-revision-changeset)
- (define-key map (xetla-prefix-buffer ?p) 'xetla-show-process-buffer)
- (define-key map (xetla-prefix-buffer ?L) 'xetla-open-internal-log-buffer)
- (define-key map (xetla-prefix-buffer xetla-key-show-bookmark) 'xetla-bookmarks)
- (define-key map xetla-keyvec-inventory 'xetla-pop-to-inventory)
- (define-key map xetla-keyvec-quit 'xetla-buffer-quit)
- (define-key map xetla-keyvec-add-bookmark 'xetla-revision-bookmarks-add)
- map)
- "Keymap used in `xetla-revision-list-mode' buffers.")
-
-(defstruct (xetla-revision)
- revision ;; The revision, as a list
- summary creator date
- merges ;; List of patches merged by this revision
- merged-by ;; List of patches merging this revision
- )
-
-(defvar xetla-revision-revision-map
- (let ((map (copy-keymap xetla-context-map-template)))
- (define-key map [button2] 'xetla-revision-show-changeset-by-mouse)
- map)
- "Keymap used on revisions in `xetla-revision-list-mode' buffers.")
-
-;;
-;; Changes mode
-;;
-(defvar xetla-changes-mode-map
- (let ((map (copy-keymap diff-mode-shared-map)))
- (define-key map xetla-keyvec-help 'describe-mode)
- (define-key map "\C-m" 'xetla-changes-jump-to-change)
- (define-key map [return] 'xetla-changes-jump-to-change)
- (define-key map [?=] 'xetla-changes-diff)
- (define-key map xetla-keyvec-ediff 'xetla-changes-ediff)
- (define-key map xetla-keyvec-refresh 'xetla-generic-refresh)
- (define-key map xetla-keyvec-commit 'xetla-changes-edit-log)
- (define-key map [?I] 'xetla-inventory)
- (define-key map xetla-keyvec-inventory 'xetla-pop-to-inventory)
- (define-key map xetla-keyvec-next 'xetla-changes-next)
- (define-key map xetla-keyvec-previous 'xetla-changes-prev)
- (define-key map xetla-keyvec-revert 'xetla-changes-revert)
- (define-key map xetla-keyvec-quit 'xetla-buffer-quit)
- (define-key map [?d] 'xetla-changes-rm)
- (define-key map xetla-keyvec-mark 'xetla-changes-mark-file)
- (define-key map xetla-keyvec-unmark 'xetla-changes-unmark-file)
- (define-key map [?v] 'xetla-changes-view-source)
- (define-key map xetla-keyvec-parent 'xetla-changes-master-buffer)
- (define-key map [?j] 'xetla-changes-diff-or-list)
- ;; Buffers group
- (define-key map (xetla-prefix-buffer ?p) 'xetla-show-process-buffer)
- (define-key map (xetla-prefix-buffer ?L) 'xetla-open-internal-log-buffer)
- (define-key map (xetla-prefix-buffer xetla-key-show-bookmark) 'xetla-bookmarks)
- map)
- "Keymap used in `xetla-changes-mode'.")
-
-(defvar xetla-changes-file-map
- (let ((map (copy-keymap xetla-context-map-template)))
- (define-key map [button2] 'xetla-changes-jump-to-change-by-mouse)
- map)
- "Keymap used on files in `xetla-changes-mode' buffers.")
-
-
-;;
-;; ChangeLog mode section
-;;
-(defvar xetla-changelog-mode-map
- (let ((map (copy-keymap change-log-mode-map)))
- (define-key map xetla-keyvec-quit 'xetla-buffer-quit)
- map)
- "Keymap used in `xetla-changelog-mode'.")
-
-
-;;
-;; Log buffer mode section
-;;
-(defvar xetla-log-buffer-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map xetla-keyvec-help 'describe-mode)
- (define-key map [?o] 'xetla-switch-to-output-buffer)
- (define-key map "\C-m" 'xetla-switch-to-output-buffer)
- (define-key map [?e] 'xetla-switch-to-error-buffer)
- (define-key map [?r] 'xetla-switch-to-related-buffer)
- (define-key map [?n] 'xetla-log-next)
- (define-key map [?p] 'xetla-log-prev)
- (define-key map xetla-keyvec-quit 'xetla-buffer-quit)
- map)
- "Keymap used in XEtla's log buffer.")
-
-;;
-;; Process buffer mode section
-;;
-(defvar xetla-process-buffer-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map (xetla-prefix-buffer ?L) 'xetla-open-internal-log-buffer)
-
- (define-key map xetla-keyvec-inventory 'xetla-show-inventory-buffer)
- (define-key map xetla-keyvec-quit 'xetla-buffer-quit)
- map)
- "Keymap used in XEtla's log buffer.")
-
-;;
-;; Log edit buffer mode section
-;;
-
-(defvar xetla-log-edit-keywords-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map [?n] 'xetla-log-edit-keywords-next)
- (define-key map [?p] 'xetla-log-edit-keywords-previous)
- (define-key map [?m] 'xetla-log-edit-keywords-mark)
- (define-key map [?u] 'xetla-log-edit-keywords-unmark)
- (define-key map [?t] 'xetla-log-edit-keywords-toggle-mark)
- (define-key map [?* ?!] 'xetla-log-edit-keywords-unmark-all)
- (define-key map [?* ?*] 'xetla-log-edit-keywords-mark-all)
- (define-key map "\C-c\C-c" 'xetla-log-edit-keywords-insert)
- map)
- "Keymap used in xetla-log-edit-keywords-mode buffers.")
-
-\f
-;; --------------------------------------
-;; Menu entries
-;; --------------------------------------
-;;
-;; Conventions
-;;
-;; 1. Each Nouns and verbs in menu items are should be capitalized.
-;; 2. TODO: Consider menu items order.
-
-;;
-;; Common submenus
-;;
-
-(defconst xetla-.arch-inventory-menu-list
- '("Put to .arch-inventory"
- ["Junk" xetla-generic-add-to-junk t]
- ["Backup" xetla-generic-add-to-backup t]
- ["Precious" xetla-generic-add-to-precious t]
- ["Unrecognized" xetla-generic-add-to-unrecognized t]))
-
-(defconst xetla-=tagging-method-menu-list
- '("Put to =tagging-method"
- ["Junk" (xetla-generic-add-to-junk t) t]
- ["Backup" (xetla-generic-add-to-backup t) t]
- ["Precious" (xetla-generic-add-to-precious t) t]
- ["Unrecognized" (xetla-generic-add-to-junk t) t]))
-
-
-;;
-;; Global
-;;
-
-(easy-menu-add-item
- (or (xetla-do-in-gnu-emacs menu-bar-tools-menu) nil)
- (or (xetla-do-in-xemacs '("Tools")) nil)
- '("XEtla"
- ["Browse Archives" xetla-archives t]
- ["Show Bookmarks" xetla-bookmarks t]
- ["Start New Project" xetla-start-project t]
- "--"
- "Tree Commands:"
- ["View Changes" xetla-changes t]
- ["View Inventory" xetla-inventory t]
- ["View Tree Lint" xetla-tree-lint t]
- ["Show Tree Revisions" xetla-tree-revisions t]
- ["Edit Arch Log" xetla-edit-log t]
- "--"
- "File Commands:"
- ["Insert Arch Tag" xetla-tag-insert t]
- ["Add Log Entry" xetla-add-log-entry t]
- ["View File Diff" xetla-file-diff t]
- ["View File Ediff" xetla-file-ediff t]
- ["View Original" xetla-file-view-original t]
- ["View Conflicts" xetla-view-conflicts t]
- "--"
- ("Quick Configuration"
- ["Three Way Merge" xetla-toggle-three-way-merge
- :style toggle :selected xetla-three-way-merge]
- ["Use --forward" xetla-toggle-use-forward-option
- :style toggle :selected xetla-use-forward-option]
- ["Use --skip-present" xetla-toggle-use-skip-present-option
- :style toggle :selected xetla-use-skip-present-option]
- )
- )
- "PCL-CVS")
-
-;;
-;; Bookmarks mode
-;;
-(defconst xetla-bookmarks-entry-menu-list
- '("Bookmark Entry"
- ["Delete" xetla-bookmarks-delete t]
- ["Goto Location" xetla-bookmarks-goto t]
- ("File Tree"
- ["Find File" xetla-bookmarks-find-file t]
- ["Run Dired" xetla-bookmarks-open-tree t]
- ["Run Inventory" xetla-bookmarks-inventory t]
- ["View Changes" xetla-bookmarks-changes t]
- )
- ("Merge"
- ["View Missing Patches" xetla-bookmarks-missing t]
- ["Replay" xetla-bookmarks-replay t]
- ["Update" xetla-bookmarks-update t]
- ["Star-merge" xetla-bookmarks-star-merge t]
- )
- ("Edit"
- ["Edit Bookmark" xetla-bookmarks-edit t]
- ["Add Nickname" xetla-bookmarks-add-nickname-interactive t]
- ["Remove Nickname" xetla-bookmarks-delete-nickname-interactive t]
- ["Add Local Tree" xetla-bookmarks-add-tree-interactive t]
- ["Remove Local Tree" xetla-bookmarks-delete-tree-interactive t]
- ["Add Group" xetla-bookmarks-add-group-interactive t]
- ["Remove Group" xetla-bookmarks-delete-group-interactive t]
- ["Add Partner" xetla-bookmarks-add-partner-interactive t]
- ["Remove Partner" xetla-bookmarks-delete-partner-interactive t]
- )
- ("Partners"
- ["Add Partner" xetla-bookmarks-add-partner-interactive t]
- ["Remove Partner" xetla-bookmarks-delete-partner-interactive t]
- ["Write to Partner File" xetla-bookmarks-write-partners-to-file t]
- ["Load from Partner File" xetla-bookmarks-add-partners-from-file t]
- ["View Missing Patches" xetla-bookmarks-missing t]
- ))
- "Used both for the local and the global menu."
- )
-
-(easy-menu-define xetla-bookmarks-mode-menu xetla-bookmarks-mode-map
- "`xetla-bookmarks-mode' menu"
- `("XEtla-Bookmarks"
- ["Add Bookmark" xetla-bookmarks-add t]
- ["Show Details" xetla-bookmarks-toggle-details
- :style toggle :selected xetla-bookmarks-show-details]
- ["Select by Group" xetla-bookmarks-select-by-group t]
- ["Cleanup 'local-tree fields" xetla-bookmarks-cleanup-local-trees t]
- ,xetla-bookmarks-entry-menu-list
- ))
-
-(easy-menu-define xetla-bookmarks-entry-menu nil
- "Menu used on a xetla bookmark entry."
- xetla-bookmarks-entry-menu-list)
-
-;;
-;; Inventory mode
-;;
-(easy-menu-define xetla-inventory-mode-partners-menu xetla-inventory-mode-map
- "`xetla-inventory-mode' partners menu"
- '("Partners"
- ["Add Partner..." xetla-partner-add t]
- ("Set Tree Version" :filter (lambda (x)
- (xetla-partner-create-menu
- 'xetla-generic-set-tree-version)))
- "--"
- ("Show Changes" :filter (lambda (x)
- (xetla-partner-create-menu
- '(lambda (x)
- (xetla-changes current-prefix-arg
- (list 'revision (xetla-name-split x)))))))
- ("Show Missing" :filter (lambda (x)
- (xetla-partner-create-menu
- '(lambda (x)
- (xetla-missing default-directory x)))))
- "--"
- ("Replay" :filter (lambda (x)
- (xetla-partner-create-menu
- 'xetla-inventory-replay)))
- ("Star-merge" :filter (lambda (x)
- (xetla-partner-create-menu
- 'xetla-inventory-star-merge)))))
-
-(defconst xetla-inventory-item-menu-list
- `("Inventory Item"
- ["Open File" xetla-inventory-find-file t]
- ["Redo" xetla-inventory-redo (xetla-inventory-maybe-undo-directory)]
- "--"
- ["Add" xetla-inventory-add-files t]
- ["Move" xetla-inventory-move t]
- ["Remove" xetla-inventory-remove-files t]
- ["Delete" xetla-inventory-delete-files t]
- "--"
- ["Make Junk" xetla-inventory-make-junk t]
- ["Make Precious" xetla-inventory-make-precious t]
- ,xetla-.arch-inventory-menu-list
- ,xetla-=tagging-method-menu-list)
- "Used both in the context and the global menu for inventory.")
-
-(easy-menu-define xetla-inventory-mode-menu xetla-inventory-mode-map
- "`xetla-inventory-mode' menu"
- `("Inventory"
- ["Edit Log" xetla-inventory-edit-log t]
- "--"
- ["Show Changes" xetla-inventory-changes t]
- ["Show Changelog" xetla-changelog t]
- ["Show Logs" xetla-logs t]
- ["Show Missing" xetla-inventory-missing t]
- "--"
- ,xetla-inventory-item-menu-list
- "--"
- ["Update" xetla-inventory-update t]
- ["Replay" xetla-inventory-replay t]
- ["Star-merge" xetla-inventory-star-merge t]
- ("Changesets"
- ["Save actual changes in directory" xetla-changes-save t]
- ["Save actual changes in tarball" xetla-changes-save-as-tgz t]
- ["View changeset from directory" xetla-show-changeset t]
- ["View changeset from tarball" xetla-show-changeset-from-tgz t]
- ["Apply changeset from directory" xetla-inventory-apply-changeset t]
- ["Apply changeset from tarball" xetla-inventory-apply-changeset-from-tgz t]
- )
- "--"
- ["Undo" xetla-inventory-undo t]
- ["Redo" xetla-inventory-redo t]
- "--"
- ["Synchronize Mirror" xetla-inventory-mirror t]
- ("Taging Method"
- ["Edit .arch-inventory" xetla-edit-.arch-inventory-file t]
- ["Edit =tagging-method" xetla-edit-=tagging-method-file t]
- ["Set Tagging Method" xetla-generic-set-id-tagging-method t]
- ["Set Tree Version From Scratch" xetla-generic-set-tree-version t]
- )
- ["Tree-lint" xetla-tree-lint t]
- "--"
- ("Toggles"
- ["Set All Toggle Variables" xetla-inventory-set-all-toggle-variables t]
- ["Reset All Toggle Variables" xetla-inventory-reset-all-toggle-variables t]
- ["Toggle All Toggle Variables" xetla-inventory-toggle-all-toggle-variables t] .
- ,(mapcar '(lambda (elem) `[,(concat "Toggle " (car (cddddr elem)))
- ,(caddr elem)
- :style toggle
- :selected ,(cadr elem)])
- xetla-inventory-file-types-manipulators))))
-
-(easy-menu-define xetla-inventory-item-menu nil
- "Menu used on a inventory item."
- xetla-inventory-item-menu-list)
-
-(easy-menu-define xetla-inventory-tagging-method-menu nil
- "Menu used on the taggine method line in a inventory buffer."
- '("Switch Taggine Method"
- ["Tagline" (xetla-generic-set-id-tagging-method "tagline") t]
- ["Explicit" (xetla-generic-set-id-tagging-method "explicit") t]
- ["Names" (xetla-generic-set-id-tagging-method "names") t]
- ["Implicit" (xetla-generic-set-id-tagging-method "implicit") t]))
-
-;;
-;; Cat-log mode
-;;
-(easy-menu-define xetla-cat-log-mode-menu xetla-cat-log-mode-map
- "'xetla-cat-log-mode' menu"
- '("Cat-Log"
- ["Inventory" xetla-pop-to-inventory t]
- ["Quit" xetla-buffer-quit t]
- ))
-
-;;
-;; Log edit mode
-;;
-(easy-menu-define xetla-log-edit-mode-menu xetla-log-edit-mode-map
- "`xetla-log-edit-mode' menu"
- '("Log"
- ["Insert xetla log-for-merge" xetla-log-edit-insert-log-for-merge t]
- ["log-for-merge and headers"
- xetla-log-edit-insert-log-for-merge-and-headers t]
- ["Insert memorized log" xetla-log-edit-insert-memorized-log t]
- ["Show changes" xetla-changes t]
- ["Commit" xetla-log-edit-done t]
- ["Show Changelog" xetla-changelog t]
- ["Goto Summary Field" xetla-log-goto-summary t]
- ["Goto Body" xetla-log-goto-body t]
- ["Edit Keywords Field" xetla-log-edit-keywords t]
- ["Kill Body" xetla-log-kill-body t]
- ["Tree Lint" xetla-tree-lint t]
- ["Abort" xetla-log-edit-abort t]))
-
-;;
-;; Archive list mode
-;;
-(easy-menu-define xetla-archive-list-mode-menu xetla-archive-list-mode-map
- "`xetla-archive-list-mode' menu"
- '("Archives"
- ["Register New Archive" xetla-register-archive t]
- ["Add a Bookmark" xetla-bookmarks-add t]
- ["Update Archives List" xetla-archives t]
- ["Set Default Archive" xetla-archive-select-default t]
- ["Remove Archive Registration" xetla-archive-unregister-archive t]
- ["Edit Archive Location" xetla-archive-edit-archive-location t]
- ["Make New Archive..." xetla-make-archive t]
- ["Create a Mirror" xetla-archive-mirror-archive t]
- ["Use as default Mirror" xetla-archive-use-as-default-mirror t]
- ["Synchronize Mirror" xetla-archive-synchronize-archive t]
- ))
-
-;;
-;; Category list mode
-;;
-(easy-menu-define xetla-category-list-mode-menu xetla-category-list-mode-map
- "`xetla-category-list-mode' menu"
- '("Categories"
- ["List Archives" xetla-archives t]
- ["Update Categories List" xetla-category-refresh t]
- ["Make New Category..." xetla-category-make-category t]
- ["Add a Bookmark" xetla-bookmarks-add t]
- ["Synchronize Mirror" xetla-category-mirror-archive t]
- ))
-
-
-;;
-;; Branch list mode
-;;
-(easy-menu-define xetla-branch-list-mode-menu xetla-branch-list-mode-map
- "`xetla-branch-list-mode' menu"
- '("Branches"
- ["Update Branches List" xetla-branch-refresh t]
- ["List Parent Category" xetla-branch-list-parent-category t]
- ["Make New Branch..." xetla-branch-make-branch t]
- ["Synchronize Mirror" xetla-branch-mirror-archive t]
- ["Bookmark Branch under Point" xetla-branch-bookmarks-add t]
- ["Get..." xetla-branch-get-branch t]
- ))
-
-;;
-;; Version list mode
-;;
-(easy-menu-define xetla-version-list-mode-menu xetla-version-list-mode-map
- "`xetla-version-list-mode' menu"
- '("Versions"
- ["Update Versions List" xetla-version-refresh t]
- ["Get..." xetla-version-get-version t]
- ["Make New Version..." xetla-version-make-version t]
- ["List Parent Branch" xetla-version-list-parent-branch t]
- ["Synchronize Mirror" xetla-version-mirror-archive t]
- ["Bookmark Version under Point" xetla-version-bookmarks-add t]
- ["Tag This Version" xetla-version-tag t]))
-
-;;
-;; Revision list mode
-;;
-(easy-menu-define xetla-revision-list-mode-menu xetla-revision-list-mode-map
- "`xetla-revision-list-mode' menu"
- '("Revisions"
- ["Refresh Revisions List" xetla-generic-refresh t]
- ["List Parent Version" xetla-revision-list-parent-version t]
- "--"
- ["Bookmark Revision under Point" xetla-revision-bookmarks-add t]
- ("Mark"
- ["Mark Revision" xetla-revision-mark-revision t]
- ["Unmark Revision" xetla-revision-unmark-revision t])
- "--"
- ["Show Log" xetla-revision-cat-log t]
- ["Unify Patch Logs with This Revision" xetla-revision-sync-tree t]
- ["View changeset" xetla-revision-changeset t]
- ("Delta"
- ["View" (xetla-revision-delta t) t]
- ["Store to Directory" (xetla-revision-store-delta t) t])
- "--"
- ["Update" xetla-revision-update t]
- ("Replay"
- ["From Head Revision" xetla-revision-replay-version t]
- ["From Revision under Point" xetla-revision-replay t])
- ("Star-Merge"
- ["From Head Revision" xetla-revision-star-merge-version t]
- ["From Revision under Point" xetla-revision-star-merge t])
- ("Get"
- ["Get a Local Copy" xetla-revision-get-revision t]
- ["Make Cache" xetla-revision-cache-revision t]
- ["Add to Library" xetla-revision-add-to-library t])
- ("Tag "
- ["From Head Revision" xetla-revision-tag-from-head t]
- ["From Revision under Point" xetla-revision-tag-from-here t])
- ["Send comment to author" xetla-revision-send-comments t]
- "--"
- ("Filter Display"
- ["Date" xetla-revision-toggle-date
- :style toggle :selected xetla-revisions-shows-date]
- ["Creator" xetla-revision-toggle-creator
- :style toggle :selected xetla-revisions-shows-creator]
- ["Summary" xetla-revision-toggle-summary
- :style toggle :selected xetla-revisions-shows-summary]
- ["Presence in Revlib" xetla-revision-toggle-library
- :style toggle :selected xetla-revisions-shows-library]
- ["Merged Patches" xetla-revision-toggle-merges
- :style toggle :selected xetla-revisions-shows-merges]
- ["Patches Merging ..." xetla-revision-toggle-merged-by
- :style toggle :selected xetla-revisions-shows-merged-by])))
-
-(easy-menu-define xetla-revision-revision-menu nil
- "Menu used on a revision item in `xetla-revision-list-mode' buffer"
- '("Revision"
- ["Show Log" xetla-revision-cat-log t]
- ["Unify Patch Logs with This Revision" xetla-revision-sync-tree t]
- ["View changeset" xetla-revision-changeset t]
- ["Set Bookmark" xetla-revision-bookmarks-add t]
- ("Mark"
- ["Mark Revision" xetla-revision-mark-revision t]
- ["Unmark Revision" xetla-revision-unmark-revision t])
- ("Delta"
- ["In This Version" xetla-revision-delta t]
- ["With Revision in Another Archive" xetla-revision-store-delta t])
- ("Merge"
- ["Star-Merge" xetla-revision-star-merge t]
- ["Replay" xetla-revision-replay t])
- ("Get"
- ["Get a Local Copy" xetla-revision-get-revision t]
- ["Make Cache" xetla-revision-cache-revision t]
- ["Add to Library" xetla-revision-add-to-library t])
- ["Send comment to author" xetla-revision-send-comments t]
- ["Tag from Here" xetla-revision-tag-from-here]))
-
-;;
-;; Changes mode
-;;
-(defconst xetla-changes-file-menu-list
- '("File Changes"
- ["Jump to File" xetla-changes-jump-to-change t]
- ["Jump to Diffs" xetla-changes-diff-or-list t]
- ["View Diff in Separate Buffer" xetla-changes-diff t]
- ["View Diff with Ediff" xetla-changes-ediff t]
- "--"
- ["Delete File" xetla-changes-rm t]
- ["Revert File" xetla-changes-revert t]
- )
- "Used both in the global and the context menu of `xetla-changes-mode'.")
-
-(easy-menu-define xetla-changes-mode-menu xetla-changes-mode-map
- "`xetla-changes' menu"
- `("Changes"
- ["Refresh Buffer" xetla-generic-refresh t]
- ["Edit log before commit" xetla-changes-edit-log t]
- ["View other revisions" xetla-tree-revisions t]
- ,xetla-changes-file-menu-list
- ))
-
-(easy-menu-define xetla-changes-file-menu nil
- "Menu used on a `xetla-changes' file"
- xetla-changes-file-menu-list)
-
-;;
-;; Lint mode
-;;
-(defconst xetla-tree-lint-file-menu-list
- `("File"
- ["Jump to File" xetla-generic-find-file-at-point t]
- ("Mark"
- ["Mark File" xetla-tree-lint-mark-file t]
- ["Unmark File" xetla-tree-lint-unmark-file t])
- "--"
- ["Add File" xetla-tree-lint-add-files t]
- ["Delete File" xetla-tree-lint-delete-files t]
- ["Regenerate ID" xetla-tree-lint-regenerate-id t]
- "--"
- ["Make Junk" xetla-tree-lint-make-junk t]
- ["Make Precious" xetla-tree-lint-make-precious t]
- ,xetla-.arch-inventory-menu-list
- ,xetla-=tagging-method-menu-list
- )
- "Used both for context and global menu.")
-
-(easy-menu-define xetla-tree-lint-file-menu nil
- "Menu used on files listed in `xetla-tree-lint'"
- xetla-tree-lint-file-menu-list
- )
-
-(easy-menu-define xetla-tree-lint-mode-menu xetla-tree-lint-mode-map
- "`xetla-tree-lint' menu"
- `("Tree Lint"
- ["Refresh Buffer" xetla-generic-refresh t]
- ,xetla-tree-lint-file-menu-list
- ))
-
-;;
-;; Event Log buffer
-;;
-(easy-menu-define xetla-log-buffer-mode-menu xetla-log-buffer-mode-map
- "`xetla-log-buffer' menu"
- '("Logs"
- ["Show Related Buffer" xetla-switch-to-related-buffer t]
- ["Show Output Buffer" xetla-switch-to-output-buffer t]
- ["Show Error Buffer" xetla-switch-to-error-buffer t]
- ))
-
-\f
-;; --------------------------------------
-;; User customization section
-;; --------------------------------------
-
-
-(defgroup xetla nil
- "Arch interface for emacs."
- :group 'tools
- :prefix "xetla-")
-
-
-(defgroup xetla-inventory nil
- "This group contains items used in inventory mode."
- :group 'xetla)
-
-
-(defgroup xetla-revisions nil
- "This group contains items used in revisions mode."
- :group 'xetla)
-
-
-(defgroup xetla-file-actions nil
- "This group contains items manipulating finding, saving and reverting files."
- :group 'xetla)
-
-
-(defgroup xetla-bindings nil
- "This group contains items related to key bindings."
- :group 'xetla)
-
-
-(defgroup xetla-faces nil
- "This group contains faces defined for Xetla."
- :group 'xetla)
-
-
-(defcustom xetla-prefix-key [(control x) ?T]
- "Prefix key for most xetla commands."
- :type '(choice (const [(control x) ?T])
- (const [(control x) ?t])
- (const [(control x) ?v])
- (const [(control x) ?V])
- (const [(control x) ?v ?t])
- (sexp))
- :group 'xetla-bindings
- :set (lambda (var value)
- (if (boundp var)
- (global-unset-key (symbol-value var)))
- (set var value)
- (global-set-key (symbol-value var) xetla-global-keymap)))
-
-
-(global-set-key xetla-prefix-key xetla-global-keymap)
-
-
-(defcustom xetla-tla-executable "tla"
- "*The name of the xetla executable."
- :type 'string
- :group 'xetla)
-
-
-(defcustom xetla-diff-executable "diff"
- "*The name of the diff executable."
- :type 'string
- :group 'xetla)
-
-
-(defcustom xetla-patch-executable "patch"
- "*The name of the patch executable."
- :type 'string
- :group 'xetla)
-
-
-(defcustom xetla-highlight t
- "*Use highlighting for XEtla buffers."
- :type 'boolean
- :group 'xetla)
-
-
-(defcustom xetla-install-command-help-system t
- "*Use f1 to display help for the actual function call during minibuffer input.
-Note: this functionality is provided for all minibuffer prompts."
- :type 'boolean
- :group 'xetla)
-
-
-(defcustom xetla-do-not-prompt-for-save nil
- "*Whether or not xetla will prompt before saving.
-
-If non nil, xetla will not prompt you before saving buffers of the
-working local tree."
- :type 'boolean
- :group 'xetla-file-actions)
-
-
-(defcustom xetla-automatically-revert-buffers t
- "*Whether or not xetla will automatically revert buffers.
-
-If non nil, xetla will automatically revert unmodified buffers after an
-arch operation modifying the file."
- :type 'boolean
- :group 'xetla-file-actions)
-
-
-(defcustom xetla-changes-recursive t
- "*Whether or not xetla will compute changes recursively.
-
-If non nil, `xetla-changes' will be applied recursively to subprojects
-of the current tree"
- :type 'boolean
- :group 'xetla)
-
-
-(defcustom xetla-strict-commits nil
- "*If non-nil, commit operations are invoked with the -strict option."
- :type 'boolean
- :group 'xetla)
-
-
-(defcustom xetla-commit-check-log-buffer-functions
- '(xetla-commit-check-empty-headers
- xetla-commit-check-empty-line
- xetla-commit-check-missing-space)
- "*List of functions to check the ++log.. buffer.
-
-Each function is called, from the log buffer, with no argument. It
-should raise an error if commit should be canceled."
- :type 'hook
- :group 'xetla)
-
-
-(defcustom xetla-commit-headers-allowed-to-be-empty
- "^\\(Keywords\\)$"
- "*Headers allowed to be empty in the ++log.. buffer.
-
-This should be a regexp matching the header names. Headers not
-matching this regexp should not be empty when committing."
- :type 'string
- :group 'xetla)
-
-
-(defcustom xetla-commit-fix-missing-space t
- "*Whether or not xetla will add missing spaces after header names.
-
-If non-nil, missing spaces after a space will be inserted
-automatically instead of raising an error when committing."
- :type 'boolean
- :group 'xetla)
-
-
-(defcustom xetla-three-way-merge t
- "*If non-nil, star-merge operations are invoked with -three-way."
- :type 'boolean
- :group 'xetla)
-
-
-(defcustom xetla-use-forward-option nil
- "*If non-nil, use the -forward option with commands that allow it."
- :type 'boolean
- :group 'xetla)
-
-
-(defcustom xetla-use-skip-present-option nil
- "*If non-nil, use -skip-present with commands that allow it."
- :type 'boolean
- :group 'xetla)
-
-
-(defun xetla-toggle-use-forward-option ()
- "Toggle the value of `xetla-use-forward-option'."
- (interactive)
- (setq xetla-use-forward-option (not xetla-use-forward-option)))
-
-
-(defun xetla-toggle-use-skip-present-option ()
- "Toggle the value of `xetla-use-skip-present-option'."
- (interactive)
- (setq xetla-use-skip-present-option
- (not xetla-use-skip-present-option)))
-
-
-(defun xetla-toggle-three-way-merge ()
- "Toggle the value of `xetla-three-way-merge'."
- (interactive)
- (setq xetla-three-way-merge (not xetla-three-way-merge)))
-
-
-(defgroup xetla-bookmarks nil
- "xetla bookmarks allows you to save places (archive, category,
-branch, version) in the archive that you use often. Try M-x
-xetla-bookmarks RET to see."
- :group 'xetla)
-
-
-(defcustom xetla-bookmarks-file-name "bookmarks.el"
- "*File in which xetla bookmarks will be saved.
-The bookmark file is stored in the `xetla-config-directory'"
- :type 'file
- :group 'xetla-bookmarks)
-
-
-(defcustom xetla-tag-function 'xetla-tag-uuid
- "Function called to generate the value of the arch-tag.
-
-The function must take no argument, and return a string without a
-final newline."
- :type '(choice (const xetla-tag-uuid)
- (const xetla-tag-name-date-filename)
- function)
- :group 'xetla)
-
-
-(defcustom xetla-config-directory "~/.xetla/"
- "*Directory in which the xetla config files will be stored."
- :type 'directory
- :group 'xetla)
-
-
-(defcustom xetla-log-library "~/.arch-log-library/"
- "*Directory in which the log library will be stored."
- :type 'directory
- :group 'xetla-internal)
-
-
-(defcustom xetla-log-library-greedy t
- "*Whether log files are automatically saved in the log library.
-
-If non-nil, then, whenever xetla needs to access a log file, this file
-will be copied to the log library."
- :type 'boolean
- :group 'xetla-internal)
-
-
-(defcustom xetla-cache-xetla-get-changeset 2
- "*Cache `xetla-get-changeset' calls.
-When nil, don't cache.
-When a number, cache only if the `xetla-get-changeset' call takes
-more seconds than the number.
-Otherwise don't cache the results.
-The cache is kept only in RAM."
- :type 'integer
- :group 'xetla)
-
-
-(defcustom xetla-bookmarks-cleanup-dont-prompt nil
- "*Whether xetla should prompt before cleaning a local tree.
-
-non nil means `xetla-bookmarks-cleanup-local-trees' shouldn't prompt
-before removing a local-tree"
- :type 'boolean
- :group 'xetla-bookmarks)
-
-
-(defgroup xetla-internal nil
- "This group contains items used mainly for debugging."
- :group 'xetla)
-
-
-(defcustom xetla-log-commands t
- "*Non nil means log all xetla commands in the buffer *xetla-log*."
- :type 'boolean
- :group 'xetla-internal)
-
-
-(defcustom xetla-log-buffer " *xetla-log*"
- "*Name of the buffer in which xetla logs main events."
- :type 'string
- :group 'xetla-internal)
-
-
-(defcustom xetla-switch-to-buffer-mode 'pop-to-buffer
- "*Mode for switching to xetla buffers.
-Recommended settings are: 'pop-to-buffer, and 'show-in-other-window
-and 'single-window"
- :type '(choice (const pop-to-buffer)
- (const single-window)
- (const dedicated-frame)
- (const show-in-other-window))
- :group 'xetla)
-
-(defcustom xetla-switch-to-changes-buffer nil
- "Switch to the changes buffer or stay in the current buffer."
- :type 'boolean
- :group 'xetla)
-
-
-(defcustom xetla-read-project-tree-mode 'sometimes
- "*Mode for prompting project tree directories. Possible values are:
-
-- always: When running a tla command requiring a tree, always prompt
- for it.
-
-- sometimes: If a command is ran inside a project tree, the tree root
- is used. Otherwise, prompt.
-
-- never: If a command is run inside a project tree, use the tree root.
- Othwise, raise an error."
- :type '(choice (const always)
- (const sometimes)
- (const never))
- :group 'xetla)
-
-
-(defcustom xetla-read-directory-mode 'sometimes
- "*How prompting project directories should be done.
-
-Works similarly to `xetla-read-project-tree-mode', but this one is used
-for commands like `xetla-inventory' for which a subdirectory of a
-project tree is accepted."
- :type '(choice (const always)
- (const sometimes)
- (const never))
- :group 'xetla)
-
-
-(defcustom xetla-switch-to-buffer-first t
- "*Switch to newly created buffer on creation of buffers?
-
-If non-nil, xetla commands implementing this feature will switch to the
-newly created buffer when the command is called. Further (potentially
-asynchronous) processes are run without modifying your
-window-configuration. Otherwise, xetla will switch to the new buffer on
-command completion."
- :type 'boolean
- :group 'xetla)
-
-
-(defcustom xetla-buffer-quit-mode 'kill
- "*How *xetla-...* buffer should be killed.
-If the value is 'kill, buffers are actually killed. Otherwise, just
-burry them."
- :type '(choice (const kill)
- (const burry))
- :group 'xetla)
-
-
-(defcustom xetla-log-insert-last t
- "*If non-nil, insert changelog entries at the end of the log file."
- :type 'boolean
- :group 'xetla)
-
-
-(defgroup xetla-hooks nil
- "This group contains hooks into xetla."
- :prefix "xetla-"
- :group 'xetla)
-
-
-(defcustom xetla-archive-list-mode-hook nil
- "*Hooks run after switching to `xetla-archive-list-mode'."
- :type 'hook
- :group 'xetla-hooks)
-
-
-(defcustom xetla-bookmarks-mode-hook nil
- "*Hooks run after switching to `xetla-bookmarks-mode'."
- :type 'hook
- :group 'xetla-hooks)
-
-
-(defcustom xetla-branch-list-mode-hook nil
- "*Hooks run after switching to `xetla-branch-list-mode'."
- :type 'hook
- :group 'xetla-hooks)
-
-
-(defcustom xetla-cat-log-mode-hook nil
- "*Hooks run after switching to `xetla-cat-log-mode'."
- :type 'hook
- :group 'xetla-hooks)
-
-
-(defcustom xetla-category-list-mode-hook nil
- "*Hooks run after switching to `xetla-category-list-mode'."
- :type 'hook
- :group 'xetla-hooks)
-
-
-(defcustom xetla-inventory-file-mode-hook nil
- "*Hooks run after switching to `xetla-inventory-file-mode'."
- :type 'hook
- :group 'xetla-hooks)
-
-
-(defcustom xetla-inventory-mode-hook nil
- "*Hooks run after switching to `xetla-inventory-mode'."
- :type 'hook
- :group 'xetla-hooks)
-
-
-(defcustom xetla-log-edit-mode-hook nil
- "*Hooks run after switching to `xetla-log-edit-mode'."
- :type 'hook
- :group 'xetla-hooks)
-
-
-(defcustom xetla-logs-mode-hook nil
- "*Hooks run after switching to `xetla-logs-mode'."
- :type 'hook
- :group 'xetla-hooks)
-
-
-(defcustom xetla-revision-list-mode-hook nil
- "*Hooks run after switching to `xetla-revision-list-mode'."
- :type 'hook
- :group 'xetla-hooks)
-
-
-(defcustom xetla-version-list-mode-hook nil
- "*Hooks run after switching to `xetla-version-list-mode'."
- :type 'hook
- :group 'xetla-hooks)
-
-
-(defcustom xetla-make-branch-hook nil
- "*Hooks run after making a branch."
- :type 'hook
- :group 'xetla-hooks)
-
-
-(defcustom xetla-make-category-hook nil
- "*Hooks run after making a category."
- :type 'hook
- :group 'xetla-hooks)
-
-
-(defcustom xetla-make-version-hook nil
- "*Hooks run after making a version."
- :type 'hook
- :group 'xetla-hooks)
-
-
-(defcustom xetla-make-archive-hook nil
- "*Hooks run after creating a new archive."
- :type 'hook
- :group 'xetla-hooks)
-
-
-(defcustom xetla-name-read-init-hook nil
- "*Hooks run when the control enters to `xetla-name-read'."
- :type 'hook
- :group 'xetla-hooks)
-
-(defcustom xetla-name-read-final-hook nil
- "*Hooks run when the control leaves `xetla-name-read'.
-The name read by `xetla-name-read' is passed to functions connected
-to this hook as an argument."
- :type 'hook
- :group 'xetla-hooks)
-
-(defcustom xetla-name-read-error-hook nil
- "*Hooks run when an error is occurred in `xetla-name-read'."
- :type 'hook
- :group 'xetla-hooks)
-
-(defcustom xetla-follow-symlinks 'tree
- "*Follow symlinks of this type."
- :type '(choice (const :tag "None" nil)
- (const :tag "Symlinks into an arch-managed tree" tree)
- (const :tag "Symlinks to an arch-managed file" id))
- :group 'xetla-file-actions)
-
-(defcustom xetla-follow-symlinks-mode 'follow
- "*Before following a symlink do this."
- :type '(choice (const :tag "Ask" ask)
- (const :tag "Follow" follow)
- (const :tag "Warn" warn))
- :group 'xetla-file-actions)
-
-(defcustom xetla-use-arrow-keys-for-navigation nil
- "*Enable left/right for navigation.
-This works best if `xetla-switch-to-buffer-mode' is set to 'single-window.
-
-It enables binding for navigation allowing you to browse by only using the
-cursor keys, which is much faster than n/p/return/^. Use up/down to move to
-an item, right to select it and left to go to its \"logical\" parent!
-
-Got the idea?
-
-See the variable `xetla-use-arrow-keys-for-navigation-list' for a list of
-bindings that will be installed."
- :type '(choice (const :tag "Disabled" nil)
- (const :tag "Enabled" t)
- (const :tag "Enabled with Shift" shift))
- :group 'xetla-bindings)
-
-(defcustom xetla-revisions-shows-summary t
- "*Whether summary should be displayed for `xetla-revisions'."
- :type 'boolean
- :group 'xetla-revisions)
-
-(defcustom xetla-revisions-shows-creator t
- "*Whether creator should be displayed for `xetla-revisions'."
- :type 'boolean
- :group 'xetla-revisions)
-
-(defcustom xetla-revisions-shows-date t
- "*Whether date should be displayed for `xetla-revisions'."
- :type 'boolean
- :group 'xetla-revisions)
-
-(defcustom xetla-revisions-shows-library t
- "*Display library information in revision lists.
-
-If non-nil the presence of this revision in the library should be
-displayed for `xetla-revisions'"
- :type 'boolean
- :group 'xetla-revisions)
-
-(defcustom xetla-revisions-shows-merges nil
- "*Display merge information in revision lists.
-
-If non-nil, the list of merged patches of this revision should be
-displayed for `xetla-revisions'"
- :type 'boolean
- :group 'xetla-revisions)
-
-(defcustom xetla-revisions-shows-merged-by t
- "*Display \"merged-by\" field in revision lists.
-
-If non-nil the list of patches merged by this revision should be
-displayed for `xetla-revisions'"
- :type 'boolean
- :group 'xetla-revisions)
-
-;;; FIXME: This should be an alist of keyword . description, and
-;;; both the keyword and its description should display in the
-;;; *xetla-log-keywords* buffer.
-(defcustom xetla-log-edit-keywords
- '("admin" ; Administrative changes
- "audit" ; Code clean up/audit
- "bugfix" ; The good ol' bug fix
- "build/compile" ; Compile-time related
- "compat" ; Compatibility changes
- "delete" ; File/dir deletion
- "docfix" ; More that just a typo
- "documentation" ; Writing documentation
- "enhancement" ; Extending existing features
- "internal" ; Changes that don't affect the user
- "linting" ; aka "admin", "audit", "whitespace"
- "merge" ; Merging in changes from other repo
- "newfeature" ; New features
- "newfile" ; New file/dir added to the repo
- "release" ; Changes involved with releases
- "rename" ; Rename file/dir/function/var etc
- "revert" ; Revert some previous changes
- "security" ; Security fixes
- "sync" ; Synching code (eg GNU/Emacs -> XEmacs)
- "trivial" ; Tiny fixes/changes
- "typo" ; Typographic changes
- "update" ; General updates
- "ui" ; User-interface related changes
- "user-visible" ; User-visible changes
- "warnfix" ; Build or run-time warning fixes
- "whitespace" ; Whitespace changes
- )
- "A list of keywords for the Keywords field of a log message."
- :type '(repeat (string))
- :group 'xetla)
-
-
-(defcustom xetla-apply-patch-mapping nil
- "*Tree in which patches should be applied.
-
-An alist of rules to match fully qualified revision names to target
-directories.
-
-That variable is used to offer a directory in `xetla-gnus-apply-patch'.
-Example setting: '(((nil \"xetla\" nil nil nil) \"~/work/xetla/xetla\")))"
- :type '(repeat (cons :tag "Rule"
- (cons :tag "Full revision (regexps)"
- (choice (const nil) (regexp :tag "Archive"))
- (cons
- (choice (const nil) (regexp :tag "Category"))
- (cons
- (choice (const nil) (regexp :tag "Branch"))
- (cons
- (choice (const nil) (regexp :tag "Version"))
- (cons (choice (const nil) (string :tag "Revision"))
- (const nil))))))
- (cons (string :tag "tree") (const nil))))
- :group 'xetla)
-
-;;
-;; Tips
-;;
-
-(defgroup xetla-tips nil
- "\"Tip of the day\" feature for XEtla"
- :prefix "xetla-"
- :group 'xetla)
-
-
-(defcustom xetla-tips-enabled t
- "*Set this to nil to disable tips."
- :type 'boolean
- :group 'xetla-tips)
-
-;;
-;; State
-;;
-
-(defgroup xetla-state nil
- "Saving XEtla's state between Emacs sessions."
- :prefix "xetla-"
- :group 'xetla)
-
-
-(defcustom xetla-state-file-name "state.el"
- "*File in which xetla saves state variables between Emacs sessions.
-The file is stored in the `xetla-config-directory'"
- :type 'file
- :group 'xetla-state)
-
-(defcustom xetla-state-variables-list '(xetla-tips-number)
- "*List of variables to store in the state file `xetla-state-file-name'."
- :type '(repeat (symbol))
- :group 'xetla-state)
-
-\f
-;; --------------------------------------
-;; Face
-;; --------------------------------------
-(defface xetla-marked
- '((((class color) (background dark)) (:foreground "yellow"))
- (((class color) (background light)) (:foreground "magenta"))
- (t (:bold t)))
- "Face to highlight a marked entry in xetla buffers"
- :group 'xetla-faces)
-
-(defface xetla-archive-name
- '((((class color) (background dark)) (:foreground "lightskyblue1"))
- (((class color) (background light)) (:foreground "blue4"))
- (t (:bold t)))
- "Face to highlight xetla archive names."
- :group 'xetla-faces)
-
-(make-face 'xetla-source-archive-name
- "Face to highlight xetla source archive names.")
-(set-face-parent 'xetla-source-archive-name 'xetla-archive-name)
-
-(make-face 'xetla-mirror-archive-name
- "Face to highlight xetla mirror archive names.")
-(set-face-parent 'xetla-mirror-archive-name 'xetla-archive-name)
-
-(make-face 'xetla-category-name
- "Face to highlight xetla category names.")
-(set-face-parent 'xetla-category-name 'xetla-archive-name)
-
-(make-face 'xetla-branch-name
- "Face to highlight xetla branch names.")
-(set-face-parent 'xetla-branch-name 'xetla-archive-name)
-
-(make-face 'xetla-version-name
- "Face to highlight xetla version names.")
-(set-face-parent 'xetla-version-name 'xetla-archive-name)
-
-(make-face 'xetla-revision-name
- "Face to highlight xetla revision names.")
-(set-face-parent 'xetla-revision-name 'xetla-archive-name)
-
-(make-face 'xetla-local-directory
- "Face to highlight xetla local directory.")
-(set-face-parent 'xetla-local-directory 'xetla-archive-name)
-
-(make-face 'xetla-buffer
- "Face to highlight buffer names printed in xetla's buffer.")
-(set-face-parent 'xetla-buffer 'xetla-archive-name)
-
-(make-face 'xetla-tagging-method
- "Face to highlight taggine methods.")
-(set-face-parent 'xetla-tagging-method 'xetla-archive-name)
-
-(make-face 'xetla-id
- "Face to highlight an arch id.")
-(set-face-parent 'xetla-id 'font-lock-keyword-face)
-
-(defface xetla-separator
- '((((class color) (background dark)) (:underline t :bold t))
- (((class color) (background light)) (:underline t :bold t)))
- "Face to highlight separators."
- :group 'xetla-faces)
-
-(make-face 'xetla-keyword
- "Face to highlight keywords.")
-(set-face-parent 'xetla-keyword 'font-lock-keyword-face)
-
-(make-face 'xetla-comment
- "Face to highlight comments.")
-(set-face-parent 'xetla-comment 'font-lock-comment-face)
-
-(make-face 'xetla-precious
- "Face to highlight precious entries")
-(set-face-parent 'xetla-precious 'font-lock-comment-face)
-
-(make-face 'xetla-unrecognized
- "Face to highlight unrecognized entries")
-(set-face-parent 'xetla-unrecognized 'font-lock-warning-face)
-
-(make-face 'xetla-duplicate
- "Face to highlight files with duplicate IDs")
-(set-face-parent 'xetla-duplicate 'font-lock-warning-face)
-
-(make-face 'xetla-source
- "Face to highlight source code entries")
-(set-face-parent 'xetla-source 'font-lock-string-face)
-
-(make-face 'xetla-junk
- "Face to highlight junk entries")
-(set-face-parent 'xetla-junk 'font-lock-function-name-face)
-
-(make-face 'xetla-nested-tree
- "Face to highlight nested trees")
-(set-face-parent 'xetla-nested-tree 'font-lock-type-face)
-
-(make-face
- 'xetla-to-add
- "Face to highlight a file that should probably be added to the archive.")
-(set-face-parent 'xetla-to-add 'font-lock-comment-face)
-
-(make-face 'xetla-broken-link
- "Face to highlight a broken link")
-(set-face-parent 'xetla-broken-link 'font-lock-warning-face)
-
-(make-face 'xetla-unmerged
- "Face to highlight unmerged patches")
-(set-face-parent 'xetla-unmerged 'font-lock-keyword-face)
-
-(make-face 'xetla-header
- "Face to highlight header in log mode for example")
-(set-face-parent 'xetla-header 'font-lock-function-name-face)
-
-(make-face 'xetla-conflict
- "Face to highlight conflicts")
-(set-face-parent 'xetla-conflict 'font-lock-warning-face)
-
-(make-face 'xetla-modified
- "Face to highlight modified files")
-(set-face-parent 'xetla-modified 'font-lock-function-name-face)
-
-(make-face 'xetla-move
- "Face to highlight moved files/directory")
-(set-face-parent 'xetla-move 'font-lock-function-name-face)
-
-(make-face 'xetla-deleted
- "Face to highlight deleted files")
-(set-face-parent 'xetla-deleted 'font-lock-warning-face)
-
-(make-face 'xetla-added
- "Face to highlight added files")
-(set-face-parent 'xetla-added 'font-lock-warning-face)
-
-(make-face 'xetla-meta-info
- "Face to highlight files with meta-info changes")
-(set-face-parent 'xetla-meta-info 'font-lock-comment-face)
-
-(make-face 'xetla-messages
- "Face to highlight messages in xetla buffers")
-(set-face-parent 'xetla-messages 'font-lock-function-name-face)
-
-(defface xetla-highlight
- '((((class color) (background dark)) (:background "darkblue"))
- (((class color) (background light)) (:background "gold")))
- "Face to use as an alternative to `highlight' face.
-If there could be more than two highlighted things, the user will confuse.
-In such case use this face."
- :group 'xetla-faces)
-
-(defface xetla-mark
- '((((class color) (background dark)) (:foreground "green" :bold t))
- (((class color) (background light)) (:foreground "green3" :bold t))
- (t (:bold t)))
- "Xetla face used to highlight marked file indicator."
- :group 'xetla-faces)
-
-\f
-;; --------------------------------------
-;; Font lock keywords
-;; --------------------------------------
-
-;;
-;; Inventory file mode
-;;
-(defvar xetla-inventory-file-font-lock-keywords
- '(
- ("^#.*$" . xetla-comment)
- ("^[ \t]*\\(backup\\|exclude\\|junk\\|precious\\|unrecognized\\|source\\)\\>[ ]*\\(.*\\)$"
- (1 font-lock-keyword-face)
- (2 font-lock-string-face))
- ("^[ \t]*\\(untagged-source\\)"
- (1 font-lock-builtin-face))
- ("^[ \t]*\\(untagged-source\\) \\(precious\\|source\\|backup\\|junk\\|unrecognized\\)\\>"
- (1 font-lock-builtin-face)
- (2 font-lock-keyword-face))
- ("^[ \t]*\\(explicit\\|tagline\\|names\\|implicit\\)\\>"
- (1 font-lock-builtin-face))
- )
- "Keywords in xetla-inventory-file mode.")
-
-;;
-;; Logs mode
-;;
-(defvar xetla-logs-font-lock-keywords
- '(("^[^ \t]*\\(base\\|patch\\|version\\(fix\\)?\\)-[0-9]+" .
- font-lock-function-name-face))
- "Keywords in xetla-logs-mode.")
-
-;;
-;; Changes mode
-;;
-(defvar xetla-changes-font-lock-keywords
- (append
- '(("^\\* looking for .* to compare with$" . font-lock-function-name-face)
- ("^\\* comparing to .*$" . font-lock-function-name-face)
- ("^\\* dir metadata changed$" . font-lock-function-name-face)
- ("^\\* file metadata changed$" . font-lock-function-name-face)
- ("^\\* modified files" . font-lock-function-name-face)
- ("^\\* added files" . font-lock-function-name-face)
- ("^\\* removed files" . font-lock-function-name-face)
- ("^ +-?-/ .*$" . xetla-meta-info)
- ("^ +- .*$" . xetla-meta-info)
- ("^ *T. .*$" . xetla-nested-tree))
- diff-font-lock-keywords)
- "Keywords in `xetla-changes' mode.")
-
-;;
-;; ChangeLog mode
-;;
-(defvar xetla-changelog-font-lock-keywords
- '((" \\([^ ].+:\\)\n\\(.*$\\)"
- (1 'xetla-keyword)
- (2 'change-log-acknowledgement-face))
- ("\t\\(patch-[0-9]+\\)" (1 'xetla-keyword))
- ("^#.*$" . xetla-comment)
- ("^\\sw.........[0-9:+ ]* GMT"
- (0 'change-log-date-face)
- ("\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.-]+@[A-Za-z0-9_.-]+\\)[>)]" nil nil
- (1 'change-log-name-face)
- (2 'change-log-email-face)))
- ("^.*\\* \\([^ ,:([\n]+\\)"
- (1 'change-log-file-face)
- ("\\=, \\([^ ,:([\n]+\\)" nil nil (1 'change-log-file-face))
- ("\\= (\\([^) ,:\n]+\\)" nil nil (1 'change-log-list-face))
- ("\\=, *\\([^) ,:\n]+\\)" nil nil (1 'change-log-list-face)))
- ("^.*(\\([^) ,:\n]+\\)"
- (1 'change-log-list-face)
- ("\\=, *\\([^) ,:\n]+\\)" nil nil (1 'change-log-list-face)))
- ("\\[!?\\([^]\n]+\\)\\]\\(:\\| (\\)" (1 'change-log-conditionals-face))
- ("<\\([^>\n]+\\)>\\(:\\| (\\)" (1 'change-log-function-face))
- ("\\(^.*\\| \\)\\(From\\|Patch\\(es\\)? by\\|Report\\(ed by\\| from\\)\\|Suggest\\(ed by\\|ion from\\)\\)"
- 2 'change-log-acknowledgement-face))
- "Keywords in `xetla-changelog' mode.")
-
-;;
-;; Log edit mode
-;;
-(defvar xetla-log-edit-font-lock-keywords
- (append
- '(("^\\(Summary\\|Keywords\\): \\(.*$\\)"
- (1 'xetla-header)
- (2 'change-log-conditionals-face)))
- xetla-changelog-font-lock-keywords)
-
- "Keywords in xetla-log-edit mode.")
-
-;;
-;; Cat-Log mode
-;;
-(defvar xetla-cat-log-font-lock-keywords
- (append
- '(("^\\(Revision\\|Archive\\|Creator\\|Date\\|Standard-date\\|Modified-files\\|New-patches\\|Summary\\|Keywords\\|New-files\\|New-directories\\|Removed-files\\|Removed-directories\\|Renamed-files\\|Renamed-directories\\|Modified-directories\\|Removed-patches\\): \\(.*$\\)"
- (1 'xetla-header)
- (2 'change-log-conditionals-face)))
- xetla-changelog-font-lock-keywords)
- "Keywords in `xetla-cat-log-mode'.")
-
-;;
-;; Tips mode
-;;
-(defvar xetla-tips-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map xetla-keyvec-quit 'xetla-buffer-quit)
- (define-key map xetla-keyvec-next 'xetla-tips-next-tip)
- (define-key map xetla-keyvec-previous 'xetla-tips-previous-tip)
- (define-key map [?c] 'xetla-tips-customize)
- map))
-
-\f
-;; --------------------------------------
-;; Auto-mode-alist entries
-;; --------------------------------------
-;;;###autoload(add-to-list 'auto-mode-alist '("/\\(=tagging-method\\|\\.arch-inventory\\)$" . xetla-inventory-file-mode))
-
-;; --------------------------------------
-;; Hooks into other packages and/or functions
-;; --------------------------------------
-
-;;
-;; ediff
-;;
-(defvar xetla-ediff-keymap (copy-keymap xetla-global-keymap)
- "Global keymap used by XEtla in the ediff control buffer.")
-
-(define-key xetla-ediff-keymap xetla-keyvec-log-entry 'xetla-ediff-add-log-entry)
-
-(add-hook 'ediff-keymap-setup-hook
- #'(lambda ()
- (define-key ediff-mode-map xetla-prefix-key xetla-ediff-keymap)))
-
-;;
-;; find-file
-;;
-(add-hook 'find-file-hooks 'xetla-find-file-hook)
-
-;; --------------------------------------
-;; Enables arrow key navigation for left/right
-;; --------------------------------------
-(defvar xetla-use-arrow-keys-for-navigation-list
- '((xetla-inventory-mode-map right 'xetla-inventory-find-file)
- (xetla-inventory-mode-map left 'xetla-inventory-parent-directory)
- (xetla-archive-list-mode-map right 'xetla-archive-list-categories)
- (xetla-archive-list-mode-map left 'xetla-buffer-quit)
- (xetla-category-list-mode-map right 'xetla-category-list-branches)
- (xetla-category-list-mode-map left 'xetla-archives)
- (xetla-branch-list-mode-map right 'xetla-branch-list-versions)
- (xetla-branch-list-mode-map left 'xetla-branch-list-parent-category)
- (xetla-version-list-mode-map right 'xetla-version-list-revisions)
- (xetla-version-list-mode-map left 'xetla-version-list-parent-branch)
- (xetla-revision-list-mode-map left 'xetla-revision-list-parent-version)
- (xetla-revision-list-mode-map right 'xetla-revision-show-changeset)
- (xetla-changes-mode-map left 'xetla-changes-jump-to-change)
- (xetla-changes-mode-map right 'xetla-changes-view-source)
- (xetla-changelog-mode-map left 'xetla-buffer-quit)
- (xetla-process-buffer-mode-map left 'xetla-buffer-quit)
- (xetla-bookmarks-mode-map right 'xetla-bookmarks-inventory)
- ))
-
-(defun xetla-use-arrow-keys-for-navigation (&optional uninstall)
- "Bind the left/right keys for navigation.
-
-This function will be called automatically if variable
-`xetla-use-arrow-keys-for-navigation' is non-nil.
-
-If argument UNINSTALL is non-nil, undefine the keys instead of
-defining it."
- (interactive "P")
- (let ((bl xetla-use-arrow-keys-for-navigation-list) b
- (m xetla-use-arrow-keys-for-navigation))
- (while bl
- (setq b (car bl)
- bl (cdr bl))
- (eval
- (append (list 'define-key
- (car b))
- (cond ((eq nil m)
- (list (vector (cadr b)) nil))
- ((eq 'shift m)
- (if uninstall
- (list (vector (list 'shift (cadr b))) nil)
- (list (vector (list 'shift (cadr b))) (caddr b))))
- ((eq t m)
- (if uninstall
- (list (vector (cadr b)) nil)
- (list (vector (cadr b)) (caddr b))))))))
- (if uninstall
- (message "%sleft/right bindings for xetla have been removed."
- (if (eq 'shift m) "Shifted " ""))
- (message "%sleft/right bindings for xetla have been installed."
- (if (eq 'shift m) "Shifted " "")))))
-
-;; install them if customized
-(if xetla-use-arrow-keys-for-navigation
- (xetla-use-arrow-keys-for-navigation))
-
-(provide 'xetla-defs)
-
-;;; xetla-defs.el ends here
+++ /dev/null
-;;; 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
projects / packages / commitdiff