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