Megatest

Check-in [efa1af53d5]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Display of tests on canvas partially implemented
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | runcontrol
Files: files | file ages | folders
SHA1: efa1af53d52663d00b4cd70a346cb294e77cdad7
User & Date: matt on 2013-04-22 00:59:07
Other Links: branch diff | manifest | tags
Context
2013-04-22
01:25
Draw test/task boxes in rows to keep compact interface check-in: df77e9f1bd user: matt tags: runcontrol
00:59
Display of tests on canvas partially implemented check-in: efa1af53d5 user: matt tags: runcontrol
2013-04-21
01:24
Target selector done check-in: 5a56443663 user: matt tags: runcontrol
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified dashboard.scm from [5c1a3909e7] to [3061b16302].

︙
10
11
12
13
14
15
16

17
18
19
20
21
22
23

10
11
12
13
14
15
16
17
18
19
20
21
22
23
24








+








;;======================================================================

(use format)
(require-library iup)
(import (prefix iup iup:))

(use canvas-draw)
(import canvas-draw-iup)

(use sqlite3 srfi-1 posix regex regex-case srfi-69)
(import (prefix sqlite3 sqlite3:))
(use trace)

(declare (uses common))
(declare (uses margs))
︙
507
508
509
510
511
512
513


514
515
516
517



518
519
520
521
522
523
524








525
526
527
528


529

530
531
532
533
534
535
536




























537
538
539
540
541
542
543

508
509
510
511
512
513
514
515
516
517
518
519

520
521
522
523
524
525
526
527


528
529
530
531
532
533
534
535
536
537
538
539
540
541

542
543
544
545
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
571
572
573
574
575
576
577
578
579
580
581
582
583








+
+



-
+
+
+





-
-
+
+
+
+
+
+
+
+




+
+
-
+






-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








			 listboxes)))
	    (loop (car remkeys)
		  (cdr remkeys)
		  (append refvals (list selected-value))
		  (+ indx 1)
		  (append lbs (list lb))))))))

;(define (dashboard:display-tests cnv x y)

(define (dashboard:run-controls)
  (let* ((targets       (make-hash-table))
	 (runconf-targs (common:get-runconfig-targets))
	 (tests         (make-hash-table))
	 (test-records  (make-hash-table))
	 (test-names    (tests:get-valid-tests *toppath* '()))
	 (sorted-testnames #f)
	 (action        "-runtests")
	 (cmdln         "")
	 (runlogs       (make-hash-table))
	 (key-listboxes #f)
	 (update-keyvals (lambda (obj b c d)
			   (print "obj: " obj ", b " b ", c " c ", d " d)
			   (dashboard:update-target-selector key-listboxes))))
			   ;; (print "obj: " obj ", b " b ", c " c ", d " d)
			   (dashboard:update-target-selector key-listboxes)))
	 (test-browse-xoffset 0)
	 (test-browse-yoffset 0)
	 (first-time    #t))
    (tests:get-full-data test-names test-records '())
    (set! sorted-testnames (tests:sort-by-priority-and-waiton test-records))
    
    ;; refer to *keys*, *dbkeys* for keys
    (iup:vbox
     (iup:hbox
       ;; Target and action
      (iup:frame
       #:title "Target"
      (iup:vbox
       (iup:vbox
        ;; Target selectors
        (apply iup:hbox
	       (let* ((dat      (dashboard:update-target-selector key-listboxes action-proc: update-keyvals))
		      (key-lb   (car dat))
		      (combos   (cadr dat)))
		 (set! key-listboxes key-lb)
		 combos)))))))
		 combos))))
      (iup:frame
       #:title "Tests and Tasks"
       (iup:vbox
	(iup:canvas #:action (make-canvas-action
			      (lambda (cnv xadj yadj)
				;; (print "cnv: " cnv " x: " x " y: " y)
				(canvas-clear! cnv)
				(canvas-font-set! cnv "Courier New, -8")
				(let-values (((sizex   sizey sizexmm sizeymm) (canvas-size cnv)))
	                           (if first-time
				       (begin
					 (set! first-time #f)
					 (set! test-browse-xoffset (- 20 (* (/ sizex 2) (* 8 xadj))))
					 (set! test-browse-yoffset (- 20 (* (/ sizey 2) (* 8 (- 1 yadj)))))))
			           (let* ((xtorig (+ test-browse-xoffset (* (/ sizex 2) (* 8 xadj)))) ;;  (- xadj 1))))
					  (ytorig (+ test-browse-yoffset (* (/ sizey 2) (* 8 (- 1 yadj))))))
				     (print "sizex: " sizex " sizey: " sizey " font: " (canvas-font cnv))
				     (for-each (lambda (testname)
						 (canvas-text! cnv (+ xtorig 5)(+ ytorig 5) testname) ;; (conc testname " (" xtorig "," ytorig ")"))
						 (canvas-rectangle! cnv xtorig (+ 60 xtorig) ytorig (+ ytorig 30))
						 (set! ytorig (+ ytorig 50)))
					       (reverse sorted-testnames))))))
		    #:size "150x200"
		    #:scrollbar "YES"
		    #:posx "0.5"
		    #:posy "0.5")))))))


(trace dashboard:populate-target-dropdown
       common:list-is-sublist)

;;       ;; key1 key2 key3 ...
;;       ;; target entry (wild cards allowed)
;;
︙

Modified docs/manual/megatest_manual.txt from [db93d807cc] to [6b638a28bf]. 

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31

1
2
3
4
5
6
7

















8
9
10
11
12
13
14








-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-








The Megatest Users Manual
=========================
Matt Welland <matt@kiatoa.com>
v1.0, April 2012
:doctype: book


[dedication]
Dedication
==========

Dedicated to my wife Joanna who has kindly supported my working on various projects over the years.

Thanks
------

Thank you the many people I've worked over the years who have 
shared their knowledge and insights with me.

Thanks also to the creators of the various open source projects that
Megatest is built on. These include Linux, xemacs, chicken scheme,
fossil and asciidoc. Without these projects something like Megatest 
would be difficult or impossible to do.

[preface]
Preface
=======
This book is organised as three sub-books; getting started, writing tests and reference.

Why Megatest?
~~~~~~~~~~~~~
︙

Modified runs.scm from [f136285a97] to [0d071f8e6c].

︙
975
976
977
978
979
980
981
982

983
984
985
986
987
988
989

975
976
977
978
979
980
981

982
983
984
985
986
987
988
989








-
+








	     (begin
	       (print "Updating " test-name " " fld " to " val)
	       (open-run-close db:testmeta-update-field db test-name fld val)))))
     '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)))))

