Megatest

Diff
Login

Differences From Artifact [40daf428a9]:

To Artifact [dad7155e28]:


159
160
161
162
163
164
165
166
167


168
169
170

171
172
173
174
175


176
177




178
179
180
181
182
183
184
159
160
161
162
163
164
165


166
167



168





169
170


171
172
173
174
175
176
177
178
179
180
181







-
-
+
+
-
-
-
+
-
-
-
-
-
+
+
-
-
+
+
+
+







;;    if run-id is a string treat it as a filename
;;    if db already open - return inmem
;;    if db not open, open inmem, rundb and sync then return inmem
;;    inuse gets set automatically for rundb's
;;
;; (define db:get-db db:get-subdb)

;; (define (db:get-db subdb #;dbstruct run-id) ;; RENAME TO db:get-dbh
;;   ;; (let* ((subdb (dbfile:get-subdb dbstruct run-id)))
(define (db:get-db dbstruct run-id) 
   (let* ((subdb (dbfile:get-subdb dbstruct run-id))
;;     (if (stack? (dbr:subdb-dbstack subdb))
;; 	(if (stack-empty? (dbr:subdb-dbstack subdb))
;; 	    (let* ((dbname (db:run-id->dbname run-id))
        (dbdat (dbfile:get-dbdat dbstruct run-id)))
;; 		   (newdb  (db:open-megatest-db path: (db:dbfile-path)
;; 						name: dbname)))
;; 	      ;; NOTE: pushing on the stack only happens AFTER the handle has been used
;; 	      ;; (stack-push! (dbr:dbstruct-dbstack dbstruct) newdb)
;; 	      newdb)
        (if (dbr:dbdat? dbdat)
          dbdat
;;           (stack-pop! (dbr:subdb-dbstack subdb)))
;; 	(db:open-db subdb run-id))) ;; )
          (dbfile:open-db *dbstruct-dbs* #f db:initialize-main-db)
        )
   )
)

(define-inline (db:generic-error-printout exn . message)
  (print-call-chain (current-error-port))
  (apply debug:print-error 0 *default-log-port* message)
  (debug:print-error 0 *default-log-port* "   params: " params
		     ", error: "     ((condition-property-accessor 'exn 'message)   exn)
		     ", arguments: " ((condition-property-accessor 'exn 'arguments) exn)
2103
2104
2105
2106
2107
2108
2109
















2110
2111
2112
2113
2114
2115
2116
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129







+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+







  (db:with-db dbstruct #f #t 
	      (lambda (dbdat db)
		(sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var))))

;;======================================================================
;; no-sync.db - small bits of data to be shared between servers
;;======================================================================

;; if we are not a server create a db handle. this is not finalized
;; so watch for problems. I'm still not clear if it is needed to manually
;; finalize sqlite3 dbs with the sqlite3 egg.
;;
(define (db:no-sync-db db-in)
  (if db-in
      db-in
      (if *no-sync-db*
	  *no-sync-db*
	  (begin
	    (mutex-lock! *db-access-mutex*)
	    (let ((db (db:open-no-sync-db)))
	      (set! *no-sync-db* db)
	      (mutex-unlock! *db-access-mutex*)
	      db)))))

(define (db:open-no-sync-db)
  (dbfile:open-no-sync-db (db:dbfile-path)))

(define (db:no-sync-close-db db stmt-cache)
  (db:safely-close-sqlite3-db db stmt-cache))

5059
5060
5061
5062
5063
5064
5065


5066

5067
5068
5069
5070
5071
5072
5073
5072
5073
5074
5075
5076
5077
5078
5079
5080

5081
5082
5083
5084
5085
5086
5087
5088







+
+
-
+







    
    (if (and legacy-sync (not *time-to-exit*))
 	(begin
 	  (debug:print-info 0 *default-log-port* "Server running, periodic copy-based sync started.")
	  (let loop ()

	    ;; run the sync and print out durations
	    (let* ((changed (db:run-lock-and-sync no-sync-db)))
	      (if (not (null? changed))
	    (debug:print-info 0 *default-log-port* "Sync durations: "(db:run-lock-and-sync no-sync-db))
		  (debug:print-info 0 *default-log-port* "Sync durations: "changed)))
	    ;; keep going unless time to exit
	    ;;
	    (if (not *time-to-exit*)
		(let delay-loop ((count 0))
		  ;;(debug:print-info 13 *default-log-port* "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*)
		  
		  (if (and (not *time-to-exit*)