From 8c685e1fee08b4d1d9ef43b8d2784ac283c94096 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Fri, 6 Jan 2006 16:44:59 +0000 Subject: [PATCH] 0.9.8.17: Fix a bug in ENSURE-DIRECTORIES-EXIST: merge in *DEFAULT-PATHNAME-DEFAULTS*. ... this fix may also include a mostly-working set of pathname functions for Win32. Or it may not. You have been warned. --- build-order.lisp-expr | 3 + src/code/filesys.lisp | 396 ++++++----------------------------------- src/code/pathname.lisp | 2 + src/code/target-pathname.lisp | 27 ++- src/code/unix-pathname.lisp | 318 +++++++++++++++++++++++++++++++++ src/code/unix.lisp | 10 +- src/code/win32-pathname.lisp | 340 +++++++++++++++++++++++++++++++++++ src/runtime/wrap.c | 25 --- version.lisp-expr | 2 +- 9 files changed, 750 insertions(+), 373 deletions(-) create mode 100644 src/code/unix-pathname.lisp create mode 100644 src/code/win32-pathname.lisp diff --git a/build-order.lisp-expr b/build-order.lisp-expr index ba71c0e..627a884 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -640,7 +640,10 @@ ("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" diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index 9349fe9..1161929 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -1,4 +1,5 @@ -;;;; 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. @@ -13,6 +14,11 @@ ;;;; 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 ]]] @@ -29,11 +35,7 @@ ;;; - 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: ;;; @@ -41,10 +43,11 @@ ;;; 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. @@ -171,311 +174,6 @@ (/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))))) ;;;; wildcard matching stuff @@ -514,6 +212,15 @@ (/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) @@ -522,25 +229,28 @@ (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 @@ -566,10 +276,12 @@ (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 @@ -593,7 +305,7 @@ (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)))))))) @@ -608,26 +320,26 @@ (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 "~@")) (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 "~@")))) @@ -739,6 +451,13 @@ ;;; 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 @@ -787,6 +506,7 @@ (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)))))))) @@ -1088,7 +808,7 @@ 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 diff --git a/src/code/pathname.lisp b/src/code/pathname.lisp index 18c14b9..2fa8fa0 100644 --- a/src/code/pathname.lisp +++ b/src/code/pathname.lisp @@ -25,6 +25,7 @@ (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) @@ -49,6 +50,7 @@ (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) diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index 226e4c4..f39c285 100644 --- a/src/code/target-pathname.lisp +++ b/src/code/target-pathname.lisp @@ -13,7 +13,7 @@ #!-sb-fluid (declaim (freeze-type logical-pathname logical-host)) -;;;; UNIX-HOST stuff +;;;; PHYSICAL-HOST stuff (def!struct (unix-host (:make-load-form-fun make-unix-host-load-form) @@ -26,15 +26,34 @@ (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 diff --git a/src/code/unix-pathname.lisp b/src/code/unix-pathname.lisp new file mode 100644 index 0000000..6f1cf6a --- /dev/null +++ b/src/code/unix-pathname.lisp @@ -0,0 +1,318 @@ +;;;; 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))))) diff --git a/src/code/unix.lisp b/src/code/unix.lisp index af55732..2423d6c 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -346,17 +346,13 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;; 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)) @@ -876,6 +872,10 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; 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 diff --git a/src/code/win32-pathname.lisp b/src/code/win32-pathname.lisp new file mode 100644 index 0000000..0b5872a --- /dev/null +++ b/src/code/win32-pathname.lisp @@ -0,0 +1,340 @@ +;;;; 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))))) diff --git a/src/runtime/wrap.c b/src/runtime/wrap.c index 8d576d1..39080d2 100644 --- a/src/runtime/wrap.c +++ b/src/runtime/wrap.c @@ -397,31 +397,6 @@ int select(int top_fd, DWORD *read_set, DWORD *write_set, DWORD *except_set, tim } /* - * 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 diff --git a/version.lisp-expr b/version.lisp-expr index 0d8fd6e..20592f2 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; 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" -- 1.7.10.4