Megatest

Check-in [0044c7f04a]
Login
Overview
Comment:Merged in db-only-on-homehost fix
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.64
Files: files | file ages | folders
SHA1: 0044c7f04a56ede11222b59918a61533d2a0e438
User & Date: matt on 2017-03-22 13:29:57
Other Links: branch diff | manifest | tags
Context
2017-03-24
22:39
Merged v1.63 changes into v1.64 check-in: b2e6452e2f user: matt tags: v1.64
22:18
non-good commit of merge multi-server-hack into v1.64 Leaf check-in: 42e2fcd1c8 user: matt tags: private (unpublished)
2017-03-22
13:29
Merged in db-only-on-homehost fix check-in: 0044c7f04a user: matt tags: v1.64
13:29
Fixed several places where an attempt was being made to open databases in spite on NOT being on homehost. Closed-Leaf check-in: 6e46d4a93e user: matt tags: db-only-on-homehost
12:53
Cleaned out handful of not used globals and added exception handler for dealing with problems when switching log file output port check-in: f61cc5eb98 user: matt tags: v1.64
Changes

Modified common.scm from [3ce2c22c8f] to [0b58394952].

276
277
278
279
280
281
282

283
284
285
286

287
288
289
290
291
292
293
                 exn
                 #f
                 (delete-file fullname)))))))
   '()
   "logs"))

;; Force a megatest cleanup-db if version is changed and skip-version-check not specified

;;
(define (common:exit-on-version-changed)
  (if (common:version-changed?)
      (if (common:on-homehost?)

	  (let* ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config"))
                (dbfile (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.db"))
                (read-only (not (file-write-access? dbfile)))
                (dbstruct (db:setup)))
	    (debug:print 0 *default-log-port*
			 "WARNING: Version mismatch!\n"
			 "   expected: " (common:version-signature) "\n"







>


<
|
>







276
277
278
279
280
281
282
283
284
285

286
287
288
289
290
291
292
293
294
                 exn
                 #f
                 (delete-file fullname)))))))
   '()
   "logs"))

;; Force a megatest cleanup-db if version is changed and skip-version-check not specified
;; Do NOT check if not on homehost!
;;
(define (common:exit-on-version-changed)

  (if (common:on-homehost?)
      (if (common:version-changed?)
	  (let* ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config"))
                (dbfile (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.db"))
                (read-only (not (file-write-access? dbfile)))
                (dbstruct (db:setup)))
	    (debug:print 0 *default-log-port*
			 "WARNING: Version mismatch!\n"
			 "   expected: " (common:version-signature) "\n"
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
              (debug:print 0 *default-log-port* "   You do not own megatest.db in this area.  Cannot proceed with megatest version migration.")
              (exit 1))
             (read-only
              (debug:print 0 *default-log-port* "   You have read-only access to this area.  Cannot proceed with megatest version migration.")
              (exit 1))
             (else
              (debug:print 0 *default-log-port* " to switch versions you can run: \"megatest -cleanup-db\"")
              (exit 1))))
	  (begin
	    (debug:print 0 *default-log-port* "ERROR: cannot migrate version unless on homehost. Exiting.")
	    (exit 1)))))

;;======================================================================
;; S P A R S E   A R R A Y S
;;======================================================================

(define (make-sparse-array)
  (let ((a (make-sparse-vector)))







|
|
|
|







316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
              (debug:print 0 *default-log-port* "   You do not own megatest.db in this area.  Cannot proceed with megatest version migration.")
              (exit 1))
             (read-only
              (debug:print 0 *default-log-port* "   You have read-only access to this area.  Cannot proceed with megatest version migration.")
              (exit 1))
             (else
              (debug:print 0 *default-log-port* " to switch versions you can run: \"megatest -cleanup-db\"")
              (exit 1)))))
      (begin
	(debug:print 0 *default-log-port* "ERROR: cannot migrate version unless on homehost. Exiting.")
	(exit 1))))

;;======================================================================
;; S P A R S E   A R R A Y S
;;======================================================================

(define (make-sparse-array)
  (let ((a (make-sparse-vector)))
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
			(delay-loop (+ count 1))))
		  (if (not *time-to-exit*) (loop))))
	    (if (common:low-noise-print 30)
		(debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)" this-wd-num="this-wd-num)))))))

;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
(define (common:watchdog)
  ;;#t)
  (debug:print-info 13 *default-log-port* "common:watchdog entered.")

 (let ((dbstruct (db:setup)))
   (debug:print-info 13 *default-log-port* "after db:setup with dbstruct="dbstruct)
   (cond
    ((dbr:dbstruct-read-only dbstruct)
     (debug:print-info 13 *default-log-port* "loading read-only watchdog")
     (common:readonly-watchdog dbstruct))
    (else
     (debug:print-info 13 *default-log-port* "loading writable-watchdog.")
     (common:writable-watchdog dbstruct))))
 (debug:print-info 13 *default-log-port* "watchdog done.");;)
 )



(define (std-exit-procedure)
  (on-exit (lambda () 0))
  ;;(debug:print-info 13 *default-log-port* "std-exit-procedure called; *time-to-exit*="*time-to-exit*)
  (let ((no-hurry  (if *time-to-exit* ;; hurry up
		       #f







<

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







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
			(delay-loop (+ count 1))))
		  (if (not *time-to-exit*) (loop))))
	    (if (common:low-noise-print 30)
		(debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)" this-wd-num="this-wd-num)))))))

;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
(define (common:watchdog)

  (debug:print-info 13 *default-log-port* "common:watchdog entered.")
  (if (common:on-homehost?)
      (let ((dbstruct (db:setup)))
	(debug:print-info 13 *default-log-port* "after db:setup with dbstruct="dbstruct)
	(cond
	 ((dbr:dbstruct-read-only dbstruct)
	  (debug:print-info 13 *default-log-port* "loading read-only watchdog")
	  (common:readonly-watchdog dbstruct))
	 (else
	  (debug:print-info 13 *default-log-port* "loading writable-watchdog.")
	  (common:writable-watchdog dbstruct)))
	(debug:print-info 13 *default-log-port* "watchdog done."))

      (debug:print-info 13 *default-log-port* "no need for watchdog on non-homehost")))


(define (std-exit-procedure)
  (on-exit (lambda () 0))
  ;;(debug:print-info 13 *default-log-port* "std-exit-procedure called; *time-to-exit*="*time-to-exit*)
  (let ((no-hurry  (if *time-to-exit* ;; hurry up
		       #f