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-syntax.scm < prev    next >
Text File  |  2000-07-04  |  20KB  |  628 lines
  1. ;;; -*-Scheme-*-
  2. ;;;
  3. ;;; $Id: imap-syntax.scm,v 1.16 2000/07/05 03:25:35 cph Exp $
  4. ;;;
  5. ;;; Copyright (c) 2000 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 Syntax
  22.  
  23. (declare (usual-integrations))
  24.  
  25. (define imap:char-set:achar
  26.   (char-set-union url:char-set:unreserved (string->char-set "&=~")))
  27.  
  28. (define imap:match:achar+
  29.   (rexp-matcher
  30.    (rexp+ (rexp-alternatives imap:char-set:achar url:rexp:escape))))
  31.  
  32. (define imap:match:bchar+
  33.   (rexp-matcher
  34.    (rexp+ (rexp-alternatives (char-set-union imap:char-set:achar
  35.                          (string->char-set ":@/"))
  36.                  url:rexp:escape))))
  37.  
  38. (define imap:char-set:quoted-specials
  39.   (char-set #\" #\\))
  40.  
  41. (define (imap:quoted-special? char)
  42.   (char-set-member? imap:char-set:quoted-specials char))
  43.  
  44. (define imap:char-set:list-wildcards
  45.   (char-set #\% #\*))
  46.  
  47. (define imap:char-set:char
  48.   (ascii-range->char-set #x01 #x80))
  49.  
  50. (define imap:char-set:ctl
  51.   (char-set-union (ascii-range->char-set #x00 #x20)
  52.           (char-set #\rubout)))
  53.  
  54. (define imap:char-set:atom-char
  55.   (char-set-difference imap:char-set:char
  56.                (char-set-union (char-set #\( #\) #\{ #\space)
  57.                        imap:char-set:ctl
  58.                        imap:char-set:list-wildcards
  59.                        imap:char-set:quoted-specials)))
  60.  
  61. (define (imap:atom-char? char)
  62.   (char-set-member? imap:char-set:atom-char char))
  63.  
  64. (define imap:char-set:text-char
  65.   (char-set-difference imap:char-set:char
  66.                (char-set #\return #\linefeed)))
  67.  
  68. (define imap:char-set:not-text-char
  69.   (char-set-invert imap:char-set:text-char))
  70.  
  71. (define (imap:string-may-be-quoted? string)
  72.   (not (string-find-next-char-in-set string imap:char-set:not-text-char)))
  73.  
  74. (define imap:char-set:quoted-char
  75.   (char-set-difference imap:char-set:text-char
  76.                imap:char-set:quoted-specials))
  77.  
  78. (define (imap:quoted-char? char)
  79.   (char-set-member? imap:char-set:quoted-char char))
  80.  
  81. (define imap:char-set:base64
  82.   (char-set-union char-set:alphanumeric
  83.           (char-set #\+ #\/)))
  84.  
  85. (define imap:char-set:tag-char
  86.   (char-set-difference imap:char-set:atom-char
  87.                (char-set #\+)))
  88.  
  89. (define imap:match:atom
  90.   (rexp-matcher (rexp+ imap:char-set:atom-char)))
  91.  
  92. (define imap:match:text
  93.   (rexp-matcher (rexp+ imap:char-set:text-char)))
  94.  
  95. (define imap:match:tag
  96.   (rexp-matcher (rexp+ imap:char-set:tag-char)))
  97.  
  98. (define imap:match:base64
  99.   (rexp-matcher
  100.    (rexp-sequence
  101.     (rexp* imap:char-set:base64
  102.        imap:char-set:base64
  103.        imap:char-set:base64
  104.        imap:char-set:base64)
  105.     (rexp-optional
  106.      (rexp-alternatives
  107.       (rexp-sequence imap:char-set:base64
  108.              imap:char-set:base64
  109.              "==")
  110.       (rexp-sequence imap:char-set:base64
  111.              imap:char-set:base64
  112.              imap:char-set:base64
  113.              "="))))))
  114.  
  115. (define imap:match:quoted-string
  116.   (rexp-matcher
  117.    (rexp-sequence "\""
  118.           (rexp* (rexp-alternatives
  119.               imap:char-set:quoted-char
  120.               (rexp-sequence "\\" imap:char-set:quoted-specials)))
  121.           "\"")))
  122.  
  123. (define (imap:match:literal string start end)
  124.   (let ((regs (re-substring-match "{\\([0-9]+\\)}\r\n" string start end)))
  125.     (and regs
  126.      (let ((index
  127.         (fix:+ (re-match-end-index 0 regs)
  128.                (substring->number string
  129.                       (re-match-start-index 1 regs)
  130.                       (re-match-end-index 1 regs)))))
  131.        (and (fix:<= index end)
  132.         index)))))
  133.  
  134. (define imap:match:string
  135.   (alternatives-matcher imap:match:quoted-string
  136.             imap:match:literal))
  137.  
  138. (define imap:match:astring
  139.   (alternatives-matcher imap:match:atom
  140.             imap:match:string))
  141.  
  142. (define imap:match:number
  143.   (rexp-matcher (rexp+ char-set:numeric)))
  144.  
  145. (define imap:match:nz-number
  146.   (rexp-matcher
  147.    (rexp-sequence (char-set-difference char-set:numeric (char-set #\0))
  148.           (rexp* char-set:numeric))))
  149.  
  150. (define imap:match:date
  151.   (let ((date-text
  152.      (rexp-matcher
  153.       (rexp-sequence
  154.        (rexp-sequence (rexp-optional (char-set #\1 #\2 #\3))
  155.               char-set:numeric)
  156.        "-"
  157.        (apply rexp-alternatives
  158.           (map rexp-case-fold
  159.                '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul"
  160.                    "Aug" "Sep" "Oct" "Nov" "Dec")))
  161.        "-"
  162.        (rexp-sequence char-set:numeric
  163.               char-set:numeric
  164.               char-set:numeric
  165.               char-set:numeric)))))
  166.     (alternatives-matcher date-text
  167.               (sequence-matcher (string-matcher "\"")
  168.                         date-text
  169.                         (string-matcher "\"")))))
  170.  
  171. (define imap:parse:section-text
  172.   (alternatives-parser
  173.    (simple-parser (alternatives-matcher
  174.            (ci-string-matcher "header")
  175.            (ci-string-matcher "text"))
  176.           'KEYWORD)
  177.    (sequence-parser
  178.     (simple-parser (sequence-matcher
  179.             (ci-string-matcher "header.fields")
  180.             (optional-matcher
  181.              (ci-string-matcher ".not")))
  182.            'KEYWORD)
  183.     (noise-parser (string-matcher " ("))
  184.     (predicated-parser (list-parser imap:match:astring
  185.                     (string-matcher " ")
  186.                     'HEADERS)
  187.                (lambda (pv) (pair? (parser-token pv 'HEADERS))))
  188.     (noise-parser (string-matcher ")")))))
  189.  
  190. (define imap:parse:section
  191.   (encapsulating-parser
  192.    (alternatives-parser
  193.     imap:parse:section-text
  194.     (sequence-parser
  195.      (list-parser imap:match:nz-number (string-matcher ".") 'NUMBER)
  196.      (optional-parser
  197.       (noise-parser (string-matcher "."))
  198.       (alternatives-parser
  199.        imap:parse:section-text
  200.        (simple-parser (ci-string-matcher "mime") 'KEYWORD)))))
  201.    (lambda (pv)
  202.      (map* (let ((keyword (parser-token pv 'KEYWORD)))
  203.          (if keyword
  204.          (cons (intern keyword)
  205.                (or (parser-token pv 'HEADERS) '()))
  206.          '()))
  207.        string->number
  208.        (or (parser-token pv 'NUMBER) '())))
  209.    'SECTION))
  210.  
  211. (define imap:match:set
  212.   (let ((range
  213.      (let ((number
  214.         (alternatives-matcher imap:match:nz-number
  215.                       (string-matcher "*"))))
  216.        (alternatives-matcher number
  217.                  (sequence-matcher number ":" number)))))
  218.     (sequence-matcher range
  219.               (*-matcher (string-matcher ",") range))))
  220.  
  221. (define imap:match:search-key
  222.   (let ((m
  223.      (lambda (keyword . arguments)
  224.        (apply sequence-matcher
  225.           (ci-string-matcher keyword)
  226.           (map (lambda (argument)
  227.              (sequence-matcher (string-matcher " ")
  228.                        argument))
  229.                arguments))))
  230.     ;; Kludge: self reference.
  231.     (imap:match:search-key
  232.      (lambda (string start end)
  233.        (imap:match:search-key string start end))))
  234.     (alternatives-matcher
  235.      (m "all")
  236.      (m "answered")
  237.      (m "bcc"        imap:match:astring)
  238.      (m "before"    imap:match:date)
  239.      (m "body"        imap:match:astring)
  240.      (m "cc"        imap:match:astring)
  241.      (m "deleted")
  242.      (m "draft")
  243.      (m "flagged")
  244.      (m "from"        imap:match:astring)
  245.      (m "header"    imap:match:astring imap:match:astring)
  246.      (m "keyword"    imap:match:atom)
  247.      (m "larger"    imap:match:number)
  248.      (m "new")
  249.      (m "not"        imap:match:search-key)
  250.      (m "old")
  251.      (m "on"        imap:match:date)
  252.      (m "or"        imap:match:search-key imap:match:search-key)
  253.      (m "recent")
  254.      (m "seen")
  255.      (m "sentbefore"    imap:match:date)
  256.      (m "senton"    imap:match:date)
  257.      (m "sentsince"    imap:match:date)
  258.      (m "since"        imap:match:date)
  259.      (m "smaller"    imap:match:number)
  260.      (m "subject"    imap:match:astring)
  261.      (m "text"        imap:match:astring)
  262.      (m "to"        imap:match:astring)
  263.      (m "uid"        imap:match:set)
  264.      (m "unanswered")
  265.      (m "undeleted")
  266.      (m "undraft")
  267.      (m "unflagged")
  268.      (m "unkeyword"    imap:match:atom)
  269.      (m "unseen")
  270.      imap:match:set
  271.      (sequence-matcher (string-matcher "(")
  272.                imap:match:search-key
  273.                (string-matcher ")")))))
  274.  
  275. (define imap:match:search-program
  276.   (sequence-matcher
  277.    (optional-matcher (ci-string-matcher "charset ")
  278.              imap:match:astring
  279.              (string-matcher " "))
  280.    imap:match:search-key))
  281.  
  282. ;;;; URL parser
  283.  
  284. (define (url:decoding-parser match-encoded keyword)
  285.   (decoding-parser match-encoded
  286.            url:decode-substring
  287.            (simple-parser (lambda (string start end)
  288.                     string start
  289.                     end)
  290.                   keyword)))
  291.  
  292. (define (imap:server-parser allow-auth?)
  293.   (sequence-parser
  294.    (optional-parser
  295.     (sequence-parser
  296.      (let ((parse-user-id (url:decoding-parser imap:match:achar+ 'USER-ID)))
  297.        (if allow-auth?
  298.        (let ((parse-auth
  299.           (sequence-parser
  300.            (noise-parser (ci-string-matcher ";auth="))
  301.            (alternatives-parser
  302.             (simple-parser (string-matcher "*") 'AUTH-TYPE)
  303.             (url:decoding-parser imap:match:achar+ 'AUTH-TYPE)))))
  304.          (alternatives-parser
  305.           (sequence-parser parse-user-id
  306.                    (optional-parser parse-auth))
  307.           (sequence-parser (optional-parser parse-user-id)
  308.                    parse-auth)))
  309.        parse-user-id))
  310.      (noise-parser (string-matcher "@"))))
  311.    (simple-parser (rexp-matcher url:rexp:host) 'HOST)
  312.    (optional-parser
  313.     (noise-parser (string-matcher ":"))
  314.     (simple-parser (rexp-matcher (rexp+ char-set:numeric)) 'PORT))))
  315.  
  316. (define imap:parse:server
  317.   (imap:server-parser #t))
  318.  
  319. (define imap:parse:mailboxlist
  320.   (sequence-parser
  321.    (optional-parser
  322.     (url:decoding-parser imap:match:bchar+ 'MAILBOX-LIST))
  323.    (noise-parser (ci-string-matcher ";type="))
  324.    (simple-parser (alternatives-matcher (ci-string-matcher "list")
  325.                     (ci-string-matcher "lsub"))
  326.           'LIST-TYPE)))
  327.  
  328. (define imap:parse:enc-mailbox
  329.   (url:decoding-parser imap:match:bchar+ 'MAILBOX))
  330.  
  331. (define imap:parse:uidvalidity
  332.   (sequence-parser (noise-parser (ci-string-matcher ";uidvalidity="))
  333.            (simple-parser imap:match:nz-number 'UID-VALIDITY)))
  334.  
  335. (define imap:parse:messagelist
  336.   (sequence-parser imap:parse:enc-mailbox
  337.            (optional-parser
  338.             (url:decoding-parser imap:match:bchar+ 'SEARCH-PROGRAM))
  339.            (optional-parser imap:parse:uidvalidity)))
  340.  
  341. (define imap:parse:messagepart
  342.   (sequence-parser imap:parse:enc-mailbox
  343.            (optional-parser imap:parse:uidvalidity)
  344.            (noise-parser (ci-string-matcher "/;uid="))
  345.            (simple-parser imap:match:nz-number 'UID)
  346.            (optional-parser
  347.             (noise-parser (ci-string-matcher "/;section="))
  348.             (decoding-parser imap:match:bchar+
  349.                      url:decode-substring
  350.                      imap:parse:section))))
  351.  
  352. ;;;; Mailbox-name encoding (modified UTF-7)
  353.  
  354. (define (imap:encode-mailbox-name string #!optional start end)
  355.   (let* ((start (if (default-object? start) 0 start))
  356.      (end (if (default-object? end) (string-length string) end))
  357.      (n
  358.       (let loop ((start start) (n 0))
  359.         (let ((index
  360.            (substring-find-next-char-in-set
  361.             string start end imap:char-set:mailbox-name-encoded)))
  362.           (if index
  363.           (let ((n (fix:+ n (fix:+ (fix:- index start) 2))))
  364.             (let ((index*
  365.                (or (substring-find-next-char-in-set
  366.                 string (fix:+ index 1) end
  367.                 imap:char-set:mailbox-name-unencoded)
  368.                    end)))
  369.               (loop index*
  370.                 (fix:+ n
  371.                    (let ((m (fix:- index* index)))
  372.                      (if (and (fix:= m 1)
  373.                           (char=? (string-ref string index)
  374.                               #\&))
  375.                      0
  376.                      (integer-ceiling (fix:* 8 m) 6)))))))
  377.           (fix:+ n (fix:- end start)))))))
  378.     (let ((s (make-string n)))
  379.       (let loop ((start start) (j 0))
  380.     (let ((index
  381.            (substring-find-next-char-in-set
  382.         string start end imap:char-set:mailbox-name-encoded)))
  383.       (if index
  384.           (let ((j (substring-move! string start index s j)))
  385.         (string-set! s j #\&)
  386.         (let ((j (fix:+ j 1))
  387.               (index*
  388.                (or (substring-find-next-char-in-set
  389.                 string (fix:+ index 1) end
  390.                 imap:char-set:mailbox-name-unencoded)
  391.                end)))
  392.           (let ((j
  393.              (if (and (fix:= (fix:- index* index) 1)
  394.                   (char=? (string-ref string index) #\&))
  395.                  j
  396.                  (encode-mailbox-name-1 string index index* s j))))
  397.             (string-set! s j #\-)
  398.             (loop index* (fix:+ j 1)))))
  399.           (substring-move! string start end s j))))
  400.       s)))
  401.  
  402. (define (imap:decode-mailbox-name string #!optional start end)
  403.   (let* ((start (if (default-object? start) 0 start))
  404.      (end (if (default-object? end) (string-length string) end))
  405.      (lose
  406.       (lambda ()
  407.         (error "Malformed encoded mailbox name:"
  408.            (substring string start end)))))
  409.     (let ((n
  410.        (let loop ((start start) (n 0))
  411.          (let ((index (substring-find-next-char string start end #\&)))
  412.            (if index
  413.            (let ((index*
  414.               (substring-find-next-char string (fix:+ index 1) end
  415.                             #\-)))
  416.              (if (not index*) (lose))
  417.              (loop (fix:+ index* 1)
  418.                (fix:+ (fix:+ n (fix:- index start))
  419.                   (let ((m (fix:- index* (fix:+ index 1))))
  420.                     (if (fix:= m 1)
  421.                     1
  422.                     (let ((q (fix:quotient m 4))
  423.                           (r (fix:remainder m 4)))
  424.                       (fix:+ (fix:* 3 q)
  425.                          (case r
  426.                            ((0) 0)
  427.                            ((2) 1)
  428.                            ((3) 2)
  429.                            (else (lose))))))))))
  430.            (fix:+ n (fix:- end start)))))))
  431.       (let ((s (make-string n)))
  432.     (let loop ((start start) (j 0))
  433.       (let ((index (substring-find-next-char string start end #\&)))
  434.         (if index
  435.         (let ((index*
  436.                (substring-find-next-char string (fix:+ index 1) end
  437.                          #\-)))
  438.           (if (not index*) (lose))
  439.           (let ((j (substring-move! string start index s j))
  440.             (m (fix:- index* index)))
  441.             (if (fix:= m 1)
  442.             (begin
  443.               (string-set! s j #\&)
  444.               (loop (fix:+ index* 1) (fix:+ j 1)))
  445.             (loop (fix:+ index* 1)
  446.                   (decode-mailbox-name-1 string
  447.                              (fix:+ index 1)
  448.                              index*
  449.                              s
  450.                              j
  451.                              lose)))))
  452.         (substring-move! string start end s j))))
  453.     s))))
  454.  
  455. (define (encode-mailbox-name-1 string start end s j)
  456.   (let ((write
  457.      (lambda (j v)
  458.        (string-set! s j
  459.             (vector-8b-ref base64-digit-table
  460.                        (fix:and #x3f v))))))
  461.     (let loop ((start start) (j j))
  462.       (case (fix:- end start)
  463.     ((0)
  464.      j)
  465.     ((1)
  466.      (let ((d0 (string-ref string start)))
  467.        (write j (fix:lsh d0 -2))
  468.        (write (fix:+ j 1) (fix:lsh d0 4)))
  469.      (fix:+ j 2))
  470.     ((2)
  471.      (let ((d0 (string-ref string start))
  472.            (d1 (string-ref string (fix:+ start 1))))
  473.        (write j (fix:lsh d0 -2))
  474.        (write (fix:+ j 1) (fix:+ (fix:lsh d0 4) (fix:lsh d1 -4)))
  475.        (write (fix:+ j 2) (fix:lsh d1 2)))
  476.      (fix:+ j 3))
  477.     (else
  478.      (let ((d0 (string-ref string start))
  479.            (d1 (string-ref string (fix:+ start 1)))
  480.            (d2 (string-ref string (fix:+ start 2))))
  481.        (write j (fix:lsh d0 -2))
  482.        (write (fix:+ j 1) (fix:+ (fix:lsh d0 4) (fix:lsh d1 -4)))
  483.        (write (fix:+ j 2) (fix:+ (fix:lsh d1 2) (fix:lsh d2 -6)))
  484.        (write (fix:+ j 3) d2)
  485.        (loop (fix:+ start 3) (fix:+ j 4))))))))
  486.  
  487. (define (decode-mailbox-name-1 string start end s j lose)
  488.   (let ((read (lambda (i) (decode-base64-char (vector-8b-ref string i))))
  489.     (write (lambda (j v) (vector-8b-set! s j v))))
  490.     (let loop ((start start) (j j))
  491.       (case (fix:- end start)
  492.     ((0)
  493.      j)
  494.     ((1)
  495.      (lose))
  496.     ((2)
  497.      (let ((d0 (read start))
  498.            (d1 (read (fix:+ start 1))))
  499.        (write j
  500.           (fix:+ (fix:lsh d0 2)
  501.              (fix:lsh d1 -4))))
  502.      (fix:+ j 1))
  503.     ((3)
  504.      (let ((d0 (read start))
  505.            (d1 (read (fix:+ start 1)))
  506.            (d2 (read (fix:+ start 2))))
  507.        (write j
  508.           (fix:+ (fix:lsh d0 2)
  509.              (fix:lsh d1 -4)))
  510.        (write (fix:+ j 1)
  511.           (fix:+ (fix:lsh (fix:and #x0f d1) 4)
  512.              (fix:lsh d2 -2))))
  513.      (fix:+ j 2))
  514.     (else
  515.      (let ((d0 (read start))
  516.            (d1 (read (fix:+ start 1)))
  517.            (d2 (read (fix:+ start 2)))
  518.            (d3 (read (fix:+ start 3))))
  519.        (write j
  520.           (fix:+ (fix:lsh d0 2)
  521.              (fix:lsh d1 -4)))
  522.        (write (fix:+ j 1)
  523.           (fix:+ (fix:lsh (fix:and #x0f d1) 4)
  524.              (fix:lsh d2 -2)))
  525.        (write (fix:+ j 2)
  526.           (fix:+ (fix:lsh (fix:and #x03 d2) 6)
  527.              d3)))
  528.      (loop (fix:+ start 4) (fix:+ j 3)))))))
  529.  
  530. (define imap:char-set:mailbox-name-encoded
  531.   (char-set-union char-set:not-graphic (char-set #\&)))
  532.  
  533. (define imap:char-set:mailbox-name-unencoded
  534.   (char-set-invert imap:char-set:mailbox-name-encoded))
  535.  
  536. (define (decode-base64-char byte)
  537.   (let ((digit (vector-8b-ref base64-char-table byte)))
  538.     (if (>= digit #x40)
  539.     (error "Character not a base64 component:" (integer->char byte)))
  540.     digit))  
  541.  
  542. (define base64-char-table)
  543. (define base64-digit-table)
  544. (let ((char-table (make-string 256 (integer->char #xff)))
  545.       (digit-table (make-string 64)))
  546.   (let ((do-single
  547.      (lambda (index value)
  548.        (vector-8b-set! char-table index value)
  549.        (vector-8b-set! digit-table value index))))
  550.     (letrec
  551.     ((do-range
  552.       (lambda (low high value)
  553.         (do-single low value)
  554.         (if (fix:< low high)
  555.         (do-range (fix:+ low 1) high (fix:+ value 1))))))
  556.       (do-range (char->integer #\A) (char->integer #\Z) 0)
  557.       (do-range (char->integer #\a) (char->integer #\z) 26)
  558.       (do-range (char->integer #\0) (char->integer #\9) 52)
  559.       (do-single (char->integer #\+) 62)
  560.       (do-single (char->integer #\,) 63)))
  561.   (set! base64-char-table char-table)
  562.   (set! base64-digit-table digit-table)
  563.   unspecific)
  564.  
  565. ;;;; Formatted output
  566.  
  567. (define (imap:write-quoted-string string port)
  568.   (imap:write-quoted-substring string 0 (string-length string) port))
  569.  
  570. (define (imap:write-quoted-substring string start end port)
  571.   (imap-transcript-write-char #\" port)
  572.   (let loop ((start start))
  573.     (if (fix:< start end)
  574.     (let ((char (string-ref string start)))
  575.       (if (or (char=? char #\\) (char=? char #\"))
  576.           (imap-transcript-write-char #\\ port))
  577.       (imap-transcript-write-char char port)
  578.       (loop (fix:+ start 1)))))
  579.   (imap-transcript-write-char #\" port))
  580.  
  581. (define (imap:write-literal-string-header string port)
  582.   (imap:write-literal-substring-header string 0 (string-length string) port))
  583.  
  584. (define (imap:write-literal-substring-header string start end port)
  585.   (imap-transcript-write-char #\{ port)
  586.   (imap-transcript-write
  587.    (+ (- end start) (length (substring-search-all "\n" string start end)))
  588.    port)
  589.   (imap-transcript-write-char #\} port)
  590.   (imap-transcript-write-char #\return port)
  591.   (imap-transcript-write-char #\linefeed port))
  592.  
  593. (define (imap:write-literal-string-body string port)
  594.   (imap:write-literal-substring-body string 0 (string-length string) port))
  595.  
  596. (define (imap:write-literal-substring-body string start end port)
  597.   ;; Translate newlines back to network line endings.
  598.   (let loop ((start start))
  599.     (if (fix:<= start end)
  600.     (let ((index (substring-find-next-char string start end #\newline)))
  601.       (if index
  602.           (begin
  603.         (imap-transcript-write-substring string start index port)
  604.         (imap-transcript-write-char #\return port)
  605.         (imap-transcript-write-char #\linefeed port)
  606.         (loop (fix:+ index 1)))
  607.           (imap-transcript-write-substring string start end port))))))
  608.  
  609. (define (imap:universal-time->date-time time)
  610.   (imap:decoded-time->date-time (universal-time->global-decoded-time time)))
  611.  
  612. (define (imap:decoded-time->date-time dt)
  613.   (let ((2digit
  614.      (lambda (n)
  615.        (string-pad-left (number->string n) 2 #\0))))
  616.     (string-append (string-pad-left (number->string (decoded-time/day dt)) 2)
  617.            "-"
  618.            (month/short-string (decoded-time/month dt))
  619.            "-"
  620.            (number->string (decoded-time/year dt))
  621.            " "
  622.            (2digit (decoded-time/hour dt))
  623.            ":"
  624.            (2digit (decoded-time/minute dt))
  625.            ":"
  626.            (2digit (decoded-time/second dt))
  627.            " "
  628.            (time-zone->string (decoded-time/zone dt)))))