Megatest

Changes On Branch b71c8dd55401492d
Login

Changes In Branch filters-fix Through [b71c8dd554] Excluding Merge-Ins

This is equivalent to a diff from cf1f6d704a to b71c8dd554

2016-06-20
11:35
Added test for basic filter operation on rmt:get-tests-for-run check-in: 35bbab5179 user: mrwellan tags: filters-fix
2016-06-17
17:40
Auto compile for correct readline version check-in: b71c8dd554 user: mrwellan tags: filters-fix
09:05
Minor refactor on get-tests check-in: 9996ef5713 user: mrwellan tags: filters-fix
2016-05-18
11:21
Forced cleanup db on changing versions check-in: c2ba631f76 user: ritikaag tags: v1.61
2016-05-16
18:08
Unfinished db changes for filters check-in: f903f42e57 user: mrwellan tags: filters-fix
17:13
Split show/hide to two buttons check-in: cf1f6d704a user: mrwellan tags: v1.61
13:56
Better filter behavior in states/statuses check-in: 49e3212725 user: mrwellan tags: v1.61, v1.6102

Modified Makefile from [9afa174d56] to [1879ee0391].

226
227
228
229
230
231
232


233
234
235


236
237

238
239
240
241
242
243
244
226
227
228
229
230
231
232
233
234
235


236
237
238

239
240
241
242
243
244
245
246







+
+

-
-
+
+

-
+







	chicken-install -keep-installed $(PROXY) -deploy -prefix sretrieve defstruct srfi-18 format sql-de-lite \
             srfi-1 posix regex regex-case srfi-69

# base64 dot-locking \
#             csv-xml z3

#  "(define (toplevel-command . a) #f)"
# if egrep 'version.*3.0' $(shell dirname $(shell dirname $(shell which csi)))/lib/chicken/7/readline.setup-info;then \

readline-fix.scm :
	if egrep 'version.*3.0' $(shell dirname $(shell dirname $(shell which csi)))/lib/chicken/7/readline.setup-info;then \
           echo "(use-legacy-bindings)" > readline-fix.scm; \
	if [[ $(shell chicken-status | grep readline | awk '{print $4}' | cut -d. -f1) -gt 3 ]];then \
	   echo "(define *use-new-readline* #f)" > readline-fix.scm; \
	else \
	   echo "" > readline-fix.scm;\
	   echo "(define *use-new-readline* #t)" > readline-fix.scm;\
	fi

altdb.scm :
	echo ";; optional alternate db setup" > altdb.scm
	echo "(define *available-db* (make-hash-table))" >> altdb.scm
	if  csi -ne '(use mysql-client)';then \
           echo "(use mysql-client)(hash-table-set! *available-db* 'mysql #t)" >> altdb.scm; \

Modified dashboard.scm from [dfc3e5bd3f] to [9b342a8bb8].

386
387
388
389
390
391
392
393

394
395
396
397
398
399
400
401
386
387
388
389
390
391
392

393

394
395
396
397
398
399
400







