From 969e03cbafac846a8139f8aeb15f8cf86961a637 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 13 Jan 2000 22:20:48 +0000 Subject: [PATCH] Implement import and export of messages and folders. Clean up interface to I/O procedures so that it can be used for this purpose. --- v7/src/imail/imail-rmail.scm | 99 ++++++++++++++++++++---------------- v7/src/imail/imail-umail.scm | 75 +++++++++++++++++---------- 2 files changed, 101 insertions(+), 73 deletions(-) diff --git a/v7/src/imail/imail-rmail.scm b/v7/src/imail/imail-rmail.scm index 5b6e33c43..3ddf68726 100644 --- a/v7/src/imail/imail-rmail.scm +++ b/v7/src/imail/imail-rmail.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: imail-rmail.scm,v 1.2 2000/01/07 23:09:17 cph Exp $ +;;; $Id: imail-rmail.scm,v 1.3 2000/01/13 22:17:42 cph Exp $ ;;; -;;; Copyright (c) 1999 Massachusetts Institute of Technology +;;; Copyright (c) 1999-2000 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 @@ -24,7 +24,12 @@ ;;;; URL -(define-class ( (constructor (pathname))) ()) +(define-class ()) + +(define make-rmail-url + (let ((constructor (instance-constructor '(PATHNAME)))) + (lambda (pathname) + (constructor (merge-pathnames pathname))))) (define-url-protocol "rmail" (lambda (string) @@ -33,7 +38,7 @@ ;;;; Server operations (define-method %open-folder ((url )) - (read-rmail-file url)) + (read-rmail-file (file-url-pathname url) #f)) (define-method %new-folder ((url )) (let ((folder (make-rmail-folder url 'COMPUTE '()))) @@ -47,7 +52,7 @@ (header-fields accessor header-fields define modifier)) (define-method %write-folder ((folder ) (url )) - (write-rmail-file folder url)) + (write-rmail-file folder (file-url-pathname url) #f)) (define-method poll-folder ((folder )) (rmail-get-new-mail folder)) @@ -89,25 +94,26 @@ ;;;; 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-file pathname import?) + (call-with-input-file pathname + (lambda (port) + (read-rmail-folder (make-rmail-url pathname) port import?)))) + +(define (read-rmail-folder url port import?) + (let ((folder-headers (read-rmail-prolog port))) + (make-rmail-folder url + folder-headers + (read-rmail-messages port import?)))) (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-messages port import?) + (source->list (lambda () (read-rmail-message port import?)))) -(define (read-rmail-message port) +(define (read-rmail-message port import?) ;; **** This must be generalized to recognize an RMAIL file that has ;; unix-mail format messages appended to it. (let ((line (read-line port))) @@ -115,17 +121,21 @@ line) ((and (fix:= 1 (string-length line)) (char=? rmail-message:start-char (string-ref line 0))) - (read-rmail-message-1 port)) + (read-rmail-message-1 port import?)) (else (error "Malformed RMAIL file:" port))))) -(define (read-rmail-message-1 port) +(define (read-rmail-message-1 port import?) (call-with-values (lambda () (parse-attributes-line (read-required-line port))) (lambda (formatted? flags) - (let* ((headers (read-rmail-header-fields port)) + (let* ((headers + (maybe-strip-imail-headers import? + (read-rmail-header-fields port))) (displayed-headers - (lines->header-fields (read-header-lines port))) + (maybe-strip-imail-headers + import? + (lines->header-fields (read-header-lines port)))) (body (read-to-eom port)) (finish (lambda (headers) @@ -185,23 +195,21 @@ ;;;; Write RMAIL file -(define (write-rmail-file folder url) +(define (write-rmail-file folder pathname export?) ;; **** Do backup of file here. - (call-with-output-file (file-url-pathname url) + (call-with-output-file pathname (lambda (port) - (write-rmail-prolog (header-fields folder) port) - (write-rmail-messages (file-folder-messages folder) port)))) + (write-rmail-folder folder port export?)))) -(define (write-rmail-prolog header-fields port) +(define (write-rmail-folder folder port export?) (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)) + (write-header-fields (header-fields folder) port) + (write-char rmail-message:end-char port) + (for-each (lambda (message) (write-rmail-message message port export?)) + (file-folder-messages folder))) -(define (write-rmail-message message port) +(define (write-rmail-message message port export?) (write-char rmail-message:start-char port) (newline port) (let ((headers (message-header-fields message)) @@ -210,14 +218,14 @@ (write-rmail-attributes-line message displayed-headers port) (if (not (eq? 'NONE displayed-headers)) (begin - (write-rmail-properties message port) + (write-rmail-properties message port export?) (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-rmail-properties message port export?) (write-header-fields headers port)) (write-header-fields displayed-headers port)) (newline port) @@ -242,7 +250,7 @@ (write-markers labels)))) (newline port)) -(define (write-rmail-properties message port) +(define (write-rmail-properties message port export?) (let ((alist (message-properties message))) (let ((summary-line (list-search-positive alist @@ -250,14 +258,15 @@ (string-ci=? "summary-line" (car n.v)))))) (if summary-line (%write-header-field (car summary-line) (cdr summary-line) 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))) + (if (not export?) + (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 @@ -279,7 +288,7 @@ (save-folder folder) (for-each (lambda (folder) (if folder - (delete-folder (folder-url folder)))) + (delete-folder folder))) inbox-folders)) (fix:- (count-messages folder) initial-count))))) @@ -318,7 +327,7 @@ (else (rename-inbox-using-rename pathname))))) (and (file-exists? pathname) - (open-folder (make-url "umail" (pathname->short-name pathname)))))) + (read-umail-file pathname #t)))) (define (rename-inbox-using-movemail pathname directory) (let ((pathname diff --git a/v7/src/imail/imail-umail.scm b/v7/src/imail/imail-umail.scm index eb619ac08..871e38d7b 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.2 2000/01/07 23:10:02 cph Exp $ +;;; $Id: imail-umail.scm,v 1.3 2000/01/13 22:20:48 cph Exp $ ;;; ;;; Copyright (c) 1999 Massachusetts Institute of Technology ;;; @@ -24,7 +24,12 @@ ;;;; URL -(define-class ( (constructor (pathname))) ()) +(define-class ()) + +(define make-umail-url + (let ((constructor (instance-constructor '(PATHNAME)))) + (lambda (pathname) + (constructor (merge-pathnames pathname))))) (define-url-protocol "umail" (lambda (string) @@ -33,7 +38,7 @@ ;;;; Server operations (define-method %open-folder ((url )) - (read-umail-file url)) + (read-umail-file (file-url-pathname url) #f)) (define-method %new-folder ((url )) (let ((folder (make-umail-folder url '()))) @@ -45,7 +50,7 @@ (define-class ( (constructor (url messages))) ()) (define-method %write-folder ((folder ) (url )) - (write-umail-file folder url)) + (write-umail-file folder (file-url-pathname url) #f)) (define-method poll-folder ((folder )) folder @@ -53,25 +58,30 @@ ;;;; Read unix mail file -(define (read-umail-file url) - (let* ((pathname (file-url-pathname url))) - (call-with-input-file pathname - (lambda (port) - (make-umail-folder url (read-umail-messages port)))))) +(define (read-umail-file pathname import?) + (call-with-input-file pathname + (lambda (port) + (read-umail-folder (make-umail-url pathname) port import?)))) + +(define (read-umail-folder url port import?) + (make-umail-folder url (read-umail-messages port import?))) -(define (read-umail-messages port) - (map parse-umail-message +(define (read-umail-messages port import?) + (map (lambda (lines) + (parse-umail-message lines import?)) (burst-list (read-lines port) (lambda (line) (re-string-match unix-mail-delimiter line))))) -(define (parse-umail-message lines) +(define (parse-umail-message lines import?) (let ((message (let loop ((ls (cdr lines)) (header-lines '())) (if (pair? ls) (if (string-null? (car ls)) (make-standard-message - (lines->header-fields (reverse! header-lines)) + (maybe-strip-imail-headers + import? + (lines->header-fields (reverse! header-lines))) (lines->string (map (lambda (line) (if (string-prefix-ci? ">From " line) @@ -79,21 +89,27 @@ line)) (cdr ls)))) (loop (cdr ls) (cons (car ls) header-lines))) - (make-standard-message (reverse! header-lines) ""))))) + (make-standard-message + (maybe-strip-imail-headers + import? + (lines->header-fields (reverse! header-lines))) + (make-string 0)))))) (set-message-property message "umail-from-line" (car lines)) message)) ;;;; Write unix mail file -(define (write-umail-file folder url) - (call-with-output-file (file-url-pathname url) +(define (write-umail-file folder pathname export?) + ;; **** Do backup of file here. + (call-with-output-file pathname (lambda (port) - (write-umail-messages (file-folder-messages folder) port)))) + (write-umail-folder folder port export?)))) -(define (write-umail-messages messages port) - (for-each (lambda (message) (write-umail-message message port)) messages)) +(define (write-umail-folder folder port export?) + (for-each (lambda (message) (write-umail-message message port export?)) + (file-folder-messages folder))) -(define (write-umail-message message port) +(define (write-umail-message message port export?) (let ((from-line (get-message-property message "umail-from-line" #f))) (if from-line (write-string from-line port) @@ -110,14 +126,17 @@ (write-string (universal-time->unix-ctime (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)) + (if (not export) + (begin + (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) (for-each (lambda (line) -- 2.25.1