Mercurial > hg > xemacs-beta
annotate lisp/find-paths.el @ 5818:15b0715c204d
Avoid passing patterns to with charset property to FcNameUnparse.
Prevents crash reported by Raymond Toy.
| author | Stephen J. Turnbull <stephen@xemacs.org> |
|---|---|
| date | Sat, 18 Oct 2014 21:20:42 +0900 |
| parents | 308d34e9f07d |
| children |
| 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 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4919
diff
changeset
|
14 ;; XEmacs is free software: you can redistribute it and/or modify it |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4919
diff
changeset
|
15 ;; under the terms of the GNU General Public License as published by the |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4919
diff
changeset
|
16 ;; Free Software Foundation, either version 3 of the License, or (at your |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4919
diff
changeset
|
17 ;; option) any later version. |
| 428 | 18 |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4919
diff
changeset
|
19 ;; XEmacs is distributed in the hope that it will be useful, but WITHOUT |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4919
diff
changeset
|
20 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4919
diff
changeset
|
21 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4919
diff
changeset
|
22 ;; for more details. |
| 428 | 23 |
| 24 ;; You should have received a copy of the GNU General Public License | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4919
diff
changeset
|
25 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>. |
| 428 | 26 |
| 27 ;;; Synched up with: Not in FSF. | |
| 28 | |
| 29 ;;; Commentary: | |
| 30 | |
| 31 ;; This file is dumped with XEmacs. | |
| 32 | |
| 776 | 33 ;; This file contains basic library functionality for manipulating paths |
| 34 ;; and path lists and finding paths in the XEmacs hierarchy. | |
| 35 | |
| 428 | 36 |
| 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?\\)$" | |
| 2297 | 45 "File bases that name Emacs Lisp files.") |
| 428 | 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 | |
| 531 | 72 (if (not (and exclude-regexp |
| 73 (string-match exclude-regexp (car raw-entries)))) | |
| 428 | 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-chase-symlink (file-name) | |
| 102 "Chase a symlink until the bitter end." | |
| 103 (let ((maybe-symlink (file-symlink-p file-name))) | |
| 104 (if maybe-symlink | |
| 105 (let* ((directory (file-name-directory file-name)) | |
| 106 (destination (expand-file-name maybe-symlink directory))) | |
| 107 (paths-chase-symlink destination)) | |
| 108 file-name))) | |
| 109 | |
| 110 (defun paths-construct-path (components &optional expand-directory) | |
| 111 "Convert list of path components COMPONENTS into a path. | |
| 112 If EXPAND-DIRECTORY is non-NIL, use it as a directory to feed | |
| 113 to EXPAND-FILE-NAME." | |
| 114 (let* ((reverse-components (reverse components)) | |
| 115 (last-component (car reverse-components)) | |
| 116 (first-components (reverse (cdr reverse-components))) | |
| 117 (path | |
| 118 (apply #'concat | |
| 119 (append (mapcar #'file-name-as-directory first-components) | |
| 120 (list last-component))))) | |
| 121 (if expand-directory | |
| 122 (expand-file-name path expand-directory) | |
| 123 path))) | |
| 124 | |
| 125 (defun paths-construct-emacs-directory (root suffix base) | |
| 2456 | 126 "Construct a directory name within the XEmacs hierarchy. |
| 3753 | 127 ROOT must be an installation root. |
| 2456 | 128 SUFFIX is the subdirectory from there. |
| 129 BASE is the base to look for." | |
| 428 | 130 (file-name-as-directory |
| 131 (expand-file-name | |
| 132 (concat | |
| 133 (file-name-as-directory root) | |
| 134 suffix | |
| 135 base)))) | |
| 136 | |
| 2481 | 137 |
| 138 (defun paths-for-each-emacs-directory (func | |
| 4108 | 139 roots suffix bases |
| 2481 | 140 &optional envvar default keep-suffix) |
| 141 "Iterate over directories in the XEmacs hierarchy. | |
| 142 FUNC is a function that called for each directory, with the directory | |
| 143 as the only argument. | |
| 428 | 144 ROOTS must be a list of installation roots. |
| 145 SUFFIX is the subdirectory from there. | |
| 4108 | 146 BASEA is a list of possible bases to look for. |
| 428 | 147 ENVVAR is the name of the environment variable that might also |
| 148 specify the directory. | |
| 149 DEFAULT is the preferred value. | |
| 150 If KEEP-SUFFIX is non-nil, the suffix must be respected in searching | |
| 1218 | 151 the directory." |
| 428 | 152 (let ((preferred-value (or (and envvar (getenv envvar)) |
| 153 default))) | |
| 154 (if (and preferred-value | |
| 155 (paths-file-readable-directory-p preferred-value)) | |
| 156 (file-name-as-directory preferred-value) | |
| 2481 | 157 (while roots |
| 4108 | 158 (let ((root (car roots)) |
| 159 (bases bases)) | |
| 160 (while bases | |
| 161 (let* ((base (car bases)) | |
| 162 ;; installed | |
| 163 (path (paths-construct-emacs-directory root suffix base))) | |
| 164 (if (paths-file-readable-directory-p path) | |
| 165 (funcall func path) | |
| 166 ;; in-place | |
| 167 (if (null keep-suffix) | |
| 168 (let ((path (paths-construct-emacs-directory root "" base))) | |
| 169 (if (paths-file-readable-directory-p path) | |
| 170 (funcall func path)))))) | |
| 171 (setq bases (cdr bases)))) | |
| 2481 | 172 (setq roots (cdr roots)))))) |
| 173 | |
| 174 (defun paths-find-emacs-directories (roots | |
| 4108 | 175 suffix bases |
| 2481 | 176 &optional envvar default keep-suffix) |
| 177 "Find a list of directories in the XEmacs hierarchy. | |
| 178 ROOTS must be a list of installation roots. | |
| 179 SUFFIX is the subdirectory from there. | |
| 4108 | 180 BASES is a list of bases to look for. |
| 2481 | 181 ENVVAR is the name of the environment variable that might also |
| 182 specify the directory. | |
| 183 DEFAULT is the preferred value. | |
| 184 If KEEP-SUFFIX is non-nil, the suffix must be respected in searching | |
| 185 the directory." | |
| 186 (let ((l '())) | |
| 187 (paths-for-each-emacs-directory #'(lambda (dir) | |
| 188 (setq l (cons dir l))) | |
| 189 roots | |
| 4108 | 190 suffix bases |
| 2481 | 191 envvar default keep-suffix) |
| 192 (reverse l))) | |
| 193 | |
| 4108 | 194 (defun paths-find-emacs-directory (roots suffix bases |
| 2481 | 195 &optional envvar default keep-suffix) |
| 196 "Find a directory in the XEmacs hierarchy. | |
| 197 ROOTS must be a list of installation roots. | |
| 198 SUFFIX is the subdirectory from there. | |
| 4108 | 199 BASES is a list of possible bases to look for. |
| 2481 | 200 ENVVAR is the name of the environment variable that might also |
| 201 specify the directory. | |
| 202 DEFAULT is the preferred value. | |
| 203 If KEEP-SUFFIX is non-nil, the suffix must be respected in searching | |
| 204 the directory." | |
| 205 (catch 'gotcha | |
| 206 (paths-for-each-emacs-directory #'(lambda (dir) | |
| 207 (throw 'gotcha dir)) | |
| 208 roots | |
| 4108 | 209 suffix bases |
| 2481 | 210 envvar default keep-suffix))) |
| 211 | |
| 4108 | 212 (defun paths-for-each-site-directory (func |
| 213 roots bases | |
| 214 arch-dependent-p | |
| 215 &optional envvar default) | |
| 2481 | 216 "Iterate over the site-specific directories in the XEmacs hierarchy. |
| 217 FUNC is a function that called for each directory, with the directory | |
| 218 as the only argument. | |
| 3753 | 219 ROOTS must be a list of installation roots. |
| 4108 | 220 BASES is a list of possible bases to look for. |
| 4092 | 221 ARCH-DEPENDENT-P says whether the file is architecture-specific. |
| 2481 | 222 ENVVAR is the name of the environment variable that might also |
| 223 specify the directory. | |
| 224 DEFAULT is the preferred value." | |
| 225 (paths-for-each-emacs-directory func | |
| 226 roots | |
| 227 (file-name-as-directory | |
| 228 (paths-construct-path (list | |
| 4092 | 229 (if arch-dependent-p "lib" "share") |
| 2481 | 230 emacs-program-name))) |
| 4108 | 231 bases |
| 2481 | 232 envvar default)) |
| 428 | 233 |
| 4108 | 234 (defun paths-find-site-directory (roots bases arch-dependent-p &optional envvar default) |
| 2456 | 235 "Find a site-specific directory in the XEmacs hierarchy. |
| 3753 | 236 ROOTS must be a list of installation roots. |
| 4108 | 237 BASES is a list of possible bases to look for. |
| 4092 | 238 ARCH-DEPENDENT-P says whether the file is architecture-specific. |
| 2456 | 239 ENVVAR is the name of the environment variable that might also |
| 240 specify the directory. | |
| 241 DEFAULT is the preferred value." | |
| 2481 | 242 (catch 'gotcha |
| 243 (paths-for-each-site-directory #'(lambda (dir) | |
| 244 (throw 'gotcha dir)) | |
| 4108 | 245 roots bases arch-dependent-p |
| 2481 | 246 envvar default))) |
| 428 | 247 |
| 4108 | 248 (defun paths-find-site-directories (roots bases arch-dependent-p &optional envvar default) |
| 2481 | 249 "Find a list of site-specific directories in the XEmacs hierarchy. |
| 3753 | 250 ROOTS must be a list of installation roots. |
| 4108 | 251 BASES is a list of bases to look for. |
| 4092 | 252 ARCH-DEPENDENT-P says whether the file is architecture-specific. |
| 2481 | 253 ENVVAR is the name of the environment variable that might also |
| 254 specify the directory. | |
| 255 DEFAULT is the preferred value." | |
| 256 (let ((l '())) | |
| 257 (paths-for-each-site-directory #'(lambda (dir) | |
| 258 (setq l (cons dir l))) | |
| 4108 | 259 roots bases arch-dependent-p |
| 2481 | 260 envvar default) |
| 261 (reverse l))) | |
| 2456 | 262 |
| 4108 | 263 (defun paths-for-each-version-directory (func roots bases arch-dependent-p |
| 2481 | 264 &optional envvar default enforce-version) |
| 265 "Iterate over version-specific directories in the XEmacs hierarchy. | |
| 266 FUNC is a function that called for each directory, with the directory | |
| 267 as the only argument. | |
| 3753 | 268 ROOTS must be a list of installation roots. |
| 4108 | 269 BASES is a list of possible bases to look for. |
| 4092 | 270 ARCH-DEPENDENT-P says whether the file is architecture-specific. |
| 2456 | 271 ENVVAR is the name of the environment variable that might also |
| 272 specify the directory. | |
| 273 DEFAULT is the preferred value. | |
| 428 | 274 If ENFORCE-VERSION is non-nil, the directory must contain the XEmacs version." |
| 2481 | 275 (paths-for-each-emacs-directory func |
| 276 roots | |
| 277 (file-name-as-directory | |
| 278 (paths-construct-path | |
| 4092 | 279 (list (if arch-dependent-p "lib" "share") |
| 2481 | 280 (construct-emacs-version-name)))) |
| 4108 | 281 bases |
| 2481 | 282 envvar default)) |
| 283 | |
| 4108 | 284 (defun paths-find-version-directory (roots bases arch-dependent-p |
| 2481 | 285 &optional envvar default enforce-version) |
| 286 "Find a version-specific directory in the XEmacs hierarchy. | |
| 3753 | 287 ROOTS must be a list of installation roots. |
| 4108 | 288 BASES is a list of possible bases to look for. |
| 4092 | 289 ARCH-DEPENDENT-P says whether the file is architecture-specific. |
| 2481 | 290 ENVVAR is the name of the environment variable that might also |
| 291 specify the directory. | |
| 292 DEFAULT is the preferred value. | |
| 293 If ENFORCE-VERSION is non-nil, the directory must contain the XEmacs version." | |
| 294 (catch 'gotcha | |
| 295 (paths-for-each-version-directory #'(lambda (dir) | |
| 296 (throw 'gotcha dir)) | |
| 4108 | 297 roots bases arch-dependent-p |
| 2481 | 298 envvar default))) |
| 299 | |
| 4108 | 300 (defun paths-find-version-directories (roots bases arch-dependent-p |
| 2481 | 301 &optional envvar default enforce-version) |
| 302 "Find a list of version-specific directories in the XEmacs hierarchy. | |
| 3753 | 303 ROOTS must be a list of installation roots. |
| 4108 | 304 BASES is a list of possible bases to look for. |
| 4092 | 305 ARCH-DEPENDENT-P says whether the file is architecture-specific. |
| 2481 | 306 ENVVAR is the name of the environment variable that might also |
| 307 specify the directory. | |
| 308 DEFAULT is the preferred value. | |
| 309 If ENFORCE-VERSION is non-nil, the directory must contain the XEmacs version." | |
| 310 (let ((l '())) | |
| 4092 | 311 (paths-for-each-version-directory #'(lambda (dir) |
| 312 (setq l (cons dir l))) | |
| 4108 | 313 roots bases arch-dependent-p |
| 4092 | 314 envvar default) |
| 2481 | 315 (reverse l))) |
| 428 | 316 |
| 4108 | 317 (defun paths-find-architecture-directory (roots bases &optional envvar default) |
| 2456 | 318 "Find an architecture-specific directory in the XEmacs hierarchy. |
| 3753 | 319 ROOTS must be a list of installation roots. |
| 4108 | 320 BASES is a list of possible bases to look for. |
| 2456 | 321 ENVVAR is the name of the environment variable that might also |
| 322 specify the directory. | |
| 323 DEFAULT is the preferred value." | |
| 4108 | 324 (paths-find-version-directory roots |
| 325 ;; from more to less specific | |
| 326 (append | |
| 327 (mapcar | |
| 328 #'(lambda (base) | |
| 329 (paths-construct-path | |
| 330 (list system-configuration base))) | |
| 331 bases) | |
| 332 bases | |
| 333 (list system-configuration)) | |
| 334 t | |
| 335 envvar default)) | |
| 428 | 336 |
| 337 (defun construct-emacs-version-name () | |
| 2456 | 338 "Construct a string from the raw XEmacs version number." |
| 428 | 339 (concat emacs-program-name "-" emacs-program-version)) |
| 340 | |
| 341 (defun paths-directories-which-exist (directories) | |
| 2456 | 342 "Return the directories among DIRECTORIES. |
| 343 DIRECTORIES is a list of strings." | |
| 428 | 344 (let ((reverse-directories '())) |
| 345 (while directories | |
| 346 (if (paths-file-readable-directory-p (car directories)) | |
| 347 (setq reverse-directories | |
| 348 (cons (car directories) | |
| 349 reverse-directories))) | |
| 350 (setq directories (cdr directories))) | |
| 351 (reverse reverse-directories))) | |
| 352 | |
| 353 (defun paths-decode-directory-path (string &optional drop-empties) | |
| 354 "Split STRING at path separators into a directory list. | |
| 442 | 355 Non-\"\" components are converted into directory form. |
| 428 | 356 If DROP-EMPTIES is non-NIL, \"\" components are dropped from the output. |
| 357 Otherwise, they are left alone." | |
| 358 (let* ((components (split-path string)) | |
| 359 (directories | |
| 360 (mapcar #'(lambda (component) | |
| 361 (if (string-equal "" component) | |
| 362 component | |
| 363 (file-name-as-directory component))) | |
| 364 components))) | |
| 365 (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
|
366 (delete "" directories) |
| 428 | 367 directories))) |
| 368 | |
| 369 ;;; find-paths.el ends here |