Megatest

Diff
Login

Differences From Artifact [a300371475]:

To Artifact [48ed807e56]:


36
37
38
39
40
41
42
43



44
45
46
47
48
49
50
36
37
38
39
40
41
42

43
44
45
46
47
48
49
50
51
52







-
+
+
+







(define *incoming-mutex*     (make-mutex))
(define *cache-on* #f)

(define (open-db) ;;  (conc *toppath* "/megatest.db") (car *configinfo*)))
  (let* ((dbpath    (conc *toppath* "/megatest.db")) ;; fname)
	 (dbexists  (file-exists? dbpath))
	 (db        (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath))
	 (handler   (make-busy-timeout 3600))) ;; 136000)))
	 (handler   (make-busy-timeout (if (args:get-arg "-override-timeout")
					   (string->number (args:get-arg "-override-timeout"))
					   36000)))) ;; 136000)))
    (sqlite3:set-busy-handler! db handler)
    (if (not dbexists)
	(db:initialize db))
    db))

(define (db:initialize db)
  (let* ((configdat (car *configinfo*))  ;; tut tut, global warning...
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
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







-
+


-
-
+
+








-
+

-
-
+
+







       (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment)))
     db 
     "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment FROM tests WHERE id=?;"
     test-id)
    res))


(define (db:test-set-comment db run-id test-name item-path comment)
(define (db:test-set-comment db test-id comment)
  (sqlite3:execute 
   db 
   "UPDATE tests SET comment=? WHERE run_id=? AND testname=? AND item_path=?;"
   comment run-id test-name item-path))
   "UPDATE tests SET comment=? WHERE id=?;"
   comment test-id))

;;
(define (db:test-set-rundir! db run-id test-name item-path rundir)
  (sqlite3:execute 
   db 
   "UPDATE tests SET rundir=? WHERE run_id=? AND testname=? AND item_path=?;"
   rundir run-id test-name item-path))

(define (db:test-set-log! db run-id test-name item-path logf)
(define (db:test-set-log! db test-id logf)
  (if (string? logf)
      (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path=?;" 
		   logf run-id test-name item-path)
      (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE id=?;"
		   logf test-id)
      (debug:print 0 "ERROR: db:test-set-log! called with non-string log file name " logf)))

;;======================================================================
;; Misc. test related queries
;;======================================================================

(define (db:test-get-paths-matching db keynames target)
680
681
682
683
684
685
686


687
688

689
690
691
692
693
694
695
696
697
682
683
684
685
686
687
688
689
690
691

692


693
694
695
696
697
698
699







+
+

-
+
-
-







		     ((meta-info)
		      (apply sqlite3:execute meta-stmt (vector-ref entry 2)))
		     ((step-status)
		      (apply sqlite3:execute step-stmt (vector-ref entry 2)))
		     (else
		      (debug:print 0 "ERROR: Queued entry not recognised " entry))))
		 data)))
    (sqlite3:finalize! meta-stmt) ;; sqlite is the bottleneck, clear the statements asap?
    (sqlite3:finalize! step-stmt)
    (set! *incoming-data* '())
    (mutex-unlock! *incoming-mutex*)
    (mutex-unlock! *incoming-mutex*)))
    (sqlite3:finalize! meta-stmt)
    (sqlite3:finalize! step-stmt)))

(define (db:roll-up-pass-fail-counts db run-id test-name item-path status)
  (if (and (not (equal? item-path ""))
	   (or (equal? status "PASS")
	       (equal? status "WARN")
	       (equal? status "FAIL")
	       (equal? status "WAIVED")
711
712
713
714
715
716
717
718



719
720
721
722
723
724
725
713
714
715
716
717
718
719

720
721
722
723
724
725
726
727
728
729







-
+
+
+







	     db
	     "UPDATE tests
                       SET state=CASE WHEN (SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND state in ('RUNNING','NOT_STARTED')) > 0 THEN 
                          'RUNNING'
                       ELSE 'COMPLETED' END,
                          status=CASE WHEN fail_count > 0 THEN 'FAIL' WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' ELSE 'UNKNOWN' END
                       WHERE run_id=? AND testname=? AND item_path='';"
	     run-id test-name run-id test-name)))))
	     run-id test-name run-id test-name))
	#f)
      #f))


