#lang scheme/base
(require (lib "pretty.ss")
(lib "match.ss")
(lib "process.ss") )
(provide
read-byte-timeout
with-output-to-file/safe
with-output-to-string
write-tree
file-in-path)
(define (port-ready? timeout port)
(sync/timeout timeout port))
(define (read-byte-timeout port timeout)
(let again ()
(if (port-ready? timeout port)
(read-byte port)
(begin
(error 'time-out "~a" timeout)
))))
(define (write-tree . args)
(apply pretty-print args))
(define (file-in-path path filename)
(let next ((p path))
(if (null? p)
(error 'file-not-in-path "~a ~a" filename path)
(let ((full (format "~a/~a" (car p) filename)))
(if (file-exists? full)
full
(next (cdr p)))))))
(define (delete-if-exists file)
(when (file-exists? file) (delete-file file)))
(define (with-output-to-file/safe file thunk)
(let ((file.bak (string-append file "~"))
(file.tmp (string-append file ".bak")))
(delete-if-exists file.tmp)
(let ((value
(with-output-to-file
file.tmp thunk)))
(delete-if-exists file.bak)
(when (file-exists? file)
(rename-file-or-directory file file.bak))
(rename-file-or-directory file.tmp file)
value)))
(define (with-output-to-string thunk)
(let ((p (open-output-string)))
(parameterize ((current-output-port p)) (thunk))
(close-output-port p)
(get-output-string p)))