-
+
-







	 (allruns     (if (d:alldat-useserver data)
			  (rmt:get-runs runnamepatt numruns (d:alldat-start-run-offset data) keypatts)
			  (db:get-runs (d:alldat-dblocal data) runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2))
				       (d:alldat-start-run-offset data) keypatts)))
	 (header      (db:get-header allruns))
	 (runs        (db:get-rows   allruns))
	 (result      '())
	 (maxtests    0)
	 (maxtests    0))
)
    ;; 
    ;; trim runs to only those that are changing often here
    ;; 
    (for-each (lambda (run)
		(let* ((run-id      (db:get-value-by-header run header "id"))
		       (key-vals    (if (d:alldat-useserver data) 
					(rmt:get-key-vals run-id)
1602
1603
1604
1605
1606
1607
1608
1609

1610
1611
1612
1613
1614
1615
1616
1601
1602
1603
1604
1605
1606
1607

1608
1609
1610
1611
1612
1613
1614
1615







-
+







						   ;; (iup:attribute-set! obj "TITLE" (if (d:alldat-hide-not-hide data) "HideTests" "NotHide"))
						   (iup:attribute-set! hide "BGCOLOR" sel-color)
						   (iup:attribute-set! show "BGCOLOR" nonsel-color)
						   (mark-for-update))))
		 (set! show (iup:button "Show"
					#:expand "YES"
					#:action (lambda (obj)
						   (d:alldat-hide-not-hide-set! data (not (d:alldat-hide-not-hide data)))
						   (d:alldat-hide-not-hide-set! data #f) ;; (not (d:alldat-hide-not-hide data)))
						   (iup:attribute-set! show "BGCOLOR" sel-color)
						   (iup:attribute-set! hide "BGCOLOR" nonsel-color)
						   (mark-for-update))))
		 (iup:attribute-set! hide "BGCOLOR" sel-color)
		 (iup:attribute-set! show "BGCOLOR" nonsel-color)
		 ;; (d:alldat-hide-not-hide-button-set! data hideit) ;; never used, can eliminate ...
		 (iup:vbox

Modified db.scm from [b405cf0e93] to [62ae9e6cf9].

2195
2196
2197
2198
2199
2200
2201




2202
2203
2204
2205
2206

2207
2208
2209
2210
2211
2212
2213
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209

2210
2211
2212
2213
2214
2215
2216
2217







+
+
+
+




-
+







					(if (eq? mode 'dashboard)
					    " IN ('"
					    (if not-in 
						" NOT IN ('"
						" IN ('") )
					(string-intersperse statuses "','")
					"')")))
	     (interim-qry       (conc " AND " (if not-in "NOT " "") "( ( state='COMPLETED' AND " statuses-qry " ) "
				      (if states-qry
					  (conc (if not-in " AND " " OR ") states-qry " ) ")
					  "")))
	     (states-statuses-qry 
	      (cond 
	       ((and states-qry statuses-qry)
		(case mode
		  ((dashboard)(conc " AND " (if not-in "NOT " "") "( ( state='COMPLETED' AND " statuses-qry " ) OR " states-qry " ) "))
		  ((dashboard) interim-qry)
		  (else       (conc " AND ( " states-qry " AND " statuses-qry " ) "))))
	       (states-qry  
		(conc " AND " states-qry))
	       (statuses-qry 
		(conc " AND " statuses-qry))
	       (else "")))
	     (tests-match-qry (tests:match->sqlqry testpatt))
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2289
2290
2291
2292
2293
2294
2295







2296
2297
2298
2299
2300
2301
2302







-
-
-
-
-
-
-







		   db 
		   "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=?;" 
		   test-id)))
    res))

;; get a useful subset of the tests data (used in dashboard
;; use db:mintest-get-{id ,run_id,testname ...}
;; 
(define (db:get-tests-for-runs-mindata dbstruct run-ids testpatt states statuses not-in)
  (debug:print 0 "ERROR: BROKN!")
  ;; (db:get-tests-for-runs dbstruct run-ids testpatt states statuses not-in: not-in qryvals: "id,run_id,testname,state,status,event_time,item_path"))
)

