;;; -*-Scheme-*-
;;;
-;;; $Id: imail-core.scm,v 1.30 2000/04/23 04:02:38 cph Exp $
+;;; $Id: imail-core.scm,v 1.31 2000/04/27 02:16:37 cph Exp $
;;;
;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
(define-class (<message> (constructor (header-fields body flags properties)))
()
- (header-fields define standard
- accessor header-fields
- modifier set-header-fields!)
- (body define standard)
+ (header-fields define accessor)
+ (body define accessor)
(flags define standard)
(modified? define standard
initial-value #t)
(define (attach-message message folder)
(guarantee-folder folder 'ATTACH-MESSAGE)
(let ((message
- (make-message (map copy-header-field (header-fields message))
+ (make-message (map copy-header-field (message-header-fields message))
(message-body message)
(list-copy (message-flags message))
(alist-copy (message-properties message)))))
headers))
(define (message->string message)
- (string-append (header-fields->string (header-fields message))
+ (string-append (header-fields->string (message-header-fields message))
"\n"
(message-body message)))
\f
(define (copy-header-field header)
(record-copy header))
+(define (->header-fields object)
+ (cond ((or (pair? object) (null? object)) object)
+ ((message? object) (message-header-fields object))
+ (else (error:wrong-type-argument object "header fields" #f))))
+
(define (get-first-header-field headers name error?)
- (let loop
- ((headers
- (if (or (pair? headers) (null? headers))
- headers
- (header-fields headers))))
+ (let loop ((headers (->header-fields headers)))
(cond ((pair? headers)
(if (string-ci=? name (header-field-name (car headers)))
(car headers)
(else #f))))
(define (get-last-header-field headers name error?)
- (let loop
- ((headers
- (if (or (pair? headers) (null? headers))
- headers
- (header-fields headers)))
- (winner #f))
+ (let loop ((headers (->header-fields headers)) (winner #f))
(cond ((pair? headers)
(loop (cdr headers)
(if (string-ci=? name (header-field-name (car headers)))
(else winner))))
(define (get-all-header-fields headers name)
- (list-transform-positive
- (if (or (pair? headers) (null? headers))
- headers
- (header-fields headers))
+ (list-transform-positive (->header-fields headers)
(lambda (header)
(string-ci=? name (header-field-name header)))))
;;; -*-Scheme-*-
;;;
-;;; $Id: imail-rmail.scm,v 1.18 2000/04/14 01:45:37 cph Exp $
+;;; $Id: imail-rmail.scm,v 1.19 2000/04/27 02:16:41 cph Exp $
;;;
;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
(define-method %new-folder ((url <rmail-url>))
(let ((folder (make-rmail-folder url)))
- (set-header-fields! folder (compute-rmail-folder-header-fields folder))
+ (set-rmail-folder-header-fields!
+ folder
+ (compute-rmail-folder-header-fields folder))
(save-folder folder)
folder))
;;;; Folder
-(define-class (<rmail-folder> (constructor (url))) (<file-folder>))
+(define-class (<rmail-folder> (constructor (url))) (<file-folder>)
+ (header-fields define standard))
-(define-method header-fields ((folder <rmail-folder>))
- (folder-get folder 'RMAIL-HEADER-FIELDS '()))
-
-(define-method set-header-fields! ((folder <rmail-folder>) headers)
- (folder-put! folder 'RMAIL-HEADER-FIELDS headers))
+(define-method rmail-folder-header-fields ((folder <folder>))
+ (compute-rmail-folder-header-fields folder))
(define-method %write-folder ((folder <folder>) (url <rmail-url>))
(write-rmail-file folder (file-url-pathname url))
(define-method poll-folder ((folder <rmail-folder>))
(rmail-get-new-mail folder))
-(define-method header-fields ((folder <folder>))
- (compute-rmail-folder-header-fields folder))
-
(define (compute-rmail-folder-header-fields folder)
(list (make-header-field "Version" " 5")
(make-header-field "Labels"
(define-method %revert-folder ((folder <rmail-folder>))
(call-with-binary-input-file (file-folder-pathname folder)
(lambda (port)
- (set-header-fields! folder (read-rmail-prolog port))
+ (set-rmail-folder-header-fields! folder (read-rmail-prolog port))
(let loop ()
(let ((message (read-rmail-message port)))
(if message
(for-each (lambda (flag)
(set-message-flag message flag))
flags)
- (let ((headers (header-fields message)))
- (if (and (pair? headers)
- (string-ci=? "summary-line"
- (header-field-name (car headers))))
- (begin
- (set-message-property
- message
- (header-field-name (car headers))
- (header-field-value (car headers)))
- (set-header-fields! message (cdr headers)))))
message))))
(if formatted?
(let ((message (finish headers)))
(lambda (port)
(write-string "BABYL OPTIONS: -*- rmail -*-" port)
(newline port)
- (write-header-fields (header-fields folder) port)
+ (write-header-fields (rmail-folder-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))
+ (let ((headers (message-header-fields message))
(displayed-headers
(get-message-property message "displayed-header-fields" 'NONE)))
(write-rmail-attributes-line message displayed-headers port)
(define (write-rmail-properties message port)
(let ((alist (message-properties message)))
- (let ((summary-line
- (list-search-positive alist
- (lambda (n.v)
- (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))))
+ (if (not (string-ci=? "displayed-header-fields" (car n.v)))
(write-header-field
(message-property->header-field (car n.v) (cdr n.v))
port)))
(- (folder-length folder) initial-count)))))
(define (rmail-folder-inbox-list folder)
- (let ((inboxes (get-first-header-field-value folder "mail" #f)))
+ (let ((inboxes
+ (get-first-header-field-value (rmail-folder-header-fields folder)
+ "mail" #f)))
(cond (inboxes
(map (let ((directory
(directory-pathname (file-folder-pathname folder))))
;;; -*-Scheme-*-
;;;
-;;; $Id: imail-top.scm,v 1.23 2000/04/27 00:28:09 cph Exp $
+;;; $Id: imail-top.scm,v 1.24 2000/04/27 02:16:43 cph Exp $
;;;
;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
\\[imail-summary-by-recipients] Like \\[imail-summary] only just messages with particular recipient(s) are summarized.
\\[imail-toggle-header] Toggle between full headers and reduced headers.
- Normally only reduced headers are shown.
-\\[imail-edit-current-message] Edit the current message. C-c C-c to return to IMAIL."
+ Normally only reduced headers are shown."
(lambda (buffer)
(buffer-put! buffer 'REVERT-BUFFER-METHOD imail-revert-buffer)
(local-set-variable! mode-line-modified "--- " buffer)
(define-key 'imail #\i 'imail-input)
(define-key 'imail #\q 'imail-quit)
(define-key 'imail #\? 'describe-mode)
-(define-key 'imail #\w 'imail-edit-current-message)
(define (imail-revert-buffer buffer dont-use-auto-save? dont-confirm?)
dont-use-auto-save?
(insert-string
(header-fields->string
(if full-headers?
- (header-fields message)
+ (message-header-fields message)
(maybe-reformat-headers message buffer)))
mark)
(insert-newline mark)
(if (eq? 'NONE displayed)
(let ((trimmed
(let ((headers
- (let ((headers (header-fields message))
+ (let ((headers (message-header-fields message))
(regexp
(ref-variable imail-ignored-headers buffer)))
(if regexp
(strip-subject-re (string-trim-left (string-tail subject 3)))
subject))
\f
-;;;; Message editing
-
-(define-command imail-edit-current-message
- "Edit the current IMAIL message."
- ()
- (lambda ()
- ;; Guarantee that this buffer has both folder and message bindings.
- (selected-folder)
- (selected-message)
- (let ((buffer (selected-buffer)))
- (set-buffer-major-mode! buffer (ref-mode-object imail-edit))
- (set-buffer-writeable! buffer)
- (message
- (substitute-command-keys
- "Editing: Type \\[imail-cease-edit] to return to Imail, \\[imail-abort-edit] to abort."
- buffer)))))
-
-(define-major-mode imail-edit text "IMAIL Edit"
- "Major mode for editing the contents of an IMAIL message.
-The editing commands are the same as in Text mode,
-together with two commands to return to regular IMAIL:
- \\[imail-abort-edit] cancels the changes you have made and returns to IMAIL;
- \\[imail-cease-edit] makes them permanent."
- (lambda (buffer)
- (enable-group-undo! (buffer-group buffer))))
-
-(define-key 'imail-edit '(#\c-c #\c-c) 'imail-cease-edit)
-(define-key 'imail-edit '(#\c-c #\c-\]) 'imail-abort-edit)
-
-(define-command imail-cease-edit
- "Finish editing message; switch back to IMAIL proper."
- ()
- (lambda ()
- (call-with-values
- (lambda ()
- (let ((buffer (selected-buffer)))
- (set-buffer-writeable! buffer)
- (buffer-widen! buffer)
- (guarantee-newline (buffer-end buffer))
- (let ((body-start
- (search-forward "\n\n"
- (buffer-start buffer)
- (buffer-end buffer)
- #f)))
- (if body-start
- (values (extract-string (buffer-start buffer)
- (mark-1+ body-start))
- (extract-string body-start
- (buffer-end buffer)))
- (values (extract-string (buffer-start buffer)
- (buffer-end buffer))
- "")))))
- (lambda (headers-string body)
- (let ((message (selected-message)))
- ;; **** The next line could generate an error. We need to
- ;; figure out what to do if that happens.
- (set-header-fields! message (string->header-fields headers-string))
- (set-message-body! message body)
- (select-message (selected-folder) message #t))))))
-
-(define-command imail-abort-edit
- "Abort edit of current message; restore original contents."
- ()
- (lambda ()
- (select-message (selected-folder) (selected-message) #t)))
-\f
;;;; Miscellany
(define-command imail-toggle-header
;;; -*-Scheme-*-
;;;
-;;; $Id: imail-umail.scm,v 1.11 2000/04/06 03:26:41 cph Exp $
+;;; $Id: imail-umail.scm,v 1.12 2000/04/27 02:16:47 cph Exp $
;;;
;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
(message-property->header-field (car n.v) (cdr n.v))
port)))
(message-properties message))
- (write-header-fields (header-fields message) port)
+ (write-header-fields (message-header-fields message) port)
(newline port)
(for-each (lambda (line)
(if (string-prefix-ci? "From " line)
projects / mit-scheme.git / commitdiff