--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/find-paths.el	Mon Aug 13 11:28:15 2007 +0200
@@ -0,0 +1,302 @@
+;;; find-paths.el --- setup various XEmacs paths
+
+;; Copyright (C) 1985-1986, 1990, 1992-1997 Free Software Foundation, Inc.
+;; Copyright (c) 1993, 1994 Sun Microsystems, Inc.
+;; Copyright (C) 1995 Board of Trustees, University of Illinois
+
+;; Author: Mike Sperber <sperber@informatik.uni-tuebingen.de>
+;; Maintainer: XEmacs Development Team
+;; Keywords: internal, dumped
+
+;; This file is part of XEmacs.
+
+;; XEmacs is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; XEmacs is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with XEmacs; see the file COPYING.  If not, write to the 
+;; Free Software Foundation, 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Synched up with: Not in FSF.
+
+;;; Commentary:
+
+;; This file is dumped with XEmacs.
+
+;; This file contains the library functionality to find paths into the
+;; XEmacs hierarchy.
+
+;;; Code:
+
+(defvar paths-version-control-filename-regexp
+  "^\\(RCS\\|CVS\\|SCCS\\)$"
+  "File bases associated with version control.")
+
+(defvar paths-lisp-filename-regexp
+  "^\\(.*\\.elc?\\)$"
+  "File bases that contain Lisp file.")
+
+(defvar paths-no-lisp-directory-regexp
+  (concat "\\(" paths-version-control-filename-regexp "\\)"
+	  "\\|"
+	  "\\(" paths-lisp-filename-regexp "\\)")
+  "File bases that may not be directories containing Lisp code.")
+
+(defun paths-find-recursive-path (directories &optional max-depth exclude-regexp)
+  "Return a list of the directory hierarchy underneath DIRECTORIES.
+The returned list is sorted by pre-order and lexicographically.
+MAX-DEPTH limits the depth of the search to MAX-DEPTH level,
+if it is a number.  If MAX-DEPTH is NIL, the search depth is unlimited.
+EXCLUDE-REGEXP is a regexp that matches directory names to exclude
+from the search."
+  (let ((path '()))
+    (while directories
+      (let ((directory (file-name-as-directory
+			(expand-file-name
+			 (car directories)))))
+	(if (paths-file-readable-directory-p directory)
+	    (let ((raw-entries
+		   (if (equal 0 max-depth)
+		       '()
+		     (directory-files directory nil "^[^.-]")))
+		  (reverse-dirs '()))
+	      (while raw-entries
+		(if (null (string-match exclude-regexp (car raw-entries)))
+		    (setq reverse-dirs
+			  (cons (expand-file-name (car raw-entries) directory)
+				reverse-dirs)))
+		(setq raw-entries (cdr raw-entries)))
+
+	      (let ((sub-path
+		     (paths-find-recursive-path (reverse reverse-dirs)
+						(if (numberp max-depth)
+						    (- max-depth 1)
+						  max-depth)
+						exclude-regexp)))
+		(setq path (nconc path
+				  (list directory)
+				  sub-path))))))
+      (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
+			     max-depth paths-no-lisp-directory-regexp))
+
+(defun paths-emacs-root-p (directory)
+  "Check if DIRECTORY is a plausible installation root for XEmacs."
+  (or
+   ;; installed
+   (paths-file-readable-directory-p (paths-construct-path (list directory
+								"lib"
+								emacs-program-name)))
+   ;; in-place or windows-nt
+   (and
+    (paths-file-readable-directory-p (paths-construct-path (list directory "lisp")))
+    (paths-file-readable-directory-p (paths-construct-path (list directory "etc"))))))
+
+(defun paths-chase-symlink (file-name)
+  "Chase a symlink until the bitter end."
+      (let ((maybe-symlink (file-symlink-p file-name)))
+	(if maybe-symlink
+	    (let* ((directory (file-name-directory file-name))
+		   (destination (expand-file-name maybe-symlink directory)))
+	      (paths-chase-symlink destination))
+	  file-name)))
+
+(defun paths-find-emacs-root
+  (invocation-directory invocation-name)
+  "Find the run-time root of XEmacs."
+  (let* ((executable-file-name (paths-chase-symlink
+				(concat invocation-directory
+					invocation-name)))
+	 (executable-directory (file-name-directory executable-file-name))
+	 (maybe-root-1 (file-name-as-directory
+			(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))))
+
+(defun paths-construct-path (components &optional expand-directory)
+  "Convert list of path components COMPONENTS into a path.
+If EXPAND-DIRECTORY is non-NIL, use it as a directory to feed
+to EXPAND-FILE-NAME."
+  (let* ((reverse-components (reverse components))
+	 (last-component (car reverse-components))
+	 (first-components (reverse (cdr reverse-components)))
+	 (path
+	  (apply #'concat
+		 (append (mapcar #'file-name-as-directory first-components)
+			 (list last-component)))))
+    (if expand-directory
+	(expand-file-name path expand-directory)
+      path)))
+
+(defun paths-construct-emacs-directory (root suffix base)
+  "Construct a directory name within the XEmacs hierarchy."
+  (file-name-as-directory
+   (expand-file-name
+    (concat
+     (file-name-as-directory root)
+     suffix
+     base))))
+
+(defun paths-find-emacs-directory (roots suffix base
+				   &optional envvar default keep-suffix)
+  "Find a directory in the XEmacs hierarchy.
+ROOTS must be a list of installation roots.
+SUFFIX is the subdirectory from there.
+BASE is the base to look for.
+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."
+  (let ((preferred-value (or (and envvar (getenv envvar))
+			     default)))
+    (if (and 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 (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))))))
+	  (setq roots (cdr roots)))
+	nil))))
+
+(defun paths-find-site-directory (roots base &optional envvar default)
+  "Find a site-specific directory in the XEmacs hierarchy."
+  (paths-find-emacs-directory roots
+			      (file-name-as-directory
+			       (paths-construct-path (list
+						      "lib"
+						      emacs-program-name)))
+			      base
+			      envvar default))
+
+(defun paths-find-version-directory (roots base
+				     &optional envvar default enforce-version)
+  "Find a version-specific directory in the XEmacs hierarchy.
+If ENFORCE-VERSION is non-nil, the directory must contain the XEmacs version."
+  (paths-find-emacs-directory roots
+			      (file-name-as-directory
+			       (paths-construct-path
+				(list "lib"
+				      (construct-emacs-version-name))))
+			      base
+			      envvar default
+			      enforce-version))
+
+(defun paths-find-architecture-directory (roots base &optional envvar default)
+  "Find an architecture-specific directory in the XEmacs hierarchy."
+  (or
+   ;; from more to less specific
+   (paths-find-version-directory roots
+				 (concat base system-configuration)
+				 envvar default)
+   (paths-find-version-directory roots
+				 base
+				 envvar)
+   (paths-find-version-directory roots
+				 system-configuration
+				 envvar)))
+
+(defun construct-emacs-version-name ()
+  "Construct the raw XEmacs version number."
+  (concat emacs-program-name "-" emacs-program-version))
+
+(defun paths-directories-which-exist (directories)
+  "Return the directories among DIRECTORIES."
+  (let ((reverse-directories '()))
+    (while directories
+      (if (paths-file-readable-directory-p (car directories))
+	  (setq reverse-directories
+		(cons (car directories)
+		      reverse-directories)))
+      (setq directories (cdr directories)))
+    (reverse reverse-directories)))
+
+(defun paths-uniq-append (list-1 list-2)
+  "Append LIST-1 and LIST-2, omitting duplicates."
+  (let ((reverse-survivors '()))
+    (while list-2
+      (if (null (member (car list-2) list-1))
+	  (setq reverse-survivors (cons (car list-2) reverse-survivors)))
+      (setq list-2 (cdr list-2)))
+    (append list-1
+	    (reverse reverse-survivors))))
+
+(defun paths-filter (predicate list)
+  "Delete all matches of PREDICATE from LIST."
+  (let ((reverse-result '()))
+    (while list
+      (if (funcall predicate (car list))
+	  (setq reverse-result (cons (car list) reverse-result)))
+      (setq list (cdr list)))
+    (nreverse reverse-result)))
+
+(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.
+If DROP-EMPTIES is non-NIL, \"\" components are dropped from the output.
+Otherwise, they are left alone."
+  (let* ((components (split-path string))
+	 (directories
+	  (mapcar #'(lambda (component)
+		      (if (string-equal "" component)
+			  component
+			(file-name-as-directory component)))
+		  components)))
+    (if drop-empties
+	(paths-filter #'(lambda (component)
+			  (null (string-equal "" component)))
+		      directories)
+      directories)))
+
+(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)))
+	 (potential-installation-roots
+	  (paths-uniq-append
+	   (and configure-exec-prefix-directory
+		(list (file-name-as-directory
+		       configure-exec-prefix-directory)))
+	   (and configure-prefix-directory
+		(list (file-name-as-directory
+		       configure-prefix-directory)))))
+	 (installation-roots
+	  (paths-filter #'paths-emacs-root-p potential-installation-roots)))
+    (paths-uniq-append invocation-roots
+		       installation-roots)))
+
+;;; find-paths.el ends here