;;======================================================================
;; Copyright 2017, Matthew Welland.
;;
;; This file is part of Megatest.
;;
;; Megatest is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; Megatest is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;======================================================================
(declare (unit mtmod))
;; (declare (uses mtargs))
(declare (uses debugprint))
(declare (uses commonmod))
(declare (uses dbmod))
;; (declare (uses rmtmod))
(module mtmod
*
(import scheme
chicken.base
chicken.condition
chicken.file
chicken.io
chicken.pathname
chicken.port
chicken.pretty-print
chicken.process
chicken.process-context
chicken.sort
chicken.string
chicken.time
debugprint
;; mtargs
;; pkts
commonmod
dbmod
;; rmtmod
(prefix base64 base64:)
(prefix dbi dbi:)
(prefix sqlite3 sqlite3:)
(srfi 18)
directory-utils
format
matchable
md5
message-digest
regex
regex-case
sparse-vectors
srfi-1
srfi-13
srfi-69
stack
typed-records
z3
)
;; (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) posix-extras directory-utils call-with-environment-variables)
;; (import (prefix sqlite3 sqlite3:))
;;
;; (declare (unit mt))
;; (declare (uses db))
;; (declare (uses common))
;; (declare (uses items))
;; (declare (uses runconfig))
;; (declare (uses tests))
;; (declare (uses server))
;; (declare (uses runs))
;; (declare (uses rmt))
;; ;; (declare (uses filedb))
;;
;; (include "common_records.scm")
;; (include "key_records.scm")
(include "db_records.scm")
;; (include "run_records.scm")
;; (include "test_records.scm")
;; This is the Megatest API. All generally "useful" routines will be wrapped or extended
;; here.
(define (mt:get-run-stats dbstruct run-id)
;; Get run stats from local access, move this ... but where?
(db:get-run-stats dbstruct run-id))
(define (mt:discard-blocked-tests run-id failed-test tests test-records)
(if (null? tests)
tests
(begin
(debug:print-info 1 *default-log-port* "Discarding tests from " tests " that are waiting on " failed-test)
(let loop ((testn (car tests))
(remt (cdr tests))
(res '()))
(let* ((test-dat (hash-table-ref/default test-records testn (vector #f #f '())))
(waitons (vector-ref test-dat 2)))
;; (print "mt:discard-blocked-tests run-id: " run-id " failed-test: " failed-test " testn: " testn " with waitons: " waitons)
(if (null? remt)
(let ((new-res (reverse res)))
;; (print " new-res: " new-res)
new-res)
(loop (car remt)
(cdr remt)
(if (member failed-test waitons)
(begin
(debug:print 0 *default-log-port* "Discarding test " testn "(" test-dat ") due to " failed-test)
res)
(cons testn res)))))))))
)