| ︙ | | |
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
|
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
|
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
|
(let ((stmts (make-hash-table)) ;; table-field => stmt
(all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 ))
(numrecs (make-hash-table))
(start-time (current-milliseconds))
(tot-count 0))
(for-each ;; table
(lambda (tabledat)
(let* ((tablename (car tabledat))
(fields (cdr tabledat))
(use-last-update (if last-update
(if (pair? last-update)
(member (car last-update) ;; last-update field name
(map car fields))
(begin
(debug:print 0 *default-log-port* "ERROR: parameter last-update for db:sync-tables must be a pair, received: " last-update) ;; found in fields
#f))
#f))
(let* ((tablename (car tabledat))
(fields (cdr tabledat))
(has-last-update (member "last_update" fields))
(use-last-update (cond
((and has-last-update
(member "last_update" fields))
#t) ;; if given a number, just use it for all fields
((number? last-update) #f) ;; if not matched first entry then ignore last-update for this table
((and (pair? last-update)
(member (car last-update) ;; last-update field name
(map car fields))) #t)
(last-update
(debug:print 0 *default-log-port* "ERROR: parameter last-update for db:sync-tables must be a pair or a number, received: " last-update) ;; found in fields
#f)
(else
#f)))
(last-update-value (if use-last-update ;; no need to check for has-last-update - it is already accounted for
(if (number? last-update)
last-update
(cdr last-update))
#f))
(last-update-field (if use-last-update
(if (number? last-update)
"last_update"
(car last-update))
#f))
(num-fields (length fields))
(field->num (make-hash-table))
(num->field (apply vector (map car fields)))
(full-sel (conc "SELECT " (string-intersperse (map car fields) ",")
" FROM " tablename (if use-last-update ;; apply last-update criteria
(conc " " (car last-update) ">=" (cdr last-update))
(conc " WHERE " last-update-field " >= " last-update-value)
"")
";"))
(full-ins (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) "
" VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );"))
(fromdat '())
(fromdats '())
(totrecords 0)
|
| ︙ | | |
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
|
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(res '())
(last-update (if use-last-update (cons "last_update" targ-db-last-mod) #f)))
(db:sync-tables (db:sync-main-list source-db) last-update source-db cache-db)
(db:sync-tables db:sync-tests-only last-update source-db cache-db)
(hash-table-set! *global-db-store* target cache-db)
cache-db)))
;; call a proc with a cached db
;;
(define (db:call-with-cached-db proc . params)
;; first cache the db in /tmp
(let* ((cname-part (conc "megatest_cache/" (common:get-testsuite-name)))
(fname (conc (common:get-area-path-signature) ".db"))
(cache-dir (common:get-create-writeable-dir
(list (conc "/tmp/" (current-user-name) "/" cname-part)
(conc "/tmp/" (current-user-name) "-" cname-part)
(conc "/tmp/" (current-user-name) "_" cname-part))))
(megatest-db (conc *toppath* "/megatest.db")))
;; (debug:print-info 0 *default-log-port* "Using cache dir " cache-dir)
(if (not cache-dir)
(begin
(debug:print 0 *default-log-port* "ERROR: Failed to find an area to write the cache db")
(exit 1))
(let* ((th1 (make-thread
(lambda ()
(if (and (file-exists? megatest-db)
(file-write-access? megatest-db))
(begin
(common:sync-to-megatest.db 'timestamps) ;; internally mutexes on *db-local-sync*
(debug:print-info 2 *default-log-port* "Done syncing to megatest.db"))))
"call-with-cached-db sync-to-megatest.db"))
(cache-db (db:cache-for-read-only
megatest-db
(conc cache-dir "/" fname)
use-last-update: #t)))
(thread-start! th1)
(apply proc cache-db params)
))))
;; ;; call a proc with a cached db
;; ;;
;; (define (db:call-with-cached-db proc . params)
;; ;; first cache the db in /tmp
;; (let* ((cname-part (conc "megatest_cache/" (common:get-testsuite-name)))
;; (fname (conc (common:get-area-path-signature) ".db"))
;; (cache-dir (common:get-create-writeable-dir
;; (list (conc "/tmp/" (current-user-name) "/" cname-part)
;; (conc "/tmp/" (current-user-name) "-" cname-part)
;; (conc "/tmp/" (current-user-name) "_" cname-part))))
;; (megatest-db (conc *toppath* "/megatest.db")))
;; ;; (debug:print-info 0 *default-log-port* "Using cache dir " cache-dir)
;; (if (not cache-dir)
;; (begin
;; (debug:print 0 *default-log-port* "ERROR: Failed to find an area to write the cache db")
;; (exit 1))
;; (let* ((th1 (make-thread
;; (lambda ()
;; (if (and (file-exists? megatest-db)
;; (file-write-access? megatest-db))
;; (begin
;; (db:sync-to-megatest.db dbstruct 'timestamps) ;; internally mutexes on *db-local-sync*
;; (debug:print-info 2 *default-log-port* "Done syncing to megatest.db"))))
;; "call-with-cached-db sync-to-megatest.db"))
;; (cache-db (db:cache-for-read-only
;; megatest-db
;; (conc cache-dir "/" fname)
;; use-last-update: #t)))
;; (thread-start! th1)
;; (apply proc cache-db params)
;; ))))
;; options:
;;
;; 'killservers - kills all servers
;; 'dejunk - removes junk records
;; 'adj-testids - move test-ids into correct ranges
;; 'old2new - sync megatest.db to /tmp/.../megatest.db and /tmp/.../megatest_ref.db
|
| ︙ | | |
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
|
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(db:patch-schema-rundb (db:dbdat-get-db mtdb))
(db:patch-schema-rundb (db:dbdat-get-db tmpdb))
(db:patch-schema-rundb (db:dbdat-get-db refndb))))
(stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb))
options)
data-synced))
(define (db:tmp->megatest.db-sync dbstruct last-update)
(let* ((mtdb (dbr:dbstruct-mtdb dbstruct))
(tmpdb (db:get-db dbstruct))
(refndb (dbr:dbstruct-refndb dbstruct)))
(db:sync-tables (db:sync-all-tables-list dbstruct) last-update tmpdb refndb mtdb)))
;;;; run-ids
;; if #f use *db-local-sync* : or 'local-sync-flags
;; if #t use timestamps : or 'timestamps
(define (db:sync-to-megatest.db dbstruct #!key (no-sync-db #f))
(let* ((start-time (current-seconds))
(last-update (if no-sync-db
(db:no-sync-get/default no-sync-db "LAST_UPDATE" 0)
0)) ;; (or (db:get-var dbstruct "LAST_UPDATE") 0))
(res (db:tmp->megatest.db-sync dbstruct last-update)))
(let ((sync-time (- (current-seconds) start-time)))
(if no-sync-db
(db:no-sync-set no-sync-db "LAST_UPDATE" start-time))
(debug:print-info 3 *default-log-port* "Sync of newdb to olddb completed in " sync-time " seconds pid="(current-process-id))
(if (common:low-noise-print 30 "sync new to old")
(debug:print-info 0 *default-log-port* "Sync of newdb to olddb completed in " sync-time " seconds pid="(current-process-id))))
res))
;; keeping it around for debugging purposes only
(define (open-run-close-no-exception-handling proc idb . params)
(debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params)
(print "I don't work anymore. open-run-close-no-exception-handling needs fixing or removing...")
(exit)
(if (or *db-write-access*
|
| ︙ | | |
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
|
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(lambda (db)
(sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val))))
(define (db:del-var dbstruct var)
(db:with-db dbstruct #f #t
(lambda (db)
(sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var))))
;;======================================================================
;; no-sync.db - small bits of data to be shared between servers
;;======================================================================
(define (db:open-no-sync-db)
(let* ((dbpath (db:dbfile-path))
(dbname (conc dbpath "/no-sync.db"))
(db (sqlite3:open-database dbname)))
(sqlite3:set-busy-handler! db (make-busy-timeout 136000))
(sqlite3:execute db "PRAGMA synchronous = 0;")
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS no_sync_metadat (var TEXT,val TEXT, CONSTRAINT no_sync_metadat_constraint UNIQUE (var));")
db))
(define (db:no-sync-set db var val)
(sqlite3:execute db "INSERT OR REPLACE INTO no_sync_metadat (var,val) VALUES (?,?);" var val))
(define (db:no-sync-get/default db var default)
(let ((res default))
(sqlite3:for-each-row
(lambda (val)
(set! res val))
db
"SELECT val FROM no_sync_metadat WHERE var=?;"
var)
res))
(define (db:no-sync-close-db db)
(db:safely-close-sqlite3-db db))
;; use a global for some primitive caching, it is just silly to
;; re-read the db over and over again for the keys since they never
;; change
;; why get the keys from the db? why not get from the *configdat*
;; using keys:config-get-fields?
|
| ︙ | | |