From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 4 Jan 2000 22:52:21 +0000 (+0000)
Subject: Initial revision
X-Git-Tag: 20090517-FFI~4380
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=2da3c37ea0926b2941a7942ed6a8382016c2907f;p=mit-scheme.git

Initial revision
---

diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm
new file mode 100644
index 000000000..2dc45cf37
--- /dev/null
+++ b/v7/src/imail/imail-core.scm
@@ -0,0 +1,603 @@
+;;; -*-Scheme-*-
+;;;
+;;; $Id: imail-core.scm,v 1.1 2000/01/04 22:50:53 cph Exp $
+;;;
+;;; Copyright (c) 1999 Massachusetts Institute of Technology
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License as
+;;; published by the Free Software Foundation; either version 2 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;;; IMAIL mail reader: core definitions
+
+;;; **** Implement file backup.
+;;; **** Strip IMAIL headers when importing or exporting messages.
+;;;      (What does that mean, precisely?)
+
+(declare (usual-integrations))
+
+;;;; URL type
+
+(define-class <url> ())
+
+;; Return the canonical name of URL's protocol as a string.
+(define-generic url-protocol (url))
+
+;; Return the body of URL as a string.
+(define-generic url-body (url))
+
+(define (guarantee-url url procedure)
+  (if (not (url? url))
+      (error:wrong-type-argument url "IMAIL url" procedure)))
+
+(define-method write-instance ((url <url>) port)
+  (write-instance-helper 'URL url port
+    (lambda ()
+      (write-char #\space port)
+      (write (url->string url) port))))
+
+(define (make-url protocol body)
+  (string->url (string-append protocol ":" body)))
+
+(define (->url object)
+  (cond ((url? object) object)
+	((string? object) (string->url object))
+	(else (error:wrong-type-argument object "URL" '->URL))))
+
+(define (string->url string)
+  (or (hash-table/get saved-urls string #f)
+      (let ((url
+	     (let ((colon (string-find-next-char string #\:)))
+	       (if (not colon)
+		   (error "Malformed URL string:" string))
+	       ((get-url-protocol-parser (string-head string colon))
+		(string-tail string (fix:+ colon 1))))))
+	(hash-table/put! saved-urls string url)
+	url)))
+
+(define saved-urls
+  (make-string-hash-table))
+
+(define (url->string url)
+  (string-append (url-protocol url) ":" (url-body url)))
+
+(define (define-url-protocol name class parser)
+  (define-method url-protocol ((url class)) url name)
+  (hash-table/put! url-protocol-parsers (string-downcase name) parser))
+
+(define (get-url-protocol-parser name)
+  (let ((parser
+	 (hash-table/get url-protocol-parsers (string-downcase name) #f)))
+    (if (not parser)
+	(error:bad-range-argument name 'GET-URL-PROTOCOL-PARSER))
+    parser))
+
+(define url-protocol-parsers
+  (make-string-hash-table))
+
+(define (get-memoized-folder url)
+  (let ((folder (hash-table/get memoized-folders url #f)))
+    (and folder
+	 (if (%folder-valid? folder)
+	     folder
+	     (begin
+	       (unmemoize-folder url)
+	       #f)))))
+
+(define (memoize-folder folder)
+  (hash-table/put! memoized-folders (folder-url folder) folder)
+  folder)
+
+(define (unmemoize-folder url)
+  (hash-table/remove! memoized-folders url))
+
+(define memoized-folders
+  (make-eq-hash-table))
+
+;;;; Server operations
+
+;; Open the folder named URL.
+(define (open-folder url)
+  (let ((url (->url url)))
+    (or (get-memoized-folder url)
+	(memoize-folder (%open-folder url)))))
+
+(define-generic %open-folder (url))
+
+;; Create a new folder named URL.  Signal an error if the folder
+;; already exists or can't be created.
+(define (new-folder url)
+  (let ((url (->url url)))
+    (if (get-memoized-folder url)
+	(error "Folder already exists:" url)
+	(memoize-folder (%new-folder url)))))
+
+(define-generic %new-folder (url))
+
+;; Delete the folder named URL.  Signal an error if the folder doesn't
+;; exist or if it can't be deleted.
+(define (delete-folder url)
+  (let ((url (->url url)))
+    (unmemoize-folder url)
+    (%delete-folder url)))
+
+(define-generic %delete-folder (url))
+
+;; Move the folder named URL to NEW-URL.  Signal an error if the
+;; folder doesn't exist, if NEW-URL already refers to a folder, or if
+;; the move can't be performed for some reason.  This operation can be
+;; also be used to convert between protocols, e.g. to move a folder
+;; from a server to a file.
+(define (move-folder url new-url)
+  (let ((url (->url url))
+	(new-url (->url new-url)))
+    (unmemoize-folder url)
+    (%move-folder url new-url)))
+
+(define-generic %move-folder (url new-url))
+
+(define-method %move-folder ((url <url>) (new-url <url>))
+  (%copy-folder url new-url)
+  (%delete-folder url))
+
+;; Copy the folder named URL to be NEW-URL.  Signal an error if the
+;; folder doesn't exist, if NEW-URL already refers to a folder, or if
+;; the copy can't be performed for some reason.
+(define (copy-folder url new-url)
+  (%copy-folder (->url url) (->url new-url)))
+
+(define-generic %copy-folder (url new-url))
+
+(define-method %copy-folder ((url <url>) (new-url <url>))
+  (%write-folder (open-folder url) new-url))
+
+;; Return a list of URLs for folders that match URL-PATTERN.
+;; URL-PATTERN can contain wildcards.
+(define-generic available-folder-names (url-pattern))
+
+;; [This is an IMAP command that appears to be designed to support
+;; delivery of usenet news.]
+(define-generic subscribed-folder-names (url-pattern))
+
+;; Define AUTHENTICATOR to be the authenticator to use in the dynamic
+;; extent of THUNK.
+
+;; AUTHENTICATOR is a procedure that performs authentication, for
+;; protocols that require it.  AUTHENTICATOR is called with URL as its
+;; only argument and must return the authentication information,
+;; usually a username/password, as multiple values.
+
+;; For protocols that don't require authentication, AUTHENTICATOR is
+;; not called, and BIND-AUTHENTICATOR need not be used.
+
+;; [AUTHENTICATOR can be called at a variety of times; these will be
+;; made more explicit when known.]
+
+(define (bind-authenticator authenticator thunk)
+  (fluid-let ((authenticate authenticator))
+    (thunk)))
+
+(define authenticate)
+
+;;;; Folder type
+
+(define-class <folder> ())
+
+(define (guarantee-folder folder procedure)
+  (if (not (folder? folder))
+      (error:wrong-type-argument folder "IMAIL folder" procedure)))
+
+;; Return the URL of FOLDER.
+(define-generic folder-url (folder))
+
+;; Return #T if FOLDER represents a real folder, i.e. has a
+;; corresponding file or server entry.
+(define (folder-valid? folder)
+  (eq? folder (get-memoized-folder (folder-url folder))))
+
+(define-generic %folder-valid? (folder))
+
+;; Return the number of messages in FOLDER.
+(define-generic count-messages (folder))
+
+;; Get the INDEX'th message in FOLDER and return it.  Signal an
+;; error for invalid INDEX.
+(define (get-message folder index)
+  (guarantee-index index 'GET-MESSAGE)
+  (if (not (fix:< index (length (count-messages folder))))
+      (error:bad-range-argument index 'GET-MESSAGE))
+  (%get-message folder index))
+
+(define-generic %get-message (folder index))
+
+;; Insert a copy of MESSAGE in FOLDER at INDEX; pre-existing messages
+;; with indices of INDEX or higher have their indices incremented.
+;; Unspecified result.
+(define (insert-message folder index message)
+  (guarantee-index index 'INSERT-MESSAGE)
+  (if (not (fix:<= index (length (count-messages folder))))
+      (error:bad-range-argument index 'INSERT-MESSAGE))
+  (guarantee-message message 'INSERT-MESSAGE)
+  (%insert-message folder index message))
+
+(define-generic %insert-message (folder index message))
+
+;;; Insert a copy of MESSAGE in FOLDER at the end of the existing
+;;; messages.  Unspecified result.
+(define (append-message folder message)
+  (guarantee-message message 'APPEND-MESSAGE)
+  (%append-message folder message))
+
+(define-generic %append-message (folder message))
+
+;; Remove all messages in FOLDER that are marked for deletion.
+;; Unspecified result.
+(define-generic expunge-deleted-messages (folder))
+
+;; Search FOLDER for messages matching CRITERIA, returning them in a
+;; list.  [Possible values for CRITERIA not yet defined.]  Returns a
+;; list of messages.
+(define-generic search-folder (folder criteria))
+
+;; Poll the inbox associated with FOLDER to see if there is new mail.
+;; If so, the mail is appended to FOLDER.  Return the number of new
+;; messages.  Return #F if FOLDER has no associated inbox.
+(define-generic poll-folder (folder))
+
+;; Synchronize the local copy of FOLDER with the server's copy.
+;; Unspecified result.  Meaningless for file-based protocols.
+(define-generic synchronize-folder (folder))
+
+;; Save any changes made to FOLDER.  This permits the use of caches
+;; for improved performance.
+(define (save-folder folder)
+  (%save-folder folder))
+
+(define-generic %save-folder (folder))
+
+(define-method %save-folder ((folder <folder>))
+  (%write-folder folder (folder-url folder)))
+
+;; Write the contents of FOLDER to URL.
+(define-generic %write-folder (folder url))
+
+;; [These are IMAP commands that appear to be designed to support
+;; delivery of usenet news.]
+(define-generic subscribe-folder (folder))
+(define-generic unsubscribe-folder (folder))
+
+;;;; Message type
+
+(define-structure (message (type-descriptor message-rtd)
+			   (safe-accessors #t))
+  header-fields
+  body
+  flags
+  properties)
+
+(define (guarantee-message message procedure)
+  (if (not (message? message))
+      (error:wrong-type-argument message "IMAIL message" procedure)))
+
+(define-generic header-fields (object))
+
+(define-method header-fields ((message message-rtd))
+  (message-header-fields message))
+
+(define (copy-message message)
+  (make-message (map copy-header-field (message-header-fields message))
+		(message-body message)
+		(list-copy (message-flags message))
+		(alist-copy (message-properties message))))
+
+(define (make-standard-message headers body)
+  (let loop ((headers headers) (headers* '()) (flags '()) (properties '()))
+    (cond ((not (pair? headers))
+	   (make-message (reverse! headers*)
+			 body
+			 (reverse! flags)
+			 (reverse! properties)))
+	  ((header-field->message-flags (car headers))
+	   => (lambda (flags*)
+		(loop (cdr headers)
+		      headers*
+		      (append! (reverse! (cdr flags*)) flags)
+		      properties)))
+	  ((header-field->message-property header)
+	   => (lambda (property)
+		(loop (cdr headers)
+		      headers*
+		      flags
+		      (cons property properties))))
+	  (else
+	   (loop (cdr headers)
+		 (cons (car headers) headers*)
+		 flags
+		 properties)))))
+
+;;;; Message flags
+
+;;; Flags are markers that can be attached to messages.  They indicate
+;;; state about the message, such as whether it has been deleted,
+;;; seen, etc.  A flag is represented by a symbol or a string; symbols
+;;; represent standard flags with predefined meanings, while strings
+;;; represent user-defined flags.
+
+(define (message-flagged? message flag)
+  (guarantee-message-flag flag 'MESSAGE-FLAGGED?)
+  (if (member flag (message-flags message)) #t #f))
+
+(define (set-message-flag message flag)
+  (guarantee-message-flag flag 'SET-MESSAGE-FLAG)
+  (let ((flags (message-flags message)))
+    (if (not (member flag flags))
+	(set-message-flags! message (cons flag flags)))))
+
+(define (clear-message-flag message flag)
+  (set-message-flags! message (delete flag (message-flags message))))
+
+(define (message-flag? object)
+  (or (memq object standard-message-flags)
+      (header-field-name? object)))
+
+(define (guarantee-message-flag object procedure)
+  (if (not (message-flag? object))
+      (error:wrong-type-argument object "message flag" procedure)))
+
+(define standard-message-flags
+  ;; **** Use SEEN rather than UNSEEN?
+  '(DELETED ANSWERED UNSEEN FILED FORWARDED EDITED RESENT))
+
+(define (message-deleted? message)
+  (message-flagged? message 'DELETED))
+
+(define (delete-message message)
+  (set-message-flag message 'DELETED))
+
+(define (undelete-message message)
+  (clear-message-flag message 'DELETED))
+
+(define (message-flags->header-field flags)
+  (make-header-field
+   message-flags:name
+   (apply string-append
+	  (map (lambda (flag)
+		 (if (symbol? flag)
+		     (string-append " :" (symbol->string flag))
+		     (string-append " " flag)))
+	       flags))))
+
+(define (header-field->message-flags header)
+  (and (string-ci=? message-flags:name (header-field-name header))
+       ;; Extra pair needed to distinguish #F from ().
+       (cons 'YUK
+	     (map (lambda (token)
+		    (if (char=? #\: (string-ref token 0))
+			(intern (string-tail token 1))
+			token))
+		  (burst-string (header-field-value header)
+				char-set:lwsp
+				#t)))))
+
+(define message-flags:name "X-IMAIL-FLAGS")
+
+;;;; Message properties
+
+;;; Properties are used to associate information with a message.  A
+;;; property is a distinguished header field that carries information
+;;; intended for the mail reader rather than the user.
+
+(define (get-message-property message name default)
+  (guarantee-message-property-name name 'GET-MESSAGE-PROPERTY)
+  (let loop ((headers (message-properties message)))
+    (if (pair? headers)
+	(if (string-ci=? name (caar headers))
+	    (cdar headers)
+	    (loop (cdr headers)))
+	default)))
+
+(define (set-message-property message name value)
+  (guarantee-message-property-name name 'SET-MESSAGE-PROPERTY)
+  (guarantee-message-property-value value 'SET-MESSAGE-PROPERTY)
+  (let ((headers (message-properties message)))
+    (let loop ((headers headers))
+      (if (pair? headers)
+	  (if (string-ci=? name (caar headers))
+	      (set-cdr! (car headers) value)
+	      (loop (cdr headers)))
+	  (set-message-properties! message
+				   (cons (cons name value) headers))))))
+
+(define (message-property-name? object)
+  (header-field-name? object))
+
+(define (message-property-value? object)
+  (or (header-field-value? object)
+      (and (list? object)
+	   (for-all? object header-field?))))
+
+(define (guarantee-message-property-name name procedure)
+  (if (not (message-property-name? name))
+      (error:wrong-type-argument name "message-property name" procedure)))
+
+(define (guarantee-message-property-value value procedure)
+  (if (not (message-property-value? value))
+      (error:wrong-type-argument value "message-property value" procedure)))
+
+(define (message-property->header-field name value)
+  (make-header-field
+   (string-append message-property:prefix name)
+   (if (header-field-value? value)
+       (string-append message-property:single-marker value)
+       (apply string-append
+	      message-property:multiple-marker
+	      (map (lambda (line)
+		     (string-append "\n" line))
+		   (quote-lines
+		    (append-map (lambda (header)
+				  (header-field->lines header))
+				value)))))))
+
+(define (header-field->message-property header)
+  (and (string-prefix-ci? message-property:prefix (header-field-name header))
+       (cons (string-tail (header-field-name header)
+			  (string-length message-property:prefix))
+	     (let ((value (header-field-value header)))
+	       (cond ((string-prefix? message-property:single-marker value)
+		      (string-tail
+		       value
+		       (string-length message-property:single-marker)))
+		     ((string-prefix? message-property:multiple-marker value)
+		      (lines->header-fields
+		       (unquote-lines
+			(cdr (burst-string value #\newline #f)))))
+		     (else
+		      (error "Malformed message-property value:" value)))))))
+
+(define message-property:prefix "X-IMAIL-PROPERTY-")
+(define message-property:single-marker "[single]")
+(define message-property:multiple-marker "[multiple]")
+
+;;;; Header fields
+
+(define-structure (header-field
+		   (type-descriptor header-field-rtd)
+		   (safe-accessors #t)
+		   (constructor #f)
+		   (print-procedure
+		    (standard-unparser-method 'HEADER-FIELD
+		      (lambda (header port)
+			(write-char #\space port)
+			(write (header-field-name header) port)))))
+  (name #f read-only #t)
+  (value #f read-only #t))
+
+(define make-header-field
+  (let ((constructor (record-constructor header-field-rtd)))
+    (lambda (name value)
+      (guarantee-header-field-name name 'MAKE-HEADER-FIELD)
+      (guarantee-header-field-value value 'MAKE-HEADER-FIELD)
+      (constructor name value))))
+
+(define (copy-header-field header)
+  (record-copy header))
+
+(define (get-first-header-field headers name error?)
+  (let loop
+      ((headers
+	(if (or (pair? headers) (null? headers))
+	    headers
+	    (header-fields headers))))
+    (cond ((pair? headers)
+	   (if (string-ci=? name (header-field-name (car headers)))
+	       (car headers)
+	       (loop (cdr headers))))
+	  (error? (error:bad-range-argument name 'GET-FIRST-HEADER-FIELD))
+	  (else #f))))
+
+(define (get-last-header-field headers name error?)
+  (let loop
+      ((headers
+	(if (or (pair? headers) (null? headers))
+	    headers
+	    (header-fields headers)))
+       (winner #f))
+    (cond ((pair? headers)
+	   (loop (cdr headers)
+		 (if (string-ci=? name (header-field-name (car headers)))
+		     (car headers)
+		     winner)))
+	  ((and (not winner) error?)
+	   (error:bad-range-argument name 'GET-LAST-HEADER-FIELD))
+	  (else winner))))
+
+(define (get-all-header-fields headers name)
+  (list-transform-positive headers
+    (lambda (header)
+      (string-ci=? name (header-field-name header)))))
+
+(define (get-first-header-field-value headers name error?)
+  (let ((header (get-first-header-field headers name error?)))
+    (and header
+	 (header-field-value header))))
+
+(define (get-last-header-field-value headers name error?)
+  (let ((header (get-last-header-field headers name error?)))
+    (and header
+	 (header-field-value header))))
+
+(define (get-all-header-field-values headers name)
+  (map header-field-value (get-all-header-fields headers name)))
+
+(define (header-field-name? object)
+  (and (string? object)
+       (%header-field-name? object 0 (string-length object))))
+
+(define %header-field-name?
+  (let ((excluded-chars
+	 (char-set-invert
+	  (char-set-difference (ascii-range->char-set 33 127)
+			       (char-set #\:)))))
+    (lambda (string start end)
+      (and (fix:< start end)
+	   (not (substring-find-next-char-in-set string start end
+						 excluded-chars))))))
+
+(define (header-field-value? object)
+  (and (string? object)
+       (let ((end (string-length object)))
+	 (let loop ((index 0))
+	   (let ((nl (substring-find-next-char object index end #\newline)))
+	     (or (not nl)
+		 (and (fix:< (fix:+ nl 1) end)
+		      (char-lwsp? (string-ref object (fix:+ nl 1)))
+		      (loop (fix:+ nl 2)))))))))
+
+(define (guarantee-header-field-name object procedure)
+  (if (not (header-field-name? object))
+      (error:wrong-type-argument object "header-field name" procedure)))
+
+(define (guarantee-header-field-value object procedure)
+  (if (not (header-field-value? object))
+      (error:wrong-type-argument object "header-field value" procedure)))
+
+(define (header-field->lines header)
+  (let ((lines (string->lines (header-field-value header))))
+    (cons (string-append (header-field-name header) ":" (car lines))
+	  (cdr lines))))
+
+(define (lines->header-field lines)
+  (let ((colon
+	 (and (pair? lines)
+	      (string-find-next-char (car lines) #\:))))
+    (if (not colon)
+	(error "Malformed header-field lines:" lines))
+    (make-header-field (string-head (car lines) colon)
+		       (apply string-append
+			      (string-tail (car lines) (fix:+ colon 1))
+			      (map (lambda (line)
+				     (string-append "\n" line))
+				   (cdr lines))))))
+
+(define (lines->header-fields lines)
+  (map lines->header-field
+       (burst-list lines header-field-initial-line?)))
+
+(define (header-field-initial-line? line)
+  (let ((colon (string-find-next-char line #\:)))
+    (and colon
+	 (%header-field-name? line 0 colon))))
+
+(define (header-field-continuation-line? line)
+  (and (not (string-null? line))
+       (char-lwsp? (string-ref line 0))))
\ No newline at end of file
diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm
new file mode 100644
index 000000000..2fb69fffe
--- /dev/null
+++ b/v7/src/imail/imail-file.scm
@@ -0,0 +1,111 @@
+;;; -*-Scheme-*-
+;;;
+;;; $Id: imail-file.scm,v 1.1 2000/01/04 22:50:56 cph Exp $
+;;;
+;;; Copyright (c) 1999 Massachusetts Institute of Technology
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License as
+;;; published by the Free Software Foundation; either version 2 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;;; IMAIL mail reader: file-based folder support
+
+(declare (usual-integrations))
+
+;;;; URL
+
+(define-class <file-url> (<url>)
+  (pathname define accessor))
+
+(define-method url-body ((url <file-url>))
+  (pathname->short-name (file-url-pathname url)))
+
+;;;; Server operations
+
+(define-method %delete-folder ((url <file-url>))
+  (delete-file (file-url-pathname url)))
+
+;;; The next two methods only work when operating on two URLs of the
+;;; same class.  Otherwise, it's necessary to do format conversions;
+;;; this is handled at a higher level in the class heirarchy.
+
+(define-computed-method %move-folder ((uc1 <file-url>) (uc2 <file-url>))
+  (and (eq? uc1 uc2)
+       (lambda (url new-url)
+	 ;; **** Not really correct -- must handle cases where RENAME-FILE
+	 ;; fails, such as moving across file systems under unix.
+	 (rename-file (file-url-pathname url) (file-url-pathname new-url)))))
+
+(define-computed-method %copy-folder ((uc1 <file-url>) (uc2 <file-url>))
+  (and (eq? uc1 uc2)
+       (lambda (url new-url)
+	 (copy-file (file-url-pathname url) (file-url-pathname new-url)))))
+
+(define-method available-folder-names ((url <file-url>))
+  url
+  (error "Unimplemented operation:" 'AVAILABLE-FOLDER-NAMES))
+
+(define-method subscribed-folder-names ((url <file-url>))
+  url
+  (error "Unimplemented operation:" 'SUBSCRIBED-FOLDER-NAMES))
+
+;;;; Folder
+
+(define-class <file-folder> (<folder>)
+  (url accessor folder-url)
+  (messages define standard))
+
+(define-method %folder-valid? ((folder <file-folder>))
+  (file-exists? (file-url-pathname (folder-url folder))))
+
+(define-method count-messages ((folder <file-folder>))
+  (length (file-folder-messages folder)))
+
+(define-method %get-message ((folder <file-folder>) index)
+  (list-ref (file-folder-messages folder) index))
+
+(define-method %insert-message ((folder <file-folder>) index message)
+  (let ((message (copy-message message))
+	(messages (file-folder-messages folder)))
+    (if (fix:= 0 index)
+	(set-file-folder-messages! folder (cons message messages))
+	(let loop ((index* 1) (prev messages) (this (cdr messages)))
+	  (if (fix:= index index*)
+	      (set-cdr! prev (cons message this))
+	      (loop (fix:+ index* 1) this (cdr this)))))))
+
+(define-method %append-message ((folder <file-folder>) message)
+  (set-file-folder-messages! folder
+			     (append! (file-folder-messages folder)
+				      (list (copy-message message)))))
+
+(define-method expunge-deleted-messages ((folder <file-folder>))
+  (set-file-folder-messages!
+   folder
+   (list-transform-negative (file-folder-messages folder) message-deleted?)))
+
+(define-method search-folder ((folder <file-folder>) criteria)
+  folder criteria
+  (error "Unimplemented operation:" 'SEARCH-FOLDER))
+
+(define-method synchronize-folder ((folder <file-folder>))
+  folder
+  unspecific)
+
+(define-method subscribe-folder ((folder <file-folder>))
+  folder
+  (error "Unimplemented operation:" 'SUBSCRIBE-FOLDER))
+
+(define-method unsubscribe-folder ((folder <file-folder>))
+  folder
+  (error "Unimplemented operation:" 'UNSUBSCRIBE-FOLDER))
\ No newline at end of file
diff --git a/v7/src/imail/imail-rmail.scm b/v7/src/imail/imail-rmail.scm
new file mode 100644
index 000000000..6cdde14c1
--- /dev/null
+++ b/v7/src/imail/imail-rmail.scm
@@ -0,0 +1,445 @@
+;;; -*-Scheme-*-
+;;;
+;;; $Id: imail-rmail.scm,v 1.1 2000/01/04 22:51:02 cph Exp $
+;;;
+;;; Copyright (c) 1999 Massachusetts Institute of Technology
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License as
+;;; published by the Free Software Foundation; either version 2 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;;; IMAIL mail reader: RMAIL back end
+
+(declare (usual-integrations))
+
+;;;; URL
+
+(define-class (<rmail-url> (constructor (pathname))) (<file-url>))
+
+(define-url-protocol "rmail" <rmail-url>
+  (lambda (string)
+    (make-rmail-url (short-name->pathname string))))
+
+;;;; Server operations
+
+(define-method %open-folder ((url <rmail-url>))
+  (read-rmail-file url))
+
+(define-method %new-folder ((url <rmail-url>))
+  (let ((folder (make-rmail-folder url 'COMPUTE '())))
+    (save-folder folder)
+    folder))
+
+;;;; Folder
+
+(define-class (<rmail-folder> (constructor (url header-fields messages)))
+    (<file-folder>)
+  (header-fields define standard accessor header-fields))
+
+(define-method %write-folder ((folder <folder>) (url <rmail-url>))
+  (write-rmail-file folder (file-url-pathname url)))
+
+(define-method poll-folder ((folder <rmail-folder>))
+  (rmail-get-new-mail folder))
+
+(define-method initialize-instance ((folder <rmail-folder>))
+  (if (eq? 'COMPUTE (header-fields folder))
+      (set-rmail-folder-header-fields!
+       folder
+       (compute-rmail-folder-header-fields folder))))
+
+(define-method header-fields ((folder <folder>))
+  (compute-rmail-folder-header-fields folder))
+
+(define (compute-rmail-folder-header-fields folder)
+  (list (make-header-field "Version" " 5")
+	(make-header-field
+	 "Labels"
+	 (let ((labels (compute-rmail-folder-labels folder)))
+	   (if (pair? labels)
+	       (apply string-append
+		      (car labels)
+		      (map (lambda (label) (string-append "," label))
+			   (cdr labels)))
+	       "")))
+	(make-header-field "Note" "   This is the header of an rmail file.")
+	(make-header-field "Note" "   If you are seeing it in rmail,")
+	(make-header-field "Note"
+			   "    it means the file has no messages in it.")))
+
+(define (compute-rmail-folder-labels folder)
+  (flags->rmail-labels
+   (let ((n (count-messages folder)))
+     (let loop ((index 0) (flags '()))
+       (if (fix:< index n)
+	   (loop (fix:+ index 1)
+		 (union-of-lists (message-flags (get-message folder index))
+				 flags))
+	   flags)))))
+
+;;;; Read RMAIL file
+
+(define (read-rmail-file url)
+  (let* ((pathname (file-url-pathname url))
+	 (namestring (->namestring pathname)))
+    (call-with-input-file pathname
+      (lambda (port)
+	(let ((folder-headers (read-rmail-prolog port)))
+	  (make-rmail-folder url
+			     folder-headers
+			     (read-rmail-messages port)))))))
+
+(define (read-rmail-prolog port)
+  (if (not (string-prefix? "BABYL OPTIONS:" (read-required-line port)))
+      (error "Not an RMAIL file:" port))
+  (lines->header-fields (read-lines-to-eom port)))
+
+(define (read-rmail-messages port)
+  (source->list (lambda () (read-rmail-message port))))
+
+(define (read-rmail-message port)
+  ;; **** This must be generalized to recognize an RMAIL file that has
+  ;; unix-mail format messages appended to it.
+  (let ((line (read-line port)))
+    (cond ((eof-object? line)
+	   line)
+	  ((and (fix:= 1 (string-length line))
+		(char=? rmail-message:start-char (string-ref line 0)))
+	   (read-rmail-message-1 port))
+	  (else
+	   (error "Malformed RMAIL file:" port)))))
+
+(define (read-rmail-message-1 port)
+  (call-with-values
+      (lambda () (parse-attributes-line (read-required-line port)))
+    (lambda (formatted? flags)
+      (let* ((headers (read-rmail-header-fields port))
+	     (displayed-headers
+	      (lines->header-fields (read-header-lines port)))
+	     (body (read-to-eom port))
+	     (finish
+	      (lambda (headers)
+		(let ((message (make-standard-message headers body)))
+		  (for-each (lambda (flag)
+			      (set-message-flag message flag))
+			    flags)
+		  (let ((headers (message-header-fields message)))
+		    (if (and (pair? headers)
+			     (string-ci=? "summary-line"
+					  (header-field-name (car headers))))
+			(begin
+			  (set-message-property
+			   message
+			   (header-field-name (car headers))
+			   (header-field-value (car headers)))
+			  (set-message-header-fields! message (cdr headers)))))
+		  message))))
+	(if formatted?
+	    (let ((message (finish headers)))
+	      (set-message-property message
+				    "displayed-header-fields"
+				    displayed-headers)
+	      message)
+	    (finish displayed-headers))))))
+
+(define (parse-attributes-line line)
+  (let ((parts (map string-trim (burst-string line #\, #f))))
+    (if (not (and (fix:= 2 (count-matching-items parts string-null?))
+		  (or (string=? "0" (car parts))
+		      (string=? "1" (car parts)))
+		  (string-null? (car (last-pair parts)))))
+	(error "Malformed RMAIL message-attributes line:" line))
+    (call-with-values
+	(lambda () (cut-list! (except-last-pair (cdr parts)) string-null?))
+      (lambda (attributes labels)
+	(values (string=? "1" (car parts))
+		(rmail-markers->flags attributes
+				      (if (pair? labels)
+					  (cdr labels)
+					  labels)))))))
+
+(define (read-rmail-header-fields port)
+  (lines->header-fields
+   (source->list
+    (lambda ()
+      (let ((line (read-required-line port)))
+	(cond ((string-null? line)
+	       (if (not (string=? rmail-message:headers-separator
+				  (read-required-line port)))
+		   (error "Missing RMAIL message-header separator string:"
+			  port))
+	       (make-eof-object port))
+	      ((string=? rmail-message:headers-separator line)
+	       (make-eof-object port))
+	      (else line)))))))
+
+;;;; Write RMAIL file
+
+(define (write-rmail-file folder url)
+  ;; **** Do backup of file here.
+  (call-with-output-file (file-url-pathname url)
+    (lambda (port)
+      (write-rmail-prolog (header-fields folder) port)
+      (write-rmail-messages (file-folder-messages folder) port))))
+
+(define (write-rmail-prolog header-fields port)
+  (write-string "BABYL OPTIONS: -*- rmail -*-" port)
+  (newline port)
+  (write-header-fields header-fields port)
+  (write-char rmail-message:end-char port))
+
+(define (write-rmail-messages messages port)
+  (for-each (lambda (message) (write-rmail-message message port)) messages))
+
+(define (write-rmail-message message port)
+  (write-char rmail-message:start-char port)
+  (newline port)
+  (let ((headers (message-header-fields message))
+	(displayed-headers
+	 (get-message-property message "displayed-header-fields" 'NONE)))
+    (write-rmail-attributes-line message displayed-headers port)
+    (if (not (eq? 'NONE displayed-headers))
+	(begin
+	  (write-rmail-properties message port)
+	  (write-header-fields headers port)
+	  (newline port)))
+    (write-string rmail-message:headers-separator port)
+    (newline port)
+    (if (eq? 'NONE displayed-headers)
+	(begin
+	  (write-rmail-properties message port)
+	  (write-header-fields headers port))
+	(write-header-fields displayed-headers port))
+    (newline port)
+    (write-string (message-body message) port)
+    (fresh-line port)
+    (write-char rmail-message:end-char port)))
+
+(define (write-rmail-attributes-line message formatted? port)
+  (write-char (if formatted? #\1 #\0) port)
+  (write-char #\, port)
+  (call-with-values (lambda () (flags->rmail-markers (message-flags message)))
+    (lambda (attributes labels)
+      (let ((write-markers
+	     (lambda (markers)
+	       (for-each (lambda (marker)
+			   (write-char #\space port)
+			   (write-string marker port)
+			   (write-char #\, port))
+			 markers))))
+	(write-markers attributes)
+	(write-char #\, port)
+	(write-markers labels))))
+  (newline port))
+
+(define (write-rmail-properties message port)
+  (let ((alist (message-properties message)))
+    (let ((summary-line
+	   (list-search-positive alist
+	     (lambda (n.v)
+	       (string-ci=? "summary-line" (car n.v))))))
+      (if summary-line
+	  (%write-header-field (car n.v) (cdr n.v) port)))
+    (for-each
+     (lambda (n.v)
+       (if (not (or (string-ci=? "summary-line" (car n.v))
+		    (string-ci=? "displayed-header-fields" (car n.v))))
+	   (write-header-field
+	    (message-property->header-field (car n.v) (cdr n.v))
+	    port)))
+     alist)))
+
+;;;; Get new mail
+
+(define (rmail-get-new-mail folder)
+  (let ((pathnames (rmail-folder-inbox-list folder)))
+    (if (null? pathnames)
+	#f
+	(let ((initial-count (count-messages folder)))
+	  (let ((inbox-folders
+		 (map (lambda (pathname)
+			(let ((inbox (read-rmail-inbox folder pathname #t)))
+			  (let ((n (count-messages inbox)))
+			    (do ((index 0 (fix:+ index 1)))
+				((fix:= i n))
+			      (append-message folder
+					      (get-message inbox index))))
+			  inbox))
+		      pathnames)))
+	    (save-folder folder)
+	    (for-each (lambda (folder)
+			(if folder
+			    (delete-folder (folder-url folder))))
+		      inbox-folders))
+	  (fix:- (count-messages folder) initial-count)))))
+
+(define (rmail-folder-inbox-list folder)
+  (let ((url (folder-url folder))
+	(inboxes (get-first-header-field-value folder "mail" #f)))
+    (cond (inboxes
+	   (map (let ((directory
+		       (directory-pathname (file-url-pathname url))))
+		  (lambda (filename)
+		    (merge-pathnames (string-trim filename) directory)))
+		(burst-string inboxes #\, #f)))
+	  ((pathname=? (rmail-primary-folder-name) (url-body url))
+	   (rmail-primary-inbox-list))
+	  (else '()))))
+
+(define (rmail-primary-folder-name)
+  "RMAIL")
+
+(define (rmail-primary-inbox-list)
+  (error "Unimplemented procedure:" 'RMAIL-PRIMARY-INBOX-LIST))
+
+(define (rmail-spool-directory)
+  (error "Unimplemented procedure:" 'RMAIL-SPOOL-DIRECTORY))
+
+(define (read-rmail-inbox folder pathname rename?)
+  (let ((pathname
+	 (cond ((not rename?)
+		pathname)
+	       ((pathname=? (rmail-spool-directory)
+			    (directory-pathname pathname))
+		(rename-inbox-using-movemail
+		 pathname
+		 (directory-pathname
+		  (file-url-pathname (folder-url folder)))))
+	       (else
+		(rename-inbox-using-rename pathname)))))
+    (and (file-exists? pathname)
+	 (open-folder (make-url "umail" (pathname->short-name pathname))))))
+
+(define (rename-inbox-using-movemail pathname directory)
+  (let ((pathname
+	 ;; On some systems, /usr/spool/mail/foo is a directory and
+	 ;; the actual inbox is /usr/spool/mail/foo/foo.
+	 (if (file-directory? pathname)
+	     (merge-pathnames (file-pathname pathname)
+			      (pathname-as-directory pathname))
+	     pathname))
+	(target (merge-pathnames ".newmail" directory)))
+    (if (and (file-exists? pathname)
+	     (not (file-exists? target)))
+	(let ((port (make-accumulator-output-port)))
+	  (let ((result
+		 (run-shell-command
+		  (string-append "movemail "
+				 (->namestring pathname)
+				 " "
+				 (->namestring target))
+		  'OUTPUT port)))
+	    (if (not (= 0 result))
+		(error "Movemail failure:"
+		       (get-output-from-accumulator port))))))
+    target))
+
+(define (rename-inbox-using-rename pathname)
+  (let ((target
+	 (merge-pathnames (string-append (file-namestring pathname) "+")
+			  (directory-pathname pathname))))
+    (if (and (file-exists? pathname)
+	     (not (file-exists? target)))
+	(rename-file pathname target))
+    target))
+
+;;;; Attributes and labels
+
+(define (rmail-markers->flags attributes labels)
+  (let loop
+      ((strings (remove-equal-duplicates (append attributes labels)))
+       (flags '()))
+    (if (pair? strings)
+	(loop (cdr strings)
+	      (cons (if (list-search-positive rmail-attributes
+			  (lambda (attribute)
+			    (string-ci=? attribute (car strings))))
+			(rmail-attribute->flag (car strings))
+			(rmail-label->flag (car strings)))
+		    flags))
+	(reverse! flags))))
+
+(define (flags->rmail-markers flags)
+  (let loop ((flags flags) (attributes '()) (labels '()))
+    (if (pair? flags)
+	(if (flag-is-rmail-attribute? (car flags))
+	    (loop (cdr flags)
+		  (cons (flag->rmail-attribute (car flags)) attributes)
+		  labels)
+	    (loop (cdr flags)
+		  attributes
+		  (cons (flag->rmail-label (car flags)) labels)))
+	(values (reverse! attributes) (reverse! labels)))))
+
+(define (flags->rmail-labels flags)
+  (call-with-values (lambda () (flags->rmail-markers flags))
+    (lambda (attributes labels)
+      attributes
+      labels)))
+
+(define (flag-is-rmail-attribute? flag)
+  (memq flag rmail-attribute-flags))
+
+(define (flag->rmail-attribute flag)
+  (symbol->string flag))
+
+(define (rmail-attribute->flag attribute)
+  (intern attribute))
+
+(define (flag->rmail-label flag)
+  (if (symbol? flag)
+      (string-append "standard:" (symbol->string flag))
+      flag))
+
+(define (rmail-label->flag label)
+  (if (string-prefix? "standard:" label)
+      (intern (string-tail label 9))
+      label))
+
+;;;; Syntactic Markers
+
+(define rmail-message:headers-separator
+  "*** EOOH ***")
+
+(define rmail-message:start-char
+  #\page)
+
+(define rmail-message:end-char
+  (integer->char #x1f))
+
+(define rmail-message:end-char-set
+  (char-set rmail-message:end-char))
+
+(define rmail-attributes
+  '("deleted" "answered" "unseen" "filed" "forwarded" "edited" "resent"))
+
+(define rmail-attribute-flags
+  (map intern rmail-attributes))
+
+;;;; Utilities
+
+(define (read-lines-to-eom port)
+  (source->list
+   (lambda ()
+     (if (eqv? rmail-message:end-char (peek-char port))
+	 (begin
+	   (read-char port)		;discard
+	   (make-eof-object port))
+	 (read-required-line port)))))
+
+(define (read-to-eom port)
+  (let ((string (read-string rmail-message:end-char-set port)))
+    (if (or (eof-object? string)
+	    (eof-object? (read-char port)))
+	(error "EOF while reading RMAIL message body:" port))
+    string))
\ No newline at end of file
diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm
new file mode 100644
index 000000000..c7e610795
--- /dev/null
+++ b/v7/src/imail/imail-top.scm
@@ -0,0 +1,89 @@
+;;; -*-Scheme-*-
+;;;
+;;; $Id: imail-top.scm,v 1.1 2000/01/04 22:51:05 cph Exp $
+;;;
+;;; Copyright (c) 1999 Massachusetts Institute of Technology
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License as
+;;; published by the Free Software Foundation; either version 2 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;;; IMAIL mail reader: top level
+
+(declare (usual-integrations))
+
+(define-command imail
+  "Read and edit incoming mail."
+  ()
+  (lambda ()
+    (let ((connection
+	   (let ((backend (get-backend (ref-variable imail-backend-type))))
+	     (open-connection
+	      backend
+	      (and (backend-requires-hostname? backend)
+		   (ref-variable imail-backend-server))))))
+      (authenticate-connection connection
+			       (or (ref-variable imail-user-name)
+				   (current-user-name))
+	(lambda (prompt-string)
+	  (call-with-pass-phrase prompt-string string-copy)))
+      (let ((name (ref-variable imail-primary-folder)))
+	(let ((folder (get-folder connection name)))
+	  (let ((buffer
+		 (or (imail-folder->buffer folder)
+		     (let ((buffer
+			    (new-buffer
+			     (imail-folder-name->buffer-name name))))
+		       (buffer-put! buffer 'IMAIL-FOLDER folder)
+		       (select-message
+			buffer
+			(let ((count (count-messages folder)))
+			  (if (= 0 count)
+			      count
+			      (- count 1))))
+		       buffer))))
+	    (select-buffer buffer)))))
+    ((ref-command imail-get-new-mail) #f)))
+
+(define (imail-folder->buffer folder)
+  )
+
+(define (imail-folder-name->buffer-name folder)
+  )
+
+(define-command imail-get-new-mail
+  "Get new mail from this folder's inbox."
+  ()
+  (lambda ()
+    (let ((buffer (current-buffer)))
+      (rmail-find-file-revert buffer)
+      (let ((n-messages
+	     (let ((memo (buffer-msg-memo buffer)))
+	       (if (msg-memo? memo)
+		   (msg-memo/number (msg-memo/last memo))
+		   0))))
+	(with-buffer-open buffer
+	  (lambda ()
+	    (with-buffer-undo-disabled buffer
+	      (lambda ()
+		(get-new-mail buffer
+			      (ref-variable rmail-inbox-list)
+			      #t)))))
+	(show-message
+	 buffer
+	 (let ((memo (buffer-msg-memo buffer)))
+	   (cond ((not (msg-memo? memo)) 0)
+		 ((> (msg-memo/number (msg-memo/last memo)) n-messages)
+		  (+ n-messages 1))
+		 (else (msg-memo/number memo)))))
+	(event-distributor/invoke! (ref-variable rmail-new-mail-hook))))))
\ No newline at end of file
diff --git a/v7/src/imail/imail-umail.scm b/v7/src/imail/imail-umail.scm
new file mode 100644
index 000000000..d8c39e4f3
--- /dev/null
+++ b/v7/src/imail/imail-umail.scm
@@ -0,0 +1,175 @@
+;;; -*-Scheme-*-
+;;;
+;;; $Id: imail-umail.scm,v 1.1 2000/01/04 22:51:09 cph Exp $
+;;;
+;;; Copyright (c) 1999 Massachusetts Institute of Technology
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License as
+;;; published by the Free Software Foundation; either version 2 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;;; IMAIL mail reader: RMAIL back end
+
+(declare (usual-integrations))
+
+;;;; URL
+
+(define-class (<umail-url> (constructor (pathname))) (<file-url>))
+
+(define-url-protocol "umail" <umail-url>
+  (lambda (string)
+    (make-umail-url (short-name->pathname string))))
+
+;;;; Server operations
+
+(define-method %open-folder ((url <umail-url>))
+  (read-umail-file url))
+
+(define-method %new-folder ((url <umail-url>))
+  (let ((folder (make-umail-folder url '())))
+    (save-folder folder)
+    folder))
+
+;;;; Folder
+
+(define-class (<umail-folder> (constructor (url messages))) (<file-folder>))
+
+(define-method %write-folder ((folder <folder>) (url <umail-url>))
+  (write-umail-file folder (file-url-pathname url)))
+
+(define-method poll-folder ((folder <umail-folder>))
+  folder
+  #f)
+
+;;;; Read unix mail file
+
+(define (read-umail-file url)
+  (let* ((pathname (file-url-pathname url))
+	 (namestring (->namestring pathname)))
+    (call-with-input-file pathname
+      (lambda (port)
+	(make-umail-folder url (read-umail-messages port namestring))))))
+
+(define (read-umail-messages port namestring)
+  (map (lambda (lines)
+	 (parse-umail-message lines namestring))
+       (let ((groups
+	      (burst-list (read-lines port)
+			  (lambda (line)
+			    (re-string-match unix-mail-delimiter line)))))
+	 (if (and (pair? groups)
+		  (not (null? (caar groups))))
+	     (error "Malformed unix mail file:" namestring))
+	 groups)))
+
+(define (parse-umail-message lines namestring)
+  (let loop ((ls (cdr lines)) (header-lines '()))
+    (if (pair? ls)
+	(if (string-null? (car ls))
+	    (let ((message
+		   (make-standard-message headers (lines->string (cdr ls)))))
+	      (set-message-property message "umail-from-line" (car lines))
+	      message)
+	    (loop (cdr ls) (cons (car ls) header-lines)))
+	(error "Malformed unix mail file:" namestring))))
+
+;;;; Write unix mail file
+
+(define (write-umail-file folder pathname)
+  (call-with-output-file (file-url-pathname url)
+    (lambda (port)
+      (write-umail-messages (file-folder-messages folder) port))))
+
+(define (write-umail-messages messages port)
+  (for-each (lambda (message) (write-umail-message message port)) messages))
+
+(define (write-umail-message message port)
+  (write-string
+   (let ((header (get-first-header-field message "umail-from-line" #f)))
+     (if header
+	 (string-trim (header-field-value header))
+	 (string-append "From "
+			(or (rfc822-first-address
+			     (get-first-header-field message "from" #t))
+			    "unknown")
+			" "
+			(universal-time->string (get-universal-time)))))
+   port)
+  (newline port)
+  (write-header-field (message-flags->header-field (message-flags message))
+		      port)
+  (for-each (lambda (n.v)
+	      (if (not (string-ci=? "umail-from-line" (car n.v)))
+		  (write-header-field
+		   (message-property->header-field (car n.v) (cdr n.v))
+		   port)))
+	    (message-properties message))
+  (write-header-fields (message-header-fields message) port)
+  (newline port)
+  (write-string (message-body message) port)
+  (fresh-line port))
+
+;;;; Detection of unix "from" lines.
+
+(define unix-mail-delimiter
+  ;; This very complex regular expression taken from Emacs 20.
+  (let ((time-zone-regexp
+	 (string-append
+	  (regexp-group "[A-Z]?[A-Z]?[A-Z][A-Z]\\( DST\\)?"
+			"[-+]?[0-9][0-9][0-9][0-9]"
+			"")
+	  " *")))
+    (string-append
+     "^From "
+
+     ;; Many things can happen to an RFC 822 mailbox before it is put into
+     ;; a `From' line.  The leading phrase can be stripped, e.g.
+     ;; `Joe <@w.x:joe@y.z>' -> `<@w.x:joe@y.z>'.  The <> can be stripped, e.g.
+     ;; `<@x.y:joe@y.z>' -> `@x.y:joe@y.z'.  Everything starting with a CRLF
+     ;; can be removed, e.g.
+     ;;		From: joe@y.z (Joe	K
+     ;;			User)
+     ;; can yield `From joe@y.z (Joe 	K Fri Mar 22 08:11:15 1996', and
+     ;;		From: Joe User
+     ;;			<joe@y.z>
+     ;; can yield `From Joe User Fri Mar 22 08:11:15 1996'.
+     ;; The mailbox can be removed or be replaced by white space, e.g.
+     ;;		From: "Joe User"{space}{tab}
+     ;;			<joe@y.z>
+     ;; can yield `From {space}{tab} Fri Mar 22 08:11:15 1996',
+     ;; where {space} and {tab} represent the Ascii space and tab characters.
+     ;; We want to match the results of any of these manglings.
+     ;; The following regexp rejects names whose first characters are
+     ;; obviously bogus, but after that anything goes.
+     "\\([^\0-\b\n-\r\^?].*\\)? "
+
+     ;; The time the message was sent.
+     "\\([^\0-\r \^?]+\\) +"				; day of the week
+     "\\([^\0-\r \^?]+\\) +"				; month
+     "\\([0-3]?[0-9]\\) +"				; day of month
+     "\\([0-2][0-9]:[0-5][0-9]\\(:[0-6][0-9]\\)?\\) *"	; time of day
+
+     ;; Perhaps a time zone, specified by an abbreviation, or by a
+     ;; numeric offset.
+     time-zone-regexp
+
+     ;; The year.
+     " \\([0-9][0-9]+\\) *"
+
+     ;; On some systems the time zone can appear after the year, too.
+     time-zone-regexp
+
+     ;; Old uucp cruft.
+     "\\(remote from .*\\)?"
+
+     "$")))
\ No newline at end of file
diff --git a/v7/src/imail/imail-util.scm b/v7/src/imail/imail-util.scm
new file mode 100644
index 000000000..a45a96039
--- /dev/null
+++ b/v7/src/imail/imail-util.scm
@@ -0,0 +1,185 @@
+;;; -*-Scheme-*-
+;;;
+;;; $Id: imail-util.scm,v 1.1 2000/01/04 22:51:15 cph Exp $
+;;;
+;;; Copyright (c) 1999 Massachusetts Institute of Technology
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License as
+;;; published by the Free Software Foundation; either version 2 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;;; IMAIL mail reader: utilities
+
+(declare (usual-integrations))
+
+(define (guarantee-index index procedure)
+  (if (not (index-fixnum? index))
+      (error:wrong-type-argument index "index" procedure)))
+
+(define (union-of-lists l1 l2)
+  (let loop ((l1 l1) (l2 l2))
+    (if (pair? l1)
+	(loop (cdr l1)
+	      (if (member (car l1) l2)
+		  l2
+		  (cons (car l1) l2)))
+	l2)))
+
+(define (source->list source)
+  (let ((item (source)))
+    (if (eof-object? item)
+	'()
+	(let ((head (list item)))
+	  (let loop ((prev head))
+	    (let ((item (source)))
+	      (if (eof-object? item)
+		  head
+		  (let ((this (list item)))
+		    (set-cdr! prev this)
+		    (loop this)))))))))
+
+(define (list->source items)
+  (lambda ()
+    (if (pair? items)
+	(let ((item (car items)))
+	  (set! items (cdr items))
+	  item)
+	(make-eof-object #f))))
+
+(define (cut-list items predicate)
+  (if (or (not (pair? items)) (predicate (car items)))
+      (values '() items)
+      (let ((head (list (car items))))
+	(values head
+		(let loop ((prev head) (this (cdr items)))
+		  (if (or (not (pair? this)) (predicate (car this)))
+		      this
+		      (let ((next (list (car this))))
+			(set-cdr! prev next)
+			(loop next (cdr this)))))))))
+
+(define (cut-list! items predicate)
+  (if (or (not (pair? items)) (predicate (car items)))
+      (values '() items)
+      (let loop ((prev items) (this (cdr items)))
+	(if (or (not (pair? this)) (predicate (car this)))
+	    (begin
+	      (set-cdr! prev '())
+	      (values items this))
+	    (loop this (cdr this))))))
+
+(define (burst-list items predicate)
+  (let loop ((items items) (groups '()))
+    (if (pair? items)
+	(let find-next ((items (cdr items)) (group (list (car items))))
+	  (if (and (pair? items) (not (predicate (car items))))
+	      (find-next (cdr items) (cons (car items) group))
+	      (loop items (cons (reverse! group) groups))))
+	(reverse! groups))))
+
+;; The cryptic LWSP means Linear White SPace.  We use it because it
+;; is the terminology from RFC 822.
+
+(define (char-lwsp? char)
+  (or (char=? #\space char)
+      (char=? #\tab char)))
+
+(define char-set:lwsp
+  (char-set #\space #\tab))
+
+(define (quote-lines lines)
+  (map (lambda (line)
+	 (string-append "\t" line))
+       lines))
+
+(define (unquote-lines lines)
+  (map (lambda (line)
+	 (if (and (fix:> (string-length line) 0)
+		  (char=? #\tab (string-ref line 0)))
+	     (string-tail line 1)
+	     (error "Unquoted line:" line)))
+       lines))
+
+(define (string->lines string)
+  (let ((lines (burst-string string #\newline #f)))
+    (if (string-null? (car (last-pair lines)))
+	(except-last-pair! lines)
+	lines)))
+
+(define (lines->string lines)
+  (apply string-append
+	 (map (lambda (line)
+		(string-append line "\n"))
+	      lines)))
+
+(define (short-name->pathname name)
+  (merge-pathnames name (current-home-directory)))
+
+(define (pathname->short-name pathname)
+  (enough-namestring pathname (current-home-directory)))
+
+(define (write-header-fields headers port)
+  (for-each (lambda (header)
+	      (write-header-field header port))
+	    headers))
+
+(define (write-header-field header port)
+  (%write-header-field (header-field-name header)
+		       (header-field-value header)
+		       port))
+
+(define (%write-header-field name value port)
+  (write-string name port)
+  (write-char #\: port)
+  (write-string value port)
+  (newline port))
+
+(define (separated-append tokens separator)
+  (if (pair? tokens)
+      (if (pair? (cdr tokens))
+	  (let loop ((tokens (cdr tokens)) (tokens* (list (car tokens))))
+	    (if (pair? tokens)
+		(loop (cdr tokens) (cons* (car tokens) separator tokens*))
+		(apply string-append (reverse! tokens*))))
+	  (car tokens))
+      ""))
+
+(define (read-header-lines port)
+  (source->list
+   (lambda ()
+     (let ((line (read-required-line port)))
+       (if (string-null? line)
+	   (make-eof-object port)
+	   line)))))
+
+(define (read-required-line port)
+  (let ((line (read-line port)))
+    (if (eof-object? line)
+	(error "Premature end of file:" port))
+    line))
+
+(define (remove-equal-duplicates items)
+  (if (pair? items)
+      (if (member (car items) (cdr items))
+	  (remove-equal-duplicates (cdr items))
+	  (cons (car items) (remove-equal-duplicates (cdr items))))
+      '()))
+
+(define (count-matching-items items predicate)
+  (let loop ((items items) (count 0))
+    (if (pair? items)
+	(loop (cdr items)
+	      (if (predicate (car items))
+		  (fix:+ count 1)
+		  count))
+	count)))
\ No newline at end of file
diff --git a/v7/src/imail/load.scm b/v7/src/imail/load.scm
new file mode 100644
index 000000000..9c6ba2813
--- /dev/null
+++ b/v7/src/imail/load.scm
@@ -0,0 +1,29 @@
+;;; -*-Scheme-*-
+;;;
+;;; $Id: load.scm,v 1.1 2000/01/04 22:51:42 cph Exp $
+;;;
+;;; Copyright (c) 1999 Massachusetts Institute of Technology
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License as
+;;; published by the Free Software Foundation; either version 2 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;;; IMAIL mail reader: loader
+
+(load-option 'SOS)
+(load "imail-util")
+(load "rfc822")
+(load "imail-core")
+(load "imail-file")
+(load "imail-rmail")
+(load "imail-umail")
\ No newline at end of file
diff --git a/v7/src/imail/print.sh b/v7/src/imail/print.sh
new file mode 100755
index 000000000..b3640b8a8
--- /dev/null
+++ b/v7/src/imail/print.sh
@@ -0,0 +1,21 @@
+#!/bin/sh
+#
+# $Id: print.sh,v 1.1 2000/01/04 22:52:21 cph Exp $
+#
+# Copyright (c) 1999 Massachusetts Institute of Technology
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License as
+# published by the Free Software Foundation; either version 2 of the
+# License, or (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+prlist imail-core.scm imail-file.scm imail-rmail.scm imail-umail.scm rfc822.scm imail-util.scm
diff --git a/v7/src/imail/rfc822.scm b/v7/src/imail/rfc822.scm
new file mode 100644
index 000000000..4ceb4abe8
--- /dev/null
+++ b/v7/src/imail/rfc822.scm
@@ -0,0 +1,261 @@
+;;; -*-Scheme-*-
+;;;
+;;; $Id: rfc822.scm,v 1.1 2000/01/04 22:51:45 cph Exp $
+;;;
+;;; Copyright (c) 1999 Massachusetts Institute of Technology
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License as
+;;; published by the Free Software Foundation; either version 2 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;;; IMAIL mail reader: RFC-822 support
+
+(declare (usual-integrations))
+
+(define (rfc822-first-address field)
+  (let ((addresses (rfc822-strip-quoted-names field)))
+    (and (pair? addresses)
+	 (car addresses))))
+
+(define (rfc822-addresses->string addresses)
+  (if (null? addresses)
+      ""
+      (separated-append addresses ", ")))
+
+;;;; Address extractor
+
+(define (rfc822-strip-quoted-names string)
+  (let ((address-list
+	 (rfc822-strip-quoted-names-1 (string->rfc822-tokens string))))
+    (if (and address-list (null? (cdr address-list)))
+	(car address-list)
+	(map string-trim (burst-string string #\, #f)))))
+
+(define (rfc822-strip-quoted-names-1 tokens)
+  (define (parse-addr-spec tokens)
+    (let ((local-part (parse-list tokens parse-word #\.)))
+      (and local-part
+	   (not (null? (cdr local-part)))
+	   (eqv? #\@ (cadr local-part))
+	   (let ((domain (parse-domain (cddr local-part))))
+	     (and domain
+		  (cons (string-append (separated-append (car local-part) ".")
+				       "@"
+				       (separated-append (car domain) "."))
+			(cdr domain)))))))
+  (define (parse-domain tokens)
+    (parse-list tokens
+		(lambda (tokens)
+		  (and (not (null? tokens))
+		       (string? (car tokens))
+		       (not (eqv? #\" (string-ref (car tokens) 0)))
+		       tokens))
+		#\.))
+  (define (parse-list tokens parse-element separator)
+    (let ((first (parse-element tokens)))
+      (and first
+	   (let loop ((tokens (cdr first)) (words (list (car first))))
+	     (let ((next
+		    (and (not (null? tokens))
+			 (eqv? separator (car tokens))
+			 (parse-element (cdr tokens)))))
+	       (if next
+		   (loop (cdr next) (cons (car next) words))
+		   (cons (reverse! words) tokens)))))))
+  (define (parse-word tokens)
+    (and (not (null? tokens))
+	 (string? (car tokens))
+	 (not (eqv? #\[ (string-ref (car tokens) 0)))
+	 tokens))
+  (parse-list
+   tokens
+   (lambda (tokens)
+     (or (parse-addr-spec tokens)
+	 (let ((word (parse-word tokens)))
+	   (and word
+		(let ((tokens
+		       (let loop ((tokens (cdr word)))
+			 (let ((word (parse-word tokens)))
+			   (if word
+			       (loop (cdr word))
+			       tokens)))))
+		  (and (not (null? tokens))
+		       (eqv? #\< (car tokens))
+		       (let ((addr-spec
+			      (parse-addr-spec
+			       (let ((domains
+				      (parse-list
+				       (cdr tokens)
+				       (lambda (tokens)
+					 (and (not (null? tokens))
+					      (eqv? #\@ (car tokens))
+					      (parse-domain (cdr tokens))))
+				       #\,)))
+				 (if (and domains
+					  (not (null? (cdr domains)))
+					  (eqv? #\: (cadr domains)))
+				     (cddr domains)
+				     (cdr tokens))))))
+			 (and addr-spec
+			      (not (null? (cdr addr-spec)))
+			      (eqv? #\> (cadr addr-spec))
+			      (cons (car addr-spec) (cddr addr-spec))))))))))
+   #\,))
+
+;;;; Parser
+
+(define (string->rfc822-tokens string)
+  (rfc822-clean-tokens (rfc822-read-tokens (string->input-port string))))
+
+(define (rfc822-clean-tokens tokens)
+  (let loop ((tokens tokens))
+    (if (null? tokens)
+	'()
+	(let ((rest (loop (cdr tokens))))
+	  (if (cond ((char? (car tokens))
+		     (eqv? #\space (car tokens)))
+		    ((string? (car tokens))
+		     (char=? #\( (string-ref (car tokens) 0)))
+		    (else true))
+	      rest
+	      (cons (car tokens) rest))))))
+
+(define rfc822-read-tokens
+  (let* ((special-chars
+	  (char-set #\( #\) #\[ #\] #\< #\> #\@ #\, #\; #\: #\\ #\" #\.))
+	 (atom-chars
+	  (char-set-difference (ascii-range->char-set #x21 #x7F)
+			       special-chars)))
+    (lambda (port)
+      (let ((special-char?
+	     (lambda (char) (char-set-member? special-chars char)))
+	    (atom-char? (lambda (char) (char-set-member? atom-chars char)))
+	    (lwsp?
+	     (lambda (char) (or (char=? #\space char) (char=? #\tab char))))
+	    (loser
+	     (lambda (chars)
+	       (list (cons 'UNTERMINATED (apply string (reverse! chars)))))))
+	(let dispatch ()
+	  (let ((char (input-port/read-char port)))
+	    (cond ((eof-object? char)
+		   '())
+		  ((lwsp? char)
+		   (do ()
+		       ((not (lwsp? (input-port/peek-char port))))
+		     (input-port/discard-char port))
+		   (cons #\space (dispatch)))
+		  ((atom-char? char)
+		   ;; atom
+		   (let loop ((chars (list char)))
+		     (let ((char (input-port/peek-char port)))
+		       (if (and (not (eof-object? char))
+				(atom-char? char))
+			   (begin
+			     (input-port/discard-char port)
+			     (loop (cons char chars)))
+			   (cons (apply string (reverse! chars))
+				 (dispatch))))))
+		  ((char=? #\" char)
+		   ;; quoted string
+		   (let loop ((chars (list char)))
+		     (let ((char (input-port/read-char port)))
+		       (cond ((eof-object? char)
+			      (loser chars))
+			     ((char=? #\" char)
+			      (cons (apply string (reverse! (cons char chars)))
+				    (dispatch)))
+			     ((char=? #\\ char)
+			      (let ((char (input-port/read-char port))
+				    (chars (cons char chars)))
+				(if (eof-object? char)
+				    (loser chars)
+				    (loop (cons char chars)))))
+			     ((char=? #\newline char)
+			      (let ((char (input-port/peek-char port)))
+				(if (lwsp? char)
+				    (begin
+				      (input-port/discard-char port)
+				      (loop (cons char chars)))
+				    (loser chars))))
+			     (else
+			      (loop (cons char chars)))))))
+
+		  ((char=? #\( char)
+		   ;; comment
+		   (let loop ((level 1) (chars (list char)))
+		     (let ((char (input-port/read-char port)))
+		       (cond ((eof-object? char)
+			      (loser chars))
+			     ((char=? #\( char)
+			      (loop (+ level 1) (cons char chars)))
+			     ((char=? #\) char)
+			      (let ((chars (cons char chars)))
+				(if (= level 1)
+				    (cons (apply string (reverse! chars))
+					  (dispatch))
+				    (loop (- level 1) chars))))
+			     ((char=? #\\ char)
+			      (let ((char (input-port/read-char port))
+				    (chars (cons char chars)))
+				(if (eof-object? char)
+				    (loser chars)
+				    (loop level (cons char chars)))))
+			     ((char=? #\newline char)
+			      (let ((char (input-port/peek-char port)))
+				(if (lwsp? char)
+				    (begin
+				      (input-port/discard-char port)
+				      (loop level (cons char chars)))
+				    (loser chars))))
+			     (else
+			      (loop level (cons char chars)))))))
+		  ((char=? #\[ char)
+		   ;; domain literal
+		   (let loop ((chars (list char)))
+		     (let ((char (input-port/peek-char port)))
+		       (cond ((or (eof-object? char)
+				  (char=? #\[ char))
+			      (loser chars))
+			     ((char=? #\] char)
+			      (input-port/discard-char port)
+			      (cons (apply string (reverse! (cons char chars)))
+				    (dispatch)))
+			     ((char=? #\\ char)
+			      (input-port/discard-char port)
+			      (let ((char (input-port/read-char port))
+				    (chars (cons char chars)))
+				(if (eof-object? char)
+				    (loser chars)
+				    (loop (cons char chars)))))
+			     ((char=? #\newline char)
+			      (input-port/discard-char port)
+			      (let ((char (input-port/peek-char port)))
+				(if (lwsp? char)
+				    (begin
+				      (input-port/discard-char port)
+				      (loop (cons char chars)))
+				    (loser chars))))
+			     (else
+			      (input-port/discard-char port)
+			      (loop (cons char chars)))))))
+		  ((char=? #\newline char)
+		   (let ((char (input-port/peek-char port)))
+		     (if (and (not (eof-object? char))
+			      (lwsp? char))
+			 (dispatch)
+			 '())))
+		  (else
+		   (cons (if (special-char? char)
+			     char
+			     (cons 'ILLEGAL char))
+			 (dispatch))))))))))
\ No newline at end of file