[Top][All Lists]

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

Filesets 1.3

From: Thomas Link
Subject: Filesets 1.3
Date: Sun, 11 Nov 2001 17:44:29 +0100

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.



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

;; Copyright (C) 2001 Thomas Link

;; Author: Thomas Link <address@hidden>
;; URL:
;; 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
;; 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

;;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"
  '(repeat :tag "Viewer"
           (list :tag "Definition"
                 (regexp :tag "Pattern" :value "^.+\\.suffix$")
                  :tag "Viewer"
                  (symbol :tag "Function" :value nil)
                  (string :tag "Program" :value ""))))
  :group 'filesets)

(defcustom filesets-subdocument-pattern
  '(("^.+\\.tex$" t
     (((:name "Package")
       (:match-number 2)
       (:get-path (lambda (master file)
                    (filesets-which-file master
                                         (concat file ".sty")
                                          (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")
                                          (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")
                                          (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")
                                          (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")
      ((: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
                                         (if (boundp 'emacs-wiki-directories)

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

    :tag "Subdocument"
     :tag "Definition"
     (regexp :tag "File Pattern" :value "^.+\\.suffix$")
     (boolean :tag "Remove Duplicates" :value t)
     (repeat :tag "Commands"
             (repeat :tag "Command"
                      :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)

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
    (cons :tag "Fileset"
          (string :tag "Name" :value "")
          (repeat :tag "Data"
                   :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
  (defvar running-xemacs (string-match "XEmacs\\|Lucid" emacs-version)))

  (if running-xemacs
        (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)))
      (require 'easymenu)
        ;; This should work for 21.1 GNU Emacs
       ((fboundp 'easy-menu-define)
        (defun filesets-add-submenu (menu-path submenu &optional
                                               before in-menu)
           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)
            [menu-bar filesets]
            (cons "Filesets"
                  (easy-menu-create-keymaps "Filesets" (cdr submenu))))))
        (message "Filesets: I don't know how to build menus with your emacs.
      (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)))))

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

(defun filesets-get-shortcut (n)
  (let ((n (mod (- n 1) 51)))
     ((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))

(defun filesets-which-file (master filename &optional path-list)
  (let* ((f (concat (file-name-directory master) filename)))
    (if (file-exists-p 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)
                (some (lambda (file)
                        (if (equal filename (file-name-nondirectory file))
                            (concat dir file)

(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)

(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)
                          (concat (caddr entry) file))))
                (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)))
      (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)
          '(: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)

(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)
    (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 ()

(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
          (filesets-entry-get-files entry))
          (cons entry
                (plist-get filesets-document--cache entry)))
          (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))
                                    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."
  (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."
  (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))))
      (message "Filesets: Unknown fileset: '%s'" name))))

(defun filesets-add-buffer (&optional name buffer)
  (let* ((buffer (or buffer
         (name   (or name
                      (format "Add '%s' to fileset: " buffer)
         (entry  (assoc name filesets-data)))
    (if entry
        (let ((files (filesets-entry-get-files entry))
              (this  (buffer-file-name buffer)))
          (if (and files this)
                (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'"

(defun filesets-remove-buffer (&optional name buffer)
  (let* ((buffer (or buffer
         (name   (or name
                      (format "Remove '%s' from fileset: " buffer)
                 (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'"

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

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

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

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

(defun filesets-makeup-submenu (submenu-body)
  (let ((bl   (length submenu-body)))
    (if (or (= filesets-max-submenu-length 0)
            (<= bl filesets-max-submenu-length))
      (let* ((result  nil)
             (factor (ceiling (/ (float bl)
        (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)
            (when sl
              (setq result
                     (if (= (length sl) 1)
                            "%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 
                                         (if filesets-create-menu-shortcuts-p
                                             (substring y 2)
                              (if (> (length rv)
                                   (substring rv 0 filesets-max-entry-length)
                                   " ...")

(defun filesets-get-menu-entry (name &optional mode save-function rebuild)
  (case mode
     (when rebuild
         ["Rebuild this submenu"
          ,(list (function filesets-rebuild-this-submenu) rebuild)])))
       [,(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)]))))
       [,(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)]))))
       [,(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)]))))
     (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)

(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)

(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))
     (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
              (lst       nil))
         (if this-patt
               (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
                     (setq count (+ count 1))
                     (setq filesets-document--paths
                           (cons f filesets-document--paths))
                     (setq filesets-document--cache
                           (plist-put filesets-document--cache
                                      (cons f
                                            (plist-get filesets-document--cache
                     (setq lst
                           (let* ((nm (concat (filesets-get-shortcut count)
                                              (if (equal this-name "")
                                                  "" ": ")
                                  (single `([,nm ,(list fn f)])))
                             (if (> this-sd 0)
                                 (let ((other (filesets-document--collect
                                               fn sfn
                                               (filesets-document--patts f)
                                               (- this-sd 1))))
                                   (if (not other)
                                       (append lst single)
                                     (append lst
                                                [,(concat "Document: " txt)
                                                 ,(list (function 
                                                        `(quote ,fn))]
                                                [,f ,(list fn f)]
                                                   f ':document sfn))))))
                               (append lst single))))))))
           (message "Filesets: malformed document definition: %s" this-def))

(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))
        (message "Filesets: can't parse %s" master)

(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)
                                     (concat ".../"
                                               (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)
                             (if dd
                                 `(,nm ,@dd)
                               `[,nm ,(list filesets-browse-dir-fn xx)])))
             (files     (filesets-directory-files dir nil patt nil t))
             (filesmenu (mapcar (lambda (x)
                                  (setq count (+ count 1))
                                  `[,(concat (filesets-get-shortcut count)
                                    ,(list open-fn (concat dir x))])
         (list header "---")
         (when rebuild
           (filesets-get-menu-entry dirsmenu ':tree nil desc))))

(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
           (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)]
                   (lambda (x)
                     (setq count (+ count 1))
                     `[,(concat (filesets-get-shortcut count)
                                (file-name-nondirectory x))
                       ,(list fn x)])
               ,@(filesets-get-menu-entry desc mode nil desc))))
           (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-build-document-submenu master fn sfn))
               ,@(filesets-get-menu-entry master mode sfn desc))))
           (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)))
           (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)]
                   (lambda (x)
                     (setq count (+ count 1))
                     `[,(concat (filesets-get-shortcut count)
                                (file-name-nondirectory x))
                       ,(list fn x)])
               ,@(filesets-get-menu-entry desc mode nil desc))))))))

(defun filesets-remove-from-ubl (&optional buffer)
  (let ((b (or 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
            (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))))
                (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"
          ["Edit Filesets"  filesets-edit]
          ["Save Filesets"  filesets-save-config]
          ["Rebuild Menu"   filesets-build-menu]
          ["Customize"      filesets-customize]
          ["Info"           filesets-info])
      (setq filesets-updated-buffers
            (cons cb filesets-updated-buffers))
      (message nil)
      ;(message "Filesets updated: %s" cb)

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

(defun filesets-build-menu ()
  (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
;               ("Test1" (:files "~/tmp/1" "~/tmp/2"))
;               ("Test2" (:tree "~/tmp/" "^[0-9]+$"))))

;;; run

  (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

reply via email to

[Prev in Thread] Current Thread [Next in Thread]