From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 23 Apr 2000 04:02:48 +0000 (+0000)
Subject: Implement URL-USER-ID.
X-Git-Tag: 20090517-FFI~3984
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=a5e4ecba586b2fd593a9791e78f2e7da330498ea;p=mit-scheme.git

Implement URL-USER-ID.
---

diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm
index cfbdeecca..7afd929ea 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.29 2000/04/18 21:20:00 cph Exp $
+;;; $Id: imail-core.scm,v 1.30 2000/04/23 04:02:38 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -81,6 +81,9 @@
 
 (define url-protocol-parsers
   (make-string-hash-table))
+
+(define-generic url-user-id (url))
+(define-method url-user-id ((url <url>)) url #f)
 
 (define (get-memoized-folder url)
   (let ((folder (hash-table/get memoized-folders url #f)))
diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm
index a60db506d..d74786a68 100644
--- a/v7/src/imail/imail-top.scm
+++ b/v7/src/imail/imail-top.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-top.scm,v 1.20 2000/04/14 01:45:39 cph Exp $
+;;; $Id: imail-top.scm,v 1.21 2000/04/23 04:02:48 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -101,7 +101,8 @@ May be called with an IMAIL folder URL as argument;
 
 (define (imail-authenticator url)
   (let ((user-name
-	 (or (ref-variable imail-user-name)
+	 (or (url-user-id url)
+	     (ref-variable imail-user-name)
 	     (current-user-name))))
     (values user-name
 	    (call-with-pass-phrase