Mercurial > hg > xemacs-beta
comparison lisp/utils/tree-menu.el @ 0:376386a54a3c r19-14
Import from CVS: tag r19-14
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 08:45:50 +0200 |
| parents | |
| children | ec9a17fef872 |
comparison
equal
deleted
inserted
replaced
| -1:000000000000 | 0:376386a54a3c |
|---|---|
| 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 neccessary, 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) |