Megatest

(define (db:setup run-id #!key (local #f))
  (let* ((dbdir    (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
	 (dbstruct (make-dbr:dbstruct path: dbdir local: local)))
    dbstruct))

;; Open the classic megatest.db file in toppath
;;
(define (db:open-megatest-db #!key (path #f))
  (let* ((dbpath       (or path (conc *toppath* "/megatest.db")))
	 (dbexists     (file-exists? dbpath))
	 (db           (db:lock-create-open dbpath
					    (lambda (db)
					      (db:initialize-main-db db)
					      (db:initialize-run-id-db db))))
	 (write-access (file-write-access? dbpath)))
    (if (and dbexists (not write-access))

                              last_update INTEGER DEFAULT (strftime('%s','now')))")
  (sqlite3:execute maindb "CREATE TRIGGER  IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats
                             FOR EACH ROW
                               BEGIN 
                                 UPDATE run_stats SET last_update=(strftime('%s','now'))
                                   WHERE id=old.id;
                               END;"))

(define (db:cache-for-read-only source target)
	(let* ((toppath  (launch:setup))
		(cache-db (db:open-megatest-db path: target))
		(source-db (db:open-megatest-db path: source))
		(curr-time (current-seconds))
		(res '()))
		(print source-db)
		(begin
			(if (not (file-exists? target)) 
				((db:sync-tables (db:sync-main-list source-db) source-db cache-db)
				(db:sync-tables db:sync-tests-only source-db cache-db)
				(db:clean-up-rundb cache-db))
				((sqlite3:for-each-row
				     (lambda (id release runname state status owner event_time comment fail_count pass_count )
				       (set! res (cons (id release runname state status owner event_time comment fail_count pass_count ) res)))
				     (db:dbdat-get-db source-db)
				     "SELECT id, release, runname, state, status, owner, event_time, comment, fail_count, pass_count FROM runs;"))
				)
			(print res)
			(sqlite3:finalize! (db:dbdat-get-db cache-db))
		   ))
	)

;; options:
;;
;;  'killservers  - kills all servers
;;  'dejunk       - removes junk records
;;  'adj-testids  - move test-ids into correct ranges
;;  'old2new      - sync megatest.db records to .db/{main,1,2 ...}.db

	 servers))

    ;; clear out junk records
    ;;
    (if (member 'dejunk options)
	(begin
	  (db:delay-if-busy mtdb)
	  (db:clean-up mtdb)))	

    ;; adjust test-ids to fit into proper range
    ;;
    (if (member 'adj-testids options)
	(begin
	  (db:delay-if-busy mtdb)
	  (db:prep-megatest.db-for-migration mtdb)))

			"-o"
			"-log"
			"-archive"
			"-since"
			"-fields"
			"-recover-test" ;; run-id,test-id - used internally to recover a test stuck in RUNNING state
			"-sort"
			"-target-db"
			"-source-db"
			)
 		 (list  "-h" "-help" "--help"
			"-manual"
			"-version"
		        "-force"
		        "-xterm"
		        "-showkeys"
		        "-show-keys"
		        "-test-status"
			"-set-values"
			"-load-test-data"
			"-summarize-items"
		        "-gui"
			"-daemonize"
			"-preclean"
			"-rerun-clean"
			"-rerun-all"
			"-clean-cache"
			"-cache-db"
			;; misc
			"-repl"
			"-lock"
			"-unlock"
			"-list-servers"
                        "-run-wait"      ;; wait on a run to complete (i.e. no RUNNING)
			"-local"         ;; run some commands using local db access

(on-exit std-exit-procedure)

;;======================================================================
;; Misc general calls
;;======================================================================

(if (args:get-arg "-cache-db")
	(begin
		(set! *didsomething* #t)
		(let* ((temp-dir (or (args:get-arg "-target-db") (create-directory (conc "/tmp/" (getenv "USER") "/" (string-translate (current-directory) "/" "_")))))
			(target-db (conc temp-dir "/cached.db"))
			(source-db (args:get-arg "-source-db")))

		(db:cache-for-read-only source-db target-db))))

;; handle a clean-cache request as early as possible
;;
(if (args:get-arg "-clean-cache")
    (begin
      (set! *didsomething* #t) ;; suppress the help output.
      (if (getenv "MT_TARGET") ;; no point in trying if no target
	  (if (args:get-arg "-runname")