Megatest

Check-in [9a5898a74e]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Fixed -import-megatest.db and -sync-to-megatest.db, fixed dashboard startup with no db
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | 1.70-fixed-sync
Files: files | file ages | folders
SHA1: 9a5898a74edca2d99049994ffc3cdf2dd8fb75a8
User & Date: mmgraham on 2022-06-04 18:08:50
Other Links: branch diff | manifest | tags
Context
2022-06-04
18:08
Fixed -import-megatest.db and -sync-to-megatest.db, fixed dashboard startup with no db Leaf check-in: 9a5898a74e user: mmgraham tags: 1.70-fixed-sync
2022-06-01
21:14
speculative fix check-in: 2f1850785d user: matt tags: v1.70-refactor-procedures
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Modified dashboard.scm from [e90491091e] to [22b0256617].

︙︙
24
25
26
27
28
29
30

31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49

50
51
52
53
54
55
56
57


58
59
60
61
62
63
64

(import (prefix iup iup:))

(use canvas-draw)
(import canvas-draw-iup)
(use ducttape-lib)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors) ;; defstruct
(import (prefix sqlite3 sqlite3:))


(declare (uses common))
(declare (uses margs))
(declare (uses keys))
(declare (uses items))
(declare (uses db))
(declare (uses configf))
(declare (uses process))
(declare (uses launch))
(declare (uses runs))
(declare (uses dashboard-tests))
(declare (uses dashboard-guimonitor))
(declare (uses tree))
(declare (uses dcommon))
(declare (uses dashboard-context-menu))
(declare (uses vg))
(declare (uses subrun))
;; (declare (uses dashboard-main))
(declare (uses mt))


