From: Chris Hanson Date: Wed, 17 May 2000 15:03:49 +0000 (+0000) Subject: Eliminate COPY-MESSAGE, which no longer worked. X-Git-Tag: 20090517-FFI~3851 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=92bf4e0902bb0583e94288f774c17eda65de8229;p=mit-scheme.git Eliminate COPY-MESSAGE, which no longer worked. --- diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm index c387914b5..2c2355834 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.61 2000/05/16 18:55:35 cph Exp $ +;;; $Id: imail-core.scm,v 1.62 2000/05/17 15:03:49 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -331,11 +331,6 @@ (if (not (message? message)) (error:wrong-type-argument message "IMAIL message" procedure))) -(define (copy-message message) - (make-message (map copy-header-field (message-header-fields message)) - (message-body message) - (list-copy (message-flags message)))) - (define (attach-message! message folder index) (guarantee-folder folder 'ATTACH-MESSAGE!) (set-message-folder! message folder) diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm index f1f1bcb11..9c1fa0cac 100644 --- a/v7/src/imail/imail-file.scm +++ b/v7/src/imail/imail-file.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: imail-file.scm,v 1.24 2000/05/15 19:17:12 cph Exp $ +;;; $Id: imail-file.scm,v 1.25 2000/05/17 15:03:15 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -92,7 +92,7 @@ (define-method %append-message ((message ) (url )) (let ((folder (get-memoized-folder url))) (if folder - (let ((message (copy-message message))) + (let ((message (make-message-copy message folder))) (without-interrupts (lambda () (set-file-folder-messages! @@ -115,6 +115,7 @@ (list message)))))))) (append-message-to-file message url)))) +(define-generic make-message-copy (message folder)) (define-generic append-message-to-file (message url)) (define-method expunge-deleted-messages ((folder )) diff --git a/v7/src/imail/imail-rmail.scm b/v7/src/imail/imail-rmail.scm index a696bd445..1b16d1478 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.28 2000/05/16 18:55:38 cph Exp $ +;;; $Id: imail-rmail.scm,v 1.29 2000/05/17 15:03:10 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -91,6 +91,12 @@ (define-method rmail-message-displayed-header-fields ((message )) message 'UNDEFINED) + +(define-method make-message-copy ((message ) (folder )) + (make-rmail-message (message-header-fields message) + (message-body message) + (list-copy (message-flags message)) + (rmail-message-displayed-header-fields message))) ;;;; Read RMAIL file diff --git a/v7/src/imail/imail-umail.scm b/v7/src/imail/imail-umail.scm index 3cfb93dc9..8d263a6eb 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.24 2000/05/16 04:14:42 cph Exp $ +;;; $Id: imail-umail.scm,v 1.25 2000/05/17 15:03:01 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -64,7 +64,9 @@ ;;;; Message -(define-class () +(define-class ( + (constructor (header-fields body flags from-line))) + () (from-line define accessor)) (define-method umail-message-from-line ((message )) @@ -75,7 +77,14 @@ (rfc822:first-address from))) "unknown") " " - (universal-time->local-ctime-string (get-universal-time)))) + (universal-time->local-ctime-string + (message-internal-time message)))) + +(define-method make-message-copy ((message ) (folder )) + (make-umail-message (message-header-fields message) + (message-body message) + (list-copy (message-flags message)) + (umail-message-from-line message))) (define-method message-internal-time ((message )) (or (extract-umail-from-time (umail-message-from-line message)) @@ -110,46 +119,42 @@ (let read-headers ((header-lines '())) (let ((line (read-line port))) (cond ((eof-object? line) - (values (make-umail-message from-line - (reverse! header-lines) - '()) + (values (read-umail-message-1 from-line + (reverse! header-lines) + '()) #f)) ((string-null? line) (let read-body ((body-lines '())) (let ((line (read-line port))) (cond ((eof-object? line) - (values (make-umail-message from-line - (reverse! header-lines) - (reverse! body-lines)) + (values (read-umail-message-1 from-line + (reverse! header-lines) + (reverse! body-lines)) #f)) ((umail-delimiter? line) - (values (make-umail-message from-line - (reverse! header-lines) - (reverse! body-lines)) + (values (read-umail-message-1 from-line + (reverse! header-lines) + (reverse! body-lines)) line)) (else (read-body (cons line body-lines))))))) (else (read-headers (cons line header-lines))))))) -(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 (read-umail-message-1 from-line header-lines body-lines) + (call-with-values + (lambda () + (parse-imail-header-fields (lines->header-fields header-lines))) + (lambda (headers flags) + (make-umail-message 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))