suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Get rid of `combine-outputs' which isn't working well: since it's a

Browse Source 
thread, then when mzscheme dies (for example, when there's an error
starting the server) it will kill the thread before it shows any output,
so nothing is shown.  Instead, write to both ports directly.

svn: r16194
This commit is contained in:
Eli Barzilay 2009-10-01 05:26:48 +00:00
parent f58882b4d1
commit a2565bb873
1 changed files with 20 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
collects/handin-server/private/logger.ss
View File

@ -18,19 +18,6 @@
(or (current-session) '-) (or (current-session) '-)
(date->string (seconds->date (current-seconds)) #t)))) (date->string (seconds->date (current-seconds)) #t))))
(define (combine-outputs o1 o2)
(let-values ([(i o) (make-pipe)])
(thread
(lambda ()
(let loop ()
(let ([line (read-bytes-line i)])
(if (eof-object? line)
(begin (close-output-port o1) (close-output-port o2))
(begin (write-bytes line o1) (newline o1) (flush-output o1)
(write-bytes line o2) (newline o2) (flush-output o2)
(loop)))))))
o))
;; Implement a logger by making the current-error-port show prefix tags and ;; Implement a logger by making the current-error-port show prefix tags and
;; output the line on the output port ;; output the line on the output port
(define (make-logger-port out log) (define (make-logger-port out log)
@ -38,31 +25,36 @@
(open-output-nowhere) (open-output-nowhere)
(let ([prompt? #t] (let ([prompt? #t]
[sema (make-semaphore 1)] [sema (make-semaphore 1)]
[outp (cond [(not log) out] [outps (filter values (list out log))])
[(not out) log]
[else (combine-outputs out log)])])
(make-output-port (make-output-port
'logger-output 'logger-output
outp (car outps)
(lambda (buf start end imm? break?) (lambda (buf start end imm? break?)
(dynamic-wind (dynamic-wind
(lambda () (semaphore-wait sema)) (lambda () (semaphore-wait sema))
(lambda () (lambda ()
(if (= start end) (if (= start end)
(begin (flush-output outp) 0) (begin (for-each flush-output outps) 0)
(let ([nl (regexp-match-positions #rx#"\n" buf start end)]) (let ([nl (regexp-match-positions #rx#"\n" buf start end)])
;; may be problematic if this hangs... ;; may be problematic if this hangs...
(when prompt? (display (prefix) outp) (set! prompt? #f)) (when prompt?
(if (not nl) (let ([pfx (prefix)])
(write-bytes-avail* buf outp start end) (for ([p (in-list outps)]) (display pfx p)))
(let* ([nl (cdar nl)] (set! prompt? #f))
[l (write-bytes-avail* buf outp start nl)]) (let* ([nl (if nl (cdar nl) end)]
(when (= l (- nl start)) [ls (for/list ([p (in-list outps)])
;; pre-newline part written (write-bytes-avail* buf p start nl))]
(flush-output outp) (set! prompt? #t)) [l (car ls)])
l))))) (when (and (pair? (cdr ls))
(not (equal? (car ls) (cadr ls))))
(display "WARNING: incomplete write to log file\n"
(car outps)))
(when (and nl (= l (- nl start)))
;; pre-newline part written
(map flush-output outps) (set! prompt? #t))
l))))
(lambda () (semaphore-post sema)))) (lambda () (semaphore-post sema))))
(lambda () (close-output-port outp)))))) (lambda () (map close-output-port outps))))))
;; Install this wrapper as the current error port ;; Install this wrapper as the current error port
(provide install-logger-port) (provide install-logger-port)