Random Bits of Open Code

Check-in [7d200f0d31]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Added mindata-filtered
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:7d200f0d31d76597f29201231e77eb289a4fa268
User & Date: mrwellan 2018-05-09 03:32:43
Context
2018-05-09
06:19
Merged/melded margs.scm from Megatest into opensrc/margs check-in: 477df8bc03 user: matt tags: trunk
03:32
Added mindata-filtered check-in: 7d200f0d31 user: mrwellan tags: trunk
2018-05-08
11:19
Fix case where . is provided as directory. check-in: 478335bf96 user: matt tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to mtutils/mtdb/mtdb.scm.

34
35
36
37
38
39
40




41
42
43
44
45
46
47
..
70
71
72
73
74
75
76

77
78
79
80
81
82
83
...
394
395
396
397
398
399
400









































401
402
403
404
405
406
407
...
662
663
664
665
666
667
668














669
670
671
672
673
674
675
     ;; db access routines
     get-db-tmp-area
     with-megatest-db
     with-main-db
     with-run-db
     with-common-db
     close-all-dbs




     
     ;; targets
     get-ttype

     ;; areas
     add-area
     get-areas
................................................................................
     get-run-name-from-id

     ;; tests
     get-test-info-by-id
     get-test-id
     full-name
     get-tests-mindata

     
     ;; misc queries
     get-changed-record-ids
     ;; data structs - there must be an easy way to do this?
     ;; Megatest 1.X stuff
     get-run-info-1.X
     get-header
................................................................................
  ;; run dbs
  (for-each
   (lambda (run-id)
     (let ((run-db (hash-table-ref (adat-mtdb-runs adat) run-id)))
       (dbi:close run-db)
       (hash-table-delete! (adat-mtdb-runs adat) run-id)))
   (hash-table-keys (adat-mtdb-runs adat))))










































;;======================================================================
;;  A R E A S
;;======================================================================

(defstruct area id area-name area-path last-update)

................................................................................
;;
(define (get-tests-mindata dbh)
  (dbi:fold-row
   cons
   '()
   dbh   ;; 0    1         2        3     4          5          6        7
   "SELECT id,test_name,item_path,state,status,run_duration,event_time,archived FROM tests ORDER BY event_time DESC;"))















;;======================================================================
;; T E S T   D A T A 
;;======================================================================

;; FOR 2.0 THIS MUST BE CALLED ON CORRECT run-id.db
;;







>
>
>
>







 







>







 







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







 







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







34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
..
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
...
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
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
...
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
     ;; db access routines
     get-db-tmp-area
     with-megatest-db
     with-main-db
     with-run-db
     with-common-db
     close-all-dbs

     ;; patterns
     patt->like
     match->sqlqry
     
     ;; targets
     get-ttype

     ;; areas
     add-area
     get-areas
................................................................................
     get-run-name-from-id

     ;; tests
     get-test-info-by-id
     get-test-id
     full-name
     get-tests-mindata
     get-tests-mindata-filtered
     
     ;; misc queries
     get-changed-record-ids
     ;; data structs - there must be an easy way to do this?
     ;; Megatest 1.X stuff
     get-run-info-1.X
     get-header
................................................................................
  ;; run dbs
  (for-each
   (lambda (run-id)
     (let ((run-db (hash-table-ref (adat-mtdb-runs adat) run-id)))
       (dbi:close run-db)
       (hash-table-delete! (adat-mtdb-runs adat) run-id)))
   (hash-table-keys (adat-mtdb-runs adat))))

;;======================================================================
;; Pattern handling
;;======================================================================

;; make a query (fieldname like 'patt1' OR fieldname 
(define (patt->like fieldname pattstr #!key (comparator " OR "))
  (let ((patts (if (string? pattstr)
		   (string-split pattstr ",")
		   '("%"))))
    (string-intersperse (map (lambda (patt)
			       (let ((wildtype (if (substring-index "%" patt) "LIKE" "GLOB")))
				 (conc fieldname " " wildtype " '" patt "'")))
			     (if (null? patts)
				 '("")
				 patts))
			comparator)))

;; if itempath is #f then look only at the testname part
;;
;; NOTE: convert to return parameterized string and list of params
;;
(define (match->sqlqry patterns)
  (if (string? patterns)
      (let ((patts (string-split patterns ",")))
	(if (null? patts) ;;; no pattern(s) means no match, we will do no query
	    #f
	    (let loop ((patt (car patts))
		       (tal  (cdr patts))
		       (res  '()))
	      (let* ((patt-parts (string-match (regexp "^([^\\/]*)(\\/(.*)|)$") patt))
		     (test-patt  (cadr patt-parts))
		     (item-patt  (cadddr patt-parts))
		     (test-qry   (patt->like "test_name" test-patt))
		     (item-qry   (patt->like "item_path" item-patt))
		     (qry        (conc "(" test-qry " AND " item-qry ")")))
		(if (null? tal)
		    (string-intersperse (append (reverse res)(list qry)) " OR ")
		    (loop (car tal)(cdr tal)(cons qry res)))))))
      #f))


;;======================================================================
;;  A R E A S
;;======================================================================

(defstruct area id area-name area-path last-update)

................................................................................
;;
(define (get-tests-mindata dbh)
  (dbi:fold-row
   cons
   '()
   dbh   ;; 0    1         2        3     4          5          6        7
   "SELECT id,test_name,item_path,state,status,run_duration,event_time,archived FROM tests ORDER BY event_time DESC;"))

;; Get minimal data for tests given a run-id
;;
(define (get-tests-mindata-filtered dbh test-patts)
  (let ((patt-str (match->sqlqry test-patts)))
    (dbi:fold-row
     cons
     '()
     dbh   ;; 0    1         2        3     4          5          6        7
     (conc "SELECT id,test_name,item_path,state,status,run_duration,event_time,archived FROM tests "
	   (if patt-str
	       (conc " WHERE " patt-str)
	       "")
	   " ORDER BY event_time DESC;"))))

;;======================================================================
;; T E S T   D A T A 
;;======================================================================

;; FOR 2.0 THIS MUST BE CALLED ON CORRECT run-id.db
;;