From: Chris Hanson Date: Mon, 15 May 2000 19:01:57 +0000 (+0000) Subject: Eliminate message properties. X-Git-Tag: 20090517-FFI~3873 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=0b512335f3f241189e5a015da69e90c3ff514817;p=mit-scheme.git Eliminate message properties. --- diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm index 6b8351bab..d153c69ce 100644 --- a/v7/src/imail/imail-core.scm +++ b/v7/src/imail/imail-core.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: imail-core.scm,v 1.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 ;;; @@ -333,12 +333,10 @@ ;;;; Message type -(define-class ( (constructor (header-fields body flags properties))) - () +(define-class ( (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 @@ -359,32 +357,28 @@ (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))))) (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!) @@ -556,84 +550,6 @@ (define (message-resent msg) (set-message-flag msg "resent")) (define (message-not-resent msg) (clear-message-flag msg "resent")) -;;;; 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]") - ;;;; Header fields (define-structure (header-field diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm index adca138d2..ed8789286 100644 --- a/v7/src/imail/imail-imap.scm +++ b/v7/src/imail/imail-imap.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: imail-imap.scm,v 1.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 ;;; @@ -420,7 +420,6 @@ ;;;; Message datatype (define-class ( (constructor (folder index))) () - (properties initial-value '()) (uid) (length)) diff --git a/v7/src/imail/imail-rmail.scm b/v7/src/imail/imail-rmail.scm index ba71ea9d9..a958191db 100644 --- a/v7/src/imail/imail-rmail.scm +++ b/v7/src/imail/imail-rmail.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: imail-rmail.scm,v 1.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 ;;; @@ -80,6 +80,18 @@ (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 ( + (constructor (header-fields body flags + displayed-header-fields))) + () + (displayed-header-fields define accessor)) + +(define-method rmail-message-displayed-header-fields ((message )) + message + 'UNDEFINED) ;;;; Read RMAIL file @@ -128,19 +140,11 @@ (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)))))) (define (parse-attributes-line line) (let ((parts (map string-trim (burst-string line #\, #f)))) @@ -204,25 +208,20 @@ (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) @@ -240,16 +239,6 @@ (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))) ;;;; Get new mail diff --git a/v7/src/imail/imail-umail.scm b/v7/src/imail/imail-umail.scm index a04903329..758373138 100644 --- a/v7/src/imail/imail-umail.scm +++ b/v7/src/imail/imail-umail.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -62,6 +62,21 @@ (define-method save-folder ((folder )) (synchronize-file-folder-write folder write-umail-file)) + +;;;; Message + +(define-class () + (from-line define accessor)) + +(define-method umail-message-from-line ((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)))) ;;;; Read unix mail file @@ -114,17 +129,24 @@ (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 + '(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)) @@ -144,32 +166,10 @@ (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)