cgit.sxemacs.org Git - sxemacs/blob - lisp/find-paths.el

   1 ;;; find-paths.el --- setup various SXEmacs 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: SXEmacs Development Team
   9 ;; Keywords: internal, dumped
  10
  11 ;; This file is part of SXEmacs.
  12
  13 ;; SXEmacs is free software: you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation, either version 3 of the License, or
  16 ;; (at your option) any later version.
  17
  18 ;; SXEmacs is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  25
  26 ;;; Synched up with: Not in FSF.
  27
  28 ;;; Commentary:
  29
  30 ;; This file is dumped with SXEmacs.
  31
  32 ;; This file contains the library functionality to find paths into the
  33 ;; SXEmacs hierarchy.
  34 \f
  35 ;;; Code:
  36
  37 (defvar paths-version-control-filename-regexp
  38   #r"^\(RCS\|CVS\|SCCS\|.arch-ids\|.arch-inventory\|{arch}\)$"
  39   "File bases associated with version control.")
  40
  41 (defvar paths-lisp-filename-regexp
  42   #r"^\(.*\.elc?\)$"
  43   "File bases that contain Lisp file.")
  44
  45 (defvar paths-no-lisp-directory-regexp
  46   (concat "\\(" paths-version-control-filename-regexp "\\)"
  47           "\\|"
  48           "\\(" paths-lisp-filename-regexp "\\)")
  49   "File bases that may not be directories containing Lisp code.")
  50
  51 (defun paths-find-recursive-path (directories &optional max-depth exclude-regexp)
  52   "Return a list of the directory hierarchy underneath DIRECTORIES.
  53 The returned list is sorted by pre-order and lexicographically.
  54 MAX-DEPTH limits the depth of the search to MAX-DEPTH level,
  55 if it is a number.  If MAX-DEPTH is NIL, the search depth is unlimited.
  56 EXCLUDE-REGEXP is a regexp that matches directory names to exclude
  57 from the search."
  58   (let ((path '()))
  59     (while directories
  60       (let ((directory (file-name-as-directory
  61                         (expand-file-name
  62                          (car directories)))))
  63         (if (paths-file-readable-directory-p directory)
  64             (let ((raw-entries
  65                    (if (equal 0 max-depth)
  66                        '()
  67                      (directory-files directory nil "^[^.-]")))
  68                   (reverse-dirs '()))
  69               (while raw-entries
  70                 (if (not (and exclude-regexp
  71                               (string-match exclude-regexp (car raw-entries))))
  72                     (setq reverse-dirs
  73                           (cons (expand-file-name (car raw-entries) directory)
  74                                 reverse-dirs)))
  75                 (setq raw-entries (cdr raw-entries)))
  76
  77               (let ((sub-path
  78                      (paths-find-recursive-path (reverse reverse-dirs)
  79                                                 (if (numberp max-depth)
  80                                                     (- max-depth 1)
  81                                                   max-depth)
  82                                                 exclude-regexp)))
  83                 (setq path (nconc path
  84                                   (list directory)
  85                                   sub-path))))))
  86       (setq directories (cdr directories)))
  87     path))
  88
  89 (defun paths-file-readable-directory-p (filename)
  90   "Check if filename is a readable directory."
  91   (and (file-directory-p filename)
  92        (file-readable-p filename)))
  93
  94 (defun paths-find-recursive-load-path (directories &optional max-depth)
  95   "Construct a recursive load path underneath DIRECTORIES."
  96   (paths-find-recursive-path directories
  97                              max-depth paths-no-lisp-directory-regexp))
  98
  99 (defun paths-emacs-root-p (directory)
 100   "Check if DIRECTORY is a plausible installation root for XEmacs."
 101   (or
 102    ;; installed
 103    (paths-file-readable-directory-p (paths-construct-path
 104                                      (list directory
 105                                            "lib"
 106                                            (construct-emacs-version-name))))
 107    (paths-file-readable-directory-p (paths-construct-path
 108                                      (list directory
 109                                            "share"
 110                                            (construct-emacs-version-name))))
 111    ;; inplace
 112    (and
 113     (paths-file-readable-directory-p (paths-construct-path
 114                                       (list directory "lisp")))
 115     (paths-file-readable-directory-p (paths-construct-path
 116                                       (list directory "etc"))))))
 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-emacs-root
 132   (invocation-directory invocation-name)
 133   "Find the run-time root of XEmacs."
 134   (let* ((executable-file-name (paths-chase-symlink
 135                                 (concat invocation-directory
 136                                         invocation-name)))
 137          (executable-directory (file-name-directory executable-file-name))
 138          (maybe-root-1 (file-name-as-directory
 139                         (paths-construct-path '("..") executable-directory)))
 140          (maybe-root-2 (file-name-as-directory
 141                         (paths-construct-path '(".." "..") executable-directory))))
 142     (or (and (paths-emacs-root-p maybe-root-1)
 143              maybe-root-1)
 144         (and (paths-emacs-root-p maybe-root-2)
 145              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-archindep-directory
 213   (roots base &optional envvar default in-place-external)
 214   "Find a site-specific directory in the XEmacs hierarchy.
 215 If IN-PLACE-EXTERNAL is non-nil, the directory might be found outside
 216 an in-place root-hierarchy."
 217   (paths-find-emacs-directory roots
 218                               (file-name-as-directory
 219                                (paths-construct-path (list
 220                                                       "share"
 221                                                       emacs-program-name)))
 222                               base
 223                               envvar default
 224                               nil
 225                               in-place-external))
 226
 227 (defun paths-find-site-archdep-directory
 228   (roots base &optional envvar default in-place-external)
 229   "Find a site-specific directory in the XEmacs hierarchy.
 230 If IN-PLACE-EXTERNAL is non-nil, the directory might be found outside
 231 an in-place root-hierarchy."
 232   (paths-find-emacs-directory roots
 233                               (file-name-as-directory
 234                                (paths-construct-path (list
 235                                                       "lib"
 236                                                       emacs-program-name
 237                                                       system-configuration)))
 238                               base
 239                               envvar default
 240                               nil
 241                               in-place-external))
 242
 243 ;; we default to the arch-independent directory atm
 244 (defalias 'paths-find-site-directory #'paths-find-site-archindep-directory)
 245
 246 (defun paths-find-version-archdep-directory
 247   (roots base &optional envvar default enforce-version)
 248   "Find a version-specific directory in the SXEmacs hierarchy.
 249 If ENFORCE-VERSION is non-nil, the directory must contain the SXEmacs version."
 250    ;; look for lib/sxemacs-xx.y.z
 251    ;; what do we do if user specifies --libdir?
 252    (paths-find-emacs-directory roots
 253                                (file-name-as-directory
 254                                 (paths-construct-path
 255                                  (list "lib"
 256                                        (construct-emacs-version-name))))
 257                                base
 258                                envvar default
 259                                enforce-version))
 260
 261 (defun paths-find-version-archindep-directory
 262   (roots base &optional envvar default enforce-version)
 263   "Find a version-specific directory in the SXEmacs hierarchy.
 264 If ENFORCE-VERSION is non-nil, the directory must contain the SXEmacs version."
 265    ;; look for share/sxemacs-xx.y.z
 266    (paths-find-emacs-directory roots
 267                                (file-name-as-directory
 268                                 (paths-construct-path
 269                                  (list "share"
 270                                        (construct-emacs-version-name))))
 271                                base
 272                                envvar default
 273                                enforce-version))
 274
 275 ;; we default to the arch-independent directory atm
 276 (defalias 'path-find-version-directory #'paths-find-version-archindep-directory)
 277
 278 (defun paths-find-architecture-directory (roots base &optional envvar default)
 279   "Find an architecture-specific directory in the XEmacs hierarchy."
 280   (or
 281    ;; from more to less specific
 282    (paths-find-version-archdep-directory roots
 283                                          (paths-construct-path
 284                                           (list system-configuration base))
 285                                          envvar default)
 286    (paths-find-version-archdep-directory roots
 287                                          base
 288                                          envvar)
 289    (paths-find-version-archdep-directory roots
 290                                          system-configuration
 291                                          envvar)))
 292
 293 (defun construct-emacs-version-name ()
 294   "Construct the raw XEmacs version number."
 295   (concat emacs-program-name "-" emacs-program-version))
 296
 297 (defun paths-directories-which-exist (directories)
 298   "Return the directories among DIRECTORIES."
 299   (let ((reverse-directories '()))
 300     (while directories
 301       (if (paths-file-readable-directory-p (car directories))
 302           (setq reverse-directories
 303                 (cons (car directories)
 304                       reverse-directories)))
 305       (setq directories (cdr directories)))
 306     (reverse reverse-directories)))
 307
 308 (defun paths-uniq-append (list-1 list-2)
 309   "Append LIST-1 and LIST-2, omitting duplicates."
 310   (let ((reverse-survivors '()))
 311     (while list-2
 312       (if (null (member (car list-2) list-1))
 313           (setq reverse-survivors (cons (car list-2) reverse-survivors)))
 314       (setq list-2 (cdr list-2)))
 315     (append list-1
 316             (reverse reverse-survivors))))
 317
 318 (defun paths-filter (predicate list)
 319   "Delete all matches of PREDICATE from LIST."
 320   (let ((reverse-result '()))
 321     (while list
 322       (if (funcall predicate (car list))
 323           (setq reverse-result (cons (car list) reverse-result)))
 324       (setq list (cdr list)))
 325     (nreverse reverse-result)))
 326
 327 (defun paths-decode-directory-path (string &optional drop-empties)
 328   "Split STRING at path separators into a directory list.
 329 Non-\"\" components are converted into directory form.
 330 If DROP-EMPTIES is non-NIL, \"\" components are dropped from the output.
 331 Otherwise, they are left alone."
 332   (let* ((components (split-path string))
 333          (directories
 334           (mapcar #'(lambda (component)
 335                       (if (string-equal "" component)
 336                           component
 337                         (file-name-as-directory component)))
 338                   components)))
 339     (if drop-empties
 340         (paths-filter #'(lambda (component)
 341                           (null (string-equal "" component)))
 342                       directories)
 343       directories)))
 344
 345 (defun paths-find-emacs-roots (invocation-directory
 346                                invocation-name &optional dumpp)
 347   "Find all plausible installation roots for SXEmacs."
 348   (let* ((potential-invocation-root
 349           (paths-find-emacs-root
 350            invocation-directory invocation-name))
 351          (invocation-roots nil)
 352          (potential-installation-roots
 353           (when (null dumpp)
 354             (paths-uniq-append
 355              (and configure-exec-prefix-directory
 356                   (list (file-name-as-directory
 357                          configure-exec-prefix-directory)))
 358              (and configure-prefix-directory
 359                   (list (file-name-as-directory
 360                          configure-prefix-directory))))))
 361          (installation-roots
 362           (paths-filter #'paths-emacs-root-p potential-installation-roots))
 363          (source-tree-root
 364           (or (getenv "SOURCE_TREE_ROOT")
 365               (and potential-invocation-root
 366                    (file-exists-p
 367                     (expand-file-name ".sxemacs.source.tree"
 368                                       potential-invocation-root))
 369                    (file-truename
 370                     (expand-file-name ".sxemacs.source.tree"
 371                                       potential-invocation-root)))))
 372          (build-tree-root
 373           (getenv "BUILD_TREE_ROOT")))
 374     (when source-tree-root
 375       (setq invocation-roots (cons source-tree-root invocation-roots)
 376             invocation-roots (cons (or configure-prefix-directory
 377                                        configure-exec-prefix-directory
 378                                        "/usr/local")
 379                                    invocation-roots)))
 380     (when build-tree-root
 381       (setq invocation-roots (cons build-tree-root invocation-roots)
 382             invocation-roots (cons (or configure-prefix-directory
 383                                        configure-exec-prefix-directory
 384                                        "/usr/local")
 385                                    invocation-roots)))
 386     (when potential-invocation-root
 387       (setq invocation-roots (cons potential-invocation-root invocation-roots)))
 388     (paths-uniq-append invocation-roots installation-roots)))
 389
 390 ;;; find-paths.el ends here