Megatest

Check-in [8bf767b71b]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Little bit further
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | refactor-dbr:dbstruct
Files: files | file ages | folders
SHA1: 8bf767b71b6ae0823eb72a59e63e5d31436cd923
User & Date: matt on 2016-01-28 23:22:22
Other Links: branch diff | manifest | tags
Context
2016-09-08
23:34
Merged v1.61 into refactor-dbr:dbstruct branch. Can use meld to bring some of the work back to v1.62 Closed-Leaf check-in: ac0e82322e user: matt tags: refactor-dbr:dbstruct
2016-01-28
23:22
Little bit further check-in: 8bf767b71b user: matt tags: refactor-dbr:dbstruct
11:00
some progress on unit tests check-in: 473832ad6f user: bjbarcla tags: refactor-dbr:dbstruct
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Modified api.scm from [36f919b0c4] to [b315c63e34].

︙︙
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149

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

	    ;; SERVERS
	    ((start-server)                    (apply server:kind-run params))
	    ((kill-server)                     (set! *server-run* #f))

	    ;; TESTS
	    ((test-set-state-status-by-id)     (apply db:test-state-status-by-id-set! dbstruct params))
	    ((delete-test-records)             (apply db:delete-test-records dbstruct params))
	    ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params))
	    ((test-set-status-state)           (apply db:test-status-state-set! dbstruct params))
	    ((test-set-top-process-pid)        (apply db:test-set-top-process-pid dbstruct params))
	    ((roll-up-pass-fail-counts)        (apply db:roll-up-pass-fail-counts dbstruct params))
	    ;; ((update-pass-fail-counts)         (apply db:general-call dbstruct 'update-pass-fail-counts params))
	    ((top-test-set-per-pf-counts)      (apply db:top-test-set-per-pf-counts dbstruct params))
	    ((test-set-archive-block-id)       (apply db:test-set-archive-block-id dbstruct params))

	    ;; RUNS








|


|








132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149

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

	    ;; SERVERS
	    ((start-server)                    (apply server:kind-run params))
	    ((kill-server)                     (set! *server-run* #f))

	    ;; TESTS
	    ((test-set-state-status-by-id)     (apply db:test-set-state-status-by-id dbstruct params))
	    ((delete-test-records)             (apply db:delete-test-records dbstruct params))
	    ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params))
	    ((test-set-status-state)           (apply db:test-set-status-state dbstruct params))
	    ((test-set-top-process-pid)        (apply db:test-set-top-process-pid dbstruct params))
	    ((roll-up-pass-fail-counts)        (apply db:roll-up-pass-fail-counts dbstruct params))
	    ;; ((update-pass-fail-counts)         (apply db:general-call dbstruct 'update-pass-fail-counts params))
	    ((top-test-set-per-pf-counts)      (apply db:top-test-set-per-pf-counts dbstruct params))
	    ((test-set-archive-block-id)       (apply db:test-set-archive-block-id dbstruct params))

	    ;; RUNS
︙︙
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216

	    ;; KEYS
	    ((get-key-val-pairs)               (apply db:get-key-val-pairs dbstruct params))
	    ((get-keys)                        (db:get-keys dbstruct))
	    ((get-key-vals)                    (apply db:get-key-vals dbstruct params))
	    ((get-targets)                     (db:get-targets  dbstruct))

	    ;; ARCHIVES
	    ((test-get-archive-block-info)     (apply db:test-archive-block-info dbstruct params))
	    
	    ;; TESTS
	    ((test-toplevel-num-items)         (apply db:test-toplevel-num-items dbstruct params))
	    ((get-test-info-by-id)	       (apply db:get-test-info-by-id dbstruct params))
	    ((test-get-rundir-from-test-id)    (apply db:test-rundir-from-test-id dbstruct params))
	    ((get-count-tests-running-for-testname) (apply db:get-count-tests-running-for-testname dbstruct params))
	    ((get-count-tests-running)         (apply db:get-count-tests-running dbstruct params))
	    ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params))
	    ;; ((delete-test-step-records)        (apply db:delete-test-step-records dbstruct params))
	    ((get-previous-test-run-record)    (apply db:get-previous-test-run-record dbstruct params))
	    ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params))
	    ((test-get-logfile-info)           (apply db:test-logfile-info dbstruct params))
	    ((test-get-records-for-index-file)  (apply db:test-records-for-index-file dbstruct params))
	    ((get-testinfo-state-status)       (apply db:get-testinfo-state-status dbstruct params))
	    ((test-get-top-process-pid)        (apply db:test-top-process-pid dbstruct params))
	    ((test-get-paths-matching-keynames-target-new) (apply db:test-paths-matching-keynames-target-new dbstruct params))
	    ((get-prereqs-not-met)             (apply db:get-prereqs-not-met dbstruct params))
	    ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params))
	    ((synchash-get)                    (apply synchash:server-get dbstruct params))

	    ;; RUNS
	    ((get-run-info)                 (apply db:get-run-info dbstruct params))
	    ((get-run-status)               (apply db:get-run-status dbstruct params))








