~ chicken-core (chicken-5) 93517411bfad107871a11cdc4ecc1a9a12079290
commit 93517411bfad107871a11cdc4ecc1a9a12079290
Author: Peter Bex <peter.bex@xs4all.nl>
AuthorDate: Sun Jul 17 15:56:55 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Sun Jul 17 23:30:29 2011 +0200
Change port procedures which try to read or write (or access the underlying descriptor) to not just check their arguments for being a port, but also check that the port is still open.
diff --git a/extras.scm b/extras.scm
index 31309c24..e790fff8 100644
--- a/extras.scm
+++ b/extras.scm
@@ -84,7 +84,7 @@
(let* ([parg (pair? args)]
[p (if parg (car args) ##sys#standard-input)]
[limit (and parg (pair? (cdr args)) (cadr args))])
- (##sys#check-port p 'read-line)
+ (##sys#check-port* p 'read-line)
(cond ((##sys#slot (##sys#slot p 2) 8) => (lambda (rl) (rl p limit)))
(else
(let* ((buffer-len (if limit limit 256))
@@ -175,7 +175,7 @@
(else (fx+ n2 m))) )))))))
(define (read-string! n dest #!optional (port ##sys#standard-input) (start 0))
- (##sys#check-port port 'read-string!)
+ (##sys#check-port* port 'read-string!)
(##sys#check-string dest 'read-string!)
(when n
(##sys#check-exact n 'read-string!)
@@ -188,7 +188,7 @@
(define ##sys#read-string/port
(lambda (n p)
- (##sys#check-port p 'read-string)
+ (##sys#check-port* p 'read-string)
(cond (n (##sys#check-exact n 'read-string)
(let* ((str (##sys#make-string n))
(n2 (##sys#read-string! n str p 0)) )
@@ -230,7 +230,7 @@
(define read-token
(lambda (pred . port)
(let ([port (optional port ##sys#standard-input)])
- (##sys#check-port port 'read-token)
+ (##sys#check-port* port 'read-token)
(let ([out (open-output-string)])
(let loop ()
(let ([c (##sys#peek-char-0 port)])
@@ -256,7 +256,7 @@
;;; Binary I/O
(define (read-byte #!optional (port ##sys#standard-input))
- (##sys#check-port port 'read-byte)
+ (##sys#check-port* port 'read-byte)
(let ((x (##sys#read-char-0 port)))
(if (eof-object? x)
x
@@ -264,7 +264,7 @@
(define (write-byte byte #!optional (port ##sys#standard-output))
(##sys#check-exact byte 'write-byte)
- (##sys#check-port port 'write-byte)
+ (##sys#check-port* port 'write-byte)
(##sys#write-char-0 (integer->char byte) port) )
@@ -575,7 +575,7 @@
(define fprintf0
(lambda (loc port msg args)
- (when port (##sys#check-port port loc))
+ (when port (##sys#check-port* port loc))
(let ((out (if (and port (##sys#tty-port? port))
port
(open-output-string))))
diff --git a/library.scm b/library.scm
index 63c6c964..c08a43a1 100644
--- a/library.scm
+++ b/library.scm
@@ -3009,11 +3009,13 @@ EOF
(for-each (cut ##sys#print <> #f ##sys#standard-output) lst) )
(define (print . args)
+ (##sys#check-port* ##sys#standard-output 'print)
(*print-each args)
(##sys#write-char-0 #\newline ##sys#standard-output)
(void) )
(define (print* . args)
+ (##sys#check-port* ##sys#standard-output 'print)
(*print-each args)
(##sys#flush-output ##sys#standard-output)
(void) )
@@ -3689,7 +3691,7 @@ EOF
(define (print-call-chain #!optional (port ##sys#standard-output) (start 0)
(thread ##sys#current-thread)
(header "\n\tCall history:\n") )
- (##sys#check-port port 'print-call-chain)
+ (##sys#check-port* port 'print-call-chain)
(##sys#check-exact start 'print-call-chain)
(##sys#check-string header 'print-call-chain)
(let ((ct (##sys#get-call-chain start thread)))
diff --git a/posixunix.scm b/posixunix.scm
index 82adbbb2..3e578d92 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -1757,7 +1757,7 @@ EOF
(##sys#error 'set-buffering-mode! "cannot set buffering mode" port mode size) ) ) ) )
(define (terminal-port? port)
- (##sys#check-port port 'terminal-port?)
+ (##sys#check-port* port 'terminal-port?)
(let ([fp (##sys#peek-unsigned-integer port 0)])
(and (not (eq? 0 fp)) (##core#inline "C_tty_portp" port) ) ) )
diff --git a/posixwin.scm b/posixwin.scm
index a1e976ab..28f8c5fa 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -1461,7 +1461,7 @@ EOF
(ex0 (if (pair? code) (car code) 0)) ) ) )
(define (terminal-port? port)
- (##sys#check-port port 'terminal-port?)
+ (##sys#check-port* port 'terminal-port?)
(let ([fp (##sys#peek-unsigned-integer port 0)])
(and (not (eq? 0 fp)) (##core#inline "C_tty_portp" port) ) ) )
diff --git a/srfi-4.scm b/srfi-4.scm
index 83df6718..c41a261c 100644
--- a/srfi-4.scm
+++ b/srfi-4.scm
@@ -642,7 +642,7 @@ EOF
(define (write-u8vector v #!optional (port ##sys#standard-output) (from 0)
(to (u8vector-length v)))
(##sys#check-structure v 'u8vector 'write-u8vector)
- (##sys#check-port port 'write-u8vector)
+ (##sys#check-port* port 'write-u8vector)
(do ((i from (fx+ i 1)))
((fx>= i to))
(##sys#write-char-0
@@ -650,7 +650,7 @@ EOF
port) ) )
(define (read-u8vector! n dest #!optional (port ##sys#standard-input) (start 0))
- (##sys#check-port port 'read-u8vector!)
+ (##sys#check-port* port 'read-u8vector!)
(##sys#check-exact start 'read-u8vector!)
(##sys#check-structure dest 'u8vector 'read-u8vector!)
(let ((dest (##sys#slot dest 1)))
@@ -670,7 +670,7 @@ EOF
(##core#inline "C_substring_copy" str str2 0 n 0)
str2) ) )
(lambda (#!optional n (p ##sys#standard-input))
- (##sys#check-port p 'read-u8vector)
+ (##sys#check-port* p 'read-u8vector)
(cond (n (##sys#check-exact n 'read-u8vector)
(let* ((str (##sys#allocate-vector n #t #f #t))
(n2 (##sys#read-string! n str p 0)) )
diff --git a/tcp.scm b/tcp.scm
index c8e1bd76..18530924 100644
--- a/tcp.scm
+++ b/tcp.scm
@@ -629,7 +629,7 @@ EOF
(error '##sys#tcp-port->fileno "argument does not appear to be a TCP port" p))))
(define (tcp-addresses p)
- (##sys#check-port p 'tcp-addresses)
+ (##sys#check-port* p 'tcp-addresses)
(let ((fd (##sys#tcp-port->fileno p)))
(values
(or (##net#getsockname fd)
@@ -642,7 +642,7 @@ EOF
(##sys#string-append "cannot compute remote address - " strerror) p) ) ) ) )
(define (tcp-port-numbers p)
- (##sys#check-port p 'tcp-port-numbers)
+ (##sys#check-port* p 'tcp-port-numbers)
(let ((fd (##sys#tcp-port->fileno p)))
(values
(or (##net#getsockport fd)
@@ -665,7 +665,7 @@ EOF
port) )
(define (tcp-abandon-port p)
- (##sys#check-port p 'tcp-abandon-port)
+ (##sys#check-port* p 'tcp-abandon-port)
(##sys#setislot
(##sys#port-data p)
(if (##sys#slot p 1) 1 2)
diff --git a/tests/port-tests.scm b/tests/port-tests.scm
index 72795418..ee562c20 100644
--- a/tests/port-tests.scm
+++ b/tests/port-tests.scm
@@ -1,4 +1,4 @@
-(require-extension srfi-1 ports utils)
+(require-extension srfi-1 ports utils srfi-4 extras tcp posix)
(define *text* #<<EOF
this is a test
@@ -99,3 +99,84 @@ EOF
(copy-port (current-input-port) (current-output-port)))))))
(delete-file "compiler.scm.2")
+
+(define-syntax check
+ (syntax-rules ()
+ ((_ (expr-head expr-rest ...))
+ (check 'expr-head (expr-head expr-rest ...)))
+ ((_ name expr)
+ (let ((okay (list 'okay)))
+ (assert
+ (eq? okay
+ (condition-case
+ (begin (print* name "...")
+ (flush-output)
+ (let ((output expr))
+ (printf "FAIL [ ~S ]\n" output)))
+ ((exn i/o file) (printf "OK\n") okay))))))))
+
+(define proc (process-fork (lambda () (tcp-accept (tcp-listen 8080)))))
+
+(on-exit (lambda () (handle-exceptions exn #f (process-signal proc))))
+
+(print "\n\nProcedures check on TCP ports being closed\n")
+
+(receive (in out)
+ (let lp ()
+ (condition-case (tcp-connect "localhost" 8080)
+ ((exn i/o net) (lp))))
+ (close-output-port out)
+ (close-input-port in)
+ (check (tcp-addresses in))
+ (check (tcp-port-numbers in))
+ (check (tcp-abandon-port in))) ; Not sure about abandon-port
+
+(print "\n\nProcedures check on output ports being closed\n")
+
+(call-with-output-file "/dev/null"
+ (lambda (out)
+ (close-output-port out)
+ (check (write '(foo) out))
+ (check (fprintf out "blabla"))
+ (check "print-call-chain" (begin (print-call-chain out) (void)))
+ (check (print-error-message (make-property-condition 'exn 'message "foo") out))
+ (check "print" (with-output-to-port out
+ (lambda () (print "foo"))))
+ (check "print*" (with-output-to-port out
+ (lambda () (print* "foo"))))
+ (check (display "foo" out))
+ (check (terminal-port? out)) ; Calls isatty() on C_SCHEME_FALSE?
+ (check (newline out))
+ (check (write-char #\x out))
+ (check (write-line "foo" out))
+ (check (write-u8vector '#u8(1 2 3) out))
+ (check (port->fileno out))
+ (check (flush-output out))
+ (check (file-test-lock out))
+ (check (file-lock out))
+ (check (file-lock/blocking out))
+ (check (write-byte 120 out))
+ (check (write-string "foo" #f out))))
+
+(print "\n\nProcedures check on input ports being closed\n")
+(call-with-input-file "/dev/zero"
+ (lambda (in)
+ (close-input-port in)
+ (check (read in))
+ (check (read-char in))
+ (check (char-ready? in))
+ (check (peek-char in))
+ (check (port->fileno in))
+ (check (terminal-port? in)) ; Calls isatty() on C_SCHEME_FALSE?
+ (check (read-line in 5))
+ (check (read-u8vector 5 in))
+ (check "read-u8vector!" (let ((dest (make-u8vector 5)))
+ (read-u8vector! 5 dest in)))
+ (check (file-test-lock in))
+ (check (file-lock in))
+ (check (file-lock/blocking in))
+ (check (read-byte in))
+ (check (read-token (constantly #t) in))
+ (check (read-string 10 in))
+ (check "read-string!" (let ((buf (make-string 10)))
+ (read-string! 10 buf in) buf))))
\ No newline at end of file
Trap