Filesets 1.3

[Thomas Link]

This package is inspired by the Alpha editor's filesets. =filesets.el=
adds a new menu to the menubar, each submenu of which holds the files
of a fileset (defined as a list of files, by a regular pattern
expression, or a base document referring to other subdocuments) or a
directory tree. =filesets.el= makes it easy to open frequently
accessed files. In conjunction with external programs for viewing
various formats like PDF or HTML, =filesets.el= can also be used to
browse your documentation files or your sourcecode with just a few
mouse clicks. All files belonging to a fileset can be opened or closed
at once.

Supported modes for document trees:

- Elisp
- Emacs-Wiki (simple names only)
- LaTeX


** Change log

v1.3 :: Some optimizations, splitting of long menus.

Cheers,
Thomas.


-8<---------------------------------------------------------

;;; FILESETS.EL --- filesets vor (X)Emacs

;; Copyright (C) 2001 Thomas Link

;; Author: Thomas Link <address@hidden>
;; URL: http://members.a1.net/t.link/CompEmacsFilesets.html
;; Time-stamp: <2001-11-11>
;; Keywords: filesets convenience

(defvar filesets-version "1.3.2")

;; 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.

;; A copy of the GNU General Public License can be obtained from this
;; program's author (send electronic mail to <address@hidden>) or
;; from the Free Software Foundation, Inc., 675 Mass Ave, Cambridge,
;; MA 02139, USA.


;;; Commentary:

;;Define filesets, which can be opened or saved with the power one or
;;two mouse clicks only.

;;I guess there already is a similar package around. But as I don't
;;know of such a package, I wrote my own. Here it is.

;;Oh yes, usage. Edit `filesets-data' and put (require 'filesets) into
;;your startup file. This will add a nifty filesets menu to your
;;menubar. If you change your filesets on the fly, don't forget to
;;press "Save Filesets".

;;Press on the first item in the submenu to open all files at once.
;;You can also define your own function, e.g. browse-url, to open
;;files. An alternative would be to define a global external viewer.
;;See `filesets-external-viewers'.

;;BTW, if you close a fileset, files, which have been changed, will
;;silently be saved. Change this behaviour by setting
;;`filesets-save-buffer-fn'.

;;Caveat: Fileset names have to be unique.


;;; Supported modes for document trees (`filesets-subdocument-pattern':)
;; - Elisp
;; - Emacs-Wiki (simple names only)
;; - LaTeX


;;; Change log:

;; v1.3:

;;- some optimizations
;;- splitting of long menus

;; v1.2:
;;- Improved support for document trees (i.e. master documents
;;referring to other files)

;; v1.1:
;;- First experimental support for document trees (i.e. master
;;documents referring to other files)
;;- First support for GNU Emacs. (Tested on 21.1.2)

;; v1.0: Initial release. Tested on Xemacs 21.4.4 (AI).


;;; To do:

;;; Credits:

;; - Christoph Conrad <address@hidden>


;;; Code:

