;;; 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
(position #\. namestr :start (1+ start)
:end last-dot :from-end t)))
(version :newest))
- ;; If there is a second-to-last dot, check to see whether there is a valid
- ;; version after the last dot.
+ ;; If there is a second-to-last dot, check to see whether there is
+ ;; a valid version after the last dot.
(when second-to-last-dot
(cond ((and (= (+ last-dot 2) end)
(char= (schar namestr (1+ last-dot)) #\*))
(/show0 "filesys.lisp 200")
;;; Take a string and return a list of cons cells that mark the char
-;;; separated subseq. The first value t if absolute directories location.
+;;; separated subseq. The first value is true if absolute directories
+;;; location.
(defun split-at-slashes (namestr start end)
(declare (type simple-base-string namestr)
(type index start end))
(setf start (1+ slash))))
(values absolute (pieces)))))
-(defun maybe-extract-search-list (namestr start end)
- (declare (type simple-base-string namestr)
- (type index start end))
- (let ((quoted nil))
- (do ((index start (1+ index)))
- ((= index end)
- (values nil start))
- (if quoted
- (setf quoted nil)
- (case (schar namestr index)
- (#\\
- (setf quoted t))
- (#\:
- (return (values (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)))))
- (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)))))
+ (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)))
+
+ (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))
+ (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")
(defun unparse-unix-host (pathname)
(declare (type pathname pathname)
(ignore pathname))
- "Unix")
+ ;; this host designator needs to be recognized as a physical host in
+ ;; PARSE-NAMESTRING. Until sbcl-0.7.3.x, we had "Unix" here, but
+ ;; that's a valid Logical Hostname, so that's a bad choice. -- CSR,
+ ;; 2002-05-09
+ "")
(defun unparse-unix-piece (thing)
(etypecase thing
(when directory
(ecase (pop directory)
(:absolute
- (cond ((search-list-p (car directory))
- (pieces (search-list-name (pop directory)))
- (pieces ":"))
- (t
- (pieces "/"))))
+ (pieces "/"))
(:relative
- ;; Nothing special.
+ ;; nothing special
))
(dolist (dir directory)
(typecase dir
(collect ((strings))
(let* ((name (%pathname-name pathname))
(type (%pathname-type pathname))
- (type-supplied (not (or (null type) (eq type :unspecific))))
- (version (%pathname-version pathname))
- (version-supplied (not (or (null version) (eq version :newest)))))
+ (type-supplied (not (or (null type) (eq type :unspecific)))))
+ ;; Note: by ANSI 19.3.1.1.5, we ignore the version slot when
+ ;; translating logical pathnames to a filesystem without
+ ;; versions (like Unix).
(when name
(strings (unparse-unix-piece name)))
(when type-supplied
(unless name
(error "cannot specify the type without a file: ~S" pathname))
(strings ".")
- (strings (unparse-unix-piece type)))
- (when version-supplied
- (unless type-supplied
- (error "cannot specify the version without a type: ~S" pathname))
- (strings (if (eq version :wild)
- ".*"
- (format nil ".~D" version)))))
+ (strings (unparse-unix-piece type))))
(apply #'concatenate 'simple-string (strings))))
(/show0 "filesys.lisp 406")
(let* ((pathname-directory (%pathname-directory pathname))
(defaults-directory (%pathname-directory defaults))
(prefix-len (length defaults-directory))
- (result-dir
+ (result-directory
(cond ((and (> prefix-len 1)
(>= (length pathname-directory) prefix-len)
(compare-component (subseq pathname-directory
(t
;; We are a relative directory. So we lose.
(lose)))))
- (strings (unparse-unix-directory-list result-dir)))
+ (strings (unparse-unix-directory-list result-directory)))
(let* ((pathname-version (%pathname-version pathname))
(version-needed (and pathname-version
(not (eq pathname-version :newest))))
(t
(lose)))))
(apply #'concatenate 'simple-string (strings)))))
-
-(/show0 "filesys.lisp 471")
-
-(def!struct (unix-host
- (:make-load-form-fun make-unix-host-load-form)
- (:include host
- (parse #'parse-unix-namestring)
- (unparse #'unparse-unix-namestring)
- (unparse-host #'unparse-unix-host)
- (unparse-directory #'unparse-unix-directory)
- (unparse-file #'unparse-unix-file)
- (unparse-enough #'unparse-unix-enough)
- (customary-case :lower))))
-
-(/show0 "filesys.lisp 486")
-
-(defvar *unix-host* (make-unix-host))
-
-(/show0 "filesys.lisp 488")
-
-(defun make-unix-host-load-form (host)
- (declare (ignore host))
- '*unix-host*)
\f
;;;; wildcard matching stuff
+;;; Return a list of all the Lispy filenames (not including e.g. the
+;;; Unix magic "." and "..") in the directory named by DIRECTORY-NAME.
+(defun directory-lispy-filenames (directory-name)
+ (with-alien ((adlf (* c-string)
+ (alien-funcall (extern-alien
+ "alloc_directory_lispy_filenames"
+ (function (* c-string) c-string))
+ directory-name)))
+ (if (null-alien adlf)
+ (error 'simple-file-error
+ :pathname directory-name
+ :format-control "~@<couldn't read directory ~S: ~2I~_~A~:>"
+ :format-arguments (list directory-name (strerror)))
+ (unwind-protect
+ (c-strings->string-list adlf)
+ (alien-funcall (extern-alien "free_directory_lispy_filenames"
+ (function void (* c-string)))
+ adlf)))))
+
(/show0 "filesys.lisp 498")
-;;; FIXME: could maybe be EVAL-WHEN (COMPILE EVAL)
-(defmacro enumerate-matches ((var pathname &optional result
- &key (verify-existence t))
- &body body)
- (let ((body-name (gensym)))
- `(block nil
- (flet ((,body-name (,var)
- ,@body))
- (%enumerate-matches (pathname ,pathname)
- ,verify-existence
- #',body-name)
- ,result))))
+(defmacro !enumerate-matches ((var pathname &optional result
+ &key (verify-existence t)
+ (follow-links t))
+ &body body)
+ `(block nil
+ (%enumerate-matches (pathname ,pathname)
+ ,verify-existence
+ ,follow-links
+ (lambda (,var) ,@body))
+ ,result))
(/show0 "filesys.lisp 500")
-(defun %enumerate-matches (pathname verify-existence function)
- (/show0 "entering %ENUMERATE-MATCHES")
+;;; Call FUNCTION on matches.
+(defun %enumerate-matches (pathname verify-existence follow-links function)
+ (/noshow0 "entering %ENUMERATE-MATCHES")
(when (pathname-type pathname)
(unless (pathname-name pathname)
(error "cannot supply a type without a name:~% ~S" pathname)))
(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)
+ (ecase (first directory)
(:absolute
- (/show0 "absolute directory")
- (%enumerate-directories "/" (cdr directory) pathname
- verify-existence function))
+ (/noshow0 "absolute directory")
+ (%enumerate-directories "/" (rest directory) pathname
+ verify-existence follow-links
+ nil function))
(:relative
- (/show0 "relative directory")
- (%enumerate-directories "" (cdr directory) pathname
- verify-existence function)))
+ (/noshow0 "relative directory")
+ (%enumerate-directories "" (rest directory) pathname
+ verify-existence follow-links
+ nil function)))
(%enumerate-files "" pathname verify-existence function))))
-(defun %enumerate-directories (head tail pathname verify-existence function)
+;;; Call FUNCTION on directories.
+(defun %enumerate-directories (head tail pathname verify-existence
+ follow-links nodes function)
(declare (simple-string head))
- (if tail
- (let ((piece (car tail)))
- (etypecase piece
- (simple-string
- (%enumerate-directories (concatenate 'string head piece "/")
- (cdr tail) pathname verify-existence
- function))
- ((or pattern (member :wild :wild-inferiors))
- (let ((dir (sb!unix:open-dir head)))
- (when dir
- (unwind-protect
- (loop
- (let ((name (sb!unix:read-dir dir)))
- (cond ((null name)
- (return))
- ((string= name "."))
- ((string= name ".."))
- ((pattern-matches piece name)
- (let ((subdir (concatenate 'string
- head name "/")))
- (when (eq (sb!unix:unix-file-kind subdir)
- :directory)
- (%enumerate-directories
- subdir (cdr tail) pathname verify-existence
- function)))))))
- (sb!unix:close-dir dir)))))
+ (macrolet ((unix-xstat (name)
+ `(if follow-links
+ (sb!unix:unix-stat ,name)
+ (sb!unix:unix-lstat ,name)))
+ (with-directory-node-noted ((head) &body body)
+ `(multiple-value-bind (res dev ino mode)
+ (unix-xstat ,head)
+ (when (and res (eql (logand mode sb!unix:s-ifmt)
+ sb!unix:s-ifdir))
+ (let ((nodes (cons (cons dev ino) nodes)))
+ ,@body))))
+ (with-directory-node-removed ((head) &body body)
+ `(multiple-value-bind (res dev ino mode)
+ (unix-xstat ,head)
+ (when (and res (eql (logand mode sb!unix:s-ifmt)
+ sb!unix:s-ifdir))
+ (let ((nodes (remove (cons dev ino) nodes :test #'equal)))
+ ,@body)))))
+ (if tail
+ (let ((piece (car tail)))
+ (etypecase piece
+ (simple-string
+ (let ((head (concatenate 'string head piece)))
+ (with-directory-node-noted (head)
+ (%enumerate-directories (concatenate 'string head "/")
+ (cdr tail) pathname
+ verify-existence follow-links
+ nodes function))))
+ ((member :wild-inferiors)
+ (%enumerate-directories head (rest tail) pathname
+ verify-existence follow-links
+ nodes function)
+ (dolist (name (ignore-errors (directory-lispy-filenames head)))
+ (let ((subdir (concatenate 'string head name)))
+ (multiple-value-bind (res dev ino mode)
+ (unix-xstat subdir)
+ (declare (type (or fixnum null) mode))
+ (when (and res (eql (logand mode sb!unix:s-ifmt)
+ sb!unix:s-ifdir))
+ (unless (dolist (dir nodes nil)
+ (when (and (eql (car dir) dev)
+ (eql (cdr dir) ino))
+ (return t)))
+ (let ((nodes (cons (cons dev ino) nodes))
+ (subdir (concatenate 'string subdir "/")))
+ (%enumerate-directories subdir tail pathname
+ verify-existence follow-links
+ nodes function))))))))
+ ((or pattern (member :wild))
+ (dolist (name (directory-lispy-filenames head))
+ (when (or (eq piece :wild) (pattern-matches piece name))
+ (let ((subdir (concatenate 'string head name)))
+ (multiple-value-bind (res dev ino mode)
+ (unix-xstat subdir)
+ (declare (type (or fixnum null) mode))
+ (when (and res
+ (eql (logand mode sb!unix:s-ifmt)
+ sb!unix:s-ifdir))
+ (let ((nodes (cons (cons dev ino) nodes))
+ (subdir (concatenate 'string subdir "/")))
+ (%enumerate-directories subdir (rest tail) pathname
+ verify-existence follow-links
+ nodes function))))))))
((member :up)
- (%enumerate-directories (concatenate 'string head "../")
- (cdr tail) pathname verify-existence
- function))))
- (%enumerate-files head pathname verify-existence function)))
-
+ (with-directory-node-removed (head)
+ (let ((head (concatenate 'string head "..")))
+ (with-directory-node-noted (head)
+ (%enumerate-directories (concatenate 'string head "/")
+ (rest tail) pathname
+ verify-existence follow-links
+ nodes function)))))))
+ (%enumerate-files head pathname verify-existence function))))
+
+;;; 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)))
(pattern-p type)
(eq name :wild)
(eq type :wild))
- (/show0 "WILD, more or less")
- (let ((dir (sb!unix:open-dir directory)))
- (when dir
- (unwind-protect
- (loop
- (/show0 "at head of LOOP")
- (let ((file (sb!unix:read-dir dir)))
- (if file
- (unless (or (string= file ".")
- (string= file ".."))
- (multiple-value-bind
- (file-name file-type file-version)
- (let ((*ignore-wildcards* t))
- (extract-name-type-and-version
- file 0 (length file)))
- (when (and (components-match file-name name)
- (components-match file-type type)
- (components-match file-version
- version))
- (funcall function
- (concatenate 'string
- directory
- file)))))
- (return))))
- (sb!unix:close-dir dir)))))
+ (/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
+ ;; exist, but I haven't tried to figure out whether
+ ;; everything is kosher. (E.g. what if we try to match a
+ ;; wildcard but we don't have permission to read one of the
+ ;; relevant directories?) -- WHN 2001-04-17
+ (dolist (complete-filename (ignore-errors
+ (directory-lispy-filenames directory)))
+ (multiple-value-bind
+ (file-name file-type file-version)
+ (let ((*ignore-wildcards* t))
+ (extract-name-type-and-version
+ complete-filename 0 (length complete-filename)))
+ (when (and (components-match file-name name)
+ (components-match file-type type)
+ (components-match file-version version))
+ (funcall function
+ (concatenate 'string
+ directory
+ complete-filename))))))
(t
- (/show0 "default case")
+ (/noshow0 "default case")
(let ((file (concatenate 'string directory name)))
- (/show0 "computed basic FILE=..")
- #!+sb-show (%primitive print file)
+ (/noshow "computed basic 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=..")
- #!+sb-show (%primitive print file)
+ (/noshow0 "finished possibly tweaking 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)
\f
;;;; UNIX-NAMESTRING
-(defun unix-namestring (pathname &optional (for-input t) executable-only)
- #!+sb-doc
- "Convert PATHNAME into a string that can be used with UNIX system calls.
- Search-lists and wild-cards are expanded."
- ;; toy@rtp.ericsson.se: Let unix-namestring also handle logical
- ;; pathnames too.
- ;; FIXME: What does this ^ mean? A bug? A remark on a change already made?
- (/show0 "entering UNIX-NAMESTRING")
- (let ((path (let ((lpn (pathname pathname)))
- (if (typep lpn 'logical-pathname)
- (namestring (translate-logical-pathname lpn))
- pathname))))
- (/show0 "PATH computed, enumerating search list")
- (enumerate-search-list
- (pathname path)
- (collect ((names))
- (/show0 "collecting NAMES")
- (enumerate-matches (name pathname nil :verify-existence for-input)
- (when (or (not executable-only)
- (and (eq (sb!unix:unix-file-kind name)
- :file)
- (sb!unix:unix-access name
- sb!unix:x_ok)))
- (names name)))
- (/show0 "NAMES collected")
- (let ((names (names)))
- (when names
- (/show0 "NAMES is true.")
- (when (cdr names)
- (/show0 "Alas! CDR NAMES")
- (error 'simple-file-error
- :format-control "~S is ambiguous:~{~% ~A~}"
- :format-arguments (list pathname names)))
- (/show0 "returning from UNIX-NAMESTRING")
- (return (car names))))))))
+(defun empty-relative-pathname-spec-p (x)
+ (or (equal x "")
+ (and (pathnamep x)
+ (or (equal (pathname-directory x) '(:relative))
+ ;; KLUDGE: I'm not sure this second check should really
+ ;; have to be here. But on sbcl-0.6.12.7,
+ ;; (PATHNAME-DIRECTORY (PATHNAME "")) is NIL, and
+ ;; (PATHNAME "") seems to act like an empty relative
+ ;; pathname, so in order to work with that, I test
+ ;; for NIL here. -- WHN 2001-05-18
+ (null (pathname-directory x)))
+ (null (pathname-name x))
+ (null (pathname-type x)))
+ ;; (The ANSI definition of "pathname specifier" has
+ ;; other cases, but none of them seem to admit the possibility
+ ;; of being empty and relative.)
+ ))
+
+;;; Convert PATHNAME into a string that can be used with UNIX system
+;;; calls, or return NIL if no match is found. Wild-cards are expanded.
+;;; FIXME this should signal file-error if the pathname is wild, whether
+;;; or not it turns out to have only one match. Fix post 0.7.2
+(defun unix-namestring (pathname-spec &optional (for-input t))
+ (let* ((namestring (physicalize-pathname (merge-pathnames pathname-spec)))
+ (matches nil)) ; an accumulator for actual matches
+ (when (wild-pathname-p namestring)
+ (error 'simple-file-error
+ :pathname namestring
+ :format-control "bad place for a wild pathname"))
+ (!enumerate-matches (match namestring nil :verify-existence for-input)
+ (push match matches))
+ (case (length matches)
+ (0 nil)
+ (1 (first matches))
+ (t (bug "!ENUMERATE-MATCHES returned more than one match on a non-wild pathname")))))
\f
;;;; TRUENAME and PROBE-FILE
-;;; Another silly file function trivially different from another function.
+;;; This is only trivially different from PROBE-FILE, which is silly
+;;; but ANSI.
(defun truename (pathname)
#!+sb-doc
- "Return the pathname for the actual file described by the pathname
- An error of type file-error is signalled if no such file exists,
- or the pathname is wild."
- (if (wild-pathname-p pathname)
+ "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.
+
+ Under Unix, the TRUENAME of a broken symlink is considered to be
+ the name of the broken symlink itself."
+ (let ((result (probe-file pathname)))
+ (unless result
(error 'simple-file-error
- :format-control "bad place for a wild pathname"
- :pathname pathname)
- (let ((result (probe-file pathname)))
- (unless result
- (error 'simple-file-error
- :pathname pathname
- :format-control "The file ~S does not exist."
- :format-arguments (list (namestring pathname))))
- result)))
+ :pathname pathname
+ :format-control "The file ~S does not exist."
+ :format-arguments (list (namestring pathname))))
+ result))
;;; If PATHNAME exists, return its truename, otherwise NIL.
(defun probe-file (pathname)
#!+sb-doc
- "Return a pathname which is the truename of the file if it exists, NIL
- otherwise. An error of type file-error is signaled if pathname is wild."
- (/show0 "entering PROBE-FILE")
- (if (wild-pathname-p pathname)
- (error 'simple-file-error
- :pathname pathname
- :format-control "bad place for a wild pathname")
- (let ((namestring (unix-namestring pathname t)))
- (/show0 "NAMESTRING computed")
- (when (and namestring (sb!unix:unix-file-kind namestring))
- (/show0 "NAMESTRING is promising.")
- (let ((truename (sb!unix:unix-resolve-links
- (sb!unix:unix-maybe-prepend-current-directory
- namestring))))
- (/show0 "TRUENAME computed")
- (when truename
- (/show0 "TRUENAME is true.")
- (let ((*ignore-wildcards* t))
- (pathname (sb!unix:unix-simplify-pathname truename)))))))))
+ "Return a pathname which is the truename of the file if it exists, or NIL
+ otherwise. An error of type FILE-ERROR is signaled if pathname is wild."
+ (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 trueishname))))))))
\f
;;;; miscellaneous other operations
(defun rename-file (file new-name)
#!+sb-doc
- "Rename File to have the specified New-Name. If file is a stream open to a
+ "Rename FILE to have the specified NEW-NAME. If FILE is a stream open to a
file, then the associated file is renamed."
(let* ((original (truename file))
(original-namestring (unix-namestring original t))
(unless res
(error 'simple-file-error
:pathname new-name
- :format-control "failed to rename ~A to ~A: ~A"
- :format-arguments (list original new-name
- (sb!unix:get-unix-error-msg error))))
+ :format-control "~@<couldn't rename ~2I~_~A ~I~_to ~2I~_~A: ~
+ ~I~_~A~:>"
+ :format-arguments (list original new-name (strerror error))))
(when (streamp file)
(file-name file new-namestring))
(values new-name original (truename new-name)))))
(defun delete-file (file)
#!+sb-doc
- "Delete the specified file."
+ "Delete the specified FILE."
(let ((namestring (unix-namestring file t)))
(when (streamp file)
(close file :abort t))
:pathname file
:format-control "~S doesn't exist."
:format-arguments (list file)))
-
(multiple-value-bind (res err) (sb!unix:unix-unlink namestring)
(unless res
- (error 'simple-file-error
- :pathname namestring
- :format-control "could not delete ~A: ~A"
- :format-arguments (list namestring
- (sb!unix:get-unix-error-msg err))))))
+ (simple-file-perror "couldn't delete ~A" namestring err))))
t)
\f
-;;; Return Home:, which is set up for us at initialization time.
+;;; (This is an ANSI Common Lisp function.)
(defun user-homedir-pathname (&optional host)
- #!+sb-doc
- "Returns the home directory of the logged in user as a pathname.
- This is obtained from the logical name \"home:\"."
+ "Return the home directory of the user as a pathname."
(declare (ignore host))
- ;; Note: CMU CL did #P"home:" here instead of using a call to
- ;; PATHNAME. Delaying construction of the pathname until we're
- ;; running in a target Lisp lets us avoid figuring out how to dump
- ;; cross-compilation host Lisp PATHNAME objects into a target Lisp
- ;; object file. It also might have a small positive effect on
- ;; efficiency, in that we don't allocate a PATHNAME we don't need,
- ;; but it it could also have a larger negative effect. Hopefully
- ;; it'll be OK. -- WHN 19990714
- (pathname "home:"))
+ (pathname (sb!unix:uid-homedir (sb!unix:unix-getuid))))
(defun file-write-date (file)
#!+sb-doc
"Return file's creation date, or NIL if it doesn't exist.
An error of type file-error is signaled if file is a wild pathname"
- (if (wild-pathname-p file)
- ;; FIXME: This idiom appears many times in this file. Perhaps it
- ;; should turn into (CANNOT-BE-WILD-PATHNAME FILE). (C-B-W-P
- ;; should be a macro, not a function, so that the error message
- ;; is reported as coming from e.g. FILE-WRITE-DATE instead of
- ;; from CANNOT-BE-WILD-PATHNAME itself.)
- (error 'simple-file-error
- :pathname file
- :format-control "bad place for a wild pathname")
- (let ((name (unix-namestring file t)))
- (when name
- (multiple-value-bind
- (res dev ino mode nlink uid gid rdev size atime mtime)
- (sb!unix:unix-stat name)
- (declare (ignore dev ino mode nlink uid gid rdev size atime))
- (when res
- (+ unix-to-universal-time mtime)))))))
+ (let ((name (unix-namestring file t)))
+ (when name
+ (multiple-value-bind
+ (res dev ino mode nlink uid gid rdev size atime mtime)
+ (sb!unix:unix-stat name)
+ (declare (ignore dev ino mode nlink uid gid rdev size atime))
+ (when res
+ (+ unix-to-universal-time mtime))))))
(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."
- (if (wild-pathname-p file)
+ "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."
+ (let ((name (unix-namestring (pathname file) t)))
+ (unless name
(error 'simple-file-error
:pathname file
- "bad place for a wild pathname")
- (let ((name (unix-namestring (pathname file) t)))
- (unless name
- (error 'simple-file-error
- :pathname file
- :format-control "~S doesn't exist."
- :format-arguments (list file)))
- (multiple-value-bind (winp dev ino mode nlink uid)
- (sb!unix:unix-stat name)
- (declare (ignore dev ino mode nlink))
- (if winp (lookup-login-name uid))))))
+ :format-control "~S doesn't exist."
+ :format-arguments (list file)))
+ (multiple-value-bind (winp dev ino mode nlink uid)
+ (sb!unix:unix-stat name)
+ (declare (ignore dev ino mode nlink))
+ (and winp (sb!unix:uid-username uid)))))
\f
;;;; DIRECTORY
(/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 symblolic 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<)))))
-\f
-;;;; translating Unix uid's
-;;;;
-;;;; FIXME: should probably move into unix.lisp
-
-(defvar *uid-hash-table* (make-hash-table)
- #!+sb-doc
- "hash table for keeping track of uid's and login names")
-
-(/show0 "filesys.lisp 844")
-
-;;; LOOKUP-LOGIN-NAME translates a user id into a login name. Previous
-;;; lookups are cached in a hash table since groveling the passwd(s)
-;;; files is somewhat expensive. The table may hold NIL for id's that
-;;; cannot be looked up since this keeps the files from having to be
-;;; searched in their entirety each time this id is translated.
-(defun lookup-login-name (uid)
- (multiple-value-bind (login-name foundp) (gethash uid *uid-hash-table*)
- (if foundp
- login-name
- (setf (gethash uid *uid-hash-table*)
- (get-group-or-user-name :user uid)))))
-
-;;; GET-GROUP-OR-USER-NAME first tries "/etc/passwd" ("/etc/group")
-;;; since it is a much smaller file, contains all the local id's, and
-;;; most uses probably involve id's on machines one would login into.
-;;; Then if necessary, we look in "/etc/passwds" ("/etc/groups") which
-;;; is really long and has to be fetched over the net.
-;;;
-;;; FIXME: Now that we no longer have lookup-group-name, we no longer need
-;;; the GROUP-OR-USER argument.
-(defun get-group-or-user-name (group-or-user id)
- #!+sb-doc
- "Returns the simple-string user or group name of the user whose uid or gid
- is id, or NIL if no such user or group exists. Group-or-user is either
- :group or :user."
- (let ((id-string (let ((*print-base* 10)) (prin1-to-string id))))
- (declare (simple-string id-string))
- (multiple-value-bind (file1 file2)
- (ecase group-or-user
- (:group (values "/etc/group" "/etc/groups"))
- (:user (values "/etc/passwd" "/etc/passwd")))
- (or (get-group-or-user-name-aux id-string file1)
- (get-group-or-user-name-aux id-string file2)))))
-
-;;; FIXME: Isn't there now a POSIX routine to parse the passwd file?
-;;; getpwent? getpwuid?
-(defun get-group-or-user-name-aux (id-string passwd-file)
- (with-open-file (stream passwd-file)
- (loop
- (let ((entry (read-line stream nil)))
- (unless entry (return nil))
- (let ((name-end (position #\: (the simple-string entry)
- :test #'char=)))
- (when name-end
- (let ((id-start (position #\: (the simple-string entry)
- :start (1+ name-end) :test #'char=)))
- (when id-start
- (incf id-start)
- (let ((id-end (position #\: (the simple-string entry)
- :start id-start :test #'char=)))
- (when (and id-end
- (string= id-string entry
- :start2 id-start :end2 id-end))
- (return (subseq entry 0 name-end))))))))))))
+ "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 (;; We create one entry in this hash table for each truename,
+ ;; as an asymptotically efficient way of removing duplicates
+ ;; (which can arise when e.g. multiple symlinks map to the
+ ;; same truename).
+ (truenames (make-hash-table :test #'equal))
+ (merged-pathname (merge-pathnames pathname
+ *default-pathname-defaults*)))
+ (!enumerate-matches (match merged-pathname)
+ (let ((*ignore-wildcards* t)
+ (truename (truename (if (eq (sb!unix:unix-file-kind match)
+ :directory)
+ (concatenate 'string match "/")
+ match))))
+ (setf (gethash (namestring truename) truenames)
+ truename)))
+ (mapcar #'cdr
+ ;; Sorting isn't required by the ANSI spec, but sorting
+ ;; into some canonical order seems good just on the
+ ;; grounds that the implementation should have repeatable
+ ;; behavior when possible.
+ (sort (loop for name being each hash-key in truenames
+ using (hash-value truename)
+ collect (cons name truename))
+ #'string<
+ :key #'car))))
\f
(/show0 "filesys.lisp 899")
-;;; Predicate to order pathnames by. Goes by name.
+;;; predicate to order pathnames by; goes by name
(defun pathname-order (x y)
(let ((xn (%pathname-name x))
(yn (%pathname-name y)))
(t t)))
xn)))
\f
-(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))
- (error (sb!unix:get-unix-error-msg 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")
-\f
(defun ensure-directories-exist (pathspec &key verbose (mode #o777))
#!+sb-doc
- "Tests whether the directories containing the specified file
- actually exist, and attempts to create them if they do not.
- Portable programs should avoid using the :MODE keyword argument."
- (let* ((pathname (pathname pathspec))
- (pathname (if (typep pathname 'logical-pathname)
- (translate-logical-pathname pathname)
- pathname))
- (created-p nil))
+ "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 (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")
projects / sbcl.git / blobdiff