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