X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffilesys.lisp;h=482b34b4fc316cf117e49738d17a41a23f3f24c8;hb=c6e249ac371fae7bf2d04defa9433720108376e4;hp=ecb6cd20eb94a8185b80ae73076cc7cc41efda51;hpb=0567612118d44cde39bb41058a4d06e771fcf0c6;p=sbcl.git diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index ecb6cd2..482b34b 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -450,7 +450,8 @@ or if PATHSPEC is a wild pathname." (let* ((original (truename file)) (original-namestring (native-namestring original :as-file t)) (new-name (merge-pathnames new-name original)) - (new-namestring (native-namestring new-name :as-file t))) + (new-namestring (native-namestring (physicalize-pathname new-name) + :as-file t))) (unless new-namestring (error 'simple-file-error :pathname new-name @@ -559,29 +560,15 @@ matching filenames." (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 - ;; name and type -- just take care with "*.*"! - (dirname (if (and (eq :wild name) (eq :wild type)) - "*" - (with-output-to-string (s) - (when name - (write-string (unparse-physical-piece name) s)) - (when type - (write-string "." s) - (write-string (unparse-physical-piece type) s))))) - (dir (maybe-make-pattern dirname 0 (length dirname))) (match-name (make-matcher name)) - (match-type (make-matcher type)) - (match-dir (make-matcher dir))) + (match-type (make-matcher type))) (map-matching-directories (if (or name type) (lambda (directory) - (map-matching-files #'record - directory - match-name - match-type - match-dir)) + (map-matching-entries #'record + directory + match-name + match-type)) #'record) pathname))) (do-pathnames (pathname) @@ -606,15 +593,33 @@ matching filenames." #'string< :key #'car)))) - (defun canonicalize-pathname (pathname) - ;; We're really only interested in :UNSPECIFIC -> NIL, - ;; and dealing with #p"foo/.." and #p"foo/." - (flet ((simplify (piece) - (unless (eq :unspecific piece) - piece))) - (let ((name (simplify (pathname-name pathname))) - (type (simplify (pathname-type pathname))) - (dir (pathname-directory pathname))) +(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)) @@ -624,8 +629,9 @@ matching filenames." :directory (butlast dir) :defaults pathname)))) (t - (make-pathname :name name :type type :defaults pathname)))))) - + (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 @@ -671,11 +677,22 @@ matching filenames." ;;; DIRECTORY. (defun map-directory (function directory &key (files t) (directories t) (errorp t)) #!+sb-doc - "Call FUNCTION with the pathname for each entry in DIRECTORY as follows: if -FILES is true (the default), FUNCTION is called for each file in the -directory; if DIRECTORIES is true (the default), FUNCTION is called for each -subdirectory. If ERRORP is true (the default) signal an error if DIRECTORY -does not exist, cannot be read, etc. + "Map over entries in DIRECTORY. Keyword arguments specify which entries to +map over, and how: + + :FILES + If true, call FUNCTION with the pathname of each file in DIRECTORY. + Defaults to T. + + :DIRECTORIES + If true, call FUNCTION with a pathname for each subdirectory of DIRECTORY. + If :AS-FILES, the pathname used is a pathname designating the subdirectory + as a file in DIRECTORY. Otherwise the pathname used is a directory + pathname. Defaults to T. + + :ERRORP + If true, signal an error if DIRECTORY does not exist, cannot be read, etc. + Defaults to T. On platforms supporting symbolic links the decision to call FUNCTION with its pathname depends on the resolution of the link: if it points to a directory, @@ -684,7 +701,9 @@ directory, the provided pathname is not fully resolved, but rather names the symbolic link as an immediate child of DIRECTORY. Experimental: interface subject to change." + (declare (pathname-designator directory)) (let* ((fun (%coerce-callable-to-fun function)) + (as-files (eq :as-files directories)) (physical (physicalize-pathname directory)) ;; Not QUERY-FILE-SYSTEM :EXISTENCE, since it doesn't work on Windows ;; network shares. @@ -699,7 +718,8 @@ Experimental: interface subject to change." (flet ((map-it (name dirp) (funcall fun (merge-pathnames (parse-native-namestring - name nil physical :as-directory dirp) + name nil physical + :as-directory (and dirp (not as-files))) physical)))) (with-native-directory-iterator (next dirname :errorp errorp) (loop for name = (next) @@ -770,25 +790,21 @@ Experimental: interface subject to change." ;; end of the line (funcall function subdirectory)) ((or (eq :wild next) (typep next 'pattern)) - (lambda (pathname) - (map-wild function more pathname))) + (map-wild function more subdirectory)) ((eq :wild-inferiors next) - (lambda (pathname) - (map-wild-inferiors function more pathname))) + (map-wild-inferiors function more subdirectory)) (t - (lambda (pathname) - (let ((this (pathname-directory pathname))) - (when (equal next (car (last this))) - (map-matching-directories - function - (make-pathname :directory (append this more) - :defaults pathname))))))))) + (let ((this (pathname-directory subdirectory))) + (map-matching-directories + function + (make-pathname :directory (append this more) + :defaults subdirectory))))))) (map-directory (if (eq :wild this) #'cont (lambda (sub) - (awhen (pattern-matches this (last-directory-piece sub)) - (funcall #'cont it)))) + (when (pattern-matches this (last-directory-piece sub)) + (funcall #'cont sub)))) directory :files nil :directories t @@ -822,20 +838,17 @@ Experimental: interface subject to change." :directories t :errorp nil))) -;;; Part of DIRECTORY: implements iterating over files in a directory, and matching -;;; them. -(defun map-matching-files (function directory match-name match-type match-dir) +;;; Part of DIRECTORY: implements iterating over entries in a directory, and +;;; matching them. +(defun map-matching-entries (function directory match-name match-type) (map-directory (lambda (file) - (let ((pname (pathname-name file)) - (ptype (pathname-type file))) - (when (if (or pname ptype) - (and (funcall match-name pname) (funcall match-type ptype)) - (funcall match-dir (last-directory-piece file))) - (funcall function file)))) + (when (and (funcall match-name (pathname-name file)) + (funcall match-type (pathname-type file))) + (funcall function file))) directory :files t - :directories t + :directories :as-files :errorp nil)) ;;; NOTE: There is a fair amount of hair below that is probably not