Megatest

Check-in [f6db288849]
Login
Overview
Comment:wip
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.63-xor-report
Files: files | file ages | folders
SHA1: f6db2888496dca454e1211440d00b7a5959d6343
User & Date: bjbarcla on 2017-01-13 17:53:52
Other Links: branch diff | manifest | tags
Context
2017-01-13
17:54
mergefork check-in: 460f43937c user: bjbarcla tags: v1.63-xor-report
17:53
wip check-in: f6db288849 user: bjbarcla tags: v1.63-xor-report
17:06
wip check-in: 6217b90877 user: bjbarcla tags: v1.63-xor-report
Changes

Modified diff-report.scm from [0053a9f3a7] to [ce3a2d0284].

11
12
13
14
15
16
17














































































































18
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
63
;; #;; (rmt:get-test-info-by-id run-id test-id)
;; #;;  (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode)

;; megatest -repl << EOF

;; TODO:dashboard not on homehost message exit















































































































(define (run-name->run-id runname)
  (let* ((qry-res (rmt:get-runs runname 1 0 '())))
    (if (eq? 2 (vector-length qry-res))
        (vector-ref (car (vector-ref qry-res 1)) 1)
        #f)))




(define (run-name->test-ht runname)
  (let* ((ht (make-hash-table))
         (run-id (run-name->run-id runname))
         (testpatt "%/%")
         (states '("COMPLETED" "INCOMPLETE"))
         (statuses '("PASS" "FAIL" "ABORT" "SKIP"))


         (offset #f)
         (limit #f)
         (not-in #f)
         (sort-by #f)
         (sort-order #f)

         (qryvals "id,testname,item_path,state,status")
         (last-update 0)
         (mode #f)
         )
    (print run-id)











    (print (rmt:get-tests-for-run run-id
                                  testpatt states statuses
                                  offset limit
                                  not-in sort-by sort-order
                                  qryvals
                                  last-update
                                  mode))
    ;(print (rmt:get-tests-for-run run-id testpatt  states statuses offset limit not-in "%" "%" #f "id,testname,testpath,state,status" 0 'normal))
    ;(print run-id)

    ))

(run-name->test-ht "all57")







;;(exit)

;;EOF

         







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







>
>
|
<
|

|
|
>
>


|


>





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


>


|



|
|
>






11
12
13
14
15
16
17
18
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
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
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137

138
139
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
180
181
182
183
184
185
186
187
188
189
190
;; #;; (rmt:get-test-info-by-id run-id test-id)
;; #;;  (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode)

;; megatest -repl << EOF

;; TODO:dashboard not on homehost message exit


(define (tests-mindat->hash tests-mindat)
  (let* ((res (make-hash-table)))
    (for-each
     (lambda (item)
       (let* ((test-name+item-path (cons (list-ref item 0) (list-ref item 1)))
              (value (list-ref item 2)))
         (hash-table-set! res test-name+item-path value)))
     tests-mindat)
    res))

;; return 1 if status1 is better
;; return 0 if status1 and 2 are equally good
;; return -1 if status2 is better
(define (status-compare3 status1 status2)
  (let*
      ((status-goodness-ranking  (list "PASS" "WARN" "WAIVED" "SKIP" "FAIL" "ABORT" #f))
       (mem1 (member status1 status-goodness-ranking))
       (mem2 (member status2 status-goodness-ranking))
       )
    (cond
     ((and (not mem1) (not mem2)) 0)
     ((not mem1) -1)
     ((not mem2) 1)
     ((= (length mem1) (length mem2)) 0)
     ((> (length mem1) (length mem2)) 1)
     (else -1))))


(define (xor-tests-mindat src-tests-mindat dest-tests-mindat #!key (hide-clean #f))
  (let* ((src-hash (tests-mindat->hash src-tests-mindat))
         (dest-hash (tests-mindat->hash dest-tests-mindat))
         (all-keys
          (reverse (sort 
           (delete-duplicates
            (append (hash-table-keys src-hash) (hash-table-keys dest-hash)))

           (lambda (a b) 
             (cond
              ((< 0 (string-compare3 (car a) (car b))) #t)
              ((> 0 (string-compare3 (car a) (car b))) #f)
              ((< 0 (string-compare3 (cdr a) (cdr b))) #t)
              (else #f)))

           ))))
    (let ((res
           (map ;; TODO: rename xor to delta globally in dcommon and dashboard
            (lambda (key)
              (let* ((test-name (car key))
                     (item-path (cdr key))

                     (dest-value (hash-table-ref/default dest-hash key #f)) ;; (list test-id state status)
                     (dest-test-id  (if dest-value (list-ref dest-value 0) #f))
                     (dest-state    (if dest-value (list-ref dest-value 1) #f))
                     (dest-status   (if dest-value (list-ref dest-value 2) #f))

                     (src-value     (hash-table-ref/default src-hash key #f))   ;; (list test-id state status)
                     (src-test-id   (if src-value (list-ref src-value 0) #f))
                     (src-state     (if src-value (list-ref src-value 1) #f))
                     (src-status    (if src-value (list-ref src-value 2) #f))

                     (incomplete-statuses '("DELETED" "INCOMPLETE" "STUCK/DEAD" "N/A")) ;; if any of these statuses apply, treat test as incomplete

                     (dest-complete
                      (and dest-value dest-state dest-status
                           (equal? dest-state "COMPLETED")
                           (not (member dest-status incomplete-statuses))))
                     (src-complete
                      (and src-value src-state src-status
                           (equal? src-state "COMPLETED")
                           (not (member src-status incomplete-statuses))))
                     (status-compare-result (status-compare3 src-status dest-status))
                     (xor-new-item
                      (cond
                       ;; complete, for this case means: state=compelte AND status not in ( deleted uncomplete stuck/dead n/a )
                       ;; neither complete -> bad

                       ;; src !complete, dest complete -> better
                       ((and (not dest-complete) (not src-complete))
                        (list dest-test-id "BOTH-BAD" "BOTH-INCOMPLETE"))
                       ((not dest-complete)
                        (list src-test-id "DIFF-MISSING" "DEST-INCOMPLETE"))  
                       ((not src-complete)
                        (list dest-test-id "DIFF-NEW" "SRC-INCOMPLETE"))      
                       ((and
                         (equal? src-state dest-state)
                         (equal? src-status dest-status))
                        (list dest-test-id  (conc "CLEAN") (conc "CLEAN-" dest-status) )) 
                       ;;    better or worse: pass > warn > waived > skip > fail > abort
                       ;;     pass > warn > waived > skip > fail > abort
                       
                       ((= 1 status-compare-result) ;; src is better, dest is worse
                        (list dest-test-id "DIRTY-WORSE" (conc src-status "->" dest-status)))
                       (else
                        (list dest-test-id "DIRTY-BETTER" (conc src-status "->" dest-status)))
                       )))
                (list test-name item-path  xor-new-item)))
            all-keys)))

      (if hide-clean
          (filter
           (lambda (item)
             ;;(print item)
             (not
              (equal?
               "CLEAN"
               (list-ref (list-ref item 2) 1))))
           res)
          res))))

(define (run-name->run-id runname)
  (let* ((qry-res (rmt:get-runs runname 1 0 '())))
    (if (eq? 2 (vector-length qry-res))
        (vector-ref (car (vector-ref qry-res 1)) 1)
        #f)))




(define (run-name->tests-mindat runname)

  (let* ((run-id (run-name->run-id runname))
         (testpatt "%/%")
;;         (states '("COMPLETED" "INCOMPLETE"))
 ;;        (statuses '("PASS" "FAIL" "ABORT" "SKIP"))
         (states '())
         (statuses '())
         (offset #f)
         (limit #f)
         (not-in #t)
         (sort-by #f)
         (sort-order #f)
         (qryvals "id,testname,item_path,state,status")
         (qryvals "id,testname,item_path,state,status")
         (last-update 0)
         (mode #f)
         )
    (print run-id)
    (map
     (lambda (row)
       (let* ((id        (vector-ref row 0))
              (test-name  (vector-ref row 1))
              (item-path (vector-ref row 2))
              (state     (vector-ref row 3))
              (status    (vector-ref row 4)))
         ;;(hash-table-set! ht (cons testname item_path) (list id state status))
         (list test-name item-path (list id state status))
         ;;(print testname id))
       ))
     (rmt:get-tests-for-run run-id
                            testpatt states statuses
                            offset limit
                            not-in sort-by sort-order
                            qryvals
                            last-update
                            mode))
    ;(print (rmt:get-tests-for-run run-id testpatt  states statuses offset limit not-in "%" "%" #f "id,testname,testpath,state,status" 0 'normal))
    ;(print run-id)

    ))

(print (run-name->tests-mindat "all60"))



(let* ((src-tests-mindat  (run-name->tests-mindat "all57"))
       (dest-tests-mindat (run-name->tests-mindat "all60")))
  (print (xor-tests-mindat src-tests-mindat dest-tests-mindat)));; #!key (hide-clean #f))

;;(exit)

;;EOF