Megatest

Check-in [d8806806d5]
Login
Overview
Comment:Default to tcp in dashboard.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.80
Files: files | file ages | folders
SHA1: d8806806d573da5f818b3288cd647256ed05c7ed
User & Date: matt on 2023-08-21 17:15:26
Other Links: branch diff | manifest | tags
Context
2023-09-29
08:07
Added beginnings of processes table in no-sync check-in: 923cf91611 user: matt tags: v1.80-processes
2023-08-21
17:44
merged fork check-in: f5b6549716 user: mmgraham tags: v1.80, v1.8017
17:15
Default to tcp in dashboard. check-in: d8806806d5 user: matt tags: v1.80
10:29
Changed servers to be run under system instead of nbfake to help batch tools detect that the process is still running (untested). check-in: 4fe087efa3 user: matt tags: v1.80
Changes

Modified common.scm from [00402a6248] to [516effd7ae].

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
931
932
933
934
935
936
937











938
939
940
941
942
943
944







-
-
-
-
-
-
-
-
-
-
-







	    (if (equal? thepath "/")
		(begin
		  (debug:print-error 0 *default-log-port* "Unable to find megatest home directory.")
		  #f)
		(loop (pathname-directory thepath)))))
      ))


(define (common:db-tmp-area-path)
  (conc "/tmp/" 
         (current-user-name)
	 "/megatest_localdb/"
	 (common:get-testsuite-name)
         "/"
	 (string-translate *toppath* "/" ".")
  )
)


;;======================================================================
;; redefine for future cleanup (converge on area-name, the more generic
;;
(define common:get-area-name common:get-testsuite-name)

(define (common:get-db-tmp-area . junk)
965
966
967
968
969
970
971
972

973
974
975
976
977
978
979
954
955
956
957
958
959
960

961
962
963
964
965
966
967
968







-
+







		     (tsname (common:get-testsuite-name))
		     (dbpath (common:get-create-writeable-dir
			      (list (conc "/tmp/" (current-user-name)
					  "/megatest_localdb/"
					  tsname "/"
					  (string-translate toppath "/" "."))
				    (conc "/tmp/" (current-process-id) ;; just in case we have an issue with the dir by own user name
					  "/megatest_localdb/"
					  "/"(current-user-name) "/megatest_localdb/"
					  tsname
					  (string-translate toppath "/" "."))
				    ))))
		(set! *db-cache-path* dbpath)
		;; ensure megatest area has .mtdb
		(let ((dbarea (conc *toppath* "/.mtdb")))
		  (if (not (file-exists? dbarea))

Modified commonmod.scm from [409ebb7538] to [7e88abb9dd].

164
165
166
167
168
169
170



171
172
173
174
175





176
177

178
179
180
181
182
183
184
164
165
166
167
168
169
170
171
172
173





174
175
176
177
178
179
180
181
182
183
184
185
186
187
188







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


+







  (hash-table-ref/default cfgdat section '()))

;; dot-locking egg seems not to work, using this for now
;; if lock is older than expire-time then remove it and try again
;; to get the lock
;;
(define (common:simple-file-lock fname #!key (expire-time 300))
  (let* ((lock-exists (file-exists? fname))
	 (fmod-time (if lock-exists
			(current-seconds)
  (let ((fmod-time (handle-exceptions
		       ext
		     (current-seconds)
		     (file-modification-time fname))))
    (if (file-exists? fname) ;; (common:file-exists? fname)
			(handle-exceptions
			 ext
			 (current-seconds)
			 (file-modification-time fname)))))
    (if lock-exists
	(if (> (- (current-seconds) fmod-time) expire-time)
	    (begin
	      (debug:print-info 1 *default-log-port* "Removing stale lock "fname)
	      (handle-exceptions exn #f (delete-file* fname))	
	      (common:simple-file-lock fname expire-time: expire-time))
	    #f)
	(let ((key-string (conc (get-host-name) "-" (current-process-id))))
	  (with-output-to-file fname
	    (lambda ()
	      (print key-string)))

Modified dashboard.scm from [349c7d2aed] to [d064a48d13].

115
116
117
118
119
120
121
122


123
124
125
126
127
128
129
115
116
117
118
119
120
121

122
123
124
125
126
127
128
129
130







-
+
+







			"-:p"     ;; ignore the built in chicken profiling switch
			)
		 args:arg-hash
		 0))

(if (args:get-arg "-mode")
    (let* ((mode (string->symbol (args:get-arg "-mode"))))
      (rmt:transport-mode mode)))
      (rmt:transport-mode mode))
    (rmt:transport-mode 'tcp))

(if (args:get-arg "-test") ;; need to use tcp for test control panel
    (rmt:transport-mode 'tcp))

;; RA => Might require revert for filters 
;; create a watch dog to move changes from lt/.db/*.db to megatest.db
;;
695
696
697
698
699
700
701
702
703


704
705
706
707
708
709
710
696
697
698
699
700
701
702


703
704
705
706
707
708
709
710
711







-
-
+
+







                        0
                        (dboard:rundat-last-update run-dat)))
	 (last-db-time (if do-not-use-db-file-timestamps
			   0
			   (dboard:rundat-last-db-time run-dat)))
	 (db-path      (or (dboard:rundat-db-path run-dat)
			   (let* ((db-dir (get-environment-variable "MT_RUN_AREA_HOME")) ;;  (common:get-db-tmp-area))
				  (db-pth (conc db-dir "/.mtdb/main.db")))
			     (dboard:rundat-db-path-set! run-dat db-pth)
				  (db-pth (conc db-dir "/.mtdb/*.db")))
			     (dboard:rundat-db-path-set! run-dat db-pth) ;; this is just a cache of the path
			     db-pth)))
	 (db-mod-time  (common:lazy-sqlite-db-modification-time db-path))
	 (db-modified  (>= db-mod-time last-db-time))
	 (multi-get    (> (dboard:rundat-run-data-offset run-dat) 0))  ;; multi-get in progress
	 (tmptests     (if (or do-not-use-db-file-timestamps
			       (dboard:tabdat-filters-changed tabdat)
			       db-modified)

Modified db.scm from [d424f2ae6d] to [a33d322bf7].

560
561
562
563
564
565
566
567


568
569
570
571
572
573
574
560
561
562
563
564
565
566

567
568
569
570
571
572
573
574
575







-
+
+







	 (data-synced 0) ;; count of changed records
	 (tmp-area       (common:get-db-tmp-area))
	 (old2new (member 'old2new options))
	 (dejunk (member 'dejunk options))
	 (killservers (member 'killservers options))
	 (src-area (if old2new *toppath* tmp-area))
	 (dest-area (if old2new tmp-area *toppath*))
	 (dbfiles        (if old2new (glob (conc *toppath* "/.mtdb/*.db")) (glob (conc tmp-area "/.mtdt/*.db"))))
	 (dbfiles        (if old2new (glob (conc *toppath* "/.mtdb/*.db"))
			     (glob (conc tmp-area "/.mtdb/*.db"))))
	 (keys (db:get-keys dbstruct))
	 (sync-durations (make-hash-table)))

    ;; kill servers
    (if killservers (db:kill-servers))
    
    (if (not dbfiles)