suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

IMAP: generate shorter message lists

Browse Source 
svn: r6750
This commit is contained in:
Matthew Flatt 2007-06-27 21:54:22 +00:00
parent 30ec6ccdd1
commit c8b406bc79
1 changed files with 22 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
collects/net/imap-unit.ss
View File

@ -383,6 +383,25 @@
(unless (tree-empty? (imap-expunges imap)) (unless (tree-empty? (imap-expunges imap))
(raise-mismatch-error who "session has pending expunge reports: " imap))) (raise-mismatch-error who "session has pending expunge reports: " imap)))
(define (msg-set msgs)
(apply
string-append
(let loop ([prev #f][msgs msgs])
(cond
[(null? msgs) null]
[(and prev
(pair? (cdr msgs))
(= (add1 prev) (car msgs)))
(loop (car msgs) (cdr msgs))]
[prev (cons (format ":~a," prev)
(loop #f msgs))]
[(null? (cdr msgs)) (list (format "~a" (car msgs)))]
[(= (add1 (car msgs)) (cadr msgs))
(cons (format "~a" (car msgs))
(loop (car msgs) (cdr msgs)))]
[else (cons (format "~a," (car msgs))
(loop #f (cdr msgs)))]))))
(define (imap-get-messages imap msgs field-list) (define (imap-get-messages imap msgs field-list)
(no-expunges 'imap-get-messages imap) (no-expunges 'imap-get-messages imap)
(when (or (not (list? msgs)) (when (or (not (list? msgs))
@ -399,7 +418,7 @@
;; FETCH request adds info to `(imap-fectches imap)': ;; FETCH request adds info to `(imap-fectches imap)':
(imap-send imap (imap-send imap
(list "FETCH" (list "FETCH"
(box (splice msgs ",")) (box (msg-set msgs))
(box (box
(format "(~a)" (format "(~a)"
(splice (map (lambda (f) (splice (map (lambda (f)
@ -434,7 +453,7 @@
(check-ok (check-ok
(imap-send imap (imap-send imap
(list "STORE" (list "STORE"
(box (splice msgs ",")) (box (msg-set msgs))
(case mode (case mode
[(+) "+FLAGS.SILENT"] [(+) "+FLAGS.SILENT"]
[(-) "-FLAGS.SILENT"] [(-) "-FLAGS.SILENT"]
@ -447,7 +466,7 @@
(define (imap-copy imap msgs dest-mailbox) (define (imap-copy imap msgs dest-mailbox)
(no-expunges 'imap-copy imap) (no-expunges 'imap-copy imap)
(check-ok (check-ok
(imap-send imap (list "COPY" (box (splice msgs ",")) dest-mailbox) (imap-send imap (list "COPY" (box (msg-set msgs)) dest-mailbox)
void))) void)))
(define (imap-append imap dest-mailbox msg) (define (imap-append imap dest-mailbox msg)