Megatest

Check-in [b4c4ed6017]
Login
Overview
Comment:first cut at hierarchial selector for targets
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | runcontrol
Files: files | file ages | folders
SHA1: b4c4ed6017bf87262ee59d912e91da8407fea4bd
User & Date: matt on 2013-04-20 11:49:18
Other Links: branch diff | manifest | tags
Context
2013-04-20
22:41
Fix to margs? check-in: a29af7bffd user: matt tags: runcontrol
11:49
first cut at hierarchial selector for targets check-in: b4c4ed6017 user: matt tags: runcontrol
2013-04-19
18:12
Minor changes for run control panel check-in: f6a292210e user: mrwellan tags: runcontrol
Changes

Modified common.scm from [3109b21887] to [7f9cf64fe3].

140
141
142
143
144
145
146


























147
148
149
150
151
152
153
			       #f #t))) string<?))

;; '(print (string-intersperse (map cadr (hash-table-ref/default (read-config "megatest.config" \#f \#t) "disks" '"'"'("none" ""))) "\n"))'
(define (common:get-disks)
  (hash-table-ref/default 
   (read-config "megatest.config" #f #t)
   "disks" '("none" "")))



























;;======================================================================
;; System stuff
;;======================================================================

;; return a nice clean pathname made absolute
(define (nice-path dir)







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
			       #f #t))) string<?))

;; '(print (string-intersperse (map cadr (hash-table-ref/default (read-config "megatest.config" \#f \#t) "disks" '"'"'("none" ""))) "\n"))'
(define (common:get-disks)
  (hash-table-ref/default 
   (read-config "megatest.config" #f #t)
   "disks" '("none" "")))

;;======================================================================
;; M I S C   L I S T S
;;======================================================================

;; items in lista are matched value and position in listb
;; return the remaining items in listb or #f
;;
(define (common:list-is-sublist lista listb)
  (if (null? lista)
      listb ;; all items in listb are "remaining"
      (if (> (length lista)(length listb)) 
	  #f
	  (let loop ((heda (car lista))
		     (tala (cdr lista))
		     (hedb (car listb))
		     (talb (cdr listb)))
	    (if (equal? heda hedb)
		(if (null? tala) ;; we are done
		    talb
		    (loop (car tala)
			  (cdr tala)
			  (car talb)
			  (cdr talb)))
		#f)))))
      

;;======================================================================
;; System stuff
;;======================================================================

;; return a nice clean pathname made absolute
(define (nice-path dir)

Modified dashboard.scm from [af16f05103] to [a699a04ab1].

425
426
427
428
429
430
431



































432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452

453

454
455
456
457
458
459
460

461
462

463
464

465
466
467
468

469
470
471
472
473
474
475
(define (mark-for-update)
  (set! *last-db-update-time* 0)
  (set! *delayed-update* 1))

;;======================================================================
;; R U N C O N T R O L
;;======================================================================




































(define (dashboard:run-controls)
  (let* ((targets       (make-hash-table))
	 (runconf-targs (common:get-runconfig-targets))
	 (db-target-dat (open-run-close db:get-targets #f))
	 (header        (vector-ref db-target-dat 0))
	 (db-targets    (vector-ref db-target-dat 1))
	 (tests         (make-hash-table))
	 (action        "-runtests")
	 (cmdln         "")
	 (runlogs       (make-hash-table)))
    ;; refer to *keys*, *dbkeys* for keys
    (print "db-targets: " db-targets)
     (iup:vbox
      (iup:hbox
       ;; Target and action
      (iup:vbox
        ;; Target selectors
        (apply iup:hbox
	       (map 
		(lambda (key)

		  (print "Label key=" key)

		  (let ((lb (iup:listbox 
			     key 
			     #:size "x15" 
			     #:fontsize "10"
			     #:expand "YES"
			     #:value "1"
			     #:dropdown "YES"

			     )))
		    (let loop ((count 1))

		      (iup:attribute-set!
		       lb count 

		       (db:get-value-by-header row header field)
		header)))
))))


;;       ;; key1 key2 key3 ...
;;       ;; target entry (wild cards allowed)
;;       
;;       ;; The action
;;       (iup:hbox
;;        ;; label Action | action selector
;;        ))







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>













|
|




|
|
>
|
>
|
|
|
|
|
<
|
>
|
|
>
|
|
>
|
<
|
|
>







425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495

496
497
498
499
500
501
502
503
504

505
506
507
508
509
510
511
512
513
514
(define (mark-for-update)
  (set! *last-db-update-time* 0)
  (set! *delayed-update* 1))

;;======================================================================
;; R U N C O N T R O L
;;======================================================================

;; target populating logic
;;  
;; lb            = <vector curr-label-object next-label-object>
;; field         = target field name for this dropdown
;; referent-vals = selected value in the left dropdown
;; targets       = list of targets to use to build the dropdown
;; 
;; each node is chained: key1 -> key2 -> key3
;;
;; must select values from only apropriate targets
;;   a b c
;;   a d e
;;   a b f
;;        a/b => c f
;;
(define (dashboard:populate-target-dropdown lb referent-vals targets)
  ;; is the current value in the new list? choose new default if not
  (let* ((remvalues  (map (lambda (row)
			    (common:list-is-sublist referent-vals (vector->list row)))
			  targets))
	 (values     (map car (filter list? remvalues)))
	 (sel-valnum (iup:attribute lb "VALUE"))
	 (sel-val    (iup:attribute lb sel-valnum))
	 (val-num    0))
    ;; first check if the current value is in the new list, otherwise replace with 
    ;; first value from values
    (iup:attribute-set! lb "REMOVEITEM" "ALL")
    (for-each (lambda (val)
		(iup:attribute-set! lb "APPENDITEM" val)
		(if (equal? sel-val val)
		    (iup:attribute-set! lb "VALUE" val-num))
		(set! val-num (+ val-num 1)))
	      values)))
  

(define (dashboard:run-controls)
  (let* ((targets       (make-hash-table))
	 (runconf-targs (common:get-runconfig-targets))
	 (db-target-dat (open-run-close db:get-targets #f))
	 (header        (vector-ref db-target-dat 0))
	 (db-targets    (vector-ref db-target-dat 1))
	 (tests         (make-hash-table))
	 (action        "-runtests")
	 (cmdln         "")
	 (runlogs       (make-hash-table)))
    ;; refer to *keys*, *dbkeys* for keys
    (print "db-targets: " db-targets)
    (iup:vbox
     (iup:hbox
       ;; Target and action
      (iup:vbox
        ;; Target selectors
        (apply iup:hbox
	       (let loop ((key     (car header))
			  (remkeys (cdr header))
			  (refvals '())
			  (indx    0)
			  (lbs     '()))
		 (let ((lb (iup:listbox 
			    key 
			    #:size "x15" 
			    #:fontsize "10"
			    #:expand "YES"

			    #:dropdown "YES"
			    #:editbox "YES"
			    )))
		    ;; loop though all the targets and build the list for this dropdown
		    (dashboard:populate-target-dropdown lb refvals db-targets)
		    (if (null? remkeys)
			(append lbs (list lb))
			(loop (car remkeys)
			      (cdr remkeys)

			      (append refvals (list key))
			      (+ indx 1)
			      (append lbs (list lb))))))))))))
;;       ;; key1 key2 key3 ...
;;       ;; target entry (wild cards allowed)
;;       
;;       ;; The action
;;       (iup:hbox
;;        ;; label Action | action selector
;;        ))