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 167f84592e32106965ce8af06ccb3551ab96c446..9306aee2b804b79f697ee001762d90410c7430bf 100644 (file)
--- 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 e7ece5862cec03d2147a1d17899a56959b6c0854..6bf6184f889d3b957bd866f44d17a7afb09be2e0 100644 (file)
--- 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 741ef7f6d1309b4f71f10ed79723a162326ed125..d06ad6ba0b58955e5dc6905c6006408af63e8df6 100644 (file)
--- 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>))