sunet/scheme/lib/crlf-io.scm

51 lines
1.7 KiB
Scheme
Raw Normal View History

2002-06-08 11:07:01 -04:00
;;; Read cr/lf and lf terminated lines. -*- Scheme -*-
2002-08-27 05:03:22 -04:00
;;; This file is part of the Scheme Untergrund Networking package.
2002-06-08 11:07:01 -04:00
;;; Copyright (c) 1995 by Olin Shivers. <shivers@lcs.mit.edu>
2002-08-27 05:03:22 -04:00
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
2002-06-08 11:07:01 -04:00
;;; (read-crlf-line [fd/port retain-crlf?]) -> string or EOF object
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Read a line terminated by either line-feed or EOF. If RETAIN-CRLF? is #f
;;; (the default), a terminating cr/lf or lf sequence is trimmed from the
;;; returned string.
;;;
;;; This is simple and inefficient. It would be save one copy if we didn't
;;; use READ-LINE, but replicated its implementation instead.
(define (read-crlf-line . args)
(let-optionals args ((fd/port (current-input-port))
(retain-crlf? #f))
(let ((ln (read-line fd/port retain-crlf?)))
(if (or retain-crlf? (eof-object? ln))
ln
(let ((slen (string-length ln))) ; Trim a trailing cr, if any.
(if (or (zero? slen)
(not (char=? (string-ref ln (- slen 1)) cr)))
ln
(substring ln 0 (- slen 1))))))))
(define cr (ascii->char 13))
(define (write-crlf port)
(write-string "\r\n" port)
(force-output port))
(define (read-crlf-line-timeout . args)
(let-optionals args ((fd/port (current-input-port))
(retain-crlf? #f)
(timeout 8000)
(max-interval 500))
(let loop ((waited 0) (interval 100))
(cond ((> waited timeout)
'timeout)
((char-ready? fd/port)
(read-crlf-line fd/port retain-crlf?))
(else (sleep interval)
(loop (+ waited interval) (min (* interval 2)
max-interval)))))))