home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / utils / tree-menu.el.z / tree-menu.el
Encoding:
Text File  |  1998-05-21  |  6.2 KB  |  200 lines
  1. ;;; tree-menu.el
  2. ;;; v1.20; 10-May-1994
  3. ;;; Copyright (C) 1994 Heiko Muenkel
  4. ;;; email: muenkel@tnt.uni-hannover.de
  5. ;;;
  6. ;;;  This program is free software; you can redistribute it and/or modify
  7. ;;;  it under the terms of the GNU General Public License as published by
  8. ;;;  the Free Software Foundation; either version 1, or (at your option)
  9. ;;;  any later version.
  10. ;;;
  11. ;;;  This program is distributed in the hope that it will be useful,
  12. ;;;  but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;;;  GNU General Public License for more details.
  15. ;;;
  16. ;;;  You should have received a copy of the GNU General Public License
  17. ;;;  along with this program; if not, write to the Free Software
  18. ;;;  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  19. ;;;
  20. ;;; Synched up with: Not in FSF.
  21. ;;; 
  22. ;;; Description:
  23. ;;;
  24. ;;;    Provides the functions `tree-make-file-list' and `tree-make-menu'.
  25. ;;;    With these functions it is possible to generate file browsing menus,
  26. ;;;     where each menu-item calls the same function, but on different files.
  27. ;;;    Example: 
  28. ;;;         (popup-menu (cons "Open File"
  29. ;;;                        (tree-make-menu (tree-make-file-list "~/")
  30. ;;;                            'find-file
  31. ;;;                            t
  32. ;;;                            t
  33. ;;;                            '("\\..*"))))
  34. ;;;
  35. ;;;    Note: This function is very time consuming ! Therefore you should
  36. ;;;          call `tree-make-file-list' once and make several menus
  37. ;;;          from the same list. And you should only rebuild the menu if 
  38. ;;;          it is necessary, if you've a big directory tree.
  39. ;;;
  40. ;;; Installation: 
  41. ;;;   
  42. ;;;    Put this file in one of your lisp load directories.
  43. ;;;
  44. ;;;  Changed 18-May-1995, Kyle Jones
  45. ;;;    Removed the need for the utils.el package and references thereto.
  46. ;;;    Changed file-truename calls to tree-menu-file-truename so
  47. ;;;    the calls could be made compatible with FSF Emacs 19's
  48. ;;;    file-truename function.
  49.  
  50. (defvar tree-ls-flags "-AFLR" 
  51.   "*A String with the flags used in the function tree-ls-in-temp-buffer 
  52. for the ls command. Be careful if you want to change this variable. 
  53. The ls command must append a / on all files which are directories. 
  54. The original flags are -AFLR.")
  55.  
  56.  
  57. (defun tree-ls-in-temp-buffer (dir temp-buffer)
  58. "List the directory DIR in the TEMP-BUFFER."
  59.   (switch-to-buffer temp-buffer)
  60.   (erase-buffer)
  61.   (call-process "ls" nil temp-buffer nil tree-ls-flags dir)
  62.   (goto-char (point-min))
  63.   (while (search-forward "//" nil t)
  64.     (replace-match "/"))
  65.   (goto-char (point-min)))
  66.  
  67.  
  68. (defvar tree-temp-buffername "*tree*"
  69.   "Name of the temp buffers in tree.")
  70.  
  71.  
  72. (defun tree-make-file-list-1 (root list)
  73.   (let ((filename (buffer-substring (point) (progn
  74.                           (end-of-line)
  75.                           (point)))))
  76.     (while (not (string= filename ""))
  77.       (setq 
  78.        list 
  79.        (append
  80.     list
  81.     (list
  82.      (cond ((char-equal (char-after (- (point) 1)) ?/)
  83.         ;; Directory
  84.         (setq filename (substring filename 0 (1- (length filename))))
  85.         (save-excursion
  86.           (search-forward (concat root filename ":"))
  87.           (forward-line)
  88.           (tree-make-file-list-1 (concat root filename "/")
  89.                         (list (tree-menu-file-truename 
  90.                                filename
  91.                                root)))))
  92.            ((char-equal (char-after (- (point) 1)) ?*)
  93.         ;; Executable
  94.         (setq filename (substring filename 0 (1- (length filename))))
  95.         (tree-menu-file-truename filename root))
  96.            (t (tree-menu-file-truename filename root))))))
  97.       (forward-line)
  98.       (setq filename (buffer-substring (point) (progn
  99.                          (end-of-line)
  100.                          (point)))))
  101.     list))
  102.  
  103.  
  104. (defun tree-menu-file-truename (file &optional root)
  105.   (file-truename (expand-file-name file root)))
  106.  
  107. (defun tree-make-file-list (dir)
  108.   "Makes a list with the files and subdirectories of DIR.
  109. The list looks like: ((dirname1 file1 file2) 
  110.                       file3
  111.                       (dirname2 (dirname3 file4 file5) file6))"
  112.   (save-window-excursion
  113.     (setq dir (expand-file-name dir))
  114.     (if (not (string= (substring dir -1) "/"))
  115.     (setq dir (concat dir "/")))
  116. ;;    (while (string-match "/$" dir)
  117. ;;      (setq dir (substring dir 0 -1)))
  118.     (tree-ls-in-temp-buffer dir
  119.                  (generate-new-buffer-name 
  120.                   tree-temp-buffername))
  121.     (let ((list nil))
  122.       (setq list (tree-make-file-list-1 dir nil))
  123.       (kill-buffer (current-buffer))
  124.       list)))
  125.  
  126.  
  127. (defun tree-hide-file-p (filename re-hidden-file-list)
  128.   "t, if one of the regexps in RE-HIDDEN-FILE-LIST matches the FILENAME."
  129.   (cond ((not re-hidden-file-list) nil)
  130.     ((string-match (car re-hidden-file-list) 
  131.                (tree-menu-file-truename filename)))
  132.     (t (tree-hide-file-p filename (cdr re-hidden-file-list)))))
  133.  
  134.  
  135. (defun tree-make-menu (dirlist 
  136.                function 
  137.                selectable 
  138.                &optional 
  139.                no-hidden-dirs
  140.                re-hidden-file-list
  141.                include-current-dir)
  142.   "Returns a menu list.
  143. Each item of the menu list has the form 
  144.  [\"subdir\" (FUNCTION \"dir\") SELECTABLE].
  145. Hidden directories (with a leading point) are suppressed, 
  146. if NO-HIDDEN-DIRS are non nil. Also all files which are
  147. matching a regexp in RE-HIDDEN-FILE-LIST are suppressed.
  148. If INCLUDE-CURRENT-DIR non nil, then an additional command
  149. for the current directory (.) is inserted."
  150.   (let ((subdir nil)
  151.     (menulist nil))
  152.     (while (setq subdir (car dirlist))
  153.       (setq dirlist (cdr dirlist))
  154.       (cond ((and (stringp subdir)
  155.           (not (tree-hide-file-p subdir re-hidden-file-list)))
  156.          (setq menulist
  157.            (append menulist
  158.                (list
  159.                 (vector (file-name-nondirectory subdir)
  160.                     (list function subdir)
  161.                     selectable)))))
  162.         ((and (listp subdir)
  163.           (or (not no-hidden-dirs)
  164.               (not (char-equal 
  165.                 ?.
  166.                 (string-to-char 
  167.                  (file-name-nondirectory (car subdir))))))
  168.           (setq menulist
  169.             (append 
  170.              menulist
  171.              (list
  172.               (cons (file-name-nondirectory (car subdir))
  173.                 (if include-current-dir
  174.                     (cons
  175.                      (vector "."
  176.                          (list function
  177.                            (car subdir))
  178.                          selectable)
  179.                      (tree-make-menu (cdr subdir)
  180.                              function
  181.                              selectable
  182.                              no-hidden-dirs
  183.                              re-hidden-file-list
  184.                              include-current-dir
  185.                              ))
  186.                   (tree-make-menu (cdr subdir)
  187.                           function
  188.                           selectable
  189.                           no-hidden-dirs
  190.                           re-hidden-file-list
  191.                           ))))))))
  192.         (t nil))
  193.       )
  194.     menulist
  195.     )
  196.   )
  197.  
  198.  
  199. (provide 'tree-menu)
  200.