;; Update test_meta for all tests
(define (runs:update-all-test_meta db)
  (let ((test-names (get-all-legal-tests)))
  (let ((test-names (tests:get-valid-tests)))
    (for-each 
     (lambda (test-name)
       (let* ((test-path    (conc *toppath* "/tests/" test-name))
	      (test-configf (conc test-path "/testconfig"))
	      (testexists   (and (file-exists? test-configf)(file-read-access? test-configf)))
	      ;; read configs with tricks turned off (i.e. no system)
	      (test-conf    (if testexists (read-config test-configf #f #f)(make-hash-table))))
︙

Modified tests.scm from [45344ee04b] to [628e641bd0].

︙
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47

24
25
26
27
28
29
30










31
32
33
34
35
36
37








-
-
-
-
-
-
-
-
-
-









(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")

(define (tests:get-valid-tests testsdir test-patts) ;;  #!key (test-names '()))
  (let ((tests (glob (conc testsdir "/tests/*")))) ;; " (string-translate patt "%" "*")))))
    (set! tests (filter (lambda (test)(file-exists? (conc test "/testconfig"))) tests))
    (delete-duplicates
     (filter (lambda (testname)
	       (tests:match test-patts testname #f))
	     (map (lambda (testp)
		    (last (string-split testp "/")))
		  tests)))))

;; tests:glob-like-match
(define (tests:glob-like-match patt str) 
  (let ((like (substring-index "%" patt)))
    (let* ((notpatt  (equal? (substring-index "~" patt) 0))
	   (newpatt  (if notpatt (substring patt 1) patt))
	   (finpatt  (if like
			(string-substitute (regexp "%") ".*" newpatt)
︙
427
428
429
430
431
432
433



434
435
436






437
438


439
440
441


442
443
444
445
446
447
448
449

417
418
419
420
421
422
423
424
425
426



427
428
429
430
431
432


433
434



435
436

437
438
439
440
441
442
443








+
+
+
-
-
-
+
+
+
+
+
+
-
-
+
+
-
-
-
+
+
-








		(release-dot-lock outputfilename)))
	    (close-output-port oup)
	    (change-directory orig-dir)
	    ;; NB// tests:test-set-toplog! is remote internal...
	    (tests:test-set-toplog! db run-id test-name outputfilename)
	    )))))

;;======================================================================
;; Gather data from test/task specifications
;;======================================================================
(define (get-all-legal-tests)
  (let* ((tests  (glob (conc *toppath* "/tests/*")))
	 (res    '()))

(define (tests:get-valid-tests testsdir test-patts) ;;  #!key (test-names '()))
  (let ((tests (glob (conc testsdir "/tests/*")))) ;; " (string-translate patt "%" "*")))))
    (set! tests (filter (lambda (test)(file-exists? (conc test "/testconfig"))) tests))
    (delete-duplicates
     (filter (lambda (testname)
    (debug:print-info 4 "Looking at tests " (string-intersperse tests ","))
    (for-each (lambda (testpath)
	       (tests:match test-patts testname #f))
	     (map (lambda (testp)
		(if (file-exists? (conc testpath "/testconfig"))
		    (set! res (cons (last (string-split testpath "/")) res))))
	      tests)
		    (last (string-split testp "/")))
		  tests)))))
    res))

(define (tests:get-testconfig test-name system-allowed)
  (let* ((test-path    (conc *toppath* "/tests/" test-name))
	 (test-configf (conc test-path "/testconfig"))
	 (testexists   (and (file-exists? test-configf)(file-read-access? test-configf))))
    (if testexists
	(read-config test-configf #f system-allowed environ-patt: (if system-allowed
︙
528
529
530
531
532
533
534
















































































535
536
537
538
539
540
541

522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
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
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615








+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








					 (member (db:test-get-state wtdat)
						 '("INCOMPETE")))
				     (set! keep-test #f)))) ;; no point in running this one again
			     waitons))))
	 (if keep-test (set! runnables (cons testkeyname runnables)))))
     testkeynames)
    runnables))

;;======================================================================
;; refactoring this block into tests:get-full-data from line 263 of runs.scm
;;======================================================================
;; hed is the test name
;; test-records is a hash of test-name => test record
(define (tests:get-full-data test-names test-records required-tests)
  (if (not (null? test-names))
      (let loop ((hed (car test-names))
		 (tal (cdr test-names)))         ;; 'return-procs tells the config reader to prep running system but return a proc
	(debug:print-info 4 "hed=" hed " at top of loop")
	(let* ((config  (tests:get-testconfig hed 'return-procs))
	       (waitons (let ((instr (if config 
					 (config-lookup config "requirements" "waiton")
					 (begin ;; No config means this is a non-existant test
					   (debug:print 0 "ERROR: non-existent required test \"" hed "\"")
					   (if db (sqlite3:finalize! db))
					   (exit 1)))))
			  (debug:print-info 8 "waitons string is " instr)
			  (string-split (cond
					 ((procedure? instr)
					  (let ((res (instr)))
					    (debug:print-info 8 "waiton procedure results in string " res " for test " hed)
					    res))
					 ((string? instr)     instr)
					 (else 
					  ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 "ERROR: something went wrong in processing waitons for test " hed)
					  ""))))))
	  (debug:print-info 8 "waitons: " waitons)
	  ;; check for hed in waitons => this would be circular, remove it and issue an
	  ;; error
	  (if (member hed waitons)
	      (begin
		(debug:print 0 "ERROR: test " hed " has listed itself as a waiton, please correct this!")
		(set! waitons (filter (lambda (x)(not (equal? x hed))) waitons))))
	  
	  ;; (items   (items:get-items-from-config config)))
	  (if (not (hash-table-ref/default test-records hed #f))
	      (hash-table-set! test-records
			       hed (vector hed     ;; 0
					   config  ;; 1
					   waitons ;; 2
					   (config-lookup config "requirements" "priority")     ;; priority 3
					   (let ((items      (hash-table-ref/default config "items" #f)) ;; items 4
						 (itemstable (hash-table-ref/default config "itemstable" #f))) 
					     ;; if either items or items table is a proc return it so test running
					     ;; process can know to call items:get-items-from-config
					     ;; if either is a list and none is a proc go ahead and call get-items
					     ;; otherwise return #f - this is not an iterated test
					     (cond
					      ((procedure? items)      
					       (debug:print-info 4 "items is a procedure, will calc later")
					       items)            ;; calc later
					      ((procedure? itemstable)
					       (debug:print-info 4 "itemstable is a procedure, will calc later")
					       itemstable)       ;; calc later
					      ((filter (lambda (x)
							 (let ((val (car x)))
							   (if (procedure? val) val #f)))
						       (append (if (list? items) items '())
							       (if (list? itemstable) itemstable '())))
					       'have-procedure)
					      ((or (list? items)(list? itemstable)) ;; calc now
					       (debug:print-info 4 "items and itemstable are lists, calc now\n"
								 "    items: " items " itemstable: " itemstable)
					       (items:get-items-from-config config))
					      (else #f)))                           ;; not iterated
					   #f      ;; itemsdat 5
					   #f      ;; spare - used for item-path
					   )))
	  (for-each 
	   (lambda (waiton)
	     (if (and waiton (not (member waiton test-names)))
		 (begin
		   (set! required-tests (cons waiton required-tests))
		   (set! test-names (cons waiton test-names))))) ;; was an append, now a cons
	   waitons)
	  (let ((remtests (delete-duplicates (append waitons tal))))
	    (if (not (null? remtests))
		(loop (car remtests)(cdr remtests))))))))

;;======================================================================
;; test steps
;;======================================================================

;; teststep-set-status! used to be here
︙

This page was generated in about 0.12s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00