diff --git a/collects/rackunit/private/gui/controller.rkt b/collects/rackunit/private/gui/controller.rkt index 16ba57fd0f..9d45086d39 100644 --- a/collects/rackunit/private/gui/controller.rkt +++ b/collects/rackunit/private/gui/controller.rkt @@ -16,13 +16,18 @@ ;; The model currently displayed in the Details view, of #f is none. (define-notify selected-model (new notify-box% (value #f))) + ;; locked? : (notify-box boolean) + (define-notify locked? (new notify-box% (value #f))) + ;; view : #f or view<%> (define view #f) ;; check-ready : -> void (define/private (check-ready) (unless view - (error 'racunit "The RacUnit GUI is no longer running."))) + (error 'racunit "The RacUnit GUI is no longer running.")) + (when (get-locked?) + (error 'racunit "The RacUnit GUI is locked and not accepting tests."))) ;; create-model : test suite<%>/#f -> result<%> (define/public (create-model test parent) @@ -47,7 +52,7 @@ ;; on-model-status-change : model<%> -> void (define/public (on-model-status-change model) - (check-ready) + ;; (check-ready) ;; allow completion of tests to change status (send view queue-for-update model) (let [(parent (send model get-parent))] (when parent (send parent on-child-status-change model)))) diff --git a/collects/rackunit/private/gui/interfaces.rkt b/collects/rackunit/private/gui/interfaces.rkt index 004a08628f..adcff8f9d5 100644 --- a/collects/rackunit/private/gui/interfaces.rkt +++ b/collects/rackunit/private/gui/interfaces.rkt @@ -14,7 +14,10 @@ create-model on-model-status-change register-view - on-view-shutdown)) + on-view-shutdown + + ;; field: locked? + )) ;; result ;; Represents a test (case or suite) together with the state associated diff --git a/collects/rackunit/private/gui/view.rkt b/collects/rackunit/private/gui/view.rkt index c966a7c173..84aec27b81 100644 --- a/collects/rackunit/private/gui/view.rkt +++ b/collects/rackunit/private/gui/view.rkt @@ -1,6 +1,7 @@ #lang racket/base (require racket/class unstable/class-iop + unstable/gui/notify racket/list racket/gui framework @@ -276,6 +277,7 @@ still be there, just not visible? (inherit get-help-menu get-width get-height + get-menu-bar get-area-container) (define-syntax override-false @@ -306,6 +308,14 @@ still be there, just not visible? (super-new (width width) (height height)) (send (get-help-menu) delete) + (let ([racunit-menu + (new menu% + (label "RacUnit") + (parent (get-menu-bar)))]) + (menu-option/notify-box racunit-menu + "Lock" + (get-field locked? controller))) + (define view (new view% (controller controller)