From: Chris Hanson Date: Fri, 19 May 2000 02:31:12 +0000 (+0000) Subject: Reimplement low-level IMAP tracing code to be a complete transcript X-Git-Tag: 20090517-FFI~3810 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f0a25e8d9e7186d29014564a60e9a1e935a78c07;p=mit-scheme.git Reimplement low-level IMAP tracing code to be a complete transcript mechanism. --- diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm index 3686c2561..face7ab53 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.56 2000/05/18 22:11:14 cph Exp $ +;;; $Id: imail-imap.scm,v 1.57 2000/05/19 02:31:07 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -897,18 +897,18 @@ (port (imap-connection-port connection))) (if imail-trace? (imail-trace-record-output (cons* 'SEND tag command arguments))) - (write-string tag port) - (write-char #\space port) - (write command port) + (imap-transcript-write-string tag port) + (imap-transcript-write-char #\space port) + (imap-transcript-write command port) (for-each (lambda (argument) (if argument (begin - (write-char #\space port) + (imap-transcript-write-char #\space port) (imap:send-command-argument connection tag argument)))) arguments) - (write-char #\return port) - (write-char #\linefeed port) - (flush-output port) + (imap-transcript-write-char #\return port) + (imap-transcript-write-char #\linefeed port) + (imap-transcript-flush-output port) tag)) (define (imap:send-command-argument connection tag argument) @@ -916,11 +916,11 @@ (let loop ((argument argument)) (cond ((or (symbol? argument) (exact-nonnegative-integer? argument)) - (write argument port)) + (imap-transcript-write argument port)) ((and (pair? argument) (eq? (car argument) 'ATOM) (string? (cdr argument))) - (write-string (cdr argument) port)) + (imap-transcript-write-string (cdr argument) port)) ((and (pair? argument) (eq? (car argument) 'LITERAL) (string? (cdr argument))) @@ -930,21 +930,21 @@ (imap:write-quoted-string argument port) (imap:write-literal-string connection tag argument))) ((list? argument) - (write-char #\( port) + (imap-transcript-write-char #\( port) (if (pair? argument) (begin (loop (car argument)) (for-each (lambda (object) - (write-char #\space port) + (imap-transcript-write-char #\space port) (loop object)) (cdr argument)))) - (write-char #\) port)) + (imap-transcript-write-char #\) port)) (else (error "Illegal IMAP syntax:" argument)))))) (define (imap:write-literal-string connection tag string) (let ((port (imap-connection-port connection))) (imap:write-literal-string-header string port) - (flush-output port) + (imap-transcript-flush-output port) (let loop () (let ((response (imap:read-server-response port))) (cond ((imap:response:continue? response) diff --git a/v7/src/imail/imail.pkg b/v7/src/imail/imail.pkg index 0b91c1bbe..e36282bef 100644 --- a/v7/src/imail/imail.pkg +++ b/v7/src/imail/imail.pkg @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: imail.pkg,v 1.35 2000/05/18 19:53:25 cph Exp $ +;;; $Id: imail.pkg,v 1.36 2000/05/19 02:31:05 cph Exp $ ;;; ;;; Copyright (c) 2000 Massachusetts Institute of Technology ;;; @@ -150,6 +150,11 @@ (files "imap-response") (parent (edwin imail)) (export (edwin imail) + imap-transcript-flush-output + imap-transcript-write + imap-transcript-write-char + imap-transcript-write-string + imap-transcript-write-substring imap:read-literal-progress-hook imap:read-server-response imap:response-code:alert? @@ -191,7 +196,8 @@ imap:response:status-response? imap:response:status? imap:response:tag - trace-imap-server-responses?)) + start-imap-transcript + stop-imap-transcript)) (define-package (edwin imail) (files "imail-util" diff --git a/v7/src/imail/imap-syntax.scm b/v7/src/imail/imap-syntax.scm index 0fa8f313a..0a539322a 100644 --- a/v7/src/imail/imap-syntax.scm +++ b/v7/src/imail/imap-syntax.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: imap-syntax.scm,v 1.9 2000/05/16 15:14:17 cph Exp $ +;;; $Id: imap-syntax.scm,v 1.10 2000/05/19 02:31:12 cph Exp $ ;;; ;;; Copyright (c) 2000 Massachusetts Institute of Technology ;;; @@ -573,26 +573,26 @@ (imap:write-quoted-substring string 0 (string-length string) port)) (define (imap:write-quoted-substring string start end port) - (write-char #\" port) + (imap-transcript-write-char #\" port) (let loop ((start start)) (if (fix:< start end) (let ((char (string-ref string start))) (if (or (char=? char #\\) (char=? char #\")) - (write-char #\\ port)) - (write-char char port) + (imap-transcript-write-char #\\ port)) + (imap-transcript-write-char char port) (loop (fix:+ start 1))))) - (write-char #\" port)) + (imap-transcript-write-char #\" port)) (define (imap:write-literal-string-header string port) (imap:write-literal-substring-header string 0 (string-length string) port)) (define (imap:write-literal-substring-header string start end port) string - (write-char #\{ port) - (write (fix:- end start) port) - (write-char #\} port) - (write-char #\return port) - (write-char #\linefeed port)) + (imap-transcript-write-char #\{ port) + (imap-transcript-write (fix:- end start) port) + (imap-transcript-write-char #\} port) + (imap-transcript-write-char #\return port) + (imap-transcript-write-char #\linefeed port)) (define (imap:write-literal-string-body string port) (imap:write-literal-substring-body string 0 (string-length string) port)) @@ -604,11 +604,11 @@ (let ((index (substring-find-next-char string start end #\newline))) (if index (begin - (write-substring string start index port) - (write-char #\return port) - (write-char #\linefeed port) + (imap-transcript-write-substring string start index port) + (imap-transcript-write-char #\return port) + (imap-transcript-write-char #\linefeed port) (loop (fix:+ index 1))) - (write-substring string start end port)))))) + (imap-transcript-write-substring string start end port)))))) (define (imap:universal-time->date-time time) (imap:decoded-time->date-time (universal-time->global-decoded-time time)))