(in-package "SB!IMPL")
+(def!struct (unix-host
+ (:make-load-form-fun make-host-load-form)
+ (:include host
+ (parse #'parse-unix-namestring)
+ (parse-native #'parse-native-unix-namestring)
+ (unparse #'unparse-unix-namestring)
+ (unparse-native #'unparse-native-unix-namestring)
+ (unparse-host #'unparse-unix-host)
+ (unparse-directory #'unparse-physical-directory)
+ (unparse-file #'unparse-unix-file)
+ (unparse-enough #'unparse-unix-enough)
+ (unparse-directory-separator "/")
+ (simplify-namestring #'simplify-unix-namestring)
+ (customary-case :lower))))
+
+(defvar *physical-host* (make-unix-host))
+
;;; 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.
: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))))
+
+ (let (home)
+ ;; Deal with ~ and ~user
+ (when (car pieces)
+ (destructuring-bind (start . end) (car pieces)
+ (when (and (not absolute)
+ (not (eql start end))
+ (string= namestring "~"
+ :start1 start
+ :end1 (1+ start)))
+ (setf absolute t)
+ (if (> end (1+ start))
+ (setf home (list :home (subseq namestring (1+ start) end)))
+ (setf home :home))
+ (pop pieces))))
+
+ ;; 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
+ (if home
+ (list* :absolute home (dirs))
+ (cons :absolute (dirs))))
+ ((dirs)
+ (cons :relative (dirs)))
+ (t
+ nil)))
+ name
+ type
+ version)))))
(defun parse-native-unix-namestring (namestring start end as-directory)
(declare (type simple-string namestring)
;; 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-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-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))
(when (and (typep name 'string)
(string= name ""))
(error "name is of length 0: ~S" pathname))
- (strings (unparse-unix-piece name)))
+ (strings (unparse-physical-piece name)))
(when type-supplied
(unless name
(error "cannot specify the type without a file: ~S" pathname))
(when (position #\. type)
(error "type component can't have a #\. inside: ~S" pathname)))
(strings ".")
- (strings (unparse-unix-piece type))))
+ (strings (unparse-physical-piece type))))
(apply #'concatenate 'simple-string (strings))))
(/show0 "filesys.lisp 406")
(defun unparse-unix-namestring (pathname)
(declare (type pathname pathname))
(concatenate 'simple-string
- (unparse-unix-directory pathname)
+ (unparse-physical-directory pathname)
(unparse-unix-file pathname)))
(defun unparse-native-unix-namestring (pathname as-file)
(coerce
(with-output-to-string (s)
(when directory
- (ecase (car directory)
- (:absolute (write-char #\/ s))
+ (ecase (pop directory)
+ (:absolute
+ (let ((next (pop directory)))
+ (cond ((eq :home next)
+ (write-string (user-homedir-namestring) s))
+ ((and (consp next) (eq :home (car next)))
+ (let ((where (user-homedir-namestring (second next))))
+ (if where
+ (write-string where s)
+ (error "User homedir unknown for: ~S" (second next)))))
+ (next
+ (push next directory)))
+ (write-char #\/ s)))
(:relative)))
- (loop for (piece . subdirs) on (cdr directory)
+ (loop for (piece . subdirs) on directory
do (typecase piece
- ((member :up) (write-string ".." s))
- (string (write-string piece s))
- (t (error "ungood directory segment in NATIVE-NAMESTRING: ~S"
- piece)))
+ ((member :up)
+ (write-string ".." s))
+ (string
+ (write-string piece s))
+ (t
+ (error "ungood directory segment in NATIVE-NAMESTRING: ~S"
+ piece)))
if (or subdirs (stringp name))
do (write-char #\/ s)
else
pathname-directory)
(t
(bug "Bad fallthrough in ~S" 'unparse-unix-enough)))))
- (strings (unparse-unix-directory-list result-directory)))
+ (strings (unparse-physical-directory-list result-directory)))
(let* ((pathname-type (%pathname-type pathname))
(type-needed (and pathname-type
(not (eq pathname-type :unspecific))))
(typep pathname-name 'simple-string)
(position #\. pathname-name :start 1))
(error "too many dots in the name: ~S" pathname))
- (strings (unparse-unix-piece pathname-name)))
+ (strings (unparse-physical-piece pathname-name)))
(when type-needed
(when (or (null pathname-type) (eq pathname-type :unspecific))
(lose))
(when (position #\. pathname-type)
(error "type component can't have a #\. inside: ~S" pathname)))
(strings ".")
- (strings (unparse-unix-piece pathname-type))))
+ (strings (unparse-physical-piece pathname-type))))
(apply #'concatenate 'simple-string (strings)))))
(defun simplify-unix-namestring (src)
projects / sbcl.git / blobdiff