From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 5 Jul 2000 20:49:36 +0000 (+0000)
Subject: Fix bug in file URL parsing for DOS-style pathnames.
X-Git-Tag: 20090517-FFI~3378
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=578da28322b2ee7f0ff3471598332ddb4fe4d71b;p=mit-scheme.git

Fix bug in file URL parsing for DOS-style pathnames.
---

diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm
index dc930a8aa..c98450915 100644
--- a/v7/src/imail/imail-file.scm
+++ b/v7/src/imail/imail-file.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-file.scm,v 1.55 2000/07/05 20:03:20 cph Exp $
+;;; $Id: imail-file.scm,v 1.56 2000/07/05 20:49:36 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -64,9 +64,15 @@
   (let ((finish
 	 (lambda (string)
 	   (merge-pathnames
-	    (decorated-string-append
-	     "" "/" ""
-	     (map url:decode-string (burst-string string #\/ #f)))
+	    (let ((s
+		   (decorated-string-append
+		    "" "/" ""
+		    (map url:decode-string (burst-string string #\/ #f)))))
+	      (if (and (eq? (host/type-name (pathname-host default-pathname))
+			    'DOS)
+		       (re-string-match "/[a-z]:" s #t))
+		  (string-tail s 1)
+		  s))
 	    default-pathname))))
     (cond ((string-prefix? "//localhost/" string)
 	   (finish (string-tail string (string-length "//localhost"))))