From 31e47e5c9952085f0b7d9f98851decc2bd3cef68 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 8 May 2000 15:04:01 +0000 Subject: [PATCH] Rework handling of FETCH commands: any attributes that we care about are now transparently stored directly into the appropriate message. This allows for unsolicited FETCH responses from the server. --- v7/src/imail/imail-imap.scm | 211 +++++++++++++++++++----------------- 1 file changed, 109 insertions(+), 102 deletions(-) diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm index 770d002c5..29d6f04fe 100644 --- a/v7/src/imail/imail-imap.scm +++ b/v7/src/imail/imail-imap.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: imail-imap.scm,v 1.19 2000/05/08 04:31:01 cph Exp $ +;;; $Id: imail-imap.scm,v 1.20 2000/05/08 15:04:01 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -247,69 +247,6 @@ (unseen define standard) (messages define standard initial-value '#())) -(define-class () - (uid define accessor) - (length define accessor)) - -(define make-imap-message - (let ((constructor - (instance-constructor - '(HEADER-FIELDS BODY FLAGS PROPERTIES - UID LENGTH)))) - (lambda (uid flags rfc822.size rfc822.header) - (constructor (lines->header-fields - (except-last-pair! - (string->lines - (translate-string-line-endings rfc822.header)))) - 'UNCACHED - (map imap-flag->imail-flag flags) - '() - uid - rfc822.size)))) - -(let ((modifier (slot-modifier 'BODY))) - (define-method message-body ((message )) - (let ((body (call-next-method message))) - (if (eq? 'UNCACHED body) - (let ((body - (translate-string-line-endings - (car - (let ((index (message-index message))) - ((imail-message-wrapper "Reading body for message " - (number->string (+ index 1))) - (lambda () - (imap:command:fetch (imap-folder-connection - (message-folder message)) - index - '(RFC822.TEXT))))))))) - (modifier message body) - body) - body)))) - -(define-method set-message-flags! ((message ) flags) - (call-next-method - message - (map imap-flag->imail-flag - (imap:response:fetch-attribute - (imap:command:store-flags - (imap-folder-connection (message-folder message)) - (message-index message) - (map imail-flag->imap-flag (flags-delete "\\recent" flags))) - 'FLAGS)))) - -(define (imap-flag->imail-flag flag) - (case flag - ((\ANSWERED) "answered") - ((\DELETED) "deleted") - ((\SEEN) "seen") - (else (symbol->string flag)))) - -(define (imail-flag->imap-flag flag) - (cond ((string-ci=? flag "answered") '\ANSWERED) - ((string-ci=? flag "deleted") '\DELETED) - ((string-ci=? flag "seen") '\SEEN) - (else (intern flag)))) - (define (reset-imap-folder! folder) (without-interrupts (lambda () @@ -326,8 +263,8 @@ (define (set-imap-folder-length! folder count) (let ((v (imap-folder-messages folder))) (let ((v* (vector-grow v count #f))) - (fill-messages-vector folder v* (vector-length v)) - (set-imap-folder-messages! folder v*))) + (set-imap-folder-messages! folder v*) + (fill-messages-vector folder v* (vector-length v)))) (folder-modified! folder)) (define (forget-imap-folder-messages! folder) @@ -337,21 +274,16 @@ (folder-modified! folder)) (define (fill-messages-vector folder messages start) - (let ((connection (imap-folder-connection folder)) - (end (vector-length messages))) - (do ((responses - ((imail-message-wrapper "Reading message outlines") - (lambda () - (imap:command:fetch-range connection 0 end - '(UID FLAGS RFC822.SIZE - RFC822.HEADER)))) - (cdr responses)) - (index start (fix:+ index 1))) + (let ((end (vector-length messages))) + (do ((index start (fix:+ index 1))) ((fix:= index end)) - (let ((message (apply make-imap-message (car responses)))) - (set-message-folder! message folder) - (set-message-index! message index) - (vector-set! messages index message))))) + (vector-set! messages index (make-imap-message folder index))) + ((imail-message-wrapper "Reading message headers") + (lambda () + ;; Ignore the value of this command, as the results are + ;; transparently stored in the messages. + (imap:command:fetch-range (imap-folder-connection folder) start end + '(UID FLAGS RFC822.SIZE RFC822.HEADER)))))) (define (remove-imap-folder-message folder index) (let ((v (imap-folder-messages folder))) @@ -363,6 +295,51 @@ (set-imap-folder-messages! folder v*)))) (folder-modified! folder)) +;;;; Message datatype + +(define-class ( (constructor (folder index))) () + (properties initial-value '()) + (uid define standard) + (length define standard)) + +(define %set-message-header-fields! (slot-modifier 'HEADER-FIELDS)) +(define %set-message-body! (slot-modifier 'BODY)) +(define %message-body-initialized? (slot-initpred 'BODY)) +(define %set-message-flags! (slot-modifier 'FLAGS)) + +(define-method message-body ((message )) + (if (not (%message-body-initialized? message)) + (let ((index (message-index message))) + ((imail-message-wrapper "Reading body for message " + (number->string (+ index 1))) + (lambda () + ;; Ignore the value of this command, as the result is + ;; transparently stored in the message. + (imap:command:fetch (imap-folder-connection + (message-folder message)) + index + '(RFC822.TEXT)))))) + (call-next-method message)) + +(define-method set-message-flags! ((message ) flags) + (imap:command:store-flags (imap-folder-connection (message-folder message)) + (message-index message) + (map imail-flag->imap-flag + (flags-delete "\\recent" flags)))) + +(define (imap-flag->imail-flag flag) + (case flag + ((\ANSWERED) "answered") + ((\DELETED) "deleted") + ((\SEEN) "seen") + (else (symbol->string flag)))) + +(define (imail-flag->imap-flag flag) + (cond ((string-ci=? flag "answered") '\ANSWERED) + ((string-ci=? flag "deleted") '\DELETED) + ((string-ci=? flag "seen") '\SEEN) + (else (intern flag)))) + ;;;; Server operations (define-method %new-folder ((url )) @@ -469,32 +446,23 @@ (imap:command:no-response connection 'SELECT mailbox))))) (define (imap:command:fetch connection index items) - (let ((response - (imap:command:single-response imap:response:fetch? - connection 'FETCH (+ index 1) items))) - (map (lambda (item) - (imap:response:fetch-attribute response item)) - items))) + (imap:command:single-response imap:response:fetch? + connection 'FETCH (+ index 1) items)) (define (imap:command:fetch-range connection start end items) (if (fix:< start end) - (map (lambda (response) - (map (lambda (item) - (imap:response:fetch-attribute response item)) - items)) - (imap:command:multiple-response imap:response:fetch? - connection 'FETCH - (cons 'ATOM - (string-append - (number->string (+ start 1)) - ":" - (number->string end))) - items)) + (imap:command:multiple-response imap:response:fetch? + connection 'FETCH + (cons 'ATOM + (string-append + (number->string (+ start 1)) + ":" + (number->string end))) + items) '())) (define (imap:command:store-flags connection index flags) - (imap:command:single-response imap:response:fetch? - connection 'STORE index 'FLAGS flags)) + (imap:command:no-response connection 'STORE index 'FLAGS flags)) (define (imap:command:expunge connection) ((imail-message-wrapper "Expunging messages") @@ -675,7 +643,11 @@ ((imap:response:status? response) (eq? command 'STATUS)) ((imap:response:fetch? response) - (memq command '(FETCH STORE))) + (process-fetch-attributes + (get-message (selected-imap-folder connection) + (fix:- (imap:response:fetch-index response) 1)) + response) + (eq? command 'FETCH)) (else (error "Illegal server response:" response)))) @@ -731,4 +703,39 @@ (imap:response-code:trycreate? code)) unspecific) |# - )) \ No newline at end of file + )) + +(define (process-fetch-attributes message response) + (let loop + ((keywords (imap:response:fetch-attribute-keywords response)) + (any-modifications? #f)) + (if (pair? keywords) + (loop (cdr keywords) + (or (process-fetch-attribute + message + (car keywords) + (imap:response:fetch-attribute response (car keywords))) + any-modifications?)) + (if any-modifications? + (message-modified! message))))) + +(define (process-fetch-attribute message keyword datum) + (case keyword + ((FLAGS) + (%set-message-flags! message (map imap-flag->imail-flag datum)) + #t) + ((RFC822.HEADER) + (%set-message-header-fields! + message + (lines->header-fields (network-string->lines datum))) + #t) + ((RFC822.SIZE) + (set-imap-message-length! message datum) + #t) + ((RFC822.TEXT) + (%set-message-body! message (translate-string-line-endings datum)) + #t) + ((UID) + (set-imap-message-uid! message datum) + #t) + (else #f))) \ No newline at end of file -- 2.25.1