|




|






|
|

|
|








186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216

	    ;; KEYS
	    ((get-key-val-pairs)               (apply db:get-key-val-pairs dbstruct params))
	    ((get-keys)                        (db:get-keys dbstruct))
	    ((get-key-vals)                    (apply db:get-key-vals dbstruct params))
	    ((get-targets)                     (db:get-targets  dbstruct))

	    ;; ARCHIVES
	    ((test-get-archive-block-info)     (apply db:test-get-archive-block-info dbstruct params))
	    
	    ;; TESTS
	    ((test-toplevel-num-items)         (apply db:test-toplevel-num-items dbstruct params))
	    ((get-test-info-by-id)	       (apply db:get-test-info-by-id dbstruct params))
	    ((test-get-rundir-from-test-id)    (apply db:test-get-rundir-from-test-id dbstruct params))
	    ((get-count-tests-running-for-testname) (apply db:get-count-tests-running-for-testname dbstruct params))
	    ((get-count-tests-running)         (apply db:get-count-tests-running dbstruct params))
	    ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params))
	    ;; ((delete-test-step-records)        (apply db:delete-test-step-records dbstruct params))
	    ((get-previous-test-run-record)    (apply db:get-previous-test-run-record dbstruct params))
	    ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params))
	    ((test-get-logfile-info)           (apply db:test-get-logfile-info dbstruct params))
	    ((test-get-records-for-index-file)  (apply db:test-get-records-for-index-file dbstruct params))
	    ((get-testinfo-state-status)       (apply db:get-testinfo-state-status dbstruct params))
	    ((test-get-top-process-pid)        (apply db:test-get-top-process-pid dbstruct params))
	    ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params))
	    ((get-prereqs-not-met)             (apply db:get-prereqs-not-met dbstruct params))
	    ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params))
	    ((synchash-get)                    (apply synchash:server-get dbstruct params))

	    ;; RUNS
	    ((get-run-info)                 (apply db:get-run-info dbstruct params))
	    ((get-run-status)               (apply db:get-run-status dbstruct params))
︙︙

Modified dashboard.scm from [2973414ade] to [8fcf66ed5d].

︙︙
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232

(define (colors-similar? color1 color2)
  (let* ((c1    (map string->number (string-split color1)))
	 (c2    (map string->number (string-split color2)))
	 (delta (map (lambda (a b)(abs (- a b))) c1 c2)))
    (null? (filter (lambda (x)(> x 3)) delta))))