(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "task_records.scm")
(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
(include "vg_records.scm")



(define help (conc 
	      "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
  version " megatest-version "
  license GPL, Copyright (C) Matt Welland 2012-2017

Usage: dashboard [options]








>



















>








>
>








24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68

(import (prefix iup iup:))

(use canvas-draw)
(import canvas-draw-iup)
(use ducttape-lib)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors) ;; defstruct
(import (prefix sqlite3 sqlite3:))
(import dbfile)

(declare (uses common))
(declare (uses margs))
(declare (uses keys))
(declare (uses items))
(declare (uses db))
(declare (uses configf))
(declare (uses process))
(declare (uses launch))
(declare (uses runs))
(declare (uses dashboard-tests))
(declare (uses dashboard-guimonitor))
(declare (uses tree))
(declare (uses dcommon))
(declare (uses dashboard-context-menu))
(declare (uses vg))
(declare (uses subrun))
;; (declare (uses dashboard-main))
(declare (uses mt))
(declare (uses dbfile))

(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "task_records.scm")
(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
(include "vg_records.scm")

(dbfile:db-init-proc db:initialize-main-db)

(define help (conc 
	      "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
  version " megatest-version "
  license GPL, Copyright (C) Matt Welland 2012-2017

Usage: dashboard [options]
︙︙

Modified db.scm from [451105ba06] to [5bf0387307].

︙︙
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358

         (exn (io-error)  (debug:print 0 *default-log-port* "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again."))
         (exn (corrupt)   (debug:print 0 *default-log-port* "ERROR: database " fname " is corrupt. Repair it to proceed."))
         (exn (busy)      (debug:print 0 *default-log-port* "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back."))
         (exn (permission)(debug:print 0 *default-log-port* "ERROR: database " fname " has some permissions problem."))
         (exn () (debug:print 0 *default-log-port* "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn))))
	)))

;; This routine creates the db if not already present. It is only called if the db is not already opened
;;
#;(define (db:open-db dbstruct run-id #!key (areapath #f)(do-sync #t))
  (let* ((subdb       (dbfile:get-subdb dbstruct run-id))
	 (tmpdb-stack (dbr:subdb-dbstack subdb))) 
    (if (stack? tmpdb-stack)
	(db:get-subdb tmpdb-stack run-id) ;; get previously opened db (will create new db handle if all in the stack are already used
        (let* ((max-stale-tmp (configf:lookup-number *configdat* "server" "filling-db-max-stale-seconds" default: 10))
               (dbpath       (db:dbfile-path))      ;; path to tmp db area
	       (dbname       (db:run-id->dbname run-id))
               (dbexists     (common:file-exists? dbpath))
	       (mtdbfname    (conc *toppath* "/"dbname))
               (mtdbexists   (common:file-exists? mtdbfname))
               (mtdbmodtime  (if mtdbexists (common:lazy-sqlite-db-modification-time mtdbfname)  #f))
               (mtdb         (db:open-megatest-db mtdbfname))
	       ;; the reference db for syncing
	       (refdbfname   (conc dbpath "/"dbname"_ref"))
               (refndb       (db:open-megatest-db refdbfname))
               ;; (mtdbpath     (dbr:dbdat-dbfile mtdb))
	       ;; the tmpdb
	       (tmpdbfname   (conc dbpath"/"dbname)) ;; /tmp/<stuff>/.db/[main|1,2...].db 
               (tmpdb        (db:open-megatest-db tmpdbfname)) ;; lock-create-open dbpath db:initialize-main-db))
	       (dbfexists    (common:file-exists? tmpdbfname))  ;; (conc dbpath "/megatest.db")))
	       (tmpdbmodtime (if dbfexists  (common:lazy-sqlite-db-modification-time tmpdbfname) #f))

               (write-access (file-write-access? mtdbfname))
	       
	       ;; (mtdbmodtime (if mtdbexists
	       ;; (common:lazy-sqlite-db-modification-time mtdbpath)
	       ;; #f)) ; moving this before db:open-megatest-db is
	       ;; called. if wal mode is on -WAL and -shm file get
	       ;; created with causing the tmpdbmodtime timestamp
	       ;; always greater than mtdbmodtime (tmpdbmodtime (if
	       ;; dbfexists (common:lazy-sqlite-db-modification-time
	       ;; tmpdbfname) #f)) if wal mode is on -WAL and -shm
	       ;; file get created when db:open-megatest-db is
	       ;; called. modtimedelta will always be < 10 so db in
	       ;; tmp not get synced (tmpdbmodtime (if dbfexists
	       ;; (db:get-last-update-time (car tmpdb)) #f)) (fmt
	       ;; (file-modification-time tmpdbfname))
	       
	       (modtimedelta (and mtdbmodtime tmpdbmodtime (- mtdbmodtime tmpdbmodtime))))

          (when write-access
            (sqlite3:execute (dbr:dbdat-dbh mtdb) "drop trigger if exists update_tests_trigger")
            (sqlite3:execute (dbr:dbdat-dbh mtdb) "drop trigger if exists update_runs_trigger"))
          
	  ;; (print "mtdbmodtime " mtdbmodtime " tmpdbmodtime " tmpdbmodtime " mtdbpath " mtdbpath " " (conc *toppath* "/megatest.db"))
	  ;; (debug:print-info 13 *default-log-port* "db:open-db>> mtdbpath="mtdbpath" mtdbexists="mtdbexists" and write-access="write-access)
          (if (and dbexists (not write-access))
              (begin
                (set! *db-write-access* #f)
                (dbr:subdb-read-only-set! subdb #t)))
          (dbr:subdb-mtdb-set!   subdb mtdb)
          (dbr:subdb-tmpdb-set!  subdb tmpdb)
          (dbr:subdb-dbstack-set! subdb (make-stack)) ;; BB: why a stack?  Why would the number of db's be indeterminate?  Is this a legacy of 1.db 2.db .. ?
          (stack-push! (dbr:subdb-dbstack subdb) tmpdb) ;; olddb is already a (cons db path)
          (dbr:subdb-refndb-set! subdb refndb)
          (if (and  (or (not dbfexists)
			(and modtimedelta
			     (> modtimedelta max-stale-tmp))) ;; if db in tmp is over ten seconds older than the file in MTRA then do a sync back
		    do-sync)
	      (begin
		(debug:print 1 *default-log-port* "filling db " (dbr:dbdat-dbfile tmpdb) " with data \n    from " (dbr:dbdat-dbfile mtdb) " mod time delta: " modtimedelta)
		(db:sync-tables (db:sync-all-tables-list subdb) #f mtdb refndb tmpdb)
		;; touch tmp db to avoid wal mode wierdness  
		(set! (file-modification-time tmpdbfname) (current-seconds))  
                (debug:print-info 13 *default-log-port* "db:sync-all-tables-list done.")
                )
	      (debug:print 4 *default-log-port* " db, " (dbr:dbdat-dbfile tmpdb) " already exists or fresh enough, not propogating data from\n     " (dbr:dbdat-dbfile mtdb) " mod time delta: " modtimedelta) )
	  ;; (db:multi-db-sync subdb 'old2new))  ;; migrate data from megatest.db automatically
          tmpdb))))


(define (db:get-last-update-time db)
  (let ((last-update-time #f))
    (sqlite3:for-each-row 
     (lambda (lup) 
       (set! last-update-time lup))     








<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








273
274
275
276
277
278
279








































































280
281
282
283
284
285
286

         (exn (io-error)  (debug:print 0 *default-log-port* "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again."))
         (exn (corrupt)   (debug:print 0 *default-log-port* "ERROR: database " fname " is corrupt. Repair it to proceed."))
         (exn (busy)      (debug:print 0 *default-log-port* "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back."))
         (exn (permission)(debug:print 0 *default-log-port* "ERROR: database " fname " has some permissions problem."))
         (exn () (debug:print 0 *default-log-port* "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn))))
	)))











































































(define (db:get-last-update-time db)
  (let ((last-update-time #f))
    (sqlite3:for-each-row 
     (lambda (lup) 
       (set! last-update-time lup))
︙︙
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699

		      ((and changed *time-to-exit*) ;; last sync
		       #t)
		      (else
		       #f))))
	 (if do-cp
	     (let* ((start-time (current-milliseconds))
              (fname (pathname-file file))
              (runid (if (string= fname "main") #f (string->number fname)))
              )
	       (debug:print-info 3 *default-log-port* "db:all-db-sync: fname: "
				 fname", delta: " (- time1 time2) " seconds")
	       (db:lock-and-delta-sync no-sync-db dbstruct fname runid (db:get-keys dbstruct) db:initialize-main-db)
	       (hash-table-set! sync-durations (conc fname".db")
				(- (current-milliseconds) start-time)))
	     (debug:print-info 3 *default-log-port* "skipping sync. " file " is up to date")
         )))
     dbfiles
     )
    (if dbdat (dbfile:add-dbdat dbstruct #f dbdat)))








|



|








609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627

		      ((and changed *time-to-exit*) ;; last sync
		       #t)
		      (else
		       #f))))
	 (if do-cp
	     (let* ((start-time (current-milliseconds))
              (fname (pathname-file file))
              (run-id (if (string= fname "main") #f (string->number fname)))
              )
	       (debug:print-info 3 *default-log-port* "db:all-db-sync: fname: "
				 fname", delta: " (- time1 time2) " seconds")
	       (db:lock-and-delta-sync no-sync-db dbstruct fname run-id (db:get-keys dbstruct) db:initialize-main-db)
	       (hash-table-set! sync-durations (conc fname".db")
				(- (current-milliseconds) start-time)))
	     (debug:print-info 3 *default-log-port* "skipping sync. " file " is up to date")
         )))
     dbfiles
     )
    (if dbdat (dbfile:add-dbdat dbstruct #f dbdat)))
︙︙
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
734
735
736
737
738
739
740
741
742
743
744
745
746

747





748
749






750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
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
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

;;  'old2new      - sync megatest.db to /tmp/.../megatest.db and /tmp/.../megatest_ref.db
;;  'new2old      - sync /tmp/.../megatest.db to megatest.db and /tmp/.../megatest_ref.db (and update data_synced)
;;  'closeall     - close all opened dbs
;;  'schema       - attempt to apply schema changes
;;  run-ids: '(1 2 3 ...) or #f (for all)
;;
(define (db:multi-db-sync dbstruct . options)
  (let* ((dbdat       (db:open-db dbstruct #f))
	 (data-synced 0) ;; count of changed records
    (tmp-area       (common:get-db-tmp-area))



    (dbfiles        (glob (conc tmp-area"/.db/*.db")))

    (sync-durations (make-hash-table)))

    (for-each
     (lambda (file)
       (debug:print-info 0 *default-log-port* "file: " file)
       (let* ((fname (conc (pathname-file file) ".db"))
	      (fulln (conc *toppath*"/.db/"fname))
	      (time1 (if (file-exists? file)

			 (file-modification-time file)
			 (begin
			   (debug:print-info 0 *default-log-port* "Sync - I do not see file "file)
			   1)))
	      (time2 (if (file-exists? fulln)
			 (file-modification-time fulln)
			 (begin
			   (debug:print-info 0 *default-log-port* "Sync - I do not see file "fulln)
			   0)))
	      (changed (> time1 time2))
	      (do-cp (cond
		      ((not (file-exists? fulln)) ;; shouldn't happen, but this might recover
		       (debug:print-info 0 *default-log-port* "File "fulln" not found! Copying "fname" to "fulln)
		       #t)
		      (changed ;; (and changed
		       ;; (> (- (current-seconds) time1) 3)) ;; if file is changed and three seconds have passed.
		       #t)
		      ((and changed *time-to-exit*) ;; last sync
		       #t)
		      (else
		       #f))))
	 (if do-cp

	     (let* ((start-time (current-milliseconds)))





	       (debug:print-info 0 *default-log-port* "delta sync delta file: " fname", delta: " (- time1 time2) " seconds")
	       (db:lock-and-delta-sync *no-sync-db* file fulln)






	       (hash-table-set! sync-durations (conc fname".db") (- (current-milliseconds) start-time)))
	     (debug:print-info 0 *default-log-port* "skipping delta sync. " file " is up to date")
         )
       )
     )
     dbfiles
    )


    (hash-table->alist sync-durations)



    (debug:print 0 *default-log-port* "db:multi-db-sync subdbs: " (hash-table-values (dbr:dbstruct-subdbs dbstruct)))
    (for-each
     (lambda (subdb)
       (let* ((mtdb     (dbr:subdb-mtdbdat subdb))
	      (tmpdbfile    (dbr:subdb-tmpdbfile subdb))
              (main-tmpdb (dbfile:open-db dbstruct #f db:initialize-main-db))
	      (allow-cleanup #t) ;; (if run-ids #f #t))
	      (servers  (server:get-list *toppath*)) ;; (tasks:get-all-servers (db:delay-if-busy tdbdat)))
	      )    
         (debug:print 0 *default-log-port* "db:multi-db-sync mtdb: " mtdb " tmpdbfile:" tmpdbfile )
	 (for-each
	  (lambda (option)
	    
	    (case option
	      ;; kill servers
	      ((killservers)
	       (for-each
		(lambda (server)
		  (handle-exceptions
		      exn
		      (begin 
			(debug:print-info 0 *default-log-port*  "Unable to get host and/or port from " server ", exn=" exn)     
			#f)
		    (match-let (((mod-time host port start-time server-id pid) server))
		      (if (and host pid)
			  (tasks:kill-server host pid)))))
		servers)
	       
	       ;; /tmp/bjbarcla/megatest_localdb/fullrun/.nfs.pdx.disks.icf_env_disk001.bjbarcla.gwa.issues.mtdev.matt-bisect.megatest.ext-tests.runs.all.v1.65.1.6524.dev.bb-24-justrollup-f8.rollup.fullrun/megatest.db.lock
	       (delete-file* (common:get-sync-lock-filepath)))
	      
	      ;; clear out junk records
	      ;;
	      ((dejunk)
	       ;; (db:delay-if-busy mtdb) ;; ok to delay on mtdb
	       (when (file-write-access? (dbr:dbdat-dbfile mtdb)) (db:clean-up mtdb))
	       (db:clean-up main-tmpdb)
              )
	      ;; sync from main dbs to /tmp ones.
	      ;;
	      ((old2new)
	       (set! data-synced
		 (+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb main-tmpdb)
		    data-synced)))
	      
	      ;; sync from /tmp dbs to main ones.
	      ;;
	      ((new2old)
	       (set! data-synced
		 (+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f main-tmpdb mtdb)
		    data-synced)))

	      ((adj-target)
	       (db:adj-target (dbr:dbdat-dbh mtdb))
	       (db:adj-target (dbr:dbdat-dbh main-tmpdb))
              )
	      
	      ((schema)
	       (db:patch-schema-maindb (dbr:dbdat-dbh mtdb))
	       (db:patch-schema-maindb (dbr:dbdat-dbh main-tmpdb))
	       (db:patch-schema-rundb  (dbr:dbdat-dbh mtdb))
	       (db:patch-schema-rundb  (dbr:dbdat-dbh main-tmpdb))
               )
              )
	    (dbfile:add-dbdat dbstruct #f main-tmpdb))
	  options)))
     (hash-table-values (dbr:dbstruct-subdbs dbstruct)))
    (if dbdat (dbfile:add-dbdat dbstruct #f dbdat))
    data-synced)
)

;; Sync all changed db's
;;
(define (db:tmp->megatest.db-sync dbstruct run-id last-update)
  (let* ((subdbs (hash-table-values (dbr:dbstruct-subdbs dbstruct)))
	 (res    '()))
    (for-each
     (lambda (subdb)
       (let* ((dbname (db:run-id->dbname run-id))
	      (mtdb   (dbr:subdb-mtdb subdb))
	      (tmpdb  (db:get-subdb dbstruct run-id))
	      (refndb (dbr:subdb-refndb subdb))
	      (newres (db:sync-tables (db:sync-all-tables-list dbstruct) last-update tmpdb refndb mtdb)))
	 ;; (stack-push! (dbr:subdb-dbstack subdb) tmpdb)
	 (dbfile:add-dbdat dbstruct run-id tmpdb)
	 (set! res (cons newres res))))
     subdbs)
    res))

;;;; run-ids








|


>
>
>
|
>

>
|
|
|
|
|
|
>
|
<
<
<
|
|

|



|
|








|
>
|
>
>
>
>
>
|
|
>
>
>
>
>
>
|
|
|




<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<













|








635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659



660
661
662
663
664
665
666
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
713
714
715
716
717
718
719
720
721
722

;;  'old2new      - sync megatest.db to /tmp/.../megatest.db and /tmp/.../megatest_ref.db
;;  'new2old      - sync /tmp/.../megatest.db to megatest.db and /tmp/.../megatest_ref.db (and update data_synced)
;;  'closeall     - close all opened dbs
;;  'schema       - attempt to apply schema changes
;;  run-ids: '(1 2 3 ...) or #f (for all)
;;
(define (db:multi-db-sync dbstruct . options)
  (let* ((dbdat       (db:open-db dbstruct #f db:initialize-main-db))
	 (data-synced 0) ;; count of changed records
    (tmp-area       (common:get-db-tmp-area))
    (old2new (member 'old2new options)) 
    (src-area (if old2new *toppath* tmp-area))
    (dest-area (if old2new tmp-area *toppath*))
    (dbfiles        (glob (conc src-area"/.db/*.db")))
    (keys (db:get-keys dbstruct))
    (sync-durations (make-hash-table)))
    
   (for-each
     (lambda (srcfile)
       (debug:print-info 3 *default-log-port* "file: " srcfile)
       (let* ((fname (conc (pathname-file srcfile) ".db"))
              (basename (pathname-file srcfile))
              (run-id (if (string= basename "main") #f (string->number basename)))
	      (destfile (conc dest-area "/.db/" fname))
	      (time1 (file-modification-time srcfile))



	      (time2 (if (file-exists? destfile)
			 (file-modification-time destfile)
			 (begin
			   (debug:print-info 0 *default-log-port* "Sync - I do not see file " destfile)
			   0)))
	      (changed (> time1 time2))
	      (do-cp (cond
		      ((not (file-exists? destfile)) ;; shouldn't happen, but this might recover
		       (debug:print-info 0 *default-log-port* "File " destfile " not found! Copying "srcfile" to "destfile)
		       #t)
		      (changed ;; (and changed
		       ;; (> (- (current-seconds) time1) 3)) ;; if file is changed and three seconds have passed.
		       #t)
		      ((and changed *time-to-exit*) ;; last sync
		       #t)
		      (else
		       #f))))
          (if do-cp
	     (let* (
                    (start-time (current-milliseconds))
                    (subdb (or (dbfile:get-subdb dbstruct run-id) (dbfile:init-subdb dbstruct run-id dbfile:db-init-proc)))
                    (mtdb      (dbr:subdb-mtdbdat subdb))
                    (tmpdb     (dbfile:open-db dbstruct run-id dbfile:db-init-proc))

                    )
	       (debug:print-info 0 *default-log-port* "delta syncing file: " srcfile ", time diff: " (- time1 time2) " seconds")

               (if old2new
		 (db:sync-tables (db:sync-all-tables-list dbstruct (db:get-keys dbstruct)) #f mtdb tmpdb)
		 (db:sync-tables (db:sync-all-tables-list dbstruct (db:get-keys dbstruct)) #f tmpdb mtdb)
               )


	       (hash-table-set! sync-durations (conc srcfile ".db") (- (current-milliseconds) start-time)))
	     (debug:print-info 0 *default-log-port* "skipping delta sync. " srcfile " is up to date")
          )
       )
     )
     dbfiles
    )

















































    data-synced
  )
























)

;; Sync all changed db's
;;
(define (db:tmp->megatest.db-sync dbstruct run-id last-update)
  (let* ((subdbs (hash-table-values (dbr:dbstruct-subdbs dbstruct)))
	 (res    '()))
    (for-each
     (lambda (subdb)
       (let* ((dbname (db:run-id->dbname run-id))
	      (mtdb   (dbr:subdb-mtdb subdb))
	      (tmpdb  (db:get-subdb dbstruct run-id))
	      (refndb (dbr:subdb-refndb subdb))
	      (newres (db:sync-tables (db:sync-all-tables-list dbstruct (db:get-keys dbstruct)) last-update tmpdb refndb mtdb)))
	 ;; (stack-push! (dbr:subdb-dbstack subdb) tmpdb)
	 (dbfile:add-dbdat dbstruct run-id tmpdb)
	 (set! res (cons newres res))))
     subdbs)
    res))

;;;; run-ids
︙︙

Modified dbfile.scm from [6257400a66] to [ec5e9b082c].

︙︙
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476

	       "ERROR: database " fname " has some permissions problem."))
         (exn ()
	      (dbfile:print-and-exit
	       "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn))))
	)))


;; This routine creates the db if not already present. It is only called if the db is not already opened
;;
#;(define (db:init-dbstruct dbstruct run-id init-proc #!key (do-sync #t))
  (let* ((subdb          (dbfile:get-subdb dbstruct run-id))
	 (tmpdb-stack    (dbr:subdb-dbstack subdb)) 
	 (max-stale-tmp  (dbr:dbstruct-max-stale-secs dbstruct));; (configf:lookup-number *configdat* "server" "filling-db-max-stale-seconds" default: 10))
	   (dbpath       (dbr:dbstruct-tmppath dbstruct)) ;;  (db:dbfile-path))      ;; path to tmp db area
	   (dbname       (dbfile:run-id->dbname run-id))
	   (dbexists     (file-exists? dbpath))
	   (areapath     (dbr:dbstruct-areapath dbstruct))
	   (mtdbfname    (conc areapath "/"dbname))
	   (mtdbexists   (file-exists? mtdbfname))
	   (mtdbmodtime  (if mtdbexists (dbfile:lazy-sqlite-db-modification-time mtdbfname)  #f))
	   (mtdb         (db:open-sqlite-db mtdbfname init-proc))
	   ;; the reference db for syncing
	   (refdbfname   (conc dbpath "/"dbname"_ref"))
	   (refndb       (db:open-megatest-db refdbfname))
	   ;; (mtdbpath     (dbr:dbdat-dbfile mtdb))
	   ;; the tmpdb
	   (tmpdbfname   (conc dbpath"/"dbname)) ;; /tmp/<stuff>/.db/[main|1,2...].db 
	   (tmpdb        (db:open-megatest-db tmpdbfname)) ;; lock-create-open dbpath db:initialize-main-db))
	   (dbfexists    (common:file-exists? tmpdbfname))  ;; (conc dbpath "/megatest.db")))
	   (tmpdbmodtime (if dbfexists  (common:lazy-sqlite-db-modification-time tmpdbfname) #f))
	   
	   (write-access (file-write-access? mtdbfname))
	   
	   ;; (mtdbmodtime (if mtdbexists
	   ;; (common:lazy-sqlite-db-modification-time mtdbpath)
	   ;; #f)) ; moving this before db:open-megatest-db is
	   ;; called. if wal mode is on -WAL and -shm file get
	   ;; created with causing the tmpdbmodtime timestamp
	   ;; always greater than mtdbmodtime (tmpdbmodtime (if
	   ;; dbfexists (common:lazy-sqlite-db-modification-time
	   ;; tmpdbfname) #f)) if wal mode is on -WAL and -shm
	   ;; file get created when db:open-megatest-db is
	   ;; called. modtimedelta will always be < 10 so db in
	   ;; tmp not get synced (tmpdbmodtime (if dbfexists
	   ;; (db:get-last-update-time (car tmpdb)) #f)) (fmt
	   ;; (file-modification-time tmpdbfname))
	   
	   (modtimedelta (and mtdbmodtime tmpdbmodtime (- mtdbmodtime tmpdbmodtime))))

    (when write-access
      (sqlite3:execute (dbr:dbdat-dbh mtdb) "drop trigger if exists update_tests_trigger")
      (sqlite3:execute (dbr:dbdat-dbh mtdb) "drop trigger if exists update_runs_trigger"))
    
    ;; (print "mtdbmodtime " mtdbmodtime " tmpdbmodtime " tmpdbmodtime " mtdbpath " mtdbpath " " (conc *toppath* "/megatest.db"))
    ;; (debug:print-info 13 *default-log-port* "db:open-db>> mtdbpath="mtdbpath" mtdbexists="mtdbexists" and write-access="write-access)
    (if (and dbexists (not write-access))
	(begin
	  (set! *db-write-access* #f)
	  (dbr:subdb-read-only-set! subdb #t)))
    (dbr:subdb-mtdb-set!   subdb mtdb)
    (dbr:subdb-tmpdb-set!  subdb tmpdb)
    (dbr:subdb-dbstack-set! subdb (make-stack)) ;; BB: why a stack?  Why would the number of db's be indeterminate?  Is this a legacy of 1.db 2.db .. ?
    (stack-push! (dbr:subdb-dbstack subdb) tmpdb) ;; olddb is already a (cons db path)
    (dbr:subdb-refndb-set! subdb refndb)
    (if (and  (or (not dbfexists)
		  (and modtimedelta
		       (> modtimedelta max-stale-tmp))) ;; if db in tmp is over ten seconds older than the file in MTRA then do a sync back
	      do-sync)
	(begin
	  (dbfile:print-err "filling db " (dbr:dbdat-dbfile tmpdb) " with data \n    from " (dbr:dbdat-dbfile mtdb) " mod time delta: " modtimedelta)
	  (db:sync-tables (db:sync-all-tables-list subdb) #f mtdb refndb tmpdb)
	  ;; touch tmp db to avoid wal mode wierdness  
	  (set! (file-modification-time tmpdbfname) (current-seconds))  
	  (dbfile:print-err "INFO: db:sync-all-tables-list done.")
	  )
	(dbfile:print-err " db, " (dbr:dbdat-dbfile tmpdb) " already exists or fresh enough, not propogating data from\n     " (dbr:dbdat-dbfile mtdb) " mod time delta: " modtimedelta) )
    ;; (db:multi-db-sync subdb 'old2new))  ;; migrate data from megatest.db automatically
    tmpdb))
		
;;======================================================================
;; 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








<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








392
393
394
395
396
397
398







































































399
400
401
402
403
404
405

	       "ERROR: database " fname " has some permissions problem."))
         (exn ()
	      (dbfile:print-and-exit
	       "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn))))
	)))









































































		
;;======================================================================
;; 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
︙︙
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890

                         slave-dbs)))
                   (for-each
                    (lambda (bad-dbdat)
                      (dbfile:print-err "db:sync-tables called with todb not a read-only database " bad-dbdat))
                    readonly-slave-dbs)
                   readonly-slave-dbs))) -6)
    (else
     (dbfile:print-err "db:sync-tables: args are good")

     (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








|








805
806
807
808
809
810
811
812
813
814
815
816
817
818
819

                         slave-dbs)))
                   (for-each
                    (lambda (bad-dbdat)
                      (dbfile:print-err "db:sync-tables called with todb not a read-only database " bad-dbdat))
                    readonly-slave-dbs)
                   readonly-slave-dbs))) -6)
    (else
    ;; (dbfile:print-err "db:sync-tables: args are good")

     (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
︙︙
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007

					      #f))
                      (is-trigger-dropped (if (member "last_update" field-names)
                                              (db:is-trigger-dropped db tablename)
					      #f)) 
		      (stmth  (sqlite3:prepare db full-ins))
                      (changed-rows 0))
		 ;; (db:delay-if-busy targdb) ;; NO WAITING
                 (if (member "last_update" field-names)
                     (dbfile:print-err "is-trigger-dropped: " is-trigger-dropped)) 

		 (for-each
		  (lambda (fromdat-lst)
		    (sqlite3:with-transaction
		     db
		     (lambda ()
		       (for-each ;; 








|
|








921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936

					      #f))
                      (is-trigger-dropped (if (member "last_update" field-names)
                                              (db:is-trigger-dropped db tablename)
					      #f)) 
		      (stmth  (sqlite3:prepare db full-ins))
                      (changed-rows 0))
		 ;; (db:delay-if-busy targdb) ;; NO WAITING
                 ;; (if (member "last_update" field-names)
                 ;;    (dbfile:print-err "is-trigger-dropped: " is-trigger-dropped)) 

		 (for-each
		  (lambda (fromdat-lst)
		    (sqlite3:with-transaction
		     db
		     (lambda ()
		       (for-each ;;
︙︙

This page was generated in about 0.115s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00