("src/code/reader" :not-host) ; needs "code/readtable"
("src/code/target-stream" :not-host) ; needs WHITESPACEP from "code/reader"
("src/code/target-pathname" :not-host) ; needs "code/pathname"
+ ("src/code/unix-pathname" :not-host)
+ ("src/code/win32-pathname" :not-host)
("src/code/filesys" :not-host) ; needs HOST from "code/pathname"
+
("src/code/save" :not-host) ; uses the definition of PATHNAME
; from "code/pathname"
("src/code/sharpm" :not-host) ; uses stuff from "code/reader"
-;;;; file system interface functions -- fairly Unix-specific
+;;;; file system interface functions -- fairly Unix-centric, but with
+;;;; differences between Unix and Win32 papered over.
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
\f
;;;; Unix pathname host support
+;;; FIXME: the below shouldn't really be here, but in documentation
+;;; (chapter 19 makes a lot of requirements for documenting
+;;; implementation-dependent decisions), but anyway it's probably not
+;;; what we currently do.
+;;;
;;; Unix namestrings have the following format:
;;;
;;; namestring := [ directory ] [ file [ type [ version ]]]
;;; - If the first character is a dot, it's part of the file. It is not
;;; considered a dot in the following rules.
;;;
-;;; - If there is only one dot, it separates the file and the type.
-;;;
-;;; - If there are multiple dots and the stuff following the last dot
-;;; is a valid version, then that is the version and the stuff between
-;;; the second to last dot and the last dot is the type.
+;;; - Otherwise, the last dot separates the file and the type.
;;;
;;; Wildcard characters:
;;;
;;; following characters, it is considered part of a wildcard pattern
;;; and has the following meaning.
;;;
-;;; ? - matches any character
+;;; ? - matches any one character
;;; * - matches any zero or more characters.
;;; [abc] - matches any of a, b, or c.
;;; {str1,str2,...,strn} - matches any of str1, str2, ..., or strn.
+;;; (FIXME: no it doesn't)
;;;
;;; Any of these special characters can be preceded by a backslash to
;;; cause it to be treated as a regular character.
(/show0 "filesys.lisp 200")
-;;; Take a string and return a list of cons cells that mark the char
-;;; 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))
- (let ((absolute (and (/= start end)
- (char= (schar namestr start) #\/))))
- (when absolute
- (incf start))
- ;; Next, split the remainder into slash-separated chunks.
- (collect ((pieces))
- (loop
- (let ((slash (position #\/ namestr :start start :end end)))
- (pieces (cons start (or slash end)))
- (unless slash
- (return))
- (setf start (1+ slash))))
- (values absolute (pieces)))))
-
-(defun parse-unix-namestring (namestring start end)
- (declare (type simple-string namestring)
- (type index start end))
- (setf namestring (coerce namestring 'simple-base-string))
- (multiple-value-bind (absolute pieces)
- (split-at-slashes namestring start end)
- (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 namestring 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 namestring
- :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= namestring ".."
- :start1 piece-start
- :end1 piece-end)
- (dirs :up))
- ((string= namestring "**"
- :start1 piece-start
- :end1 piece-end)
- (dirs :wild-inferiors))
- (t
- (dirs (maybe-make-pattern namestring
- piece-start
- piece-end)))))))
- (cond (absolute
- (cons :absolute (dirs)))
- ((dirs)
- (cons :relative (dirs)))
- (t
- nil)))
- name
- type
- version))))
-
-(defun parse-native-unix-namestring (namestring start end)
- (declare (type simple-string namestring)
- (type index start end))
- (setf namestring (coerce namestring 'simple-base-string))
- (multiple-value-bind (absolute ranges)
- (split-at-slashes namestring start end)
- (let* ((components (loop for ((start . end) . rest) on ranges
- for piece = (subseq namestring start end)
- collect (if (and (string= piece "..") rest)
- :up
- piece)))
- (name-and-type
- (let* ((end (first (last components)))
- (dot (position #\. end :from-end t)))
- ;; FIXME: can we get this dot-interpretation knowledge
- ;; from existing code? EXTRACT-NAME-TYPE-AND-VERSION
- ;; does slightly more work than that.
- (cond
- ((string= end "")
- (list nil nil))
- ((and dot (> dot 0))
- (list (subseq end 0 dot) (subseq end (1+ dot))))
- (t
- (list end nil))))))
- (values nil
- nil
- (cons (if absolute :absolute :relative) (butlast components))
- (first name-and-type)
- (second name-and-type)
- nil))))
-
-(/show0 "filesys.lisp 300")
-
-(defun unparse-unix-host (pathname)
- (declare (type pathname pathname)
- (ignore pathname))
- ;; 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
- ((member :wild) "*")
- (simple-string
- (let* ((srclen (length thing))
- (dstlen srclen))
- (dotimes (i srclen)
- (case (schar thing i)
- ((#\* #\? #\[)
- (incf dstlen))))
- (let ((result (make-string dstlen))
- (dst 0))
- (dotimes (src srclen)
- (let ((char (schar thing src)))
- (case char
- ((#\* #\? #\[)
- (setf (schar result dst) #\\)
- (incf dst)))
- (setf (schar result dst) char)
- (incf dst)))
- result)))
- (pattern
- (collect ((strings))
- (dolist (piece (pattern-pieces thing))
- (etypecase piece
- (simple-string
- (strings piece))
- (symbol
- (ecase piece
- (:multi-char-wild
- (strings "*"))
- (:single-char-wild
- (strings "?"))))
- (cons
- (case (car piece)
- (:character-set
- (strings "[")
- (strings (cdr piece))
- (strings "]"))
- (t
- (error "invalid pattern piece: ~S" piece))))))
- (apply #'concatenate
- 'simple-base-string
- (strings))))))
-
-(defun unparse-unix-directory-list (directory)
- (declare (type list directory))
- (collect ((pieces))
- (when directory
- (ecase (pop directory)
- (:absolute
- (pieces "/"))
- (:relative
- ;; nothing special
- ))
- (dolist (dir directory)
- (typecase dir
- ((member :up)
- (pieces "../"))
- ((member :back)
- (error ":BACK cannot be represented in namestrings."))
- ((member :wild-inferiors)
- (pieces "**/"))
- ((or simple-string pattern (member :wild))
- (pieces (unparse-unix-piece dir))
- (pieces "/"))
- (t
- (error "invalid directory component: ~S" dir)))))
- (apply #'concatenate 'simple-base-string (pieces))))
-
-(defun unparse-unix-directory (pathname)
- (declare (type pathname pathname))
- (unparse-unix-directory-list (%pathname-directory pathname)))
-
-(defun unparse-unix-file (pathname)
- (declare (type pathname pathname))
- (collect ((strings))
- (let* ((name (%pathname-name pathname))
- (type (%pathname-type pathname))
- (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
- (when (and (null type)
- (typep name 'string)
- (> (length name) 0)
- (position #\. name :start 1))
- (error "too many dots in the name: ~S" pathname))
- (when (and (typep name 'string)
- (string= name ""))
- (error "name is of length 0: ~S" pathname))
- (strings (unparse-unix-piece name)))
- (when type-supplied
- (unless name
- (error "cannot specify the type without a file: ~S" pathname))
- (when (typep type 'simple-string)
- (when (position #\. type)
- (error "type component can't have a #\. inside: ~S" pathname)))
- (strings ".")
- (strings (unparse-unix-piece type))))
- (apply #'concatenate 'simple-base-string (strings))))
-
-(/show0 "filesys.lisp 406")
-
-(defun unparse-unix-namestring (pathname)
- (declare (type pathname pathname))
- (concatenate 'simple-base-string
- (unparse-unix-directory pathname)
- (unparse-unix-file pathname)))
-
-(defun unparse-native-unix-namestring (pathname)
- (declare (type pathname pathname))
- (let ((directory (pathname-directory pathname))
- (name (pathname-name pathname))
- (type (pathname-type pathname)))
- (coerce
- (with-output-to-string (s)
- (ecase (car directory)
- (:absolute (write-char #\/ s))
- (:relative))
- (dolist (piece (cdr directory))
- (typecase piece
- ((member :up) (write-string ".." s))
- (string (write-string piece s))
- (t (error "ungood piece in NATIVE-NAMESTRING: ~S" piece)))
- (write-char #\/ s))
- (when name
- (unless (stringp name)
- (error "non-STRING name in NATIVE-NAMESTRING: ~S" name))
- (write-string name s)
- (when type
- (unless (stringp type)
- (error "non-STRING type in NATIVE-NAMESTRING: ~S" name))
- (write-char #\. s)
- (write-string type s))))
- 'simple-base-string)))
-
-(defun unparse-unix-enough (pathname defaults)
- (declare (type pathname pathname defaults))
- (flet ((lose ()
- (error "~S cannot be represented relative to ~S."
- pathname defaults)))
- (collect ((strings))
- (let* ((pathname-directory (%pathname-directory pathname))
- (defaults-directory (%pathname-directory defaults))
- (prefix-len (length defaults-directory))
- (result-directory
- (cond ((null pathname-directory) '(:relative))
- ((eq (car pathname-directory) :relative)
- pathname-directory)
- ((and (> prefix-len 1)
- (>= (length pathname-directory) prefix-len)
- (compare-component (subseq pathname-directory
- 0 prefix-len)
- defaults-directory))
- ;; Pathname starts with a prefix of default. So
- ;; just use a relative directory from then on out.
- (cons :relative (nthcdr prefix-len pathname-directory)))
- ((eq (car pathname-directory) :absolute)
- ;; We are an absolute pathname, so we can just use it.
- pathname-directory)
- (t
- (bug "Bad fallthrough in ~S" 'unparse-unix-enough)))))
- (strings (unparse-unix-directory-list result-directory)))
- (let* ((pathname-type (%pathname-type pathname))
- (type-needed (and pathname-type
- (not (eq pathname-type :unspecific))))
- (pathname-name (%pathname-name pathname))
- (name-needed (or type-needed
- (and pathname-name
- (not (compare-component pathname-name
- (%pathname-name
- defaults)))))))
- (when name-needed
- (unless pathname-name (lose))
- (when (and (null pathname-type)
- (position #\. pathname-name :start 1))
- (error "too many dots in the name: ~S" pathname))
- (strings (unparse-unix-piece pathname-name)))
- (when type-needed
- (when (or (null pathname-type) (eq pathname-type :unspecific))
- (lose))
- (when (typep pathname-type 'simple-base-string)
- (when (position #\. pathname-type)
- (error "type component can't have a #\. inside: ~S" pathname)))
- (strings ".")
- (strings (unparse-unix-piece pathname-type))))
- (apply #'concatenate 'simple-string (strings)))))
\f
;;;; wildcard matching stuff
(/show0 "filesys.lisp 500")
;;; Call FUNCTION on matches.
+;;;
+;;; KLUDGE: this assumes that an absolute pathname is indicated to the
+;;; operating system by having a directory separator as the first
+;;; character in the directory part. This is true for Win32 pathnames
+;;; and for Unix pathnames, but it isn't true for LispM pathnames (and
+;;; their bastard offspring, logical pathnames. Also it assumes that
+;;; Unix pathnames have an empty or :unspecific device, and that
+;;; windows drive letters are the only kinds of non-empty/:UNSPECIFIC
+;;; devices.
(defun %enumerate-matches (pathname verify-existence follow-links function)
(/noshow0 "entering %ENUMERATE-MATCHES")
(when (pathname-type pathname)
(when (and (integerp (pathname-version pathname))
(member (pathname-type pathname) '(nil :unspecific)))
(error "cannot supply a version without a type:~% ~S" pathname))
- (let ((directory (pathname-directory pathname)))
- (/noshow0 "computed DIRECTORY")
- (if directory
- (ecase (first directory)
- (:absolute
- (/noshow0 "absolute directory")
- (%enumerate-directories "/" (rest directory) pathname
- verify-existence follow-links
- nil function))
- (:relative
- (/noshow0 "relative directory")
- (%enumerate-directories "" (rest directory) pathname
- verify-existence follow-links
- nil function)))
- (%enumerate-files "" pathname verify-existence function))))
+ (let ((host (pathname-host pathname))
+ (device (pathname-device pathname))
+ (directory (pathname-directory pathname)))
+ (/noshow0 "computed HOST and DIRECTORY")
+ (let* ((dirstring (if directory
+ (ecase (first directory)
+ (:absolute (host-unparse-directory-separator host))
+ (:relative ""))
+ ""))
+ (devstring (if (and device (not (eq device :unspecific)))
+ (concatenate 'simple-base-string (string device) (string #\:))
+ ""))
+ (headstring (concatenate 'simple-base-string devstring dirstring)))
+ (if directory
+ (%enumerate-directories headstring (rest directory) pathname
+ verify-existence follow-links nil function)
+ (%enumerate-files headstring pathname verify-existence function)))))
;;; Call FUNCTION on directories.
(defun %enumerate-directories (head tail pathname verify-existence
- follow-links nodes function)
+ follow-links nodes function
+ &aux (host (pathname-host pathname)))
(declare (simple-string head))
(macrolet ((unix-xstat (name)
`(if follow-links
(simple-string
(let ((head (concatenate 'base-string head piece)))
(with-directory-node-noted (head)
- (%enumerate-directories (concatenate 'base-string head "/")
- (cdr tail) pathname
- verify-existence follow-links
- nodes function))))
+ (%enumerate-directories
+ (concatenate 'base-string head
+ (host-unparse-directory-separator host))
+ (cdr tail) pathname
+ verify-existence follow-links
+ nodes function))))
((member :wild-inferiors)
;; now with extra error case handling from CLHS
;; 19.2.2.4.3 -- CSR, 2004-01-24
(eql (cdr dir) ino))
(return t)))
(let ((nodes (cons (cons dev ino) nodes))
- (subdir (concatenate 'base-string subdir "/")))
+ (subdir (concatenate 'base-string subdir (host-unparse-directory-separator host))))
(%enumerate-directories subdir tail pathname
verify-existence follow-links
nodes function))))))))
(eql (logand mode sb!unix:s-ifmt)
sb!unix:s-ifdir))
(let ((nodes (cons (cons dev ino) nodes))
- (subdir (concatenate 'base-string subdir "/")))
+ (subdir (concatenate 'base-string subdir (host-unparse-directory-separator host))))
(%enumerate-directories subdir (rest tail) pathname
verify-existence follow-links
nodes function))))))))
((member :up)
- (when (string= head "/")
+ (when (string= head (host-unparse-directory-separator host))
(error 'simple-file-error
:pathname pathname
:format-control "~@<invalid use of :UP after :ABSOLUTE.~@:>"))
(with-directory-node-removed (head)
(let ((head (concatenate 'base-string head "..")))
(with-directory-node-noted (head)
- (%enumerate-directories (concatenate 'base-string head "/")
+ (%enumerate-directories (concatenate 'base-string head (host-unparse-directory-separator host))
(rest tail) pathname
verify-existence follow-links
nodes function)))))
((member :back)
;; :WILD-INFERIORS is handled above, so the only case here
;; should be (:ABSOLUTE :BACK)
- (aver (string= head "/"))
+ (aver (string= head (host-unparse-directory-separator host)))
(error 'simple-file-error
:pathname pathname
:format-control "~@<invalid use of :BACK after :ABSOLUTE.~@:>"))))
;;; 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: apart from the error checking (for wildness and for
+;;; existence) and conversion to physical pathanme, this is redundant
+;;; with UNPARSE-NATIVE-UNIX-NAMESTRING; one should probably be
+;;; written in terms of the other.
+;;;
+;;; FIXME: actually this (I think) works not just for Unix.
(defun unix-namestring (pathname-spec &optional (for-input t))
(let* ((namestring (physicalize-pathname (merge-pathnames pathname-spec)))
(matches nil)) ; an accumulator for actual matches
(let* ((*ignore-wildcards* t)
(name (sb!unix:unix-simplify-pathname trueishname)))
(if (eq (sb!unix:unix-file-kind name) :directory)
+ ;; FIXME: this might work, but it's ugly.
(pathname (concatenate 'string name "/"))
(pathname name))))))))
\f
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)))
+ (let ((pathname (physicalize-pathname (merge-pathnames (pathname pathspec))))
(created-p nil))
(when (wild-pathname-p pathname)
(error 'simple-file-error
(unparse-directory (missing-arg) :type function)
(unparse-file (missing-arg) :type function)
(unparse-enough (missing-arg) :type function)
+ (unparse-directory-separator (missing-arg) :type simple-string)
(customary-case (missing-arg) :type (member :upper :lower)))
(def!method print-object ((host host) stream)
(unparse-directory #'unparse-logical-directory)
(unparse-file #'unparse-logical-file)
(unparse-enough #'unparse-enough-namestring)
+ (unparse-directory-separator ";")
(customary-case :upper)))
(name "" :type simple-base-string)
(translations nil :type list)
#!-sb-fluid (declaim (freeze-type logical-pathname logical-host))
\f
-;;;; UNIX-HOST stuff
+;;;; PHYSICAL-HOST stuff
(def!struct (unix-host
(:make-load-form-fun make-unix-host-load-form)
(unparse-directory #'unparse-unix-directory)
(unparse-file #'unparse-unix-file)
(unparse-enough #'unparse-unix-enough)
+ (unparse-directory-separator "/")
(customary-case :lower))))
-
(defvar *unix-host* (make-unix-host))
-
(defun make-unix-host-load-form (host)
(declare (ignore host))
'*unix-host*)
-(defvar *physical-host* *unix-host*)
+(def!struct (win32-host
+ (:make-load-form-fun make-win32-host-load-form)
+ (:include host
+ (parse #'parse-win32-namestring)
+ (parse-native #'parse-native-win32-namestring)
+ (unparse #'unparse-win32-namestring)
+ (unparse-native #'unparse-native-win32-namestring)
+ (unparse-host #'unparse-win32-host)
+ (unparse-directory #'unparse-win32-directory)
+ (unparse-file #'unparse-win32-file)
+ (unparse-enough #'unparse-win32-enough)
+ (unparse-directory-separator "\\")
+ (customary-case :upper))))
+(defvar *win32-host* (make-win32-host))
+(defun make-win32-host-load-form (host)
+ (declare (ignore host))
+ '*win32-host*)
+
+(defvar *physical-host*
+ #!-win32 *unix-host*
+ #!+win32 *win32-host*)
;;; Return a value suitable, e.g., for preinitializing
;;; *DEFAULT-PATHNAME-DEFAULTS* before *DEFAULT-PATHNAME-DEFAULTS* is
--- /dev/null
+;;;; pathname parsing for Unix filesystems
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+;;; Take a string and return a list of cons cells that mark the char
+;;; 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))
+ (let ((absolute (and (/= start end)
+ (char= (schar namestr start) #\/))))
+ (when absolute
+ (incf start))
+ ;; Next, split the remainder into slash-separated chunks.
+ (collect ((pieces))
+ (loop
+ (let ((slash (position #\/ namestr :start start :end end)))
+ (pieces (cons start (or slash end)))
+ (unless slash
+ (return))
+ (setf start (1+ slash))))
+ (values absolute (pieces)))))
+
+(defun parse-unix-namestring (namestring start end)
+ (declare (type simple-string namestring)
+ (type index start end))
+ (setf namestring (coerce namestring 'simple-base-string))
+ (multiple-value-bind (absolute pieces)
+ (split-at-slashes namestring start end)
+ (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 namestring 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 namestring
+ :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= namestring ".."
+ :start1 piece-start
+ :end1 piece-end)
+ (dirs :up))
+ ((string= namestring "**"
+ :start1 piece-start
+ :end1 piece-end)
+ (dirs :wild-inferiors))
+ (t
+ (dirs (maybe-make-pattern namestring
+ piece-start
+ piece-end)))))))
+ (cond (absolute
+ (cons :absolute (dirs)))
+ ((dirs)
+ (cons :relative (dirs)))
+ (t
+ nil)))
+ name
+ type
+ version))))
+
+(defun parse-native-unix-namestring (namestring start end)
+ (declare (type simple-string namestring)
+ (type index start end))
+ (setf namestring (coerce namestring 'simple-base-string))
+ (multiple-value-bind (absolute ranges)
+ (split-at-slashes namestring start end)
+ (let* ((components (loop for ((start . end) . rest) on ranges
+ for piece = (subseq namestring start end)
+ collect (if (and (string= piece "..") rest)
+ :up
+ piece)))
+ (name-and-type
+ (let* ((end (first (last components)))
+ (dot (position #\. end :from-end t)))
+ ;; FIXME: can we get this dot-interpretation knowledge
+ ;; from existing code? EXTRACT-NAME-TYPE-AND-VERSION
+ ;; does slightly more work than that.
+ (cond
+ ((string= end "")
+ (list nil nil))
+ ((and dot (> dot 0))
+ (list (subseq end 0 dot) (subseq end (1+ dot))))
+ (t
+ (list end nil))))))
+ (values nil
+ nil
+ (cons (if absolute :absolute :relative) (butlast components))
+ (first name-and-type)
+ (second name-and-type)
+ nil))))
+
+(/show0 "filesys.lisp 300")
+
+(defun unparse-unix-host (pathname)
+ (declare (type pathname pathname)
+ (ignore pathname))
+ ;; 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
+ ((member :wild) "*")
+ (simple-string
+ (let* ((srclen (length thing))
+ (dstlen srclen))
+ (dotimes (i srclen)
+ (case (schar thing i)
+ ((#\* #\? #\[)
+ (incf dstlen))))
+ (let ((result (make-string dstlen))
+ (dst 0))
+ (dotimes (src srclen)
+ (let ((char (schar thing src)))
+ (case char
+ ((#\* #\? #\[)
+ (setf (schar result dst) #\\)
+ (incf dst)))
+ (setf (schar result dst) char)
+ (incf dst)))
+ result)))
+ (pattern
+ (collect ((strings))
+ (dolist (piece (pattern-pieces thing))
+ (etypecase piece
+ (simple-string
+ (strings piece))
+ (symbol
+ (ecase piece
+ (:multi-char-wild
+ (strings "*"))
+ (:single-char-wild
+ (strings "?"))))
+ (cons
+ (case (car piece)
+ (:character-set
+ (strings "[")
+ (strings (cdr piece))
+ (strings "]"))
+ (t
+ (error "invalid pattern piece: ~S" piece))))))
+ (apply #'concatenate
+ 'simple-base-string
+ (strings))))))
+
+(defun unparse-unix-directory-list (directory)
+ (declare (type list directory))
+ (collect ((pieces))
+ (when directory
+ (ecase (pop directory)
+ (:absolute
+ (pieces "/"))
+ (:relative
+ ;; nothing special
+ ))
+ (dolist (dir directory)
+ (typecase dir
+ ((member :up)
+ (pieces "../"))
+ ((member :back)
+ (error ":BACK cannot be represented in namestrings."))
+ ((member :wild-inferiors)
+ (pieces "**/"))
+ ((or simple-string pattern (member :wild))
+ (pieces (unparse-unix-piece dir))
+ (pieces "/"))
+ (t
+ (error "invalid directory component: ~S" dir)))))
+ (apply #'concatenate 'simple-base-string (pieces))))
+
+(defun unparse-unix-directory (pathname)
+ (declare (type pathname pathname))
+ (unparse-unix-directory-list (%pathname-directory pathname)))
+
+(defun unparse-unix-file (pathname)
+ (declare (type pathname pathname))
+ (collect ((strings))
+ (let* ((name (%pathname-name pathname))
+ (type (%pathname-type pathname))
+ (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
+ (when (and (null type)
+ (typep name 'string)
+ (> (length name) 0)
+ (position #\. name :start 1))
+ (error "too many dots in the name: ~S" pathname))
+ (when (and (typep name 'string)
+ (string= name ""))
+ (error "name is of length 0: ~S" pathname))
+ (strings (unparse-unix-piece name)))
+ (when type-supplied
+ (unless name
+ (error "cannot specify the type without a file: ~S" pathname))
+ (when (typep type 'simple-string)
+ (when (position #\. type)
+ (error "type component can't have a #\. inside: ~S" pathname)))
+ (strings ".")
+ (strings (unparse-unix-piece type))))
+ (apply #'concatenate 'simple-base-string (strings))))
+
+(/show0 "filesys.lisp 406")
+
+(defun unparse-unix-namestring (pathname)
+ (declare (type pathname pathname))
+ (concatenate 'simple-base-string
+ (unparse-unix-directory pathname)
+ (unparse-unix-file pathname)))
+
+(defun unparse-native-unix-namestring (pathname)
+ (declare (type pathname pathname))
+ (let ((directory (pathname-directory pathname))
+ (name (pathname-name pathname))
+ (type (pathname-type pathname)))
+ (coerce
+ (with-output-to-string (s)
+ (ecase (car directory)
+ (:absolute (write-char #\/ s))
+ (:relative))
+ (dolist (piece (cdr directory))
+ (typecase piece
+ ((member :up) (write-string ".." s))
+ (string (write-string piece s))
+ (t (error "ungood piece in NATIVE-NAMESTRING: ~S" piece)))
+ (write-char #\/ s))
+ (when name
+ (unless (stringp name)
+ (error "non-STRING name in NATIVE-NAMESTRING: ~S" name))
+ (write-string name s)
+ (when type
+ (unless (stringp type)
+ (error "non-STRING type in NATIVE-NAMESTRING: ~S" name))
+ (write-char #\. s)
+ (write-string type s))))
+ 'simple-base-string)))
+
+(defun unparse-unix-enough (pathname defaults)
+ (declare (type pathname pathname defaults))
+ (flet ((lose ()
+ (error "~S cannot be represented relative to ~S."
+ pathname defaults)))
+ (collect ((strings))
+ (let* ((pathname-directory (%pathname-directory pathname))
+ (defaults-directory (%pathname-directory defaults))
+ (prefix-len (length defaults-directory))
+ (result-directory
+ (cond ((null pathname-directory) '(:relative))
+ ((eq (car pathname-directory) :relative)
+ pathname-directory)
+ ((and (> prefix-len 1)
+ (>= (length pathname-directory) prefix-len)
+ (compare-component (subseq pathname-directory
+ 0 prefix-len)
+ defaults-directory))
+ ;; Pathname starts with a prefix of default. So
+ ;; just use a relative directory from then on out.
+ (cons :relative (nthcdr prefix-len pathname-directory)))
+ ((eq (car pathname-directory) :absolute)
+ ;; We are an absolute pathname, so we can just use it.
+ pathname-directory)
+ (t
+ (bug "Bad fallthrough in ~S" 'unparse-unix-enough)))))
+ (strings (unparse-unix-directory-list result-directory)))
+ (let* ((pathname-type (%pathname-type pathname))
+ (type-needed (and pathname-type
+ (not (eq pathname-type :unspecific))))
+ (pathname-name (%pathname-name pathname))
+ (name-needed (or type-needed
+ (and pathname-name
+ (not (compare-component pathname-name
+ (%pathname-name
+ defaults)))))))
+ (when name-needed
+ (unless pathname-name (lose))
+ (when (and (null pathname-type)
+ (position #\. pathname-name :start 1))
+ (error "too many dots in the name: ~S" pathname))
+ (strings (unparse-unix-piece pathname-name)))
+ (when type-needed
+ (when (or (null pathname-type) (eq pathname-type :unspecific))
+ (lose))
+ (when (typep pathname-type 'simple-base-string)
+ (when (position #\. pathname-type)
+ (error "type component can't have a #\. inside: ~S" pathname)))
+ (strings ".")
+ (strings (unparse-unix-piece pathname-type))))
+ (apply #'concatenate 'simple-string (strings)))))
;; helpful, either, as Solaris doesn't export PATH_MAX from
;; unistd.h.
;;
- ;; The Win32 damage here is explained in the comment above wrap_getcwd()
- ;; in src/runtime/wrap.c. Short form: We need it now, it goes away later.
- ;;
;; FIXME: The (,stub,) nastiness produces an error message about a
;; comma not inside a backquote. This error has absolutely nothing
;; to do with the actual meaning of the error (and little to do with
;; its location, either).
#!-(or linux openbsd freebsd netbsd sunos osf1 darwin win32) (,stub,)
#!+(or linux openbsd freebsd netbsd sunos osf1 darwin win32)
- (or (newcharstar-string (alien-funcall (extern-alien #!-win32 "getcwd"
- #!+win32 "wrap_getcwd"
+ (or (newcharstar-string (alien-funcall (extern-alien "getcwd"
(function (* char)
(* char)
size-t))
;;; try to handle any more generality than that.
(defun unix-resolve-links (pathname)
(declare (type simple-base-string pathname))
+ ;; KLUDGE: The Win32 platform doesn't have symbolic links, so
+ ;; short-cut this computation (and the check for being an absolute
+ ;; unix pathname...)
+ #!+win32 (return-from unix-resolve-links pathname)
(aver (not (relative-unix-pathname? pathname)))
;; KLUDGE: readlink and lstat are unreliable if given symlinks
;; ending in slashes -- fix the issue here instead of waiting for
--- /dev/null
+;;;; pathname parsing for Win32 filesystems
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(defun extract-device (namestr start end)
+ (declare (type simple-base-string namestr)
+ (type index start end))
+ (if (and (>= end (+ start 2))
+ (alpha-char-p (char namestr start))
+ (eql (char namestr (1+ start)) #\:))
+ (values (string (char namestr start)) (+ start 2))
+ (values nil start)))
+
+(defun split-at-slashes-and-backslashes (namestr start end)
+ (declare (type simple-base-string namestr)
+ (type index start end))
+ (let ((absolute (and (/= start end)
+ (or (char= (schar namestr start) #\/)
+ (char= (schar namestr start) #\\)))))
+ (when absolute
+ (incf start))
+ ;; Next, split the remainder into slash-separated chunks.
+ (collect ((pieces))
+ (loop
+ (let ((slash (position-if (lambda (c)
+ (or (char= c #\/)
+ (char= c #\\)))
+ namestr :start start :end end)))
+ (pieces (cons start (or slash end)))
+ (unless slash
+ (return))
+ (setf start (1+ slash))))
+ (values absolute (pieces)))))
+
+(defun parse-win32-namestring (namestring start end)
+ (declare (type simple-string namestring)
+ (type index start end))
+ (setf namestring (coerce namestring 'simple-base-string))
+ (multiple-value-bind (device new-start)
+ (extract-device namestring start end)
+ (multiple-value-bind (absolute pieces)
+ (split-at-slashes-and-backslashes namestring new-start end)
+ (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 namestring 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 namestring
+ :offset position))))
+ ;; Now we have everything we want. So return it.
+ (values nil ; no host for Win32 namestrings
+ device
+ (collect ((dirs))
+ (dolist (piece pieces)
+ (let ((piece-start (car piece))
+ (piece-end (cdr piece)))
+ (unless (= piece-start piece-end)
+ (cond ((string= namestring ".."
+ :start1 piece-start
+ :end1 piece-end)
+ (dirs :up))
+ ((string= namestring "**"
+ :start1 piece-start
+ :end1 piece-end)
+ (dirs :wild-inferiors))
+ (t
+ (dirs (maybe-make-pattern namestring
+ piece-start
+ piece-end)))))))
+ (cond (absolute
+ (cons :absolute (dirs)))
+ ((dirs)
+ (cons :relative (dirs)))
+ (t
+ nil)))
+ name
+ type
+ version)))))
+
+(defun parse-native-win32-namestring (namestring start end)
+ (declare (type simple-string namestring)
+ (type index start end))
+ (setf namestring (coerce namestring 'simple-base-string))
+ (multiple-value-bind (device new-start)
+ (extract-device namestring start end)
+ (multiple-value-bind (absolute ranges)
+ (split-at-slashes-and-backslashes namestring new-start end)
+ (let* ((components (loop for ((start . end) . rest) on ranges
+ for piece = (subseq namestring start end)
+ collect (if (and (string= piece "..") rest)
+ :up
+ piece)))
+ (name-and-type
+ (let* ((end (first (last components)))
+ (dot (position #\. end :from-end t)))
+ ;; FIXME: can we get this dot-interpretation knowledge
+ ;; from existing code? EXTRACT-NAME-TYPE-AND-VERSION
+ ;; does slightly more work than that.
+ (cond
+ ((string= end "")
+ (list nil nil))
+ ((and dot (> dot 0))
+ (list (subseq end 0 dot) (subseq end (1+ dot))))
+ (t
+ (list end nil))))))
+ (values nil
+ device
+ (cons (if absolute :absolute :relative) (butlast components))
+ (first name-and-type)
+ (second name-and-type)
+ nil)))))
+
+
+
+(defun unparse-win32-host (pathname)
+ (declare (type pathname pathname)
+ (ignore pathname))
+ ;; FIXME: same as UNPARSE-UNIX-HOST. That's probably not good.
+ "")
+
+(defun unparse-win32-device (pathname)
+ (declare (type pathname pathname))
+ (let ((device (pathname-device pathname)))
+ (if (or (null device) (eq device :unspecific))
+ ""
+ (concatenate 'simple-string (string device) ":"))))
+
+(defun unparse-win32-piece (thing)
+ (etypecase thing
+ ((member :wild) "*")
+ (simple-string
+ (let* ((srclen (length thing))
+ (dstlen srclen))
+ (dotimes (i srclen)
+ (case (schar thing i)
+ ((#\* #\? #\[)
+ (incf dstlen))))
+ (let ((result (make-string dstlen))
+ (dst 0))
+ (dotimes (src srclen)
+ (let ((char (schar thing src)))
+ (case char
+ ((#\* #\? #\[)
+ (setf (schar result dst) #\\)
+ (incf dst)))
+ (setf (schar result dst) char)
+ (incf dst)))
+ result)))
+ (pattern
+ (collect ((strings))
+ (dolist (piece (pattern-pieces thing))
+ (etypecase piece
+ (simple-string
+ (strings piece))
+ (symbol
+ (ecase piece
+ (:multi-char-wild
+ (strings "*"))
+ (:single-char-wild
+ (strings "?"))))
+ (cons
+ (case (car piece)
+ (:character-set
+ (strings "[")
+ (strings (cdr piece))
+ (strings "]"))
+ (t
+ (error "invalid pattern piece: ~S" piece))))))
+ (apply #'concatenate
+ 'simple-base-string
+ (strings))))))
+
+(defun unparse-win32-directory-list (directory)
+ (declare (type list directory))
+ (collect ((pieces))
+ (when directory
+ (ecase (pop directory)
+ (:absolute
+ (pieces "\\"))
+ (:relative
+ ;; nothing special
+ ))
+ (dolist (dir directory)
+ (typecase dir
+ ((member :up)
+ (pieces "..\\"))
+ ((member :back)
+ (error ":BACK cannot be represented in namestrings."))
+ ((member :wild-inferiors)
+ (pieces "**\\"))
+ ((or simple-string pattern (member :wild))
+ (pieces (unparse-unix-piece dir))
+ (pieces "\\"))
+ (t
+ (error "invalid directory component: ~S" dir)))))
+ (apply #'concatenate 'simple-base-string (pieces))))
+
+(defun unparse-win32-directory (pathname)
+ (declare (type pathname pathname))
+ (unparse-win32-directory-list (%pathname-directory pathname)))
+
+(defun unparse-win32-file (pathname)
+ (declare (type pathname pathname))
+ (collect ((strings))
+ (let* ((name (%pathname-name pathname))
+ (type (%pathname-type pathname))
+ (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 Win32).
+ (when name
+ (when (and (null type)
+ (typep name 'string)
+ (> (length name) 0)
+ (position #\. name :start 1))
+ (error "too many dots in the name: ~S" pathname))
+ (when (and (typep name 'string)
+ (string= name ""))
+ (error "name is of length 0: ~S" pathname))
+ (strings (unparse-unix-piece name)))
+ (when type-supplied
+ (unless name
+ (error "cannot specify the type without a file: ~S" pathname))
+ (when (typep type 'simple-string)
+ (when (position #\. type)
+ (error "type component can't have a #\. inside: ~S" pathname)))
+ (strings ".")
+ (strings (unparse-unix-piece type))))
+ (apply #'concatenate 'simple-base-string (strings))))
+
+(defun unparse-win32-namestring (pathname)
+ (declare (type pathname pathname))
+ (concatenate 'simple-base-string
+ (unparse-win32-device pathname)
+ (unparse-win32-directory pathname)
+ (unparse-win32-file pathname)))
+
+(defun unparse-native-win32-namestring (pathname)
+ (declare (type pathname pathname))
+ (let ((device (pathname-device pathname))
+ (directory (pathname-directory pathname))
+ (name (pathname-name pathname))
+ (type (pathname-type pathname)))
+ (coerce
+ (with-output-to-string (s)
+ (when device
+ (write-string device s)
+ (write-char #\: s))
+ (ecase (car directory)
+ (:absolute (write-char #\\ s))
+ (:relative))
+ (dolist (piece (cdr directory))
+ (typecase piece
+ ((member :up) (write-string ".." s))
+ (string (write-string piece s))
+ (t (error "ungood piece in NATIVE-NAMESTRING: ~S" piece)))
+ (write-char #\\ s))
+ (when name
+ (unless (stringp name)
+ (error "non-STRING name in NATIVE-NAMESTRING: ~S" name))
+ (write-string name s)
+ (when type
+ (unless (stringp type)
+ (error "non-STRING type in NATIVE-NAMESTRING: ~S" name))
+ (write-char #\. s)
+ (write-string type s))))
+ 'simple-base-string)))
+
+;;; FIXME.
+(defun unparse-win32-enough (pathname defaults)
+ (declare (type pathname pathname defaults))
+ (flet ((lose ()
+ (error "~S cannot be represented relative to ~S."
+ pathname defaults)))
+ (collect ((strings))
+ (let* ((pathname-directory (%pathname-directory pathname))
+ (defaults-directory (%pathname-directory defaults))
+ (prefix-len (length defaults-directory))
+ (result-directory
+ (cond ((null pathname-directory) '(:relative))
+ ((eq (car pathname-directory) :relative)
+ pathname-directory)
+ ((and (> prefix-len 1)
+ (>= (length pathname-directory) prefix-len)
+ (compare-component (subseq pathname-directory
+ 0 prefix-len)
+ defaults-directory))
+ ;; Pathname starts with a prefix of default. So
+ ;; just use a relative directory from then on out.
+ (cons :relative (nthcdr prefix-len pathname-directory)))
+ ((eq (car pathname-directory) :absolute)
+ ;; We are an absolute pathname, so we can just use it.
+ pathname-directory)
+ (t
+ (bug "Bad fallthrough in ~S" 'unparse-unix-enough)))))
+ (strings (unparse-unix-directory-list result-directory)))
+ (let* ((pathname-type (%pathname-type pathname))
+ (type-needed (and pathname-type
+ (not (eq pathname-type :unspecific))))
+ (pathname-name (%pathname-name pathname))
+ (name-needed (or type-needed
+ (and pathname-name
+ (not (compare-component pathname-name
+ (%pathname-name
+ defaults)))))))
+ (when name-needed
+ (unless pathname-name (lose))
+ (when (and (null pathname-type)
+ (position #\. pathname-name :start 1))
+ (error "too many dots in the name: ~S" pathname))
+ (strings (unparse-unix-piece pathname-name)))
+ (when type-needed
+ (when (or (null pathname-type) (eq pathname-type :unspecific))
+ (lose))
+ (when (typep pathname-type 'simple-base-string)
+ (when (position #\. pathname-type)
+ (error "type component can't have a #\. inside: ~S" pathname)))
+ (strings ".")
+ (strings (unparse-unix-piece pathname-type))))
+ (apply #'concatenate 'simple-string (strings)))))
}
/*
- * SBCL doesn't like backslashes in pathnames from getcwd for some reason.
- * Probably because they don't happen in posix systems. Windows doesn't
- * mind slashes, so we convert from one to the other. We also strip off
- * the drive prefix while we're at it ("C:", or whatever).
- *
- * The real fix for this problem is to create a windows-host setup that
- * parallels the unix-host in src/code/target-pathname.lisp and actually
- * parse this junk properly, drive letter and everything.
- *
- * Also see POSIX-GETCWD in src/code/unix.lisp.
- */
-char *wrap_getcwd(char *buf, size_t len)
-{
- char *retval = _getcwd(buf, len);
-
- if (retval[1] == ':') {
- char *p;
- for (p = retval; (*p = p[2]); p++)
- if (*p == '\\') *p = '/';
- }
-
- return retval;
-}
-
-/*
* Windows doesn't have gettimeofday(), and we need it for the compiler,
* for serve-event, and for a couple other things. We don't need a timezone
* yet, however, and the closest we can easily get to a timeval is the
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.9.8.16"
+"0.9.8.17"
projects / sbcl.git / commitdiff