;;; -*-Scheme-*-
;;;
-;;; $Id: imail-rmail.scm,v 1.13 2000/02/07 22:31:53 cph Exp $
+;;; $Id: imail-rmail.scm,v 1.14 2000/04/06 03:25:19 cph Exp $
;;;
;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
;;;; Server operations
(define-method %open-folder ((url <rmail-url>))
- (read-rmail-file (file-url-pathname url) #f))
+ (read-rmail-file (file-url-pathname url)))
(define-method %new-folder ((url <rmail-url>))
(let ((folder (make-rmail-folder url)))
(folder-put! folder 'RMAIL-HEADER-FIELDS headers))
(define-method %write-folder ((folder <folder>) (url <rmail-url>))
- (write-rmail-file folder (file-url-pathname url) #f)
+ (write-rmail-file folder (file-url-pathname url))
(if (eq? url (folder-url folder))
(update-file-folder-modification-time! folder)))
\f
;;;; Read RMAIL file
-(define (read-rmail-file pathname import?)
- (call-with-binary-input-file pathname
- (lambda (port)
- (read-rmail-folder (make-rmail-url pathname) port import?))))
-
-(define (read-rmail-folder url port import?)
- (let ((folder (make-rmail-folder url)))
+(define (read-rmail-file pathname)
+ (let ((folder (make-rmail-folder (make-rmail-url pathname))))
(%revert-folder folder)
folder))
(define-method %revert-folder ((folder <rmail-folder>))
- (set-header-fields! folder (read-rmail-prolog port))
- (let loop ()
- (let ((message (read-rmail-message port import?)))
- (if message
- (begin
- (append-message folder message)
- (loop)))))
+ (call-with-binary-input-file (file-folder-pathname folder)
+ (lambda (port)
+ (set-header-fields! folder (read-rmail-prolog port))
+ (let loop ()
+ (let ((message (read-rmail-message port)))
+ (if message
+ (begin
+ (append-message folder message)
+ (loop)))))))
(update-file-folder-modification-time! folder))
(define (read-rmail-prolog port)
(error "Not an RMAIL file:" port))
(lines->header-fields (read-lines-to-eom port)))
-(define (read-rmail-message port import?)
+(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)))
#f)
((and (fix:= 1 (string-length line))
(char=? rmail-message:start-char (string-ref line 0)))
- (read-rmail-message-1 port import?))
+ (read-rmail-message-1 port))
(else
(error "Malformed RMAIL file:" port)))))
-(define (read-rmail-message-1 port import?)
+(define (read-rmail-message-1 port)
(call-with-values
(lambda () (parse-attributes-line (read-required-line port)))
(lambda (formatted? flags)
- (let* ((headers
- (maybe-strip-imail-headers import?
- (read-rmail-header-fields port)))
+ (let* ((headers (read-rmail-header-fields port))
(displayed-headers
- (maybe-strip-imail-headers
- import?
- (lines->header-fields (read-header-lines port))))
+ (lines->header-fields (read-header-lines port)))
(body (read-to-eom port))
(finish
(lambda (headers)
\f
;;;; Write RMAIL file
-(define (write-rmail-file folder pathname export?)
+(define (write-rmail-file folder pathname)
;; **** Do backup of file here.
(call-with-binary-output-file pathname
(lambda (port)
- (write-rmail-folder folder port export?))))
-
-(define (write-rmail-folder folder port export?)
- (write-string "BABYL OPTIONS: -*- rmail -*-" port)
- (newline port)
- (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 export?)
+ (write-string "BABYL OPTIONS: -*- rmail -*-" port)
+ (newline port)
+ (write-header-fields (header-fields folder) port)
+ (write-char rmail-message:end-char port)
+ (for-each (lambda (message) (write-rmail-message message port))
+ (file-folder-messages folder)))))
+
+(define (write-rmail-message message port)
(write-char rmail-message:start-char port)
(newline port)
(let ((headers (header-fields message))
(write-rmail-attributes-line message displayed-headers port)
(if (not (eq? 'NONE displayed-headers))
(begin
- (write-rmail-properties message port export?)
+ (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 export?)
+ (write-rmail-properties message port)
(write-header-fields headers port))
(write-header-fields displayed-headers port))
(newline port)
(write-markers labels))))
(newline port))
-(define (write-rmail-properties message port export?)
+(define (write-rmail-properties message port)
(let ((alist (message-properties message)))
(let ((summary-line
(list-search-positive alist
(string-ci=? "summary-line" (car n.v))))))
(if summary-line
(%write-header-field (car summary-line) (cdr summary-line) port)))
- (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))))
+ (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)))
\f
;;;; Get new mail
(else
(rename-inbox-using-rename pathname)))))
(and (file-exists? pathname)
- (read-umail-file pathname #t))))
+ (read-umail-file pathname))))
(define (rename-inbox-using-movemail pathname directory)
(let ((pathname
;;; -*-Scheme-*-
;;;
-;;; $Id: imail-umail.scm,v 1.9 2000/02/07 22:31:56 cph Exp $
+;;; $Id: imail-umail.scm,v 1.10 2000/04/06 03:25:27 cph Exp $
;;;
;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
;;;; Server operations
(define-method %open-folder ((url <umail-url>))
- (read-umail-file (file-url-pathname url) #f))
+ (read-umail-file (file-url-pathname url)))
(define-method %new-folder ((url <umail-url>))
(let ((folder (make-umail-folder url)))
(define-class (<umail-folder> (constructor (url))) (<file-folder>))
(define-method %write-folder ((folder <folder>) (url <umail-url>))
- (write-umail-file folder (file-url-pathname url) #f)
+ (write-umail-file folder (file-url-pathname url))
(if (eq? url (folder-url folder))
(update-file-folder-modification-time! folder)))
\f
;;;; Read unix mail file
-(define (read-umail-file pathname import?)
- (call-with-binary-input-file pathname
- (lambda (port)
- (read-umail-folder (make-umail-url pathname) port import?))))
-
-(define (read-umail-folder url port import?)
- (let ((folder (make-umail-folder url)))
+(define (read-umail-file pathname)
+ (let ((folder (make-umail-folder (make-umail-url pathname))))
(%revert-folder folder)
folder))
(define-method %revert-folder ((folder <umail-folder>))
(set-file-folder-messages!
folder
- (let ((from-line (read-line port)))
- (if (eof-object? from-line)
- '()
- (begin
- (if (not (umail-delimiter? from-line))
- (error "Malformed unix mail file:" port))
- (let loop ((from-line from-line) (messages '()))
- (call-with-values
- (lambda () (read-umail-message from-line port import?))
- (lambda (message from-line)
- (let ((messages (cons message messages)))
- (if from-line
- (loop from-line messages)
- (reverse! messages))))))))))
- (update-file-folder-modification-time! folder))
-
-(define (read-umail-message from-line port import?)
+ (call-with-binary-input-file pathname
+ (lambda (port)
+ (let ((from-line (read-line port)))
+ (if (eof-object? from-line)
+ '()
+ (begin
+ (if (not (umail-delimiter? from-line))
+ (error "Malformed unix mail file:" port))
+ (let loop ((from-line from-line) (messages '()))
+ (call-with-values
+ (lambda () (read-umail-message from-line port))
+ (lambda (message from-line)
+ (let ((messages (cons message messages)))
+ (if from-line
+ (loop from-line messages)
+ (reverse! messages))))))))))))
+ (update-file-folder-modification-time! folder))
+
+(define (read-umail-message from-line port)
(let read-headers ((header-lines '()))
(let ((line (read-line port)))
(cond ((eof-object? line)
(values (make-umail-message from-line
(reverse! header-lines)
- '()
- import?)
+ '())
#f))
((string-null? line)
(let read-body ((body-lines '()))
(cond ((eof-object? line)
(values (make-umail-message from-line
(reverse! header-lines)
- (reverse! body-lines)
- import?)
+ (reverse! body-lines))
#f))
((umail-delimiter? line)
(values (make-umail-message from-line
(reverse! header-lines)
- (reverse! body-lines)
- import?)
+ (reverse! body-lines))
line))
(else
(read-body (cons line body-lines)))))))
(else
(read-headers (cons line header-lines)))))))
-(define (make-umail-message from-line header-lines body-lines import?)
+(define (make-umail-message from-line header-lines body-lines)
(let ((message
(make-detached-message
- (maybe-strip-imail-headers import?
- (lines->header-fields header-lines))
+ (lines->header-fields header-lines)
(lines->string (map (lambda (line)
(if (string-prefix-ci? ">From " line)
(string-tail line 1)
\f
;;;; Write unix mail file
-(define (write-umail-file folder pathname export?)
+(define (write-umail-file folder pathname)
;; **** Do backup of file here.
(call-with-binary-output-file pathname
(lambda (port)
- (write-umail-folder folder port export?))))
-
-(define (write-umail-folder folder port export?)
- (for-each (lambda (message) (write-umail-message message port export?))
- (file-folder-messages folder)))
+ (for-each (lambda (message) (write-umail-message message port))
+ (file-folder-messages folder)))))
-(define (write-umail-message message port export?)
+(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)
(write-string (universal-time->unix-ctime (get-universal-time))
port))))
(newline port)
- (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-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 (header-fields message) port)
(newline port)
(for-each (lambda (line)
projects / mit-scheme.git / commitdiff