(define (compare-tests test1 test2)
  (let* ((test-name1  (db:test-testname  test1))
	 (item-path1  (db:test-item-path test1))
	 (eventtime1  (db:test-event_time test1))
	 (test-name2  (db:test-testname  test2))
	 (item-path2  (db:test-item-path test2))
	 (eventtime2  (db:test-event_time test2))
	 (same-name   (equal? test-name1 test-name2))
	 (test1-top   (equal? item-path1 ""))
	 (test2-top   (equal? item-path2 ""))
	 (test1-older (> eventtime1 eventtime2))
	 (same-time   (equal? eventtime1 eventtime2)))			 
    (if same-name








|
|

|
|








214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232

(define (colors-similar? color1 color2)
  (let* ((c1    (map string->number (string-split color1)))
	 (c2    (map string->number (string-split color2)))
	 (delta (map (lambda (a b)(abs (- a b))) c1 c2)))
    (null? (filter (lambda (x)(> x 3)) delta))))

(define (compare-tests test1 test2)
  (let* ((test-name1  (or (db:test-testname  test1) ""))
	 (item-path1  (or (db:test-item-path test1) ""))
	 (eventtime1  (db:test-event_time test1))
	 (test-name2  (or (db:test-testname  test2) ""))
	 (item-path2  (or (db:test-item-path test2) ""))
	 (eventtime2  (db:test-event_time test2))
	 (same-name   (equal? test-name1 test-name2))
	 (test1-top   (equal? item-path1 ""))
	 (test2-top   (equal? item-path2 ""))
	 (test1-older (> eventtime1 eventtime2))
	 (same-time   (equal? eventtime1 eventtime2)))			 
    (if same-name
︙︙
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423

	(if (< i maxn)
	    (loop (+ i 1)))))))

;; 
(define (get-itemized-tests test-dats)
  (let ((tnames '()))
    (for-each (lambda (tdat)
		(let ((tname (db:test-testname tdat))  ;; (db:test-get-testname tdat))
		      (ipath (db:test-item-path tdat) ) ) ;; (db:test-get-item-path tdat)))
		  (if (not (equal? ipath ""))
		      (if (and (list? tnames)
			       (string? tname)
			       (not (member tname tnames)))
			  (set! tnames (append tnames (list tname)))))))
	      test-dats)
    tnames))

;; Bubble up the top tests to above the items, collect the items underneath
;; all while preserving the sort order from the SQL query as best as possible.
;;
(define (bubble-up test-dats #!key (priority 'itempath))
  (if (null? test-dats)
      test-dats
      (begin
	(let* ((tnames   '())                ;; list of names used to reserve order
	       (tests    (make-hash-table))  ;; hash of lists, used to build as we go
	       (itemized (get-itemized-tests test-dats)))
	  (for-each 
	   (lambda (testdat)
             (let* ((tname (db:test-testname tdat))  ;; (db:test-get-testname tdat))
                    (ipath (db:test-item-path tdat))) ;; (db:test-get-item-path tdat)))
	       ;;   (seen  (hash-table-ref/default tests tname #f)))
	       (if (not (member tname tnames))
		   (if (or (and (eq? priority 'itempath)
				(not (equal? ipath "")))
			   (and (eq? priority 'testname)
				(equal? ipath ""))
			   (not (member tname itemized)))








|
|




















|
|








386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423

	(if (< i maxn)
	    (loop (+ i 1)))))))

;; 
(define (get-itemized-tests test-dats)
  (let ((tnames '()))
    (for-each (lambda (tdat)
		(let ((tname (vector-ref tdat 0))  ;; (db:test-testname tdat))  ;; (db:test-get-testname tdat))
		      (ipath (vector-ref tdat 1))) ;; (db:test-item-path tdat) ) ) ;; (db:test-get-item-path tdat)))
		  (if (not (equal? ipath ""))
		      (if (and (list? tnames)
			       (string? tname)
			       (not (member tname tnames)))
			  (set! tnames (append tnames (list tname)))))))
	      test-dats)
    tnames))

;; Bubble up the top tests to above the items, collect the items underneath
;; all while preserving the sort order from the SQL query as best as possible.
;;
(define (bubble-up test-dats #!key (priority 'itempath))
  (if (null? test-dats)
      test-dats
      (begin
	(let* ((tnames   '())                ;; list of names used to reserve order
	       (tests    (make-hash-table))  ;; hash of lists, used to build as we go
	       (itemized (get-itemized-tests test-dats)))
	  (for-each 
	   (lambda (testdat)
             (let* ((tname (vector-ref testdat 0))  ;; (db:test-testname tdat))  ;; (db:test-get-testname tdat))
                    (ipath (vector-ref testdat 1))) ;; (db:test-item-path tdat))) ;; (db:test-get-item-path tdat)))
	       ;;   (seen  (hash-table-ref/default tests tname #f)))
	       (if (not (member tname tnames))
		   (if (or (and (eq? priority 'itempath)
				(not (equal? ipath "")))
			   (and (eq? priority 'testname)
				(equal? ipath ""))
			   (not (member tname itemized)))
︙︙
506
507
508
509
510
511
512

513













514
515
516
517
518
519
520

	    (lambda (testname)
	      (let ((buttondat  (hash-table-ref/default *buttondat* (mkstr coln rown) #f)))
		(if buttondat
		    (let* ((test       (let ((matching (filter 
							(lambda (x)(equal? (test:test-get-fullname x) testname))
							testsdat)))
					 (if (null? matching)

					     (vector -1 -1 "" "" "" 0 "" "" 0 "" "" "" 0 "" "")













					     (car matching))))
			   (testname   (db:test-testname  test))
			   (itempath   (db:test-item-path test))
			   (testfullname (test:test-get-fullname test))
			   (teststatus (db:test-status   test))
			   (teststate  (db:test-state    test))
			   ;;(teststart  (db:test-event_time test))








>
|
>
>
>
>
>
>
>
>
>
>
>
>
>








506
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

	    (lambda (testname)
	      (let ((buttondat  (hash-table-ref/default *buttondat* (mkstr coln rown) #f)))
		(if buttondat
		    (let* ((test       (let ((matching (filter 
							(lambda (x)(equal? (test:test-get-fullname x) testname))
							testsdat)))
					 (if (null? matching)
					     (make-db:test id: -1
							   run_id: -1
							   testname: ""
							   state: ""
							   status: ""
							   event_time: 0
							   host: ""
							   cpuload: ""
							   diskfree: 0
							   uname: ""
							   rundir: ""
							   item-path: ""
							   run_duration: 0
							   final_logf: ""
							   comment: "")
					     (car matching))))
			   (testname   (db:test-testname  test))
			   (itempath   (db:test-item-path test))
			   (testfullname (test:test-get-fullname test))
			   (teststatus (db:test-status   test))
			   (teststate  (db:test-state    test))
			   ;;(teststart  (db:test-event_time test))
︙︙

Modified db.scm from [57558c8677] to [1bcfba7312].

︙︙
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152

   #f
   (lambda (db)
     (sqlite3:execute db "UPDATE tests SET archived=? WHERE id=?;"
		      archive-block-id test-id))))
 
;; Look up the archive block info given a block-id
;;
(define (db:test-archive-block-info dbstruct archive-block-id)
  (db:with-db
   dbstruct
   #f
   #f
   (lambda (db)
     (let ((res #f))
       (sqlite3:for-each-row 








|








1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152

   #f
   (lambda (db)
     (sqlite3:execute db "UPDATE tests SET archived=? WHERE id=?;"
		      archive-block-id test-id))))
 
;; Look up the archive block info given a block-id
;;
(define (db:test-get-archive-block-info dbstruct archive-block-id)
  (db:with-db
   dbstruct
   #f
   #f
   (lambda (db)
     (let ((res #f))
       (sqlite3:for-each-row
︙︙
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211

		       qry
		       run-id
		       )))
        ;; (case qryvals
        ;;   ((shortlist)(map db:test-short-record->norm res))
        ;;   ((#f)       res)
        ;;   (else       res)))))
        (if (eq? qryvals shortlist)
            (for-each (lambda (inrec) (db:test-short-record->norm inrec)) res))
        res)))

(define (db:test-short-record->norm inrec)
  ;;  "id,run_id,testname,item_path,state,status"
  ;;  "id,run_id,testname,state,status, event_time,host,cpuload,diskfree,uname,rundir, item_path, run_duration,final_logf,comment

  (db-test-event_time-set! inrec -1)
  (db-test-host-set!       inrec "")
  (db-test-cpuload-set!    inrec -1)
  (db-test-diskfree-set!   inrec -1)
  (db-test-uname-set!      inrec "")
  (db-test-rundir-set!     inrec "-")
  (db-test-run_duration-set!     inrec "-")
  (db-test-final_logf-set! inrec "-")
  (db-test-comment-set!    inrec "-")
  
  ;; (vector (vector-ref inrec 0) ;; id
  ;;         (vector-ref inrec 1) ;; run_id
  ;;         (vector-ref inrec 2) ;; testname
  ;;         (vector-ref inrec 4) ;; state
  ;;         (vector-ref inrec 5) ;; status
  ;;         -1 "" -1 -1 "" "-" 
  ;;         (vector-ref inrec 3) ;; item-path
  ;;         -1 "-" "-")

  )

(define (db:get-tests-for-run-state-status dbstruct run-id testpatt)
  (let* ((res            '())
	 (tests-match-qry (tests:match->sqlqry testpatt))
         (qryfields '(id testname item_path state,status))
         (qryfields-str (string-join (map ->string qryfields) "," ))
	 (qry             (conc "SELECT " qryfields-str " FROM tests WHERE run_id=? " 
				(if tests-match-qry (conc " AND (" tests-match-qry ") ") ""))))
    (debug:print-info 8 "db:get-tests-for-run qry=" qry)
    (db:with-db dbstruct run-id #f
		(lambda (db)
		  (sqlite3:for-each-row
		   (lambda (id testname item-path state status)
		     ;;                      id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
                     (let ((1res make-db:test))
                       (db:test-id-set! 1res id)
                       (db:test-testname-set! 1res testname)
                       (db:test-item_path-set! 1res item-path)
                       (db:test-state-set! 1res state)
                       (db:test-status-set! 1res status)
                       (db:test-short-record->norm 1res)
                       (set! res (cons 1res res))))
                   ;;(set! res (cons (vector id run-id testname state status -1         ""     -1      -1       ""    "-"  item-path -1           "-"         "-") res)))
                   db 
		   qry








|







|
|
|
|
|
|
|
|
|















|









|


|








2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211

		       qry
		       run-id
		       )))
        ;; (case qryvals
        ;;   ((shortlist)(map db:test-short-record->norm res))
        ;;   ((#f)       res)
        ;;   (else       res)))))
        (if (eq? qryvals 'shortlist)
            (for-each (lambda (inrec) (db:test-short-record->norm inrec)) res))
        res)))

(define (db:test-short-record->norm inrec)
  ;;  "id,run_id,testname,item_path,state,status"
  ;;  "id,run_id,testname,state,status, event_time,host,cpuload,diskfree,uname,rundir, item_path, run_duration,final_logf,comment

  (db:test-event_time-set! inrec -1)
  (db:test-host-set!       inrec "")
  (db:test-cpuload-set!    inrec -1)
  (db:test-diskfree-set!   inrec -1)
  (db:test-uname-set!      inrec "")
  (db:test-rundir-set!     inrec "-")
  (db:test-run_duration-set!     inrec "-")
  (db:test-final_logf-set! inrec "-")
  (db:test-comment-set!    inrec "-")
  
  ;; (vector (vector-ref inrec 0) ;; id
  ;;         (vector-ref inrec 1) ;; run_id
  ;;         (vector-ref inrec 2) ;; testname
  ;;         (vector-ref inrec 4) ;; state
  ;;         (vector-ref inrec 5) ;; status
  ;;         -1 "" -1 -1 "" "-" 
  ;;         (vector-ref inrec 3) ;; item-path
  ;;         -1 "-" "-")

  )

(define (db:get-tests-for-run-state-status dbstruct run-id testpatt)
  (let* ((res            '())
	 (tests-match-qry (tests:match->sqlqry testpatt))
         (qryfields '(id testname item_path state status))
         (qryfields-str (string-join (map ->string qryfields) "," ))
	 (qry             (conc "SELECT " qryfields-str " FROM tests WHERE run_id=? " 
				(if tests-match-qry (conc " AND (" tests-match-qry ") ") ""))))
    (debug:print-info 8 "db:get-tests-for-run qry=" qry)
    (db:with-db dbstruct run-id #f
		(lambda (db)
		  (sqlite3:for-each-row
		   (lambda (id testname item-path state status)
		     ;;                      id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
                     (let ((1res (make-db:test)))
                       (db:test-id-set! 1res id)
                       (db:test-testname-set! 1res testname)
                       (db:test-item-path-set! 1res item-path)
                       (db:test-state-set! 1res state)
                       (db:test-status-set! 1res status)
                       (db:test-short-record->norm 1res)
                       (set! res (cons 1res res))))
                   ;;(set! res (cons (vector id run-id testname state status -1         ""     -1      -1       ""    "-"  item-path -1           "-"         "-") res)))
                   db 
		   qry
︙︙
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639

        ;; BB: replaced following vec construction with db:test defstruct
        ;;(set! res (apply vector a b)))
	db
	(conc "SELECT " db:test-record-qry-selector " FROM tests WHERE testname=? AND item_path=?;")
	test-name item-path)
       res))))

(define (db:test-rundir-from-test-id dbstruct run-id test-id)
  (db:with-db
   dbstruct
   run-id
   #f
   (lambda (db)
     (db:first-result-default
      db








|








2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639

        ;; BB: replaced following vec construction with db:test defstruct
        ;;(set! res (apply vector a b)))
	db
	(conc "SELECT " db:test-record-qry-selector " FROM tests WHERE testname=? AND item_path=?;")
	test-name item-path)
       res))))

(define (db:test-get-rundir-from-test-id dbstruct run-id test-id)
  (db:with-db
   dbstruct
   run-id
   #f
   (lambda (db)
     (db:first-result-default
      db
︙︙
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827

		  (map (lambda (key val)
			 (conc key " like '" val "'"))
		       keynames 
		       (string-split target "/"))
		  " AND "))
	 ;; (testqry (tests:match->sqlqry testpatt))
	 (runsqry (sqlite3:prepare db (conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';"))))
    ;; (debug:print 8 "db:test-paths-matching-keynames-target-new\n  runsqry=" runsqry "\n  tstsqry=" testqry)
    (sqlite3:for-each-row
     (lambda (rid)
       (set! row-ids (cons rid row-ids)))
     runsqry)
    (sqlite3:finalize! runsqry)
    row-ids))

(define (db:test-paths-matching-keynames-target-new dbstruct run-id keynames target res testpatt statepatt statuspatt runname)
  (let* ((testqry (tests:match->sqlqry testpatt))
	 (tstsqry (conc "SELECT rundir FROM tests WHERE " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;")))
    (db:with-db
     dbstruct
     run-id
     #f
     (lambda (db)








|







|








2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827

		  (map (lambda (key val)
			 (conc key " like '" val "'"))
		       keynames 
		       (string-split target "/"))
		  " AND "))
	 ;; (testqry (tests:match->sqlqry testpatt))
	 (runsqry (sqlite3:prepare db (conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';"))))
    ;; (debug:print 8 "db:test-get-paths-matching-keynames-target-new\n  runsqry=" runsqry "\n  tstsqry=" testqry)
    (sqlite3:for-each-row
     (lambda (rid)
       (set! row-ids (cons rid row-ids)))
     runsqry)
    (sqlite3:finalize! runsqry)
    row-ids))

(define (db:test-get-paths-matching-keynames-target-new dbstruct run-id keynames target res testpatt statepatt statuspatt runname)
  (let* ((testqry (tests:match->sqlqry testpatt))
	 (tstsqry (conc "SELECT rundir FROM tests WHERE " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;")))
    (db:with-db
     dbstruct
     run-id
     #f
     (lambda (db)
︙︙
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932

;; 	  (case (string->symbol status)
;; 	    ((RUNNING)  (db:general-call dbdat 'top-test-set-running (list test-name)))
;; 	    ((LAUNCHED) (db:general-call dbdat 'top-test-set (list "LAUNCHED" test-name)))
;; 	    ((ABORT INCOMPLETE) (db:general-call dbdat 'top-test-set (list status test-name))))
;; 	  #f)
;; 	)))

(define (db:test-logfile-info dbstruct run-id test-name)
  (db:with-db
   dbstruct
   run-id
   #f
   (lambda (db)
     (let ((res #f))
       (sqlite3:for-each-row 








|








2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932

;; 	  (case (string->symbol status)
;; 	    ((RUNNING)  (db:general-call dbdat 'top-test-set-running (list test-name)))
;; 	    ((LAUNCHED) (db:general-call dbdat 'top-test-set (list "LAUNCHED" test-name)))
;; 	    ((ABORT INCOMPLETE) (db:general-call dbdat 'top-test-set (list status test-name))))
;; 	  #f)
;; 	)))

(define (db:test-get-logfile-info dbstruct run-id test-name)
  (db:with-db
   dbstruct
   run-id
   #f
   (lambda (db)
     (let ((res #f))
       (sqlite3:for-each-row
︙︙
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264

		   (db:delay-if-busy count: 0))
		  (else
		   (debug:print-info 0 "delaying db access due to high database load.")
		   (thread-sleep! 12.8))))
	    db)
	  "bogus result from db:delay-if-busy")))

(define (db:test-records-for-index-file dbstruct run-id test-name)
  (let ((res '()))
    (db:with-db
     dbstruct
     run-id
     #f
     (lambda (db)
       (sqlite3:for-each-row 








|








3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264

		   (db:delay-if-busy count: 0))
		  (else
		   (debug:print-info 0 "delaying db access due to high database load.")
		   (thread-sleep! 12.8))))
	    db)
	  "bogus result from db:delay-if-busy")))

(define (db:test-get-records-for-index-file dbstruct run-id test-name)
  (let ((res '()))
    (db:with-db
     dbstruct
     run-id
     #f
     (lambda (db)
       (sqlite3:for-each-row
︙︙

Modified gutils.scm from [628c78d614] to [49be3b47ca].

︙︙
19
20
21
22
23
24
25








26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54

(define (gutils:colors-similar? color1 color2)
  (let* ((c1 (map string->number (string-split color1)))
	 (c2 (map string->number (string-split color2)))
	 (delta (map (lambda (a b)(abs (- a b))) c1 c2)))
    (null? (filter (lambda (x)(> x 3)) delta))))

(define (gutils:get-color-for-state-status state status);; #!key (get-label #f))








  ;; ((if get-label cadr car)
  (case (string->symbol state)
    ((COMPLETED) ;; ARCHIVED)
     (case (string->symbol status)
       ((PASS)        (list "70  249 73" status))
       ((WARN WAIVED) (list "255 172 13" status))
       ((SKIP)        (list "230 230 0" status))
       (else (list "253 33 49" status))))
    ((ARCHIVED)
     (case (string->symbol status)
       ((PASS)        (list "70  170 73" status))
       ((WARN WAIVED) (list "200 130 13" status))
       ((SKIP)        (list "180 180 0" status))
       (else (list "180 33 49" status))))
    ;;      (if (equal? status "PASS")
    ;;	  '("70 249 73" "PASS")
    ;;	  (if (or (equal? status "WARN")
    ;;		  (equal? status "WAIVED"))
    ;;	      (list "255 172 13" status)
    ;;	      (list "223 33 49"  status)))) ;; greenish orangeish redish
    ((LAUNCHED)         (list "101 123 142"  state))
    ((CHECK)            (list "255 100 50"   state))
    ((REMOTEHOSTSTART)  (list "50 130 195"   state))
    ((RUNNING)          (list "9 131 232"    state))
    ((KILLREQ)          (list "39 82 206"    state))
    ((KILLED)           (list "234 101 17"   state))
    ((NOT_STARTED)      (list "240 240 240"  state))
    (else               (list "192 192 192"  state))))









>
>
>
>
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|


19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62

(define (gutils:colors-similar? color1 color2)
  (let* ((c1 (map string->number (string-split color1)))
	 (c2 (map string->number (string-split color2)))
	 (delta (map (lambda (a b)(abs (- a b))) c1 c2)))
    (null? (filter (lambda (x)(> x 3)) delta))))

(define (gutils:get-color-for-state-status state status);; #!key (get-label #f))
  (cond
   ((not (string? state))
    (debug:print 0 "ERROR: gutils:get-color-for-state-status recieved non-string state " state)
    (list "253 33 49" status))
   ((not (string? status))
    (debug:print 0 "ERROR: gutils:get-color-for-state-status recieved non-string status " status)
    (list "253 33 49" status))
   (else
    ;; ((if get-label cadr car)
    (case (string->symbol state)
      ((COMPLETED) ;; ARCHIVED)
       (case (string->symbol status)
	 ((PASS)        (list "70  249 73" status))
	 ((WARN WAIVED) (list "255 172 13" status))
	 ((SKIP)        (list "230 230 0" status))
	 (else (list "253 33 49" status))))
      ((ARCHIVED)
       (case (string->symbol status)
	 ((PASS)        (list "70  170 73" status))
	 ((WARN WAIVED) (list "200 130 13" status))
	 ((SKIP)        (list "180 180 0" status))
	 (else (list "180 33 49" status))))
      ;;      (if (equal? status "PASS")
      ;;	  '("70 249 73" "PASS")
      ;;	  (if (or (equal? status "WARN")
      ;;		  (equal? status "WAIVED"))
      ;;	      (list "255 172 13" status)
      ;;	      (list "223 33 49"  status)))) ;; greenish orangeish redish
      ((LAUNCHED)         (list "101 123 142"  state))
      ((CHECK)            (list "255 100 50"   state))
      ((REMOTEHOSTSTART)  (list "50 130 195"   state))
      ((RUNNING)          (list "9 131 232"    state))
      ((KILLREQ)          (list "39 82 206"    state))
      ((KILLED)           (list "234 101 17"   state))
      ((NOT_STARTED)      (list "240 240 240"  state))
      (else               (list "192 192 192"  state))))))

Modified runs.scm from [cb71d2d7c9] to [a3d8939c92].

︙︙
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024

    ;; convert state to symbol and use that as the hash value
    (for-each (lambda (trec)
		(let ((id (db:test-id        trec))
		      (tn (db:test-testname  trec))
		      (ip (db:test-item-path trec))
		      (st (db:test-state     trec)))
		  (if (not (equal? st "DELETED"))
		      (hash-table-set! test-registry (db:test-make-full-name tn ip) (string->symbol st)))))
	      tests-info)
    (set! max-retries (if (and max-retries (string->number max-retries))(string->number max-retries) 100))

    (let loop ((hed         (car sorted-test-names))
	       (tal         (cdr sorted-test-names))
	       (reg         '()) ;; registered, put these at the head of tal 
	       (reruns      '()))








|








1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024

    ;; convert state to symbol and use that as the hash value
    (for-each (lambda (trec)
		(let ((id (db:test-id        trec))
		      (tn (db:test-testname  trec))
		      (ip (db:test-item-path trec))
		      (st (db:test-state     trec)))
		  (if (not (equal? st "DELETED"))
		      (hash-table-set! test-registry (db:test-make-full-name tn ip) (string->symbol (or st "#F=>BAD DATA"))))))
	      tests-info)
    (set! max-retries (if (and max-retries (string->number max-retries))(string->number max-retries) 100))

    (let loop ((hed         (car sorted-test-names))
	       (tal         (cdr sorted-test-names))
	       (reg         '()) ;; registered, put these at the head of tal 
	       (reruns      '()))
︙︙
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171

						  (string-intersperse varval "="))
						row)
					   " ")
					  "\n"))
				  items)))
	  (for-each
	   (lambda (my-itemdat)
	     (let* ((new-test-record (let ((newrec (make-tests:testqueue)))
				       (vector-copy! test-record newrec)
				       newrec))
		    (my-item-path (item-list->path my-itemdat)))
	       (if (tests:match test-patts hed my-item-path required: required-tests) ;; (patt-list-match my-item-path item-patts)           ;; yes, we want to process this item, NOTE: Should not need this check here!
		   (let ((newtestname (db:test-make-full-name hed my-item-path)))    ;; test names are unique on testname/item-path
		     (tests:testqueue-set-items!     new-test-record #f)
		     (tests:testqueue-set-itemdat!   new-test-record my-itemdat)
		     (tests:testqueue-set-item_path! new-test-record my-item-path)
		     (hash-table-set! test-records newtestname new-test-record)
		     (set! tal (append tal (list newtestname))))))) ;; since these are itemized create new test names testname/itempath
	   items)








|
|
<
|
|








1153
1154
1155
1156
1157
1158
1159
1160
1161

1162
1163
1164
1165
1166
1167
1168
1169
1170

						  (string-intersperse varval "="))
						row)
					   " ")
					  "\n"))
				  items)))
	  (for-each
	   (lambda (my-itemdat)
	     (let* ((new-test-record (make-tests:testqueue))
				     ;;  (update-tests:testqueue test-record)))

		    (my-item-path    (item-list->path my-itemdat)))
	     (if (tests:match test-patts hed my-item-path required: required-tests) ;; (patt-list-match my-item-path item-patts)           ;; yes, we want to process this item, NOTE: Should not need this check here!
		   (let ((newtestname (db:test-make-full-name hed my-item-path)))    ;; test names are unique on testname/item-path
		     (tests:testqueue-set-items!     new-test-record #f)
		     (tests:testqueue-set-itemdat!   new-test-record my-itemdat)
		     (tests:testqueue-set-item_path! new-test-record my-item-path)
		     (hash-table-set! test-records newtestname new-test-record)
		     (set! tal (append tal (list newtestname))))))) ;; since these are itemized create new test names testname/itempath
	   items)
︙︙

Modified tests/unittests/runs.scm from [267c3ffa13] to [e0bcac340a].

︙︙
117
118
119
120
121
122
123




124
125
126
127
128
129
130

   (rmt:register-test 1 "rollup" itempath)
   (let ((test-id (rmt:get-test-id 1 "rollup" itempath))
	 (comment (conc "This is a comment for itempath " itempath)))
     ;; (rmt:test-set-state-status-by-id run-id test-id "COMPLETED" "PASS" comment)
      (tests:test-set-status! 1 test-id "COMPLETED" "PASS" comment #f))) ;;  #!key (work-area #f))
 '("item/1" "item/2" "item/3" "item/4" "item/5"))
 




(test #f #t (number? (rmt:get-test-id 1 "rollup" "item/4")))

(define (get-state-status run-id testname itempath)
  (let ((tdat (rmt:get-test-info-by-id 1 (rmt:get-test-id run-id testname itempath))))
    (list (db:test-state  tdat)
	  (db:test-status tdat))))









>
>
>
>








117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134

   (rmt:register-test 1 "rollup" itempath)
   (let ((test-id (rmt:get-test-id 1 "rollup" itempath))
	 (comment (conc "This is a comment for itempath " itempath)))
     ;; (rmt:test-set-state-status-by-id run-id test-id "COMPLETED" "PASS" comment)
      (tests:test-set-status! 1 test-id "COMPLETED" "PASS" comment #f))) ;;  #!key (work-area #f))
 '("item/1" "item/2" "item/3" "item/4" "item/5"))
 

(exit)


(test #f #t (number? (rmt:get-test-id 1 "rollup" "item/4")))

(define (get-state-status run-id testname itempath)
  (let ((tdat (rmt:get-test-info-by-id 1 (rmt:get-test-id run-id testname itempath))))
    (list (db:test-state  tdat)
	  (db:test-status tdat))))
︙︙

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