1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
|
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
|
-
+
|
id INTEGER PRIMARY KEY,
test_id INTEGER,
state TEXT DEFAULT 'new',
status TEXT DEFAULT 'n/a',
archive_type TEXT DEFAULT 'bup',
du INTEGER,
archive_path TEXT);")))
(print "creating trigges from init")
;; (print "creating trigges from init")
(db:create-triggers db)
db)) ;; )
;;======================================================================
;; A R C H I V E S
;;======================================================================
|
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
|
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
|
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(if (not (equal? item-path "")) ;; only roll up IF incoming test is an item
(begin
;; is there a rollup lock? If not, take it
(sqlite3:with-transaction
no-sync-db
(lambda ()
(handle-exceptions
exn
(debug:print 0 *default-log-port* "EXCEPTION: exn="exn)
(let* ((rollup-lock-time (db:no-sync-get/default no-sync-db rollup-lock-key #f))
(waiting-lock-time (db:no-sync-get/default no-sync-db waiting-lock-key #f)))
(if rollup-lock-time ;; someone is doing a rollup
(if (not waiting-lock-time) ;; no one is waiting
(begin
(set! wait-flag #t)
(set! rollup-flag #t)
(db:no-sync-set no-sync-db waiting-lock-key (current-seconds)))) ;; we are going to wait
(begin
(set! rollup-flag #t)
(db:no-sync-set no-sync-db rollup-lock-key (current-seconds)))))))
(if wait-flag
(let loop ((count 100))
(thread-sleep! 2)
(if (and (not (db:no-sync-get/default no-sync-db waiting-lock-key #f))
(> count 0))
(loop (+ count 1))
(sqlite3:with-transaction
no-sync-db
(lambda ()
(db:no-sync-set no-sync-db rollup-lock-key (current-seconds))
(db:no-sync-del! no-sync-db waiting-lock-key))))))
(let* ((rollup-lock-time (db:no-sync-get/default no-sync-db rollup-lock-key #f))
(waiting-lock-time (db:no-sync-get/default no-sync-db waiting-lock-key #f)))
(if rollup-lock-time ;; someone is doing a rollup
(if (not waiting-lock-time) ;; no one is waiting
(begin
(set! wait-flag #t)
(set! rollup-flag #t)
(db:no-sync-set no-sync-db waiting-lock-key (current-seconds)))) ;; we are going to wait
(begin
(set! rollup-flag #t)
(db:no-sync-set no-sync-db rollup-lock-key (current-seconds)))))))
(if wait-flag
(let loop ((count 100))
(thread-sleep! 2)
(if (and (not (db:no-sync-get/default no-sync-db waiting-lock-key #f))
(> count 0))
(loop (+ count 1))
(sqlite3:with-transaction
no-sync-db
(lambda ()
(db:no-sync-set no-sync-db rollup-lock-key (current-seconds))
(db:no-sync-del! no-sync-db waiting-lock-key)))))))
;; now the rollup
(if rollup-flag ;; put this into a thread
(thread-start! (make-thread
(lambda ()
(db:roll-up-test-state-status dbstruct run-id test-name state status)
(db:no-sync-del! no-sync-db rollup-flag))
(conc "thread for run-id: " run-id " test-name: " test-name))))))))
|
4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
|
4472
4473
4474
4475
4476
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
4491
4492
4493
4494
|
-
+
+
-
+
|
flush
sync
set-verbosity
killserver
))
(define (db:login dbstruct calling-path calling-version client-signature)
(cond
(cond
((not (equal? calling-path *toppath*))
(list #f "Login failed due to mismatch paths: " calling-path ", " *toppath*))
;; ((not (equal? *run-id* run-id))
;; (list #f "Login failed due to mismatch run-id: " run-id ", " *run-id*))
((not (equal? megatest-version calling-version))
(list #t (conc "Login warning due to mismatch megatest version: " calling-version ", " megatest-version)))
(else
(else
(hash-table-set! *logged-in-clients* client-signature (current-seconds))
'(#t "successful login"))))
(define (db:general-call dbstruct stmtname params)
(let ((query (let ((q (alist-ref (if (string? stmtname)
(string->symbol stmtname)
stmtname)
|