Mercurial > hg > xemacs-beta

comparison lisp/find-paths.el @ 276:6330739388db r21-0b36

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-0b36
author cvs
date Mon, 13 Aug 2007 10:30:37 +0200
parents ca9a9ec9c1c1
children 90d73dddcdc4
comparison
equal deleted inserted replaced
275:a68ae4439f57 276:6330739388db
37 ;;; Code: 37 ;;; Code:
38 38
39 (defvar paths-version-control-bases '("RCS" "CVS" "SCCS") 39 (defvar paths-version-control-bases '("RCS" "CVS" "SCCS")
40 "File bases associated with version control.") 40 "File bases associated with version control.")
41 41
42 (defun paths-find-recursive-path (directories &optional exclude) 42 (defun paths-find-recursive-path (directories &optional max-depth exclude)
43 "Return a list of the directory hierarchy underneath DIRECTORIES. 43 "Return a list of the directory hierarchy underneath DIRECTORIES.
44 The returned list is sorted by pre-order and lexicographically." 44 The returned list is sorted by pre-order and lexicographically.
45 MAX-DEPTH limits the depth of the search to MAX-DEPTH level,
46 if it is a number. If MAX-DEPTH is NIL, the search depth is unlimited.
47 EXCLUDE is a list of directory names to exclude from the search."
45 (let ((path '())) 48 (let ((path '()))
46 (while directories 49 (while directories
47 (let ((directory (file-name-as-directory 50 (let ((directory (file-name-as-directory
48 (expand-file-name 51 (expand-file-name
49 (car directories))))) 52 (car directories)))))
50 (if (file-directory-p directory) 53 (if (file-directory-p directory)
51 (let ((raw-dirs (directory-files directory nil "^[^-.]" nil 'dirs-only)) 54 (let ((raw-dirs
55 (if (equal 0 max-depth)
56 '()
57 (directory-files directory nil "^[^-.]" nil 'dirs-only)))
52 (reverse-dirs '())) 58 (reverse-dirs '()))
53 59
54 (while raw-dirs 60 (while raw-dirs
55 (if (null (member (car raw-dirs) exclude)) 61 (if (null (member (car raw-dirs) exclude))
56 (setq reverse-dirs 62 (setq reverse-dirs
57 (cons (expand-file-name (car raw-dirs) directory) 63 (cons (expand-file-name (car raw-dirs) directory)
58 reverse-dirs))) 64 reverse-dirs)))
59 (setq raw-dirs (cdr raw-dirs))) 65 (setq raw-dirs (cdr raw-dirs)))
60 66
61 (let ((sub-path 67 (let ((sub-path
62 (paths-find-recursive-path (reverse reverse-dirs) exclude))) 68 (paths-find-recursive-path (reverse reverse-dirs)
69 (if (numberp max-depth)
70 (- max-depth 1)
71 max-depth)
72 exclude)))
63 (setq path (nconc path 73 (setq path (nconc path
64 (list directory) 74 (list directory)
65 sub-path)))))) 75 sub-path))))))
66 (setq directories (cdr directories))) 76 (setq directories (cdr directories)))
67 path)) 77 path))
68 78
69 (defun paths-find-recursive-load-path (directories) 79 (defun paths-find-recursive-load-path (directories &optional max-depth)
70 "Construct a recursive load path underneath DIRECTORIES." 80 "Construct a recursive load path underneath DIRECTORIES."
71 (paths-find-recursive-path directories paths-version-control-bases)) 81 (paths-find-recursive-path directories
82 max-depth paths-version-control-bases))
72 83
73 (defun paths-emacs-root-p (directory) 84 (defun paths-emacs-root-p (directory)
74 "Check if DIRECTORY is a plausible installation root for XEmacs." 85 "Check if DIRECTORY is a plausible installation root for XEmacs."
75 (or 86 (or
76 ;; installed 87 ;; installed
77 (file-directory-p (concat directory "lib/xemacs")) 88 (file-directory-p (paths-construct-path (list directory "lib" "xemacs")))
78 ;; in-place 89 ;; in-place
79 (and 90 (and
80 (file-directory-p (concat directory "lib-src")) 91 (file-directory-p (paths-construct-path (list directory "lib-src")))
81 (file-directory-p (concat directory "lisp")) 92 (file-directory-p (paths-construct-path (list directory "lisp")))
82 (file-directory-p (concat directory "src"))))) 93 (file-directory-p (paths-construct-path (list directory "src"))))))
83 94
84 (defun paths-chase-symlink (file-name) 95 (defun paths-chase-symlink (file-name)
85 "Chase a symlink until the bitter end." 96 "Chase a symlink until the bitter end."
86 (let ((maybe-symlink (file-symlink-p file-name))) 97 (let ((maybe-symlink (file-symlink-p file-name)))
87 (if maybe-symlink 98 (if maybe-symlink
96 (let* ((executable-file-name (paths-chase-symlink 107 (let* ((executable-file-name (paths-chase-symlink
97 (concat invocation-directory 108 (concat invocation-directory
98 invocation-name))) 109 invocation-name)))
99 (executable-directory (file-name-directory executable-file-name)) 110 (executable-directory (file-name-directory executable-file-name))
100 (maybe-root-1 (file-name-as-directory 111 (maybe-root-1 (file-name-as-directory
101 (expand-file-name ".." executable-directory))) 112 (paths-construct-path '("..") executable-directory)))
102 (maybe-root-2 (file-name-as-directory 113 (maybe-root-2 (file-name-as-directory
103 (expand-file-name "../.." executable-directory)))) 114 (paths-construct-path '(".." "..") executable-directory))))
104 (or (and (paths-emacs-root-p maybe-root-1) 115 (or (and (paths-emacs-root-p maybe-root-1)
105 maybe-root-1) 116 maybe-root-1)
106 (and (paths-emacs-root-p maybe-root-2) 117 (and (paths-emacs-root-p maybe-root-2)
107 maybe-root-2)))) 118 maybe-root-2))))
119
120 (defun paths-construct-path (components &optional expand-directory)
121 "Convert list of path components COMPONENTS into a path.
122 If EXPAND-DIRECTORY is non-NIL, use it as a directory to feed
123 to EXPAND-FILE-NAME."
124 (let* ((reverse-components (reverse components))
125 (last-component (car reverse-components))
126 (first-components (reverse (cdr reverse-components)))
127 (path
128 (apply #'concat
129 (append (mapcar #'file-name-as-directory first-components)
130 (list last-component)))))
131 (if expand-directory
132 (expand-file-name path expand-directory)
133 path)))
108 134
109 (defun paths-construct-emacs-directory (root suffix base) 135 (defun paths-construct-emacs-directory (root suffix base)
110 "Construct a directory name within the XEmacs hierarchy." 136 "Construct a directory name within the XEmacs hierarchy."
111 (file-name-as-directory 137 (file-name-as-directory
112 (expand-file-name 138 (expand-file-name
120 ROOTS must be a list of installation roots. 146 ROOTS must be a list of installation roots.
121 SUFFIX is the subdirectory from there. 147 SUFFIX is the subdirectory from there.
122 BASE is the base to look for. 148 BASE is the base to look for.
123 ENVVAR is the name of the environment variable that might also 149 ENVVAR is the name of the environment variable that might also
124 specify the directory. 150 specify the directory.
125 DEFAULT is a fall-back value." 151 DEFAULT is the preferred value."
126 (let ((envvar-value (and envvar (getenv envvar)))) 152 (let ((preferred-value (or (and envvar (getenv envvar))
127 (if (and envvar-value 153 default)))
128 (file-directory-p envvar-value)) 154 (if (and preferred-value
129 (file-name-as-directory envvar-value) 155 (file-directory-p preferred-value))
156 (file-name-as-directory preferred-value)
130 (catch 'gotcha 157 (catch 'gotcha
131 (while roots 158 (while roots
132 (let* ((root (car roots)) 159 (let* ((root (car roots))
133 (path (paths-construct-emacs-directory root suffix base))) 160 (path (paths-construct-emacs-directory root suffix base)))
134 ;; installed 161 ;; installed
137 (let ((path (paths-construct-emacs-directory root "" base))) 164 (let ((path (paths-construct-emacs-directory root "" base)))
138 ;; in-place 165 ;; in-place
139 (if (file-directory-p path) 166 (if (file-directory-p path)
140 (throw 'gotcha path))))) 167 (throw 'gotcha path)))))
141 (setq roots (cdr roots))) 168 (setq roots (cdr roots)))
142 (if (and default 169 nil))))
143 (file-directory-p default))
144 (file-name-as-directory default)
145 nil)))))
146 170
147 (defun paths-find-site-directory (roots base &optional envvar default) 171 (defun paths-find-site-directory (roots base &optional envvar default)
148 "Find a site-specific directory in the XEmacs hierarchy." 172 "Find a site-specific directory in the XEmacs hierarchy."
149 (paths-find-emacs-directory roots "lib/xemacs/" base envvar default)) 173 (paths-find-emacs-directory roots
174 (file-name-as-directory
175 (paths-construct-path '("lib" "xemacs")))
176 base
177 envvar default))
150 178
151 (defun paths-find-version-directory (roots base &optional envvar default) 179 (defun paths-find-version-directory (roots base &optional envvar default)
152 "Find a version-specific directory in the XEmacs hierarchy." 180 "Find a version-specific directory in the XEmacs hierarchy."
153 (paths-find-emacs-directory roots 181 (paths-find-emacs-directory roots
154 (concat "lib/xemacs-" (construct-emacs-version) "/") 182 (file-name-as-directory
183 (paths-construct-path
184 (list "lib"
185 (concat "xemacs-"
186 (construct-emacs-version)))))
155 base 187 base
156 envvar default)) 188 envvar default))
157 189
158 (defun paths-find-architecture-directory (roots base &optional envvar default) 190 (defun paths-find-architecture-directory (roots base &optional envvar default)
159 "Find an architecture-specific directory in the XEmacs hierarchy." 191 "Find an architecture-specific directory in the XEmacs hierarchy."
187 "-b" 219 "-b"
188 (substring emacs-version 220 (substring emacs-version
189 (match-beginning 1) (match-end 1))))) 221 (match-beginning 1) (match-end 1)))))
190 (setq paths-path-emacs-version version) 222 (setq paths-path-emacs-version version)
191 version))))) 223 version)))))
192
193 (defun paths-find-emacs-path (roots suffix base &optional envvar default)
194 "Find a path in the XEmacs hierarchy.
195 ROOTS must be a list of installation roots.
196 SUFFIX is the subdirectory from there.
197 BASE is the base to look for.
198 ENVVAR is the name of the environment variable that might also
199 specify the path.
200 DEFAULT is a fall-back value."
201 (let ((envvar-value (and envvar (getenv envvar))))
202 (if envvar-value
203 (decode-path-internal envvar-value)
204 (let ((directory (paths-find-emacs-directory roots base suffix)))
205 (if (and directory (file-directory-p directory))
206 (list directory)
207 (paths-directories-which-exist default))))))
208 224
209 (defun paths-directories-which-exist (directories) 225 (defun paths-directories-which-exist (directories)
210 "Return the directories among DIRECTORIES." 226 "Return the directories among DIRECTORIES."
211 (let ((reverse-directories '())) 227 (let ((reverse-directories '()))
212 (while directories 228 (while directories
225 (setq reverse-survivors (cons (car list-2) reverse-survivors))) 241 (setq reverse-survivors (cons (car list-2) reverse-survivors)))
226 (setq list-2 (cdr list-2))) 242 (setq list-2 (cdr list-2)))
227 (append list-1 243 (append list-1
228 (reverse reverse-survivors)))) 244 (reverse reverse-survivors))))
229 245
230 (defun paths-find-site-path (roots base &optional envvar default) 246 (defun paths-delete (predicate list)
231 "Find a path underneath the site hierarchy." 247 "Delete all matches of PREDICATE from LIST."
232 (paths-find-emacs-path roots "lib/xemacs/" base envvar default)) 248 (let ((reverse-result '()))
233 249 (while list
234 (defun paths-find-version-path (roots base &optional envvar default) 250 (if (not (funcall predicate (car list)))
235 "Find a path underneath the site hierarchy." 251 (setq reverse-result (cons (car list) reverse-result)))
236 (paths-find-emacs-path roots 252 (setq list (cdr list)))
237 (concat "lib/xemacs-" (construct-emacs-version) "/") 253 (nreverse reverse-result)))
238 base 254
239 envvar default)) 255 (defun paths-decode-directory-path (string &optional drop-empties)
240 256 "Split STRING at path separators into a directory list.
257 Non-\"\" comonents are converted into directory form.
258 If DROP-EMPTIES is non-NIL, \"\" components are dropped from the output.
259 Otherwise, they are left alone."
260 (let* ((components (decode-path-internal string))
261 (directories
262 (mapcar #'(lambda (component)
263 (if (string-equal "" component)
264 component
265 (file-name-as-directory component)))
266 components)))
267 (if drop-empties
268 (paths-delete #'(lambda (component)
269 (string-equal "" component))
270 directories)
271 directories)))
272
241 (defun paths-find-emacs-roots (invocation-directory 273 (defun paths-find-emacs-roots (invocation-directory
242 invocation-name) 274 invocation-name)
243 "Find all plausible installation roots for XEmacs." 275 "Find all plausible installation roots for XEmacs."
244 (let ((invocation-root 276 (let ((invocation-root
245 (paths-find-emacs-root invocation-directory invocation-name)) 277 (paths-find-emacs-root invocation-directory invocation-name))