I didn't know where to put this; in GNU Emacs, it's in the core in
files.el. I put it in a new file in xemacs-base. Let me know if you
have better ideas.
2013-02-21 Michael Sperber <mike(a)xemacs.org>
* file-util.el:
(locate-dominating-stop-dir-regexp, locate-dominating-file): New
file, add functions from GNU Emacs.
--
Regards,
Mike
diff --git a/Makefile b/Makefile
--- a/Makefile
+++ b/Makefile
@@ -35,6 +35,7 @@
chistory.elc comint.elc comint-xemacs.elc compile.elc debug.elc \
easy-mmode.elc ebuff-menu.elc echistory.elc ehelp.elc edmacro.elc \
electric.elc enriched.elc env.elc facemenu.elc ffap.elc field.elc \
+ file-util.elc \
helper.elc imenu.elc iso-syntax.elc macros.elc novice.elc outline.elc \
passwd.elc pp.elc regexp-opt.elc regi.elc ring.elc shell.elc \
skeleton.elc sort.elc thing.elc time-stamp.elc timer-funcs.elc \
diff --git a/file-util.el b/file-util.el
new file mode 100644
--- /dev/null
+++ b/file-util.el
@@ -0,0 +1,106 @@
+;;; file-util.el --- utilities for dealing with files
+
+;; Copyright (C) 1985-1987, 1992-2012 Free Software Foundation, Inc.
+
+;; 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, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;;###autoload
+(defvar locate-dominating-stop-dir-regexp
+ "\\`\\(?:[\\/][\\/][^\\/]+[\\/]\\|/\\(?:net\\|afs\\|\\.\\.\\.\\)/\\)\\'"
+ "Regexp of directory names which stop the search in `locate-dominating-file'.
+Any directory whose name matches this regexp will be treated like
+a kind of root directory by `locate-dominating-file' which will stop its search
+when it bumps into it.
+The default regexp prevents fruitless and time-consuming attempts to find
+special files in directories in which filenames are interpreted as hostnames,
+or mount points potentially requiring authentication as a different user.")
+
+;; (defun locate-dominating-files (file regexp)
+;; "Look up the directory hierarchy from FILE for a file matching REGEXP.
+;; Stop at the first parent where a matching file is found and return the list
+;; of files that that match in this directory."
+;; (catch 'found
+;; ;; `user' is not initialized yet because `file' may not exist, so we may
+;; ;; have to walk up part of the hierarchy before we find the "initial
UID".
+;; (let ((user nil)
+;; ;; Abbreviate, so as to stop when we cross ~/.
+;; (dir (abbreviate-file-name (file-name-as-directory file)))
+;; files)
+;; (while (and dir
+;; ;; As a heuristic, we stop looking up the hierarchy of
+;; ;; directories as soon as we find a directory belonging to
+;; ;; another user. This should save us from looking in
+;; ;; things like /net and /afs. This assumes that all the
+;; ;; files inside a project belong to the same user.
+;; (let ((prev-user user))
+;; (setq user (nth 2 (file-attributes dir)))
+;; (or (null prev-user) (equal user prev-user))))
+;; (if (setq files (condition-case nil
+;; (directory-files dir 'full regexp 'nosort)
+;; (error nil)))
+;; (throw 'found files)
+;; (if (equal dir
+;; (setq dir (file-name-directory
+;; (directory-file-name dir))))
+;; (setq dir nil))))
+;; nil)))
+
+;;;###autoload
+(defun locate-dominating-file (file name)
+ "Look up the directory hierarchy from FILE for a file named NAME.
+Stop at the first parent directory containing a file NAME,
+and return the directory. Return nil if not found.
+
+This function only tests if FILE exists. If you care about whether
+it is readable, regular, etc., you should test the result."
+ ;; We used to use the above locate-dominating-files code, but the
+ ;; directory-files call is very costly, so we're much better off doing
+ ;; multiple calls using the code in here.
+ ;;
+ ;; Represent /home/luser/foo as ~/foo so that we don't try to look for
+ ;; `name' in /home or in /.
+ (setq file (abbreviate-file-name file))
+ (let ((root nil)
+ ;; `user' is not initialized outside the loop because
+ ;; `file' may not exist, so we may have to walk up part of the
+ ;; hierarchy before we find the "initial UID". Note: currently unused
+ ;; (user nil)
+ try)
+ (while (not (or root
+ (null file)
+ ;; FIXME: Disabled this heuristic because it is sometimes
+ ;; inappropriate.
+ ;; As a heuristic, we stop looking up the hierarchy of
+ ;; directories as soon as we find a directory belonging
+ ;; to another user. This should save us from looking in
+ ;; things like /net and /afs. This assumes that all the
+ ;; files inside a project belong to the same user.
+ ;; (let ((prev-user user))
+ ;; (setq user (nth 2 (file-attributes file)))
+ ;; (and prev-user (not (equal user prev-user))))
+ (string-match locate-dominating-stop-dir-regexp file)))
+ ;; FIXME? maybe this function should (optionally?)
+ ;; use file-readable-p instead. In many cases, an unreadable
+ ;; FILE is no better than a non-existent one.
+ ;; See eg dir-locals-find-file.
+ (setq try (file-exists-p (expand-file-name name file)))
+ (cond (try (setq root file))
+ ((equal file (setq file (file-name-directory
+ (directory-file-name file))))
+ (setq file nil))))
+ root))
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches