Commits

Anonymous committed 873b1ac

New package -- XEtla

  • Participants

Comments (0)

Files changed (11)

+2005-04-04  Steve Youngs  <steve@sxemacs.org>
+
+	* New package
+
+# Makefile for XEtla
+
+# This file is part of XEmacs.
+
+# XEmacs is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the
+# Free Software Foundation; either version 2, or (at your option) any
+# later version.
+
+# XEmacs is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+# for more details.
+
+# You should have received a copy of the GNU General Public License
+# along with XEmacs; see the file COPYING.  If not, write to
+# the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+# Boston, MA 02111-1307, USA.
+
+VERSION = 0.99
+AUTHOR_VERSION = steve@eicq.org--2005/xetla--main--1.0--version-0
+MAINTAINER = Steve Youngs <steve@youngs.au.com>
+PACKAGE = xetla
+PKG_TYPE = regular
+REQUIRES = ediff xemacs-base jde mail-lib dired prog-modes
+CATEGORY = standard
+
+ELCS = \
+	ewoc.elc          \
+	smerge.elc        \
+	xetla-version.elc \
+	xetla-browse.elc  \
+	xetla-core.elc    \
+	xetla-defs.elc    \
+	xetla-tips.elc    \
+	xetla.elc
+
+# XEtla can use Gnus, but it is optional.  So instead of making Gnus a
+# dependency of XEtla, just put the Gnus directory into the load-path
+# to avoid byte-compiler warnings. --SY.
+PRELOADS = -eval \("push \"../gnus/lisp\" load-path"\)
+
+include ../../XEmacs.rules
+;;; ewoc.el --- utility to maintain a view of a list of objects in a buffer
+
+;; Copyright (C) 1991, 92, 93, 94, 95, 96, 97, 98, 99, 2000   Free Software Foundation
+
+;; Author: Per Cederqvist <ceder@lysator.liu.se>
+;;	Inge Wallin <inge@lysator.liu.se>
+;; Maintainer: monnier@gnu.org
+;; Created: 3 Aug 1992
+;; Keywords: extensions, lisp
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; Ewoc Was Once Cookie
+;; But now it's Emacs' Widget for Object Collections
+
+;; As the name implies this derives from the `cookie' package (part
+;; of Elib).  The changes are pervasive though mostly superficial:
+
+;; - uses CL (and its `defstruct')
+;; - separate from Elib.
+;; - uses its own version of a doubly-linked list which allows us
+;;   to merge the elib-wrapper and the elib-node structures into ewoc-node
+;; - dropping functions not used by PCL-CVS (the only client of ewoc at the
+;;   time of writing)
+;; - removing unused arguments
+;; - renaming:
+;;   elib-node	==>  ewoc--node
+;;   collection ==>  ewoc
+;;   tin 	==>  ewoc--node
+;;   cookie 	==>  data or element or elem
+
+;;     Introduction
+;;     ============
+;;
+;; Ewoc is a package that implements a connection between an
+;; dll (a doubly linked list) and the contents of a buffer.
+;; Possible uses are dired (have all files in a list, and show them),
+;; buffer-list, kom-prioritize (in the LysKOM elisp client) and
+;; others.  pcl-cvs.el uses ewoc.el.
+;;
+;; Ewoc can be considered as the `view' part of a model-view-controller.
+;;
+;; A `element' can be any lisp object.  When you use the ewoc
+;; package you specify a pretty-printer, a function that inserts
+;; a printable representation of the element in the buffer.  (The
+;; pretty-printer should use "insert" and not
+;; "insert-before-markers").
+;;
+;; A `ewoc' consists of a doubly linked list of elements, a
+;; header, a footer and a pretty-printer.  It is displayed at a
+;; certain point in a certain buffer.  (The buffer and point are
+;; fixed when the ewoc is created).  The header and the footer
+;; are constant strings.  They appear before and after the elements.
+;;
+;; Ewoc does not affect the mode of the buffer in any way. It
+;; merely makes it easy to connect an underlying data representation
+;; to the buffer contents.
+;;
+;; A `ewoc--node' is an object that contains one element.  There are
+;; functions in this package that given an ewoc--node extract the data, or
+;; give the next or previous ewoc--node.  (All ewoc--nodes are linked together
+;; in a doubly linked list.  The `previous' ewoc--node is the one that appears
+;; before the other in the buffer.)  You should not do anything with
+;; an ewoc--node except pass it to the functions in this package.
+;;
+;; An ewoc is a very dynamic thing.  You can easily add or delete elements.
+;; You can apply a function to all elements in an ewoc, etc, etc.
+;;
+;; Remember that an element can be anything.  Your imagination is the
+;; limit!  It is even possible to have another ewoc as an
+;; element.  In that way some kind of tree hierarchy can be created.
+;;
+;; Full documentation will, God willing, soon be available in a
+;; Texinfo manual.
+
+;; In the mean time `grep '^(.*ewoc-[^-]' emacs-lisp/ewoc.el' can help
+;; you find all the exported functions:
+;; 
+;; (defun ewoc-create (pretty-printer &optional header footer)
+;; (defalias 'ewoc-data 'ewoc--node-data)
+;; (defun ewoc-location (node)
+;; (defun ewoc-enter-first (ewoc data)
+;; (defun ewoc-enter-last (ewoc data)
+;; (defun ewoc-enter-after (ewoc node data)
+;; (defun ewoc-enter-before (ewoc node data)
+;; (defun ewoc-next (ewoc node)
+;; (defun ewoc-prev (ewoc node)
+;; (defun ewoc-nth (ewoc n)
+;; (defun ewoc-map (map-function ewoc &rest args)
+;; (defun ewoc-filter (ewoc predicate &rest args)
+;; (defun ewoc-locate (ewoc &optional pos guess)
+;; (defun ewoc-invalidate (ewoc &rest nodes)
+;; (defun ewoc-goto-prev (ewoc arg)
+;; (defun ewoc-goto-next (ewoc arg)
+;; (defun ewoc-goto-node (ewoc node)
+;; (defun ewoc-refresh (ewoc)
+;; (defun ewoc-collect (ewoc predicate &rest args)
+;; (defun ewoc-buffer (ewoc)
+;; (defun ewoc-get-hf (ewoc)
+;; (defun ewoc-set-hf (ewoc header footer)
+
+;;     Coding conventions
+;;     ==================
+;;
+;; All functions of course start with `ewoc'.  Functions and macros
+;; starting with the prefix `ewoc--' are meant for internal use,
+;; while those starting with `ewoc-' are exported for public use.
+;; There are currently no global or buffer-local variables used.
+
+
+;;; Code:
+
+(eval-when-compile (require 'cl))	;because of CL compiler macros
+
+;; The doubly linked list is implemented as a circular list
+;; with a dummy node first and last. The dummy node is used as
+;; "the dll" (or rather is the dll handle passed around).
+
+(defstruct (ewoc--node
+	    (:type vector)		;required for ewoc--node-branch hack
+	    (:constructor ewoc--node-create (start-marker data)))
+  left right data start-marker)
+
+(eval-when-compile (defvar dll))
+
+(defalias 'ewoc--node-branch 'aref)
+
+(defun ewoc--dll-create ()
+  "Create an empty doubly linked list."
+  (let ((dummy-node (ewoc--node-create 'DL-LIST 'DL-LIST)))
+    (setf (ewoc--node-right dummy-node) dummy-node)
+    (setf (ewoc--node-left dummy-node) dummy-node)
+    dummy-node))
+
+(defun ewoc--node-enter-before (node elemnode)
+  "Insert ELEMNODE before NODE in a DLL."
+  (assert (and (null (ewoc--node-left elemnode)) (null (ewoc--node-right elemnode))))
+  (setf (ewoc--node-left elemnode) (ewoc--node-left node))
+  (setf (ewoc--node-right elemnode) node)
+  (setf (ewoc--node-right (ewoc--node-left node)) elemnode)
+  (setf (ewoc--node-left node) elemnode))
+
+(defun ewoc--node-enter-first (dll node)
+  "Add a free floating NODE first in DLL."
+  (ewoc--node-enter-before (ewoc--node-right dll) node))
+
+(defun ewoc--node-enter-last (dll node)
+  "Add a free floating NODE last in DLL."
+  (ewoc--node-enter-before dll node))
+
+(defun ewoc--node-next (dll node)
+  "Return the node after NODE, or nil if NODE is the last node."
+  (unless (eq (ewoc--node-right node) dll) (ewoc--node-right node)))
+
+(defun ewoc--node-prev (dll node)
+  "Return the node before NODE, or nil if NODE is the first node."
+  (unless (eq (ewoc--node-left node) dll) (ewoc--node-left node)))
+
+(defun ewoc--node-delete (node)
+  "Unbind NODE from its doubly linked list and return it."
+  ;; This is a no-op when applied to the dummy node. This will return
+  ;; nil if applied to the dummy node since it always contains nil.
+  (setf (ewoc--node-right (ewoc--node-left node)) (ewoc--node-right node))
+  (setf (ewoc--node-left (ewoc--node-right node)) (ewoc--node-left node))
+  (setf (ewoc--node-left node) nil)
+  (setf (ewoc--node-right node) nil)
+  node)
+
+(defun ewoc--node-nth (dll n)
+  "Return the Nth node from the doubly linked list DLL.
+N counts from zero. If DLL is not that long, nil is returned.
+If N is negative, return the -(N+1)th last element.
+Thus, (ewoc--node-nth dll 0) returns the first node,
+and (ewoc--node-nth dll -1) returns the last node."
+  ;; Branch 0 ("follow left pointer") is used when n is negative.
+  ;; Branch 1 ("follow right pointer") is used otherwise.
+  (let* ((branch (if (< n 0) 0 1))
+	 (node   (ewoc--node-branch dll branch)))
+    (if (< n 0) (setq n (- -1 n)))
+    (while (and (not (eq dll node)) (> n 0))
+      (setq node (ewoc--node-branch node branch))
+      (setq n (1- n)))
+    (unless (eq dll node) node)))
+
+(defun ewoc-location (node)
+  "Return the start location of NODE."
+  (ewoc--node-start-marker node))
+
+
+;;; The ewoc data type
+
+(defstruct (ewoc
+	    (:constructor nil)
+	    (:constructor ewoc--create
+			  (buffer pretty-printer header footer dll))
+	    (:conc-name ewoc--))
+  buffer pretty-printer header footer dll last-node)
+
+(defmacro ewoc--set-buffer-bind-dll-let* (ewoc varlist &rest forms)
+  "Execute FORMS with ewoc--buffer selected as current buffer,
+dll bound to dll, and VARLIST bound as in a let*.
+dll will be bound when VARLIST is initialized, but the current
+buffer will *not* have been changed.
+Return value of last form in FORMS."
+  (let ((old-buffer (make-symbol "old-buffer"))
+	(hnd (make-symbol "ewoc")))
+    (` (let* (((, old-buffer) (current-buffer))
+	      ((, hnd) (, ewoc))
+	      (dll (ewoc--dll (, hnd)))
+	      (,@ varlist))
+	 (set-buffer (ewoc--buffer (, hnd)))
+	 (unwind-protect
+	     (progn (,@ forms))
+	   (set-buffer (, old-buffer)))))))
+
+(defmacro ewoc--set-buffer-bind-dll (ewoc &rest forms)
+  `(ewoc--set-buffer-bind-dll-let* ,ewoc nil ,@forms))
+
+(defsubst ewoc--filter-hf-nodes (ewoc node)
+  "Evaluate NODE once and return it.
+BUT if it is the header or the footer in EWOC return nil instead."
+  (unless (or (eq node (ewoc--header ewoc))
+	      (eq node (ewoc--footer ewoc)))
+    node))
+
+
+(defun ewoc--create-node (data pretty-printer pos)
+  "Call PRETTY-PRINTER with point set at POS in current buffer.
+Remember the start position. Create a wrapper containing that
+start position and the element DATA."
+  (save-excursion
+    ;; Remember the position as a number so that it doesn't move
+    ;; when we insert the string.
+    (when (markerp pos) (setq pos (marker-position pos)))
+    (goto-char pos)
+    (let ((inhibit-read-only t))
+      ;; Insert the trailing newline using insert-before-markers
+      ;; so that the start position for the next element is updated.
+      (insert-before-markers ?\n)
+      ;; Move back, and call the pretty-printer.
+      (backward-char 1)
+      (funcall pretty-printer data)
+      (ewoc--node-create (copy-marker pos) data))))
+
+
+(defun ewoc--delete-node-internal (ewoc node)
+  "Delete a data string from EWOC.
+Can not be used on the footer. Returns the wrapper that is deleted.
+The start-marker in the wrapper is set to nil, so that it doesn't
+consume any more resources."
+  (let ((dll (ewoc--dll ewoc))
+	(inhibit-read-only t))
+    ;; If we are about to delete the node pointed at by last-node,
+    ;; set last-node to nil.
+    (if (eq (ewoc--last-node ewoc) node)
+	(setf (ewoc--last-node ewoc) nil))
+
+    (delete-region (ewoc--node-start-marker node)
+		   (ewoc--node-start-marker (ewoc--node-next dll node)))
+    (set-marker (ewoc--node-start-marker node) nil)
+    ;; Delete the node, and return the wrapper.
+    (ewoc--node-delete node)))
+
+
+(defun ewoc--refresh-node (pp node)
+  "Redisplay the element represented by NODE using the pretty-printer PP."
+  (let ((inhibit-read-only t))
+    (save-excursion
+      ;; First, remove the string from the buffer:
+      (delete-region (ewoc--node-start-marker node)
+		     (1- (marker-position
+			  (ewoc--node-start-marker (ewoc--node-right node)))))
+      ;; Calculate and insert the string.
+      (goto-char (ewoc--node-start-marker node))
+      (funcall pp (ewoc--node-data node)))))
+
+;;; ===========================================================================
+;;;                  Public members of the Ewoc package
+
+
+(defun ewoc-create (pretty-printer &optional header footer)
+  "Create an empty ewoc.
+
+The ewoc will be inserted in the current buffer at the current position.
+
+PRETTY-PRINTER should be a function that takes one argument, an
+element, and inserts a string representing it in the buffer (at
+point). The string PRETTY-PRINTER inserts may be empty or span
+several linse. A trailing newline will always be inserted
+automatically. The PRETTY-PRINTER should use insert, and not
+insert-before-markers.
+
+Optional third argument HEADER is a string that will always be
+present at the top of the ewoc. HEADER should end with a
+newline.  Optionaly fourth argument FOOTER is similar, and will
+be inserted at the bottom of the ewoc."
+  (let ((new-ewoc
+	 (ewoc--create (current-buffer)
+		       pretty-printer nil nil (ewoc--dll-create)))
+	(pos (point)))
+    (ewoc--set-buffer-bind-dll new-ewoc
+      ;; Set default values
+      (unless header (setq header ""))
+      (unless footer (setq footer ""))
+      (setf (ewoc--node-start-marker dll) (copy-marker pos))
+      (let ((foot (ewoc--create-node footer (lambda (x) (insert footer)) pos))
+	    (head (ewoc--create-node header (lambda (x) (insert header)) pos)))
+	(ewoc--node-enter-first dll head)
+	(ewoc--node-enter-last  dll foot)
+	(setf (ewoc--header new-ewoc) head)
+	(setf (ewoc--footer new-ewoc) foot)))
+    ;; Return the ewoc
+    new-ewoc))
+
+(defalias 'ewoc-data 'ewoc--node-data)
+
+(defun ewoc-enter-first (ewoc data)
+  "Enter DATA first in EWOC."
+  (ewoc--set-buffer-bind-dll ewoc
+    (ewoc-enter-after ewoc (ewoc--node-nth dll 0) data)))
+
+(defun ewoc-enter-last (ewoc data)
+  "Enter DATA last in EWOC."
+  (ewoc--set-buffer-bind-dll ewoc
+    (ewoc-enter-before ewoc (ewoc--node-nth dll -1) data)))
+
+
+(defun ewoc-enter-after (ewoc node data)
+  "Enter a new element DATA after NODE in EWOC.
+Returns the new NODE."
+  (ewoc--set-buffer-bind-dll ewoc
+    (ewoc-enter-before ewoc (ewoc--node-next dll node) data)))
+
+(defun ewoc-enter-before (ewoc node data)
+  "Enter a new element DATA before NODE in EWOC.
+Returns the new NODE."
+  (ewoc--set-buffer-bind-dll ewoc
+    (ewoc--node-enter-before
+     node
+     (ewoc--create-node
+      data
+      (ewoc--pretty-printer ewoc)
+      (ewoc--node-start-marker node)))))
+
+(defun ewoc-next (ewoc node)
+  "Get the next node.
+Returns nil if NODE is nil or the last element."
+  (when node
+    (ewoc--filter-hf-nodes
+     ewoc (ewoc--node-next (ewoc--dll ewoc) node))))
+
+(defun ewoc-prev (ewoc node)
+  "Get the previous node.
+Returns nil if NODE is nil or the first element."
+  (when node
+    (ewoc--filter-hf-nodes
+     ewoc
+     (ewoc--node-prev (ewoc--dll ewoc) node))))
+
+
+(defun ewoc-nth (ewoc n)
+  "Return the Nth node.
+N counts from zero. Nil is returned if there is less than N elements.
+If N is negative, return the -(N+1)th last element.
+Thus, (ewoc-nth dll 0) returns the first node,
+and (ewoc-nth dll -1) returns the last node.
+Use `ewoc--node-data' to extract the data from the node."
+  ;; Skip the header (or footer, if n is negative).
+  (setq n (if (< n 0) (1- n) (1+ n)))
+  (ewoc--filter-hf-nodes ewoc
+		  (ewoc--node-nth (ewoc--dll ewoc) n)))
+
+(defun ewoc-map (map-function ewoc &rest args)
+  "Apply MAP-FUNCTION to all elements in EWOC.
+MAP-FUNCTION is applied to the first element first.
+If MAP-FUNCTION returns non-nil the element will be refreshed (its
+pretty-printer will be called once again).
+
+Note that the buffer for EWOC will be current buffer when MAP-FUNCTION 
+is called.  MAP-FUNCTION must restore the current buffer to BUFFER before 
+it returns, if it changes it.
+
+If more than two arguments are given, the remaining
+arguments will be passed to MAP-FUNCTION."
+  (ewoc--set-buffer-bind-dll-let* ewoc
+      ((footer (ewoc--footer ewoc))
+       (node (ewoc--node-nth dll 1)))
+    (while (not (eq node footer))
+      (if (apply map-function (ewoc--node-data node) args)
+	  (ewoc--refresh-node (ewoc--pretty-printer ewoc) node))
+      (setq node (ewoc--node-next dll node)))))
+
+(defun ewoc-filter (ewoc predicate &rest args)
+  "Remove all elements in EWOC for which PREDICATE returns nil.
+Note that the buffer for EWOC will be current-buffer when PREDICATE 
+is called. PREDICATE must restore the current buffer before it returns
+if it changes it.
+The PREDICATE is called with the element as its first argument. If any
+ARGS are given they will be passed to the PREDICATE."
+  (ewoc--set-buffer-bind-dll-let* ewoc
+      ((node (ewoc--node-nth dll 1))
+       (footer (ewoc--footer ewoc))
+       (next nil))
+    (while (not (eq node footer))
+      (setq next (ewoc--node-next dll node))
+      (unless (apply predicate (ewoc--node-data node) args)
+	(ewoc--delete-node-internal ewoc node))
+      (setq node next))))
+
+(defun ewoc-locate (ewoc &optional pos guess)
+  "Return the node that POS (a buffer position) is within.
+POS may be a marker or an integer.  It defaults to point.
+GUESS should be a node that it is likely that POS is near.
+
+If POS points before the first element, the first node is returned.
+If POS points after the last element, the last node is returned.
+If the EWOC is empty, nil is returned."
+  (unless pos (setq pos (point)))
+  (ewoc--set-buffer-bind-dll-let* ewoc
+      () ;; ((footer (ewoc--footer ewoc)))
+
+    (cond
+     ;; Nothing present?
+     ((eq (ewoc--node-nth dll 1) (ewoc--node-nth dll -1))
+      nil)
+
+     ;; Before second elem?
+     ((< pos (ewoc--node-start-marker (ewoc--node-nth dll 2)))
+      (ewoc--node-nth dll 1))
+
+     ;; After one-before-last elem?
+     ((>= pos (ewoc--node-start-marker (ewoc--node-nth dll -2)))
+      (ewoc--node-nth dll -2))
+
+     ;; We now know that pos is within a elem.
+     (t
+      ;; Make an educated guess about which of the three known
+      ;; node'es (the first, the last, or GUESS) is nearest.
+      (let* ((best-guess (ewoc--node-nth dll 1))
+	     (distance (abs (- pos (ewoc--node-start-marker best-guess)))))
+	(when guess
+	  (let ((d (abs (- pos (ewoc--node-start-marker guess)))))
+	    (when (< d distance)
+	      (setq distance d)
+	      (setq best-guess guess))))
+
+	(let* ((g (ewoc--node-nth dll -1))	;Check the last elem
+	       (d (abs (- pos (ewoc--node-start-marker g)))))
+	  (when (< d distance)
+	    (setq distance d)
+	    (setq best-guess g)))
+
+	(when (ewoc--last-node ewoc) ;Check "previous".
+	  (let* ((g (ewoc--last-node ewoc))
+		 (d (abs (- pos (ewoc--node-start-marker g)))))
+	    (when (< d distance)
+	      (setq distance d)
+	      (setq best-guess g))))
+
+	;; best-guess is now a "best guess".
+	;; Find the correct node. First determine in which direction
+	;; it lies, and then move in that direction until it is found.
+    
+	(cond
+	 ;; Is pos after the guess?
+	 ((>= pos
+	      (ewoc--node-start-marker best-guess))
+	  ;; Loop until we are exactly one node too far down...
+	  (while (>= pos (ewoc--node-start-marker best-guess))
+	    (setq best-guess (ewoc--node-next dll best-guess)))
+	  ;; ...and return the previous node.
+	  (ewoc--node-prev dll best-guess))
+
+	 ;; Pos is before best-guess
+	 (t
+	  (while (< pos (ewoc--node-start-marker best-guess))
+	    (setq best-guess (ewoc--node-prev dll best-guess)))
+	  best-guess)))))))
+
+(defun ewoc-invalidate (ewoc &rest nodes)
+  "Refresh some elements.
+The pretty-printer that for EWOC will be called for all NODES."
+  (ewoc--set-buffer-bind-dll ewoc
+    (dolist (node nodes)
+      (ewoc--refresh-node (ewoc--pretty-printer ewoc) node))))
+
+(defun ewoc-goto-prev (ewoc arg)
+  "Move point to the ARGth previous element.
+Don't move if we are at the first element, or if EWOC is empty.
+Returns the node we moved to."
+  (ewoc--set-buffer-bind-dll-let* ewoc
+      ((node (ewoc-locate ewoc (point))))
+    (when node
+      ;; If we were past the last element, first jump to it.
+      (when (>= (point) (ewoc--node-start-marker (ewoc--node-right node)))
+	(setq arg (1- arg)))
+      (while (and node (> arg 0))
+	(setq arg (1- arg))
+	(setq node (ewoc--node-prev dll node)))
+      ;; Never step above the first element.
+      (unless (ewoc--filter-hf-nodes ewoc node)
+	(setq node (ewoc--node-nth dll 1)))
+      (ewoc-goto-node ewoc node))))
+
+(defun ewoc-goto-next (ewoc arg)
+  "Move point to the ARGth next element.
+Returns the node (or nil if we just passed the last node)."
+  (ewoc--set-buffer-bind-dll-let* ewoc
+      ((node (ewoc-locate ewoc (point))))
+    (while (and node (> arg 0))
+      (setq arg (1- arg))
+      (setq node (ewoc--node-next dll node)))
+    ;; Never step below the first element.
+    ;; (unless (ewoc--filter-hf-nodes ewoc node)
+    ;;   (setq node (ewoc--node-nth dll -2)))
+    (ewoc-goto-node ewoc node)))
+
+(defun ewoc-goto-node (ewoc node)
+  "Move point to NODE."
+  (ewoc--set-buffer-bind-dll ewoc
+    (goto-char (ewoc--node-start-marker node))
+    (if goal-column (move-to-column goal-column))
+    (setf (ewoc--last-node ewoc) node)))
+
+(defun ewoc-refresh (ewoc)
+  "Refresh all data in EWOC.
+The pretty-printer that was specified when the EWOC was created
+will be called for all elements in EWOC.
+Note that `ewoc-invalidate' is more efficient if only a small
+number of elements needs to be refreshed."
+  (ewoc--set-buffer-bind-dll-let* ewoc
+      ((footer (ewoc--footer ewoc)))
+    (let ((inhibit-read-only t))
+      (delete-region (ewoc--node-start-marker (ewoc--node-nth dll 1))
+		     (ewoc--node-start-marker footer))
+      (goto-char (ewoc--node-start-marker footer))
+      (let ((node (ewoc--node-nth dll 1)))
+	(while (not (eq node footer))
+	  (set-marker (ewoc--node-start-marker node) (point))
+	  (funcall (ewoc--pretty-printer ewoc)
+		   (ewoc--node-data node))
+	  (insert "\n")
+	  (setq node (ewoc--node-next dll node)))))
+    (set-marker (ewoc--node-start-marker footer) (point))))
+
+(defun ewoc-collect (ewoc predicate &rest args)
+  "Select elements from EWOC using PREDICATE.
+Return a list of all selected data elements.
+PREDICATE is a function that takes a data element as its first argument.
+The elements on the returned list will appear in the same order as in
+the buffer.  You should not rely on in which order PREDICATE is
+called.
+Note that the buffer the EWOC is displayed in is current-buffer
+when PREDICATE is called.  If PREDICATE must restore current-buffer if
+it changes it.
+If more than two arguments are given the
+remaining arguments will be passed to PREDICATE."
+  (ewoc--set-buffer-bind-dll-let* ewoc
+      ((header (ewoc--header ewoc))
+       (node (ewoc--node-nth dll -2))
+       result)
+    (while (not (eq node header))
+      (if (apply predicate (ewoc--node-data node) args)
+	  (push (ewoc--node-data node) result))
+      (setq node (ewoc--node-prev dll node)))
+    (nreverse result)))
+
+(defun ewoc-buffer (ewoc)
+  "Return the buffer that is associated with EWOC.
+Returns nil if the buffer has been deleted."
+  (let ((buf (ewoc--buffer ewoc)))
+    (when (buffer-name buf) buf)))
+
+(defun ewoc-get-hf (ewoc)
+  "Return a cons cell containing the (HEADER . FOOTER) of EWOC."
+  (cons (ewoc--node-data (ewoc--header ewoc))
+	(ewoc--node-data (ewoc--footer ewoc))))
+
+(defun ewoc-set-hf (ewoc header footer)
+  "Set the HEADER and FOOTER of EWOC."
+  (setf (ewoc--node-data (ewoc--header ewoc)) header)
+  (setf (ewoc--node-data (ewoc--footer ewoc)) footer)
+  (ewoc--refresh-node (lambda (x) (insert header)) (ewoc--header ewoc))
+  (ewoc--refresh-node (lambda (x) (insert footer)) (ewoc--footer ewoc)))
+
+
+(provide 'ewoc)
+
+;;; Local Variables:
+;;; eval: (put 'ewoc--set-buffer-bind-dll 'lisp-indent-hook 1)
+;;; eval: (put 'ewoc--set-buffer-bind-dll-let* 'lisp-indent-hook 2)
+;;; End:
+
+;;; ewoc.el ends here

File package-info.in

+(xetla
+  (standards-version 1.1
+   version VERSION
+   author-version AUTHOR_VERSION
+   date DATE
+   build-date BUILD_DATE
+   maintainer MAINTAINER
+   distribution xemacs
+   priority low
+   category CATEGORY
+   dump nil
+   description "Frontend to GNU/arch (tla)."
+   filename FILENAME
+   md5sum MD5SUM
+   size SIZE
+   provides (ewoc smerge xetla-browse xetla-core
+             xetla-defs xetla-tips xetla-version xetla)
+   requires (REQUIRES)
+   type regular
+))
+;;; smerge.el --- SAM's Merge layer on top of ediff
+
+;; Copyright (C) 2002,2003 Sean MacLennan
+;; $Revision$ $Date$
+;; XEmacs
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;; TODO:
+;;      - keymap for buffer!
+;;	- ediff needs a list of args
+;;	- add more documentation!!!
+
+;; smerge marks the file with the `smerge-merged-face' when the files
+;; are merged. In the case of "only in" files, merged means you copied
+;; the file over to the other directory. However, for ediffed files,
+;; merged means you ran ediff on the files. This does not mean the
+;; files are identical. And you are allowed to run ediff on the files
+;; again. It is really just a marker that you looked at the file.
+
+(require 'ediff)
+
+(defmacro smerge-do-in-gnu-emacs (&rest body)
+  "Execute BODY if in GNU/Emacs."
+  (unless running-xemacs `(progn ,@body)))
+(put 'smerge-do-in-gnu-emacs 'lisp-indent-hook 'defun)
+
+(defmacro smerge-do-in-xemacs (&rest body)
+  "Execute BODY if in XEmacs."
+  (when running-xemacs `(progn ,@body)))
+(put 'smerge-do-in-xemacs 'lisp-indent-hook 'defun)
+
+
+(smerge-do-in-xemacs
+  (defalias 'smerge-dirlist 'directory-files))
+
+(smerge-do-in-gnu-emacs
+  (require 'extent)
+
+  (defun smerge-dirlist (directory &optional full match nosort files-only)
+    (if (eq files-only nil)
+	(directory-files directory full match nosort)
+      (let ((rawlist (directory-files-and-attributes
+		      directory full match nosort))
+	    dirlist)
+	(setq files-only (if (eq files-only t) nil t))
+	(dolist (entry rawlist)
+	  (when (eq (nth 1 entry) files-only)
+	    (setq dirlist (cons (car entry) dirlist))))
+	dirlist)))
+
+  (defun temp-directory ()
+    (let ((tmp (getenv "TMPDIR")))
+      (if tmp tmp "/tmp")))
+
+  (defun read-directory-name (prompt &optional dir default mustmatch)
+    (let* ((dir (read-file-name prompt dir default mustmatch))
+	   (attr (file-attributes dir)))
+      (unless (eq (car attr) t) (error "Must be a directory"))
+      dir))
+
+  (defun kill-entire-line (&optional arg)
+    (let ((kill-whole-line t)) (beginning-of-line) (kill-line arg)))
+  )
+
+(defvar smerge-diff-program ediff-diff-program
+  "*Program to use to diff the directories. Must support --brief option.")
+
+(defvar smerge-diff-options ediff-diff-options "*See `ediff-diff-options'.")
+
+(defvar smerge-diff-excludes '("*.o" "*.obj" "*.a" "*.lib" "*~" ".#*" "CVS")
+  "*List of patterns of files and subdirectories to ignore.
+smerge builds a temprorary file (`smerge-exclude-file') based on this list
+and passes it to `smerge-diff-program' with the --exclude-from option.
+Note: These excludes are wildcard expressions as used by diff, not lisp
+regular expressions.")
+
+(defvar smerge-preserve-modes t
+  "*When copying files, preserver the mode of the destination file.")
+
+(defvar smerge-exclude-file (concat (temp-directory) "/smerge-excludes")
+  "*Temporary file to hold the `smerge-excludes'.")
+
+(defface smerge-only1-face
+  '((((class color))  (:foreground "purple"))
+    (t (:underline t)))
+  "Face for files/directories only in directory 1.")
+
+(defface smerge-only2-face
+  '((((class color))  (:foreground "blue"))
+    (t (:underline t)))
+  "Face for files/directories only in directory 2.")
+
+(defface smerge-diff-face
+  '((((class color))  (:foreground "red"))
+    (t (:bold t)))
+  "Face for files that are different.")
+
+(defface smerge-merged-face
+  '((((class color))  (:foreground "black"))
+    (t (:bold t)))
+  "Face for files that are merged.")
+
+
+(defvar smerge-buffer "*smerge-output*" "*Name of smerge output buffer.")
+
+(defvar smerge-keymap nil "*Keymap used by smerge.")
+
+(defvar smerge-cvsignore nil
+  "*If non-nil, use the .cvsignore files in `dir1' to ignore files.")
+
+;; For debugging
+(defvar smerge-raw-diff-output nil
+  "*If non-nil, filename to write the raw diff output to. (dbg)")
+(defvar smerge-keep-cvsignore-buffer nil
+  "*If non-nil, keep the raw cvsignore buffer. (dbg)")
+
+;; Internals
+;; SAM This should be a list?
+(defvar smerge-flags nil)
+(defvar smerge-dir1 nil)
+(defvar smerge-dir2 nil)
+(defvar smerge-file nil)
+(defvar smerge-extent nil)
+
+
+(defconst smerge-copy-menu
+  (list "Copy to ..."
+	[(concat smerge-dir1 smerge-file) (smerge-copy 1) (smerge-allow-dir 1)]
+	[(concat smerge-dir2 smerge-file) (smerge-copy 2) (smerge-allow-dir 2)]
+	))
+
+(defun smerge-init ()
+  "This creates the keymap."
+  (unless smerge-keymap
+    (setq smerge-keymap (make-sparse-keymap "smerge"))
+    (if running-xemacs
+	(progn
+	  (define-key smerge-keymap 'button1 'smerge-mousable)
+	  (define-key smerge-keymap 'button2 'smerge-mousable)
+	  (define-key smerge-keymap 'button3 'smerge-menu))
+      (define-key smerge-keymap [mouse-1] 'smerge-mousable)
+      (define-key smerge-keymap [mouse-2] 'smerge-mousable)
+      (define-key smerge-keymap [mouse-3] 'smerge-menu))
+
+    (define-key smerge-keymap "\C-m" 'smerge-ediff-or-copy)
+    (define-key smerge-keymap "g"    'smerge-reload)
+    (define-key smerge-keymap "r"    'smerge-reload)
+    (define-key smerge-keymap "n"    'smerge-next)
+    (define-key smerge-keymap "p"    'smerge-prev)
+    ))
+
+;;;###autoload
+(defun smerge (flags &optional dir1 dir2)
+  "Merge two directories recursively."
+  (interactive "p")
+  (smerge-init)
+  (unless dir1
+    (setq dir1 (read-directory-name "Directory 1: " nil nil t)))
+  (unless dir2
+    (setq dir2 (read-directory-name "Directory 2: " nil nil t)))
+  (switch-to-buffer smerge-buffer) ;; Yes I want to be in the output buffer
+  (toggle-read-only 0) ;; writable
+  (setq smerge-flags flags)
+  (setq smerge-dir1 (file-name-as-directory (expand-file-name dir1)))
+  (setq smerge-dir2 (file-name-as-directory (expand-file-name dir2)))
+  (smerge-recursive-diff)
+  (smerge-fixup-filenames)
+  (when smerge-cvsignore (smerge-cvsignore smerge-dir1))
+  (smerge-post-process flags)
+  (toggle-read-only 1) ;; read-only
+  )
+
+(defun smerge-reload ()
+  "Rediff two directories recursively."
+  (interactive)
+  (smerge smerge-flags smerge-dir1 smerge-dir2))
+
+(defun smerge-recursive-diff ()
+  (let (rc)
+    (erase-buffer)
+    (dolist (exclude smerge-diff-excludes) (insert (concat exclude "\n")))
+    (write-region (point-min) (point-max) smerge-exclude-file nil 'no-message)
+    (erase-buffer)
+    (let ((diff-options (concat "--exclude-from=" smerge-exclude-file
+			      " -r" " --brief " smerge-diff-options)))
+      ;; Since we are tightly coupled with ediff, use their program!
+      ;; This erases the diff buffer automatically.
+      (ediff-exec-process smerge-diff-program
+			  (current-buffer)
+			  'synchronize
+			  diff-options
+			  smerge-dir1 smerge-dir2))
+    (delete-file smerge-exclude-file)
+    (when smerge-raw-diff-output
+      (write-region (point-min) (point-max) smerge-raw-diff-output))
+    (and (numberp rc) (eq rc 0))))
+
+(defun smerge-fixup-filenames ()
+  "Diff splits the `Only in' files into directory and filename.
+Top level directories end in /, subdirs do not."
+  (goto-char (point-min))
+  (while (re-search-forward "^\\(Only in [^:]*\\)\\(.\\): " nil t)
+    (if (string= (match-string 2) "/")
+	(replace-match "\\1/" nil nil)
+      (replace-match "\\1\\2/" nil nil))))
+
+(defun smerge-post-process (flags)
+  (let (match extent file start)
+    (goto-char (point-min))
+    (insert (format "Diff %s and %s\n\n" smerge-dir1 smerge-dir2))
+    (setq start (point))
+
+    (cond ((> flags 4) ;; c-u c-u
+	   ;; Remove different files
+	   (while (re-search-forward "^Files .*\n" nil t)
+	     (replace-match "")))
+	  ((> flags 1) ;; c-u
+	   ;; Remove the unique files
+	   (while (re-search-forward "^Only in .*\n" nil t)
+	     (replace-match ""))))
+
+    ;; Only in 1
+    (setq match (format "^Only in %s\\(.*\\)$" smerge-dir1))
+    (goto-char (point-min))
+    (while (re-search-forward match nil t)
+      (setq file (match-string 1))
+      (setq extent
+	    (smerge-make-extent (match-beginning 0) (match-end 0) 'smerge-only1-face))
+      (set-extent-property extent 'type 2)
+      (replace-match file)
+      )
+
+    ;; Only in 2
+    (setq match (format "^Only in %s\\(.*\\)$" smerge-dir2))
+    (goto-char (point-min))
+    (while (re-search-forward match nil t)
+      (setq file (match-string 1))
+      (setq extent
+	    (smerge-make-extent (match-beginning 0) (match-end 0) 'smerge-only2-face))
+      (set-extent-property extent 'type 1)
+      (replace-match (concat "\t\t\t\t" file))
+      )
+
+    ;; Both
+    (setq match (format "^Files %s\\(.+\\) and %s.+ differ$" smerge-dir1 smerge-dir2))
+    (goto-char (point-min))
+    (while (re-search-forward match nil t)
+      (setq file (match-string 1))
+      (setq extent
+	    (smerge-make-extent (match-beginning 0) (match-end 0) 'smerge-diff-face))
+      (set-extent-property extent 'type 3)
+      (replace-match (concat "\t\t" file))
+      )
+
+    ;; Back to start
+    (goto-char start)
+    (if (re-search-forward "\\w" nil t) (forward-char -1))
+    ))
+
+(autoload 'defadvice "advice" nil nil 'macro)
+
+(defadvice ediff-quit (after smerge activate)
+  (when (extentp smerge-extent)
+    (set-extent-property smerge-extent 'face 'smerge-merged-face) ;; SAM
+    (delete-other-windows)
+    (switch-to-buffer smerge-buffer)
+    (let ((next (next-extent smerge-extent))
+	  start)
+      (when next
+	(setq start (extent-start-position next))
+	(goto-char start)
+	(if (re-search-forward "\\w" nil t) (forward-char -1))
+	))
+    (setq smerge-extent nil) ;; done
+    ))
+
+(defun smerge-file (extent)
+  "Given a smerge extent, return the file name."
+  (let ((file (buffer-substring
+	       (extent-start-position extent)
+	       (extent-end-position extent))))
+    (string-match "\t*\\(.*\\)" file)
+    (match-string 1 file)))
+
+(defun smerge-menu (event)
+  "This is called on a right mouse click in the display window.
+Pops up a menu that allows copying the file to directory one or two."
+  (interactive "e")
+  (let ((extent (extent-at (event-point event))))
+    (unless extent (error "No extent at point"))
+    (setq smerge-file (smerge-file extent))
+    (setq smerge-extent extent)
+    (popup-menu smerge-copy-menu)))
+
+
+(defun smerge-mousable (event)
+  "This is called on a left or middle mouse click in the display window."
+  (interactive "e")
+  (smerge-ediff (extent-at (event-point event))))
+
+(defun smerge-ediff-or-copy ()
+  "Ediff or copy the file."
+  (interactive)
+  (let* ((extent (extent-at (point)))
+	 (type (extent-property extent 'type)))
+    (unless extent (error "No extent at point"))
+    (cond ((or (eq type 1) (eq type 2))
+	   (setq smerge-file (smerge-file extent))
+	   (smerge-copy 1 t))
+	  ((eq type 3) (smerge-ediff extent))
+	  (t (beep)))))
+
+(defun smerge-ediff (&optional extent)
+  "Ediff the two files."
+  (interactive)
+  (let (file)
+    (unless extent
+      (setq extent (extent-at (point)))
+      (unless extent (error "No extent at point")))
+    (if (eq (extent-property extent 'type) 3)
+	(progn
+	  (setq smerge-extent extent)
+	  (setq file (smerge-file extent))
+	  (ediff-files
+	   (concat smerge-dir1 file) (concat smerge-dir2 file)))
+      (beep))))
+
+
+(defun smerge-allow-dir (dir)
+  "Are we allowed to copy to this directory."
+  (let ((type (extent-property smerge-extent 'type)))
+    (if type
+	(> (logand (extent-property smerge-extent 'type) dir) 0)
+      (message "WARNING: No type for extent!")
+      0)))
+
+;; Copy file preserving the destination modes if necessary
+(defun smerge-copy-file (src dst &optional ok-if-already-exists keep-time)
+  (let ((modes (file-modes dst)))
+    (copy-file src dst ok-if-already-exists keep-time)
+    (and smerge-preserve-modes
+	 modes
+	 (set-file-modes dst modes))))
+
+(defun smerge-copy (dir &optional ask)
+  "Do the copy to the directory specified."
+  (let ((file1 (concat smerge-dir1 smerge-file))
+	(file2 (concat smerge-dir2 smerge-file))
+	src dst)
+    (cond ((eq dir 1) (setq src file2 dst file1))
+	  ((eq dir 2) (setq src file1 dst file2))
+	  (t (error "Huh?")))
+    (when (or (not ask)
+	      (yes-or-no-p (format "Copy to %s? " dst)))
+      (smerge-copy-file src dst t t)
+      ;; Mark as merged
+      (set-extent-property smerge-extent 'face 'smerge-merged-face)
+      ;; If this is an "only" mark as copied
+      (when (< (extent-property smerge-extent 'type) 3)
+	(set-extent-property smerge-extent 'type 0))
+      (setq smerge-extent nil)
+      )))
+
+(defun smerge-make-extent (start end face)
+  (let (extent)
+    (setq end (1+ end)) ;; include the NL
+    (setq extent (make-extent start end))
+    (set-extent-face extent face)
+    (set-extent-mouse-face extent 'highlight)
+    (set-extent-keymap extent smerge-keymap)
+    extent
+    ))
+
+;; .cvsignore code
+
+(defun smerge-find-ignores (dir)
+  "Find all the .cvsignore files recursively from `dir'. `dir' must end in /."
+  (let ((dirlist (smerge-dirlist dir nil "^[^.].*" nil 'dirs))
+	(file (concat dir ".cvsignore"))
+	filelist)
+    (if (file-exists-p file) (setq filelist (list file)))
+    (dolist (subdir dirlist)
+      (unless (string= subdir "CVS")
+	(setq filelist (append filelist
+			       (smerge-find-ignores (concat dir subdir "/"))))))
+    filelist))
+
+(defun smerge-build-ignore-list (dir)
+  "Build a list of files/directories to ignore. `dir' must end in /."
+  (let ((list (smerge-find-ignores dir))
+	(buff (get-buffer-create "*smerge-cvsignores*"))
+	start)
+    (save-excursion
+      (set-buffer buff)
+      (erase-buffer)
+      (dolist (file list)
+	(setq start (point))
+	(insert-file-contents file)
+	(goto-char start)
+	(while (re-search-forward "^" nil t)
+	  (insert file)))
+      (goto-char (point-min))
+      (while (re-search-forward ".cvsignore" nil t)
+	(replace-match ""))
+      ;; Protect . from regexp
+      (goto-char (point-min))
+      (while (search-forward "." nil t)
+	(replace-match "\\\\."))
+      ;; Convert * -> .*
+      (goto-char (point-min))
+      (while (search-forward "*" nil t)
+	(replace-match ".*"))
+      ;; Build the list
+      (setq list nil)
+      (goto-char (point-min))
+      (while (re-search-forward "^.+$" nil t)
+	(setq list (cons (match-string 0) list))))
+    (unless smerge-keep-cvsignore-buffer
+      (kill-buffer buff))
+    list))
+
+(defun smerge-cvsignore (dir)
+  "smerge internal function to remove the .cvsignore matches"
+  (let ((list (smerge-build-ignore-list dir))
+	match)
+    (dolist (ignore list)
+      (goto-char (point-min))
+      ;; Only match complete matches
+      ;; We cannot use \b here since we are matching filenames
+      (setq match (concat ignore "\\s-"))
+      (while (re-search-forward match nil t)
+	;; Since we match the \n at the end of some lines...
+	(goto-char (match-beginning 0))
+	(kill-entire-line)
+	))))
+
+;; .cvsignore code ends
+
+(provide 'smerge)

File xetla-browse.el

+;;; xetla-browse.el --- Arch archives/library browser
+
+;; Copyright (C) 2004 by Stefan Reichoer (GPL)
+;; Copyright (C) 2004 Steve Youngs (BSD)
+
+;; Author:        Steve Youngs <steve@eicq.org>
+;; Maintainer:    Steve Youngs <steve@eicq.org>
+;; Created:       2004-11-25
+;; Keywords:      archive arch tla
+
+;; Based on xtla-browse.el by: Masatake YAMATO <jet@gyve.org>
+
+;; This file is part of XEtla.
+
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions
+;; are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;; 3. Neither the name of the author nor the names of any contributors
+;;    may be used to endorse or promote products derived from this
+;;    software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR
+;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+;; DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
+;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
+;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+;;; Commentary:
+;;
+;; Contributions from:
+;;    Stefan Reichoer, <stefan@xsteve.at>
+;;    Matthieu Moy <Matthieu.Moy@imag.fr>
+;;    Masatake YAMATO <jet@gyve.org>
+;;    Milan Zamazal <pdm@zamazal.org>
+;;    Martin Pool <mbp@sourcefrog.net>
+;;    Robert Widhopf-Fenk <hack@robf.de>
+;;    Mark Triggs <mst@dishevelled.net>
+
+;; 1. Load xetla-browse.el
+;; 2. M-x xetla-browse RET
+
+;;; TODO:
+;; - Generic refresh
+;;
+
+;;; History:
+;;
+
+;;; Code:
+(eval-when-compile
+  (require 'cl)
+  (autoload 'easy-mmode-define-keymap "easy-mmode"))
+
+(require 'tree-widget)
+(require 'xetla)
+
+(defvar xetla-browse-buffer-name "*xetla-browse*")
+(defvar xetla-browse-buffer-type 'browse)
+(xetla-add-buffer-type xetla-browse-buffer-type
+                        xetla-browse-buffer-name)
+
+;; --------------------------------------
+;; Open node tracking
+;; --------------------------------------
+(defvar xetla-browse-open-list '()
+  "List holding the name of open nodes.")
+
+(defun xetla-browse-open-list-member (archive
+                                     &optional category branch version)
+  "Return a node, ARCHIVE/CATEGORY-BRANCH-VERSION is opend or not.
+CATEGORY, BRANCH, VERSION are optional."
+  (let ((name (list archive category branch version nil)))
+    (member name xetla-browse-open-list)))
+
+(defun xetla-browse-open-list-add (archive
+                                  &optional category branch version)
+  "Add a node specified by the arguments to 'xetla-browse-open-list'.
+ARCHIVE/CATEGORY-BRANCH-VERSION,  ARCHIVE/CATEGORY-BRANCH,
+ARCHIVE/CATEGORY, ARCHIVE are added.  CATEGORY, BRANCH, VERSION
+are optional."
+  (xetla-browse-open-list-add-internal (list archive category branch version nil))
+  (xetla-browse-open-list-add-internal (list archive category branch nil nil))
+  (xetla-browse-open-list-add-internal (list archive category nil nil nil))
+  (xetla-browse-open-list-add-internal (list archive nil nil nil nil))
+  (xetla-browse-open-list-add-internal (list nil nil nil nil nil)))
+
+(defun xetla-browse-open-list-add-internal (name)
+  "Add NAME to `xetla-browse-open-list'."
+  (unless (xetla-browse-open-list-member (xetla-name-archive name)
+                                        (xetla-name-category name)
+                                        (xetla-name-branch name)
+                                        (xetla-name-version name))
+    (push name xetla-browse-open-list)))
+
+(defun xetla-browse-open-list-remove (archive
+                                     &optional category branch version)
+  "Remove ARCHIVE/CATEGORY-BRANCH-VERSION from `xetla-browse-open-list'.
+CATEGORY, BRANCH and VERSION are optional."
+  (let ((name (list archive category branch version nil)))
+    (setq xetla-browse-open-list (delete name xetla-browse-open-list))))
+
+(defun xetla-browse-open-tracker (tree)
+  "Add or remove a node represented by TREE to/from `xetla-browse-open-list'.
+If TREE is opened, it is added.  Else it is removed."
+  (let* ((node (widget-get tree :node))
+         (a (widget-get node :archive))
+         (c (widget-get node :category))
+         (b (widget-get node :branch))
+         (v (widget-get node :version)))
+  (if (widget-get tree :open)
+      (xetla-browse-open-list-add a c b v)
+    (xetla-browse-open-list-remove a c b v))))
+
+(defun xetla-browse-find-archives-root-widget ()
+  "Return the root widget of archives tree."
+  (save-excursion
+    (goto-char (point-min))
+    (re-search-forward " Archives$")
+    (backward-char 1)
+    (xetla-widget-node-get-at)))
+
+(defun xetla-browse-find-named-widget (parent name type)
+  "Find a widget specified with arguments.
+PARENT specifies the parent widget.
+NAME is the name of the widget.
+TYPE is the type of widget.  You can specify :archive, :category,
+:branch, or :version."
+  (let* ((args (widget-get parent :args))
+         (index (position name args :test (lambda (e w)
+                                               (let ((node (widget-get w :node)))
+                                                 ;; Next line is hack for version node.
+                                                 (unless node (setq node w))
+                                                 (string= e (widget-get node type))))))
+         (tree (when index (nth index (widget-get parent :children))))
+         (node (when tree (save-excursion (goto-char (widget-get tree :from))
+                                          (goto-char (next-single-property-change (point) 'widget))
+                                          (xetla-widget-node-get-at)))))
+    node))
+
+
+(defun xetla-browse-find-widget (archive
+                                &optional category branch version)
+  "Return a list of widgets: (root archive category branch version)
+root is always the root of the tree, of type `xetla-widget-root-node'.
+archive is the widget representing ARCHIVE, of type
+`xetla-widget-archive-node'.  The last items are potentially nil if
+CATEGORY, BRANCH or VERSION is nil.  Otherwise, they are respectively
+of type `xetla-widget-category-node', `xetla-widget-revision-node' and
+`xetla-widget-version-node'."
+  (let* ((root (xetla-browse-find-archives-root-widget))
+         (a    (xetla-browse-find-named-widget
+                (widget-get root :parent) archive :archive))
+         (c    (and a category
+                    (xetla-browse-find-named-widget
+                     (widget-get a :parent) category :category)))
+         (b    (and c branch
+                    (xetla-browse-find-named-widget
+                     (widget-get c :parent) branch :branch)))
+         (v    (and b version
+                    (xetla-browse-find-named-widget
+                     (widget-get b :parent) version :version))))
+    (list root a c b v)))
+
+(defun xetla-browse-find-single-widget (archive
+                                       &optional category branch
+                                       version)
+  "Similar to `xetla-browse-find-widget'.
+Difference is it returns only the widget representing the last non-nil
+widget of the list.  The means of ARCHIVE, CATEGORY, BRANCH and VERSION
+are the same as that of `xetla-browse-find-widget'."
+  (let ((widgets (xetla-browse-find-widget archive category branch
+                                          version)))
+    (or (nth 4 widgets)
+        (nth 3 widgets)
+        (nth 2 widgets)
+        (nth 1 widgets)
+        (error "Widget not found.  Please fill-in a bug report"))))
+
+(defun xetla-browse-find-real-widget (widget)
+  "Find real(complete) widget from incomplete WIDGET.
+When trying to find widgets using (widget-get ... :args), we
+sometimes find an incomplete widget, having no :from or :to
+information for example.  This function takes as an argument an
+incomplete widget, and finds the corresponding full widget.
+
+WIDGET must be of type xetla-widget-*-node."
+  (case (widget-type widget)
+    (xetla-widget-archive-node
+     (xetla-browse-find-single-widget
+      (widget-get widget :archive)))
+    (xetla-widget-category-node
+     (xetla-browse-find-single-widget
+      (widget-get widget :archive)
+      (widget-get widget :category)))
+    (xetla-widget-branch-node
+     (xetla-browse-find-single-widget
+      (widget-get widget :archive)
+      (widget-get widget :category)
+      (widget-get widget :branch)))
+    (xetla-widget-version-node
+     (xetla-browse-find-single-widget
+      (widget-get widget :archive)
+      (widget-get widget :category)
+      (widget-get widget :version)))))
+
+(defun* xetla-browse-open (flash archive
+                                &optional category branch version)
+  (let (widgets root a c b v)
+
+    (unless archive
+      (return-from xetla-browse-open nil))
+    (setq widgets (xetla-browse-find-widget archive category branch nil))
+    (setq root (nth 0 widgets))
+    (unless root
+      (error "Cannot find root archives node"))
+    (xetla-widget-node-toggle-subtree-internal root 'open)
+
+    (setq widgets (xetla-browse-find-widget archive category branch nil))
+    (setq a (nth 1 widgets))
+    (unless category
+      (if a
+          (progn (when flash
+                   (goto-char (widget-get a :from))
+                   (xetla-flash-line))
+            (return-from xetla-browse-open nil))
+        (error "Cannot find archive node for: %s" archive)))
+    (xetla-widget-node-toggle-subtree-internal a 'open)
+
+    (setq widgets (xetla-browse-find-widget archive category branch nil))
+    (setq c (nth 2 widgets))
+    (unless branch
+      (if c
+          (progn (when flash
+                   (goto-char (widget-get c :from))
+                   (xetla-flash-line))
+            (return-from xetla-browse-open nil))
+        (error "Cannot find category node for: %s/%s" archive category)))
+    (xetla-widget-node-toggle-subtree-internal c 'open)
+
+    (setq widgets (xetla-browse-find-widget archive category branch nil))
+    (setq b (nth 3 widgets))
+    (unless version
+      (if b
+          (progn (when flash
+                   (goto-char (widget-get b :from))
+                   (xetla-flash-line))
+            (return-from xetla-browse-open nil))
+        (error "Cannot find branch node for: %s/%s-%s" archive category branch)))
+    (xetla-widget-node-toggle-subtree-internal b 'open)
+
+    (setq widgets (xetla-browse-find-widget archive category branch version))
+    (setq v (nth 4 widgets))
+    (if v
+        (progn (when flash
+                 (goto-char (widget-get v :from))
+                 (xetla-flash-line))
+          (return-from xetla-browse-open nil))
+      (error "Cannot find branch node for: %s/%s-%s-%s" archive category branch version)))
+  )
+
+;; --------------------------------------
+;; Abstract Super Widget
+;; --------------------------------------
+(define-widget 'xetla-widget-node 'item
+  "Abstract super widget for xetla-widget-*-node."
+  :xetla-type nil
+  :format "%[ %t%]%{%v%}\n"
+  :face nil
+  :keymap nil
+  :menu nil
+  :marks " "
+  :keep '(:marks :open)
+  :open-subtree (if (fboundp 'tree-widget-open-node)
+		    'tree-widget-open-node
+		  'xetla-tree-widget-node-toggle-subtree-for-tree-widget-v1)
+  :close-subtree (if (fboundp 'tree-widget-open-node)
+		     'tree-widget-close-node
+		   'xetla-tree-widget-node-toggle-subtree-for-tree-widget-v1))
+
+(defvar xetla-widget-node-map
+  (let ((map (copy-keymap xetla-context-map-template)))
+    (define-key map [return]
+      'xetla-widget-node-toggle-subtree)
+    (define-key map [button2]
+      'xetla-widget-node-toggle-subtree-by-mouse)
+    (define-key map "\C-m"
+      'xetla-widget-node-toggle-subtree)
+    (define-key map (xetla-prefix-buffer ?p)
+      'xetla-show-process-buffer)
+    (define-key map (xetla-prefix-buffer ?L)
+      'xetla-open-internal-log-buffer)
+    (define-key map (xetla-prefix-buffer xetla-key-show-bookmark)
+      'xetla-bookmarks)
+    (define-key map xetla-keyvec-kill-ring
+      'xetla-widget-node-save-name-to-kill-ring)
+    (define-key map xetla-keyvec-add-bookmark
+      'xetla-widget-node-add-bookmark)
+    map)
+  "Keymap commonly used in xetla-widget-*-node.")
+
+(defun xetla-widget-node-value-create (widget keyword)
+  "Create value for WIDGET.
+KEYWORD is used to get the base string to create the value."
+  (insert (let* ((marks (widget-get widget :marks))
+                 (string (widget-get widget keyword))
+                 (value (xetla-widget-node-install-ui-element
+                         widget (if (string= string "") "<empty>"
+                                  string))))
+            (concat marks value))))
+
+(defun xetla-widget-node-install-ui-element (widget value &optional face)
+  "Create a string with keymap, menu and face properties.
+The keymap and menu are retrieved from WIDGET.
+The string is copied from VALUE.
+FACE is useds as the face."
+  (let ((prop-value (xetla-face-add value
+                                   (if face face (widget-get widget :face))
+                                   (widget-get widget :keymap)
+                                   (widget-get widget :menu))))
+    (put-text-property 0 (length value)
+                       'widget widget
+                       prop-value)
+    prop-value))
+
+(defun xetla-widget-node-get-at (&optional point)
+  "Get widget at POINT."
+  (get-text-property (if point point (point)) 'widget))
+
+(defun xetla-widget-node-get-name (&optional point)
+  "Get name list associated widget under the POINT."
+  (let ((widget (xetla-widget-node-get-at point)))
+    (list (widget-get widget :archive)
+          (widget-get widget :category)
+          (widget-get widget :branch)
+          (widget-get widget :version)
+          nil)))
+
+(defun xetla-widget-node-get-type (&optional point)
+  "Get type of widget under the POINT.
+
+Can be either 'archive, 'category, 'branch, 'version or nil for the
+root of the tree."
+  (let ((widget (xetla-widget-node-get-at point)))
+    (widget-get widget :xetla-type)))
+
+(defun xetla-widget-get-ancestor (widget level)
+  "Get the ancestor widget of WIDGET.
+\"ancestor\" widget stands for the LEVEL upper widget
+in the archives tree."
+  (let ((i 0)
+        (parent widget))
+    (while (< i level)
+      (setq parent (widget-get parent :parent)
+            i (1+ i)))
+    parent))
+
+(defun xetla-widget-node-refresh (&optional level point
+                                           archive
+                                           category
+                                           branch)
+  "Refresh node and LEVEL subnode at the POINT.
+Before refreshing node, names cache are also refreshed if
+ARCHIVE, CATEGORY, and/or BRANCH are specified."
+  (interactive)
+  (unless level (setq level 1))
+  (unless point (setq point (point)))
+  (if branch
+      (xetla-archive-tree-build-versions archive
+                                        category
+                                        branch
+                                        nil t)
+    (if category
+        (xetla-archive-tree-build-branches archive
+                                          category
+                                          nil t)
+      (if archive
+          (xetla-archive-tree-build-categories archive
+                                              nil
+                                              t)
+        (xetla-archive-tree-build-archives nil t))))
+  (let* ((widget (xetla-widget-node-get-at point))
+         (tree (xetla-widget-get-ancestor widget level)))
+    (widget-put tree :args nil)
+    (widget-value-set tree (widget-value tree))
+    (widget-setup)))
+
+(defun xetla-widget-node-synchronize-mirror-to-remote ()
+  "Synchronizes the mirror for the archive at point to remote from local."
+  (interactive)
+  (let* ((name (xetla-widget-node-get-name))
+         (archive (xetla-name-archive name))
+         (type (xetla-archive-type archive))
+         mirror source)
+    (cond
+     ((eq type 'normal)
+      (setq mirror (xetla-archive-name-mirror archive t))
+      (unless mirror
+        (error "No mirror archive for `%s'" archive)))
+     ((eq type 'mirror)
+      (setq source (xetla-archive-name-source archive t))
+      (if source
+          (setq archive source)
+        (error "No source archive for `%s'" archive)))
+     (t (error "Cannot mirror to a source archive: `%s'" archive)))
+    (xetla-archive-mirror archive
+                        (xetla-name-category name)
+                          (xetla-name-branch name)
+                          (xetla-name-version name)
+                          nil)))
+
+(defun xetla-widget-node-synchronize-mirror-to-local ()
+  "Synchronizes the mirror for the archive at point to local from remote."
+  (interactive)
+  ;; TODO
+  )
+
+(defun xetla-widget-node-save-name-to-kill-ring ()
+  "Save the name under point to `kill-ring'."
+  (interactive)
+  (let ((name (xetla-name-construct (xetla-widget-node-get-name))))
+    (when (equal "" name)
+      (error "No widget under the point"))
+    (kill-new name)
+    (message "Name: %s" name)))
+
+(defun xetla-widget-node-add-bookmark ()
+  "Add a name associated with a widget at point to xetla's bookmarks."
+  (interactive)
+  (let* ((target (xetla-widget-node-get-name))
+         (target-fq (xetla-name-construct target))
+         (bookmark (read-from-minibuffer (format "Name of Bookmark for `%s': "
+                                                 target-fq))))
+    (xetla-bookmarks-add bookmark target)
+    (when (y-or-n-p "View bookmarks? ")
+      (xetla-bookmarks))
+    (message "bookmark %s(=> %s) added." bookmark target-fq)))
+
+(defun xetla-widget-node-toggle-subtree (&optional point force)
+  "Toggle between closing and opening the node at POINT.
+You can specify a symbol, `open' or `close' to FORCE to force
+the node to open or to close."
+  (interactive)
+  (xetla-widget-node-toggle-subtree-internal
+   (xetla-widget-node-get-at point) force))
+
+(defun xetla-widget-node-toggle-subtree-recursive (&optional point
+                                                            force)
+  "Same as `xetla-widget-node-toggle-subtree'.
+The difference is that when the node is expanded, expands it
+recursively, which means all the children will also be expanded.  (this
+may take looong).
+Meaning of POINT and FORCE are the same as that of
+`xetla-widget-node-toggle-subtree'."
+  (interactive)
+  (xetla-widget-node-toggle-subtree-internal
+   (xetla-widget-node-get-at point) force t))
+
+(defun xetla-widget-node-toggle-subtree-internal (widget force
+                                                        &optional
+                                                        recursive)
+  "Toggle between closing and opening the WIDGET.
+You can specify a symbol, `open' or `close' to FORCE to force
+the node to open or to close.  If RECURSIVE is non-nil, the opening
+or closing are applied recursively."
+  (let* ((open-subtree (widget-get widget :open-subtree))
+         (close-subtree (widget-get widget :close-subtree)))
+    (cond
+     ((or (eq force 'open)
+          (and (not force)
+               (not (widget-get (widget-get widget :parent) :open))))
+      (when open-subtree (funcall open-subtree widget))
+      (when recursive
+        (xetla-widget-node-toggle-subtree-recursion widget 'open)))
+     ((or (eq force 'close)
+	  (and (not force)
+               (widget-get (widget-get widget :parent) :open)))
+      (when (and recursive
+                 (widget-get (widget-get widget :parent) :open))
+        (when open-subtree (funcall open-subtree widget))
+        (xetla-widget-node-toggle-subtree-recursion widget 'close))
+      (when close-subtree (funcall close-subtree widget))))))
+
+(defun xetla-widget-node-toggle-subtree-recursion (widget force)
+  "A helper function for 'xetla-widget-node-toggle-subtree-internal'.
+Apply all sub node of WIDGET opening or closing which is specified
+by FORCE."
+  (let ((args (widget-get (widget-get widget :parent) :args)))
+    (dolist (arg args)
+      (let* ((t-widget (widget-get arg :node))
+             ;; surprisingly, t-widget doesn't have all the
+             ;; necessary fields. Look for the _real_ widget.
+             (full-widget
+              (xetla-browse-find-real-widget t-widget)))
+        (unless (eq (widget-type t-widget)
+                    (widget-type full-widget))
+          (error "Incorrect widget.  Please contact the developers"))
+        (when full-widget
+          (xetla-widget-node-toggle-subtree-internal
+           full-widget force t))))))
+
+(defun xetla-tree-widget-node-toggle-subtree-for-tree-widget-v1 (widget)
+  "Toggle tree node function used in `xetla-browse' with tree-widget ver.1.0.5.
+The code is the almost same as in tree-widget-toggle-folding tree-widget version
+1.0.5.
+
+Original documents say:
+  \"Toggle a `tree-widget' folding.
+WIDGET is a `tree-widget-node-handle-widget' and its parent the
+`tree-widget' itself.  IGNORE other arguments.\""
+  (let* ((parent (widget-get widget :parent))
+	 ;; Original code
+	 ; (open   (widget-value widget))
+	 ;; Here `parent' is used instead of `widget'.
+	 (open   (widget-value parent)))
+    (if open
+	(tree-widget-children-value-save parent))
+    (widget-put parent :open (not open))
+    (widget-value-set parent (not open))
+    (run-hook-with-args 'tree-widget-after-toggle-functions parent)))
+
+(xetla-make-bymouse-function xetla-widget-node-toggle-subtree)
+
+;; --------------------------------------
+;; My-id
+;; --------------------------------------
+(define-widget 'xetla-widget-my-id 'push-button
+  "Widget to control xetla's my-id."
+  :format "%{My-id:%} %[%t%]"
+  :sample-face 'bold
+  :button-face 'widget-field-face
+  :notify 'xetla-widget-my-id-set
+  :help-echo "Click here to change my-id")
+
+(defun xetla-widget-my-id-set (self changed event)
+  "Set my-id to my-id-widget.
+SELF is not used.  CHANGED is just passed to `widget-value-set'.
+EVENT is also not used."
+  (let ((new-id (xetla-my-id t)))
+    (widget-value-set changed new-id)
+    (widget-setup)))
+
+;; --------------------------------------
+;; Root node
+;; --------------------------------------
+(define-widget 'xetla-widget-root-node 'xetla-widget-node
+  "Root node widget for trees in xetla-browse buffer."
+  :value-create 'xetla-widget-root-node-value-create
+  :format " %v\n"
+  :face 'bold)
+
+(defun xetla-widget-root-node-value-create (widget)
+  "Create a value for root node represented by WIDGET."
+  (insert (xetla-widget-node-install-ui-element
+           widget
+           (widget-get widget :tag))))
+
+(defvar xetla-widget-archives-root-node-map
+  (let ((map (copy-keymap xetla-widget-node-map)))
+    (define-key map xetla-keyvec-refresh
+      'xetla-widget-node-refresh)
+    (define-key map (xetla-prefix-add ?a)
+      'xetla-widget-archives-root-node-make-archive)
+    (define-key map (xetla-prefix-add ?r)
+      'xetla-widget-archives-root-node-register-archive)
+    map)
+  "Keymap used on the archives root node.")
+
+(easy-menu-define xetla-widget-archives-root-node-menu nil
+  "Menu used on the root archives item in `xetla-browse-mode' buffer."
+  '("Archives Root"
+    ["Update Archives List"
+     xetla-widget-node-refresh t]
+    ["Make New Archive..."
+     xetla-widget-archives-root-node-make-archive t]
+    ["Register Archive"
+     xetla-widget-archives-root-node-register-archive t]))
+
+(defun xetla-widget-archives-root-node-make-archive ()
+  "Call `xetla-make-archive-internal' interactively  then update the tree of `xetla-browse'."
+  (interactive)
+  (call-interactively 'xetla-make-archive-internal)
+  (xetla-widget-node-refresh 1))
+
+(defun xetla-widget-archives-root-node-goto (name)
+  "Move the point to beginning of line in where the NAME is.
+This may be useful to search an archive named NAME."
+  (goto-char (point-min))
+  (search-forward name)
+  (beginning-of-line))
+
+(defun xetla-widget-archives-root-node-register-archive ()
+  "Call `xetla-register-archive-internal' interactively ; then update the tree of `xetla-browse'."
+  (interactive)
+  (let* ((result (call-interactively 'xetla-register-archive-internal))
+         (archive-registered (nth 0 result))
+         (archive (nth 1 result))
+         (xetla-response (nth 3 result)))
+    (when archive-registered
+      (xetla-widget-node-refresh 1)
+      (message xetla-response)
+      (xetla-widget-archives-root-node-goto
+       (if (string-match ".+: \\(.+\\)" xetla-response)
+           (match-string 1 xetla-response)
+         archive))
+      (xetla-flash-line))))
+
+
+;; --------------------------------------
+;; Archive
+;; --------------------------------------
+(defface xetla-location
+  '((((class color) (background dark)) (:foreground "gray"))
+    (((class color) (background light)) (:foreground "gray"))
+    (t (:bold t)))
+  "Face to highlight xetla's archive location."
+  :group 'xetla-faces)
+
+(make-face 'xetla-location-ftp
+	   "Face to highlight xetla's archive ftp location.")
+(set-face-parent 'xetla-location-ftp 'xetla-location)
+
+(make-face 'xetla-location-sftp
+	   "Face to highlight xetla's archive sftp location.")
+(set-face-parent 'xetla-location-sftp 'xetla-location)
+(set-face-foreground 'xetla-location-sftp "gray50")
+
+(make-face 'xetla-location-http
+		  "Face to highlight xetla's archive sftp location.")
+(set-face-parent 'xetla-location-http 'xetla-location)
+(set-face-foreground 'xetla-location-http "gray60")
+
+(make-face 'xetla-location-local
+	   "Face to highlight xetla's local archive.")
+(set-face-parent 'xetla-location-local 'xetla-location)
+(set-face-foreground 'xetla-location-local "gray30")
+
+(defvar xetla-widget-archive-node-map
+  (let ((map (copy-keymap xetla-widget-node-map)))
+    (define-key map xetla-keyvec-refresh
+      'xetla-widget-archive-node-refresh)
+    (define-key map "*" 'xetla-widget-archive-node-select-default)
+    (define-key map xetla-keyvec-remove
+      'xetla-widget-archive-node-unregister-archive)
+    (define-key map (xetla-prefix-add ?c)
+      'xetla-widget-archive-node-make-category)
+    (define-key map (xetla-prefix-apply-from-here xetla-key-reflect)
+      'xetla-widget-archive-node-start-project)
+    (define-key map xetla-keyvec-reflect
+      'xetla-widget-node-synchronize-mirror-to-remote)
+    (define-key map xetla-keyvec-get
+      'xetla-widget-node-synchronize-mirror-to-local)
+    (define-key map (xetla-prefix-add xetla-key-reflect)
+      'xetla-widget-archive-node-make-mirror-at-remote)
+    (define-key map (xetla-prefix-add xetla-key-get)
+      'xetla-widget-archive-node-make-mirror-at-local)
+    map)
+  "Keymap used on xetla-widget-archive-node.")
+
+(easy-menu-define xetla-widget-archive-node-menu nil
+  "Menu used on a archive item in `xetla-browse-mode' buffer."
+  '("Archive"
+    ["Update Categories List"      xetla-widget-archive-node-refresh t]
+    ["Set Default Archive"         xetla-widget-archive-node-select-default t]
+    ["Remove Archive Registration" xetla-widget-archive-node-unregister-archive t]
+    ["Make New Category..."        xetla-widget-archive-node-make-category t]
+    ["Start Project from Here"     xetla-widget-archive-node-start-project t]
+    ["Add a Bookmark"              xetla-widget-node-add-bookmark t]
+    ("Remote Mirror"
+     ["Synchronize Mirror to Remote From Local"
+      xetla-widget-node-synchronize-mirror-to-remote
+      (let* ((archive (xetla-name-archive (xetla-widget-node-get-name)))
+             (type (xetla-archive-type archive)))
+        (or (and (eq type 'normal)
+                 (xetla-archive-name-mirror archive t))
+            (and (eq type 'mirror)
+                 (xetla-archive-name-source archive t))))]
+     ["Create a Mirror at Remote"
+      xetla-widget-archive-node-make-mirror-at-remote
+      (eq (xetla-archive-type (xetla-name-archive (xetla-widget-node-get-name)))
+          'normal)])
+    ("Local Mirror"
+     ["Synchronize Mirror to Local[TODO]"
+      ;; TODO
+      xetla-widget-node-synchronize-mirror-to-local nil]
+     ["Create a Mirror at Local" xetla-widget-archive-node-make-mirror-at-local
+      (eq (xetla-archive-type (xetla-name-archive (xetla-widget-node-get-name)))
+          'source)]
+     "-"
+     ["Convert to SOURCE archive" xetla-widget-archive-node-convert-to-source
+      (eq (xetla-archive-type (xetla-name-archive (xetla-widget-node-get-name)))
+          'normal)])
+    ["Save Name to Kill Ring" xetla-widget-node-save-name-to-kill-ring t]))
+
+(defconst xetla-widget-archive-node-tag "a")
+(defconst xetla-widget-archive-node-default-tag "A")
+
+(define-widget 'xetla-widget-archive-node 'xetla-widget-node
+  "Archive node in xetla-browse."
+  :tag xetla-widget-archive-node-tag
+  :value-create 'xetla-widget-archive-node-value-create
+  :xetla-type 'archive
+  :face 'xetla-archive-name
+  :keymap 'xetla-widget-archive-node-map
+  :menu xetla-widget-archive-node-menu
+  :archive nil
+  :archive-location nil
+  :archive-defaultp nil)
+
+(defvar xetla-widget-archive-node-list nil)
+(defun xetla-browse-expand-archives (root)
+  "Expand ROOT widget."
+  (or (and (not current-prefix-arg) (widget-get root :args))
+      (let ((default-archive (xetla-my-default-archive)))
+        (setq xetla-widget-archive-node-list nil)
+        (mapcar
+         (lambda (archive)
+           (let ((res
+                  `(tree-widget
+                    :open ,(xetla-browse-open-list-member (car archive))
+                    :has-children t
+                    :dynargs xetla-browse-expand-categories
+                    :node (xetla-widget-archive-node
+                           :tag ,(if (equal default-archive (car archive))
+                                     xetla-widget-archive-node-default-tag
+                                   xetla-widget-archive-node-tag)
+                           :archive ,(car archive)
+                           :archive-location ,(cadr archive)
+                           :archive-defaultp ,(equal
+                                               default-archive
+                                               (car
+                                                archive))))))
+             (widget-put (widget-get res :node) :parent res)
+             res))
+         (let* ((l xetla-archive-tree))
+           (when (or (null l) current-prefix-arg)
+             (xetla-archive-tree-build-archives nil t))
+           xetla-archive-tree)))))
+
+(defun xetla-widget-archive-node-value-create (widget)
+  "Create values for WIDGET."
+  (push widget xetla-widget-archive-node-list)
+  (insert (let* ((archive  (widget-get widget :archive))
+                 (location (widget-get widget :archive-location))
+                 (defaultp (widget-get widget :archive-defaultp))
+                 (marks    (widget-get widget :marks))
+                 (value (progn
+                          (case (xetla-archive-type archive)
+                            (mirror (widget-put widget :face 'xetla-mirror-archive-name))
+                            (source (widget-put widget :face 'xetla-source-archive-name)))
+                          ;;
+                          ;; It seems that XEmacs's format hides text properties.
+                          ;;
+                          (concat marks
+                                  (xetla-widget-node-install-ui-element
+                                   widget archive (when defaultp
+                                                    'xetla-marked))
+                                  " => "
+                                  (xetla-widget-archive-put-face-on-location
+                                   location)))))
+            value)))
+
+(defun xetla-widget-archive-put-face-on-location (location)
+  "Set face to LOCATION based on the location type(ftp, sftp, http or local)."
+(let ((face (case (xetla-location-type location)
+                (ftp 'xetla-location-ftp)
+                (sftp 'xetla-location-sftp)
+                (http 'xetla-location-http)
+                (local 'xetla-location-local)))
+        (location (copy-sequence location)))
+    (put-text-property 0 (length location)
+                       'face face location)
+    location))
+
+(defun xetla-widget-archive-node-refresh ()
+  "Refresh an archive node under the point."
+  (interactive)
+  (xetla-widget-node-refresh 1 nil
+                            (xetla-name-archive
+                             (xetla-widget-node-get-name))))
+
+(defun xetla-widget-archive-node-select-default ()
+  "Mark a widget associated with the default archive.
+Unmark widgets not associated with the default archive.
+`:archive-defaultp' keyword is used to mark."
+  (interactive)
+  (mapc
+   (lambda (widget)
+     (when (equal xetla-widget-archive-node-default-tag
+                  (widget-get widget :tag))
+       (widget-put widget :tag xetla-widget-archive-node-tag)
+       (widget-put widget :archive-defaultp nil)
+       (widget-value-set widget (widget-value widget))))
+   xetla-widget-archive-node-list)
+  (let* ((widget (xetla-widget-node-get-at))
+         (archive (xetla-name-archive (xetla-widget-node-get-name) )))
+    (xetla-my-default-archive archive)
+    (widget-put widget :tag xetla-widget-archive-node-default-tag)
+    (widget-put widget :archive-defaultp t)
+    (widget-value-set widget (widget-value widget))))
+
+(defun xetla-widget-archive-node-unregister-archive ()
+  "Delete the registration of the archive under the point."
+  (interactive)
+  (let ((archive (xetla-name-archive (xetla-widget-node-get-name))))
+    (if archive
+        (progn (xetla-unregister-archive archive t)
+               (xetla-widget-node-refresh 2))
+      (error "No archive under the point"))))
+
+(defun xetla-widget-archive-node-make-category ()
+  "Make new category in the archive under the point."
+  (interactive)
+  (let* ((name (xetla-widget-node-get-name))
+         (archive (xetla-name-archive name))
+         (l (xetla-name-read "New Category: "
+                            archive
+                            'prompt)))
+    (xetla-make-category (xetla-name-archive l) (xetla-name-category l))
+    (xetla-widget-node-refresh 1 nil (xetla-name-archive l))
+    (xetla-browse-open t
+                      (xetla-name-archive l)
+                      (xetla-name-category l))
+    ))
+
+(defun xetla-widget-archive-node-convert-to-source ()
+  "Convert the archive under the point to a source archive."
+  (interactive)
+  (let* ((widget (xetla-widget-node-get-at))
+         (archive (widget-get widget :archive))
+         (location (widget-get widget :archive-location))
+         (result (xetla-archive-convert-to-source-archive archive location)))
+    (let ((archive-registered (nth 0 result))
+          (archive (nth 1 result))
+          (xetla-response (nth 3 result)))
+      (when archive-registered
+        (xetla-widget-node-refresh 2)
+        (message xetla-response)
+        (xetla-widget-archives-root-node-goto
+         (if (string-match ".+: \\(.+\\)" xetla-response)
+             (match-string 1 xetla-response)
+           archive))
+        (xetla-flash-line)))))
+
+(defun xetla-widget-archive-node-start-project ()
+  "Start new project in the archive unde the point."
+  (interactive)
+  (let* ((archive (xetla-name-archive (xetla-widget-node-get-name)))
+         (buffer (current-buffer))
+         (p (point))
+         (result (xetla-start-project archive 'synchronously))
+         (category (xetla-name-category (car result)))
+         (branch (xetla-name-branch (car result)))
+         (version (xetla-name-version (car result)))
+         )
+    (with-current-buffer buffer
+      (xetla-widget-node-refresh 1 p archive)
+      (xetla-browse-open t
+                        archive category branch version))))
+
+(defun xetla-widget-archive-node-make-mirror-at-remote ()
+  "Create a mirror for the local archive under the point at somewhere remote."
+  (interactive)
+  (let ((archive (xetla-name-archive (xetla-widget-node-get-name))))
+    (unless archive
+      (error "No archive under the point"))
+    (xetla-mirror-archive archive nil nil nil nil)
+    (xetla-widget-node-refresh 2)
+    (xetla-widget-archives-root-node-goto (format "%s-MIRROR" archive))
+    (xetla-flash-line)))
+
+(defun xetla-widget-archive-node-make-mirror-at-local ()
+  "Create a mirror for the remote archive under the point to local."
+  (interactive)
+  (let ((archive (xetla-name-archive (xetla-widget-node-get-name))))
+    (unless archive
+      (error "No archive under the point"))
+    (xetla-mirror-from-archive archive nil)
+    (xetla-widget-node-refresh 2)
+    (string-match "\\(.*\\)-SOURCE$" archive)
+    (xetla-widget-archives-root-node-goto
+     ;; Adding a space not to match SOURCE archive.
+     (concat (match-string 1 archive) " "))
+    (xetla-flash-line)))
+
+;; --------------------------------------
+;; Categories
+;; --------------------------------------
+(defvar xetla-widget-category-node-map
+  (let ((map (copy-keymap xetla-widget-node-map)))
+    (define-key map xetla-keyvec-refresh
+      'xetla-widget-category-node-refresh)
+    (define-key map (xetla-prefix-add ?b)
+      'xetla-widget-category-node-make-branch)
+    map)
+  "Keymap used on xetla-widget-category-node.")
+
+(easy-menu-define xetla-widget-category-node-menu nil
+  "Menu used on a archive item in `xetla-browse-mode' buffer."
+  '("Category"
+    ["Update Branches List" xetla-widget-category-node-refresh t]
+    ["Remove Category[NOT IMPLEMENTED]" nil t]
+    ["Make New Branch..." xetla-widget-category-node-make-branch t]
+    ["Add a Bookmark" xetla-widget-node-add-bookmark t]
+    ["Synchronize Mirror to Remote"
+     xetla-widget-node-synchronize-mirror-to-remote t]
+    ["Save Name to Kill Ring" xetla-widget-node-save-name-to-kill-ring t]))
+
+(define-widget 'xetla-widget-category-node 'xetla-widget-node
+  "Category node in xetla-browse."
+  :tag "c"
+  :value-create 'xetla-widget-category-node-value-create
+  :xetla-type 'category
+  :face 'xetla-category-name
+  :keymap 'xetla-widget-category-node-map
+  :menu xetla-widget-category-node-menu
+  :archive nil
+  :category nil)
+
+(defun xetla-browse-expand-categories (archive)
+  "Expand ARCHIVE widget."
+  (or (and (not current-prefix-arg) (widget-get archive :args))
+      (let ((archive-name (widget-get
+                           (widget-get archive :node)
+                           :archive)))
+        (mapcar
+         (lambda (category)
+           (let ((res `(tree-widget
+                        :open ,(xetla-browse-open-list-member archive-name
+                                                             (car category))
+                        :has-children t
+                        :dynargs xetla-browse-expand-branches
+                        :node (xetla-widget-category-node
+                               :archive ,archive-name
+                               :category ,(car category)))))
+             (widget-put (widget-get res :node) :parent res)
+             res))
+         (let* ((l (cddr (xetla-archive-tree-get-archive
+                          archive-name))))
+           (when (or (null l) current-prefix-arg)
+             (xetla-archive-tree-build-categories archive-name nil t))
+           (cddr (xetla-archive-tree-get-archive archive-name)))))))
+
+(defun xetla-widget-category-node-value-create (widget)
+  "Create values for category WIDGET."
+  (xetla-widget-node-value-create widget :category))
+
+(defun xetla-widget-category-node-refresh ()
+  "Refresh a category widget at the point."
+  (interactive)
+  (let ((name (xetla-widget-node-get-name)))
+    (xetla-widget-node-refresh 1 nil
+                              (xetla-name-archive name)
+                              (xetla-name-category name))))
+
+(defun xetla-widget-category-node-make-branch ()
+  "Make new branch in the category under the point."
+  (interactive)
+  (let* ((name (xetla-widget-node-get-name))
+         (archive (xetla-name-archive name))
+         (category  (xetla-name-category name))
+         (l (xetla-name-read "New Branch: "
+                            archive
+                            category
+                            'prompt)))
+    (xetla-make-branch (xetla-name-archive l)
+		     (xetla-name-category l)
+		     (xetla-name-branch l))
+    (xetla-widget-node-refresh 1 nil
+			      (xetla-name-archive l)
+			      (xetla-name-category l))
+    (xetla-browse-open t
+                      (xetla-name-archive l)
+                      (xetla-name-category l)
+                      (xetla-name-branch l))))
+
+;; --------------------------------------
+;; Branch
+;; --------------------------------------
+(defvar xetla-widget-branch-node-map
+  (let ((map (copy-keymap xetla-widget-node-map)))
+    (define-key map xetla-keyvec-refresh
+      'xetla-widget-branch-node-refresh)
+    (define-key map (xetla-prefix-add ?v)
+      'xetla-widget-branch-node-make-version)
+    (define-key map xetla-keyvec-get
+      'xetla-widget-branch-node-get-branch)
+    map)
+  "Keymap used on xetla-widget-branch-node.")
+
+(easy-menu-define xetla-widget-branch-node-menu nil
+  "Menu used on a archive item in `xetla-browse-mode' buffer."
+  '("Branch"
+    ["Update Version List" xetla-widget-branch-node-refresh t]
+    ["Remove Branch Registration[NOT IMPLEMENTED]" nil t]
+    ["Make New Version..." xetla-widget-branch-node-make-version t]
+    ["Get..."              xetla-widget-branch-node-get-branch t]
+    ["Add a Bookmark" xetla-widget-node-add-bookmark t]
+    ["Synchronize Mirror to Remote"
+     xetla-widget-node-synchronize-mirror-to-remote t]
+    ["Save Name to Kill Ring" xetla-widget-node-save-name-to-kill-ring t]))
+
+(define-widget 'xetla-widget-branch-node 'xetla-widget-node
+  "Branch node in xetla-browse."
+  :tag "b"
+  :value-create 'xetla-widget-branch-node-value-create
+  :xetla-type 'branch
+  :face 'xetla-branch-name
+  :keymap 'xetla-widget-branch-node-map
+  :menu xetla-widget-branch-node-menu
+  :archive nil
+  :category nil
+  :branch nil)
+
+(defun xetla-browse-expand-branches (category)
+  "Expand CATEGORY widget."
+  (or (and (not current-prefix-arg) (widget-get category :args))
+      (let* ((parent-node   (widget-get category :node))
+             (archive-name  (widget-get parent-node :archive))
+             (category-name (widget-get parent-node :category)))
+        (mapcar
+         (lambda (branch)
+           (let ((res
+                  `(tree-widget
+                    :open ,(xetla-browse-open-list-member archive-name
+                                                         category-name
+                                                         (car branch))
+                    :has-children t
+                    :leaf-control xetla-widget-version-control
+                    :dynargs xetla-browse-expand-versions
+                    :node (xetla-widget-branch-node
+                           :archive ,archive-name
+                           :category ,category-name
+                           :branch ,(car branch)))))
+             (widget-put (widget-get res :node) :parent res)
+             res))
+         (let* ((l (cdr (xetla-archive-tree-get-category
+                         archive-name
+                         category-name))))
+           (when (or (null l) current-prefix-arg)
+             (xetla-archive-tree-build-branches archive-name
+                                               category-name
+                                               nil t))
+           (cdr (xetla-archive-tree-get-category archive-name
+                                                category-name)))))))
+
+(defun xetla-widget-branch-node-value-create (widget)
+  "Create values for branch WIDGET."
+  (xetla-widget-node-value-create widget :branch))
+
+(defun xetla-widget-branch-node-refresh ()
+  "Refresh a branch widget at the point."
+  (interactive)
+  (let ((name (xetla-widget-node-get-name)))
+    (xetla-widget-node-refresh 1 nil
+			      (xetla-name-archive name)