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

   1 ;;; xetla-browse.el --- Arch archives/library browser
   2
   3 ;; Copyright (C) 2004 by Stefan Reichoer (GPL)
   4 ;; Copyright (C) 2004 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:      archive arch tla
  10
  11 ;; Based on xtla-browse.el by: Masatake YAMATO <jet@gyve.org>
  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 ;;    Stefan Reichoer, <stefan@xsteve.at>
  46 ;;    Matthieu Moy <Matthieu.Moy@imag.fr>
  47 ;;    Masatake YAMATO <jet@gyve.org>
  48 ;;    Milan Zamazal <pdm@zamazal.org>
  49 ;;    Martin Pool <mbp@sourcefrog.net>
  50 ;;    Robert Widhopf-Fenk <hack@robf.de>
  51 ;;    Mark Triggs <mst@dishevelled.net>
  52
  53 ;; 1. Load xetla-browse.el
  54 ;; 2. M-x xetla-browse RET
  55
  56 ;;; TODO:
  57 ;; - Generic refresh
  58 ;;
  59
  60 ;;; History:
  61 ;;
  62
  63 ;;; Code:
  64 (eval-when-compile
  65   (require 'cl)
  66   (autoload 'easy-mmode-define-keymap "easy-mmode")
  67   (autoload 'ad-add-advice "advice"))
  68
  69 (require 'jde-tree-widget)
  70 (require 'xetla)
  71
  72 (defvar xetla-browse-buffer-name "*xetla-browse*")
  73 (defvar xetla-browse-buffer-type 'browse)
  74 (xetla-add-buffer-type xetla-browse-buffer-type
  75                         xetla-browse-buffer-name)
  76
  77 ;; --------------------------------------
  78 ;; Open node tracking
  79 ;; --------------------------------------
  80 (defvar xetla-browse-open-list '()
  81   "List holding the name of open nodes.")
  82
  83 (defun xetla-browse-open-list-member (archive
  84                                      &optional category branch version)
  85   "Return a node, ARCHIVE/CATEGORY-BRANCH-VERSION is opend or not.
  86 CATEGORY, BRANCH, VERSION are optional."
  87   (let ((name (list archive category branch version nil)))
  88     (member name xetla-browse-open-list)))
  89
  90 (defun xetla-browse-open-list-add (archive
  91                                   &optional category branch version)
  92   "Add a node specified by the arguments to 'xetla-browse-open-list'.
  93 ARCHIVE/CATEGORY-BRANCH-VERSION,  ARCHIVE/CATEGORY-BRANCH,
  94 ARCHIVE/CATEGORY, ARCHIVE are added.  CATEGORY, BRANCH, VERSION
  95 are optional."
  96   (xetla-browse-open-list-add-internal (list archive category branch version nil))
  97   (xetla-browse-open-list-add-internal (list archive category branch nil nil))
  98   (xetla-browse-open-list-add-internal (list archive category nil nil nil))
  99   (xetla-browse-open-list-add-internal (list archive nil nil nil nil))
 100   (xetla-browse-open-list-add-internal (list nil nil nil nil nil)))
 101
 102 (defun xetla-browse-open-list-add-internal (name)
 103   "Add NAME to `xetla-browse-open-list'."
 104   (unless (xetla-browse-open-list-member (xetla-name-archive name)
 105                                         (xetla-name-category name)
 106                                         (xetla-name-branch name)
 107                                         (xetla-name-version name))
 108     (push name xetla-browse-open-list)))
 109
 110 (defun xetla-browse-open-list-remove (archive
 111                                      &optional category branch version)
 112   "Remove ARCHIVE/CATEGORY-BRANCH-VERSION from `xetla-browse-open-list'.
 113 CATEGORY, BRANCH and VERSION are optional."
 114   (let ((name (list archive category branch version nil)))
 115     (setq xetla-browse-open-list (delete name xetla-browse-open-list))))
 116
 117 (defun xetla-browse-open-tracker (tree)
 118   "Add or remove a node represented by TREE to/from `xetla-browse-open-list'.
 119 If TREE is opened, it is added.  Else it is removed."
 120   (let* ((node (widget-get tree :node))
 121          (a (widget-get node :archive))
 122          (c (widget-get node :category))
 123          (b (widget-get node :branch))
 124          (v (widget-get node :version)))
 125   (if (widget-get tree :open)
 126       (xetla-browse-open-list-add a c b v)
 127     (xetla-browse-open-list-remove a c b v))))
 128
 129 (defun xetla-browse-find-archives-root-widget ()
 130   "Return the root widget of archives tree."
 131   (save-excursion
 132     (goto-char (point-min))
 133     (re-search-forward " Archives$")
 134     (backward-char 1)
 135     (xetla-widget-node-get-at)))
 136
 137 (defun xetla-browse-find-named-widget (parent name type)
 138   "Find a widget specified with arguments.
 139 PARENT specifies the parent widget.
 140 NAME is the name of the widget.
 141 TYPE is the type of widget.  You can specify :archive, :category,
 142 :branch, or :version."
 143   (let* ((args (widget-get parent :args))
 144          (index (position name args :test (lambda (e w)
 145                                                (let ((node (widget-get w :node)))
 146                                                  ;; Next line is hack for version node.
 147                                                  (unless node (setq node w))
 148                                                  (string= e (widget-get node type))))))
 149          (tree (when index (nth index (widget-get parent :children))))
 150          (node (when tree (save-excursion (goto-char (widget-get tree :from))
 151                                           (goto-char (next-single-property-change (point) 'widget))
 152                                           (xetla-widget-node-get-at)))))
 153     node))
 154
 155
 156 (defun xetla-browse-find-widget (archive
 157                                 &optional category branch version)
 158   "Return a list of widgets: (root archive category branch version)
 159 root is always the root of the tree, of type `xetla-widget-root-node'.
 160 archive is the widget representing ARCHIVE, of type
 161 `xetla-widget-archive-node'.  The last items are potentially nil if
 162 CATEGORY, BRANCH or VERSION is nil.  Otherwise, they are respectively
 163 of type `xetla-widget-category-node', `xetla-widget-revision-node' and
 164 `xetla-widget-version-node'."
 165   (let* ((root (xetla-browse-find-archives-root-widget))
 166          (a    (xetla-browse-find-named-widget
 167                 (widget-get root :parent) archive :archive))
 168          (c    (and a category
 169                     (xetla-browse-find-named-widget
 170                      (widget-get a :parent) category :category)))
 171          (b    (and c branch
 172                     (xetla-browse-find-named-widget
 173                      (widget-get c :parent) branch :branch)))
 174          (v    (and b version
 175                     (xetla-browse-find-named-widget
 176                      (widget-get b :parent) version :version))))
 177     (list root a c b v)))
 178
 179 (defun xetla-browse-find-single-widget (archive
 180                                        &optional category branch
 181                                        version)
 182   "Similar to `xetla-browse-find-widget'.
 183 Difference is it returns only the widget representing the last non-nil
 184 widget of the list.  The means of ARCHIVE, CATEGORY, BRANCH and VERSION
 185 are the same as that of `xetla-browse-find-widget'."
 186   (let ((widgets (xetla-browse-find-widget archive category branch
 187                                           version)))
 188     (or (nth 4 widgets)
 189         (nth 3 widgets)
 190         (nth 2 widgets)
 191         (nth 1 widgets)
 192         (error "Widget not found.  Please fill-in a bug report"))))
 193
 194 (defun xetla-browse-find-real-widget (widget)
 195   "Find real(complete) widget from incomplete WIDGET.
 196 When trying to find widgets using (widget-get ... :args), we
 197 sometimes find an incomplete widget, having no :from or :to
 198 information for example.  This function takes as an argument an
 199 incomplete widget, and finds the corresponding full widget.
 200
 201 WIDGET must be of type xetla-widget-*-node."
 202   (case (widget-type widget)
 203     (xetla-widget-archive-node
 204      (xetla-browse-find-single-widget
 205       (widget-get widget :archive)))
 206     (xetla-widget-category-node
 207      (xetla-browse-find-single-widget
 208       (widget-get widget :archive)
 209       (widget-get widget :category)))
 210     (xetla-widget-branch-node
 211      (xetla-browse-find-single-widget
 212       (widget-get widget :archive)
 213       (widget-get widget :category)
 214       (widget-get widget :branch)))
 215     (xetla-widget-version-node
 216      (xetla-browse-find-single-widget
 217       (widget-get widget :archive)
 218       (widget-get widget :category)
 219       (widget-get widget :version)))))
 220
 221 (defun* xetla-browse-open (flash archive
 222                                 &optional category branch version)
 223   (let (widgets root a c b v)
 224
 225     (unless archive
 226       (return-from xetla-browse-open nil))
 227     (setq widgets (xetla-browse-find-widget archive category branch nil))
 228     (setq root (nth 0 widgets))
 229     (unless root
 230       (error "Cannot find root archives node"))
 231     (xetla-widget-node-toggle-subtree-internal root 'open)
 232
 233     (setq widgets (xetla-browse-find-widget archive category branch nil))
 234     (setq a (nth 1 widgets))
 235     (unless category
 236       (if a
 237           (progn (when flash
 238                    (goto-char (widget-get a :from))
 239                    (xetla-flash-line))
 240             (return-from xetla-browse-open nil))
 241         (error "Cannot find archive node for: %s" archive)))
 242     (xetla-widget-node-toggle-subtree-internal a 'open)
 243
 244     (setq widgets (xetla-browse-find-widget archive category branch nil))
 245     (setq c (nth 2 widgets))
 246     (unless branch
 247       (if c
 248           (progn (when flash
 249                    (goto-char (widget-get c :from))
 250                    (xetla-flash-line))
 251             (return-from xetla-browse-open nil))
 252         (error "Cannot find category node for: %s/%s" archive category)))
 253     (xetla-widget-node-toggle-subtree-internal c 'open)
 254
 255     (setq widgets (xetla-browse-find-widget archive category branch nil))
 256     (setq b (nth 3 widgets))
 257     (unless version
 258       (if b
 259           (progn (when flash
 260                    (goto-char (widget-get b :from))
 261                    (xetla-flash-line))
 262             (return-from xetla-browse-open nil))
 263         (error "Cannot find branch node for: %s/%s-%s" archive category branch)))
 264     (xetla-widget-node-toggle-subtree-internal b 'open)
 265
 266     (setq widgets (xetla-browse-find-widget archive category branch version))
 267     (setq v (nth 4 widgets))
 268     (if v
 269         (progn (when flash
 270                  (goto-char (widget-get v :from))
 271                  (xetla-flash-line))
 272           (return-from xetla-browse-open nil))
 273       (error "Cannot find branch node for: %s/%s-%s-%s" archive category branch version)))
 274   )
 275
 276 ;; --------------------------------------
 277 ;; Abstract Super Widget
 278 ;; --------------------------------------
 279 (define-widget 'xetla-widget-node 'item
 280   "Abstract super widget for xetla-widget-*-node."
 281   :xetla-type nil
 282   :format "%[ %t%]%{%v%}\n"
 283   :face nil
 284   :keymap nil
 285   :menu nil
 286   :marks " "
 287   :keep '(:marks :open)
 288   :open-subtree (if (fboundp 'tree-widget-open-node)
 289                     'tree-widget-open-node
 290                   'xetla-tree-widget-node-toggle-subtree-for-tree-widget-v1)
 291   :close-subtree (if (fboundp 'tree-widget-open-node)
 292                      'tree-widget-close-node
 293                    'xetla-tree-widget-node-toggle-subtree-for-tree-widget-v1))
 294
 295 (defvar xetla-widget-node-map
 296   (let ((map (copy-keymap xetla-context-map-template)))
 297     (define-key map [return]
 298       'xetla-widget-node-toggle-subtree)
 299     (define-key map [button2]
 300       'xetla-widget-node-toggle-subtree-by-mouse)
 301     (define-key map "\C-m"
 302       'xetla-widget-node-toggle-subtree)
 303     (define-key map (xetla-prefix-buffer ?p)
 304       'xetla-show-process-buffer)
 305     (define-key map (xetla-prefix-buffer ?L)
 306       'xetla-open-internal-log-buffer)
 307     (define-key map (xetla-prefix-buffer xetla-key-show-bookmark)
 308       'xetla-bookmarks)
 309     (define-key map xetla-keyvec-kill-ring
 310       'xetla-widget-node-save-name-to-kill-ring)
 311     (define-key map xetla-keyvec-add-bookmark
 312       'xetla-widget-node-add-bookmark)
 313     map)
 314   "Keymap commonly used in xetla-widget-*-node.")
 315
 316 (defun xetla-widget-node-value-create (widget keyword)
 317   "Create value for WIDGET.
 318 KEYWORD is used to get the base string to create the value."
 319   (insert (let* ((marks (widget-get widget :marks))
 320                  (string (widget-get widget keyword))
 321                  (value (xetla-widget-node-install-ui-element
 322                          widget (if (string= string "") "<empty>"
 323                                   string))))
 324             (concat marks value))))
 325
 326 (defun xetla-widget-node-install-ui-element (widget value &optional face)
 327   "Create a string with keymap, menu and face properties.
 328 The keymap and menu are retrieved from WIDGET.
 329 The string is copied from VALUE.
 330 FACE is useds as the face."
 331   (let ((prop-value (xetla-face-add value
 332                                    (if face face (widget-get widget :face))
 333                                    (widget-get widget :keymap)
 334                                    (widget-get widget :menu))))
 335     (put-text-property 0 (length value)
 336                        'widget widget
 337                        prop-value)
 338     prop-value))
 339
 340 (defun xetla-widget-node-get-at (&optional point)
 341   "Get widget at POINT."
 342   (get-text-property (if point point (point)) 'widget))
 343
 344 (defun xetla-widget-node-get-name (&optional point)
 345   "Get name list associated widget under the POINT."
 346   (let ((widget (xetla-widget-node-get-at point)))
 347     (list (widget-get widget :archive)
 348           (widget-get widget :category)
 349           (widget-get widget :branch)
 350           (widget-get widget :version)
 351           nil)))
 352
 353 (defun xetla-widget-node-get-type (&optional point)
 354   "Get type of widget under the POINT.
 355
 356 Can be either 'archive, 'category, 'branch, 'version or nil for the
 357 root of the tree."
 358   (let ((widget (xetla-widget-node-get-at point)))
 359     (widget-get widget :xetla-type)))
 360
 361 (defun xetla-widget-get-ancestor (widget level)
 362   "Get the ancestor widget of WIDGET.
 363 \"ancestor\" widget stands for the LEVEL upper widget
 364 in the archives tree."
 365   (let ((i 0)
 366         (parent widget))
 367     (while (< i level)
 368       (setq parent (widget-get parent :parent)
 369             i (1+ i)))
 370     parent))
 371
 372 (defun xetla-widget-node-refresh (&optional level point
 373                                            archive
 374                                            category
 375                                            branch)
 376   "Refresh node and LEVEL subnode at the POINT.
 377 Before refreshing node, names cache are also refreshed if
 378 ARCHIVE, CATEGORY, and/or BRANCH are specified."
 379   (interactive)
 380   (unless level (setq level 1))
 381   (unless point (setq point (point)))
 382   (if branch
 383       (xetla-archive-tree-build-versions archive
 384                                         category
 385                                         branch
 386                                         nil t)
 387     (if category
 388         (xetla-archive-tree-build-branches archive
 389                                           category
 390                                           nil t)
 391       (if archive
 392           (xetla-archive-tree-build-categories archive
 393                                               nil
 394                                               t)
 395         (xetla-archive-tree-build-archives nil t))))
 396   (let* ((widget (xetla-widget-node-get-at point))
 397          (tree (xetla-widget-get-ancestor widget level)))
 398     (widget-put tree :args nil)
 399     (widget-value-set tree (widget-value tree))
 400     (widget-setup)))
 401
 402 (defun xetla-widget-node-synchronize-mirror-to-remote ()
 403   "Synchronizes the mirror for the archive at point to remote from local."
 404   (interactive)
 405   (let* ((name (xetla-widget-node-get-name))
 406          (archive (xetla-name-archive name))
 407          (type (xetla-archive-type archive))
 408          mirror source)
 409     (cond
 410      ((eq type 'normal)
 411       (setq mirror (xetla-archive-name-mirror archive t))
 412       (unless mirror
 413         (error "No mirror archive for `%s'" archive)))
 414      ((eq type 'mirror)
 415       (setq source (xetla-archive-name-source archive t))
 416       (if source
 417           (setq archive source)
 418         (error "No source archive for `%s'" archive)))
 419      (t (error "Cannot mirror to a source archive: `%s'" archive)))
 420     (xetla-archive-mirror archive
 421                         (xetla-name-category name)
 422                           (xetla-name-branch name)
 423                           (xetla-name-version name)
 424                           nil)))
 425
 426 (defun xetla-widget-node-synchronize-mirror-to-local ()
 427   "Synchronizes the mirror for the archive at point to local from remote."
 428   (interactive)
 429   ;; TODO
 430   )
 431
 432 (defun xetla-widget-node-save-name-to-kill-ring ()
 433   "Save the name under point to `kill-ring'."
 434   (interactive)
 435   (let ((name (xetla-name-construct (xetla-widget-node-get-name))))
 436     (when (equal "" name)
 437       (error "No widget under the point"))
 438     (kill-new name)
 439     (message "Name: %s" name)))
 440
 441 (defun xetla-widget-node-add-bookmark ()
 442   "Add a name associated with a widget at point to xetla's bookmarks."
 443   (interactive)
 444   (let* ((target (xetla-widget-node-get-name))
 445          (target-fq (xetla-name-construct target))
 446          (bookmark (read-from-minibuffer (format "Name of Bookmark for `%s': "
 447                                                  target-fq))))
 448     (xetla-bookmarks-add bookmark target)
 449     (when (y-or-n-p "View bookmarks? ")
 450       (xetla-bookmarks))
 451     (message "bookmark %s(=> %s) added." bookmark target-fq)))
 452
 453 (defun xetla-widget-node-toggle-subtree (&optional point force)
 454   "Toggle between closing and opening the node at POINT.
 455 You can specify a symbol, `open' or `close' to FORCE to force
 456 the node to open or to close."
 457   (interactive)
 458   (xetla-widget-node-toggle-subtree-internal
 459    (xetla-widget-node-get-at point) force))
 460
 461 (defun xetla-widget-node-toggle-subtree-recursive (&optional point
 462                                                             force)
 463   "Same as `xetla-widget-node-toggle-subtree'.
 464 The difference is that when the node is expanded, expands it
 465 recursively, which means all the children will also be expanded.  (this
 466 may take looong).
 467 Meaning of POINT and FORCE are the same as that of
 468 `xetla-widget-node-toggle-subtree'."
 469   (interactive)
 470   (xetla-widget-node-toggle-subtree-internal
 471    (xetla-widget-node-get-at point) force t))
 472
 473 (defun xetla-widget-node-toggle-subtree-internal (widget force
 474                                                         &optional
 475                                                         recursive)
 476   "Toggle between closing and opening the WIDGET.
 477 You can specify a symbol, `open' or `close' to FORCE to force
 478 the node to open or to close.  If RECURSIVE is non-nil, the opening
 479 or closing are applied recursively."
 480   (let* ((open-subtree (widget-get widget :open-subtree))
 481          (close-subtree (widget-get widget :close-subtree)))
 482     (cond
 483      ((or (eq force 'open)
 484           (and (not force)
 485                (not (widget-get (widget-get widget :parent) :open))))
 486       (when open-subtree (funcall open-subtree widget))
 487       (when recursive
 488         (xetla-widget-node-toggle-subtree-recursion widget 'open)))
 489      ((or (eq force 'close)
 490           (and (not force)
 491                (widget-get (widget-get widget :parent) :open)))
 492       (when (and recursive
 493                  (widget-get (widget-get widget :parent) :open))
 494         (when open-subtree (funcall open-subtree widget))
 495         (xetla-widget-node-toggle-subtree-recursion widget 'close))
 496       (when close-subtree (funcall close-subtree widget))))))
 497
 498 (defun xetla-widget-node-toggle-subtree-recursion (widget force)
 499   "A helper function for 'xetla-widget-node-toggle-subtree-internal'.
 500 Apply all sub node of WIDGET opening or closing which is specified
 501 by FORCE."
 502   (let ((args (widget-get (widget-get widget :parent) :args)))
 503     (dolist (arg args)
 504       (let* ((t-widget (widget-get arg :node))
 505              ;; surprisingly, t-widget doesn't have all the
 506              ;; necessary fields. Look for the _real_ widget.
 507              (full-widget
 508               (xetla-browse-find-real-widget t-widget)))
 509         (unless (eq (widget-type t-widget)
 510                     (widget-type full-widget))
 511           (error "Incorrect widget.  Please contact the developers"))
 512         (when full-widget
 513           (xetla-widget-node-toggle-subtree-internal
 514            full-widget force t))))))
 515
 516 (defun xetla-tree-widget-node-toggle-subtree-for-tree-widget-v1 (widget)
 517   "Toggle tree node function used in `xetla-browse' with tree-widget ver.1.0.5.
 518 The code is the almost same as in tree-widget-toggle-folding tree-widget version
 519 1.0.5.
 520
 521 Original documents say:
 522   \"Toggle a `tree-widget' folding.
 523 WIDGET is a `tree-widget-node-handle-widget' and its parent the
 524 `tree-widget' itself.  IGNORE other arguments.\""
 525   (let* ((parent (widget-get widget :parent))
 526          ;; Original code
 527          ; (open   (widget-value widget))
 528          ;; Here `parent' is used instead of `widget'.
 529          (open   (widget-value parent)))
 530     (if open
 531         (tree-widget-children-value-save parent))
 532     (widget-put parent :open (not open))
 533     (widget-value-set parent (not open))
 534     (run-hook-with-args 'tree-widget-after-toggle-functions parent)))
 535
 536 (xetla-make-bymouse-function xetla-widget-node-toggle-subtree)
 537
 538 ;; --------------------------------------
 539 ;; My-id
 540 ;; --------------------------------------
 541 (define-widget 'xetla-widget-my-id 'push-button
 542   "Widget to control xetla's my-id."
 543   :format "%{My-id:%} %[%t%]"
 544   :sample-face 'bold
 545   :button-face 'widget-field-face
 546   :notify 'xetla-widget-my-id-set
 547   :help-echo "Click here to change my-id")
 548
 549 (defun xetla-widget-my-id-set (self changed event)
 550   "Set my-id to my-id-widget.
 551 SELF is not used.  CHANGED is just passed to `widget-value-set'.
 552 EVENT is also not used."
 553   (let ((new-id (xetla-my-id t)))
 554     (widget-value-set changed new-id)
 555     (widget-setup)))
 556
 557 ;; --------------------------------------
 558 ;; Root node
 559 ;; --------------------------------------
 560 (define-widget 'xetla-widget-root-node 'xetla-widget-node
 561   "Root node widget for trees in xetla-browse buffer."
 562   :value-create 'xetla-widget-root-node-value-create
 563   :format " %v\n"
 564   :face 'bold)
 565
 566 (defun xetla-widget-root-node-value-create (widget)
 567   "Create a value for root node represented by WIDGET."
 568   (insert (xetla-widget-node-install-ui-element
 569            widget
 570            (widget-get widget :tag))))
 571
 572 (defvar xetla-widget-archives-root-node-map
 573   (let ((map (copy-keymap xetla-widget-node-map)))
 574     (define-key map xetla-keyvec-refresh
 575       'xetla-widget-node-refresh)
 576     (define-key map (xetla-prefix-add ?a)
 577       'xetla-widget-archives-root-node-make-archive)
 578     (define-key map (xetla-prefix-add ?r)
 579       'xetla-widget-archives-root-node-register-archive)
 580     map)
 581   "Keymap used on the archives root node.")
 582
 583 (easy-menu-define xetla-widget-archives-root-node-menu nil
 584   "Menu used on the root archives item in `xetla-browse-mode' buffer."
 585   '("Archives Root"
 586     ["Update Archives List"
 587      xetla-widget-node-refresh t]
 588     ["Make New Archive..."
 589      xetla-widget-archives-root-node-make-archive t]
 590     ["Register Archive"
 591      xetla-widget-archives-root-node-register-archive t]))
 592
 593 (defun xetla-widget-archives-root-node-make-archive ()
 594   "Call `xetla-make-archive-internal' interactively  then update the tree of `xetla-browse'."
 595   (interactive)
 596   (call-interactively 'xetla-make-archive-internal)
 597   (xetla-widget-node-refresh 1))
 598
 599 (defun xetla-widget-archives-root-node-goto (name)
 600   "Move the point to beginning of line in where the NAME is.
 601 This may be useful to search an archive named NAME."
 602   (goto-char (point-min))
 603   (search-forward name)
 604   (beginning-of-line))
 605
 606 (defun xetla-widget-archives-root-node-register-archive ()
 607   "Call `xetla-register-archive-internal' interactively ; then update the tree of `xetla-browse'."
 608   (interactive)
 609   (let* ((result (call-interactively 'xetla-register-archive-internal))
 610          (archive-registered (nth 0 result))
 611          (archive (nth 1 result))
 612          (xetla-response (nth 3 result)))
 613     (when archive-registered
 614       (xetla-widget-node-refresh 1)
 615       (message xetla-response)
 616       (xetla-widget-archives-root-node-goto
 617        (if (string-match ".+: \\(.+\\)" xetla-response)
 618            (match-string 1 xetla-response)
 619          archive))
 620       (xetla-flash-line))))
 621
 622
 623 ;; --------------------------------------
 624 ;; Archive
 625 ;; --------------------------------------
 626 (defface xetla-location
 627   '((((class color) (background dark)) (:foreground "gray"))
 628     (((class color) (background light)) (:foreground "gray"))
 629     (t (:bold t)))
 630   "Face to highlight xetla's archive location."
 631   :group 'xetla-faces)
 632
 633 (make-face 'xetla-location-ftp
 634            "Face to highlight xetla's archive ftp location.")
 635 (set-face-parent 'xetla-location-ftp 'xetla-location)
 636
 637 (make-face 'xetla-location-sftp
 638            "Face to highlight xetla's archive sftp location.")
 639 (set-face-parent 'xetla-location-sftp 'xetla-location)
 640 (set-face-foreground 'xetla-location-sftp "gray50")
 641
 642 (make-face 'xetla-location-http
 643                   "Face to highlight xetla's archive sftp location.")
 644 (set-face-parent 'xetla-location-http 'xetla-location)
 645 (set-face-foreground 'xetla-location-http "gray60")
 646
 647 (make-face 'xetla-location-local
 648            "Face to highlight xetla's local archive.")
 649 (set-face-parent 'xetla-location-local 'xetla-location)
 650 (set-face-foreground 'xetla-location-local "gray30")
 651
 652 (defvar xetla-widget-archive-node-map
 653   (let ((map (copy-keymap xetla-widget-node-map)))
 654     (define-key map xetla-keyvec-refresh
 655       'xetla-widget-archive-node-refresh)
 656     (define-key map "*" 'xetla-widget-archive-node-select-default)
 657     (define-key map xetla-keyvec-remove
 658       'xetla-widget-archive-node-unregister-archive)
 659     (define-key map (xetla-prefix-add ?c)
 660       'xetla-widget-archive-node-make-category)
 661     (define-key map (xetla-prefix-apply-from-here xetla-key-reflect)
 662       'xetla-widget-archive-node-start-project)
 663     (define-key map xetla-keyvec-reflect
 664       'xetla-widget-node-synchronize-mirror-to-remote)
 665     (define-key map xetla-keyvec-get
 666       'xetla-widget-node-synchronize-mirror-to-local)
 667     (define-key map (xetla-prefix-add xetla-key-reflect)
 668       'xetla-widget-archive-node-make-mirror-at-remote)
 669     (define-key map (xetla-prefix-add xetla-key-get)
 670       'xetla-widget-archive-node-make-mirror-at-local)
 671     map)
 672   "Keymap used on xetla-widget-archive-node.")
 673
 674 (easy-menu-define xetla-widget-archive-node-menu nil
 675   "Menu used on a archive item in `xetla-browse-mode' buffer."
 676   '("Archive"
 677     ["Update Categories List"      xetla-widget-archive-node-refresh t]
 678     ["Set Default Archive"         xetla-widget-archive-node-select-default t]
 679     ["Remove Archive Registration" xetla-widget-archive-node-unregister-archive t]
 680     ["Make New Category..."        xetla-widget-archive-node-make-category t]
 681     ["Start Project from Here"     xetla-widget-archive-node-start-project t]
 682     ["Add a Bookmark"              xetla-widget-node-add-bookmark t]
 683     ("Remote Mirror"
 684      ["Synchronize Mirror to Remote From Local"
 685       xetla-widget-node-synchronize-mirror-to-remote
 686       (let* ((archive (xetla-name-archive (xetla-widget-node-get-name)))
 687              (type (xetla-archive-type archive)))
 688         (or (and (eq type 'normal)
 689                  (xetla-archive-name-mirror archive t))
 690             (and (eq type 'mirror)
 691                  (xetla-archive-name-source archive t))))]
 692      ["Create a Mirror at Remote"
 693       xetla-widget-archive-node-make-mirror-at-remote
 694       (eq (xetla-archive-type (xetla-name-archive (xetla-widget-node-get-name)))
 695           'normal)])
 696     ("Local Mirror"
 697      ["Synchronize Mirror to Local[TODO]"
 698       ;; TODO
 699       xetla-widget-node-synchronize-mirror-to-local nil]
 700      ["Create a Mirror at Local" xetla-widget-archive-node-make-mirror-at-local
 701       (eq (xetla-archive-type (xetla-name-archive (xetla-widget-node-get-name)))
 702           'source)]
 703      "-"
 704      ["Convert to SOURCE archive" xetla-widget-archive-node-convert-to-source
 705       (eq (xetla-archive-type (xetla-name-archive (xetla-widget-node-get-name)))
 706           'normal)])
 707     ["Save Name to Kill Ring" xetla-widget-node-save-name-to-kill-ring t]))
 708
 709 (defconst xetla-widget-archive-node-tag "a")
 710 (defconst xetla-widget-archive-node-default-tag "A")
 711
 712 (define-widget 'xetla-widget-archive-node 'xetla-widget-node
 713   "Archive node in xetla-browse."
 714   :tag xetla-widget-archive-node-tag
 715   :value-create 'xetla-widget-archive-node-value-create
 716   :xetla-type 'archive
 717   :face 'xetla-archive-name
 718   :keymap 'xetla-widget-archive-node-map
 719   :menu xetla-widget-archive-node-menu
 720   :archive nil
 721   :archive-location nil
 722   :archive-defaultp nil)
 723
 724 (defvar xetla-widget-archive-node-list nil)
 725 (defun xetla-browse-expand-archives (root)
 726   "Expand ROOT widget."
 727   (or (and (not current-prefix-arg) (widget-get root :args))
 728       (let ((default-archive (xetla-my-default-archive)))
 729         (setq xetla-widget-archive-node-list nil)
 730         (mapcar
 731          (lambda (archive)
 732            (let ((res
 733                   `(tree-widget
 734                     :open ,(xetla-browse-open-list-member (car archive))
 735                     :has-children t
 736                     :dynargs xetla-browse-expand-categories
 737                     :node (xetla-widget-archive-node
 738                            :tag ,(if (equal default-archive (car archive))
 739                                      xetla-widget-archive-node-default-tag
 740                                    xetla-widget-archive-node-tag)
 741                            :archive ,(car archive)
 742                            :archive-location ,(cadr archive)
 743                            :archive-defaultp ,(equal
 744                                                default-archive
 745                                                (car
 746                                                 archive))))))
 747              (widget-put (widget-get res :node) :parent res)
 748              res))
 749          (let* ((l xetla-archive-tree))
 750            (when (or (null l) current-prefix-arg)
 751              (xetla-archive-tree-build-archives nil t))
 752            xetla-archive-tree)))))
 753
 754 (defun xetla-widget-archive-node-value-create (widget)
 755   "Create values for WIDGET."
 756   (push widget xetla-widget-archive-node-list)
 757   (insert (let* ((archive  (widget-get widget :archive))
 758                  (location (widget-get widget :archive-location))
 759                  (defaultp (widget-get widget :archive-defaultp))
 760                  (marks    (widget-get widget :marks))
 761                  (value (progn
 762                           (case (xetla-archive-type archive)
 763                             (mirror (widget-put widget :face 'xetla-mirror-archive-name))
 764                             (source (widget-put widget :face 'xetla-source-archive-name)))
 765                           ;;
 766                           ;; It seems that XEmacs's format hides text properties.
 767                           ;;
 768                           (concat marks
 769                                   (xetla-widget-node-install-ui-element
 770                                    widget archive (when defaultp
 771                                                     'xetla-marked))
 772                                   " => "
 773                                   (xetla-widget-archive-put-face-on-location
 774                                    location)))))
 775             value)))
 776
 777 (defun xetla-widget-archive-put-face-on-location (location)
 778   "Set face to LOCATION based on the location type(ftp, sftp, http or local)."
 779 (let ((face (case (xetla-location-type location)
 780                 (ftp 'xetla-location-ftp)
 781                 (sftp 'xetla-location-sftp)
 782                 (http 'xetla-location-http)
 783                 (local 'xetla-location-local)))
 784         (location (copy-sequence location)))
 785     (put-text-property 0 (length location)
 786                        'face face location)
 787     location))
 788
 789 (defun xetla-widget-archive-node-refresh ()
 790   "Refresh an archive node under the point."
 791   (interactive)
 792   (xetla-widget-node-refresh 1 nil
 793                             (xetla-name-archive
 794                              (xetla-widget-node-get-name))))
 795
 796 (defun xetla-widget-archive-node-select-default ()
 797   "Mark a widget associated with the default archive.
 798 Unmark widgets not associated with the default archive.
 799 `:archive-defaultp' keyword is used to mark."
 800   (interactive)
 801   (mapc
 802    (lambda (widget)
 803      (when (equal xetla-widget-archive-node-default-tag
 804                   (widget-get widget :tag))
 805        (widget-put widget :tag xetla-widget-archive-node-tag)
 806        (widget-put widget :archive-defaultp nil)
 807        (widget-value-set widget (widget-value widget))))
 808    xetla-widget-archive-node-list)
 809   (let* ((widget (xetla-widget-node-get-at))
 810          (archive (xetla-name-archive (xetla-widget-node-get-name) )))
 811     (xetla-my-default-archive archive)
 812     (widget-put widget :tag xetla-widget-archive-node-default-tag)
 813     (widget-put widget :archive-defaultp t)
 814     (widget-value-set widget (widget-value widget))))
 815
 816 (defun xetla-widget-archive-node-unregister-archive ()
 817   "Delete the registration of the archive under the point."
 818   (interactive)
 819   (let ((archive (xetla-name-archive (xetla-widget-node-get-name))))
 820     (if archive
 821         (progn (xetla-unregister-archive archive t)
 822                (xetla-widget-node-refresh 2))
 823       (error "No archive under the point"))))
 824
 825 (defun xetla-widget-archive-node-make-category ()
 826   "Make new category in the archive under the point."
 827   (interactive)
 828   (let* ((name (xetla-widget-node-get-name))
 829          (archive (xetla-name-archive name))
 830          (l (xetla-name-read "New Category: "
 831                             archive
 832                             'prompt)))
 833     (xetla-make-category (xetla-name-archive l) (xetla-name-category l))
 834     (xetla-widget-node-refresh 1 nil (xetla-name-archive l))
 835     (xetla-browse-open t
 836                       (xetla-name-archive l)
 837                       (xetla-name-category l))
 838     ))
 839
 840 (defun xetla-widget-archive-node-convert-to-source ()
 841   "Convert the archive under the point to a source archive."
 842   (interactive)
 843   (let* ((widget (xetla-widget-node-get-at))
 844          (archive (widget-get widget :archive))
 845          (location (widget-get widget :archive-location))
 846          (result (xetla-archive-convert-to-source-archive archive location)))
 847     (let ((archive-registered (nth 0 result))
 848           (archive (nth 1 result))
 849           (xetla-response (nth 3 result)))
 850       (when archive-registered
 851         (xetla-widget-node-refresh 2)
 852         (message xetla-response)
 853         (xetla-widget-archives-root-node-goto
 854          (if (string-match ".+: \\(.+\\)" xetla-response)
 855              (match-string 1 xetla-response)
 856            archive))
 857         (xetla-flash-line)))))
 858
 859 (defun xetla-widget-archive-node-start-project ()
 860   "Start new project in the archive unde the point."
 861   (interactive)
 862   (let* ((archive (xetla-name-archive (xetla-widget-node-get-name)))
 863          (buffer (current-buffer))
 864          (p (point))
 865          (result (xetla-start-project archive 'synchronously))
 866          (category (xetla-name-category (car result)))
 867          (branch (xetla-name-branch (car result)))
 868          (version (xetla-name-version (car result)))
 869          )
 870     (with-current-buffer buffer
 871       (xetla-widget-node-refresh 1 p archive)
 872       (xetla-browse-open t
 873                         archive category branch version))))
 874
 875 (defun xetla-widget-archive-node-make-mirror-at-remote ()
 876   "Create a mirror for the local archive under the point at somewhere remote."
 877   (interactive)
 878   (let ((archive (xetla-name-archive (xetla-widget-node-get-name))))
 879     (unless archive
 880       (error "No archive under the point"))
 881     (xetla-mirror-archive archive nil nil nil nil)
 882     (xetla-widget-node-refresh 2)
 883     (xetla-widget-archives-root-node-goto (format "%s-MIRROR" archive))
 884     (xetla-flash-line)))
 885
 886 (defun xetla-widget-archive-node-make-mirror-at-local ()
 887   "Create a mirror for the remote archive under the point to local."
 888   (interactive)
 889   (let ((archive (xetla-name-archive (xetla-widget-node-get-name))))
 890     (unless archive
 891       (error "No archive under the point"))
 892     (xetla-mirror-from-archive archive nil)
 893     (xetla-widget-node-refresh 2)
 894     (string-match "\\(.*\\)-SOURCE$" archive)
 895     (xetla-widget-archives-root-node-goto
 896      ;; Adding a space not to match SOURCE archive.
 897      (concat (match-string 1 archive) " "))
 898     (xetla-flash-line)))
 899
 900 ;; --------------------------------------
 901 ;; Categories
 902 ;; --------------------------------------
 903 (defvar xetla-widget-category-node-map
 904   (let ((map (copy-keymap xetla-widget-node-map)))
 905     (define-key map xetla-keyvec-refresh
 906       'xetla-widget-category-node-refresh)
 907     (define-key map (xetla-prefix-add ?b)
 908       'xetla-widget-category-node-make-branch)
 909     map)
 910   "Keymap used on xetla-widget-category-node.")
 911
 912 (easy-menu-define xetla-widget-category-node-menu nil
 913   "Menu used on a archive item in `xetla-browse-mode' buffer."
 914   '("Category"
 915     ["Update Branches List" xetla-widget-category-node-refresh t]
 916     ["Remove Category[NOT IMPLEMENTED]" nil t]
 917     ["Make New Branch..." xetla-widget-category-node-make-branch t]
 918     ["Add a Bookmark" xetla-widget-node-add-bookmark t]
 919     ["Synchronize Mirror to Remote"
 920      xetla-widget-node-synchronize-mirror-to-remote t]
 921     ["Save Name to Kill Ring" xetla-widget-node-save-name-to-kill-ring t]))
 922
 923 (define-widget 'xetla-widget-category-node 'xetla-widget-node
 924   "Category node in xetla-browse."
 925   :tag "c"
 926   :value-create 'xetla-widget-category-node-value-create
 927   :xetla-type 'category
 928   :face 'xetla-category-name
 929   :keymap 'xetla-widget-category-node-map
 930   :menu xetla-widget-category-node-menu
 931   :archive nil
 932   :category nil)
 933
 934 (defun xetla-browse-expand-categories (archive)
 935   "Expand ARCHIVE widget."
 936   (or (and (not current-prefix-arg) (widget-get archive :args))
 937       (let ((archive-name (widget-get
 938                            (widget-get archive :node)
 939                            :archive)))
 940         (mapcar
 941          (lambda (category)
 942            (let ((res `(tree-widget
 943                         :open ,(xetla-browse-open-list-member archive-name
 944                                                              (car category))
 945                         :has-children t
 946                         :dynargs xetla-browse-expand-branches
 947                         :node (xetla-widget-category-node
 948                                :archive ,archive-name
 949                                :category ,(car category)))))
 950              (widget-put (widget-get res :node) :parent res)
 951              res))
 952          (let* ((l (cddr (xetla-archive-tree-get-archive
 953                           archive-name))))
 954            (when (or (null l) current-prefix-arg)
 955              (xetla-archive-tree-build-categories archive-name nil t))
 956            (cddr (xetla-archive-tree-get-archive archive-name)))))))
 957
 958 (defun xetla-widget-category-node-value-create (widget)
 959   "Create values for category WIDGET."
 960   (xetla-widget-node-value-create widget :category))
 961
 962 (defun xetla-widget-category-node-refresh ()
 963   "Refresh a category widget at the point."
 964   (interactive)
 965   (let ((name (xetla-widget-node-get-name)))
 966     (xetla-widget-node-refresh 1 nil
 967                               (xetla-name-archive name)
 968                               (xetla-name-category name))))
 969
 970 (defun xetla-widget-category-node-make-branch ()
 971   "Make new branch in the category under the point."
 972   (interactive)
 973   (let* ((name (xetla-widget-node-get-name))
 974          (archive (xetla-name-archive name))
 975          (category  (xetla-name-category name))
 976          (l (xetla-name-read "New Branch: "
 977                             archive
 978                             category
 979                             'prompt)))
 980     (xetla-make-branch (xetla-name-archive l)
 981                      (xetla-name-category l)
 982                      (xetla-name-branch l))
 983     (xetla-widget-node-refresh 1 nil
 984                               (xetla-name-archive l)
 985                               (xetla-name-category l))
 986     (xetla-browse-open t
 987                       (xetla-name-archive l)
 988                       (xetla-name-category l)
 989                       (xetla-name-branch l))))
 990
 991 ;; --------------------------------------
 992 ;; Branch
 993 ;; --------------------------------------
 994 (defvar xetla-widget-branch-node-map
 995   (let ((map (copy-keymap xetla-widget-node-map)))
 996     (define-key map xetla-keyvec-refresh
 997       'xetla-widget-branch-node-refresh)
 998     (define-key map (xetla-prefix-add ?v)
 999       'xetla-widget-branch-node-make-version)
1000     (define-key map xetla-keyvec-get
1001       'xetla-widget-branch-node-get-branch)
1002     map)
1003   "Keymap used on xetla-widget-branch-node.")
1004
1005 (easy-menu-define xetla-widget-branch-node-menu nil
1006   "Menu used on a archive item in `xetla-browse-mode' buffer."
1007   '("Branch"
1008     ["Update Version List" xetla-widget-branch-node-refresh t]
1009     ["Remove Branch Registration[NOT IMPLEMENTED]" nil t]
1010     ["Make New Version..." xetla-widget-branch-node-make-version t]
1011     ["Get..."              xetla-widget-branch-node-get-branch t]
1012     ["Add a Bookmark" xetla-widget-node-add-bookmark t]
1013     ["Synchronize Mirror to Remote"
1014      xetla-widget-node-synchronize-mirror-to-remote t]
1015     ["Save Name to Kill Ring" xetla-widget-node-save-name-to-kill-ring t]))
1016
1017 (define-widget 'xetla-widget-branch-node 'xetla-widget-node
1018   "Branch node in xetla-browse."
1019   :tag "b"
1020   :value-create 'xetla-widget-branch-node-value-create
1021   :xetla-type 'branch
1022   :face 'xetla-branch-name
1023   :keymap 'xetla-widget-branch-node-map
1024   :menu xetla-widget-branch-node-menu
1025   :archive nil
1026   :category nil
1027   :branch nil)
1028
1029 (defun xetla-browse-expand-branches (category)
1030   "Expand CATEGORY widget."
1031   (or (and (not current-prefix-arg) (widget-get category :args))
1032       (let* ((parent-node   (widget-get category :node))
1033              (archive-name  (widget-get parent-node :archive))
1034              (category-name (widget-get parent-node :category)))
1035         (mapcar
1036          (lambda (branch)
1037            (let ((res
1038                   `(tree-widget
1039                     :open ,(xetla-browse-open-list-member archive-name
1040                                                          category-name
1041                                                          (car branch))
1042                     :has-children t
1043                     :leaf-control xetla-widget-version-control
1044                     :dynargs xetla-browse-expand-versions
1045                     :node (xetla-widget-branch-node
1046                            :archive ,archive-name
1047                            :category ,category-name
1048                            :branch ,(car branch)))))
1049              (widget-put (widget-get res :node) :parent res)
1050              res))
1051          (let* ((l (cdr (xetla-archive-tree-get-category
1052                          archive-name
1053                          category-name))))
1054            (when (or (null l) current-prefix-arg)
1055              (xetla-archive-tree-build-branches archive-name
1056                                                category-name
1057                                                nil t))
1058            (cdr (xetla-archive-tree-get-category archive-name
1059                                                 category-name)))))))
1060
1061 (defun xetla-widget-branch-node-value-create (widget)
1062   "Create values for branch WIDGET."
1063   (xetla-widget-node-value-create widget :branch))
1064
1065 (defun xetla-widget-branch-node-refresh ()
1066   "Refresh a branch widget at the point."
1067   (interactive)
1068   (let ((name (xetla-widget-node-get-name)))
1069     (xetla-widget-node-refresh 1 nil
1070                               (xetla-name-archive name)
1071                               (xetla-name-category name)
1072                               (xetla-name-branch name))))
1073
1074 (defun xetla-widget-branch-node-make-version ()
1075   "Make new version in the branch under the point."
1076   (interactive)
1077   (let* ((name (xetla-widget-node-get-name))
1078          (archive (xetla-name-archive name))
1079          (category (xetla-name-category name))
1080          (branch (xetla-name-category name))
1081          (l (xetla-name-read "New Version: "
1082                             archive
1083                             category
1084                             branch
1085                             'prompt)))
1086     (xetla-make-version (xetla-name-archive l)
1087                       (xetla-name-category l)
1088                       (xetla-name-branch l)
1089                       (xetla-name-version l))
1090     (xetla-widget-node-refresh 1 nil
1091                               (xetla-name-archive l)
1092                               (xetla-name-category l)
1093                               (xetla-name-branch l))
1094     (xetla-browse-open t
1095                       (xetla-name-archive l)
1096                       (xetla-name-category l)
1097                       (xetla-name-branch l)
1098                       (xetla-name-version l))))
1099
1100 (defun xetla-widget-branch-node-get-branch ()
1101   "Run `tla get' against the branch at point."
1102   (interactive)
1103   (let* ((name (xetla-widget-node-get-name))
1104          (archive (xetla-name-archive name))
1105          (category (xetla-name-category name))
1106          (branch (xetla-name-branch name))
1107          (directory (expand-file-name
1108                      (read-directory-name
1109                       (format "Restore \"%s\" to: "
1110                               (progn
1111                                 (unless branch
1112                                   (error "No branch under the point"))
1113                                 (xetla-name-construct
1114                                  archive category branch)))))))
1115     (if branch
1116         (xetla-get directory
1117                  'ask
1118                  archive
1119                  category
1120                  branch)
1121       (error "No branch under the point"))))
1122
1123
1124 ;; --------------------------------------
1125 ;; Version
1126 ;; --------------------------------------
1127 (defvar xetla-widget-version-node-map
1128   (let ((map (copy-keymap xetla-widget-node-map)))
1129     (define-key map xetla-keyvec-refresh
1130       'xetla-widget-version-node-show-revisions)
1131     (define-key map xetla-keyvec-get
1132       'xetla-widget-version-node-get-version)
1133     (define-key map xetla-keyvec-tag 'xetla-widget-version-node-tag)
1134     map)
1135   "Keymap used on xetla-widget-version-node.")
1136
1137 (easy-menu-define xetla-widget-version-node-menu nil
1138   "Menu used on a archive item in `xetla-browse-mode' buffer."
1139   '("Version"
1140     ["Show Revisions" xetla-widget-version-node-show-revisions t]
1141     ["Remove Version Registration[NOT IMPLEMENTED]" nil t]
1142     ["Get..." xetla-widget-version-node-get-version t]
1143     ["Add a Bookmark" xetla-widget-node-add-bookmark t]
1144     ["Synchronize Mirror to Remote"
1145      xetla-widget-node-synchronize-mirror-to-remote t]
1146     ["Put Tag..." xetla-widget-version-node-tag t]
1147     ["Save Name to Kill Ring" xetla-widget-node-save-name-to-kill-ring t]))
1148
1149 (define-widget 'xetla-widget-version-node 'xetla-widget-node
1150   "Version node in xetla-browse."
1151   :tag "v"
1152   :value-create 'xetla-widget-version-node-value-create
1153   :xetla-type 'version
1154   :face 'xetla-version-name
1155   :keymap 'xetla-widget-version-node-map
1156   :menu   xetla-widget-version-node-menu
1157   :archive nil
1158   :category nil
1159   :branch nil
1160   :version nil
1161   :open-subtree 'xetla-widget-version-node-open-subtree
1162   :close-subtree 'xetla-widget-version-node-open-subtree)
1163
1164
1165 (define-widget 'xetla-widget-version-control 'tree-widget-empty-control
1166   "Control widget that represents a leaf version node."
1167   :tag       "[->]"
1168   :format    "%[%t%]"
1169   :action  'xetla-widget-version-control-show-revisions)
1170
1171 (defun xetla-widget-version-control-show-revisions (widget &optional event)
1172   "Show revisions in a version associated with WIDGET.
1173 The version is under the point or place where click EVENT is created."
1174   (if event
1175       (mouse-set-point event))
1176   (let ((pos (next-single-property-change (point)
1177                                           'widget
1178                                           (current-buffer)
1179                                           (point-at-eol))))
1180     (when pos
1181       (xetla-widget-version-node-show-revisions pos))))
1182
1183 (defun xetla-browse-expand-versions (branch)
1184   "Expand BRANCH widget."
1185   (or (and (not current-prefix-arg) (widget-get branch :args))
1186       (let* ((parent-node   (widget-get branch :node))
1187              (archive-name  (widget-get parent-node :archive))
1188              (category-name (widget-get parent-node :category))
1189              (branch-name (widget-get parent-node :branch)))
1190         (mapcar (lambda (version)
1191                   `(xetla-widget-version-node
1192                         :archive  ,archive-name
1193                         :category ,category-name
1194                         :branch   ,branch-name
1195                         :version  ,(car version)))
1196                 (let* ((l (cdr (xetla-archive-tree-get-branch archive-name
1197                                                              category-name
1198                                                              branch-name))))
1199                   (when (or (null l) current-prefix-arg)
1200                     (xetla-archive-tree-build-versions archive-name
1201                                                       category-name
1202                                                       branch-name
1203                                                       nil t))
1204                   (cdr (xetla-archive-tree-get-branch archive-name
1205                                                      category-name
1206                                                      branch-name)))))))
1207
1208 (defun xetla-widget-version-node-value-create (widget)
1209   "Create values for version WIDGET."
1210   (xetla-widget-node-value-create widget :version))
1211
1212 (defun xetla-widget-version-node-show-revisions (&optional point)
1213   "Show revisions in the version under the POINT.
1214 If POINT is nil, use the point under `point'."
1215   (interactive)
1216   (let ((name (xetla-widget-node-get-name (or point (point)))))
1217     (xetla-revisions (xetla-name-archive name)
1218                    (xetla-name-category name)
1219                    (xetla-name-branch name)
1220                    (xetla-name-version name)
1221                    nil nil)))
1222
1223 (defun xetla-widget-version-node-get-version ()
1224   "Run \"tla get\" against the version at point."
1225   (interactive)
1226   (let* ((name (xetla-widget-node-get-name))
1227          (archive (xetla-name-archive name))
1228          (category (xetla-name-category name))
1229          (branch (xetla-name-branch name))
1230          (version (xetla-name-version name))
1231          (directory (expand-file-name
1232                      (read-directory-name
1233                       (format "Restore \"%s\" to: "
1234                               (progn
1235                                 (unless version
1236                                   (error "No version under the point"))
1237                                 (xetla-name-construct
1238                                  archive category branch version)))))))
1239     (if version
1240         (xetla-get directory
1241                  'ask
1242                  archive
1243                  category
1244                  branch
1245                  version)
1246       (error "No version under the point"))))
1247
1248 (defun xetla-widget-version-node-tag ()
1249   "Run tla tag from the version under the point."
1250   (interactive)
1251   (let* ((from (xetla-widget-node-get-name))
1252          (from-fq (xetla-name-construct from))
1253          (to   (xetla-name-read (format "Tag from `%s' to: " from-fq)
1254                                'prompt 'prompt 'prompt 'prompt))
1255          (to-fq (xetla-name-construct to)))
1256     (unless from
1257       (error "No version under the point"))
1258     (unless to-fq
1259       (error "Wrong version tagged to is given"))
1260     (save-excursion
1261       (xetla-version-tag-internal from-fq to-fq 'synchronously))
1262     (xetla-widget-node-refresh 1 nil
1263                               (xetla-name-archive to-fq)
1264                               (xetla-name-category to-fq)
1265                               (xetla-name-branch to-fq))
1266     (xetla-browse-open t
1267                       (xetla-name-archive to-fq)
1268                       (xetla-name-category to-fq)
1269                       (xetla-name-branch to-fq)
1270                       (xetla-name-version to-fq))))
1271
1272 (defun xetla-widget-version-node-open-subtree (widget)
1273   "List revisions in the version associated with WIDGET."
1274   (xetla-revisions (widget-get widget :archive)
1275                  (widget-get widget :category)
1276                  (widget-get widget :branch)
1277                  (widget-get widget :version)
1278                  nil nil))
1279
1280 ;; --------------------------------------
1281 ;; Entry point
1282 ;; --------------------------------------
1283 ;; TODO: Filtered by GROUP in bookmark
1284 ;;;###autoload
1285 (defun xetla-browse (&optional initial-open-list append)
1286   "Browse registered archives as trees within one buffer.
1287 You can specify the node should be opened by alist,
1288 INITIAL-OPEN-LIST.  If APPEND is nil, the nodes not in
1289 INITIAL-OPEN-LIST are made closed.  If non-nil, the nodes
1290 already opened are kept open."
1291
1292   (interactive)
1293   (switch-to-buffer (xetla-get-buffer-create
1294                      xetla-browse-buffer-type))
1295   (make-local-variable 'xetla-browse-open-list)
1296   (setq truncate-lines t)
1297
1298   (let (building)
1299     (if (zerop (buffer-size))
1300         (progn (setq building t)
1301                (xetla-browse-set-initial-open-list initial-open-list t))
1302       (if append
1303           (progn
1304             (setq building nil)
1305             (xetla-browse-set-initial-open-list initial-open-list nil))
1306         (if (y-or-n-p (format "Remove old %s? " (buffer-name)))
1307             (progn (setq building t)
1308                    (xetla-browse-set-initial-open-list initial-open-list nil))
1309           (setq building nil)
1310           (xetla-browse-set-initial-open-list initial-open-list t))))
1311
1312     (if building
1313         (progn
1314           (xetla-browse-erase-buffer)
1315           (xetla-browse-build-buffer))
1316       (mapc
1317        (lambda (elt)
1318          (xetla-browse-open nil
1319                            (xetla-name-archive elt)
1320                            (xetla-name-category elt)
1321                            (xetla-name-branch elt)
1322                            (xetla-name-version elt)))
1323        xetla-browse-open-list)))
1324   (goto-char (point-min))
1325   (xetla-browse-mode))
1326
1327 (defun xetla-browse-set-initial-open-list (list clearp)
1328   "Insert LIST to `xetla-browse-open-list'.
1329 If CLEARP is set, clear `xetla-browse-open-list' before insertion.
1330 This is a helper function for `xetla-browse'."
1331   (when clearp
1332     (setq xetla-browse-open-list nil))
1333   (mapc
1334    (lambda (elt)
1335      (xetla-browse-open-list-add (xetla-name-archive elt)
1336                                 (xetla-name-category elt)
1337                                 (xetla-name-branch elt)
1338                                 (xetla-name-version elt)))
1339    list))
1340 (defun xetla-browse-erase-buffer ()
1341   "Erase *xetla-browse* buffer."
1342   (let ((inhibit-read-only t))
1343     (erase-buffer))
1344   ;; remove-extent is not portable enough.
1345   (mapc #'delete-extent
1346         (mapcar-extents #'identity
1347                         nil nil (point-min) (point-max)
1348                         'all-extents-closed-open)))
1349
1350 (defun xetla-browse-build-buffer ()
1351   "Insert contents of *xetla-buffer*."
1352   ;; Xetla config
1353   (widget-create 'tree-widget
1354                  :open t
1355                  :node '(item :format "%[%t%]\n"
1356                               :tag "Personal Configuration")
1357                  :has-chidren t
1358                  `(xetla-widget-my-id ,(xetla-my-id)))
1359
1360   (widget-insert "\n")
1361
1362   ;; Archives
1363   (add-hook 'tree-widget-after-toggle-functions
1364             'xetla-browse-open-tracker)
1365   (widget-create 'tree-widget
1366                  :open t
1367                  :node `(xetla-widget-root-node
1368                          :xetla-type archives-root
1369                          :tag "Archives"
1370                          :keymap xetla-widget-archives-root-node-map
1371                          :menu ,xetla-widget-archives-root-node-menu)
1372                  :has-children t
1373                  :dynargs 'xetla-browse-expand-archives)
1374   ;; Libraries
1375   ;; TODO
1376   (widget-setup))
1377
1378 (defun xetla-browse-toggle-subtree-maybe ()
1379   "Run `xetla-browse-toggle-subtree'.
1380 Before running a widget is searched and move the point to
1381 the widget if it is found.  If no widget is found,
1382 `widget-button-press'."
1383   (interactive)
1384   (let ((p (next-single-property-change (point-at-bol)
1385                                         'widget
1386                                         nil
1387                                         (point-at-eol))))
1388     (if (and p (xetla-widget-node-get-type p))
1389         (xetla-widget-node-toggle-subtree p)
1390       (widget-button-press (point)))))
1391
1392 (defun xetla-browse-dash ()
1393   "Move the point to the place where a widget is in the current line."
1394   (interactive)
1395   (let ((p (next-single-property-change (point-at-bol)
1396                                         'widget
1397                                         nil
1398                                         (point-at-eol))))
1399     (when (and p (xetla-widget-node-get-type p))
1400       (goto-char p)
1401       (xetla-flash-line))))
1402
1403 (defvar xetla-browse-map
1404   (let ((map (copy-keymap widget-keymap)))
1405     (define-key map xetla-keyvec-help 'describe-mode)
1406     (define-key map (xetla-prefix-buffer ?p) 'xetla-show-process-buffer)
1407     (define-key map (xetla-prefix-buffer ?L) 'xetla-open-internal-log-buffer)
1408     (define-key map (xetla-prefix-buffer xetla-key-show-bookmark) 'xetla-bookmarks)
1409     (define-key map [return] 'xetla-browse-toggle-subtree-maybe)
1410     (define-key map "\C-m" 'xetla-browse-toggle-subtree-maybe)
1411     (define-key map " " 'xetla-browse-dash)
1412     (define-key map xetla-keyvec-next     'next-line)
1413     (define-key map xetla-keyvec-previous 'previous-line)
1414     (define-key map xetla-keyvec-quit     'kill-this-buffer)
1415     (define-key map [?+] 'xetla-widget-node-toggle-subtree-recursive)
1416     map)
1417   "Keymap used in `xetla-browse-mode'.")
1418
1419 (defun xetla-browse-mode ()
1420   "Mode for browsing xetla's archives.
1421 Don't use this function.  Instead call `xetla-browse'."
1422   (setq major-mode 'xetla-browse-mode
1423         mode-name "xetla-browse")
1424   (use-local-map xetla-browse-map)
1425   (set-buffer-modified-p nil)
1426   (run-hooks 'xetla-browse-mode-hook))
1427
1428 (provide 'xetla-browse)
1429
1430 ;;; xetla-browse.el ends here