Megatest

Diff
Login

Differences From Artifact [99429bb96b]:

To Artifact [a41d5fcea3]:


2165
2166
2167
2168
2169
2170
2171

2172


2173
2174

2175


2176
2177
2178
2179
2180
2181
2182
                 (let ((db (db:open-no-sync-db)))
                   (set! *no-sync-db* db)
                   db))))
    (mutex-unlock! *db-access-mutex*)
    res))

(define (db:no-sync-set db var val)

  (sqlite3:execute (db:no-sync-db db) "INSERT OR REPLACE INTO no_sync_metadat (var,val) VALUES (?,?);" var val))



(define (db:no-sync-del! db var)

  (sqlite3:execute (db:no-sync-db db) "DELETE FROM no_sync_metadat WHERE var=?;" var))



(define (db:no-sync-get/default db var default)
  (let ((res default))
    (sqlite3:for-each-row
     (lambda (val)
       (set! res val))
     (db:no-sync-db db)







>
|
>
>


>
|
>
>







2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
                 (let ((db (db:open-no-sync-db)))
                   (set! *no-sync-db* db)
                   db))))
    (mutex-unlock! *db-access-mutex*)
    res))

(define (db:no-sync-set db var val)
  ;; (mutex-lock! *db-access-mutex*)
  (let ((res (sqlite3:execute (db:no-sync-db db) "INSERT OR REPLACE INTO no_sync_metadat (var,val) VALUES (?,?);" var val)))
    ;; (mutex-unlock! *db-access-mutex*)
    res))

(define (db:no-sync-del! db var)
  ;; (mutex-lock! *db-access-mutex*)
  (sqlite3:execute (db:no-sync-db db) "DELETE FROM no_sync_metadat WHERE var=?;" var)
  ;; (mutex-unlock! *db-access-mutex*)
  )

(define (db:no-sync-get/default db var default)
  (let ((res default))
    (sqlite3:for-each-row
     (lambda (val)
       (set! res val))
     (db:no-sync-db db)
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
;; 	  (("WARN" "FAIL")  '("COMPLETED" "FAIL"))
;; 	  (("WARN" "CHECK") '("COMPLETED" "CHECK"))
;; 	  (("WARN" "DEAD")
       
(define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment)
  ;; establish info on incoming test followed by info on top level test
  ;; BBnote - for mode itemwait, linkage between upstream test & matching item status is propagated to run queue in db:prereqs-not-met
  ;; (mutex-lock! *db-transaction-mutex*) ;; why do we need a mutex?
  (let* ((testdat      (if (number? test-name)
			   (db:get-test-info-by-id dbstruct run-id test-name) ;; test-name is actually a test-id
			   (db:get-test-info       dbstruct run-id test-name item-path)))
	 (test-id      (db:test-get-id testdat))
	 (test-name    (if (number? test-name)
			   (db:test-get-testname testdat)
			   test-name))
	 (no-sync-db   (db:no-sync-db #f))
	 (rollup-flag  #f)
	 (wait-flag    #f)
	 (rollup-lock-key  (conc run-id "-rollup-" test-name))
	 (waiting-lock-key (conc run-id "-waiting-" test-name)))
    (db:test-set-state-status dbstruct run-id test-id state status #f)
    (if (and test-id state status (equal? status "AUTO")) 
	(db:test-data-rollup dbstruct run-id test-id status))
    (if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
	(db:general-call dbstruct 'set-test-start-time (list test-id)))

    (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 ()
	     ;; (debug:print 0 *default-log-port* "EXCEPTION: exn="exn)







|

















<







3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009

4010
4011
4012
4013
4014
4015
4016
;; 	  (("WARN" "FAIL")  '("COMPLETED" "FAIL"))
;; 	  (("WARN" "CHECK") '("COMPLETED" "CHECK"))
;; 	  (("WARN" "DEAD")
       
(define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment)
  ;; establish info on incoming test followed by info on top level test
  ;; BBnote - for mode itemwait, linkage between upstream test & matching item status is propagated to run queue in db:prereqs-not-met
  (mutex-lock! *db-transaction-mutex*) ;; why do we need a mutex?
  (let* ((testdat      (if (number? test-name)
			   (db:get-test-info-by-id dbstruct run-id test-name) ;; test-name is actually a test-id
			   (db:get-test-info       dbstruct run-id test-name item-path)))
	 (test-id      (db:test-get-id testdat))
	 (test-name    (if (number? test-name)
			   (db:test-get-testname testdat)
			   test-name))
	 (no-sync-db   (db:no-sync-db #f))
	 (rollup-flag  #f)
	 (wait-flag    #f)
	 (rollup-lock-key  (conc run-id "-rollup-" test-name))
	 (waiting-lock-key (conc run-id "-waiting-" test-name)))
    (db:test-set-state-status dbstruct run-id test-id state status #f)
    (if (and test-id state status (equal? status "AUTO")) 
	(db:test-data-rollup dbstruct run-id test-id status))
    (if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
	(db:general-call dbstruct 'set-test-start-time (list test-id)))

    (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 ()
	     ;; (debug:print 0 *default-log-port* "EXCEPTION: exn="exn)
4028
4029
4030
4031
4032
4033
4034

4035
4036
4037
4038
4039
4040
4041


4042
4043
4044
4045
4046
4047
4048
4049
		    (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
	      (begin
		;; (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-lock-key))
	      ;; (conc "thread for run-id: " run-id " test-name: " test-name))))))))


	      )))))
	      
;; I'd like to remove the need for item-path - it is logically not needed here
;; for now we pass in state and status - NOTE: There is a possible race if a test
;; is rapidly re-run while an earlier run is waiting to rollup.
;;
(define (db:roll-up-test-state-status dbstruct run-id test-name state status)
  (let* ((testdat      (if (number? test-name)







>







>
>
|







4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
		    (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
	  (mutex-unlock! *db-transaction-mutex*) ;; why do we need a mutex?
	  (if rollup-flag ;; put this into a thread
	      (begin
		;; (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-lock-key))
	      ;; (conc "thread for run-id: " run-id " test-name: " test-name))))))))
	      ))
	(mutex-unlock! *db-transaction-mutex*) ;; why do we need a mutex?
	)))
	      
;; I'd like to remove the need for item-path - it is logically not needed here
;; for now we pass in state and status - NOTE: There is a possible race if a test
;; is rapidly re-run while an earlier run is waiting to rollup.
;;
(define (db:roll-up-test-state-status dbstruct run-id test-name state status)
  (let* ((testdat      (if (number? test-name)