Mercurial > hg > xemacs-beta

comparison lisp/setup-paths.el @ 267:966663fcf606 r20-5b32

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-5b32
author cvs
date Mon, 13 Aug 2007 10:26:29 +0200
parents 8efd647ea9ca
children b2472a1930f2
comparison
equal deleted inserted replaced
266:18d185df8c54 267:966663fcf606
29 29
30 ;;; Commentary: 30 ;;; Commentary:
31 31
32 ;; This file is dumped with XEmacs. 32 ;; This file is dumped with XEmacs.
33 33
34 ;; This file contains the machinery necessary to find the various 34 ;; This file describes and constructs the various paths into the
35 ;; paths into the XEmacs hierarchy. 35 ;; XEmacs hierarchy from a global viewpoint.
36 36
37 (defvar paths-version-control-bases '("RCS" "CVS" "SCCS") 37 ;; It requires find-paths.el and packages.el.
38 "File bases associated with version control.") 38
39 ;;; Code:
39 40
40 (defun paths-find-recursive-path (directories &optional exclude) 41 (defun paths-find-site-lisp-directory (roots)
41 "Return a list of the directory hierarchy underneath DIRECTORIES. 42 "Find the site Lisp directory of the XEmacs hierarchy."
42 The returned list is sorted by pre-order and lexicographically." 43 (paths-find-site-directory roots "site-lisp"
43 (let ((path '())) 44 nil
44 (while directories 45 configure-site-directory))
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 46
52 (while raw-dirs 47 (defun paths-find-lisp-directory (roots)
53 (if (null (member (car raw-dirs) exclude)) 48 "Find the main Lisp directory of the XEmacs hierarchy."
54 (setq reverse-dirs 49 (paths-find-version-directory roots "lisp"
55 (cons (expand-file-name (car raw-dirs) directory) 50 nil
56 reverse-dirs))) 51 configure-lisp-directory))
57 (setq raw-dirs (cdr raw-dirs)))
58 52
59 (let ((sub-path 53 (defun paths-construct-load-path
60 (paths-find-recursive-path (reverse reverse-dirs) exclude))) 54 (roots early-package-load-path late-package-load-path
61 (setq path (nconc path 55 &optional inhibit-site-lisp)
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." 56 "Construct the load path."
323 (let ((envvar-value (getenv "EMACSLOADPATH"))) 57 (let ((envvar-value (getenv "EMACSLOADPATH")))
324 (if (and (fboundp 'parse-colon-path) envvar-value) 58 (if envvar-value
325 (parse-colon-path envvar-value) 59 (decode-path-internal envvar-value)
326 (let* ((site-lisp-directory 60 (let* ((site-lisp-directory
327 (and allow-site-lisp 61 (and (null inhibit-site-lisp)
328 (paths-find-site-directory roots "site-lisp" 62 (paths-find-site-lisp-directory roots)))
329 nil
330 configure-site-directory)))
331 (site-lisp-load-path 63 (site-lisp-load-path
332 (and site-lisp-directory 64 (and site-lisp-directory
333 (paths-find-recursive-load-path (list site-lisp-directory)))) 65 (paths-find-recursive-load-path (list site-lisp-directory))))
334 (lisp-directory 66 (lisp-directory (paths-find-lisp-directory roots))
335 (paths-find-version-directory roots "lisp"
336 nil
337 configure-lisp-directory))
338 (lisp-load-path 67 (lisp-load-path
339 (paths-find-recursive-load-path (list lisp-directory)))) 68 (paths-find-recursive-load-path (list lisp-directory))))
340 (nconc early-package-load-path 69 (append early-package-load-path
341 site-lisp-load-path 70 site-lisp-load-path
342 late-package-load-path 71 late-package-load-path
343 lisp-load-path))))) 72 lisp-load-path)))))
344 73
345 (defun paths-find-info-path (roots early-packages late-packages) 74 (defun paths-construct-info-path (roots early-packages late-packages)
346 "Construct the info path." 75 "Construct the info path."
347 (append 76 (append
348 (paths-find-package-info-path early-packages) 77 (packages-find-package-info-path early-packages)
349 (paths-find-package-info-path late-packages) 78 (packages-find-package-info-path late-packages)
350 (let ((info-directory 79 (let ((info-directory
351 (paths-find-version-directory roots "info" 80 (paths-find-version-directory roots "info"
352 nil 81 nil
353 (append 82 (append
354 (and configure-info-directory 83 (and configure-info-directory
355 (list configure-info-directory)) 84 (list configure-info-directory))
356 configure-info-path)))) 85 configure-info-path))))
357 (and info-directory 86 (and info-directory
358 (list info-directory))) 87 (list info-directory)))
359 (let ((info-path-envval (getenv "INFOPATH"))) 88 (let ((info-path-envval (getenv "INFOPATH")))
360 (if (and (fboundp 'parse-colon-path) info-path-envval) 89 (if info-path-envval
361 (parse-colon-path info-path-envval))))) 90 (decode-path-internal info-path-envval)))))
362 91
363 (defun paths-find-doc-directory (roots) 92 (defun paths-find-doc-directory (roots)
364 "Find the documentation directory." 93 "Find the documentation directory."
365 (paths-find-architecture-directory roots "lib-src")) 94 (paths-find-architecture-directory roots "lib-src"))
366 95
381 110
382 (defun paths-find-exec-directory (roots) 111 (defun paths-find-exec-directory (roots)
383 "Find the binary directory." 112 "Find the binary directory."
384 (paths-find-architecture-directory roots "lib-src")) 113 (paths-find-architecture-directory roots "lib-src"))
385 114
386 (defun paths-find-exec-path (roots exec-directory early-packages late-packages) 115 (defun paths-construct-exec-path (roots exec-directory early-packages late-packages)
387 "Find the binary path." 116 "Find the binary path."
388 (append 117 (append
389 (let ((path-envval (getenv "PATH"))) 118 (let ((path-envval (getenv "PATH")))
390 (and (fboundp 'parse-colon-path) path-envval 119 (if path-envval
391 (parse-colon-path path-envval))) 120 (decode-path-internal path-envval)))
392 (paths-find-package-exec-path early-packages) 121 (packages-find-package-exec-path early-packages)
393 (paths-find-package-exec-path late-packages) 122 (packages-find-package-exec-path late-packages)
394 (let ((emacspath-envval (getenv "EMACSPATH"))) 123 (let ((emacspath-envval (getenv "EMACSPATH")))
395 (if (and (fboundp 'parse-colon-path) emacspath-envval) 124 (if emacspath-envval
396 (parse-colon-path path-envval) 125 (decode-path-internal emacspath-envval)
397 (paths-directories-which-exist configure-exec-path))) 126 (paths-directories-which-exist configure-exec-path)))
398 (and exec-directory 127 (and exec-directory
399 (list exec-directory)))) 128 (list exec-directory))))
400 129
401 (defun paths-find-data-directory (roots) 130 (defun paths-find-data-directory (roots)
402 "Find the data directory." 131 "Find the data directory."
403 (paths-find-version-directory roots "etc" "EMACSDATA" configure-data-directory)) 132 (paths-find-version-directory roots "etc" "EMACSDATA" configure-data-directory))
404 133
405 (defun paths-find-data-directory-list (data-directory early-packages late-packages) 134 (defun paths-construct-data-directory-list (data-directory early-packages late-packages)
406 "Find the data path." 135 "Find the data path."
407 (append 136 (append
408 (paths-find-package-data-path early-packages) 137 (packages-find-package-data-path early-packages)
409 (paths-find-package-data-path late-packages) 138 (packages-find-package-data-path late-packages)
410 (list data-directory))) 139 (list data-directory)))
411 140
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 141 ;;; setup-paths.el ends here