X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffilesys.lisp;h=e5968528b75ef777e99d968cf04ff558cf714b31;hb=872175cd9cb5b4966a36d4bd92421cc407a0355b;hp=ebd6325e2720c329a5c2981cbc4c0058f21724ee;hpb=5108495b13b99452d5a85c4600f68432ff8894b2;p=sbcl.git diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index ebd6325..e596852 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -16,14 +16,11 @@ ;;; Unix namestrings have the following format: ;;; ;;; namestring := [ directory ] [ file [ type [ version ]]] -;;; directory := [ "/" | search-list ] { file "/" }* -;;; search-list := [^:/]*: +;;; directory := [ "/" ] { file "/" }* ;;; file := [^/]* ;;; type := "." [^/.]* ;;; version := "." ([0-9]+ | "*") ;;; -;;; FIXME: Search lists are no longer supported. -;;; ;;; Note: this grammar is ambiguous. The string foo.bar.5 can be ;;; parsed as either just the file specified or as specifying the ;;; file, type, and version. Therefore, we use the following rules @@ -218,7 +215,17 @@ (setf start (1+ slash)))) (values absolute (pieces))))) -(defun maybe-extract-search-list (namestr start end) +;;; the thing before a colon in a logical path +(def!struct (logical-hostname (:make-load-form-fun + (lambda (x) + (values `(make-logical-hostname + ,(logical-hostname-name x)) + nil))) + (:copier nil) + (:constructor make-logical-hostname (name))) + (name (required-argument) :type simple-string)) + +(defun maybe-extract-logical-hostname (namestr start end) (declare (type simple-base-string namestr) (type index start end)) (let ((quoted nil)) @@ -231,69 +238,77 @@ (#\\ (setf quoted t)) (#\: - (return (values (remove-backslashes namestr start index) + (return (values (make-logical-hostname + (remove-backslashes namestr start index)) (1+ index))))))))) (defun parse-unix-namestring (namestr start end) (declare (type simple-base-string namestr) - (type index start end)) + (type index start end)) (multiple-value-bind (absolute pieces) (split-at-slashes namestr start end) - (let ((search-list (if absolute - nil - (let ((first (car pieces))) - (multiple-value-bind (search-list new-start) - (maybe-extract-search-list namestr - (car first) - (cdr first)) - (when search-list - (setf absolute t) - (setf (car first) new-start)) - search-list))))) + (let ((logical-hostname + (if absolute + nil + (let ((first (car pieces))) + (multiple-value-bind (logical-hostname new-start) + (maybe-extract-logical-hostname namestr + (car first) + (cdr first)) + (when logical-hostname + (setf absolute t) + (setf (car first) new-start)) + logical-hostname))))) + (declare (type (or null logical-hostname) logical-hostname)) (multiple-value-bind (name type version) - (let* ((tail (car (last pieces))) - (tail-start (car tail)) - (tail-end (cdr tail))) - (unless (= tail-start tail-end) - (setf pieces (butlast pieces)) - (extract-name-type-and-version namestr tail-start tail-end))) - ;; PVE: make sure there are no illegal characters in - ;; the name, illegal being (code-char 0) and #\/ - #!+high-security - (when (and (stringp name) - (find-if #'(lambda (x) (or (char= x (code-char 0)) - (char= x #\/))) - name)) - (error 'parse-error)) - - ;; Now we have everything we want. So return it. - (values nil ; no host for unix namestrings. - nil ; no devices for unix namestrings. - (collect ((dirs)) - (when search-list - (dirs (intern-search-list search-list))) - (dolist (piece pieces) - (let ((piece-start (car piece)) - (piece-end (cdr piece))) - (unless (= piece-start piece-end) - (cond ((string= namestr ".." :start1 piece-start - :end1 piece-end) - (dirs :up)) - ((string= namestr "**" :start1 piece-start - :end1 piece-end) - (dirs :wild-inferiors)) - (t - (dirs (maybe-make-pattern namestr - piece-start - piece-end))))))) - (cond (absolute - (cons :absolute (dirs))) - ((dirs) - (cons :relative (dirs))) - (t - nil))) - name - type - version))))) + (let* ((tail (car (last pieces))) + (tail-start (car tail)) + (tail-end (cdr tail))) + (unless (= tail-start tail-end) + (setf pieces (butlast pieces)) + (extract-name-type-and-version namestr tail-start tail-end))) + + (when (stringp name) + (let ((position (position-if (lambda (char) + (or (char= char (code-char 0)) + (char= char #\/))) + name))) + (when position + (error 'namestring-parse-error + :complaint "can't embed #\\Nul or #\\/ in Unix namestring" + :namestring namestr + :offset position)))) + + ;; Now we have everything we want. So return it. + (values nil ; no host for Unix namestrings + nil ; no device for Unix namestrings + (collect ((dirs)) + (when logical-hostname + (dirs logical-hostname)) + (dolist (piece pieces) + (let ((piece-start (car piece)) + (piece-end (cdr piece))) + (unless (= piece-start piece-end) + (cond ((string= namestr ".." + :start1 piece-start + :end1 piece-end) + (dirs :up)) + ((string= namestr "**" + :start1 piece-start + :end1 piece-end) + (dirs :wild-inferiors)) + (t + (dirs (maybe-make-pattern namestr + piece-start + piece-end))))))) + (cond (absolute + (cons :absolute (dirs))) + ((dirs) + (cons :relative (dirs))) + (t + nil))) + name + type + version))))) (/show0 "filesys.lisp 300") @@ -353,8 +368,14 @@ (when directory (ecase (pop directory) (:absolute - (cond ((search-list-p (car directory)) - (pieces (search-list-name (pop directory))) + (cond ((logical-hostname-p (car directory)) + ;; FIXME: The old CMU CL "search list" extension is + ;; gone, but the old machinery is still being used + ;; clumsily here and elsewhere, to represent anything + ;; which belongs before a colon prefix in the ANSI + ;; pathname machinery. This should be cleaned up, + ;; using simpler machinery with more mnemonic names. + (pieces (logical-hostname-name (pop directory))) (pieces ":")) (t (pieces "/")))) @@ -529,7 +550,7 @@ ;;; Call FUNCTION on matches. (defun %enumerate-matches (pathname verify-existence follow-links function) - (/show0 "entering %ENUMERATE-MATCHES") + (/noshow0 "entering %ENUMERATE-MATCHES") (when (pathname-type pathname) (unless (pathname-name pathname) (error "cannot supply a type without a name:~% ~S" pathname))) @@ -537,16 +558,16 @@ (member (pathname-type pathname) '(nil :unspecific))) (error "cannot supply a version without a type:~% ~S" pathname)) (let ((directory (pathname-directory pathname))) - (/show0 "computed DIRECTORY") + (/noshow0 "computed DIRECTORY") (if directory (ecase (car directory) (:absolute - (/show0 "absolute directory") + (/noshow0 "absolute directory") (%enumerate-directories "/" (cdr directory) pathname verify-existence follow-links nil function)) (:relative - (/show0 "relative directory") + (/noshow0 "relative directory") (%enumerate-directories "" (cdr directory) pathname verify-existence follow-links nil function))) @@ -624,13 +645,13 @@ ;;; Call FUNCTION on files. (defun %enumerate-files (directory pathname verify-existence function) (declare (simple-string directory)) - (/show0 "entering %ENUMERATE-FILES") + (/noshow0 "entering %ENUMERATE-FILES") (let ((name (%pathname-name pathname)) (type (%pathname-type pathname)) (version (%pathname-version pathname))) - (/show0 "computed NAME, TYPE, and VERSION") + (/noshow0 "computed NAME, TYPE, and VERSION") (cond ((member name '(nil :unspecific)) - (/show0 "UNSPECIFIC, more or less") + (/noshow0 "UNSPECIFIC, more or less") (when (or (not verify-existence) (sb!unix:unix-file-kind directory)) (funcall function directory))) @@ -638,7 +659,7 @@ (pattern-p type) (eq name :wild) (eq type :wild)) - (/show0 "WILD, more or less") + (/noshow0 "WILD, more or less") ;; I IGNORE-ERRORS here just because the original CMU CL ;; code did. I think the intent is that it's not an error ;; to request matches to a wild pattern when no matches @@ -661,25 +682,25 @@ directory complete-filename)))))) (t - (/show0 "default case") + (/noshow0 "default case") (let ((file (concatenate 'string directory name))) - (/show0 "computed basic FILE=..") + (/noshow0 "computed basic FILE=..") (/primitive-print file) (unless (or (null type) (eq type :unspecific)) - (/show0 "tweaking FILE for more-or-less-:UNSPECIFIC case") + (/noshow0 "tweaking FILE for more-or-less-:UNSPECIFIC case") (setf file (concatenate 'string file "." type))) (unless (member version '(nil :newest :wild)) - (/show0 "tweaking FILE for more-or-less-:WILD case") + (/noshow0 "tweaking FILE for more-or-less-:WILD case") (setf file (concatenate 'string file "." (quick-integer-to-string version)))) - (/show0 "finished possibly tweaking FILE=..") + (/noshow0 "finished possibly tweaking FILE=..") (/primitive-print file) (when (or (not verify-existence) (sb!unix:unix-file-kind file t)) - (/show0 "calling FUNCTION on FILE") + (/noshow0 "calling FUNCTION on FILE") (funcall function file))))))) -(/show0 "filesys.lisp 603") +(/noshow0 "filesys.lisp 603") ;;; FIXME: Why do we need this? (defun quick-integer-to-string (n) @@ -727,8 +748,7 @@ )) ;;; Convert PATHNAME into a string that can be used with UNIX system -;;; calls, or return NIL if no match is found. Search-lists and -;;; wild-cards are expanded. +;;; calls, or return NIL if no match is found. Wild-cards are expanded. (defun unix-namestring (pathname-spec &optional (for-input t)) ;; The ordinary rules of converting Lispy paths to Unix paths break ;; down for the current working directory, which Lisp thinks of as @@ -746,15 +766,9 @@ (if (empty-relative-pathname-spec-p pathname-spec) "." ;; Otherwise, the ordinary rules apply. - (let* ((possibly-logical-pathname (pathname pathname-spec)) - (physical-pathname (if (typep possibly-logical-pathname - 'logical-pathname) - (namestring (translate-logical-pathname - possibly-logical-pathname)) - possibly-logical-pathname)) + (let* ((namestring (physicalize-pathname (pathname pathname-spec))) (matches nil)) ; an accumulator for actual matches - (enumerate-matches (match physical-pathname nil - :verify-existence for-input) + (enumerate-matches (match namestring nil :verify-existence for-input) (push match matches)) (case (length matches) (0 nil) @@ -771,7 +785,10 @@ #!+sb-doc "Return the pathname for the actual file described by PATHNAME. An error of type FILE-ERROR is signalled if no such file exists, - or the pathname is wild." + or the pathname is wild. + + Under Unix, the TRUENAME of a broken symlink is considered to be + the name of the broken symlink itself." (if (wild-pathname-p pathname) (error 'simple-file-error :format-control "can't use a wild pathname here" @@ -793,14 +810,15 @@ (error 'simple-file-error :pathname pathname :format-control "can't use a wild pathname here")) - (let ((namestring (unix-namestring pathname t))) - (when (and namestring (sb!unix:unix-file-kind namestring)) - (let ((truename (sb!unix:unix-resolve-links - (sb!unix:unix-maybe-prepend-current-directory - namestring)))) - (when truename + (let* ((defaulted-pathname (merge-pathnames + pathname + (sane-default-pathname-defaults))) + (namestring (unix-namestring defaulted-pathname t))) + (when (and namestring (sb!unix:unix-file-kind namestring t)) + (let ((trueishname (sb!unix:unix-resolve-links namestring))) + (when trueishname (let ((*ignore-wildcards* t)) - (pathname (sb!unix:unix-simplify-pathname truename)))))))) + (pathname (sb!unix:unix-simplify-pathname trueishname)))))))) ;;;; miscellaneous other operations @@ -888,9 +906,9 @@ (defun file-author (file) #!+sb-doc - "Returns the file author as a string, or nil if the author cannot be - determined. Signals an error of type file-error if file doesn't exist, - or file is a wild pathname." + "Return the file author as a string, or nil if the author cannot be + determined. Signal an error of type FILE-ERROR if FILE doesn't exist, + or FILE is a wild pathname." (if (wild-pathname-p file) (error 'simple-file-error :pathname file @@ -910,38 +928,33 @@ (/show0 "filesys.lisp 800") -(defun directory (pathname &key (all t) (check-for-subdirs t) - (follow-links t)) +(defun directory (pathname &key) #!+sb-doc - "Returns a list of pathnames, one for each file that matches the given - pathname. Supplying :ALL as NIL causes this to ignore Unix dot files. This - never includes Unix dot and dot-dot in the result. If :FOLLOW-LINKS is NIL, - then symbolic links in the result are not expanded. This is not the - default because TRUENAME does follow links, and the result pathnames are - defined to be the TRUENAME of the pathname (the truename of a link may well - be in another directory.)" - (let ((results nil)) - (enumerate-search-list - (pathname (merge-pathnames pathname - (make-pathname :name :wild - :type :wild - :version :wild))) - (enumerate-matches (name pathname) - (when (or all - (let ((slash (position #\/ name :from-end t))) - (or (null slash) - (= (1+ slash) (length name)) - (char/= (schar name (1+ slash)) #\.)))) - (push name results)))) - (let ((*ignore-wildcards* t)) - (mapcar (lambda (name) - (let ((name (if (and check-for-subdirs - (eq (sb!unix:unix-file-kind name) - :directory)) - (concatenate 'string name "/") - name))) - (if follow-links (truename name) (pathname name)))) - (sort (delete-duplicates results :test #'string=) #'string<))))) + "Return a list of PATHNAMEs, each the TRUENAME of a file that matched the + given pathname. Note that the interaction between this ANSI-specified + TRUENAMEing and the semantics of the Unix filesystem (symbolic links..) + means this function can sometimes return files which don't have the same + directory as PATHNAME." + (let ((truenames nil) + (merged-pathname (merge-pathnames pathname + (make-pathname :name :wild + :type :wild + :version :wild)))) + (enumerate-matches (match merged-pathname) + (let ((*ignore-wildcards* t)) + (push (truename (if (eq (sb!unix:unix-file-kind match) :directory) + (concatenate 'string match "/") + match)) + truenames))) + ;; FIXME: The DELETE-DUPLICATES here requires quadratic time, + ;; which is unnecessarily slow. That might not be an issue, + ;; though, since the time constant for doing TRUENAME on every + ;; directory entry is likely to be (much) larger, and the cost of + ;; all those TRUENAMEs on a huge directory might even be quadratic + ;; in the directory size. Someone who cares about enormous + ;; directories might want to check this. -- WHN 2001-06-19 + (sort (delete-duplicates truenames :test #'string= :key #'pathname-name) + #'string< :key #'pathname-name))) ;;;; translating Unix uid's ;;;; @@ -1022,80 +1035,37 @@ (t t))) xn))) -;;;; DEFAULT-DIRECTORY stuff -;;;; -;;;; FIXME: *DEFAULT-DIRECTORY-DEFAULTS* seems to be the ANSI way to -;;;; deal with this, so we should beef up *DEFAULT-DIRECTORY-DEFAULTS* -;;;; and make all the old DEFAULT-DIRECTORY stuff go away. (At that -;;;; time the need for UNIX-CHDIR will go away too, I think.) - -(defun default-directory () - #!+sb-doc - "Returns the pathname for the default directory. This is the place where - a file will be written if no directory is specified. This may be changed - with setf." - (multiple-value-bind (gr dir-or-error) (sb!unix:unix-current-directory) - (if gr - (let ((*ignore-wildcards* t)) - (pathname (concatenate 'simple-string dir-or-error "/"))) - (error dir-or-error)))) - -(defun %set-default-directory (new-val) - (let ((namestring (unix-namestring new-val t))) - (unless namestring - (error "~S doesn't exist." new-val)) - (multiple-value-bind (gr error) (sb!unix:unix-chdir namestring) - (if gr - (setf (search-list "default:") (default-directory)) - (simple-file-perror "couldn't set default directory to ~S" - new-val - error))) - new-val)) - -(/show0 "filesys.lisp 934") - -(/show0 "entering what used to be !FILESYS-COLD-INIT") -(defvar *default-pathname-defaults* - (%make-pathname *unix-host* nil nil nil nil :newest)) -(setf (search-list "default:") (default-directory)) -(/show0 "leaving what used to be !FILESYS-COLD-INIT") - (defun ensure-directories-exist (pathspec &key verbose (mode #o777)) #!+sb-doc "Test whether the directories containing the specified file actually exist, and attempt to create them if they do not. The MODE argument is a CMUCL/SBCL-specific extension to control the Unix permission bits." - (let* ((pathname (pathname pathspec)) - (pathname (if (typep pathname 'logical-pathname) - (translate-logical-pathname pathname) - pathname)) - (created-p nil)) + (let ((pathname (physicalize-pathname (pathname pathspec))) + (created-p nil)) (when (wild-pathname-p pathname) (error 'simple-file-error :format-control "bad place for a wild pathname" :pathname pathspec)) - (enumerate-search-list (pathname pathname) - (let ((dir (pathname-directory pathname))) - (loop for i from 1 upto (length dir) - do (let ((newpath (make-pathname - :host (pathname-host pathname) - :device (pathname-device pathname) - :directory (subseq dir 0 i)))) - (unless (probe-file newpath) - (let ((namestring (namestring newpath))) - (when verbose - (format *standard-output* - "~&creating directory: ~A~%" - namestring)) - (sb!unix:unix-mkdir namestring mode) - (unless (probe-file namestring) - (error 'simple-file-error - :pathname pathspec - :format-control "can't create directory ~A" - :format-arguments (list namestring))) - (setf created-p t))))) - ;; Only the first path in a search-list is considered. - (return (values pathname created-p)))))) + (let ((dir (pathname-directory pathname))) + (loop for i from 1 upto (length dir) + do (let ((newpath (make-pathname + :host (pathname-host pathname) + :device (pathname-device pathname) + :directory (subseq dir 0 i)))) + (unless (probe-file newpath) + (let ((namestring (namestring newpath))) + (when verbose + (format *standard-output* + "~&creating directory: ~A~%" + namestring)) + (sb!unix:unix-mkdir namestring mode) + (unless (probe-file namestring) + (error 'simple-file-error + :pathname pathspec + :format-control "can't create directory ~A" + :format-arguments (list namestring))) + (setf created-p t))))) + (values pathname created-p)))) (/show0 "filesys.lisp 1000")