(require 'cl)


;;; some variables
(defgroup filesets nil
  "Fileset swapper."
  :prefix "filesets-"
  :group 'convenience)

(defcustom filesets-menu-name "Filesets"
  "Filesets' menu name."
  :type 'sexp
  :group 'filesets)

(defcustom filesets-menu-path nil
  "Where to put the filesets menu. See `add-submenu' for
documentation. (If you're using GNU Emacs, this won't affect you.)"
  :type 'sexp
  :group 'filesets)

(defcustom filesets-menu-before "File"
  "Put the filesets menu before this item. See `add-submenu' for
documentation. (If you're using GNU Emacs, this won't affect you.)"
  :type 'sexp
  :group 'filesets)

(defcustom filesets-menu-in-menu nil
  "Put the filesets menu in a menu. See `add-submenu' for
documentation. (If you're using GNU Emacs, this won't affect you.)"
  :type 'sexp
  :group 'filesets)

(defcustom filesets-create-menu-shortcuts-p t
  "Whether to prepend menus with hopefully unique shortcuts, i.e.
letters or numbers."
  :type 'boolean
  :group 'filesets)

(defcustom filesets-max-submenu-length 25
  "Maximum length of submenus. Set this value to 0 to turn menu
splitting off. BTW, parts of submenus will not be made up if their
length exceeds this value."
  :type 'integer
  :group 'filesets)

(defcustom filesets-max-entry-length 50
  "The names of splitted submenus will be truncated to this length."
  :type 'integer
  :group 'filesets)

(defcustom filesets-browse-dir-fn 'dired
  "The function used to browse a directory, when in :tree view."
  :type 'function
  :group 'filesets)

(defcustom filesets-open-file-fn 'filesets-find-or-display-file
  "The default function used to open a file."
  :type 'function
  :group 'filesets)

(defcustom filesets-save-buffer-fn 'save-buffer
  "The default function used to save a buffer."
  :type 'function
  :group 'filesets)

(defcustom filesets-find-file-delay 0.5
  "Delay before calling find-file. You may want to set this
to 0, if you don't use Xemacs' buffer tabs."
  :type 'number
  :group 'filesets)

(defcustom filesets-sort-menup t
  "Whether to sort the filesets menu."
  :type 'boolean
  :group 'filesets)

(defcustom filesets-tree-max-level 3
  "Maximum scan depth for directory trees."
  :type 'integer
  :group 'filesets)

(defcustom filesets-external-viewers
  `(("^.+\\..?html?$" browse-url)
    ("^.+\\.pdf$" "acroread")
    ("^.+\\.e?ps\\(.gz\\)?$" "ggv")
    ("^.+\\.dvi$" "xdvi")
    ("^.+\\.\\(tiff\\|xpm\\|gif\\|pgn\\)$" "gqview"))
  "Alist of external viewers"
  :type
  '(repeat :tag "Viewer"
           (list :tag "Definition"
                 (regexp :tag "Pattern" :value "^.+\\.suffix$")
                 (choice
                  :tag "Viewer"
                  (symbol :tag "Function" :value nil)
                  (string :tag "Program" :value ""))))
  :group 'filesets)

(defcustom filesets-subdocument-pattern
  '(("^.+\\.tex$" t
     (((:name "Package")
       (:pattern
"\\\\usepackage\\W*\\(\\[[^\]]*\\]\\W*\\)?{\\W*\\(.+\\)\\W*}")
       (:match-number 2)
       (:get-path (lambda (master file)
                    (filesets-which-file master
                                         (concat file ".sty")
                                         (filesets-convert-path-list 
                                          (or (getenv "MY_TEXINPUTS")
                                              (getenv "TEXINPUTS")))))))
      ((:name "Include")
       (:pattern "\\\\include\\W*{\\W*\\(.+\\)\\W*}")
       (:get-path (lambda (master file)
                    (filesets-which-file master
                                         (concat file ".tex")
                                         (filesets-convert-path-list 
                                          (or (getenv "MY_TEXINPUTS")
                                              (getenv "TEXINPUTS"))))))
       (:scan-depth 5))
      ((:name "Input")
       (:pattern "\\\\input\\W*{\\W*\\(.+\\)\\W*}")
       (:get-path (lambda (master file)
                    (filesets-which-file master
                                         (concat file ".tex")
                                         (filesets-convert-path-list 
                                          (or (getenv "MY_TEXINPUTS")
                                              (getenv "TEXINPUTS"))))))
       (:scan-depth 5))
      ((:name "Bibliography")
       (:pattern "\\\\bibliography\\W*{\\W*\\(.+\\)\\W*}")
       (:get-path (lambda (master file)
                    (filesets-which-file master
                                         (concat file ".bib")
                                         (filesets-convert-path-list 
                                          (or (getenv "MY_BIBINPUTS")
                                              (getenv "BIBINPUTS")))))))))
    ("^.+\\.el$" t
     (((:name "Require")
       (:pattern "(require\\W+'\\(.+\\))")
       (:get-path (lambda (master file)
                    (filesets-which-file master
                                         (concat file ".el")
                                         load-path))))
      ((:name "Load")
       (:pattern "(load \"\\(.+\\)\")")
       (:get-path (lambda (master file)
                    (filesets-which-file master file load-path))))))
    ("^\\([A-ZÄÖÜ][a-zäöü]+\\([A-ZÄÖÜ][a-zäöü]+\\)+\\)$" t
     (((:pattern "\\<\\([A-ZÄÖÜ][a-zäöü]+\\([A-ZÄÖÜ][a-zäöü]+\\)+\\)\\>")
       (:scan-depth 5)
       (:case-sensitive t)
       (:get-path (lambda (master file)
                    (filesets-which-file master
                                         file
                                         (if (boundp 'emacs-wiki-directories)
                                             emacs-wiki-directories
                                           nil))))))))

  "Parsing of document trees. A valid entry has the form (FILE-PATTERN
REMOVE-DUPLICATESP . CMD-DEF1 ...), CMD-DEF1 being a plist containing
the fields :pattern (mandatory), :name, :get-path, :match-number,
:scan-depth, :preprocess, :case-sensitive.

File Pattern ... A regexp matching the file's name for which the
following rules should be applied.

Remove Duplicates ... If t, only the first occurence of a subdocument
is retained.

:name STRING ... This pattern's name.

:pattern REGEXP ... A regexp matching the command. This regexp has to
include a group that holds the name of the subdocument.

:get-path FUNCTION/2 (default: `filesets-which-file') ... A function
that takes two arguments (the path of the master document and the name
of the subdocument) and returns a valid path or nil -- if the
subdocument can't be found.

:match-number INTEGER (default: 1) ... The number of the match/group
in the pattern holding the subdocument's name. 0 refers the whole
match, 1 to the first group.

:scan-depth INTEGER (default: 0) ... Whether subdocuments should be
scanned. Set this to 0 to disable.

:preprocess FUNCTION/0 ... A function modifying a buffer holding the
master document so that pattern matching becomes easier. This is
usually used to narrow a buffer to the relevant region. This function
could also be destructive and simply delete non-relevant text.

:case-sensitive BOOLEAN (default: nil) ... Whether a pattern is
case-sensitive or not."

  :type
  '(repeat
    :tag "Subdocument"
    (list
     :tag "Definition"
     (regexp :tag "File Pattern" :value "^.+\\.suffix$")
     (boolean :tag "Remove Duplicates" :value t)
     (repeat :tag "Commands"
             (repeat :tag "Command"
                     (choice
                      :tag "Definition"
                      (list :tag ":name"
                            (const :tag ":name" :value :name)
                            (string :tag "Name" :value ""))
                      (list :tag ":pattern"
                            (const :tag ":pattern" :value :pattern)
                            (regexp :tag "RegExp"
                                    :value "\\<CMD\\W*\\(.+\\)\\>"))
                      (list :tag ":get-path"
                            (const :tag ":get-path" :value :get-path)
                            (function :tag "Function" :value nil))
                      (list :tag ":match-number"
                            (const :tag ":match-number" :value :match-number)
                            (integer :tag "Integer" :value 1))
                      (list :tag ":scan-depth"
                            (const :tag ":scan-depth" :value :scan-depth)
                            (integer :tag "Integer" :value 0))
                      (list :tag ":case-sensitive"
                            (const :tag ":case-sensitive"
                                   :value :case-sensitive)
                            (integer :tag "Boolean" :value nil))
                      (list :tag ":preprocess"
                            (const :tag ":preprocess" :value :preprocess)
                            (function :tag "Function" :value nil)))))))
  :group 'filesets)


(defcustom filesets-data nil

  "List of (NAME-AS-STRING . DEFINITION), DEFINITION being a alist
with the fields ((:files . LIST-OF-FILES-AS-STRING) (:pattern PATTERN)
(:tree ROOT-DIR PATTERN) (:document FILE-PATH) (:open OPEN-FUNCTION)
(:save SAVE-FUNCTION)).

Either :files, :pattern, :tree, or :document must be supplied. :files
overrules :tree, :tree overrules :pattern, :pattern overrules
:document, i.e. these tags are mutually exclusive. The fields :open
and :save are optional.

In conjunction with the :tree tag, :save is void. :open refers to the
function used for opening files in a directory, not for opening the
directory. For browsing directories, `filesets-browse-dir-fn' is used.

PATTERN is a regular expression usually consisting of 'PATH/^REGEXP$'.

Before using :document, make sure that the file type is already
defined in `filesets-subdocument-pattern'.

Caveat: Fileset names have to be unique."
  :group 'filesets
  :type
  '(repeat
    (cons :tag "Fileset"
          (string :tag "Name" :value "")
          (repeat :tag "Data"
                  (choice
                   :tag "Type" :value nil
                   (list :tag "Pattern"
                         (const :tag ":pattern" :value :pattern)
                         (regexp :tag "Pattern" :value "~/^.+\\.suffix$"))
                   (cons :tag "Files"
                         (const :tag ":files" :value :files)
                         (repeat :tag "Files" file))
                   (list :tag "Document Tree"
                         (const :tag ":document" :value :document)
                         (file :tag "Path" :value "~/"))
                   (list :tag "Directory Tree"
                         (const :tag "dir" :value :tree)
                         (directory :tag "Dir" :value "~/")
                         (regexp :tag "Pattern" :value "^.+\\.suffix$"))
                   (list :tag "Save function"
                         (const :tag ":save"    :value :save)
                         (function :tag "Function" :value nil))
                   (list :tag "Open function"
                         (const :tag ":open"    :value :open)
                         (function :tag "Function" :value nil)))))))

(defvar filesets-menu-cache nil)
;;; (setq filesets-menu-cache nil)
(defvar filesets-document--cache nil)
(defvar filesets-document--paths nil)
;;; (setq filesets-document--cache nil)

(defvar filesets-has-changed-p t)
(defvar filesets-submenus nil)
(defvar filesets-updated-buffers nil)


;;; GNU Emacs compatibility
(eval-and-compile
  (defvar running-xemacs (string-match "XEmacs\\|Lucid" emacs-version)))

(eval-and-compile
  (if running-xemacs
      (progn
        (defun filesets-add-submenu (menu-path menu &optional before in-menu)
          (add-submenu menu-path menu before in-menu))
        (defun filesets-directory-files (dir &optional
                                             full match nosort files-only)
          (directory-files dir full match nosort files-only)))
    (progn
      (require 'easymenu)
      (cond
        ;; This should work for 21.1 GNU Emacs
       ((fboundp 'easy-menu-define)
        (defun filesets-add-submenu (menu-path submenu &optional
                                               before in-menu)
          (easy-menu-define
           filesets-submenu global-map "Filesets menu" submenu)))
       ((fboundp 'easy-menu-create-keymaps)
        ;; This is based on a proposal kindly made by Christoph Conrad.
        ;; This is untested. I don't know if it works.
        (defun filesets-add-submenu (menu-path submenu &optional
                                               before in-menu)
          (define-key
            global-map
            [menu-bar filesets]
            (cons "Filesets"
                  (easy-menu-create-keymaps "Filesets" (cdr submenu))))))
       (t
        (message "Filesets: I don't know how to build menus with your emacs.
Sorry.")))
      (defun filesets-directory-files (dir &optional
                                           full match nosort files-only)
        (let* ((this-dir (file-name-as-directory dir))
               (files (directory-files this-dir full match nosort)))
          (if files-only
              (filesets-filter-list files
                                    (lambda (x)
                                      (not (file-directory-p
                                            (concat this-dir x)))))
            files))))))


;;; helper
(defmacro filesets-testing (feature messagep &rest body)
  (cond
   ((equal filesets-version "testing")
    `(progn ,@body))
   (messagep
    (message "Filestats: feature '%s' is disabled." feature)
    nil)
   (t
    nil)))

(defun filesets-get-shortcut (n)
  (let ((n (mod (- n 1) 51)))
    (cond
     ((not filesets-create-menu-shortcuts-p)
      "")
     ((<= n 9)
      (concat (number-to-string n) " "))
     ((<= n 35)
      (format "%c " (+ 87 n)))
     ((<= n 51)
      (format "%c " (+ -3 n))))))

(defun filesets-files-equalp (a b)
  (equal (expand-file-name a) (expand-file-name b)))

(defun filesets-convert-path-list (str)
  (if str
      (mapcar (lambda (x) (file-name-as-directory x))
              (split-string str path-separator))
    nil))

(defun filesets-which-file (master filename &optional path-list)
  (let* ((f (concat (file-name-directory master) filename)))
    (if (file-exists-p f)
        f
      (some (lambda (dir)
              (let ((dir (file-name-as-directory dir))
                    (files (if (file-exists-p dir)
                               (filesets-directory-files dir nil nil nil t)
                             nil)))
                (some (lambda (file)
                        (if (equal filename (file-name-nondirectory file))
                            (concat dir file)
                          nil))
                      files)))
            path-list))))

(defun filesets-get-external-viewer (file)
  (let* ((filename (file-name-nondirectory file))
         (entry    (member* filename filesets-external-viewers
                            :test (lambda (fn vd)
                                    (string-match (car vd) fn)))))
    (if entry
        (car entry)
      nil)))

(defun filesets-spawn-external-viewer (file &optional ev-entry)
  (let* ((file     (expand-file-name file))
         (entry    (or ev-entry
                       (filesets-get-external-viewer file))))
    (if entry
        (let ((vwr  (cadr entry)))
          (if (symbolp vwr)
              (funcall vwr file)
            (let ((args (if (<= (length entry) 2)
                            file
                          (concat (caddr entry) file))))
              (with-temp-buffer
                (start-process (concat "Filesets:" vwr)
                               "*Filesets external viewer*"
                               vwr args)))))
      (message "Filesets: general confusion"))))

(defun filesets-filter-list (lst cond-fn)
  (remove* 'dummy lst :test (lambda (dummy elt)
                              (not (funcall cond-fn elt)))))

(defun filesets-find-file (file)
  (sleep-for filesets-find-file-delay)
  (find-file file))

(defun filesets-find-or-display-file (file)
  (let ((external-viewer-def (filesets-get-external-viewer file)))
        ;(message "DBG viewer %s" external-viewer-def)
    (if external-viewer-def
        (filesets-spawn-external-viewer file external-viewer-def)
      (filesets-find-file file))))

(defun filesets-data-get-name (entry)
  (car entry))

(defun filesets-data-get-data (entry)
  (cdr entry))

(defun filesets-alist-get (alist key &optional default carp)
  (let* ((elt (assoc key alist)))
    (cond
     (elt
      (if carp
          (cadr elt)
        (cdr elt)))
     (default default)
     (t nil))))

(defun filesets-data-get (entry key &optional default carp)
  (filesets-alist-get (filesets-data-get-data entry) key default carp))

(defun filesets-data-set (entry key value)
  (let* ((alist (filesets-data-get-data entry))
         (elt (assoc key alist)))
    (if elt
        (setcdr elt value)
      (setcdr entry (cons (cons key value) alist)))))

(defun filesets-data-remove (entry key)
  (let ((alist (filesets-data-get-data entry)))
    (setcdr entry (remassoc key alist))))

(defun filesets-entry-mode (entry)
  (let ((data (filesets-data-get-data entry)))
    (some (lambda (x)
            (if (assoc x data)
                x))
          '(:files :tree :pattern :document))))

(defun filesets-entry-get-open-fn (entry &optional this-mode)
  (filesets-data-get entry ':open
                     (case (or this-mode
                               (filesets-entry-mode entry))
                       ((:files :pattern :document)
                        filesets-open-file-fn)
                       ((:tree)
                        filesets-browse-dir-fn))
                     t))

(defun filesets-entry-get-save-fn (entry)
  (filesets-data-get entry ':save filesets-save-buffer-fn t))

(defun filesets-entry-get-files (entry)
  (filesets-data-get entry ':files))

(defun filesets-entry-set-files (entry data &optional anyways)
  (let ((files (filesets-entry-get-files entry)))
    (if (or anyways files)
        (filesets-data-set entry ':files data))))

(defun filesets-entry-get-pattern (entry)
  (filesets-data-get entry ':pattern nil t))

(defun filesets-entry-get-tree (entry)
  (filesets-data-get entry ':tree))

(defun filesets-entry-get-master (entry)
  (filesets-data-get entry ':document nil t))

(defun filesets-entry-set-pattern (entry data &optional anyways key)
  (let ((pattern (filesets-entry-get-pattern entry)))
    (if (or anyways pattern)
        (if key
            (filesets-data-set entry key (list data))
          (filesets-data-set entry ':pattern (list data))))))

(defun filesets-file-open (fn path)
  (if (file-readable-p path)
      (funcall fn path)
    (message "Filesets: Couldn't open '%s'" path)))

(defun filesets-file-save (fn buffer)
  (save-excursion
    (set-buffer buffer)
    (funcall fn)
        (if (not (buffer-modified-p))
            (kill-buffer buffer))))

(defun filesets-get-fileset-from-name (name &optional mode)
  (or (and (equal mode ':document) name)
      (assoc name filesets-data)))


;;; config file
(defun filesets-save-config ()
  (interactive)
  (customize-save-customized))

(defun filesets-reset-fileset (fileset)
  (setq filesets-submenus
        (plist-put filesets-submenus fileset nil))
  (setq filesets-has-changed-p t))

(defun filesets-set-config (fileset var val)
  (customize-set-variable var val)
  (filesets-reset-fileset fileset))
;  (filesets-build-menu))


;;; body
(defun filesets-get-filelist (entry &optional mode)
  (let ((mode (or mode
                           (filesets-entry-mode entry))))
    (case mode
         ((:files)
          (filesets-entry-get-files entry))
         ((:document)
          (cons entry
                (plist-get filesets-document--cache entry)))
         ((:pattern)
          (let ((dirpatt (filesets-entry-get-pattern entry)))
            (if dirpatt
                   (let ((dir (file-name-directory dirpatt))
                            (patt (file-name-nondirectory dirpatt)))
                        ;(message "Filesets: scanning %s" dirpatt)
                        (mapcar (lambda (x) (concat dir x))
                                   (filesets-directory-files
                                    dir nil patt nil t)))
                 (message "Filesets: malformed entry: %s" entry)))))))

(defun filesets-open (mode name &optional this-fn)
  "Open the fileset NAME. Use this-fn, if provided, for opening files."
  (interactive)
  (let ((fileset (filesets-get-fileset-from-name name mode)))
    (if fileset
        (let ((fn (or this-fn
                      (filesets-entry-get-open-fn fileset mode)))
              (files (filesets-get-filelist fileset mode)))
          (map nil (lambda (x) (filesets-file-open fn x)) files))
      (message "Filesets: Unknown fileset: '%s'" name))))

(defun filesets-close (mode name &optional this-fn)
  "Close all buffers belonging to fileset NAME."
  (interactive)
  (let ((fileset (filesets-get-fileset-from-name name mode)))
    (if fileset
        (let ((fn (or this-fn
                      (filesets-entry-get-save-fn fileset)))
              (files (filesets-get-filelist fileset mode)))
          (map nil (lambda (path)
                     (let* ((buffer (get-file-buffer path)))
                       (if buffer
                           (filesets-file-save fn buffer))))
               files))
      (message "Filesets: Unknown fileset: '%s'" name))))

(defun filesets-add-buffer (&optional name buffer)
  (interactive)
  (let* ((buffer (or buffer
                     (current-buffer)))
         (name   (or name
                     (completing-read
                      (format "Add '%s' to fileset: " buffer)
                      filesets-data)))
         (entry  (assoc name filesets-data)))
    (if entry
        (let ((files (filesets-entry-get-files entry))
              (this  (buffer-file-name buffer)))
          (if (and files this)
              (progn
                (filesets-entry-set-files entry (cons this files))
                (filesets-set-config name 'filesets-data filesets-data))
            (message "Filesets: Can't add '%s' to fileset '%s'"
                     this
                     name))))))

(defun filesets-remove-buffer (&optional name buffer)
  (interactive)
  (let* ((buffer (or buffer
                     (current-buffer)))
         (name   (or name
                     (completing-read
                      (format "Remove '%s' from fileset: " buffer)
                      filesets-data)))
                 (entry (assoc name filesets-data)))
    (if entry
        (let* ((files  (filesets-entry-get-files entry))
               (this   (buffer-file-name buffer))
               (inlist (member* this files :test 'filesets-files-equalp)))
          (if (and files this inlist)
              (let ((new (list (cons ':files (delete (car inlist) files)))))
                (setcdr entry new)
                (filesets-set-config name 'filesets-data filesets-data))
            (message "Filesets: Can't remove '%s' from fileset '%s'"
                     this
                     name))))))

(defun filesets-convert-patterns (name)
  (interactive)
  (let ((entry (assoc name filesets-data)))
    (if entry
        (let ((pattern  (filesets-entry-get-pattern entry))
              (patfiles (filesets-get-filelist entry ':pattern)))
          (if pattern
              (progn
                (filesets-entry-set-files entry patfiles t)
                (filesets-set-config name 'filesets-data filesets-data)))))))

(defun filesets-edit ()
  (interactive)
  (customize-variable 'filesets-data))

(defun filesets-customize ()
  (interactive)
  (customize-group 'filesets))

(defun filesets-info ()
  (interactive)
  (message "Filesets %s, by Thomas Link <address@hidden>"
           filesets-version))

(defun filesets-makeup-submenu (submenu-body)
  (let ((bl   (length submenu-body)))
    (if (or (= filesets-max-submenu-length 0)
            (<= bl filesets-max-submenu-length))
        submenu-body
      (let* ((result  nil)
             (factor (ceiling (/ (float bl)
                                 filesets-max-submenu-length))))
        (do ((data  submenu-body (cdr data))
             (n     1            (+ n 1))
             (count 0            (+ count factor)))
            ((or (> count bl)
                 (null data)))
          (let ((sl (subseq submenu-body count
                            (let ((x (+ count factor)))
                              (if (>= bl x)
                                  x
                                nil)))))
            (when sl
              (setq result
                    (append
                     result
                     (if (= (length sl) 1)
                         sl
                       `((,(format
                            "%s %s"
                            (filesets-get-shortcut n)
                            (let ((rv ""))
                              (do ((x sl (cdr x)))
                                  ((null x))
                                (let ((y (concat (elt (car x) 0)
                                                 (if (null (cdr x))
                                                     ""
                                                   ", "))))
                                  (setq rv 
                                        (concat
                                         rv
                                         (if filesets-create-menu-shortcuts-p
                                             (substring y 2)
                                           y)))))
                              (if (> (length rv)
                                     filesets-max-entry-length)
                                  (concat
                                   (substring rv 0 filesets-max-entry-length)
                                   " ...")
                                rv)))
                          ,@sl))))))))
        result))))

(defun filesets-get-menu-entry (name &optional mode save-function rebuild)
  (case mode
    ((:tree)
     (when rebuild
       `("---"
         ["Rebuild this submenu"
          ,(list (function filesets-rebuild-this-submenu) rebuild)])))
    ((:document)
     `("---"
       [,(concat "Close all files")
        ,(list (function filesets-close) mode name `(quote ,save-function))]
       ,@(when rebuild
           `(["Rebuild this submenu"
              ,(list (function filesets-rebuild-this-submenu) rebuild)]))))
    ((:pattern)
     `("---"
       [,(concat "Close all files")
        ,(list (function filesets-close) mode name)]
       ["Con%_vert :pattern to :files"
        ,(list (function filesets-convert-patterns) name)]
       ,@(when rebuild
           `(["Rebuild this submenu"
              ,(list (function filesets-rebuild-this-submenu) rebuild)]))))
    ((:files)
     `("---"
       [,(concat "Close all files")
        ,(list (function filesets-close) mode name)]
       ["Add current buffer"
        ,(list (function filesets-add-buffer) name '(current-buffer))]
       ["Remove current buffer"
        ,(list (function filesets-remove-buffer) name '(current-buffer))]
       ,@(when rebuild
           `(["Rebuild this submenu"
              ,(list (function filesets-rebuild-this-submenu) rebuild)]))))
    (t
     (message "Filesets: malformed defintion of %s" name))))

(defun filesets-document--get-data (master pos &optional fun)
  (let ((masterfile (file-name-nondirectory master))
        (fn (or fun (lambda (a b)
                      (and (stringp a)
                           (stringp b)
                           (string-match a b))))))
    (some (lambda (x)
            (if (funcall fn (car x) masterfile)
                (nth pos x)
              nil))
          filesets-subdocument-pattern)))

(defun filesets-document--patts (master)
  (filesets-document--get-data master 2))

(defun filesets-document--as-setp (master)
  (filesets-document--get-data master 1))

(defun filesets-document--searcher (patt case-sencitivep)
  (let ((cfs case-fold-search)
        (rv  (progn
               (setq case-fold-search (not case-sencitivep))
               (re-search-forward patt nil t))))
    (setq case-fold-search cfs)
    rv))

(defun filesets-document--collect (fn sfn as-setp master cmdpatts
                                      &optional depth)
  (setq filesets-document--cache
        (plist-put filesets-document--cache master nil))
  (let ((count 0))
    (mapcan
     (lambda (this-def)
       (let* ((this-name (filesets-alist-get this-def ':name "" t))
              (this-patt (filesets-alist-get this-def ':pattern nil t))
              (this-pp   (filesets-alist-get this-def ':preprocess nil t))
              (this-mn   (filesets-alist-get this-def ':match-number 1 t))
              (this-sd   (or depth
                             (filesets-alist-get this-def ':scan-depth 0 t)))
              (this-csp  (filesets-alist-get this-def ':case-sensitive nil t))
              (this-fn   (filesets-alist-get this-def
                                             ':get-path 'filesets-which-file
                                             t))
              (lst       nil))
         (if this-patt
             (with-temp-buffer
               (insert-file-contents master)
               (goto-char (point-min))
               (if this-pp
                   (funcall this-pp))
               (while (filesets-document--searcher this-patt this-csp)
                 (let* ((txt (match-string this-mn))
                        (f   (funcall this-fn master txt)))
                   (when (and f
                              (or (not as-setp)
                                  (not (member* f filesets-document--paths
                                                :test
                                                'filesets-files-equalp))))
                     (setq count (+ count 1))
                     (setq filesets-document--paths
                           (cons f filesets-document--paths))
                     (setq filesets-document--cache
                           (plist-put filesets-document--cache
                                      master
                                      (cons f
                                            (plist-get filesets-document--cache
                                                       master))))
                     (setq lst
                           (let* ((nm (concat (filesets-get-shortcut count)
                                              this-name
                                              (if (equal this-name "")
                                                  "" ": ")
                                              txt))
                                  (single `([,nm ,(list fn f)])))
                             (if (> this-sd 0)
                                 (let ((other (filesets-document--collect
                                               fn sfn
                                               as-setp
                                               f
                                               (filesets-document--patts f)
                                               (- this-sd 1))))
                                   (if (not other)
                                       (append lst single)
                                     (append lst
                                             `((,nm
                                                [,(concat "Document: " txt)
                                                 ,(list (function 
                                                         filesets-open)
                                                        ':document
                                                        f
                                                        `(quote ,fn))]
                                                "---"
                                                [,f ,(list fn f)]
                                                "---"
                                                ,@other
                                                ,@(filesets-get-menu-entry
                                                   f ':document sfn))))))
                               (append lst single))))))))
           (message "Filesets: malformed document definition: %s" this-def))
         lst))
     cmdpatts)))

(defun filesets-build-document-submenu (master fn sfn)
  (let ((cmdpatts (filesets-document--patts master)))
    (if (and cmdpatts
             (file-readable-p master))
        (let ((as-setp  (filesets-document--as-setp master)))
          (setq filesets-document--paths (list master))
          (filesets-document--collect fn sfn as-setp master cmdpatts))
      (progn
        (message "Filesets: can't parse %s" master)
        nil))))

(defun filesets-build-dir-submenu-now (level entry fn desc dir patt
                                             &optional rebuild)
  ;(message "Filesets: scanning %s" dir)
  (if (or (= filesets-tree-max-level 0)
          (< level filesets-tree-max-level))
      (let* ((dir       (file-name-as-directory dir))
             (header    `[,(concat "Tree: "
                                   (if (= level 0)
                                       dir
                                     (concat ".../"
                                             (file-name-as-directory
                                              (file-name-nondirectory
                                               (directory-file-name dir))))))
                          ,(list filesets-browse-dir-fn dir)])
             (open-fn   (filesets-entry-get-open-fn entry ':files))
             (dirlist   (filesets-directory-files dir))
             (subdirs   (filesets-filter-list dirlist
                                              (lambda (x)
                                                (and (file-directory-p
                                                      (concat dir x))
                                                     (not (equal x "."))
                                                     (not (equal x ".."))))))
             (count     0)
             (dirsmenu  (mapcar
                         (lambda (x)
                           (setq count (+ count 1))
                           (let* ((x  (file-name-as-directory x))
                                  (xx (concat dir x))
                                  (dd (filesets-build-dir-submenu-now
                                       (+ level 1) entry fn desc xx patt))
                                  (nm (concat (filesets-get-shortcut count)
                                              x)))
                             (if dd
                                 `(,nm ,@dd)
                               `[,nm ,(list filesets-browse-dir-fn xx)])))
                         subdirs))
             (files     (filesets-directory-files dir nil patt nil t))
             (filesmenu (mapcar (lambda (x)
                                  (setq count (+ count 1))
                                  `[,(concat (filesets-get-shortcut count)
                                             x)
                                    ,(list open-fn (concat dir x))])
                                files)))
        (append
         (list header "---")
         (filesets-makeup-submenu
          (append
           dirsmenu
           filesmenu))
         (when rebuild
           (filesets-get-menu-entry dirsmenu ':tree nil desc))))
    nil))

(defun filesets-build-dir-submenu (entry fn desc dir patt)
  (filesets-build-dir-submenu-now 0 entry fn desc dir patt t))

(defun filesets-build-submenu (desc count entry)
  (message "Filesets: %s" desc)
  (let ((mode (filesets-entry-mode entry)))
    `(,(concat (filesets-get-shortcut count) desc)
      ,@(case mode
          ((:pattern)
           (let ((files   (filesets-get-filelist entry mode))
                 (dirpatt (filesets-entry-get-pattern entry))
                 (fn      (filesets-entry-get-open-fn entry mode))
                 (count   0))
             `([,(concat "Pattern: " dirpatt)
                ,(list (function filesets-open) mode desc)]
               "---"
               ,@(filesets-makeup-submenu
                  (mapcar
                   (lambda (x)
                     (setq count (+ count 1))
                     `[,(concat (filesets-get-shortcut count)
                                (file-name-nondirectory x))
                       ,(list fn x)])
                   files))
               ,@(filesets-get-menu-entry desc mode nil desc))))
          ((:document)
           (let* ((master (filesets-entry-get-master entry))
                  (fn (filesets-entry-get-open-fn entry mode))
                  (sfn (filesets-entry-get-save-fn entry)))
             `([,(concat "Document: " (file-name-nondirectory master))
                ,(list (function filesets-open) mode master
                       `(quote ,fn))]
               "---"
               [,master ,(list fn master)]
               "---"
               ,@(filesets-makeup-submenu
                  (filesets-build-document-submenu master fn sfn))
               ,@(filesets-get-menu-entry master mode sfn desc))))
          ((:tree)
           (let* ((dirpatt (filesets-entry-get-tree entry))
                  (fn      (filesets-entry-get-open-fn entry mode))
                  (dir     (car dirpatt))
                  (patt    (cadr dirpatt)))
             (filesets-build-dir-submenu entry fn desc dir patt)))
          ((:files)
           (let ((files (filesets-get-filelist entry mode))
                 (fn    (filesets-entry-get-open-fn entry mode))
                 (count 0))
             `([,(concat "Files: " desc)
                ,(list (function filesets-open) mode desc)]
               "---"
               ,@(filesets-makeup-submenu
                  (mapcar
                   (lambda (x)
                     (setq count (+ count 1))
                     `[,(concat (filesets-get-shortcut count)
                                (file-name-nondirectory x))
                       ,(list fn x)])
                   files))
               ,@(filesets-get-menu-entry desc mode nil desc))))))))

(defun filesets-remove-from-ubl (&optional buffer)
  (let ((b (or buffer
               (current-buffer))))
    (if (member b filesets-updated-buffers)
        (setq filesets-updated-buffers
              (delete b filesets-updated-buffers)))))

(defun filesets-build-menu-now (from-scratchp)
  (when (or from-scratchp
            filesets-has-changed-p
            (not filesets-menu-cache))
    (setq filesets-menu-cache nil)
    (do ((data  (if filesets-sort-menup
                    (sort (copy-list filesets-data)
                          (lambda (a b)
                            (string< (car a) (car b))))
                  filesets-data)
                (cdr data))
         (count 1 (+ count 1)))
        ((null data))
      (let* ((this    (car data))
             (name    (filesets-data-get-name this))
             (cached  (plist-get filesets-submenus name))
             (submenu (or cached
                          (filesets-build-submenu name count (car data)))))
        (unless cached
          (setq filesets-submenus
                (plist-put filesets-submenus name submenu)))
        (setq filesets-menu-cache
              (append filesets-menu-cache (list submenu)))))
    (setq filesets-has-changed-p nil)
    (setq filesets-updated-buffers nil))
  (let ((cb (current-buffer)))
    (when (not (member cb filesets-updated-buffers))
      (filesets-add-submenu
       filesets-menu-path
       `(,filesets-menu-name
         ("# Filesets"
          ["Edit Filesets"  filesets-edit]
          ["Save Filesets"  filesets-save-config]
          ["Rebuild Menu"   filesets-build-menu]
          ["Customize"      filesets-customize]
          ["Info"           filesets-info])
         "---"
         ,@filesets-menu-cache)
       filesets-menu-before
       filesets-menu-in-menu)
      (setq filesets-updated-buffers
            (cons cb filesets-updated-buffers))
      (message nil)
      ;(message "Filesets updated: %s" cb)
      )))

(defun filesets-build-menu-maybe ()
  (interactive)
  (filesets-build-menu-now nil))

(defun filesets-build-menu ()
  (interactive)
  (setq filesets-submenus nil)
  (filesets-build-menu-now t))

(defun filesets-rebuild-this-submenu (fileset)
  (filesets-reset-fileset fileset)
  (filesets-build-menu-now t))

;;; Example data:
; (setq filesets-data
;       '(("Stacker" (:pattern
"~/Projekte/Comp/2001/Stacker-0108a/^.+\\.ml$"))
;               ("Test1" (:files "~/tmp/1" "~/tmp/2"))
;               ("Test2" (:tree "~/tmp/" "^[0-9]+$"))))

;;; run
(filesets-build-menu)

(eval-and-compile
  (if running-xemacs
      (add-hook 'activate-menubar-hook 'filesets-build-menu-maybe)
    (add-hook 'menu-bar-update-hook 'filesets-build-menu-maybe)))

(add-hook 'kill-buffer-hook (function filesets-remove-from-ubl))


(provide 'filesets)

;;; FILESETS.EL ends here