cgit.sxemacs.org Git - packages/blob - xemacs-packages/xetla/xetla.el

   1 ;;; xetla.el --- Arch (tla) interface for XEmacs
   2
   3 ;; Copyright (C) 2003-2004 by Stefan Reichoer (GPL)
   4 ;; Copyright (C) 2004 2005 Steve Youngs (BSD)
   5
   6 ;; Author:        Steve Youngs <steve@eicq.org>
   7 ;; Maintainer:    Steve Youngs <steve@eicq.org>
   8 ;; Created:       2004-11-25
   9 ;; Keywords:      arch archive tla
  10
  11 ;; Based on xtla.el by: Stefan Reichoer, <stefan@xsteve.at>
  12
  13 ;; This file is part of XEtla.
  14
  15 ;; Redistribution and use in source and binary forms, with or without
  16 ;; modification, are permitted provided that the following conditions
  17 ;; are met:
  18 ;;
  19 ;; 1. Redistributions of source code must retain the above copyright
  20 ;;    notice, this list of conditions and the following disclaimer.
  21 ;;
  22 ;; 2. Redistributions in binary form must reproduce the above copyright
  23 ;;    notice, this list of conditions and the following disclaimer in the
  24 ;;    documentation and/or other materials provided with the distribution.
  25 ;;
  26 ;; 3. Neither the name of the author nor the names of any contributors
  27 ;;    may be used to endorse or promote products derived from this
  28 ;;    software without specific prior written permission.
  29 ;;
  30 ;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR
  31 ;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  32 ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
  33 ;; DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
  34 ;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  35 ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
  36 ;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
  37 ;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  38 ;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
  39 ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
  40 ;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  41
  42 ;;; Commentary:
  43
  44 ;; Contributions from:
  45 ;;    Matthieu Moy <Matthieu.Moy@imag.fr>
  46 ;;    Masatake YAMATO <jet@gyve.org>
  47 ;;    Milan Zamazal <pdm@zamazal.org>
  48 ;;    Martin Pool <mbp@sourcefrog.net>
  49 ;;    Robert Widhopf-Fenk <hack@robf.de>
  50 ;;    Mark Triggs <mst@dishevelled.net>
  51
  52
  53 ;; The main commands are available with the prefix key C-x T.
  54 ;; Type C-x T C-h for a list.
  55
  56 ;; M-x xetla-inventory shows a xetla inventory
  57 ;; In this inventory buffer the following commands are available:
  58 ;; e ... xetla-edit-log
  59 ;; = ... xetla-changes
  60 ;; l ... xetla-changelog
  61 ;; L ... xetla-logs
  62
  63 ;; To Edit a logfile issue: M-x xetla-edit-log
  64 ;; In this mode you can hit C-c C-d to show the changes
  65 ;; Edit the log file
  66 ;; After that you issue M-x xetla-commit (bound to C-c C-c) to commit the files
  67
  68 ;; M-x xetla-archives starts the interactive archive browser
  69
  70 ;; M-x xetla-make-archive creates a new archive directory
  71 ;; Many commands are available from here.  Look at the menus, they're
  72 ;; very helpful to begin.
  73
  74 ;; M-x xetla-bookmarks RET
  75 ;; Is another good starting point.  This is the place where you put the
  76 ;; project you work on most often, and you can get a new version, see
  77 ;; the missing patches, and a few other useful features from here.
  78 ;; Use `a' to add a bookmark.  Add your own projects, and your
  79 ;; contributor's projects too.  Select several related projects with
  80 ;; `m' (unselect with M-u or M-del).  Make them partners with 'M-p'.
  81 ;; Now, with your cursor on a bookmark, view the uncommitted changes,
  82 ;; the missing patches from your archive and your contributors with
  83 ;; 'M'.
  84
  85 ;; M-x xetla-file-ediff RET
  86 ;; Is an wrapper to xetla file-diff, ediff to view the changes
  87 ;; interactively.
  88
  89 ;; Misc commands:
  90 ;; xetla-tag-insert inserts a arch-tag entry generated with uuidgen
  91
  92 ;; If you find xetla.el useful, and you have some ideas to improve it
  93 ;; please share them with us (Patches are preferred :-))
  94
  95 ;;; Code:
  96
  97 ;;; XEtla/Xtla safety code
  98 ;; You can run into some problems if you have both XEtla and Xtla
  99 ;; installed at the same time.  The following attempts to guard
 100 ;; against it by warning the user and giving them a couple of
 101 ;; functions for disabling one of XEtla or Xtla in their current
 102 ;; session.  Dangerous stuff!!
 103 (defvar xetla-dont-warn-about-xtla nil)
 104
 105 (when (and (featurep 'xtla)
 106            (not xetla-dont-warn-about-xtla))
 107   (xetla-warn-about-xtla))
 108
 109 (defconst xetla-warn-about-xtla-text
 110   "We have detected that you have both XEtla and Xtla installed.
 111
 112 This is never a very good idea (unless you _really_ know what you are
 113 doing) because both packages share similar key bindings and install
 114 similar hooks.
 115
 116 Our suggestion is that you remove either XEtla or Xtla and just use the
 117 other.  For your convenience there is `xetla-attempt-xetla-removal' and
 118 `xetla-attempt-xtla-removal', which will attempt to disable one of the
 119 packages for the current session only.
 120
 121 Use those functions at your own risk.  The best answer is to not load
 122 one of XEtla or Xtla in the first place.
 123
 124 To disable this warning: (setq xetla-dont-warn-about-xtla t).")
 125
 126 (defun xetla-warn-about-xtla ()
 127   "Pop up a big fat warning about trying to use XEtla and xtla together."
 128   (get-buffer-create "*XEtla/Xtla Warning*")
 129   (with-current-buffer "*XEtla/Xtla Warning*"
 130     (erase-buffer)
 131     (insert xetla-warn-about-xtla-text))
 132   (pop-to-buffer "*XEtla/Xtla Warning*"))
 133
 134 (defun xetla-attempt-xetla-removal ()
 135   "Attempt to disable xetla.
 136
 137 **** This is dangerous, use at your own risk. ****
 138
 139 This function attempts to unload all the XEtla features, remove the
 140 `xetla-find-file-hook', remove entries from `auto-mode-alist', and
 141 finally, remove the XEtla lisp directory from the `load-path'.  After
 142 all of this has happened, Xtla should run without problems.  Please
 143 note that we do _NOT_ guarantee that this will work perfectly and you
 144 really should physically remove either XEtla or Xtla.
 145
 146 Use of this function is only valid in the current session, in other
 147 words, it ain't saved."
 148   (interactive)
 149   ;; unload the features
 150   (when (featurep 'xetla-tips)      (unload-feature 'xetla-tips      t))
 151   (when (featurep 'xetla-browse)    (unload-feature 'xetla-browse    t))
 152   (when (featurep 'xetla)           (unload-feature 'xetla           t))
 153   (when (featurep 'xetla-core)      (unload-feature 'xetla-core      t))
 154   (when (featurep 'xetla-defs)      (unload-feature 'xetla-defs      t))
 155   (when (featurep 'xetla-autoloads) (unload-feature 'xetla-autoloads t))
 156   ;; remove the hooks
 157   (remove-hook 'find-file-hooks 'xetla-find-file-hook)
 158   ;; clean out auto-mode-alist
 159   (setq auto-mode-alist
 160         (delete '("\\+\\+log\\." . xetla-log-edit-mode) auto-mode-alist))
 161   (setq auto-mode-alist
 162         (delete '("/\\(=tagging-method\\|\\.arch-inventory\\)$" . xetla-inventory-file-mode)
 163                 auto-mode-alist))
 164   ;; clean out the load-path
 165   (setq load-path
 166         (remove (file-name-directory (locate-library "xetla")) load-path))
 167   ;; did I miss anything?
 168   ;; what can we do about key bindings?
 169
 170   (message "To ensure correct key bindings, please reload Xtla"))
 171
 172 (defun xetla-attempt-xtla-removal ()
 173   "Attempt to disable Xtla.
 174
 175 **** This is dangerous, use at your own risk. ****
 176
 177 This function attempts to unload all the Xtla features, remove the
 178 `tla-find-file-hook', remove entries from `auto-mode-alist', and
 179 finally, remove the XEtla lisp directory from the `load-path'.  After
 180 all of this has happened, XEtla should run without problems.  Please
 181 note that we do _NOT_ guarantee that this will work perfectly and you
 182 really should physically remove either XEtla or Xtla.
 183
 184 Use of this function is only valid in the current session, in other
 185 words, it ain't saved."
 186   (interactive)
 187   ;; unload the features
 188   (when (featurep 'xtla-tips)      (unload-feature 'xtla-tips      t))
 189   (when (featurep 'xtla-browse)    (unload-feature 'xtla-browse    t))
 190   (when (featurep 'xtla)           (unload-feature 'xtla           t))
 191   (when (featurep 'xtla-core)      (unload-feature 'xtla-core      t))
 192   (when (featurep 'xtla-defs)      (unload-feature 'xtla-defs      t))
 193   (when (featurep 'xtla-emacs)     (unload-feature 'xtla-emacs     t))
 194   (when (featurep 'xtla-xemacs)    (unload-feature 'xtla-xemacs    t))
 195   (when (featurep 'xtla-autoloads) (unload-feature 'xtla-autoloads t))
 196   ;; remove the hooks
 197   (remove-hook 'find-file-hooks 'tla-find-file-hook)
 198   ;; clean out auto-mode-alist
 199   (setq auto-mode-alist
 200         (delete '("\\+\\+log\\." . tla-log-edit-mode) auto-mode-alist))
 201   (setq auto-mode-alist
 202         (delete '("/\\(=tagging-method\\|\\.arch-inventory\\)$" . tla-inventory-file-mode)
 203                 auto-mode-alist))
 204   ;; clean out the load-path
 205   (setq load-path
 206         (remove (file-name-directory (locate-library "xtla")) load-path))
 207   ;; did I miss anything?
 208   ;; what can we do about key bindings?
 209   (message "To ensure correct key bindings, please reload XEtla"))
 210
 211 ;;; End XEtls/Xtla safety code
 212
 213
 214 (eval-and-compile
 215   (when (locate-library "xetla-version")
 216     (require 'xetla-version)))
 217
 218 (eval-when-compile (require 'cl))
 219
 220 ;; gnus is optional. Load it at compile-time to avoid warnings.
 221 (eval-when-compile
 222   (autoload 'gnus-article-part-wrapper "gnus-art")
 223   (autoload 'gnus-article-show-summary "gnus-art" nil t)
 224   (autoload 'gnus-summary-select-article-buffer "gnus-sum" nil t)
 225   (autoload 'mm-save-part-to-file "mm-decode")
 226   (autoload 'mml-attach-file "mml" nil t))
 227
 228 (eval-and-compile
 229   (require 'ediff)
 230   (require 'font-lock))
 231
 232 (require 'sendmail)
 233 (require 'pp)
 234 (require 'ewoc)
 235 (require 'diff)
 236 (require 'diff-mode)
 237
 238 (eval-and-compile
 239   (require 'xetla-defs)
 240   (require 'xetla-core))
 241
 242 (eval-when-compile
 243   (when (locate-library "smerge-mode")
 244     (require 'smerge-mode))
 245
 246   (when (locate-library "hl-line")
 247     (require 'hl-line)))
 248
 249 (eval-when-compile
 250   (autoload 'dired "dired" nil t)
 251   (autoload 'dired-make-relative "dired")
 252   (autoload 'dired-other-window "dired" nil t)
 253   (autoload 'minibuffer-prompt-end "completer")
 254   (autoload 'regexp-opt "regexp-opt")
 255   (autoload 'reporter-submit-bug-report "reporter")
 256   (autoload 'view-file-other-window "view-less" nil t)
 257   (autoload 'view-mode "view-less" nil t)
 258   (autoload 'with-electric-help "ehelp"))
 259
 260 ;; --------------------------------------
 261 ;; Internal variables
 262 ;; --------------------------------------
 263 (defvar xetla-edit-arch-command nil)
 264 (defvar xetla-pre-commit-window-configuration nil)
 265 (defvar xetla-log-edit-file-name nil)
 266 (defvar xetla-log-edit-file-buffer nil)
 267 (defvar xetla-my-id-history nil)
 268 (defvar xetla-memorized-log-header nil)
 269 (defvar xetla-memorized-log-message nil)
 270 (defvar xetla-memorized-version nil)
 271
 272 (defvar xetla-buffer-archive-name nil)
 273 (defvar xetla-buffer-category-name nil)
 274 (defvar xetla-buffer-branch-name nil)
 275 (defvar xetla-buffer-version-name nil)
 276 (defvar xetla-buffer-refresh-function nil
 277   "Variable should be local to each buffer.
 278 Function used to refresh the current buffer")
 279 (defvar xetla-buffer-marked-file-list nil
 280   "List of marked files in the current buffer.")
 281 (defvar xetla-get-revision-info-at-point-function nil
 282   "Variable should be local to each buffer.
 283 Function used to get the revision info at point")
 284
 285 (defvar xetla-mode-line-process "")
 286 (defvar xetla-mode-line-process-status "")
 287
 288 ;; Extent category
 289 (put 'xetla-default-button 'mouse-face 'highlight)
 290 (put 'xetla-default-button 'evaporate t)
 291 ;;(put 'xetla-default-button 'rear-nonsticky t)
 292 ;;(put 'xetla-default-button 'front-nonsticky t)
 293
 294 ;;;###autoload
 295 (defun xetla ()
 296   "Displays a welcome message."
 297   (interactive)
 298   (let* ((name "*xetla-welcome*")
 299          (buffer (get-buffer name)))
 300     (if buffer (xetla-switch-to-buffer buffer)
 301       (xetla-switch-to-buffer
 302        (setq buffer (get-buffer-create name)))
 303       (insert "            *** Welcome to XEtla ! ***
 304
 305 XEtla is the XEmacs frontend to the revision control system GNU/arch (tla).
 306
 307 As a starting point, you should look at the \"Tools\" menu, there is a
 308 \"XEtla\" entry with a lot of interesting commands.
 309
 310 There is also a manual for XEtla. It should be available using the
 311 Info system, however it is still just a skeleton file with no
 312 information in it yet.  Well, you know how much hackers just love
 313 doing documentation. :-)
 314
 315 Hope you'll enjoy it !
 316 ")
 317       (insert
 318        "\n"
 319        ""
 320        "[" (xetla-insert-button "Bookmarks" 'xetla-bookmarks)
 321        "]"
 322        "[" (xetla-insert-button "Inventory" 'xetla-inventory)
 323        "]"
 324        "[" (xetla-insert-button "Browse Archives" (if (fboundp 'xetla-browse)
 325                                                       'xetla-browse
 326                                                     'xetla-archives))
 327        "]"
 328        "[" (xetla-insert-button "Browse Revisions" 'xetla-revisions)
 329        "]"
 330        "[" (xetla-insert-button "Report Bug" 'xetla-submit-bug-report)
 331        "]"
 332        "\n")
 333       (toggle-read-only t)
 334       (local-set-key [?q] (lambda () (interactive)
 335                             (kill-buffer (current-buffer)))))
 336     (xetla-message-with-bouncing
 337      (concat "XEtla core development team: "
 338              "Steve Youngs <steve@eicq.org>, "
 339              "Sebastian Freundt <freundt@math.tu-berlin.de> "
 340              " --- We hope you have as much fun using XEtla "
 341              "as we have had in hacking it for you."))))
 342
 343 (defun xetla-insert-button (label function)
 344   "Insert a button labeled with LABEL and launching FUNCTION.
 345 Helper function for `xetla'."
 346   (xetla-face-add label 'bold
 347                  (let ((map (make-sparse-keymap)))
 348                    (define-key map [return]  function)
 349                    (define-key map "\C-m"    function)
 350                    (define-key map [button2] function)
 351                    map)
 352                  nil))
 353
 354 (defun xetla-face-add-with-condition (condition text face1 face2)
 355   "If CONDITION then add TEXT the face FACE1, else add FACE2."
 356   (if condition
 357       (xetla-face-add text face1)
 358     (xetla-face-add text face2)))
 359
 360 (defun xetla-face-set-temporary-during-popup (face begin end menu &optional prefix)
 361   "Put FACE on BEGIN and END in the buffer during Popup MENU.
 362 PREFIX is passed to `popup-menu'."
 363   (let (o)
 364     (unwind-protect
 365         (progn
 366           (setq o (make-extent begin end))
 367           (set-extent-face o face)
 368           (sit-for 0)
 369           (popup-menu menu prefix))
 370       (delete-extent o))))
 371
 372 (defconst xetla-mark (xetla-face-add "*" 'xetla-mark)
 373   "Fontified string used for marking.")
 374
 375 ;; --------------------------------------
 376 ;; Macros
 377 ;; --------------------------------------
 378 (defmacro xetla-toggle-list-entry (list entry)
 379   "Either add or remove from the value of LIST the value ENTRY."
 380   `(if (member ,entry ,list)
 381        (setq ,list (delete ,entry ,list))
 382      (add-to-list ',list ,entry)))
 383
 384 ;; --------------------------------------
 385 ;; Common used functions for many xetla modes
 386 ;; --------------------------------------
 387 (defun xetla-kill-all-buffers ()
 388   "Kill all xetla buffers."
 389   (interactive)
 390   (let ((number 0))
 391     (dolist (type-cons xetla-buffers-tree)
 392       (dolist (path-buffer (cdr type-cons))
 393         (setq number (1+ number))
 394         (kill-buffer (cadr path-buffer))))
 395     (message "Killed %d buffer%s" number
 396              (if (> number 1) "s" "")))
 397   (setq xetla-buffers-tree nil))
 398
 399 (defvar xetla-buffer-previous-window-config nil
 400   "Window-configuration to return to on buffer quit.
 401
 402 If nil, nothing is done special.  Otherwise, must be a
 403 window-configuration.  `xetla-buffer-quit' will restore this
 404 window-configuration.")
 405
 406 (make-variable-buffer-local 'xetla-buffer-previous-window-config)
 407
 408 (defun xetla-buffer-quit ()
 409   "Quit the current buffer.
 410
 411 If `xetla-buffer-quit-mode' is 'kill, then kill the buffer.  Otherwise,
 412 just burry it."
 413   (interactive)
 414   ;; Value is buffer local => keep it before killing the buffer!
 415   (let ((prev-wind-conf xetla-buffer-previous-window-config))
 416     (if (eq xetla-buffer-quit-mode 'kill)
 417         (kill-buffer (current-buffer))
 418       (bury-buffer))
 419     (when prev-wind-conf
 420       (set-window-configuration prev-wind-conf))))
 421
 422 (defun xetla-edit-=tagging-method-file ()
 423   "Edit the {arch}/=tagging-method file."
 424   (interactive)
 425   (find-file (expand-file-name "{arch}/=tagging-method" (xetla-tree-root))))
 426
 427 (defun xetla-edit-.arch-inventory-file (&optional dir)
 428   "Edit DIR/.arch-inventory file.
 429 `default-directory' is used as DIR if DIR is nil.
 430 If it is called interactively and the prefix argument is given via DIR,
 431 use the directory of a file associated with the point to find .arch-inventory.
 432 In the case no file is associated with the point, it reads the directory name
 433 with `read-directory-name'."
 434   (interactive
 435    (list (if (not (interactive-p))
 436              default-directory
 437            (let ((file (xetla-get-file-info-at-point)))
 438              (if file
 439                  (if (not (file-name-absolute-p file))
 440                      (concat default-directory
 441                              (file-name-directory file))
 442                    (file-name-directory file))
 443                (expand-file-name (read-directory-name
 444                                   "Directory containing \".arch-inventory\":  ")))))))
 445   (let* ((dir (or dir default-directory))
 446          (file (expand-file-name ".arch-inventory" dir))
 447          (newp (not (file-exists-p file))))
 448     (find-file file)
 449     (save-excursion
 450       (when (and newp (y-or-n-p
 451                        (format "Insert arch tag to \"%s\"? " file)))
 452         (xetla-tag-insert)))))
 453
 454 (defun xetla-ewoc-delete (cookie elem)
 455   "Remove element from COOKIE the element ELEM."
 456   (ewoc-filter cookie
 457                '(lambda (x) (not (eq x (ewoc-data elem))))))
 458
 459 (defun xetla-generic-refresh ()
 460   "Call the function specified by `xetla-buffer-refresh-function'."
 461   (interactive)
 462   (let ((xetla-read-directory-mode 'never)
 463         (xetla-read-project-tree-mode 'never))
 464     (funcall xetla-buffer-refresh-function)))
 465
 466 (defun xetla-get-info-at-point ()
 467   "Get the version information that point is on."
 468   (when (fboundp xetla-get-revision-info-at-point-function)
 469     (funcall xetla-get-revision-info-at-point-function)))
 470
 471 (defvar xetla-window-config nil
 472   "Used for inter-function communication.")
 473
 474 (defun xetla-ediff-buffers (bufferA bufferB)
 475   "Wrapper around `ediff-buffers'.
 476
 477 Calls `ediff-buffers' on BUFFERA and BUFFERB."
 478   (let ((xetla-window-config (current-window-configuration)))
 479     (ediff-buffers bufferA bufferB
 480                    '(xetla-ediff-startup-hook) 'xetla-ediff)))
 481
 482 (defun xetla-insert-right-justified (string count &optional face)
 483   "Insert a string with a right-justification.
 484
 485 Inserts STRING preceded by spaces so that the line ends exactly at
 486 COUNT characters (or after if STRING is too long).
 487 If FACE is non-nil, insert the string fontified with FACE."
 488   (insert-char ?\  (max 0 (- count (length string))))
 489   (insert (if face (xetla-face-add string face) string))
 490   )
 491
 492 (defun xetla-generic-popup-menu (event prefix)
 493   "Generic function to popup a menu.
 494
 495 The menu is defined in the text property under the point which is
 496 given by mouse.  EVENT is the mouse event that called the function.
 497 PREFIX is passed to `xetla-generic-popup-menu-by-keyboard'."
 498   (interactive "e\nP")
 499   (mouse-set-point event)
 500   (xetla-generic-popup-menu-by-keyboard prefix))
 501
 502
 503 (defun xetla-generic-popup-menu-by-keyboard (prefix)
 504   "Popup a menu defined in the text property under the point.
 505
 506 PREFIX is passed to `popup-menu'."
 507   (interactive "P")
 508   (if (get-text-property (point) 'menu)
 509       (let* ((menu (get-text-property (point) 'menu))
 510              (p (previous-single-property-change (point) 'menu nil
 511                                                  (point-at-bol)))
 512              (n (next-single-property-change (point) 'menu nil
 513                                              (point-at-eol)))
 514              (b (if (and p (get-text-property p 'menu)) p (point)))
 515              (e (if n n (point))))
 516         (xetla-face-set-temporary-during-popup 'xetla-highlight
 517                                               b e
 518                                               menu
 519                                               prefix))
 520     (error "No context-menu under the point")))
 521
 522
 523 ;; Test cases
 524 ;; (xetla-message-with-bouncing
 525 ;;  (concat "Author: Stefan Reichoer <stefan@xsteve.at>, "
 526 ;;          "Contributions from: "
 527 ;;          "Matthieu Moy <Matthieu.Moy@imag.fr>, "
 528 ;;          "Masatake YAMATO <jet@gyve.org>, "
 529 ;;          "Milan Zamazal <pdm@zamazal.org>, "
 530 ;;          "Martin Pool <mbp@sourcefrog.net>, "
 531 ;;          "Robert Widhopf-Fenk <hack@robf.de>, "
 532 ;;          "Mark Triggs <mst@dishevelled.net>"))
 533 ;; (xetla-message-with-rolling
 534 ;;  (concat "Author: Stefan Reichoer <stefan@xsteve.at>, "
 535 ;;          "Contributions from: "
 536 ;;          "Matthieu Moy <Matthieu.Moy@imag.fr>, "
 537 ;;          "Masatake YAMATO <jet@gyve.org>, "
 538 ;;          "Milan Zamazal <pdm@zamazal.org>, "
 539 ;;          "Martin Pool <mbp@sourcefrog.net>, "
 540 ;;          "Robert Widhopf-Fenk <hack@robf.de>, "
 541 ;;          "Mark Triggs <mst@dishevelled.net>"))
 542 (defvar xetla-message-long-default-interval 0.2
 543   "Default animation step interval.
 544
 545 Used in `xetla-message-with-bouncing' and `xetla-message-with-rolling'")
 546
 547 (defvar xetla-message-long-border-interval 1.0
 548   "Animation step interval when bouncing in `xetla-message-with-bouncing'.")
 549
 550 (defun* xetla-message-with-bouncing (&rest msg)
 551   "Similar to `message' but display the message in bouncing animation to show long line."
 552   (setq msg (apply 'format msg))
 553   (let* ((width (- (window-width (minibuffer-window))
 554                    (+ 1 (length "[<] ") (length " [>]"))))
 555          (msglen (length msg))
 556          submsg
 557          (steps (- msglen width))
 558          j)
 559     (if (< msglen width)
 560         (message "%s" msg)
 561       (while t
 562         ;; Go forward
 563         (dotimes (i steps)
 564           (setq submsg (substring msg i (+ i width)))
 565           (message "[<] %s [ ]" submsg)
 566           (unless (sit-for (cond
 567                             ((eq i 0) xetla-message-long-border-interval)
 568                             (t xetla-message-long-default-interval)))
 569             (return-from xetla-message-with-bouncing)))
 570         ;; Go back
 571         (dotimes (i steps)
 572           (setq j (- steps i))
 573           (setq submsg (substring msg j (+ j width)))
 574           (message "[ ] %s [>]" submsg)
 575           (unless (sit-for (cond
 576                             ((eq i 0) xetla-message-long-border-interval)
 577                             (t xetla-message-long-default-interval)))
 578             (return-from xetla-message-with-bouncing)))
 579         (garbage-collect)))))
 580
 581 (defun* xetla-message-with-rolling (&rest msg)
 582   "Similar to `message' but display the message in rolling animation to show long line."
 583   (setq msg (concat "  <MESSAGE>: "
 584                     (apply 'format msg)
 585                     "            "))
 586   (let* ((width (- (window-width (minibuffer-window))
 587                    (+ 1 (length "[<] "))))
 588          (msglen (length msg))
 589          submsg
 590          (normal-range (- msglen width)))
 591     (if (< msglen width)
 592         (message "%s" msg)
 593       (while t
 594         (dotimes (i msglen)
 595           (setq submsg (if (< i normal-range)
 596                            (substring msg i (+ i width))
 597                          ;; Rolling is needed.
 598                          (concat (substring msg i)
 599                                  (substring msg 0 (- (+ i width) msglen)))))
 600           (message "[<] %s" submsg)
 601           (unless (sit-for (cond
 602                             ((eq i 0) xetla-message-long-border-interval)
 603                             (t xetla-message-long-default-interval)))
 604             (return-from xetla-message-with-rolling)))
 605           (garbage-collect)))))
 606
 607 ;; --------------------------------------
 608 ;; Name read engine helpers
 609 ;; --------------------------------------
 610 ;;
 611 ;; Extended version of xetla-read-name
 612 ;;
 613 (defun xetla-name-read-help ()
 614   "Displays a help message with keybindings for the minibuffer prompt."
 615   (interactive)
 616   (set-buffer (get-buffer-create "*Help*"))
 617   (let ((inhibit-read-only t))
 618     (erase-buffer)
 619     (kill-all-local-variables)
 620     (help-mode)
 621     (view-mode -1)
 622     (insert "This buffer describes the name reading engine for xetla
 623
 624 You are prompted for a fully qualified archive, category, branch,
 625 version, or revision, which means a string like
 626 \"John.Smith@rt.fm-arch/xetla-revolutionary-1.0\". Completion is
 627 available with TAB. Only the item being entered is proposed for
 628 completion, which means that if you're typing the archive name,
 629 pressing TAB will give you the list of archives. If you started to
 630 type the category name, you'll get the list of category for this
 631 archive.
 632
 633 Here's a list of other interesting bindings available in the
 634 minibuffer:
 635
 636 ")
 637     (let ((interesting (mapcar (lambda (pair) (cdr pair))
 638                                xetla-name-read-extension-keydefs)))
 639       (dolist (func interesting)
 640         (let* ((keys (where-is-internal func xetla-name-read-minibuf-map))
 641                (keys1 ""))
 642           (while keys
 643             (when (not (eq 'menu-bar (aref (car keys) 0)))
 644               (setq keys1 (if (string= keys1 "") (key-description (car keys))
 645                             (concat keys1 ", "
 646                                     (key-description (car keys))))))
 647             (setq keys (cdr keys)))
 648           (insert (format "%s%s\t`%s'\n" keys1
 649                           (make-string (max 0 (- 5 (length keys1))) ?\ )
 650                           (symbol-name func))))))
 651     (goto-char (point-min))
 652     (xetla-funcall-if-exists
 653      help-setup-xref (list 'xetla-name-read-help)
 654      (interactive-p)))
 655   (display-buffer (current-buffer))
 656   (toggle-read-only 1))
 657
 658 (defun xetla-name-read-inline-help ()
 659   "Displays a help message in echo area."
 660   (interactive)
 661   (let ((interesting (mapcar (lambda (pair) (cdr pair))
 662                              xetla-name-read-extension-keydefs))
 663         (line ""))
 664     (dolist (func interesting)
 665         (let* ((keys (where-is-internal func xetla-name-read-minibuf-map))
 666                (keys1 "")
 667                (func (symbol-name func)))
 668           (while keys
 669             (when (not (eq 'menu-bar (aref (car keys) 0)))
 670               (setq keys1 (if (string= keys1 "") (key-description (car keys))
 671                             (concat keys1 ", "
 672                                     (key-description (car keys))))))
 673             (setq keys (cdr keys)))
 674           (setq func (progn (string-match "xetla-name-read-\\(.+\\)"
 675                                           func)
 676                             (match-string 1 func)))
 677           (setq line (concat line (format "%s => `%s'" keys1 func) "    "))))
 678     (xetla-message-with-rolling line)
 679     ))
 680
 681
 682
 683
 684 (defun xetla-read-revision-with-default-tree (&optional prompt tree)
 685   "Read revision name with `xetla-name-read'.
 686 PROMPT is passed to `xetla-name-read' without changing.
 687 Default version associated with TREE, a directory is used as default arguments
 688 for`xetla-name-read'."
 689   (setq tree (xetla-tree-root (or tree default-directory) t))
 690   (let ((tree-rev (xetla-tree-version-list tree)))
 691     (xetla-name-read prompt
 692                     (if tree-rev (xetla-name-archive tree-rev) 'prompt)
 693                     (if tree-rev (xetla-name-category tree-rev) 'prompt)
 694                     (if tree-rev (xetla-name-branch tree-rev) 'prompt)
 695                     (if tree-rev (xetla-name-version tree-rev) 'prompt)
 696                     'prompt)))
 697
 698 ;;
 699 ;; Version for the tree of default directory
 700 ;;
 701 (defvar xetla-name-read-insert-version-associated-with-default-directory nil)
 702 (defun xetla-name-read-insert-version-associated-with-default-directory (&optional force)
 703   "Insert the version for the tree of the directory specified by .
 704
 705 If FORCE is non-nil, insert the version even if the minibuffer isn't empty."
 706   (interactive "P")
 707   (let ((version-for-tree
 708          (xetla-name-mask
 709           (xetla-tree-version-list
 710            (if xetla-name-read-insert-version-associated-with-default-directory
 711                xetla-name-read-insert-version-associated-with-default-directory
 712              default-directory))
 713           t
 714           (xetla-name-read-arguments 'archive)
 715           (xetla-name-read-arguments 'category)
 716           (xetla-name-read-arguments 'branch)
 717           (xetla-name-read-arguments 'version))))
 718     (if (and (window-minibuffer-p (selected-window))
 719              (or force (equal "" (buffer-substring))))
 720         (insert version-for-tree))))
 721
 722 ;;
 723 ;; Default archive
 724 ;;
 725 (defun xetla-name-read-insert-default-archive (&optional force)
 726   "Insert default archive name into the minibuffer if it is empty.
 727
 728 If FORCE is non-nil, insert the archive name even if the minibuffer
 729 isn't empty."
 730   (interactive "P")
 731   (if (and (window-minibuffer-p (selected-window))
 732            (or (equal "" (buffer-substring)) force)
 733            (member
 734             (xetla-name-read-arguments 'archive)
 735             '(prompt maybe)))
 736       (insert (xetla-my-default-archive))))
 737
 738 ;;
 739 ;; Info at point
 740 ;;
 741 (defvar xetla-name-read-insert-info-at-point nil)
 742 (defvar xetla-name-read-insert-info-at-point-extent nil)
 743 (defun xetla-name-read-insert-info-at-point (&optional force)
 744   "Insert the info(maybe revision) under the point to the minibuffer.
 745
 746 If FORCE is non-nil, insert the version even if the minibuffer isn't
 747 empty."
 748   (interactive "P")
 749   (let ((info-at-point
 750          (or xetla-name-read-insert-info-at-point
 751              (xetla-name-read-insert-version-associated-with-default-directory))))
 752     (when (and (window-minibuffer-p (selected-window))
 753                (or (equal "" (buffer-substring)) force)
 754                info-at-point)
 755       (insert info-at-point))))
 756
 757 (defun xetla-name-read-insert-info-at-point-init ()
 758   "This function retrieves the info at point.
 759
 760 Further call to `xetla-name-read-insert-info-at-point-final' will
 761 actuall insert the value computed here."
 762   (setq xetla-name-read-insert-info-at-point
 763         (let ((raw-info (cadr (xetla-get-info-at-point)))
 764               (b (previous-single-property-change (point) 'menu))
 765               (e (next-single-property-change (point) 'menu)))
 766           (when raw-info
 767             (when (and b e)
 768               (setq xetla-name-read-insert-info-at-point-extent
 769                     (make-extent (1- b) e))
 770               (set-extent-property xetla-name-read-insert-info-at-point-extent
 771                            'face 'xetla-highlight))
 772             (xetla-name-mask
 773              (xetla-name-split raw-info) t
 774              (xetla-name-read-arguments 'archive)
 775              (xetla-name-read-arguments 'category)
 776              (xetla-name-read-arguments 'branch)
 777              (xetla-name-read-arguments 'version)
 778              (xetla-name-read-arguments 'revision))))))
 779
 780 (defun xetla-name-read-insert-info-at-point-final (&optional no-use)
 781   "Called when exitting the minibuffer prompt.
 782
 783 Cancels the effect of `xetla-name-read-insert-info-at-point-init'.
 784
 785 Argument NO-USE is ignored."
 786   (when xetla-name-read-insert-info-at-point-extent
 787     (delete-extent xetla-name-read-insert-info-at-point-extent)
 788     (setq xetla-name-read-insert-info-at-point-extent nil)))
 789
 790 ;;
 791 ;; Partner file
 792 ;;
 793 (defvar xetla-name-read-insert-partner-ring-position nil)
 794 (defun xetla-name-read-insert-partner-init ()
 795   "Initialize \"Insert Partner Version\" menu used in `xetla-name-read'."
 796   (setq xetla-name-read-insert-partner-ring-position nil)
 797   ;; Create menu items
 798   (setq xetla-name-read-partner-menu (cons "Insert Partner Version" nil))
 799   (let ((partners (reverse (xetla-partner-list))))
 800     (mapc (lambda (p)
 801             (setq p (xetla-name-mask
 802                      (xetla-name-split p) t
 803                      (xetla-name-read-arguments 'archive)
 804                      (xetla-name-read-arguments 'category)
 805                      (xetla-name-read-arguments 'branch)
 806                      (xetla-name-read-arguments 'version)
 807                      (xetla-name-read-arguments 'revision)))
 808             (setcdr xetla-name-read-partner-menu
 809                     (cons (cons p
 810                                 (cons p
 811                                       `(lambda () (interactive)
 812                                          (delete-region
 813                                           (minibuffer-prompt-end) (point-max))
 814                                          (insert ,p))))
 815                           (cdr xetla-name-read-partner-menu))))
 816           partners))
 817   (fset 'xetla-name-read-partner-menu (cons 'keymap xetla-name-read-partner-menu)))
 818
 819 (defun xetla-name-read-insert-partner-previous ()
 820   "Insert the previous partner version into miniffer."
 821   (interactive)
 822   (let* ((partners (xetla-partner-list))
 823          (plen (length partners))
 824          (pos (if xetla-name-read-insert-partner-ring-position
 825                   (if (eq xetla-name-read-insert-partner-ring-position 0)
 826                       (1- plen)
 827                     (1- xetla-name-read-insert-partner-ring-position))
 828                 0))
 829          (pversion (when partners (xetla-name-mask
 830                                    (xetla-name-split (nth pos partners)) t
 831                                    (xetla-name-read-arguments 'archive)
 832                                    (xetla-name-read-arguments 'category)
 833                                    (xetla-name-read-arguments 'branch)
 834                                    (xetla-name-read-arguments 'version)
 835                                    (xetla-name-read-arguments 'revision)))))
 836     (when (and (window-minibuffer-p (selected-window))
 837                partners
 838                pversion)
 839       (delete-region (minibuffer-prompt-end) (point-max))
 840       (insert pversion)
 841       (setq xetla-name-read-insert-partner-ring-position pos))))
 842
 843 (defun xetla-name-read-insert-partner-next ()
 844   "Insert the next partner version into the miniffer."
 845   (interactive)
 846   (let* ((partners (xetla-partner-list))
 847          (plen (length partners))
 848          (pos (if xetla-name-read-insert-partner-ring-position
 849                   (if (eq xetla-name-read-insert-partner-ring-position (1- plen))
 850                       0
 851                     (1+ xetla-name-read-insert-partner-ring-position))
 852                 0))
 853          (pversion (when partners (xetla-name-mask
 854                                    (xetla-name-split (nth pos partners)) t
 855                                    (xetla-name-read-arguments 'archive)
 856                                    (xetla-name-read-arguments 'category)
 857                                    (xetla-name-read-arguments 'branch)
 858                                    (xetla-name-read-arguments 'version)
 859                                    (xetla-name-read-arguments 'revision)))))
 860     (when (and (window-minibuffer-p (selected-window))
 861                partners
 862                pversion)
 863       (delete-region (minibuffer-prompt-end) (point-max))
 864       (insert pversion)
 865       (setq xetla-name-read-insert-partner-ring-position pos))))
 866
 867 ;;
 868 ;; Ancestor
 869 ;;
 870 (defun xetla-name-read-insert-ancestor (&optional force)
 871   "Insert the ancestor name into the minibuffer if it is empty.
 872
 873 If FORCE is non-nil, insert the ancestor even if the minibuffer isn't
 874 empty."
 875   (interactive "P")
 876   (let* ((version (xetla-tree-version-list default-directory))
 877          (ancestor (when (and version
 878                               (not (eq this-command 'xetla-compute-direct-ancestor)))
 879                      (xetla-compute-direct-ancestor
 880                       (xetla-name-mask version nil
 881                                       t t t t "base-0")))))
 882     (when (and ancestor
 883                (window-minibuffer-p (selected-window))
 884                (or (equal "" (buffer-substring)) force)
 885                (member
 886                 (xetla-name-read-arguments 'archive)
 887                 '(prompt maybe)))
 888       (insert (xetla-name-mask
 889                ancestor t
 890                t
 891                (member
 892                 (xetla-name-read-arguments 'category)
 893                 '(prompt maybe))
 894                (member
 895                 (xetla-name-read-arguments 'branch)
 896                 '(prompt maybe))
 897                (member
 898                 (xetla-name-read-arguments 'version)
 899                 '(prompt maybe))
 900                (member
 901                 (xetla-name-read-arguments 'revision)
 902                 '(prompt maybe)))))))
 903
 904 ;;
 905 ;; Partners in Bookmark
 906 ;;
 907 (defvar xetla-name-read-insert-bookmark-ring-position nil)
 908 (defun xetla-name-read-insert-bookmark-init ()
 909   "Initialize \"Insert Version in Bookmark\" menu used in `xetla-name-read'."
 910   (setq xetla-name-read-insert-bookmark-ring-position nil)
 911   ;; Create menu items
 912   (setq xetla-name-read-bookmark-menu (cons "Insert Version in Bookmark" nil))
 913   (let* ((default-version (xetla-tree-version-list default-directory 'no-error))
 914          (bookmarks (when default-version
 915                       (nreverse (xetla-bookmarks-get-partner-versions default-version)))))
 916     (mapc (lambda (p)
 917             (setq p (xetla-name-mask
 918                      p t
 919                      (xetla-name-read-arguments 'archive)
 920                      (xetla-name-read-arguments 'category)
 921                      (xetla-name-read-arguments 'branch)
 922                      (xetla-name-read-arguments 'version)
 923                      (xetla-name-read-arguments 'revision)))
 924             (setcdr xetla-name-read-bookmark-menu
 925                     (cons (cons p
 926                                 (cons p
 927                                       `(lambda () (interactive)
 928                                          (delete-region
 929                                           (minibuffer-prompt-end) (point-max))
 930                                          (insert ,p))))
 931                           (cdr xetla-name-read-bookmark-menu))))
 932           bookmarks))
 933   (fset 'xetla-name-read-bookmark-menu (cons 'keymap xetla-name-read-bookmark-menu)))
 934
 935 (defun xetla-name-read-insert-bookmark-previous ()
 936   "Insert the previous partner version in the bookmark into minibuffer."
 937   (interactive)
 938   (let* ((default-version (xetla-tree-version-list default-directory))
 939          (bookmarks (when default-version
 940                       (nreverse (xetla-bookmarks-get-partner-versions default-version))))
 941          (plen (length bookmarks))
 942          (pos (if xetla-name-read-insert-bookmark-ring-position
 943                   (if (eq xetla-name-read-insert-bookmark-ring-position 0)
 944                       (1- plen)
 945                     (1- xetla-name-read-insert-bookmark-ring-position))
 946                 0))
 947          (pversion (when bookmarks (xetla-name-mask
 948                                     (nth pos bookmarks) t
 949                                     (xetla-name-read-arguments 'archive)
 950                                     (xetla-name-read-arguments 'category)
 951                                     (xetla-name-read-arguments 'branch)
 952                                     (xetla-name-read-arguments 'version)
 953                                     (xetla-name-read-arguments 'revision)))))
 954     (when (and (window-minibuffer-p (selected-window))
 955                bookmarks
 956                pversion)
 957       (delete-region (minibuffer-prompt-end) (point-max))
 958       (insert pversion)
 959       (setq xetla-name-read-insert-bookmark-ring-position pos))))
 960
 961 (defun xetla-name-read-insert-bookmark-next ()
 962   "Insert the next partner version in the bookmark into the miniffer."
 963   (interactive)
 964   (let* ((default-version (xetla-tree-version-list default-directory))
 965          (bookmarks (when default-version
 966                       (nreverse (xetla-bookmarks-get-partner-versions default-version))))
 967          (plen (length bookmarks))
 968          (pos (if xetla-name-read-insert-bookmark-ring-position
 969                   (if (eq xetla-name-read-insert-bookmark-ring-position (1- plen))
 970                       0
 971                     (1+ xetla-name-read-insert-bookmark-ring-position))
 972                 0))
 973          (pversion (when bookmarks (xetla-name-mask
 974                                     (nth pos bookmarks) t
 975                                     (xetla-name-read-arguments 'archive)
 976                                     (xetla-name-read-arguments 'category)
 977                                     (xetla-name-read-arguments 'branch)
 978                                     (xetla-name-read-arguments 'version)
 979                                     (xetla-name-read-arguments 'revision)))))
 980     (when (and (window-minibuffer-p (selected-window))
 981                bookmarks
 982                pversion)
 983       (delete-region (minibuffer-prompt-end) (point-max))
 984       (insert pversion)
 985       (setq xetla-name-read-insert-bookmark-ring-position pos))))
 986
 987 (add-hook 'xetla-name-read-init-hook
 988           'xetla-name-read-insert-info-at-point-init)
 989 (add-hook 'xetla-name-read-final-hook
 990           'xetla-name-read-insert-info-at-point-final)
 991 (add-hook 'xetla-name-read-error-hook
 992           'xetla-name-read-insert-info-at-point-final)
 993 (add-hook 'xetla-name-read-init-hook
 994           'xetla-name-read-insert-partner-init)
 995 (add-hook 'xetla-name-read-init-hook
 996           'xetla-name-read-insert-bookmark-init)
 997
 998 (defun xetla-tree-root (&optional location no-error)
 999   "Return the tree root for LOCATION, nil if not in a local tree.
1000 Computation is done from withing Emacs, by looking at an {arch}
1001 directory in a parent buffer of LOCATION.  This is therefore very
1002 fast.
1003
1004 If NO-ERROR is non-nil, don't raise an error if LOCATION is not an
1005 arch managed tree (but return nil)."
1006   (setq location (or location default-directory))
1007   (let ((pwd location))
1008     (while (not (or (string= pwd "/")
1009                     (file-exists-p (concat (file-name-as-directory pwd) "{arch}"))))
1010       (setq pwd (expand-file-name (concat (file-name-as-directory pwd) ".."))))
1011     (if (file-exists-p (concat pwd "/{arch}/=tagging-method"))
1012         (expand-file-name
1013          (replace-regexp-in-string "/+$" "/" pwd))
1014       (if no-error
1015           nil
1016         (error "%S is not in an arch-managed tree!" location)))))
1017
1018 (defun xetla-read-project-tree-maybe (&optional prompt directory)
1019   "Return a directory name which is the root of some project tree.
1020 Either prompt from the user or use the current directory.  The
1021 recommended usage is
1022
1023  (defun xetla-some-feature (...)
1024    (let ((default-directory (xetla-read-project-tree-maybe
1025                              \"Run some feature in\")))
1026       (code-for-some-feature))
1027
1028 The behavior can be changed according to the value of
1029 `xetla-read-project-tree-mode'.
1030
1031 PROMPT is used as a user prompt, and DIRECTORY is the default
1032 directory."
1033   (let ((root (xetla-tree-root (or directory default-directory) t))
1034         (default-directory (or (xetla-tree-root
1035                                 (or directory default-directory) t)
1036                                directory
1037                                default-directory))
1038         (prompt (or prompt "Use directory: ")))
1039     (case xetla-read-project-tree-mode
1040       (always (xetla-tree-root (read-directory-name prompt)))
1041       (sometimes (or root
1042                      (xetla-tree-root (read-directory-name prompt))))
1043       (never (or root
1044                  (error "Not in a project tree")))
1045       (t (error "Wrong value for xetla-prompt-for-directory")))))
1046
1047 (defun xetla-read-directory-maybe (&optional prompt directory force)
1048   "Read a directory name inside an arch managed tree.
1049
1050 Return a directory name which is a subdirectory or the root of some
1051 project tree.  Works in a way similar to
1052 `xetla-read-project-tree-maybe', but is customized with the variable
1053 `xetla-read-directory-mode'.
1054
1055 PROMPT is the user prompt, and DIRECTORY is the default directory."
1056   (let ((root (xetla-tree-root (or directory default-directory) t))
1057         (default-directory (or directory default-directory))
1058         (prompt (or prompt "Use directory: ")))
1059     (case xetla-read-directory-mode
1060       (always (read-directory-name prompt))
1061       (sometimes
1062        (cond (force
1063               (read-directory-name prompt))
1064              (root
1065               default-directory)
1066              (t
1067               (read-directory-name prompt))))
1068       (never (if root (or directory default-directory)
1069                (error "Not in a project tree")))
1070       (t (error "Wrong value for xetla-read-directory-mode")))))
1071
1072 (defun xetla-save-some-buffers (&optional tree)
1073   "Save all buffers visiting a file in TREE."
1074   (let ((ok t)
1075         (tree (or (xetla-tree-root tree t)
1076                   tree)))
1077     (unless tree
1078       (error "Not in a project tree"))
1079     (dolist (buffer (buffer-list))
1080       (with-current-buffer buffer
1081         (when (buffer-modified-p)
1082           (let ((file (buffer-file-name)))
1083             (when file
1084               (let ((root (xetla-tree-root (file-name-directory file) t))
1085                     (tree-exp (expand-file-name tree)))
1086                 (when (and root
1087                            (string= (file-name-as-directory root) tree-exp)
1088                            ;; buffer is modified and in the tree TREE.
1089                            (or xetla-do-not-prompt-for-save
1090                                (y-or-n-p (concat "Save buffer "
1091                                                  (buffer-name)
1092                                                  "? "))
1093                                (setq ok nil)))
1094                   (save-buffer))))))))
1095     ok))
1096
1097 (defun xetla-revert-some-buffers (&optional tree)
1098   "Reverts all buffers visiting a file in TREE that aren't modified.
1099 To be run after an update or a merge."
1100   (let ((tree (xetla-tree-root tree)))
1101     (dolist (buffer (buffer-list))
1102       (with-current-buffer buffer
1103         (when (not (buffer-modified-p))
1104           (let ((file (buffer-file-name)))
1105             (when file
1106               (let ((root (xetla-uniquify-file-name
1107                            (xetla-tree-root (file-name-directory file) t)))
1108                     (tree-exp (xetla-uniquify-file-name
1109                                (expand-file-name tree))))
1110                 (when (and (string= root tree-exp)
1111                            ;; buffer is modified and in the tree TREE.
1112                            xetla-automatically-revert-buffers)
1113                   ;; Keep the buffer if the file doesn't exist
1114                   (if (file-exists-p file)
1115                       (revert-buffer t t)))))))))))
1116
1117 ;; --------------------------------------
1118 ;; xetla help system for commands that get input from the user via the minibuffer
1119 ;; --------------------------------------
1120
1121 ;; GENERIC: This functionality should be in emacs itself. >> Masatake
1122 ;;  to check: we should use some other binding for this, perhaps f1 C-m
1123 (defun xetla-display-command-help (command)
1124   "Help system for commands that get input via the minibuffer.
1125
1126 This is an internal function called by `xetla-show-command-help'.
1127
1128 COMMAND is the last command executed."
1129   (with-electric-help
1130    (lambda ()
1131      (let ((cmd-help (when (fboundp command)
1132                        (documentation command))))
1133        (delete-region (point-min) (point-max))
1134        (insert (if cmd-help
1135                    (format "Help for %S:\n%s" command cmd-help)
1136                  (format "No help available for %S" command)))))
1137    " *xetla-command-help*"))
1138
1139 (defvar xetla-command-stack nil)
1140
1141 (defun xetla-minibuffer-setup ()
1142   "Function called in `minibuffer-setup-hook'.
1143
1144 Memorize last command run."
1145   (push  this-command xetla-command-stack))
1146
1147 (defun xetla-minibuffer-exit ()
1148   "Function called in `minibuffer-exit-hook'.
1149
1150 Cancels the effect of `xetla-minibuffer-setup'."
1151   (pop xetla-command-stack))
1152
1153 (defun xetla-show-command-help ()
1154   "Help system for commands that get input via the minibuffer.
1155
1156 When the user is asked for input in the minibuffer, a help for the
1157 command will be shown, if the user hits \\<minibuffer-local-map>\\[xetla-show-command-help].
1158 This functionality is not only for xetla commands available it is
1159 available for all Emacs commands."
1160   (interactive)
1161   (xetla-display-command-help (car xetla-command-stack)))
1162
1163 (when xetla-install-command-help-system
1164   (define-key minibuffer-local-map            [f1]
1165     'xetla-show-command-help)
1166   (define-key minibuffer-local-completion-map [f1]
1167     'xetla-show-command-help)
1168   (define-key minibuffer-local-must-match-map [f1]
1169     'xetla-show-command-help)
1170   (define-key minibuffer-local-map            [(control meta ?h)]
1171     'xetla-show-command-help)
1172   (define-key minibuffer-local-completion-map [(control meta ?h)]
1173     'xetla-show-command-help)
1174   (define-key minibuffer-local-must-match-map [(control meta ?h)]
1175     'xetla-show-command-help)
1176   (add-hook 'minibuffer-setup-hook 'xetla-minibuffer-setup)
1177   (add-hook 'minibuffer-exit-hook 'xetla-minibuffer-exit))
1178
1179 ;; --------------------------------------
1180 ;; Top level xetla commands
1181 ;; --------------------------------------
1182 (defcustom xetla-make-log-function 'xetla-default-make-log-function
1183   "*Function used to create the log buffer.
1184
1185 Must return a string which is the absolute name of the log file.  This
1186 function is called only when the log file doesn't exist already.  The
1187 default is `xetla-default-make-log-function', which just calls \"xetla
1188 make-log\". If you want to override this function, you may just write
1189 a wrapper around `xetla-default-make-log-function'."
1190   :type 'function
1191   :group 'xetla)
1192
1193 (defun xetla-make-log ()
1194   "Create the log file and return its filename.
1195
1196 If the file exists, its name is returned.  Otherwise, the log file is
1197 created by the function specified by `xetla-make-log-function', which,
1198 by default, calls \"xetla make-log\"."
1199   (interactive)
1200   (let* ((version (xetla-tree-version-list))
1201          (file (concat (xetla-tree-root) "++log."
1202                        (xetla-name-category version) "--"
1203                        (xetla-name-branch   version) "--"
1204                        (xetla-name-version  version) "--"
1205                        (xetla-name-archive  version))))
1206     (if (file-exists-p file)
1207         file
1208       (funcall xetla-make-log-function))))
1209
1210 (defun xetla-default-make-log-function ()
1211   "Candidate (and default value) for `xetla-make-log-function'.
1212 Calls \"xetla make-log\" to generate the log file."
1213   (xetla-run-tla-sync '("make-log")
1214                      :finished
1215                      (lambda (output error status arguments)
1216                        (xetla-buffer-content output))))
1217
1218 (defun xetla-pop-to-inventory ()
1219   "Call `xetla-inventory' with a prefix arg."
1220   (interactive)
1221   (xetla-inventory nil t))
1222
1223 (defvar xetla-inventory-cookie nil)
1224 (defvar xetla-inventory-list nil
1225   "Full list for the inventory.")
1226
1227 (defun xetla-inventory-goto-file (file)
1228   "Put cursor on FILE.  nil return means the file hasn't been found."
1229   (goto-char (point-min))
1230   (let ((current (ewoc-locate xetla-inventory-cookie)))
1231     (while (and current (not (string= (caddr (ewoc-data current))
1232                                       file)))
1233       (setq current (ewoc-next xetla-inventory-cookie current)))
1234     (when current (xetla-inventory-cursor-goto current))
1235     current))
1236
1237
1238 (defun xetla-inventory-make-toggle-fn-and-var (variable function)
1239   "Define the VARIABLE and the toggle FUNCTION for type TYPE."
1240   (make-variable-buffer-local variable)
1241   (eval `(defun ,function ()
1242            (interactive)
1243            (setq ,variable (not ,variable))
1244            (xetla-inventory-redisplay))))
1245
1246 (dolist (type-arg xetla-inventory-file-types-manipulators)
1247   (xetla-inventory-make-toggle-fn-and-var (cadr type-arg) (caddr type-arg)))
1248
1249 (defun xetla-inventory-redisplay ()
1250   "Refresh *xetla-inventory* buffer."
1251   (let* ((elem (ewoc-locate xetla-inventory-cookie))
1252          (file (when elem (caddr (ewoc-data elem))))
1253          (pos (point)))
1254     (xetla-inventory-display)
1255     (or (and file
1256              (xetla-inventory-goto-file file))
1257         (goto-char pos))
1258     (xetla-inventory-cursor-goto (ewoc-locate xetla-inventory-cookie))))
1259
1260
1261 (defun xetla-inventory-set-toggle-variables (new-value)
1262   "Set all xetla-inventory-display-* variables.
1263 If NEW-VALUE is 'toggle set the values to (not xetla-inventory-display-*
1264 Otherwise set it to NEW-VALUE."
1265   (dolist (type-arg xetla-inventory-file-types-manipulators)
1266     (eval `(setq ,(cadr type-arg)
1267                  (if (eq new-value 'toggle)
1268                      (not ,(cadr type-arg))
1269                    new-value)))))
1270
1271 (defun xetla-inventory-set-all-toggle-variables ()
1272   "Set all inventory toggle variables to t."
1273   (interactive)
1274   (xetla-inventory-set-toggle-variables t)
1275   (xetla-inventory-redisplay))
1276
1277 (defun xetla-inventory-reset-all-toggle-variables ()
1278   "Set all inventory toggle variables to nil."
1279   (interactive)
1280   (xetla-inventory-set-toggle-variables nil)
1281   (xetla-inventory-redisplay))
1282
1283 (defun xetla-inventory-toggle-all-toggle-variables ()
1284   "Toggle the value of all inventory toggle variables."
1285   (interactive)
1286   (xetla-inventory-set-toggle-variables 'toggle)
1287   (xetla-inventory-redisplay))
1288
1289
1290 ;;;###autoload
1291 (defun xetla-inventory (&optional directory arg)
1292   "Show a xetla inventory at DIRECTORY.
1293 When called with a prefix arg, pop to the inventory buffer.
1294 DIRECTORY defaults to the current one when within an arch managed tree,
1295 unless prefix argument ARG is non-nil."
1296   (interactive (list (xetla-read-directory-maybe
1297                       "Run inventory in (directory): "
1298                       nil current-prefix-arg)
1299                      current-prefix-arg))
1300   (let ((default-directory (or directory default-directory)))
1301     (if arg
1302         (pop-to-buffer (xetla-get-buffer-create 'inventory directory))
1303       (switch-to-buffer (xetla-get-buffer-create 'inventory directory))))
1304   (xetla-inventory-mode)
1305   (xetla-run-tla-sync
1306    ;; We have to provide all file types or xetla inventory won't display
1307    ;; junk files
1308    '("inventory" "--both" "--kind" "--source" "--backups" "--junk"
1309      "--unrecognized" "--precious")
1310    :finished
1311    (lambda (output error status arguments)
1312      (let ((list (split-string (xetla-buffer-content output) "\n"))
1313            (inventory-list '()))
1314        (mapc
1315         (lambda (item)
1316           (when (string-match "\\([A-Z]\\)\\([\\? ]\\) +\\([^ ]\\) \\(.*\\)"
1317                               item)
1318             (let ((xetla-type (string-to-char (match-string 1 item)))
1319                   (question (string= (match-string 2 item) "?"))
1320                   (escaped-filename (match-string 4 item))
1321                   (type (string-to-char (match-string 3 item))))
1322             (push (list xetla-type
1323                         question
1324                         (xetla-unescape escaped-filename)
1325                         type)
1326                   inventory-list))))
1327         list)
1328        (setq inventory-list (reverse inventory-list))
1329        (set (make-local-variable 'xetla-inventory-list)
1330             inventory-list)
1331        (xetla-inventory-display)))))
1332
1333 (defun xetla-inventory-display ()
1334   "Display the inventory.
1335 This function creates the ewoc from the variable `xetla-inventory-list',
1336 selecting only files to print."
1337   (interactive)
1338   (let (buffer-read-only)
1339     (erase-buffer)
1340     (set (make-local-variable 'xetla-inventory-cookie)
1341          (ewoc-create 'xetla-inventory-printer))
1342     (xetla-inventory-insert-headers)
1343     (dolist (elem xetla-inventory-list)
1344       (let ((type (car elem)))
1345         (if (eval (cadr (assoc type
1346                                xetla-inventory-file-types-manipulators)))
1347             (ewoc-enter-last xetla-inventory-cookie elem)))))
1348   (goto-char (point-min)))
1349
1350 (defun xetla-inventory-chose-face (type)
1351   "Return a face adapted to TYPE, which can be J, S, P, T or U."
1352   (case type
1353     (?P 'xetla-precious)
1354     (?U 'xetla-unrecognized)
1355     (?S 'xetla-source)
1356     (?J 'xetla-junk)
1357     (?T 'xetla-nested-tree)))
1358
1359 (defun xetla-inventory-printer (elem)
1360   "Ewoc printer for `xetla-inventory-cookie'.
1361 Pretty print ELEM."
1362   (let* ((type (nth 0 elem))
1363          (question (nth 1 elem))
1364          (file (nth 2 elem))
1365          (file-type (nth 3 elem))
1366          (face (xetla-inventory-chose-face type)))
1367     (insert (if (member file xetla-buffer-marked-file-list)
1368                 (concat " " xetla-mark " ") "   "))
1369     (insert (xetla-face-add (format "%c%s  "
1370                                    type
1371                                    (if question "?" " "))
1372                            face)
1373             (xetla-face-add
1374              (format "%s%s" file
1375                      (case file-type (?d "/") (?> "@") (t "")))
1376              face
1377              'xetla-inventory-item-map
1378              xetla-inventory-item-menu))))
1379
1380 (defun xetla-inventory-mark-file ()
1381   "Mark file at point in inventory mode.
1382
1383 Adds it to the variable `xetla-buffer-marked-file-list', and move cursor
1384 to the next entry."
1385   (interactive)
1386   (let ((current (ewoc-locate xetla-inventory-cookie))
1387         (file (xetla-get-file-info-at-point)))
1388     (add-to-list 'xetla-buffer-marked-file-list file)
1389     (ewoc-refresh xetla-inventory-cookie)
1390     (xetla-inventory-cursor-goto (or (ewoc-next xetla-inventory-cookie
1391                                               current)
1392                                    current))))
1393
1394 (defun xetla-inventory-unmark-file ()
1395   "Unmark file at point in inventory mode."
1396   (interactive)
1397   (let ((current (ewoc-locate xetla-inventory-cookie))
1398         (file (xetla-get-file-info-at-point)))
1399     (setq xetla-buffer-marked-file-list
1400           (delete file xetla-buffer-marked-file-list))
1401     (ewoc-refresh xetla-inventory-cookie)
1402     (xetla-inventory-cursor-goto (or (ewoc-next xetla-inventory-cookie
1403                                               current)
1404                                    current))))
1405
1406 (defun xetla-inventory-unmark-all ()
1407   "Unmark all files in inventory mode."
1408   (interactive)
1409   (let ((current (ewoc-locate xetla-inventory-cookie)))
1410     (setq xetla-buffer-marked-file-list nil)
1411     (ewoc-refresh xetla-inventory-cookie)
1412     (xetla-inventory-cursor-goto current)))
1413
1414 (defvar xetla-get-file-info-at-point-function nil
1415   "Function used to get the file at point, anywhere.")
1416
1417 (defun xetla-get-file-info-at-point ()
1418   "Gets the filename at point, according to mode.
1419 Actually calls the function `xetla-get-file-info-at-point-function'."
1420   (when xetla-get-file-info-at-point-function
1421     (funcall xetla-get-file-info-at-point-function)))
1422
1423 (defvar xetla-generic-select-files-function nil
1424   "Function called by `xetla-generic-select-files'.
1425 Must be local to each buffer.")
1426
1427 (defun xetla-generic-select-files (msg-singular
1428                                   msg-plural msg-err
1429                                   msg-prompt
1430                                   &optional
1431                                   no-group ignore-marked
1432                                   no-prompt
1433                                   y-or-n)
1434   "Get the list of files at point, and ask confirmation of the user.
1435
1436 This is a generic function calling
1437 `xetla-generic-select-files-function', defined locally for each xetla
1438 buffer. The behavior should be the following:
1439
1440 Prompt with either MSG-SINGULAR, MSG-PLURAL, MSG-ERR OR MSG-PROMPT. If
1441 NO-GROUP is nil and if the cursor is on the beginning of a group, all
1442 the files belonging to this message are selected. If some files are
1443 marked \(i.e. `xetla-buffer-marked-file-list' is non-nil) and
1444 IGNORE-MARKED is non-nil, the list of marked files is returned. If
1445 NO-PROMPT is non-nil, don't ask for confirmation. If Y-OR-N is
1446 non-nil, then this function is used instead of `y-or-n-p'."
1447   (when xetla-generic-select-files-function
1448     (funcall xetla-generic-select-files-function
1449              msg-singular msg-plural msg-err msg-prompt no-group
1450              ignore-marked no-prompt y-or-n)))
1451
1452 (defun xetla-generic-find-file-at-point ()
1453   "Opens the file at point.
1454
1455 The filename is obtained with `xetla-get-file-info-at-point', so, this
1456 function should be useable in all modes seting
1457 `xetla-get-file-info-at-point-function'"
1458   (interactive)
1459   (let* ((file (xetla-get-file-info-at-point)))
1460     (cond
1461      ((not file)
1462       (error "No file at point"))
1463      (t
1464       (find-file file)))))
1465
1466 (xetla-make-bymouse-function xetla-generic-find-file-at-point)
1467
1468 (defun xetla-generic-find-file-other-window ()
1469   "Visit the current inventory file in the other window."
1470   (interactive)
1471   (let ((file (xetla-get-file-info-at-point)))
1472     (if file
1473         (progn
1474           (find-file-other-window file))
1475       (error "No file at point"))))
1476
1477 (defun xetla-generic-view-file ()
1478   "Visit the current inventory file in view mode."
1479   (interactive)
1480   (let ((file (xetla-get-file-info-at-point)))
1481     (if file
1482         (view-file-other-window file)
1483       (error "No file at point"))))
1484
1485 (defun xetla-inventory-get-file-info-at-point ()
1486   "Gets the file at point in inventory mode."
1487   (caddr (ewoc-data (ewoc-locate xetla-inventory-cookie))))
1488
1489 (defun xetla-inventory-insert-headers ()
1490   "Insert the header (top of buffer) for *xetla-inventory*."
1491   (let* ((tree-version (xetla-name-construct
1492                         (xetla-tree-version-list nil 'no-error)))
1493          (tagging-method (xetla-id-tagging-method nil))
1494          (separator
1495           (xetla-face-add (make-string
1496                           (max (+ (length "Directory: ")   (length default-directory))
1497                                (+ (length "Default Tree Version: ") (length tree-version))
1498                                (+ (length "ID Tagging Method: ") (length tagging-method)))
1499                           ?\ )
1500                          'xetla-separator)))
1501     (ewoc-set-hf
1502      xetla-inventory-cookie
1503      (concat
1504       "Directory: "    (xetla-face-add default-directory 'xetla-local-directory
1505                                       (let ((map  (make-sparse-keymap))
1506                                             (func `(lambda ()
1507                                                      (interactive)
1508                                                      (dired ,default-directory))))
1509                                         (define-key map [return]  func)
1510                                         (define-key map "\C-m"    func)
1511                                         (define-key map [button2] func)
1512                                         map)
1513                                       nil
1514                                       "Run Dired Here") "\n"
1515       "Default Tree Version: " (xetla-face-add tree-version 'xetla-archive-name
1516                                               'xetla-inventory-default-version-map
1517                                               (xetla-partner-create-menu
1518                                                'xetla-generic-set-tree-version
1519                                                "Change the Default Tree Version")) "\n"
1520       "ID Tagging Method: " (xetla-face-add tagging-method 'xetla-tagging-method
1521                                            'xetla-inventory-tagging-method-map
1522                                            xetla-inventory-tagging-method-menu) "\n"
1523       separator "\n")
1524      (concat "\n" separator))))
1525
1526 (defvar xetla-buffer-source-buffer nil
1527   "Buffer from where a command was called.")
1528
1529 ;;;###autoload
1530 (defun xetla-edit-log (&optional insert-changelog source-buffer)
1531   "Edit the xetla log file.
1532
1533 With an optional prefix argument INSERT-CHANGELOG, insert the last
1534 group of entries from the ChangeLog file.  SOURCE-BUFFER, if non-nil,
1535 is the buffer from which the function was called.  It is used to get
1536 the list of marked files, and potentially run a selected file commit."
1537   (interactive "P")
1538   (setq xetla-pre-commit-window-configuration
1539         (current-window-configuration))
1540   (setq xetla-log-edit-file-name (xetla-make-log))
1541   (xetla-switch-to-buffer
1542    (find-file-noselect xetla-log-edit-file-name))
1543   (when insert-changelog
1544     (goto-char (point-max))
1545     (let ((buf (find-file-noselect (find-change-log))))
1546       (insert-buffer buf))
1547     (when (re-search-forward "^2" nil t)
1548       (delete-region (point-at-bol)
1549                      (point-at-bol 3)))
1550     (when (re-search-forward "^2" nil t)
1551       (delete-region (point-at-bol) (point-max)))
1552     (goto-char (point-min)))
1553   (xetla-log-edit-mode)
1554   (set (make-local-variable 'xetla-buffer-source-buffer)
1555        source-buffer)
1556   (end-of-line))
1557
1558 ;;;###autoload
1559 (defun xetla-add-log-entry ()
1560   "Add new xetla log ChangeLog style entry."
1561   (interactive)
1562   (save-restriction
1563     (xetla-add-log-entry-internal)))
1564
1565 (defun xetla-add-log-entry-internal ()
1566   "Similar to `add-change-log-entry'.
1567
1568 Inserts the entry in the arch log file instead of the ChangeLog."
1569   ;; This is mostly copied from add-log.el.  Perhaps it would be better to
1570   ;; split add-change-log-entry into several functions and then use them, but
1571   ;; that wouldn't work with older versions of Emacs.
1572   (require 'add-log)
1573   (let* ((defun (add-log-current-defun))
1574          (buf-file-name (if (and (boundp 'add-log-buffer-file-name-function)
1575                                  add-log-buffer-file-name-function)
1576                             (funcall add-log-buffer-file-name-function)
1577                           buffer-file-name))
1578          (buffer-file (if buf-file-name (expand-file-name buf-file-name)))
1579          (file-name (xetla-make-log))
1580          ;; Set ENTRY to the file name to use in the new entry.
1581          (entry (add-log-file-name buffer-file file-name))
1582          beg
1583          bound
1584          narrowing)
1585     (xetla-edit-log)
1586     (undo-boundary)
1587     (goto-char (point-min))
1588     (when (re-search-forward "^Patches applied:" nil t)
1589       (narrow-to-region (point-min) (match-beginning 0))
1590       (setq narrowing t)
1591       (goto-char (point-min)))
1592     (re-search-forward "\n\n\\|\\'")
1593     (setq beg (point))
1594     (setq bound
1595           (progn
1596             (if (looking-at "\n*[^\n* \t]")
1597                 (skip-chars-forward "\n")
1598               (if (and (boundp 'add-log-keep-changes-together)
1599                        add-log-keep-changes-together)
1600                   (goto-char (point-max))
1601                 (forward-paragraph))) ; paragraph delimits entries for file
1602             (point)))
1603     (goto-char beg)
1604     (forward-line -1)
1605     ;; Now insert the new line for this entry.
1606     (cond ((re-search-forward "^\\s *\\*\\s *$" bound t)
1607            ;; Put this file name into the existing empty entry.
1608            (if entry
1609                (insert entry)))
1610           ((let (case-fold-search)
1611              (re-search-forward
1612               (concat (regexp-quote (concat "* " entry))
1613                       ;; Don't accept `foo.bar' when
1614                       ;; looking for `foo':
1615                       "\\(\\s \\|[(),:]\\)")
1616               bound t))
1617            ;; Add to the existing entry for the same file.
1618            (re-search-forward "^\\s *$\\|^\\s \\*")
1619            (goto-char (match-beginning 0))
1620            ;; Delete excess empty lines; make just 2.
1621            (while (and (not (eobp)) (looking-at "^\\s *$"))
1622              (delete-region (point) (point-at-bol 2)))
1623            (insert-char ?\n 2)
1624            (forward-line -2)
1625            (indent-relative-maybe))
1626           (t
1627            ;; Make a new entry.
1628            (if xetla-log-insert-last
1629                (progn
1630                  (goto-char (point-max))
1631                  (re-search-backward "^.")
1632                  (end-of-line)
1633                  (insert "\n\n* ")
1634                  )
1635              (forward-line 1)
1636              (while (looking-at "\\sW")
1637                (forward-line 1))
1638              (while (and (not (eobp)) (looking-at "^\\s *$"))
1639                (delete-region (point) (point-at-bol 2)))
1640              (insert-char ?\n 3)
1641              (forward-line -2)
1642              (indent-to left-margin)
1643              (insert "* "))
1644            (if entry (insert entry))))
1645     (if narrowing (widen))
1646     ;; Now insert the function name, if we have one.
1647     ;; Point is at the entry for this file,
1648     ;; either at the end of the line or at the first blank line.
1649     (if defun
1650         (progn
1651           ;; Make it easy to get rid of the function name.
1652           (undo-boundary)
1653           (unless (save-excursion
1654                     (beginning-of-line 1)
1655                     (looking-at "\\s *$"))
1656             (insert ?\ ))
1657           ;; See if the prev function name has a message yet or not
1658           ;; If not, merge the two entries.
1659           (let ((pos (point-marker)))
1660             (if (and (skip-syntax-backward " ")
1661                      (skip-chars-backward "):")
1662                      (looking-at "):")
1663                      (progn (delete-region (+ 1 (point)) (+ 2 (point))) t)
1664                      (> fill-column (+ (current-column) (length defun) 3)))
1665                 (progn (delete-region (point) pos)
1666                        (insert ", "))
1667               (goto-char pos)
1668               (insert "("))
1669             (set-marker pos nil))
1670           (insert defun "): "))
1671       ;; No function name, so put in a colon unless we have just a star.
1672       (unless (save-excursion
1673                 (beginning-of-line 1)
1674                 (looking-at "\\s *\\(\\*\\s *\\)?$"))
1675         (insert ": ")))))
1676
1677 (defvar xetla-changes-cookie nil
1678   "Ewoc cookie for the changes buffer.
1679
1680 Element should look like
1681
1682  (file \"filename\" \"M\" \"/\")
1683  (file \"newname\" \"M\" \"/\" \"filename\")
1684  (subtree \"name\" related-buffer changes?)
1685  (message \"doing such or such thing\")")
1686
1687 (defun xetla-changes-delete-messages (&optional immediate)
1688   "Remove messages from the ewoc list of modifications.
1689
1690 if IMMEDIATE is non-nil, refresh the display too."
1691   (when xetla-changes-cookie
1692     (ewoc-filter xetla-changes-cookie
1693                  (lambda (elem)
1694                    (not (eq (car elem) 'message))))))
1695
1696 (defvar xetla-changes-summary nil
1697   "Wether the current buffer display only a summary or a full diff.")
1698
1699 (defvar xetla-changes-buffer-master-buffer nil
1700   "Master buffer for a nested *xetla-changes* buffer.")
1701
1702 (defvar xetla-changes-summary nil
1703   "Wether the current buffer display only a summary or a full diff.")
1704
1705 ;;;###autoload
1706 (defun xetla-changes (&optional summary against)
1707   "Run \"tla changes\".
1708
1709 When called without a prefix argument: show the detailed diffs also.
1710 When called with a prefix argument SUMMARY: do not show detailed
1711 diffs. When AGAINST is non-nil, use it as comparison tree."
1712   (interactive "P")
1713   (let* ((root (xetla-read-project-tree-maybe
1714                 "Run tla changes in: "))
1715          (default-directory root)
1716          (buffer (xetla-prepare-changes-buffer
1717                   (or against
1718                       (list 'last-revision root))
1719                   (list 'local-tree root)
1720                   'changes
1721                   default-directory)))
1722     (with-current-buffer buffer
1723       (set (make-local-variable 'xetla-changes-summary)
1724            summary))
1725     (when xetla-switch-to-buffer-first
1726       (xetla-switch-to-buffer buffer))
1727     (xetla-save-some-buffers)
1728     (xetla-run-tla-async
1729      '("inventory" "--nested" "--trees")
1730      :related-buffer buffer
1731      :finished
1732      `(lambda (output error status arguments)
1733         (let ((subtrees (delete ""
1734                                 (split-string
1735                                  (with-current-buffer
1736                                      output (buffer-string)) "\n"))))
1737           (with-current-buffer ,buffer
1738             (let ((inhibit-read-only t))
1739               (ewoc-enter-last
1740                xetla-changes-cookie
1741                (list 'message
1742                      (concat "* running tla changes in tree " ,root
1743                              "...\n\n")))
1744               (ewoc-refresh xetla-changes-cookie))
1745             (dolist (subtree subtrees)
1746               (let ((buffer-sub (xetla-get-buffer-create
1747                                  'changes subtree)))
1748                 (with-current-buffer buffer-sub
1749                   (let ((inhibit-read-only t))
1750                     (erase-buffer))
1751                   (xetla-changes-mode)
1752                   (set (make-local-variable
1753                         'xetla-changes-buffer-master-buffer)
1754                        ,buffer))
1755                 (ewoc-enter-last xetla-changes-cookie
1756                                  (list 'subtree buffer-sub subtree
1757                                        nil))
1758                 (xetla-changes-internal
1759                  ,(not summary)
1760                  nil ;; TODO "against" what for a nested tree?
1761                  subtree
1762                  buffer-sub
1763                  ,buffer)))
1764             (xetla-changes-internal ,(not summary)
1765                                    (quote ,against)
1766                                    ,root ,buffer nil)))))))
1767
1768 ;;;###autoload
1769 (defun xetla-changes-against (&optional summary against)
1770   "Wrapper for `xetla-changes'.
1771
1772 When called interactively, SUMMARY is the prefix arg, and AGAINST is
1773 read from the user."
1774   (interactive (list current-prefix-arg
1775                      (list 'revision (xetla-name-read "Compute changes against: "
1776                                                     'prompt 'prompt 'prompt 'prompt
1777                                                     'maybe))))
1778   (xetla-changes summary against))
1779
1780 ;;;###autoload
1781 (defun xetla-changes-last-revision (&optional summary)
1782   "Run `xetla-changes' against the last but one revision.
1783
1784 The idea is that running this command just after a commit should be
1785 equivalent to running `xetla-changes' just before the commit.
1786
1787 SUMMARY is passed to `xetla-changes'."
1788   (interactive "P")
1789   (let ((default-directory (xetla-read-project-tree-maybe
1790                             "Review last patch in directory: ")))
1791     (xetla-changes summary (list 'revision
1792                                (xetla-name-construct (xetla-compute-direct-ancestor))))))
1793
1794 (defvar xetla-changes-modified nil
1795   "MODIFIED revision for the changes currently displayed.
1796
1797 Must be buffer-local.
1798
1799 This variable has the form (type location), and can be either
1800
1801 '(revision (\"archive\" \"category\" \"branch\" \"version\"
1802             \"revision\"))
1803
1804 or
1805
1806 '(local-tree \"/path/to/local/tree\")
1807
1808 The value nil means we have no information about which local tree or
1809 revision is used.")
1810
1811 (defvar xetla-changes-base nil
1812   "BASE revision for the changes currently displayed.
1813
1814 Must be buffer-local.
1815
1816 The values for this variable can be the same as for
1817 `xetla-changes-modified', plus the values
1818
1819 '(last-revision \"/path/to/tree\"),
1820 used by `xetla-changes' to mean \"revision on which this local tree is
1821 based\".
1822
1823 and
1824
1825 '(previous-revision (\"archive\" \"category\" \"branch\" \"version\"
1826                      \"revision\")),
1827 used by commands like xetla-get-changeset, and means that the changes
1828 are against the previous revision.")
1829
1830 (defun xetla-changes-internal (diffs against root buffer master-buffer)
1831   "Internal function to run \"tla changes\".
1832
1833 If DIFFS is non nil, show the detailed diffs also.
1834 Run the command against tree AGAINST in directory ROOT.
1835 The output will be displayed in buffer BUFFER.
1836
1837 BUFFER must already be in changes mode, but mustn't contain any change
1838 information. Only roots of subprojects are already in the ewoc.
1839
1840 If MASTER-BUFFER is non-nil, this run of tla changes is done in a
1841 nested project of a bigger one. MASTER-BUFFER is the buffer in which
1842 the root of the projects is displayed."
1843   (with-current-buffer buffer
1844     (xetla-run-tla-async
1845      `("changes" ,(when diffs "--diffs")
1846        ,(case (car against)
1847           (local-tree
1848            (error "Can not run tla changes against a local tree"))
1849           (previous-revision (xetla-compute-direct-ancestor
1850                               (cadr against)))
1851           (last-revision (if (string= (xetla-uniquify-file-name
1852                                        (cadr against))
1853                                       (xetla-uniquify-file-name
1854                                        (xetla-tree-root)))
1855                              nil
1856                            (error "tla changes against last %s %s"
1857                                   "revision of local tree not"
1858                                   "implemented.")))
1859           (revision (xetla-name-construct (cadr against)))))
1860      :finished
1861      `(lambda (output error status arguments)
1862         (if ,master-buffer
1863             (message "No changes in subtree %s" ,root)
1864           (message "No changes in %s" ,root))
1865         (with-current-buffer ,(current-buffer)
1866           (let ((inhibit-read-only t))
1867             (xetla-changes-delete-messages)
1868             (ewoc-enter-last xetla-changes-cookie
1869                              (list 'message (concat "* No changes in "
1870                                                     ,root ".\n\n")))
1871             (when ,master-buffer
1872               (with-current-buffer ,master-buffer
1873                 (ewoc-map (lambda (x)
1874                             (when (and (eq (car x) 'subtree)
1875                                        (eq (cadr x) ,buffer))
1876                               (setcar (cdddr x) 'no-changes))
1877                             )
1878                           ;; (ewoc-refresh xetla-changes-cookie)))
1879                           xetla-changes-cookie)))
1880             (ewoc-refresh xetla-changes-cookie))))
1881      :error
1882      `(lambda (output error status arguments)
1883         (if (/= 1 status)
1884             (progn
1885               (xetla-show-error-buffer error)
1886               (goto-char (point-min))
1887               (when (search-forward "try tree-lint" nil t)
1888                 (xetla-tree-lint ,root)))
1889           (xetla-show-changes-buffer output nil ,buffer ,master-buffer)
1890           (when ,master-buffer
1891             (with-current-buffer ,master-buffer
1892               (ewoc-map (lambda (x)
1893                           (when (and (eq (car x) 'subtree)
1894                                      (eq (cadr x) ,buffer))
1895                             (setcar (cdddr x) 'changes))
1896                           )
1897                         xetla-changes-cookie)))))
1898      )))
1899
1900 (defun xetla-changes-chose-face (modif)
1901   "Return a face adapted to MODIF, a string, which can be A, M, C, or D."
1902   (cond
1903    ((string-match "A" modif) 'xetla-added)
1904    ((string-match "M" modif) 'xetla-modified)
1905    ((string-match "-" modif) 'xetla-modified)
1906    ((string-match "C" modif) 'xetla-conflict)
1907    ((string-match "D" modif) 'xetla-conflict)
1908    ((string-match "/" modif) 'xetla-move)
1909    ((string-match "=" modif) 'xetla-move)
1910    (t
1911     (xetla-trace "unknown modif: \"%s\"" modif)
1912     'default)))
1913
1914 (defun xetla-changes-printer (elem)
1915   "Ewoc pretty-printer for `xetla-changes-cookie'.
1916
1917 Pretty-print ELEM."
1918   (cond
1919    ((eq (car elem) 'file)
1920     (let* ((empty-mark "  ")
1921            (mark (when (member (cadr elem) xetla-buffer-marked-file-list)
1922                    (concat xetla-mark " ")))
1923            (file (cadr elem))
1924            (modif (caddr elem))
1925            (dir (cadddr elem))
1926            (basename (nth 4 elem))
1927            (line (concat modif dir " "
1928                          (when basename (concat basename "\t"))
1929                          file))
1930            (face (if mark
1931                      'xetla-marked
1932                    (xetla-changes-chose-face modif))))
1933       (if mark
1934           (insert mark)
1935         (insert empty-mark))
1936       (insert (xetla-face-add line
1937                              face
1938                              'xetla-changes-file-map
1939                              xetla-changes-file-menu))))
1940    ((eq (car elem) 'subtree)
1941     (insert " T" (cond ((not (cadddr elem)) "?")
1942                        ((eq  (cadddr elem) 'changes) "M")
1943                        ((eq  (cadddr elem) 'no-changes) "-"))
1944             " " (caddr elem)))
1945    ((eq (car elem) 'message)
1946     (insert (cadr elem))))
1947   )
1948
1949 (defconst xetla-verbose-format-spec
1950   '(("added files"    "A" " ")
1951     ("modified files" "M" " ")
1952     ("removed files"  "D" " "))
1953   "Internal variable used to parse the output of xetla show-changeset."
1954   )
1955
1956 (defun xetla-show-changes-buffer (buffer &optional verbose-format
1957                                        output-buffer no-switch)
1958   "Show the *xetla-changes* buffer built from the *xetla-process* BUFFER.
1959
1960 If VERBOSE-FORMAT is non-nil, the format of the *xetla-process* buffer
1961 should be the one of xetla show-changeset.
1962
1963 Use OUTPUT-BUFFER to display changes if provided.  That buffer must
1964 already be in changes mode.
1965
1966 If NO-SWITCH is nil, don't switch to the created buffer."
1967   (let* ((root (with-current-buffer buffer
1968                  (xetla-tree-root default-directory t)))
1969          (changes-buffer (or output-buffer (xetla-get-buffer-create
1970                                             'changes root)))
1971          (header ""))
1972     (if (or no-switch xetla-switch-to-buffer-first)
1973         (set-buffer changes-buffer)
1974       (xetla-switch-to-buffer changes-buffer))
1975     (let (buffer-read-only)
1976       (xetla-changes-delete-messages)
1977       (unless output-buffer
1978         (erase-buffer)
1979         (xetla-changes-mode))
1980       (with-current-buffer buffer
1981         (if verbose-format
1982             (progn
1983               (goto-char (point-min))
1984               (while (re-search-forward
1985                       (concat "^\\* \\(" (regexp-opt
1986                                           (mapcar 'car xetla-verbose-format-spec))
1987                               "\\)\n")
1988                       nil t)
1989                 (let* ((elem (assoc (match-string 1)
1990                                     xetla-verbose-format-spec))
1991                        (modif (cadr elem))
1992                        (dir (caddr elem)))
1993                   (if (string= modif "M")
1994                       (while (re-search-forward "^--- orig/\\(.*\\)$"
1995                                                 nil t)
1996                         (let ((file (match-string 1)))
1997                           (with-current-buffer changes-buffer
1998                             (ewoc-enter-last
1999                              xetla-changes-cookie
2000                              (list 'file (xetla-unescape file)
2001                                    modif dir)))))
2002                     (while (looking-at "^$") (forward-line 1))
2003                     (while (looking-at
2004                             "^ +\\([^ ].*\\)$")
2005                       (let ((file (match-string 1)))
2006                         (with-current-buffer changes-buffer
2007                           (ewoc-enter-last
2008                            xetla-changes-cookie
2009                            (list 'file (xetla-unescape file)
2010                                  modif dir)))
2011                         (forward-line 1))))))
2012               (goto-char (point-min))
2013               (if (re-search-forward "^---" nil t)
2014                   (forward-line -1)
2015                 (beginning-of-line)))
2016           (setq header (buffer-substring-no-properties
2017                         (goto-char (point-min))
2018                         (progn (re-search-forward "^[^*]" nil t)
2019                                (beginning-of-line)
2020                                (point))))
2021           (beginning-of-line)
2022           (while (or (eq (char-after) ?*)
2023                      (looking-at "^\\(.\\)\\([ /bfl>-]?\\) +\\([^\t\n]*\\)\\(\t\\(.*\\)\\)?$"))
2024             (if (eq (char-after) ?*)
2025                 (let ((msg (buffer-substring-no-properties
2026                             (point) (point-at-eol))))
2027                   (with-current-buffer changes-buffer
2028                     (ewoc-enter-last xetla-changes-cookie
2029                                      (list 'message msg))))
2030               (let ((file (match-string 3))
2031                     (modif (match-string 1))
2032                     (dir (match-string 2))
2033                     (newname (match-string 5)))
2034                 (with-current-buffer changes-buffer
2035                   (if newname
2036                       (ewoc-enter-last xetla-changes-cookie
2037                                        (list 'file
2038                                              (xetla-unescape newname)
2039                                              modif dir
2040                                              (xetla-unescape file)))
2041                     (ewoc-enter-last xetla-changes-cookie
2042                                      (list 'file
2043                                            (xetla-unescape file)
2044                                            modif dir))))))
2045             (forward-line 1)))
2046         (let ((footer (concat
2047                        (xetla-face-add (make-string  72 ?\ ) 'xetla-separator)
2048                        "\n\n"
2049                        (buffer-substring-no-properties
2050                         (point) (point-max)))))
2051           (with-current-buffer changes-buffer
2052             (ewoc-set-hf xetla-changes-cookie header footer)
2053             (if root (cd root)))))
2054       ))
2055   (toggle-read-only 1)
2056   (when font-lock-mode
2057     (let ((font-lock-verbose nil))
2058       (font-lock-fontify-buffer)))
2059   (if (ewoc-nth xetla-changes-cookie 0)
2060       (goto-char (ewoc-location (ewoc-nth xetla-changes-cookie 0)))))
2061
2062 (defun xetla-changes-save (directory)
2063   "Run \"tla changes -o\" to create a changeset.
2064
2065 The changeset is stored in DIRECTORY."
2066   (interactive "FDirectory to store the changeset: ")
2067   (xetla-run-tla-sync (list "changes" "-o" directory)
2068                      :error `(lambda (output error status arguments)
2069                                (case status
2070                                  (0 (message "xetla-changes-save: 0"))
2071                                  (1 (message (format "xetla-changes-save to %s finished" ,directory)))
2072                                  (otherwise (xetla-default-error-function
2073                                              output error status arguments))))))
2074
2075
2076 (defun xetla-changes-save-as-tgz (file-name)
2077   "Run \"tla changes -o\" to create .tar.gz file.
2078 The changeset is stored in the tarball 'FILE-NAME.tar.gz'."
2079   (interactive "FFile to store the changeset (without .tar.gz extension): ")
2080   (let* ((changeset-dir (expand-file-name file-name))
2081         (tgz-file-name (concat changeset-dir ".tar.gz")))
2082     (when (file-directory-p changeset-dir)
2083       (error "The changeset directory %s does already exist" changeset-dir))
2084     (when (file-exists-p tgz-file-name)
2085       (error "The changeset tarball %s does already exist" tgz-file-name))
2086     (xetla-changes-save changeset-dir)
2087     ;;create the archive: tar cfz ,,cset.tar.gz ,,cset
2088     (let ((default-directory (file-name-directory changeset-dir)))
2089       ;;(message "Calling tar cfz %s %s" tgz-file-name (file-name-nondirectory changeset-dir))
2090       (call-process "tar" nil nil nil "cfz" tgz-file-name (file-name-nondirectory changeset-dir)))
2091     (call-process "rm" nil nil nil "-rf" changeset-dir)
2092     (message "Created changeset tarball %s" tgz-file-name)))
2093
2094 ;;;###autoload
2095 (defun xetla-delta (base modified &optional directory)
2096   "Run tla delta BASE MODIFIED.
2097 If DIRECTORY is a non-empty string, the delta is stored to it.
2098 If DIRECTORY is ask, a symbol, ask the name of directory.
2099 If DIRECTORY is nil or an empty string, just show the delta using --diffs."
2100   (interactive (list
2101                 (xetla-name-construct
2102                  (xetla-name-read "Base: "
2103                                  'prompt 'prompt 'prompt 'prompt 'prompt))
2104                 (xetla-name-construct
2105                  (xetla-name-read "Modified: "
2106                                  'prompt 'prompt 'prompt 'prompt 'prompt))
2107                 (when current-prefix-arg
2108                   'ask)))
2109
2110   (when (eq directory 'ask)
2111     (setq directory
2112           (read-directory-name "Stored to: "
2113                                     (xetla-tree-root default-directory t)
2114                                     (xetla-tree-root default-directory t)
2115                                     nil
2116                                     "")))
2117
2118   (when (and directory (stringp directory) (string= directory ""))
2119     (setq directory nil))
2120
2121   (when (and directory (file-directory-p directory))
2122     (error "%s already exists" directory))
2123
2124   (let ((args
2125          (if directory
2126              (list "delta" base modified directory)
2127            (list "delta" "--diffs" base modified)))
2128         (run-dired-p (when directory 'ask)))
2129     (xetla-run-tla-async args
2130                         :finished
2131                         `(lambda (output error status arguments)
2132                            (if ,directory
2133                                (xetla-delta-show-directory ,directory ',run-dired-p)
2134                              (xetla-delta-show-diff-on-buffer
2135                               output ,base ,modified))))))
2136
2137 (defun xetla-delta-show-diff-on-buffer (output base modified)
2138   "Show the result of \"delta -diffs\".
2139
2140 OUTPUT is the output buffer of the xetla process.
2141 BASE is the name of the base revision, and MODIFIED is the name of the
2142 modified revision, (then command being run is tla delta BASE
2143 MODIFIED)."
2144   (with-current-buffer output
2145     (let ((no-changes
2146            ;; There were no changes if the last line of
2147            ;; the buffer is "* changeset report"
2148            (save-excursion
2149              (goto-char (point-max))
2150              (previous-line 1)
2151              (beginning-of-line)
2152              (looking-at "^* changeset report")))
2153           buffer)
2154       (if no-changes
2155           (message
2156            (concat "tla delta finished: "
2157                    "No changes in this arch working copy"))
2158         (setq buffer (xetla-prepare-changes-buffer
2159                       (list 'revision
2160                             (xetla-name-split base))
2161                       (list 'revision
2162                             (xetla-name-split modified))
2163                       'delta default-directory))
2164         (xetla-show-changes-buffer output nil buffer)
2165         (xetla-switch-to-buffer buffer)
2166         (message "tla delta finished")))))
2167
2168 (defun xetla-delta-show-directory (directory run-dired-p)
2169   "Called by `xetla-delta' to show a changeset in DIRECTORY.
2170
2171 If RUN-DIRED-P is non-nil, run dired in the parent directory of the
2172 changeset."
2173   (xetla-show-changeset directory nil)
2174   (when (xetla-do-dired (concat (file-name-as-directory directory) "..")  run-dired-p)
2175     (revert-buffer)
2176     (goto-char (point-min))
2177     (re-search-forward (concat
2178                         (regexp-quote (file-name-nondirectory directory))
2179                         "$"))
2180     (goto-char (match-beginning 0))
2181     (xetla-flash-line)))
2182
2183 ;; (defvar xetla-get-changeset-start-time nil)
2184 ;; (defvar xetla-changeset-cache (make-hash-table :test 'equal)
2185 ;;   "The cache for `xetla-get-changeset'.
2186 ;; A hashtable, where the revisions are used as keys.
2187 ;; The value is a list containing the time the cache data was recorded and
2188 ;; the text representation of the changeset.")
2189
2190 ;;;###autoload
2191 (defun xetla-get-changeset (revision justshow &optional destination
2192                                    without-diff)
2193   "Gets the changeset corresponding to REVISION.
2194
2195 When JUSTSHOW is non-nil (no prefix arg), just show the diff.
2196 Otherwise, store changeset in DESTINATION.
2197 If WITHOUT-DIFF is non-nil, don't use the -diff option to show the
2198 changeset."
2199   (interactive
2200    (list (let ((current-version (xetla-tree-version nil t)))
2201            (xetla-name-construct
2202             (apply 'xetla-name-read "Revision to view: "
2203                    (if current-version
2204                        (append (delete nil (xetla-name-split current-version))
2205                                '(prompt))
2206                      (list 'prompt 'prompt 'prompt 'prompt 'prompt)))))
2207          (not current-prefix-arg)))
2208   (let ((buffer (xetla-get-buffer 'changeset revision)))
2209     (if buffer (save-selected-window (xetla-switch-to-buffer buffer))
2210       (let* ((dest (or destination
2211                        (xetla-make-temp-name "xetla-changeset")))
2212              (rev-list (xetla-name-split revision))
2213              (buffer (and justshow
2214                           (xetla-prepare-changes-buffer
2215                            (list 'previous-revision rev-list)
2216                            (list 'revision rev-list)
2217                            'changeset revision)))
2218              (xetla-switch-to-buffer-mode
2219               (if xetla-switch-to-changes-buffer
2220                   xetla-switch-to-buffer-mode 'show-in-other-window)))
2221         (when (and justshow xetla-switch-to-buffer-first)
2222           (xetla-switch-to-buffer buffer))
2223         ;;     (if (gethash revision xetla-changeset-cache)
2224         ;;         (progn
2225         ;;           (message (format "Using changes for revision %S from cache." revision))
2226         ;;           (with-current-buffer buffer
2227         ;;             (let ((buffer-read-only nil))
2228         ;;               (insert (cadr (gethash revision xetla-changeset-cache))))))
2229         ;;       (setq xetla-get-changeset-start-time (current-time))
2230         (xetla-run-tla-async
2231          (list "get-changeset" revision dest)
2232          :finished
2233          `(lambda (output error status arguments)
2234             ;;            (let* ((xetla-run-time (time-to-seconds (time-since xetla-get-changeset-start-time)))
2235             ;;                  (cache-revision (or (and (numberp xetla-cache-xetla-get-changeset)
2236             ;;                                           (> xetla-run-time xetla-cache-xetla-get-changeset))
2237             ;;                                      (and (not (numberp xetla-cache-xetla-get-changeset))
2238             ;;                                           xetla-cache-xetla-get-changeset)))
2239             ;;            )
2240               (when ,justshow
2241                 (xetla-show-changeset ,dest ,without-diff ,buffer)
2242                 ;;               (when cache-revision
2243                 ;;                 (message (format "caching result from xetla-get-changeset, xetla-run-time=%S"
2244                 ;;                                  xetla-run-time))
2245                 ;;                 (with-current-buffer ,buffer
2246                 ;;                   (puthash ,revision
2247                 ;;                            (list (current-time)
2248                 ;;                                  (buffer-substring-no-properties (point-min) (point-max)))
2249                 ;;                            xetla-changeset-cache)))
2250                 (call-process "rm" nil nil nil "-rf" ,dest))))))))
2251     ;; ))
2252
2253 (defun xetla-prepare-changes-buffer (base modified type path)
2254   "Create and return a buffer to run \"tla changes\" or equivalent.
2255
2256 Sets the local-variables `xetla-changes-base' and
2257 `xetla-changes-modified' are set according to BASE and MODIFIED.
2258
2259 TYPE and PATH are passed to `xetla-get-buffer-create'."
2260   (with-current-buffer
2261       (xetla-get-buffer-create type path)
2262     (let ((inhibit-read-only t)) (erase-buffer))
2263     (xetla-changes-mode)
2264     (set (make-local-variable 'xetla-changes-base)     base)
2265     (set (make-local-variable 'xetla-changes-modified) modified)
2266     (current-buffer)))
2267
2268 (defun xetla-show-changeset (directory &optional without-diff buffer
2269                                      base modified)
2270   "Run tla show-changeset on DIRECTORY.
2271
2272 If prefix argument, WITHOUT-DIFF is non-nil, just show the summary.
2273 BUFFER is the target buffer to output.  If BUFFER is nil, create a new
2274 one.
2275
2276 BASE and MODIFIED are the name of the base and modified.  Their values
2277 will be used for the variables `xetla-changes-base' and
2278 `xetla-changes-modified'."
2279   (interactive (list (let ((changeset-dir (or (xetla-get-file-info-at-point) "")))
2280                        (unless (file-directory-p (expand-file-name changeset-dir))
2281                          (setq changeset-dir ""))
2282                        (xetla-uniquify-file-name
2283                         (read-directory-name
2284                          "Changeset directory to view: "  changeset-dir changeset-dir)))))
2285   (unless buffer
2286     (setq buffer (xetla-prepare-changes-buffer base modified
2287                                               'changeset directory))
2288     (if xetla-switch-to-buffer-first
2289         (xetla-switch-to-buffer buffer)))
2290   (xetla-run-tla-sync (list "show-changeset"
2291                            (unless without-diff
2292                              "--diffs")
2293                            directory)
2294                      :finished
2295                      `(lambda (output error status arguments)
2296                         (xetla-show-changes-buffer output (not ',without-diff)
2297                                                  ,buffer
2298                                                  ,xetla-switch-to-buffer-first)
2299                         (xetla-post-switch-to-buffer))))
2300
2301 (defun xetla-show-changeset-from-tgz (file)
2302   "Show the archived changeset from a tar.gz FILE.
2303 Such a changeset can be created via `xetla-changes-save-as-tgz'."
2304   (interactive (list (let ((changeset-tarball (or (xetla-get-file-info-at-point) "")))
2305                        (read-file-name "Changeset tarball to view: " nil changeset-tarball t changeset-tarball))))
2306   (let ((temp-dir (xetla-make-temp-name "xetla-changeset-tgz"))
2307         (changeset-dir))
2308     (message "temp-dir: %s" temp-dir)
2309     (call-process "mkdir" nil nil nil temp-dir)
2310     (call-process "tar" nil nil nil "xfz" file "-C" temp-dir)
2311     (setq changeset-dir (car (delete "." (delete ".." (directory-files temp-dir)))))
2312     (xetla-show-changeset (concat (xetla-uniquify-file-name temp-dir) changeset-dir))
2313     (call-process "rm" nil nil nil "-rf" temp-dir)))
2314
2315 ;;;###autoload
2316 (defun xetla-apply-changeset (changeset target &optional reverse)
2317   "Call \"tla apply-changeset\".
2318
2319 CHANGESET is the changeset to apply, TARGET is the directory in which
2320 to apply the changeset. If REVERSE is non-nil, apply the changeset in
2321 reverse."
2322   (interactive "DChangeset Directory: \nDTarget Directory: \nP")
2323   (if (file-directory-p changeset)
2324       (setq changeset (expand-file-name changeset))
2325     (error "%s is not directory" changeset))
2326   (if (file-directory-p target)
2327       (setq target (expand-file-name target))
2328     (error "%s is not directory" target))
2329
2330   (or (xetla-save-some-buffers target)
2331       (y-or-n-p
2332        "Apply-change may delete unsaved changes.  Continue anyway? ")
2333       (error "Not applying"))
2334   (xetla-apply-changeset-internal changeset target reverse)
2335   (when (y-or-n-p (format "Run inventory at `%s'? " target))
2336     (xetla-inventory target)))
2337
2338 (defun xetla-apply-changeset-internal (changeset target reverse)
2339   "Actually call \"tla apply-changeset CHANGESET TARGET\".
2340
2341 If REVERSE is non-nil, use --reverse too."
2342   (xetla-run-tla-sync (list "apply-changeset"
2343                            (when reverse "--reverse")
2344                            (when xetla-use-forward-option "--forward")
2345                            changeset target)
2346                      :finished `(lambda (output error status arguments)
2347                                   ;; (xetla-show-last-process-buffer)
2348                                   (xetla-show-changes-buffer output)
2349                                   (message "tla apply-changeset finished")
2350                                   (xetla-revert-some-buffers ,target))))
2351
2352 (defun xetla-apply-changeset-from-tgz (file tree)
2353   "Apply changeset in FILE to TREE."
2354   (interactive "fApply changeset from tarball: \nDApply to tree: ")
2355   (let ((target (xetla-tree-root tree))
2356         (temp-dir (xetla-make-temp-name "xetla-changeset-tgz"))
2357         (changeset-dir))
2358     (call-process "mkdir" nil nil nil temp-dir)
2359     (call-process "tar" nil nil nil "xfz" (expand-file-name file) "-C" temp-dir)
2360     (setq changeset-dir (concat (xetla-uniquify-file-name temp-dir)
2361                                 (car (delete "." (delete ".." (directory-files temp-dir))))))
2362     (xetla-show-changeset changeset-dir)
2363     (when (yes-or-no-p "Apply the changeset? ")
2364       (xetla-apply-changeset changeset-dir target))
2365     (call-process "rm" nil nil nil "-rf" temp-dir)))
2366
2367
2368 ;;;###autoload
2369 (defun xetla-file-ediff-revisions (file &optional base modified)
2370   "View changes in FILE between BASE and MODIFIED using ediff."
2371   (interactive (let ((version-list (xetla-tree-version-list)))
2372                  (list (buffer-file-name)
2373                        (list 'revision
2374                              (xetla-name-read "Base revision: "
2375                                              (xetla-name-archive version-list)
2376                                              (xetla-name-category version-list)
2377                                              (xetla-name-branch version-list)
2378                                              (xetla-name-version version-list)
2379                                              'prompt))
2380                        (list 'revision
2381                              (xetla-name-read "Modified revision: "
2382                                              (xetla-name-archive version-list)
2383                                              (xetla-name-category version-list)
2384                                              (xetla-name-branch version-list)
2385                                              (xetla-name-version version-list)
2386                                              'prompt)))))
2387   (xetla-ediff-buffers
2388    (xetla-file-get-revision-in-buffer file base)
2389    (xetla-file-get-revision-in-buffer file modified)))
2390
2391 ;;;###autoload
2392 (defun xetla-file-diff (file &optional revision)
2393   "Run \"tla file-diff\" on file FILE.
2394
2395 In interactive mode, the file is the current buffer's file.
2396 If REVISION is specified, it must be a string representing a revision
2397 name, and the file will be diffed according to this revision."
2398   (interactive (list (buffer-file-name)))
2399   (let ()
2400     (xetla-run-tla-async (list "file-diffs" file revision)
2401                         :finished
2402                         (lambda (output error status arguments)
2403                           (message "No changes in this arch working copy"))
2404                         :error
2405                         (lambda (output error status arguments)
2406                           (if (= 1 status)
2407                               (xetla-show-last-process-buffer
2408                                'file-diff
2409                                'diff-mode)
2410                             (xetla-default-error-function
2411                              output error status arguments))))))
2412
2413 (defvar xetla-mine-string "TREE")
2414 (defvar xetla-his-string "MERGE-SOURCE")
2415
2416 (eval-when-compile
2417   (defvar smerge-mode))
2418
2419 ;;;###autoload
2420 (defun xetla-conflicts-finish ()
2421   "Command to delete .rej file after conflicts resolution.
2422 Asks confirmation if the file still has diff3 markers."
2423   (interactive)
2424   (if (and (boundp 'smerge-mode) smerge-mode)
2425       (progn
2426         (when (and
2427                (save-excursion
2428                  (goto-char (point-min))
2429                  (xetla-funcall-if-exists smerge-find-conflict))
2430                (not (y-or-n-p (concat "Buffer still has diff3 markers. "
2431                                       "Delete .rej file anyway? "))))
2432           (error "Not deleting .rej file"))
2433         (xetla-funcall-if-exists smerge-mode -1))
2434     (when (not (y-or-n-p (concat "Buffer is not in in smerge-mode. "
2435                                  "Delete .rej file anyway? ")))
2436       (error "Not deleting .rej file")))
2437   (let ((rejfile (concat (buffer-file-name) ".rej")))
2438     (if (file-exists-p rejfile)
2439         (progn
2440           (delete-file rejfile)
2441           (message "deleted file %s" rejfile))
2442       (error (format "%s: no such file" rejfile)))))
2443
2444 ;;;###autoload
2445 (defun xetla-view-conflicts (buffer)
2446   "*** WARNING: semi-deprecated function.
2447 Use this function if you like, but M-x smerge-mode RET is actually
2448 better for the same task ****
2449
2450 Graphical view of conflicts after xetla star-merge -three-way. The
2451 buffer given as an argument must be the content of a file with
2452 conflicts markers like.
2453
2454     <<<<<<< TREE
2455     my text
2456     =======
2457     his text
2458     >>>>>>> MERGE-SOURCE
2459
2460 Priority is given to your file by default. (This means all conflicts
2461 will be rejected if you do nothing)."
2462   (interactive (list (find-file (read-file-name "View conflicts in: "))))
2463   (let ((mine-buffer buffer)
2464         (his-buffer (get-buffer-create "*xetla-his*")))
2465     (with-current-buffer his-buffer
2466       (erase-buffer)
2467       (insert-buffer mine-buffer)
2468       (goto-char (point-min))
2469       (while (re-search-forward (concat "^<<<<<<< "
2470                                         (regexp-quote xetla-mine-string) "$")
2471                                 nil t)
2472         (beginning-of-line)
2473         (delete-region (point) (progn
2474                                  (re-search-forward "^=======\n")))
2475         (re-search-forward
2476          (concat "^>>>>>>> "
2477                  (regexp-quote xetla-his-string) "$"))
2478         (beginning-of-line)
2479         (delete-region (point) (1+ (point-at-eol)))
2480         )
2481       )
2482     (with-current-buffer mine-buffer
2483       (goto-char (point-min))
2484       (while (re-search-forward (concat "^<<<<<<< "
2485                                         (regexp-quote xetla-mine-string) "$")
2486                                 nil t)
2487         (beginning-of-line)
2488         (delete-region (point) (1+ (point-at-eol)))
2489         (re-search-forward "^=======$")
2490         (beginning-of-line)
2491         (delete-region (point) (progn
2492                                  (re-search-forward
2493                                   (concat "^>>>>>>> "
2494                                           (regexp-quote xetla-his-string) "\n"))))
2495         ))
2496     (xetla-ediff-buffers mine-buffer his-buffer)
2497     ))
2498
2499 (defun xetla-file-get-revision-in-file (file &optional revision)
2500   "Get the last-committed version of FILE.
2501
2502 If REVISION is non-nil, it must be a cons representing the revision,
2503 and this revision will be used as a reference.
2504
2505 Return (file temporary).  temporary is non-nil when the file is
2506 temporary and should be deleted."
2507   (case (car revision)
2508     (local-tree (list file nil))
2509     (previous-revision (xetla-file-get-revision-in-file
2510                         file
2511                         (list 'revision
2512                               (xetla-compute-direct-ancestor
2513                                (cadr revision)))))
2514     ((last-revision revision)
2515      (let* ((default-directory (if (eq (car revision) 'last-revision)
2516                                    (cadr revision)
2517                                  (xetla-tree-root file)))
2518             (revision (if (eq (car revision) 'revision)
2519                           (xetla-name-construct (cadr revision))))
2520             (original (progn (xetla-run-tla-sync
2521                               (list "file-find" file revision)
2522                               :finished 'xetla-null-handler)
2523                              (with-current-buffer xetla-last-process-buffer
2524                                (goto-char (point-min))
2525                                (re-search-forward "^[^*]")
2526                                (buffer-substring-no-properties
2527                                 (point-at-bol)
2528                                 (point-at-eol)))))
2529             (original-to-be-removed nil)
2530             file-unmodified-p)
2531        (unless (file-exists-p original)
2532          ;; Probably xetla is ran remotely or whatever. Well, get the
2533          ;; file using the old good tla file-diff | patch -R -o ...
2534          (setq original (xetla-make-temp-name "xetla-ediff")
2535                original-to-be-removed t)
2536          (xetla-run-tla-sync (list "file-diffs" file revision)
2537                             :finished 'xetla-null-handler
2538                             :error
2539                             (lambda (output error status arguments)
2540                               (if (not (eq status 1))
2541                                   (xetla-default-error-function
2542                                    output error status arguments))))
2543          (with-current-buffer xetla-last-process-buffer
2544            (if (= (point-min) (point-max))
2545                (setq file-unmodified-p t))
2546            (call-process-region (point-min) (point-max)
2547                                 xetla-patch-executable
2548                                 nil nil nil
2549                                 "-R" "-o" original file)))
2550        (list original file-unmodified-p original-to-be-removed)))))
2551
2552 (defun xetla-file-revert (file &optional revision)
2553   "Revert the file FILE to the last committed version.
2554
2555 Warning: You use version control to keep backups of your files.  This
2556 function will by definition not keep any backup in the archive.
2557
2558 Most of the time, you should not use this function.  Call
2559 `xetla-file-ediff' instead, and undo the changes one by one with the key
2560 `b', then save your buffer.
2561
2562 As a last chance, `xetla-file-revert' keeps a backup of the last-saved in
2563 ~ backup file.
2564
2565 If REVISION is non-nil, it must be a cons representing the revision,
2566 and this revision will be used as a reference."
2567   (interactive (list (progn (when (and (buffer-modified-p)
2568                                        (or xetla-do-not-prompt-for-save
2569                                            (y-or-n-p (format "Save buffer %s? "
2570                                                              (buffer-name
2571                                                               (current-buffer))))))
2572                               (save-buffer))
2573                             (buffer-file-name))))
2574   ;; set aside a backup copy
2575   (copy-file file (car (find-backup-file-name file)) t)
2576
2577   ;; display diff
2578   (xetla-run-tla-sync (list "file-diffs" file revision)
2579                      :finished
2580                      (lambda (output error status arguments)
2581                        (error "File %s is not modified!" (cadr arguments)))
2582                      :error
2583                      (lambda (output error status arguments)
2584                        (if (/= 1 status)
2585                            (xetla-default-error-function
2586                             output error status arguments)
2587                          (xetla-show-last-process-buffer
2588                           'file-diff
2589                           (lambda ()
2590                             (goto-char (point-min))
2591                             (let ((inhibit-read-only t))
2592                               (insert
2593                                (format "M %s\n" (cadr arguments))
2594                                "Do you really want to revert ALL the changes listed below?\n")
2595                               (if xetla-highlight (font-lock-fontify-buffer)))
2596                             (diff-mode))))))
2597
2598   (let* ((file-unmo-temp (xetla-file-get-revision-in-file
2599                           file (if revision
2600                                    (list 'revision revision)
2601                                  (list 'last-revision (xetla-tree-root)))))
2602          (original (car file-unmo-temp)))
2603     (unless (yes-or-no-p (format "Really revert %s? " file))
2604       (bury-buffer)
2605       (error "Not reverting file %s!" file))
2606     (bury-buffer)
2607     (copy-file original file t)
2608     (let ((buf (get-file-buffer file)))
2609       (when buf (with-current-buffer buf (revert-buffer))))))
2610
2611 (defun xetla-undo (tree &optional
2612                       archive category branch version revision)
2613   ; checkdoc-params: (archive category branch version revision)
2614   "Undo whole local TREE against ARCHIVE/CATEGORY-BRANCH-VERSION-REVISION.
2615 If ARCHIVE is nil, default ARCHIVE/CATEGORY-BRANCH-VERSION-REVISION
2616 associated with TREE."
2617   (interactive
2618    (if (and (not current-prefix-arg)
2619             (y-or-n-p "Use default revision to undo? "))
2620        (list default-directory nil nil nil nil nil)
2621      (cons default-directory
2622            (xetla-read-revision-with-default-tree "Undo against archive: "
2623                                                  default-directory))))
2624   (xetla-undo-internal tree archive category branch version revision))
2625
2626
2627 (defun xetla-undo-internal (tree &optional archive category branch version revision)
2628   ; checkdoc-params: (tree archive category branch version revision)
2629   "Internal function used by `xetla-undo'."
2630   (save-excursion (if archive
2631                       (xetla-changes nil (xetla-name-construct
2632                                         archive category branch version revision))
2633                     (xetla-changes)))
2634   (sit-for 1) ;;xetla-changes should start before the yes-or-no-p query
2635   (when (yes-or-no-p
2636          (if archive
2637              (format "Revert whole local tree (%s) from `%s'? "
2638                      tree (xetla-name-construct
2639                            archive category branch version revision))
2640            (format "Revert whole local tree (%s) from default revision? " tree)))
2641     (let ((default-directory tree))
2642       (xetla-run-tla-sync (if archive
2643                              (list "undo" (xetla-name-construct
2644                                            archive category branch version revision))
2645                            (list "undo"))
2646                          ;; TODO in case of files violating the naming
2647                          ;; conventions we could offer to delete them  or
2648                          ;; switch to inventory-mode and do it there,
2649                          ;; basically saying YES should delete them and
2650                          ;; perform the undo operation again
2651                          ))
2652     (xetla-revert-some-buffers tree)))
2653
2654 (defun xetla-get-undo-changeset-names ()
2655   "Get the list of directories starting with \",,undo-\".
2656
2657 This is used by xetla-redo to get the list of candidates for an undo
2658 changeset."
2659   (interactive)
2660   (directory-files (xetla-tree-root default-directory t) t ",,undo-"))
2661
2662 (defun xetla-select-changeset (dir-list)
2663   "Select a changeset.
2664
2665 DIR-LIST is intended to be the result of
2666 `xetla-get-undo-changeset-names'."
2667   (completing-read "Select changeset: " (mapcar 'list dir-list) nil nil (car dir-list)))
2668
2669
2670 (defun xetla-redo (&optional target)
2671   "Run tla redo.
2672 If TARGET directroy is given, TARGET should hold undo data generated by `xetla undo'."
2673   (interactive)
2674   (let* ((undo-changesets (xetla-get-undo-changeset-names))
2675          (undo-changeset (or target
2676                              (when (= (length undo-changesets) 1) (car undo-changesets))
2677                              (xetla-select-changeset undo-changesets))))
2678     (xetla-show-changeset undo-changeset)
2679     (when (yes-or-no-p (format "Redo the %s changeset? " undo-changeset))
2680       (xetla-run-tla-sync (list "redo" undo-changeset)))))
2681
2682
2683 ;;;###autoload
2684 (defun xetla-file-ediff (file &optional revision)
2685   "Interactive view of differences in FILE with ediff.
2686
2687 Changes are computed since last commit (or REVISION if specified)."
2688   (interactive (list (progn (when (and (buffer-modified-p)
2689                                        (y-or-n-p (format "Save buffer %s? "
2690                                                          (buffer-name
2691                                                           (current-buffer)))))
2692                               (save-buffer))
2693                             (buffer-file-name))))
2694   (let ((original (xetla-file-get-revision-in-buffer
2695                    file (or revision (list 'last-revision
2696                                            (xetla-tree-root))))))
2697     (when (string= (with-current-buffer original (buffer-string))
2698                    (buffer-string))
2699       (error "No modification in this file"))
2700     (xetla-ediff-buffers (or (get-file-buffer file)
2701                             (find-file-noselect file))
2702                         original)))
2703
2704 ;;;###autoload
2705 (defun xetla-file-view-original (file &optional revision)
2706   "Get the last-committed version of FILE in a buffer.
2707
2708 If REVISION is specified, it must be a cons representing the revision
2709 for which to get the original."
2710   (interactive (list (buffer-file-name)))
2711   (let ((original (xetla-file-get-revision-in-buffer
2712                    file (or revision (list 'last-revision
2713                                            (xetla-tree-root))))))
2714     (when (string= (with-current-buffer original (buffer-string))
2715                    (buffer-string))
2716       (message "No modification in this file"))
2717     (xetla-switch-to-buffer original)))
2718
2719 (defun xetla-buffer-for-rev (file revision)
2720   "Return an empty buffer suitable for viewing FILE in REVISION.
2721
2722 The name of the buffer is chosen according to FILE and REVISION.
2723
2724 REVISION may have one of the values described in the docstring of
2725 `xetla-changes-modified' or `xetla-changes-base'."
2726   (let ((name (concat
2727                (file-name-nondirectory file)
2728                "(" (cond
2729                     ((eq (car revision) 'revision)
2730                      (xetla-name-construct (cadr revision)))
2731                     ((eq (car revision) 'local-tree)
2732                      (cadr revision))
2733                     ((eq (car revision) 'last-revision) "original")
2734                     ((eq (car revision) 'previous-revision)
2735                      (xetla-name-construct-semi-qualified
2736                       (xetla-compute-direct-ancestor (cadr revision))))
2737                     (t ""))
2738                ")")))
2739     (get-buffer-create
2740      (create-file-buffer name))))
2741
2742 (defun xetla-file-get-revision-in-buffer (file &optional revision)
2743   "Get the last committed version of FILE in a buffer.
2744
2745 Returned value is the buffer.
2746
2747 REVISION can have any of the values described in the docstring of
2748 `xetla-changes-base' and `xetla-changes-modified'"
2749   (let* ((default-directory (xetla-tree-root))
2750          (file-unmo-temp (xetla-file-get-revision-in-file file revision))
2751          (original (car file-unmo-temp))
2752          (original-to-be-removed (cadr file-unmo-temp)))
2753     (if (eq (car revision) 'local-tree)
2754         (find-file-noselect original)
2755       (let ((buffer-orig (xetla-buffer-for-rev file revision)))
2756         (with-current-buffer buffer-orig
2757           (erase-buffer)
2758           (insert-file-contents original)
2759           (when original-to-be-removed
2760             (delete-file original)))
2761         buffer-orig))))
2762
2763 (defun xetla-ediff-startup-hook ()
2764   "Passed as a startup hook for ediff.
2765
2766 Programs ediff to return to the current window configuration after
2767 quitting."
2768   ;; ediff-after-quit-hook-internal is local to an ediff session.
2769   (add-hook 'ediff-after-quit-hook-internal
2770             `(lambda ()
2771                (set-window-configuration
2772                 ,xetla-window-config))
2773             nil 'local))
2774
2775 (defun xetla-commit-check-empty-line ()
2776   "Check that the headers are followed by an empty line.
2777
2778 Current buffer must be a log buffer.  This function checks it starts
2779 with RFC822-like headers, followed by an empty line"
2780   (interactive)
2781   (goto-char (point-min))
2782   (while (not (looking-at "^$"))
2783     (unless (looking-at "^[A-Za-z0-9_-]*:")
2784       (error "A blank line must follow the last header field"))
2785     (forward-line 1)
2786     ;; space and tabs are continuation line.
2787     (while (looking-at "[ \t]+")
2788       (forward-line 1))))
2789
2790 (defun xetla-commit-check-empty-headers ()
2791   "Check that the current buffer starts with non-empty headers.
2792
2793 Also checks that the the line following headers is empty (or the
2794 notion of \"header\" would loose its meaning)."
2795   (interactive)
2796   (goto-char (point-min))
2797   (while (not (looking-at "^$"))
2798     (unless (looking-at "^[A-Za-z0-9_-]*:")
2799       (error "A blank line must follow the last header field"))
2800     (when (looking-at "^\\([A-Za-z0-9_-]*\\):[ \t]*$")
2801       (let ((header (match-string 1)))
2802         (unless (string-match xetla-commit-headers-allowed-to-be-empty
2803                               header)
2804           (end-of-line)
2805           (when (eq (char-before) ?:) (insert " "))
2806           (error (format "Empty \"%s: \" header" header)))))
2807     (forward-line 1)
2808     ;; space and tabs are continuation line.
2809     (while (looking-at "[ \t]+")
2810       (forward-line 1))))
2811
2812 (defun xetla-commit-check-missing-space ()
2813   "Check the space after the colon in each header:
2814
2815 Check that no header in the summary buffer miss the SPC character
2816 following the semicolon.  Also checks that the the line following
2817 headers is empty (or the notion of \"header\" would loose its
2818 meaning)"
2819   (interactive)
2820   (goto-char (point-min))
2821   (let ((stg-changed))
2822     (while (not (looking-at "^$"))
2823       (unless (looking-at "^[A-Za-z0-9_-]*:")
2824         (error "A blank line must follow the last header field"))
2825       (when (looking-at "^\\([A-Za-z0-9_-]*\\):[^ ]")
2826         (let ((header (match-string 1)))
2827           (if xetla-commit-fix-missing-space
2828               (progn
2829                 (setq stg-changed t)
2830                 (search-forward ":")
2831                 (insert " "))
2832             (error (format "Missing space after colon for \"%s:\""
2833                            header)))))
2834       (forward-line 1)
2835       ;; space and tabs are continuation line.
2836       (while (looking-at "[ \t]+")
2837         (forward-line 1)))
2838     (when stg-changed
2839       (save-buffer))))
2840
2841 (defun xetla-commit-check-log-buffer ()
2842   "Function to call from the ++log... buffer, before comitting.
2843
2844 \(`xetla-commit' calls it automatically). This runs the tests listed in
2845 `xetla-commit-check-log-buffer-functions'.  Each function is called with
2846 no argument and can raise an error in case the log buffer isn't
2847 correctly filled in."
2848   (dolist (function xetla-commit-check-log-buffer-functions)
2849     (funcall function)))
2850
2851 (defcustom xetla-warn-about-conflict-files t
2852   "*When non-`nil' ask whether to commit if conflict files are present.
2853 When `nil' commit anyway."
2854   :group 'xetla)
2855
2856 (defun xetla-commit-find-conflict-files (dir)
2857   "Searches for conflict files in the current working directory."
2858   (when (file-readable-p dir)
2859     (let* ((dirs (directory-files dir t "^[^.]+$" nil 'subdirs))
2860            (cur (directory-files dir t "\\.rej"))
2861            (sub (mapcar #'xetla-commit-find-conflict-files dirs)))
2862       (setq cur (delete nil cur))
2863       (setq sub (delete nil sub))
2864       (if sub
2865           (append cur sub)
2866         cur))))
2867
2868 (defun xetla-commit-seal (&optional force)
2869   "Commit a `version-0' revision to seal a repo.
2870
2871 This calls `tla commit --seal'.  With optional argument FORCE, don't
2872 prompt for confirmation."
2873   (interactive)
2874   (when (or force
2875             (y-or-n-p
2876              (format "Do you really want to seal `%s'? "
2877                      (xetla-tree-version))))
2878     (if (string-match "--version\\(-\\|fix-\\)+"
2879                       (xetla-get-current-revision default-directory))
2880         (error "Revision already sealed, use `xetla-commit-fix' instead")
2881       (xetla-commit
2882        (lambda (output error status args)
2883          (xetla-tips-popup-maybe))
2884        'seal))))
2885
2886 (defun xetla-commit-fix (&optional force)
2887   "Commit a `versionfix' revision.
2888
2889 This calls `tla commit --fix'.  With optional argument FORCE, don't
2890 prompt for confirmation."
2891   (interactive)
2892   (when (or force
2893             (y-or-n-p
2894              (format "Do you really want to versionfix `%s'? "
2895                      (xetla-tree-version))))
2896     (if (not (string-match "--version\\(-\\|fix-\\)+"
2897                            (xetla-get-current-revision default-directory)))
2898         (error "Revision not sealed")
2899       (xetla-commit
2900        (lambda (output error status args)
2901          (xetla-tips-popup-maybe))
2902        'fix))))
2903
2904 ;;;###autoload
2905 (defun xetla-commit (&optional handler version-flag)
2906   "Run tla commit.
2907
2908 Optional argument HANDLER is the process handler for the commit
2909 command.
2910
2911 Optional argument VERSION-FLAG may be one of the symbols
2912 'seal to commit a sealed version
2913 'fix  to commit a fix version
2914 If omitted it defaults to a normal commit.
2915
2916 When the commit finishes successful, `tla-commit-done-hook' is called."
2917   (interactive)
2918   (with-current-buffer
2919       (find-file-noselect (xetla-make-log))
2920     (condition-case x
2921         (xetla-commit-check-log-buffer)
2922       (error (progn (switch-to-buffer (current-buffer))
2923                     (eval x))))
2924     (or (xetla-save-some-buffers)
2925         (y-or-n-p
2926          "Commit with unsaved changes is a bad idea.  Continue anyway? ")
2927         (error "Not committing"))
2928     (and xetla-warn-about-conflict-files
2929          ;; fsck it, actually we dont need all the .rej files (yet), so
2930          ;; speed up would be to unwind the recursion after the first
2931          ;; occurrence of a .rej
2932          (xetla-commit-find-conflict-files ".")
2933          (or (y-or-n-p
2934               (concat
2935                "Commit with unresolved conflicts is a bad idea.  "
2936                "Continue anyway? "))
2937              (error "Not committing")))
2938     (let* ((file-list (and (buffer-live-p xetla-buffer-source-buffer)
2939                            (with-current-buffer xetla-buffer-source-buffer
2940                              xetla-buffer-marked-file-list)))
2941            arglist)
2942       (when file-list (setq arglist (append arglist (cons "--"
2943                                                           file-list))))
2944       ;; raises an error if commit isn't possible
2945       (xetla-run-tla-async
2946        (cons "commit"
2947              (cons (when xetla-strict-commits "--strict")
2948                    (cons (cond
2949                           ((eq version-flag 'fix)  "--fix")
2950                           ((eq version-flag 'seal) "--seal")
2951                           ((eq version-flag nil)   nil)
2952                           (t (error "Wrong version flag: %s" version-flag)))
2953                          (when file-list (cons "--"
2954                                                file-list)))))
2955          :finished handler))))
2956
2957 (defun xetla-import ()
2958   "Run tla import."
2959   (interactive)
2960   (with-current-buffer
2961       (find-file-noselect (xetla-make-log)))
2962   (xetla-run-tla-sync (list "import")
2963                        :finished 'xetla-null-handler))
2964
2965
2966 ;;;###autoload
2967 (defun xetla-rm (file)
2968   "Call tla rm on file FILE.  Prompts for confirmation before."
2969   (interactive)
2970   (when (yes-or-no-p (format "Delete file %s? " file))
2971     (xetla-run-tla-sync (list "rm" file)
2972                        :finished 'xetla-null-handler)))
2973
2974 (defun xetla-pristines ()
2975   "Run \"tla pristine\"."
2976   (interactive)
2977   (xetla-run-tla-sync '("pristines")))
2978
2979 ;;;###autoload
2980 (defun xetla-changelog (&optional version)
2981   "Run \"tla changelog\".
2982
2983 Display the result in an improved ChangeLog mode.
2984 With prefix arg, VERSION, display that version's changelog."
2985   (interactive "p")
2986   (let ((default-directory (xetla-read-project-tree-maybe))
2987         (version (when current-prefix-arg
2988                    (xetla-name-construct
2989                     (xetla-name-read "ChangeLog for version: "
2990                                      'prompt 'prompt 'prompt 'prompt)))))
2991     (xetla-run-tla-sync (list "changelog" version)
2992                        :finished 'xetla-null-handler)
2993     (xetla-show-last-process-buffer 'changelog 'xetla-changelog-mode)
2994     (goto-char (point-min))
2995     (view-mode nil (lambda (&rest args)
2996                      (xetla-buffer-quit)))))
2997
2998 ;;;###autoload
2999 (defun xetla-logs ()
3000   "Run tla logs."
3001   (interactive)
3002   (let ((default-directory (xetla-read-project-tree-maybe))
3003 ;        (details (or xetla-revisions-shows-date
3004 ;                     xetla-revisions-shows-creator
3005 ;                     xetla-revisions-shows-summary))
3006         )
3007     (xetla-run-tla-async
3008      (list "logs" "--full"
3009                                         ;           (when details "-date")
3010                                         ;           (when details "-creator")
3011                                         ;           (when details "-summary"))
3012            )
3013      :finished
3014      `(lambda (output error status arguments)
3015         (let ((buffer (xetla-get-buffer-create 'logs (xetla-tree-root))))
3016           (xetla-switch-to-buffer buffer)
3017           (xetla-revision-list-mode)
3018           (xetla-revisions-parse-list 'logs nil ;;,details
3019                                      nil ;; TODO (merges)
3020                                      output nil
3021                                      xetla-revision-list-cookie)
3022           (set (make-local-variable 'xetla-buffer-refresh-function)
3023                'xetla-logs))))))
3024
3025 (defun xetla-help-via-keyb ()
3026   (interactive)
3027   (let ((ext (extent-string (extent-at (point)))))
3028     (xetla-help ext)))
3029
3030 (defun xetla-help-via-mouse (event)
3031   (interactive "e")
3032   (goto-char (event-point event))
3033   (let ((ext (extent-string (extent-at (point)))))
3034     (xetla-help ext)))
3035
3036 (defconst xetla-help-extent-map
3037   (let* ((map (make-sparse-keymap 'xetla-help-extent-map)))
3038     (define-key map [button2] 'xetla-help-via-mouse)
3039     (define-key map [return] 'xetla-help-via-keyb)
3040     map)
3041   "A keymap for the extents in output from `tla help'.")
3042
3043 (defun xetla-display-global-help (buffer &rest args)
3044   (switch-to-buffer buffer)
3045   (xetla-process-buffer-mode)
3046   (goto-char (point-min))
3047   (save-excursion
3048     (while (re-search-forward "\\(\\w+.*\\) : " nil t)
3049       (let ((extent (make-extent (match-beginning 1) (match-end 1)))
3050             (echo "RET or button2 for help on this command."))
3051         (set-extent-property extent 'face 'widget-button-face)
3052         (set-extent-property extent 'mouse-face 'highlight)
3053         (set-extent-property extent 'keymap xetla-help-extent-map)
3054         (set-extent-property extent 'help-echo echo)
3055         (set-extent-property extent 'balloon-help echo)
3056         (set-extent-property extent 'duplicable t)))))
3057
3058 ;;;###autoload
3059 (defun xetla-help (command)
3060   "Run tla COMMAND -H."
3061   (interactive
3062    (list (completing-read
3063           "Get help for: "
3064           (xetla-run-tla-sync
3065            '("help")
3066            :finished
3067            `(lambda (output error status arguments)
3068               (with-current-buffer output
3069                 (goto-char (point-min))
3070                 (let (listcmd)
3071                   (while (re-search-forward
3072                           " *\\([^ ]*\\) : " nil t)
3073                     (setq listcmd
3074                           (cons (list (match-string 1))
3075                                 listcmd)))
3076                   listcmd)))))))
3077   (if (string= command "")
3078       (xetla-run-tla-sync
3079        '("help")
3080        :finished 'xetla-display-global-help)
3081     (xetla-run-tla-sync (list command "-H"))))
3082
3083 (defun xetla-tree-version-list-tla ()
3084   "Return the tree version, or nil if not in a project tree."
3085   (xetla-run-tla-sync '("tree-version")
3086                      :finished
3087                      (lambda (output error status arguments)
3088                        (with-current-buffer output
3089                          (and
3090                           (goto-char (point-min))
3091                           (re-search-forward "\\(.*\\)/\\(.*\\)--\\(.*\\)--\\(.*\\)" nil t)
3092                           (list (match-string 1)
3093                                 (match-string 2)
3094                                 (match-string 3)
3095                                 (match-string 4)))))))
3096
3097 (defun xetla-tree-version-list (&optional location no-error)
3098   "Elisp implementation of `xetla-tree-version-list-tla'.
3099
3100 A string, LOCATION is used as a directory where
3101 \"/{arch}/++default-version\" is. If NO-ERROR is non-nil, errors are
3102 not reported; just return nil."
3103   (let ((version-string (xetla-tree-version location no-error)))
3104     (and version-string
3105          (string-match "\\(.*\\)/\\(.*\\)--\\(.*\\)--\\(.*\\)" version-string)
3106          (list (match-string 1 version-string)
3107                (match-string 2 version-string)
3108                (match-string 3 version-string)
3109                (match-string 4 version-string)))))
3110
3111 (defun xetla-tree-root-xetla ()
3112   "Run tla tree-root."
3113   (interactive)
3114   (xetla-run-tla-sync '("tree-root")
3115                      :finished
3116                      `(lambda (output error status arguments)
3117                         (let ((result (xetla-buffer-content output)))
3118                           (when ,(interactive-p)
3119                             (message "tla tree-root is: %s"
3120                                      result))
3121                           result))))
3122
3123 ;;;###autoload
3124 (defun xetla-tree-version (&optional location no-error)
3125   "Equivalent of xetla tree-version (but implemented in pure elisp).
3126
3127 Optional argument LOCATION is the directory in which the command must
3128 be ran.  If NO-ERROR is non-nil, don't raise errors if ran outside an
3129 arch managed tree."
3130   (interactive (list nil nil))
3131   (let* ((tree-root (xetla-tree-root location no-error))
3132          (default-version-file (when tree-root
3133                                  (expand-file-name
3134                                   "{arch}/++default-version"
3135                                   tree-root)))
3136          (version (and (boundp 'xetla-buffer-version-name)
3137                        xetla-buffer-version-name)))
3138     (if (and (null version)
3139              default-version-file
3140              (file-readable-p default-version-file))
3141         (with-temp-buffer
3142           (insert-file-contents default-version-file)
3143           (setq version (buffer-substring-no-properties
3144                          (point-min)
3145                          (if (eq (char-before (point-max)) ?\n)
3146                              (1- (point-max))
3147                            (point-max))))))
3148     (when (interactive-p)
3149       (message "%s" version))
3150     version))
3151
3152 ;;;###autoload
3153 (defun xetla-my-id (&optional arg my-id)
3154   "Run tla my-id.
3155
3156 When called without a prefix argument ARG, just print the my-id from
3157 xetla and return it.  If MY-ID is not set yet, return an empty string.
3158 When called with a prefix argument, ask for a new my-id.
3159
3160 The my-id should have the following format:
3161
3162 Your id is recorded in various archives and log messages as you use
3163 arch.  It must consist entirely of printable characters and fit on one
3164 line.  By convention, it should have the form of an email address, as
3165 in this example:
3166
3167 Jane Hacker <jane.hacker@email.address>"
3168   (interactive "P")
3169   (let ((id (xetla-run-tla-sync '("my-id")
3170                                :finished
3171                                (lambda (output error status arguments)
3172                                  (xetla-buffer-content output))
3173                                :error
3174                                (lambda (output error status arguments)
3175                                  nil))))
3176     (if arg
3177         ;; Set the user's ID
3178         (let ((new-id (or my-id
3179                           (read-string "New arch my-id: "
3180                                        id xetla-my-id-history id))))
3181           (if (string= id new-id)
3182               (message "Id unchanged! Id = %s" new-id)
3183             (message "Setting id to: %s" new-id)
3184             (xetla-run-tla-sync (list "my-id" new-id)
3185                                :finished (lambda (output error status arguments)
3186                                            (message "Id changed"))
3187                                :error
3188                                (lambda (output error status arguments)
3189                                  (message "Could not change Id")
3190                                  (xetla-show-error-buffer error)
3191                                  )))
3192           new-id)
3193       (cond (id (when (interactive-p)
3194                   (message "Arch my-id: %s" id))
3195                 id)
3196             (t (when (interactive-p)
3197                  (message (concat "Arch my-id has not been given yet. "
3198                                   "Call `%s' to set.")
3199                           "xetla-set-my-id"))
3200                "")))))
3201
3202 (defun xetla-set-my-id ()
3203   "Set xetla's my-id."
3204   (interactive)
3205   (xetla-my-id 1))
3206
3207 ;;
3208 ;; Library
3209 ;;
3210
3211 ;;;###autoload
3212 (defun xetla-my-revision-library (&optional arg)
3213   "Run tla my-revision-library.
3214
3215 When called without a prefix argument ARG, just print the
3216 my-revision-library from xetla.  When called with a prefix argument, ask
3217 for a new my-revision-library.
3218
3219 my-revision-library specifies a path, where the revision library is
3220 stored to speed up tla.  For example ~/tmp/arch-lib.
3221
3222 You can configure the parameters for the library via
3223 `xetla-library-config'."
3224   (interactive "P")
3225   (let ((result (xetla-run-tla-sync '("my-revision-library")
3226                                    :finished 'xetla-status-handler
3227                                    :error 'xetla-null-handler))
3228         (rev-lib (xetla-get-process-output)))
3229     (when (eq 0 result)
3230       (if arg
3231           (xetla-library-add-interactive rev-lib)
3232         (if (and rev-lib (string= "" rev-lib))
3233             (message "Arch my-revision-library has not been given yet. Call `%s' with prefix arguments to set."
3234                      this-command)
3235           (when (interactive-p) (message "Arch my-revision-library: %s" rev-lib)))
3236         rev-lib))))
3237
3238 (defun xetla-library-add-interactive (&optional old-rev-lib)
3239   "Prompts for argument and run `xetla-library-add'.
3240
3241 Argument OLD-REV-LIB is the previously set revision library (a
3242 string)."
3243   (unless old-rev-lib (setq old-rev-lib ""))
3244   (let ((new-rev-lib (expand-file-name (read-directory-name
3245                                         "New arch revision library: " old-rev-lib))))
3246     (if (not (string= old-rev-lib new-rev-lib))
3247         (progn
3248           (message "Setting my-revision-library to: %s" new-rev-lib)
3249           (xetla-library-add-internal new-rev-lib))
3250       old-rev-lib)))
3251
3252 (defun xetla-library-delete (rev-lib)
3253   "Unregister revision library REV-LIB."
3254   (interactive (list (xetla-read-revision-library)))
3255   (xetla-run-tla-sync (list "my-revision-library" "--delete" rev-lib)
3256                      :finished (lambda (output error status arguments)
3257                                  (message "Library %s removed."
3258                                           rev-lib))))
3259
3260 (defun xetla-library-add-internal (new-rev-lib)
3261   "Change the revision library path to NEW-REV-LIB."
3262   (let ((dir-attr (file-attributes new-rev-lib)))
3263     (unless dir-attr
3264       (make-directory new-rev-lib t))
3265     (xetla-run-tla-sync (list "my-revision-library" new-rev-lib)
3266                        :finished
3267                        (lambda (output error status arguments)
3268                          (message (xetla-buffer-content output))))
3269     new-rev-lib))
3270
3271 (defun xetla-revision-library-list ()
3272   "Parse `xetla my-revision-library' into a list of revision libraries."
3273   (xetla-run-tla-sync '("my-revision-library")
3274                      :finished
3275                      'xetla-output-buffer-split-handler))
3276
3277 (defvar xetla-library-history nil)
3278
3279 (defun xetla-read-revision-library (&optional prompt)
3280   "Read a revision library from keyboard.
3281 Prompt the user with PROMPT if given."
3282   (let ((list-lib (xetla-revision-library-list)))
3283     (if (null (cdr list-lib))
3284         (car list-lib)
3285       (completing-read (or prompt
3286                            (format "Revision library (default %s): "
3287                                    (car list-lib)))
3288                        (mapcar 'list (xetla-revision-library-list))
3289                        nil t nil xetla-library-history
3290                        (car list-lib)))))
3291
3292 (defun xetla-library-config (&optional arg)
3293   "Run tla library-config.
3294 When called without prefix argument ARG, just print the config.
3295 When called with prefix argument ARG, let the user change the config."
3296   (interactive "P")
3297   (let ((rev-lib (xetla-read-revision-library))
3298         (config-param (when arg
3299                         (completing-read "tla library config "
3300                                          (mapcar 'list '("--greedy"
3301                                                          "--sparse"
3302                                                          "--non-greedy"
3303                                                          "--non-sparse"))
3304                                          nil t "--"))))
3305     (xetla-run-tla-sync (list "library-config" config-param rev-lib)
3306                        :finished 'xetla-null-handler)
3307     (message (xetla-get-process-output))))
3308
3309 (defun xetla-library-add (archive category branch version revision)
3310   "Add ARCHIVE-CATEGORY-BRANCH-VERSION-REVISION to the revision library."
3311   (xetla-show-last-process-buffer)
3312   (xetla-run-tla-async `("library-add"
3313                         ,(xetla-name-construct archive category
3314                                               branch version
3315                                               revision))))
3316
3317 (defun xetla-library-find (archive category branch version revision
3318                                  &optional silent)
3319   "Find ARCHIVE-CATEGORY-BRANCH-VERSION-REVISION in the revision library.
3320 If the revision is found, return the path for it. Else return nil."
3321   (if (zerop (xetla-run-tla-sync (list "library-find" (when silent "--silent")
3322                                       (xetla-name-construct
3323                                        archive category branch
3324                                        version revision))
3325                                 :finished 'xetla-status-handler
3326                                 :error 'xetla-status-handler))
3327       (xetla-get-process-output)))
3328
3329 ;; completing-read: tagline, explicit, names, implicit
3330 (defvar xetla-id-tagging-method-history nil)
3331 ;;;###autoload
3332 (defun xetla-id-tagging-method (arg)
3333   "View (and return) or change the id-tagging method.
3334 When called without prefix argument ARG: show the actual tagging method.
3335 When called with prefix argument ARG: Ask the user for the new tagging method."
3336   (interactive "P")
3337   (let ((tm (progn (xetla-run-tla-sync '("id-tagging-method")
3338                                       :finished
3339                                       (lambda (output error status arguments)
3340                                         (xetla-buffer-content output)))))
3341         (new-tagging-method))
3342     (if arg
3343         (progn
3344           (setq new-tagging-method
3345                 (xetla-id-tagging-method-read tm))
3346           (when (not (string= tm new-tagging-method))
3347             (xetla-id-tagging-method-set new-tagging-method)))
3348       (when (interactive-p)
3349         (message "Arch id tagging method: %s" tm))
3350       tm
3351       )))
3352
3353 (defun xetla-id-tagging-method-read (old-method)
3354   "Read id tagging method.
3355 If OLD-METHOD is given, use it as the default method."
3356   (completing-read
3357    (if old-method
3358        (format "New id tagging method (default %s): " old-method)
3359      "New id tagging method: ")
3360    (mapcar 'list '("tagline" "explicit" "names" "implicit"))
3361    nil t nil
3362    xetla-id-tagging-method-history
3363    old-method))
3364
3365 (defun xetla-id-tagging-method-set (method)
3366   "Set the tagging method to METHOD."
3367   (message "Setting tagging method to: %s" method)
3368   (xetla-run-tla-sync (list "id-tagging-method"
3369                            method)
3370                      :finished 'xetla-null-handler))
3371
3372 (defun xetla-archive-mirror (archive &optional category branch version from)
3373   "Synchronize the mirror for ARCHIVE.
3374 Limit to CATEGORY-BRANCH-VERSION. If FROM is provided, mirror from it."
3375   (interactive (xetla-name-read nil 'prompt))
3376   (let ((name (xetla-name-construct-semi-qualified category branch version)))
3377     (when (string= name "") (setq name nil))
3378     (xetla-run-tla-async (list "archive-mirror"
3379                               archive
3380                               name
3381                               from)
3382                         :finished `(lambda (output error status arguments)
3383                                      (message "tla archive-mirror finished"))
3384                         )))
3385
3386 (defun xetla-archive-fixup (archive)
3387   "Run tla archive-fixup for ARCHIVE."
3388   (interactive (list (car (xetla-name-read "Archive to fixup: " 'prompt))))
3389   (xetla-run-tla-async (list "archive-fixup" "-A" archive)
3390                       :finished `(lambda (output error status arguments)
3391                                    (message "tla archive-fixup %s finished" ,archive))
3392                       ))
3393
3394
3395 (defun xetla-star-merge (from &optional to-tree)
3396   "Star merge from version/revision FROM to local tree TO-TREE."
3397   (interactive (list (xetla-name-construct
3398                       (xetla-name-read "Star merge from (version or revision): "
3399                                        'prompt 'prompt 'prompt 'prompt 'maybe))
3400                      (read-directory-name "In tree: ")))
3401   (let ((to-tree (when to-tree (expand-file-name to-tree))))
3402     (or (xetla-save-some-buffers (or to-tree default-directory))
3403         (y-or-n-p
3404          "Star-merge may delete unsaved changes.  Continue anyway? ")
3405         (error "Not running star-merge"))
3406     (let* ((default-directory (or to-tree default-directory))
3407            (arglist '())
3408            (buffer (xetla-prepare-changes-buffer
3409                     (list 'last-revision default-directory)
3410                     (list 'local-tree default-directory)
3411                     ;; TODO using xetla-changes here makes it simpler.
3412                     ;; The user can just type `g' and get the real
3413                     ;; changes. Maybe a 'star-merge would be better
3414                     ;; here ...
3415                     'changes default-directory)))
3416       (when xetla-switch-to-buffer-first
3417         (xetla-switch-to-buffer buffer))
3418       (when xetla-three-way-merge (add-to-list 'arglist "--three-way"))
3419       (when xetla-use-forward-option (add-to-list 'arglist "--forward"))
3420       (xetla-run-tla-async `("star-merge" ,@arglist ,from)
3421                           :finished `(lambda (output error status arguments)
3422                                        ;; (xetla-show-last-process-buffer)
3423                                        (xetla-show-changes-buffer
3424                                         output nil ,buffer)
3425                                        (message "tla star-merge finished")
3426                                        (xetla-revert-some-buffers ,to-tree))
3427                           :error `(lambda (output error status arguments)
3428                                     (case status
3429                                       ;; 2 stands for an error.
3430                                       (2 (xetla-default-error-function
3431                                           output error status arguments))
3432                                       ;; How about other status?
3433                                       (otherwise (xetla-show-changes-buffer output)
3434                                                  output nil ,buffer)))))))
3435
3436 (defun xetla-replay-arguments ()
3437   "Build an argument list for the replay command.
3438 Used to factorize the code of (interactive ...) between `xetla-replay-reverse'
3439 and `xetla-replay'."
3440   (list (xetla-name-construct
3441          (xetla-name-read "Relay version or revision: "
3442                          'prompt 'prompt 'prompt 'prompt 'maybe))
3443         (read-directory-name "Replay in tree: ")
3444         current-prefix-arg))
3445
3446 (defun xetla-replay-reverse (from &optional to-tree arg)
3447   "Call `xetla-replay' with the REVERSE option."
3448   (interactive (xetla-replay-arguments))
3449   (xetla-replay from to-tree arg t))
3450
3451
3452 (defun xetla-replay (from &optional to-tree arg reverse)
3453   "Replay the revision FROM into tree TO-TREE.
3454 If FROM is a string, it should be a fully qualified revision.
3455 If FROM is a list, it should be a list of fully qualified revisions to
3456 be replayed.
3457
3458 If ARG is non-nil, replay all the version instead of the revision only.
3459 If REVERSE is non-nil, reverse the requested revision."
3460   (interactive (xetla-replay-arguments))
3461   (let ((default-directory (or to-tree default-directory)))
3462     (or (xetla-save-some-buffers)
3463         (y-or-n-p
3464          "Replay may delete unsaved changes.  Continue anyway? ")
3465         (error "Not replaying"))
3466     (xetla-show-last-process-buffer)
3467     (let ((buffer (xetla-prepare-changes-buffer
3468                    (list 'last-revision default-directory)
3469                    (list 'local-tree default-directory)
3470                    'changes default-directory)))
3471       (when xetla-switch-to-buffer-first
3472         (xetla-switch-to-buffer buffer))
3473       (xetla-run-tla-async `("replay"
3474                             ,(when xetla-use-forward-option "--forward")
3475                             ,(when reverse "--reverse")
3476                             ,(when xetla-use-skip-present-option "--skip-present")
3477                             ,@(if (listp from)
3478                                   from
3479                                 (list from)))
3480                           :finished `(lambda (output error status arguments)
3481                                        (xetla-show-changes-buffer output
3482                                                                 nil ,buffer)
3483                                        (message "tla replay finished")
3484                                        (xetla-revert-some-buffers ,to-tree))
3485                           :error (lambda (output error status arguments)
3486                                    (xetla-show-error-buffer error)
3487                                    (xetla-show-last-process-buffer))))))
3488
3489 (defun xetla-sync-tree (from &optional to-tree)
3490   "Synchronize the patch logs of revision FROM and tree TO-TREE."
3491   (interactive (list
3492                 (xetla-name-construct
3493                  (xetla-name-read "Sync tree with revision: "
3494                                  'prompt 'prompt 'prompt 'prompt 'prompt))
3495                 (read-directory-name "Sync tree: ")))
3496   (let ((default-directory (or to-tree default-directory)))
3497     (or (xetla-save-some-buffers)
3498         (y-or-n-p
3499          "Update may delete unsaved changes.  Continue anyway? ")
3500         (error "Not updating"))
3501     (xetla-show-last-process-buffer)
3502     (xetla-run-tla-async `("sync-tree" ,from)
3503                         :finished `(lambda (output error status arguments)
3504                                      (xetla-show-last-process-buffer)
3505                                      (message "tla sync-tree finished")
3506                                      (xetla-revert-some-buffers ,to-tree))
3507                         :error (lambda (output error status arguments)
3508                                  (xetla-show-changes-buffer output)))))
3509
3510 (defun xetla-tag (source-revision tag-version)
3511   "Create a tag from SOURCE-REVISION to TAG-VERSION.
3512 Run tla tag --setup."
3513   (interactive
3514    (list (xetla-name-construct
3515           (xetla-name-read "Source revision (or version): " 'prompt 'prompt 'prompt
3516                          'prompt 'maybe))
3517          (xetla-name-construct
3518           (xetla-name-read "Tag version: " 'prompt 'prompt 'prompt
3519                          'prompt))))
3520   (xetla-run-tla-async (list "tag" "--setup"
3521                             source-revision tag-version)))
3522
3523 (defun xetla-set-tree-version (version)
3524   "Run tla set-tree-version VERSION."
3525   (interactive (list (xetla-name-read "Set tree version to: "
3526                                      'prompt 'prompt 'prompt 'prompt)))
3527
3528   (let ((new-version (xetla-name-construct version))
3529         (old-version (xetla-tree-version)))
3530     (when (y-or-n-p (format "Switch tree version from `%s' to `%s'? "
3531                             old-version
3532                             new-version))
3533       (xetla-run-tla-sync (list "set-tree-version" new-version)))))
3534
3535 ;; --------------------------------------
3536 ;; Xetla bookmarks
3537 ;; --------------------------------------
3538
3539 (make-face 'xetla-bookmark-name
3540            "Face used for bookmark names.")
3541 (set-face-foreground 'xetla-bookmark-name "magenta")
3542
3543 (defvar xetla-bookmarks-loaded nil
3544   "Whether `xetla-bookmarks' have been loaded from file.")
3545
3546 (defvar xetla-bookmarks-alist nil
3547   "Alist containing Xetla bookmarks.")
3548
3549 (defvar xetla-bookmarks-show-details nil
3550   "Whether `xetla-bookmarks' should show bookmark details.")
3551
3552 (defvar xetla-bookmarks-cookie nil
3553   "Ewoc dll.")
3554
3555 (defvar xetla-missing-buffer-todolist nil
3556   "List of (kind info).
3557
3558 Can be
3559 \(separator \"label\" bookmark \"local-tree\")
3560 \(changes \"local-tree\")
3561 \(missing \"local-tree\" \"location\" \"bookmark-name\")")
3562
3563 (defvar xetla-bookmarks-marked-list nil
3564   "A list of marked bookmarks.")
3565
3566 (defun xetla-bookmarks-load-from-file (&optional force)
3567   "Load bookmarks from the file `xetla-bookmarks-file-name'.
3568
3569 If FORCE is non-nil, reload the file even if it was loaded before."
3570   (when (or force (not xetla-bookmarks-loaded))
3571     (xetla-load-state (xetla-config-file-full-path
3572                        xetla-bookmarks-file-name t))
3573     (setq xetla-bookmarks-loaded t)))
3574
3575 (defun xetla-bookmarks-save-to-file ()
3576   "Save `xetla-bookmarks-alist' to the file `xetla-bookmarks-file-name'."
3577   (xetla-save-state '(xetla-bookmarks-alist)
3578                   (xetla-config-file-full-path xetla-bookmarks-file-name t)
3579                   t))
3580
3581 (defun xetla-bookmarks-toggle-details (&optional val)
3582   "Toggle the display of bookmark details.
3583 If VAL is positive, enable bookmark details.
3584 If VAL is negative, disable bookmark details."
3585   (interactive "P")
3586   (let ((current-bookmark (ewoc-locate xetla-bookmarks-cookie)))
3587     (setq xetla-bookmarks-show-details
3588           (if val
3589               (if (> val 0) t
3590                 (if (< val 0) nil
3591                   (not xetla-bookmarks-show-details)))
3592             (not xetla-bookmarks-show-details)))
3593     (ewoc-refresh xetla-bookmarks-cookie)
3594     (xetla-bookmarks-cursor-goto current-bookmark)))
3595
3596 (defvar xetla-bookmarks-align 19
3597   "Position, in chars, of the `:' when displaying the bookmarks buffer.")
3598
3599 (defun xetla-bookmarks-printer (element)
3600   "Pretty print ELEMENT, an entry of the bookmark list.
3601 This is invoked by ewoc when displaying the bookmark list."
3602   (insert (if (member element xetla-bookmarks-marked-list)
3603               (concat " " xetla-mark " ") "   "))
3604   (xetla-insert-right-justified (concat (car element) ": ")
3605                                (- xetla-bookmarks-align 3)
3606                                'xetla-bookmark-name)
3607   (insert (xetla-face-add (xetla-name-construct
3608                           (cdr (assoc 'location (cdr element))))
3609                          'xetla-revision-name
3610                          'xetla-bookmarks-entry-map
3611                          xetla-bookmarks-entry-menu
3612                          ))
3613   (when xetla-bookmarks-show-details
3614     (newline)
3615     (insert-char ?\  xetla-bookmarks-align)
3616     (insert (cdr (assoc 'timestamp (cdr element))))
3617     (newline)
3618     (let ((notes (assoc 'notes (cdr element))))
3619       (when notes
3620         (insert-char ?\  xetla-bookmarks-align)
3621         (insert (cdr notes))
3622         (newline)))
3623     (let ((nickname (assoc 'nickname (cdr element))))
3624       (when nickname
3625         (xetla-insert-right-justified "nickname: " xetla-bookmarks-align)
3626         (insert (cadr nickname))
3627         (newline)))
3628     (let ((partners (assoc 'partners (cdr element))))
3629       (when partners
3630         (xetla-insert-right-justified "partners: " xetla-bookmarks-align)
3631         (insert (cadr partners))
3632         (dolist (x (cddr partners))
3633           (insert ",\n")
3634           (insert-char ?\  xetla-bookmarks-align)
3635           (insert x))
3636         (newline)))
3637     (let ((local-tree (assoc 'local-tree (cdr element))))
3638       (when local-tree
3639         (xetla-insert-right-justified "local trees: " xetla-bookmarks-align)
3640         (insert (cadr local-tree))
3641         (dolist (x (cddr local-tree))
3642           (insert ", " x ))
3643         (newline)))
3644     (let ((groups (assoc 'groups (cdr element))))
3645       (when groups
3646         (xetla-insert-right-justified "Groups: " xetla-bookmarks-align)
3647         (insert (cadr groups))
3648         (dolist (x (cddr groups))
3649           (insert ", " x ))
3650         (newline)))
3651     (let ((summary-format (assoc 'summary-format (cdr element))))
3652       (when summary-format
3653         (xetla-insert-right-justified "Summary format: " xetla-bookmarks-align)
3654         (insert "\"" (cadr summary-format) "\"")
3655         (newline)))))
3656
3657 (defvar xetla-revision-list-cookie nil
3658   "Ewoc cookie for xetla-bookmark-missing.")
3659
3660 (defun xetla-bookmarks-read-local-tree (&optional bookmark arg)
3661   "Read a local tree for BOOKMARK, and possibly add it to the bookmarks.
3662 If ARG is non-nil, user will be prompted anyway.  Otherwise, just use the
3663 default if it exists."
3664   (let* ((bookmark (or bookmark
3665                        (ewoc-data (ewoc-locate
3666                                    xetla-bookmarks-cookie))))
3667          (local-trees (assoc 'local-tree (cdr bookmark))))
3668     (cond
3669      ((not local-trees)
3670       (let ((dir (read-directory-name
3671                   (format "Local tree for \"%s\": "
3672                           (car bookmark)))))
3673         (when (y-or-n-p "Add this tree in your bookmarks? ")
3674           (xetla-bookmarks-add-tree bookmark dir))
3675         dir))
3676      (arg
3677       ;; multiple local trees.
3678       (let ((dir (completing-read
3679                   (format "Local tree for \"%s\": "
3680                           (car bookmark))
3681                   (mapcar #'(lambda (x) (cons x nil))
3682                           (cdr local-trees))
3683                   nil nil nil nil (cadr local-trees))))
3684         (when (and (not (member dir (cdr local-trees)))
3685                    (y-or-n-p "Add this tree in your bookmarks? "))
3686           (xetla-bookmarks-add-tree bookmark dir))
3687         (when (and (not (string=
3688                          dir (cadr local-trees)))
3689                    (y-or-n-p "Make this the default? "))
3690           (xetla-bookmarks-delete-tree bookmark dir)
3691           (xetla-bookmarks-add-tree bookmark dir))
3692         dir))
3693      (t (cadr local-trees)))))
3694
3695 (defun xetla-bookmarks-missing (&optional arg)
3696   "Show the missing patches from your partners.
3697 The missing patches are received via xetla missing.
3698 Additionally the local changes in your working copy are also shown.
3699
3700 If prefix argument ARG is specified, the local tree is prompted even
3701 if already set in the bookmarks."
3702   (interactive "P")
3703   (unless xetla-bookmarks-cookie
3704     (error "Wrong buffer, run: `%s' and try again"
3705            (substitute-command-keys "\\[xetla-bookmarks]")))
3706   (let ((list (or xetla-bookmarks-marked-list
3707                   (list (ewoc-data (ewoc-locate
3708                                     xetla-bookmarks-cookie))))))
3709     (set-buffer (xetla-get-buffer-create 'missing))
3710     (xetla-revision-list-mode)
3711     (set (make-local-variable 'xetla-buffer-refresh-function)
3712          'xetla-missing-refresh)
3713     (let ((xetla-bookmarks-missing-buffer-list-elem
3714            (mapcar
3715             #'(lambda (elem)
3716                 (cons
3717                  elem
3718                  (xetla-bookmarks-read-local-tree elem arg)))
3719             list)))
3720       (set (make-local-variable 'xetla-missing-buffer-todolist)
3721            (reverse
3722             (apply 'append
3723                    (mapcar (lambda (elem)
3724                              (xetla-bookmarks-missing-elem
3725                               (car elem) arg (cdr elem) t t))
3726                            xetla-bookmarks-missing-buffer-list-elem))))
3727       (xetla-missing-refresh))))
3728
3729 (defvar xetla-nb-active-processes 1
3730   "Number of active processes in this buffer.
3731
3732 Used internally as a counter to launch a global handler when all
3733 processes have finished.")
3734
3735 (defun xetla-missing-refresh ()
3736   "Refreshed a *xetla-missing* buffer.
3737
3738 Process the variable `xetla-missing-buffer-todolist' and launches the
3739 xetla processes with the appropriate handlers to fill in the ewoc."
3740   (interactive)
3741   (set (make-local-variable 'xetla-nb-active-processes) 1)
3742   (let ((buffer-read-only nil))
3743     (erase-buffer)
3744     (set (make-local-variable 'xetla-revision-list-cookie)
3745          (ewoc-create 'xetla-revision-list-printer))
3746     (xetla-kill-process-maybe (current-buffer))
3747     (dolist (item xetla-missing-buffer-todolist)
3748       (case (car item)
3749         (missing
3750          ;; This item is a version that we want to check for missing patches.
3751          ;; ITEM is of the form:
3752          ;; (missing <local tree> <fully qualified version> [bookmark name])
3753          (let* ((local-tree (nth 1 item))
3754                 (version (nth 2 item))
3755                 (bookmark-name (nth 3 item))
3756                 (text (if bookmark-name
3757                           (format "Missing patches from partner %s:"
3758                                   bookmark-name)
3759                         (concat "Missing patches from archive " version)))
3760                 (node (ewoc-enter-last xetla-revision-list-cookie
3761                                        (list 'separator (concat
3762                                                          text)
3763                                              'partner))))
3764            (ewoc-enter-last xetla-revision-list-cookie
3765                             '(message "Checking for missing patches..."))
3766            (let ((default-directory local-tree))
3767              ;; Set the default-directory for the *xetla-missing* buffer.
3768              (cd default-directory)
3769              (setq xetla-nb-active-processes
3770                    (+ xetla-nb-active-processes 1))
3771              (xetla-run-tla-async
3772               `("missing" "--full" ,(when xetla-use-skip-present-option
3773                                       "--skip-present");;"-summary" "-creator" "-date"
3774                 ,version)
3775               :finished
3776               `(lambda (output error status arguments)
3777                  (when (and (xetla-get-buffer 'missing)
3778                             (buffer-live-p (xetla-get-buffer 'missing)))
3779                    (with-current-buffer (xetla-get-buffer-create 'missing)
3780                      (when (ewoc-p xetla-revision-list-cookie)
3781                        (let* ((cookie xetla-revision-list-cookie)
3782                               (to-delete (ewoc-next cookie ,node))
3783                               (prev (ewoc-prev
3784                                      xetla-revision-list-cookie
3785                                      to-delete))
3786                               (cur (ewoc-locate
3787                                     xetla-revision-list-cookie))
3788                               (deleted (eq cur to-delete)))
3789                          (xetla-revisions-parse-list
3790                           'missing nil
3791                           nil
3792                           output ,node cookie
3793                           'xetla-revision-compute-merged-by
3794                           )
3795                          (ewoc--node-delete to-delete)
3796                          (ewoc-refresh xetla-revision-list-cookie)
3797                          (let ((loc (if deleted
3798                                         (ewoc-next
3799                                          xetla-revision-list-cookie
3800                                          prev)
3801                                       cur)))
3802                            (when loc
3803                              (goto-char (ewoc-location loc)))))))))
3804               :error
3805               `(lambda (output error status arguments)
3806                  (when (and (xetla-get-buffer 'missing)
3807                             (buffer-live-p (xetla-get-buffer 'missing)))
3808                    (with-current-buffer (xetla-get-buffer-create 'missing)
3809                      (when (ewoc-p xetla-revision-list-cookie)
3810                        (let* ((cookie xetla-revision-list-cookie)
3811                               (to-delete (ewoc-next cookie ,node)))
3812                          (setcdr (ewoc-data to-delete) '("Error in xetla process"))))))
3813                  (message "Abnormal exit with code %d!\n%s" status
3814                           (xetla-buffer-content error)))))))
3815         (separator
3816          ;; This item is a separator - the name of a bookmark.
3817          ;; ITEM is of the form:
3818          ;; (separator <text> bookmark <local tree>)
3819          (let* ((text (nth 1 item))
3820                 (local-tree (nth 3 item)))
3821            (ewoc-enter-last xetla-revision-list-cookie
3822                             (list 'separator
3823                                   text
3824                                   'bookmark
3825                                   local-tree))))
3826         (changes
3827          ;; This item is a local-tree that should be checked for changes.
3828          ;; ITEM is of the form:
3829          ;; (changes <local tree>)
3830          (let ((to-delete
3831                 (ewoc-enter-last xetla-revision-list-cookie
3832                                  '(message "Checking for local changes..."))))
3833            (let ((default-directory (nth 1 item)))
3834              (xetla-run-tla-async
3835               '("changes")
3836               :error `(lambda (output error status arguments)
3837                         (with-current-buffer ,(current-buffer)
3838                           (let* ((prev (ewoc-prev
3839                                         xetla-revision-list-cookie
3840                                         ,to-delete))
3841                                  (cur (ewoc-locate
3842                                        xetla-revision-list-cookie))
3843                                  (deleted (eq cur ,to-delete)))
3844                             (xetla-bookmarks-missing-parse-changes
3845                              output ,(ewoc-nth xetla-revision-list-cookie
3846                                                -1))
3847                             (ewoc--node-delete ,to-delete)
3848                             (ewoc-refresh xetla-revision-list-cookie)
3849                             (let ((loc (if deleted
3850                                            (ewoc-next
3851                                             xetla-revision-list-cookie
3852                                             prev)
3853                                          cur)))
3854                               (when loc
3855                                 (goto-char (ewoc-location loc)))))))
3856               :finished `(lambda (output error status arguments)
3857                            (with-current-buffer ,(current-buffer)
3858                              (let* ((prev (ewoc-prev
3859                                            xetla-revision-list-cookie
3860                                            ,to-delete))
3861                                     (cur (ewoc-locate
3862                                           xetla-revision-list-cookie))
3863                                     (deleted (eq cur ,to-delete)))
3864                                (ewoc--node-delete ,to-delete)
3865                                (ewoc-refresh xetla-revision-list-cookie)
3866                                (let ((loc (if deleted
3867                                               (ewoc-next
3868                                                xetla-revision-list-cookie
3869                                                prev)
3870                                             cur)))
3871                                  (when loc
3872                                    (goto-char (ewoc-location loc)))))))
3873               )))))
3874       (ewoc-set-hf xetla-revision-list-cookie ""
3875                    (concat "\n" (xetla-face-add "end."
3876                                                'xetla-separator)))))
3877   (goto-char (point-min))
3878   ;; If all processes have been run synchronously,
3879   ;; xetla-nb-active-processes is 1 now, and we should run the
3880   ;; callback.
3881   (setq xetla-nb-active-processes
3882         (- xetla-nb-active-processes 1))
3883   (when (zerop xetla-nb-active-processes)
3884     (xetla-revision-compute-merged-by))
3885   )
3886
3887 (defun xetla-revision-ewoc-map (function ewoc-list)
3888   "Invoke FUNCTION on 'entry-patch nodes of EWOC-LIST.
3889 Like (ewoc-map FUNCTION EWOC-LIST), but call FUNCTION only on
3890 'entry-patch nodes.  The argument passed to FUNCTION is a struct of
3891 type xetla-revisions."
3892   (ewoc-map (lambda (elem)
3893               (when (eq (car elem) 'entry-patch)
3894                 (funcall function (caddr elem))))
3895             ewoc-list))
3896
3897 (defvar xetla-revision-merge-by-computed nil
3898   "Non-nil when the \"merged-by\" field have been computed.")
3899
3900 (defun xetla-revision-compute-merged-by ()
3901   "Computes the field \"merged-by:\" for a revision.
3902
3903 In a revision list buffer, with revisions containing the \"merges:\"
3904 information, compute another field \"merged-by:\", containing the
3905 reverse information. If revision-A is a merge of revision-B, then,
3906 you'll get revision-A merges: revision-B revision-B merged-by:
3907 revision-A"
3908   (interactive)
3909   (xetla-revision-ewoc-map (lambda (elem)
3910                             (setf (xetla-revision-merged-by elem) nil))
3911                           xetla-revision-list-cookie)
3912   (xetla-revision-ewoc-map 'xetla-set-merged-patches
3913                           xetla-revision-list-cookie)
3914   (xetla-revision-ewoc-map (lambda (elem)
3915                             (unless (xetla-revision-merged-by elem)
3916                               (setf (xetla-revision-merged-by elem) 'nobody)))
3917                           xetla-revision-list-cookie)
3918   (set (make-local-variable 'xetla-revision-merge-by-computed) t)
3919   )
3920
3921 (eval-when-compile
3922   (defvar xetla-merged-rev))
3923
3924 (defun xetla-set-merged-patches (rev)
3925   "Set the \"merged-by\" field for other revisions according to REV.
3926
3927 Adds REV to the list of all patches merged by REV."
3928   (dolist (merged-rev (xetla-revision-merges rev))
3929     (setq xetla-merged-rev merged-rev)
3930     (xetla-revision-ewoc-map
3931      `(lambda (rev-to-fill)
3932         (when (equal (xetla-name-construct
3933                       (xetla-revision-revision rev-to-fill))
3934                      xetla-merged-rev)
3935           (setf (xetla-revision-merged-by rev-to-fill)
3936                 (cons ,(xetla-name-construct
3937                         (xetla-revision-revision rev))
3938                       (xetla-revision-merged-by rev-to-fill)))))
3939      xetla-revision-list-cookie)))
3940
3941 (defun xetla-bookmarks-missing-elem (data arg local-tree header
3942                                         &optional changes-too)
3943   "Show missing patches for DATA.
3944 ARG is currently ignored but is present for backwards compatibility.
3945 LOCAL-TREE is the local tree for which missing patches should be shown.
3946 HEADER is currently ignored but is present for backwards compatibility.
3947 If CHANGES-TOO is non-nil, show changes for DATA as well as missing patches."
3948   (let* ((default-directory local-tree)
3949          (partners (assoc 'partners (cdr data)))
3950          (location (cdr (assoc 'location (cdr data)))))
3951     (xetla-switch-to-buffer (xetla-get-buffer-create 'missing))
3952     ;; The buffer was created in a context where we didn't know the
3953     ;; path to use. Set it now.
3954     (cd local-tree)
3955     (let ((item '()))
3956       (add-to-list 'item
3957                    `(separator
3958                      ,(format "Bookmark %s (%s):"
3959                               (car data)
3960                               (xetla-name-construct location))
3961                      bookmark
3962                      ,local-tree))
3963       (when changes-too
3964         (add-to-list 'item `(changes ,local-tree)))
3965       (dolist (partner (cons (xetla-name-construct
3966                               (cdr (assoc 'location (cdr data)))) ; Me
3967                              (cdr partners))) ; and my partners
3968         (let* ((bookmark-list
3969                 (mapcar (lambda (bookmark)
3970                           (and (string= partner
3971                                         (xetla-name-construct
3972                                          (cdr (assoc 'location bookmark))))
3973                                (car bookmark)))
3974                         xetla-bookmarks-alist))
3975                (bookmark-name (progn (while (and (not (car bookmark-list))
3976                                                  (cdr bookmark-list))
3977                                        (setq bookmark-list
3978                                              (cdr bookmark-list)))
3979                                      (car bookmark-list))))
3980           (add-to-list 'item `(missing ,local-tree ,partner ,bookmark-name))))
3981       item)))
3982
3983 (defun xetla-read-field (field)
3984   "Read the contents of FIELD from a log buffer.
3985 Must be called from a log file buffer.  Returns the content of the
3986 field FIELD.  FIELD is just the name of the field, without trailing
3987 \": \""
3988   (save-excursion
3989     (goto-char (point-min))
3990     (if (re-search-forward (concat "^" field ": ") nil t)
3991         (buffer-substring-no-properties
3992          (point) (progn
3993                    (re-search-forward "^[^ \t]")
3994                    (- (point) 2))) ;; back to the end of the last line
3995       ;; of the field.
3996       "")))
3997
3998 (defun xetla-revisions-parse-list (type details merges buffer
3999                                        parent-node cookie
4000                                        &optional callback)
4001   "Parse a list of revisions.
4002 TYPE can be either 'logs, 'missing, but
4003 could be extended in the future.
4004
4005 DETAILS must be non-nil if the buffer contains date, author and
4006 summary.
4007 MERGES must be non-nil if the buffer contains list of merged patches
4008 for each revision.
4009 BUFFER is the buffer to parse.
4010
4011 PARENT-NODE is an ewoc node to which the new items will be appened.  If
4012 nil, append at the end of the ewoc list.
4013 COOKIE must be the ewoc list containing PARENT-NODE.
4014
4015 If CALLBACK is given, it should be a function (or symbol naming a
4016 function) that will be called once the revision list has been fully
4017 parsed."
4018   (with-current-buffer (ewoc-buffer cookie)
4019     (set (make-local-variable 'xetla-revision-merge-by-computed) nil))
4020   (let ((last-node parent-node)
4021         revision)
4022     (with-current-buffer (with-current-buffer buffer
4023                            (clone-buffer))
4024       (goto-char (point-min))
4025       (re-search-forward ".*/.*--.*--.*--.*" nil t)
4026       (beginning-of-line)
4027       (while (progn (> (point-max) (point)))
4028         (setq revision (buffer-substring-no-properties
4029                         (point) (point-at-eol)))
4030         (forward-line 1)
4031         (let* ((rev-struct (make-xetla-revision
4032                             :revision (xetla-name-split revision)))
4033                (elem (list 'entry-patch nil
4034                            rev-struct)))
4035           (when (or xetla-revisions-shows-summary
4036                     xetla-revisions-shows-creator
4037                     xetla-revisions-shows-date
4038                     xetla-revisions-shows-merges
4039                     xetla-revisions-shows-merged-by)
4040             (with-current-buffer (ewoc-buffer cookie)
4041               (setq xetla-nb-active-processes
4042                     (+ xetla-nb-active-processes 1))
4043               (xetla-cat-log-any
4044                (xetla-name-split revision)
4045                nil
4046                `(lambda (output error status arguments)
4047                   (with-current-buffer output
4048                     (setf (xetla-revision-date ,rev-struct)
4049                           (xetla-read-field "Standard-date"))
4050                     (setf (xetla-revision-creator ,rev-struct)
4051                           (xetla-read-field "Creator"))
4052                     (setf (xetla-revision-summary ,rev-struct)
4053                           (xetla-read-field "Summary"))
4054                     (setf (xetla-revision-merges ,rev-struct)
4055                           (remove ,revision
4056                                   (split-string (xetla-read-field
4057                                                  "New-patches")))))
4058                   (with-current-buffer ,(ewoc-buffer cookie)
4059                     (setq xetla-nb-active-processes
4060                           (- xetla-nb-active-processes 1))
4061                     (when (and ',callback
4062                                (zerop xetla-nb-active-processes))
4063                       (funcall ',callback)))
4064                   (let* ((cur (ewoc-locate xetla-revision-list-cookie)))
4065                     (ewoc-refresh ,cookie)
4066                     (when cur (goto-char (ewoc-location cur))))))))
4067           (if last-node
4068               (setq last-node
4069                     (ewoc-enter-after cookie last-node elem))
4070             (ewoc-enter-last cookie elem))))
4071       (kill-buffer (current-buffer)))
4072     (with-current-buffer (ewoc-buffer cookie)
4073       (setq xetla-nb-active-processes (- xetla-nb-active-processes 1))
4074       (when (and callback
4075                  (zerop xetla-nb-active-processes))
4076         (funcall callback))))
4077   (ewoc-refresh cookie))
4078
4079 (defun xetla-bookmarks-missing-parse-changes (buffer parent-node)
4080   "Parse the output of `xetla changes' from BUFFER and update PARENT-NODE."
4081   (with-current-buffer buffer
4082     (let ((changes
4083            (progn (goto-char (point-min))
4084                   (when (re-search-forward "^[^\\*]" nil t)
4085                     (buffer-substring-no-properties
4086                      (point-at-bol)
4087                      (point-max)))))
4088           (local-tree default-directory))
4089       (when changes
4090         (with-current-buffer (xetla-get-buffer-create 'missing)
4091           (ewoc-enter-after xetla-revision-list-cookie
4092                             parent-node
4093                             (list 'entry-change
4094                                   changes
4095                                   local-tree)))))))
4096
4097 (defun xetla-bookmarks-open-tree ()
4098   "Open a local tree in a dired buffer.
4099
4100 With a prefix arg, prompt for a local tree to use."
4101   (interactive)
4102   (let ((x-dired (if (eq xetla-switch-to-buffer-mode 'single-window)
4103                      'dired
4104                    'dired-other-window))
4105         (open (if current-prefix-arg
4106                   (xetla-bookmarks-read-local-tree nil 'ask)
4107                 (xetla-bookmarks-read-local-tree))))
4108     (funcall x-dired open)))
4109
4110 (defun xetla-bookmarks-find-file ()
4111   "Find a file starting from the local tree of the current bookmark.
4112
4113 This way, you can type C-x C-f in the bookmarks buffer to open a file
4114 of a bookmarked project.
4115
4116 With a prefix arg, prompt for the local tree to use."
4117   (interactive)
4118   (let ((default-directory (xetla-uniquify-file-name
4119                             (if current-prefix-arg
4120                                 (xetla-bookmarks-read-local-tree nil 'ask)
4121                               (xetla-bookmarks-read-local-tree)))))
4122     (call-interactively 'find-file)))
4123
4124 (defun xetla-bookmarks-tag (arg)
4125   "Run `tla tag' on the current bookmark.
4126
4127 If multiple bookmarks are marked, create a tag for each of them. If a
4128 prefix argument ARG is given, explicitly ask for the revision to tag
4129 from."
4130   (interactive "P")
4131   (unless xetla-bookmarks-cookie
4132     (error "Not in bookmarks buffer, run: `%s' and try again"
4133            (substitute-command-keys "\\[xetla-bookmarks]")))
4134   (let ((list (or xetla-bookmarks-marked-list
4135                   (list (ewoc-data (ewoc-locate xetla-bookmarks-cookie))))))
4136     (let ((tags (mapcar
4137                  (lambda (bookmark)
4138                    (let ((location
4139                           (xetla-name-construct
4140                            (if arg
4141                                (apply 'xetla-name-read "Tag from revision: "
4142                                       (append (cdr (assoc 'location bookmark))
4143                                               '(prompt)))
4144                              (cdr (assoc 'location bookmark))))))
4145                      (list location
4146                            (xetla-name-construct
4147                             (xetla-name-read (format "Tag version for '%s': "
4148                                                    location)
4149                                            'prompt 'prompt 'prompt 'prompt))
4150                            (read-string
4151                             "Name of the bookmark for this tag: "))))
4152                  list)))
4153       (dolist (tag tags)
4154         (destructuring-bind (src destination name) tag
4155           (xetla-run-tla-async
4156            (list "tag" "--setup" src destination)
4157            :finished
4158            `(lambda (output error status arguments)
4159               (xetla-bookmarks-add ,name (xetla-name-split ,destination))
4160               (xetla-bookmarks-add-partner (assoc ,name xetla-bookmarks-alist)
4161                                          ,src t))
4162            :error
4163            `(lambda (output error status arguments)
4164               (error "Fail to create a tag for %s" ,src))))))
4165     (setq xetla-bookmarks-marked-list nil)
4166     (ewoc-refresh xetla-bookmarks-cookie)))
4167
4168 (defun xetla-bookmarks-inventory ()
4169   "Run `tla inventory' on a local tree."
4170   (interactive)
4171   (let ((default-directory (if current-prefix-arg
4172                                (xetla-bookmarks-read-local-tree nil 'ask)
4173                              (xetla-bookmarks-read-local-tree))))
4174     (xetla-inventory nil
4175                      (unless (eq xetla-switch-to-buffer-mode 'single-window)
4176                        t))))
4177
4178 (defun xetla-bookmarks-changes (arg)
4179   "Run `xetla-changes' on a local tree.
4180
4181 Prefix argument, ARG, determines whether or not to use a full format or
4182 summary format and if it should prompt for the local tree to use.
4183
4184   No prefix arg -- full format, default tree.
4185   One prefix arg -- summary format, default tree.
4186   Two prefix args -- full format, prompt for tree.
4187   Three prefix args -- summary format, prompt for tree."
4188   (interactive "p")
4189   (let* ((arg (car current-prefix-arg))
4190          (default-directory (if (or (eq arg 16) (eq arg 64))
4191                                 (xetla-bookmarks-read-local-tree nil 'ask)
4192                               (xetla-bookmarks-read-local-tree))))
4193     (if (or (eq arg 4) (eq arg 64))
4194         (xetla-changes t)
4195       (xetla-changes))))
4196
4197 (defmacro xetla-make-move-fn (ewoc-direction function cookie
4198                                            &optional only-unmerged)
4199   "Create function to move up or down in `xetla-revision-list-cookie'.
4200
4201 EWOC-DIRECTION is either `ewoc-next' or `ewoc-prev'.
4202 FUNCTION is the name of the function to declare.
4203 COOKIE is the ewoc to navigate in.
4204 if ONLY-UNMERGED is non-nil, then, navigate only through revisions not
4205 merged by another revision in the same list."
4206   `(defun ,function ()
4207      (interactive)
4208      (let* ((elem (ewoc-locate ,cookie))
4209             (next (or (,ewoc-direction ,cookie elem) elem)))
4210        (while (and next
4211                    (if ,only-unmerged
4212                        (not (and (eq (car (ewoc-data next))
4213                                      'entry-patch)
4214                                  (eq (xetla-revision-merged-by
4215                                       (caddr (ewoc-data next)))
4216                                      'nobody)))
4217                      (eq (car (ewoc-data next)) 'separator))
4218                    (,ewoc-direction ,cookie next))
4219          (setq next (,ewoc-direction ,cookie next)))
4220        (while (and next
4221                    (if ,only-unmerged
4222                        (not (and (eq (car (ewoc-data next))
4223                                      'entry-patch)
4224                                  (eq (xetla-revision-merged-by
4225                                       (caddr (ewoc-data next)))
4226                                      'nobody)))
4227                      (eq (car (ewoc-data next)) 'separator)))
4228          (setq next (,(if (eq ewoc-direction 'ewoc-next)
4229                           'ewoc-prev
4230                         'ewoc-next) ,cookie next)))
4231        (when next (goto-char (ewoc-location next)))))
4232   )
4233
4234 (xetla-make-move-fn ewoc-next xetla-revision-next
4235                   xetla-revision-list-cookie)
4236
4237 (xetla-make-move-fn ewoc-prev xetla-revision-prev
4238                   xetla-revision-list-cookie)
4239
4240 (xetla-make-move-fn ewoc-next xetla-revision-next-unmerged
4241                   xetla-revision-list-cookie t)
4242
4243 (xetla-make-move-fn ewoc-prev xetla-revision-prev-unmerged
4244                   xetla-revision-list-cookie t)
4245
4246 ;;;###autoload
4247 (defun xetla-bookmarks (&optional arg)
4248   "Display XEtla bookmarks in a buffer.
4249
4250 With prefix argument ARG, reload the bookmarks file from disk."
4251   (interactive "P")
4252   (xetla-bookmarks-load-from-file arg)
4253   (if (eq xetla-switch-to-buffer-mode 'single-window)
4254       (switch-to-buffer (get-buffer-create "*xetla-bookmarks*"))
4255     (pop-to-buffer (get-buffer-create "*xetla-bookmarks*")))
4256   (let ((pos (point)))
4257     (toggle-read-only -1)
4258     (erase-buffer)
4259     (set (make-local-variable 'xetla-bookmarks-cookie)
4260          (ewoc-create 'xetla-bookmarks-printer))
4261     (set (make-local-variable 'xetla-bookmarks-marked-list) nil)
4262     (dolist (elem xetla-bookmarks-alist)
4263       (ewoc-enter-last xetla-bookmarks-cookie elem))
4264     (xetla-bookmarks-mode)
4265     (if (equal pos (point-min))
4266         (if (ewoc-nth xetla-bookmarks-cookie 0)
4267             (xetla-bookmarks-cursor-goto (ewoc-nth xetla-bookmarks-cookie 0))
4268           (message "You have no bookmarks, create some in the other buffers"))
4269       (goto-char pos))))
4270
4271
4272 (defun xetla-bookmarks-mode ()
4273   "Major mode to show XEtla bookmarks.
4274
4275 Commands:
4276 \\{xetla-bookmarks-mode-map}"
4277   (interactive)
4278   (use-local-map xetla-bookmarks-mode-map)
4279   (setq major-mode 'xetla-bookmarks-mode)
4280   (setq mode-name "xetla-bookmarks")
4281   (toggle-read-only 1)
4282   (run-hooks 'xetla-bookmarks-mode-hook))
4283
4284 (defun xetla-bookmarks-cursor-goto (ewoc-bookmark)
4285   "Move cursor to the ewoc location of EWOC-BOOKMARK."
4286   (interactive)
4287   (goto-char (ewoc-location ewoc-bookmark))
4288   (search-forward ":"))
4289
4290 (defun xetla-bookmarks-next ()
4291   "Move the cursor to the next bookmark."
4292   (interactive)
4293   (let* ((cookie xetla-bookmarks-cookie)
4294          (elem (ewoc-locate cookie))
4295          (next (or (ewoc-next cookie elem) elem)))
4296     (xetla-bookmarks-cursor-goto next)))
4297
4298 (defun xetla-bookmarks-previous ()
4299   "Move the cursor to the previous bookmark."
4300   (interactive)
4301   (let* ((cookie xetla-bookmarks-cookie)
4302          (elem (ewoc-locate cookie))
4303          (previous (or (ewoc-prev cookie elem) elem)))
4304     (xetla-bookmarks-cursor-goto previous)))
4305
4306 (defun xetla-bookmarks-move-down ()
4307   "Move the current bookmark down."
4308   (interactive)
4309   (let* ((cookie xetla-bookmarks-cookie)
4310          (elem (ewoc-locate cookie))
4311          (data (ewoc-data elem))
4312          (oldname (car data))
4313          (next (ewoc-next cookie elem)))
4314     (unless next
4315       (error "Can't go lower"))
4316     (xetla-ewoc-delete cookie elem)
4317     (goto-char (ewoc-location
4318                 (ewoc-enter-after cookie next data)))
4319     (let ((list xetla-bookmarks-alist)
4320           newlist)
4321       (while list
4322         (if (string= (caar list) oldname)
4323             (progn
4324               (setq newlist (cons (car (cdr list)) newlist))
4325               (setq newlist (cons (car      list)  newlist))
4326               (setq list (cdr list)))
4327           (setq newlist (cons (car list) newlist)))
4328         (setq list (cdr list)))
4329       (setq xetla-bookmarks-alist (reverse newlist)))
4330     (search-forward ":")))
4331
4332 (defun xetla-bookmarks-move-up ()
4333   "Move the current bookmark up."
4334   (interactive)
4335   (let* ((cookie xetla-bookmarks-cookie)
4336          (elem (ewoc-locate cookie))
4337          (data (ewoc-data elem))
4338          (oldname (car data))
4339          (previous (ewoc-prev cookie elem)))
4340     (unless previous
4341       (error "Can't go upper"))
4342     (xetla-ewoc-delete cookie elem)
4343     (goto-char (ewoc-location
4344                 (ewoc-enter-before cookie previous data)))
4345     (let ((list xetla-bookmarks-alist)
4346           newlist)
4347       (while list
4348         (if (string= (caar (cdr list)) oldname)
4349             (progn
4350               (setq newlist (cons (car (cdr list)) newlist))
4351               (setq newlist (cons (car      list)  newlist))
4352               (setq list (cdr list)))
4353           (setq newlist (cons (car list) newlist)))
4354         (setq list (cdr list)))
4355       (setq xetla-bookmarks-alist (reverse newlist)))
4356     (search-forward ":")))
4357
4358 (defun xetla-get-location-as-string ()
4359   "Construct an a/c-b-v-r string from the current bookmark."
4360   (let* ((elem (ewoc-data (ewoc-locate xetla-bookmarks-cookie)))
4361          (location (cdr (assoc 'location elem))))
4362     (xetla-name-construct location)))
4363
4364 (defun xetla-bookmarks-get (directory)
4365   "Run `tla get' on the bookmark under point, placing the tree in DIRECTORY."
4366   (interactive (list (expand-file-name
4367                       (read-directory-name
4368                        (format "Get %s in directory: " (xetla-get-location-as-string))))))
4369   (let* ((elem (ewoc-data (ewoc-locate xetla-bookmarks-cookie)))
4370          (location (cdr (assoc 'location elem))))
4371     (xetla-get directory t
4372              (xetla-name-archive  location)
4373              (xetla-name-category location)
4374              (xetla-name-branch  location)
4375              (xetla-name-version location))))
4376
4377 (defun xetla-bookmarks-goto ()
4378   "Browse the archive of the current bookmark."
4379   (interactive)
4380   (let* ((elem (ewoc-data (ewoc-locate xetla-bookmarks-cookie)))
4381          (location (cdr (assoc 'location elem)))
4382          (archive  (xetla-name-archive  location))
4383          (category (xetla-name-category location))
4384          (branch   (xetla-name-branch  location))
4385          (version  (xetla-name-version location)))
4386     (cond (version  (xetla-revisions archive category branch version))
4387           (branch   (xetla-versions  archive category branch))
4388           (category (xetla-branches  archive category))
4389           (archive  (xetla-categories archive))
4390           (t (error "Nothing specified for this bookmark")))))
4391
4392 (xetla-make-bymouse-function xetla-bookmarks-goto)
4393
4394 (defun xetla-bookmarks-star-merge (arg)
4395   "Star-merge the current bookmark to a local tree.
4396 Accepts prefix argument ARG for future extension."
4397   (interactive "P")
4398   (let* ((elem (ewoc-data (ewoc-locate xetla-bookmarks-cookie)))
4399          (location (cdr (assoc 'location elem)))
4400          (local-tree (read-directory-name "Star-merge into: ")))
4401     (xetla-star-merge (xetla-name-construct location)
4402                     local-tree)))
4403
4404 (defun xetla-bookmarks-replay (arg)
4405   "Replay the current bookmark to some local tree.
4406 Accepts prefix argument ARG for future extension."
4407   (interactive "P")
4408   (let* ((elem (ewoc-data (ewoc-locate xetla-bookmarks-cookie)))
4409          (location (xetla-name-construct (cdr (assoc 'location elem))))
4410          (local-tree (read-directory-name
4411                       (format "Replay %s into: " location))))
4412     (xetla-replay location local-tree)))
4413
4414 (defun xetla-bookmarks-update (arg)
4415   "Update the local tree of the current bookmark.
4416 Accepts prefix argument ARG for future extension."
4417   (interactive "P")
4418   (let* ((buf (current-buffer))
4419          (work-list (or xetla-bookmarks-marked-list
4420                         (list (ewoc-data (ewoc-locate xetla-bookmarks-cookie)))))
4421          (update-trees
4422           (mapcar (lambda (bookmark)
4423                     (let ((local-trees (cdr (assoc 'local-tree bookmark))))
4424                       (xetla-uniquify-file-name
4425                        (cond ((null local-trees)
4426                               (read-directory-name
4427                                (format "Local tree for '%s'?: "
4428                                        (car bookmark)) nil nil t))
4429                              ((not (null (cdr local-trees)))
4430                               (completing-read
4431                                (format "Local tree for '%s'?: "
4432                                        (car bookmark))
4433                                local-trees nil t))
4434                              (t (car local-trees))))))
4435                   work-list)))
4436     (mapc 'xetla-update update-trees)
4437     (with-current-buffer buf
4438       (setq xetla-bookmarks-marked-list '())
4439       (ewoc-refresh xetla-bookmarks-cookie))))
4440
4441 (defun xetla-bookmarks-add-elem (name info)
4442   "Add the association (NAME . INFO) to the list of bookmarks, and save it.
4443 This is an internal function."
4444   (when (assoc name xetla-bookmarks-alist)
4445     (error (concat "Already got a bookmark " name)))
4446   (let ((elem (cons name info)))
4447     (add-to-list 'xetla-bookmarks-alist elem t)
4448     (xetla-bookmarks-save-to-file)
4449     (ewoc-enter-last xetla-bookmarks-cookie elem)
4450     ))
4451
4452 (defun xetla-bookmarks-add (name revision-spec)
4453   "Add a bookmark named NAME for REVISION-SPEC."
4454   (interactive (let* ((fq (xetla-name-read "Version: "
4455                                           'prompt 'prompt 'prompt 'prompt))
4456                       (n  (read-string (format "Name of the bookmark for `%s': "
4457                                                (xetla-name-construct fq)))))
4458                  (list n fq)))
4459   (unless (get-buffer "*xetla-bookmarks*")
4460     (xetla-bookmarks))
4461   (with-current-buffer "*xetla-bookmarks*"
4462     (let* ((info (list (cons 'location
4463                              revision-spec)
4464                        (cons 'timestamp (current-time-string)))))
4465       (xetla-bookmarks-add-elem name info))))
4466
4467 (defun xetla-bookmarks-mark ()
4468   "Mark the bookmark at point."
4469   (interactive)
4470   (let ((pos (point)))
4471     (add-to-list 'xetla-bookmarks-marked-list
4472                  (ewoc-data (ewoc-locate xetla-bookmarks-cookie)))
4473     (ewoc-refresh xetla-bookmarks-cookie)
4474     (goto-char pos))
4475   (xetla-bookmarks-next))
4476
4477 (defun xetla-bookmarks-unmark ()
4478   "Unmark the bookmark at point."
4479   (interactive)
4480   (let ((pos (point)))
4481     (setq xetla-bookmarks-marked-list
4482           (delq (ewoc-data (ewoc-locate xetla-bookmarks-cookie))
4483                 xetla-bookmarks-marked-list))
4484     (ewoc-refresh xetla-bookmarks-cookie)
4485     (goto-char pos))
4486   (xetla-bookmarks-next))
4487
4488 (defun xetla-bookmarks-unmark-all ()
4489   "Unmark all bookmarks in current buffer."
4490   (interactive)
4491   (let ((pos (point)))
4492     (setq xetla-bookmarks-marked-list nil)
4493     (ewoc-refresh xetla-bookmarks-cookie)
4494     (goto-char pos)))
4495
4496 (defun xetla-bookmarks-marked-are-partners ()
4497   "Make marked bookmarks mutual partners."
4498   (interactive)
4499   (let ((list-arch (mapcar
4500                     #'(lambda (x)
4501                         (format "%s"
4502                                 (xetla-name-construct
4503                                  (cdr (assoc 'location x)))))
4504                     xetla-bookmarks-marked-list)))
4505     (dolist (book xetla-bookmarks-marked-list)
4506       (let ((myloc (xetla-name-construct
4507                     (cdr (assoc 'location book)))))
4508         (message myloc)
4509         (dolist (arch list-arch)
4510           (unless (string= myloc arch)
4511             (xetla-bookmarks-add-partner book arch t))))))
4512   (xetla-bookmarks-save-to-file)
4513   (save-window-excursion
4514     (xetla-bookmarks)))
4515
4516 (defun xetla-bookmarks-cleanup-local-trees ()
4517   "Remove LOCAL-TREE field from bookmarks if they don't exist."
4518   (interactive)
4519   (dolist (book xetla-bookmarks-alist)
4520     (let ()
4521       (dolist (local-tree (cdr (assoc 'local-tree book)))
4522         (when (and (not (file-exists-p local-tree))
4523                    (or xetla-bookmarks-cleanup-dont-prompt
4524                        (y-or-n-p
4525                         (format
4526                          "Remove tree %s from bookmarks %s? "
4527                          local-tree
4528                          (car book)))))
4529           (xetla-bookmarks-delete-tree book local-tree t)))))
4530   (xetla-bookmarks-save-to-file)
4531   (save-window-excursion
4532     (xetla-bookmarks)))
4533
4534 (defun xetla-bookmarks-delete (elem &optional force)
4535   "Delete the bookmark entry ELEM.
4536 If FORCE is non-nil, don't ask for confirmation."
4537   (interactive (list (ewoc-locate xetla-bookmarks-cookie)))
4538   (let* ((data (ewoc-data elem)))
4539     (when (or force
4540               (yes-or-no-p (format "Delete bookmark \"%s\"? " (car data))))
4541       (xetla-ewoc-delete xetla-bookmarks-cookie elem)
4542       (let ((list xetla-bookmarks-alist)
4543             newlist)
4544         (while list
4545           (unless (string= (caar list) (car data))
4546             (setq newlist (cons (car list) newlist)))
4547           (setq list (cdr list)))
4548         (setq xetla-bookmarks-alist (reverse newlist)))
4549       ;; TODO could be optimized
4550       (xetla-bookmarks-save-to-file)
4551       )))
4552
4553 (defun xetla-bookmarks-find-bookmark (location)
4554   "Find the bookmark whose location is LOCATION (a string)."
4555   (let ((list xetla-bookmarks-alist)
4556         result)
4557     (while list
4558       (when (string= (xetla-name-construct
4559                       (cdr (assoc 'location (cdar list))))
4560                      location)
4561         (setq result (car list))
4562         (setq list nil))
4563       (setq list (cdr list)))
4564     result))
4565
4566 (defun xetla-bookmarks-get-field (version field default)
4567   "Return VERSION'S value of FIELD, or DEFAULT if there is no value."
4568   (xetla-bookmarks-load-from-file)
4569   (block dolist
4570     (dolist (elem xetla-bookmarks-alist)
4571       (let ((location (cdr (assoc 'location elem))))
4572         (when (and (string= (xetla-name-archive location)
4573                             (xetla-name-archive version))
4574                    (string= (xetla-name-category location)
4575                             (xetla-name-category version))
4576                    (string= (xetla-name-branch location)
4577                             (xetla-name-branch version))
4578                    (string= (xetla-name-version location)
4579                             (xetla-name-version version)))
4580           (return-from dolist (or (cadr (assoc field (cdr elem))) default)))))
4581     default))
4582
4583 (defmacro xetla-bookmarks-make-add-fn (name field message-already message-add)
4584   "Define a function called NAME for adding FIELD to a bookmark entry.
4585 This function will display MESSAGE-ALREADY if the user tries to add a field
4586 twice, and will display MESSAGE-ADD when a new field is successfully added."
4587   `(defun ,name (bookmark value &optional dont-save)
4588      "Adds the directory VALUE to the list of local trees of bookmark
4589 BOOKMARK."
4590      (let ((local-trees (assoc ,field (cdr bookmark))))
4591        (if local-trees
4592            (if (member value (cdr local-trees))
4593                (message ,message-already)
4594              (progn
4595                (message ,message-add)
4596                (setcdr local-trees (cons value
4597                                          (cdr local-trees)))))
4598          (progn
4599            (message ,message-add)
4600            (setcdr bookmark (cons (list ,field value)
4601                                   (cdr bookmark)))))
4602        (unless dont-save
4603          (xetla-bookmarks-save-to-file)
4604          (save-window-excursion
4605            (xetla-bookmarks)))))
4606   )
4607
4608 (xetla-bookmarks-make-add-fn xetla-bookmarks-add-tree
4609                            'local-tree
4610                            "Local tree already in the list"
4611                            "Local tree added to your bookmarks")
4612
4613 (xetla-bookmarks-make-add-fn xetla-bookmarks-add-partner
4614                            'partners
4615                            "Partner already in the list"
4616                            "Partner added to your bookmarks")
4617
4618 (xetla-bookmarks-make-add-fn xetla-bookmarks-add-group
4619                            'groups
4620                            "Group already in the list"
4621                            "Group added to your bookmarks")
4622
4623 (xetla-bookmarks-make-add-fn xetla-bookmarks-add-nickname
4624                            'nickname
4625                            "Nickname already in the list"
4626                            "Nickname added to your bookmark")
4627
4628 (defmacro xetla-bookmarks-make-delete-fn (name field)
4629   "Define a function called NAME for removing FIELD from bookmark entries."
4630   `(defun ,name (bookmark value &optional dont-save)
4631      "Deletes the directory VALUE to the list of local trees of bookmark
4632 BOOKMARK."
4633      (let ((local-trees (assoc ,field (cdr bookmark))))
4634        (when local-trees
4635          (let ((rem-list (delete value (cdr (assoc ,field
4636                                                    bookmark)))))
4637            (if rem-list
4638                (setcdr local-trees rem-list)
4639              ;; Remove the whole ('field ...)
4640              (setcdr bookmark (delq local-trees (cdr bookmark))))))
4641        (unless dont-save
4642          (xetla-bookmarks-save-to-file)
4643          (save-window-excursion
4644            (xetla-bookmarks)))))
4645   )
4646
4647 (xetla-bookmarks-make-delete-fn xetla-bookmarks-delete-tree
4648                               'local-tree)
4649
4650 (xetla-bookmarks-make-delete-fn xetla-bookmarks-delete-partner
4651                               'partners)
4652
4653 (xetla-bookmarks-make-delete-fn xetla-bookmarks-delete-group
4654                               'groups)
4655
4656 (xetla-bookmarks-make-delete-fn xetla-bookmarks-delete-nickname
4657                               'nickname)
4658
4659 (defun xetla-bookmarks-add-partner-interactive ()
4660   "Add a partner to the current or marked bookmarks."
4661   (interactive)
4662   (let ((bookmarks (or xetla-bookmarks-marked-list
4663                        (list (ewoc-data (ewoc-locate
4664                                          xetla-bookmarks-cookie)))))
4665         (partner (xetla-name-construct
4666                   (xetla-name-read "Version: "
4667                                   'prompt 'prompt 'prompt 'prompt))))
4668     (dolist (bookmark bookmarks)
4669       (xetla-bookmarks-add-partner bookmark partner t))
4670     (xetla-bookmarks-save-to-file)
4671     (save-window-excursion
4672       (xetla-bookmarks))))
4673
4674 (defun xetla-bookmarks-add-partners-from-file ()
4675   "Add a partner to the current or marked bookmarks."
4676   (interactive)
4677   (let ((bookmarks (or xetla-bookmarks-marked-list
4678                        (list (ewoc-data (ewoc-locate
4679                                          xetla-bookmarks-cookie))))))
4680     (dolist (bookmark bookmarks)
4681       (let ((partners (xetla-partner-list
4682                        (xetla-bookmarks-read-local-tree bookmark))))
4683         (dolist (partner partners)
4684           (xetla-bookmarks-add-partner bookmark partner t))))
4685     (xetla-bookmarks-save-to-file)
4686     (save-window-excursion
4687       (xetla-bookmarks))))
4688
4689 (defun xetla-bookmarks-write-partners-to-file ()
4690   "Add the partners recorded in the bookmarks to the partner file."
4691   (interactive)
4692   (let ((bookmarks (or xetla-bookmarks-marked-list
4693                        (list (ewoc-data (ewoc-locate
4694                                          xetla-bookmarks-cookie))))))
4695     (dolist (bookmark bookmarks)
4696       (let* ((local-tree (xetla-bookmarks-read-local-tree bookmark))
4697              (partners (xetla-partner-list local-tree)))
4698         (with-current-buffer
4699             (xetla-partner-find-partner-file local-tree)
4700           (dolist (partner (cdr (assoc 'partners (cdr bookmark))))
4701             (unless (member partner partners)
4702               (insert partner "\n")))
4703           (and (buffer-modified-p)
4704                (progn (switch-to-buffer (current-buffer))
4705                       (y-or-n-p (format "Save file %s? "
4706                                         (buffer-file-name))))
4707                (save-buffer)))))))
4708
4709
4710 (defun xetla-bookmarks-delete-partner-interactive ()
4711   "Delete a partner from the current or marked bookmarks."
4712   (interactive)
4713   (let* ((bookmarks (or xetla-bookmarks-marked-list
4714                         (list (ewoc-data (ewoc-locate
4715                                           xetla-bookmarks-cookie)))))
4716          (choices (apply 'append
4717                          (mapcar #'(lambda (x)
4718                                      (cdr (assoc 'partners
4719                                                  (cdr x))))
4720                                  bookmarks)))
4721          (choices-alist (mapcar #'(lambda (x) (list x)) choices))
4722          (partner (completing-read "Partner to remove: " choices-alist)))
4723     (dolist (bookmark bookmarks)
4724       (xetla-bookmarks-delete-partner bookmark partner t))
4725     (xetla-bookmarks-save-to-file)
4726     (save-window-excursion
4727       (xetla-bookmarks))))
4728
4729 (defun xetla-bookmarks-add-tree-interactive ()
4730   "Add a local tree to the current or marked bookmarks."
4731   (interactive)
4732   (let ((bookmarks (or xetla-bookmarks-marked-list
4733                        (list (ewoc-data (ewoc-locate
4734                                          xetla-bookmarks-cookie)))))
4735         (local-tree (read-directory-name "Local tree to add: ")))
4736     (unless (file-exists-p (concat (file-name-as-directory local-tree) "{arch}"))
4737       (error (concat local-tree " is not an arch local tree.")))
4738     (dolist (bookmark bookmarks)
4739       (xetla-bookmarks-add-tree bookmark local-tree t))
4740     (xetla-bookmarks-save-to-file)
4741     (save-window-excursion
4742       (xetla-bookmarks))))
4743
4744 (defun xetla-bookmarks-delete-tree-interactive ()
4745   "Add a local tree to the current or marked bookmarks."
4746   (interactive)
4747   (let* ((bookmarks (or xetla-bookmarks-marked-list
4748                         (list (ewoc-data (ewoc-locate
4749                                           xetla-bookmarks-cookie)))))
4750          (choices (apply 'append
4751                          (mapcar #'(lambda (x)
4752                                      (cdr (assoc 'local-tree
4753                                                  (cdr x))))
4754                                  bookmarks)))
4755          (choices-alist (mapcar #'(lambda (x) (list x)) choices))
4756          (local-tree (completing-read "Local tree to remove: " choices-alist)))
4757     (dolist (bookmark bookmarks)
4758       (xetla-bookmarks-delete-tree bookmark local-tree t))
4759     (xetla-bookmarks-save-to-file)
4760     (save-window-excursion
4761       (xetla-bookmarks))))
4762
4763 (defun xetla-bookmarks-list-groups ()
4764   "Return the list of groups currently used by bookmarks."
4765   (let ((list (apply 'append
4766                      (mapcar #'(lambda (x)
4767                                  (cdr (assoc 'groups
4768                                              (cdr x))))
4769                              xetla-bookmarks-alist)))
4770         result)
4771     ;; Make elements unique
4772     (dolist (elem list)
4773       (add-to-list 'result elem))
4774     result))
4775
4776 (defun xetla-bookmarks-add-group-interactive ()
4777   "Add a group entry in the current or marked bookmarks."
4778   (interactive)
4779   (let* ((bookmarks (or xetla-bookmarks-marked-list
4780                         (list (ewoc-data (ewoc-locate
4781                                           xetla-bookmarks-cookie)))))
4782          (group (completing-read "Group of bookmarks: "
4783                                  (mapcar #'(lambda (x) (list x))
4784                                          (xetla-bookmarks-list-groups)))))
4785     (dolist (bookmark bookmarks)
4786       (xetla-bookmarks-add-group bookmark group t)))
4787   (xetla-bookmarks-save-to-file)
4788   (save-window-excursion
4789     (xetla-bookmarks)))
4790
4791
4792 (defun xetla-bookmarks-delete-group-interactive ()
4793   "Delete a group of bookmark entry from the current or marked bookmarks."
4794   (interactive)
4795   (let* ((bookmarks (or xetla-bookmarks-marked-list
4796                         (list (ewoc-data (ewoc-locate
4797                                           xetla-bookmarks-cookie)))))
4798          (choices (apply 'append
4799                          (mapcar #'(lambda (x)
4800                                      (cdr (assoc 'groups
4801                                                  (cdr x))))
4802                                  bookmarks)))
4803          (choices-alist (mapcar #'(lambda (x) (list x)) choices))
4804          (group (completing-read "Group to remove: " choices-alist)))
4805     (dolist (bookmark bookmarks)
4806       (xetla-bookmarks-delete-group bookmark group t)))
4807   (xetla-bookmarks-save-to-file)
4808   (save-window-excursion
4809     (xetla-bookmarks)))
4810
4811 (defun xetla-bookmarks-select-by-group (group)
4812   "Select all bookmarks in GROUP."
4813   (interactive (list (completing-read "Group to select: "
4814                                       (mapcar #'(lambda (x) (list x))
4815                                               (xetla-bookmarks-list-groups)))))
4816   (dolist (bookmark xetla-bookmarks-alist)
4817     (when (member group (cdr (assoc 'groups bookmark)))
4818       (add-to-list 'xetla-bookmarks-marked-list bookmark))
4819     )
4820   (ewoc-refresh xetla-bookmarks-cookie))
4821
4822 (defun xetla-bookmarks-add-nickname-interactive ()
4823   "Add a nickname to the current bookmark."
4824   (interactive)
4825   (let* ((bookmark (ewoc-data (ewoc-locate
4826                                xetla-bookmarks-cookie)))
4827          (prompt (format "Nickname for %s: " (xetla-name-construct
4828                                               (cdr (assoc 'location bookmark))))))
4829     (xetla-bookmarks-add-nickname bookmark (read-string prompt) t)
4830     (xetla-bookmarks-save-to-file)
4831     (save-window-excursion
4832       (xetla-bookmarks))))
4833
4834 (defun xetla-bookmarks-delete-nickname-interactive ()
4835   "Delete the nickname of the current bookmark."
4836   (interactive)
4837   (let* ((bookmark (ewoc-data (ewoc-locate
4838                                xetla-bookmarks-cookie)))
4839          (nickname (cadr (assoc 'nickname bookmark))))
4840     (xetla-bookmarks-delete-nickname bookmark nickname t)
4841     (xetla-bookmarks-save-to-file)
4842     (save-window-excursion
4843       (xetla-bookmarks))))
4844
4845 (defvar xetla-buffer-bookmark nil
4846   "The bookmark manipulated in the current buffer.")
4847
4848 (defun xetla-bookmarks-edit ()
4849   "Edit the bookmark at point."
4850   (interactive)
4851   (let* ((elem (ewoc-locate xetla-bookmarks-cookie))
4852          (data (ewoc-data elem)))
4853     (pop-to-buffer (concat "*xetla bookmark " (car data) "*"))
4854     (erase-buffer)
4855     (emacs-lisp-mode)
4856     (make-local-variable 'xetla-buffer-bookmark)
4857     (setq xetla-buffer-bookmark elem)
4858     (insert ";; Edit the current bookmark. C-c C-c to finish\n\n")
4859     (pp data (current-buffer))
4860     (goto-char (point-min)) (forward-line 2) (forward-char 2)
4861     (local-set-key [(control ?c) (control ?c)]
4862                    #'(lambda () (interactive)
4863                        (goto-char (point-min))
4864                        (let* ((newval (read (current-buffer)))
4865                               (elem xetla-buffer-bookmark)
4866                               (oldname (car (ewoc-data elem))))
4867                          (kill-buffer (current-buffer))
4868                          (pop-to-buffer "*xetla-bookmarks*")
4869                          (setcar (ewoc-data elem) (car newval))
4870                          (setcdr (ewoc-data elem) (cdr newval))
4871                          (let ((list xetla-bookmarks-alist)
4872                                newlist)
4873                            (while list
4874                              (if (string= (caar list) oldname)
4875                                  (setq newlist (cons newval newlist))
4876                                (setq newlist (cons (car list) newlist)))
4877                              (setq list (cdr list)))
4878                            (setq xetla-bookmarks-alist (reverse newlist)))
4879                          (xetla-bookmarks-save-to-file)
4880                          (save-excursion (xetla-bookmarks))
4881                          )))))
4882
4883 (defun xetla-bookmarks-get-partner-versions (version)
4884   "Return version lists of partners in bookmarks for VERSION.
4885 Each version in the returned list has a list form.
4886 If no partner, return nil.
4887 VERSION is a fully qualified version string or a list."
4888   (xetla-bookmarks-load-from-file)
4889   (when (consp version)
4890     (setq version (xetla-name-mask version t
4891                                   t t t t)))
4892   (let* ((bookmark (xetla-bookmarks-find-bookmark version))
4893          (groups (cdr (assoc 'groups bookmark)))
4894          (partners (delete nil (mapcar
4895                                 (lambda (b)
4896                                   (when (intersection groups (cdr (assoc 'groups b)) :test 'string=)
4897                                     (cdr (assoc 'location b))
4898                                     ))
4899                                 xetla-bookmarks-alist))))
4900     partners))
4901
4902 ;;
4903 ;; Archives
4904 ;;
4905 ;;;###autoload
4906 (defun xetla-archives ()
4907   "Start the archive browser."
4908   (interactive)
4909   (xetla-archive-tree-build-archives)
4910   (xetla-switch-to-buffer "*xetla-archives*")
4911   (let ((a-list xetla-archive-tree)
4912         (my-default-archive (xetla-my-default-archive))
4913         defaultp
4914         archive-name
4915         archive-location
4916         p)
4917     (toggle-read-only -1)
4918     (erase-buffer)
4919     (while a-list
4920       (setq archive-name (caar a-list)
4921             archive-location (cadar a-list)
4922             a-list (cdr a-list)
4923             defaultp (string= archive-name my-default-archive))
4924       (if defaultp (setq p (point)))
4925       (xetla-archives-insert-item archive-name archive-location defaultp))
4926     (if (> (point) (point-min))
4927         (delete-backward-char 1))
4928     (when p (goto-char p))
4929     (xetla-archive-list-mode)))
4930
4931 (defun xetla-archives-insert-item (archive location defaultp)
4932   "Add an entry for ARCHIVE at LOCATION to the archive list.
4933 If DEFAULTP is non-nil, this item will be rendered as the default archive."
4934   (let ((start-pos (point))
4935         extent)
4936     (insert (if defaultp xetla-mark " ")
4937             "  "
4938             (xetla-face-add-with-condition
4939              defaultp
4940              archive 'xetla-marked 'xetla-archive-name))
4941     (newline)
4942     (insert "      " location)
4943     (newline)
4944     (setq extent (make-extent start-pos (point)))
4945     (set-extent-property extent 'category 'xetla-default-button)
4946     (set-extent-property extent 'keymap xetla-archive-archive-map)
4947     (set-extent-property extent 'xetla-archive-info archive)))
4948
4949 (defun xetla-archives-goto-archive-by-name (name)
4950   "Jump to the archive named NAME."
4951   (unless (string= (buffer-name) "*xetla-archives*")
4952     (error "`xetla-archives-goto-archive-by-name' can only be called in *xetla-archives* buffer"))
4953   (goto-char (point-min))
4954   (search-forward name)
4955   (beginning-of-line))
4956
4957 (defun xetla-get-archive-info (&optional property)
4958   "Get some PROPERTY of the archive at point in an archive list buffer."
4959   (unless property
4960     (setq property 'xetla-archive-info))
4961   (let ((extent (car (extents-at (point)))))
4962     (when extent
4963       (extent-property extent property))))
4964
4965 (defun xetla-my-default-archive (&optional new-default)
4966   "Set or get the default archive.
4967 When called with a prefix argument NEW-DEFAULT: Ask the user for the new
4968 default archive.
4969 If NEW-DEFAULT IS A STRING: Set the default archive to this string.
4970 When called with no argument: return the name of the default argument.
4971 When called interactively, with no argument: Show the name of the default archive."
4972   (interactive "P")
4973   (when (or (numberp new-default) (and (listp new-default) (> (length new-default) 0)))
4974     (setq new-default (car (xetla-name-read nil 'prompt))))
4975   (cond ((stringp new-default)
4976          (message "Setting arch default archive to: %s" new-default)
4977          (xetla-run-tla-sync (list "my-default-archive" new-default)
4978                             :finished 'xetla-null-handler))
4979         (t
4980          (xetla-run-tla-sync '("my-default-archive")
4981                             :finished
4982                             `(lambda (output error status arguments)
4983                                (let ((result (xetla-buffer-content output)))
4984                                  (when ,(interactive-p)
4985                                    (message "Default arch archive: %s"
4986                                             result))
4987                                  result))
4988                             :error
4989                             `(lambda (output error status arguments)
4990                                (if (eq status 1)
4991                                    (if ,(interactive-p)
4992                                        (message "default archive not set")
4993                                      "")
4994                                  (xetla-default-error-function
4995                                   output error status arguments)))))))
4996
4997 (defun xetla-whereis-archive (&optional archive)
4998   "Call xetla whereis-archive on ARCHIVE."
4999   (interactive "P")
5000   (let (location)
5001     (unless archive
5002       (setq archive (xetla-name-mask (xetla-name-read "Archive: " 'prompt)
5003                                     t
5004                                     :archive)))
5005     (setq location
5006           (xetla-run-tla-sync (list "whereis-archive" archive)
5007                              :finished
5008                              (lambda (output error status arguments)
5009                                (xetla-buffer-content output))))
5010     (when (interactive-p)
5011       (message "archive location for %s: %s" archive location))
5012     location))
5013
5014 (defun xetla-read-location (prompt)
5015   "Read the location for an archive operation, prompting with PROMPT.
5016 The following forms are supported:
5017 * local path: e.g.: ~/archive2004
5018 * ftp path: e.g.: ftp://user:passwd@host.name.com/remote-path
5019 * sftp path: e.g.: sftp://user:passwd@host.name.com/remote-path
5020 * HTTP/WebDAV path: e.g.: http://user:passwd@host.name.com/remote-path"
5021   (read-string prompt (ffap-url-at-point)))
5022
5023 (defun xetla-register-archive ()
5024   "Call `xetla-register-archive-internal' interactively and `xetla-archives' on success."
5025   (interactive)
5026   (let* ((result (call-interactively 'xetla-register-archive-internal))
5027          (archive-registered (nth 0 result))
5028          (archive (nth 1 result))
5029          (xetla-response (nth 3 result)))
5030     (when archive-registered
5031       (xetla-archives)
5032       (xetla-archives-goto-archive-by-name
5033        (progn
5034          (message xetla-response) ; inform the user about the response from xetla
5035          (if (string-match ".+: \\(.+\\)" xetla-response)
5036              (match-string 1 xetla-response)
5037            archive)))
5038       (xetla-flash-line))))
5039
5040 (defun xetla-register-archive-internal (location &optional archive)
5041   "Register arch archive.
5042 LOCATION should be either a local directory or a remote path.
5043 When ffap is available the url at point is suggested for LOCATION.
5044 ARCHIVE is the name is archive.  If ARCHIVE is not given or an empty string,
5045 the default name is used.
5046 The return value is a list.
5047 - The first element shows whether the archive is registered or not; t means that
5048   it is registered, already means that the archive was already
5049   registered, and nil means that it is not registered.
5050 - The second element shows archive name.
5051 - The third element shows archive location.
5052 - The fourth element is the command output string."
5053   (interactive (list (xetla-read-location "Location: ")
5054                      (read-string "Archive (empty for default): ")))
5055   (if (and archive (eq 0 (length archive)))
5056       (setq archive nil))
5057   (let ((archive-registered nil)
5058         (xetla-response nil))
5059     (xetla-run-tla-sync (list "register-archive" archive location)
5060                        :finished
5061                        (lambda (output error status arguments)
5062                          (setq xetla-response (xetla-get-process-output))
5063                          (setq archive-registered t)
5064                          (message "Registered archive %s (=> %s)" archive location))
5065                        :error
5066                        (lambda (output error status arguments)
5067                          (setq xetla-response (xetla-get-error-output))
5068                          (when (eq status 2) ;; already registered
5069                            (setq archive-registered 'already))))
5070     (list archive-registered archive location xetla-response)))
5071
5072 (defun xetla-unregister-archive (archive ask-for-confirmation)
5073   "Delete the registration of ARCHIVE.
5074 When ASK-FOR-CONFIRMATION is non nil, ask the user for confirmation."
5075   (unless (xetla-archive-tree-get-archive archive)
5076     (xetla-archive-tree-build-archives))
5077   (let ((location (cadr (xetla-archive-tree-get-archive archive))))
5078     (when (or (not ask-for-confirmation)
5079               (yes-or-no-p (format "Delete the registration of %s(=> %s)? " archive location)))
5080       (xetla-run-tla-sync
5081        (list "register-archive" "--delete" archive)
5082        :finished
5083        (lambda (output error status arguments)
5084          (message "Deleted the registration of %s (=> %s)" archive location))))))
5085
5086 (defun xetla-edit-archive-location (archive)
5087   "Edit the location of ARCHIVE."
5088   (let* ((old-location (xetla-whereis-archive archive))
5089          (new-location (read-string (format "New location for %s: " archive) old-location)))
5090     (unless (string= old-location new-location)
5091       (xetla-unregister-archive archive nil)
5092       (xetla-register-archive-internal new-location archive))))
5093
5094 ;;;###autoload
5095 (defun xetla-make-archive ()
5096   "Call `xetla-make-archive-internal' interactively  then call `xetla-archives'."
5097   (interactive)
5098   (call-interactively 'xetla-make-archive-internal)
5099   (xetla-archives))
5100
5101 (defun xetla-make-archive-internal (name location &optional signed listing)
5102   "Create a new arch archive.
5103 NAME is the global name for the archive.  It must be an
5104 email address with a fully qualified domain name, optionally
5105 followed by \"--\" and a string of letters, digits, periods
5106 and dashes.
5107 LOCATION specifies the path, where the archive should be created.
5108
5109 Examples for name are:
5110 foo.bar@flups.com--public
5111 foo.bar@flups.com--public-2004
5112
5113 If SIGNED is non-nil, the archive will be created with -signed.
5114 If LISTING is non-nil, the archive will be created with -listing
5115  (Usefull for http mirrors)."
5116   (interactive
5117    (list (read-string "Archive name: ")
5118          (let ((path-ok nil)
5119                location)
5120            (while (not path-ok)
5121              (setq location (xetla-read-location "Location: "))
5122              (setq path-ok t)
5123              (when (eq 'local (xetla-location-type location))
5124                (setq location (expand-file-name location))
5125                (when (file-directory-p location)
5126                  (message "directory already exists: %s" location)
5127                  (setq path-ok nil)
5128                  (sit-for 1))
5129                (when (not (file-directory-p
5130                            (file-name-directory location)))
5131                  (message "parent directory doesn't exists for %s"
5132                           location)
5133                  (setq path-ok nil)
5134                  (sit-for 1))))
5135            location)
5136          (y-or-n-p "Sign the archive? ")
5137          (y-or-n-p "Create .listing files? ")))
5138   (xetla-run-tla-sync (list "make-archive"
5139                            (when listing "--listing")
5140                            (when signed "--signed")
5141                            name location)
5142                      :error
5143                      (lambda (output error status arguments)
5144                        (xetla-show-error-buffer error)
5145                        (xetla-show-last-process-buffer)
5146                        (error (format "xetla failed: exits-status=%s"
5147                                       status)))))
5148
5149 (defun xetla-mirror-archive (&optional archive location mirror signed
5150                                      listing)
5151   "Create a mirror for ARCHIVE, at location LOCATION, named MIRROR.
5152 If SIGNED is non-nil, the archive will be signed.
5153 If LISTING is non-nil, .listing files will be created (useful for HTTP
5154 mirrors)."
5155   (interactive)
5156   (let* ((archive (or archive (car (xetla-name-read "Archive to mirror: " 'prompt))))
5157          (location (or location (xetla-read-location
5158                                  (format "Location of the mirror for %s: " archive))))
5159          ;;todo: take a look ath the mirror-list, when suggesting a mirror name
5160          ;;(mirror-list (xetla-get-mirrors-for-archive archive))
5161          (mirror (or mirror (read-string "Name of the mirror: "
5162                                          (concat archive
5163                                                  "-MIRROR"))))
5164          (signed (or signed (y-or-n-p "Sign mirror? ")))
5165          (listing (or listing (y-or-n-p "Create .listing files? "))))
5166     (xetla-run-tla-sync (list "make-archive"
5167                              (when listing "--listing")
5168                              (when signed "--signed")
5169                              "--mirror"
5170                              archive mirror location))))
5171
5172 (defun xetla-mirror-from-archive (&optional from-archive location)
5173   "Create a mirror-from archive for FROM-ARCHIVE, at location LOCATION.
5174 The archive name FROM-ARCHIVE must end with \"-SOURCE\"."
5175   (interactive)
5176   (let* ((from-archive (or from-archive
5177                            (car (xetla-name-read "Mirror from archive: " 'prompt))))
5178          (location (or location (read-string
5179                                  (format "Location of the mirror for %s : " from-archive)))))
5180     (unless (eq (xetla-archive-type from-archive) 'source)
5181       (error "%s is not SOURCE archive" from-archive))
5182     (xetla-run-tla-sync (list "make-archive"
5183                              "--mirror-from"
5184                              from-archive location))))
5185
5186 (defun xetla-get-mirrors-for-archive (archive)
5187   "Get a list of all mirrors for the given ARCHIVE."
5188   (xetla-archive-tree-build-archives)
5189   (delete nil (mapcar '(lambda (elem)
5190                          (let ((a-name (car elem)))
5191                            (when (and (eq (xetla-archive-type a-name) 'mirror)
5192                                       (string= archive
5193                                                (substring a-name 0 (length archive))))
5194                              a-name)))
5195                       xetla-archive-tree)))
5196
5197 ;; in xetla-browse use: (xetla-name-archive (xetla-widget-node-get-name))
5198 ;; to get the name of an archive.
5199 ;; in xetla-archives: use (xetla-get-archive-info)
5200
5201 ;; (xetla-get-mirrors-for-archive (xetla-get-archive-info))
5202 ;; (xetla-get-mirrors-for-archive "xsteve@nit.at-public")
5203
5204 (defun xetla-mirror-base-name (archive)
5205   "Return the base name of the mirror ARCHIVE."
5206   (when (eq (xetla-archive-type archive) 'mirror)
5207     (substring archive 0 (string-match "-MIRROR.*$" archive))))
5208
5209 (defun xetla-use-as-default-mirror (archive)
5210   "Use the ARCHIVE as default mirror.
5211 This function checks, if ARCHIVE is a mirror (contains -MIRROR).
5212 The default mirror ends with -MIRROR.  Other mirrors have some
5213 other characters after -MIRROR (e.g.: -MIRROR-2.
5214 This function swaps the location of that -MIRROR and the -MIRROR-2.
5215 The effect of the swapping is, that the mirroring functions work
5216 per default on the default mirror."
5217   (interactive (list (xetla-name-archive (xetla-name-read "Mirror archive name: " 'prompt))))
5218   (unless (eq (xetla-archive-type archive) 'mirror)
5219     (error "%s is not a mirror" archive))
5220   (if (string-match "-MIRROR$" archive)
5221       (message "%s is already the default mirror." archive)
5222     (let* ((archive-base-name (xetla-mirror-base-name archive))
5223            (mirror-list (xetla-get-mirrors-for-archive archive-base-name))
5224            (default-mirror (concat archive-base-name "-MIRROR"))
5225            (default-mirror-present (member default-mirror mirror-list))
5226            (archive-location (xetla-whereis-archive archive))
5227            (default-mirror-location (and default-mirror-present
5228                                          (xetla-whereis-archive default-mirror))))
5229       (if default-mirror-present
5230           (message "swapping mirrors %s <-> %s." archive default-mirror)
5231         (message "using %s as default mirror." archive))
5232       (xetla-unregister-archive archive nil)
5233       (when default-mirror-present
5234         (xetla-unregister-archive default-mirror nil))
5235       (xetla-register-archive-internal archive-location default-mirror)
5236       (when default-mirror-present
5237         (xetla-register-archive-internal default-mirror-location archive)))))
5238
5239
5240 (defun xetla-archive-convert-to-source-archive (archive &optional location)
5241   "Change the name of ARCHIVE to ARCHIVE-SOURCE.
5242 Sets the archive location to LOCATION."
5243   (unless location
5244     (setq location (nth 1 (xetla-archive-tree-get-archive archive))))
5245   (unless location
5246     (error "Location for `%s' is unknown" archive))
5247   (when (eq 'source (xetla-archive-type archive))
5248     (error "%s is already source" archive))
5249 ;  (unless (eq 'http (xetla-location-type location))
5250 ;    (error "Read only archive is supported in xetla: " location))
5251   (xetla-unregister-archive archive nil)
5252   (xetla-register-archive-internal location (concat archive "-SOURCE")))
5253
5254 ;;
5255 ;; Categories
5256 ;;
5257 (defun xetla-categories (archive)
5258   "List the categories of ARCHIVE."
5259   (interactive (list (xetla-name-archive
5260                       (xetla-name-read nil 'prompt))))
5261   (unless archive
5262     (setq archive (xetla-my-default-archive)))
5263   (xetla-archive-tree-build-categories archive)
5264   (xetla-switch-to-buffer "*xetla-categories*")
5265   (let ((list (cddr (xetla-archive-tree-get-archive archive)))
5266         category start-pos extent)
5267     (toggle-read-only -1)
5268     (erase-buffer)
5269     ;; TODO: button to invoke xetla-archives.
5270     (insert (format "Archive: %s\n%s\n" archive
5271                     (make-string (+ (length archive)
5272                                     (length "Archive: ")) ?=)))
5273     (save-excursion
5274       (while list
5275         (setq category (car (car list))
5276               start-pos (point)
5277               list (cdr list))
5278         (insert "   " (xetla-face-add category 'xetla-category-name))
5279         (newline)
5280         (setq extent (make-extent start-pos (point)))
5281         (set-extent-property extent 'category 'xetla-default-button)
5282         (set-extent-property extent 'keymap   xetla-category-category-map)
5283         (set-extent-property extent 'xetla-category-info category)
5284         )
5285       (delete-backward-char 1)))
5286   (xetla-category-list-mode)
5287   (set (make-local-variable 'xetla-buffer-archive-name)
5288        archive))
5289
5290 (defun xetla-make-category (archive category)
5291   "In ARCHIVE, create CATEGORY."
5292   (interactive (let ((l (xetla-name-read "New Category: " 'prompt 'prompt)))
5293                  (list (xetla-name-archive l)
5294                        (xetla-name-category l))))
5295   (xetla-run-tla-sync (list "make-category" "-A" archive category))
5296   (let ((xetla-buffer-archive-name archive))
5297     (run-hooks 'xetla-make-category-hook)))
5298
5299 ;;
5300 ;; Branches
5301 ;;
5302 (defun xetla-branches (archive category)
5303   "Display the branches of ARCHIVE/CATEGORY."
5304   (interactive (let ((l (xetla-name-read nil 'prompt 'prompt)))
5305                  (list (xetla-name-archive l)
5306                        (xetla-name-category l))))
5307   (xetla-archive-tree-build-branches archive category)
5308   (xetla-switch-to-buffer "*xetla-branches*")
5309   (let ((list (cdr (xetla-archive-tree-get-category archive category)))
5310         alength
5311         clength
5312         branch
5313         start-pos
5314         extent)
5315     (toggle-read-only -1)
5316     (erase-buffer)
5317     ;; TODO: button to invoke xetla-categories and xetla-archives
5318     (setq alength (+ (length archive)  (length "Archive: "))
5319           clength (+ (length category) (length "Category: ")))
5320     (insert (format "Archive: %s\nCategory: %s\n%s\n" archive category
5321                     (make-string (max alength clength) ?=)))
5322     (save-excursion
5323       (while list
5324         (setq branch (car (car list))
5325               start-pos (point)
5326               list (cdr list))
5327         (insert "   " (xetla-face-add (if (string= branch "")
5328                                          "<empty>" branch)
5329                                      'xetla-branch-name))
5330         (newline)
5331         (setq extent (make-extent start-pos (point)))
5332         (set-extent-property extent 'category 'xetla-default-button)
5333         (set-extent-property extent 'keymap    xetla-branch-branch-map)
5334         (set-extent-property extent 'xetla-branch-info branch))
5335       (delete-backward-char 1)))
5336   (xetla-branch-list-mode)
5337   (set (make-local-variable 'xetla-buffer-archive-name)
5338        archive)
5339   (set (make-local-variable 'xetla-buffer-category-name)
5340        category))
5341
5342 (defun xetla-make-branch (archive category branch)
5343   "Make a new branch in ARCHIVE/CATEGORY called BRANCH."
5344   (interactive (let ((l (xetla-name-read "New Branch: "
5345                                         'prompt 'prompt 'prompt)))
5346                  (list (xetla-name-archive l)
5347                        (xetla-name-category l)
5348                        (xetla-name-branch l))))
5349   (xetla-run-tla-sync (list "make-branch"
5350                            (xetla-name-construct
5351                             archive category branch)))
5352   (let ((xetla-buffer-archive-name archive)
5353         (xetla-buffer-category-name category))
5354     (run-hooks 'xetla-make-branch-hook)))
5355
5356 ;;
5357 ;; Versions
5358 ;;
5359 (defun xetla-versions (archive category branch)
5360   "Display the versions of ARCHIVE/CATEGORY in BRANCH."
5361   (interactive (let ((l (xetla-name-read nil
5362                                         'prompt 'prompt 'prompt)))
5363                  (list (xetla-name-archive l)
5364                        (xetla-name-category l)
5365                        (xetla-name-branch l))))
5366   (xetla-archive-tree-build-versions archive category branch)
5367   (xetla-switch-to-buffer "*xetla-versions*")
5368   (let ((list (cdr (xetla-archive-tree-get-branch
5369                     archive category branch)))
5370         alength
5371         clength
5372         blength
5373         version
5374         start-pos
5375         extent)
5376     (toggle-read-only -1)
5377     (erase-buffer)
5378     ;; TODO: button to invoke xetla-categories and xetla-archives
5379     (setq alength (+ (length archive)  (length "Archive: "))
5380           clength (+ (length category) (length "Category: "))
5381           blength (+ (length branch)   (length "Branch: ")))
5382     (insert (format "Archive: %s\nCategory: %s\nBranch: %s\n%s\n"
5383                     archive category branch
5384                     (make-string (max alength clength blength) ?=)))
5385     (save-excursion
5386       (while list
5387         (setq version (car (car list))
5388               start-pos (point)
5389               list (cdr list))
5390         (insert "   " (xetla-face-add version 'xetla-version-name))
5391         (newline)
5392         (setq extent (make-extent start-pos (point)))
5393         (set-extent-property extent 'category 'xetla-default-button)
5394         (set-extent-property extent 'keymap   xetla-version-version-map)
5395         (set-extent-property extent 'xetla-version-info version))
5396       (delete-backward-char 1)))
5397   (xetla-version-list-mode)
5398   (set (make-local-variable 'xetla-buffer-archive-name) archive)
5399   (set (make-local-variable 'xetla-buffer-category-name) category)
5400   (set (make-local-variable 'xetla-buffer-branch-name) branch))
5401
5402 (defun xetla-make-version (archive category branch version)
5403   "In ARCHIVE/CATEGORY, add a version to BRANCH called VERSION."
5404   (interactive (let ((l (xetla-name-read "Version: "
5405                                         'prompt 'prompt 'prompt 'prompt)))
5406                  (list (xetla-name-archive l)
5407                        (xetla-name-category l)
5408                        (xetla-name-branch l)
5409                        (xetla-name-version l))))
5410
5411   (xetla-run-tla-sync (list "make-version"
5412                            (xetla-name-construct
5413                             archive category branch version)))
5414   (let ((xetla-buffer-archive-name archive)
5415         (xetla-buffer-category-name category)
5416         (xetla-buffer-branch-name branch))
5417     (run-hooks 'xetla-make-version-hook)))
5418
5419 ;;
5420 ;; Revisions
5421 ;;
5422
5423 ;; elem should be
5424 ;; ('separator "string" kind)
5425 ;; or
5426 ;; ('entry-patch nil revision) Where "revision" is of xetla-revision
5427 ;; struct type.
5428 ;; ('entry-change "changes")
5429 ;; The second element tells if the element is marked or not.
5430 (defun xetla-revision-list-printer (elem)
5431   "Print an element ELEM of the revision list."
5432   (let ()
5433     (case (car elem)
5434       (entry-patch
5435        (let* ((struct (caddr elem))
5436               (merged-by (xetla-revision-merged-by struct))
5437               (unmerged (eq merged-by 'nobody)))
5438          (insert (if (cadr elem) (concat " " xetla-mark) "  ")
5439                  ;; The revision is in library?
5440                  (if (and xetla-revisions-shows-library
5441                           (apply 'xetla-revlib-tree-get-revision
5442                                  (xetla-revision-revision struct)))
5443                      ;;
5444                      ;; (apply 'xetla-library-find
5445                      ;;       (append (caddr elem) '(t))
5446
5447                      "L " "  ")
5448                  (xetla-face-add (xetla-name-construct
5449                                  (xetla-revision-revision struct))
5450                                 (if unmerged 'xetla-unmerged
5451                                   'xetla-revision-name)
5452                                 'xetla-revision-revision-map
5453                                 xetla-revision-revision-menu)
5454                  (if unmerged (xetla-face-add "  [NOT MERGED]"
5455                                              'xetla-unmerged)
5456                    ""))
5457          (let ((summary (xetla-revision-summary struct))
5458                (creator (xetla-revision-creator struct))
5459                (date (xetla-revision-date struct)))
5460            (when (and summary xetla-revisions-shows-summary)
5461              (insert "\n      " summary))
5462            (when (and creator xetla-revisions-shows-creator)
5463              (insert "\n      " creator))
5464            (when (and date xetla-revisions-shows-date)
5465              (insert "\n      " date)))
5466          (when (and xetla-revisions-shows-merges
5467                     (xetla-revision-merges struct)
5468                     (not (null (car (xetla-revision-merges struct)))))
5469            (insert "\n      Merges:")
5470            (dolist (elem (xetla-revision-merges struct))
5471              (insert "\n        " elem)))
5472          (when xetla-revisions-shows-merged-by
5473            (cond ((null merged-by) nil)
5474                  ((listp merged-by)
5475                   (insert "\n      Merged-by:")
5476                   (dolist (elem merged-by)
5477                     (insert "\n        " elem)))))))
5478       (entry-change (insert  (cadr elem)))
5479       (message (insert (xetla-face-add (cadr elem)
5480                                       'xetla-messages)))
5481       (separator
5482        (case (caddr elem)
5483          (partner (insert "\n" (xetla-face-add (cadr elem)
5484                                               'xetla-separator)))
5485          (bookmark (insert "\n" (xetla-face-add
5486                                  (concat "*** "
5487                                          (cadr elem)
5488                                          " ***")
5489                                  'xetla-separator) "\n")))))))
5490
5491 (defun xetla-get-current-revision (&optional directory)
5492   "Return the current revision in DIRECTORY."
5493   (interactive)
5494   (let* ((directory (or directory
5495                         (xetla-read-project-tree-maybe
5496                          "Get current revision in: ")))
5497          (revision (shell-command-to-string
5498                     (concat "tla revisions --full "
5499                             (xetla-tree-version directory)
5500                             "|tail -n1"))))
5501     (if (interactive-p)
5502         (message revision)
5503       revision)))
5504
5505 (defun xetla-tree-revisions ()
5506   "Call `xetla-revisions' in the current tree."
5507   (interactive)
5508   (let* ((default-directory (xetla-read-project-tree-maybe
5509                              "Run tla revisions in: "))
5510          (version (xetla-tree-version-list)))
5511     (unless version
5512       (error "Not in a project tree"))
5513     (apply 'xetla-revisions version)))
5514
5515 ;;;###autoload
5516 (defun xetla-revisions (archive category branch version
5517                               &optional update-display from-revlib)
5518   "List the revisions of ARCHIVE/CATEGORY-BRANCH-VERSION."
5519   (interactive (let ((l (xetla-name-read "Version: " 'prompt 'prompt 'prompt 'prompt)))
5520                  (list
5521                   (xetla-name-archive l)
5522                   (xetla-name-category l)
5523                   (xetla-name-branch l)
5524                   (xetla-name-version l))))
5525   ;; TODO: Consdider the case where (and update-display from-revlib) is t.
5526   (unless (and update-display
5527                (or (xetla-revisions-tree-contains-details
5528                     archive category branch version)
5529                    (not (or xetla-revisions-shows-summary
5530                             xetla-revisions-shows-creator
5531                             xetla-revisions-shows-date))))
5532     (if from-revlib
5533         (xetla-revlib-tree-build-revisions archive category branch version)
5534       (xetla-archive-tree-build-revisions archive category branch version)))
5535   (xetla-switch-to-buffer "*xetla-revisions*")
5536   (let ((list (cdr (if from-revlib
5537                        (xetla-revlib-tree-get-version
5538                         archive category branch version)
5539                      (xetla-archive-tree-get-version
5540                       archive category branch version))))
5541         first
5542         separator
5543         revision
5544         summary
5545         creator
5546         date)
5547     (xetla-revision-list-mode)
5548     (toggle-read-only -1)
5549     (set (make-local-variable 'xetla-buffer-refresh-function)
5550          'xetla-revision-refresh)
5551     (setq separator (xetla-face-add
5552                      (make-string
5553                       (max (+ (length archive)  (length "Archive: "))
5554                            (+ (length category) (length "Category: "))
5555                            (+ (length branch)   (length "Branch: "))
5556                            (+ (length version)  (length "Version: ")))
5557                       ?\ )
5558                      'xetla-separator))
5559     (ewoc-set-hf xetla-revision-list-cookie
5560                  (xetla-revisions-header archive category branch version
5561                                         from-revlib separator)
5562                  (concat "\n" separator))
5563     (if xetla-revisions-shows-library
5564         (xetla-revlib-tree-build-revisions
5565          archive category branch version nil t))
5566     (while list
5567       (setq revision (car (car list))
5568             summary (car (cdr (car list)))
5569             creator (car (cddr (car list)))
5570             date (car (cdddr (car list)))
5571             list (cdr list))
5572       (ewoc-enter-last xetla-revision-list-cookie
5573                        (list 'entry-patch nil
5574                              (make-xetla-revision
5575                               :revision (list archive
5576                                               category
5577                                               branch
5578                                               version
5579                                               revision)
5580                               :summary summary
5581                               :creator creator
5582                               :date    date)))
5583       (if first
5584           (goto-char first)
5585         (goto-char (point-min))
5586         (re-search-forward "^$")
5587         (forward-line 1)
5588         (setq first (point)))
5589       (sit-for 0)))
5590
5591   (set (make-local-variable 'xetla-buffer-archive-name) archive)
5592   (set (make-local-variable 'xetla-buffer-category-name) category)
5593   (set (make-local-variable 'xetla-buffer-branch-name) branch)
5594   (set (make-local-variable 'xetla-buffer-version-name) version)
5595   (toggle-read-only t))
5596
5597 (defun xetla-revisions-header (archive category branch version from-revlib separator)
5598   "Construct a header for the revision ARCHIVE/CATEGORY-BRANCH-VERSION.
5599 Mark the revision as contained in FROM-REVLIB and use SEPARATOR to separate
5600 the entries."
5601   (concat
5602    "Version: "
5603    (xetla-face-add archive  'xetla-archive-name)  "/"
5604    (xetla-face-add category 'xetla-category-name) "--"
5605    (xetla-face-add branch   'xetla-branch-name)   "--"
5606    (xetla-face-add version  'xetla-version-name)  "\n"
5607    "In Revision Library: " (xetla-face-add (if from-revlib "Yes" "No")  'bold)
5608    "\n"
5609    separator "\n"))
5610
5611
5612 ;;;###autoload
5613 (defun xetla-missing (local-tree location)
5614   "Search in directory LOCAL-TREE for missing patches from LOCATION.
5615 If the current buffers default directory is in an arch managed tree use that
5616 one unless called with a prefix arg.  In all other cases prompt for the local
5617 tree and the location."
5618   (interactive (let ((dir
5619                       (or (if (not current-prefix-arg)
5620                               (xetla-tree-root nil t))
5621                           (expand-file-name
5622                            (read-directory-name
5623                             "Search missing patches in directory: "
5624                             default-directory default-directory t nil)))))
5625                  (list dir
5626                        (let ((default-directory dir))
5627                          (if current-prefix-arg
5628                              (xetla-name-read
5629                               "From location: "
5630                               'prompt 'prompt 'prompt 'prompt)
5631                            (xetla-tree-version))))))
5632   (let ((dir (xetla-tree-root)))
5633     (pop-to-buffer (xetla-get-buffer-create 'missing))
5634     (cd dir))
5635   (xetla-revision-list-mode)
5636   (set (make-local-variable 'xetla-buffer-refresh-function)
5637        'xetla-missing-refresh)
5638   (set (make-local-variable 'xetla-missing-buffer-todolist)
5639        `((missing ,local-tree ,(xetla-name-construct location) nil)))
5640   (xetla-missing-refresh))
5641
5642
5643 ;;
5644 ;; Rbrowse interface
5645 ;;
5646 (defun xetla-browse-archive (archive)
5647   "Browse ARCHIVE.
5648
5649 The interface is rather poor, but xetla-browse does a better job
5650 anyway ..."
5651   (interactive (let ((l (xetla-name-read nil 'prompt)))
5652                  (list (xetla-name-archive l))))
5653   (unless archive
5654     (setq archive (xetla-my-default-archive)))
5655   (xetla-run-tla-sync (list "rbrowse" "-A" archive)))
5656
5657 (defun xetla-read-config-file (prompt-tree prompt-file)
5658   "Interactively read the arguments of `xetla-build-config'and `xetla-cat-config'.
5659
5660 The string PROMPT-TREE will be used when prompting the user for a tree.
5661 The string PROMPT-FILE will be used when prompting the user for a file."
5662   (let* ((tree-root (xetla-uniquify-file-name
5663                      (xetla-read-project-tree-maybe
5664                       prompt-tree)))
5665          (current-file-name
5666           (and buffer-file-name
5667                (replace-regexp-in-string
5668                 (concat "^" (regexp-quote tree-root))
5669                 ""
5670                 buffer-file-name)))
5671          (relative-conf-file
5672           (replace-regexp-in-string
5673            (concat "^" (regexp-quote tree-root))
5674            ""
5675            (expand-file-name
5676             (read-file-name prompt-file
5677                             tree-root nil t
5678                             current-file-name)))))
5679     (when (file-name-absolute-p relative-conf-file)
5680       ;; The replace-regexp-in-string failed.
5681       (error "Configuration file must be in a %s"
5682              "subdirectory of tree-root"))
5683     (list tree-root relative-conf-file)))
5684
5685 (defun xetla-build-config (tree-root config-file)
5686   "Run tla build-config in TREE-ROOT, outputting to CONFIG-FILE.
5687 CONFIG-FILE is the relative path-name of the configuration.
5688
5689 When called interactively, arguments are read with the function
5690 `xetla-read-project-tree-maybe'."
5691   (interactive (xetla-read-config-file "Build configuration in directory: "
5692                                       "Build configuration: "))
5693   (let ((default-directory tree-root))
5694     (xetla-run-tla-async (list "build-config" config-file))))
5695
5696 (defun xetla-cat-config (tree-root config-file snap)
5697   "Run tla cat-config in TREE-ROOT, showing CONFIG-FILE.
5698 If SNAP is non-nil, then the --snap option of tla is used.
5699
5700 When called interactively, arguments TREE-ROOT and CONFIG-FILE are
5701 read with the function `xetla-read-project-tree-maybe'."
5702   (interactive (append (xetla-read-config-file "Cat configuration in directory: "
5703                                               "Cat configuration: ")
5704                        (list (y-or-n-p "Include revision number? "))))
5705   (let ((default-directory tree-root))
5706     (xetla-run-tla-async
5707      (list "cat-config" (when snap "--snap") config-file))))
5708
5709 ;;
5710 ;; Get
5711 ;;
5712 (defun xetla-get (directory run-dired-p archive category branch
5713                           &optional version revision synchronously)
5714   "Run tla get in DIRECTORY.
5715 If RUN-DIRED-P is non-nil, display the new tree in dired.
5716 ARCHIVE, CATEGORY, BRANCH, VERSION and REVISION make up the revision to be
5717 fetched.
5718 If SYNCHRONOUSLY is non-nil, run the process synchronously.
5719 Else, run the process asynchronously."
5720   ;; run-dired-p => t, nil, ask
5721   (interactive (let* ((l (xetla-name-read "Get: "
5722                                          'prompt 'prompt 'prompt 'maybe 'maybe))
5723                       (name (xetla-name-construct l))
5724                       (d (read-directory-name (format "Store \"%s\" to: " name))))
5725                  (cons d (cons 'ask l))))
5726   (setq directory (expand-file-name directory))
5727   (if (file-exists-p directory)
5728       (error "Directory %s already exists" directory))
5729   (let* ((name (xetla-name-construct
5730                 (if (or
5731                      ;; the name element are given in interactive form
5732                      (interactive-p)
5733                      ;; not interactive, but revision(and maybe version) is
5734                      ;; passed tothis function.
5735                      (and revision (stringp revision)))
5736                     (list archive category branch version revision)
5737                   (xetla-name-read "Version-Revision for Get(if necessary): "
5738                                   archive category branch
5739                                   (if version version 'maybe)
5740                                   'maybe)))))
5741     (funcall (if synchronously 'xetla-run-tla-sync 'xetla-run-tla-async)
5742              (list "get" "-A" archive name directory)
5743              :finished `(lambda (output error status arguments)
5744                           (let ((i (xetla-status-handler output error status arguments)))
5745                             (when (zerop i)
5746                               (xetla-get-do-bookmark ,directory ,archive ,category ,branch ,version)
5747                               (xetla-do-dired ,directory ',run-dired-p)))))))
5748
5749 (defun xetla-get-do-bookmark (directory archive category branch version)
5750   "Add DIRECTORY to the bookmark for ARCHIVE/CATEGORY-BRANCH-VERSION."
5751   (let ((bookmark (xetla-bookmarks-find-bookmark
5752                    (xetla-name-construct
5753                     archive category branch version))))
5754     (when bookmark
5755       (xetla-bookmarks-add-tree bookmark directory))))
5756
5757 (defun xetla-do-dired (directory run-dired-p)
5758   "Possible run dired in DIRECTORY.
5759 If RUN-DIRED-P is 'ask, ask the user whether to run dired.
5760 If RUN-DIRED-P is nil, do not run dired.
5761 Otherwise, run dired."
5762   (setq directory (expand-file-name directory))
5763   (case run-dired-p
5764     (ask (when (y-or-n-p (format "Run dired at %s? " directory))
5765            (dired directory)))
5766     ('nil nil)
5767     (t (dired directory))))
5768
5769 ;;
5770 ;; Cacherev
5771 ;;
5772 ;; TODO:
5773 ;; - provide the way to run interactively
5774 ;; - show progress
5775 ;;
5776 (defun xetla-cache-revision (archive category branch version revision)
5777   "Cache the revision named by ARCHIVE/CATEGORY-BRANCH-VERSION-REVISION."
5778   (interactive (xetla-name-read "Revision to cache: "
5779                                'prompt 'prompt 'prompt 'prompt 'prompt))
5780   (let ((result (xetla-run-tla-async (list "cacherev"
5781                                           (xetla-name-construct
5782                                            archive category branch version revision)))))
5783     ;;    (xetla-show-last-process-buffer)
5784     result))
5785
5786 ;;
5787 ;; Add
5788 ;;
5789 (defun xetla-add-id (id &rest files)
5790   "Using ID, add FILES to this tree."
5791   (interactive (let ((name
5792                       (read-file-name "Add file as source: "
5793                                       nil nil t
5794                                       (file-name-nondirectory (or
5795                                                                (buffer-file-name) ""))))
5796                      (id (read-string "id (empty for default): ")))
5797                  (list id name)))
5798   (if (and id (string= id ""))
5799       (setq id nil))
5800   (setq files (mapcar 'expand-file-name files))
5801   (let* ((arch-ver (or xetla-arch-version-number
5802                        (xetla-arch-version-number)))
5803          (add-id-string
5804           (cond ((> 2 (or (cdr-safe (assoc 'minor arch-ver)) 0))
5805                  "add")
5806                 (t "add-id"))))
5807     (if id
5808         (xetla-run-tla-sync `(,add-id-string "--id" ,id . ,files)
5809                             :finished 'xetla-null-handler)
5810       (xetla-run-tla-sync `(,add-id-string . ,files)
5811                           :finished 'xetla-null-handler))))
5812
5813 (defalias 'xetla-add 'xetla-add-id)
5814
5815 ;;
5816 ;; Remove
5817 ;;
5818 (defun xetla-remove (only-id &rest files)
5819   "Remove the ids of FILES, possibly also deleting the files.
5820 If ONLY-ID is non-nil, remove the files as well as their ids.  Otherwise,
5821 just remove the ids."
5822   (interactive (let* ((name
5823                        (read-file-name "Remove file: "
5824                                        nil nil t
5825                                        (file-name-nondirectory (or
5826                                                                 (buffer-file-name) ""))))
5827                       (only-id (not (y-or-n-p (format
5828                                                "Delete the \"%s\" locally also? "
5829                                                name)))))
5830                  (list only-id name)))
5831   (setq files (mapcar 'expand-file-name files))
5832   (dolist (f files)
5833     (when (equal 0 (xetla-run-tla-sync (list "id" "--explicit" f)
5834                                       :finished 'xetla-status-handler
5835                                       :error 'xetla-status-handler))
5836       (xetla-run-tla-sync (list "delete-id" f)
5837                          :finished 'xetla-status-handler))
5838     (unless only-id
5839       (delete-file f))))
5840
5841 ;;
5842 ;; Move
5843 ;;
5844 (defun xetla-move (from to only-id)
5845   "Move the file FROM to TO.
5846 If ONLY-ID is non-nil, move only the ID file."
5847   (interactive
5848    (list (read-file-name "Move file: "
5849                          nil nil t
5850                          (file-name-nondirectory
5851                           (or (buffer-file-name) "")))
5852          nil nil))
5853   (setq to (or to (read-file-name (format "Move file %S to: " from)
5854                                   nil nil nil (file-name-nondirectory from)))
5855         only-id (if (eq only-id 'ask)
5856                     (not (y-or-n-p "Move the file locally also? "))
5857                   only-id)
5858         from (expand-file-name from)
5859         to   (expand-file-name to))
5860   (let ((buffer (get-file-buffer from))
5861         (cmd (if only-id "move-id" "mv")))
5862     (if buffer
5863         (save-excursion
5864           (set-buffer buffer)
5865           (set-visited-file-name to)))
5866     (xetla-run-tla-sync (list cmd from to)
5867                        :finished
5868                        `(lambda (output error status arguments)
5869                           (let ((buf (find-buffer-visiting ,from)))
5870                             (when buf
5871                               (with-current-buffer buf
5872                                 (rename-buffer (file-name-nondirectory
5873                                                 ,to))
5874                                 (set-visited-file-name ,to))))
5875                           status))))
5876
5877 (defalias 'xetla-mv 'xetla-move)
5878
5879 ;;
5880 ;; Update
5881 ;;
5882 (defun xetla-update (tree &optional handle)
5883   "Run tla update in TREE.
5884
5885 After running update, execute HANDLE (function taking no argument)."
5886   (interactive (list (expand-file-name
5887                       (read-directory-name "Update tree: " nil nil nil ""))))
5888   (or (xetla-save-some-buffers tree)
5889       (y-or-n-p
5890        "Update may delete unsaved changes.  Continue anyway? ")
5891       (error "Not updating"))
5892   (let* ((default-directory (or tree default-directory))
5893          (buffer (xetla-prepare-changes-buffer
5894                   (list 'last-revision default-directory)
5895                   (list 'local-tree default-directory)
5896                   'changes default-directory)))
5897     (when xetla-switch-to-buffer-first
5898       (xetla-switch-to-buffer buffer))
5899     (xetla-run-tla-async `("update")
5900                         :finished `(lambda (output error status arguments)
5901                                      ;; (xetla-show-last-process-buffer)
5902                                      (xetla-show-changes-buffer
5903                                       output nil ,buffer)
5904                                      (message "`tla update' finished")
5905                                      (xetla-revert-some-buffers ,tree)
5906                                      (when ,handle (funcall ,handle)))
5907                         :error
5908                         (lambda (output error status arguments)
5909                           (xetla-show-error-buffer error)
5910                           (xetla-show-last-process-buffer)
5911                           ))
5912   (xetla-revert-some-buffers tree)))
5913
5914 ;;
5915 ;; Import
5916 ;;
5917 ;;;###autoload
5918 (defun xetla-start-project (&optional archive synchronously)
5919   "Start a new project.
5920 Prompts for the root directory of the project and the fully
5921 qualified version name to use.  Sets up and imports the tree and
5922 displays an inventory buffer to allow the project's files to be
5923 added and committed.
5924 If ARCHIVE is given, use it when reading version.
5925 Return a cons pair: its car is the new version name string, and
5926 its cdr is imported location.
5927 If SYNCHRONOUSLY is non-nil, run \"tla import\" synchronously.
5928 Else run it asynchronously."
5929   (interactive)
5930   (let* ((base (read-directory-name "Directory containing files to import: "
5931                                          (or default-directory
5932                                              (getenv "HOME"))))
5933          (l (xetla-name-read (format "Import `%s' to: " base)
5934                            (if archive archive (xetla-my-default-archive))
5935                            'prompt 'prompt 'prompt))
5936          (project (xetla-name-construct l)))
5937     (let ((default-directory (file-name-as-directory base)))
5938       (xetla-run-tla-sync (list "init-tree" project))
5939       (save-excursion
5940         (xetla-inventory default-directory)
5941         (message "Type %s when ready to import"
5942                  (substitute-command-keys "\\[exit-recursive-edit]"))
5943         (recursive-edit))
5944       (funcall (if synchronously 'xetla-run-tla-sync 'xetla-run-tla-async)
5945                (list "import" "--setup")
5946                :finished
5947                `(lambda (output error status arguments)
5948                   (xetla-inventory ,base t)))
5949       (cons project default-directory))))
5950
5951 (defvar xetla-partner-file-precious "/{arch}/+partner-versions"
5952   "Precious version of the partner file.
5953 We strongly suggest keeping the default value since this is a
5954 convention used by other xetla front-ends like Aba.")
5955
5956 (defvar xetla-partner-file-source "/{arch}/=partner-versions"
5957   "Source version of the partner file.
5958 We strongly suggest keeping the default value since this is
5959 a convention used by other xetla front-ends like Aba.")
5960
5961 ;; --------------------------------------
5962 ;; xetla partner stuff
5963 ;; --------------------------------------
5964 (defun xetla-partner-find-partner-file (&optional local-tree)
5965   "Do `find-file' xetla-partners file and return the buffer.
5966 If the file `xetla-partner-file-precious' exists, it is used in priority.
5967 Otherwise,use `xetla-partner-file-source'.  The precious one is meant for user
5968 configuration, whereas the source one is used for project-wide
5969 configuration.  If LOCAL-TREE is not managed by arch, return nil."
5970   (interactive)
5971   (let ((default-directory (or local-tree
5972                                (xetla-tree-root default-directory t))))
5973     (let* ((partner-file
5974             (cond ((not default-directory) nil)
5975                   ((file-exists-p (concat (xetla-tree-root)
5976                                            xetla-partner-file-precious))
5977                    (concat (xetla-tree-root) xetla-partner-file-precious))
5978                   (t (concat (xetla-tree-root)
5979                              xetla-partner-file-source))))
5980            (buffer-visiting (and partner-file (find-buffer-visiting partner-file))))
5981       (if buffer-visiting
5982           (with-current-buffer buffer-visiting
5983             (if (buffer-modified-p)
5984                 (if (progn (switch-to-buffer (current-buffer))
5985                            (y-or-n-p (format "Save file %s? "
5986                                              (buffer-file-name))))
5987                     (save-buffer)
5988                   (revert-buffer)))
5989             buffer-visiting)
5990         (when partner-file
5991           (find-file-noselect partner-file))))))
5992
5993
5994 (defun xetla-partner-add (partner &optional local-tree)
5995   "Add a partner for this xetla working copy.
5996 Return nil if PARTNER is alerady in partners file.
5997 Look for the parners file in LOCAL-TREE.
5998 For example: Franz.Lustig@foo.bar-public/xetla-main-0.1"
5999   (interactive (list (xetla-name-construct
6000                       (xetla-name-read
6001                        "Version to Add Partner File: "
6002                        'prompt 'prompt 'prompt 'prompt))))
6003   (let ((list (xetla-partner-list local-tree)))
6004     (if (member partner list)
6005         nil
6006       (with-current-buffer (xetla-partner-find-partner-file)
6007         (goto-char (point-min))
6008         (insert partner)
6009         (newline)
6010         (save-buffer))
6011       partner)))
6012
6013 (defun xetla-partner-list (&optional local-tree)
6014   "Read the partner list from partner files in LOCAL-TREE.
6015 If LOCAL-TREE is nil, use the `xetla-tree-root' of `default-directory' instead.
6016 If LOCAL-TREE is not managed by arch, return nil."
6017   (let ((buffer (xetla-partner-find-partner-file local-tree)))
6018     (when buffer
6019       (with-current-buffer buffer
6020         (let ((partners (split-string (buffer-substring (point-min) (point-max)) "\n")))
6021           (remove "" partners))))))
6022
6023 (defun xetla-partner-member (version &optional local-tree)
6024   "Predicate to check whether VERSION is in the partners file in LOCAL-TREE."
6025   (let ((list (xetla-partner-list local-tree)))
6026     (member version list)))
6027
6028 (defun xetla-partner-read-version (&optional prompt including-self)
6029   "Specialized version for `xetla-name-read' to read a partner.
6030 - This function displays PROMPT, reads an archive/category-branch-version,
6031 and:
6032 - Return the result in a string form (not in a list form) and
6033 - Ask to the user whether adding the result to the partner file or not
6034   if the result is not in the partner file.
6035
6036 If INCLUDING-SELF is non-nil, this function asks a question whether
6037 using self as partner or not.  If the user answers `y' as the question,
6038 this function returns a symbol, `self'.  If the user answers `n' as the
6039 question, this function runs as the same as if INCLUDING-SELF is nil."
6040   (unless prompt (setq prompt "Enter Xetla Partner: "))
6041   (if (and including-self
6042              (y-or-n-p "Select `self' as partner? "))
6043       'self
6044     (let ((version (xetla-name-construct
6045                     (xetla-name-read
6046                      prompt
6047                      'prompt 'prompt 'prompt 'prompt))))
6048       (when (and (not (xetla-partner-member version))
6049                  (y-or-n-p (format "Add `%s' to Partner File? " version)))
6050         (xetla-partner-add version))
6051       version)))
6052
6053 ;; FIXME: Currently does nothing in XEmacs.
6054 (defun xetla-partner-create-menu (action &optional prompt)
6055   "Create the partner menu with ACTION using PROMPT as the menu name."
6056   (let ((list (xetla-partner-list)))
6057     (xetla-funcall-if-exists
6058      easy-menu-create-menu prompt
6059      (mapcar
6060       (lambda (item)
6061         (let ((v (make-vector 3 nil)))
6062           (aset v 0 item)               ; name
6063           (aset v 1 `(,action ,item))
6064           (aset v 2 t)                  ; enable
6065           ;;(aset v 3 :style)
6066           ;;(aset v 4 'radio)
6067           ;;(aset v 5 :selected)
6068           ;;(aset v 6 (if ...))
6069           v))
6070       list))))
6071
6072 ;; --------------------------------------
6073 ;; xetla-inventory-mode:
6074 ;; --------------------------------------
6075
6076 (defun xetla-inventory-mode ()
6077   "Major Mode to show the inventory of a xetla working copy.
6078
6079 This allows you to view the list of files in your local tree.  You can
6080 display only some particular kinds of files with 't' keybindings:
6081 '\\<xetla-inventory-mode-map>\\[xetla-inventory-toggle-source]' to toggle show sources,
6082 '\\[xetla-inventory-toggle-precious]' to toggle show precious, ...
6083
6084 Use '\\[xetla-inventory-mark-file]' to mark files, and '\\[xetla-inventory-unmark-file]' to unmark.
6085 If you commit from this buffer (with '\\[xetla-inventory-edit-log]'), then, the list of selected
6086 files in this buffer at the time you actually commit with
6087 \\<xetla-log-edit-mode-map>\\[xetla-log-edit-done].
6088
6089 Commands:
6090 \\{xetla-inventory-mode-map}"
6091   (interactive)
6092   ;;  don't kill all local variables : this would clear the values of
6093   ;;  xetla-inventory-display-*, and refresh wouldn't work well anymore.
6094   ;;  (kill-all-local-variables)
6095   (use-local-map xetla-inventory-mode-map)
6096   (set (make-local-variable 'xetla-buffer-refresh-function)
6097        'xetla-inventory)
6098   (make-local-variable 'xetla-buffer-marked-file-list)
6099   (easy-menu-add xetla-inventory-mode-menu)
6100   (setq major-mode 'xetla-inventory-mode)
6101   (setq mode-name "xetla-inventory")
6102   (setq mode-line-process 'xetla-mode-line-process)
6103   (set (make-local-variable 'xetla-get-file-info-at-point-function)
6104        'xetla-inventory-get-file-info-at-point)
6105   (set (make-local-variable 'xetla-generic-select-files-function)
6106        'xetla-inventory-select-files)
6107   (toggle-read-only 1)
6108   (run-hooks 'xetla-inventory-mode-hook))
6109
6110 (defun xetla-inventory-cursor-goto (ewoc-inv)
6111   "Move cursor to the ewoc location of EWOC-INV."
6112   (interactive)
6113   (if ewoc-inv
6114       (progn (goto-char (ewoc-location ewoc-inv))
6115              (forward-char 6))
6116     (goto-char (point-min))))
6117
6118 (defun xetla-inventory-next ()
6119   "Go to the next inventory item."
6120   (interactive)
6121   (let* ((cookie xetla-inventory-cookie)
6122          (elem (ewoc-locate cookie))
6123          (next (or (ewoc-next cookie elem) elem)))
6124     (xetla-inventory-cursor-goto next)))
6125
6126 (defun xetla-inventory-previous ()
6127   "Go to the previous inventory item."
6128   (interactive)
6129   (let* ((cookie xetla-inventory-cookie)
6130          (elem (ewoc-locate cookie))
6131          (previous (or (ewoc-prev cookie elem) elem)))
6132     (xetla-inventory-cursor-goto previous)))
6133
6134 (defun xetla-inventory-edit-log (&optional insert-changelog)
6135   "Wrapper around `xetla-edit-log', setting the source buffer to current buffer.
6136 If INSERT-CHANGELOG is non-nil, insert a changelog too."
6137   (interactive "P")
6138   (xetla-edit-log insert-changelog (current-buffer)))
6139
6140 (defun xetla-inventory-add-files (files)
6141   "Create explicit inventory ids for FILES."
6142   (interactive
6143    (list
6144     (if xetla-buffer-marked-file-list
6145         (progn
6146           (unless (y-or-n-p (if (eq 1 (length xetla-buffer-marked-file-list))
6147                                 (format "Add %s? "
6148                                         (car xetla-buffer-marked-file-list))
6149                               (format "Add %s files? "
6150                                       (length xetla-buffer-marked-file-list))))
6151             (error "Not adding any file"))
6152           xetla-buffer-marked-file-list)
6153       (list (read-file-name "Add file: " default-directory
6154                             nil nil
6155                             (xetla-get-file-info-at-point))))))
6156   (apply 'xetla-add-id nil files)
6157   (xetla-inventory))
6158
6159 (defun xetla-inventory-remove-files (files id-only)
6160   "Remove explicit inventory ids of FILES.
6161 If ID-ONLY is nil, remove the files as well."
6162   (interactive
6163    (let ((read-files
6164           (if xetla-buffer-marked-file-list
6165               (progn
6166                 (unless (yes-or-no-p
6167                          (format "Remove %d MARKED file%s? "
6168                                  (length xetla-buffer-marked-file-list)
6169                                  (if (< (length xetla-buffer-marked-file-list) 2)
6170                                         "" "s")))
6171                   (error "Not removing any file"))
6172                 xetla-buffer-marked-file-list)
6173             (list (let ((file (xetla-get-file-info-at-point)))
6174                     (if (yes-or-no-p (format "Remove %s? " file))
6175                         file
6176                       (error "Not removing any file")))))))
6177      (list read-files (not (y-or-n-p (format "Delete %d %sfile%s also locally? "
6178                                              (length read-files)
6179                                              (if xetla-buffer-marked-file-list "MARKED " "")
6180                                              (if (< (length read-files) 2) "" "s")))))))
6181   (apply 'xetla-remove id-only files)
6182   (xetla-inventory))
6183
6184 (defun xetla-delete-file (file &optional recursive)
6185   "Delete FILE or directory, recursively if optional RECURSIVE is non-nil.
6186 RECURSIVE determines what to do with a non-empty directory.  If RECURSIVE is:
6187 Nil, do not delete.
6188 `always', delete recursively without asking.
6189 `top', ask for each directory at top level.
6190 Anything else, ask for each sub-directory."
6191   (let (files)
6192     ;; This test is equivalent to
6193     ;; (and (file-directory-p fn) (not (file-symlink-p fn)))
6194     ;; but more efficient
6195     (if (not (eq t (car (file-attributes file))))
6196         (delete-file file)
6197       (when (and recursive
6198                  (setq files
6199                        (directory-files
6200                         file t
6201                         "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*")) ; Not empty.
6202                  (or (eq recursive 'always)
6203                      (yes-or-no-p (format "Recursive delete of %s "
6204                                           (dired-make-relative file)))))
6205         (if (eq recursive 'top) (setq recursive 'always)) ; Don't ask again.
6206         (while files           ; Recursively delete (possibly asking).
6207           (xetla-delete-file (car files) recursive)
6208           (setq files (cdr files))))
6209       (delete-directory file))))
6210
6211 (defun xetla-inventory-delete-files (files no-questions)
6212   "Delete FILES locally.
6213 This is here for convenience to delete left over, temporary files or files
6214 avoiding a commit or conflicting with tree-lint.
6215
6216 It is not meant to delete xetla managed files, i.e. files with IDs will be
6217 passed to `xetla-inventory-remove-files'!
6218
6219 When called with a prefix arg NO-QUESTIONS, just delete the files."
6220   (interactive
6221    (list
6222     (if xetla-buffer-marked-file-list
6223         (progn
6224           (or current-prefix-arg
6225               (unless (yes-or-no-p
6226                        (format "Delete %d files permanently? "
6227                                (length xetla-buffer-marked-file-list)))
6228                 (error "Not deleting any files")))
6229           xetla-buffer-marked-file-list)
6230       (if (or current-prefix-arg
6231               (yes-or-no-p (format "Delete file %S permanently? "
6232                                    (xetla-get-file-info-at-point))))
6233           (list (xetla-get-file-info-at-point))))
6234     current-prefix-arg))
6235   (while files
6236     (let ((f (car files)))
6237       (if (= 0 (xetla-run-tla-sync (list "id" f)
6238                                   :finished 'xetla-status-handler
6239                                   :error 'xetla-status-handler))
6240           (if (or no-questions
6241                   (y-or-n-p (format (concat "File %s is arch managed! "
6242                                             "Delete it with its id?") f)))
6243               (xetla-inventory-remove-files (list f) nil))
6244         (if (file-directory-p f)
6245             (condition-case nil
6246                 (delete-directory f)
6247               (file-error
6248                (if (or no-questions
6249                        (y-or-n-p (format "Delete non-empty directory %S? " f)))
6250                    (xetla-delete-file f 'always))))
6251           (delete-file f))))
6252     (setq files (cdr files)))
6253   (if xetla-buffer-marked-file-list
6254       (setq xetla-buffer-marked-file-list nil))
6255   (xetla-inventory))
6256
6257 (defun xetla-inventory-move ()
6258   "Rename file at the current point and update its inventory id if present."
6259   (interactive)
6260   (if (eq 0 (xetla-move (xetla-get-file-info-at-point) nil 'ask))
6261       (xetla-generic-refresh)
6262     (xetla-show-last-process-buffer)))
6263
6264 (defun xetla-inventory-revert ()
6265   "Reverts file at point."
6266   (interactive)
6267   (let* ((file (xetla-get-file-info-at-point))
6268          (absolute (if (file-name-absolute-p file)
6269                        file
6270                      (expand-file-name
6271                       (concat (file-name-as-directory
6272                                default-directory) file)))))
6273     (xetla-file-revert absolute)))
6274
6275 (defun xetla-inventory-undo (specify-revision)
6276   "Undo whole local tree associated with the current inventory buffer.
6277 If prefix arg, SPECIFY-REVISION is non-nil, read a revision and use it to undo.
6278 The changes are saved in an ,,undo directory.  You can restore them again via
6279 `xetla-inventory-redo'."
6280   (interactive "P")
6281   (let* ((tree (xetla-tree-root default-directory t))
6282          (revision (if specify-revision
6283                        (xetla-read-revision-with-default-tree
6284                         "Undo against archive: "
6285                         tree)
6286                      (list nil nil nil nil nil))))
6287     (apply 'xetla-undo-internal (cons tree revision))))
6288
6289 (defun xetla-inventory-maybe-undo-directory ()
6290   "Return the directory name under point if it may be an ,,undo-? directory.
6291 Return nil otherwise."
6292   (car (member (expand-file-name (xetla-get-file-info-at-point))
6293                (xetla-get-undo-changeset-names))))
6294
6295 (defun xetla-inventory-redo ()
6296   "Redo whole local tree associated with the current inventory buffer.
6297 This function restores the saved changes from `xetla-inventory-undo'."
6298   (interactive)
6299   (xetla-redo (xetla-inventory-maybe-undo-directory)))
6300
6301 (defun xetla-file-has-conflict-p (file-name)
6302   "Return non-nil if FILE-NAME has conflicts."
6303   (let ((rej-file-name (concat default-directory
6304                                (file-name-nondirectory file-name)
6305                                ".rej")))
6306     (file-exists-p rej-file-name)))
6307
6308 (defun xetla-inventory-find-file ()
6309   "Visit the current inventory file."
6310   (interactive)
6311   (let* ((file (xetla-get-file-info-at-point)))
6312     (cond
6313      ((not file)
6314       (error "No file at point"))
6315      ((eq t (car (file-attributes file)))      ; file is a directory
6316       (xetla-inventory (expand-file-name file)))
6317      (t
6318       (find-file file)))))
6319
6320 (defun xetla-inventory-parent-directory ()
6321   "Go to parent directory in inventory mode."
6322   (interactive)
6323   (xetla-inventory (expand-file-name "..")))
6324
6325 (defun xetla-inventory-mirror ()
6326   "Create a mirror of version of the current tree."
6327   (interactive)
6328   (let ((tree-version (xetla-tree-version-list)))
6329     (xetla-archive-mirror (xetla-name-archive  tree-version)
6330                         (xetla-name-category tree-version)
6331                         (xetla-name-branch   tree-version)
6332                         (xetla-name-version  tree-version))))
6333
6334 (defun xetla-inventory-star-merge (&optional merge-partner)
6335   "Run tla star-merge.
6336 Either use a partner in the tree's \"++tla-partners\" file or ask the user
6337 for MERGE-PARTNER."
6338   (interactive (list (xetla-partner-read-version "Star-merge with: ")))
6339   (when (y-or-n-p (format "Star-merge with %s ? " merge-partner))
6340     (xetla-star-merge merge-partner)))
6341
6342 (defun xetla-inventory-changes (summary)
6343   "Run tla changes.
6344 A prefix argument decides whether the user is asked for a diff partner
6345 and whether only a summary without detailed diffs will be shown.
6346
6347 When called without a prefix argument: Show the changes for your tree.
6348 When called with C-u as prefix: Ask the user for a diff partner via `xetla-partner-read-version'.
6349 When called with a negative prefix: Show only a summary of the changes.
6350 When called with C- C-u as prefix: Ask the user for a diff partner, show only change summary."
6351   (interactive "P")
6352   (let* ((ask-for-compare-partner (and summary (listp summary)))
6353          (compare-partner (if ask-for-compare-partner
6354                               (xetla-partner-read-version
6355                                "Compare with (default is your tree): "
6356                                t)
6357                             'self)))
6358     (if (eq 'self compare-partner)
6359         (setq compare-partner nil)
6360       (setq compare-partner (list 'revision (xetla-name-split compare-partner))))
6361     (when (listp summary)
6362       (setq summary (car summary)))
6363     (xetla-changes summary compare-partner)))
6364
6365 (defun xetla-inventory-replay (&optional merge-partner)
6366   "Run tla replay.
6367 Either use a partner in the tree's ++xetla-partners file, or ask the user
6368 for MERGE-PARTNER."
6369   (interactive (list (xetla-partner-read-version "Replay from: ")))
6370   (when (y-or-n-p (format "Replay from %s ? " merge-partner))
6371     (xetla-replay merge-partner)))
6372
6373 (defun xetla-inventory-update ()
6374   "Run tla update."
6375   (interactive)
6376   (xetla-update default-directory))
6377
6378 (defun xetla-inventory-missing (&optional arg)
6379   "Run tla missing in `default-directory'.
6380 With an prefix ARG, do this for the archive of one of your partners."
6381   (interactive "P")
6382   (if arg
6383       (let ((missing-partner (xetla-partner-read-version "Check missing against: ")))
6384         (when (y-or-n-p (format "Check missing against %s ? " missing-partner))
6385           (xetla-missing default-directory missing-partner)))
6386     (xetla-missing default-directory (xetla-tree-version))))
6387
6388 (defun xetla-inventory-file-ediff (&optional file)
6389   "Run `ediff' on FILE."
6390   (interactive (list (caddr (ewoc-data (ewoc-locate xetla-inventory-cookie)))))
6391   (xetla-file-ediff file))
6392
6393 (xetla-make-bymouse-function xetla-inventory-find-file)
6394
6395 (defun xetla-inventory-delta ()
6396   "Run tla delta.
6397 Use the head revision of the version associated with the current inventory
6398 buffer as modified tree.  Give the base tree interactively."
6399   (interactive)
6400   (let* ((modified (xetla-tree-version-list))
6401          (modified-revision (apply 'xetla-version-head modified))
6402          (modified-fq (xetla-name-construct
6403                        (xetla-name-archive modified)
6404                        (xetla-name-category modified)
6405                        (xetla-name-branch modified)
6406                        (xetla-name-version modified)
6407                        modified-revision))
6408          (base (xetla-name-read
6409                 (format "Revision for delta to %s(HEAD) from: " modified-fq)
6410                 'prompt 'prompt 'prompt 'prompt 'prompt))
6411          (base-fq (xetla-name-construct base)))
6412     (xetla-delta base-fq modified-fq 'ask)))
6413
6414
6415 (defun xetla-inventory-apply-changeset (reverse)
6416   "Apply changeset to the tree visited by the current inventory buffer.
6417 With a prefix argument REVERSE, reverse the changeset."
6418   (interactive "P")
6419   (let ((inventory-buffer (current-buffer))
6420         (target (xetla-tree-root))
6421         (changeset (let ((changeset-dir (or (xetla-get-file-info-at-point) "")))
6422                      (unless (file-directory-p (expand-file-name changeset-dir))
6423                        (setq changeset-dir ""))
6424                      (xetla-uniquify-file-name
6425                       (read-directory-name
6426                        "Changeset directory: "  changeset-dir changeset-dir)))))
6427     (xetla-show-changeset changeset nil)
6428     (when (yes-or-no-p (format "Apply the changeset%s? "
6429                             (if reverse " in REVERSE" "")))
6430       (xetla-apply-changeset changeset target reverse)
6431       (with-current-buffer inventory-buffer
6432         (xetla-generic-refresh)))))
6433
6434 (defun xetla-inventory-apply-changeset-from-tgz (file)
6435   "Apply the changeset in FILE to the currently visited tree."
6436   (interactive (list (let ((changeset-tarball (or (xetla-get-file-info-at-point) "")))
6437                        (read-file-name "Apply changeset from tarball: " nil changeset-tarball t changeset-tarball))))
6438   (let ((inventory-buffer (current-buffer))
6439         (target (xetla-tree-root)))
6440     (xetla-apply-changeset-from-tgz file target)
6441     (with-current-buffer inventory-buffer
6442       (xetla-generic-refresh))))
6443
6444 ;; TODO: Use `xetla-inventory-select-file' in other xetla-inventory-*.
6445 ;; TODO: Mouse event check like `xetla-tree-lint-select-files'.
6446 ;; TODO: Unify with `xetla-tree-lint-select-files'.
6447 (defun xetla-inventory-select-files (prompt-singular
6448                                     prompt-plural msg-err
6449                                     &optional
6450                                     msg-prompt no-group ignore-marked
6451                                     no-prompt y-or-n)
6452   "Get the list of marked files and ask confirmation of the user.
6453 PROMPT-SINGULAR or PROMPT-PLURAL is used as prompt.  If no file is under
6454 the point MSG-ERR is passed to `error'.
6455
6456 MSG-PROMPT NO-GROUP IGNORE-MARKED NO-PROMPT and Y-OR-N are currently
6457 ignored."
6458   (let ((files (if xetla-buffer-marked-file-list
6459                    xetla-buffer-marked-file-list
6460                  (list (xetla-get-file-info-at-point)))))
6461     (unless files
6462       (error msg-err))
6463     (if (y-or-n-p
6464          (format
6465           (if (> (length files) 1)
6466               prompt-plural
6467             prompt-singular)
6468           (if (> (length files) 1)
6469               (length files)
6470             (car files))))
6471         files
6472       (error msg-err))))
6473
6474 (defun xetla-inventory-make-junk (files)
6475   "Prompts and make the FILES junk.
6476 If marked files are, use them as FIELS.
6477 If not, a file under the point is used as FILES."
6478   (interactive
6479    (list
6480     (xetla-inventory-select-files "Make `%s' junk? "
6481                                  "Make %s files junk? "
6482                                  "Not making any file junk")))
6483   (xetla-generic-file-prefix files ",,"))
6484
6485 (defun xetla-inventory-make-precious (files)
6486   "Prompts and make the FILES precious.
6487 If marked files are, use them as FILES.
6488 If not, a file under the point is used as FILES."
6489   (interactive
6490    (list
6491     (xetla-inventory-select-files "Make `%s' precious? "
6492                                  "Make %s files precious? "
6493                                  "Not making any file precious")))
6494   (xetla-generic-file-prefix files "++"))
6495
6496 (defun xetla-generic-add-to-exclude (=tagging-method)
6497   "Exclude the file/directory under point by adding it to =TAGGING-METHOD.
6498 Adds an entry for the file to .arch-inventory or =tagging-method."
6499   (interactive "P")
6500   (xetla-generic-add-to-* "exclude" =tagging-method))
6501
6502 (defun xetla-generic-add-to-junk (=tagging-method)
6503   "Add the file/directory under point to =TAGGING-METHOD.
6504 Adds an entry for the file to .arch-inventory or =tagging-method."
6505   (interactive "P")
6506   (xetla-generic-add-to-* "junk" =tagging-method))
6507
6508 (defun xetla-generic-add-to-backup (=tagging-method)
6509   "Add the file/directory under the point to =TAGGING-METHOD.
6510 Adds an entry for the file to .arch-inventory or =tagging-method."
6511   (interactive "P")
6512   (xetla-generic-add-to-* "backup" =tagging-method))
6513
6514 (defun xetla-generic-add-to-precious (=tagging-method)
6515   "Add the file/directory under the point to =TAGGING-METHOD.
6516 Adds an entry for the file to .arch-inventory or =tagging-method."
6517   (interactive "P")
6518   (xetla-generic-add-to-* "precious" =tagging-method))
6519
6520 (defun xetla-generic-add-to-unrecognized (=tagging-method)
6521   "Add the file/directory under the point as a precious entry
6522 of .arch-inventory or =tagging-method file."
6523   (interactive "P")
6524   (xetla-generic-add-to-* "unrecognized" =tagging-method))
6525
6526 (defun xetla-generic-add-to-* (category =tagging-method)
6527   "Categorize currently marked files or the file under point.
6528 Each file is categorized as CATEGORY by adding it to =TAGGING-METHOD."
6529   (xetla-generic-add-files-to-*
6530    category =tagging-method
6531    (xetla-generic-select-files
6532     (format "Make `%%s' %s? " category)
6533     (format "Make %%s files %s? " category)
6534     (format "Not making any file %s? " category)
6535     (format "Make file %s: " category))))
6536
6537 (defun xetla-generic-add-files-to-* (category =tagging-method files)
6538   "Categorize FILES as CATEGORY in =TAGGING-METHOD.
6539 If =TAGGING-METHOD is t, entries for the files are added to =tagging-method.
6540 Else, they are added to .arch-inventory.
6541 CATEGORY is one of the following strings: \"unrecognized\", \"precious\",
6542 \"backup\",\"junk\" or \"exclude\"."
6543   (let ((point (point))
6544         (basedir (expand-file-name default-directory)))
6545     ;; Write down
6546     (save-excursion
6547       (mapc (lambda (file)
6548               (if =tagging-method
6549                   (xetla-edit-=tagging-method-file)
6550                 (xetla-edit-.arch-inventory-file
6551                  (concat basedir (file-name-directory file))))
6552               (xetla-inventory-file-add-file
6553                category (xetla-regexp-quote (file-name-nondirectory file)))
6554               (save-buffer)) files))
6555     ;; Keep the position
6556     (prog1
6557         (xetla-generic-refresh)
6558       (if (< point (point-max))
6559           (goto-char point)))))
6560
6561
6562 (defun xetla-generic-set-id-tagging-method (method)
6563   "Set the id tagging method of the current tree to METHOD."
6564   (interactive (list (xetla-id-tagging-method-read
6565                       (xetla-id-tagging-method nil))))
6566   (xetla-id-tagging-method-set method)
6567   (xetla-generic-refresh))
6568
6569 (defun xetla-generic-set-id-tagging-method-by-mouse (dummy-event)
6570   "Interactively set the id tagging method of the current tree.
6571 DUMMY-EVENT is ignored."
6572   (interactive "e")
6573   (call-interactively 'xetla-generic-set-id-tagging-method))
6574
6575 (defun xetla-generic-set-tree-version (&optional version)
6576   "Run tla set-tree-version, setting the tree to VERSION."
6577   (interactive)
6578   (if version
6579       (xetla-set-tree-version version)
6580     (call-interactively 'xetla-set-tree-version))
6581   (xetla-generic-refresh))
6582
6583 ;; --------------------------------------
6584 ;; xetla-cat-log-mode:
6585 ;; --------------------------------------
6586 (defun xetla-cat-log-mode ()
6587   "Major Mode to show a specific log message.
6588 Commands:
6589 \\{xetla-cat-log-mode-map}"
6590   (interactive)
6591   (kill-all-local-variables)
6592   (use-local-map xetla-cat-log-mode-map)
6593   (set (make-local-variable 'font-lock-defaults)
6594        '(xetla-cat-log-font-lock-keywords t))
6595   (font-lock-mode)
6596   (setq major-mode 'xetla-cat-log-mode)
6597   (setq mode-name "xetla-cat-log")
6598   (toggle-read-only 1)
6599   (run-hooks 'xetla-cat-log-mode-hook))
6600
6601 (defun xetla-cat-log (revision-spec)
6602   "Show the log for REVISION-SPEC."
6603   (interactive (list (xetla-name-construct
6604                       (xetla-name-read "Revision spec: "
6605                                      'prompt 'prompt 'prompt 'prompt 'prompt))))
6606   (xetla-run-tla-sync (list "cat-log" revision-spec)
6607                      :finished 'xetla-finish-function-without-buffer-switch)
6608   (xetla-show-last-process-buffer 'cat-log 'xetla-cat-log-mode revision-spec))
6609
6610 (defun xetla-cat-archive-log (revision-spec)
6611   "Run cat-archive-log for REVISION-SPEC."
6612   (interactive (list (xetla-name-construct
6613                       (xetla-name-read "Revision spec: "
6614                                      'prompt 'prompt 'prompt 'prompt 'prompt))))
6615   (xetla-run-tla-sync (list "cat-archive-log" revision-spec)
6616                      :finished 'xetla-finish-function-without-buffer-switch)
6617   (xetla-show-last-process-buffer 'cat-log 'xetla-cat-log-mode revision-spec))
6618
6619 (defun xetla-maybe-save-log (revision)
6620   "Must be called from the buffer containing the log for REVISION.
6621 Saves this buffer to the corresponding file in the log-library if
6622 `xetla-log-library-greedy' is non-nil."
6623   (if xetla-log-library-greedy
6624       (let ((dir (expand-file-name
6625                   (concat (file-name-as-directory xetla-log-library)
6626                           (car revision))))
6627             (file (xetla-name-construct-semi-qualified (cdr revision))))
6628         (unless (file-directory-p dir)
6629           (make-directory dir))
6630         (let ((name (concat " *xetla-log-rev-" (xetla-name-construct
6631                                               revision) "*"))
6632               make-backup-files)
6633           (write-file (concat (file-name-as-directory dir) file))
6634           (set-visited-file-name
6635            (concat (file-name-as-directory dir) file))
6636           (set-buffer-modified-p nil)
6637           (rename-buffer name)
6638           (current-buffer)))
6639     (clone-buffer)))
6640
6641 (defun xetla-cat-log-any (revision &optional tree async-handler)
6642   "Create a buffer containing the log file for REVISION.
6643
6644 Either call cat-log, cat-archive-log, or read the log from the log library.
6645
6646 REVISION must be specified as a list.  If TREE is provided, try a
6647 cat-log in TREE preferably.  Otherwise, try a cat-log in the local
6648 directory.  If both are impossible, run cat-archive-log.  (same result,
6649 but needs to retrieve something from the archive).
6650
6651 Call the function ASYNC-HANDLER in the created buffer, with arguments
6652  (output error status arguments)."
6653   ;;  (message "xetla-cat-log-any %S" revision)
6654   ;; See if the log is in the log library
6655   (when xetla-log-library-greedy
6656     (if (not (file-directory-p xetla-log-library))
6657         (make-directory xetla-log-library)))
6658   (let* ((lib-log (concat (file-name-as-directory xetla-log-library)
6659                           (xetla-name-construct revision)))
6660          (buffer
6661           (or (get-file-buffer lib-log)
6662               (when (file-exists-p lib-log)
6663                 (let* ((name (concat " *xetla-log("
6664                                      (xetla-name-construct revision) ")*")))
6665                   (or (get-buffer name)
6666                       ;; Surprisingly, (rename-buffer) didn't rename
6667                       ;; anything here. Solution: Create a buffer with
6668                       ;; the right name, and simulate a find-file.
6669                       (with-current-buffer
6670                           (get-buffer-create name)
6671                         (insert-file-contents lib-log)
6672                         (set-visited-file-name lib-log)
6673                         (rename-buffer name)
6674                         (set-buffer-modified-p nil)
6675                         (current-buffer))))))))
6676     (if buffer
6677         (if async-handler
6678             (funcall async-handler buffer nil 0 "cat-log")
6679           buffer)
6680       ;; Try a cat-log
6681       (let* ((revision-string (xetla-name-construct revision)))
6682         (let ((run-mode (if async-handler 'xetla-run-tla-async 'xetla-run-tla-sync))
6683               (handler (if async-handler
6684                            `(lambda (output error status arguments)
6685                               (with-current-buffer output
6686                                 (xetla-maybe-save-log ',revision))
6687                               (funcall ,async-handler output error status
6688                                        arguments))
6689                          `(lambda (output error status arguments)
6690                             (with-current-buffer output
6691                               (xetla-maybe-save-log ',revision))))))
6692           (xetla-run-tla-sync ;; Anyway, tla cat-log is fast, so, no
6693            ;; need for an asynchronous process. For some reason,
6694            ;; running it asynchronously caused a random bug when
6695            ;; running tla remotely.
6696            (list "cat-log" revision-string)
6697            :finished handler
6698            ;; cat-log failed: cat-archive-log is needed
6699            :error `(lambda (output error status arguments)
6700                      (funcall ',run-mode
6701                               (list "cat-archive-log"
6702                                     ,revision-string)
6703                               :finished ',handler))))))))
6704
6705 ;; Obsolete
6706 (defun xetla-log-merges (revision &optional callback)
6707   "Return a list that will contain patches merged by REVISION.
6708 When the list has been filled in, CALLBACK is called with no arguments."
6709   (let ((merges (list "")))
6710     (xetla-cat-log-any
6711      revision nil
6712      `(lambda (output error status args)
6713         (with-current-buffer output
6714           (goto-char (point-min))
6715           (unwind-protect
6716               (let ((list (split-string
6717                            (buffer-substring-no-properties
6718                             (re-search-forward "^New-patches: ")
6719                             (progn (re-search-forward "^[^\t ]")
6720                                    (beginning-of-line) (point))))))
6721                 (setq list
6722                       (remove (xetla-name-construct
6723                                ',revision)
6724                               list))
6725                 (setcar ',merges (car list))
6726                 (setcdr ',merges (cdr list)))
6727             (when ',callback (funcall ',callback))
6728             (kill-buffer nil)))))
6729     merges))
6730
6731 ;; --------------------------------------
6732 ;; xetla-log-edit-mode:
6733 ;; --------------------------------------
6734 (defun xetla-log-edit-next-field ()
6735   "Go to next field in a log edition."
6736   (interactive)
6737   (let ((in-field (string-match "^\\([A-Z][A-Za-z]*\\(: ?\\)?\\)?$"
6738                                 (buffer-substring
6739                                  (point-at-bol) (point)))))
6740     (if (and in-field
6741              (string-match "^[A-Z][A-Za-z]*: $"
6742 \0                          (buffer-substring
6743                             (point-at-bol) (point))))
6744         (forward-line))
6745     (if in-field (beginning-of-line) (forward-line 1))
6746     (or (and (looking-at "^[A-Z][a-zA-Z]*: ")
6747              (goto-char (match-end 0)))
6748         (and (looking-at "^[A-Z][a-zA-Z]*:$")
6749              (goto-char (match-end 0))
6750              (progn (insert " ") t))
6751         (goto-char (point-max)))))
6752
6753 (defun xetla-log-goto-field (field)
6754   "Go to FIELD in a log file."
6755   (goto-char (point-min))
6756   (re-search-forward field)
6757   (save-excursion
6758     (if (not (looking-at " "))
6759         (insert " ")))
6760   (forward-char 1))
6761
6762 (defun xetla-log-goto-summary ()
6763   "Go to the Summary field in a log file."
6764   (interactive)
6765   (xetla-log-goto-field "^Summary:"))
6766
6767 (defun xetla-log-goto-keywords ()
6768   "Go to the Keywords field in a log file."
6769   (interactive)
6770   (xetla-log-goto-field "^Keywords:"))
6771
6772 (defun xetla-log-goto-body ()
6773   "Go to the Body in a log file."
6774   (interactive)
6775   (goto-char (point-min))
6776   (forward-line 3))
6777
6778 (defun xetla-log-kill-body ()
6779   "Kill the content of the log file body."
6780   (interactive)
6781   (xetla-log-goto-body)
6782   (kill-region (point) (point-max)))
6783
6784 ;;;###autoload(add-to-list 'auto-mode-alist '("\\+\\+log\\." . xetla-log-edit-mode))
6785
6786 ;;;###autoload
6787 (define-derived-mode xetla-log-edit-mode text-mode "xetla-log-edit"
6788   "Major Mode to edit xetla log messages.
6789 Commands:
6790 \\{xetla-log-edit-mode-map}
6791 "
6792   (use-local-map xetla-log-edit-mode-map)
6793   (easy-menu-add xetla-log-edit-mode-menu)
6794   (set (make-local-variable 'font-lock-defaults)
6795        '(xetla-log-edit-font-lock-keywords t))
6796   (font-lock-mode)
6797   (setq fill-column 73)
6798   (run-hooks 'xetla-log-edit-mode-hook))
6799
6800 (defun xetla-log-edit-abort ()
6801   "Abort the current log edit."
6802   (interactive)
6803   (bury-buffer)
6804   (set-window-configuration xetla-pre-commit-window-configuration))
6805
6806 (autoload (quote xetla-tips-popup-maybe) "xetla-tips" "\
6807 Pops up a buffer with a tip if tips are enabled (see
6808 `xetla-tips-enabled')" nil nil)
6809
6810 (defun xetla-log-edit-done (&optional commit version-flag)
6811   "Save the current log edit.
6812
6813 When optional argument COMMIT is non-nil, run `tla commit'.
6814
6815 Optional argument VERSION-FLAG is for specifying either a `seal'
6816 commit or a `fix' commit.  It is a symbol and can be either `seal' or
6817 `fix'.
6818
6819 Both COMMIT and VERSION-FLAG are really meant for non-interactive
6820 use.  When this function is called interactively the same thing can
6821 be achieved through prefix arguments...
6822
6823 With a single prefix arg, run `tla commit'.
6824 With 2 prefix args, run `tla commit --seal'.
6825 With 3 prefix args, run `tla commit --fix'."
6826   (interactive "p")
6827   (save-buffer)
6828   (let ((log-buffer (current-buffer))
6829         (commit (car current-prefix-arg))
6830         (type version-flag)
6831         (dir default-directory))
6832     (pop-window-configuration)
6833     (when (interactive-p)
6834       (cond ((eq commit 4)
6835              (setq type nil))
6836             ((eq commit 16)
6837              (setq type 'seal))
6838             ((eq commit 64)
6839              (setq type 'fix))
6840             (t
6841              (setq type nil))))
6842     (if (not commit)
6843         (bury-buffer log-buffer)
6844       (if type
6845           (funcall (intern (format "xetla-commit-%s" type)))
6846         (if (string-match "--version\\(-\\|fix-\\)+"
6847                       (xetla-get-current-revision dir))
6848             (error "Can't commit to sealed archive without --fix")
6849           (kill-buffer log-buffer)
6850           (xetla-commit
6851            (lambda (output error status args)
6852              (xetla-tips-popup-maybe))))))))
6853
6854 (defun xetla-archive-maintainer-name (version)
6855   "Return the maintainer name for a given VERSION.
6856 This function looks in the bookmarks file for the nickname field and
6857 returns it.
6858 If the nickname field is not present, just return the archive name for
6859 VERSION."
6860   (xetla-bookmarks-get-field version 'nickname (xetla-name-archive version)))
6861
6862 (defun xetla-archive-maintainer-id (archive &optional shorter)
6863   "Return my-id substring from ARCHIVE.
6864 If SHORTER is non-nil, return login name part of the my-id substring.
6865 E.g. If ARCHIVE is x@y.z-a, the result is x@y.z.
6866 If SHORTER is non-nil, the result is x."
6867   (if (string-match "\\(\\(.+\\)@.+\\)--.+" archive)
6868       (if shorter
6869           (match-string 2 archive)
6870         (match-string 1 archive))))
6871
6872 (defun xetla-archive-default-maintainer-name (version)
6873   "Return a suitable maintainer name or version name for VERSION.
6874 Either the nickname if defined in the bookmarks, or the left hand side
6875 of the email in the archive name."
6876   (or (xetla-archive-maintainer-name version)
6877       (xetla-archive-maintainer-id (xetla-name-archive version) t)))
6878
6879 (defun xetla-merge-summary-end-of-sequence (string low high)
6880   "Pretty-print a range of merged patches.
6881 STRING is an identifier for this merge, while LOW and HIGH are the lowest
6882 and highest patches that were merged."
6883   (let ((elem
6884          (if (= low high)
6885              ;; singleton
6886              (int-to-string low)
6887            (format "%d-%d" low high))))
6888     (if (string= string "")
6889         (concat "patch " elem)
6890       (concat string ", " elem))))
6891
6892
6893 (defun xetla-merge-summary-line (mergelist)
6894   "Create a suitable log summary line for a list of merges.
6895 MERGELIST is an alist in the form
6896 \((maintainer1 12 13 14 25 26)
6897   ...
6898   (maintainerN num42))
6899 The return value is a string in the form
6900 \"maintainer1 (patch 12-14, 25-26), maintainerN (patch-num42)\""
6901   (let ((res ""))
6902     (while mergelist
6903       (let ((patch-list (sort (cdar mergelist) '<))
6904             (list-string "")
6905             last-patch-number-low
6906             last-patch-number-high)
6907         ;; patch-list is the list of patch numbers.
6908         (while patch-list
6909           (unless last-patch-number-low
6910             (setq last-patch-number-low (car patch-list))
6911             (setq last-patch-number-high (- (car patch-list) 1)))
6912           (if (= (1+ last-patch-number-high) (car patch-list))
6913               ;; normal sequence
6914               (setq last-patch-number-high (car patch-list))
6915             (setq list-string
6916                   (xetla-merge-summary-end-of-sequence
6917                    list-string
6918                    last-patch-number-low
6919                    last-patch-number-high))
6920             (setq last-patch-number-low (car patch-list)))
6921           (setq last-patch-number-high (car patch-list))
6922           (setq patch-list (cdr patch-list)))
6923         (setq list-string
6924               (xetla-merge-summary-end-of-sequence
6925                list-string
6926                last-patch-number-low
6927                last-patch-number-high))
6928         (setq last-patch-number-low nil)
6929         (setq res
6930               (let ((maint (format "%s (%s)" (caar mergelist)
6931                                    list-string)))
6932                 (if (string= res "")
6933                     maint
6934                   (concat res ", " maint)))))
6935       (setq mergelist (cdr mergelist)))
6936     res))
6937
6938 (defun xetla-merge-summary-default-format-function (string)
6939   "Return an appropriate \"Merged from\" summary line for STRING.
6940
6941 Gets the 'summary-format field for that version in the bookmarks (or
6942 use \"Merged from %s\" by default), and calls
6943 \(format summary-format S)."
6944   (let ((format-string (xetla-bookmarks-get-field
6945                         (xetla-tree-version-list)
6946                         'summary-format
6947                         "Merged from %s")))
6948     (format format-string string)))
6949
6950 (defun xetla-merge-summary-line-for-log (&optional
6951                                        version-to-name-function
6952                                        generate-line-function
6953                                        format-line-function)
6954   "Generate an appropriate summary line after a merge.
6955 The generated line is of the form
6956 \"Merged from Robert (167-168, 170), Masatake (209, 213-215, 217-218)\".
6957 The names \"Robert\" and \"Masatake\" in this example are nicknames
6958 defined in the bookmarks for the corresponding versions.
6959
6960 First, an alist A like
6961  ((\"Robert\" 167 168 170) (\"Masatake\" 209 213 214 215 217 218))
6962 is generated.  If VERSION-TO-NAME-FUNCTION is non-nil, then it must be
6963 a function that is called with the version as an argument, and must
6964 return a string that will be used to instead of the nickname.
6965
6966 Then, a string S like
6967 \"Robert (167-168, 170), Masatake (209, 213-215, 217-218)\"
6968 is generated. This is done by default by `xetla-merge-summary-line',
6969 which can be overridden by GENERATE-LINE-FUNCTION.
6970
6971 Then, the function FORMAT-LINE-FUNCTION is called with this string S
6972 as an argument. If FORMAT-LINE-FUNCTION is nil, then,
6973 `xetla-merge-summary-default-format-function' is called. It retrieves
6974 the fields summary-format from the bookmark for the tree version, and
6975 calls (format summary-format S)."
6976   (save-excursion
6977     (let ((rev-list)
6978           (maintainer)
6979           (rev)
6980           (patch-list))
6981       (goto-char (point-min))
6982       (while (re-search-forward "^ \\* \\(.+@.+--.+/.+--.+\\)$" nil t)
6983         (setq rev-list (xetla-name-split (match-string 1)))
6984         (setq maintainer (funcall (or version-to-name-function
6985                                       'xetla-archive-default-maintainer-name)
6986                                   rev-list))
6987         (setq rev (cadr (split-string (xetla-name-revision rev-list) "-")))
6988         (add-to-list 'patch-list (list maintainer rev)))
6989       ;; patch-list has now the form
6990       ;; ((maintainer1 num1) (maintainer1 num2) ... (maintainerN num42))
6991       (let ((alist))
6992         (while patch-list
6993           (let* ((elem (car patch-list))
6994                  (patch-number-list (assoc (car elem) alist)))
6995             (if patch-number-list
6996                 ;; This maintainer already has a patch in the list
6997                 (setcdr patch-number-list
6998                         (cons (string-to-number (cadr elem))
6999                               (cdr patch-number-list)))
7000               ;; First patch for this maintainer. add
7001               ;; (maintainer patch-number) to the alist.
7002               (setq alist (cons (list (car elem)
7003                                       (string-to-number (cadr elem)))
7004                                 alist))))
7005           (setq patch-list (cdr patch-list)))
7006         ;; alist now has the form
7007         ;; ((maintainer1 num1 num2)
7008         ;;  ...
7009         ;;  (maintainerN num42))
7010         ;; where numX are of type integer.
7011         (funcall (or format-line-function
7012                      'xetla-merge-summary-default-format-function)
7013                  (funcall (or generate-line-function
7014                               'xetla-merge-summary-line) alist))))))
7015
7016 (defun xetla-log-edit-insert-log-for-merge-and-headers ()
7017   "Call `xetla-log-edit-insert-log-for-merge' with a prefix arg."
7018   (interactive)
7019   (xetla-log-edit-insert-log-for-merge t))
7020
7021 (defun xetla-log-edit-insert-log-for-merge (arg)
7022   "Insert the output of xetla log-for-merge at POINT.
7023
7024 When called with a prefix argument ARG, create a standard Merged from
7025 line as Summary with `xetla-merge-summary-line-for-log'."
7026   (interactive "P")
7027   (xetla-run-tla-sync '("log-for-merge")
7028                      :finished
7029                      `(lambda (output error status arguments)
7030                         (let ((content (xetla-buffer-content
7031                                         output)))
7032                           (if (= 0 (length content))
7033                               (error "There was no merge!"))
7034                           (with-current-buffer ,(current-buffer)
7035                             (let ((on-summary-line
7036                                    (= 1 (count-lines (point-min) (point))))
7037                                   (old-pos (point)))
7038                               (if on-summary-line
7039                                   (xetla-log-goto-body)
7040                                 (goto-char old-pos))
7041                               (insert content)))
7042                           (when arg
7043                             (xetla-log-goto-summary)
7044                             (delete-region (point) (point-at-eol))
7045                             (insert
7046                              (with-current-buffer output
7047                                (xetla-merge-summary-line-for-log)))
7048                             (xetla-log-goto-keywords)
7049                             (delete-region (point) (point-at-eol))
7050                             (insert "merge")
7051                             (xetla-log-goto-summary))))))
7052
7053
7054 (defun xetla-log-edit-insert-memorized-log ()
7055   "Insert a memorized log message."
7056   (interactive)
7057   (when xetla-memorized-log-header
7058     (xetla-log-goto-summary)
7059     (delete-region (point) (point-at-eol))
7060     (insert xetla-memorized-log-header))
7061   (when xetla-memorized-log-message
7062     (xetla-log-goto-body)
7063     (insert xetla-memorized-log-message)))
7064
7065
7066 ;; --------------------------------------
7067 ;; xetla-log-edit-insert-keywords:
7068 ;; --------------------------------------
7069
7070 (defvar xetla-log-edit-keywords-marked-list)
7071 (defvar xetla-log-edit-keywords-cookie)
7072 (defvar xetla-log-edit-keywords-log-buffer)
7073
7074 (defun xetla-log-edit-keywords-printer (elem)
7075   "If ELEM is a keyword, print it differently."
7076   (insert (if (member elem xetla-log-edit-keywords-marked-list)
7077               (concat xetla-mark " ") "  ")
7078           elem))
7079
7080 (defun xetla-log-edit-keywords (arg)
7081   "Add keywords listed in variable `xetla-log-edit-keywords'.
7082 When called with a prefix argument ARG, delete all current keywords."
7083   (interactive "P")
7084   (let ((current-keywords
7085          (save-excursion
7086            (xetla-log-goto-keywords)
7087            (buffer-substring (point) (point-at-eol))))
7088         (log-buffer (current-buffer))
7089         keywords)
7090     (setq current-keywords (replace-regexp-in-string "," " " current-keywords nil t)
7091           current-keywords (mapcar (lambda (k) (format "%s" k))
7092                                    (read (concat "(" current-keywords ")"))))
7093     (switch-to-buffer " *xetla-log-keywords*")
7094     (toggle-read-only 0)
7095     (erase-buffer)
7096     (make-local-variable 'xetla-log-edit-keywords)
7097     (make-local-variable 'xetla-log-edit-keywords-marked-list)
7098     (make-local-variable 'xetla-log-edit-keywords-cookie)
7099     (make-local-variable 'xetla-log-edit-keywords-log-buffer)
7100     (setq xetla-log-edit-keywords-log-buffer
7101           log-buffer
7102           xetla-log-edit-keywords-marked-list
7103           current-keywords
7104           xetla-log-edit-keywords-cookie
7105           (ewoc-create 'xetla-log-edit-keywords-printer
7106                        "List of keywords from `xetla-log-edit-keywords':"
7107                        (format "type C-c C-c to insert the marked keywords to the buffer\n%s"
7108                                (buffer-name log-buffer))))
7109
7110     (while current-keywords
7111       (add-to-list 'xetla-log-edit-keywords (car current-keywords))
7112       (setq current-keywords (cdr current-keywords)))
7113
7114     (setq keywords xetla-log-edit-keywords)
7115
7116     (while keywords
7117       (add-to-list 'xetla-log-edit-keywords (car keywords))
7118       (ewoc-enter-last xetla-log-edit-keywords-cookie (car keywords))
7119       (setq keywords (cdr keywords))))
7120
7121   (use-local-map xetla-log-edit-keywords-mode-map)
7122   (setq major-mode 'xetla-log-edit-keywords-mode)
7123   (setq mode-name "xetla-log-keywords")
7124   (toggle-read-only 1)
7125   (message "Type C-c C-c to finish.")
7126   (goto-char (point-min))
7127   (forward-line 1))
7128
7129 (defun xetla-log-edit-keywords-cursor-goto (elem)
7130   "Jump to the location of ELEM."
7131   (interactive)
7132   (goto-char (ewoc-location elem))
7133   (re-search-forward "^"))
7134
7135 (defun xetla-log-edit-keywords-next ()
7136   "Go to the next keyword."
7137   (interactive)
7138   (let* ((cookie xetla-log-edit-keywords-cookie)
7139          (elem (ewoc-locate cookie))
7140          (next (or (ewoc-next cookie elem) elem)))
7141     (xetla-log-edit-keywords-cursor-goto next)))
7142
7143 (defun xetla-log-edit-keywords-previous ()
7144   "Go to the previous keyword."
7145   (interactive)
7146   (let* ((cookie xetla-log-edit-keywords-cookie)
7147          (elem (ewoc-locate cookie))
7148          (previous (or (ewoc-prev cookie elem) elem)))
7149     (xetla-log-edit-keywords-cursor-goto previous)))
7150
7151 (defun xetla-log-edit-keywords-mark ()
7152   "Mark the current keyword."
7153   (interactive)
7154   (let ((pos (point)))
7155     (add-to-list 'xetla-log-edit-keywords-marked-list
7156                  (ewoc-data (ewoc-locate xetla-log-edit-keywords-cookie)))
7157     (ewoc-refresh xetla-log-edit-keywords-cookie)
7158     (goto-char pos))
7159   (xetla-log-edit-keywords-next))
7160
7161 (defun xetla-log-edit-keywords-unmark ()
7162   "Unmark the current keyword."
7163   (interactive)
7164   (let ((pos (point)))
7165     (setq xetla-log-edit-keywords-marked-list
7166           (delete (ewoc-data (ewoc-locate xetla-log-edit-keywords-cookie))
7167                   xetla-log-edit-keywords-marked-list))
7168     (ewoc-refresh xetla-log-edit-keywords-cookie)
7169     (goto-char pos))
7170   (xetla-log-edit-keywords-next))
7171
7172 (defun xetla-log-edit-keywords-unmark-all ()
7173   "Unmark all marked keywords."
7174   (interactive)
7175   (let ((pos (point)))
7176     (setq xetla-log-edit-keywords-marked-list nil)
7177     (ewoc-refresh xetla-log-edit-keywords-cookie)
7178     (goto-char pos)))
7179
7180 (defun xetla-log-edit-keywords-mark-all ()
7181   "Mark all keywords."
7182   (interactive)
7183   (let ((pos (point)))
7184     (setq xetla-log-edit-keywords-marked-list xetla-log-edit-keywords)
7185     (ewoc-refresh xetla-log-edit-keywords-cookie)
7186     (goto-char pos)))
7187
7188 (defun xetla-log-edit-keywords-toggle-mark ()
7189   "Toggle marking of the current keyword."
7190   (interactive)
7191   (let ((pos (point)))
7192     (if (member (ewoc-data (ewoc-locate xetla-log-edit-keywords-cookie))
7193                 xetla-log-edit-keywords-marked-list)
7194         (xetla-log-edit-keywords-unmark)
7195       (xetla-log-edit-keywords-mark))
7196     (ewoc-refresh xetla-log-edit-keywords-cookie)
7197     (goto-char pos)))
7198
7199 (defun xetla-log-edit-keywords-insert ()
7200   "Insert marked keywords into log buffer."
7201   (interactive)
7202   (let ((keywords xetla-log-edit-keywords-marked-list))
7203     (switch-to-buffer xetla-log-edit-keywords-log-buffer)
7204     (kill-buffer " *xetla-log-keywords*")
7205     (save-excursion
7206       (xetla-log-goto-keywords)
7207       (delete-region (point) (point-at-eol))
7208       (insert (mapconcat 'identity (reverse keywords) ", ")))))
7209
7210 ;; --------------------------------------
7211 ;; xetla-archive-list-mode:
7212 ;; --------------------------------------
7213 (defun xetla-archive-mirror-archive ()
7214   "Mirror the archive at point."
7215   (interactive)
7216   (let ((archive-info (xetla-get-archive-info)))
7217     (when archive-info
7218       (xetla-mirror-archive archive-info)
7219       (xetla-archives))))
7220
7221 (defun xetla-archive-synchronize-archive ()
7222   "Synchronizes the mirror for the archive at point."
7223   (interactive)
7224   (let ((archive-info (xetla-get-archive-info)))
7225     (when archive-info
7226       (xetla-archive-mirror archive-info))))
7227
7228 (defun xetla-archive-list-mode ()
7229   "Major Mode to show arch archives:
7230 \\{xetla-archive-list-mode-map}"
7231   (interactive)
7232   (kill-all-local-variables)
7233   (use-local-map xetla-archive-list-mode-map)
7234   (easy-menu-add xetla-archive-list-mode-menu)
7235   (setq major-mode 'xetla-archive-list-mode)
7236   (setq mode-name "xetla-archives")
7237
7238   (toggle-read-only 1)
7239   (set-buffer-modified-p nil)
7240   (set (make-local-variable 'xetla-get-revision-info-at-point-function)
7241        'xetla-get-archive-info-at-point)
7242   (run-hooks 'xetla-archive-list-mode-hook))
7243
7244 (defun xetla-get-archive-info-at-point ()
7245   "Get archive information."
7246   (list 'archive (xetla-get-archive-info)))
7247
7248 (defun xetla-archive-select-default ()
7249   "Select the default archive."
7250   (interactive)
7251   (when (xetla-get-archive-info)
7252     (let ((pos (point)))
7253       (xetla-my-default-archive (xetla-get-archive-info))
7254       (xetla-archives)
7255       (goto-char pos))))
7256
7257 (defun xetla-archive-unregister-archive ()
7258   "Delete the registration of the selected archive."
7259   (interactive)
7260   (let ((archive (xetla-get-archive-info)))
7261     (if archive
7262         (progn (xetla-unregister-archive archive t)
7263                (xetla-archives))
7264       (error "No archive under the point"))))
7265
7266 (defun xetla-archive-edit-archive-location ()
7267   "Edit the archive location for a archive.
7268 This is done by unregistering the archive, followed by a new registration with
7269 the new location."
7270   (interactive)
7271   (let ((archive (xetla-get-archive-info)))
7272     (xetla-edit-archive-location archive)
7273     (save-excursion
7274       (xetla-archives))))
7275
7276 (defun xetla-archive-use-as-default-mirror ()
7277   "Use the mirror archive as default mirror."
7278   (interactive)
7279   (let ((archive (xetla-get-archive-info)))
7280     (xetla-use-as-default-mirror archive)
7281     (save-excursion
7282       (xetla-archives))))
7283
7284 (defun xetla-archive-list-categories ()
7285   "List the categories for the current archive."
7286   (interactive)
7287   (let ((archive (xetla-get-archive-info)))
7288     (if archive
7289         (xetla-categories archive)
7290       (error "No archive under the point"))))
7291
7292 (xetla-make-bymouse-function xetla-archive-list-categories)
7293
7294 (defun xetla-archive-browse-archive ()
7295   "Browse the current archive."
7296   (interactive)
7297   (let ((archive (xetla-get-archive-info)))
7298     (if archive
7299         (xetla-browse-archive archive)
7300       (error "No archive under the point"))))
7301
7302 (defun xetla-archive-next ()
7303   "Go to the next archive."
7304   (interactive)
7305   (forward-line 2)
7306   (beginning-of-line))
7307
7308 (defun xetla-archive-previous ()
7309   "Go to the previous archive."
7310   (interactive)
7311   (forward-line -2)
7312   (beginning-of-line))
7313
7314 (defun xetla-save-archive-to-kill-ring ()
7315   "Save the name of the current archive to the kill ring."
7316   (interactive)
7317   (let ((archive (or (xetla-get-archive-info)
7318                      xetla-buffer-archive-name
7319                      (xetla-name-archive (xetla-tree-version-list nil 'no-error)))))
7320     (unless archive
7321       (error "No archive name associated with current buffer"))
7322     (kill-new archive)
7323     (if (interactive-p)
7324         (message "%s" archive))
7325     archive))
7326
7327 ;; --------------------------------------
7328 ;; xetla-category-list-mode:
7329 ;; --------------------------------------
7330 (defun xetla-category-list-mode ()
7331   "Major Mode to show arch categories:
7332 \\{xetla-category-list-mode-map}"
7333   (interactive)
7334   (kill-all-local-variables)
7335   (use-local-map xetla-category-list-mode-map)
7336   (easy-menu-add xetla-category-list-mode-menu)
7337   (setq major-mode 'xetla-category-list-mode)
7338   (setq mode-name "xetla-category")
7339   (add-hook 'xetla-make-category-hook 'xetla-category-refresh)
7340
7341   (toggle-read-only 1)
7342   (set-buffer-modified-p nil)
7343   (set (make-local-variable 'xetla-get-revision-info-at-point-function)
7344        'xetla-get-category-info-at-point)
7345   (run-hooks 'xetla-category-list-mode-hook))
7346
7347 (defun xetla-get-category-info-at-point ()
7348   "Get archive/category-branch information."
7349   (let ((buffer-version (xetla-name-construct
7350                          xetla-buffer-archive-name
7351                          (xetla-get-archive-info 'xetla-category-info))))
7352     (list 'category buffer-version)))
7353
7354 (defun xetla-category-list-branches ()
7355   "List branches of the current category."
7356   (interactive)
7357   (let ((category (xetla-get-archive-info 'xetla-category-info)))
7358     (if category
7359         (xetla-branches xetla-buffer-archive-name category)
7360       (error "No category under the point"))))
7361
7362 (xetla-make-bymouse-function xetla-category-list-branches)
7363
7364 (defun xetla-category-make-category (category)
7365   "Create a new category named CATEGORY."
7366   (interactive "sCategory name: ")
7367   (xetla-make-category xetla-buffer-archive-name category))
7368
7369 (defun xetla-category-refresh ()
7370   "Refresh the current category list."
7371   (interactive)
7372   (xetla-categories xetla-buffer-archive-name))
7373
7374 (defun xetla-category-next ()
7375   "Move to the next category."
7376   (interactive)
7377   (forward-line 1)
7378   (beginning-of-line))
7379
7380 (defun xetla-category-previous ()
7381   "Move to the previous category."
7382   (interactive)
7383   (forward-line -1)
7384   (beginning-of-line)
7385   (unless (looking-at "^   ")
7386     (forward-line 1)))
7387
7388 (defun xetla-category-mirror-archive ()
7389   "Mirror the current category."
7390   (interactive)
7391   (let ((category (xetla-get-archive-info 'xetla-category-info)))
7392     (unless category
7393       (error "No category at point"))
7394     (xetla-archive-mirror xetla-buffer-archive-name
7395                         category)))
7396
7397
7398 (defun xetla-category-bookmarks-add-here (name)
7399   "Add a bookmark named NAME for this category."
7400   (interactive "sBookmark name: ")
7401   (xetla-bookmarks-add name
7402                      (list xetla-buffer-archive-name
7403                            (xetla-get-archive-info 'xetla-category-info)
7404                            nil nil nil))
7405   (message "bookmark %s added." name))
7406
7407 (defun xetla-category-bookmarks-add (name)
7408   "Add a bookmark named NAME for this category."
7409   (interactive "sBookmark name: ")
7410   (xetla-bookmarks-add name
7411                      (list xetla-buffer-archive-name nil nil nil))
7412   (message "bookmark %s added." name))
7413
7414 ;; --------------------------------------
7415 ;; xetla-branch-list-mode
7416 ;; --------------------------------------
7417 (defun xetla-branch-list-mode ()
7418   "Major Mode to show arch branches:
7419 \\{xetla-branch-list-mode-map}"
7420   (interactive)
7421   (kill-all-local-variables)
7422   (use-local-map xetla-branch-list-mode-map)
7423   (easy-menu-add xetla-branch-list-mode-menu)
7424   (setq major-mode 'xetla-branch-list-mode)
7425   (setq mode-name "xetla-branch")
7426   (add-hook 'xetla-make-branch-hook 'xetla-branch-refresh)
7427
7428   (toggle-read-only 1)
7429   (set-buffer-modified-p nil)
7430   (set (make-local-variable 'xetla-get-revision-info-at-point-function)
7431        'xetla-get-branch-info-at-point)
7432   (run-hooks 'xetla-branch-list-mode-hook))
7433
7434 (defun xetla-get-branch-info-at-point ()
7435   "Get archive/category-branch-version information."
7436   (let ((buffer-version (xetla-name-construct
7437                          xetla-buffer-archive-name
7438                          xetla-buffer-category-name
7439                          (xetla-get-archive-info 'xetla-branch-info))))
7440     (list 'branch buffer-version)))
7441
7442 (defun xetla-branch-make-branch (branch)
7443   "Create a new branch named BRANCH."
7444   (interactive "sBranch name: ")
7445   (xetla-make-branch xetla-buffer-archive-name
7446                    xetla-buffer-category-name
7447                    branch))
7448
7449 (defun xetla-branch-refresh ()
7450   "Refresh the current branch list."
7451   (interactive)
7452   (xetla-branches
7453    xetla-buffer-archive-name
7454    xetla-buffer-category-name))
7455
7456 (defun xetla-branch-list-parent-category ()
7457   "List the parent category of the current branch."
7458   (interactive)
7459   (xetla-categories xetla-buffer-archive-name))
7460
7461 (defun xetla-branch-list-versions ()
7462   "List the versions of the current branch."
7463   (interactive)
7464   (let ((branch (xetla-get-archive-info 'xetla-branch-info)))
7465     (if branch
7466         (xetla-versions xetla-buffer-archive-name
7467                       xetla-buffer-category-name
7468                       branch)
7469       (error "No branch under the point"))))
7470
7471 (xetla-make-bymouse-function xetla-branch-list-versions)
7472
7473 (defun xetla-branch-mirror-archive ()
7474   "Mirror the current branch."
7475   (interactive)
7476   (let ((branch (xetla-get-archive-info 'xetla-branch-info)))
7477     (unless branch
7478       (error "No branch under the point"))
7479     (xetla-archive-mirror xetla-buffer-archive-name
7480                         xetla-buffer-category-name
7481                         branch)))
7482
7483 (defun xetla-branch-get-branch (directory)
7484   "Get the current branch and place it in DIRECTORY."
7485   (interactive (list (expand-file-name
7486                       (read-directory-name
7487                        (format "Restore \"%s\" to: "
7488                                (let ((branch
7489                                       (xetla-get-archive-info 'xetla-branch-info)))
7490                                  (unless branch
7491                                    (error "No branch under the point"))
7492                                  (xetla-name-construct
7493                                   xetla-buffer-archive-name
7494                                   xetla-buffer-category-name
7495                                   branch)))))))
7496   (let ((branch (xetla-get-archive-info 'xetla-branch-info)))
7497     (if branch
7498         (xetla-get directory
7499                  t
7500                  xetla-buffer-archive-name
7501                  xetla-buffer-category-name
7502                  branch)
7503       (error "No branch under the point"))))
7504
7505 (defun xetla-branch-bookmarks-add-here (name)
7506   "Add a bookmark named NAME for the current branch."
7507   (interactive "sBookmark name: ")
7508   (xetla-bookmarks-add name
7509                      (list xetla-buffer-archive-name
7510                            xetla-buffer-category-name
7511                            (xetla-get-archive-info 'xetla-branch-info)
7512                            nil nil))
7513   (message "bookmark %s added." name))
7514
7515 (defun xetla-branch-bookmarks-add (name)
7516   "Add a bookmark named NAME for the current branch."
7517   (interactive "sBookmark name: ")
7518   (xetla-bookmarks-add name
7519                      (list xetla-buffer-archive-name
7520                            xetla-buffer-category-name
7521                            nil nil nil))
7522   (message "bookmark %s added." name))
7523
7524
7525
7526
7527 ;; --------------------------------------
7528 ;; xetla-version-list-mode
7529 ;; --------------------------------------
7530 (defun xetla-version-list-mode ()
7531   "Major Mode to show arch versions:
7532 \\{xetla-version-list-mode-map}"
7533   (interactive)
7534   (kill-all-local-variables)
7535   (use-local-map xetla-version-list-mode-map)
7536   (easy-menu-add xetla-version-list-mode-menu)
7537   (setq major-mode 'xetla-version-list-mode)
7538   (setq mode-name "xetla-version")
7539   (add-hook 'xetla-make-version-hook 'xetla-version-refresh)
7540
7541   (toggle-read-only 1)
7542   (set-buffer-modified-p nil)
7543   (set (make-local-variable 'xetla-get-revision-info-at-point-function)
7544        'xetla-get-version-info-at-point)
7545   (run-hooks 'xetla-version-list-mode-hook))
7546
7547 (defun xetla-get-version-info-at-point ()
7548   "Get archive/category-branch-version-revision information."
7549   (let ((buffer-version (xetla-name-construct
7550                          xetla-buffer-archive-name
7551                          xetla-buffer-category-name
7552                          xetla-buffer-branch-name
7553                          (xetla-get-archive-info 'xetla-version-info))))
7554     (list 'version buffer-version)))
7555
7556 (defun xetla-version-refresh ()
7557   "Refresh the current version list."
7558   (interactive)
7559   (xetla-versions
7560    xetla-buffer-archive-name
7561    xetla-buffer-category-name
7562    xetla-buffer-branch-name))
7563
7564 (defun xetla-version-list-parent-branch ()
7565   "List the parent branch of this version."
7566   (interactive)
7567   (xetla-branches xetla-buffer-archive-name
7568                 xetla-buffer-category-name))
7569
7570 (defun xetla-version-list-revisions ()
7571   "List the revisions of this version."
7572   (interactive)
7573   (let ((version (xetla-get-archive-info 'xetla-version-info)))
7574     (if version
7575         (xetla-revisions xetla-buffer-archive-name
7576                        xetla-buffer-category-name
7577                        xetla-buffer-branch-name
7578                        version)
7579       (error "No version under the point"))))
7580
7581 (xetla-make-bymouse-function xetla-version-list-revisions)
7582
7583 (defun xetla-version-make-version (version)
7584   "Create a new version named VERSION."
7585   (interactive "sVersion name: ")
7586   (xetla-make-version xetla-buffer-archive-name
7587                     xetla-buffer-category-name
7588                     xetla-buffer-branch-name
7589                     version))
7590
7591 (defun xetla-version-bookmarks-add-here (name)
7592   "Add a bookmark named NAME for the current version."
7593   (interactive "sBookmark name: ")
7594   (xetla-bookmarks-add name
7595                      (list xetla-buffer-archive-name
7596                            xetla-buffer-category-name
7597                            xetla-buffer-branch-name
7598                            (xetla-get-archive-info 'xetla-version-info)
7599                            nil))
7600   (message "bookmark %s added." name))
7601
7602 (defun xetla-version-bookmarks-add (name)
7603   "Add a bookmark named NAME for the current version."
7604   (interactive "sBookmark name: ")
7605   (xetla-bookmarks-add name
7606                      (list xetla-buffer-archive-name
7607                            xetla-buffer-category-name
7608                            xetla-buffer-branch-name
7609                            nil nil))
7610   (message "bookmark %s added." name))
7611
7612 (defun xetla-version-get-version (directory)
7613   "Get a version and place it in DIRECTORY."
7614   (interactive (list (expand-file-name
7615                       (read-directory-name
7616                        (format "Restore \"%s\" to: "
7617                                (let ((version
7618                                       (xetla-get-archive-info 'xetla-version-info)))
7619                                  (unless version
7620                                    (error "No version under the point"))
7621                                  (xetla-name-construct
7622                                   xetla-buffer-archive-name
7623                                   xetla-buffer-category-name
7624                                   xetla-buffer-branch-name
7625                                   version)))))))
7626   (let ((version (xetla-get-archive-info 'xetla-version-info)))
7627     (if version
7628         (xetla-get directory
7629                  t
7630                  xetla-buffer-archive-name
7631                  xetla-buffer-category-name
7632                  xetla-buffer-branch-name
7633                  version)
7634       (error "No version under the point"))))
7635
7636
7637 (defun xetla-version-mirror-archive ()
7638   "Mirror the current version."
7639   (interactive)
7640   (let ((version (xetla-get-archive-info 'xetla-version-info)))
7641     (if version
7642         (xetla-archive-mirror xetla-buffer-archive-name
7643                             xetla-buffer-category-name
7644                             xetla-buffer-branch-name
7645                             version))))
7646
7647 (defun xetla-version-tag (to-archive to-category to-branch to-version)
7648   "Run tla tag from the current location in version buffer.
7649 The tag is created in TO-ARCHIVE/TO-CATEGORY-TO-BRANCH-TO-VERSION."
7650   (interactive
7651    (let ((l (xetla-name-read "Tag to: " 'prompt 'prompt 'prompt 'prompt)))
7652      (list
7653       (xetla-name-archive l)
7654       (xetla-name-category l)
7655       (xetla-name-branch l)
7656       (xetla-name-version l))))
7657   (let ((to-fq (xetla-name-construct to-archive
7658                                     to-category
7659                                     to-branch
7660                                     to-version))
7661         from-fq
7662         (from-version (xetla-get-archive-info 'xetla-version-info)))
7663     (unless from-version
7664       (error "No version under the point"))
7665     (setq from-fq (xetla-name-construct
7666                    xetla-buffer-archive-name
7667                    xetla-buffer-category-name
7668                    xetla-buffer-branch-name
7669                    from-version))
7670     (xetla-version-tag-internal from-fq to-fq)))
7671
7672
7673 (defun xetla-version-tag-internal (from-fq to-fq &optional synchronously)
7674   "Create a tag from FROM-FQ to TO-FQ.
7675 If SYNCHRONOUSLY is non-nil, internal `xetla-get' runs synchronously.
7676 Else it runs asynchronously."
7677   (when (yes-or-no-p (format "Create a tag from `%s' to `%s'? " from-fq to-fq))
7678     (unless (xetla-tag from-fq to-fq)
7679       (error "Fail to create a tag"))
7680     (when (y-or-n-p "Tag created.  Get a copy of this revision? ")
7681       (let* ((prompt "Get a copy in: ")
7682              dir parent
7683              to-fq-split)
7684         (while (not dir)
7685           (setq dir (read-directory-name prompt dir)
7686                 parent (expand-file-name
7687                         (concat (file-name-as-directory dir) "..")))
7688           (cond
7689            ;; Parent directoy must be.
7690            ((not (file-directory-p parent))
7691             (message "`%s' is not directory" parent)
7692             (sit-for 2)
7693             (setq dir nil))
7694            ;; dir itself must not be.
7695            ((file-exists-p dir)
7696             (message "`%s' exists already" dir)
7697             (sit-for 2)
7698             (setq dir nil))))
7699         (setq to-fq-split (xetla-name-split to-fq))
7700         (xetla-get dir 'ask
7701                  (nth 0 to-fq-split)
7702                  (nth 1 to-fq-split)
7703                  (nth 2 to-fq-split)
7704                  (nth 3 to-fq-split)
7705                  (nth 4 to-fq-split)
7706                  synchronously)))))
7707
7708 ;; --------------------------------------
7709 ;; xetla-revision-list-mode
7710 ;; --------------------------------------
7711 (defun xetla-revision-list-mode ()
7712   "Major Mode to show arch revisions:
7713 \\{xetla-revision-list-mode-map}"
7714   (interactive)
7715   (kill-all-local-variables)
7716   (toggle-read-only -1)
7717   (use-local-map xetla-revision-list-mode-map)
7718   (easy-menu-add xetla-revision-list-mode-menu)
7719   (setq major-mode 'xetla-revision-list-mode)
7720   (setq mode-name "xetla-revision")
7721   (add-hook 'xetla-make-revision-hook 'xetla-revision-refresh)
7722   (erase-buffer)
7723   (set (make-local-variable 'xetla-revision-list-cookie)
7724        (ewoc-create 'xetla-revision-list-printer))
7725   (toggle-read-only 1)
7726   (set-buffer-modified-p nil)
7727   (set (make-local-variable 'xetla-get-revision-info-at-point-function)
7728        'xetla-get-revision-info-at-point)
7729   (setq mode-line-process 'xetla-mode-line-process)
7730   (run-hooks 'xetla-revision-list-mode-hook))
7731
7732 (defun xetla-get-revision-info-at-point ()
7733   "Get archive/category-branch-version-revision-patch information.
7734 Returns nil if not on a revision list, or not on a revision entry in a
7735 revision list."
7736   (let ((elem (ewoc-data (ewoc-locate xetla-revision-list-cookie))))
7737     (when (eq (car elem) 'entry-patch)
7738       (let* ((full (xetla-revision-revision (caddr elem)))
7739              (buffer-revision (xetla-name-construct full)))
7740         (list 'revision buffer-revision)))))
7741
7742 (defun xetla-revision-refresh ()
7743   "Refresh the current list of revisions."
7744   (interactive)
7745   (xetla-revisions
7746    xetla-buffer-archive-name
7747    xetla-buffer-category-name
7748    xetla-buffer-branch-name
7749    xetla-buffer-version-name))
7750
7751 (defun xetla-revision-list-parent-version ()
7752   "List the versions of the parent of this revision."
7753   (interactive)
7754   (xetla-versions xetla-buffer-archive-name
7755                 xetla-buffer-category-name
7756                 xetla-buffer-branch-name))
7757
7758 (defun xetla-revision-get-revision (directory archive category branch
7759                                             version revision)
7760   "Get a revision and place it in DIRECTORY.
7761 The revision is named by ARCHIVE/CATEGORY-BRANCH-VERSION-REVISION."
7762   (interactive
7763    (let* ((elem (ewoc-data (ewoc-locate xetla-revision-list-cookie)))
7764           (full (xetla-revision-revision (caddr elem)))
7765           (revision (xetla-name-revision full))
7766           (archive (xetla-name-archive full))
7767           (category (xetla-name-category full))
7768           (branch (xetla-name-branch full))
7769           (version (xetla-name-version full))
7770           dir)
7771      (unless revision
7772        (error "No revision under the point"))
7773      (setq dir (expand-file-name
7774                 (read-directory-name
7775                  (format "Restore \"%s\" to: "
7776                          (xetla-name-construct
7777                           archive category branch version revision)))))
7778      (if (file-exists-p dir)
7779          (error "Directory %s already exists" dir))
7780      (list dir archive category branch version revision)))
7781   (if revision
7782       (xetla-get directory t archive category branch version revision)
7783     (error "No revision under the point")))
7784
7785 (defun xetla-revision-cache-revision (archive category branch version revision)
7786   "Create a cached revision for the revision at point."
7787   (interactive
7788    (let* ((elem (ewoc-data (ewoc-locate xetla-revision-list-cookie)))
7789           (full (xetla-revision-revision (caddr elem)))
7790           (archive (xetla-name-archive full))
7791           (category (xetla-name-category full))
7792           (branch (xetla-name-branch full))
7793           (version (xetla-name-version full))
7794           (revision (xetla-name-revision full)))
7795      (unless revision
7796        (error "No revision under the point"))
7797      (list archive category branch version revision)))
7798   (if revision
7799       (xetla-cache-revision archive category branch version revision)
7800     (error "No revision under the point")))
7801
7802 (defun xetla-revision-add-to-library (archive category branch version revision)
7803   "Add the revision at point to library."
7804   (interactive
7805    (let* ((elem (ewoc-data (ewoc-locate xetla-revision-list-cookie)))
7806           (full (xetla-revision-revision (caddr elem)))
7807           (archive (xetla-name-archive full))
7808           (category (xetla-name-category full))
7809           (branch (xetla-name-branch full))
7810           (version (xetla-name-version full))
7811           (revision (xetla-name-revision full)))
7812      (unless revision
7813        (error "No revision under the point"))
7814      (list archive category branch version revision)))
7815   (if revision
7816       (xetla-library-add archive category branch version revision)
7817     (error "No revision under the point")))
7818
7819 (defun xetla-revision-maybe-refresh ()
7820   "Refresh the revision list if new information is available.
7821 If the current ewoc doesn't contain creator, date, and summary, and
7822 if these values should now be displayed, run the refresh function."
7823   (when (or xetla-revisions-shows-date
7824             xetla-revisions-shows-creator
7825             xetla-revisions-shows-summary
7826             xetla-revisions-shows-merges
7827             xetla-revisions-shows-merged-by)
7828     (let ((stop nil)
7829           (ewoc-elem (ewoc-nth xetla-revision-list-cookie 0)))
7830       (while (and ewoc-elem (not stop))
7831         (let ((elem (ewoc-data ewoc-elem)))
7832           (if (eq (car elem) 'entry-patch)
7833               (setq stop t)
7834             (setq ewoc-elem (ewoc-next xetla-revision-list-cookie
7835                                        ewoc-elem)))))
7836       (when (and ewoc-elem
7837                  (null (xetla-revision-summary (caddr (ewoc-data ewoc-elem)))))
7838         (xetla-generic-refresh)))))
7839
7840 (defun xetla-revision-toggle-date ()
7841   "Toggle display of the date in the revision list."
7842   (interactive)
7843   (setq xetla-revisions-shows-date (not xetla-revisions-shows-date))
7844   (xetla-revision-maybe-refresh)
7845   (ewoc-refresh xetla-revision-list-cookie))
7846
7847 (defun xetla-revision-toggle-summary ()
7848   "Toggle display of the summary information in the revision list."
7849   (interactive)
7850   (setq xetla-revisions-shows-summary (not xetla-revisions-shows-summary))
7851   (xetla-revision-maybe-refresh)
7852   (ewoc-refresh xetla-revision-list-cookie))
7853
7854 (defun xetla-revision-toggle-creator ()
7855   "Toggle display of the creator in the revision list."
7856   (interactive)
7857   (setq xetla-revisions-shows-creator (not xetla-revisions-shows-creator))
7858   (xetla-revision-maybe-refresh)
7859   (ewoc-refresh xetla-revision-list-cookie))
7860
7861 (defun xetla-revision-toggle-library ()
7862   "Toggle display of the revision library in the revision list."
7863   (interactive)
7864   (setq xetla-revisions-shows-library (not xetla-revisions-shows-library))
7865   (ewoc-refresh xetla-revision-list-cookie))
7866
7867 (defun xetla-revision-toggle-merges ()
7868   "Toggle display of the merges in the revision list."
7869   (interactive)
7870   (setq xetla-revisions-shows-merges (not xetla-revisions-shows-merges))
7871   (xetla-revision-maybe-refresh)
7872   (ewoc-refresh xetla-revision-list-cookie))
7873
7874 (defun xetla-revision-toggle-merged-by ()
7875   "Toggle display of merged-by in the revision list."
7876   (interactive)
7877   (setq xetla-revisions-shows-merged-by
7878         (not xetla-revisions-shows-merged-by))
7879   (when (and (not xetla-revision-merge-by-computed)
7880              xetla-revisions-shows-merged-by)
7881     (xetla-revision-maybe-refresh)
7882     (xetla-revision-compute-merged-by))
7883   (ewoc-refresh xetla-revision-list-cookie))
7884
7885 (defun xetla-revision-changeset (arg)
7886   "Gets and display the changeset at point in a revision list buffer.
7887 If used with a prefix arg ARG, don't include the diffs from the output."
7888   (interactive "P")
7889   (let* ((cookie xetla-revision-list-cookie)
7890          (full (xetla-revision-revision
7891                 (caddr (ewoc-data (ewoc-locate cookie)))))
7892          (revision (xetla-name-construct full)))
7893     (xetla-get-changeset revision t nil arg)))
7894
7895 (defun xetla-revision-store-delta (across-versions)
7896   "Store a delta between two marked revisions.
7897 If prefix argument ACROSS-VERSIONS is given, read revision details from the
7898 user."
7899   (interactive "P")
7900   (xetla-revision-delta across-versions t))
7901
7902 (defun xetla-revision-delta (across-versions &optional stored-to-directory)
7903   "Run tla delta from marked revision to revision at point.
7904 If prefix-argument ACROSS-VERSIONS is nil, read a revision
7905 in the current version.  If ACROSS-VERSIONS is non-nil, read an archive,
7906 a category, a branch, a version, and a revision to specify the revision.
7907 If STORED-TO-DIRECTORY is nil, ask the user whether the changeset is stored
7908 to or not.  If STORED-TO-DIRECTORY is non-nil, don't ask the use and the
7909 changeset is stored."
7910   (interactive "P")
7911   (let* ((modified
7912           (xetla-revision-revision
7913            (caddr (ewoc-data (ewoc-locate xetla-revision-list-cookie)))))
7914          (modified-fq (xetla-name-construct modified))
7915          (base
7916           (let ((marked (xetla-revision-marked-revisions)))
7917             (when (< 1 (length marked))
7918               (error "Delta can be run against one marked revision as the base revision"))
7919             (cond ((and marked (null (cdr marked)))
7920                    ;; use the marked revision
7921                    ;; (xetla-revision-unmark-all)
7922                    (xetla-revision-revision (car marked)))
7923                   (t
7924                    (xetla-name-read
7925                     (format "Revision for delta to %s from: "
7926                             (if across-versions
7927                                 modified-fq
7928                               (xetla-name-revision modified)))
7929                     (if across-versions 'prompt (xetla-name-archive modified))
7930                     (if across-versions 'prompt (xetla-name-category modified))
7931                     (if across-versions 'prompt (xetla-name-branch modified))
7932                     (if across-versions 'prompt (xetla-name-version modified))
7933                     'maybe))))))
7934
7935     (unless (xetla-name-archive base)
7936       (error "Archive for the base is not specified"))
7937     (unless (xetla-name-category base)
7938       (error "Cateogory for the base is not specified"))
7939     (unless (xetla-name-branch base)
7940       (error "Branch for the base is not specified"))
7941     (unless (xetla-name-version base)
7942       (error "Version for the base is not specified"))
7943     (unless (xetla-name-revision base)
7944       ;; No revision for modified is specified.
7945       ;; Use HEAD revision.
7946       (setcar (nthcdr 4 base)
7947               (xetla-version-head
7948                (xetla-name-archive base)
7949                (xetla-name-category base)
7950                (xetla-name-branch base)
7951                (xetla-name-version base))))
7952
7953     (when (or stored-to-directory
7954               (and (not stored-to-directory)
7955                    (y-or-n-p "Store the delta to a directory? ")))
7956       (setq stored-to-directory 'ask))
7957
7958     (xetla-delta (xetla-name-construct base)
7959                modified-fq
7960                stored-to-directory)))
7961
7962 (defun xetla-revision-bookmarks-add (name)
7963   "Add a bookmark named NAME for the current revision."
7964   (interactive "sBookmark name: ")
7965   (xetla-bookmarks-add name
7966                      (list xetla-buffer-archive-name
7967                            xetla-buffer-category-name
7968                            xetla-buffer-branch-name
7969                            xetla-buffer-version-name
7970                            nil))
7971   (message "bookmark %s added." name))
7972
7973 (defun xetla-revision-sync-tree (arg)
7974   "Unify a tree's patch log with the current revision.
7975 With prefix argument ARG, use the latest version instead."
7976   (interactive "P")
7977   (let* ((last-inventory (xetla-last-visited-inventory-buffer))
7978          (local-tree (or (if last-inventory
7979                              (with-current-buffer last-inventory
7980                                default-directory)
7981                            default-directory)))
7982          (current (ewoc-locate xetla-revision-list-cookie)))
7983     (while (and current
7984                 (not (and (eq (car (ewoc-data current))
7985                               'separator)
7986                           (eq (caddr (ewoc-data current))
7987                               'bookmark))))
7988       (setq current (ewoc-prev xetla-revision-list-cookie current)))
7989     (when (and current
7990                (eq (car (ewoc-data current)) 'separator)
7991                (eq (caddr (ewoc-data current)) 'bookmark))
7992       (setq local-tree (cadddr (ewoc-data current))))
7993     (let ((to-tree (read-directory-name "Sync with tree: " local-tree)))
7994       (let* ((elem (ewoc-data (ewoc-locate
7995                                xetla-revision-list-cookie)))
7996              (full (xetla-revision-revision (caddr elem))))
7997         (xetla-sync-tree (xetla-name-construct
7998                         (if arg (butlast full) full))
7999                        to-tree)))))
8000
8001 (defun xetla-revision-star-merge-version ()
8002   "Run star-merge for the version at point."
8003   (interactive)
8004   (xetla-revision-star-merge t))
8005
8006 (defun xetla-revision-star-merge (arg)
8007   "Run star-merge from the revision at point.
8008 With prefix argument ARG, merge all missing revisions from this version."
8009   (interactive "P")
8010   (let* ((last-inventory (xetla-last-visited-inventory-buffer))
8011          (local-tree (or (if last-inventory
8012                              (with-current-buffer last-inventory
8013                                default-directory)
8014                            default-directory)))
8015          (current (ewoc-locate xetla-revision-list-cookie)))
8016     (while (and current
8017                 (not (and (eq (car (ewoc-data current))
8018                               'separator)
8019                           (eq (caddr (ewoc-data current))
8020                               'bookmark))))
8021       (setq current (ewoc-prev xetla-revision-list-cookie current)))
8022     (when (and current
8023                (eq (car (ewoc-data current)) 'separator)
8024                (eq (caddr (ewoc-data current)) 'bookmark))
8025       (setq local-tree (cadddr (ewoc-data current))))
8026     (let ((to-tree (read-directory-name "Merge to tree: "
8027                                              local-tree)))
8028       (let* ((elem (ewoc-data (ewoc-locate
8029                                xetla-revision-list-cookie)))
8030              (full (xetla-revision-revision (caddr elem))))
8031         (xetla-star-merge (xetla-name-construct
8032                          (if arg (butlast full) full))
8033                         to-tree)))))
8034
8035 (defun xetla-revision-replay-version ()
8036   "Call `xetla-revision-replay' with a prefix arg."
8037   (interactive)
8038   (xetla-revision-replay t))
8039
8040 (defun xetla-revision-replay (arg)
8041   "Run replay from the current location.
8042 If there are marked revisions, these are replayed.
8043 Otherwise, if an argument ARG is given, all missing
8044 revisions from this version are replayed.  If there are no marked
8045 revisions and no argument is given, the revision under the point
8046 is replayed."
8047   (interactive "P")
8048   (let* ((last-inventory (xetla-last-visited-inventory-buffer))
8049          (local-tree (or (if last-inventory
8050                              (with-current-buffer last-inventory
8051                                default-directory)
8052                            default-directory)))
8053          (current (ewoc-locate xetla-revision-list-cookie)))
8054     (while (and current
8055                 (not (and (eq (car (ewoc-data current))
8056                               'separator)
8057                           (eq (caddr (ewoc-data current))
8058                               'bookmark))))
8059       (setq current (ewoc-prev xetla-revision-list-cookie current)))
8060     (when (and current
8061                (eq (car (ewoc-data current)) 'separator)
8062                (eq (caddr (ewoc-data current)) 'bookmark))
8063       (setq local-tree (cadddr (ewoc-data current))))
8064     (let ((to-tree (read-directory-name "Replay to tree: " local-tree)))
8065       (if (xetla-revision-marked-revisions)
8066           (let ((revisions (mapcar 'xetla-revision-revision
8067                             (xetla-revision-marked-revisions))))
8068             (xetla-replay (sort (mapcar (lambda (revision)
8069                                         (xetla-name-construct
8070                                          revision))
8071                                       revisions)
8072                               'string<)
8073                         to-tree))
8074         (let* ((elem (ewoc-data (ewoc-locate
8075                                  xetla-revision-list-cookie)))
8076                (full (xetla-revision-revision (caddr elem))))
8077           (xetla-replay (xetla-name-construct
8078                        (if arg (butlast full) full))
8079                       to-tree))))))
8080
8081 (defun xetla-revision-mark-revision ()
8082   "Mark revision at point."
8083   (interactive)
8084   (let ((pos (point))
8085         (data (ewoc-data (ewoc-locate
8086                           xetla-revision-list-cookie))))
8087     (setcar (cdr data) t)
8088     (ewoc-refresh xetla-revision-list-cookie)
8089     (goto-char pos)
8090     (xetla-revision-next)))
8091
8092 (defun xetla-revision-marked-revisions ()
8093   "Return the revisions that are currently marked."
8094   (let ((acc '()))
8095     (ewoc-map #'(lambda (x) (when (and (eq (car x) 'entry-patch)
8096                                        (cadr x))
8097                               (push (caddr x) acc)))
8098               xetla-revision-list-cookie)
8099     (nreverse acc)))
8100
8101 (defun xetla-revision-unmark-revision ()
8102   "Unmark the revision at point."
8103   (interactive)
8104   (let ((pos (point))
8105         (data (ewoc-data (ewoc-locate
8106                           xetla-revision-list-cookie))))
8107     (setcar (cdr data) nil)
8108     (ewoc-refresh xetla-revision-list-cookie)
8109     (goto-char pos)
8110     (xetla-revision-next)))
8111
8112 (defun xetla-revision-unmark-all ()
8113   "Unmark all revisions."
8114   (interactive)
8115   (let ((pos (point)))
8116     (ewoc-map #'(lambda (x) (when (and (eq (car x) 'entry-patch)
8117                                        (cadr x))
8118                               (setcar (cdr x) nil)))
8119               xetla-revision-list-cookie)
8120     (ewoc-refresh xetla-revision-list-cookie)
8121     (goto-char pos)))
8122
8123 (defun xetla-revision-tag-from-head ()
8124   "Run tla tag from the newest revision in revision buffer."
8125   (interactive)
8126   (let* ((from (when xetla-buffer-archive-name
8127                  (xetla-name-construct xetla-buffer-archive-name
8128                                       xetla-buffer-category-name
8129                                       xetla-buffer-branch-name
8130                                       xetla-buffer-version-name))))
8131     (unless from (error "No head revision"))
8132     (xetla-revision-tag-internal from)))
8133
8134 (defun xetla-revision-tag-from-here ()
8135   "Run tla tag from the current location in revision buffer."
8136   (interactive)
8137   (let ((from (when xetla-revision-list-cookie
8138                 (let* ((elem (ewoc-data (ewoc-locate
8139                                          xetla-revision-list-cookie))))
8140                   (apply 'xetla-name-construct (aref (caddr elem) 1))))))
8141     (unless from (error "No revision here"))
8142     (xetla-revision-tag-internal from)))
8143
8144 (defun xetla-revision-tag-internal (from-fq)
8145   "Tag from FROM-FQ to some destination."
8146   (let* ((to (xetla-name-read "Tag to: "
8147                              'prompt 'prompt 'prompt 'prompt))
8148          (to-fq (xetla-name-construct to)))
8149     (xetla-version-tag-internal from-fq to-fq)))
8150
8151 (defun xetla-revision-show-changeset ()
8152   "Show a changeset for the current revision."
8153   (interactive)
8154   (let ((elem (ewoc-data (ewoc-locate
8155                           xetla-revision-list-cookie))))
8156     (case (car elem)
8157       (entry-patch (xetla-revision-cat-log))
8158       (entry-change (let ((default-directory (caddr elem)))
8159                       (xetla-changes))))))
8160
8161 (xetla-make-bymouse-function xetla-revision-show-changeset)
8162
8163 (defun xetla-revision-cat-log ()
8164   "Show the log entry for the revision at point."
8165   (interactive)
8166   (let* ((elem (ewoc-data (ewoc-locate
8167                            xetla-revision-list-cookie)))
8168          (full (xetla-revision-revision (caddr elem)))
8169          (cur-buf (current-buffer))
8170          (log-buf (xetla-cat-log-any full))
8171          (display-buf (xetla-get-buffer-create 'cat-log
8172                                               (xetla-name-construct full))))
8173     (xetla-switch-to-buffer display-buf)
8174     (let ((inhibit-read-only t))
8175       (erase-buffer)
8176       (insert (with-current-buffer log-buf
8177                 (buffer-string)))
8178       (goto-char (point-min)))
8179     (xetla-cat-log-mode)
8180     (when (eq xetla-switch-to-buffer-mode 'pop-to-buffer)
8181       (pop-to-buffer cur-buf))))
8182
8183 (defun xetla-revision-update ()
8184   "Run tla update for this revision."
8185   (interactive)
8186   (let ((local-tree default-directory) ;; Default value
8187         (current (ewoc-locate xetla-revision-list-cookie)))
8188     (while (and current
8189                 (not (and (eq (car (ewoc-data current))
8190                               'separator)
8191                           (eq (caddr (ewoc-data current))
8192                               'bookmark))))
8193       (setq current (ewoc-prev xetla-revision-list-cookie current)))
8194     (when (and current
8195                (eq (car (ewoc-data current)) 'separator)
8196                (eq (caddr (ewoc-data current)) 'bookmark))
8197       (setq local-tree (cadddr (ewoc-data current))))
8198     (let ((buffer (current-buffer)))
8199       (xetla-update (read-directory-name "Update tree: "
8200                                             local-tree)
8201                   `(lambda ()
8202                      (pop-to-buffer ,buffer)
8203                      (xetla-generic-refresh))))))
8204
8205 (defcustom xetla-send-comments-width 25
8206   "*Max length for the summary line when using %t in `xetla-send-comments-format'.")
8207
8208 (defcustom xetla-send-comments-format "Your patch %c--%b--%v--%r (%t)"
8209   "Format for the Subject line for `xetla-revision-send-comments'.
8210
8211 The following substring will be substituted:
8212
8213 %f: Full revision name
8214 %a: The archive name
8215 %c: The category name
8216 %b: The branch name
8217 %v: The version name
8218 %r: The revision name
8219 %s: The summary line
8220 %t: The summary line, truncated to `xetla-send-comments-width'
8221 characters.")
8222
8223 (defun xetla-revision-send-comments (revision)
8224   "Sends comments to the author of REVISION.
8225
8226 The email is extracted from the archive name.  A new mail message is
8227 opened with a description of the revision.  REVISION must be the same
8228 structure as the elem of `xetla-revision-list-cookie'.
8229
8230 When called interactively, REVISION is the revision at point."
8231   (interactive (list (caddr (ewoc-data (ewoc-locate xetla-revision-list-cookie)))))
8232   (let* ((full-rev (xetla-revision-revision revision))
8233          (archive (xetla-name-archive full-rev))
8234          (email (progn (string-match "\\(.*\\)--\\([^-]\\|-[^-]\\)"
8235                                      archive)
8236                        (match-string 1 archive)))
8237          (summary (xetla-revision-summary revision))
8238          (subject xetla-send-comments-format))
8239     (dolist (pair '(("%f" . (xetla-name-construct full-rev))
8240                     ("%a" . archive)
8241                     ("%c" . (xetla-name-category full-rev))
8242                     ("%b" . (xetla-name-branch full-rev))
8243                     ("%v" . (xetla-name-version full-rev))
8244                     ("%r" . (xetla-name-revision full-rev))
8245                     ("%s" . summary)
8246                     ("%t" . (if (> (string-width summary)
8247                                    xetla-send-comments-width)
8248                                 (concat (truncate-string summary 25)
8249                                         "...")
8250                               summary))))
8251       (setq subject
8252             (replace-regexp-in-string (car pair) (eval (cdr pair))
8253                                       subject)))
8254     (compose-mail email subject)
8255     (save-excursion
8256       (insert "\n\n" (xetla-name-construct full-rev) "\n"
8257               "  " summary "\n"
8258               "  " (xetla-revision-date revision) "\n"
8259               "  " (xetla-revision-creator revision) "\n"))))
8260
8261 ;; --------------------------------------
8262 ;; xetla-changes-mode
8263 ;; --------------------------------------
8264 (define-derived-mode xetla-changes-mode fundamental-mode "xetla-changes"
8265   "Major mode to display changesets. Derives from `diff-mode'.
8266
8267 Use '\\<xetla-changes-mode-map>\\[xetla-changes-mark-file]' to mark files, and '\\[xetla-changes-unmark-file]' to unmark.
8268 If you commit from this buffer (with '\\[xetla-changes-edit-log]'), then, the list of selected
8269 files in this buffer at the time you actually commit with
8270 \\<xetla-log-edit-mode-map>\\[xetla-log-edit-done].
8271
8272 Commands:
8273 \\{xetla-changes-mode-map}
8274 "
8275   (let ((diff-mode-shared-map (copy-keymap xetla-changes-mode-map))
8276         major-mode mode-name)
8277     (diff-mode))
8278
8279   (set (make-local-variable 'font-lock-defaults)
8280        (list 'xetla-changes-font-lock-keywords t nil nil))
8281   (font-lock-mode)
8282   (set (make-local-variable 'xetla-get-file-info-at-point-function)
8283        'xetla-changes-get-file-at-point)
8284   (set (make-local-variable 'xetla-buffer-refresh-function)
8285        'xetla-changes-generic-refresh)
8286   (set (make-local-variable 'xetla-changes-cookie)
8287        (ewoc-create 'xetla-changes-printer))
8288   (make-local-variable 'xetla-buffer-marked-file-list)
8289   (easy-menu-add xetla-changes-mode-menu)
8290   (toggle-read-only 1)
8291   (set-buffer-modified-p nil))
8292
8293 (defun xetla-changes-generic-refresh ()
8294   "Refresh the changes buffer."
8295   (interactive)
8296   (if (eq (car xetla-changes-modified) 'local-tree)
8297       (xetla-changes xetla-changes-summary xetla-changes-base)))
8298
8299 (defun xetla-changes-jump-to-change (&optional other-file)
8300   "Jump to the corresponding file and location of the change.
8301 The prefix argument OTHER-FILE controls whether the original or new
8302 file is visited."
8303   (interactive "P")
8304   (let* ((elem (ewoc-locate xetla-changes-cookie))
8305          (data (ewoc-data elem)))
8306     (cond ((< (ewoc-location elem) (point-at-bol))
8307            (xetla-changes-diff-goto-source other-file))
8308           ((eq (car data) 'file)
8309            (find-file (cadr data)))
8310           ((eq (car data) 'subtree)
8311            (xetla-switch-to-buffer (cadr data)))
8312           (t (error "Not on a recognized location")))))
8313
8314 (defun xetla-changes-diff-goto-source (other-file)
8315   "Almost the same as `diff-goto-source'.
8316 But the target file is transformed by `xetla-changes-what-changed-original-file'
8317 to handle files in what-changed directory.
8318 OTHER-FILE controls whether the original or new file is visited."
8319   (let ((xetla-original-file-exists-p (symbol-function
8320                                      'file-exists-p))
8321         (xetla-original-find-file-noselect (symbol-function
8322                                           'find-file-noselect)))
8323     (flet ((file-exists-p (file)
8324                           (unless (string= "/dev/null" file)
8325                             (funcall
8326                              xetla-original-file-exists-p
8327                              (xetla-changes-what-changed-original-file file))))
8328            (find-file-noselect (file &optional nowarn rawfile wildcards)
8329              (if (featurep 'xemacs)
8330                  (funcall xetla-original-find-file-noselect
8331                           (xetla-changes-what-changed-original-file file)
8332                           nowarn rawfile)
8333                (funcall xetla-original-find-file-noselect
8334                         (xetla-changes-what-changed-original-file file)
8335                         nowarn rawfile wildcards))))
8336       (diff-goto-source other-file))))
8337
8338 (defun xetla-changes-what-changed-original-file (file)
8339   "Remove what-changed directory part from FILE and return it."
8340   (if (string-match
8341        "\\(/,,what-changed[^/]+/new-files-archive\\)"
8342        file)
8343       (concat (substring file 0 (match-beginning 1))
8344               (substring file (match-end 1)))
8345     file))
8346
8347 (defun xetla-changes-diff-or-list ()
8348   "Move around the changes buffer.
8349 When in the list part of the buffer, jump to the corresponding
8350 patch. When on a patch, jump to the corresponding entry in the list of
8351 files."
8352   (interactive)
8353   (let* ((elem (ewoc-locate xetla-changes-cookie))
8354          (data (ewoc-data elem)))
8355     (cond ((< (ewoc-location elem) (point-at-bol))
8356            (let ((file (xetla-changes-get-file-at-point))
8357                  (elem (ewoc-nth xetla-changes-cookie 0)))
8358              (while (and elem
8359                          (or (not (eq (car (ewoc-data elem)) 'file))
8360                              (not (string= (expand-file-name
8361                                             (cadr (ewoc-data elem)))
8362                                            file))))
8363                (setq elem (ewoc-next xetla-changes-cookie elem)))
8364              (if elem (goto-char (ewoc-location elem))
8365                (error (format "Can't find file %s in list" file)))
8366              ))
8367           ((eq (car data) 'file)
8368            (re-search-forward (concat "^--- orig/" (cadr data)))
8369            (diff-hunk-next))
8370           ((eq (car data) 'subtree)
8371            (xetla-switch-to-buffer (cadr data)))
8372           (t (error "Not on a recognized location")))))
8373
8374 (defun xetla-changes-master-buffer ()
8375   "Jump to the master *xetla-changes* buffer for a nested changes buffer."
8376   (interactive)
8377   (unless xetla-changes-buffer-master-buffer
8378     (error "No master buffer"))
8379   (xetla-switch-to-buffer xetla-changes-buffer-master-buffer))
8380
8381 (defun xetla-flash-line-on ()
8382   "Turn on highline mode or equivalent."
8383   (or (xetla-funcall-if-exists hl-line-mode)
8384       (xetla-funcall-if-exists highline-on)))
8385
8386 (defun xetla-flash-line-off ()
8387   "Turn off highline mode or equivalent."
8388   (or (xetla-funcall-if-exists hl-line-mode)
8389       (xetla-funcall-if-exists highline-off)))
8390
8391 (defun xetla-flash-line ()
8392   "Flash the current line."
8393   (let ((buffer (current-buffer)))
8394     (xetla-flash-line-on)
8395     (sit-for 1000)
8396     ;; Avoid to switching buffer by asynchronously running
8397     ;; processes.
8398     ;; TODO: This is adhoc solution. Something guard-mechanism to avoid
8399     ;; buffer switching may be needed.
8400     (set-buffer buffer)
8401     (xetla-flash-line-off)))
8402
8403 (defun xetla-changes-view-source (&optional other-file)
8404   "Show the corresponding file and location of the change.
8405 This function does not switch to the file, but it places the cursor
8406 temporarily at the location of the change and will stay in the changes
8407 buffer.  Thus you can quickly see more context on a specific change without
8408 switching buffers.
8409 The prefix argument OTHER-FILE controls whether the original or new
8410 file is visited."
8411   (interactive "P")
8412   (let ((diff-window (selected-window)))
8413     (save-excursion
8414       (diff-goto-source other-file)
8415       (recenter)
8416       (xetla-flash-line)
8417       (select-window diff-window))))
8418
8419 (defun xetla-changes-edit-log (&optional insert-changelog)
8420   "Wrapper around `xetla-edit-log', setting the source buffer to current
8421 buffer."
8422   (interactive "P")
8423   (xetla-edit-log insert-changelog (current-buffer)))
8424
8425 (defun xetla-changes-rm ()
8426   "Remove the file under point."
8427   (interactive)
8428   (let ((file (xetla-get-file-info-at-point)))
8429     (unless file
8430       (error "No file at point"))
8431     (xetla-rm file)))
8432
8433 (defun xetla-changes-mark-file ()
8434   "Mark the file under point."
8435   (interactive)
8436   (let ((current (ewoc-locate xetla-changes-cookie))
8437         (file (xetla-get-file-info-at-point)))
8438     (add-to-list 'xetla-buffer-marked-file-list file)
8439     (ewoc-refresh xetla-changes-cookie)
8440     (goto-char (ewoc-location (or (ewoc-next xetla-changes-cookie
8441                                              current)
8442                                   current)))))
8443
8444 (defun xetla-changes-unmark-file ()
8445   "Unmark the file under point."
8446   (interactive)
8447   (let ((current (ewoc-locate xetla-changes-cookie))
8448         (file (xetla-get-file-info-at-point)))
8449     (setq xetla-buffer-marked-file-list
8450           (delete file xetla-buffer-marked-file-list))
8451     (ewoc-refresh xetla-changes-cookie)
8452     (goto-char (ewoc-location (or (ewoc-next xetla-changes-cookie
8453                                              current)
8454                                   current)))))
8455
8456 (defun xetla-changes-diff ()
8457   "Run tla file-diff on the file at point in *xetla-changes*."
8458   (interactive)
8459   (let ((on-modified-file (xetla-get-file-info-at-point)))
8460     (if on-modified-file
8461         (xetla-file-diff on-modified-file)
8462       (error "Not on a modified file"))))
8463
8464 (defun xetla-changes-next ()
8465   "Move to the next changes."
8466   (interactive)
8467   (let ((cur-location (ewoc-location (ewoc-locate xetla-changes-cookie)))
8468         (next (ewoc-next xetla-changes-cookie
8469                          (ewoc-locate xetla-changes-cookie))))
8470     (cond
8471      ((> cur-location (point))
8472       (goto-char cur-location))
8473      (next
8474       (goto-char (ewoc-location next)))
8475      (t
8476       (diff-hunk-next)))))
8477
8478 (defun xetla-changes-prev ()
8479   "Move to the previous changes."
8480   (interactive)
8481   (let* ((current (ewoc-locate xetla-changes-cookie))
8482          (cur-location (ewoc-location current))
8483          (prev (ewoc-prev xetla-changes-cookie current))
8484          (next (ewoc-next xetla-changes-cookie current)))
8485     (cond (next
8486            (if prev (goto-char (ewoc-location prev))
8487              (goto-char cur-location)))
8488           ((condition-case nil (progn (diff-hunk-prev) t) (error nil)))
8489           ((> (point-at-bol) cur-location)
8490            (goto-char cur-location))
8491           (prev
8492            (goto-char (ewoc-location prev)))
8493           (t
8494            (goto-char cur-location)))
8495     ))
8496
8497 (defun xetla-changes-in-diff ()
8498   "Return t if cursor is in the diffs section of the changes buffer."
8499   (save-excursion (re-search-backward "^--- orig" nil t)))
8500
8501
8502 (defun xetla-changes-ediff (&optional other-file)
8503   "Run ediff on the current changes.
8504 The prefix argument OTHER-FILE controls whether the original or new
8505 file is visited."
8506   (interactive "P")
8507   (unless (and (car xetla-changes-base)
8508                (car xetla-changes-base))
8509     (error "No revision information to base ediff on"))
8510   (let ((on-modified-file (xetla-get-file-info-at-point))
8511         (loc (point)))
8512     (if (and on-modified-file (not (xetla-changes-in-diff)))
8513         (xetla-file-ediff-revisions on-modified-file
8514                                   xetla-changes-base
8515                                   xetla-changes-modified)
8516       (re-search-backward "^--- orig/")
8517       (re-search-forward "^--- orig/")
8518       (let ((file (expand-file-name
8519                    (concat (file-name-as-directory default-directory)
8520                            (buffer-substring-no-properties (point)
8521                                                            (point-at-eol)))))
8522             (hunk 1))
8523         (diff-hunk-next)
8524         (while (<= (re-search-forward "\\(^[\\+-].*\n\\)+" nil t) loc)
8525           (setq hunk (1+ hunk)))
8526         (goto-char loc)
8527         (with-current-buffer
8528             (xetla-file-ediff-revisions file xetla-changes-base
8529                                       xetla-changes-modified)
8530           (ediff-jump-to-difference hunk))))))
8531
8532 (defun xetla-changes-get-file-at-point ()
8533   "Find file at point in *xetla-changes*.
8534 Throw an error when not on a file."
8535   (let ((elem (ewoc-locate xetla-changes-cookie (point))))
8536     (or (when (and elem
8537                    (eq (car (ewoc-data elem)) 'file)
8538                    (>= (ewoc-location elem) (point-at-bol)))
8539           (cadr (ewoc-data elem)))
8540         (expand-file-name (concat (file-name-as-directory
8541                                    default-directory)
8542                                   (diff-find-file-name))))))
8543
8544 (defun xetla-changes-jump-to-change-by-mouse (event &optional other-file)
8545   "Jump to the changes."
8546   (interactive "e\nP")
8547   (mouse-set-point event)
8548   (xetla-changes-jump-to-change other-file))
8549
8550 (defun xetla-changes-revert ()
8551   "Reverts file at point."
8552   (interactive)
8553   (let* ((file (xetla-get-file-info-at-point))
8554          (absolute (if (file-name-absolute-p file)
8555                        file
8556                      (expand-file-name
8557                       (concat (file-name-as-directory
8558                                default-directory)
8559                               file)))))
8560     (xetla-file-revert absolute)))
8561
8562 ;; --------------------------------------
8563 ;; xetla-changelog-mode
8564 ;; --------------------------------------
8565
8566 (define-derived-mode xetla-changelog-mode change-log-mode "xetla-changelog"
8567   (set (make-local-variable 'font-lock-defaults)
8568        (list 'xetla-changelog-font-lock-keywords
8569              t nil nil 'backward-paragraph))
8570   (font-lock-mode)
8571   (use-local-map xetla-changelog-mode-map)
8572   (toggle-read-only 1)
8573   (set-buffer-modified-p nil))
8574
8575 ;; --------------------------------------
8576 ;; xetla-inventory-file-mode
8577 ;; --------------------------------------
8578 ;;;###autoload
8579 (defun xetla-inventory-file-mode ()
8580   "Major mode to edit xetla inventory files (=tagging-method, .arch-inventory)."
8581   (interactive)
8582   (kill-all-local-variables)
8583   (set (make-local-variable 'font-lock-defaults)
8584        '(xetla-inventory-file-font-lock-keywords t))
8585   (set (make-local-variable 'comment-start) "# ")
8586   (setq major-mode 'xetla-inventory-file-mode
8587         mode-name "xetla-inventory-file")
8588   (run-hooks 'xetla-inventory-file-mode-hook))
8589
8590 (defun xetla-inventory-file-jump-from-head (category)
8591   "Search CATEGORY from the head of the buffer."
8592   (let ((p (save-excursion (goto-char (point-min))
8593                            (re-search-forward
8594                             (concat "^" category) nil t))))
8595     (when p
8596       (goto-char p))))
8597
8598 (defun xetla-inventory-file-jump-from-tail (category)
8599   "Search CATEGORY from the tail of the buffer.
8600 Return nil if CATEGORY is not found."
8601   (let ((p (save-excursion (goto-char (point-max))
8602                            (re-search-backward
8603                             (concat "^" category) nil t))))
8604     (when p
8605       (goto-char p))))
8606
8607 (defun xetla-inventory-file-add-file (category file)
8608   "Added FILE to CATEGORY."
8609   (unless (xetla-inventory-file-jump-from-tail category)
8610     (goto-char (point-min)))
8611   (save-excursion (open-line 1))
8612   ;; TODO regexp quote FILE
8613   (insert (format "%s ^(%s)$" category file)))
8614
8615 ;; --------------------------------------
8616 ;; Find file hook
8617 ;; --------------------------------------
8618 ;; just 99% cut&paste from vc-follow-link in vc-hook.el, but this way there is
8619 ;; no need to load it thus avoiding interfering with VC ...
8620 (defun xetla-follow-link ()
8621   "Follow a symbolic link.
8622 If the current buffer visits a symbolic link, this function makes it
8623 visit the real file instead.  If the real file is already visited in
8624 another buffer, make that buffer current, and kill the buffer
8625 that visits the link."
8626   (let* ((truename (abbreviate-file-name (file-truename buffer-file-name)))
8627          (true-buffer (find-buffer-visiting truename))
8628          (this-buffer (current-buffer)))
8629     (if (eq true-buffer this-buffer)
8630         (progn
8631           (kill-buffer this-buffer)
8632           ;; In principle, we could do something like set-visited-file-name.
8633           ;; However, it can't be exactly the same as set-visited-file-name.
8634           ;; I'm not going to work out the details right now. - rms.
8635           (set-buffer (find-file-noselect truename)))
8636       (set-buffer true-buffer)
8637       (kill-buffer this-buffer))))
8638
8639
8640 (defvar vc-ignore-vc-files)
8641
8642 ;;;###autoload
8643 (defun xetla-find-file-hook ()
8644   "Hook executed when opening a file.
8645 Follow symlinked files/directories to the actual location of a file.
8646 Enter smerge mode if the file has conflicts (detected by the presence
8647 of a .rej file)."
8648   (when (xetla-file-has-conflict-p (buffer-file-name))
8649     (xetla-funcall-if-exists smerge-mode 1))
8650   (let (link file result)
8651     (when (and (not vc-ignore-vc-files)
8652                xetla-follow-symlinks
8653                (setq file buffer-file-name)
8654                (not (string= (setq link (file-truename file)) file)))
8655       (setq file link
8656             result (cond ((equal xetla-follow-symlinks 'tree)
8657                           (xetla-tree-root file t))
8658                          ((equal xetla-follow-symlinks 'id)
8659                           (= 0 (xetla-run-tla-sync
8660                                 (list "id" file)
8661                                 :finished 'xetla-status-handler
8662                                 :error 'xetla-status-handler)))))
8663
8664       (if result
8665           (cond ((eq xetla-follow-symlinks-mode 'warn)
8666                  (message
8667                   "Warning: symbolic link to arch-controlled source file: %s"
8668                   file))
8669                 ((or (eq xetla-follow-symlinks-mode 'follow)
8670                      (find-buffer-visiting file))
8671                  (xetla-follow-link)
8672                  (message "Followed link to arch-controlled %s"
8673                           buffer-file-name))
8674                 ((eq xetla-follow-symlinks-mode 'ask)
8675                  (if (y-or-n-p "Follow symbolic link to arch-controlled source file? ")
8676                      (progn
8677                        (xetla-follow-link)
8678                        (message "Followed link to arch-controlled %s"
8679                                 buffer-file-name))
8680                    (message
8681                     "Warning: editing through the link bypasses version control")))
8682                 (t (error "Unknown mode for xetla-follow-symlinks-mode=%s"
8683                           xetla-follow-symlinks-mode)))
8684         ))))
8685
8686 ;; --------------------------------------
8687 ;; Misc functions
8688 ;; --------------------------------------
8689 (defvar xetla-insert-arch-tag-functions
8690   '((autoconf-mode . xetla-insert-arch-tag-for-autoconf-mode)
8691     (makefile-mode . xetla-insert-arch-tag-for-makefile-mode))
8692   "Alist containing per mode specialized functions for inserting arch-tag.
8693 Key stands for a major mode.  Value is a function which inserts arch-tag.
8694 The function takes two arguments.  The first argument is an uuid string.
8695 The second argument is a boolean showing whether the point is in a comment
8696 or not." )
8697
8698 (defconst xetla-arch-tag-string (concat "arch-ta" "g: ")
8699   "To avoid having the string a-r-c-h-t-a-g: in this buffer ;-).")
8700
8701 (defun xetla-tag-uuid ()
8702   "Candidate for `xetla-tag-function'.
8703 Returns a unique string using uuidgen"
8704   (xetla-strip-final-newline (shell-command-to-string "uuidgen")))
8705
8706 (defun xetla-tag-name-date-filename ()
8707   "Candidate for `xetla-tag-function'.
8708 Returns a string containing the name of the user, the precise date,
8709 and the name of the current file.  This should be unique worldwide,
8710 has the advantage of containing usefull information in addition to
8711 the unique identifier.  The inconvenient in comparison to
8712 `xetla-tag-uuid' is that an unfortunate modification of the tag is more
8713 easily made (sed script or manual modification)"
8714   (concat (user-full-name) ", "
8715           (format-time-string "%c")
8716           " (" (file-name-nondirectory (buffer-file-name)) ")"))
8717
8718 ;;;###autoload
8719 (defun xetla-tag-string ()
8720   "Return a suitable string for an arch-tag.
8721 Actually calls `xetla-tag-function', which defaults to `xetla-tag-uuid' to generate
8722 string (and possibly add a comment-end after).
8723
8724 Interactively, you should call `xetla-tag-insert', but this function can
8725 be usefull to write template files."
8726   (funcall xetla-tag-function))
8727
8728 ;;;###autoload
8729 (defun xetla-tag-insert ()
8730   "Insert a unique arch-tag in the current file.
8731 Actually calls `xetla-tag-function', which defaults to `xetla-tag-uuid' to generate
8732 string (and possibly add a comment-end after)"
8733   (interactive)
8734   (let ((the-tag-itself (xetla-tag-string))
8735         (in-comment-p (nth 4 (parse-partial-sexp (point) (point-min))))
8736         (header "")
8737         (footer "")
8738         (handler (assoc major-mode xetla-insert-arch-tag-functions)))
8739     (if (cdr handler)
8740         (funcall (cdr handler) the-tag-itself in-comment-p)
8741       (unless in-comment-p
8742         (setq header (if comment-start
8743                          (concat comment-start
8744                                  (if (string-match " $" comment-start)
8745                                      "" " "))
8746                        "")
8747               footer (if (and comment-end (not (string= "" comment-end)))
8748                          (format "\n%s(do not change this comment)%s%s"
8749                                  (make-string (length header) ?\ )
8750                                  comment-end
8751                                  (if (string-match "^ " comment-end)
8752                                      "" " "))
8753                        "")))
8754       (insert (concat header xetla-arch-tag-string the-tag-itself
8755                       footer)))))
8756
8757 ;;;###autoload
8758 (defun xetla-tag-regenerate ()
8759   "Find an arch tag in the current buffer and regenerates it.
8760 This means changing the ID of the file, which will usually be done after
8761 copying a file in the same tree to avoid duplicates ID.
8762
8763 Raises an error when multiple tags are found or when no tag is found."
8764   (interactive)
8765   (let ((second-tag
8766          (save-excursion
8767            (goto-char (point-min))
8768            (unless (search-forward xetla-arch-tag-string nil t)
8769              (error "No arch tag in this buffer"))
8770            (delete-region (point) (progn (end-of-line) (point)))
8771            (insert (funcall xetla-tag-function))
8772            (if (search-forward xetla-arch-tag-string nil t)
8773                (point)
8774              nil))))
8775     (when second-tag
8776       (goto-char second-tag)
8777       (beginning-of-line)
8778       (error "Multiple tag in this buffer"))))
8779
8780 (defun xetla-regenerate-id-for-file (file)
8781   "Create a new id for the file FILE.
8782 Does roughly
8783
8784 $ xetla delete file
8785 $ xetla add file
8786
8787 But also works for the tagline method.  When the tagline method is
8788 used, the file is opened in a buffer.  If the file had modifications,
8789 the tag is modified in the buffer, and the user is prompted for
8790 saving.  If the file had no unsaved modifications, the modification is
8791 done in the buffer and the file is saved without prompting.
8792
8793 FILE must be an absolute filename.  It can also be a directory"
8794   (interactive "f")
8795   (if (file-directory-p file)
8796       (progn
8797         (delete-file (concat (file-name-as-directory file)
8798                              ".arch-ids/=id"))
8799         (xetla-add-id nil file))
8800     (let* ((dir (file-name-directory file))
8801            (basename (file-name-nondirectory file))
8802            (id-file (concat dir
8803                             (file-name-as-directory ".arch-ids")
8804                             basename ".id")))
8805       (if (file-exists-p id-file)
8806           (progn (delete-file id-file)
8807                  (xetla-add-id nil file))
8808         (with-current-buffer
8809             (find-file-noselect file)
8810           (let ((modif (buffer-modified-p)))
8811             (xetla-tag-regenerate)
8812             (if modif
8813                 (when (y-or-n-p (format "Save buffer %s? " (buffer-name)))
8814                   (save-buffer))
8815               ;; No modif. We can safely save without prompting.
8816               (save-buffer))))))))
8817
8818 (defun xetla-insert-arch-tag-for-autoconf-mode (uuid in-comment-p)
8819   "Insert arch-tag, UUID to the current `autoconf-mode' buffer.
8820 IN-COMMENT-P indicates whether we are currently inside a comment."
8821   (when in-comment-p
8822     ;; In current GNU Emacs's autoconf-mode implementation,
8823     ;; next line is never executed.
8824     (error "Comment prefix \"dnl\" is not suitable for gnuarch"))
8825   (let ((header "m4_if(dnl      Do not change this comment\n")
8826         (footer "\n)dnl\n"))
8827     (insert (concat header "    " xetla-arch-tag-string uuid footer))))
8828
8829 (defun xetla-insert-arch-tag-for-makefile-mode (uuid in-comment-p)
8830   "Insert arch-tag, UUID to the current `makefile-mode' buffer.
8831 If the file is Makefile.am, input for automake, use `##' as `comment-start'.
8832 Comment started with `##' in Makefile.am is automatically stripped by automake.
8833 IN-COMMENT-P indicates whether we are currently inside a comment."
8834   (let ((xetla-insert-arch-tag-functions
8835          (assq-delete-all 'makefile-mode
8836                           (copy-sequence xetla-insert-arch-tag-functions)))
8837         (comment-start (if (and (buffer-file-name)
8838                                 (string-match "Makefile.am$" (buffer-file-name)))
8839                            "##"
8840                          comment-start)))
8841     (xetla-tag-insert)))
8842
8843 ;;;###autoload
8844 (defun xetla-ediff-add-log-entry ()
8845   "Add a log entry."
8846   (interactive)
8847   (pop-to-buffer ediff-buffer-A)
8848   (xetla-add-log-entry))
8849
8850 ;;
8851 ;; Tree-lint mode
8852 ;;
8853 (defvar xetla-tree-lint-cookie nil
8854   "Ewoc cookie used in tree-lint mode.")
8855
8856 (define-derived-mode xetla-tree-lint-mode fundamental-mode
8857   "xetla-tree-lint"
8858   "Major mode to view tree-lint warnings.
8859 Commands:
8860 \\{xetla-tree-lint-mode-map}
8861 "
8862   (let ((inhibit-read-only t))
8863     (erase-buffer))
8864   (set (make-local-variable 'xetla-buffer-refresh-function)
8865        `(lambda () (interactive) (xetla-tree-lint ,default-directory)))
8866   (set (make-local-variable 'xetla-tree-lint-cookie)
8867        (ewoc-create 'xetla-tree-lint-printer))
8868   (set (make-local-variable 'xetla-get-file-info-at-point-function)
8869        'xetla-tree-lint-get-file-at-point)
8870   (set (make-local-variable 'xetla-buffer-marked-file-list)
8871        nil)
8872   (set (make-local-variable 'xetla-generic-select-files-function)
8873        'xetla-tree-lint-select-files)
8874   (toggle-read-only t))
8875
8876 (defun xetla-tree-lint-get-file-at-point ()
8877   "Find file at point in *xetla-tree-lint*.  Error when not on a file."
8878   (let ((data (ewoc-data (ewoc-locate xetla-tree-lint-cookie))))
8879     (if (eq (car data) 'message)
8880         nil
8881       (cadr data))))
8882
8883 (defun xetla-tree-lint-prepare-buffer (root)
8884   "Prepare the buffer to display the tree-lint warnings for tree ROOT."
8885   (let ((buffer (xetla-get-buffer-create 'tree-lint root)))
8886     (with-current-buffer buffer
8887       (xetla-tree-lint-mode)
8888       (ewoc-enter-last
8889        xetla-tree-lint-cookie
8890        (list 'message (format "Running tree-lint in %s ..."
8891                               root)))
8892       buffer)))
8893
8894 ;;;###autoload
8895 (defun xetla-tree-lint (root)
8896   "Run tla tree-lint in directory ROOT."
8897   (interactive
8898    (list (xetla-read-project-tree-maybe "Run tla tree-lint in: ")))
8899   (let ((default-directory root)
8900         (buffer (xetla-tree-lint-prepare-buffer root)))
8901     (when xetla-switch-to-buffer-first
8902       (xetla-switch-to-buffer buffer))
8903     (xetla-run-tla-async
8904      '("tree-lint")
8905      :related-buffer buffer
8906      :finished
8907      `(lambda (output error status arguments)
8908         (if (> (buffer-size output) 0)
8909             (progn
8910               (save-excursion
8911                 (xetla-tree-lint-parse-buffer output ,buffer))
8912               (with-current-buffer ,buffer
8913                 (xetla-tree-lint-cursor-goto
8914                  (ewoc-nth xetla-tree-lint-cookie 0))))
8915           (message "No tree-lint warnings for %s." ,default-directory)
8916           (with-current-buffer ,buffer
8917             (let ((inhibit-read-only t))
8918               (erase-buffer)
8919               (ewoc-enter-last
8920                xetla-tree-lint-cookie
8921                (list 'message (format "No tree-lint warnings for %s."
8922                                       ,default-directory)))))))
8923      :error
8924      `(lambda (output error status arguments)
8925         (save-excursion
8926           (xetla-tree-lint-parse-buffer output ,buffer))
8927         (with-current-buffer ,buffer
8928           (xetla-tree-lint-cursor-goto
8929            (ewoc-nth xetla-tree-lint-cookie 0)))))))
8930
8931 (defconst xetla-tree-lint-message-alist
8932   '(("^These files would be source but lack inventory ids"
8933      missing-file)
8934     ("^These explicit ids have no corresponding file:"
8935      id-without-file)
8936     ("^These files violate naming conventions:"
8937      unrecognized)
8938     ("^These symlinks point to nonexistent files:"
8939      broken-link)
8940     ("^Duplicated ids among each group of files listed here:"
8941      duplicate-id)
8942     ))
8943
8944 (defun xetla-tree-lint-message-type (message)
8945   "Return a symbol saying which type of message the string MESSAGE is."
8946   (let ((result nil)
8947         (iterator xetla-tree-lint-message-alist))
8948     (while (and iterator (not result))
8949       (when (string-match (caar iterator) message)
8950         (setq result (cadar iterator)))
8951       (setq iterator (cdr iterator)))
8952     (or result 'unknown)))
8953
8954 (defun xetla-tree-lint-parse-buffer (buffer output-buffer)
8955   "Parse the output of xetla tree-lint in BUFFER.
8956 Show in in the tree-lint-mode buffer OUTPUT-BUFFER."
8957   (with-current-buffer output-buffer
8958     (let ((inhibit-read-only t))
8959       (erase-buffer)
8960       (insert (xetla-face-add (format "Tree lint warnings in %s\n"
8961                                      default-directory)
8962                              'xetla-messages)))
8963     (setq xetla-tree-lint-cookie
8964           (ewoc-create 'xetla-tree-lint-printer)))
8965   (with-current-buffer buffer
8966     (goto-char (point-min))
8967     (let ((cookie (with-current-buffer output-buffer
8968                     xetla-tree-lint-cookie)))
8969       (while (re-search-forward "^." nil t)
8970         (goto-char (point-at-bol))
8971         (let* ((message (buffer-substring-no-properties
8972                          (point) (point-at-eol)))
8973                (type (xetla-tree-lint-message-type message)))
8974           (ewoc-enter-last cookie (list 'message message))
8975           (forward-line 2)
8976           (if (eq type 'duplicate-id)
8977               (progn
8978                 (while (looking-at "\\([^ \t]*\\)[ \t]+\\(.*\\)")
8979                   (let* ((file (match-string 1))
8980                          (id (match-string 2)))
8981                     ;; Format: (duplicate-id "filename" "id" first? last?)
8982                     (ewoc-enter-last
8983                      cookie (list 'duplicate-id (xetla-unescape file) id
8984                                   t nil))
8985                     (forward-line 1)
8986                     (while (not (eq (char-after) ?\n))
8987                       (let ((file (buffer-substring-no-properties
8988                                    (point) (point-at-eol))))
8989                         (forward-line 1)
8990                         (ewoc-enter-last cookie
8991                                          (list 'duplicate-id
8992                                                (xetla-unescape file)
8993                                                id nil
8994                                                (eq (char-after) ?\n)))))
8995                     (forward-line 1)
8996                     )))
8997             (while (not (eq (char-after) ?\n))
8998               (ewoc-enter-last cookie
8999                                (list type (xetla-unescape
9000                                            (buffer-substring-no-properties
9001                                             (point)
9002                                             (point-at-eol)))))
9003               (forward-line 1)))))
9004       (let ((inhibit-read-only t))
9005         (ewoc-refresh cookie)))))
9006
9007 (defvar xetla-tree-lint-printer-first-duplicate nil
9008   "Internal variable.
9009 non-nil when the ewoc printer is printing the first group of duplicate ID's")
9010
9011 (defun xetla-tree-lint-printer (elem)
9012   "Ewoc printer for the tree-lint buffer.
9013 Displays ELEM."
9014   (when (not (eq (car elem) 'message))
9015     (insert (if (member (cadr elem)
9016                         xetla-buffer-marked-file-list)
9017                 (concat " " xetla-mark " ") "   ")))
9018   (case (car elem)
9019     (message (insert "\n" (xetla-face-add (cadr elem) 'xetla-messages)
9020                      "\n")
9021              (setq xetla-tree-lint-printer-first-duplicate t))
9022     (missing-file (insert
9023                    (xetla-face-add (cadr elem) 'xetla-to-add
9024                                   'xetla-tree-lint-file-map
9025                                   xetla-tree-lint-file-menu)))
9026     (id-without-file (insert
9027                       (xetla-face-add (cadr elem) 'xetla-to-add
9028                                      'xetla-tree-lint-file-map
9029                                      xetla-tree-lint-file-menu)))
9030     (unrecognized (insert
9031                    (xetla-face-add (cadr elem)
9032                                   'xetla-unrecognized
9033                                   'xetla-tree-lint-file-map
9034                                   xetla-tree-lint-file-menu)))
9035     (broken-link (insert (xetla-face-add (cadr elem)
9036                                         'xetla-broken-link
9037                                         'xetla-tree-lint-file-map
9038                                         xetla-tree-lint-file-menu)))
9039     (unknown (insert (xetla-face-add (cadr elem)
9040                                     'xetla-unrecognized
9041                                     'xetla-tree-lint-file-map
9042                                     xetla-tree-lint-file-menu)))
9043     (duplicate-id
9044      (insert (xetla-face-add (cadr elem)
9045                             'xetla-duplicate
9046                             'xetla-tree-lint-file-map
9047                             xetla-tree-lint-file-menu))
9048      (when (nth 3 elem) (insert "\t"
9049                                 (xetla-face-add (caddr elem)
9050                                                'xetla-id)))
9051      (when (nth 4 elem) (insert "\n")))
9052     (t (error "Unimplemented type of tree-lint error")))
9053   )
9054
9055 (defun xetla-tree-lint-cursor-goto (ewoc-tree-lint)
9056   "Move cursor to the ewoc location of EWOC-TREE-LINT."
9057   (interactive)
9058   (if ewoc-tree-lint
9059       (progn (goto-char (ewoc-location ewoc-tree-lint))
9060              (re-search-forward "." nil t)
9061              (backward-char 1))
9062     (goto-char (point-min))))
9063
9064 (defun xetla-tree-lint-next ()
9065   "Move to the next tree lint item."
9066   (interactive)
9067   (let* ((cookie xetla-tree-lint-cookie)
9068          (elem (ewoc-locate cookie))
9069          (next (or (ewoc-next cookie elem) elem)))
9070     (xetla-tree-lint-cursor-goto next)))
9071
9072 (defun xetla-tree-lint-previous ()
9073   "Move to the previous tree lint item."
9074   (interactive)
9075   (let* ((cookie xetla-tree-lint-cookie)
9076          (elem (ewoc-locate cookie))
9077          (previous (or (ewoc-prev cookie elem) elem)))
9078     (xetla-tree-lint-cursor-goto previous)))
9079
9080 (defun xetla-tree-lint-mark-file ()
9081   "Mark the current tree-lint file."
9082   (interactive)
9083   (let ((current (ewoc-locate xetla-tree-lint-cookie))
9084         (files (xetla-tree-lint-select-files nil nil nil nil nil t t)))
9085     (when files
9086       (dolist (file files)
9087         (add-to-list 'xetla-buffer-marked-file-list file))
9088       (ewoc-refresh xetla-tree-lint-cookie))
9089     (xetla-tree-lint-cursor-goto
9090      (if (eq (car (ewoc-data current)) 'message)
9091          current
9092        (ewoc-next xetla-tree-lint-cookie current)))))
9093
9094 (defun xetla-tree-lint-unmark-file ()
9095   "Unmark the current tree-lint file."
9096   (interactive)
9097   (let ((current (ewoc-locate xetla-tree-lint-cookie))
9098         (files (xetla-tree-lint-select-files nil nil nil nil nil t t)))
9099     (when files
9100       (dolist (file files)
9101         (setq xetla-buffer-marked-file-list
9102               (delete file xetla-buffer-marked-file-list)))
9103       (ewoc-refresh xetla-tree-lint-cookie))
9104     (xetla-tree-lint-cursor-goto
9105      (if (eq (car (ewoc-data current)) 'message)
9106          current
9107        (ewoc-next xetla-tree-lint-cookie current)))))
9108
9109 (defun xetla-tree-lint-unmark-all ()
9110   "Unmark all tree-lint files."
9111   (interactive)
9112   (let ((current (ewoc-locate xetla-tree-lint-cookie)))
9113     (setq xetla-buffer-marked-file-list nil)
9114     (ewoc-refresh xetla-tree-lint-cookie)
9115     (xetla-tree-lint-cursor-goto current)))
9116
9117
9118 (defun xetla-tree-lint-select-files (msg-singular
9119                                     msg-plural msg-err
9120                                     msg-prompt
9121                                     &optional
9122                                     no-group ignore-marked
9123                                     no-prompt
9124                                     y-or-n)
9125   "Get the list of files under cursor, and ask confirmation of the user.
9126 Prompt with either MSG-SINGULAR, MSG-PLURAL, MSG-ERR OR MSG-PROMPT.
9127 If NO-GROUP is nil and if the cursor is on a message, all the
9128 files belonging to this message are selected.  If some files are marked
9129  (i.e. `xetla-buffer-marked-file-list' is non-nil) and IGNORE-MARKED is
9130 non-nil, the list of marked files is returned.  If NO-PROMPT is
9131 non-nil, don't ask for confirmation.  If Y-OR-N is non-nil, then this
9132 function is used instead of `y-or-n-p'."
9133   (if (and xetla-buffer-marked-file-list
9134            (not ignore-marked)
9135            (not (xetla-mouse-event-p last-input-event)))
9136       (let ((list xetla-buffer-marked-file-list))
9137         (unless (or no-prompt
9138                     (funcall (or y-or-n 'y-or-n-p)
9139                              (if (eq 1 (length list))
9140                                  (format msg-singular
9141                                          (car list))
9142                                (format msg-plural
9143                                        (length list))))
9144                     (error msg-err)))
9145         list)
9146     (let* ((ewoc-elem (ewoc-locate xetla-tree-lint-cookie))
9147            (elem (ewoc-data ewoc-elem)))
9148       (if (eq (car elem) 'message)
9149           (progn
9150             (when no-group (error msg-err))
9151             (let ((list nil))
9152               (setq ewoc-elem
9153                     (ewoc-next xetla-tree-lint-cookie ewoc-elem))
9154               (setq elem (and ewoc-elem (ewoc-data ewoc-elem)))
9155               (while (and ewoc-elem (not (eq (car elem) 'message)))
9156                 (add-to-list 'list (cadr elem))
9157                 (setq ewoc-elem
9158                       (ewoc-next xetla-tree-lint-cookie ewoc-elem))
9159                 (setq elem (and ewoc-elem (ewoc-data ewoc-elem))))
9160               (progn
9161                 (unless (or no-prompt
9162                             (funcall (or y-or-n 'y-or-n-p)
9163                                      (if (eq 1 (length list))
9164                                          (format msg-singular
9165                                                  (car list))
9166                                        (format msg-plural
9167                                                (length list)))))
9168                   (error msg-err))
9169                 list)))
9170         (list (if (or no-prompt
9171                       (funcall (or y-or-n 'y-or-n-p)
9172                                (format msg-singular
9173                                        (cadr elem))))
9174                   (cadr elem)
9175                 (error msg-err)))))))
9176
9177 (defun xetla-tree-lint-add-files (files)
9178   "Prompts and add FILES.
9179 If on a message field, add all the files below this message."
9180   (interactive
9181    (list
9182     (xetla-tree-lint-select-files "Add %s? "
9183                                  "Add %s files? "
9184                                  "Not adding any file"
9185                                  "Add file: ")))
9186   (apply 'xetla-add-id nil files)
9187   (xetla-tree-lint default-directory))
9188
9189 (defun xetla-tree-lint-delete-files (files)
9190   "Prompts and delete FILES.
9191 If on a message field, delete all the files below this message."
9192   (interactive
9193    (list
9194     (xetla-tree-lint-select-files "Delete %s? "
9195                                  "Delete %s files? "
9196                                  "Not deleting any file"
9197                                  "Delete file: "
9198                                  nil nil nil
9199                                  'yes-or-no-p)))
9200   (mapcar 'delete-file files)
9201   (xetla-tree-lint default-directory))
9202
9203 (defun xetla-tree-lint-regenerate-id (files)
9204   "Prompts and regenerate an ID (either explicit or tagline) for FILES."
9205   (interactive
9206    (list
9207     (xetla-tree-lint-select-files "Regenerate ID for %s? "
9208                                  "Regenerate ID for %s files? "
9209                                  "Not regenerating ID for any file"
9210                                  "Regenerate ID for file: "
9211                                  t)))
9212   (mapcar 'xetla-regenerate-id-for-file files)
9213   (xetla-tree-lint default-directory))
9214
9215 (defun xetla-tree-lint-make-junk (files)
9216   "Prompts and make the FILES junk.
9217 If marked files are, use them as FIELS.
9218 If not, a file under the point is used as FILES.
9219 If on a message field, make all the files below this message junk."
9220   (interactive
9221    (list
9222     (xetla-tree-lint-select-files "Make %s junk(prefixing \",,\")? "
9223                                  "Make %s files junk? "
9224                                  "Not making any file junk"
9225                                  "Make file junk: "
9226                                  nil nil nil
9227                                  'yes-or-no-p)))
9228   (xetla-generic-file-prefix files ",,"))
9229
9230 (defun xetla-tree-lint-make-precious (files)
9231   "Prompts and make the FILES precious.
9232 If marked files are, use them as FIELS.
9233 If not, a file under the point is used as FILES.
9234 If on a message field, make all the files below this message precious."
9235   (interactive
9236    (list
9237     (xetla-tree-lint-select-files "Make %s precious(prefixing \"++\")? "
9238                                  "Make %s files precious? "
9239                                  "Not making any file precious? "
9240                                  "Make file precious: "
9241                                  nil nil nil
9242                                  'yes-or-no-p)))
9243   (xetla-generic-file-prefix files "++"))
9244
9245 (defun xetla-generic-file-prefix (files prefix)
9246   "Rename FILES with adding prefix PREFIX.
9247 Visited buffer associations also updated."
9248   (mapcar
9249    (lambda (from)
9250      (let* ((buf (find-buffer-visiting from))
9251             (to (concat
9252                  (file-name-directory from)
9253                  prefix
9254                  (file-name-nondirectory from))))
9255        (rename-file from to)
9256        (when buf
9257          (with-current-buffer buf
9258            (rename-buffer to)
9259            (set-visited-file-name to)))))
9260    files)
9261   (xetla-generic-refresh))
9262
9263
9264 ;; end tree-lint-mode
9265
9266 (defvar xetla-arch-version nil
9267   "Version of the underlying tla binary.")
9268
9269 (defvar xetla-arch-version-number nil
9270   "Version _number_ of the underlying tla binary.
9271 It is stored in an alist in the form
9272 \(\(major . <major>\)
9273  \(minor . <minor>\)
9274  \(minor-minor . <minor-minor>\)
9275  \(fix . <fix>\)\)")
9276
9277 (defun xetla-arch-version ()
9278   "Return the TLA (arch) version."
9279   (interactive)
9280   (setq xetla-arch-version
9281         (xetla-run-tla-sync '("-V")
9282                            :finished
9283                            (lambda (output error status arguments)
9284                              (xetla-buffer-content output))))
9285   (if (interactive-p)
9286       (message xetla-arch-version))
9287   xetla-arch-version)
9288
9289 (defun xetla-arch-version-number ()
9290   "Return the TLA (arch) version number.
9291 This is extremely mandatory since tla 1.3 parameters differ from
9292 those used in tla 1.2 for example."
9293   (interactive)
9294   (unless xetla-arch-version
9295     (xetla-arch-version))
9296   (setq xetla-arch-version-number
9297         (when (string-match
9298                (concat "([^0-9]+"
9299                        "\\([0-9]\\)"
9300                        "\\.\\([0-9]\\)"
9301                        "\\.?\\([0-9]\\)?"
9302                        ".*\\(?:fix-?\\)?\\([0-9]\\)?.*)")
9303                xetla-arch-version)
9304           (mapcar* #'cons
9305                    '(major minor minor-minor fix)
9306                    (mapcar #'string-to-number
9307                            (list (match-string 1 xetla-arch-version)
9308                                  (match-string 2 xetla-arch-version)
9309                                  (or (match-string 3 xetla-arch-version)
9310                                      "")
9311                                  (or (match-string 4 xetla-arch-version)
9312                                      ""))))))
9313   (if (interactive-p)
9314       (message "%S" xetla-arch-version-number))
9315   xetla-arch-version-number)
9316
9317
9318 ;;;###autoload
9319 (defun xetla-version ()
9320   "Return the XEtla version."
9321   (interactive)
9322   (let ((version
9323          (or (when (locate-library "xetla-version")
9324                (load-library "xetla-version")
9325                (when (boundp 'xetla-version)
9326                  xetla-version))
9327              (let ((default-directory
9328                      (file-name-directory (locate-library "xetla"))))
9329                (defvar xetla-version nil "Version of xetla")
9330                (xetla-run-tla-sync '("logs" "-f" "-r")
9331                                   :finished
9332                                   (lambda (output error status arguments)
9333                                     (set-buffer output)
9334                                     (goto-char (point-min))
9335                                     (setq xetla-version
9336                                           (buffer-substring-no-properties
9337                                            (point)
9338                                            (point-at-eol))))
9339                                   :error
9340                                   (lambda (output error status arguments)
9341                                     (setq xetla-version "unknown")))))))
9342     (if (not version)
9343         (progn
9344           (message "We did not find xetla-version.el nor the arch-tree containing xetla.el!")
9345           (sit-for 2)
9346           (message "Are you using a developer version of XEtla?")
9347           (sit-for 2))
9348       (if (interactive-p)
9349           (message xetla-version))
9350       xetla-version)))
9351
9352
9353 ;;;###autoload
9354 (defun xetla-prepare-patch-submission (xetla-tree-root tarball-base-name email version-string
9355                                                    &optional description subject)
9356   "Submit a patch to a xetla working copy (at XETLA-TREE-ROOT) via email.
9357 With this feature it is not necessary to tag an xetla archive.
9358 You simply edit your checked out copy from your project and call this function.
9359 The function will create a patch as *.tar.gz file (based on TARBALL-BASE-NAME)
9360 and send it to the given email address EMAIL.
9361 VERSION-STRING should indicate the version of xetla that the patch applies to.
9362 DESCRIPTION is a brief descsription of the patch.
9363 SUBJECT is the subject for the email message.
9364 For an example, how to use this function see: `xetla-submit-patch'."
9365   (interactive)
9366
9367   ;; create the patch
9368   (let* ((default-directory xetla-tree-root)
9369          (tarball-full-base-name (concat default-directory tarball-base-name))
9370          (tarball-full-name (concat tarball-full-base-name ".tar.gz")))
9371     (xetla-changes-save-as-tgz tarball-full-base-name)
9372
9373     (require 'reporter)
9374     (delete-other-windows)
9375     (reporter-submit-bug-report
9376      email
9377      nil
9378      nil
9379      nil
9380      nil
9381      description)
9382
9383     (insert "[VERSION] " version-string)
9384     (goto-char (point-max))
9385     (mml-attach-file tarball-full-name "application/octet-stream")
9386     (xetla-show-changeset-from-tgz tarball-full-name)
9387     (other-window 1)
9388
9389     (goto-char (point-min))
9390     (mail-position-on-field "Subject")
9391     (insert (or subject "[PATCH] "))))
9392
9393 (defvar xetla-package-root-directory nil)
9394 (defun xetla-submit-patch ()
9395   "Submit a patch to the XEtla devel list.
9396 With this feature it is not necessary to tag an xetla.el archive.
9397 You simply edit your checked out copy from xetla.el and call this function.
9398 The function will create a patch as *.tar.gz file and send it to the xetla-el-dev list."
9399   (interactive)
9400   (xetla-version)
9401   (xetla-arch-version)
9402   (xetla-prepare-patch-submission (xetla-tree-root
9403                                  (file-name-directory (or xetla-package-root-directory (locate-library "xetla"))))
9404                                 (concat ",,xetla-patch-" (format-time-string "%Y-%m-%d_%H-%M-%S" (current-time)))
9405                                 "xetla-devel@youngs.au.com"
9406                                 xetla-version
9407                                 (concat
9408                                  "Please change the Subject header to a concise description of your patch.\n"
9409                                  "Please describe your patch between the LOG-START and LOG-END markers:\n"
9410                                  "<<LOG-START>>\n"
9411                                  "\n"
9412                                  "<<LOG-END>>\n"
9413                                  "\n"
9414                                  )))
9415
9416 ;; Integration into gnus
9417 (defvar gnus-summary-xetla-submap nil
9418   "Key mapping added to gnus summary.")
9419
9420 (eval-when-compile
9421   (defvar gnus-summary-mode-map))
9422
9423 (defun xetla-insinuate-gnus ()
9424   "Integrate xetla to gnus.
9425 The following keybindings are installed for gnus-summary:
9426 K t v `xetla-gnus-article-view-patch'
9427 K t a `xetla-gnus-article-apply-patch'
9428 K t l `xetla-gnus-article-extract-log-message'"
9429   (interactive)
9430   (setq gnus-summary-xetla-submap (make-sparse-keymap))
9431   (define-key gnus-summary-xetla-submap [?v] 'xetla-gnus-article-view-patch)
9432   (define-key gnus-summary-xetla-submap [?a] 'xetla-gnus-article-apply-patch)
9433   (define-key gnus-summary-xetla-submap [?l] 'xetla-gnus-article-extract-log-message)
9434   (define-key gnus-summary-mode-map [?K ?t] gnus-summary-xetla-submap))
9435
9436 (defun xetla-gnus-article-view-patch (n)
9437   "View MIME part N, as xetla patchset.
9438 Note, N is forced to 2 at the moment!"
9439   (interactive "p")
9440   (setq n 2)
9441   (gnus-article-part-wrapper n 'xetla-gnus-view-patch))
9442
9443 (defun xetla-gnus-view-patch (handle)
9444   "View a patch within gnus.  HANDLE should be the handle of the part."
9445   (let ((archive-name (xetla-make-temp-name "gnus-patch-tgz")))
9446     (mm-save-part-to-file handle archive-name)
9447     (gnus-summary-select-article-buffer)
9448     (split-window-vertically)
9449     (xetla-show-changeset-from-tgz archive-name)
9450     (delete-file archive-name)))
9451
9452 (defun xetla-gnus-article-apply-patch (n)
9453   "Apply MIME part N, as xetla patchset.
9454 Note, N is forced to 2 at the moment!"
9455   (interactive "p")
9456   (setq n 2)
9457   (gnus-article-part-wrapper n 'xetla-gnus-apply-patch))
9458
9459 (defun xetla-gnus-apply-patch (handle)
9460   "Apply the patch corresponding to HANDLE."
9461   (let ((archive-name (xetla-make-temp-name "gnus-patch-tgz"))
9462         (tree))
9463     (xetla-gnus-article-extract-log-message)
9464     (mm-save-part-to-file handle archive-name)
9465     (gnus-summary-select-article-buffer)
9466     (split-window-vertically)
9467     (xetla-show-changeset-from-tgz archive-name)
9468     (setq tree (read-directory-name
9469                 "Apply to tree: "
9470                 (xetla-name-match-from-list
9471                  (when xetla-memorized-version
9472                    (xetla-name-split xetla-memorized-version))
9473                  xetla-apply-patch-mapping)))
9474     (xetla-apply-changeset-from-tgz archive-name tree)
9475     (delete-file archive-name)))
9476
9477 (defun xetla-gnus-article-extract-log-message ()
9478   "Parse the mail and extract the log information.
9479 Save it to `xetla-memorized-log-header', `xetla-memorized-log-message'
9480 and `xetla-memorized-version'."
9481   (interactive)
9482   (gnus-summary-select-article-buffer)
9483   (save-excursion
9484     (goto-char (point-min))
9485     (let* ((start-pos (search-forward "[PATCH] "))
9486            (end-pos (point-at-eol))
9487            (log-header (buffer-substring-no-properties start-pos end-pos)))
9488       (setq xetla-memorized-log-header log-header))
9489     (goto-char (point-min))
9490     (let* ((start-pos (search-forward "[VERSION] " nil t))
9491            (end-pos (point-at-eol))
9492            (version (when start-pos (buffer-substring-no-properties start-pos end-pos))))
9493       (setq xetla-memorized-version (and start-pos version)))
9494     (goto-char (point-min))
9495     (let* ((start-pos (+ (search-forward "<<LOG-START>>") 1))
9496            (end-pos (- (progn (search-forward "<LOG-END>>") (point-at-bol)) 1))
9497            (log-message (buffer-substring-no-properties start-pos end-pos)))
9498       (setq xetla-memorized-log-message log-message)
9499       (message "Extracted the xetla log message from '%s'" xetla-memorized-log-header)))
9500   (gnus-article-show-summary))
9501
9502 ;;;###autoload
9503 (defun xetla-submit-bug-report ()
9504   "Submit a bug report, with pertinent information to the XEtla Devel list."
9505   (interactive)
9506   (require 'reporter)
9507   (delete-other-windows)
9508   (xetla-version)
9509   (xetla-arch-version)
9510   (reporter-submit-bug-report
9511    "xetla-devel@youngs.au.com"
9512    (concat "XEtla " xetla-version)
9513    (append
9514     ;; non user variables
9515     '(emacs-version
9516       xetla-version
9517       xetla-arch-version
9518       )
9519     ;; user variables
9520     (sort (apropos-internal "^xetla-" 'user-variable-p)
9521           (lambda (v1 v2) (string-lessp (format "%s" v1) (format "%s" v2))))
9522     ;; see what the user had loaded
9523     (list 'features)
9524     )
9525    nil
9526    nil
9527    (concat
9528     "Please change the Subject header to a concise bug description or feature request.\n"
9529     "In this report, remember to cover the basics, that is, what you \n"
9530     "expected to happen and what in fact did happen.\n"
9531     "Please remove these instructions from your message."))
9532
9533   ;; insert the backtrace buffer content if present
9534   (let ((backtrace (get-buffer "*Backtrace*")))
9535     (when backtrace
9536       (goto-char (point-max))
9537       (insert "\n\n")
9538       (insert-buffer-substring backtrace)))
9539
9540   (goto-char (point-min))
9541   (mail-position-on-field "Subject")
9542   (insert "[BUG/FEATURE] "))
9543
9544 ;; For people used to Debian's reportbug
9545 (defalias 'xetla-report-bug 'xetla-submit-bug-report)
9546 ;; For people used to Gnus M-x gnus-bug RET
9547 (defalias 'xetla-bug 'xetla-submit-bug-report)
9548 ;; (reporting bugs should be easy ;-)
9549
9550 (provide 'xetla)
9551
9552 ;;; xetla.el ends here