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)))
(setf start (1+ slash))))
(values absolute (pieces)))))
-;;; 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 (missing-arg) :type simple-string))
-
-(defun maybe-extract-logical-hostname (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 (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))
(multiple-value-bind (absolute pieces) (split-at-slashes namestr start end)
- (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)))
-
- (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)))))
+ (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 ((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 "/"))))
+ (pieces "/"))
(:relative
;; nothing special
))
(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))
;;; 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))
- ;; The ordinary rules of converting Lispy paths to Unix paths break
- ;; down for the current working directory, which Lisp thinks of as
- ;; "" (more or less, and modulo ANSI's *DEFAULT-PATHNAME-DEFAULTS*,
- ;; which unfortunately SBCL, as of sbcl-0.6.12.8, basically ignores)
- ;; and Unix thinks of as ".". Since we're at the interface between
- ;; Unix system calls and things like ENSURE-DIRECTORIES-EXIST which
- ;; think the Lisp way, we perform the conversion.
- ;;
- ;; (FIXME: The *right* way to deal with this special case is to
- ;; merge PATHNAME-SPEC with *DEFAULT-PATHNAME-DEFAULTS* here, after
- ;; which it's not a relative pathname any more so the special case
- ;; is no longer an issue. But until *DEFAULT-PATHNAME-DEFAULTS*
- ;; works, we use this hack.)
- (if (empty-relative-pathname-spec-p pathname-spec)
- "."
- ;; Otherwise, the ordinary rules apply.
- (let* ((namestring (physicalize-pathname (pathname pathname-spec)))
- (matches nil)) ; an accumulator for actual matches
- (!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)))))))
+ (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
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)))
+ :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, 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
t)
\f
;;; (This is an ANSI Common Lisp function.)
-;;;
-;;; This is obtained from the logical name \"home:\", which is set
-;;; up for us at initialization time.
(defun user-homedir-pathname (&optional host)
"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
"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))))
+ (let* ((*ignore-wildcards* t)
+ (truename (truename match)))
(setf (gethash (namestring truename) truenames)
truename)))
(mapcar #'cdr
projects / sbcl.git / blobdiff