checked for whatever they may have protected."
(declare (type simple-base-string namestr)
(type index start end))
- (let* ((result (make-string (- end start)))
+ (let* ((result (make-string (- end start) :element-type 'base-char))
(dst 0)
(quoted nil))
(do ((src start (1+ src)))
(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
(let ((piece (car tail)))
(etypecase piece
(simple-string
- (let ((head (concatenate 'string head piece)))
+ (let ((head (concatenate 'base-string head piece)))
(with-directory-node-noted (head)
- (%enumerate-directories (concatenate 'string head "/")
+ (%enumerate-directories (concatenate 'base-string head "/")
(cdr tail) pathname
verify-existence follow-links
nodes function))))
verify-existence follow-links
nodes function)
(dolist (name (ignore-errors (directory-lispy-filenames head)))
- (let ((subdir (concatenate 'string head name)))
+ (let ((subdir (concatenate 'base-string head name)))
(multiple-value-bind (res dev ino mode)
(unix-xstat subdir)
(declare (type (or fixnum null) mode))
(eql (cdr dir) ino))
(return t)))
(let ((nodes (cons (cons dev ino) nodes))
- (subdir (concatenate 'string subdir "/")))
+ (subdir (concatenate 'base-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)))
+ (let ((subdir (concatenate 'base-string head name)))
(multiple-value-bind (res dev ino mode)
(unix-xstat subdir)
(declare (type (or fixnum null) mode))
(eql (logand mode sb!unix:s-ifmt)
sb!unix:s-ifdir))
(let ((nodes (cons (cons dev ino) nodes))
- (subdir (concatenate 'string subdir "/")))
+ (subdir (concatenate 'base-string subdir "/")))
(%enumerate-directories subdir (rest tail) pathname
verify-existence follow-links
nodes function))))))))
((member :up)
(with-directory-node-removed (head)
- (let ((head (concatenate 'string head "..")))
+ (let ((head (concatenate 'base-string head "..")))
(with-directory-node-noted (head)
- (%enumerate-directories (concatenate 'string head "/")
+ (%enumerate-directories (concatenate 'base-string head "/")
(rest tail) pathname
verify-existence follow-links
nodes function)))))))
(components-match file-type type)
(components-match file-version version))
(funcall function
- (concatenate 'string
+ (concatenate 'base-string
directory
complete-filename))))))
(t
(/noshow0 "default case")
- (let ((file (concatenate 'string directory name)))
+ (let ((file (concatenate 'base-string directory name)))
(/noshow "computed basic FILE")
(unless (or (null type) (eq type :unspecific))
(/noshow0 "tweaking FILE for more-or-less-:UNSPECIFIC case")
- (setf file (concatenate 'string file "." type)))
- (unless (member version '(nil :newest :wild))
+ (setf file (concatenate 'base-string file "." type)))
+ (unless (member version '(nil :newest :wild :unspecific))
(/noshow0 "tweaking FILE for more-or-less-:WILD case")
- (setf file (concatenate 'string file "."
+ (setf file (concatenate 'base-string file "."
(quick-integer-to-string version))))
(/noshow0 "finished possibly tweaking FILE")
(when (or (not verify-existence)
((zerop n) "0")
((eql n 1) "1")
((minusp n)
- (concatenate 'simple-string "-"
- (the simple-string (quick-integer-to-string (- n)))))
+ (concatenate 'simple-base-string "-"
+ (the simple-base-string (quick-integer-to-string (- n)))))
(t
(do* ((len (1+ (truncate (integer-length n) 3)))
- (res (make-string len))
+ (res (make-string len :element-type 'base-char))
(i (1- len) (1- i))
(q n)
(r 0))
(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 (error 'simple-file-error
- :format-control "~S is ambiguous:~{~% ~A~}"
- :format-arguments (list pathname-spec matches))))))
+ (t (bug "!ENUMERATE-MATCHES returned more than one match on a non-wild pathname")))))
\f
;;;; TRUENAME and PROBE-FILE
Under Unix, the TRUENAME of a broken symlink is considered to be
the name of the broken symlink itself."
- (if (wild-pathname-p pathname)
+ (let ((result (probe-file pathname)))
+ (unless result
(error 'simple-file-error
- :format-control "can't use a wild pathname here"
- :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)))
-
-;;; If PATHNAME exists, return its truename, otherwise NIL.
+ :pathname pathname
+ :format-control "The file ~S does not exist."
+ :format-arguments (list (namestring pathname))))
+ result))
+
(defun probe-file (pathname)
#!+sb-doc
"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."
- (when (wild-pathname-p pathname)
- (error 'simple-file-error
- :pathname pathname
- :format-control "can't use a wild pathname here"))
(let* ((defaulted-pathname (merge-pathnames
pathname
(sane-default-pathname-defaults)))
(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))))))))
+ (let* ((*ignore-wildcards* t)
+ (name (sb!unix:unix-simplify-pathname trueishname)))
+ (if (eq (sb!unix:unix-file-kind name) :directory)
+ (pathname (concatenate 'string name "/"))
+ (pathname name))))))))
\f
;;;; miscellaneous other operations
#!+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
"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)
+ (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))
- (and winp (sb!unix:uid-username 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
;; (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*)))
+ (merged-pathname (merge-pathnames pathname)))
(!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)))
+ (let* ((*ignore-wildcards* t)
+ ;; FIXME: Why not TRUENAME? As reported by Milan Zamazal
+ ;; sbcl-devel 2003-10-05, using TRUENAME causes a race
+ ;; condition whereby removal of a file during the
+ ;; directory operation causes an error. It's not clear
+ ;; what the right thing to do is, though. -- CSR,
+ ;; 2003-10-13
+ (truename (probe-file match)))
+ (when truename
+ (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
projects / sbcl.git / blobdiff