;; get a useful subset of the tests data (used in dashboard
;;
(define (db:get-tests-for-run-mindata dbstruct run-id testpatt states statuses not-in)
  (db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f "id,run_id,testname,state,status,event_time,item_path" #f))

;; do not use.
;;
(define (db:get-tests-for-runs dbstruct run-ids testpatt states statuses #!key (not-in #f)(qryvals #f))

Modified megatest.scm from [d7706449e8] to [2aeb6b6eb4].

1898
1899
1900
1901
1902
1903
1904





1905
1906
1907
1908




1909
1910
1911
1912
1913
1914
1915
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909




1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920







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







	      (set! *client-non-blocking-mode* #t)
	      (import extras) ;; might not be needed
	      ;; (import csi)
	      (import readline)
	      (import apropos)
	      ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
	      (include "readline-fix.scm")
	      (if *use-new-readline*
		  (begin
		    (install-history-file (get-environment-variable "HOME") ".megatest_history") ;;  [homedir] [filename] [nlines])
		    (current-input-port (make-readline-port "megatest> ")))
		  (begin
	      (gnu-history-install-file-manager
	       (string-append
		(or (get-environment-variable "HOME") ".") "/.megatest_history"))
	      (current-input-port (make-gnu-readline-port "megatest> "))
		    (gnu-history-install-file-manager
		     (string-append
		      (or (get-environment-variable "HOME") ".") "/.megatest_history"))
		    (current-input-port (make-gnu-readline-port "megatest> "))))
	      (if (args:get-arg "-repl")
		  (repl)
		  (load (args:get-arg "-load")))
	      (db:close-all dbstruct))
	    (exit)))
	  (set! *didsomething* #t))))

Modified sretrieve.scm from [915dd04401] to [5fabfaebe0].

54
55
56
57
58
59
60

61
62
63
64
65
66
67
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68







+







(define sretrieve:help (conc "Usage: " *exe-name* " [action [params ...]]

  ls                     : list contents of target area
  get <relversion>       : retrieve data for release <version>
    -m \"message\"       : why retrieved?
  cp <relative path>     : copy file to current directory 
  log                    : get listing of recent downloads
  shell                  : start a shell-like interface

Part of the Megatest tool suite.
Learn more at http://www.kiatoa.com/fossils/megatest

Version: " megatest-fossil-hash)) ;; "

;;======================================================================
409
410
411
412
413
414
415













































416
417
418
419
420
421
422
410
411
412
413
414
415
416
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
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







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







		#f
		(loop (car tal)(cdr tal)))))))

(define (sretrieve:stderr-print . args)
  (with-output-to-port (current-error-port)
    (lambda ()
      (apply print args))))

;;======================================================================
;; SHELL
;;======================================================================

(define (toplevel-command . args) #f)
(define (sretrieve:shell)
  (use readline)
  (let* ((path      '())
	 (prompt    "> ")
	 (top-areas '("mrwellan" "pjhatwal" "bjbarcla" "ritikaag" "jmoon18"))
	 (iport     (make-readline-port prompt)))
    (install-history-file) ;;  [homedir] [filename] [nlines])
    (with-input-from-port iport
      (lambda ()
	(let loop ((inl (read-line)))
	  (if (not (or (eof-object? inl)
		       (equal? inl "exit")))
	      (let* ((parts (string-split inl))
		     (cmd   (if (null? parts) #f (car parts))))
		(if (not cmd)
		    (loop (read-line))
		    (case (string->symbol cmd)
		      ((cd)
		       (if (> (length parts) 1) ;; have a parameter
			   (set! path (append path (string-split (cadr parts)))) ;; not correct for relative paths
			   (set! path '())))
		      ((ls)
		       (let* ((thepath (if (> (length parts) 1) ;; have a parameter
					   (cdr parts)
					   path))
			      (plen    (length thepath)))
			 (cond
			  ((null? thepath)
			   (print (string-intersperse top-areas " ")))
			  ((and (< plen 2)
				(member (car thepath) top-areas))
			   (system (conc "ls /p/fdk/gwa/" (car thepath))))
			  (else ;; have a long path
			   ;; check for access rights here
			   (system (conc "ls /p/fdk/gwa/" (string-intersperse thepath "/")))))))
		      (else 
		       (print "Got command: " inl))))
		(loop (read-line)))))))))
    

;;======================================================================
;; MAIN
;;======================================================================

(define (sretrieve:load-config exe-dir exe-name)
  (let* ((fname   (conc exe-dir "/." exe-name ".config")))
556
557
558
559
560
561
562


563
564
565
566
567
568
569
570
571
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619







+
+









	((log)
	 (sretrieve:db-do configdat (lambda (db)
				     (print "Logs : ")
				     (query (for-each-row
					     (lambda (row)
					       (apply print (intersperse row " | "))))
					    (sql db "SELECT * FROM actions")))))
	((shell)
	 (sretrieve:shell))
	(else
	 (print "ERROR: Unrecognised command. Try \"sretrieve help\""))))
     ;; multi-word commands
     ((null? rema)(print sretrieve:help))
     ((>= (length rema) 2)
      (apply sretrieve:process-action configdat (car rema)(cdr rema)))
     (else (debug:print 0 "ERROR: Unrecognised command. Try \"sretrieve help\"")))))

(main)