Megatest

Check-in [6e46d4a93e]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Fixed several places where an attempt was being made to open databases in spite on NOT being on homehost.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | db-only-on-homehost
Files: files | file ages | folders
SHA1: 6e46d4a93e1eb8ca0ec08183d62a77ae18d27fd4
User & Date: matt on 2017-03-22 13:29:01
Other Links: branch diff | manifest | tags
Context
2017-03-22
14:44
applied patches for db init on non-homehost protection & no-cache mode check-in: 9ffefc583c user: bjbarcla tags: v1.63
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
2017-03-21
11:46
Added defence against bad sqlite3 handles to the finalizer check-in: 79058725e7 user: matt tags: v1.63
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified common.scm from [31405ca571] to [288525016a].

︙
271
272
273
274
275
276
277

278
279
280
281


282
283
284
285
286
287
288

271
272
273
274
275
276
277
278
279
280


281
282
283
284
285
286
287
288
289








+


-
-
+
+








                 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:version-changed?)
      (if (common:on-homehost?)
  (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"
︙
310
311
312
313
314
315
316
317
318
319
320




321
322
323
324
325
326
327

311
312
313
314
315
316
317




318
319
320
321
322
323
324
325
326
327
328








-
-
-
-
+
+
+
+








              (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)))))
              (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)))
︙
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

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








-

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








			(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.");;)
  (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
︙

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