[Openmcl-cvs-notifications] r15083 - in /trunk/source: level-1/linux-files.lisp lib/pathnames.lisp
gb at clozure.com
gb at clozure.com
Sun Nov 20 05:35:44 CST 2011
Author: gb
Date: Sun Nov 20 05:35:44 2011
New Revision: 15083
Log:
%%STAT-VALUES returns stat.st_dev. (I haven't checked to see
if it's called by any other name on non-Linux systems.)
DIRECTORY treats links to directories as directories when :FOLLOW-LINKS
is T (as it is by default.) The :DIRECTORIES argument now defaults to T.
AFAICT, fixes ticket:891.
Modified:
trunk/source/level-1/linux-files.lisp
trunk/source/lib/pathnames.lisp
Modified: trunk/source/level-1/linux-files.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/level-1/linux-files.lisp (original)
+++ trunk/source/level-1/linux-files.lisp Sun Nov 20 05:35:44 2011
@@ -362,8 +362,9 @@
#+android-target :stat.st_mtime_nsec) 1000)
#-(or linux-target solaris-target)
(round (pref stat :stat.st_mtimespec.tv_nsec) 1000)
- (pref stat :stat.st_gid))
- (values nil nil nil nil nil nil nil)))
+ (pref stat :stat.st_gid)
+ (pref stat :stat.st_dev))
+ (values nil nil nil nil nil nil nil nil nil nil)))
=
#+win64-target
(defun %stat-values (result stat)
@@ -377,8 +378,9 @@
(pref stat :_stat64.st_uid)
#$BUFSIZ
(pref stat :_stat64.st_mtime) ; ???
- (pref stat :_stat64.st_gid))
- (values nil nil nil nil nil nil nil nil nil)))
+ (pref stat :_stat64.st_gid)
+ (pref stat :_stat64.st_dev))
+ (values nil nil nil nil nil nil nil nil nil nil)))
=
#+win32-target
(defun %stat-values (result stat)
@@ -392,8 +394,9 @@
(pref stat :__stat64.st_uid)
#$BUFSIZ
(pref stat :__stat64.st_mtime) ; ???
- (pref stat :__stat64.st_gid))
- (values nil nil nil nil nil nil nil nil nil)))
+ (pref stat :__stat64.st_gid)
+ (pref stat :__stat64.st_dev))
+ (values nil nil nil nil nil nil nil nil nil nil)))
=
#+windows-target
(defun windows-strip-trailing-slash (namestring)
@@ -479,7 +482,7 @@
;; already done something fairly expensive (stat, fstat)
;; to get here. try to distinguish between pipes and
;; sockets by calling #_getsockopt. If that succeeds,
- ;; we've got a socket; otherwise, we're probably got a pipe.
+ ;; we've got a socket; otherwise, we've probably got a pipe.
#+windows-target (rlet ((ptype :int)
(plen :int 4))
(if (and fd (eql 0 (#_getsockopt fd #$SOL_SOCKET #$SO_TYPE ptype plen=
)))
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 Sun Nov 20 05:35:44 2011
@@ -330,34 +330,65 @@
(%str-cat device ":" dir subdir)
(%str-cat dir subdir)))
=
-(defmacro with-open-dir ((dirent device dir) &body body)
- `(let ((,dirent (%open-dir (native-translated-namestring (make-pathname =
:device ,device :directory ,dir :defaults nil)))))
- (when ,dirent
- (unwind-protect
- (progn , at body)
- (close-dir ,dirent)))))
+(defmacro with-open-dir ((dirent device dir state follow-links) &body body)
+ (let* ((namestring (gensym)))
+ `(let* ((,namestring (native-translated-namestring (make-pathname :dev=
ice ,device :directory ,dir :defaults nil))))
+ (when (%new-directory-p ,namestring ,follow-links ,state)
+ (let* ((,dirent (%open-dir (native-translated-namestring (make-pat=
hname :device ,device :directory ,dir :defaults nil)))))
+ (when ,dirent
+ (unwind-protect
+ (progn , at body)
+ (close-dir ,dirent))))))))
=
(defun path-is-link (path)
"Returns T if PATH is a (hard or symbolic) link, NIL otherwise."
+ ;; Actually, it's a bit more subtle than that; it basically
+ ;; returns information about the last component of PATH. If
+ ;; some enclosing directory name is a link but the last component
+ ;; isn't, this'll return false.
(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))
+(defstruct (directory-result (:constructor %make-directory-result))
+ (truenames (make-hash-table :shared nil :test 'string=3D :hash-function =
'sxhash))
+ (directories-seen ()))
+
+
+;;; If no component of the pathname involves a link we could avoid the cal=
l to
+;;; TRUENAME here. Later ...
+(defun %add-directory-result (path result follow-links &optional followed-=
some-links)
+ (declare (ignore followed-some-links))
+ (let* ((truename (if follow-links (truename path) path))
+ (namestring (namestring truename))
+ (truenames (directory-result-truenames result)))
+ (or (gethash namestring truenames)
+ (setf (gethash namestring truenames) truename))))
+ =
=
(defun %process-directory-result (result)
- (dolist (resolved (cdr result) (mapcar #'parse-namestring (sort (car res=
ult) #'string<)))
- (pushnew resolved (car result) :test #'string=3D)))
+ (collect ((pairs))
+ (maphash (lambda (namestring truename) (pairs (cons namestring truenam=
e))) (directory-result-truenames result))
+ (mapcar #'cdr (sort (pairs) #'string< :key #'car))))
+
+(defun %new-directory-p (namestring follow-links result)
+ (multiple-value-bind (win mode size mtime inode uid blocksize rmtime gi=
d dev)
+ (%stat namestring (not follow-links))
+ (declare (ignore size mtime uid blocksize rmtime gid #+windows-target =
inode #+windows-target dev))
+ (when (and win (=3D (logand mode #$S_IFMT) #$S_IFDIR))
+ #+windows-target
+ (let* ((dirname (namestring (truename (pathname namestring)))))
+ (unless (member dirname (directory-result-directories-seen result)=
:test #'string=3D)
+ (push dirname (directory-result-directories-seen result))
+ t))
+ #-windows-target
+ (when (dolist (pair (directory-result-directories-seen result) t)
+ (when (and (eql inode (car pair))
+ (eql dev (cdr pair)))
+ (return)))
+ (push (cons inode dev) (directory-result-directories-seen result))
+ t))))
=
=
-(defun directory (path &key (directories nil) ;; include subdirectories
+(defun directory (path &key (directories t) ;; include subdirectories
(files t) ;; include files
(all t) ;; include Unix dot files (other than dot and dot=
dot)
(directory-pathnames t) ;; return directories as directory-pathname=
-p's.
@@ -409,14 +440,15 @@
(defun %one-wild (dir wild rest path so-far keys result)
(let ((device (pathname-device path))
(all (getf keys :all))
+ (follow-links (getf keys :follow-links))
name)
- (with-open-dir (dirent device dir)
+ (with-open-dir (dirent device dir result follow-links)
(while (setq name (%read-dir dirent))
(when (and (or all (neq (%schar name 0) #\.))
(not (string=3D name "."))
(not (string=3D name ".."))
(%path-pstr*=3D wild name)
- (eq (%unix-file-kind (%path-cat device dir name) t) :directory))
+ (eq (%unix-file-kind (%path-cat device dir name) (not follow-links)) =
:directory))
(let ((subdir (%path-cat nil dir name))
(so-far (cons (%path-std-quotes name nil "/;:*") so-far)))
(declare (dynamic-extent so-far))
@@ -440,13 +472,13 @@
(let (full-path)
(when (and directories
(eq (%unix-file-kind (namestring (setq full-path (%cons-pathname (rev=
erse so-far) nil nil nil device)))
- t)
+ (not follow-links))
:directory))
(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)))
(%add-directory-result ans result follow-links))))
- (with-open-dir (dirent (pathname-device path) dir)
+ (with-open-dir (dirent (pathname-device path) dir result follow-link=
s)
(while (setq sub (%read-dir dirent))
(when (and (or all (neq (%schar sub 0) #\.))
(or include-emacs-lockfiles
@@ -456,7 +488,7 @@
(not (string=3D sub ".."))
(%file*=3D name type sub))
(setq ans
- (if (eq (%unix-file-kind (%path-cat device dir sub) t) :directory)
+ (if (eq (%unix-file-kind (%path-cat device dir sub) (not follow-links)=
) :directory)
(when directories
(let* ((std-sub (%path-std-quotes sub nil "/;:*")))
(if directory-pathnames
@@ -502,12 +534,12 @@
(%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 "*;:"))
+ (with-open-dir (dirent device (%path-std-quotes dir nil "*;:") result =
follow-links)
(while (setq sub (%read-dir dirent))
(when (and (or all (neq (%schar sub 0) #\.))
(not (string=3D sub "."))
(not (string=3D sub "..")))
- (if (eq (%unix-file-kind (%path-cat device dir sub) t) :directory)
+ (if (eq (%unix-file-kind (%path-cat device dir sub) (not follow-links))=
:directory)
(let* ((subfile (%path-cat nil dir sub))
(std-sub (%path-std-quotes sub nil "/;:*"))
(so-far (cons std-sub so-far))
More information about the Openmcl-cvs-notifications
mailing list