@@ -49,11 +49,11 @@ (else (debug:print 0 "ERROR: synchronous must be 0,1,2,OFF,NORMAL or FULL, you provided: " syncval) #f)))) (if val (begin - (debug:print 2 "INFO: Setting pragma synchronous to " val) + (debug:print 4 "INFO: Setting pragma synchronous to " val) (sqlite3:execute db (conc "PRAGMA synchronous = '" val "';")))))) (define (open-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) (let* ((dbpath (conc *toppath* "/megatest.db")) ;; fname) (dbexists (file-exists? dbpath)) @@ -449,11 +449,11 @@ "SELECT fieldname,fieldtype FROM keys ORDER BY id DESC;") (set! *db-keys* res) res))) (define (db:get-value-by-header row header field) - ;; (debug:print 2 "db:get-value-by-header row: " row " header: " header " field: " field) + (debug:print 4 "INFO: db:get-value-by-header row: " row " header: " header " field: " field) (if (null? header) #f (let loop ((hed (car header)) (tal (cdr header)) (n 0)) (if (equal? hed field) @@ -475,11 +475,12 @@ (define (db:patt->like fieldname pattstr #!key (comparator " OR ")) (let ((patts (if (string? pattstr) (string-split pattstr ",") '("%")))) (string-intersperse (map (lambda (patt) - (conc fieldname " LIKE '" patt "'")) + (let ((wildtype (if (substring-index "%" patt) "LIKE" "GLOB"))) + (conc fieldname " " wildtype " '" patt "'"))) (if (null? patts) '("") patts)) comparator))) @@ -649,32 +650,40 @@ ;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN ;; i.e. these lists define what to NOT show. ;; states and statuses are required to be lists, empty is ok ;; not-in #t = above behaviour, #f = must match -(define (db:get-tests-for-run db run-id testpatt itempatt states statuses +(define (db:get-tests-for-run db run-id testpatt states statuses #!key (not-in #t) (sort-by #f) ;; 'rundir 'event_time ) (let* ((res '()) ;; if states or statuses are null then assume match all when not-in is false - (states-str (conc " state in ('" (string-intersperse states "','") "')")) - (statuses-str (conc " status in ('" (string-intersperse statuses "','") "')")) - (state-status-qry (if (or (not (null? states)) - (not (null? states))) - (conc " AND " (if not-in "NOT" "") " (" states-str " AND " statuses-str ") ") - "")) - (qry (conc "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment " - " FROM tests WHERE run_id=? AND " - ;; testname like ? AND item_path LIKE ? " - (db:patt->like "testname" testpatt) " AND " - (db:patt->like "item_path" itempatt) - state-status-qry - (case sort-by - ((rundir) " ORDER BY length(rundir) DESC;") - ((event_time) " ORDER BY event_time ASC;") - (else ";")) + (states-qry (if (null? states) + #f + (conc " state " + (if not-in "NOT" "") + " IN ('" + (string-intersperse states "','") + "')"))) + (statuses-qry (if (null? statuses) + #f + (conc " status " + (if not-in "NOT" "") + " IN ('" + (string-intersperse statuses "','") + "')"))) + (tests-match-qry (tests:match->sqlqry testpatt)) + (qry (conc "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment " + " FROM tests WHERE run_id=? " + (if states-qry (conc " AND " states-qry) "") + (if statuses-qry (conc " AND " statuses-qry) "") + (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") + (case sort-by + ((rundir) " ORDER BY length(rundir) DESC;") + ((event_time) " ORDER BY event_time ASC;") + (else ";")) ))) (debug:print 8 "INFO: db:get-tests-for-run qry=" qry) (sqlite3:for-each-row (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) @@ -739,11 +748,11 @@ (define (db:test-set-state-status-by-id db test-id newstate newstatus newcomment) (cond ((and newstate newstatus newcomment) (sqlite3:exectute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus test-id)) ((and newstate newstatus) - (sqlite3:exectute db "UPDATE tests SET state=?,status=? WHERE id=?;" newstate newstatus test-id)) + (sqlite3:execute db "UPDATE tests SET state=?,status=? WHERE id=?;" newstate newstatus test-id)) (else (if newstate (sqlite3:execute db "UPDATE tests SET state=? WHERE id=?;" newstate test-id)) (if newstatus (sqlite3:execute db "UPDATE tests SET status=? WHERE id=?;" newstatus test-id)) (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment test-id))))) @@ -948,25 +957,25 @@ ;;====================================================================== ;; Misc. test related queries ;;====================================================================== (define (db:test-get-paths-matching db keynames target fnamepatt #!key (res '())) - (let* ((itempatt (if (args:get-arg "-itempatt")(args:get-arg "-itempatt") "%")) - (testpatt (if (args:get-arg "-testpatt")(args:get-arg "-testpatt") "%")) + (let* ((testpatt (if (args:get-arg "-testpatt")(args:get-arg "-testpatt") "%")) (statepatt (if (args:get-arg ":state") (args:get-arg ":state") "%")) (statuspatt (if (args:get-arg ":status") (args:get-arg ":status") "%")) (runname (if (args:get-arg ":runname") (args:get-arg ":runname") "%")) (keystr (string-intersperse (map (lambda (key val) (conc "r." key " like '" val "'")) keynames (string-split target "/")) " AND ")) + (testqry (tests:match->sqlqry testpatt)) (qrystr (conc "SELECT t.rundir FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id WHERE " - keystr " AND r.runname LIKE '" runname "' AND item_path LIKE '" itempatt "' AND testname LIKE '" - testpatt "' AND t.state LIKE '" statepatt "' AND t.status LIKE '" statuspatt - "'ORDER BY t.event_time ASC;"))) + keystr " AND r.runname LIKE '" runname "' AND " testqry + " AND t.state LIKE '" statepatt "' AND t.status LIKE '" statuspatt + "' ORDER BY t.event_time ASC;"))) (debug:print 3 "qrystr: " qrystr) (sqlite3:for-each-row (lambda (p) (set! res (cons p res))) db @@ -1476,11 +1485,11 @@ (result '())) (for-each (lambda (waitontest-name) ;; by getting the tests with matching name we are looking only at the matching test ;; and related sub items - (let ((tests (db:get-tests-for-run db run-id waitontest-name #f '() '())) + (let ((tests (db:get-tests-for-run db run-id waitontest-name '() '())) (ever-seen #f) (parent-waiton-met #f) (item-waiton-met #f)) (for-each (lambda (test)