(U+5B67): Add `total-strokes'.
[chise/xemacs-chise.git.1] / lisp / find-paths.el
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 \f
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 (not (and exclude-regexp
73                               (string-match exclude-regexp (car raw-entries))))
74                     (setq reverse-dirs
75                           (cons (expand-file-name (car raw-entries) directory)
76                                 reverse-dirs)))
77                 (setq raw-entries (cdr raw-entries)))
78
79               (let ((sub-path
80                      (paths-find-recursive-path (reverse reverse-dirs)
81                                                 (if (numberp max-depth)
82                                                     (- max-depth 1)
83                                                   max-depth)
84                                                 exclude-regexp)))
85                 (setq path (nconc path
86                                   (list directory)
87                                   sub-path))))))
88       (setq directories (cdr directories)))
89     path))
90
91 (defun paths-file-readable-directory-p (filename)
92   "Check if filename is a readable directory."
93   (and (file-directory-p filename)
94        (file-readable-p filename)))
95
96 (defun paths-find-recursive-load-path (directories &optional max-depth)
97   "Construct a recursive load path underneath DIRECTORIES."
98   (paths-find-recursive-path directories
99                              max-depth paths-no-lisp-directory-regexp))
100
101 (defun paths-emacs-root-p (directory)
102   "Check if DIRECTORY is a plausible installation root for XEmacs."
103   (or
104    ;; installed
105    (paths-file-readable-directory-p (paths-construct-path (list directory
106                                                                 "lib"
107                                                                 emacs-program-name)))
108    ;; in-place or windows-nt
109    (and
110     (paths-file-readable-directory-p (paths-construct-path (list directory "lisp")))
111     (paths-file-readable-directory-p (paths-construct-path (list directory "etc"))))))
112
113 (defun paths-root-in-place-p (root)
114   "Check if ROOT is an in-place installation root for XEmacs."
115   (paths-file-readable-directory-p (paths-construct-path (list root "lisp"))))
116
117 (defun paths-chase-symlink (file-name)
118   "Chase a symlink until the bitter end."
119       (let ((maybe-symlink (file-symlink-p file-name)))
120         (if maybe-symlink
121             (let* ((directory (file-name-directory file-name))
122                    (destination (expand-file-name maybe-symlink directory)))
123               (paths-chase-symlink destination))
124           file-name)))
125
126 (defun paths-find-emacs-root
127   (invocation-directory invocation-name)
128   "Find the run-time root of XEmacs."
129   (let* ((executable-file-name (paths-chase-symlink
130                                 (concat invocation-directory
131                                         invocation-name)))
132          (executable-directory (file-name-directory executable-file-name))
133          (maybe-root-1 (file-name-as-directory
134                         (paths-construct-path '("..") executable-directory)))
135          (maybe-root-2 (file-name-as-directory
136                         (paths-construct-path '(".." "..") executable-directory))))
137     (or (and (paths-emacs-root-p maybe-root-1)
138              maybe-root-1)
139         (and (paths-emacs-root-p maybe-root-2)
140              maybe-root-2))))
141
142 (defun paths-construct-path (components &optional expand-directory)
143   "Convert list of path components COMPONENTS into a path.
144 If EXPAND-DIRECTORY is non-NIL, use it as a directory to feed
145 to EXPAND-FILE-NAME."
146   (let* ((reverse-components (reverse components))
147          (last-component (car reverse-components))
148          (first-components (reverse (cdr reverse-components)))
149          (path
150           (apply #'concat
151                  (append (mapcar #'file-name-as-directory first-components)
152                          (list last-component)))))
153     (if expand-directory
154         (expand-file-name path expand-directory)
155       path)))
156
157 (defun paths-construct-emacs-directory (root suffix base)
158   "Construct a directory name within the XEmacs hierarchy."
159   (file-name-as-directory
160    (expand-file-name
161     (concat
162      (file-name-as-directory root)
163      suffix
164      base))))
165
166 (defun paths-find-emacs-directory (roots suffix base
167                                    &optional envvar default keep-suffix
168                                              in-place-external)
169   "Find a directory in the XEmacs hierarchy.
170 ROOTS must be a list of installation roots.
171 SUFFIX is the subdirectory from there.
172 BASE is the base to look for.
173 ENVVAR is the name of the environment variable that might also
174 specify the directory.
175 DEFAULT is the preferred value.
176 If KEEP-SUFFIX is non-nil, the suffix must be respected in searching
177 the directory.
178 If IN-PLACE-EXTERNAL is non-nil, the directory might be found outside
179 an in-place root-hierarchy."
180   (let ((preferred-value (or (and envvar (getenv envvar))
181                              default)))
182     (if (and preferred-value
183              (paths-file-readable-directory-p preferred-value))
184         (file-name-as-directory preferred-value)
185       (catch 'gotcha
186         (while roots
187           (let ((root (car roots)))
188             ;; installed
189             (let ((path (paths-construct-emacs-directory root suffix base)))
190               (if (paths-file-readable-directory-p path)
191                   (throw 'gotcha path)))
192             ;; in-place
193             (if (null keep-suffix)
194                 (let ((path (paths-construct-emacs-directory root "" base)))
195                   (if (paths-file-readable-directory-p path)
196                       (throw 'gotcha path))))
197             (if (and in-place-external
198                      (paths-root-in-place-p root))
199                 (let ((path (paths-construct-emacs-directory
200                              (paths-construct-path '("..") root)
201                              "" base)))
202                   (if (paths-file-readable-directory-p path)
203                       (throw 'gotcha path)))))
204           (setq roots (cdr roots)))
205         nil))))
206
207 (defun paths-find-site-directory (roots base &optional envvar default in-place-external)
208   "Find a site-specific directory in the XEmacs hierarchy.
209 If IN-PLACE-EXTERNAL is non-nil, the directory might be found outside
210 an in-place root-hierarchy."
211   (paths-find-emacs-directory roots
212                               (file-name-as-directory
213                                (paths-construct-path (list
214                                                       "lib"
215                                                       emacs-program-name)))
216                               base
217                               envvar default
218                               nil
219                               in-place-external))
220
221 (defun paths-find-version-directory (roots base
222                                      &optional envvar default enforce-version)
223   "Find a version-specific directory in the XEmacs hierarchy.
224 If ENFORCE-VERSION is non-nil, the directory must contain the XEmacs version."
225   (paths-find-emacs-directory roots
226                               (file-name-as-directory
227                                (paths-construct-path
228                                 (list "lib"
229                                       (construct-emacs-version-name))))
230                               base
231                               envvar default
232                               enforce-version))
233
234 (defun paths-find-architecture-directory (roots base &optional envvar default)
235   "Find an architecture-specific directory in the XEmacs hierarchy."
236   (or
237    ;; from more to less specific
238    (paths-find-version-directory roots
239                                  (paths-construct-path
240                                   (list system-configuration base))
241                                  envvar default)
242    (paths-find-version-directory roots
243                                  base
244                                  envvar)
245    (paths-find-version-directory roots
246                                  system-configuration
247                                  envvar)))
248
249 (defun construct-emacs-version-name ()
250   "Construct the raw XEmacs version number."
251   (concat emacs-program-name "-" emacs-program-version))
252
253 (defun paths-directories-which-exist (directories)
254   "Return the directories among DIRECTORIES."
255   (let ((reverse-directories '()))
256     (while directories
257       (if (paths-file-readable-directory-p (car directories))
258           (setq reverse-directories
259                 (cons (car directories)
260                       reverse-directories)))
261       (setq directories (cdr directories)))
262     (reverse reverse-directories)))
263
264 (defun paths-uniq-append (list-1 list-2)
265   "Append LIST-1 and LIST-2, omitting duplicates."
266   (let ((reverse-survivors '()))
267     (while list-2
268       (if (null (member (car list-2) list-1))
269           (setq reverse-survivors (cons (car list-2) reverse-survivors)))
270       (setq list-2 (cdr list-2)))
271     (append list-1
272             (reverse reverse-survivors))))
273
274 (defun paths-filter (predicate list)
275   "Delete all matches of PREDICATE from LIST."
276   (let ((reverse-result '()))
277     (while list
278       (if (funcall predicate (car list))
279           (setq reverse-result (cons (car list) reverse-result)))
280       (setq list (cdr list)))
281     (nreverse reverse-result)))
282
283 (defun paths-decode-directory-path (string &optional drop-empties)
284   "Split STRING at path separators into a directory list.
285 Non-\"\" components are converted into directory form.
286 If DROP-EMPTIES is non-NIL, \"\" components are dropped from the output.
287 Otherwise, they are left alone."
288   (let* ((components (split-path string))
289          (directories
290           (mapcar #'(lambda (component)
291                       (if (string-equal "" component)
292                           component
293                         (file-name-as-directory component)))
294                   components)))
295     (if drop-empties
296         (paths-filter #'(lambda (component)
297                           (null (string-equal "" component)))
298                       directories)
299       directories)))
300
301 (defun paths-find-emacs-roots (invocation-directory
302                                invocation-name)
303   "Find all plausible installation roots for XEmacs."
304   (let* ((potential-invocation-root
305           (paths-find-emacs-root invocation-directory invocation-name))
306          (invocation-roots
307           (and potential-invocation-root
308                (list potential-invocation-root)))
309          (potential-installation-roots
310           (paths-uniq-append
311            (and configure-exec-prefix-directory
312                 (list (file-name-as-directory
313                        configure-exec-prefix-directory)))
314            (and configure-prefix-directory
315                 (list (file-name-as-directory
316                        configure-prefix-directory)))))
317          (installation-roots
318           (paths-filter #'paths-emacs-root-p potential-installation-roots)))
319     (paths-uniq-append invocation-roots
320                        installation-roots)))
321
322 ;;; find-paths.el ends here