;;; -*-Scheme-*-
;;;
-;;; $Id: imail-core.scm,v 1.55 2000/05/15 12:54:18 cph Exp $
+;;; $Id: imail-core.scm,v 1.56 2000/05/15 19:01:46 cph Exp $
;;;
;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
\f
;;;; Message type
-(define-class (<message> (constructor (header-fields body flags properties)))
- ()
+(define-class (<message> (constructor (header-fields body flags))) ()
(header-fields define accessor)
(body define accessor)
(flags define standard)
- (properties define standard)
(modification-count define standard
initial-value 0)
(folder define standard
(define (make-detached-message headers body)
(call-with-values (lambda () (parse-imail-header-fields headers))
- (lambda (headers flags properties)
- (make-message headers body flags properties))))
+ (lambda (headers flags)
+ (make-message headers body flags))))
(define (parse-imail-header-fields headers)
- (let loop ((headers headers) (headers* '()) (flags '()) (properties '()))
+ (let loop ((headers headers) (headers* '()) (flags '()))
(cond ((not (pair? headers))
(values (reverse! headers*)
- (remove-duplicates! (reverse! flags) string-ci=?)
- (reverse! properties)))
+ (remove-duplicates! (reverse! flags) string-ci=?)))
((header-field->message-flags (car headers))
=> (lambda (flags*)
- (loop (cdr headers) headers*
- (append! (reverse! (cdr flags*)) flags) properties)))
- ((header-field->message-property (car headers))
- => (lambda (property)
- (loop (cdr headers) headers* flags
- (cons property properties))))
+ (loop (cdr headers)
+ headers*
+ (append! (reverse! (cdr flags*)) flags))))
(else
- (loop (cdr headers) (cons (car headers) headers*) flags
- properties)))))
+ (loop (cdr headers)
+ (cons (car headers) headers*)
+ flags)))))
\f
(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))))
+ (list-copy (message-flags message))))
(define (attach-message! message folder index)
(guarantee-folder folder 'ATTACH-MESSAGE!)
(define (message-resent msg) (set-message-flag msg "resent"))
(define (message-not-resent msg) (clear-message-flag msg "resent"))
\f
-;;;; 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 ((alist (message-properties message)))
- (let loop ((alist* alist))
- (if (pair? alist*)
- (if (string-ci=? name (caar alist*))
- (set-cdr! (car alist*) value)
- (loop (cdr alist*)))
- (set-message-properties! message
- (cons (cons name value) alist)))))
- (message-modified! message))
-
-(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:string-marker value)
- (apply string-append
- message-property:headers-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:string-marker value)
- (string-tail
- value
- (string-length message-property:string-marker)))
- ((string-prefix? message-property:headers-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:string-marker "[string]")
-(define message-property:headers-marker "[headers]")
-\f
;;;; Header fields
(define-structure (header-field
;;; -*-Scheme-*-
;;;
-;;; $Id: imail-imap.scm,v 1.33 2000/05/12 18:22:52 cph Exp $
+;;; $Id: imail-imap.scm,v 1.34 2000/05/15 19:01:50 cph Exp $
;;;
;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
;;;; Message datatype
(define-class (<imap-message> (constructor (folder index))) (<message>)
- (properties initial-value '())
(uid)
(length))
;;; -*-Scheme-*-
;;;
-;;; $Id: imail-rmail.scm,v 1.25 2000/05/12 18:22:56 cph Exp $
+;;; $Id: imail-rmail.scm,v 1.26 2000/05/15 19:01:54 cph Exp $
;;;
;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
(make-header-field "Note" " If you are seeing it in rmail,")
(make-header-field "Note"
" it means the file has no messages in it.")))
+
+;;;; Message
+
+(define-class (<rmail-message>
+ (constructor (header-fields body flags
+ displayed-header-fields)))
+ (<message>)
+ (displayed-header-fields define accessor))
+
+(define-method rmail-message-displayed-header-fields ((message <message>))
+ message
+ 'UNDEFINED)
\f
;;;; Read RMAIL file
(lines->header-fields (read-header-lines port)))
(body (read-to-eom port))
(finish
- (lambda (headers)
- (let ((message (make-detached-message headers body)))
- (for-each (lambda (flag)
- (set-message-flag message flag))
- flags)
- message))))
+ (lambda (headers displayed-headers)
+ (make-rmail-message headers body flags displayed-headers))))
(if formatted?
- (let ((message (finish headers)))
- (set-message-property message
- "displayed-header-fields"
- displayed-headers)
- message)
- (finish displayed-headers))))))
+ (finish headers displayed-headers)
+ (finish displayed-headers 'UNDEFINED))))))
\f
(define (parse-attributes-line line)
(let ((parts (map string-trim (burst-string line #\, #f))))
(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)))
+ (displayed-headers (rmail-message-displayed-header-fields message)))
+ (let ((formatted? (not (eq? 'UNDEFINED displayed-headers))))
+ (write-rmail-attributes-line message formatted? port)
+ (if formatted?
+ (begin
+ (write-header-fields headers port)
+ (newline port)))
+ (write-string rmail-message:headers-separator port)
+ (newline port)
+ (write-header-fields (if formatted? displayed-headers 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)
(write-markers labels))))
(newline port))
-
-(define (write-rmail-properties message port)
- (let ((alist (message-properties message)))
- (for-each
- (lambda (n.v)
- (if (not (string-ci=? "displayed-header-fields" (car n.v)))
- (write-header-field
- (message-property->header-field (car n.v) (cdr n.v))
- port)))
- alist)))
\f
;;;; Get new mail
;;; -*-Scheme-*-
;;;
-;;; $Id: imail-umail.scm,v 1.21 2000/05/15 18:19:46 cph Exp $
+;;; $Id: imail-umail.scm,v 1.22 2000/05/15 19:01:57 cph Exp $
;;;
;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
(define-method save-folder ((folder <umail-folder>))
(synchronize-file-folder-write folder write-umail-file))
+
+;;;; Message
+
+(define-class <umail-message> (<message>)
+ (from-line define accessor))
+
+(define-method umail-message-from-line ((message <message>))
+ (string-append "From "
+ (or (let ((from
+ (get-first-header-field-value message "from" #f)))
+ (and from
+ (rfc822:first-address from)))
+ "unknown")
+ " "
+ (universal-time->local-ctime-string (get-universal-time))))
\f
;;;; Read unix mail file
(else
(read-headers (cons line header-lines)))))))
-(define (make-umail-message from-line header-lines body-lines)
- (let ((message
- (make-detached-message
- (lines->header-fields header-lines)
- (lines->string (map (lambda (line)
- (if (string-prefix-ci? ">From " line)
- (string-tail line 1)
- line))
- body-lines)))))
- (set-message-property message "umail-from-line" from-line)
- message))
+(define make-umail-message
+ (let ((constructor
+ (instance-constructor <umail-message>
+ '(HEADER-FIELDS BODY FLAGS FROM-LINE))))
+ (lambda (from-line header-lines body-lines)
+ (call-with-values
+ (lambda ()
+ (parse-imail-header-fields (lines->header-fields header-lines)))
+ (lambda (headers flags)
+ (constructor headers
+ (lines->string
+ (map (lambda (line)
+ (if (string-prefix-ci? ">From " line)
+ (string-tail line 1)
+ line))
+ body-lines))
+ flags
+ from-line))))))
(define (umail-delimiter? line)
(re-string-match unix-mail-delimiter line))
(close-port port)))
(define (write-umail-message message port)
- (let ((from-line (get-message-property message "umail-from-line" #f)))
- (if from-line
- (write-string from-line port)
- (begin
- (write-string "From " port)
- (write-string (or (let ((from
- (get-first-header-field-value
- message "from" #f)))
- (and from
- (rfc822:first-address from)))
- "unknown")
- port)
- (write-string " " port)
- (write-string
- (universal-time->local-ctime-string (get-universal-time))
- port))))
+ (write-string (umail-message-from-line message) 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-field (message-flags->header-field (message-flags message))
+ port)
(write-header-fields (message-header-fields message) port)
(newline port)
(for-each (lambda (line)
projects / mit-scheme.git / commitdiff