From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 10 May 2000 17:03:27 +0000 (+0000)
Subject: Fix bug: URLs weren't being properly memoized when created from
X-Git-Tag: 20090517-FFI~3900
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6ebba8e007bc49f30be62bd6c74acb186154d5ac;p=mit-scheme.git

Fix bug: URLs weren't being properly memoized when created from
components rather than being translated from a string.
---

diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm
index 167f84592..9306aee2b 100644
--- a/v7/src/imail/imail-core.scm
+++ b/v7/src/imail/imail-core.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-core.scm,v 1.51 2000/05/10 16:53:19 cph Exp $
+;;; $Id: imail-core.scm,v 1.52 2000/05/10 17:03:17 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -62,6 +62,13 @@
 	(hash-table/put! saved-urls string url)
 	url)))
 
+(define (save-url url)
+  (let ((string (url->string url)))
+    (or (hash-table/get saved-urls string #f)
+	(begin
+	  (hash-table/put! saved-urls string url)
+	  url))))
+
 (define saved-urls
   (make-string-hash-table))
 
diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm
index e7ece5862..6bf6184f8 100644
--- a/v7/src/imail/imail-imap.scm
+++ b/v7/src/imail/imail-imap.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-imap.scm,v 1.24 2000/05/10 17:01:34 cph Exp $
+;;; $Id: imail-imap.scm,v 1.25 2000/05/10 17:03:21 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -25,7 +25,8 @@
 ;;;; URL
 
 (define-class (<imap-url>
-	       (constructor (user-id auth-type host port mailbox uid)))
+	       (constructor %make-imap-url
+			    (user-id auth-type host port mailbox uid)))
     (<url>)
   ;; User name to connect as.
   (user-id define accessor)
@@ -40,6 +41,9 @@
   ;; Unique ID specifying a message.  Ignored.
   (uid define accessor))
 
+(define (make-rmail-url user-id auth-type host port mailbox uid)
+  (save-url (%make-rmail-url user-id auth-type host port mailbox uid)))
+
 (define-url-protocol "imap" <imap-url>
   (let ((//server/
 	 (optional-parser
@@ -53,14 +57,14 @@
 	  (let ((pv2
 		 (or (parse-substring mbox string (car pv1) end)
 		     (error:bad-range-argument string 'STRING->URL))))
-	    (make-imap-url (parser-token pv1 'USER-ID)
-			   (parser-token pv1 'AUTH-TYPE)
-			   (parser-token pv1 'HOST)
-			   (let ((port (parser-token pv1 'PORT)))
-			     (and port
-				  (string->number port)))
-			   (parser-token pv2 'MAILBOX)
-			   (parser-token pv2 'UID))))))))
+	    (%make-imap-url (parser-token pv1 'USER-ID)
+			    (parser-token pv1 'AUTH-TYPE)
+			    (parser-token pv1 'HOST)
+			    (let ((port (parser-token pv1 'PORT)))
+			      (and port
+				   (string->number port)))
+			    (parser-token pv2 'MAILBOX)
+			    (parser-token pv2 'UID))))))))
 
 (define-method url-body ((url <imap-url>))
   (string-append
diff --git a/v7/src/imail/imail-rmail.scm b/v7/src/imail/imail-rmail.scm
index 741ef7f6d..d06ad6ba0 100644
--- a/v7/src/imail/imail-rmail.scm
+++ b/v7/src/imail/imail-rmail.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-rmail.scm,v 1.23 2000/05/08 18:51:36 cph Exp $
+;;; $Id: imail-rmail.scm,v 1.24 2000/05/10 17:03:27 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -26,15 +26,18 @@
 
 (define-class <rmail-url> (<file-url>))
 
-(define make-rmail-url
+(define-url-protocol "rmail" <rmail-url>
+  (lambda (string)
+    (%make-rmail-url (short-name->pathname string))))
+
+(define (make-rmail-url pathname)
+  (save-url (%make-rmail-url pathname)))
+
+(define %make-rmail-url
   (let ((constructor (instance-constructor <rmail-url> '(PATHNAME))))
     (lambda (pathname)
       (constructor (merge-pathnames pathname)))))
 
-(define-url-protocol "rmail" <rmail-url>
-  (lambda (string)
-    (make-rmail-url (short-name->pathname string))))
-
 ;;;; Server operations
 
 (define-method %open-folder ((url <rmail-url>))