;;======================================================================
;; Tests meta data
;;======================================================================

;; read the record given a testname
807
808
809
810
811
812
813
814

815
816
817
818
819
820
821
822
823
824
825
826
827
828
829









830
831
832
833
834
835
836
811
812
813
814
815
816
817

818















819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834







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







    (sqlite3:for-each-row 
     (lambda (id test_id category variable value expected tol units comment status type)
       (set! res (cons (vector id test_id category variable value expected tol units comment status type) res)))
     db
     "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt)
    (reverse res)))

(define (db:load-test-data db run-id test-name itemdat)
(define (db:load-test-data db test-id)
  (let* ((item-path (item-list->path itemdat))
	 (testdat (rdb:get-test-info db run-id test-name item-path))
	 (test-id (if testdat (db:test-get-id testdat) #f)))
    ;; (debug:print 1 "Enter records to insert in the test_data table, seven fields, comma separated per line")
    (debug:print 4 "itemdat: " itemdat ", test-name: " test-name ", test-id: " test-id)
    (if test-id
	(let loop ((lin (read-line)))
	  (if (not (eof-object? lin))
	      (begin
		(debug:print 4 lin)
		(rdb:csv->test-data db test-id lin)
		(loop (read-line))))))
    ;; roll up the current results.
    ;; FIXME: Add the status to 
    (rdb:test-data-rollup db test-id #f)))
  (let loop ((lin (read-line)))
    (if (not (eof-object? lin))
	(begin
	  (debug:print 4 lin)
	  (rdb:csv->test-data db test-id lin)
	  (loop (read-line)))))
  ;; roll up the current results.
  ;; FIXME: Add the status to 
  (rdb:test-data-rollup db test-id #f))

;; WARNING: Do NOT call this for the parent test on an iterated test
;; Roll up test_data pass/fail results
;; look at the test_data status field, 
;;    if all are pass (any case) and the test status is PASS or NULL or '' then set test status to PASS.
;;    if one or more are fail (any case) then set test status to PASS, non "pass" or "fail" are ignored
(define (db:test-data-rollup db test-id status)
1174
1175
1176
1177
1178
1179
1180
1181

1182
1183
1184
1185
1186
1187


1188
1189

1190
1191
1192
1193
1194


1195
1196
1197
1198
1199
1200
1201
1172
1173
1174
1175
1176
1177
1178

1179
1180
1181
1182
1183


1184
1185
1186

1187
1188
1189
1190


1191
1192
1193
1194
1195
1196
1197
1198
1199







-
+




-
-
+
+

-
+



-
-
+
+







  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	((rpc:procedure 'rdb:roll-up-pass-fail-counts host port)
	 run-id test-name item-path status))
      (db:roll-up-pass-fail-counts db run-id test-name item-path status)))

(define (rdb:test-set-comment db run-id test-name item-path comment)
(define (rdb:test-set-comment db test-id comment)
  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	((rpc:procedure 'rdb:test-set-comment host port)
	 run-id test-name item-path comment))
      (db:test-set-comment db run-id test-name item-path comment)))
	 test-id comment))
      (db:test-set-comment db test-id comment)))

(define (rdb:test-set-log! db run-id test-name item-path logf)
(define (rdb:test-set-log! db test-id logf)
  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	((rpc:procedure 'rdb:test-set-log! host port) run-id test-name item-path logf))
      (db:test-set-log! db run-id test-name item-path logf)))
	((rpc:procedure 'rdb:test-set-log! host port) test-id logf))
      (db:test-set-log! db test-id logf)))

(define (rdb:get-runs db runnamepatt numruns startrunoffset keypatts)
  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	((rpc:procedure 'rdb:get-runs host port)
	 runnamepatt numruns startrunoffset keypatts))