;;; 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 ;; Maintainer: Steve Youngs ;; Created: 2004-11-25 ;; Keywords: arch archive tla ;; Based on xtla.el by: Stefan Reichoer, ;; 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 ;; Masatake YAMATO ;; Milan Zamazal ;; Martin Pool ;; Robert Widhopf-Fenk ;; Mark Triggs ;; 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 , " "Sebastian Freundt " " --- 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 , " ;; "Contributions from: " ;; "Matthieu Moy , " ;; "Masatake YAMATO , " ;; "Milan Zamazal , " ;; "Martin Pool , " ;; "Robert Widhopf-Fenk , " ;; "Mark Triggs ")) ;; (xetla-message-with-rolling ;; (concat "Author: Stefan Reichoer , " ;; "Contributions from: " ;; "Matthieu Moy , " ;; "Masatake YAMATO , " ;; "Milan Zamazal , " ;; "Martin Pool , " ;; "Robert Widhopf-Fenk , " ;; "Mark Triggs ")) (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 " : " (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 \\\\[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 " (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 [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 bookmark ) (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 ) (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 "") "" 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-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-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]*: $" (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-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-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 . \) \(minor . \) \(minor-minor . \) \(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" "<>\n" "\n" "<>\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 "<>") 1)) (end-pos (- (progn (search-forward ">") (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