1.0.28.60: partial UNC pathname support for Windows

  UNC hosts are represented using the devíce components of pathnames,
  as are drives. This is sleightly lossy since it prevents accessing
  network hosts named with a single letter -- single-letter devices
  are taken to mean drives.

  However, since storing the host in the pathname host component
  would lead to confusion between logical hosts and UNC hosts,
  this seems preferable right now, so that

   (make-pathname :host "foo" ...)

  remains unambiguous. DIRECTORY does not work yet with UNC pathnames
  since it insists on walking the path from root -- which Windows
  doesn't seem to allow for UNC paths, not even local ones.

diff --git a/NEWS b/NEWS
index f5c7aa9..f878720 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -14,6 +14,8 @@
     the symbol, prohibits both lexical and dynamic binding. This is mainly an
     efficiency measure for threaded platforms, but also valueable in
     expressing intent.
+  * new feature: UNC pathnames are now understood by the system on Windows.
+    However, DIRECTORY does not yet support them -- but OPEN &co do.
   * optimization: the compiler uses a specialized version of FILL when the
     element type is know in more cases, making eg. (UNSIGNED-BYTE 8) case
     almost 90% faster.

diff --git a/src/code/win32-pathname.lisp b/src/code/win32-pathname.lisp
index a3770fe..c521dca 100644 (file)
--- a/src/code/win32-pathname.lisp
+++ b/src/code/win32-pathname.lisp
@@ -14,10 +14,26 @@
 (defun extract-device (namestr start end)
   (declare (type simple-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))
+  (if (>= end (+ start 2))
+      (let ((c0 (char namestr start))
+            (c1 (char namestr (1+ start))))
+        (cond ((and (eql c1 #\:) (alpha-char-p c0))
+               ;; "X:" style, saved as X
+               (values (string (char namestr start)) (+ start 2)))
+              ((and (member c0 '(#\/ #\\)) (eql c0 c1))
+               ;; "//UNC" style, saved as UNC
+               ;; FIXME: at unparsing time we tell these apart by length,
+               ;; which seems a bit lossy -- presumably one-letter UNC
+               ;; hosts can exist as well. That seems a less troublesome
+               ;; restriction than disallowing UNC hosts whose names match
+               ;; logical pathname hosts... Time will tell -- both LispWorks
+               ;; and ACL use the host component for UNC hosts, so maybe
+               ;; we will end up there as well.
+               (let ((p (or (position c0 namestr :start (+ start 3) :end end)
+                            end)))
+                 (values (subseq namestr (+ start 2) p) p)))
+              (t
+               (values nil start))))
       (values nil start)))
 
 (defun split-at-slashes-and-backslashes (namestr start end)
@@ -145,10 +161,16 @@
 
 (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) ":"))))
+  (let ((device (pathname-device pathname))
+        (directory (pathname-directory pathname)))
+    (cond ((or (null device) (eq device :unspecific))
+           "")
+          ((= 1 (length device))
+           (concatenate 'simple-string device ":"))
+          ((and (consp directory) (eq :relative (car directory)))
+           (error "No printed representation for a relative UNC pathname."))
+          (t
+           (concatenate 'simple-string "\\\\" device)))))
 
 (defun unparse-win32-piece (thing)
   (etypecase thing
@@ -275,8 +297,7 @@
     (coerce
      (with-output-to-string (s)
        (when device
-         (write-string device s)
-         (write-char #\: s))
+         (write-string (unparse-win32-device pathname) s))
        (tagbody
           (when directory
             (ecase (pop directory)

diff --git a/version.lisp-expr b/version.lisp-expr
index 019c8f6..286ec14 100644 (file)
--- 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".)
-"1.0.28.59"
+"1.0.28.60"