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

explicit flush after output intended to report progress

Browse Source
This commit is contained in:
Matthew Flatt 2013-07-20 07:10:30 -06:00
parent 949474abca
commit 4d75690aff
5 changed files with 49 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
pkgs/distro-build/drive-clients.rkt
View File

@ -91,6 +91,7 @@
(displayln (apply ~a #:separator " "
(map (lambda (p) (if (path? p) (path->string p) p))
(cons exe args))))
(flush-output)
(apply system* exe args))
(define (system*/string . args)
@ -153,6 +154,7 @@
(client-name c))))
(when vbox
(printf "Starting VirtualBox machine ~s\n" vbox)
(flush-output)
(case (vbox-state vbox)
[(running) (void)]
[(paused) (vbox-control vbox "resume")]
@ -169,6 +171,7 @@
(define vbox (get-opt c '#:vbox))
(when vbox
(printf "Stopping VirtualBox machine ~s\n" vbox)
(flush-output)
(vbox-control vbox "savestate")
(unless (eq? (vbox-state vbox) 'saved)
(error 'start-client "virtual machine isn't in the expected saved state: ~s" c))))
@ -355,7 +358,7 @@
(parameterize ([current-custodian cust])
(thread (lambda ()
(sleep (* timeout-factor timeout))
(printf "timeout for ~s\n" (client-name c))
(eprintf "timeout for ~s\n" (client-name c))
;; try nice interrupt, first:
(set! timeout? #t)
(break-thread orig-thread)
@ -377,6 +380,7 @@
(define log-file (build-path log-dir (client-name c)))
(make-directory* log-dir)
(printf "Logging build: ~a\n" log-file)
(flush-output)
(define (go)
(define p (open-output-file log-file
#:exists 'truncate/replace))

3
pkgs/distro-build/manage-snapshots.rkt
View File

@ -30,6 +30,7 @@
(when (link-exists? link-file)
(printf "Removing old \"current\" link\n")
(flush-output)
(delete-file link-file))
(define (get-snapshots)
@ -46,9 +47,11 @@
(list-tail (sort snapshots string>?) n)))
(for ([s (in-list remove-snapshots)])
(printf "Removing snapshot ~a\n" s)
(flush-output)
(delete-directory/files (build-path snapshots-dir s)))))
(printf "Creating \"current\" link\n")
(flush-output)
(make-file-or-directory-link current-snapshot link-file)
(make-download-page (build-path site-dir

3
pkgs/racket-pkgs/racket-index/setup/scribble.rkt
View File

@ -44,7 +44,8 @@
(begin
(when (verbose)
(printf (string-append " [" format-str "]\n")
arg ...))
arg ...)
(flush-output))
(log-setup-debug format-str arg ...)))
(define-serializable-struct doc (src-dir

66
racket/collects/pkg/lib.rkt
View File

@ -59,6 +59,11 @@
what
(exn-message x)))
(define (printf/flush fmt . args)
;; For status reporting, flush immediately after printing
(apply printf fmt args)
(flush-output))
(struct pkg-desc (source type name auto?))
(define (pkg-desc=? a b)
(define (->list a)
@ -589,7 +594,7 @@
(define ((remove-package quiet?) pkg-name)
(unless quiet?
(printf "Removing ~a\n" pkg-name))
(printf/flush "Removing ~a\n" pkg-name))
(define db (read-pkg-db))
(define pi (package-info pkg-name #:db db))
(match-define (pkg-info orig-pkg checksum _) pi)
@ -1060,7 +1065,7 @@
#:install-conversation [install-conversation #f]
#:update-conversation [update-conversation #f]
descs)
(define download-printf (if quiet? void printf))
(define download-printf (if quiet? void printf/flush))
(define check-sums? (not ignore-checksums?))
(define all-db (merge-pkg-dbs))
(define path-pkg-cache (make-hash))
@ -1081,17 +1086,17 @@
(cadddr ud)))))
(define (show-dependencies deps update? auto? conversation)
(unless quiet?
(printf "The following ~a packages are listed as dependencies of ~a~a:~a\n"
(if update? "out-of-date" "uninstalled")
pkg-name
(if (or auto? (eq? conversation 'always-yes))
(format "\nand they will be ~a~a"
(if auto? "automatically " "")
(if update? "updated" "installed"))
"")
(if update?
(format-deps deps)
(format-list deps)))))
(printf/flush "The following ~a packages are listed as dependencies of ~a~a:~a\n"
(if update? "out-of-date" "uninstalled")
pkg-name
(if (or auto? (eq? conversation 'always-yes))
(format "\nand they will be ~a~a"
(if auto? "automatically " "")
(if update? "updated" "installed"))
"")
(if update?
(format-deps deps)
(format-list deps)))))
(define simultaneous-installs
(for/hash ([i (in-list infos)])
(values (install-info-name i) (install-info-directory i))))
@ -1545,12 +1550,15 @@
(define to-update (filter-map (update-package download-printf db) pkgs))
(cond
[(empty? to-update)
(printf "No updates available\n")
(unless quiet?
(printf/flush "No updates available\n"))
'skip]
[else
(printf "Updating:\n")
(for ([u (in-list to-update)])
(printf " ~a\n" (pkg-desc-name u)))
(unless quiet?
(printf "Updating:\n")
(for ([u (in-list to-update)])
(printf " ~a\n" (pkg-desc-name u)))
(flush-output))
(pkg-install
#:updating? #t
#:pre-succeed (λ () (for-each (compose (remove-package quiet?) pkg-desc-name) to-update))
@ -1641,8 +1649,8 @@
(match create:format
['MANIFEST
(unless quiet?
(printf "creating manifest for ~a\n"
orig-dir))
(printf/flush "creating manifest for ~a\n"
orig-dir))
(with-output-to-file (build-path (or dest-dir dir) "MANIFEST")
#:exists 'replace
(λ ()
@ -1659,11 +1667,11 @@
[else (current-directory)]))))
(define pkg/complete (path->complete-path pkg actual-dest-dir))
(unless quiet?
(printf "packing~a into ~a\n"
(if hide-src? "" (format " ~a" dir))
(if dest-dir
pkg/complete
pkg)))
(printf/flush "packing~a into ~a\n"
(if hide-src? "" (format " ~a" dir))
(if dest-dir
pkg/complete
pkg)))
(match create:format
['tgz
(when (file-exists? pkg/complete)
@ -1702,10 +1710,10 @@
(define chk (format "~a.CHECKSUM" pkg))
(define chk/complete (path->complete-path chk actual-dest-dir))
(unless quiet?
(printf "writing package checksum to ~a\n"
(if dest-dir
chk/complete
chk)))
(printf/flush "writing package checksum to ~a\n"
(if dest-dir
chk/complete
chk)))
(with-output-to-file chk/complete
#:exists 'replace
(λ () (display (call-with-input-file pkg/complete sha1))))])))
@ -2178,7 +2186,7 @@
(define ht (hash-ref details name))
(define source (hash-ref ht 'source))
(unless quiet?
(printf "Downloading ~s\n" source))
(printf/flush "Downloading ~s\n" source))
(define-values (checksum modules deps)
(get-pkg-content (pkg-desc source
#f

3
racket/collects/setup/setup-unit.rkt
View File

@ -80,7 +80,8 @@
(define (setup-fprintf p task s . args)
(let ([task (if task (string-append task ": ") "")])
(apply fprintf p (string-append name-str ": " task s "\n") args)))
(apply fprintf p (string-append name-str ": " task s "\n") args)
(flush-output p)))
(define (setup-printf task s . args)
(apply setup-fprintf (current-output-port) task s args))