;;; -*-Scheme-*-
;;;
-;;; $Id: imail-core.scm,v 1.11 2000/01/18 22:21:01 cph Exp $
+;;; $Id: imail-core.scm,v 1.12 2000/01/19 05:39:13 cph Exp $
;;;
;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
;; error for invalid INDEX.
(define (get-message folder index)
(guarantee-index index 'GET-MESSAGE)
- (if (not (fix:< index (count-messages folder)))
+ (if (not (< index (count-messages folder)))
(error:bad-range-argument index 'GET-MESSAGE))
(%get-message folder index))
;; Unspecified result.
(define (insert-message folder index message)
(guarantee-index index 'INSERT-MESSAGE)
- (if (not (fix:<= index (length (count-messages folder))))
+ (if (not (<= index (count-messages folder)))
(error:bad-range-argument index 'INSERT-MESSAGE))
(guarantee-message message 'INSERT-MESSAGE)
(%insert-message folder index message))
\f
;;;; Message type
-(define-structure (message (type-descriptor message-rtd)
- (safe-accessors #t))
- header-fields
- body
- flags
- properties)
+(define-class <message> ()
+ (header-fields define standard
+ accessor header-fields
+ modifier set-header-fields!)
+ (body define standard)
+ (flags define standard)
+ (properties define standard)
+ (folder define accessor)
+ (index define standard))
(define (guarantee-message message procedure)
(if (not (message? message))
(error:wrong-type-argument message "IMAIL message" procedure)))
-(define-generic header-fields (object))
-
-(define-method header-fields ((message message-rtd))
- (message-header-fields message))
-
-(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))))
-
-(define (make-standard-message headers body)
- (let loop ((headers headers) (headers* '()) (flags '()) (properties '()))
- (cond ((not (pair? headers))
- (make-message (reverse! headers*)
- body
- (reverse! flags)
- (reverse! properties)))
- ((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))))
- (else
- (loop (cdr headers)
- (cons (car headers) headers*)
- flags
- properties)))))
+(define make-detached-message
+ (let ((constructor
+ (instance-constructor <message>
+ '(HEADER-FIELDS BODY FLAGS PROPERTIES))))
+ (lambda (headers body)
+ (let loop ((headers headers) (headers* '()) (flags '()) (properties '()))
+ (cond ((not (pair? headers))
+ (constructor (reverse! headers*)
+ body
+ (reverse! flags)
+ (reverse! properties)))
+ ((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))))
+ (else
+ (loop (cdr headers)
+ (cons (car headers) headers*)
+ flags
+ properties)))))))
+
+(define %copy-message
+ (let ((constructor
+ (instance-constructor <message>
+ '(HEADER-FIELDS BODY FLAGS PROPERTIES FOLDER))))
+ (lambda (message folder)
+ (guarantee-folder folder '%COPY-MESSAGE)
+ (constructor (map copy-header-field (header-fields message))
+ (message-body message)
+ (list-copy (message-flags message))
+ (alist-copy (message-properties message))
+ folder))))
(define (maybe-strip-imail-headers strip? headers)
(if strip?
(header-field->message-property header))))
headers))
\f
+;;;; Message Navigation
+
+(define (first-unseen-message folder)
+ (let ((message (first-message folder)))
+ (and message
+ (let loop ((message message))
+ (let ((next (next-message message)))
+ (cond ((not next) message)
+ ((message-seen? next) (loop next))
+ (else next)))))))
+
+(define (first-message folder)
+ (and (> (count-messages folder) 0)
+ (get-message folder 0)))
+
+(define (last-message folder)
+ (let ((n (count-messages folder)))
+ (and (> n 0)
+ (get-message folder (- n 1)))))
+
+(define (previous-message message #!optional predicate)
+ (let ((predicate
+ (if (or (default-object? predicate) (not predicate))
+ (lambda (message) message #t)
+ predicate))
+ (folder (message-folder message)))
+ (let loop ((index (message-index message)))
+ (and (> index 0)
+ (let ((index (- index 1)))
+ (let ((message (get-message folder index)))
+ (if (predicate message)
+ message
+ (loop index))))))))
+
+(define (next-message message #!optional predicate)
+ (let ((predicate
+ (if (or (default-object? predicate) (not predicate))
+ (lambda (message) message #t)
+ predicate))
+ (folder (message-folder message)))
+ (let ((n (count-messages folder)))
+ (let loop ((index (message-index message)))
+ (let ((index (+ index 1)))
+ (and (< index n)
+ (let ((message (get-message folder index)))
+ (if (predicate message)
+ message
+ (loop index)))))))))
+
+(define (previous-deleted-message message)
+ (previous-message message message-deleted?))
+
+(define (next-deleted-message message)
+ (next-message message message-deleted?))
+\f
;;;; Message flags
;;; Flags are markers that can be attached to messages. They indicate
;;; -*-Scheme-*-
;;;
-;;; $Id: imail-file.scm,v 1.2 2000/01/14 18:09:04 cph Exp $
+;;; $Id: imail-file.scm,v 1.3 2000/01/19 05:38:52 cph Exp $
;;;
;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
(list-ref (file-folder-messages folder) index))
(define-method %insert-message ((folder <file-folder>) index message)
- (let ((message (copy-message message))
- (messages (file-folder-messages folder)))
- (if (fix:= 0 index)
- (set-file-folder-messages! folder (cons message messages))
- (let loop ((index* 1) (prev messages) (this (cdr messages)))
- (if (fix:= index index*)
- (set-cdr! prev (cons message this))
- (loop (fix:+ index* 1) this (cdr this)))))))
+ (let ((message (%copy-message message folder)))
+ (set-message-index! message index)
+ (without-interrupts
+ (lambda ()
+ (let ((messages (file-folder-messages folder)))
+ (if (fix:= 0 index)
+ (begin
+ (do ((messages messages (cdr messages))
+ (index 1 (fix:+ index 1)))
+ ((not (pair? messages)))
+ (set-message-index! (car messages) index))
+ (set-file-folder-messages! folder (cons message messages)))
+ (let loop ((index* 1) (prev messages) (this (cdr messages)))
+ (if (not (pair? this))
+ (error:bad-range-argument index 'INSERT-MESSAGE))
+ (if (fix:= index index*)
+ (begin
+ (do ((messages this (cdr messages))
+ (index (fix:+ index 1) (fix:+ index 1)))
+ ((not (pair? messages)))
+ (set-message-index! (car messages) index))
+ (set-cdr! prev (cons message this)))
+ (loop (fix:+ index* 1) this (cdr this))))))))))
(define-method %append-message ((folder <file-folder>) message)
- (set-file-folder-messages! folder
- (append! (file-folder-messages folder)
- (list (copy-message message)))))
+ (let ((message (%copy-message message folder)))
+ (without-interrupts
+ (lambda ()
+ (set-file-folder-messages!
+ folder
+ (let ((messages (file-folder-messages folder)))
+ (if (pair? messages)
+ (begin
+ (let loop ((prev messages) (this (cdr messages)) (index 1))
+ (if (pair? this)
+ (loop this (cdr this) (fix:+ index 1))
+ (begin
+ (set-message-index! message index)
+ (set-cdr! prev (list message)))))
+ messages)
+ (begin
+ (set-message-index! message 0)
+ (list message)))))))))
(define-method expunge-deleted-messages ((folder <file-folder>))
- (set-file-folder-messages!
- folder
- (list-transform-negative (file-folder-messages folder) message-deleted?)))
-
+ (let ((messages
+ (list-transform-negative (file-folder-messages folder)
+ message-deleted?)))
+ (without-interrupts
+ (lambda ()
+ (do ((messages messages (cdr messages))
+ (index 0 (+ index 1)))
+ ((null? messages))
+ (set-message-index! (car messages) index))
+ (set-file-folder-messages! folder messages)))))
+\f
(define-method search-folder ((folder <file-folder>) criteria)
folder criteria
(error "Unimplemented operation:" 'SEARCH-FOLDER))
;;; -*-Scheme-*-
;;;
-;;; $Id: imail-rmail.scm,v 1.6 2000/01/18 20:54:01 cph Exp $
+;;; $Id: imail-rmail.scm,v 1.7 2000/01/19 05:37:56 cph Exp $
;;;
;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
(flags->rmail-labels
(let ((n (count-messages folder)))
(let loop ((index 0) (flags '()))
- (if (fix:< index n)
- (loop (fix:+ index 1)
+ (if (< index n)
+ (loop (+ index 1)
(union-of-lists (message-flags (get-message folder index))
flags))
flags)))))
(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?))))
+ (let ((folder (make-rmail-folder url (read-rmail-prolog port) '())))
+ (let loop ()
+ (let ((message (read-rmail-message port import?)))
+ (if message
+ (begin
+ (append-message folder message)
+ (loop)))))
+ folder))
(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 import?)
- (source->list (lambda () (read-rmail-message port import?))))
-
(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)))
(cond ((eof-object? line)
- line)
+ #f)
((and (fix:= 1 (string-length line))
(char=? rmail-message:start-char (string-ref line 0)))
(read-rmail-message-1 port import?))
(body (read-to-eom port))
(finish
(lambda (headers)
- (let ((message (make-standard-message headers body)))
+ (let ((message (make-detached-message headers body)))
(for-each (lambda (flag)
(set-message-flag message flag))
flags)
- (let ((headers (message-header-fields message)))
+ (let ((headers (header-fields message)))
(if (and (pair? headers)
(string-ci=? "summary-line"
(header-field-name (car headers))))
message
(header-field-name (car headers))
(header-field-value (car headers)))
- (set-message-header-fields! message (cdr headers)))))
+ (set-header-fields! message (cdr headers)))))
message))))
(if formatted?
(let ((message (finish headers)))
(define (write-rmail-message message port export?)
(write-char rmail-message:start-char port)
(newline port)
- (let ((headers (message-header-fields message))
+ (let ((headers (header-fields message))
(displayed-headers
(get-message-property message "displayed-header-fields" 'NONE)))
(write-rmail-attributes-line message displayed-headers port)
(map (lambda (pathname)
(let ((inbox (read-rmail-inbox folder pathname #t)))
(let ((n (count-messages inbox)))
- (do ((index 0 (fix:+ index 1)))
- ((fix:= index n))
+ (do ((index 0 (+ index 1)))
+ ((= index n))
(append-message folder
(get-message inbox index))))
inbox))
(if folder
(delete-folder folder)))
inbox-folders))
- (fix:- (count-messages folder) initial-count)))))
+ (- (count-messages folder) initial-count)))))
(define (rmail-folder-inbox-list folder)
(let ((url (folder-url folder))
;;; -*-Scheme-*-
;;;
-;;; $Id: imail-umail.scm,v 1.6 2000/01/18 20:47:17 cph Exp $
+;;; $Id: imail-umail.scm,v 1.7 2000/01/19 05:38:46 cph Exp $
;;;
;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
(define (make-umail-message from-line header-lines body-lines import?)
(let ((message
- (make-standard-message
+ (make-detached-message
(maybe-strip-imail-headers import?
(lines->header-fields header-lines))
(lines->string (map (lambda (line)
(message-property->header-field (car n.v) (cdr n.v))
port)))
(message-properties message))))
- (write-header-fields (message-header-fields message) port)
+ (write-header-fields (header-fields message) port)
(newline port)
(for-each (lambda (line)
(if (string-prefix-ci? "From " line)
projects / mit-scheme.git / commitdiff