| ︙ | | | ︙ | |
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
|
0))
(if (args:get-arg "-h")
(begin
(print help)
(exit)))
(if (not (setup-for-run))
(begin
(print "Failed to find megatest.config, exiting")
(exit 1)))
(define *dbdir* (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
(define *dbstruct-local* (make-dbr:dbstruct path: *dbdir*
local: #t))
|
|
|
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
|
0))
(if (args:get-arg "-h")
(begin
(print help)
(exit)))
(if (not (launch:setup-for-run))
(begin
(print "Failed to find megatest.config, exiting")
(exit 1)))
(define *dbdir* (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
(define *dbstruct-local* (make-dbr:dbstruct path: *dbdir*
local: #t))
|
| ︙ | | | ︙ | |
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
|
(define *tests-sort-options* (vector (vector "Sort +a" 'testname "ASC")
(vector "Sort -a" 'testname "DESC")
(vector "Sort +t" 'event_time "ASC")
(vector "Sort -t" 'event_time "DESC")
(vector "Sort +s" 'statestatus "ASC")
(vector "Sort -s" 'statestatus "DESC")))
;; Don't forget to adjust the >= below if you add to the sort-options above
(define (next-sort-option)
(if (>= *tests-sort-reverse* 5)
(set! *tests-sort-reverse* 0)
(set! *tests-sort-reverse* (+ *tests-sort-reverse* 1)))
*tests-sort-reverse*)
(define (get-curr-sort)
(vector-ref *tests-sort-options* *tests-sort-reverse*))
(define *tests-sort-reverse* 3)
|
>
>
>
>
>
>
>
>
>
>
>
>
>
<
|
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
|
(define *tests-sort-options* (vector (vector "Sort +a" 'testname "ASC")
(vector "Sort -a" 'testname "DESC")
(vector "Sort +t" 'event_time "ASC")
(vector "Sort -t" 'event_time "DESC")
(vector "Sort +s" 'statestatus "ASC")
(vector "Sort -s" 'statestatus "DESC")))
(define *tests-sort-type-index* '(("+testname" 0)
("-testname" 1)
("+event_time" 2)
("-event_time" 3)
("+statestatus" 4)
("-statestatus" 5)))
;; Don't forget to adjust the >= below if you add to the sort-options above
(define (next-sort-option)
(if (>= *tests-sort-reverse* 5)
(set! *tests-sort-reverse* 0)
(set! *tests-sort-reverse* (+ *tests-sort-reverse* 1)))
*tests-sort-reverse*)
(define *tests-sort-reverse*
(let ((t-sort (assoc (configf:lookup *configdat* "dashboard" "testsort") *tests-sort-type-index*)))
(if t-sort
(cadr t-sort)
3)))
(define (get-curr-sort)
(vector-ref *tests-sort-options* *tests-sort-reverse*))
(define *hide-empty-runs* #f)
(define *hide-not-hide* #t) ;; toggle for hide/not hide
(define *hide-not-hide-button* #f)
(define *hide-not-hide-tabs* #f)
(define *current-tab-number* 0)
(define *updaters* (make-hash-table))
|
| ︙ | | | ︙ | |
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
|
(testname (db:test-get-testname test))
(itempath (db:test-get-item-path test))
(testfullname (test:test-get-fullname test))
(teststatus (db:test-get-status test))
(teststate (db:test-get-state test))
;;(teststart (db:test-get-event_time test))
(runtime (db:test-get-run_duration test))
(buttontxt (if (equal? teststate "COMPLETED") teststatus teststate))
(button (vector-ref columndat rown))
(color (car (gutils:get-color-for-state-status teststate teststatus)))
(curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR"))
(curr-title (vector-ref buttondat 2))) ;; (iup:attribute button "TITLE")))
(if (not (equal? curr-color color))
(iup:attribute-set! button "BGCOLOR" color))
(if (not (equal? curr-title buttontxt))
|
>
|
>
>
>
>
>
|
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
|
(testname (db:test-get-testname test))
(itempath (db:test-get-item-path test))
(testfullname (test:test-get-fullname test))
(teststatus (db:test-get-status test))
(teststate (db:test-get-state test))
;;(teststart (db:test-get-event_time test))
(runtime (db:test-get-run_duration test))
(buttontxt (cond
((equal? teststate "COMPLETED") teststatus)
((and (equal? teststate "NOT_STARTED")
(member teststatus '("ZERO_ITEMS" "BLOCKED" "PREQ_FAIL" "PREQ_DISCARDED" "KEEP_TRYING" "TEN_STRIKES")))
teststatus)
(else
teststate)))
(button (vector-ref columndat rown))
(color (car (gutils:get-color-for-state-status teststate teststatus)))
(curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR"))
(curr-title (vector-ref buttondat 2))) ;; (iup:attribute button "TITLE")))
(if (not (equal? curr-color color))
(iup:attribute-set! button "BGCOLOR" color))
(if (not (equal? curr-title buttontxt))
|
| ︙ | | | ︙ | |
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
|
(begin
(hash-table-set! tests-draw-state 'first-time #f)
(hash-table-set! tests-draw-state 'scalef 8)
(hash-table-set! tests-draw-state 'tests-info (make-hash-table))
(hash-table-set! tests-draw-state 'selected-tests (make-hash-table))
;; set these
(hash-table-set! tests-draw-state 'test-browse-xoffset 20) ;; (- 0 (* (/ sizex 2) (* 8 xadj))))
(hash-table-set! tests-draw-state 'test-browse-yoffset 20))) ;; (- 0 (* (/ sizey 2) (* 8 (- 1 yadj)))))))
(let* ((scalef (hash-table-ref/default tests-draw-state 'scalef 8))
(test-browse-xoffset (hash-table-ref tests-draw-state 'test-browse-xoffset))
(test-browse-yoffset (hash-table-ref tests-draw-state 'test-browse-yoffset))
(xtorig (+ test-browse-xoffset (* (/ sizex 2) scalef (- 0.5 xadj)))) ;; (- xadj 1))))
(ytorig (+ test-browse-yoffset (* (/ sizey 2) scalef (- yadj 0.5))))
(boxw 90)
(boxh 25)
(gapx 20)
(gapy 30)
(tests-hash (hash-table-ref tests-draw-state 'tests-info))
(selected-tests (hash-table-ref tests-draw-state 'selected-tests )))
;; (print "sizex: " sizex " sizey: " sizey " font: " (canvas-font cnv) " originx: " originx " originy: " originy " xtorig: " xtorig " ytorig: " ytorig " xadj: " xadj " yadj: " yadj)
(let loop ((hed (car (reverse sorted-testnames)))
(tal (cdr (reverse sorted-testnames)))
(llx xtorig)
(lly ytorig)
(urx (+ xtorig boxw))
(ury (+ ytorig boxh)))
; (print "hed " hed " llx " llx " lly " lly " urx " urx " ury " ury)
(canvas-text! cnv (+ llx 5)(+ lly 5) hed) ;; (conc testname " (" xtorig "," ytorig ")"))
(canvas-rectangle! cnv llx urx lly ury)
(if (hash-table-ref/default selected-tests hed #f)
(canvas-box! cnv llx (+ llx 5) lly (+ lly 5)))
(hash-table-set! tests-hash hed (list llx urx (- sizey ury)(- sizey lly))) ;; NB// Swap ury and lly
(if (not (null? tal))
;; leave a column of space to the right to list items
(let ((have-room
(if #t ;; put "auto" here where some form of auto rearanging can be done
(> (* 3 (+ boxw gapx)) (- urx xtorig))
(< urx (- sizex boxw gapx boxw))))) ;; is there room for another column?
(loop (car tal)
(cdr tal)
(if have-room (+ llx boxw gapx) xtorig) ;; have room,
(if have-room lly (+ lly boxh gapy))
(if have-room (+ urx boxw gapx) (+ xtorig boxw))
(if have-room ury (+ ury boxh gapy)))))))))
;;======================================================================
;; R U N C O N T R O L S
;;======================================================================
;;
;; A gui for launching tests
;;
|
|
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
|
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
|
(begin
(hash-table-set! tests-draw-state 'first-time #f)
(hash-table-set! tests-draw-state 'scalef 8)
(hash-table-set! tests-draw-state 'tests-info (make-hash-table))
(hash-table-set! tests-draw-state 'selected-tests (make-hash-table))
;; set these
(hash-table-set! tests-draw-state 'test-browse-xoffset 20) ;; (- 0 (* (/ sizex 2) (* 8 xadj))))
(hash-table-set! tests-draw-state 'test-browse-yoffset 20) ;; (- 0 (* (/ sizey 2) (* 8 (- 1 yadj)))))))
(dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames))
(dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames))
))
;;======================================================================
;; R U N C O N T R O L S
;;======================================================================
;;
;; A gui for launching tests
;;
|
| ︙ | | | ︙ | |
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
|
(default-cmd (car cmds-list)))
(iuplistbox-fill-list lb cmds-list selected-item: default-cmd)
(dboard:data-set-command! *data* default-cmd)
lb)))
(iup:frame
#:title "Runname"
(let* ((default-run-name (conc "ww" (seconds->work-week/day (current-seconds))))
(tb (iup:textbox #:expand "HORIZONTAL"
#:action (lambda (obj val txt)
;; (print "obj: " obj " val: " val " unk: " unk)
(dboard:data-set-run-name! *data* txt) ;; (iup:attribute obj "VALUE"))
(dashboard:update-run-command))
#:value default-run-name))
(lb (iup:listbox #:expand "HORIZONTAL"
|
|
|
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
|
(default-cmd (car cmds-list)))
(iuplistbox-fill-list lb cmds-list selected-item: default-cmd)
(dboard:data-set-command! *data* default-cmd)
lb)))
(iup:frame
#:title "Runname"
(let* ((default-run-name (seconds->work-week/day (current-seconds)))
(tb (iup:textbox #:expand "HORIZONTAL"
#:action (lambda (obj val txt)
;; (print "obj: " obj " val: " val " unk: " unk)
(dboard:data-set-run-name! *data* txt) ;; (iup:attribute obj "VALUE"))
(dashboard:update-run-command))
#:value default-run-name))
(lb (iup:listbox #:expand "HORIZONTAL"
|
| ︙ | | | ︙ | |
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
|
(dashboard:update-run-command))))))))
(iup:frame
#:title "Tests and Tasks"
(let* ((updater #f)
(last-xadj 0)
(last-yadj 0)
(canvas-obj
(iup:canvas #:action (make-canvas-action
(lambda (cnv xadj yadj)
(if (not updater)
(set! updater (lambda (xadj yadj)
;; (print "cnv: " cnv " x: " x " y: " y)
(dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames))))
(updater xadj yadj)
(set! last-xadj xadj)
(set! last-yadj yadj)))
;; Following doesn't work
;; #:wheel-cb (make-canvas-action
;; (lambda (cnv xadj yadj)
;; ;; (print "cnv: " cnv " x: " x " y: " y)
;; (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames)))
;; #:size "50x50"
#:expand "YES"
#:scrollbar "YES"
#:posx "0.5"
#:posy "0.5"
#:button-cb (lambda (obj btn pressed x y status)
;; (print "obj: " obj)
(let ((tests-info (hash-table-ref tests-draw-state 'tests-info))
(selected-tests (hash-table-ref tests-draw-state 'selected-tests)))
;; (print "x\ty\tllx\tlly\turx\tury")
(for-each (lambda (test-name)
(let* ((rec-coords (hash-table-ref tests-info test-name))
(llx (list-ref rec-coords 0))
(urx (list-ref rec-coords 1))
(lly (list-ref rec-coords 2))
(ury (list-ref rec-coords 3)))
;; (print x "\t" y "\t" llx "\t" lly "\t" urx "\t" ury "\t" test-name " "
(if (and (eq? pressed 1)
(> x llx)
(> y lly)
(< x urx)
(< y ury))
(let ((patterns (string-split (iup:attribute test-patterns-textbox "VALUE"))))
(let* ((selected (not (member test-name patterns)))
(newpatt-list (if selected
(cons test-name patterns)
(delete test-name patterns)))
(newpatt (string-intersperse newpatt-list "\n")))
;; (if cnv-obj
;; (dashboard:draw-tests cnv-obj 0 0 tests-draw-state sorted-testnames))
(iup:attribute-set! obj "REDRAW" "ALL")
(hash-table-set! selected-tests test-name selected)
(iup:attribute-set! test-patterns-textbox "VALUE" newpatt)
(dboard:data-set-test-patts! *data* (dboard:lines->test-patt newpatt))
(dashboard:update-run-command)
(if updater (updater last-xadj last-yadj)))))))
(hash-table-keys tests-info)))))))
canvas-obj)))
;; (print "obj: " obj " btn: " btn " pressed: " pressed " x: " x " y: " y " status: " status))
(iup:frame
#:title "Logs" ;; To be replaced with tabs
(let ((logs-tb (iup:textbox #:expand "YES"
#:multiline "YES")))
(dboard:data-set-logs-textbox! *data* logs-tb)
logs-tb))))))
|
>
|
|
|
|
|
|
|
<
|
|
>
>
>
|
|
|
>
>
>
|
>
>
|
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
|
(dashboard:update-run-command))))))))
(iup:frame
#:title "Tests and Tasks"
(let* ((updater #f)
(last-xadj 0)
(last-yadj 0)
(the-cnv #f)
(canvas-obj
(iup:canvas #:action (make-canvas-action
(lambda (cnv xadj yadj)
(if (not updater)
(set! updater (lambda (xadj yadj)
;; (print "cnv: " cnv " xadj: " xadj " yadj: " yadj)
(dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames)
(set! last-xadj xadj)
(set! last-yadj yadj))))
(updater xadj yadj)
(set! the-cnv cnv)
))
;; Following doesn't work
#:wheel-cb (lambda (obj step x y dir) ;; dir is 4 for up and 5 for down. I think.
(let ((xadj last-xadj)
(yadj (+ last-yadj (if (> step 0)
-0.01
0.01))))
;; (print "step: " step " x: " x " y: " y " dir: \"" dir "\"")
;; (print "the-cnv: " the-cnv " obj: " obj " xadj: " xadj " yadj: " yadj " dir: " dir)
(if the-cnv
(dashboard:draw-tests the-cnv xadj yadj tests-draw-state sorted-testnames))
(set! last-xadj xadj)
(set! last-yadj yadj)
))
;; #:size "50x50"
#:expand "YES"
#:scrollbar "YES"
#:posx "0.5"
#:posy "0.5"
#:button-cb (lambda (obj btn pressed x y status)
;; (print "obj: " obj)
(let ((tests-info (hash-table-ref tests-draw-state 'tests-info))
(selected-tests (hash-table-ref tests-draw-state 'selected-tests)))
;; (print "x\ty\tllx\tlly\turx\tury")
(for-each (lambda (test-name)
(let* ((rec-coords (hash-table-ref tests-info test-name))
(llx (list-ref rec-coords 0))
(urx (list-ref rec-coords 1))
(lly (list-ref rec-coords 2))
(ury (list-ref rec-coords 3)))
;; (print x "\t" y "\t" llx "\t" lly "\t" urx "\t" ury "\t" test-name " "
(if (and (eq? pressed 1)
(> x llx)
(> y lly)
(< x urx)
(< y ury))
(let ((patterns (string-split (iup:attribute test-patterns-textbox "VALUE"))))
(let* ((selected (not (member test-name patterns)))
(newpatt-list (if selected
(cons test-name patterns)
(delete test-name patterns)))
(newpatt (string-intersperse newpatt-list "\n")))
;; (if cnv-obj
;; (dashboard:draw-tests cnv-obj 0 0 tests-draw-state sorted-testnames))
(iup:attribute-set! obj "REDRAW" "ALL")
(hash-table-set! selected-tests test-name selected)
(iup:attribute-set! test-patterns-textbox "VALUE" newpatt)
(dboard:data-set-test-patts! *data* (dboard:lines->test-patt newpatt))
(dashboard:update-run-command)
(if updater (updater last-xadj last-yadj)))))))
(hash-table-keys tests-info)))))))
canvas-obj)))
;; (print "obj: " obj " btn: " btn " pressed: " pressed " x: " x " y: " y " status: " status))
(iup:frame
#:title "Logs" ;; To be replaced with tabs
(let ((logs-tb (iup:textbox #:expand "YES"
#:multiline "YES")))
(dboard:data-set-logs-textbox! *data* logs-tb)
logs-tb))))))
|
| ︙ | | | ︙ | |
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
|
;;(iup:textbox #:size "60x15" #:fontsize "10" #:value "%"
;; #:action (lambda (obj unk val)
;; (mark-for-update)
;; (update-search "item-name" val))
))
(iup:vbox
(iup:hbox
(iup:button "Sort -t" #:action (lambda (obj)
(next-sort-option)
(iup:attribute-set! obj "TITLE" (vector-ref (vector-ref *tests-sort-options* *tests-sort-reverse*) 0))
(mark-for-update)))
(iup:button "HideEmpty" #:action (lambda (obj)
(set! *hide-empty-runs* (not *hide-empty-runs*))
(iup:attribute-set! obj "TITLE" (if *hide-empty-runs* "+HideE" "-HideE"))
(mark-for-update)))
(let ((hideit (iup:button "HideTests" #:action (lambda (obj)
(set! *hide-not-hide* (not *hide-not-hide*))
(iup:attribute-set! obj "TITLE" (if *hide-not-hide* "HideTests" "NotHide"))
|
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
|
;;(iup:textbox #:size "60x15" #:fontsize "10" #:value "%"
;; #:action (lambda (obj unk val)
;; (mark-for-update)
;; (update-search "item-name" val))
))
(iup:vbox
(iup:hbox
(let* ((cmds-list '("+testname" "-testname" "+event_time" "-event_time" "+statestatus" "-statestatus"))
(lb (iup:listbox #:expand "HORIZONTAL"
#:dropdown "YES"
#:action (lambda (obj val index lbstate)
(set! *tests-sort-reverse* index)
(mark-for-update))))
(default-cmd (car (list-ref *tests-sort-type-index* *tests-sort-reverse*))))
(iuplistbox-fill-list lb cmds-list selected-item: default-cmd)
(mark-for-update)
;; (set! *tests-sort-reverse* *tests-sort-reverse*0)
lb)
;; (iup:button "Sort -t" #:action (lambda (obj)
;; (next-sort-option)
;; (iup:attribute-set! obj "TITLE" (vector-ref (vector-ref *tests-sort-options* *tests-sort-reverse*) 0))
;; (mark-for-update)))
(iup:button "HideEmpty" #:action (lambda (obj)
(set! *hide-empty-runs* (not *hide-empty-runs*))
(iup:attribute-set! obj "TITLE" (if *hide-empty-runs* "+HideE" "-HideE"))
(mark-for-update)))
(let ((hideit (iup:button "HideTests" #:action (lambda (obj)
(set! *hide-not-hide* (not *hide-not-hide*))
(iup:attribute-set! obj "TITLE" (if *hide-not-hide* "HideTests" "NotHide"))
|
| ︙ | | | ︙ | |
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
|
;; Move this stuff to db.scm? I'm not sure that is the right thing to do...
;;
(define *last-db-update-time* (file-modification-time *db-file-path*)) ;; (conc *toppath* "/db/main.db")))
(define *last-recalc-ended-time* 0)
(define (dashboard:been-changed)
(> (file-modification-time *db-file-path* *last-db-update-time*)))
(define (dashboard:set-db-update-time)
(set! *last-db-update-time* (file-modification-time *db-file-path*)))
(define (dashboard:recalc modtime please-update-buttons last-db-update-time)
(or please-update-buttons
(and (> (current-milliseconds)(+ *last-recalc-ended-time* 150))
|
|
|
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
|
;; Move this stuff to db.scm? I'm not sure that is the right thing to do...
;;
(define *last-db-update-time* (file-modification-time *db-file-path*)) ;; (conc *toppath* "/db/main.db")))
(define *last-recalc-ended-time* 0)
(define (dashboard:been-changed)
(> (file-modification-time *db-file-path*) *last-db-update-time*))
(define (dashboard:set-db-update-time)
(set! *last-db-update-time* (file-modification-time *db-file-path*)))
(define (dashboard:recalc modtime please-update-buttons last-db-update-time)
(or please-update-buttons
(and (> (current-milliseconds)(+ *last-recalc-ended-time* 150))
|
| ︙ | | | ︙ | |
1542
1543
1544
1545
1546
1547
1548
1549
1550
|
(begin
(dashboard:run-update x)
(mutex-lock! *update-mutex*)
(set! *update-is-running* #f)
(mutex-unlock! *update-mutex*))))
1))))
(iup:main-loop)
(db:close-all *dbstruct-local*)
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
|
|
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
|
(begin
(dashboard:run-update x)
(mutex-lock! *update-mutex*)
(set! *update-is-running* #f)
(mutex-unlock! *update-mutex*))))
1))))
(let ((th1 (make-thread (lambda ()
(thread-sleep! 1)
(set! *please-update-buttons* #t)
(dashboard:run-update 1)) "update buttons once"))
;; need to wait for first *update-is-running* #t
;; (let loop ()
;; (mutex-lock! *update-mutex*)
;; (if *update-is-running*
;; (begin
;; (set! *please-update-buttons* #t)
;; (mark-for-update)
;; (print "Did redraw trigger")) "First update after startup")
;; (mutex-unlock! *update-mutex*)
;; (thread-sleep! 1)
;; (if (not *please-update-buttons*)
;; (loop))))))
(th2 (make-thread iup:main-loop "Main loop")))
(thread-start! th1)
(thread-start! th2)
(thread-join! th2))
;; (iup:main-loop)(db:close-all *dbstruct-local*)
|