1 ;;; find-paths.el --- setup various SXEmacs paths
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
7 ;; Author: Mike Sperber <sperber@informatik.uni-tuebingen.de>
8 ;; Maintainer: SXEmacs Development Team
9 ;; Keywords: internal, dumped
11 ;; This file is part of SXEmacs.
13 ;; SXEmacs is free software: you can redistribute it and/or modify
14 ;; it under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation, either version 3 of the License, or
16 ;; (at your option) any later version.
18 ;; SXEmacs is distributed in the hope that it will be useful,
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;; GNU General Public License for more details.
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
26 ;;; Synched up with: Not in FSF.
30 ;; This file is dumped with SXEmacs.
32 ;; This file contains the library functionality to find paths into the
37 (defvar paths-version-control-filename-regexp
38 #r"^\(RCS\|CVS\|SCCS\|.arch-ids\|.arch-inventory\|{arch}\)$"
39 "File bases associated with version control.")
41 (defvar paths-lisp-filename-regexp
43 "File bases that contain Lisp file.")
45 (defvar paths-no-lisp-directory-regexp
46 (concat "\\(" paths-version-control-filename-regexp "\\)"
48 "\\(" paths-lisp-filename-regexp "\\)")
49 "File bases that may not be directories containing Lisp code.")
51 (defun paths-find-recursive-path (directories &optional max-depth exclude-regexp)
52 "Return a list of the directory hierarchy underneath DIRECTORIES.
53 The returned list is sorted by pre-order and lexicographically.
54 MAX-DEPTH limits the depth of the search to MAX-DEPTH level,
55 if it is a number. If MAX-DEPTH is NIL, the search depth is unlimited.
56 EXCLUDE-REGEXP is a regexp that matches directory names to exclude
60 (let ((directory (file-name-as-directory
63 (if (paths-file-readable-directory-p directory)
65 (if (equal 0 max-depth)
67 (directory-files directory nil "^[^.-]")))
70 (if (not (and exclude-regexp
71 (string-match exclude-regexp (car raw-entries))))
73 (cons (expand-file-name (car raw-entries) directory)
75 (setq raw-entries (cdr raw-entries)))
78 (paths-find-recursive-path (reverse reverse-dirs)
79 (if (numberp max-depth)
83 (setq path (nconc path
86 (setq directories (cdr directories)))
89 (defun paths-file-readable-directory-p (filename)
90 "Check if filename is a readable directory."
91 (and (file-directory-p filename)
92 (file-readable-p filename)))
94 (defun paths-find-recursive-load-path (directories &optional max-depth)
95 "Construct a recursive load path underneath DIRECTORIES."
96 (paths-find-recursive-path directories
97 max-depth paths-no-lisp-directory-regexp))
99 (defun paths-emacs-root-p (directory)
100 "Check if DIRECTORY is a plausible installation root for XEmacs."
103 (paths-file-readable-directory-p (paths-construct-path
106 (construct-emacs-version-name))))
107 (paths-file-readable-directory-p (paths-construct-path
110 (construct-emacs-version-name))))
113 (paths-file-readable-directory-p (paths-construct-path
114 (list directory "lisp")))
115 (paths-file-readable-directory-p (paths-construct-path
116 (list directory "etc"))))))
118 (defun paths-root-in-place-p (root)
119 "Check if ROOT is an in-place installation root for XEmacs."
120 (paths-file-readable-directory-p (paths-construct-path (list root "lisp"))))
122 (defun paths-chase-symlink (file-name)
123 "Chase a symlink until the bitter end."
124 (let ((maybe-symlink (file-symlink-p file-name)))
126 (let* ((directory (file-name-directory file-name))
127 (destination (expand-file-name maybe-symlink directory)))
128 (paths-chase-symlink destination))
131 (defun paths-find-emacs-root
132 (invocation-directory invocation-name)
133 "Find the run-time root of XEmacs."
134 (let* ((executable-file-name (paths-chase-symlink
135 (concat invocation-directory
137 (executable-directory (file-name-directory executable-file-name))
138 (maybe-root-1 (file-name-as-directory
139 (paths-construct-path '("..") executable-directory)))
140 (maybe-root-2 (file-name-as-directory
141 (paths-construct-path '(".." "..") executable-directory))))
142 (or (and (paths-emacs-root-p maybe-root-1)
144 (and (paths-emacs-root-p maybe-root-2)
147 (defun paths-construct-path (components &optional expand-directory)
148 "Convert list of path components COMPONENTS into a path.
149 If EXPAND-DIRECTORY is non-NIL, use it as a directory to feed
150 to EXPAND-FILE-NAME."
151 (let* ((reverse-components (reverse components))
152 (last-component (car reverse-components))
153 (first-components (reverse (cdr reverse-components)))
156 (append (mapcar #'file-name-as-directory first-components)
157 (list last-component)))))
159 (expand-file-name path expand-directory)
162 (defun paths-construct-emacs-directory (root suffix base)
163 "Construct a directory name within the XEmacs hierarchy."
164 (file-name-as-directory
167 (file-name-as-directory root)
171 (defun paths-find-emacs-directory (roots suffix base
172 &optional envvar default keep-suffix
174 "Find a directory in the XEmacs hierarchy.
175 ROOTS must be a list of installation roots.
176 SUFFIX is the subdirectory from there.
177 BASE is the base to look for.
178 ENVVAR is the name of the environment variable that might also
179 specify the directory.
180 DEFAULT is the preferred value.
181 If KEEP-SUFFIX is non-nil, the suffix must be respected in searching
183 If IN-PLACE-EXTERNAL is non-nil, the directory might be found outside
184 an in-place root-hierarchy."
185 (let ((preferred-value (or (and envvar (getenv envvar))
187 (if (and preferred-value
188 (paths-file-readable-directory-p preferred-value))
189 (file-name-as-directory preferred-value)
192 (let ((root (car roots)))
194 (let ((path (paths-construct-emacs-directory root suffix base)))
195 (if (paths-file-readable-directory-p path)
196 (throw 'gotcha path)))
198 (if (null keep-suffix)
199 (let ((path (paths-construct-emacs-directory root "" base)))
200 (if (paths-file-readable-directory-p path)
201 (throw 'gotcha path))))
202 (if (and in-place-external
203 (paths-root-in-place-p root))
204 (let ((path (paths-construct-emacs-directory
205 (paths-construct-path '("..") root)
207 (if (paths-file-readable-directory-p path)
208 (throw 'gotcha path)))))
209 (setq roots (cdr roots)))
212 (defun paths-find-site-archindep-directory
213 (roots base &optional envvar default in-place-external)
214 "Find a site-specific directory in the XEmacs hierarchy.
215 If IN-PLACE-EXTERNAL is non-nil, the directory might be found outside
216 an in-place root-hierarchy."
217 (paths-find-emacs-directory roots
218 (file-name-as-directory
219 (paths-construct-path (list
221 emacs-program-name)))
227 (defun paths-find-site-archdep-directory
228 (roots base &optional envvar default in-place-external)
229 "Find a site-specific directory in the XEmacs hierarchy.
230 If IN-PLACE-EXTERNAL is non-nil, the directory might be found outside
231 an in-place root-hierarchy."
232 (paths-find-emacs-directory roots
233 (file-name-as-directory
234 (paths-construct-path (list
237 system-configuration)))
243 ;; we default to the arch-independent directory atm
244 (defalias 'paths-find-site-directory #'paths-find-site-archindep-directory)
246 (defun paths-find-version-archdep-directory
247 (roots base &optional envvar default enforce-version)
248 "Find a version-specific directory in the SXEmacs hierarchy.
249 If ENFORCE-VERSION is non-nil, the directory must contain the SXEmacs version."
250 ;; look for lib/sxemacs-xx.y.z
251 ;; what do we do if user specifies --libdir?
252 (paths-find-emacs-directory roots
253 (file-name-as-directory
254 (paths-construct-path
256 (construct-emacs-version-name))))
261 (defun paths-find-version-archindep-directory
262 (roots base &optional envvar default enforce-version)
263 "Find a version-specific directory in the SXEmacs hierarchy.
264 If ENFORCE-VERSION is non-nil, the directory must contain the SXEmacs version."
265 ;; look for share/sxemacs-xx.y.z
266 (paths-find-emacs-directory roots
267 (file-name-as-directory
268 (paths-construct-path
270 (construct-emacs-version-name))))
275 ;; we default to the arch-independent directory atm
276 (defalias 'path-find-version-directory #'paths-find-version-archindep-directory)
278 (defun paths-find-architecture-directory (roots base &optional envvar default)
279 "Find an architecture-specific directory in the XEmacs hierarchy."
281 ;; from more to less specific
282 (paths-find-version-archdep-directory roots
283 (paths-construct-path
284 (list system-configuration base))
286 (paths-find-version-archdep-directory roots
289 (paths-find-version-archdep-directory roots
293 (defun construct-emacs-version-name ()
294 "Construct the raw XEmacs version number."
295 (concat emacs-program-name "-" emacs-program-version))
297 (defun paths-directories-which-exist (directories)
298 "Return the directories among DIRECTORIES."
299 (let ((reverse-directories '()))
301 (if (paths-file-readable-directory-p (car directories))
302 (setq reverse-directories
303 (cons (car directories)
304 reverse-directories)))
305 (setq directories (cdr directories)))
306 (reverse reverse-directories)))
308 (defun paths-uniq-append (list-1 list-2)
309 "Append LIST-1 and LIST-2, omitting duplicates."
310 (let ((reverse-survivors '()))
312 (if (null (member (car list-2) list-1))
313 (setq reverse-survivors (cons (car list-2) reverse-survivors)))
314 (setq list-2 (cdr list-2)))
316 (reverse reverse-survivors))))
318 (defun paths-filter (predicate list)
319 "Delete all matches of PREDICATE from LIST."
320 (let ((reverse-result '()))
322 (if (funcall predicate (car list))
323 (setq reverse-result (cons (car list) reverse-result)))
324 (setq list (cdr list)))
325 (nreverse reverse-result)))
327 (defun paths-decode-directory-path (string &optional drop-empties)
328 "Split STRING at path separators into a directory list.
329 Non-\"\" components are converted into directory form.
330 If DROP-EMPTIES is non-NIL, \"\" components are dropped from the output.
331 Otherwise, they are left alone."
332 (let* ((components (split-path string))
334 (mapcar #'(lambda (component)
335 (if (string-equal "" component)
337 (file-name-as-directory component)))
340 (paths-filter #'(lambda (component)
341 (null (string-equal "" component)))
345 (defun paths-find-emacs-roots (invocation-directory
346 invocation-name &optional dumpp)
347 "Find all plausible installation roots for SXEmacs."
348 (let* ((potential-invocation-root
349 (paths-find-emacs-root
350 invocation-directory invocation-name))
351 (invocation-roots nil)
352 (potential-installation-roots
355 (and configure-exec-prefix-directory
356 (list (file-name-as-directory
357 configure-exec-prefix-directory)))
358 (and configure-prefix-directory
359 (list (file-name-as-directory
360 configure-prefix-directory))))))
362 (paths-filter #'paths-emacs-root-p potential-installation-roots))
364 (or (getenv "SOURCE_TREE_ROOT")
365 (and potential-invocation-root
367 (expand-file-name ".sxemacs.source.tree"
368 potential-invocation-root))
370 (expand-file-name ".sxemacs.source.tree"
371 potential-invocation-root)))))
373 (getenv "BUILD_TREE_ROOT")))
374 (when source-tree-root
375 (setq invocation-roots (cons source-tree-root invocation-roots)
376 invocation-roots (cons (or configure-prefix-directory
377 configure-exec-prefix-directory
380 (when build-tree-root
381 (setq invocation-roots (cons build-tree-root invocation-roots)
382 invocation-roots (cons (or configure-prefix-directory
383 configure-exec-prefix-directory
386 (when potential-invocation-root
387 (setq invocation-roots (cons potential-invocation-root invocation-roots)))
388 (paths-uniq-append invocation-roots installation-roots)))
390 ;;; find-paths.el ends here