Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -30,11 +30,12 @@
ezsteps.scm lock-queue.scm sdb.scm \
rmt.scm api.scm subrun.scm \
portlogger.scm archive.scm env.scm diff-report.scm cgisetup/models/pgdb.scm
# module source files
-MSRCFILES = ftail.scm
+MSRCFILES = ftail.scm rmtmod.scm commonmod.scm
+
# Eggs to install (straightforward ones)
EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \
dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \
json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \
@@ -71,11 +72,11 @@
PNGFILES = $(shell cd docs/manual;ls *png)
#all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut ndboard
all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut tcmt
-mtest: $(OFILES) readline-fix.scm megatest.o $(MOFILES) mofiles/ftail.o
+mtest: $(OFILES) readline-fix.scm megatest.o $(MOFILES) mofiles/ftail.o mofiles/rmtmod.o mofiles/commonmod.o
csc $(CSCOPTS) $(OFILES) $(MOFILES) megatest.o -o mtest
showmtesthash:
@echo $(MTESTHASH)
@@ -83,12 +84,12 @@
csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MOFILES) -o dboard
ndboard : newdashboard.scm $(OFILES) $(GOFILES)
csc $(CSCOPTS) $(OFILES) $(GOFILES) newdashboard.scm -o ndboard
-mtut: $(OFILES) megatest-fossil-hash.scm mtut.scm
- csc $(CSCOPTS) $(OFILES) mtut.scm -o mtut
+mtut: $(OFILES) $(MOFILES) megatest-fossil-hash.scm mtut.scm
+ csc $(CSCOPTS) $(OFILES) $(MOFILES) mtut.scm -o mtut
TCMTOBJS = \
api.o \
archive.o \
@@ -108,11 +109,13 @@
megatest-version.o \
ods.o \
portlogger.o \
process.o \
rmt.o \
- rpc-transport.o \
+ mofiles/rmtmod.o \
+ mofiles/commonmod.o \
+ rpc-transport.o \
runconfig.o \
runs.o \
server.o \
tasks.o \
tdb.o \
@@ -160,10 +163,13 @@
vg.o dashboard.o : vg_records.scm
dcommon.o : run_records.scm
# Temporary while transitioning to new routine
# runs.o : run-tests-queue-classic.scm run-tests-queue-new.scm
+# for the modularized stuff
+mofiles/rmtmod.o : mofiles/commonmod.o
+
megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm
echo "(define megatest-fossil-hash \"$(MTESTHASH)\")" > megatest-fossil-hash.new
if ! diff -q megatest-fossil-hash.new megatest-fossil-hash.scm ; then echo copying .new to .scm;cp -f megatest-fossil-hash.new megatest-fossil-hash.scm;fi
$(OFILES) $(GOFILES) : common_records.scm
@@ -196,12 +202,12 @@
utils/mk_wrapper $(PREFIX) mtut $(PREFIX)/bin/mtutil
chmod a+x $(PREFIX)/bin/mtutil
# mtexec
-mtexec: $(OFILES) megatest-fossil-hash.scm mtexec.scm
- csc $(CSCOPTS) $(OFILES) mtexec.scm -o mtexec
+mtexec: $(OFILES) $(MOFILES) megatest-fossil-hash.scm mtexec.scm
+ csc $(CSCOPTS) $(OFILES) $(MOFILES) mtexec.scm -o mtexec
$(PREFIX)/bin/.$(ARCHSTR)/mtexec : mtexec
$(INSTALL) mtexec $(PREFIX)/bin/.$(ARCHSTR)/mtexec
$(PREFIX)/bin/mtexec : $(PREFIX)/bin/.$(ARCHSTR)/mtexec utils/mk_wrapper
@@ -320,11 +326,12 @@
$(MTQA_FOSSIL) :
fossil clone https://www.kiatoa.com/fossils/megatest_qa $(MTQA_FOSSIL)
clean :
- rm -f $(OFILES) $(GOFILES) $(MOFILES) $(TCMTOBJS) $(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil mtut tcmt ftail.import.scm readline-fix.scm serialize-env share dboard dboard.o megatest.o dashboard.o megatest-fossil-hash.* altdb.scm mofiles/*.o vg.o
+ rm -f $(OFILES) $(GOFILES) $(MOFILES) $(TCMTOBJS) $(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil mtut tcmt ftail.import.scm readline-fix.scm serialize-env dboard dboard.o megatest.o dashboard.o megatest-fossil-hash.* altdb.scm mofiles/*.o vg.o
+ rm -rf share
#======================================================================
# Make the records files
#======================================================================
Index: api.scm
==================================================================
--- api.scm
+++ api.scm
@@ -78,11 +78,11 @@
read-test-data*
login
tasks-get-last
testmeta-get-record
have-incompletes?
- synchash-get
+ ;; synchash-get
get-changed-record-ids
get-run-record-ids
get-not-completed-cnt))
(define api:write-queries
@@ -247,11 +247,11 @@
;; ARCHIVES
;; ((archive-get-allocations)
((archive-register-disk) (apply db:archive-register-disk dbstruct params))
((archive-register-block-name)(apply db:archive-register-block-name dbstruct params))
- ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey))
+ ;; ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey))
;;======================================================================
;; READ ONLY QUERIES
;;======================================================================
@@ -271,21 +271,21 @@
((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id dbstruct params))
((get-count-tests-running-for-testname) (apply db:get-count-tests-running-for-testname dbstruct params))
((get-count-tests-running) (apply db:get-count-tests-running dbstruct params))
((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params))
;; ((delete-test-step-records) (apply db:delete-test-step-records dbstruct params))
- ((get-previous-test-run-record) (apply db:get-previous-test-run-record dbstruct params))
+ ;; ((get-previous-test-run-record) (apply db:get-previous-test-run-record dbstruct params))
((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params))
((test-get-logfile-info) (apply db:test-get-logfile-info dbstruct params))
((test-get-records-for-index-file) (apply db:test-get-records-for-index-file dbstruct params))
((get-testinfo-state-status) (apply db:get-testinfo-state-status dbstruct params))
((test-get-top-process-pid) (apply db:test-get-top-process-pid dbstruct params))
((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params))
((get-prereqs-not-met) (apply db:get-prereqs-not-met dbstruct params))
((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params))
((get-not-completed-cnt) (apply db:get-not-completed-cnt dbstruct params))
- ((synchash-get) (apply synchash:server-get dbstruct params))
+ ;; ((synchash-get) (apply synchash:server-get dbstruct params))
((get-raw-run-stats) (apply db:get-raw-run-stats dbstruct params))
((get-test-times) (apply db:get-test-times dbstruct params))
;; RUNS
((get-run-info) (apply db:get-run-info dbstruct params))
@@ -294,11 +294,11 @@
((set-run-status) (apply db:set-run-status dbstruct params))
((set-run-state-status) (apply db:set-run-state-status dbstruct params))
((get-tests-for-run) (apply db:get-tests-for-run dbstruct params))
((get-test-id) (apply db:get-test-id dbstruct params))
((get-tests-for-run-mindata) (apply db:get-tests-for-run-mindata dbstruct params))
- ((get-tests-for-runs-mindata) (apply db:get-tests-for-runs-mindata dbstruct params))
+ ;; ((get-tests-for-runs-mindata) (apply db:get-tests-for-runs-mindata dbstruct params))
((get-runs) (apply db:get-runs dbstruct params))
((simple-get-runs) (apply db:simple-get-runs dbstruct params))
((get-num-runs) (apply db:get-num-runs dbstruct params))
((get-runs-cnt-by-patt) (apply db:get-runs-cnt-by-patt dbstruct params))
((get-all-run-ids) (db:get-all-run-ids dbstruct))
@@ -329,12 +329,12 @@
(run-id (cadr params))
(realparams (cddr params)))
(db:general-call dbstruct stmtname realparams)))
((sdb-qry) (apply sdb:qry params))
((ping) (current-process-id))
- ((get-changed-record-ids) (apply db:get-changed-record-ids dbstruct params))
- ((get-run-record-ids) (apply db:get-run-record-ids dbstruct params))
+ ((get-changed-record-ids) (apply db:get-changed-record-ids dbstruct params))
+ ((get-run-record-ids) (apply db:get-run-record-ids dbstruct params))
;; TESTMETA
((testmeta-get-record) (apply db:testmeta-get-record dbstruct params))
;; TASKS
((find-task-queue-records) (apply tasks:find-task-queue-records dbstruct params))
Index: client.scm
==================================================================
--- client.scm
+++ client.scm
@@ -39,24 +39,26 @@
(let ((sig (conc (get-host-name) " " (current-process-id))))
(set! *my-client-signature* sig)
*my-client-signature*)))
;; Not currently used! But, I think it *should* be used!!!
-(define (client:logout serverdat)
+#;(define (client:logout serverdat)
(let ((ok (and (socket? serverdat)
(cdb:logout serverdat *toppath* (client:get-signature)))))
ok))
-(define (client:connect iface port)
- (case (server:get-transport)
+#;(define (client:connect iface port)
+ (http-transport:client-connect iface port)
+ #;(case (server:get-transport)
((rpc) (rpc:client-connect iface port))
((http) (http:client-connect iface port))
((zmq) (zmq:client-connect iface port))
(else (rpc:client-connect iface port))))
(define (client:setup areapath #!key (remaining-tries 100) (failed-connects 0))
- (case (server:get-transport)
+ (client:setup-http areapath remaining-tries: remaining-tries failed-connects: failed-connects)
+ #;(case (server:get-transport)
((rpc) (rpc-transport:client-setup remaining-tries: remaining-tries failed-connects: failed-connects)) ;;(client:setup-rpc run-id))
((http)(client:setup-http areapath remaining-tries: remaining-tries failed-connects: failed-connects))
(else (rpc-transport:client-setup remaining-tries: remaining-tries failed-connects: failed-connects)))) ;; (client:setup-rpc run-id))))
;; Do all the connection work, look up the transport type and set up the
Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -26,10 +26,12 @@
(prefix sqlite3 sqlite3:)
pkts (prefix dbi dbi:)
)
(declare (unit common))
+(declare (uses commonmod))
+(import commonmod)
(include "common_records.scm")
;; (require-library margs)
@@ -471,46 +473,92 @@
;; remove previous compressed log and compress this log
;; WARNING: This proc operates assuming that it is in the directory above the
;; logs directory you wish to log-rotate.
;;
(define (common:rotate-logs)
- (if (not (directory-exists? "logs"))(create-directory "logs"))
- (directory-fold
- (lambda (file rem)
- (handle-exceptions
- exn
- (debug:print-info 0 *default-log-port* "unable to rotate log " file ", probably handled by another process.")
- (let* ((fullname (conc "logs/" file))
- (file-age (- (current-seconds)(file-modification-time fullname))))
- (if (or (and (string-match "^.*.log" file)
- (> (file-size fullname) 200000))
- (and (string-match "^server-.*.log" file)
- (> (- (current-seconds) (file-modification-time fullname))
- (* 8 60 60))))
- (let ((gzfile (conc fullname ".gz")))
- (if (common:file-exists? gzfile)
- (begin
- (debug:print-info 0 *default-log-port* "removing " gzfile)
- (delete-file gzfile)))
- (debug:print-info 0 *default-log-port* "compressing " file)
- (system (conc "gzip " fullname)))
- (if (> file-age (* (string->number (or (configf:lookup *configdat* "setup" "log-expire-days") "30")) 24 3600))
- (handle-exceptions
- exn
- #f
- (delete-file fullname)))))))
- '()
- "logs"))
-
+ (let* ((all-files (make-hash-table))
+ (stats (make-hash-table))
+ (inc-stat (lambda (key)
+ (hash-table-set! stats key (+ (hash-table-ref/default stats key 0) 1))))
+ (max-allowed (string->number (or (configf:lookup *configdat* "setup" "max-logfiles") "300")))) ;; name -> age
+ (if (not (directory-exists? "logs"))(create-directory "logs"))
+ (directory-fold
+ (lambda (file rem)
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print-info 0 *default-log-port* "unable to rotate log " file ", probably handled by another process.")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (print-call-chain (current-error-port)))
+ (let* ((fullname (conc "logs/" file))
+ (mod-time (file-modification-time fullname))
+ (file-age (- (current-seconds) mod-time)))
+ (hash-table-set! all-files file mod-time)
+ (if (or (and (string-match "^.*.log" file)
+ (> (file-size fullname) 200000))
+ (and (string-match "^server-.*.log" file)
+ (> (- (current-seconds) (file-modification-time fullname))
+ (* 8 60 60))))
+ (let ((gzfile (conc fullname ".gz")))
+ (if (common:file-exists? gzfile)
+ (begin
+ (debug:print-info 0 *default-log-port* "removing " gzfile)
+ (delete-file* gzfile)
+ (hash-table-delete! all-files gzfile) ;; needed?
+ ))
+ (debug:print-info 0 *default-log-port* "compressing " file)
+ (system (conc "gzip " fullname))
+ (inc-stat "gzipped")
+ (hash-table-set! all-files (conc file ".gz") file-age) ;; add the .gz file and remove the base file
+ (hash-table-delete! all-files file)
+ )
+ (if (> file-age (* (string->number (or (configf:lookup *configdat* "setup" "log-expire-days") "30")) 24 3600))
+ (handle-exceptions
+ exn
+ #f
+ (if (directory? fullname)
+ (begin
+ (debug:print-error 0 *default-log-port* fullname " in logs directory is a directory! Cannot rotate it, it is best to not put subdirectories in the logs dir.")
+ (inc-stat "directories"))
+ (begin
+ (delete-file* fullname)
+ (inc-stat "deleted")))
+ (hash-table-delete! all-files file)))))))
+ '()
+ "logs")
+ (for-each
+ (lambda (category)
+ (let ((quant (hash-table-ref/default stats category 0)))
+ (if (> quant 0)
+ (debug:print-info 0 *default-log-port* category " log files: " quant))))
+ `("deleted" "gzipped" "directories"))
+ (let ((num-logs (hash-table-size all-files)))
+ (if (> num-logs max-allowed) ;; because NFS => don't let number of logs exceed 300
+ (let ((files (take (sort (hash-table-keys all-files)
+ (lambda (a b)
+ (< (hash-table-ref all-files a)(hash-table-ref all-files b))))
+ (- num-logs max-allowed))))
+ (for-each
+ (lambda (file)
+ (let* ((fullname (conc "logs/" file)))
+ (if (directory? fullname)
+ (debug:print-error 0 *default-log-port* fullname " in logs directory is a directory! Cannot rotate it, it is best to not put subdirectories in the logs dir.")
+ (handle-exceptions
+ exn
+ (debug:print-error 0 *default-log-port* "failed to remove " fullname)
+ (delete-file* fullname)))))
+ files)
+ (debug:print-info 0 *default-log-port* "Deleted " (length files) " files from logs, keeping " max-allowed " files."))))))
+
;; 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:api-changed?)
(let* ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config"))
- (dbfile (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.db"))
+ (dbfile (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.db"))
(read-only (not (file-write-access? dbfile)))
(dbstruct (db:setup #t)))
(debug:print 0 *default-log-port*
"WARNING: Version mismatch!\n"
" expected: " (common:version-signature) "\n"
@@ -841,11 +889,11 @@
*db-cache-path*
(if *toppath* ;; common:get-create-writeable-dir
(handle-exceptions
exn
(begin
- (debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir)
+ (debug:print-error 0 *default-log-port* "Couldn't create path to " *db-cache-path*)
(exit 1))
(let ((dbpath (common:get-create-writeable-dir
(list (conc "/tmp/" (current-user-name)
"/megatest_localdb/"
(common:get-testsuite-name) "/"
@@ -1169,21 +1217,27 @@
;; (tags-testpatt (if tagexpr (string-join (runs:get-tests-matching-tags tagexpr) ",") #f))
(testpatt-key (or (args:get-arg "-modepatt") (args:get-arg "--modepatt") "TESTPATT"))
(args-testpatt (or (args:get-arg "-testpatt") (args:get-arg "-runtests") "%"))
(rtestpatt (if rconf (runconfigs-get rconf testpatt-key) #f)))
(cond
- ((args:get-arg "--modepatt") ;; modepatt is a forced setting, when set it MUST refer to an existing PATT in the runconfig
+ ((or (args:get-arg "--modepatt") (args:get-arg "-modepatt")) ;; modepatt is a forced setting, when set it MUST refer to an existing PATT in the runconfig
(if rconf
- (runconfigs-get rconf testpatt-key)
- #f)) ;; We do NOT fall back to "%"
+ (let* ((patts-from-mode-patt (runconfigs-get rconf testpatt-key)))
+ (debug:print-info 0 *default-log-port* "modepatt defined is: "testpatt-key" runconfigs values for " testpatt-key " " patts-from-mode-patt)
+ patts-from-mode-patt)
+ (begin
+ (debug:print-info 0 *default-log-port* " modepatt defined is: "testpatt-key" runconfigs values for " testpatt-key) ;; " " patts-from-mode-patt)
+ #f))) ;; We do NOT fall back to "%"
;; (tags-testpatt
;; (debug:print-info 0 *default-log-port* "-tagexpr "tagexpr" selects testpatt "tags-testpatt)
;; tags-testpatt)
((and (equal? args-testpatt "%") rtestpatt)
(debug:print-info 0 *default-log-port* "testpatt defined in "testpatt-key" from runconfigs: " rtestpatt)
rtestpatt)
- (else args-testpatt))))
+ (else
+ (debug:print-info 0 *default-log-port* "using testpatt " args-testpatt " rtestpatt:" rtestpatt)
+ args-testpatt))))
(define (common:false-on-exception thunk #!key (message #f))
(handle-exceptions exn
@@ -1978,15 +2032,15 @@
(get-unix-df path)))
(define (get-free-inodes path)
(if (configf:lookup *configdat* "setup" "free-inodes-script")
(with-input-from-pipe
- (conc (configf:lookup *configdat* "setup" "free-inodes-script") " " path)
- (lambda ()
- (let ((res (read-line)))
- (if (string? res)
- (string->number res)))))
+ (conc (configf:lookup *configdat* "setup" "free-inodes-script") " " path)
+ (lambda ()
+ (let ((res (read-line)))
+ (if (string? res)
+ (string->number res)))))
(get-unix-inodes path)))
(define (get-unix-df path)
(let* ((df-results (process:cmd-run->list (conc "df " path)))
(space-rx (regexp "([0-9]+)\\s+([0-9]+)%"))
@@ -2002,11 +2056,11 @@
freespc))
(define (get-unix-inodes path)
(let* ((df-results (process:cmd-run->list (conc "df -i " path)))
(space-rx (regexp "([0-9]+)\\s+([0-9]+)%"))
- (freenodes #f))
+ (freenodes 0)) ;; 0 is a better failsafe than #f here.
;; (write df-results)
(for-each (lambda (l)
(let ((match (string-search space-rx l)))
(if match
(let ((newval (string->number (cadr match))))
@@ -2877,12 +2931,10 @@
(queue-push cmddat) ;; put request into the queue
(nn-send soc "queued")) ;; reply with "queued"
(print "ERROR: ["(common:human-time)"] BAD request " dat))
(loop (nn-recv soc)))))
(nn-close soc)))
-
-
;;======================================================================
;; D A S H B O A R D U S E R V I E W S
;;======================================================================
ADDED commonmod.scm
Index: commonmod.scm
==================================================================
--- /dev/null
+++ commonmod.scm
@@ -0,0 +1,36 @@
+;;======================================================================
+;; Copyright 2017, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+
+;;======================================================================
+
+(declare (unit commonmod))
+
+(module commonmod
+ *
+
+(import scheme chicken data-structures extras)
+(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18)
+
+;; (define (debug:print . params) #f)
+;; (define (debug:print-info . params) #f)
+;;
+;; (define (set-functions dbgp dbgpinfo)
+;; (set! debug:print dbgp)
+;; (set! debug:print-info dbgpinfo))
+
+)
Index: configf.scm
==================================================================
--- configf.scm
+++ configf.scm
@@ -121,11 +121,11 @@
" extra)))"))
((get g)
(let* ((parts (string-split cmd))
(sect (car parts))
(var (cadr parts)))
- (conc "(lambda (ht)(config-lookup ht \"" sect "\" \"" var "\"))")))
+ (conc "(lambda (ht)(configf:lookup ht \"" sect "\" \"" var "\"))")))
((runconfigs-get rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
;; ((rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
(else "(lambda (ht)(print \"ERROR\") \"ERROR\")"))))
;; (print "fullcmd=" fullcmd)
(handle-exceptions
@@ -463,11 +463,11 @@
;; if a continued line
(configf:cont-ln-rx ( x whsp val )
(let ((alist (hash-table-ref/default res curr-section-name '())))
(if var-flag ;; if set to a string then we have a continued var
(let ((newval (conc
- (config-lookup res curr-section-name var-flag) "\n"
+ (configf:lookup res curr-section-name var-flag) "\n"
;; trim lead from the incoming whsp to support some indenting.
(if lead
(string-substitute (regexp lead) "" whsp)
"")
val)))
@@ -498,11 +498,11 @@
(let ((configdat (if configfile
(read-config configfile #f #t environ-patt: environ-patt post-section-procs: (list (cons "^fields$" set-fields)) #f))))
(if toppath (change-directory curr-dir))
(list configdat toppath configfile fname))))
-(define (config-lookup cfgdat section var)
+(define (configf:lookup cfgdat section var)
(if (hash-table? cfgdat)
(let ((sectdat (hash-table-ref/default cfgdat section '())))
(if (null? sectdat)
#f
(let ((match (assoc var sectdat)))
@@ -519,11 +519,11 @@
;; (configf:var-is? cfgdat "foo" "var" "yes") => #t
;;
(define (configf:var-is? cfgdat section var expected-val)
(equal? (configf:lookup cfgdat section var) expected-val))
-(define configf:lookup config-lookup)
+(define config-lookup configf:lookup)
(define configf:read-file read-config)
;; safely look up a value that is expected to be a number, return
;; a default (#f unless provided)
;;
@@ -634,11 +634,11 @@
(sechash (make-hash-table)) ;; current section hash, init with hash for "default" section
(new #f) ;; put the line to be used in new, if it is to be deleted the set new to #f
(secname #f))
;; step 2: Flatten multiline entries
- (if (not (null? fdat))(set! fdat (configf:compress-multi-line fdat)))
+ (if (not (null? fdat))(set! fdat (configf:compress-multi-lines fdat)))
;; step 3: Modify values per contents of "indat" and remove absent values
(if (not (null? fdat))
(let loop ((hed (car fdat))
(tal (cadr fdat))
@@ -649,19 +649,19 @@
(configf:comment-rx _ (set! res (append res (list hed)))) ;; (loop (read-line inp) curr-section-name #f #f))
(configf:blank-l-rx _ (set! res (append res (list hed)))) ;; (loop (read-line inp) curr-section-name #f #f))
(configf:section-rx ( x section-name ) (let ((section-hash (hash-table-ref/default refdat section-name #f)))
(if (not section-hash)
(let ((newhash (make-hash-table)))
- (hash-table-set! refhash section-name newhash)
+ (hash-table-set! refdat section-name newhash) ;; was refhash - not sure that refdat is correct here
(set! sechash newhash))
(set! sechash section-hash))
(set! new hed) ;; will append this at the bottom of the loop
(set! secname section-name)
))
;; No need to process key cmd, let it fall though to key val
(configf:key-val-pr ( x key val )
- (let ((newval (config-lookup indat sec key)))
+ (let ((newval (configf:lookup indat secname key))) ;; was sec, bug or correct?
;; can handle newval == #f here => that means key is removed
(cond
((equal? newval val)
(set! res (append res (list hed))))
((not newval) ;; key has been removed
@@ -683,18 +683,18 @@
(lambda (section)
(let ((sdat '()) ;; append needed bits here
(svars (configf:section-vars indat section)))
(for-each
(lambda (var)
- (let ((val (config-lookup refdat section var)))
+ (let ((val (configf:lookup refdat section var)))
(if (not val) ;; this one is new
(begin
(if (null? sdat)(set! sdat (list (conc "[" section "]"))))
(set! sdat (append sdat (list (conc var " " val))))))))
svars)
(set! fdat (append fdat sdat))))
- (delete-duplicates (append require-sections (hash-table-keys indat))))
+ (delete-duplicates (append required-sections (hash-table-keys indat))))
;; step 5: Write out new file
(with-output-to-file fname
(lambda ()
(for-each
Index: dashboard-tests.scm
==================================================================
--- dashboard-tests.scm
+++ dashboard-tests.scm
@@ -49,10 +49,16 @@
;; C O M M O N
;;======================================================================
(define *dashboard-comment-share-slot* #f)
+(define (message-window msg)
+ (iup:show
+ (iup:dialog
+ (iup:vbox
+ (iup:label msg #:margin "40x40")))))
+
(define (dtests:get-pre-command #!key (default-override #f))
(let* ((orig-pre-command "export CMD='")
(viewscreen-pre-command "viewscreen ")
(use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen"))
(default-pre-command (if use-viewscreen viewscreen-pre-command orig-pre-command))
@@ -628,11 +634,11 @@
#:expand "HORIZONTAL"
#:font "Courier New, -10"
#:action (lambda (obj cnum val)
;; (print "cnum=" cnum)
(if (eq? cnum 13)
- (command-prox obj)))
+ (command-proc obj)))
))
(command-launch-button (iup:button "Execute!" #:action (lambda (x)
(command-proc command-text-box))))
;; (lambda (x)
;; (let* ((cmd (iup:attribute command-text-box "VALUE"))
@@ -823,6 +829,112 @@
;; Now start keeping the gui updated from the db
(refreshdat) ;; update from the db here
;(thread-suspend! other-thread)
(if *exit-started*
(set! *exit-started* 'ok))))))))))
+
+(define (colors-similar? color1 color2)
+ (let* ((c1 (map string->number (string-split color1)))
+ (c2 (map string->number (string-split color2)))
+ (delta (map (lambda (a b)(abs (- a b))) c1 c2)))
+ (null? (filter (lambda (x)(> x 3)) delta))))
+
+;; Display the tests as rows of boxes on the test/task pane
+;;
+(define (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames test-records)
+ (canvas-clear! cnv)
+ (canvas-font-set! cnv "Helvetica, -10")
+ (let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv))
+ ((originx originy) (canvas-origin cnv)))
+ ;; (print "originx: " originx " originy: " originy)
+ ;; (canvas-origin-set! cnv 0 (- (/ sizey 2)))
+ (if (hash-table-ref/default tests-draw-state 'first-time #t)
+ (begin
+ (hash-table-set! tests-draw-state 'first-time #f)
+ (hash-table-set! tests-draw-state 'scalef 1)
+ (hash-table-set! tests-draw-state 'tests-info (make-hash-table))
+ (hash-table-set! tests-draw-state 'selected-tests (make-hash-table))
+ ;; set these
+ (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records))
+ (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records))
+ ))
+
+(define (dboard:tabdat-test-patts-use vec)
+ (let ((val (dboard:tabdat-test-patts vec)))(if val val ""))) ;;RADT => What is the if for?
+
+;; additional setters for dboard:data
+(define (dboard:tabdat-test-patts-set!-use vec val)
+ (dboard:tabdat-test-patts-set! vec (if (equal? val "") #f val)))
+
+;; Extract the various bits of data from tabdat and create the command line equivalent that will be displayed
+;;
+(define (dashboard:update-run-command tabdat)
+ (let* ((cmd-tb (dboard:tabdat-command-tb tabdat))
+ (cmd (dboard:tabdat-command tabdat))
+ (test-patt (let ((tp (dboard:tabdat-test-patts tabdat)))
+ (if (or (not tp)
+ (equal? tp ""))
+ "%"
+ tp)))
+ (states (dboard:tabdat-states tabdat))
+ (statuses (dboard:tabdat-statuses tabdat))
+ (target (let ((targ-list (dboard:tabdat-target tabdat)))
+ (if targ-list (string-intersperse targ-list "/") "no-target-selected")))
+ (run-name (dboard:tabdat-run-name tabdat))
+ (states-str (if (or (not states)
+ (null? states))
+ ""
+ (conc " -state " (string-intersperse states ","))))
+ (statuses-str (if (or (not statuses)
+ (null? statuses))
+ ""
+ (conc " -status " (string-intersperse statuses ","))))
+ (full-cmd "megatest"))
+ (case (string->symbol cmd)
+ ((run)
+ (set! full-cmd (conc full-cmd
+ " -run"
+ " -testpatt "
+ test-patt
+ " -target "
+ target
+ " -runname "
+ run-name
+ " -clean-cache"
+ )))
+ ((remove-runs)
+ (set! full-cmd (conc full-cmd
+ " -remove-runs -runname "
+ run-name
+ " -target "
+ target
+ " -testpatt "
+ test-patt
+ states-str
+ statuses-str
+ )))
+ (else (set! full-cmd " no valid command ")))
+ (iup:attribute-set! cmd-tb "VALUE" full-cmd)))
+
+(define (iuplistbox-fill-list lb items #!key (selected-item #f))
+ (let ((i 1))
+ (for-each (lambda (item)
+ (iup:attribute-set! lb (number->string i) item)
+ (if selected-item
+ (if (equal? selected-item item)
+ (iup:attribute-set! lb "VALUE" i))) ;; (number->string i))))
+ (set! i (+ i 1)))
+ items)
+ ;; (iup:attribute-set! lb "VALUE" (if selected-item selected-item ""))
+ i))
+
+;; if tab-num passed in then use it, otherwise look in commondat at curr-tab-num
+;; adds the updater passed in the updaters list at that hashkey
+;;
+(define (dboard:commondat-add-updater commondat updater #!key (tab-num #f))
+ (let* ((tnum (or tab-num
+ (dboard:commondat-curr-tab-num commondat)))
+ (curr-updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '())))
+ (hash-table-set! (dboard:commondat-updaters commondat)
+ tnum
+ (cons updater curr-updaters))))
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -1,6 +1,6 @@
-;======================================================================
+;;======================================================================
;; Copyright 2006-2016, Matthew Welland.
;;
;; This file is part of Megatest.
;;
;; Megatest is free software: you can redistribute it and/or modify
@@ -226,11 +226,11 @@
(readyfname (conc parent-dir "/.ready-" raw-fname))
(readyexists (common:file-exists? readyfname)))
(if (not readyexists)
(common:simple-file-lock-and-wait lockfname))
(let ((db (sqlite3:open-database fname)))
- (sqlite3:set-busy-handler! db (make-busy-timeout 136000))
+ (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
(sqlite3:execute db "PRAGMA synchronous = 0;")
(if (and (configf:lookup *configdat* "setup" "tmp_mode") (string-match "^/tmp/.*" fname))
(begin
;;(print "DEBUG: Setting tmp_mode for " fname)
(sqlite3:execute db (configf:lookup *configdat* "setup" "tmp_mode"))
@@ -267,11 +267,13 @@
(condition-case
(begin
(debug:print 2 *default-log-port* "WARNING: opening db in non-writable dir " fname)
(let ((db (sqlite3:open-database fname)))
- ;; (mutex-unlock! *db-open-mutex*)
+ (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
+ (sqlite3:execute db "PRAGMA synchronous = 0;")
+ ;; (mutex-unlock! *db-open-mutex*)
db))
(exn (io-error) (debug:print 0 *default-log-port* "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again."))
(exn (corrupt) (debug:print 0 *default-log-port* "ERROR: database " fname " is corrupt. Repair it to proceed."))
(exn (busy) (debug:print 0 *default-log-port* "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back."))
(exn (permission)(debug:print 0 *default-log-port* "ERROR: database " fname " has some permissions problem."))
@@ -605,10 +607,12 @@
"\"\n")
(exit) ;; we can not safely continue when a db was corrupted - even if fixed.
)
;; test read/write access to the database
(let ((db (sqlite3:open-database dbpath)))
+ (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
+ (sqlite3:execute db "PRAGMA synchronous = 0;")
(cond
((equal? fname "megatest.db")
(sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';"))
((equal? fname "main.db")
(sqlite3:execute db "DELETE FROM runs WHERE state='deleted';"))
@@ -617,11 +621,11 @@
((equal? fname "monitor.db")
(sqlite3:execute "DELETE FROM servers WHERE state LIKE 'defunct%';"))
(else
(sqlite3:execute db "vacuum;")))
- (finalize! db)
+ (sqlite3:finalize! db)
#t))))))
;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) )
;; db's are dbdat's
;;
@@ -1109,11 +1113,11 @@
(debug:print-info 0 *default-log-port* "Sync of " res " records from newdb to olddb completed in " sync-time " seconds pid="(current-process-id))
(debug:print-info 0 *default-log-port* "No sync needed, last updated " (- start-time last-update) " seconds ago")))
res))
;; keeping it around for debugging purposes only
-(define (open-run-close-no-exception-handling proc idb . params)
+#;(define (open-run-close-no-exception-handling proc idb . params)
(debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params)
(print "I don't work anymore. open-run-close-no-exception-handling needs fixing or removing...")
(exit)
(if (or *db-write-access*
(not #t)) ;; was: (member proc * db:all-write-procs *)))
@@ -1128,11 +1132,11 @@
(if (not idb)(sqlite3:finalize! dbstruct))
(debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling END" )
res)
#f))
-(define (open-run-close-exception-handling proc idb . params)
+#;(define (open-run-close-exception-handling proc idb . params)
(handle-exceptions
exn
(let ((sleep-time (random 30))
(err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
(case err-status
@@ -1148,11 +1152,11 @@
(debug:print-info 0 *default-log-port* "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up")))
(apply open-run-close-exception-handling proc idb params))
(apply open-run-close-no-exception-handling proc idb params)))
;; (define open-run-close
-(define open-run-close open-run-close-exception-handling)
+#;(define open-run-close open-run-close-exception-handling)
;; open-run-close-no-exception-handling
;; open-run-close-exception-handling)
;;)
(define (db:initialize-main-db dbdat)
@@ -1461,11 +1465,11 @@
db
"SELECT id FROM archive_blocks WHERE archive_disk_id=? AND disk_path=?;"
bdisk-id archive-path)
(if res ;; record exists, update du if applicable and return res
(begin
- (if du (sqlite3:exectute db "UPDATE archive_blocks SET last_du=?,last_du_time=(strftime('%s','now'))
+ (if du (sqlite3:execute db "UPDATE archive_blocks SET last_du=?,last_du_time=(strftime('%s','now'))
WHERE archive_disk_id=? AND disk_path=?;"
bdisk-id archive-path du))
res)
(begin
(sqlite3:execute db "INSERT OR REPLACE INTO archive_blocks (archive_disk_id,disk_path,last_du)
@@ -1518,11 +1522,11 @@
(define (open-logging-db)
(let* ((dbpath (conc (if *toppath* (conc *toppath* "/") "") "logging.db")) ;; fname)
(dbexists (common:file-exists? dbpath))
(db (sqlite3:open-database dbpath))
- (handler (make-busy-timeout (if (args:get-arg "-override-timeout")
+ (handler (sqlite3:make-busy-timeout (if (args:get-arg "-override-timeout")
(string->number (args:get-arg "-override-timeout"))
136000)))) ;; 136000)))
(sqlite3:set-busy-handler! db handler)
(if (not dbexists)
(begin
@@ -1934,11 +1938,11 @@
(define (db:open-no-sync-db)
(let* ((dbpath (db:dbfile-path))
(dbname (conc dbpath "/no-sync.db"))
(db-exists (common:file-exists? dbname))
(db (sqlite3:open-database dbname)))
- (sqlite3:set-busy-handler! db (make-busy-timeout 136000))
+ (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
(if (not db-exists)
(begin
(sqlite3:execute db "PRAGMA synchronous = 0;")
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS no_sync_metadat (var TEXT,val TEXT, CONSTRAINT no_sync_metadat_constraint UNIQUE (var));")
(sqlite3:execute db "PRAGMA journal_mode=WAL;")))
@@ -4109,17 +4113,18 @@
;;
(define (db:get-state-status-summary dbstruct run-id testname)
(let ((res '()))
(db:with-db
dbstruct #f #f
- (sqlite3:for-each-row
- (lambda (state status count)
- (set! res (cons (vector state status count) res)))
- db
- "SELECT state,status,count(state) FROM tests WHERE run_id=? AND testname=? AND item_path='' GROUP BY state,status;"
- run-id testname)
- res)))
+ (lambda (db)
+ (sqlite3:for-each-row
+ (lambda (state status count)
+ (set! res (cons (vector state status count) res)))
+ db
+ "SELECT state,status,count(state) FROM tests WHERE run_id=? AND testname=? AND item_path='' GROUP BY state,status;"
+ run-id testname)
+ res))))
(define (db:get-latest-host-load dbstruct raw-hostname)
(let* ((hostname (string-substitute "\\..*$" "" raw-hostname))
(res (cons -1 0)))
(db:with-db
@@ -4569,10 +4574,11 @@
;; (if (not ever-seen)(set! result (cons waitontest-name result)))))
((not ever-seen)
(set! result (append (if (null? waiton-tests)(list waitontest-name) waiton-tests) result))))))
waitons)
(delete-duplicates result)))))
+
;;======================================================================
;; To sync individual run
;;======================================================================
(define (db:get-run-record-ids dbstruct target run keynames test-patt)
(let ((backcons (lambda (lst item)(cons item lst))))
@@ -4587,15 +4593,15 @@
" AND "))
(run-qry (conc "SELECT id FROM runs WHERE " keystr " and runname='" run"'"))
(test-qry (conc "SELECT id FROM tests WHERE run_id in (" run-qry ") and testname like '" test-patt "'")))
(print run-qry)
(print test-qry)
- `((runs . ,(fold-row backcons '() db run-qry))
- (tests . ,(fold-row backcons '() db test-qry))
- (test_steps . ,(fold-row backcons '() db (conc "SELECT id FROM test_steps WHERE test_id in (" test-qry ")")))
- (test_data . ,(fold-row backcons '() db (conc "SELECT id FROM test_data WHERE test_id in (" test-qry ")" )))
- ))))))
+ `((runs . ,(sqlite3:fold-row backcons '() db run-qry))
+ (tests . ,(sqlite3:fold-row backcons '() db test-qry))
+ (test_steps . ,(sqlite3:fold-row backcons '() db (conc "SELECT id FROM test_steps WHERE test_id in (" test-qry ")")))
+ (test_data . ,(sqlite3:fold-row backcons '() db (conc "SELECT id FROM test_data WHERE test_id in (" test-qry ")" )))
+ ))))))
;;======================================================================
;; Just for sync, procedures to make sync easy
;;======================================================================
@@ -4606,16 +4612,16 @@
;; no transaction, allow the db to be accessed between the big queries
(let ((backcons (lambda (lst item)(cons item lst))))
(db:with-db
dbstruct #f #f
(lambda (db)
- `((runs . ,(fold-row backcons '() db "SELECT id FROM runs WHERE last_update>=?" since-time))
- (tests . ,(fold-row backcons '() db "SELECT id FROM tests WHERE last_update>=?" since-time))
- (test_steps . ,(fold-row backcons '() db "SELECT id FROM test_steps WHERE last_update>=?" since-time))
- (test_data . ,(fold-row backcons '() db "SELECT id FROM test_data WHERE last_update>=?" since-time))
+ `((runs . ,(sqlite3:fold-row backcons '() db "SELECT id FROM runs WHERE last_update>=?" since-time))
+ (tests . ,(sqlite3:fold-row backcons '() db "SELECT id FROM tests WHERE last_update>=?" since-time))
+ (test_steps . ,(sqlite3:fold-row backcons '() db "SELECT id FROM test_steps WHERE last_update>=?" since-time))
+ (test_data . ,(sqlite3:fold-row backcons '() db "SELECT id FROM test_data WHERE last_update>=?" since-time))
;; (test_meta . ,(fold-row backcons '() db "SELECT id FROM test_meta WHERE last_update>?" since-time))
- (run_stats . ,(fold-row backcons '() db "SELECT id FROM run_stats WHERE last_update>=?" since-time))
+ (run_stats . ,(sqlite3:fold-row backcons '() db "SELECT id FROM run_stats WHERE last_update>=?" since-time))
)))))
;;======================================================================
;; Extract ods file from the db
;;======================================================================
Index: dcommon.scm
==================================================================
--- dcommon.scm
+++ dcommon.scm
@@ -43,10 +43,75 @@
;;======================================================================
;; C O M M O N D A T A S T R U C T U R E
;;======================================================================
;;
+;; data common to all tabs goes here
+;;
+(defstruct dboard:commondat
+ ((curr-tab-num 0) : number)
+ please-update
+ tabdats
+ update-mutex
+ updaters
+ updating
+ uidat ;; needs to move to tabdat at some time
+ hide-not-hide-tabs
+ )
+
+(define (dboard:commondat-make)
+ (make-dboard:commondat
+ curr-tab-num: 0
+ tabdats: (make-hash-table)
+ please-update: #t
+ update-mutex: (make-mutex)
+ updaters: (make-hash-table)
+ updating: #f
+ hide-not-hide-tabs: #f
+ ))
+
+;; RADT => Matrix defstruct addition
+(defstruct dboard:graph-dat
+ ((id #f) : string)
+ ((color #f) : vector)
+ ((flag #t) : boolean)
+ ((cell #f) : number)
+ )
+
+;; data for runs, tests etc. was used in run summary?
+;;
+(defstruct dboard:runsdat
+ ;; new system
+ runs-index ;; target/runname => colnum
+ tests-index ;; testname/itempath => rownum
+ matrix-dat ;; vector of vectors rows/cols
+ )
+
+(define (dboard:runsdat-make-init)
+ (make-dboard:runsdat
+ runs-index: (make-hash-table)
+ tests-index: (make-hash-table)
+ matrix-dat: (make-sparse-array)))
+
+;; used to keep the rundata from rmt:get-tests-for-run
+;; in sync.
+;;
+(defstruct dboard:rundat
+ run
+ tests-drawn ;; list of id's already drawn on screen
+ tests-notdrawn ;; list of id's NOT already drawn
+ rowsused ;; hash of lists covering what areas used - replace with quadtree
+ hierdat ;; put hierarchial sorted list here
+ tests ;; hash of id => testdat
+ ((tests-by-name (make-hash-table)) : hash-table) ;; hash of testfullname => testdat
+ key-vals
+ ((last-update 0) : number) ;; last query to db got records from before last-update
+ ((last-db-time 0) : number) ;; last timestamp on megatest.db
+ ((data-changed #f) : boolean)
+ ((run-data-offset 0) : number) ;; get only 100 items per call, set back to zero when received less than 100 items
+ (db-path #f))
+
;;======================================================================
;; D O T F I L E
;;======================================================================
@@ -81,11 +146,11 @@
;;
(define (dcommon:modifiy-if-different mtrx cell-name new-val prev-changed)
(let ((curr-val (iup:attribute mtrx cell-name)))
(if (not (equal? curr-val new-val))
(begin
- (iup:attribute-set! mtrx cell-name col-name)
+ (iup:attribute-set! mtrx cell-name new-val) ;; was col-name
#t) ;; need a re-draw
prev-changed)))
;; TO-DO
@@ -270,11 +335,11 @@
;; (if changed (iup:attribute-set! (dboard:tabdat-runs-matrix data) "REDRAW" "ALL"))
;; ;; (debug:print 2 *default-log-port* "run-changes: " run-changes)
;; ;; (debug:print 2 *default-log-port* "test-changes: " test-changes)
;; (list run-changes all-test-changes)))
-(define (dcommon:runsdat-get-col-num dat target runname force-set)
+#;(define (dcommon:runsdat-get-col-num dat target runname force-set)
(let* ((runs-index (dboard:runsdat-runs-index dat))
(col-name (conc target "/" runname))
(res (hash-table-ref/default runs-index col-name #f)))
(if res
res
@@ -281,11 +346,11 @@
(if force-set
(let ((max-col-num (+ 1 (common:max (cons-1 (hash-table-values runs-index))))))
(hash-table-set! runs-index col-name max-col-num)
max-col-num)))))
-(define (dcommon:runsdat-get-row-num dat testname itempath force-set)
+#;(define (dcommon:runsdat-get-row-num dat testname itempath force-set)
(let* ((tests-index (dboard:runsdat-runs-index dat))
(row-name (conc testname "/" itempath))
(res (hash-table-ref/default runs-index row-name #f)))
(if res
res
@@ -448,11 +513,11 @@
(debug:print 2 "ERROR: No test data found for test " test-id ", exiting")
(exit 1))
(let*
((rundir (if testdat
(db:test-get-rundir testdat)
- logfile))
+ (current-directory))) ;; logfile))
(testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ..."))
(xterm (lambda ()
(if (directory-exists? rundir)
(let* ((shell (if (get-environment-variable "SHELL")
(conc "-e " (get-environment-variable "SHELL"))
@@ -722,11 +787,11 @@
(iup:menu-item "Files" (iup:menu ;; Note that you can use either #:action or action: for options
(iup:menu-item "Open" action: (lambda (obj)
(let* ((area-name (iup:textbox #:expand "HORIZONTAL"))
(fd (iup:file-dialog #:dialogtype "DIR"))
(top (iup:show fd #:modal? "YES")))
- (iup:attribute-set! source-tb "VALUE"
+ (iup:attribute-set! area-name "VALUE" ;; was source-tb, no idea what is correct
(iup:attribute fd "VALUE"))
(iup:destroy! fd))))
;; (lambda (obj)
;; (iup:show (iup:file-dialog))
;; (print "File->open " obj)))
@@ -1330,6 +1395,63 @@
(define (dcommon:run-html-viewer lfilename)
(let ((htmlviewercmd (configf:lookup *configdat* "setup" "htmlviewercmd")))
(if htmlviewercmd
(system (conc "(" htmlviewercmd " " lfilename " ) &"))
(iup:send-url lfilename))))
+
+(define (dashboard:monitor-changed? commondat tabdat)
+ (let* ((run-update-time (current-seconds))
+ (monitor-db-path (dboard:tabdat-monitor-db-path tabdat))
+ (monitor-modtime (if (and monitor-db-path (common:file-exists? monitor-db-path))
+ (file-modification-time monitor-db-path)
+ -1)))
+ (if (and (eq? (dboard:commondat-curr-tab-num commondat) 0)
+ (or (> monitor-modtime *last-monitor-update-time*)
+ (> (- run-update-time *last-monitor-update-time*) 5))) ;; update every 1/2 minute just in case
+ (begin
+ (set! *last-monitor-update-time* run-update-time) ;; monitor-modtime)
+ #t)
+ #f)))
+
+;; DOES NOT WORK RELIABLY WITH /tmp WAL mode files. Timestamps only change when the db
+;; is closed (I think). If db dir starts with /tmp always return true
+;;
+(define (dashboard:database-changed? commondat tabdat #!key (context-key 'default))
+ (let* ((run-update-time (current-seconds))
+ (dbdir (dboard:tabdat-dbdir tabdat))
+ (modtime (dashboard:get-youngest-run-db-mod-time dbdir))
+ (recalc (dashboard:recalc modtime
+ (dboard:commondat-please-update commondat)
+ (dboard:get-last-db-update tabdat context-key))))
+ ;; (dboard:tabdat-last-db-update tabdat))))
+ (if recalc
+ (dboard:set-last-db-update! tabdat context-key run-update-time))
+ (dboard:commondat-please-update-set! commondat #f)
+ recalc))
+
+(define (dashboard:get-youngest-run-db-mod-time dbdir)
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 2 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn) " db-dir="dbdir)
+ (current-seconds)) ;; something went wrong - just print an error and return current-seconds
+ (common:max (map (lambda (filen)
+ (file-modification-time filen))
+ (glob (conc dbdir "/*.db*"))))))
+
+(define (dboard:get-last-db-update tabdat context)
+ (hash-table-ref/default (dboard:tabdat-last-db-update tabdat) context 0))
+
+(define (dboard:set-last-db-update! tabdat context newtime)
+ (hash-table-set! (dboard:tabdat-last-db-update tabdat) context newtime))
+
+;; point inside line
+;;
+(define-inline (dashboard:px-between px lx1 lx2)
+ (and (< lx1 px)(> lx2 px)))
+
+(define (dashboard:recalc modtime please-update-buttons last-db-update-time)
+ (or please-update-buttons
+ (and ;; (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) ;; can't use this - it needs to be tab specific
+ (> modtime (- last-db-update-time 3)) ;; add three seconds of margin
+ (> (current-seconds)(+ last-db-update-time 1)))))
Index: docs/manual/megatest_manual.html
==================================================================
--- docs/manual/megatest_manual.html
+++ docs/manual/megatest_manual.html
@@ -1178,11 +1178,11 @@
dependencies, waiton, itemmatch, itemwait test requirements
-miscellaneous; mode toplevel, runtimelim, skip on file or on running, waiver propagation
+miscellaneous; mode toplevel, runtimelim, skip on file, no file, script or on running, waiver propagation
@@ -2232,10 +2232,26 @@
[skip]
fileexists /path/to/a/file # skip if /path/to/a/file exists
+
+
+
Skip if a File Does not Exist
+
+
+
[skip]
+filenotexists /path/to/a/file # skip if /path/to/a/file does not exist
+
+
+
+
Skip if a script completes with 0 status
+
+
+
[skip]
+script /path/to/a/script # skip if /path/to/a/script completes with 0 status
+
Skip if test ran more recently than specified time
Skip if this test has been run in the past fifteen minutes and 15 seconds.
@@ -2974,10 +2990,10 @@