;;; 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
(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 (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))
(#\\
(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")
(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 "/"))))
(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
(/show0 "filesys.lisp 498")
-;;; FIXME: could maybe be EVAL-WHEN (COMPILE EVAL)
-
-(defmacro enumerate-matches ((var pathname &optional result
- &key (verify-existence t)
- (follow-links t))
- &body body)
- (let ((body-name (gensym "ENUMERATE-MATCHES-BODY-FUN-")))
- `(block nil
- (flet ((,body-name (,var)
- ,@body))
- (declare (dynamic-extent ,body-name))
- (%enumerate-matches (pathname ,pathname)
- ,verify-existence
- ,follow-links
- #',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")
;;; 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)))
(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)))
;;; 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")
+ (/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
directory
complete-filename))))))
(t
- (/show0 "default case")
+ (/noshow0 "default case")
(let ((file (concatenate 'string directory name)))
- (/show0 "computed basic FILE=..")
- (/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=..")
- (/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)
))
;;; 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
;; 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)
+ (!enumerate-matches (match namestring nil :verify-existence for-input)
(push match matches))
(case (length matches)
(0 nil)
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))
- (enumerate-search-list
- (pathname (merge-pathnames pathname
- (make-pathname :name :wild
- :type :wild
- :version :wild)))
- (enumerate-matches (match 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)))
+ (let (;; We create one entry in this hash table for each truename,
+ ;; as an asymptotically fast 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
+ (make-pathname :name :wild
+ :type :wild
+ :version :wild))))
+ (!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
;;;; translating Unix uid's
;;;;
;;; Then if necessary, we look in "/etc/passwds" ("/etc/groups") which
;;; is really long and has to be fetched over the net.
;;;
+;;; The result is a SIMPLE-STRING or NIL.
+;;;
;;; 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."
+ (declare (type (member :group :user) group-or-user))
+ (declare (type index id))
(let ((id-string (let ((*print-base* 10)) (prin1-to-string id))))
(declare (simple-string id-string))
(multiple-value-bind (file1 file2)
(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