Mercurial > hg > xemacs-beta
annotate lisp/find-paths.el @ 5305:09fed7053634
Handle slightly more complex type specifications, #'coerce, #'typep.
2010-11-17 Aidan Kehoe <kehoea@parhasard.net>
* cl-extra.el (coerce):
In the argument list, name the first argument OBJECT, not X; the
former name was always used in the doc string and is clearer.
Handle vector type specifications which include the length of the
target sequence, error if there's a mismatch.
* cl-macs.el (cl-make-type-test): Handle type specifications
starting with the symbol 'eql.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Wed, 17 Nov 2010 14:30:03 +0000 |
| parents | 9c6ea1581159 |
| children | 308d34e9f07d |
| rev | line source |
|---|---|
| 428 | 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 | |
| 1330 | 6 ;; Copyright (C) 2003 Ben Wing. |
| 428 | 7 |
| 2456 | 8 ;; Author: Mike Sperber <mike@xemacs.org> |
| 428 | 9 ;; Maintainer: XEmacs Development Team |
| 10 ;; Keywords: internal, dumped | |
| 11 | |
| 12 ;; This file is part of XEmacs. | |
| 13 | |
| 14 ;; XEmacs is free software; you can redistribute it and/or modify it | |
| 15 ;; under the terms of the GNU General Public License as published by | |
| 16 ;; the Free Software Foundation; either version 2, or (at your option) | |
| 17 ;; any later version. | |
| 18 | |
| 19 ;; XEmacs is distributed in the hope that it will be useful, but | |
| 20 ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
| 22 ;; General Public License for more details. | |
| 23 | |
| 24 ;; You should have received a copy of the GNU General Public License | |
| 25 ;; along with XEmacs; see the file COPYING. If not, write to the | |
| 26 ;; Free Software Foundation, 59 Temple Place - Suite 330, | |
| 27 ;; Boston, MA 02111-1307, USA. | |
| 28 | |
| 29 ;;; Synched up with: Not in FSF. | |
| 30 | |
| 31 ;;; Commentary: | |
| 32 | |
| 33 ;; This file is dumped with XEmacs. | |
| 34 | |
| 776 | 35 ;; This file contains basic library functionality for manipulating paths |
| 36 ;; and path lists and finding paths in the XEmacs hierarchy. | |
| 37 | |
| 428 | 38 |
| 39 ;;; Code: | |
| 40 | |
| 41 (defvar paths-version-control-filename-regexp | |
| 42 "^\\(RCS\\|CVS\\|SCCS\\)$" | |
| 43 "File bases associated with version control.") | |
| 44 | |
| 45 (defvar paths-lisp-filename-regexp | |
| 46 "^\\(.*\\.elc?\\)$" | |
| 2297 | 47 "File bases that name Emacs Lisp files.") |
| 428 | 48 |
| 49 (defvar paths-no-lisp-directory-regexp | |
| 50 (concat "\\(" paths-version-control-filename-regexp "\\)" | |
| 51 "\\|" | |
| 52 "\\(" paths-lisp-filename-regexp "\\)") | |
| 53 "File bases that may not be directories containing Lisp code.") | |
| 54 | |
| 55 (defun paths-find-recursive-path (directories &optional max-depth exclude-regexp) | |
| 56 "Return a list of the directory hierarchy underneath DIRECTORIES. | |
| 57 The returned list is sorted by pre-order and lexicographically. | |
| 58 MAX-DEPTH limits the depth of the search to MAX-DEPTH level, | |
| 59 if it is a number. If MAX-DEPTH is NIL, the search depth is unlimited. | |
| 60 EXCLUDE-REGEXP is a regexp that matches directory names to exclude | |
| 61 from the search." | |
| 62 (let ((path '())) | |
| 63 (while directories | |
| 64 (let ((directory (file-name-as-directory | |
| 65 (expand-file-name | |
| 66 (car directories))))) | |
| 67 (if (paths-file-readable-directory-p directory) | |
| 68 (let ((raw-entries | |
| 69 (if (equal 0 max-depth) | |
| 70 '() | |
| 71 (directory-files directory nil "^[^.-]"))) | |
| 72 (reverse-dirs '())) | |
| 73 (while raw-entries | |
| 531 | 74 (if (not (and exclude-regexp |
| 75 (string-match exclude-regexp (car raw-entries)))) | |
| 428 | 76 (setq reverse-dirs |
| 77 (cons (expand-file-name (car raw-entries) directory) | |
| 78 reverse-dirs))) | |
| 79 (setq raw-entries (cdr raw-entries))) | |
| 80 | |
| 81 (let ((sub-path | |
| 82 (paths-find-recursive-path (reverse reverse-dirs) | |
| 83 (if (numberp max-depth) | |
| 84 (- max-depth 1) | |
| 85 max-depth) | |
| 86 exclude-regexp))) | |
| 87 (setq path (nconc path | |
| 88 (list directory) | |
| 89 sub-path)))))) | |
| 90 (setq directories (cdr directories))) | |
| 91 path)) | |
| 92 | |
| 93 (defun paths-file-readable-directory-p (filename) | |
| 94 "Check if filename is a readable directory." | |
| 95 (and (file-directory-p filename) | |
| 96 (file-readable-p filename))) | |
| 97 | |
| 98 (defun paths-find-recursive-load-path (directories &optional max-depth) | |
| 99 "Construct a recursive load path underneath DIRECTORIES." | |
| 100 (paths-find-recursive-path directories | |
| 101 max-depth paths-no-lisp-directory-regexp)) | |
| 102 | |
| 103 (defun paths-chase-symlink (file-name) | |
| 104 "Chase a symlink until the bitter end." | |
| 105 (let ((maybe-symlink (file-symlink-p file-name))) | |
| 106 (if maybe-symlink | |
| 107 (let* ((directory (file-name-directory file-name)) | |
| 108 (destination (expand-file-name maybe-symlink directory))) | |
| 109 (paths-chase-symlink destination)) | |
| 110 file-name))) | |
| 111 | |
| 112 (defun paths-construct-path (components &optional expand-directory) | |
| 113 "Convert list of path components COMPONENTS into a path. | |
| 114 If EXPAND-DIRECTORY is non-NIL, use it as a directory to feed | |
| 115 to EXPAND-FILE-NAME." | |
| 116 (let* ((reverse-components (reverse components)) | |
| 117 (last-component (car reverse-components)) | |
| 118 (first-components (reverse (cdr reverse-components))) | |
| 119 (path | |
| 120 (apply #'concat | |
| 121 (append (mapcar #'file-name-as-directory first-components) | |
| 122 (list last-component))))) | |
| 123 (if expand-directory | |
| 124 (expand-file-name path expand-directory) | |
| 125 path))) | |
| 126 | |
| 127 (defun paths-construct-emacs-directory (root suffix base) | |
| 2456 | 128 "Construct a directory name within the XEmacs hierarchy. |
| 3753 | 129 ROOT must be an installation root. |
| 2456 | 130 SUFFIX is the subdirectory from there. |
| 131 BASE is the base to look for." | |
| 428 | 132 (file-name-as-directory |
| 133 (expand-file-name | |
| 134 (concat | |
| 135 (file-name-as-directory root) | |
| 136 suffix | |
| 137 base)))) | |
| 138 | |
| 2481 | 139 |
| 140 (defun paths-for-each-emacs-directory (func | |
| 4108 | 141 roots suffix bases |
| 2481 | 142 &optional envvar default keep-suffix) |
| 143 "Iterate over directories in the XEmacs hierarchy. | |
| 144 FUNC is a function that called for each directory, with the directory | |
| 145 as the only argument. | |
| 428 | 146 ROOTS must be a list of installation roots. |
| 147 SUFFIX is the subdirectory from there. | |
| 4108 | 148 BASEA is a list of possible bases to look for. |
| 428 | 149 ENVVAR is the name of the environment variable that might also |
| 150 specify the directory. | |
| 151 DEFAULT is the preferred value. | |
| 152 If KEEP-SUFFIX is non-nil, the suffix must be respected in searching | |
| 1218 | 153 the directory." |
| 428 | 154 (let ((preferred-value (or (and envvar (getenv envvar)) |
| 155 default))) | |
| 156 (if (and preferred-value | |
| 157 (paths-file-readable-directory-p preferred-value)) | |
| 158 (file-name-as-directory preferred-value) | |
| 2481 | 159 (while roots |
| 4108 | 160 (let ((root (car roots)) |
| 161 (bases bases)) | |
| 162 (while bases | |
| 163 (let* ((base (car bases)) | |
| 164 ;; installed | |
| 165 (path (paths-construct-emacs-directory root suffix base))) | |
| 166 (if (paths-file-readable-directory-p path) | |
| 167 (funcall func path) | |
| 168 ;; in-place | |
| 169 (if (null keep-suffix) | |
| 170 (let ((path (paths-construct-emacs-directory root "" base))) | |
| 171 (if (paths-file-readable-directory-p path) | |
| 172 (funcall func path)))))) | |
| 173 (setq bases (cdr bases)))) | |
| 2481 | 174 (setq roots (cdr roots)))))) |
| 175 | |
| 176 (defun paths-find-emacs-directories (roots | |
| 4108 | 177 suffix bases |
| 2481 | 178 &optional envvar default keep-suffix) |
| 179 "Find a list of directories in the XEmacs hierarchy. | |
| 180 ROOTS must be a list of installation roots. | |
| 181 SUFFIX is the subdirectory from there. | |
| 4108 | 182 BASES is a list of bases to look for. |
| 2481 | 183 ENVVAR is the name of the environment variable that might also |
| 184 specify the directory. | |
| 185 DEFAULT is the preferred value. | |
| 186 If KEEP-SUFFIX is non-nil, the suffix must be respected in searching | |
| 187 the directory." | |
| 188 (let ((l '())) | |
| 189 (paths-for-each-emacs-directory #'(lambda (dir) | |
| 190 (setq l (cons dir l))) | |
| 191 roots | |
| 4108 | 192 suffix bases |
| 2481 | 193 envvar default keep-suffix) |
| 194 (reverse l))) | |
| 195 | |
| 4108 | 196 (defun paths-find-emacs-directory (roots suffix bases |
| 2481 | 197 &optional envvar default keep-suffix) |
| 198 "Find a directory in the XEmacs hierarchy. | |
| 199 ROOTS must be a list of installation roots. | |
| 200 SUFFIX is the subdirectory from there. | |
| 4108 | 201 BASES is a list of possible bases to look for. |
| 2481 | 202 ENVVAR is the name of the environment variable that might also |
| 203 specify the directory. | |
| 204 DEFAULT is the preferred value. | |
| 205 If KEEP-SUFFIX is non-nil, the suffix must be respected in searching | |
| 206 the directory." | |
| 207 (catch 'gotcha | |
| 208 (paths-for-each-emacs-directory #'(lambda (dir) | |
| 209 (throw 'gotcha dir)) | |
| 210 roots | |
| 4108 | 211 suffix bases |
| 2481 | 212 envvar default keep-suffix))) |
| 213 | |
| 4108 | 214 (defun paths-for-each-site-directory (func |
| 215 roots bases | |
| 216 arch-dependent-p | |
| 217 &optional envvar default) | |
| 2481 | 218 "Iterate over the site-specific directories in the XEmacs hierarchy. |
| 219 FUNC is a function that called for each directory, with the directory | |
| 220 as the only argument. | |
| 3753 | 221 ROOTS must be a list of installation roots. |
| 4108 | 222 BASES is a list of possible bases to look for. |
| 4092 | 223 ARCH-DEPENDENT-P says whether the file is architecture-specific. |
| 2481 | 224 ENVVAR is the name of the environment variable that might also |
| 225 specify the directory. | |
| 226 DEFAULT is the preferred value." | |
| 227 (paths-for-each-emacs-directory func | |
| 228 roots | |
| 229 (file-name-as-directory | |
| 230 (paths-construct-path (list | |
| 4092 | 231 (if arch-dependent-p "lib" "share") |
| 2481 | 232 emacs-program-name))) |
| 4108 | 233 bases |
| 2481 | 234 envvar default)) |
| 428 | 235 |
| 4108 | 236 (defun paths-find-site-directory (roots bases arch-dependent-p &optional envvar default) |
| 2456 | 237 "Find a site-specific directory in the XEmacs hierarchy. |
| 3753 | 238 ROOTS must be a list of installation roots. |
| 4108 | 239 BASES is a list of possible bases to look for. |
| 4092 | 240 ARCH-DEPENDENT-P says whether the file is architecture-specific. |
| 2456 | 241 ENVVAR is the name of the environment variable that might also |
| 242 specify the directory. | |
| 243 DEFAULT is the preferred value." | |
| 2481 | 244 (catch 'gotcha |
| 245 (paths-for-each-site-directory #'(lambda (dir) | |
| 246 (throw 'gotcha dir)) | |
| 4108 | 247 roots bases arch-dependent-p |
| 2481 | 248 envvar default))) |
| 428 | 249 |
| 4108 | 250 (defun paths-find-site-directories (roots bases arch-dependent-p &optional envvar default) |
| 2481 | 251 "Find a list of site-specific directories in the XEmacs hierarchy. |
| 3753 | 252 ROOTS must be a list of installation roots. |
| 4108 | 253 BASES is a list of bases to look for. |
| 4092 | 254 ARCH-DEPENDENT-P says whether the file is architecture-specific. |
| 2481 | 255 ENVVAR is the name of the environment variable that might also |
| 256 specify the directory. | |
| 257 DEFAULT is the preferred value." | |
| 258 (let ((l '())) | |
| 259 (paths-for-each-site-directory #'(lambda (dir) | |
| 260 (setq l (cons dir l))) | |
| 4108 | 261 roots bases arch-dependent-p |
| 2481 | 262 envvar default) |
| 263 (reverse l))) | |
| 2456 | 264 |
| 4108 | 265 (defun paths-for-each-version-directory (func roots bases arch-dependent-p |
| 2481 | 266 &optional envvar default enforce-version) |
| 267 "Iterate over version-specific directories in the XEmacs hierarchy. | |
| 268 FUNC is a function that called for each directory, with the directory | |
| 269 as the only argument. | |
| 3753 | 270 ROOTS must be a list of installation roots. |
| 4108 | 271 BASES is a list of possible bases to look for. |
| 4092 | 272 ARCH-DEPENDENT-P says whether the file is architecture-specific. |
| 2456 | 273 ENVVAR is the name of the environment variable that might also |
| 274 specify the directory. | |
| 275 DEFAULT is the preferred value. | |
| 428 | 276 If ENFORCE-VERSION is non-nil, the directory must contain the XEmacs version." |
| 2481 | 277 (paths-for-each-emacs-directory func |
| 278 roots | |
| 279 (file-name-as-directory | |
| 280 (paths-construct-path | |
| 4092 | 281 (list (if arch-dependent-p "lib" "share") |
| 2481 | 282 (construct-emacs-version-name)))) |
| 4108 | 283 bases |
| 2481 | 284 envvar default)) |
| 285 | |
| 4108 | 286 (defun paths-find-version-directory (roots bases arch-dependent-p |
| 2481 | 287 &optional envvar default enforce-version) |
| 288 "Find a version-specific directory in the XEmacs hierarchy. | |
| 3753 | 289 ROOTS must be a list of installation roots. |
| 4108 | 290 BASES is a list of possible bases to look for. |
| 4092 | 291 ARCH-DEPENDENT-P says whether the file is architecture-specific. |
| 2481 | 292 ENVVAR is the name of the environment variable that might also |
| 293 specify the directory. | |
| 294 DEFAULT is the preferred value. | |
| 295 If ENFORCE-VERSION is non-nil, the directory must contain the XEmacs version." | |
| 296 (catch 'gotcha | |
| 297 (paths-for-each-version-directory #'(lambda (dir) | |
| 298 (throw 'gotcha dir)) | |
| 4108 | 299 roots bases arch-dependent-p |
| 2481 | 300 envvar default))) |
| 301 | |
| 4108 | 302 (defun paths-find-version-directories (roots bases arch-dependent-p |
| 2481 | 303 &optional envvar default enforce-version) |
| 304 "Find a list of version-specific directories in the XEmacs hierarchy. | |
| 3753 | 305 ROOTS must be a list of installation roots. |
| 4108 | 306 BASES is a list of possible bases to look for. |
| 4092 | 307 ARCH-DEPENDENT-P says whether the file is architecture-specific. |
| 2481 | 308 ENVVAR is the name of the environment variable that might also |
| 309 specify the directory. | |
| 310 DEFAULT is the preferred value. | |
| 311 If ENFORCE-VERSION is non-nil, the directory must contain the XEmacs version." | |
| 312 (let ((l '())) | |
| 4092 | 313 (paths-for-each-version-directory #'(lambda (dir) |
| 314 (setq l (cons dir l))) | |
| 4108 | 315 roots bases arch-dependent-p |
| 4092 | 316 envvar default) |
| 2481 | 317 (reverse l))) |
| 428 | 318 |
| 4108 | 319 (defun paths-find-architecture-directory (roots bases &optional envvar default) |
| 2456 | 320 "Find an architecture-specific directory in the XEmacs hierarchy. |
| 3753 | 321 ROOTS must be a list of installation roots. |
| 4108 | 322 BASES is a list of possible bases to look for. |
| 2456 | 323 ENVVAR is the name of the environment variable that might also |
| 324 specify the directory. | |
| 325 DEFAULT is the preferred value." | |
| 4108 | 326 (paths-find-version-directory roots |
| 327 ;; from more to less specific | |
| 328 (append | |
| 329 (mapcar | |
| 330 #'(lambda (base) | |
| 331 (paths-construct-path | |
| 332 (list system-configuration base))) | |
| 333 bases) | |
| 334 bases | |
| 335 (list system-configuration)) | |
| 336 t | |
| 337 envvar default)) | |
| 428 | 338 |
| 339 (defun construct-emacs-version-name () | |
| 2456 | 340 "Construct a string from the raw XEmacs version number." |
| 428 | 341 (concat emacs-program-name "-" emacs-program-version)) |
| 342 | |
| 343 (defun paths-directories-which-exist (directories) | |
| 2456 | 344 "Return the directories among DIRECTORIES. |
| 345 DIRECTORIES is a list of strings." | |
| 428 | 346 (let ((reverse-directories '())) |
| 347 (while directories | |
| 348 (if (paths-file-readable-directory-p (car directories)) | |
| 349 (setq reverse-directories | |
| 350 (cons (car directories) | |
| 351 reverse-directories))) | |
| 352 (setq directories (cdr directories))) | |
| 353 (reverse reverse-directories))) | |
| 354 | |
| 355 (defun paths-decode-directory-path (string &optional drop-empties) | |
| 356 "Split STRING at path separators into a directory list. | |
| 442 | 357 Non-\"\" components are converted into directory form. |
| 428 | 358 If DROP-EMPTIES is non-NIL, \"\" components are dropped from the output. |
| 359 Otherwise, they are left alone." | |
| 360 (let* ((components (split-path string)) | |
| 361 (directories | |
| 362 (mapcar #'(lambda (component) | |
| 363 (if (string-equal "" component) | |
| 364 component | |
| 365 (file-name-as-directory component))) | |
| 366 components))) | |
| 367 (if drop-empties | |
|
4919
9c6ea1581159
Remove a couple of XEmacs-specific duplicate functions, find-paths.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
4108
diff
changeset
|
368 (delete "" directories) |
| 428 | 369 directories))) |
| 370 | |
| 371 ;;; find-paths.el ends here |