X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Ffind-paths.el;h=bad05a92849ab0f48af1b6fc0b9399c53bd87d4c;hb=b66f5500af73ee849c737947fb1851cfcfff6283;hp=9685d6ef7b049662b388cd92eba09346a945cc29;hpb=6883ee56ec887c2c48abe5b06b5e66aa74031910;p=chise%2Fxemacs-chise.git.1 diff --git a/lisp/find-paths.el b/lisp/find-paths.el index 9685d6e..bad05a9 100644 --- a/lisp/find-paths.el +++ b/lisp/find-paths.el @@ -62,15 +62,15 @@ from the search." (let ((directory (file-name-as-directory (expand-file-name (car directories))))) - (if (file-directory-p directory) + (if (paths-file-readable-directory-p directory) (let ((raw-entries (if (equal 0 max-depth) '() - (directory-files directory nil "^[^.-]"))) + (directory-files directory nil "^[^.-]"))) (reverse-dirs '())) - (while raw-entries - (if (null (string-match exclude-regexp (car raw-entries))) + (if (not (and exclude-regexp + (string-match exclude-regexp (car raw-entries)))) (setq reverse-dirs (cons (expand-file-name (car raw-entries) directory) reverse-dirs))) @@ -88,6 +88,11 @@ from the search." (setq directories (cdr directories))) path)) +(defun paths-file-readable-directory-p (filename) + "Check if filename is a readable directory." + (and (file-directory-p filename) + (file-readable-p filename))) + (defun paths-find-recursive-load-path (directories &optional max-depth) "Construct a recursive load path underneath DIRECTORIES." (paths-find-recursive-path directories @@ -97,13 +102,22 @@ from the search." "Check if DIRECTORY is a plausible installation root for XEmacs." (or ;; installed - (file-directory-p (paths-construct-path (list directory - "lib" - emacs-program-name))) + (paths-file-readable-directory-p (paths-construct-path (list directory + "lib" + emacs-program-name))) ;; in-place or windows-nt - (and - (file-directory-p (paths-construct-path (list directory "lisp"))) - (file-directory-p (paths-construct-path (list directory "etc")))))) + (and + (paths-file-readable-directory-p (paths-construct-path (list directory "lisp"))) + (paths-file-readable-directory-p (paths-construct-path (list directory "etc")))) + + ;; searching for a package directory on Windows + (and + (string-match "win32\\|cygwin" system-configuration) + (paths-file-readable-directory-p (paths-construct-path (list directory "xemacs-packages")))))) + +(defun paths-root-in-place-p (root) + "Check if ROOT is an in-place installation root for XEmacs." + (paths-file-readable-directory-p (paths-construct-path (list root "lisp")))) (defun paths-chase-symlink (file-name) "Chase a symlink until the bitter end." @@ -114,9 +128,10 @@ from the search." (paths-chase-symlink destination)) file-name))) -(defun paths-find-emacs-root - (invocation-directory invocation-name) - "Find the run-time root of XEmacs." +(defun paths-find-invocation-roots (invocation-directory invocation-name) + "Find the list of run-time roots of XEmacs. +INVOCATION-DIRECTORY is a directory containing the XEmacs executable. +INVOCATION-NAME is the name of the executable itself." (let* ((executable-file-name (paths-chase-symlink (concat invocation-directory invocation-name))) @@ -125,10 +140,9 @@ from the search." (paths-construct-path '("..") executable-directory))) (maybe-root-2 (file-name-as-directory (paths-construct-path '(".." "..") executable-directory)))) - (or (and (paths-emacs-root-p maybe-root-1) - maybe-root-1) - (and (paths-emacs-root-p maybe-root-2) - maybe-root-2)))) + + (paths-filter #'paths-emacs-root-p + (list maybe-root-1 maybe-root-2)))) (defun paths-construct-path (components &optional expand-directory) "Convert list of path components COMPONENTS into a path. @@ -148,14 +162,15 @@ to EXPAND-FILE-NAME." (defun paths-construct-emacs-directory (root suffix base) "Construct a directory name within the XEmacs hierarchy." (file-name-as-directory - (expand-file-name + (expand-file-name (concat (file-name-as-directory root) suffix base)))) (defun paths-find-emacs-directory (roots suffix base - &optional envvar default keep-suffix) + &optional envvar default keep-suffix + in-place-external) "Find a directory in the XEmacs hierarchy. ROOTS must be a list of installation roots. SUFFIX is the subdirectory from there. @@ -164,36 +179,49 @@ ENVVAR is the name of the environment variable that might also specify the directory. DEFAULT is the preferred value. If KEEP-SUFFIX is non-nil, the suffix must be respected in searching -the directory." +the directory. +If IN-PLACE-EXTERNAL is non-nil, the directory might be found outside +an in-place root-hierarchy." (let ((preferred-value (or (and envvar (getenv envvar)) default))) (if (and preferred-value - (file-directory-p preferred-value)) + (paths-file-readable-directory-p preferred-value)) (file-name-as-directory preferred-value) (catch 'gotcha (while roots - (let* ((root (car roots)) - ;; installed - (path (paths-construct-emacs-directory root suffix base))) - (if (file-directory-p path) - (throw 'gotcha path) - ;; in-place - (if (null keep-suffix) - (let ((path (paths-construct-emacs-directory root "" base))) - (if (file-directory-p path) - (throw 'gotcha path)))))) + (let ((root (car roots))) + ;; installed + (let ((path (paths-construct-emacs-directory root suffix base))) + (if (paths-file-readable-directory-p path) + (throw 'gotcha path))) + ;; in-place + (if (null keep-suffix) + (let ((path (paths-construct-emacs-directory root "" base))) + (if (paths-file-readable-directory-p path) + (throw 'gotcha path)))) + (if (and in-place-external + (paths-root-in-place-p root)) + (let ((path (paths-construct-emacs-directory + (paths-construct-path '("..") root) + "" base))) + (if (paths-file-readable-directory-p path) + (throw 'gotcha path))))) (setq roots (cdr roots))) nil)))) -(defun paths-find-site-directory (roots base &optional envvar default) - "Find a site-specific directory in the XEmacs hierarchy." +(defun paths-find-site-directory (roots base &optional envvar default in-place-external) + "Find a site-specific directory in the XEmacs hierarchy. +If IN-PLACE-EXTERNAL is non-nil, the directory might be found outside +an in-place root-hierarchy." (paths-find-emacs-directory roots (file-name-as-directory (paths-construct-path (list "lib" emacs-program-name))) base - envvar default)) + envvar default + nil + in-place-external)) (defun paths-find-version-directory (roots base &optional envvar default enforce-version) @@ -213,14 +241,15 @@ If ENFORCE-VERSION is non-nil, the directory must contain the XEmacs version." (or ;; from more to less specific (paths-find-version-directory roots - (concat base system-configuration) - envvar) + (paths-construct-path + (list system-configuration base)) + envvar default) (paths-find-version-directory roots base envvar) (paths-find-version-directory roots system-configuration - envvar default))) + envvar))) (defun construct-emacs-version-name () "Construct the raw XEmacs version number." @@ -230,8 +259,8 @@ If ENFORCE-VERSION is non-nil, the directory must contain the XEmacs version." "Return the directories among DIRECTORIES." (let ((reverse-directories '())) (while directories - (if (file-directory-p (car directories)) - (setq reverse-directories + (if (paths-file-readable-directory-p (car directories)) + (setq reverse-directories (cons (car directories) reverse-directories))) (setq directories (cdr directories))) @@ -258,7 +287,7 @@ If ENFORCE-VERSION is non-nil, the directory must contain the XEmacs version." (defun paths-decode-directory-path (string &optional drop-empties) "Split STRING at path separators into a directory list. -Non-\"\" comonents are converted into directory form. +Non-\"\" components are converted into directory form. If DROP-EMPTIES is non-NIL, \"\" components are dropped from the output. Otherwise, they are left alone." (let* ((components (split-path string)) @@ -277,11 +306,8 @@ Otherwise, they are left alone." (defun paths-find-emacs-roots (invocation-directory invocation-name) "Find all plausible installation roots for XEmacs." - (let* ((potential-invocation-root - (paths-find-emacs-root invocation-directory invocation-name)) - (invocation-roots - (and potential-invocation-root - (list potential-invocation-root))) + (let* ((invocation-roots + (paths-find-invocation-roots invocation-directory invocation-name)) (potential-installation-roots (paths-uniq-append (and configure-exec-prefix-directory