Changeset 11859

Timestamp:

Mar 29, 2009, 5:41:14 PM (11 years ago)

Author:

gb

Message:

Functions that parse namestrings have called GET-SSTRING on their
string arguments so that they're sure that they're operating on a
bounded SIMPLE-STRING. Those parsing functions (hopefully all of
them) now call GET-PATHNAME-SSTRING instead. On non-Windows platforms,
this just calls GET-SSTRING and returns its results; on Windows, it
checks to see if the bounded simple-string contains backslashes and
if so, it returns a copy with the backslashes replaced with forward-slashes.

This is one way to allow pathname functions to handle Windows pathnames
that use #
as a directory separator. (The other way would be to
change a lot of ancient namestring-parsing code to handle either #
or #\/ as a directory separator, and this approach is certainly simpler.)
The extra consing should only happen if user code does something like:

(let* ((home-string (getenv "HOME")))

(if home-string

(pathname-name home-string)))

System code that deals with namestrings returned by the OS can generally
destructively change any backslashes in that namestring to forward slashes
before passing the string to pathname-parsing functions.

Location:

trunk/source/level-1

Files:

• l1-files.lisp (modified) (6 diffs)
• l1-pathnames.lisp (modified) (1 diff)

trunk/source/level-1/l1-files.lisp

@@ -499 +499 @@
   (when path (pathname path)))
 
+(defun get-pathname-sstring (string &optional (start 0) (end (length string)))
+  #-windows-target
+  (get-sstring string start end)
+  #+windows-target
+  (multiple-value-bind (sstr start end)
+      (get-sstring string start end)
+    (declare (fixnum start end)
+             (simple-string sstr))
+    (if (do* ((i start (1+ i)))
+             ((= i end))
+          (declare (fixnum i))
+          (when (eql (schar sstr i) #\\)
+            (return t)))
+      (let* ((len (- end start))
+             (new (make-string len)))
+        (declare (fixnum len) (simple-string new))
+        (dotimes (i len)
+          (let* ((ch (schar sstr start)))
+            (if (eql ch #\\)
+              (setf (schar new i) #\/)
+              (setf (schar new i) ch)))
+          (incf start))
+        (values new 0 len))
+      (values sstr start end))))
+              
 (defun string-to-pathname (string &optional (start 0) (end (length string))
                                             (reference-host nil)
                                             (defaults *default-pathname-defaults*))
   (require-type reference-host '(or null string))
-  (multiple-value-bind (sstr start end) (get-sstring string start end)
+  (multiple-value-bind (sstr start end) (get-pathname-sstring string start end)
     #-windows-target
     (if (and (> end start)
@@ -745 +770 @@
            (logical-pathname (%logical-pathname-host thing))
            (pathname :unspecific)
-           (string (multiple-value-bind (sstr start end) (get-sstring thing) 
+           (string (multiple-value-bind (sstr start end) (get-pathname-sstring thing) 
                      (pathname-host-sstr sstr start end)))
            (t (report-bad-arg thing pathname-arg-type)))))
@@ -795 +820 @@
                   (pathname (%pathname-directory path))
                   (string
-                   (multiple-value-bind (sstr start end) (get-sstring path)
-                     #+no
-                     (if (and (> end start)
-                              (eql (schar sstr start) #\~))
-                       (setq sstr (tilde-expand (subseq sstr start end))
-                             start 0
-                             end (length sstr)))
+                   (multiple-value-bind (sstr start end) (get-pathname-sstring path)
                      (multiple-value-bind (host pos2) (pathname-host-sstr sstr start end)
                        (unless (eq host :unspecific) (setq logical-p t))
@@ -881 +900 @@
     (pathname (%physical-pathname-version path))
     (string
-     (multiple-value-bind (sstr start end) (get-sstring path)
+     (multiple-value-bind (sstr start end) (get-pathname-sstring path)
        (multiple-value-bind (newstart host) (pathname-directory-end sstr start end)
          (if (eq host :unspecific)
@@ -916 +935 @@
                  (pathname (%pathname-name path))
                  (string
-                  (multiple-value-bind (sstr start end) (get-sstring path)
+                  (multiple-value-bind (sstr start end) (get-pathname-sstring path)
                     (multiple-value-bind (newstart host) (pathname-directory-end sstr start end)
                       (setq start newstart)
@@ -952 +971 @@
                  (pathname (%pathname-type path))
                  (string
-                  (multiple-value-bind (sstr start end) (get-sstring path)
+                  (multiple-value-bind (sstr start end) (get-pathname-sstring path)
                     (multiple-value-bind (newstart host) (pathname-directory-end sstr start end)
                       (setq start newstart)

trunk/source/level-1/l1-pathnames.lisp

@@ -361 +361 @@
 
 (defun logical-pathname-namestring-p (string)
-  (multiple-value-bind (sstr start end) (get-sstring string)
+  (multiple-value-bind (sstr start end) (get-pathname-sstring string)
     (let ((host (pathname-host-sstr sstr start end t)))
       (and host (not (eq host :unspecific))))))