Ticket #653: 0001-Change-port-procedures-which-try-to-read-or-write-or.patch

File 0001-Change-port-procedures-which-try-to-read-or-write-or.patch, 9.9 KB (added by sjamaan, 13 years ago)

  • extras.scm 

    From 184782873e4160d7715e57b352e398bf0e1916c0 Mon Sep 17 00:00:00 2001
From: Peter Bex <peter.bex@xs4all.nl>
Date: Sun, 17 Jul 2011 15:56:55 +0200
Subject: [PATCH] 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.

---
 extras.scm           |   14 ++++----
 library.scm          |    4 ++-
 posixunix.scm        |    2 +-
 posixwin.scm         |    2 +-
 srfi-4.scm           |    6 ++--
 tcp.scm              |    6 ++--
 tests/port-tests.scm |   83 +++++++++++++++++++++++++++++++++++++++++++++++++-
 7 files changed, 100 insertions(+), 17 deletions(-)

diff --git a/extras.scm b/extras.scm
index 31309c2..e790fff 100644
    a b  
    8484      (let* ([parg (pair? args)]
    8585             [p (if parg (car args) ##sys#standard-input)]
    8686             [limit (and parg (pair? (cdr args)) (cadr args))])
    87         (##sys#check-port p 'read-line)
     87        (##sys#check-port* p 'read-line)
    8888        (cond ((##sys#slot (##sys#slot p 2) 8) => (lambda (rl) (rl p limit)))
    8989              (else
    9090               (let* ((buffer-len (if limit limit 256))
    … …  
    175175                         (else (fx+ n2 m))) )))))))
    176176
    177177(define (read-string! n dest #!optional (port ##sys#standard-input) (start 0))
    178   (##sys#check-port port 'read-string!)
     178  (##sys#check-port* port 'read-string!)
    179179  (##sys#check-string dest 'read-string!)
    180180  (when n
    181181    (##sys#check-exact n 'read-string!)
    … …  
    188188
    189189(define ##sys#read-string/port
    190190  (lambda (n p)
    191     (##sys#check-port p 'read-string)
     191    (##sys#check-port* p 'read-string)
    192192    (cond (n (##sys#check-exact n 'read-string)
    193193             (let* ((str (##sys#make-string n))
    194194                    (n2 (##sys#read-string! n str p 0)) )
    … …  
    230230(define read-token
    231231  (lambda (pred . port)
    232232    (let ([port (optional port ##sys#standard-input)])
    233       (##sys#check-port port 'read-token)
     233      (##sys#check-port* port 'read-token)
    234234      (let ([out (open-output-string)])
    235235        (let loop ()
    236236          (let ([c (##sys#peek-char-0 port)])
    … …  
    256256;;; Binary I/O
    257257
    258258(define (read-byte #!optional (port ##sys#standard-input))
    259   (##sys#check-port port 'read-byte)
     259  (##sys#check-port* port 'read-byte)
    260260  (let ((x (##sys#read-char-0 port)))
    261261    (if (eof-object? x)
    262262        x
    … …  
    264264
    265265(define (write-byte byte #!optional (port ##sys#standard-output))
    266266  (##sys#check-exact byte 'write-byte)
    267   (##sys#check-port port 'write-byte)
     267  (##sys#check-port* port 'write-byte)
    268268  (##sys#write-char-0 (integer->char byte) port) )
    269269
    270270
    … …  
    575575
    576576(define fprintf0
    577577  (lambda (loc port msg args)
    578     (when port (##sys#check-port port loc))
     578    (when port (##sys#check-port* port loc))
    579579    (let ((out (if (and port (##sys#tty-port? port))
    580580                   port
    581581                   (open-output-string))))

  • library.scm 

    diff --git a/library.scm b/library.scm
index 63c6c96..c08a43a 100644
    a b EOF 
    30093009  (for-each (cut ##sys#print <> #f ##sys#standard-output) lst) )
    30103010 
    30113011(define (print . args)
     3012  (##sys#check-port* ##sys#standard-output 'print)
    30123013  (*print-each args)
    30133014  (##sys#write-char-0 #\newline ##sys#standard-output)
    30143015  (void) )
    30153016
    30163017(define (print* . args)
     3018  (##sys#check-port* ##sys#standard-output 'print)
    30173019  (*print-each args)
    30183020  (##sys#flush-output ##sys#standard-output)
    30193021  (void) )
    … … EOF 
    36893691(define (print-call-chain #!optional (port ##sys#standard-output) (start 0)
    36903692                                     (thread ##sys#current-thread)
    36913693                                     (header "\n\tCall history:\n") )
    3692   (##sys#check-port port 'print-call-chain)
     3694  (##sys#check-port* port 'print-call-chain)
    36933695  (##sys#check-exact start 'print-call-chain)
    36943696  (##sys#check-string header 'print-call-chain)
    36953697  (let ((ct (##sys#get-call-chain start thread)))

  • posixunix.scm 

    diff --git a/posixunix.scm b/posixunix.scm
index 82adbbb..3e578d9 100644
    a b EOF 
    17571757        (##sys#error 'set-buffering-mode! "cannot set buffering mode" port mode size) ) ) ) )
    17581758
    17591759(define (terminal-port? port)
    1760   (##sys#check-port port 'terminal-port?)
     1760  (##sys#check-port* port 'terminal-port?)
    17611761  (let ([fp (##sys#peek-unsigned-integer port 0)])
    17621762    (and (not (eq? 0 fp)) (##core#inline "C_tty_portp" port) ) ) )
    17631763

  • posixwin.scm 

    diff --git a/posixwin.scm b/posixwin.scm
index a1e976a..28f8c5f 100644
    a b EOF 
    14611461      (ex0 (if (pair? code) (car code) 0)) ) ) )
    14621462
    14631463(define (terminal-port? port)
    1464   (##sys#check-port port 'terminal-port?)
     1464  (##sys#check-port* port 'terminal-port?)
    14651465  (let ([fp (##sys#peek-unsigned-integer port 0)])
    14661466    (and (not (eq? 0 fp)) (##core#inline "C_tty_portp" port) ) ) )
    14671467

  • srfi-4.scm 

    diff --git a/srfi-4.scm b/srfi-4.scm
index 83df671..c41a261 100644
    a b EOF 
    642642(define (write-u8vector v #!optional (port ##sys#standard-output) (from 0)
    643643                        (to (u8vector-length v)))
    644644  (##sys#check-structure v 'u8vector 'write-u8vector)
    645   (##sys#check-port port 'write-u8vector)
     645  (##sys#check-port* port 'write-u8vector)
    646646  (do ((i from (fx+ i 1)))
    647647      ((fx>= i to))
    648648    (##sys#write-char-0
    … … EOF 
    650650     port) ) )
    651651
    652652(define (read-u8vector! n dest #!optional (port ##sys#standard-input) (start 0))
    653   (##sys#check-port port 'read-u8vector!)
     653  (##sys#check-port* port 'read-u8vector!)
    654654  (##sys#check-exact start 'read-u8vector!)
    655655  (##sys#check-structure dest 'u8vector 'read-u8vector!)
    656656  (let ((dest (##sys#slot dest 1)))
    … … EOF 
    670670         (##core#inline "C_substring_copy" str str2 0 n 0)
    671671         str2) ) )
    672672    (lambda (#!optional n (p ##sys#standard-input))
    673       (##sys#check-port p 'read-u8vector)
     673      (##sys#check-port* p 'read-u8vector)
    674674      (cond (n (##sys#check-exact n 'read-u8vector)
    675675               (let* ((str (##sys#allocate-vector n #t #f #t))
    676676                      (n2 (##sys#read-string! n str p 0)) )

  • tcp.scm 

    diff --git a/tcp.scm b/tcp.scm
index c8e1bd7..1853092 100644
    a b EOF 
    629629        (error '##sys#tcp-port->fileno "argument does not appear to be a TCP port" p))))
    630630
    631631(define (tcp-addresses p)
    632   (##sys#check-port p 'tcp-addresses)
     632  (##sys#check-port* p 'tcp-addresses)
    633633  (let ((fd (##sys#tcp-port->fileno p)))
    634634    (values
    635635     (or (##net#getsockname fd)
    … … EOF 
    642642          (##sys#string-append "cannot compute remote address - " strerror) p) ) ) ) )
    643643
    644644(define (tcp-port-numbers p)
    645   (##sys#check-port p 'tcp-port-numbers)
     645  (##sys#check-port* p 'tcp-port-numbers)
    646646  (let ((fd (##sys#tcp-port->fileno p)))
    647647    (values
    648648     (or (##net#getsockport fd)
    … … EOF 
    665665    port) )
    666666
    667667(define (tcp-abandon-port p)
    668   (##sys#check-port p 'tcp-abandon-port)
     668  (##sys#check-port* p 'tcp-abandon-port)
    669669  (##sys#setislot
    670670   (##sys#port-data p)
    671671   (if (##sys#slot p 1) 1 2)

  • tests/port-tests.scm 

    diff --git a/tests/port-tests.scm b/tests/port-tests.scm
index 7279541..ee562c2 100644
    a b  
    1 (require-extension srfi-1 ports utils)
     1(require-extension srfi-1 ports utils srfi-4 extras tcp posix)
    22
    33(define *text* #<<EOF
    44this is a test
    … … EOF 
    9999         (copy-port (current-input-port) (current-output-port)))))))
    100100
    101101(delete-file "compiler.scm.2")
     102
     103(define-syntax check
     104  (syntax-rules ()
     105    ((_ (expr-head expr-rest ...))
     106     (check 'expr-head (expr-head expr-rest ...)))
     107    ((_ name expr)
     108     (let ((okay (list 'okay)))
     109       (assert
     110        (eq? okay
     111             (condition-case
     112                 (begin (print* name "...")
     113                        (flush-output)
     114                        (let ((output expr))
     115                          (printf "FAIL [ ~S ]\n" output)))
     116               ((exn i/o file) (printf "OK\n") okay))))))))
     117
     118(define proc (process-fork (lambda () (tcp-accept (tcp-listen 8080)))))
     119
     120(on-exit (lambda () (handle-exceptions exn #f (process-signal proc))))
     121
     122(print "\n\nProcedures check on TCP ports being closed\n")
     123
     124(receive (in out)
     125  (let lp ()
     126    (condition-case (tcp-connect "localhost" 8080)
     127      ((exn i/o net) (lp))))
     128  (close-output-port out)
     129  (close-input-port in)
     130  (check (tcp-addresses in))
     131  (check (tcp-port-numbers in))
     132  (check (tcp-abandon-port in)))        ; Not sure about abandon-port
     133
     134(print "\n\nProcedures check on output ports being closed\n")
     135
     136(call-with-output-file "/dev/null"
     137  (lambda (out)
     138    (close-output-port out)
     139    (check (write '(foo) out))
     140    (check (fprintf out "blabla"))
     141    (check "print-call-chain" (begin (print-call-chain out) (void)))
     142    (check (print-error-message (make-property-condition 'exn 'message "foo") out))
     143    (check "print" (with-output-to-port out
     144                     (lambda () (print "foo"))))
     145    (check "print*" (with-output-to-port out
     146                      (lambda () (print* "foo"))))
     147    (check (display "foo" out))
     148    (check (terminal-port? out)) ; Calls isatty() on C_SCHEME_FALSE?
     149    (check (newline out))
     150    (check (write-char #\x out))
     151    (check (write-line "foo" out))
     152    (check (write-u8vector '#u8(1 2 3) out))
     153    (check (port->fileno out))
     154    (check (flush-output out))
     155    (check (file-test-lock out))
     156    (check (file-lock out))
     157    (check (file-lock/blocking out))
     158    (check (write-byte 120 out))
     159    (check (write-string "foo" #f out))))
     160
     161(print "\n\nProcedures check on input ports being closed\n")
     162(call-with-input-file "/dev/zero"
     163  (lambda (in)
     164    (close-input-port in)
     165    (check (read in))
     166    (check (read-char in))
     167    (check (char-ready? in))
     168    (check (peek-char in))
     169    (check (port->fileno in))
     170    (check (terminal-port? in)) ; Calls isatty() on C_SCHEME_FALSE?
     171    (check (read-line in 5))
     172    (check (read-u8vector 5 in))
     173    (check "read-u8vector!" (let ((dest (make-u8vector 5)))
     174                              (read-u8vector! 5 dest in)))
     175    (check (file-test-lock in))
     176    (check (file-lock in))
     177    (check (file-lock/blocking in))
     178    (check (read-byte in))
     179    (check (read-token (constantly #t) in))
     180    (check (read-string 10 in))
     181    (check "read-string!" (let ((buf (make-string 10)))
     182                            (read-string! 10 buf in) buf))))
     183 No newline at end of file