Mercurial > hg > xemacs-beta

comparison lisp/setup-paths.el @ 265:8efd647ea9ca r20-5b31

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-5b31
author cvs
date Mon, 13 Aug 2007 10:25:37 +0200
parents
children 966663fcf606
comparison
equal deleted inserted replaced
264:682d2a9d41a5 265:8efd647ea9ca
1 ;;; setup-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 machinery necessary to find the various
35 ;; paths into the XEmacs hierarchy.
36
37 (defvar paths-version-control-bases '("RCS" "CVS" "SCCS")
38 "File bases associated with version control.")
39
40 (defun paths-find-recursive-path (directories &optional exclude)
41 "Return a list of the directory hierarchy underneath DIRECTORIES.
42 The returned list is sorted by pre-order and lexicographically."
43 (let ((path '()))
44 (while directories
45 (let ((directory (file-name-as-directory
46 (expand-file-name
47 (car directories)))))
48 (if (file-directory-p directory)
49 (let ((raw-dirs (directory-files directory nil "^[^-.]" nil 'dirs-only))
50 (reverse-dirs '()))
51
52 (while raw-dirs
53 (if (null (member (car raw-dirs) exclude))
54 (setq reverse-dirs
55 (cons (expand-file-name (car raw-dirs) directory)
56 reverse-dirs)))
57 (setq raw-dirs (cdr raw-dirs)))
58
59 (let ((sub-path
60 (paths-find-recursive-path (reverse reverse-dirs) exclude)))
61 (setq path (nconc path
62 (list directory)
63 sub-path))))))
64 (setq directories (cdr directories)))
65 path))
66
67 (defun paths-find-recursive-load-path (directories)
68 "Construct a recursive load path underneath DIRECTORIES."
69 (paths-find-recursive-path directories paths-version-control-bases))
70
71 (defun paths-emacs-root-p (directory)
72 "Check if DIRECTORY is a plausible installation root for XEmacs."
73 (or
74 ;; installed
75 (and (boundp 'emacs-version)
76 (file-directory-p
77 (concat directory "lib/xemacs-" (construct-emacs-version))))
78 ;; in-place
79 (and
80 (file-directory-p (concat directory "lib-src"))
81 (file-directory-p (concat directory "lisp"))
82 (file-directory-p (concat directory "src")))))
83
84 (defun paths-find-emacs-root
85 (invocation-directory invocation-name)
86 "Find the run-time root of XEmacs."
87 (let ((maybe-root-1 (file-name-as-directory
88 (expand-file-name ".." invocation-directory)))
89 (maybe-root-2 (file-name-as-directory
90 (expand-file-name "../.." invocation-directory))))
91 (cond
92 ((paths-emacs-root-p maybe-root-1)
93 maybe-root-1)
94 ((paths-emacs-root-p maybe-root-2)
95 maybe-root-2)
96 (t
97 (let ((maybe-symlink (file-symlink-p (concat invocation-directory
98 invocation-name))))
99 (if maybe-symlink
100 (let ((directory (file-name-directory maybe-symlink)))
101 (paths-find-emacs-root directory invocation-name))
102 nil))))))
103
104 (defun paths-construct-emacs-directory (root suffix base)
105 "Construct a directory name within the XEmacs hierarchy."
106 (file-name-as-directory
107 (expand-file-name
108 (concat
109 (file-name-as-directory root)
110 suffix
111 base))))
112
113 (defun paths-find-emacs-directory (roots suffix base &optional envvar default)
114 "Find a directory in the XEmacs hierarchy.
115 ROOTS must be a list of installation roots.
116 SUFFIX is the subdirectory from there.
117 BASE is the base to look for.
118 ENVVAR is the name of the environment variable that might also
119 specify the directory.
120 DEFAULT is a fall-back value."
121 (let ((envvar-value (and envvar (getenv envvar))))
122 (if (and envvar-value
123 (file-directory-p envvar-value))
124 (file-name-as-directory envvar-value)
125 (catch 'gotcha
126 (while roots
127 (let* ((root (car roots))
128 (path (paths-construct-emacs-directory root suffix base)))
129 ;; installed
130 (if (file-directory-p path)
131 (throw 'gotcha path)
132 (let ((path (paths-construct-emacs-directory root "" base)))
133 ;; in-place
134 (if (file-directory-p path)
135 (throw 'gotcha path)))))
136 (setq roots (cdr roots)))
137 (if (and default
138 (file-directory-p default))
139 (file-name-as-directory default)
140 nil)))))
141
142 (defun paths-find-site-directory (roots base &optional envvar default)
143 "Find a site-specific directory in the XEmacs hierarchy."
144 (paths-find-emacs-directory roots "lib/xemacs/" base envvar default))
145
146 (defun paths-find-version-directory (roots base &optional envvar default)
147 "Find a version-specific directory in the XEmacs hierarchy."
148 (paths-find-emacs-directory roots
149 (concat "lib/xemacs-" (construct-emacs-version) "/")
150 base
151 envvar default))
152
153 (defun paths-find-architecture-directory (roots base &optional envvar default)
154 "Find an architecture-specific directory in the XEmacs hierarchy."
155 (or
156 ;; from more to less specific
157 (paths-find-version-directory roots
158 (concat base system-configuration)
159 envvar default)
160 (paths-find-version-directory roots
161 system-configuration
162 envvar default)
163 (paths-find-version-directory roots
164 base
165 envvar default)))
166
167 (defvar paths-path-emacs-version nil
168 "Emacs version as it appears in paths.")
169
170 (defun construct-emacs-version ()
171 "Construct the raw version number of XEmacs in the form XX.XX."
172 ;; emacs-version isn't available early, but we really don't care then
173 (if (null (boundp 'emacs-version))
174 ""
175 (or paths-path-emacs-version ; cache
176 (progn
177 (string-match "\\`[^0-9]*\\([0-9]+\\.[0-9]+\\)" emacs-version)
178 (let ((version (substring emacs-version
179 (match-beginning 1) (match-end 1))))
180 (if (string-match "(beta *\\([0-9]+\\))" emacs-version)
181 (setq version (concat version
182 "-b"
183 (substring emacs-version
184 (match-beginning 1) (match-end 1)))))
185 (setq paths-path-emacs-version version)
186 version)))))
187
188 (defun paths-find-emacs-path (roots suffix base &optional envvar default)
189 "Find a path in the XEmacs hierarchy.
190 ROOTS must be a list of installation roots.
191 SUFFIX is the subdirectory from there.
192 BASE is the base to look for.
193 ENVVAR is the name of the environment variable that might also
194 specify the path.
195 DEFAULT is a fall-back value."
196 (let ((envvar-value (and envvar (getenv envvar))))
197 (if (and (fboundp 'parse-colon-path) envvar-value)
198 (parse-colon-path envvar-value)
199 (let ((directory (paths-find-emacs-directory roots base suffix)))
200 (if (and directory (file-directory-p directory))
201 (list directory)
202 (paths-directories-which-exist default))))))
203
204 (defun paths-directories-which-exist (directories)
205 "Return the directories among DIRECTORIES."
206 (let ((reverse-directories '()))
207 (while directories
208 (if (file-directory-p (car directories))
209 (setq reverse-directories
210 (cons (car directories)
211 reverse-directories)))
212 (setq directories (cdr directories)))
213 (reverse reverse-directories)))
214
215 (defun paths-find-site-path (roots base &optional envvar default)
216 "Find a path underneath the site hierarchy."
217 (paths-find-emacs-path roots "lib/xemacs/" base envvar default))
218
219 (defun paths-find-version-path (roots base &optional envvar default)
220 "Find a path underneath the site hierarchy."
221 (paths-find-emacs-path roots
222 (concat "lib/xemacs-" (construct-emacs-version) "/")
223 base
224 envvar default))
225
226 ; Packages are special ...
227
228 (defun paths-find-package-path (roots)
229 "Construct the package path underneath installation roots ROOTS."
230 (let ((envvar-value (getenv "EMACSPACKAGEPATH")))
231 (if (and (fboundp 'parse-colon-path) envvar-value)
232 (parse-colon-path envvar-value)
233 (let ((base-directory (paths-find-site-directory roots "packages")))
234 (if base-directory
235 (let ((mule-directory (and (featurep 'mule)
236 (paths-find-site-directory roots
237 "mule-packages"))))
238 (append '("~/.xemacs/")
239 '(nil)
240 (and mule-directory
241 (list mule-directory))
242 (list base-directory)))
243 configure-package-path)))))
244
245 (defvar paths-package-special-bases '("etc" "info" "lisp" "lib-src" "bin")
246 "Special subdirectories of packages.")
247
248 (defun paths-find-packages-in-directories (directories)
249 "Find all packages underneath directories in DIRECTORIES."
250 (paths-find-recursive-path directories
251 (append paths-version-control-bases
252 paths-package-special-bases)))
253
254 (defun paths-split-path (path)
255 "Split PATH at NIL, return pair with two components.
256 The second component is shared with PATH."
257 (let ((reverse-early '()))
258 (while (and path (null (null (car path))))
259 (setq reverse-early (cons (car path) reverse-early))
260 (setq path (cdr path)))
261 (if (null path)
262 (cons nil path)
263 (cons (reverse reverse-early) (cdr path)))))
264
265 (defun paths-find-packages (package-path)
266 "Search for all packages in PACKAGE-PATH.
267 PACKAGE-PATH may distinguish (by NIL-separation) between early
268 and late packages.
269 This returns (CONS EARLY-PACKAGES LATE-PACKAGES)."
270 (let* ((stuff (paths-split-path package-path))
271 (early (car stuff))
272 (late (cdr stuff)))
273 (cons (paths-find-packages-in-directories early)
274 (paths-find-packages-in-directories late))))
275
276 (defun paths-find-package-library-path (packages suffixes)
277 "Construct a path into a component of the packages hierarchy.
278 PACKAGES is a list of package directories.
279 SUFFIXES is a list of names of package subdirectories to look for."
280 (let ((directories
281 (apply
282 #'append
283 (mapcar #'(lambda (package)
284 (mapcar #'(lambda (suffix)
285 (concat package suffix))
286 suffixes))
287 packages))))
288 (paths-directories-which-exist directories)))
289
290 (defun paths-find-package-load-path (packages)
291 "Construct the load-path component for packages.
292 PACKAGES is a list of package directories."
293 (paths-find-recursive-load-path
294 (paths-find-package-library-path packages '("lisp/"))))
295
296 (defun paths-find-package-exec-path (packages)
297 (paths-find-package-library-path packages
298 (list (concat "bin/" system-configuration "/")
299 "lib-src/")))
300
301 (defun paths-find-package-info-path (packages)
302 (paths-find-package-library-path packages '("info/")))
303
304 (defun paths-find-package-data-path (packages)
305 (paths-find-package-library-path packages '("etc/")))
306
307 (defun paths-find-emacs-roots (invocation-directory
308 invocation-name)
309 "Find all plausible installation roots for XEmacs."
310 (let ((invocation-root
311 (paths-find-emacs-root invocation-directory invocation-name))
312 (installation-root
313 (if (and configure-prefix-directory
314 (file-directory-p configure-prefix-directory))
315 configure-prefix-directory)))
316 (append (and invocation-root
317 (list invocation-root))
318 (and installation-root
319 (list installation-root)))))
320
321 (defun paths-find-load-path (roots early-package-load-path late-package-load-path)
322 "Construct the load path."
323 (let ((envvar-value (getenv "EMACSLOADPATH")))
324 (if (and (fboundp 'parse-colon-path) envvar-value)
325 (parse-colon-path envvar-value)
326 (let* ((site-lisp-directory
327 (and allow-site-lisp
328 (paths-find-site-directory roots "site-lisp"
329 nil
330 configure-site-directory)))
331 (site-lisp-load-path
332 (and site-lisp-directory
333 (paths-find-recursive-load-path (list site-lisp-directory))))
334 (lisp-directory
335 (paths-find-version-directory roots "lisp"
336 nil
337 configure-lisp-directory))
338 (lisp-load-path
339 (paths-find-recursive-load-path (list lisp-directory))))
340 (nconc early-package-load-path
341 site-lisp-load-path
342 late-package-load-path
343 lisp-load-path)))))
344
345 (defun paths-find-info-path (roots early-packages late-packages)
346 "Construct the info path."
347 (append
348 (paths-find-package-info-path early-packages)
349 (paths-find-package-info-path late-packages)
350 (let ((info-directory
351 (paths-find-version-directory roots "info"
352 nil
353 (append
354 (and configure-info-directory
355 (list configure-info-directory))
356 configure-info-path))))
357 (and info-directory
358 (list info-directory)))
359 (let ((info-path-envval (getenv "INFOPATH")))
360 (if (and (fboundp 'parse-colon-path) info-path-envval)
361 (parse-colon-path info-path-envval)))))
362
363 (defun paths-find-doc-directory (roots)
364 "Find the documentation directory."
365 (paths-find-architecture-directory roots "lib-src"))
366
367 (defun paths-find-lock-directory (roots)
368 "Find the lock directory."
369 (paths-find-site-path roots "lock" "EMACSLOCKDIR" configure-lock-directory))
370
371 (defun paths-find-superlock-file (lock-directory)
372 "Find the superlock file."
373 (cond
374 ((null lock-directory)
375 nil)
376 ((and configure-superlock-file
377 (file-directory-p (file-name-directory configure-superlock-file)))
378 configure-superlock-file)
379 (t
380 (expand-file-name "!!!SuperLock!!!" lock-directory))))
381
382 (defun paths-find-exec-directory (roots)
383 "Find the binary directory."
384 (paths-find-architecture-directory roots "lib-src"))
385
386 (defun paths-find-exec-path (roots exec-directory early-packages late-packages)
387 "Find the binary path."
388 (append
389 (let ((path-envval (getenv "PATH")))
390 (and (fboundp 'parse-colon-path) path-envval
391 (parse-colon-path path-envval)))
392 (paths-find-package-exec-path early-packages)
393 (paths-find-package-exec-path late-packages)
394 (let ((emacspath-envval (getenv "EMACSPATH")))
395 (if (and (fboundp 'parse-colon-path) emacspath-envval)
396 (parse-colon-path path-envval)
397 (paths-directories-which-exist configure-exec-path)))
398 (and exec-directory
399 (list exec-directory))))
400
401 (defun paths-find-data-directory (roots)
402 "Find the data directory."
403 (paths-find-version-directory roots "etc" "EMACSDATA" configure-data-directory))
404
405 (defun paths-find-data-directory-list (data-directory early-packages late-packages)
406 "Find the data path."
407 (append
408 (paths-find-package-data-path early-packages)
409 (paths-find-package-data-path late-packages)
410 (list data-directory)))
411
412 (defun paths-setup-paths ()
413 "Setup all the various paths.
414 Call this as often as you like!"
415 ;; XEmacs -- Steven Baur says invocation directory is nil if you
416 ;; try to use XEmacs as a login shell.
417 (or invocation-directory (setq invocation-directory default-directory))
418 (if (fboundp 'abbreviate-file-name)
419 ;; No abbreviate-file-name in temacs
420 (setq invocation-directory
421 ;; don't let /tmp_mnt/... get into the load-path or exec-path.
422 (abbreviate-file-name invocation-directory)))
423
424 (let ((roots (paths-find-emacs-roots invocation-directory invocation-name)))
425
426 (setq package-path (paths-find-package-path roots))
427
428 (let ((stuff (paths-find-packages package-path)))
429 (setq early-packages (car stuff))
430 (setq late-packages (cdr stuff)))
431
432 (setq early-package-load-path (paths-find-package-load-path early-packages))
433 (setq late-package-load-path (paths-find-package-load-path late-packages))
434
435 (setq load-path (paths-find-load-path roots
436 early-package-load-path
437 late-package-load-path))
438
439 (setq info-path (paths-find-info-path roots early-packages late-packages))
440
441 (if (boundp 'lock-directory)
442 (progn
443 (setq lock-directory (paths-find-lock-directory roots))
444 (setq superlock-file (paths-find-superlock-file lock-directory))))
445
446 (setq exec-directory (paths-find-exec-directory roots))
447
448 (setq exec-path (paths-find-exec-path roots exec-directory
449 early-packages late-packages))
450
451 (setq doc-directory (paths-find-doc-directory roots))
452
453 (setq data-directory (paths-find-data-directory roots))
454
455 (setq data-directory-list (paths-find-data-directory-list data-directory
456 early-packages
457 late-packages))))
458
459 (defun paths-setup-paths-warning ()
460 (let ((lock (if (boundp 'lock-directory) lock-directory 't))
461 warnings message guess)
462 (if (and (stringp lock) (null (file-directory-p lock)))
463 (setq lock nil))
464 (cond
465 ((null (and exec-directory data-directory doc-directory load-path lock))
466 (save-excursion
467 (set-buffer (get-buffer-create " *warning-tmp*"))
468 (erase-buffer)
469 (buffer-disable-undo (current-buffer))
470 (if (null lock) (push "lock-directory" warnings))
471 (if (null exec-directory) (push "exec-directory" warnings))
472 (if (null data-directory) (push "data-directory" warnings))
473 (if (null doc-directory) (push "doc-directory" warnings))
474 (if (null load-path) (push "load-path" warnings))
475 (cond ((cdr (cdr warnings))
476 (setq message (apply 'format "%s, %s, and %s" warnings)))
477 ((cdr warnings)
478 (setq message (apply 'format "%s and %s" warnings)))
479 (t (setq message (format "variable %s" (car warnings)))))
480 (insert "couldn't find an obvious default for " message
481 ", and there were no defaults specified in paths.h when "
482 "XEmacs was built. Perhaps some directories don't exist, "
483 "or the XEmacs executable, " (concat invocation-directory
484 invocation-name)
485 " is in a strange place?")
486
487 (if (fboundp 'fill-region)
488 ;; Might not be bound in the cold load environment...
489 (let ((fill-column 76))
490 (fill-region (point-min) (point-max))))
491 (goto-char (point-min))
492 (princ "\nWARNING:\n" 'external-debugging-output)
493 (princ (buffer-string) 'external-debugging-output)
494 (erase-buffer)
495 t)))))
496
497 (defun paths-load-package-lisps (package-load-path base)
498 "Load all Lisp files of a certain name along a load path.
499 BASE is the base name of the files."
500 (mapc #'(lambda (dir)
501 (let ((file-name (expand-file-name base dir)))
502 (if (file-exists-p file-name)
503 (condition-case error
504 (load file-name)
505 (error
506 (warn (format "Autoload error in: %s:\n\t%s"
507 file-name
508 (with-output-to-string
509 (display-error error nil)))))))))
510 package-load-path))
511
512 (defun paths-load-package-auto-autoloads (package-load-path)
513 "Load auto-autoload files along a load path."
514 (paths-load-package-lisps package-load-path
515 (file-name-sans-extension autoload-file-name)))
516
517 (defun paths-load-package-dumped-lisps (package-load-path)
518 "Load dumped-lisp.el files along a load path."
519 (mapc #'(lambda (dir)
520 (let ((file-name (expand-file-name "dumped-lisp.el" dir)))
521 (if (file-exists-p file-name)
522 (let (package-lisp
523 ;; 20.4 packages could set this
524 preloaded-file-list)
525 (load file-name)
526 ;; dumped-lisp.el could have set this ...
527 (if package-lisp
528 (mapc #'(lambda (base)
529 (load (expand-file-name base dir)))
530 package-lisp))))))
531 package-load-path))
532
533 ;;; setup-paths.el ends here