home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / imail / imap-response.scm < prev    next >
Text File  |  2001-02-05  |  23KB  |  691 lines
  1. ;;; -*-Scheme-*-
  2. ;;;
  3. ;;; $Id: imap-response.scm,v 1.43 2001/02/05 18:36:08 cph Exp $
  4. ;;;
  5. ;;; Copyright (c) 2000-2001 Massachusetts Institute of Technology
  6. ;;;
  7. ;;; This program is free software; you can redistribute it and/or
  8. ;;; modify it under the terms of the GNU General Public License as
  9. ;;; published by the Free Software Foundation; either version 2 of the
  10. ;;; License, or (at your option) any later version.
  11. ;;;
  12. ;;; This program is distributed in the hope that it will be useful,
  13. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. ;;; General Public License for more details.
  16. ;;;
  17. ;;; You should have received a copy of the GNU General Public License
  18. ;;; along with this program; if not, write to the Free Software
  19. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21. ;;;; IMAP Server Response Reader
  22.  
  23. (declare (usual-integrations))
  24.  
  25. (define (imap:read-server-response port)
  26.   (let ((tag (read-string-internal char-set:space port)))
  27.     (if (eof-object? tag)
  28.     tag
  29.     (let ((response
  30.            (if (string=? "+" tag)
  31.            (cons 'CONTINUE (read-response-text port))
  32.            (begin
  33.              (discard-known-char #\space port)
  34.              (cond ((string=? "*" tag)
  35.                 (read-untagged-response port))
  36.                ((let ((end (string-length tag)))
  37.                   (let ((index (imap:match:tag tag 0 end)))
  38.                 (and index
  39.                      (fix:= index end))))
  40.                 (read-tagged-response tag port))
  41.                (else
  42.                 (error "Malformed server response:" tag)))))))
  43.       (discard-known-char #\return port)
  44.       (discard-known-char #\linefeed port)
  45.       response))))
  46.  
  47. (define (read-untagged-response port)
  48.   (let ((x (read-atom port)))
  49.     (if (atom-is-number? x)
  50.     (let ((n (string->number x)))
  51.       (discard-known-char #\space port)
  52.       (let ((x (read-interned-atom port)))
  53.         (cons* x
  54.            n
  55.            (case x
  56.              ((EXISTS RECENT EXPUNGE) '())
  57.              ((FETCH) (read-fetch-response port))
  58.              (else (error "Malformed response code:" x))))))
  59.     (let ((x (intern x)))
  60.       (cons x
  61.         (case x
  62.           ((OK NO BAD) (cons #f (read-response-text port)))
  63.           ((PREAUTH BYE) (read-response-text port))
  64.           ((FLAGS) (read-flags-response port))
  65.           ((LIST LSUB) (read-list-response port))
  66.           ((SEARCH) (read-search-response port))
  67.           ((STATUS) (read-status-response port))
  68.           ((CAPABILITY) (read-capability-response port))
  69.           ((NAMESPACE) (read-namespace-response port))
  70.           (else (error "Malformed response code:" x))))))))
  71.  
  72. (define (read-tagged-response tag port)
  73.   (let ((x (read-interned-atom port)))
  74.     (if (memq x '(OK NO BAD))
  75.     (cons* x tag (read-response-text port))
  76.     (error "Malformed response code:" x))))
  77.  
  78. (define (read-flags-response port)
  79.   (discard-known-char #\space port)
  80.   (read-list port read-flag))
  81.  
  82. (define (read-list-response port)
  83.   (discard-known-char #\space port)
  84.   (let ((flags (read-list port read-flag)))
  85.     (discard-known-char #\space port)
  86.     (let ((delim (read-nstring port)))
  87.       (discard-known-char #\space port)
  88.       (cons* delim (read-astring port) flags))))
  89.  
  90. (define (read-search-response port)
  91.   (read-open-list port read-nz-number))
  92.  
  93. (define (read-status-response port)
  94.   (discard-known-char #\space port)
  95.   (let ((mailbox (read-astring port)))
  96.     (discard-known-char #\space port)
  97.     (list mailbox
  98.       (read-list port
  99.              (lambda (port)
  100.                (let ((name (read-interned-atom port)))
  101.              (discard-known-char #\space port)
  102.              (cons name (read-number port))))))))
  103.  
  104. (define (read-capability-response port)
  105.   (read-open-list port read-interned-atom))
  106.  
  107. (define (read-namespace-response port)
  108.   (discard-known-char #\space port)
  109.   (let ((ns1 (read-generic port)))
  110.     (discard-known-char #\space port)
  111.     (let ((ns2 (read-generic port)))
  112.       (discard-known-char #\space port)
  113.       (list ns1 ns2 (read-generic port)))))
  114.  
  115. (define (read-response-text port)
  116.   (discard-known-char #\space port)
  117.   (let ((code
  118.      (and (char=? #\[ (peek-char-no-eof port))
  119.           (read-response-text-code port))))
  120.     (list code
  121.       (if (char=? #\= (peek-char port))
  122.           (read-mime2-text port)
  123.           (read-text port)))))
  124.  
  125. (define (read-response-text-code port)
  126.   (discard-known-char #\[ port)
  127.   (let ((code
  128.      (let ((x (intern (read-resp-text-atom port))))
  129.        (cons x
  130.          (case x
  131.            ((ALERT PARSE READ-ONLY READ-WRITE TRYCREATE)
  132.             '())
  133.            ((BADCHARSET)
  134.             (if (char=? #\space (peek-char-no-eof port))
  135.             (begin
  136.               (discard-char port)
  137.               (read-list port read-astring))
  138.             '()))
  139.            ((NEWNAME)
  140.             (discard-known-char #\space port)
  141.             (let ((old (read-xstring port)))
  142.               (discard-known-char #\space port)
  143.               (list old (read-xstring port))))
  144.            ((UIDNEXT UIDVALIDITY UNSEEN)
  145.             (discard-known-char #\space port)
  146.             (list (read-nz-number port)))
  147.            ((PERMANENTFLAGS)
  148.             (discard-known-char #\space port)
  149.             (read-list port read-pflag))
  150.            ((APPENDUID)
  151.             (discard-known-char #\space port)
  152.             (let ((uidvalidity (read-nz-number port)))
  153.               (discard-known-char #\space port)
  154.               (list uidvalidity (read-nz-number port))))
  155.            ((COPYUID)
  156.             (discard-known-char #\space port)
  157.             (let ((uidvalidity (read-nz-number port)))
  158.               (discard-known-char #\space port)
  159.               (let ((from-uids (read-set port)))
  160.             (discard-known-char #\space port)
  161.             (list uidvalidity from-uids (read-set port)))))
  162.            (else
  163.             (if (char=? #\space (peek-char-no-eof port))
  164.             (begin
  165.               (discard-char port)
  166.               (list (read-resp-text-tail port)))
  167.             '())))))))
  168.     (discard-known-char #\] port)
  169.     ;; Work around a bug in Courier-IMAP; the #\space character is
  170.     ;; required here, but Courier-IMAP doesn't send it.
  171.     (if (not (char=? #\return (peek-char-no-eof port)))
  172.     (discard-known-char #\space port))
  173.     code))
  174.  
  175. (define (read-fetch-response port)
  176.   (discard-known-char #\space port)
  177.   (read-list port
  178.     (lambda (port)
  179.       (let ((x (intern (read-fetch-keyword port))))
  180.     (if (and (eq? 'BODY x)
  181.          (char=? #\[ (peek-char-no-eof port)))
  182.         (let ((section
  183.            (parse-section (read-bracketed-string port))))
  184.           (discard-known-char #\space port)
  185.           (let ((origin
  186.               (and (char=? #\< (peek-char-no-eof port))
  187.                (begin
  188.                  (discard-char port)
  189.                  (let ((n (read-number port)))
  190.                    (discard-known-char #\> port)
  191.                    (discard-known-char #\space port)
  192.                    n)))))
  193.         (list x section origin
  194.               (if *fetch-body-part-port*
  195.               (read-nstring-to-port port *fetch-body-part-port*)
  196.               (read-nstring port)))))
  197.         (begin
  198.           (discard-known-char #\space port)
  199.           (list x
  200.             (case x
  201.               ((ENVELOPE BODY BODYSTRUCTURE)
  202.                (read-generic port))
  203.               ((FLAGS)
  204.                (read-list port read-flag))
  205.               ((INTERNALDATE)
  206.                (parse-date-time (read-quoted port)))
  207.               ((RFC822 RFC822.HEADER RFC822.TEXT)
  208.                (read-nstring port))
  209.               ((RFC822.SIZE)
  210.                (read-number port))
  211.               ((UID)
  212.                (read-nz-number port))
  213.               (else
  214.                (error "Illegal fetch keyword:" x))))))))))
  215.  
  216. (define (imap:bind-fetch-body-part-port port thunk)
  217.   (fluid-let ((*fetch-body-part-port* port))
  218.     (thunk)))
  219.  
  220. (define *fetch-body-part-port* #f)
  221.  
  222. (define (parse-section string)
  223.   (let ((pv (parse-string imap:parse:section string)))
  224.     (if (not pv)
  225.     (error:bad-range-argument string 'PARSE-SECTION))
  226.     (parser-token pv 'SECTION)))
  227.  
  228. (define (parse-date-time string)
  229.   (decoded-time->universal-time
  230.    (make-decoded-time
  231.     (string->number (substring string 18 20))
  232.     (string->number (substring string 15 17))
  233.     (string->number (substring string 12 14))
  234.     (string->number (string-trim-left (substring string 0 2)))
  235.     (string->month (substring string 3 6))
  236.     (string->number (substring string 7 11))
  237.     (string->time-zone (string-tail string 21)))))
  238.  
  239. (define (read-generic port)
  240.   (let ((char (peek-char-no-eof port)))
  241.     (cond ((char=? #\" char) (read-quoted port))
  242.       ((char=? #\{ char) (read-literal port))
  243.       ((char=? #\( char) (read-list port read-generic))
  244.       ((imap:atom-char? char)
  245.        (let ((atom (read-atom port)))
  246.          (cond ((atom-is-number? atom) (string->number atom))
  247.            ((string-ci=? "NIL" atom) #f)
  248.            (else (intern atom)))))
  249.       (else (error "Illegal IMAP syntax:" char)))))
  250.  
  251. (define (read-astring port)
  252.   (let ((char (peek-char-no-eof port)))
  253.     (cond ((char=? #\" char) (read-quoted port))
  254.       ((char=? #\{ char) (read-literal port))
  255.       ((imap:atom-char? char) (read-atom port))
  256.       (else (error "Illegal astring syntax:" char)))))
  257.  
  258. (define (read-xstring port)
  259.   (let ((char (peek-char-no-eof port)))
  260.     (cond ((char=? #\" char) (read-quoted port))
  261.       ((char=? #\{ char) (read-literal port))
  262.       (else (error "Illegal astring syntax:" char)))))
  263.  
  264. (define (read-nstring input)
  265.   (let ((output (make-accumulator-output-port)))
  266.     (and (read-nstring-to-port input output)
  267.      (get-output-from-accumulator output))))
  268.  
  269. (define (read-nstring-to-port input output)
  270.   (let ((char (peek-char-no-eof input)))
  271.     (cond ((char=? #\" char)
  272.        (read-quoted-to-port input output)
  273.        "")
  274.       ((char=? #\{ char)
  275.        (read-literal-to-port input output)
  276.        "")
  277.       ((imap:atom-char? char)
  278.        (let ((atom (read-atom input)))
  279.          (if (string-ci=? "NIL" atom)
  280.          #f
  281.          (error "Illegal nstring:" atom))))
  282.       (else (error "Illegal astring syntax:" char)))))
  283.  
  284. (define (read-quoted input)
  285.   (with-string-output-port
  286.     (lambda (output)
  287.       (read-quoted-to-port input output))))
  288.  
  289. (define (read-quoted-to-port input output)
  290.   (discard-known-char #\" input)
  291.   (let ((lose (lambda () (error "Malformed quoted string."))))
  292.     (let loop ()
  293.       (let ((char (read-char-no-eof input)))
  294.     (cond ((imap:quoted-char? char)
  295.            (write-char char output)
  296.            (loop))
  297.           ((char=? #\\ char)
  298.            (let ((char (read-char-no-eof char)))
  299.          (if (imap:quoted-special? char)
  300.              (begin
  301.                (write-char char output)
  302.                (loop))
  303.              (lose))))
  304.           ((not (char=? #\" char))
  305.            (lose)))))))
  306.  
  307. (define (read-literal input)
  308.   (with-string-output-port
  309.     (lambda (output)
  310.       (read-literal-to-port input output))))
  311.  
  312. (define (read-literal-to-port input output)
  313.   (discard-known-char #\{ input)
  314.   (let ((n (read-number input))
  315.     (progress-hook *read-literal-progress-hook*))
  316.     (discard-known-char #\} input)
  317.     (discard-known-char #\return input)
  318.     (discard-known-char #\linefeed input)
  319.     (let loop ((i 0))
  320.       (if (fix:< i n)
  321.       (let ((i (fix:+ i 1))
  322.         (char (read-char-no-eof input)))
  323.         (if (and (char=? char #\return)
  324.              (fix:< i n)
  325.              (char=? (peek-char-no-eof input) #\linefeed))
  326.         (begin
  327.           (discard-char input)
  328.           (newline output)
  329.           (if (and progress-hook
  330.                (or (fix:= (fix:remainder i 4096) 0)
  331.                    (fix:= (fix:remainder i 4096) 4095)))
  332.               (progress-hook i n))
  333.           (loop (fix:+ i 1)))
  334.         (begin
  335.           (write-char char output)
  336.           (if (and progress-hook
  337.                (fix:= (fix:remainder i 4096) 0))
  338.               (progress-hook i n))
  339.           (loop i))))))))
  340.  
  341. (define (imap:read-literal-progress-hook procedure thunk)
  342.   (fluid-let ((*read-literal-progress-hook* procedure))
  343.     (thunk)))
  344.  
  345. (define *read-literal-progress-hook* #f)
  346.  
  347. (define (read-list port read-item)
  348.   (read-closed-list #\( #\) port read-item))
  349.  
  350. (define (read-closed-list open close port read-item)
  351.   (discard-known-char open port)
  352.   (if (char=? close (peek-char-no-eof port))
  353.       (begin
  354.     (discard-char port)
  355.     '())
  356.       (let loop ((items (list (read-item port))))
  357.     (let ((char (peek-char-no-eof port)))
  358.       (cond ((char=? char #\space)
  359.          (discard-char port)
  360.          (loop (cons (read-item port) items)))
  361.         ((char=? char #\()
  362.          (loop (cons (read-item port) items)))
  363.         ((char=? char close)
  364.          (discard-char port)
  365.          (reverse! items))
  366.         (else
  367.          (error "Illegal list delimiter:" char)))))))
  368.  
  369. (define (read-open-list port read-item)
  370.   (let loop ((items '()))
  371.     (let ((char (peek-char-no-eof port)))
  372.       (cond ((char=? char #\space)
  373.          (discard-char port)
  374.          (loop (cons (read-item port) items)))
  375.         ((char=? char #\return)
  376.          (reverse! items))
  377.         (else
  378.          (error "Illegal list delimiter:" char))))))
  379.  
  380. (define (read-bracketed-string port)
  381.   (discard-known-char #\[ port)
  382.   (let ((s (read-string-internal char-set:close-bracket port)))
  383.     (discard-known-char #\] port)
  384.     s))
  385.  
  386. (define (read-pflag port)
  387.   (intern
  388.    (if (char=? #\\ (peek-char-no-eof port))
  389.        (begin
  390.      (discard-char port)
  391.      (if (char=? #\* (peek-char-no-eof port))
  392.          (begin
  393.            (discard-char port)
  394.            "\\*")
  395.          (string-append "\\" (read-atom port))))
  396.        (read-atom port))))
  397.  
  398. (define (read-flag port)
  399.   (intern
  400.    (if (char=? #\\ (peek-char-no-eof port))
  401.        (begin
  402.      (discard-char port)
  403.      (string-append "\\" (read-atom port)))
  404.        (read-atom port))))
  405.  
  406. (define (string-reader constituents)
  407.   (let ((delimiters (char-set-invert constituents)))
  408.     (lambda (port)
  409.       (read-string-internal delimiters port))))
  410.  
  411. (define (non-null-string-reader constituents)
  412.   (let ((reader (string-reader constituents)))
  413.     (lambda (port)
  414.       (let ((s (reader port)))
  415.     (if (string-null? s)
  416.         (error "Empty string.")
  417.         s)))))
  418.  
  419. (define read-number
  420.   (let ((reader (non-null-string-reader char-set:numeric)))
  421.     (lambda (port)
  422.       (string->number (reader port)))))
  423.  
  424. (define (read-nz-number port)
  425.   (let ((n (read-number port)))
  426.     (if (> n 0)
  427.     n
  428.     (error "Zero not allowed here."))))
  429.  
  430. (define read-tag
  431.   (non-null-string-reader imap:char-set:tag-char))
  432.  
  433. (define read-atom
  434.   (non-null-string-reader imap:char-set:atom-char))
  435.  
  436. (define read-resp-text-atom
  437.   (non-null-string-reader
  438.    (char-set-difference imap:char-set:atom-char (char-set #\]))))
  439.  
  440. (define read-text
  441.   ;; This is supposed to be non-null, but Cyrus sometimes sends null.
  442.   (string-reader imap:char-set:text-char))
  443.  
  444. (define read-resp-text-tail
  445.   ;; This is also supposed to be non-null.
  446.   (string-reader
  447.    (char-set-difference imap:char-set:text-char (char-set #\]))))
  448.  
  449. (define read-fetch-keyword
  450.   (non-null-string-reader
  451.    (char-set-union char-set:alphanumeric (char-set #\.))))
  452.  
  453. (define (read-interned-atom port)
  454.   (intern (read-atom port)))
  455.  
  456. (define (read-mime2-text port)
  457.   (discard-known-char #\= port)
  458.   (discard-known-char #\? port)
  459.   (let ((charset (read-mime2-token port)))
  460.     (discard-known-char #\? port)
  461.     (let ((encoding (read-mime2-token port)))
  462.       (discard-known-char #\? port)
  463.       (let ((encoded-text (read-mime2-encoded-text port)))
  464.     (discard-known-char #\? port)
  465.     (discard-known-char #\= port)
  466.     (list charset encoding encoded-text)))))
  467.  
  468. (define read-mime2-token
  469.   (non-null-string-reader
  470.    (char-set-difference char-set:graphic
  471.             (string->char-set " ()<>@,;:\"/[]?.="))))
  472.  
  473. (define read-mime2-encoded-text
  474.   (non-null-string-reader
  475.    (char-set-difference char-set:graphic
  476.             (string->char-set " ?"))))
  477.  
  478. (define (atom-is-number? atom)
  479.   (not (string-find-next-char-in-set atom char-set:not-numeric)))
  480.  
  481. (define read-set
  482.   (let ((read-string
  483.      (non-null-string-reader
  484.       (char-set-union char-set:numeric (char-set #\: #\, #\*)))))
  485.     (lambda (port)
  486.       (let ((string (read-string port)))
  487.     (let ((lose
  488.            (lambda () (error "Malformed message-number set:" string))))
  489.       (map (lambda (token)
  490.          (let ((length (string-length token))
  491.                (seqnum
  492.             (lambda (start end)
  493.               (if (substring=? token start end "*" 0 1)
  494.                   '*
  495.                   (or (substring->number token start end)
  496.                   (lose))))))
  497.            (cond ((fix:= length 0) (lose))
  498.              ((substring-find-next-char token 0 length #\:)
  499.               => (lambda (index)
  500.                    (cons (seqnum 0 index)
  501.                      (seqnum (fix:+ index 1) length))))
  502.              (else (seqnum 0 length)))))
  503.            (burst-string string #\, #f)))))))
  504.  
  505. (define char-set:space
  506.   (char-set #\space))
  507.  
  508. (define char-set:close-bracket
  509.   (char-set #\]))
  510.  
  511. (define (read-char-no-eof port)
  512.   (let ((char (read-char-internal port)))
  513.     (if (eof-object? char)
  514.     (error "Unexpected end of file:" port))
  515.     char))
  516.  
  517. (define (peek-char-no-eof port)
  518.   (let ((char (peek-char port)))
  519.     (if (eof-object? char)
  520.     (error "Unexpected end of file:" port))
  521.     char))
  522.  
  523. (define (discard-char port)
  524.   (read-char-internal port)
  525.   unspecific)
  526.  
  527. (define (discard-known-char char port)
  528.   (let ((char* (read-char-no-eof port)))
  529.     (if (not (char=? char char*))
  530.     (error "Wrong character read:" char* char))))
  531.  
  532. (define (read-char-internal port)
  533.   (let ((char (read-char port)))
  534.     (if imap-transcript-port
  535.     (write-char char imap-transcript-port))
  536.     char))
  537.  
  538. (define (read-string-internal delimiters port)
  539.   (let ((s (read-string delimiters port)))
  540.     (if imap-transcript-port
  541.     (write-string s imap-transcript-port))
  542.     s))
  543.  
  544. (define (read-substring!-internal string start end port)
  545.   (let ((n-read (read-substring! string start end port)))
  546.     (if imap-transcript-port
  547.     (write-substring string start (fix:+ start n-read)
  548.              imap-transcript-port))
  549.     n-read))
  550.  
  551. (define (start-imap-transcript pathname)
  552.   (set! imap-transcript-port (open-output-file pathname))
  553.   unspecific)
  554.  
  555. (define (stop-imap-transcript)
  556.   (if imap-transcript-port
  557.       (begin
  558.     (close-port imap-transcript-port)
  559.     (set! imap-transcript-port #f)
  560.     unspecific)))
  561.  
  562. (define (imap-transcript-write-char char port)
  563.   (write-char char port)
  564.   (if imap-transcript-port
  565.       (write-char char imap-transcript-port)))
  566.  
  567. (define (imap-transcript-write-substring string start end port)
  568.   (write-substring string start end port)
  569.   (if imap-transcript-port
  570.       (write-substring string start end imap-transcript-port)))
  571.  
  572. (define (imap-transcript-write-string string port)
  573.   (write-string string port)
  574.   (if imap-transcript-port
  575.       (write-string string imap-transcript-port)))
  576.  
  577. (define (imap-transcript-write object port)
  578.   (write object port)
  579.   (if imap-transcript-port
  580.       (write object imap-transcript-port)))
  581.  
  582. (define (imap-transcript-flush-output port)
  583.   (flush-output port)
  584.   (if imap-transcript-port
  585.       (flush-output imap-transcript-port)))
  586.  
  587. (define imap-transcript-port #f)
  588.  
  589. (define (imap:response:bad? response) (eq? (car response) 'BAD))
  590. (define (imap:response:bye? response) (eq? (car response) 'BYE))
  591. (define (imap:response:capability? response) (eq? (car response) 'CAPABILITY))
  592. (define (imap:response:continue? response) (eq? (car response) 'CONTINUE))
  593. (define (imap:response:exists? response) (eq? (car response) 'EXISTS))
  594. (define (imap:response:expunge? response) (eq? (car response) 'EXPUNGE))
  595. (define (imap:response:fetch? response) (eq? (car response) 'FETCH))
  596. (define (imap:response:flags? response) (eq? (car response) 'FLAGS))
  597. (define (imap:response:list? response) (eq? (car response) 'LIST))
  598. (define (imap:response:lsub? response) (eq? (car response) 'LSUB))
  599. (define (imap:response:namespace? response) (eq? (car response) 'NAMESPACE))
  600. (define (imap:response:no? response) (eq? (car response) 'NO))
  601. (define (imap:response:ok? response) (eq? (car response) 'OK))
  602. (define (imap:response:preauth? response) (eq? (car response) 'PREAUTH))
  603. (define (imap:response:recent? response) (eq? (car response) 'RECENT))
  604. (define (imap:response:search? response) (eq? (car response) 'SEARCH))
  605. (define (imap:response:status? response) (eq? (car response) 'STATUS))
  606.  
  607. (define imap:response:capabilities cdr)
  608. (define imap:response:exists-count cadr)
  609. (define imap:response:expunge-index cadr)
  610. (define imap:response:fetch-index cadr)
  611. (define imap:response:flags cdr)
  612. (define imap:response:list-delimiter cadr)
  613. (define imap:response:list-mailbox caddr)
  614. (define imap:response:list-flags cdddr)
  615. (define imap:response:namespace-personal cadr)
  616. (define imap:response:namespace-other caddr)
  617. (define imap:response:namespace-shared cadddr)
  618. (define imap:response:recent-count cadr)
  619. (define imap:response:search-indices cdr)
  620.  
  621. (define (imap:response:tag response)
  622.   (and (memq (car response) '(OK NO BAD))
  623.        (cadr response)))
  624.  
  625. (define (imap:response:status-response? response)
  626.   (memq (car response) '(OK NO BAD PREAUTH BYE)))
  627.  
  628. (define (imap:response:response-text-code response)
  629.   (car (imap:response:response-text response)))
  630.  
  631. (define (imap:response:response-text-string response)
  632.   (cadr (imap:response:response-text response)))
  633.  
  634. (define (imap:response:response-text response)
  635.   (case (car response)
  636.     ((BAD NO OK) (cddr response))
  637.     ((PREAUTH BYE) (cdr response))
  638.     (else (error:bad-range-argument response 'IMAP:RESPONSE:RESPONSE-TEXT))))
  639.  
  640. (define (imap:response:fetch-attribute-keywords response)
  641.   (map car (cddr response)))
  642.  
  643. (define (imap:response:fetch-attribute response keyword)
  644.   (let ((entry (assq keyword (cddr response))))
  645.     (if (not entry)
  646.     (error "Missing FETCH attribute:" keyword))
  647.     (cadr entry)))
  648.  
  649. (define (imap:response:fetch-body-part response section offset)
  650.   (let ((entry
  651.      (list-search-positive (cddr response)
  652.        (lambda (entry)
  653.          (and (eq? (car entry) 'BODY)
  654.           (equal? (cadr entry) section)
  655.           (pair? (cddr entry))
  656.           (eqv? offset (caddr entry))
  657.           (pair? (cdddr entry))
  658.           (or (not (cadddr entry))
  659.               (string? (cadddr entry)))
  660.           (null? (cddddr entry)))))))
  661.     (if (not entry)
  662.     (error "Missing FETCH body part:" section offset))
  663.     (cadddr entry)))
  664.  
  665. (define (imap:response-code:alert? code) (eq? (car code) 'ALERT))
  666. (define (imap:response-code:appenduid? code) (eq? (car code) 'APPENDUID))
  667. (define (imap:response-code:badcharset? code) (eq? (car code) 'BADCHARSET))
  668. (define (imap:response-code:copyuid? code) (eq? (car code) 'COPYUID))
  669. (define (imap:response-code:newname? code) (eq? (car code) 'NEWNAME))
  670. (define (imap:response-code:parse? code) (eq? (car code) 'PARSE))
  671. (define (imap:response-code:read-only? code) (eq? (car code) 'READ-ONLY))
  672. (define (imap:response-code:read-write? code) (eq? (car code) 'READ-WRITE))
  673. (define (imap:response-code:trycreate? code) (eq? (car code) 'TRYCREATE))
  674. (define (imap:response-code:uidnext? code) (eq? (car code) 'UIDNEXT))
  675. (define (imap:response-code:uidvalidity? code) (eq? (car code) 'UIDVALIDITY))
  676. (define (imap:response-code:unseen? code) (eq? (car code) 'UNSEEN))
  677.  
  678. (define (imap:response-code:permanentflags? code)
  679.   (eq? (car code) 'PERMANENTFLAGS))
  680.  
  681. (define imap:response-code:appenduid-uidvalidity cadr)
  682. (define imap:response-code:appenduid-uid caddr)
  683. (define imap:response-code:copyuid-uidvalidity cadr)
  684. (define imap:response-code:copyuid-old-uids caddr)
  685. (define imap:response-code:copyuid-new-uids cadddr)
  686. (define imap:response-code:newname-old cadr)
  687. (define imap:response-code:newname-new caddr)
  688. (define imap:response-code:permanentflags cdr)
  689. (define imap:response-code:uidnext cadr)
  690. (define imap:response-code:uidvalidity cadr)
  691. (define imap:response-code:unseen cadr)