1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
|
;; T E S T S
;;======================================================================
;; 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 states statuses offset limit not-in sort-by sort-order
#!key
(qryvals #f))
(let* ((qryvalstr (case qryvals
((shortlist) "id,run_id,testname,item_path,state,status")
((#f) "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")
(else qryvals)))
(res '())
;; if states or statuses are null then assume match all when not-in is false
(states-qry (if (null? states)
|
|
<
<
|
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
|
;; T E S T S
;;======================================================================
;; 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 states statuses offset limit not-in sort-by sort-order qryvals)
(let* ((qryvalstr (case qryvals
((shortlist) "id,run_id,testname,item_path,state,status")
((#f) "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")
(else qryvals)))
(res '())
;; if states or statuses are null then assume match all when not-in is false
(states-qry (if (null? states)
|
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
|
(< (current-seconds) timeout))
(begin
(thread-sleep! 0.01)
(loop))))
(set! *number-of-writes* (+ *number-of-writes* 1))
(set! *writes-total-delay* (+ *writes-total-delay* (- (current-milliseconds) start-time)))
got-it))
(define (db:process-queue-item db item)
(let* ((stmt-key (cdb:packet-get-qtype item))
(qry-sig (cdb:packet-get-query-sig item))
(return-address (cdb:packet-get-client-sig item))
(params (cdb:packet-get-params item))
(query (let ((q (alist-ref stmt-key db:queries)))
|
>
>
>
>
>
>
>
>
>
|
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
|
(< (current-seconds) timeout))
(begin
(thread-sleep! 0.01)
(loop))))
(set! *number-of-writes* (+ *number-of-writes* 1))
(set! *writes-total-delay* (+ *writes-total-delay* (- (current-milliseconds) start-time)))
got-it))
(define (db:general-call db stmtname params)
(let ((query (let ((q (alist-ref (if (string? stmtname)
(string->symbol stmtname)
stmtname)
db:queries)))
(if q (car q) #f))))
(apply sqlite3:execute db query params)
#t))
(define (db:process-queue-item db item)
(let* ((stmt-key (cdb:packet-get-qtype item))
(qry-sig (cdb:packet-get-query-sig item))
(return-address (cdb:packet-get-client-sig item))
(params (cdb:packet-get-params item))
(query (let ((q (alist-ref stmt-key db:queries)))
|
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
|
(server:reply return-address qry-sig #f (list #f (conc "Login failed due to mismatch paths: " calling-path ", " *toppath*)))))))
((flush sync)
(server:reply return-address qry-sig #t 1)) ;; (length data)))
((set-verbosity)
(set! *verbosity* (car params))
(server:reply return-address qry-sig #t (list #t *verbosity*)))
((killserver)
(let ((hostname (car *runremote*))
(port (cadr *runremote*))
(pid (car params))
(th1 (make-thread (lambda ()(thread-sleep! 3)(debug:print 0 "Server exiting!")(exit 0)) "Server exit thread")))
(debug:print 0 "WARNING: Server on " hostname ":" port " going down by user request!")
(debug:print-info 1 "current pid=" (current-process-id))
(open-run-close tasks:server-deregister tasks:open-db
|
>
|
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
|
(server:reply return-address qry-sig #f (list #f (conc "Login failed due to mismatch paths: " calling-path ", " *toppath*)))))))
((flush sync)
(server:reply return-address qry-sig #t 1)) ;; (length data)))
((set-verbosity)
(set! *verbosity* (car params))
(server:reply return-address qry-sig #t (list #t *verbosity*)))
((killserver)
(db:sync-to *inmemdb* *db*)
(let ((hostname (car *runremote*))
(port (cadr *runremote*))
(pid (car params))
(th1 (make-thread (lambda ()(thread-sleep! 3)(debug:print 0 "Server exiting!")(exit 0)) "Server exit thread")))
(debug:print 0 "WARNING: Server on " hostname ":" port " going down by user request!")
(debug:print-info 1 "current pid=" (current-process-id))
(open-run-close tasks:server-deregister tasks:open-db
|