diff options
| -rw-r--r-- | guix/status.scm | 28 | ||||
| -rw-r--r-- | tests/status.scm | 33 |
2 files changed, 58 insertions, 3 deletions
diff --git a/guix/status.scm b/guix/status.scm index 070071d46f..c3c219219d 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -55,6 +55,9 @@ build build-derivation build-system + build-log-file + build-phase + build-completion download? download @@ -102,18 +105,20 @@ ;; On-going or completed build. (define-immutable-record-type <build> - (%build derivation id system log-file completion) + (%build derivation id system log-file phase completion) build? (derivation build-derivation) ;string (.drv file name) (id build-id) ;#f | integer (system build-system) ;string (log-file build-log-file) ;#f | string + (phase build-phase ;#f | symbol + set-build-phase) (completion build-completion ;#f | integer (percentage) set-build-completion)) -(define* (build derivation system #:key id log-file completion) +(define* (build derivation system #:key id log-file phase completion) "Return a new build." - (%build derivation id system log-file completion)) + (%build derivation id system log-file phase completion)) ;; On-going or completed downloads. Downloads can be stem from substitutes ;; and from "builtin:download" fixed-output derivations. @@ -144,6 +149,10 @@ (lambda (download) (string=? item (download-item download)))) +(define %phase-start-rx + ;; Match the "starting phase" message emitted by 'gnu-build-system'. + (make-regexp "^starting phase [`']([^']+)'")) + (define %percentage-line-rx ;; Things like CMake write lines like "[ 10%] gcc -c …". This regexp ;; matches them. @@ -185,6 +194,19 @@ a completion indication." (let ((done (string->number (match:substring match 1))) (total (string->number (match:substring match 3)))) (update (* 100. (/ done total)))))) + ((regexp-exec %phase-start-rx line) + => + (lambda (match) + (let ((phase (match:substring match 1)) + (build (find-build))) + (if build + (build-status + (inherit status) + (building + (cons (set-build-phase (set-build-completion build #f) + (string->symbol phase)) + (delq build (build-status-building status))))) + status)))) (else status))) diff --git a/tests/status.scm b/tests/status.scm index f3afadfcd0..01a61f7345 100644 --- a/tests/status.scm +++ b/tests/status.scm @@ -211,4 +211,37 @@ (display "@ build-succeeded foo.drv\n" port) (list first second third (get-status))))))) +(test-equal "compute-status, build phase" + (list (build-status + (building (list (build "foo.drv" "x86_64-linux" #:id 121 + #:phase 'configure)))) + (build-status + (building (list (build "foo.drv" "x86_64-linux" #:id 121 + #:phase 'configure + #:completion 50.)))) + (build-status + (building (list (build "foo.drv" "x86_64-linux" #:id 121 + #:phase 'install)))) + (build-status + (builds-completed (list (build "foo.drv" "x86_64-linux" #:id 121 + #:phase 'install))))) + (let-values (((port get-status) + (build-event-output-port (lambda (event status) + (compute-status event status + #:current-time + (const 'now)))))) + (display "@ build-started foo.drv - x86_64-linux 121\n" port) + (display "@ build-log 121 27\nstarting phase `configure'\n" port) + (display "@ build-log 121 6\nabcde!" port) + (let ((first (get-status))) + (display "@ build-log 121 20\n[50/100] building Y\n" port) + (display "@ build-log 121 6\nfghik!" port) + (let ((second (get-status))) + (display "@ build-log 121 21\n[100/100] building Z\n" port) + (display "@ build-log 121 25\nstarting phase `install'\n" port) + (display "@ build-log 121 6\nlmnop!" port) + (let ((third (get-status))) + (display "@ build-succeeded foo.drv\n" port) + (list first second third (get-status))))))) + (test-end "status") |