- (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)))))))))))
+ (as-files (eq :as-files directories))
+ (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 (and dirp (not as-files)))
+ 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)))))))))))