|
0
|
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
|
|
30
|
38 ;;; it is necessary, if you've a big directory tree.
|
|
0
|
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)
|
