Megatest

Diff
Login

Differences From Artifact [974c310e18]:

To Artifact [131d871139]:


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
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







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

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

-
-
+
+
-

-
+





-
+
-







    (tmp-area       (common:get-db-tmp-area))
    (dbfiles        (glob (conc tmp-area"/.megatest/*.db")))
    (sync-durations (make-hash-table))
    (no-sync-db        (db:open-no-sync-db)))
    (for-each
     (lambda (file)
       (debug:print-info 3 *default-log-port* "file: " file)
       (let* ((fname (conc (pathname-file file) ".db"))
	      (fulln (conc *toppath*"/.megatest/"fname))
	      (time1 (if (file-exists? file)
			 (file-modification-time file)
			 (begin
			   (debug:print-info 2 *default-log-port* "Sync - I do not see file "file)
       (let* ((fname       (conc (pathname-file file) ".db"))
	      (fulln       (conc *toppath*"/.megatest/"fname))
	      (time1       (if (file-exists? file)
			       (file-modification-time file)
			       (begin
				 (debug:print-info 2 *default-log-port* "Sync - I do not see file "file)
			   1)))
	      (time2 (if (file-exists? fulln)
			 (file-modification-time fulln)
			 (begin
			   (debug:print-info 2 *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 2 *default-log-port* "File "fulln" not found! Copying "fname" to "fulln)
	      (time2       (if (file-exists? fulln)
			       (file-modification-time fulln)
			       (begin
				 (debug:print-info 2 *default-log-port* "Sync - I do not see file "fulln)
				 0)))
	      (changed      (> (- time1 time2) (+ (random 5) 1)))  ;; it has been at some few seconds since last synced
	      (changed10    (> (- time1 time2) 10)) ;; it has been at least ten seconds since sync'd
	      (jfile-exists (file-exists? (conc file"-journal"))) ;; i.e. are we busy?
	      (do-cp        (cond
			     ((not (file-exists? fulln)) ;; shouldn't happen, but this might recover
			      (cons #t (conc "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.
			     ((and (not jfile-exists) changed)
			      (cons #t "not busy, changed")) ;; not busy and changed
			     ((and jfile-exists changed10)
		       #t)
		      ((and changed *time-to-exit*) ;; last sync
			      (cons #t "busy but not synced in a while")) ;; busy but not sync'd in over 10 seconds
			     ((and changed *time-to-exit*)
		       #t)
		      (else
		       #f))))
	 (if do-cp
			      (cons #t "Time to exit, forced final sync")) ;; last sync
			     (else
			      (cons #f "No sync needed")))))
	 (if (car do-cp)
	     (let* ((start-time (current-milliseconds))
              (fname (pathname-file file))
              (runid (if (string= fname "main") #f (string->number fname)))
		    (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")
				 fname", delta: " (- time1 time2) " seconds, reason: "(cdr do-cp))
	       (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
     dbfiles)
     )
    (if dbdat (dbfile:add-dbdat dbstruct #f dbdat)))
  #t)

;; options:
;;
;;  'killservers  - kills all servers
;;  'dejunk       - removes junk records
1861
1862
1863
1864
1865
1866
1867
1868

1869
1870
1871
1872
1873
1874
1875

1876

1877


1878
1879
1880
1881
1882
1883
1884
1861
1862
1863
1864
1865
1866
1867

1868
1869
1870
1871
1872
1873
1874

1875
1876
1877

1878
1879
1880
1881
1882
1883
1884
1885
1886







-
+






-
+

+
-
+
+







	 (contour   (or contour-in ""))  ;; empty string to force no hierarcy and be backwards compatible.
	 (comma     (if (> (length keys) 0) "," ""))
	 (andstr    (if (> (length keys) 0) " AND " ""))
	 (valslots  (keys->valslots keys)) ;; ?,?,? ...
	 (allvals   (append (list runname state status user contour) (map cadr keyvals)))
	 (qryvals   (append (list runname) (map cadr keyvals)))
	 (key=?str  (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND ")))
  (debug:print 0 *default-log-port* "Got here 0.")
    ;; (debug:print 0 *default-log-port* "Got here 0.")
    (debug:print 3 *default-log-port* "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str)
    (debug:print 2 *default-log-port* "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run")
    (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and"
	(db:with-db
	 dbstruct #f #f
	 (lambda (dbdat db)
  (debug:print 0 *default-log-port* "Got here 1.")
	   ;; (debug:print 0 *default-log-port* "Got here 1.")
	   (let ((res #f))
	     (apply sqlite3:execute db
	     (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time,contour" comma keystr ") VALUES (?,?,?,?,strftime('%s','now'),?" comma valslots ");")
		    (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time,contour"
			  comma keystr ") VALUES (?,?,?,?,strftime('%s','now'),?" comma valslots ");")
		    allvals)
	     (apply sqlite3:for-each-row 
		    (lambda (id)
		      (set! res id))
		    db
		    (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");")))
		      qry)