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