X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Ffilesys.lisp;h=aba52a6bdbf65533e594f978d68e232e1de0cde8;hb=16f861fd9d7c9246a22a212c26d97fb2e3712607;hp=2013e120ce19889803b845e8ab900874db66ef7e;hpb=621eebe206ae6c6d0d0897d43247ce5e05c2359a;p=sbcl.git diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index 2013e12..aba52a6 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -294,7 +294,8 @@ (multiple-value-bind (existsp errno ino mode nlink uid gid rdev size atime mtime) (sb!unix:unix-stat filename) - (declare (ignore ino nlink gid rdev size atime)) + (declare (ignore ino nlink gid rdev size atime + #!+win32 uid)) (if existsp (case query-for (:existence (nth-value @@ -322,7 +323,9 @@ ;; ... but without any trailing slash. :as-directory (eql (logand mode sb!unix:s-ifmt) sb!unix:s-ifdir)))) - (:author (sb!unix:uid-username uid)) + (:author + #!-win32 + (sb!unix:uid-username uid)) (:write-date (+ unix-to-universal-time mtime))) (progn ;; SBCL has for many years had a policy that a pathname @@ -550,7 +553,11 @@ matching filenames." truename)))) (do-physical-pathnames (pathname) (aver (not (logical-pathname-p pathname))) - (let* ((name (pathname-name pathname)) + (let* (;; KLUDGE: Since we don't canonize pathnames on construction, + ;; we really have to do it here to get #p"foo/." mean the same + ;; as #p"foo/./". + (pathname (canonicalize-pathname pathname)) + (name (pathname-name pathname)) (type (pathname-type pathname)) ;; KLUDGE: We want #p"/foo" to match #p"/foo/, ;; so cobble up a directory name component from @@ -599,6 +606,46 @@ matching filenames." #'string< :key #'car)))) +(defun canonicalize-pathname (pathname) + ;; We're really only interested in :UNSPECIFIC -> NIL, :BACK and :UP, + ;; and dealing with #p"foo/.." and #p"foo/." + (labels ((simplify (piece) + (unless (eq :unspecific piece) + piece)) + (canonicalize-directory (directory) + (let (pieces) + (dolist (piece directory) + (if (and pieces (member piece '(:back :up))) + ;; FIXME: We should really canonicalize when we construct + ;; pathnames. This is just wrong. + (case (car pieces) + ((:absolute :wild-inferiors) + (error 'simple-file-error + :format-control "Invalid use of ~S after ~S." + :format-arguments (list piece (car pieces)) + :pathname pathname)) + ((:relative :up :back) + (push piece pieces)) + (t + (pop pieces))) + (push piece pieces))) + (nreverse pieces)))) + (let ((name (simplify (pathname-name pathname))) + (type (simplify (pathname-type pathname))) + (dir (canonicalize-directory (pathname-directory pathname)))) + (cond ((equal "." name) + (cond ((not type) + (make-pathname :name nil :defaults pathname)) + ((equal "" type) + (make-pathname :name nil + :type nil + :directory (butlast dir) + :defaults pathname)))) + (t + (make-pathname :name name :type type + :directory dir + :defaults pathname)))))) + ;;; Given a native namestring, provides a WITH-HASH-TABLE-ITERATOR style ;;; interface to mapping over namestrings of entries in the corresponding ;;; directory. @@ -657,39 +704,48 @@ symbolic link as an immediate child of DIRECTORY. Experimental: interface subject to change." (let* ((fun (%coerce-callable-to-fun function)) - (realname (or (query-file-system directory :existence errorp) - (return-from map-directory nil))) - (host (pathname-host realname)) - ;; We want the trailing separator: better to ask the - ;; provide it rather than reason about its presence here. - (dirname (native-namestring realname :as-file nil))) - (with-native-directory-iterator (next dirname :errorp errorp) - (loop for name = (next) - while name - do (let* ((full (concatenate 'string dirname name)) - (kind (native-file-kind full))) - (when kind - (case kind - (:directory - (when directories - (funcall fun (parse-native-namestring - full host realname :as-directory t)))) - (:symlink - (let* ((tmpname (parse-native-namestring - full host realname :as-directory nil)) - (truename (query-file-system tmpname :truename nil))) - (if (or (not truename) - (or (pathname-name truename) (pathname-type truename))) - (when files - (funcall fun tmpname)) - (when directories - (funcall fun (parse-native-namestring - full host realname :as-directory t)))))) - (t - ;; Anything else parses as a file. - (when files - (funcall fun (parse-native-namestring - full host realname :as-directory nil))))))))))) + (physical (physicalize-pathname directory)) + ;; Not QUERY-FILE-SYSTEM :EXISTENCE, since it doesn't work on Windows + ;; network shares. + (realname (sb!unix:unix-realpath (native-namestring physical :as-file t))) + (canonical (if realname + (parse-native-namestring realname + (pathname-host physical) + (sane-default-pathname-defaults) + :as-directory t) + (return-from map-directory nil))) + (dirname (native-namestring canonical))) + (flet ((map-it (name dirp) + (funcall fun + (merge-pathnames (parse-native-namestring + name nil physical :as-directory dirp) + physical)))) + (with-native-directory-iterator (next dirname :errorp errorp) + (loop for name = (next) + while name + do (let* ((full (concatenate 'string dirname name)) + (kind (native-file-kind full))) + (when kind + (case kind + (:directory + (when directories + (map-it name t))) + (:symlink + (let* ((tmpname (merge-pathnames + (parse-native-namestring + name nil physical :as-directory nil) + physical)) + (truename (query-file-system tmpname :truename nil))) + (if (or (not truename) + (or (pathname-name truename) (pathname-type truename))) + (when files + (funcall fun tmpname)) + (when directories + (map-it name t))))) + (t + ;; Anything else parses as a file. + (when files + (map-it name nil))))))))))) ;;; Part of DIRECTORY: implements matching the directory spec. Calls FUNCTION ;;; with all DIRECTORIES that match the directory portion of PATHSPEC. @@ -717,7 +773,8 @@ Experimental: interface subject to change." (map-wild function rest starting-point)) (t ;; Nothing wild -- the directory matches itself. - (funcall function starting-point))))) + (funcall function starting-point)))) + nil) (defun last-directory-piece (pathname) (car (last (pathname-directory pathname))))