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