Mercurial > hg > xemacs-beta

comparison lisp/find-paths.el @ 428:3ecd8885ac67 r21-2-22

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-22
author cvs
date Mon, 13 Aug 2007 11:28:15 +0200
parents
children abe6d1db359e
comparison
equal deleted inserted replaced
427:0a0253eac470 428:3ecd8885ac67
1 ;;; find-paths.el --- setup various XEmacs paths
2
3 ;; Copyright (C) 1985-1986, 1990, 1992-1997 Free Software Foundation, Inc.
4 ;; Copyright (c) 1993, 1994 Sun Microsystems, Inc.
5 ;; Copyright (C) 1995 Board of Trustees, University of Illinois
6
7 ;; Author: Mike Sperber <sperber@informatik.uni-tuebingen.de>
8 ;; Maintainer: XEmacs Development Team
9 ;; Keywords: internal, dumped
10
11 ;; This file is part of XEmacs.
12
13 ;; XEmacs is free software; you can redistribute it and/or modify it
14 ;; under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation; either version 2, or (at your option)
16 ;; any later version.
17
18 ;; XEmacs is distributed in the hope that it will be useful, but
19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
21 ;; General Public License for more details.
22
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with XEmacs; see the file COPYING. If not, write to the
25 ;; Free Software Foundation, 59 Temple Place - Suite 330,
26 ;; Boston, MA 02111-1307, USA.
27
28 ;;; Synched up with: Not in FSF.
29
30 ;;; Commentary:
31
32 ;; This file is dumped with XEmacs.
33
34 ;; This file contains the library functionality to find paths into the
35 ;; XEmacs hierarchy.
36
37 ;;; Code:
38
39 (defvar paths-version-control-filename-regexp
40 "^\\(RCS\\|CVS\\|SCCS\\)$"
41 "File bases associated with version control.")
42
43 (defvar paths-lisp-filename-regexp
44 "^\\(.*\\.elc?\\)$"
45 "File bases that contain Lisp file.")
46
47 (defvar paths-no-lisp-directory-regexp
48 (concat "\\(" paths-version-control-filename-regexp "\\)"
49 "\\|"
50 "\\(" paths-lisp-filename-regexp "\\)")
51 "File bases that may not be directories containing Lisp code.")
52
53 (defun paths-find-recursive-path (directories &optional max-depth exclude-regexp)
54 "Return a list of the directory hierarchy underneath DIRECTORIES.
55 The returned list is sorted by pre-order and lexicographically.
56 MAX-DEPTH limits the depth of the search to MAX-DEPTH level,
57 if it is a number. If MAX-DEPTH is NIL, the search depth is unlimited.
58 EXCLUDE-REGEXP is a regexp that matches directory names to exclude
59 from the search."
60 (let ((path '()))
61 (while directories
62 (let ((directory (file-name-as-directory
63 (expand-file-name
64 (car directories)))))
65 (if (paths-file-readable-directory-p directory)
66 (let ((raw-entries
67 (if (equal 0 max-depth)
68 '()
69 (directory-files directory nil "^[^.-]")))
70 (reverse-dirs '()))
71 (while raw-entries
72 (if (null (string-match exclude-regexp (car raw-entries)))
73 (setq reverse-dirs
74 (cons (expand-file-name (car raw-entries) directory)
75 reverse-dirs)))
76 (setq raw-entries (cdr raw-entries)))
77
78 (let ((sub-path
79 (paths-find-recursive-path (reverse reverse-dirs)
80 (if (numberp max-depth)
81 (- max-depth 1)
82 max-depth)
83 exclude-regexp)))
84 (setq path (nconc path
85 (list directory)
86 sub-path))))))
87 (setq directories (cdr directories)))
88 path))
89
90 (defun paths-file-readable-directory-p (filename)
91 "Check if filename is a readable directory."
92 (and (file-directory-p filename)
93 (file-readable-p filename)))
94
95 (defun paths-find-recursive-load-path (directories &optional max-depth)
96 "Construct a recursive load path underneath DIRECTORIES."
97 (paths-find-recursive-path directories
98 max-depth paths-no-lisp-directory-regexp))
99
100 (defun paths-emacs-root-p (directory)
101 "Check if DIRECTORY is a plausible installation root for XEmacs."
102 (or
103 ;; installed
104 (paths-file-readable-directory-p (paths-construct-path (list directory
105 "lib"
106 emacs-program-name)))
107 ;; in-place or windows-nt
108 (and
109 (paths-file-readable-directory-p (paths-construct-path (list directory "lisp")))
110 (paths-file-readable-directory-p (paths-construct-path (list directory "etc"))))))
111
112 (defun paths-chase-symlink (file-name)
113 "Chase a symlink until the bitter end."
114 (let ((maybe-symlink (file-symlink-p file-name)))
115 (if maybe-symlink
116 (let* ((directory (file-name-directory file-name))
117 (destination (expand-file-name maybe-symlink directory)))
118 (paths-chase-symlink destination))
119 file-name)))
120
121 (defun paths-find-emacs-root
122 (invocation-directory invocation-name)
123 "Find the run-time root of XEmacs."
124 (let* ((executable-file-name (paths-chase-symlink
125 (concat invocation-directory
126 invocation-name)))
127 (executable-directory (file-name-directory executable-file-name))
128 (maybe-root-1 (file-name-as-directory
129 (paths-construct-path '("..") executable-directory)))
130 (maybe-root-2 (file-name-as-directory
131 (paths-construct-path '(".." "..") executable-directory))))
132 (or (and (paths-emacs-root-p maybe-root-1)
133 maybe-root-1)
134 (and (paths-emacs-root-p maybe-root-2)
135 maybe-root-2))))
136
137 (defun paths-construct-path (components &optional expand-directory)
138 "Convert list of path components COMPONENTS into a path.
139 If EXPAND-DIRECTORY is non-NIL, use it as a directory to feed
140 to EXPAND-FILE-NAME."
141 (let* ((reverse-components (reverse components))
142 (last-component (car reverse-components))
143 (first-components (reverse (cdr reverse-components)))
144 (path
145 (apply #'concat
146 (append (mapcar #'file-name-as-directory first-components)
147 (list last-component)))))
148 (if expand-directory
149 (expand-file-name path expand-directory)
150 path)))
151
152 (defun paths-construct-emacs-directory (root suffix base)
153 "Construct a directory name within the XEmacs hierarchy."
154 (file-name-as-directory
155 (expand-file-name
156 (concat
157 (file-name-as-directory root)
158 suffix
159 base))))
160
161 (defun paths-find-emacs-directory (roots suffix base
162 &optional envvar default keep-suffix)
163 "Find a directory in the XEmacs hierarchy.
164 ROOTS must be a list of installation roots.
165 SUFFIX is the subdirectory from there.
166 BASE is the base to look for.
167 ENVVAR is the name of the environment variable that might also
168 specify the directory.
169 DEFAULT is the preferred value.
170 If KEEP-SUFFIX is non-nil, the suffix must be respected in searching
171 the directory."
172 (let ((preferred-value (or (and envvar (getenv envvar))
173 default)))
174 (if (and preferred-value
175 (paths-file-readable-directory-p preferred-value))
176 (file-name-as-directory preferred-value)
177 (catch 'gotcha
178 (while roots
179 (let* ((root (car roots))
180 ;; installed
181 (path (paths-construct-emacs-directory root suffix base)))
182 (if (paths-file-readable-directory-p path)
183 (throw 'gotcha path)
184 ;; in-place
185 (if (null keep-suffix)
186 (let ((path (paths-construct-emacs-directory root "" base)))
187 (if (paths-file-readable-directory-p path)
188 (throw 'gotcha path))))))
189 (setq roots (cdr roots)))
190 nil))))
191
192 (defun paths-find-site-directory (roots base &optional envvar default)
193 "Find a site-specific directory in the XEmacs hierarchy."
194 (paths-find-emacs-directory roots
195 (file-name-as-directory
196 (paths-construct-path (list
197 "lib"
198 emacs-program-name)))
199 base
200 envvar default))
201
202 (defun paths-find-version-directory (roots base
203 &optional envvar default enforce-version)
204 "Find a version-specific directory in the XEmacs hierarchy.
205 If ENFORCE-VERSION is non-nil, the directory must contain the XEmacs version."
206 (paths-find-emacs-directory roots
207 (file-name-as-directory
208 (paths-construct-path
209 (list "lib"
210 (construct-emacs-version-name))))
211 base
212 envvar default
213 enforce-version))
214
215 (defun paths-find-architecture-directory (roots base &optional envvar default)
216 "Find an architecture-specific directory in the XEmacs hierarchy."
217 (or
218 ;; from more to less specific
219 (paths-find-version-directory roots
220 (concat base system-configuration)
221 envvar default)
222 (paths-find-version-directory roots
223 base
224 envvar)
225 (paths-find-version-directory roots
226 system-configuration
227 envvar)))
228
229 (defun construct-emacs-version-name ()
230 "Construct the raw XEmacs version number."
231 (concat emacs-program-name "-" emacs-program-version))
232
233 (defun paths-directories-which-exist (directories)
234 "Return the directories among DIRECTORIES."
235 (let ((reverse-directories '()))
236 (while directories
237 (if (paths-file-readable-directory-p (car directories))
238 (setq reverse-directories
239 (cons (car directories)
240 reverse-directories)))
241 (setq directories (cdr directories)))
242 (reverse reverse-directories)))
243
244 (defun paths-uniq-append (list-1 list-2)
245 "Append LIST-1 and LIST-2, omitting duplicates."
246 (let ((reverse-survivors '()))
247 (while list-2
248 (if (null (member (car list-2) list-1))
249 (setq reverse-survivors (cons (car list-2) reverse-survivors)))
250 (setq list-2 (cdr list-2)))
251 (append list-1
252 (reverse reverse-survivors))))
253
254 (defun paths-filter (predicate list)
255 "Delete all matches of PREDICATE from LIST."
256 (let ((reverse-result '()))
257 (while list
258 (if (funcall predicate (car list))
259 (setq reverse-result (cons (car list) reverse-result)))
260 (setq list (cdr list)))
261 (nreverse reverse-result)))
262
263 (defun paths-decode-directory-path (string &optional drop-empties)
264 "Split STRING at path separators into a directory list.
265 Non-\"\" comonents are converted into directory form.
266 If DROP-EMPTIES is non-NIL, \"\" components are dropped from the output.
267 Otherwise, they are left alone."
268 (let* ((components (split-path string))
269 (directories
270 (mapcar #'(lambda (component)
271 (if (string-equal "" component)
272 component
273 (file-name-as-directory component)))
274 components)))
275 (if drop-empties
276 (paths-filter #'(lambda (component)
277 (null (string-equal "" component)))
278 directories)
279 directories)))
280
281 (defun paths-find-emacs-roots (invocation-directory
282 invocation-name)
283 "Find all plausible installation roots for XEmacs."
284 (let* ((potential-invocation-root
285 (paths-find-emacs-root invocation-directory invocation-name))
286 (invocation-roots
287 (and potential-invocation-root
288 (list potential-invocation-root)))
289 (potential-installation-roots
290 (paths-uniq-append
291 (and configure-exec-prefix-directory
292 (list (file-name-as-directory
293 configure-exec-prefix-directory)))
294 (and configure-prefix-directory
295 (list (file-name-as-directory
296 configure-prefix-directory)))))
297 (installation-roots
298 (paths-filter #'paths-emacs-root-p potential-installation-roots)))
299 (paths-uniq-append invocation-roots
300 installation-roots)))
301
302 ;;; find-paths.el ends here