Megatest

Check-in [8d68c68080]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Added table based iteration
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk | v1.11
Files: files | file ages | folders
SHA1: 8d68c680803de233553324b0ade969e5b7d3215c
User & Date: mrwellan on 2011-06-07 00:25:55
Other Links: manifest | tags
Context
2011-06-07
00:48
Added testname to popup edit window title check-in: ffaa4fa4b2 user: mrwellan tags: trunk
00:25
Added table based iteration check-in: 8d68c68080 user: mrwellan tags: trunk, v1.11
2011-06-06
21:49
Bumped version to 1.11 check-in: f31622c001 user: mrwellan tags: trunk
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified items.scm from [1d66604c32] to [94efa1a3a7]. 

1
2
3
4
5
6
7
8
9
10
11
12
13
14


15
16
17
18
19
20
21

1
2
3
4
5
6
7
8
9
10
11
12


13
14
15
16
17
18
19
20
21













-
-
+
+









;; Copyright 2006-2011, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.


;; (define itemdat '((ripeness    "green ripe overripe")
;; 		  (temperature "cool medium hot")
;; 		  (season      "summer winter fall spring")))
;; 		     (temperature "cool medium hot")
;; 		     (season      "summer winter fall spring")))

;; Mostly worked = puts out all combinations?
(define (process-itemlist-try1 curritemkey itemlist)
  (let loop ((hed (car itemlist))
	     (tal (cdr itemlist)))
    (if (null? tal)
	(for-each (lambda (item)
︙
42
43
44
45
46
47
48





49
50
51
52
53
54
55
56
57







































58
59
60
61
62
63
64
65

42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61

62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108








+
+
+
+
+








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









	  (begin
	    (for-each (lambda (item)
			(set! res (append res (process-itemlist hierdepth (append curritemkey (list (list (car hed) item))) tal))))
		      (cadr hed))
	    (loop (car tal)(cdr tal)))))
    res))

;; (item-assoc->item-list '(("ANIMAL" "Elephant Lion")("SEASON" "Spring Fall")))
;;   => ((("ANIMAL" "Elephant") ("SEASON" "Spring")) 
;;       (("ANIMAL" "Elephant") ("SEASON" "Fall")) 
;;       (("ANIMAL" "Lion")     ("SEASON" "Spring"))
;;       (("ANIMAL" "Lion")     ("SEASON" "Fall")))
(define (item-assoc->item-list itemsdat)
  (if (and itemsdat (not (null? itemsdat)))
      (let ((itemlst (map (lambda (x)
			    (let ((name (car x))
				  (items (cadr x)))
			      (list name (string-split items))))
			  itemsdat)))
	(process-itemlist #f '() itemlst))
      '(()))) ;; return a list consisting on a single null list for non-item runs
      '())) ;; return a list consisting on a single null list for non-item runs
            ;; Nope, not now, return null as of 6/6/2011

;; (item-table->item-list '(("ANIMAL" "Elephant Lion")("SEASON" "Spring Winter")))
;;   => ((("ANIMAL" "Elephant")("SEASON" "Spring"))
;;       (("ANIMAL" "Lion")    ("SEASON" "Winter")))
(define (item-table->item-list itemtable)
  (let ((newlst (map (lambda (x)
		       (if (> (length x) 1)
			   (list (car x)
				 (string-split (cadr x)))
			   x))
		     itemtable))
	(res     '())) ;; a list of items
    (let loop ((indx    0)
	       (item   '()) ;; an item will be ((KEYNAME1 VAL1)(KEYNAME2 VAL2) ...)
	       (elflag  #f))
      (for-each (lambda (row)
		  (let ((rowname (car row))
			(rowdat  (cadr row)))
		    (set! item (append item 
				       (list 
					(if (< indx (length rowdat))
					    (let ((new (list rowname (list-ref rowdat indx))))
					      ;; (print "New: " new)
					      (set! elflag #t)
					      new
					      ) ;; i.e. had at least on legit value to use
					    (list rowname "-")))))))
		newlst)
      (if elflag
	  (begin
	    (set! res (append res (list item)))
	    (loop (+ indx 1)
		  '()
		  #f)))
      res)))
            ;; Nope, not now, return null as of 6/6/2011
		
  
(define-inline (item-list->path itemdat)
  (string-intersperse  (map cadr itemdat) "/"))

;; (pp (item-assoc->item-list itemdat))

Modified runs.scm from [ac80fea080] to [a13e1910a3].

︙
282
283
284
285
286
287
288
289
290






291
292

293
294
295
296
297
298
299

282
283
284
285
286
287
288


289
290
291
292
293
294
295

296
297
298
299
300
301
302
303








-
-
+
+
+
+
+
+

-
+








			 (if (string? w)(string-split w)'()))))
    (if (not testexists)
	(begin
	  (print "ERROR: Can't find config file " test-configf)
	  (exit 2))
	;; put top vars into convenient variables and open the db
	(let* (;; db is always at *toppath*/db/megatest.db
	       (items       (hash-table-ref/default test-conf "items" #f))
	       (allitems    (item-assoc->item-list items))
	       (items       (hash-table-ref/default test-conf "items" '()))
	       (itemstable  (hash-table-ref/default test-conf "itemstable" '()))
	       (allitems    (if (or (not (null? items))(not (null? itemstable)))
				(append (item-assoc->item-list items)
					(item-table->item-list itemstable))
				'(()))) ;; a list with one null list is a test with no items
	       (runconfigf  (conc  *toppath* "/runconfigs.config")))
	  ;; (print "items: ")(pp allitems)
	  (print "items: ")(pp allitems)
	  (if (args:get-arg "-m")
	      (db:set-comment-for-run db run-id (args:get-arg "-m")))
	  (let loop ((itemdat (car allitems))
		     (tal     (cdr allitems)))
	    ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer"))
	    (let* ((item-path     (item-list->path itemdat)) ;; (string-intersperse (map cadr itemdat) "/"))
		   (new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/"))
︙

Modified tests/tests/runfirst/testconfig from [8ed50f0680] to [cc16f856ec].

︙
9
10
11
12
13
14
15




16

9
10
11
12
13
14
15
16
17
18
19
20








+
+
+
+


# These are set before the test is launched on the originating
# host. This can be used to control remote launch tools, e.g. to
# to choose the target host, select the launch tool etc.
SPECIAL_ENV_VAR override with everything after the first space.

[items]
SEASON summer winter fall spring

[itemstable]
BLOCK a  b
TOCK  1  2

Modified tests/tests/runfirst/wasting_time.logpro from [73cad9c3a4] to [1c532ab9c9]. 

1
2
3
4
5
6
7
8
9
10
11
12
13
14








15

1
2
3
4
5
6








7
8
9
10
11
12
13
14
15







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


;; put stuff here

;; NOTE: This is not legit logpro code!!! 

;; Test for 0=PASS, 1=WARN, >2 = FAIL

(define season (get-environment-variable "SEASON"))

(exit 
 (case (string->symbol season)
   ((summer) 0)
   ((winter) 1)
   ((fall)   2)
   (else     0)))
;; (define season (get-environment-variable "SEASON"))
;; 
;; (exit 
;;  (case (string->symbol season)
;;    ((summer) 0)
;;    ((winter) 1)
;;    ((fall)   2)
;;    (else     0)))

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