Megatest

Check-in [61dfefd369]
Login
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: 61dfefd369ae5584aba94097d164c29d455da9a8
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
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
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
580

581
582
583

584
585
586
587
588
589
590
591
592
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"))
			       (let* ((cmd     (iup:attribute command-text-box "VALUE")))
				      (fullcmd (conc (dtests:get-pre-command)
						     cmd 
						     (dtests:get-post-command))))
				 (common:run-a-command cmd))))
				 (debug:print-info 02 *default-log-port* "Running command: " fullcmd)
				 (common:without-vars fullcmd "MT_.*"))))
	       (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
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
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
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)))
                                                                     (test-name (db:test-get-testname (rmt:get-test-info-by-id run-id test-id)))
                                                                     (popup-menu (iup:menu 
                                                                                  (iup:menu-item
                                                                                   "Run"
                                                                                   (iup:menu              
                                                                                    (iup:menu-item
                                                                                     "Rerun"
                                                                                     #:action
                                                                                     (lambda (obj)(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") "gvim"))
                                                                                              (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)) 
	       (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
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
233
234
235
236
237
238
239
240
241
242
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")

    (if (not test-patts) ;; first time in - adjust testpatt
	(set! test-patts (common:args-get-testpatt runconf)))

    ;; 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
20
21


22
23
24
25
26
27
28
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-test             vec)    (vector-ref  vec 6))
(define-inline (tasks:task-get-item             vec)    (vector-ref  vec 7))
(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
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
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 ");")))))