-;;; 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 maybe-extract-search-list (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 (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 ((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)))))
- (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)))))
-
-(/show0 "filesys.lisp 300")
-
-(defun unparse-unix-host (pathname)
- (declare (type pathname pathname)
- (ignore pathname))
- "Unix")
-
-(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
- (cond ((search-list-p (car directory))
- (pieces (search-list-name (pop directory)))
- (pieces ":"))
- (t
- (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)
- (pieces (unparse-unix-piece dir))
- (pieces "/"))
- (t
- (error "invalid directory component: ~S" dir)))))
- (unless (null (pieces))
- (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))
- (let* ((name (%pathname-name pathname))
- (type (%pathname-type pathname))
- (type-supplied (not (or (null type) (eq type :unspecific))))
- (version (%pathname-version pathname))
- (version-supplied (not (or (null version) (eq version :newest)))))
- (when name
- (strings (unparse-unix-piece name)))
- (when type-supplied
- (unless name
- (error "cannot specify the type without a file: ~S" pathname))
- (strings ".")
- (strings (unparse-unix-piece type)))
- (when version-supplied
- (unless type-supplied
- (error "cannot specify the version without a type: ~S" pathname))
- (strings (if (eq version :wild)
- ".*"
- (format nil ".~D" version)))))
- (unless (null (strings))
- (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-unix-file pathname)))
-
-(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-dir
- (cond ((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
- ;; We are a relative directory. So we lose.
- (lose)))))
- (strings (unparse-unix-directory-list result-dir)))
- (let* ((pathname-version (%pathname-version pathname))
- (version-needed (and pathname-version
- (not (eq pathname-version :newest))))
- (pathname-type (%pathname-type pathname))
- (type-needed (or version-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))
- (strings (unparse-unix-piece pathname-name)))
- (when type-needed
- (when (or (null pathname-type) (eq pathname-type :unspecific))
- (lose))
- (strings ".")
- (strings (unparse-unix-piece pathname-type)))
- (when version-needed
- (typecase pathname-version
- ((member :wild)
- (strings ".*"))
- (integer
- (strings (format nil ".~D" pathname-version)))
- (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*)