Re: [Chicken-users] replace signal with sigaction

[Jörg F . Wittenberger]

Alan,

I figured that you did almost have you for the process-io-ports code
I cited the other day.

It might make your live easier, if I just post the code as I'm using
it right now.

Be warned: it does one thing NOT.  When there is a bad fd encountered
while reading/writing to a fd, the read/write will be aborted by
exception.  But the port will *not* be closed.



(declare
(foreign-declare #<<EOF

#include <errno.h>
#include <sys/wait.h>
static int io_needs_restart()
{
 switch(errno) {
  case EAGAIN:
  case EINTR:
   return 1;
  default: return 0;
}
}

EOF
))

(define process-io-ports
 (let ([make-input-port make-input-port]
	[make-output-port make-output-port] 
	[make-string make-string] 
	[substring substring]
        [file-close-fd! (foreign-lambda* int ((int fd)) "return(close(fd));")]
        )
   (lambda (pid fdr fdw)
     (##sys#file-nonblocking! fdw)
     (##sys#file-nonblocking! fdr)      ; should not be required
     (let* ([buf (make-string buffer-size)]
             [buflen 0]
             [bufindex 0]
             [iclosed #f]
             [oclosed #f]
             [in
              (make-input-port
               (let-location
                ((again bool #f))
                (lambda ()
                  (when (fx>= bufindex buflen)
                        (let loop ()
                          (and (not iclosed)
                               (let ([n ((foreign-lambda*
                                          int
                                          ((int fd) (scheme-pointer buf) (int 
s) ((c-pointer bool) again))
                                          "int r = read(fd, buf, s); 
*again=(r==-1)&&io_needs_restart(); return(r);")
                                         fdr buf buffer-size (location again))])
                                 (cond
                                  (again
                                   (guard
                                    (ex (else (format (current-error-port) "read 
error ~a\n" ex)
                                              (raise ex)))
                                    (thread-wait-for-i/o! fdr #:input))
                                   (loop))
                                  ((eq? -1 n)
                                   ;; (##sys#update-errno)
                                   ;; (##sys#signal-hook #:process-error 
'process-io-read "can not read from fd" fdr strerror)
                                   (set! iclosed #t)
                                   #;(when (eq? -1 (file-close-fd! fdr))
                                   (##sys#update-errno)
                                   (##sys#signal-hook #:process-error 
'process-io-read
                                   "can not close fd input port" fdr) )
                                   (file-close-fd! fdr))
                                  (else
                                   ;; (print "[rd: " n "]")
                                   (set! buflen n)
                                   (set! bufindex 0))) ))) )
                  (if (or iclosed (fx>= bufindex buflen))
                      (end-of-file)
                      (let ([c (##core#inline "C_subchar" buf bufindex)])
                        (set! bufindex (fx+ bufindex 1))
                        c) ) ))
               (lambda ()
                (when iclosed
                  (##sys#signal-hook #:process-error "input port is 
closed" fdr))
                 #t )
               (lambda ()
                 (unless iclosed
                   (set! iclosed #t)
                   (when (eq? -1 (file-close-fd! fdr))
                     (##sys#update-errno)
                     (##sys#signal-hook #:process-error 'process-io-close
                                       "can not close fd input port" fdr) )
                  (if oclosed
                       (receive (p f s) (process-wait-for-pid pid) s)
                       (receive (p f s) (process-test-pid pid)
                          (when (eqv? p pid)
                            (set! oclosed #t)
                            (when (eq? -1 (file-close-fd! fdw))
                               (##sys#update-errno)
                               (##sys#signal-hook #:process-error 
'process-io-close
                                                  "can not close fd output 
port" fdw) ) s)))
                    ) ) ) ]
             [out
              (let-location
               ((again bool #f))
               (make-output-port
                (lambda (s)
                  (define start-time (current-milliseconds))
                  (let loop ([len (##sys#size s)]
                             [off 0])
                    (if oclosed
                        (##sys#signal-hook
                         #:process-error 'process-io-write "fd output port is 
closed" fdw)
                        (let ([n ((foreign-lambda*
                                   int
                                   ((int fd) (scheme-pointer buf) (int 
off) (int count) ((c-pointer bool) again))
                                   "int r = write(fd, ((char*)buf)+off, 
count); *again=(r==-1)&&io_needs_restart(); return(r);")
                                  fdw s off len (location again))])
                          (cond [again
                                 (guard
                                  (ex (else (format (current-error-port) "write 
error ~s\n" ex)
                                            (raise ex)))
                                  (thread-wait-for-i/o! fdw #:output))
                                 (loop len off)]
                                [(eq? -1 n)
                                 (##sys#update-errno)
                                 (##sys#signal-hook
                                  #:process-error 'process-io-write
                                  "can not write to fd" fdw len strerror) ]
                                [(fx< n len)
                                 (loop (fx- len n) (fx+ off n)) ] )
                          (process-io-update-bandwith! (##sys#size s) 
start-time) ))))
                (lambda ()
                  (unless oclosed
                          (set! oclosed #t)
                          (when (eq? -1 (file-close-fd! fdw))
                                (##sys#update-errno)
                                (##sys#signal-hook #:process-error 
'process-io-close
                                                   "can not close fd output 
port" fdw) )
                          (if iclosed
                              (receive (p f s) (process-wait-for-pid pid) s)
                              (receive (p f s) (process-test-pid pid)
                                       (when (eqv? p pid)
                                             (set! iclosed #t)
                                             (when (eq? -1 (file-close-fd! fdr))
                                                   (##sys#update-errno)
                                                   (##sys#signal-hook 
#:process-error 'process-io-close
                                                                      "can not close 
fd input port" fdr) ) s)))) ))) ] )
        (values in out) ) ) ) )