Overview
| Comment: | Added rerun to rhb menu |
|---|---|
| Downloads: | Tarball | ZIP archive | SQL archive |
| Timelines: | family | ancestors | descendants | both | v1.61 |
| Files: | files | file ages | folders |
| SHA1: |
61dfefd369ae5584aba94097d164c29d |
| User & Date: | matt on 2016-06-30 04:50:18 |
| Other Links: | branch diff | manifest | tags |
Context
|
2016-06-30
| ||
| 04:57 | Added re-run of test to rhb menu check-in: a38b157d75 user: matt tags: v1.61 | |
| 04:50 | Added rerun to rhb menu check-in: 61dfefd369 user: matt tags: v1.61 | |
|
2016-06-29
| ||
| 18:10 | Refactored dashboard code to make plugging in a new vector graphics view easier check-in: 4809ab9726 user: mrwellan tags: v1.61 | |
Changes
Modified api.scm from [2bd451f23e] to [6f5014b68f].
| ︙ | ︙ | |||
164 165 166 167 168 169 170 171 172 173 174 175 176 177 | ;; TESTMETA ((testmeta-add-record) (apply db:testmeta-add-record dbstruct params)) ((testmeta-update-field) (apply db:testmeta-update-field dbstruct params)) ;; TASKS ((tasks-add) (apply tasks:add dbstruct params)) ((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct params)) ;; ARCHIVES ;; ((archive-get-allocations) ((archive-register-disk) (apply db:archive-register-disk dbstruct params)) ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params)) ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey)) | > | 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 | ;; TESTMETA ((testmeta-add-record) (apply db:testmeta-add-record dbstruct params)) ((testmeta-update-field) (apply db:testmeta-update-field dbstruct params)) ;; TASKS ((tasks-add) (apply tasks:add dbstruct params)) ((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct params)) ((tasks-get-last) (apply tasks:get-last dbstruct params)) ;; ARCHIVES ;; ((archive-get-allocations) ((archive-register-disk) (apply db:archive-register-disk dbstruct params)) ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params)) ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey)) |
| ︙ | ︙ |
Modified common.scm from [0cadf9f00f] to [62abc5daf1].
| ︙ | ︙ | |||
915 916 917 918 919 920 921 922 923 924 925 926 927 928 |
((string? proc)(system proc))
(proc (proc)))
(hash-table-for-each
vars
(lambda (var val)
(setenv var val)))
vars))
;;======================================================================
;; T I M E A N D D A T E
;;======================================================================
;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5
(define (common:hms-string->seconds tstr)
| > > > > > > > | 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 |
((string? proc)(system proc))
(proc (proc)))
(hash-table-for-each
vars
(lambda (var val)
(setenv var val)))
vars))
(define (common:run-a-command cmd)
(let ((fullcmd (conc (dtests:get-pre-command)
cmd
(dtests:get-post-command))))
(debug:print-info 02 *default-log-port* "Running command: " fullcmd)
(common:without-vars fullcmd "MT_.*")))
;;======================================================================
;; T I M E A N D D A T E
;;======================================================================
;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5
(define (common:hms-string->seconds tstr)
|
| ︙ | ︙ |
Modified dashboard-tests.scm from [f4c3f49fc2] to [f1c7f822ad].
| ︙ | ︙ | |||
573 574 575 576 577 578 579 | ;(mutex-lock! mx1) (iup:attribute-set! lbl "TITLE" newval) ;(mutex-unlock! mx1) ))))) lbl)) (store-button store-label) (command-proc (lambda (command-text-box) | | < < | < < | 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 | ;(mutex-lock! mx1) (iup:attribute-set! lbl "TITLE" newval) ;(mutex-unlock! mx1) ))))) lbl)) (store-button store-label) (command-proc (lambda (command-text-box) (let* ((cmd (iup:attribute command-text-box "VALUE"))) (common:run-a-command cmd)))) (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -10" #:action (lambda (obj cnum val) ;; (print "cnum=" cnum) (if (eq? cnum 13) (command-prox obj))) |
| ︙ | ︙ |
Modified dashboard.scm from [357056d7b4] to [8faf005e26].
| ︙ | ︙ | |||
36 37 38 39 40 41 42 43 44 45 46 47 48 49 | ;; (declare (uses dashboard-main)) (declare (uses megatest-version)) (declare (uses mt)) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") (include "megatest-fossil-hash.scm") (define help (conc "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " license GPL, Copyright (C) Matt Welland 2012-2016 | > | 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 | ;; (declare (uses dashboard-main)) (declare (uses megatest-version)) (declare (uses mt)) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") (include "task_records.scm") (include "megatest-fossil-hash.scm") (define help (conc "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " license GPL, Copyright (C) Matt Welland 2012-2016 |
| ︙ | ︙ | |||
1839 1840 1841 1842 1843 1844 1845 |
((>= runnum nruns) #f) ;; (vector tableheader runsvec))
((>= testnum ntests)
(vector-set! runsvec runnum testvec)
(set! bdylst (cons (apply iup:vbox (reverse res)) bdylst))
(loop (+ runnum 1) 0 (make-vector ntests) '()))
(else
(let* ((button-key (mkstr runnum testnum))
| | > | | | | | | | | | | | > | | | | | | | | > > > > | > > > > > > > | | | | | | | | > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 |
((>= runnum nruns) #f) ;; (vector tableheader runsvec))
((>= testnum ntests)
(vector-set! runsvec runnum testvec)
(set! bdylst (cons (apply iup:vbox (reverse res)) bdylst))
(loop (+ runnum 1) 0 (make-vector ntests) '()))
(else
(let* ((button-key (mkstr runnum testnum))
(butn (iup:button
"" ;; button-key
#:size "60x15"
#:expand "HORIZONTAL"
#:fontsize "10"
;; :action (lambda (x)
;; (let* ((toolpath (car (argv)))
;; (buttndat (hash-table-ref (d:alldat-buttondat *alldat*) button-key))
;; (test-id (db:test-get-id (vector-ref buttndat 3)))
;; (run-id (db:test-get-run_id (vector-ref buttndat 3)))
;; (cmd (conc toolpath " -test " run-id "," test-id "&")))
;; ;(print "Launching " cmd)
;; (system cmd)))
#:button-cb
(lambda (obj a pressed x y btn . rem)
;; (print "pressed= " pressed " x= " x " y= " y " rem=" rem " btn=" btn " string? " (string? btn))
(if (substring-index "3" btn)
(if (eq? pressed 1)
(let* ((toolpath (car (argv)))
(buttndat (hash-table-ref (d:alldat-buttondat *alldat*) button-key))
(test-id (db:test-get-id (vector-ref buttndat 3)))
(run-id (db:test-get-run_id (vector-ref buttndat 3)))
(run-info (rmt:get-run-info run-id))
(target (rmt:get-target run-id))
(runname (db:get-value-by-header (db:get-rows run-info)
(db:get-header run-info) "runname"))
(test-name (db:test-get-testname (rmt:get-test-info-by-id run-id test-id)))
(testpatt (let ((tlast (rmt:tasks-get-last target runname)))
(if tlast
(let ((tpatt (tasks:task-get-testpatt tlast)))
(if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017
"%"
tpatt))
"%")))
(popup-menu (iup:menu
(iup:menu-item
"Run"
(iup:menu
(iup:menu-item
(conc "Rerun " testpatt)
#:action
(lambda (obj)
(common:run-a-command
(conc "megatest -run -target " target
" -runname " runname
" -testpatt " testpatt
" -preclean -clean-cache")
;; (print "Rerun")
)))))
(iup:menu-item
"Test"
(iup:menu
(iup:menu-item
"Start xterm"
#:action
(lambda (obj)
(let* ((cmd (conc toolpath " -xterm " run-id "," test-id "&")))
(system cmd))))
(iup:menu-item
"Edit testconfig"
#:action
(lambda (obj)
(let* ((all-tests (tests:get-all))
(editor-rx (or (configf:lookup *configdat* "setup" "editor-regex")
"\\b(vim?|nano|pico)\\b"))
(editor (or (configf:lookup *configdat* "setup" "editor")
(get-environment-variable "VISUAL")
(get-environment-variable "EDITOR") "vi"))
(tconfig (conc (hash-table-ref all-tests test-name) "/testconfig"))
(cmd (conc (if (string-search editor-rx editor)
(conc "xterm -e " editor)
editor)
" " tconfig " &")))
(system cmd))))
)))))
(iup:show popup-menu
#:x 'mouse
#:y 'mouse
#:modal? "NO")
;; (print "got here")
))
(if (eq? pressed 0)
(let* ((toolpath (car (argv)))
(buttndat (hash-table-ref (d:alldat-buttondat *alldat*) button-key))
(test-id (db:test-get-id (vector-ref buttndat 3)))
(run-id (db:test-get-run_id (vector-ref buttndat 3)))
(cmd (conc toolpath " -test " run-id "," test-id "&")))
(system cmd)))
)))))
(hash-table-set! (d:alldat-buttondat *alldat*) button-key (vector 0 "100 100 100" button-key #f #f))
(vector-set! testvec testnum butn)
(loop runnum (+ testnum 1) testvec (cons butn res))))))
;; now assemble the hdrlst and bdylst and kick off the dialog
(iup:show
(iup:dialog
#:title (conc "Megatest dashboard " (current-user-name) ":" *toppath*)
#:menu (dcommon:main-menu)
|
| ︙ | ︙ |
Modified rmt.scm from [11bc722afa] to [c30752aa03].
| ︙ | ︙ | |||
694 695 696 697 698 699 700 701 702 703 704 705 706 707 | (define (rmt:tasks-add action owner target runname testpatt params) (rmt:send-receive 'tasks-add #f (list action owner target runname testpatt params))) (define (rmt:tasks-set-state-given-param-key param-key new-state) (rmt:send-receive 'tasks-set-state-given-param-key #f (list param-key new-state))) ;;====================================================================== ;; A R C H I V E S ;;====================================================================== (define (rmt:archive-get-allocations testname itempath dneeded) (rmt:send-receive 'archive-get-allocations #f (list testname itempath dneeded))) | > > > | 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 | (define (rmt:tasks-add action owner target runname testpatt params) (rmt:send-receive 'tasks-add #f (list action owner target runname testpatt params))) (define (rmt:tasks-set-state-given-param-key param-key new-state) (rmt:send-receive 'tasks-set-state-given-param-key #f (list param-key new-state))) (define (rmt:tasks-get-last target runname) (rmt:send-receive 'tasks-get-last #f (list target runname))) ;;====================================================================== ;; A R C H I V E S ;;====================================================================== (define (rmt:archive-get-allocations testname itempath dneeded) (rmt:send-receive 'archive-get-allocations #f (list testname itempath dneeded))) |
| ︙ | ︙ |
Modified runs.scm from [fad0992ca2] to [700013b501].
| ︙ | ︙ | |||
222 223 224 225 226 227 228 229 230 231 232 |
(runs:set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process
(set! runconf (if (file-exists? runconfigf)
(setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals target)
(begin
(debug:print 0 *default-log-port* "WARNING: You do not have a run config file: " runconfigf)
#f)))
;; register this run in monitor.db
(rmt:tasks-add "run-tests" user target runname test-patts task-key) ;; params)
(rmt:tasks-set-state-given-param-key task-key "running")
| > > > < < < | 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 |
(runs:set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process
(set! runconf (if (file-exists? runconfigf)
(setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals target)
(begin
(debug:print 0 *default-log-port* "WARNING: You do not have a run config file: " runconfigf)
#f)))
(if (not test-patts) ;; first time in - adjust testpatt
(set! test-patts (common:args-get-testpatt runconf)))
;; register this run in monitor.db
(rmt:tasks-add "run-tests" user target runname test-patts task-key) ;; params)
(rmt:tasks-set-state-given-param-key task-key "running")
;; Now generate all the tests lists
(set! all-tests-registry (tests:get-all)) ;; hash of testname => path-to-test
(set! all-test-names (hash-table-keys all-tests-registry))
(set! test-names (tests:filter-test-names all-test-names test-patts))
;; I think seeding required-tests with all test-names makes sense but lack analysis to back that up.
|
| ︙ | ︙ |
Modified task_records.scm from [8f450896f9] to [9c8b281be4].
| ︙ | ︙ | |||
13 14 15 16 17 18 19 | (define (make-tasks:task)(make-vector 11)) (define-inline (tasks:task-get-id vec) (vector-ref vec 0)) (define-inline (tasks:task-get-action vec) (vector-ref vec 1)) (define-inline (tasks:task-get-owner vec) (vector-ref vec 2)) (define-inline (tasks:task-get-state vec) (vector-ref vec 3)) (define-inline (tasks:task-get-target vec) (vector-ref vec 4)) (define-inline (tasks:task-get-name vec) (vector-ref vec 5)) | | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 | (define (make-tasks:task)(make-vector 11)) (define-inline (tasks:task-get-id vec) (vector-ref vec 0)) (define-inline (tasks:task-get-action vec) (vector-ref vec 1)) (define-inline (tasks:task-get-owner vec) (vector-ref vec 2)) (define-inline (tasks:task-get-state vec) (vector-ref vec 3)) (define-inline (tasks:task-get-target vec) (vector-ref vec 4)) (define-inline (tasks:task-get-name vec) (vector-ref vec 5)) (define-inline (tasks:task-get-testpatt vec) (vector-ref vec 6)) (define-inline (tasks:task-get-keylock vec) (vector-ref vec 7)) (define-inline (tasks:task-get-params vec) (vector-ref vec 8)) (define-inline (tasks:task-get-creation_time vec) (vector-ref vec 9)) (define-inline (tasks:task-get-execution_time vec) (vector-ref vec 10)) (define-inline (tasks:task-set-state! vec val)(vector-set! vec 3 val)) |
| ︙ | ︙ |
Modified tasks.scm from [9d2e7dd3c6] to [4d978918ac].
| ︙ | ︙ | |||
546 547 548 549 550 551 552 553 554 555 556 557 558 559 | ;; NOTE:: These operate on task_queue which is in main.db ;; ;;====================================================================== ;; NOTE: It might be good to add one more layer of checking to ensure ;; that no task gets run in parallel. ;; register a task (define (tasks:add dbstruct action owner target runname testpatt params) (db:with-db dbstruct #f #t (lambda (db) | > > > > > > > > > > > | 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 |
;; NOTE:: These operate on task_queue which is in main.db
;;
;;======================================================================
;; NOTE: It might be good to add one more layer of checking to ensure
;; that no task gets run in parallel.
;; id INTEGER PRIMARY KEY,
;; action TEXT DEFAULT '',
;; owner TEXT,
;; state TEXT DEFAULT 'new',
;; target TEXT DEFAULT '',
;; name TEXT DEFAULT '',
;; testpatt TEXT DEFAULT '',
;; keylock TEXT,
;; params TEXT,
;; creation_time TIMESTAMP DEFAULT (strftime('%s','now')),
;; execution_time TIMESTAMP);
;; register a task
(define (tasks:add dbstruct action owner target runname testpatt params)
(db:with-db
dbstruct #f #t
(lambda (db)
|
| ︙ | ︙ | |||
643 644 645 646 647 648 649 650 651 652 653 654 655 656 |
(conc "SELECT id,action,owner,state,target,name,test,item,params,creation_time,execution_time
FROM tasks_queue "
;; WHERE
;; state IN " statesstr " AND
;; action IN " actionsstr
" ORDER BY creation_time DESC;"))
res))))
;; remove tasks given by a string of numbers comma separated
(define (tasks:remove-queue-entries dbstruct task-ids)
(db:with-db
dbstruct #f #t
(lambda (db)
(sqlite3:execute db (conc "DELETE FROM tasks_queue WHERE id IN (" task-ids ");")))))
| > > > > > > > > > > > > > > > > > | 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 |
(conc "SELECT id,action,owner,state,target,name,test,item,params,creation_time,execution_time
FROM tasks_queue "
;; WHERE
;; state IN " statesstr " AND
;; action IN " actionsstr
" ORDER BY creation_time DESC;"))
res))))
(define (tasks:get-last dbstruct target runname)
(let ((res #f))
(db:with-db
dbstruct #f #f
(lambda (db)
(sqlite3:for-each-row
(lambda (id . rem)
(set! res (apply vector id rem)))
db
(conc "SELECT id,action,owner,state,target,name,testpatt,keylock,params,creation_time,execution_time
FROM tasks_queue
WHERE
target = ? AND name =?
ORDER BY creation_time DESC LIMIT 1;")
target runname)
res))))
;; remove tasks given by a string of numbers comma separated
(define (tasks:remove-queue-entries dbstruct task-ids)
(db:with-db
dbstruct #f #t
(lambda (db)
(sqlite3:execute db (conc "DELETE FROM tasks_queue WHERE id IN (" task-ids ");")))))
|
| ︙ | ︙ |