[Openmcl-cvs-notifications] r13582 - /trunk/source/lib/pathnames.lisp
gb at clozure.com
gb at clozure.com
Tue Apr 6 03:21:31 UTC 2010
Author: gb
Date: Mon Apr 5 21:21:30 2010
New Revision: 13582
Log:
Add a function PATH-IS-LINK, which returns T if its argument is a pathname
that names a (hard or symbolic) link and NIL otherwise.
Lots of changes to DIRECTORY, notably:
- try to handle directory names that contain #\* and other characters
that may need escaping.
- maintain intermediate results; distinguish between pathnames that're
results of link expansion and those that aren't.
- don't blow up if a link doesn't name a real file.
- maintain intermediate results as namestrings (to simplify PUSHNEW
of link expansions), sort results, coerce to PATHNAMEs.
The last point may be suspect if pathname->namestring->pathname doesn't
round-trip correctly (because of link expansion.) Cases that I tested
did, but I may have missed some.
The sorting of the result means that that result may not be in traversal
order on some systems (it had been previously.) =
(DIRECTORY #p"/System/Library/Frameworks/**/*.*" :directories t)
used to take about 90 seconds before the DELETE-DUPLICATES call, which
took some unknown number of hours. It now seems to take < 20 seconds.
Modified:
trunk/source/lib/pathnames.lisp
Modified: trunk/source/lib/pathnames.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lib/pathnames.lisp (original)
+++ trunk/source/lib/pathnames.lisp Mon Apr 5 21:21:30 2010
@@ -313,6 +313,26 @@
(progn , at body)
(close-dir ,dirent)))))
=
+(defun path-is-link (path)
+ "Returns T if PATH is a (hard or symbolic) link, NIL otherwise."
+ (eq (%unix-file-kind (native-translated-namestring path) t) :link))
+
+
+(defun %add-directory-result (path result follow-links)
+ (let* ((resolved (and follow-links (path-is-link path) (probe-file path)=
)))
+ (if resolved
+ (push (namestring resolved) (cdr result)) ; may introduce duplicates.
+ (push (namestring path) (car result)))
+ path))
+
+(defun %make-directory-result ()
+ (cons nil nil))
+
+(defun %process-directory-result (result)
+ (dolist (resolved (cdr result) (mapcar #'parse-namestring (sort (car res=
ult) #'string<)))
+ (pushnew resolved (car result) :test #'string=3D)))
+
+ =
(defun directory (path &key (directories nil) ;; include subdirectories
(files t) ;; include files
(all t) ;; include Unix dot files (other than dot and dot=
dot)
@@ -341,16 +361,13 @@
(mac-default-directory))))))
(assert (eq (car (pathname-directory path)) :absolute) ()
"full-pathname returned relative path ~s??" path)
- ;; return sorted in alphabetical order, target-Xload-level-0 depends
- ;; on this.
- (nreverse
- (delete-duplicates (%directory "/" dir path '(:absolute) keys) :test =
#'equal))))
-
-(defun %directory (dir rest path so-far keys)
+ (%process-directory-result (%directory "/" dir path '(:absolute) keys =
(%make-directory-result)))))
+
+(defun %directory (dir rest path so-far keys result)
(multiple-value-bind (sub-dir wild rest) (%split-dir rest)
- (%some-specific dir sub-dir wild rest path so-far keys)))
-
-(defun %some-specific (dir sub-dir wild rest path so-far keys)
+ (%some-specific dir sub-dir wild rest path so-far keys result)))
+
+(defun %some-specific (dir sub-dir wild rest path so-far keys result)
(let* ((start 1)
(end (length sub-dir))
(full-dir (if (eq start end) dir (%str-cat dir (%substr sub-dir start en=
d)))))
@@ -359,15 +376,14 @@
(push (%path-std-quotes (%substr sub-dir start pos) nil "/:;*") so-far)
(setq start (%i+ 1 pos))))
(cond ((null wild)
- (%files-in-directory full-dir path so-far keys))
+ (%files-in-directory full-dir path so-far keys result))
((string=3D wild "**")
- (%all-directories full-dir rest path so-far keys))
- (t (%one-wild full-dir wild rest path so-far keys)))))
+ (%all-directories full-dir rest path so-far keys result))
+ (t (%one-wild full-dir wild rest path so-far keys result)))))
=
; for a * or *x*y
-(defun %one-wild (dir wild rest path so-far keys)
- (let ((result ())
- (device (pathname-device path))
+(defun %one-wild (dir wild rest path so-far keys result)
+ (let ((device (pathname-device path))
(all (getf keys :all))
name)
(with-open-dir (dirent device dir)
@@ -380,11 +396,11 @@
(let ((subdir (%path-cat nil dir name))
(so-far (cons (%path-std-quotes name nil "/;:*") so-far)))
(declare (dynamic-extent so-far))
- (setq result
- (nconc (%directory (%str-cat subdir "/") rest path so-far keys) result=
))))))
+ (%directory (%str-cat subdir "/") rest path so-far keys result)
+))))
result))
=
-(defun %files-in-directory (dir path so-far keys)
+(defun %files-in-directory (dir path so-far keys result)
(let ((device (pathname-device path))
(name (pathname-name path))
(type (pathname-type path))
@@ -395,7 +411,6 @@
(follow-links (getf keys :follow-links))
(all (getf keys :all))
(include-emacs-lockfiles (getf keys :include-emacs-lockfiles))
- (result ())
sub dir-list ans)
(if (not (or name type))
(let (full-path)
@@ -406,7 +421,7 @@
(setq ans (if directory-pathnames full-path
(%cons-pathname (reverse (cdr so-far)) (car so-far) nil nil device=
)))
(when (and ans (or (null test) (funcall test ans)))
- (setq result (list ans)))))
+ (%add-directory-result ans result follow-links))))
(with-open-dir (dirent (pathname-device path) dir)
(while (setq sub (%read-dir dirent))
(when (and (or all (neq (%schar sub 0) #\.))
@@ -427,13 +442,12 @@
(multiple-value-bind (name type) (%std-name-and-type sub)
(%cons-pathname (or dir-list (setq dir-list (reverse so-far))) name typ=
e nil device)))))
(when (and ans (or (null test) (funcall test ans)))
- (push (if follow-links (or (probe-file ans) ans) ans) result))))))
+ (%add-directory-result ans result follow-links))))))
result))
=
-(defun %all-directories (dir rest path so-far keys)
+(defun %all-directories (dir rest path so-far keys result)
(let ((do-files nil)
(do-dirs nil)
- (result nil)
(device (pathname-device path))
(name (pathname-name path))
(type (pathname-type path))
@@ -450,11 +464,9 @@
(setq rest next-rest)
(multiple-value-setq (next-dir next-wild next-rest) (%split-dir re=
st)))
(cond ((not (string=3D next-dir "/"))
- (setq result
- (%some-specific dir next-dir next-wild next-rest path so-far keys)))
+ (%some-specific dir next-dir next-wild next-rest path so-far keys re=
sult))
(next-wild
- (setq result
- (%one-wild dir next-wild next-rest path so-far keys)))
+ (%one-wild dir next-wild next-rest path so-far keys result))
((or name type)
(when (getf keys :files) (setq do-files t))
(when (getf keys :directories) (setq do-dirs t)))
@@ -463,9 +475,10 @@
(%cons-pathname (setq dir-list (reverse so-far)) nil nil nil devic=
e)
(%cons-pathname (reverse (cdr so-far)) (car so-far) nil nil device=
)))
(when (or (null test) (funcall test sub))
- (setq result (list (if follow-links (truename sub) sub))))))))
- ; now descend doing %all-dirs on dirs and collecting files & dirs if d=
o-x is t
- (with-open-dir (dirent device dir)
+ (%add-directory-result sub result follow-links))))))
+ ;; now descend doing %all-dirs on dirs and collecting files & dirs
+ ;; if do-x is t
+ (with-open-dir (dirent device (%path-std-quotes dir nil "*;:"))
(while (setq sub (%read-dir dirent))
(when (and (or all (neq (%schar sub 0) #\.))
(not (string=3D sub "."))
@@ -474,7 +487,7 @@
(let* ((subfile (%path-cat nil dir sub))
(std-sub (%path-std-quotes sub nil "/;:*"))
(so-far (cons std-sub so-far))
- (subdir (%str-cat subfile "/")))
+ (subdir (%str-cat subfile "/")))
(declare (dynamic-extent so-far))
(when (and do-dirs (%file*=3D name type sub))
(setq ans (if directory-pathnames
@@ -482,13 +495,13 @@
(%cons-pathname (or dir-list (setq dir-list (reverse (cdr so-far))))
std-sub nil nil device)))
(when (or (null test) (funcall test ans))
- (push (if follow-links (truename ans) ans) result)))
- (setq result (nconc (%all-directories subdir rest path so-far keys)=
result)))
+ (%add-directory-result ans result follow-links)))
+ (%all-directories subdir rest path so-far keys result))
(when (and do-files (%file*=3D name type sub))
(multiple-value-bind (name type) (%std-name-and-type sub)
(setq ans (%cons-pathname (or dir-list (setq dir-list (reverse so-far)))=
name type nil device))
(when (or (null test) (funcall test ans))
- (push (if follow-links (truename ans) ans) result))))))))
+ (%add-directory-result ans result follow-links))))))))
result))
=
(defun %split-dir (dir &aux pos) ; dir ends in a "/".
More information about the Openmcl-cvs-notifications
mailing list