X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Funix-pathname.lisp;h=82b39b76be3c67b05a3544d2aeaea5e274955714;hb=d442c23da9851beac541b8bddfc2c0837cb87309;hp=dc842b1306055143e782f00737ab9c090e117376;hpb=c6ca3162c8abd6ae9cce613f5df5778405806e60;p=sbcl.git diff --git a/src/code/unix-pathname.lisp b/src/code/unix-pathname.lisp index dc842b1..82b39b7 100644 --- a/src/code/unix-pathname.lisp +++ b/src/code/unix-pathname.lisp @@ -85,7 +85,7 @@ type version)))) -(defun parse-native-unix-namestring (namestring start end) +(defun parse-native-unix-namestring (namestring start end as-directory) (declare (type simple-string namestring) (type index start end)) (setf namestring (coerce namestring 'simple-string)) @@ -96,22 +96,27 @@ collect (if (and (string= piece "..") rest) :up piece))) + (directory (if (and as-directory + (string/= "" (car (last components)))) + components + (butlast components))) (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)))))) + (unless as-directory + (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)) + (cons (if absolute :absolute :relative) directory) (first name-and-type) (second name-and-type) nil)))) @@ -127,51 +132,6 @@ ;; 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)) @@ -191,7 +151,7 @@ ((member :wild-inferiors) (pieces "**/")) ((or simple-string pattern (member :wild)) - (pieces (unparse-unix-piece dir)) + (pieces (unparse-physical-piece dir)) (pieces "/")) (t (error "invalid directory component: ~S" dir))))) @@ -219,7 +179,7 @@ (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)) @@ -227,7 +187,7 @@ (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") @@ -238,32 +198,48 @@ (unparse-unix-directory pathname) (unparse-unix-file pathname))) -(defun unparse-native-unix-namestring (pathname) +(defun unparse-native-unix-namestring (pathname as-file) (declare (type pathname pathname)) - (let ((directory (pathname-directory pathname)) - (name (pathname-name pathname)) - (type (pathname-type pathname))) + (let* ((directory (pathname-directory pathname)) + (name (pathname-name pathname)) + (name-present-p (typep name '(not (member nil :unspecific)))) + (name-string (if name-present-p name "")) + (type (pathname-type pathname)) + (type-present-p (typep type '(not (member nil :unspecific)))) + (type-string (if type-present-p type ""))) + (when name-present-p + (setf as-file nil)) (coerce (with-output-to-string (s) (when directory (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)))) + (loop for (piece . subdirs) on (cdr directory) + do (typecase 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 + do (unless as-file + (write-char #\/ s))) + (if name-present-p + (progn + (unless (stringp name-string) ;some kind of wild field + (error "ungood name component in NATIVE-NAMESTRING: ~S" name)) + (write-string name-string s) + (when type-present-p + (unless (stringp type-string) ;some kind of wild field + (error "ungood type component in NATIVE-NAMESTRING: ~S" type)) + (write-char #\. s) + (write-string type-string s))) + (when type-present-p ; type without a name + (error + "type component without a name component in NATIVE-NAMESTRING: ~S" + type)))) 'simple-string))) (defun unparse-unix-enough (pathname defaults) @@ -308,7 +284,7 @@ (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)) @@ -316,7 +292,7 @@ (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)