Overview
Comment: | Fixed scroll wheel action on tests panel, added sort on alphanumeric to sorted-tests |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | v1.55 |
Files: | files | file ages | folders |
SHA1: |
fee756ae59fc4a066592b8b8b9342f0f |
User & Date: | matt on 2014-06-22 18:18:34 |
Other Links: | branch diff | manifest | tags |
Context
2014-06-22
| ||
19:03 | Made sort of runs on dashboard into a dropdown check-in: ea04a96df6 user: matt tags: v1.55 | |
18:18 | Fixed scroll wheel action on tests panel, added sort on alphanumeric to sorted-tests check-in: fee756ae59 user: matt tags: v1.55 | |
2014-06-19
| ||
11:35 | Fixed regression on running in read only areas where db does not exist. Made timeout long for cases where tests appear to be non-runnable. Improved chicken install script check-in: 2c06a41e7e user: mrwellan tags: v1.55, v1.5522 | |
Changes
Modified dashboard.scm from [216d0fa0d4] to [1413cda7a3].
︙ | ︙ | |||
706 707 708 709 710 711 712 | (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) | > | | | | | 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 | (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) (dcommon:draw-test cnv llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f)) ;; (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? |
︙ | ︙ | |||
809 810 811 812 813 814 815 | (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" | | | 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 | (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" |
︙ | ︙ | |||
891 892 893 894 895 896 897 | (dashboard:update-run-command)))))))) (iup:frame #:title "Tests and Tasks" (let* ((updater #f) (last-xadj 0) (last-yadj 0) | > | | | | | | | < | | > > > | | | > > > | > > | > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 | (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)))))) |
︙ | ︙ |
Modified dcommon.scm from [26f749e48f] to [e880bfbb25].
︙ | ︙ | |||
540 541 542 543 544 545 546 | ;; #:modal? #t ;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current ;; ;; #:x 'mouse ;; ;; #:y 'mouse ;; ) )))) | > > > > > > > > > > > > | 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 | ;; #:modal? #t ;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current ;; ;; #:x 'mouse ;; ;; #:y 'mouse ;; ) )))) ;;====================================================================== ;; CANVAS STUFF FOR TESTS ;;====================================================================== (define (dcommon:draw-test cnv x y w h name selected) (let* ((llx x) (lly y) (urx (+ x w)) (ury (+ y h))) (canvas-text! cnv (+ llx 5)(+ lly 5) name) ;; (conc testname " (" xtorig "," ytorig ")")) (canvas-rectangle! cnv llx urx lly ury) (if selected (canvas-box! cnv llx (+ llx 5) lly (+ lly 5))))) |
Modified tests.scm from [ffbdefa44d] to [e993f9a909].
︙ | ︙ | |||
539 540 541 542 543 544 545 | (tests:testqueue-set-priority! b-record b-priority) (if (and a-waitons (member (tests:testqueue-get-testname b-record) a-waitons)) #f ;; cannot have a which is waiting on b happening before b (if (and b-waitons (member (tests:testqueue-get-testname a-record) b-waitons)) #t ;; this is the correct order, b is waiting on a and b is before a (if (> a-priority b-priority) #t ;; if a is a higher priority than b then we are good to go | | | 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 | (tests:testqueue-set-priority! b-record b-priority) (if (and a-waitons (member (tests:testqueue-get-testname b-record) a-waitons)) #f ;; cannot have a which is waiting on b happening before b (if (and b-waitons (member (tests:testqueue-get-testname a-record) b-waitons)) #t ;; this is the correct order, b is waiting on a and b is before a (if (> a-priority b-priority) #t ;; if a is a higher priority than b then we are good to go (string-compare3 a b))))))))) ;; for each test: ;; (define (tests:filter-non-runnable run-id testkeynames testrecordshash) (let ((runnables '())) (for-each (lambda (testkeyname) |
︙ | ︙ |