| ︙ | | |
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
|
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
|
-
+
-
+
|
(begin
(dbr:dbstruct-localdb-set! dbstruct run-id db) ;; (dbr:dbstruct-inmem-set! dbstruct db) ;; direct access ...
db)
(begin
(dbr:dbstruct-inmem-set! dbstruct inmem)
;; dec 14, 2014 - keep deleted records available. hunch is that they are needed for id placeholders
;; (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';") ;; they just slow us down in this context
(db:sync-tables db:sync-tests-only db inmem)
(db:sync-tables db:sync-tests-only #f db inmem)
(db:delay-if-busy refdb) ;; dbpath: (db:dbdat-get-path refdb)) ;; What does delaying here achieve?
(dbr:dbstruct-refdb-set! dbstruct refdb)
(db:sync-tables db:sync-tests-only inmem refdb) ;; use inmem as the reference, don't read again from db
(db:sync-tables db:sync-tests-only #f inmem refdb) ;; use inmem as the reference, don't read again from db
;; sync once more to deal with delays?
;; (db:sync-tables db:sync-tests-only db inmem)
;; (db:sync-tables db:sync-tests-only inmem refdb)
inmem)))))))
;; This routine creates the db if not already present. It is only called if the db is not already ls opened
;;
|
| ︙ | | |
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
|
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
|
-
+
-
+
|
(if (or (not (number? mtime))
(not (number? stime))
(> mtime stime)
force-sync)
(begin
(db:delay-if-busy maindb)
(db:delay-if-busy olddb)
(let ((num-synced (db:sync-tables (db:sync-main-list maindb) maindb olddb)))
(let ((num-synced (db:sync-tables (db:sync-main-list maindb) #f maindb olddb)))
(dbr:dbstruct-stime-set! dbstruct (current-milliseconds))
num-synced)
0))
(begin
;; this can occur when using local access (i.e. not in a server)
;; need a flag to turn it off.
;;
(debug:print 3 *default-log-port* "WARNING: call to sync main.db to megatest.db but main not initialized")
0))
;; any other runid is a run
(if (or (not (number? mtime))
(not (number? stime))
(> mtime stime)
force-sync)
(begin
(db:delay-if-busy rundb)
(db:delay-if-busy olddb)
(dbr:dbstruct-stime-set! dbstruct (current-milliseconds))
(let ((num-synced (db:sync-tables db:sync-tests-only inmem refdb rundb olddb)))
(let ((num-synced (db:sync-tables db:sync-tests-only #f inmem refdb rundb olddb)))
;; (mutex-unlock! *http-mutex*)
num-synced)
(begin
;; (mutex-unlock! *http-mutex*)
0))))))
(define (db:close-main dbstruct)
|
| ︙ | | |
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
|
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
|
+
+
+
+
-
+
|
(finalize! db)
#t))))))
;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) )
;; db's are dbdat's
;;
;; if last-update specified ("field-name" . time-in-seconds)
;; then sync only records where field-name >= time-in-seconds
;; IFF field-name exists
;;
(define (db:sync-tables tbls fromdb todb . slave-dbs)
(define (db:sync-tables tbls last-update fromdb todb . slave-dbs)
(mutex-lock! *db-sync-mutex*)
(handle-exceptions
exn
(begin
(mutex-unlock! *db-sync-mutex*)
(debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.")
(print-call-chain (current-error-port))
|
| ︙ | | |
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
|
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
|
+
+
+
+
+
+
+
+
-
+
+
+
+
|
(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))
(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 ";"))
" FROM " tablename (if use-last-update ;; apply last-update criteria
(conc " " (car last-update) ">=" (cdr last-update))
"")
";"))
(full-ins (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) "
" VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );"))
(fromdat '())
(fromdats '())
(totrecords 0)
(batch-len (string->number (or (configf:lookup *configdat* "sync" "batchsize") "10")))
(todat (make-hash-table))
|
| ︙ | | |
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
|
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
|
+
-
+
|
fromdat-lst))
))
fromdats)
(sqlite3:finalize! stmth)))
(append (list todb) slave-dbs))))
tbls)
(let* ((runtime (- (current-milliseconds) start-time))
(should-print (or (debug:debug-mode 12)
(should-print (common:low-noise-print 120 "db sync" (> runtime 500)))) ;; low and high sync times treated as separate.
(common:low-noise-print 120 "db sync" (> runtime 500))))) ;; low and high sync times treated as separate.
(if should-print (debug:print 3 *default-log-port* "INFO: db sync, total run time " runtime " ms"))
(for-each
(lambda (dat)
(let ((tblname (car dat))
(count (cdr dat)))
(set! tot-count (+ tot-count count))
(if (> count 0)
|
| ︙ | | |
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
|
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
|
+
+
+
+
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(sqlite3:execute maindb "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats
FOR EACH ROW
BEGIN
UPDATE run_stats SET last_update=(strftime('%s','now'))
WHERE id=old.id;
END;"))
(define *global-db-store* (make-hash-table))
;; return the target db handle so it can be used
;;
(define (db:cache-for-read-only source target)
(let* ((toppath (launch:setup))
(cache-db (db:open-megatest-db path: target))
(source-db (db:open-megatest-db path: source))
(curr-time (current-seconds))
(res '()))
(define (db:cache-for-read-only source target #!key (use-last-update #f))
(if (and (hash-table-ref/default *global-db-store* target #f)
(>= (file-modification-time target)(file-modification-time source)))
(hash-table-ref *global-db-store* target)
(let* ((toppath (launch:setup))
(targ-db-last-mod (if (file-exists? target)
(file-modification-time target)
0))
(cache-db (or (hash-table-ref/default *global-db-store* target #f)
(db:open-megatest-db path: target)))
(source-db (db:open-megatest-db path: source))
(curr-time (current-seconds))
(res '())
(print source-db)
(begin
(if (not (file-exists? target))
((db:sync-tables (db:sync-main-list source-db) source-db cache-db)
(db:sync-tables db:sync-tests-only source-db cache-db)
(db:clean-up-rundb cache-db))
((sqlite3:for-each-row
(lambda (id release runname state status owner event_time comment fail_count pass_count )
(set! res (cons (id release runname state status owner event_time comment fail_count pass_count ) res)))
(db:dbdat-get-db source-db)
"SELECT id, release, runname, state, status, owner, event_time, comment, fail_count, pass_count FROM runs;"))
)
(print res)
(sqlite3:finalize! (db:dbdat-get-db cache-db))
))
)
|
| ︙ | | |
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
|
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
|
-
+
|
(db:delay-if-busy mtdb)
(db:prep-megatest.db-for-migration mtdb)))
;; sync runs, test_meta etc.
;;
(if (member 'old2new options)
(begin
(db:sync-tables (db:sync-main-list mtdb) mtdb (db:get-db dbstruct #f))
(db:sync-tables (db:sync-main-list mtdb) #f mtdb (db:get-db dbstruct #f))
(for-each
(lambda (run-id)
(db:delay-if-busy mtdb)
(let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id))
(dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)))
(debug:print 0 *default-log-port* "INFO: Propagating " (length testrecs) " records for run-id=" run-id " to run specific db")
(db:replace-test-records dbstruct run-id testrecs)
|
| ︙ | | |
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
|
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
|
-
+
-
+
|
(thread-start!
(make-thread
(lambda ()
(let* ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))
(frundb (db:dbdat-get-db (db:get-db fromdb run-id))))
(if (eq? run-id 0)
(let ((maindb (db:dbdat-get-db (db:get-db fromdb #f))))
(db:sync-tables (db:sync-main-list dbstruct) (db:get-db fromdb #f) mtdb)
(db:sync-tables (db:sync-main-list dbstruct) #f (db:get-db fromdb #f) mtdb)
(set! dead-runs (db:clean-up-maindb (db:get-db fromdb #f))))
(begin
;; NB// must sync first to ensure deleted tests get marked as such in megatest.db
(db:sync-tables db:sync-tests-only (db:get-db fromdb run-id) mtdb)
(db:sync-tables db:sync-tests-only #f (db:get-db fromdb run-id) mtdb)
(db:clean-up-rundb (db:get-db fromdb run-id)))))
(set! count (+ count 1))
(debug:print 0 *default-log-port* "Finished clean up of "
(if (eq? run-id 0)
" main.db " (conc run-id ".db")) ", " count " of " total)))))
all-run-ids))))
|
| ︙ | | |