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