Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -26,17 +26,14 @@ SHELL=/bin/bash PREFIX=$(PWD) CSCOPTS= INSTALL=install -SRCFILES = common.scm launch.scm runconfig.scm \ - server.scm configf.scm keys.scm \ - process.scm runs.scm genexample.scm \ - tdb.scm mt.scm \ +SRCFILES = runconfig.scm \ + server.scm keys.scm \ ezsteps.scm api.scm \ - subrun.scm archive.scm env.scm \ - diff-report.scm + archive.scm env.scm # cgisetup/models/pgdb.scm # module source files MSRCFILES = dbfile.scm debugprint.scm mtargs.scm commonmod.scm dbmod.scm \ @@ -43,11 +40,12 @@ tcp-transportmod.scm rmtmod.scm portlogger.scm apimod.scm \ configfmod.scm processmod.scm servermod.scm megatestmod.scm \ stml2.scm fsmod.scm cpumod.scm mtmod.scm odsmod.scm \ pkts.scm testsmod.scm pgdb.scm cookie.scm launchmod.scm \ subrunmod.scm runsmod.scm tasksmod.scm archivemod.scm \ - ezstepsmod.scm + ezstepsmod.scm mtbody.scm envmod.scm genexample.scm mutils.scm \ + diff-report.scm tdb.scm vgmod.scm dcommon.scm transport-mode.scm : transport-mode.scm.template cp transport-mode.scm.template transport-mode.scm dashboard-transport-mode.scm : dashboard-transport-mode.scm.template @@ -56,10 +54,12 @@ mtest : transport-mode.scm dboard : dashboard-transport-mode.scm # dbmod.import.o is just a hack here +mofiles/mtbody.o : mofiles/launchmod.o readline-fix.scm mofiles/envmod.o mofiles/genexample.o mofiles/mutils.o mofiles/diff-report.o mofiles/tdb.o +mofiles/dcommon.o : mofiles/vgmod.o process.o : mofiles/processmod.o mofiles/configfmod.o : mofiles/processmod.o mofiles/processmod.o : mofiles/commonmod.o mofiles/servermod.o : mofiles/commonmod.o mofiles/rmtmod.o : mofiles/mtmod.o mofiles/apimod.o @@ -66,10 +66,11 @@ mofiles/dbmod.o : mofiles/mtmod.o # mofiles/mtmod.o : mofiles/tcp-transportmod.o mofiles/megatestmod.o : mofiles/pkts.o mofiles/servermod.o mofiles/fsmod.o # mofiles/mtmod.o : mofiles/testsmod.o mofiles/subrunmod.o : mofiles/tasksmod.o +mofiles/dcommon.o : mofiles/tasksmod.o mofiles/launchmod.o : mofiles/subrunmod.o mofiles/runsmod.o mofiles/launchmod.o : mofiles/ezstepsmod.o mofiles/runsmod.o : mofiles/archivemod.o mofiles/testsmod.o : mofiles/dbmod.o @@ -77,11 +78,10 @@ mofiles/debugprint.o mofiles/commonmod.o mofiles/configfmod.o mofiles/apimod.o : mofiles/commonmod.o mofiles/tcp-transportmod.o mofiles/configfmod.o mofiles/megatestmod.o mofiles/dbmod.o : mofiles/dbfile.o mofiles/api.o : mofiles/apimod.o mofiles/commonmod.o : mofiles/debugprint.o mofiles/stml2.o -configf.o : commonmod.import.o mofiles/dbfile.o : mofiles/debugprint.o mofiles/rmtmod.o mofiles/dbmod.o : mofiles/dbfile.o mofiles/commonmod.o mofiles/debugprint.o db.o : mofiles/dbmod.o mofiles/dbfile.o mofiles/debugprint.o : mofiles/mtargs.o mofiles/tcp-transportmod.o : mofiles/portlogger.o @@ -91,13 +91,11 @@ # ftail.scm rmtmod.scm commonmod.scm removed # MSRCFILES = ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm \ # mtargs.scm commonmod.scm dbmod.scm adjutant.scm ulex.scm \ # rmtmod.scm apimod.scm -GUISRCF = dashboard-context-menu.scm dashboard-tests.scm \ - dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm \ - vg.scm +GUISRCF = dashboard-guimonitor.scm OFILES = $(SRCFILES:%.scm=%.o) GOFILES = $(GUISRCF:%.scm=%.o) MOFILES = $(addprefix mofiles/,$(MSRCFILES:%.scm=%.o)) @@ -171,11 +169,10 @@ # runs.o \ # server.o \ # tasks.o \ # tdb.o \ # tests.o \ -# subrun.o \ # ezsteps.o # # # mofiles/rmtmod.o \ # # mofiles/commonmod.o \ # @@ -202,45 +199,43 @@ # Special dependencies for the includes $(MOFILE) $(MOIMPFILES) : megatest-fossil-hash.scm mofiles/commonmod.o : mofiles/debugprint.o megatest-fossil-hash.scm common.o : mofiles/commonmod.o -mofiles/configfmod.o : mofiles/commonmod.o +mofiles/configfmod.o : mofiles/commonmod.o configf-guts.scm # mofiles/dbmod.o : mofiles/configfmod.o # commonmod.o dashboard.o megatest.o tcmt.o apimod.o : megatest-fossil-hash.scm -tests.o db.o launch.o runs.o dashboard-tests.o \ -dashboard-context-menu.o dashboard-guimonitor.o dashboard-main.o \ +tests.o db.o launch.o \ +dashboard-guimonitor.o dashboard-main.o \ monitor.o dashboard.o archive.o megatest.o : db_records.scm megatest-fossil-hash.scm -tests.o runs.o dashboard.o dashboard-tests.o dashboard-context-menu.o dashboard-main.o : run_records.scm +tests.o dashboard.o dashboard-main.o : run_records.scm -db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm +db.o ezsteps.o keys.o launch.o megatest.o monitor.o tests.o : key_records.scm db.o api.o : mofiles/dbmod.o mofiles/dbfile.o mofiles/debugprint.o mofiles/commonmod.o dbmod.import.o tests.o tasks.o dashboard-tasks.o : task_records.scm -runs.o : test_records.scm - # mofiles-made : $(MOFILES) # make $(MOIMPFILES) # touch mofiles-made megatest.o : megatest-fossil-hash.scm megatest-version.scm $(MOFILES) $(MOIMPFILES) -common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm dcommon.scm ezsteps.scm index-tree.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tree.scm : common_records.scm megatest-version.scm +common.scm configf.scm dashboard-guimonitor.scm dashboard.scm dcommon.scm ezsteps.scm index-tree.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm server.scm tdb.scm : common_records.scm megatest-version.scm common_records.scm : altdb.scm mofiles/dbfile.o : mofiles/commonmod.o # mofiles/stml2.o : mofiles/cookie.o # configf.o : mofiles/commonmod.o -vg.o dashboard.o : vg_records.scm megatest-version.scm +dashboard.o : megatest-version.scm dcommon.o : run_records.scm mofiles/stml2.o : mofiles/cookie.o @@ -252,13 +247,10 @@ # mofiles/ulex.o : ulex/ulex.scm # mofiles/mutils.o : mutils/mutils.scm # mofiles/cookie.o : stml2/cookie.scm # mofiles/stml2.o : stml2/stml2.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 @@ -448,68 +440,10 @@ 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 -#====================================================================== - -# vg_records.scm : records.sh -# ./records.sh - -#====================================================================== -# Deploy section (not complete yet) -#====================================================================== - -$(DEPLOYHELPERS) : utils/mt_* - $(INSTALL) $< $@ - chmod a+X $@ - -deploytarg/apropos.so : Makefile - chicken-install -p deploytarg -deploy -keep-installed $(EGGS) - -deploy : deploytarg/mtest deploytarg/dboard $(DEPLOYHELPERS) deploytarg/nbfake deploytarg/remrun deploytarg/viewsceen deploytarg/nbfind deploytarg/apropos.so - -# puts deployed megatest in directory "megatest" -deploytarg/mtest : $(OFILES) megatest.o deploytarg/apropos.so - csc -deploy $(CSCOPTS) $(OFILES) megatest.scm -o deploytarg - mv deploytarg/deploytarg deploytarg/mtest - -deploytarg/dboard : $(OFILES) $(GOFILES) dashboard.scm deploytarg/apropos.so - csc -deploy $(OFILES) $(GOFILES) dashboard.scm -o deploytarg - mv deploytarg/deploytarg deploytarg/dboard - -datashare-testing/sd : datashare.scm $(OFILES) - csc $(CSCOPTS) datashare.scm $(OFILES) -o datashare-testing/sd - -datashare-testing/sdat: sharedat.scm $(OFILES) - csc $(CSCOPTS) sharedat.scm $(OFILES) -o datashare-testing/sdat - -sd : datashare-testing/sd - mkdir -p /tmp/$(USER)/datashare/disk1 /tmp/$(USER)/basepath - -xterm : sd - (export BASEPATH=/tmp/$(USER)/basepath ; export PATH="$(PWD)/datashare-testing:$(PATH)" ; xterm &) - -datashare-testing/spublish : spublish.scm $(OFILES) megatest-version.scm - csc $(CSCOPTS) spublish.scm margs.o process.o common.o -o datashare-testing/spublish - -datashare-testing/sretrieve : sretrieve.scm $(OFILES) megatest-version.scm - csc $(CSCOPTS) sretrieve.scm margs.o process.o common.o -o datashare-testing/sretrieve - - -datashare-testing/sauthorize : sauthorize.scm $(OFILES) megatest-version.scm - csc $(CSCOPTS) sauthorize.scm margs.o process.o common.o -o datashare-testing/sauthorize - -sauth-init: - mkdir -p datashare-testing - rm datashare-testing/sauthorize - rm datashare-testing/sretrieve - rm datashare-testing/spublish - -sauth : sauth-init datashare-testing/sauthorize datashare-testing/sretrieve datashare-testing/spublish readline-fix.scm : if [[ $(shell chicken-status | grep readline | awk '{print $4}' | cut -d. -f1) -gt 3 ]];then \ echo "(define *use-new-readline* #f)" > readline-fix.scm; \ else \ @@ -530,14 +464,10 @@ fi if csi -ne '(import postgresql)'&> /dev/null;then \ echo "(import postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\ fi -# portlogger-example : portlogger-example.scm api.o archive.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o genexample.o gutils.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o server.o synchash.o tasks.o tdb.o tests.o tree.o -# csc $(CSCOPTS) portlogger-example.scm api.o archive.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o genexample.o gutils.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o server.o sync-hash.o tasks.o tdb.o tests.o tree.o - -# IMPORTSTUBS = $(*import.scm:%.scm=%) unitdeps.dot : *mod.scm ./utils/plot-uses Makefile ./utils/plot-uses todot processmod.import,dbfile.import,dbmod.import,configfmod.import,mtmod.import,procesmod.import,commonmod.import,mtargs.import,mtargs,debugprint $$(ls *.scm|grep -v import) > unitdeps.dot # ./utils/plot-uses todot commonmod,portlogger,stml2,debugprint,mtargs apimod.scm commonmod.scm configfmod.scm dbmod.scm megatestmod.scm mtmod.scm processmod.scm rmtmod.scm servermod.scm tcp-transportmod.scm > uses.dot ; dot uses.dot -Tpdf -o uses.pdf Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -40,90 +40,5 @@ matchable s11n typed-records) -;; QUEUE METHOD - -(define (api:tcp-dispatch-request-make-handler-new dbstruct) ;; cmd run-id params) - (api:tcp-dispatch-request-make-handler-core dbstruct api:dispatch-request)) - - -;; indat is (cmd run-id params meta) -;; -;; WARNING: Do not print anything in the lambda of this function as it -;; reads/writes to current in/out port -;; -(define (api:tcp-dispatch-request-make-handler-old dbstruct) ;; cmd run-id params) - (assert *toppath* "FATAL: api:tcp-dispatch-request-make-handler called but *toppath* not set.") - (if (not *server-signature*) - (set! *server-signature* (tt:mk-signature *toppath*))) - (lambda (indat) - (api:register-thread (current-thread)) - (let* ((result - (let* ((numthreads (api:get-count-threads-alive)) - (delay-wait (if (> numthreads 10) - (- numthreads 10) - 0)) - (normal-proc (lambda (cmd run-id params) - (case cmd - ((ping) *server-signature*) - (else - (api:dispatch-request dbstruct cmd run-id params)))))) - (set! *api-process-request-count* numthreads) - (set! *db-last-access* (current-seconds)) -;; (if (not (eq? numthreads numthreads)) -;; (begin -;; (api:remove-dead-or-terminated) -;; (let ((threads-now (api:get-count-threads-alive))) -;; (debug:print 0 *default-log-port* "WARNING: numthreads="numthreads", numthreads="numthreads", remaining="threads-now) -;; (set! numthreads threads-now)))) - (match indat - ((cmd run-id params meta) - (let* ((start-t (current-milliseconds)) - (db-ok (let* ((dbfname (dbmod:run-id->dbfname run-id)) - (ok (equal? dbfname (dbr:dbstruct-dbfname dbstruct)))) - (case cmd - ((ping) #t) ;; we are fine - (else - (assert ok "FATAL: database file and run-id not aligned."))))) - (ttdat *server-info*) - (server-state (tt-state ttdat)) - (maxthreads 20) ;; make this a parameter? - (status (cond - ((and (> numthreads maxthreads) - (> (random 100) 70)) ;; allow a 30% probability to go through so we can figure out what is going wrong in main.db server. - 'busy) - ;; ((> numthreads 5) 'loaded) ;; this gets transmitted to the client which calls tt:backoff-incr to slow stuff down. - (else 'ok))) - (errmsg (case status - ((busy) (conc "Server overloaded, "numthreads" threads in flight")) - ((loaded) (conc "Server loaded, "numthreads" threads in flight")) - (else #f))) - (result (case status - ((busy) - (if (eq? cmd 'ping) - (normal-proc cmd run-id params) - ;; numthreads must be greater than 5 for busy - (* 0.1 (- numthreads maxthreads)) ;; was 15 - return a number for the remote to delay - )) ;; (- numthreads 29)) ;; call back in as many seconds - ((loaded) - (normal-proc cmd run-id params)) - (else - (normal-proc cmd run-id params)))) - (meta (case cmd - ((ping) `((sstate . ,server-state))) - (else `((wait . ,delay-wait))))) - (payload (list status errmsg result meta))) - ;; (cmd run-id params meta) - (db:add-stats cmd run-id params (- (current-milliseconds) start-t)) - payload)) - (else - (assert #f "FATAL: failed to deserialize indat "indat)))))) - ;; (set! *api-process-request-count* (- *api-process-request-count* 1)) - ;; (serialize payload) - - (api:unregister-thread (current-thread)) - result))) - -(define api:tcp-dispatch-request-make-handler api:tcp-dispatch-request-make-handler-new) ;; choose -old or -new - Index: apimod.scm ================================================================== --- apimod.scm +++ apimod.scm @@ -25,11 +25,20 @@ (declare (uses dbfile)) (declare (uses tcp-transportmod)) (declare (uses megatestmod)) (module apimod - * + ( + *server-signature* + api:tcp-dispatch-request-make-handler-core + api:register-thread + api:unregister-thread + api:get-count-threads-alive + api:print-db-stats + api:queue-processor + api:dispatch-request + ) (import scheme chicken data-structures extras) (import (prefix sqlite3 sqlite3:) posix matchable typed-records srfi-1 srfi-18 srfi-69 ) (import commonmod) (import debugprint) Index: archive.scm ================================================================== --- archive.scm +++ archive.scm @@ -19,11 +19,11 @@ ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') (declare (unit archive)) (declare (uses debugprint)) (declare (uses mtargs)) -(declare (uses common)) +;; (declare (uses common)) (declare (uses commonmod)) (declare (uses configfmod)) (declare (uses rmtmod)) (use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 Index: archivemod.scm ================================================================== --- archivemod.scm +++ archivemod.scm @@ -37,11 +37,19 @@ (declare (uses dbfile)) (use srfi-69) (module archivemod - * + ( + archive:get-archive-disks + archive:allocate-new-archive-block + archive:get-timestamp-dir + archive:megatest-db + archive:bup-get-data + archive:restore-db + + ) (import scheme) (cond-expand (chicken-4 @@ -121,11 +129,11 @@ srfi-69 typed-records z3 ) -(include "common_records.scm") +;; (include "common_records.scm") ;; (include "db_records.scm") ;;====================================================================== ;; ;;====================================================================== ADDED attic/codescanlib.scm Index: attic/codescanlib.scm ================================================================== --- /dev/null +++ attic/codescanlib.scm @@ -0,0 +1,144 @@ +;; Copyright 2006-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 . +;; + +;; gotta compile with csc, doesn't work with csi -s for whatever reason + +(use srfi-69) +(use matchable) +(use utils) +(use ports) +(use extras) +(use srfi-1) +(use posix) +(use srfi-12) + +;; turn scheme file to a list of sexps, sexps of interest will be in the form of (define ( ) ) +(define (load-scm-file scm-file) + ;;(print "load "scm-file) + (handle-exceptions + exn + '() + (with-input-from-string + (conc "(" + (with-input-from-file scm-file read-all) + ")" ) + read))) + +;; extract a list of procname, filename, args and body of procedures defined in filename, input from load-scm-file +;; -- be advised: +;; * this may be fooled by macros, since this code does not take them into account. +;; * this code does only checks for form (define ( ... ) ) +;; so it excludes from reckoning +;; - generated functions, as in things like foo-set! from defstructs, +;; - define-inline, ( +;; - define procname (lambda .. +;; - etc... +(define (get-toplevel-procs+file+args+body filename) + (let* ((scm-tree (load-scm-file filename)) + (procs + (filter identity + (map + (match-lambda + [('define ('uses args ...) body ...) #f] ;; filter out (define (uses ... + [('define ('unit args ...) body ...) #f] ;; filter out (define (unit ... + [('define ('prefix args ...) body ...) #f] ;; filter out (define (prefix ... + [('define (defname args ...) body ...) ;; match (define (procname ) ) + (if (atom? defname) ;; filter out things we dont understand (procname is a list, what??) + (list defname filename args body) + #f)] + [else #f] ) scm-tree)))) + procs)) + + +;; given a sexp, return a flat list of atoms in that sexp +(define (get-atoms-in-body body) + (cond + ((null? body) '()) + ((atom? body) (list body)) + (else + (apply append (map get-atoms-in-body body))))) + +;; given a file, return a list of procname, file, list of atoms in said procname +(define (get-procs+file+atoms file) + (let* ((toplevel-proc-items (get-toplevel-procs+file+args+body file)) + (res + (map + (lambda (item) + (let* ((proc (car item)) + (file (cadr item)) + (args (caddr item)) + (body (cadddr item)) + (atoms (append (get-atoms-in-body args) (get-atoms-in-body body)))) + (list proc file atoms))) + toplevel-proc-items))) + res)) + +;; uniquify a list of atoms +(define (unique-atoms lst) + (let loop ((lst (flatten lst)) (res '())) + (if (null? lst) + (reverse res) + (let ((c (car lst))) + (loop (cdr lst) (if (member c res) res (cons c res))))))) + +;; given a list of procname, filename, list of procs called from procname, cross reference and reverse +;; returning alist mapping procname to procname that calls said procname +(define (get-callers-alist all-procs+file+calls) + (let* ((all-procs (map car all-procs+file+calls)) + (caller-ht (make-hash-table))) + ;; let's cross reference with a hash table + (for-each (lambda (proc) (hash-table-set! caller-ht proc '())) all-procs) + (for-each (lambda (item) + (let* ((proc (car item)) + (file (cadr item)) + (calls (caddr item))) + (for-each (lambda (callee) + (hash-table-set! caller-ht callee + (cons proc + (hash-table-ref caller-ht callee)))) + calls))) + all-procs+file+calls) + (map (lambda (x) + (let ((k (car x)) + (r (unique-atoms (cdr x)))) + (cons k r))) + (hash-table->alist caller-ht)))) + +;; create a handy cross-reference of callees to callers in the form of an alist. +(define (get-xref all-scm-files) + (let* ((all-procs+file+atoms + (apply append (map get-procs+file+atoms all-scm-files))) + (all-procs (map car all-procs+file+atoms)) + (all-procs+file+calls ; proc calls things in calls list + (map (lambda (item) + (let* ((proc (car item)) + (file (cadr item)) + (atoms (caddr item)) + (calls + (filter identity + (map + (lambda (x) + (if (and ;; (not (equal? x proc)) ;; uncomment to prevent listing self + (member x all-procs)) + x + #f)) + atoms)))) + (list proc file calls))) + all-procs+file+atoms)) + (callers (get-callers-alist all-procs+file+calls))) + callers)) DELETED codescanlib.scm Index: codescanlib.scm ================================================================== --- codescanlib.scm +++ /dev/null @@ -1,144 +0,0 @@ -;; Copyright 2006-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 . -;; - -;; gotta compile with csc, doesn't work with csi -s for whatever reason - -(use srfi-69) -(use matchable) -(use utils) -(use ports) -(use extras) -(use srfi-1) -(use posix) -(use srfi-12) - -;; turn scheme file to a list of sexps, sexps of interest will be in the form of (define ( ) ) -(define (load-scm-file scm-file) - ;;(print "load "scm-file) - (handle-exceptions - exn - '() - (with-input-from-string - (conc "(" - (with-input-from-file scm-file read-all) - ")" ) - read))) - -;; extract a list of procname, filename, args and body of procedures defined in filename, input from load-scm-file -;; -- be advised: -;; * this may be fooled by macros, since this code does not take them into account. -;; * this code does only checks for form (define ( ... ) ) -;; so it excludes from reckoning -;; - generated functions, as in things like foo-set! from defstructs, -;; - define-inline, ( -;; - define procname (lambda .. -;; - etc... -(define (get-toplevel-procs+file+args+body filename) - (let* ((scm-tree (load-scm-file filename)) - (procs - (filter identity - (map - (match-lambda - [('define ('uses args ...) body ...) #f] ;; filter out (define (uses ... - [('define ('unit args ...) body ...) #f] ;; filter out (define (unit ... - [('define ('prefix args ...) body ...) #f] ;; filter out (define (prefix ... - [('define (defname args ...) body ...) ;; match (define (procname ) ) - (if (atom? defname) ;; filter out things we dont understand (procname is a list, what??) - (list defname filename args body) - #f)] - [else #f] ) scm-tree)))) - procs)) - - -;; given a sexp, return a flat list of atoms in that sexp -(define (get-atoms-in-body body) - (cond - ((null? body) '()) - ((atom? body) (list body)) - (else - (apply append (map get-atoms-in-body body))))) - -;; given a file, return a list of procname, file, list of atoms in said procname -(define (get-procs+file+atoms file) - (let* ((toplevel-proc-items (get-toplevel-procs+file+args+body file)) - (res - (map - (lambda (item) - (let* ((proc (car item)) - (file (cadr item)) - (args (caddr item)) - (body (cadddr item)) - (atoms (append (get-atoms-in-body args) (get-atoms-in-body body)))) - (list proc file atoms))) - toplevel-proc-items))) - res)) - -;; uniquify a list of atoms -(define (unique-atoms lst) - (let loop ((lst (flatten lst)) (res '())) - (if (null? lst) - (reverse res) - (let ((c (car lst))) - (loop (cdr lst) (if (member c res) res (cons c res))))))) - -;; given a list of procname, filename, list of procs called from procname, cross reference and reverse -;; returning alist mapping procname to procname that calls said procname -(define (get-callers-alist all-procs+file+calls) - (let* ((all-procs (map car all-procs+file+calls)) - (caller-ht (make-hash-table))) - ;; let's cross reference with a hash table - (for-each (lambda (proc) (hash-table-set! caller-ht proc '())) all-procs) - (for-each (lambda (item) - (let* ((proc (car item)) - (file (cadr item)) - (calls (caddr item))) - (for-each (lambda (callee) - (hash-table-set! caller-ht callee - (cons proc - (hash-table-ref caller-ht callee)))) - calls))) - all-procs+file+calls) - (map (lambda (x) - (let ((k (car x)) - (r (unique-atoms (cdr x)))) - (cons k r))) - (hash-table->alist caller-ht)))) - -;; create a handy cross-reference of callees to callers in the form of an alist. -(define (get-xref all-scm-files) - (let* ((all-procs+file+atoms - (apply append (map get-procs+file+atoms all-scm-files))) - (all-procs (map car all-procs+file+atoms)) - (all-procs+file+calls ; proc calls things in calls list - (map (lambda (item) - (let* ((proc (car item)) - (file (cadr item)) - (atoms (caddr item)) - (calls - (filter identity - (map - (lambda (x) - (if (and ;; (not (equal? x proc)) ;; uncomment to prevent listing self - (member x all-procs)) - x - #f)) - atoms)))) - (list proc file calls))) - all-procs+file+atoms)) - (callers (get-callers-alist all-procs+file+calls))) - callers)) DELETED common.scm Index: common.scm ================================================================== --- common.scm +++ /dev/null @@ -1,117 +0,0 @@ -;;====================================================================== -;; Copyright 2006-2012, 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 common)) -(declare (uses commonmod)) -(declare (uses processmod)) -(declare (uses configfmod)) -(declare (uses rmtmod)) -(declare (uses debugprint)) -(declare (uses mtargs)) - - -(use srfi-1 data-structures posix regex-case (prefix base64 base64:) - format dot-locking csv-xml z3 udp ;; sql-de-lite - hostinfo md5 message-digest typed-records directory-utils stack - matchable regex posix (srfi 18) extras ;; tcp - (prefix nanomsg nmsg:) - (prefix sqlite3 sqlite3:) - pkts (prefix dbi dbi:) - ) -(use posix-extras pathname-expand files) - - -(import commonmod - processmod - debugprint - configfmod - rmtmod - (prefix mtargs args:)) - -(include "common_records.scm") - - - - - -;;====================================================================== -;; (define *common:telemetry-log-state* 'startup) -;; (define *common:telemetry-log-socket* #f) -;; -;; (define (common:telemetry-log-open) -;; (if (eq? *common:telemetry-log-state* 'startup) -;; (let* ((serverhost (configf:lookup *configdat* "telemetry" "host")) -;; (serverport (configf:lookup-number *configdat* "telemetry" "port")) -;; (user (or (get-environment-variable "USER") "unknown")) -;; (host (or (get-environment-variable "HOST") "unknown"))) -;; (set! *common:telemetry-log-state* -;; (handle-exceptions -;; exn -;; (begin -;; (debug:print-info 0 *default-log-port* "common-telemetry-log open udp port failure") -;; 'broken) -;; (if (and serverhost serverport user host) -;; (let* ((s (udp-open-socket))) -;; ;;(udp-bind! s #f 0) -;; (udp-connect! s serverhost serverport) -;; (set! *common:telemetry-log-socket* s) -;; 'open) -;; 'not-needed)))))) -;; -;; (define (common:telemetry-log event #!key (payload '())) -;; (if (eq? *common:telemetry-log-state* 'startup) -;; (common:telemetry-log-open)) -;; -;; (if (eq? 'open *common:telemetry-log-state*) -;; (handle-exceptions -;; exn -;; (begin -;; (debug:print-info 0 *default-log-port* "common-telemetry-log comms failure ; disabled (no server?)") -;; ;;(define *common:telemetry-log-state* 'broken-or-no-server-preclose) -;; ;;(common:telemetry-log-close) -;; (define *common:telemetry-log-state* 'broken-or-no-server) -;; (set! *common:telemetry-log-socket* #f) -;; ) -;; (if (and *common:telemetry-log-socket* event) ;; TODO - filter on event against telemetry.want-events -;; (let* ((user (or (get-environment-variable "USER") "unknown")) -;; (host (or (get-environment-variable "HOST") "unknown")) -;; (start (conc "[megatest "event"]")) -;; (toppath (or *toppath* "/dev/null")) -;; (payload-serialized -;; (base64:base64-encode -;; (z3:encode-buffer -;; (with-output-to-string (lambda () (pp payload)))))) -;; (msg (conc user":"host":"start":"(current-process-id)":"(car (argv))":" -;; toppath":"payload-serialized))) -;; (udp-send *common:telemetry-log-socket* msg)))))) -;; -;; (define (common:telemetry-log-close) -;; (when (or (member *common:telemetry-log-state* '(broken-or-no-server-preclose open)) *common:telemetry-log-socket*) -;; (handle-exceptions -;; exn -;; (begin -;; (define *common:telemetry-log-state* 'closed-fail) -;; (debug:print-info 0 *default-log-port* "common-telemetry-log closure failure") -;; ) -;; (begin -;; (define *common:telemetry-log-state* 'closed) -;; (udp-close-socket *common:telemetry-log-socket*) -;; (set! *common:telemetry-log-socket* #f))))) - Index: commonmod.scm ================================================================== --- commonmod.scm +++ commonmod.scm @@ -50,12 +50,253 @@ (import stml2 ) (module commonmod - * + ( + ;; globals + *already-seen-runconfig-info* + *common:badly-ended-states* + *common:dont-roll-up-states* + *common:ended-states* + *common:not-started-ok-statuses* + *common:running-states* + *common:std-states* + *common:std-statuses* + *common:well-ended-states* + *configdat* + *configinfo* + *configstatus* + *db-access-allowed* + *db-api-call-time* + *db-cache-path* + *db-keys* + *default-area-tag* + *env-vars-by-run-id* + *globalexitstatus* + *host-loads* + *keyvals* + *last-launch* + *launch-setup-mutex* + *logged-in-clients* + *my-client-signature* + *on-exit-procs* + *passnum* + *pkts-info* + *pre-reqs-met-cache* + *runconfigdat* + *runremote* + *server-id* + *server-info* + *target* + *task-db* + *test-meta-updated* + *testconfigs* + *time-to-exit* + *toppath* + *toptest-paths* + *transport-type* + *common:this-exe-dir* + + common:list-is-sublist + seconds->year-week/day-time + common:find-start-mark-and-mark-delta + + common:with-orig-env + alist->env-vars + any->number + any->number-if-possible + assoc/default + client:get-signature + + common:alist-ref/default + common:clear-caches + common:dir-clean-up + common:directory-exists? + common:directory-writable? + common:fail-safe + common:file-exists? + common:find-local-megatest + common:generic-ssh + common:get-area-path-signature + common:get-color-from-status + common:get-cpu-load + common:get-create-writeable-dir + common:get-fields + common:get-intercept + common:get-megatest-exe + common:get-megatest-exe-dir + common:get-megatest-exe-path + common:get-mtexe + common:get-normalized-cpu-load + common:get-normalized-cpu-load + common:get-num-cpus + common:get-param-mapping + common:get-signature + common:get-toppath + common:hms-string->seconds + common:htree->html + common:human-time + common:in-running-test? + common:join-backgrounded-threads + common:lazy-sqlite-db-modification-time + common:list->htree + common:list-or-null + common:logpro-exit-code->status-sym + common:low-noise-print + common:make-tmpdir-name + common:max + common:min-max + common:nice-path + common:pkts-spec + common:raw-get-remote-host-load + common:read-encoded-string + common:real-path + common:send-thunk-to-background-thread + common:simple-file-lock + common:simple-file-lock-and-wait + common:simple-file-release-lock + common:sparse-list-generate-index + common:special-sort + common:steps-can-proceed-given-status-sym + common:sum + common:to-alist + common:unix-ping + common:val->alist + common:version-signature + common:which + common:with-env-vars + common:without-vars + common:worse-status-sym + commonmod:get-cpu-load + commonmod:is-test-alive + db:mintest-get-event_time + db:patt->like + + db:test-data-get-category + db:test-data-get-comment + db:test-data-get-expected + db:test-data-get-id + db:test-data-get-last_update + db:test-data-get-status + db:test-data-get-test_id + db:test-data-get-tol + db:test-data-get-type + db:test-data-get-units + db:test-data-get-value + db:test-data-get-variable + db:test-get-archived + db:test-get-comment + db:test-get-cpuload + db:test-get-diskfree + db:test-get-event_time + db:test-get-final_logf + db:test-get-fullname + db:test-get-host + db:test-get-id + db:test-get-is-toplevel + db:test-get-item-path + db:test-get-last_update + db:test-get-process_id + db:test-get-run_duration + db:test-get-run_id + db:test-get-rundir + db:test-get-state + db:test-get-status + db:test-get-testname + db:test-get-uname + db:test-make-full-name + db:test-set-state! + db:test-set-status! + db:test-set-testname! + + db:testmeta-get-author + db:testmeta-get-description + db:testmeta-get-owner + db:testmeta-get-reviewed + db:testmeta-get-tags + + get-area-path-signature + get-normalized-cpu-load + getenv + host-last-cpuload + host-last-cpuload-set! + host-last-update + host-last-update-set! + host-last-used + host-last-used-set! + host-reachable + host-reachable-set! + item-list->path + keys->keystr + keys->valslots + keys:config-get-fields + keys:target->keyval + keys:target-set-args + make-db:testmeta + make-host + make-sparse-array + make-tests:testqueue + megatest-fossil-hash + megatest-version + number-of-processes-running + patt-list-match + rmt:transport-mode + runs:get-std-run-fields + safe-setenv + save-environment-as-files + sdb:qry + seconds->hr-min-sec + seconds->quarter + seconds->time-string + seconds->work-week/day + seconds->work-week/day-time + seconds->year-work-week/day-time + setenv + sparse-array-ref + sparse-array-set! + status-sym->string + stop-the-train + tasks:wait-on-journal + + tdb:step-get-comment + tdb:step-get-event_time + tdb:step-get-id + tdb:step-get-last_update + tdb:step-get-logfile + tdb:step-get-state + tdb:step-get-status + tdb:step-get-stepname + tdb:step-get-test_id + tdb:steps-table-get-end + tdb:steps-table-get-log-file + tdb:steps-table-get-runtime + tdb:steps-table-get-start + tdb:steps-table-get-status + tdb:steps-table-get-stepname + + tests:glob-like-match + tests:lookup-itemmap + tests:match + tests:match->sqlqry + + tests:testqueue-get-item_path + tests:testqueue-get-itemdat + tests:testqueue-get-items + tests:testqueue-get-priority + tests:testqueue-get-testconfig + tests:testqueue-get-testname + tests:testqueue-get-waitons + tests:testqueue-set-item_path! + tests:testqueue-set-itemdat! + tests:testqueue-set-items! + tests:testqueue-set-priority! + + val->alist + ) + (import scheme) (cond-expand (chicken-4 (import chicken @@ -120,10 +361,12 @@ srfi-69 typed-records system-information debugprint + megatest-fossil-hash + ))) ;;====================================================================== ;; CONTENTS ;; @@ -136,11 +379,10 @@ (include "megatest-version.scm") (include "megatest-fossil-hash.scm") (include "db_records.scm") (include "key_records.scm") (include "common_records.scm") -(include "test_records.scm") ;; http - use the old http + in /tmp db ;; tcp - use tcp transport with cachedb db ;; nfs - use direct to disk access (read-only) ;; @@ -285,10 +527,11 @@ (caddr argv)) (else (car argv)))) (fullpath (realpath this-script))) fullpath)) +;; get rid of these, no need to slow down start up ;;====================================================================== (define *common:this-exe-fullpath* (common:get-this-exe-fullpath)) (define *common:this-exe-dir* (pathname-directory *common:this-exe-fullpath*)) (define *common:this-exe-name* (pathname-strip-directory *common:this-exe-fullpath*)) @@ -385,10 +628,11 @@ (define *last-launch* (current-seconds)) ;; use for throttling the launch rate. Would be better to use the db and last time of a test in LAUNCHED state. ;; environment vars handy stuff from common.scm ;; (define getenv get-environment-variable) + (define (safe-setenv key val) (if (or (substring-index "!" key) (substring-index ":" key) ;; variables containing : are for internal use and cannot be environment variables. (substring-index "." key)) ;; periods are not allowed in environment variables (debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\" or starting with \"!\"") @@ -563,13 +807,10 @@ (if valstr (val->alist valstr) '()))) ;; should it return empty list or #f to indicate not set? -(define (get-section cfgdat section) - (hash-table-ref/default cfgdat section '())) - (define (common:make-tmpdir-name areapath tmpadj) (let* ((area (pathname-file areapath)) (dname (conc "/tmp/"(current-user-name)"/megatest_localdb/" area "/" (string-translate areapath "/" ".") tmpadj "/.mtdb"))) (unless (directory-exists? dname) (create-directory dname #t)) @@ -2735,7 +2976,229 @@ (define (common:get-fields cfgdat) (let ((fields (hash-table-ref/default cfgdat "fields" '()))) (map car fields))) (define keys:config-get-fields common:get-fields) + +;;====================================================================== +;; db_records.scm +;;====================================================================== + +;;====================================================================== +;; dbstruct +;;====================================================================== + +(define (make-db:test)(make-vector 20)) +(define (db:test-get-id vec) (vector-ref vec 0)) +(define (db:test-get-run_id vec) (vector-ref vec 1)) +(define (db:test-get-testname vec) (vector-ref vec 2)) +(define (db:test-get-state vec) (vector-ref vec 3)) +(define (db:test-get-status vec) (vector-ref vec 4)) +(define (db:test-get-event_time vec) (vector-ref vec 5)) +(define (db:test-get-host vec) (vector-ref vec 6)) +(define (db:test-get-cpuload vec) (vector-ref vec 7)) +(define (db:test-get-diskfree vec) (vector-ref vec 8)) +(define (db:test-get-uname vec) (vector-ref vec 9)) +;; (define (db:test-get-rundir vec) (sdb:qry 'getstr (vector-ref vec 10))) +(define (db:test-get-rundir vec) (vector-ref vec 10)) +(define (db:test-get-item-path vec) (vector-ref vec 11)) +(define (db:test-get-run_duration vec) (vector-ref vec 12)) +(define (db:test-get-final_logf vec) (vector-ref vec 13)) +(define (db:test-get-comment vec) (vector-ref vec 14)) +(define (db:test-get-process_id vec) (vector-ref vec 16)) +(define (db:test-get-archived vec) (vector-ref vec 17)) +(define (db:test-get-last_update vec) (vector-ref vec 18)) + +;; (define (db:test-get-pass_count vec) (vector-ref vec 15)) +;; (define (db:test-get-fail_count vec) (vector-ref vec 16)) +(define (db:test-get-fullname vec) + (conc (db:test-get-testname vec) "/" (db:test-get-item-path vec))) + +;; replace runs:make-full-test-name with this routine +(define (db:test-make-full-name testname itempath) + (if (equal? itempath "") testname (conc testname "/" itempath))) + +;; (define (db:test-get-first_err vec) (printable (vector-ref vec 15))) +;; (define (db:test-get-first_warn vec) (printable (vector-ref vec 16))) ;; RADT => reference 16 is repeated + +(define (db:test-set-cpuload! vec val)(vector-set! vec 7 val)) +(define (db:test-set-diskfree! vec val)(vector-set! vec 8 val)) +(define (db:test-set-testname! vec val)(vector-set! vec 2 val)) +(define (db:test-set-state! vec val)(vector-set! vec 3 val)) +(define (db:test-set-status! vec val)(vector-set! vec 4 val)) +(define (db:test-set-run_duration! vec val)(vector-set! vec 12 val)) +(define (db:test-set-final_logf! vec val)(vector-set! vec 13 val)) + +;; Test record utility functions + +;; Is a test a toplevel? +;; +(define (db:test-get-is-toplevel vec) + (and (equal? (db:test-get-item-path vec) "") ;; test is not an item + (equal? (db:test-get-uname vec) "n/a"))) ;; test has never been run + +;; make-vector-record "" db mintest id run_id testname state status event_time item_path +;; RADT => purpose of mintest?? +;; +(define (make-db:mintest)(make-vector 7)) +(define (db:mintest-get-id vec) (vector-ref vec 0)) +(define (db:mintest-get-run_id vec) (vector-ref vec 1)) +(define (db:mintest-get-testname vec) (vector-ref vec 2)) +(define (db:mintest-get-state vec) (vector-ref vec 3)) +(define (db:mintest-get-status vec) (vector-ref vec 4)) +(define (db:mintest-get-event_time vec) (vector-ref vec 5)) +(define (db:mintest-get-item_path vec) (vector-ref vec 6)) + +;; make-vector-record db testmeta id testname author owner description reviewed iterated avg_runtime avg_disk +(define (make-db:testmeta)(make-vector 10 "")) +(define (db:testmeta-get-id vec) (vector-ref vec 0)) +(define (db:testmeta-get-testname vec) (vector-ref vec 1)) +(define (db:testmeta-get-author vec) (vector-ref vec 2)) +(define (db:testmeta-get-owner vec) (vector-ref vec 3)) +(define (db:testmeta-get-description vec) (vector-ref vec 4)) +(define (db:testmeta-get-reviewed vec) (vector-ref vec 5)) +(define (db:testmeta-get-iterated vec) (vector-ref vec 6)) +(define (db:testmeta-get-avg_runtime vec) (vector-ref vec 7)) +(define (db:testmeta-get-avg_disk vec) (vector-ref vec 8)) +(define (db:testmeta-get-tags vec) (vector-ref vec 9)) +(define (db:testmeta-set-id! vec val)(vector-set! vec 0 val)) +(define (db:testmeta-set-testname! vec val)(vector-set! vec 1 val)) +(define (db:testmeta-set-author! vec val)(vector-set! vec 2 val)) +(define (db:testmeta-set-owner! vec val)(vector-set! vec 3 val)) +(define (db:testmeta-set-description! vec val)(vector-set! vec 4 val)) +(define (db:testmeta-set-reviewed! vec val)(vector-set! vec 5 val)) +(define (db:testmeta-set-iterated! vec val)(vector-set! vec 6 val)) +(define (db:testmeta-set-avg_runtime! vec val)(vector-set! vec 7 val)) +(define (db:testmeta-set-avg_disk! vec val)(vector-set! vec 8 val)) + +;;====================================================================== +;; S I M P L E R U N +;;====================================================================== + +;; (defstruct id "runname" "state" "status" "owner" "event_time" + +;;====================================================================== +;; T E S T D A T A +;;====================================================================== +(define (make-db:test-data)(make-vector 10)) +(define (db:test-data-get-id vec) (vector-ref vec 0)) +(define (db:test-data-get-test_id vec) (vector-ref vec 1)) +(define (db:test-data-get-category vec) (vector-ref vec 2)) +(define (db:test-data-get-variable vec) (vector-ref vec 3)) +(define (db:test-data-get-value vec) (vector-ref vec 4)) +(define (db:test-data-get-expected vec) (vector-ref vec 5)) +(define (db:test-data-get-tol vec) (vector-ref vec 6)) +(define (db:test-data-get-units vec) (vector-ref vec 7)) +(define (db:test-data-get-comment vec) (vector-ref vec 8)) +(define (db:test-data-get-status vec) (vector-ref vec 9)) +(define (db:test-data-get-type vec) (vector-ref vec 10)) +(define (db:test-data-get-last_update vec) (vector-ref vec 11)) + +(define (db:test-data-set-id! vec val)(vector-set! vec 0 val)) +(define (db:test-data-set-test_id! vec val)(vector-set! vec 1 val)) +(define (db:test-data-set-category! vec val)(vector-set! vec 2 val)) +(define (db:test-data-set-variable! vec val)(vector-set! vec 3 val)) +(define (db:test-data-set-value! vec val)(vector-set! vec 4 val)) +(define (db:test-data-set-expected! vec val)(vector-set! vec 5 val)) +(define (db:test-data-set-tol! vec val)(vector-set! vec 6 val)) +(define (db:test-data-set-units! vec val)(vector-set! vec 7 val)) +(define (db:test-data-set-comment! vec val)(vector-set! vec 8 val)) +(define (db:test-data-set-status! vec val)(vector-set! vec 9 val)) +(define (db:test-data-set-type! vec val)(vector-set! vec 10 val)) + +;;====================================================================== +;; S T E P S +;;====================================================================== +;; Run steps +;; make-vector-record "Run steps" db step id test_id stepname step_complete step_pass event_time +(define (make-db:step)(make-vector 9)) +(define (tdb:step-get-id vec) (vector-ref vec 0)) +(define (tdb:step-get-test_id vec) (vector-ref vec 1)) +(define (tdb:step-get-stepname vec) (vector-ref vec 2)) +(define (tdb:step-get-state vec) (vector-ref vec 3)) +(define (tdb:step-get-status vec) (vector-ref vec 4)) +(define (tdb:step-get-event_time vec) (vector-ref vec 5)) +(define (tdb:step-get-logfile vec) (vector-ref vec 6)) +(define (tdb:step-get-comment vec) (vector-ref vec 7)) +(define (tdb:step-get-last_update vec) (vector-ref vec 8)) +(define (tdb:step-set-id! vec val)(vector-set! vec 0 val)) +(define (tdb:step-set-test_id! vec val)(vector-set! vec 1 val)) +(define (tdb:step-set-stepname! vec val)(vector-set! vec 2 val)) +(define (tdb:step-set-state! vec val)(vector-set! vec 3 val)) +(define (tdb:step-set-status! vec val)(vector-set! vec 4 val)) +(define (tdb:step-set-event_time! vec val)(vector-set! vec 5 val)) +(define (tdb:step-set-logfile! vec val)(vector-set! vec 6 val)) +(define (tdb:step-set-comment! vec val)(vector-set! vec 7 val)) + + +;; The steps table +(define (make-db:steps-table)(make-vector 5)) +(define (tdb:steps-table-get-stepname vec) (vector-ref vec 0)) +(define (tdb:steps-table-get-start vec) (vector-ref vec 1)) +(define (tdb:steps-table-get-end vec) (vector-ref vec 2)) +(define (tdb:steps-table-get-status vec) (vector-ref vec 3)) +(define (tdb:steps-table-get-runtime vec) (vector-ref vec 4)) +(define (tdb:steps-table-get-log-file vec) (vector-ref vec 5)) + +(define (tdb:step-stable-set-stepname! vec val)(vector-set! vec 0 val)) +(define (tdb:step-stable-set-start! vec val)(vector-set! vec 1 val)) +(define (tdb:step-stable-set-end! vec val)(vector-set! vec 2 val)) +(define (tdb:step-stable-set-status! vec val)(vector-set! vec 3 val)) +(define (tdb:step-stable-set-runtime! vec val)(vector-set! vec 4 val)) + +;; ;; The data structure for handing off requests via wire +;; (define (make-cdb:packet)(make-vector 6)) +;; (define (cdb:packet-get-client-sig vec) (vector-ref vec 0)) +;; (define (cdb:packet-get-qtype vec) (vector-ref vec 1)) +;; (define (cdb:packet-get-immediate vec) (vector-ref vec 2)) +;; (define (cdb:packet-get-query-sig vec) (vector-ref vec 3)) +;; (define (cdb:packet-get-params vec) (vector-ref vec 4)) +;; (define (cdb:packet-get-qtime vec) (vector-ref vec 5)) +;; (define (cdb:packet-set-client-sig! vec val)(vector-set! vec 0 val)) +;; (define (cdb:packet-set-qtype! vec val)(vector-set! vec 1 val)) +;; (define (cdb:packet-set-immediate! vec val)(vector-set! vec 2 val)) +;; (define (cdb:packet-set-query-sig! vec val)(vector-set! vec 3 val)) +;; (define (cdb:packet-set-params! vec val)(vector-set! vec 4 val)) +;; (define (cdb:packet-set-qtime! vec val)(vector-set! vec 5 val)) + +;;====================================================================== +;; key_records +;;====================================================================== + +(define (keys->valslots keys) ;; => ?,?,? .... + (string-intersperse (map (lambda (x) "?") keys) ",")) + +;; (define (keys->key/field keys . additional) +;; (string-join (map (lambda (k)(conc k " TEXT")) +;; (append keys additional)) ",")) + +(define (item-list->path itemdat) + (if (list? itemdat) + (string-intersperse (map cadr itemdat) "/") + "")) + + +;;====================================================================== +;; test_records +;;====================================================================== + +;; make-vector-record tests testqueue testname testconfig waitons priority items +(define (make-tests:testqueue)(make-vector 7 #f)) +(define (tests:testqueue-get-testname vec) (vector-ref vec 0)) +(define (tests:testqueue-get-testconfig vec) (vector-ref vec 1)) +(define (tests:testqueue-get-waitons vec) (vector-ref vec 2)) +(define (tests:testqueue-get-priority vec) (vector-ref vec 3)) +;; items: #f=no items, list=list of items remaining, proc=need to call to get items +(define (tests:testqueue-get-items vec) (vector-ref vec 4)) +(define (tests:testqueue-get-itemdat vec) (vector-ref vec 5)) +(define (tests:testqueue-get-item_path vec) (vector-ref vec 6)) + +(define (tests:testqueue-set-testname! vec val)(vector-set! vec 0 val)) +(define (tests:testqueue-set-testconfig! vec val)(vector-set! vec 1 val)) +(define (tests:testqueue-set-waitons! vec val)(vector-set! vec 2 val)) +(define (tests:testqueue-set-priority! vec val)(vector-set! vec 3 val)) +(define (tests:testqueue-set-items! vec val)(vector-set! vec 4 val)) +(define (tests:testqueue-set-itemdat! vec val)(vector-set! vec 5 val)) +(define (tests:testqueue-set-item_path! vec val)(vector-set! vec 6 val)) + ) ADDED configf-guts.scm Index: configf-guts.scm ================================================================== --- /dev/null +++ configf-guts.scm @@ -0,0 +1,427 @@ +;;====================================================================== +;; Copyright 2006-2012, 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 . + +;;====================================================================== + +;;====================================================================== +;; Config file handling +;;====================================================================== + +;; (use regex regex-case matchable) ;; directory-utils) +;; (declare (unit configf)) +;; (declare (uses process)) +;; (declare (uses env)) +;; (declare (uses keys)) +;; (declare (uses debugprint)) +;; (declare (uses mtargs)) +;; (declare (uses mtargs.import)) +;; (declare (uses common)) +;; (declare (uses commonmod)) +;; (declare (uses commonmod.import)) +;; (declare (uses processmod)) +;; (declare (uses processmod.import)) +;; (declare (uses configfmod)) +;; (declare (uses configfmod.import)) +;; (declare (uses dbfile)) +;; (declare (uses dbfile.import)) +;; (declare (uses dbmod)) +;; (declare (uses dbmod.import)) +;; (declare (uses mtmod)) +;; (declare (uses mtmod.import)) +;; (declare (uses megatestmod)) +;; (declare (uses megatestmod.import)) +;; +;; (import commonmod +;; configfmod +;; processmod +;; (prefix mtargs args:) +;; debugprint +;; mtmod +;; ) +;; +;; (include "common_records.scm") + +(define configf:imports "(import commonmod configfmod processmod (prefix mtargs args:))") + + +(define (configf:process-line l ht allow-system #!key (linenum #f)) + (let loop ((res l)) + (if (string? res) + (let ((matchdat (string-search configf:var-expand-regex res))) + (if matchdat + (let* ((prestr (list-ref matchdat 1)) + (cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv + (cmd (list-ref matchdat 3)) + (poststr (list-ref matchdat 4)) + (result #f) + (start-time (current-seconds)) + (cmdsym (string->symbol cmdtype)) + (fullcmd (case cmdsym + ((scheme scm) (conc "(lambda (ht)(begin " configf:imports cmd "))")) + ((system) (conc "(lambda (ht)(configf:system ht \"" cmd "\"))")) + ((shell sh) (conc "(lambda (ht)(string-translate (shell \"" cmd "\") \"\n\" \" \"))")) + ((realpath rp)(conc "(lambda (ht)(common:nice-path \"" cmd "\"))")) + ((getenv gv) (conc "(lambda (ht)(get-environment-variable \"" cmd "\"))")) + ((mtrah) (conc "(lambda (ht)" + " (let ((extra \"" cmd "\"))" + " (conc (or *toppath* (get-environment-variable \"MT_RUN_AREA_HOME\"))" + " (if (string-null? extra) \"\" \"/\")" + " extra)))")) + ((get g) + (match (string-split cmd) + ((sect var)(conc "(lambda (ht)(configf:lookup ht \"" sect "\" \"" var "\"))")) + (else + (debug:print-error 0 *default-log-port* "#{get ...} used with only one parameter, \"" cmd "\", two needed.") + "(lambda (ht) #f)"))) + ((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 + exn + (begin + (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\", exn=" exn) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + ;; (print "exn=" (condition->list exn)) + (set! result (conc "#{( " cmdtype ") " cmd "}, full expansion: " fullcmd))) + (if (or allow-system + (not (member cmdtype '("system" "shell" "sh")))) + (with-input-from-string fullcmd + (lambda () + (set! result ((eval (read)) ht)))) + (set! result (conc "#{(" cmdtype ") " cmd "}")))) + (case cmdsym + ((system shell scheme) + (let ((delta (- (current-seconds) start-time))) + (if (> delta 2) + (debug:print-info 2 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result) + (debug:print-info 9 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result))))) + (loop (conc prestr result poststr))) + res)) + res))) + +;; this was inline but I'm pretty sure that is a hold over from when it was *very* simple ... +;; +(define (configf:read-line p ht allow-processing settings) + (let loop ((inl (read-line p))) + (let ((cont-line (and (string? inl) + (not (string-null? inl)) + (equal? "\\" (string-take-right inl 1))))) + (if cont-line ;; last character is \ + (let ((nextl (read-line p))) + (if (not (eof-object? nextl)) + (loop (string-append (if cont-line + (string-take inl (- (string-length inl) 1)) + inl) + nextl)))) + (let ((res (case allow-processing ;; if (and allow-processing + ;; (not (eq? allow-processing 'return-string))) + ((#t #f) + (configf:process-line inl ht allow-processing)) + ((return-string) + inl) + (else + (configf:process-line inl ht allow-processing))))) + (if (and (string? res) ;; must set to "no" to force NOT trimming trailing spaces + (not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "yes") "no"))) + (string-substitute "\\s+$" "" res) + res)))))) + +;; read a config file, returns hash table of alists + +;; read a config file, returns hash table of alists +;; adds to ht if given (must be #f otherwise) +;; allow-system: +;; #f - do not evaluate [system +;; #t - immediately evaluate [system and store result as string +;; 'return-procs -- return a proc taking ht as an argument that may be evaulated at some future time +;; 'return-string -- return a string representing a proc taking ht as an argument that may be evaulated at some future time +;; envion-patt is a regex spec that identifies sections that will be eval'd +;; in the environment on the fly +;; sections: #f => get all, else list of sections to gather +;; post-section-procs alist of section-pattern => proc, where: (proc section-name next-section-name ht curr-path) +;; apply-wildcards: #t/#f - apply vars from targets with % wildcards to all matching sections +;; +(define (read-config path ht allow-system #!key (environ-patt #f) (curr-section #f) + (sections #f) (settings (make-hash-table)) (keep-filenames #f) + (post-section-procs '()) (apply-wildcards #t) ) + (debug:print 9 *default-log-port* "START: " path) +;; (if *configdat* +;; (common:save-pkt `((action . read-config) +;; (f . ,(cond ((string? path) path) +;; ((port? path) "port") +;; (else (conc path)))) +;; (T . configf)) +;; *configdat* #t add-only: #t)) + (if (and (not (port? path)) + (not (common:file-exists? path))) ;; for case where we are handed a port + (begin + (debug:print-info 1 *default-log-port* "read-config - file not found " path " current path: " (current-directory)) + ;; WARNING: This is a risky change but really, we should not return an empty hash table if no file read? + #f) ;; (if (not ht)(make-hash-table) ht)) + (let ((inp (if (string? path) + (open-input-file path) + path)) ;; we can be handed a port + (res (if (not ht)(make-hash-table) ht)) + (metapath (if (or (debug:debug-mode 9) + keep-filenames) + path #f)) + (process-wildcards (lambda (res curr-section-name) + (if (and apply-wildcards + (or (string-contains curr-section-name "%") ;; wildcard + (string-match "/.*/" curr-section-name))) ;; regex + (begin + (configf:apply-wildcards res curr-section-name) + (hash-table-delete! res curr-section-name)))))) ;; NOTE: if the section is a wild card it will be REMOVED from res + (let loop ((inl (configf:read-line inp res (calc-allow-system allow-system curr-section sections) settings)) ;; (read-line inp)) + (curr-section-name (if curr-section curr-section "default")) + (var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere + (lead #f)) + (debug:print-info 8 *default-log-port* "curr-section-name: " curr-section-name " var-flag: " var-flag "\n inl: \"" inl "\"") + (if (eof-object? inl) + (begin + ;; process last section for wildcards + (process-wildcards res curr-section-name) + (if (string? path) ;; we received a path, not a port, thus we are responsible for closing it. + (close-input-port inp)) + (if (list? sections) ;; delete all sections except given when sections is provided + (for-each + (lambda (section) + (if (not (member section sections)) + (hash-table-delete! res section))) ;; we are using "" as a dumping ground and must remove it before returning the ht + (hash-table-keys res))) + (debug:print 9 *default-log-port* "END: " path) + res + ) ;; retval + (regex-case + inl + (configf:comment-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) + curr-section-name #f #f)) + + (configf:blank-l-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) + curr-section-name #f #f)) + (configf:settings ( x setting val ) + (begin + (hash-table-set! settings setting val) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) + curr-section-name #f #f))) + + (configf:include-rx ( x include-file ) + (let* ((curr-conf-dir (pathname-directory path)) + (full-conf (if (and (absolute-pathname? include-file) (file-exists? include-file)) + include-file + (common:nice-path + (conc (if curr-conf-dir + curr-conf-dir + ".") + "/" include-file))))) + (let ((all-matches (sort (handle-exceptions exn + (begin + (debug:print '(2 9) *default-log-port* "glob of " full-conf " gave no match. , exn=" exn) + (list)) + (glob full-conf)) string<=?))) + (if (null? all-matches) + (begin + (debug:print '(2 9) #f "INFO: include file(s) matching " include-file " not found (called from " path ")") + (debug:print 2 *default-log-port* " " full-conf)) + (for-each + (lambda (fpath) + ;; (push-directory conf-dir) + (debug:print 9 *default-log-port* "Including: " full-conf) + (read-config fpath res allow-system environ-patt: environ-patt + curr-section: curr-section-name sections: sections settings: settings + keep-filenames: keep-filenames)) + all-matches)) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) + curr-section-name #f #f)))) + (configf:script-rx ( x include-script params);; handle-exceptions + ;; exn + ;; (begin + ;; (debug:print '(0 2 9) #f "INFO: include from script " include-script " failed.") + ;; (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) + (if (and (common:file-exists? include-script)(file-execute-access? include-script)) + (let* ((local-allow-system (calc-allow-system allow-system curr-section-name sections)) + (env-delta (configf:cfgdat->env-alist curr-section-name res local-allow-system)) + (new-inp-port + (common:with-env-vars + env-delta + (lambda () + (open-input-pipe (conc include-script " " params)))))) + (debug:print '(2 9) *default-log-port* "Including from script output: " include-script) + ;; (print "We got here, calling read-config next. Port is: " new-inp-port) + (read-config new-inp-port res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames) + (close-input-port new-inp-port) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) + (begin + (debug:print 0 *default-log-port* "Script not found or not exectutable: " include-script) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))) + ) ;; ) + (configf:section-rx ( x section-name ) + (begin + ;; call post-section-procs + (for-each + (lambda (dat) + (let ((patt (car dat)) + (proc (cdr dat))) + (if (string-match patt curr-section-name) + (proc curr-section-name section-name res path)))) + post-section-procs) + ;; after gathering the vars for a section and if apply-wildcards is true and if there is a wildcard in the section name process wildcards + ;; NOTE: we are processing the curr-section-name, NOT section-name. + (process-wildcards res curr-section-name) + (if (not (hash-table-ref/default res section-name #f))(hash-table-set! res section-name '())) ;; ensure that mere mention of a section is not lost + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) + ;; if we have the sections list then force all settings into "" and delete it later? + ;; (if (or (not sections) + ;; (member section-name sections)) + ;; section-name "") ;; stick everything into "". NOPE: We need new strategy. Put stuff in correct sections and then delete all sections later. + section-name + #f #f))) + (configf:key-sys-pr ( x key cmd ) + (if (calc-allow-system allow-system curr-section-name sections) + (let ((alist (hash-table-ref/default res curr-section-name '())) + (val-proc (lambda () + (let* ((start-time (current-seconds)) + (local-allow-system (calc-allow-system allow-system curr-section-name sections)) + (env-delta (configf:cfgdat->env-alist curr-section-name res local-allow-system)) + (cmdres (process:cmd-run->list cmd delta-env-alist-or-hash-table: env-delta)) ;; BB: here is where [system is exec'd. needs to have env from other vars! + (delta (- (current-seconds) start-time)) + (status (cadr cmdres)) + (res (car cmdres))) + (debug:print-info 4 *default-log-port* "" inl "\n => " (string-intersperse res "\n")) + (if (not (eq? status 0)) + (begin + (debug:print-error 0 *default-log-port* "problem with " inl ", return code " status + " output: " cmdres))) + (if (> delta 2) + (debug:print-info 0 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res) + (debug:print-info 9 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res)) + (if (null? res) + "" + (string-intersperse res " ")))))) + (hash-table-set! res curr-section-name + (configf:assoc-safe-add alist + key + (case (calc-allow-system allow-system curr-section-name sections) + ((return-procs) val-proc) + ((return-string) cmd) + (else (val-proc))) + metadata: metapath)) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) + (loop (configf:read-line inp res + (calc-allow-system allow-system curr-section-name sections) + settings) + curr-section-name #f #f))) + + (configf:key-no-val ( x key val) + (let* ((alist (hash-table-ref/default res curr-section-name '())) + (fval (or (if (string? val) val #f) ""))) ;; fval should be either "" or " " (one or more spaces) + (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = #t") + (safe-setenv key fval) + (hash-table-set! res curr-section-name + (configf:assoc-safe-add alist key fval metadata: metapath)) + (loop (configf:read-line inp res + (calc-allow-system allow-system curr-section-name sections) + settings) + curr-section-name key #f))) + + (configf:key-val-pr ( x key unk1 val unk2 ) + (let* ((alist (hash-table-ref/default res curr-section-name '())) + (envar (and environ-patt + (string-search (regexp environ-patt) curr-section-name) ;; does the section match the envionpatt? + (and (not (string-null? key)) + (not (equal? "!" (substring key 0 1)))) ;; ! as leading character is a signature to NOT export to the environment + ;; (string-match "^.*:.*:.*$" key) ;; ;; something:something:something reserved for triggers in runconfigs + )) + (realval (if envar + (configf:eval-string-in-environment val) + val))) + (debug:print-info 6 *default-log-port* "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name) + (if envar (safe-setenv key realval)) + (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = " val) + (hash-table-set! res curr-section-name + (configf:assoc-safe-add alist key realval metadata: metapath)) + (loop (configf:read-line inp res + (calc-allow-system allow-system curr-section-name sections) settings) + curr-section-name key #f))) + ;; 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 + (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))) + ;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag) + (hash-table-set! res curr-section-name + (configf:assoc-safe-add alist var-flag newval metadata: metapath)) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name var-flag (if lead lead whsp))) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))) + (else (debug:print-error 0 *default-log-port* "problem parsing " path ",\n \"" inl "\"") + (set! var-flag #f) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))) + ) ;; end loop + ))) + +(define (setup) + (let* ((configf (find-config "megatest.config")) + (config (if configf (read-config configf #f #t) #f))) + (if config + (setenv "RUN_AREA_HOME" (pathname-directory configf))) + config)) + +;;====================================================================== +;; refdb +;;====================================================================== + +;; reads a refdb into an assoc array of assoc arrays +;; returns (list dat msg) +(define (configf:read-refdb refdb-path) + (let ((sheets-file (conc refdb-path "/sheet-names.cfg"))) + (if (not (common:file-exists? sheets-file)) + (list #f (conc "ERROR: no refdb found at " refdb-path)) + (if (not (file-read-access? sheets-file)) + (list #f (conc "ERROR: refdb file not readable at " refdb-path)) + (let* ((sheets (with-input-from-file sheets-file + (lambda () + (let loop ((inl (read-line)) + (res '())) + (if (eof-object? inl) + (reverse res) + (loop (read-line)(cons inl res))))))) + (data '())) + (for-each + (lambda (sheet-name) + (let* ((dat-path (conc refdb-path "/" sheet-name ".dat")) + (ref-dat (configf:read-file dat-path #f #t)) + (ref-assoc (map (lambda (key) + (list key (hash-table-ref ref-dat key))) + (hash-table-keys ref-dat)))) + ;; (hash-table->alist ref-dat))) + ;; (set! data (append data (list (list sheet-name ref-assoc)))))) + (set! data (cons (list sheet-name ref-assoc) data)))) + sheets) + (list data "NO ERRORS")))))) + +;; redefines +(define config-lookup configf:lookup) +(define configf:read-file read-config) + DELETED configf.scm Index: configf.scm ================================================================== --- configf.scm +++ /dev/null @@ -1,426 +0,0 @@ -;;====================================================================== -;; Copyright 2006-2012, 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 . - -;;====================================================================== - -;;====================================================================== -;; Config file handling -;;====================================================================== - -(use regex regex-case matchable) ;; directory-utils) -(declare (unit configf)) -(declare (uses process)) -(declare (uses env)) -(declare (uses keys)) -(declare (uses debugprint)) -(declare (uses mtargs)) -(declare (uses mtargs.import)) -(declare (uses common)) -(declare (uses commonmod)) -(declare (uses commonmod.import)) -(declare (uses processmod)) -(declare (uses processmod.import)) -(declare (uses configfmod)) -(declare (uses configfmod.import)) -(declare (uses dbfile)) -(declare (uses dbfile.import)) -(declare (uses dbmod)) -(declare (uses dbmod.import)) -(declare (uses mtmod)) -(declare (uses mtmod.import)) - -(import commonmod - configfmod - processmod - (prefix mtargs args:) - debugprint - mtmod - ) - -(include "common_records.scm") - -(define configf:imports "(import commonmod configfmod processmod (prefix mtargs args:))") - - -(define (configf:process-line l ht allow-system #!key (linenum #f)) - (let loop ((res l)) - (if (string? res) - (let ((matchdat (string-search configf:var-expand-regex res))) - (if matchdat - (let* ((prestr (list-ref matchdat 1)) - (cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv - (cmd (list-ref matchdat 3)) - (poststr (list-ref matchdat 4)) - (result #f) - (start-time (current-seconds)) - (cmdsym (string->symbol cmdtype)) - (fullcmd (case cmdsym - ((scheme scm) (conc "(lambda (ht)(begin " configf:imports cmd "))")) - ((system) (conc "(lambda (ht)(configf:system ht \"" cmd "\"))")) - ((shell sh) (conc "(lambda (ht)(string-translate (shell \"" cmd "\") \"\n\" \" \"))")) - ((realpath rp)(conc "(lambda (ht)(common:nice-path \"" cmd "\"))")) - ((getenv gv) (conc "(lambda (ht)(get-environment-variable \"" cmd "\"))")) - ((mtrah) (conc "(lambda (ht)" - " (let ((extra \"" cmd "\"))" - " (conc (or *toppath* (get-environment-variable \"MT_RUN_AREA_HOME\"))" - " (if (string-null? extra) \"\" \"/\")" - " extra)))")) - ((get g) - (match (string-split cmd) - ((sect var)(conc "(lambda (ht)(configf:lookup ht \"" sect "\" \"" var "\"))")) - (else - (debug:print-error 0 *default-log-port* "#{get ...} used with only one parameter, \"" cmd "\", two needed.") - "(lambda (ht) #f)"))) - ((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 - exn - (begin - (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\", exn=" exn) - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - ;; (print "exn=" (condition->list exn)) - (set! result (conc "#{( " cmdtype ") " cmd "}, full expansion: " fullcmd))) - (if (or allow-system - (not (member cmdtype '("system" "shell" "sh")))) - (with-input-from-string fullcmd - (lambda () - (set! result ((eval (read)) ht)))) - (set! result (conc "#{(" cmdtype ") " cmd "}")))) - (case cmdsym - ((system shell scheme) - (let ((delta (- (current-seconds) start-time))) - (if (> delta 2) - (debug:print-info 2 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result) - (debug:print-info 9 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result))))) - (loop (conc prestr result poststr))) - res)) - res))) - -;; this was inline but I'm pretty sure that is a hold over from when it was *very* simple ... -;; -(define (configf:read-line p ht allow-processing settings) - (let loop ((inl (read-line p))) - (let ((cont-line (and (string? inl) - (not (string-null? inl)) - (equal? "\\" (string-take-right inl 1))))) - (if cont-line ;; last character is \ - (let ((nextl (read-line p))) - (if (not (eof-object? nextl)) - (loop (string-append (if cont-line - (string-take inl (- (string-length inl) 1)) - inl) - nextl)))) - (let ((res (case allow-processing ;; if (and allow-processing - ;; (not (eq? allow-processing 'return-string))) - ((#t #f) - (configf:process-line inl ht allow-processing)) - ((return-string) - inl) - (else - (configf:process-line inl ht allow-processing))))) - (if (and (string? res) ;; must set to "no" to force NOT trimming trailing spaces - (not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "yes") "no"))) - (string-substitute "\\s+$" "" res) - res)))))) - -;; read a config file, returns hash table of alists - -;; read a config file, returns hash table of alists -;; adds to ht if given (must be #f otherwise) -;; allow-system: -;; #f - do not evaluate [system -;; #t - immediately evaluate [system and store result as string -;; 'return-procs -- return a proc taking ht as an argument that may be evaulated at some future time -;; 'return-string -- return a string representing a proc taking ht as an argument that may be evaulated at some future time -;; envion-patt is a regex spec that identifies sections that will be eval'd -;; in the environment on the fly -;; sections: #f => get all, else list of sections to gather -;; post-section-procs alist of section-pattern => proc, where: (proc section-name next-section-name ht curr-path) -;; apply-wildcards: #t/#f - apply vars from targets with % wildcards to all matching sections -;; -(define (read-config path ht allow-system #!key (environ-patt #f) (curr-section #f) - (sections #f) (settings (make-hash-table)) (keep-filenames #f) - (post-section-procs '()) (apply-wildcards #t) ) - (debug:print 9 *default-log-port* "START: " path) -;; (if *configdat* -;; (common:save-pkt `((action . read-config) -;; (f . ,(cond ((string? path) path) -;; ((port? path) "port") -;; (else (conc path)))) -;; (T . configf)) -;; *configdat* #t add-only: #t)) - (if (and (not (port? path)) - (not (common:file-exists? path))) ;; for case where we are handed a port - (begin - (debug:print-info 1 *default-log-port* "read-config - file not found " path " current path: " (current-directory)) - ;; WARNING: This is a risky change but really, we should not return an empty hash table if no file read? - #f) ;; (if (not ht)(make-hash-table) ht)) - (let ((inp (if (string? path) - (open-input-file path) - path)) ;; we can be handed a port - (res (if (not ht)(make-hash-table) ht)) - (metapath (if (or (debug:debug-mode 9) - keep-filenames) - path #f)) - (process-wildcards (lambda (res curr-section-name) - (if (and apply-wildcards - (or (string-contains curr-section-name "%") ;; wildcard - (string-match "/.*/" curr-section-name))) ;; regex - (begin - (configf:apply-wildcards res curr-section-name) - (hash-table-delete! res curr-section-name)))))) ;; NOTE: if the section is a wild card it will be REMOVED from res - (let loop ((inl (configf:read-line inp res (calc-allow-system allow-system curr-section sections) settings)) ;; (read-line inp)) - (curr-section-name (if curr-section curr-section "default")) - (var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere - (lead #f)) - (debug:print-info 8 *default-log-port* "curr-section-name: " curr-section-name " var-flag: " var-flag "\n inl: \"" inl "\"") - (if (eof-object? inl) - (begin - ;; process last section for wildcards - (process-wildcards res curr-section-name) - (if (string? path) ;; we received a path, not a port, thus we are responsible for closing it. - (close-input-port inp)) - (if (list? sections) ;; delete all sections except given when sections is provided - (for-each - (lambda (section) - (if (not (member section sections)) - (hash-table-delete! res section))) ;; we are using "" as a dumping ground and must remove it before returning the ht - (hash-table-keys res))) - (debug:print 9 *default-log-port* "END: " path) - res - ) ;; retval - (regex-case - inl - (configf:comment-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) - curr-section-name #f #f)) - - (configf:blank-l-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) - curr-section-name #f #f)) - (configf:settings ( x setting val ) - (begin - (hash-table-set! settings setting val) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) - curr-section-name #f #f))) - - (configf:include-rx ( x include-file ) - (let* ((curr-conf-dir (pathname-directory path)) - (full-conf (if (and (absolute-pathname? include-file) (file-exists? include-file)) - include-file - (common:nice-path - (conc (if curr-conf-dir - curr-conf-dir - ".") - "/" include-file))))) - (let ((all-matches (sort (handle-exceptions exn - (begin - (debug:print '(2 9) *default-log-port* "glob of " full-conf " gave no match. , exn=" exn) - (list)) - (glob full-conf)) string<=?))) - (if (null? all-matches) - (begin - (debug:print '(2 9) #f "INFO: include file(s) matching " include-file " not found (called from " path ")") - (debug:print 2 *default-log-port* " " full-conf)) - (for-each - (lambda (fpath) - ;; (push-directory conf-dir) - (debug:print 9 *default-log-port* "Including: " full-conf) - (read-config fpath res allow-system environ-patt: environ-patt - curr-section: curr-section-name sections: sections settings: settings - keep-filenames: keep-filenames)) - all-matches)) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) - curr-section-name #f #f)))) - (configf:script-rx ( x include-script params);; handle-exceptions - ;; exn - ;; (begin - ;; (debug:print '(0 2 9) #f "INFO: include from script " include-script " failed.") - ;; (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) - (if (and (common:file-exists? include-script)(file-execute-access? include-script)) - (let* ((local-allow-system (calc-allow-system allow-system curr-section-name sections)) - (env-delta (configf:cfgdat->env-alist curr-section-name res local-allow-system)) - (new-inp-port - (common:with-env-vars - env-delta - (lambda () - (open-input-pipe (conc include-script " " params)))))) - (debug:print '(2 9) *default-log-port* "Including from script output: " include-script) - ;; (print "We got here, calling read-config next. Port is: " new-inp-port) - (read-config new-inp-port res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames) - (close-input-port new-inp-port) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) - (begin - (debug:print 0 *default-log-port* "Script not found or not exectutable: " include-script) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))) - ) ;; ) - (configf:section-rx ( x section-name ) - (begin - ;; call post-section-procs - (for-each - (lambda (dat) - (let ((patt (car dat)) - (proc (cdr dat))) - (if (string-match patt curr-section-name) - (proc curr-section-name section-name res path)))) - post-section-procs) - ;; after gathering the vars for a section and if apply-wildcards is true and if there is a wildcard in the section name process wildcards - ;; NOTE: we are processing the curr-section-name, NOT section-name. - (process-wildcards res curr-section-name) - (if (not (hash-table-ref/default res section-name #f))(hash-table-set! res section-name '())) ;; ensure that mere mention of a section is not lost - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) - ;; if we have the sections list then force all settings into "" and delete it later? - ;; (if (or (not sections) - ;; (member section-name sections)) - ;; section-name "") ;; stick everything into "". NOPE: We need new strategy. Put stuff in correct sections and then delete all sections later. - section-name - #f #f))) - (configf:key-sys-pr ( x key cmd ) - (if (calc-allow-system allow-system curr-section-name sections) - (let ((alist (hash-table-ref/default res curr-section-name '())) - (val-proc (lambda () - (let* ((start-time (current-seconds)) - (local-allow-system (calc-allow-system allow-system curr-section-name sections)) - (env-delta (configf:cfgdat->env-alist curr-section-name res local-allow-system)) - (cmdres (process:cmd-run->list cmd delta-env-alist-or-hash-table: env-delta)) ;; BB: here is where [system is exec'd. needs to have env from other vars! - (delta (- (current-seconds) start-time)) - (status (cadr cmdres)) - (res (car cmdres))) - (debug:print-info 4 *default-log-port* "" inl "\n => " (string-intersperse res "\n")) - (if (not (eq? status 0)) - (begin - (debug:print-error 0 *default-log-port* "problem with " inl ", return code " status - " output: " cmdres))) - (if (> delta 2) - (debug:print-info 0 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res) - (debug:print-info 9 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res)) - (if (null? res) - "" - (string-intersperse res " ")))))) - (hash-table-set! res curr-section-name - (configf:assoc-safe-add alist - key - (case (calc-allow-system allow-system curr-section-name sections) - ((return-procs) val-proc) - ((return-string) cmd) - (else (val-proc))) - metadata: metapath)) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) - (loop (configf:read-line inp res - (calc-allow-system allow-system curr-section-name sections) - settings) - curr-section-name #f #f))) - - (configf:key-no-val ( x key val) - (let* ((alist (hash-table-ref/default res curr-section-name '())) - (fval (or (if (string? val) val #f) ""))) ;; fval should be either "" or " " (one or more spaces) - (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = #t") - (safe-setenv key fval) - (hash-table-set! res curr-section-name - (configf:assoc-safe-add alist key fval metadata: metapath)) - (loop (configf:read-line inp res - (calc-allow-system allow-system curr-section-name sections) - settings) - curr-section-name key #f))) - - (configf:key-val-pr ( x key unk1 val unk2 ) - (let* ((alist (hash-table-ref/default res curr-section-name '())) - (envar (and environ-patt - (string-search (regexp environ-patt) curr-section-name) ;; does the section match the envionpatt? - (and (not (string-null? key)) - (not (equal? "!" (substring key 0 1)))) ;; ! as leading character is a signature to NOT export to the environment - ;; (string-match "^.*:.*:.*$" key) ;; ;; something:something:something reserved for triggers in runconfigs - )) - (realval (if envar - (configf:eval-string-in-environment val) - val))) - (debug:print-info 6 *default-log-port* "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name) - (if envar (safe-setenv key realval)) - (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = " val) - (hash-table-set! res curr-section-name - (configf:assoc-safe-add alist key realval metadata: metapath)) - (loop (configf:read-line inp res - (calc-allow-system allow-system curr-section-name sections) settings) - curr-section-name key #f))) - ;; 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 - (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))) - ;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag) - (hash-table-set! res curr-section-name - (configf:assoc-safe-add alist var-flag newval metadata: metapath)) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name var-flag (if lead lead whsp))) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))) - (else (debug:print-error 0 *default-log-port* "problem parsing " path ",\n \"" inl "\"") - (set! var-flag #f) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))) - ) ;; end loop - ))) - -(define (setup) - (let* ((configf (find-config "megatest.config")) - (config (if configf (read-config configf #f #t) #f))) - (if config - (setenv "RUN_AREA_HOME" (pathname-directory configf))) - config)) - -;;====================================================================== -;; refdb -;;====================================================================== - -;; reads a refdb into an assoc array of assoc arrays -;; returns (list dat msg) -(define (configf:read-refdb refdb-path) - (let ((sheets-file (conc refdb-path "/sheet-names.cfg"))) - (if (not (common:file-exists? sheets-file)) - (list #f (conc "ERROR: no refdb found at " refdb-path)) - (if (not (file-read-access? sheets-file)) - (list #f (conc "ERROR: refdb file not readable at " refdb-path)) - (let* ((sheets (with-input-from-file sheets-file - (lambda () - (let loop ((inl (read-line)) - (res '())) - (if (eof-object? inl) - (reverse res) - (loop (read-line)(cons inl res))))))) - (data '())) - (for-each - (lambda (sheet-name) - (let* ((dat-path (conc refdb-path "/" sheet-name ".dat")) - (ref-dat (configf:read-file dat-path #f #t)) - (ref-assoc (map (lambda (key) - (list key (hash-table-ref ref-dat key))) - (hash-table-keys ref-dat)))) - ;; (hash-table->alist ref-dat))) - ;; (set! data (append data (list (list sheet-name ref-assoc)))))) - (set! data (cons (list sheet-name ref-assoc) data)))) - sheets) - (list data "NO ERRORS")))))) - -;; redefines -(define config-lookup configf:lookup) -(define configf:read-file read-config) -(define shell configfmod#shell) - Index: configfmod.scm ================================================================== --- configfmod.scm +++ configfmod.scm @@ -25,11 +25,37 @@ (declare (uses mtargs)) (use regex regex-case) (module configfmod -* + ( + configf:map-all-hier-alist + configf:read-refdb + lookup + configf:lookup + get-section + configf:get-section + configf:lookup-number + read-config + runconfigs-get + configf:section-vars + configf:read-alist + configf:config->alist + configf:alist->config + configf:set-section-var + + find-and-read-config + common:args-get-target + configf:eval-string-in-environment + + read-config-set! + configf:read-file + + configf:system + configf:config->ini + shell + ) (import scheme chicken extras files @@ -203,10 +229,12 @@ (if match ;; (and match (list? match)(> (length match) 1)) (cadr match) #f)) )) #f)) + +(define lookup configf:lookup) ;; use to have definitive setting: ;; [foo] ;; var yes ;; @@ -234,10 +262,12 @@ '() (map car sectdat)))) (define (configf:get-section cfgdat section) (hash-table-ref/default cfgdat section '())) + +(define get-section configf:get-section) (define (configf:set-section-var cfgdat section var val) (let ((sectdat (configf:get-section cfgdat section))) (hash-table-set! cfgdat section (configf:assoc-safe-add sectdat var val)))) @@ -473,8 +503,44 @@ (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)))) + +;;====================================================================== +;; Lookup a value in runconfigs based on -reqtarg or -target +;; +(define (runconfigs-get config var) + (let ((targ (common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET")))) + (if targ + (or (configf:lookup config targ var) + (configf:lookup config "default" var)) + (configf:lookup config "default" var)))) + +(define (common:args-get-target #!key (split #f)(exit-if-bad #f)) + (let* ((keys (if (hash-table? *configdat*) (common:get-fields *configdat*) '())) + (numkeys (length keys)) + (target (or (args:get-arg "-reqtarg") + (args:get-arg "-target") + (getenv "MT_TARGET"))) + (tlist (if target (string-split target "/" #t) '())) + (valid (if target + (or (null? keys) ;; probably don't know our keys yet + (and (not (null? tlist)) + (eq? numkeys (length tlist)) + (null? (filter string-null? tlist)))) + #f))) + (if valid + (if split + tlist + target) + (if target + (begin + (debug:print-error 0 *default-log-port* "Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements") + (if exit-if-bad (exit 1)) + #f) + #f)))) + +(include "configf-guts.scm") ) Index: configure ================================================================== --- configure +++ configure @@ -15,87 +15,91 @@ # 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 . -# Configure the build - -if [[ "$1"x == "x" ]];then - PREFIX=$PWD -else - PREFIX=$1 -fi - - -#====================================================================== -# Configure stuff needed for eggs -#====================================================================== - -function configure_dependencies () { - - #====================================================================== - # libnanomsg - #====================================================================== - - if [[ ! $(ls /usr/lib/*/libnanomsg*) ]];then - echo "libnanomsg build needed." - echo "BUILD_NANOMSG=yes" >> makefile.inc - fi - - #====================================================================== - # postgresql libraries - #====================================================================== - - if [[ ! $(ls /usr/lib/*/libpq.*) ]];then - echo "Postgresql build needed." - echo "BUILD_POSTGRES=yes" >> makefile.inc - fi - - if [[ ! $(ls /usr/lib/*/libsqlite3.*) ]];then - echo "Sqlite3 build needed." - echo "BUILD_SQLITE3=yes" >> makefile.inc - fi - -} - -#====================================================================== -# Initialize makefile.inc -#====================================================================== - -echo "" > makefile.inc - -#====================================================================== -# Do we need Chicken? -#====================================================================== - -if [[ -e /usr/bin/sw_vers ]]; then - ARCHSTR=$(/usr/bin/sw_vers -productVersion) -else - ARCHSTR=$(lsb_release -sr) -fi - -echo "CHICKEN_PREFIX=$PREFIX/.$ARCHSTR" >> makefile.inc -CHICKEN_PREFIX=$PREFIX/bin/.$ARCHSTR - -if [[ ! $(type csi) ]];then - echo "Chicken build needed." - echo "BUILD_CHICKEN=yes" >> makefile.inc - configure_dependencies - echo "include chicken.makefile" >> makefile.inc -else - echo "CSIPATH=$(which csi)" >> makefile.inc - CSIPATH=$(which csi) - echo "CKPATH=$(dirname $(dirname $CSIPATH))" >> makefile.inc -fi - -# Make setup scripts -echo "#!/bin/bash" > setup.sh -echo "export PATH=$CHICKEN_PREFIX/bin:\$PATH" >> setup.sh -echo "export LD_LIBRARY_PATH=$CHICKEN_PREFIX/lib" >> setup.sh -echo 'exec "$@"' >> setup.sh -chmod a+x setup.sh - -echo "setenv PATH $CHICKEN_PREFIX/bin:\$PATH" > setup.csh -echo "setenv LD_LIBRARY_PATH $CHICKEN_PREFIX/lib" >> setup.csh - -echo "All done creating makefile.inc, feel free to edit it!" -echo "run \"setup.sh bash\" or source setup.csh to get PATH and LD_LIBRARY_PATH adjusted" + + + +# # Configure the build +# +# if [[ "$1"x == "x" ]];then +# PREFIX=$PWD +# else +# PREFIX=$1 +# fi +# +# +# #====================================================================== +# # Configure stuff needed for eggs +# #====================================================================== +# +# function configure_dependencies () { +# +# #====================================================================== +# # libnanomsg +# #====================================================================== +# +# if [[ ! $(ls /usr/lib/*/libnanomsg*) ]];then +# echo "libnanomsg build needed." +# echo "BUILD_NANOMSG=yes" >> makefile.inc +# fi +# +# #====================================================================== +# # postgresql libraries +# #====================================================================== +# +# if [[ ! $(ls /usr/lib/*/libpq.*) ]];then +# echo "Postgresql build needed." +# echo "BUILD_POSTGRES=yes" >> makefile.inc +# fi +# +# if [[ ! $(ls /usr/lib/*/libsqlite3.*) ]];then +# echo "Sqlite3 build needed." +# echo "BUILD_SQLITE3=yes" >> makefile.inc +# fi +# +# } +# +# #====================================================================== +# # Initialize makefile.inc +# #====================================================================== +# +# echo "" > makefile.inc +# +# #====================================================================== +# # Do we need Chicken? +# #====================================================================== +# +# if [[ -e /usr/bin/sw_vers ]]; then +# ARCHSTR=$(/usr/bin/sw_vers -productVersion) +# else +# ARCHSTR=$(lsb_release -sr) +# fi +# +# echo "CHICKEN_PREFIX=$PREFIX/.$ARCHSTR" >> makefile.inc +# CHICKEN_PREFIX=$PREFIX/bin/.$ARCHSTR +# +# if [[ ! $(type csi) ]];then +# echo "Chicken build needed." +# echo "BUILD_CHICKEN=yes" >> makefile.inc +# configure_dependencies +# echo "include chicken.makefile" >> makefile.inc +# else +# echo "CSIPATH=$(which csi)" >> makefile.inc +# CSIPATH=$(which csi) +# echo "CKPATH=$(dirname $(dirname $CSIPATH))" >> makefile.inc +# fi +# +# # Make setup scripts +# echo "#!/bin/bash" > setup.sh +# echo "export PATH=$CHICKEN_PREFIX/bin:\$PATH" >> setup.sh +# echo "export LD_LIBRARY_PATH=$CHICKEN_PREFIX/lib" >> setup.sh +# echo 'exec "$@"' >> setup.sh +# chmod a+x setup.sh +# +# echo "setenv PATH $CHICKEN_PREFIX/bin:\$PATH" > setup.csh +# echo "setenv LD_LIBRARY_PATH $CHICKEN_PREFIX/lib" >> setup.csh +# +# echo "All done creating makefile.inc, feel free to edit it!" +# echo "run \"setup.sh bash\" or source setup.csh to get PATH and LD_LIBRARY_PATH adjusted" +# Index: cpumod.scm ================================================================== --- cpumod.scm +++ cpumod.scm @@ -29,11 +29,12 @@ (declare (uses mtargs)) (use srfi-69) (module cpumod - * + () + (import scheme) (cond-expand (chicken-4 DELETED dashboard-context-menu.scm Index: dashboard-context-menu.scm ================================================================== --- dashboard-context-menu.scm +++ /dev/null @@ -1,363 +0,0 @@ -;;====================================================================== -;; Copyright 2006-2012, 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 . - -;;====================================================================== - -;;====================================================================== -;; implementation of context menu that pops up on -;; right click on test cell in Runs & Runs Summary Tabs -;;====================================================================== - -(declare (unit dashboard-context-menu)) -(declare (uses common)) -(declare (uses commonmod)) -(declare (uses configfmod)) -(declare (uses gutils)) -(declare (uses rmtmod)) -(declare (uses ezsteps)) -;; (declare (uses sdb)) -;; (declare (uses filedb)) -(declare (uses subrun)) -(declare (uses testsmod)) -(declare (uses subrunmod)) -(declare (uses megatestmod)) - -(use format fmt) -(require-library iup) -(import (prefix iup iup:)) - -(use canvas-draw) - -(use srfi-1 posix regex regex-case srfi-69) -(use (prefix sqlite3 sqlite3:)) - -(include "common_records.scm") -;; (include "db_records.scm") -(include "run_records.scm") - -(import commonmod - configfmod - rmtmod - testsmod - subrunmod - debugprint - megatestmod - ) - -(define (dboard:launch-testpanel run-id test-id) - (let* ((dboardexe (common:find-local-megatest "dashboard")) - (cmd (conc dboardexe - " -test " run-id "," test-id - " &"))) - (system cmd))) - - -(define (dashboard:run-menu-items run-id test-id target runname test-name testpatt item-test-path test-info) - (list - (iup:menu-item - (conc "Rerun " testpatt) - #:action - (lambda (obj) - ;; (print " run-id: " run-id " test-id: " test-id " target: " target " runname: " runname " test-name: " test-name " testpatt: " testpatt "item-path : " item-path) - (common:run-a-command - (conc "megatest -run -target " target - " -runname " runname - " -testpatt " testpatt - " -preclean -clean-cache") - ))) - (iup:menu-item - "Rerun Complete Run" - #:action - (lambda (obj) - (common:run-a-command - (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target - " -runname " runname - " -testpatt % " - " -preclean -clean-cache")))) - (iup:menu-item - "Clean Complete Run" - #:action - (lambda (obj) - (common:run-a-command - (conc "megatest -remove-runs -target " target - " -runname " runname - " -testpatt % ")))) - (iup:menu-item - "Kill Complete Run" - #:action - (lambda (obj) - (common:run-a-command - (conc "megatest -set-state-status KILLREQ,n/a -target " target - " -runname " runname - " -testpatt % " - " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED")))) - (iup:menu-item - "Delete Run Data" - #:action - (lambda (obj) - (common:run-a-command - (conc "megatest -remove-runs -target " target - " -runname " runname - " -testpatt % " - " -keep-records")))))) - -(define (dashboard:test-menu-items run-id test-id target runname test-name testpatt item-test-path test-info) - (list - (iup:menu-item - (conc "Rerun " item-test-path) - #:action - (lambda (obj) - (common:run-a-command - (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target - " -runname " runname - " -testpatt " item-test-path - " -preclean -clean-cache")))) - (iup:menu-item - (conc "Kill " item-test-path) - #:action - (lambda (obj) - ;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f) - (common:run-a-command - (conc "megatest -set-state-status KILLREQ,n/a -target " target - " -runname " runname - " -testpatt " item-test-path - " -state RUNNING,REMOTEHOSTSTART,LAUNCHED")))) - (iup:menu-item - (conc "Delete data : " item-test-path) - #:action - (lambda (obj) - (common:run-a-command - (conc "megatest -remove-runs -target " target - " -runname " runname - " -testpatt " item-test-path - " -keep-records")))) - (iup:menu-item - (conc "Clean "item-test-path) - #:action - (lambda (obj) - (common:run-a-command - (conc "megatest -remove-runs -target " target - " -runname " runname - " -testpatt " item-test-path)))) - (iup:menu-item - "Start xterm" - #:action - (lambda (obj) - (dcommon:examine-xterm run-id test-id))) - ;;(let* ((cmd (conc (car (argv)) " -xterm " run-id "," test-id "&"))) - ;; (system cmd)))) - (iup:menu-item - "Edit testconfig" - #:action - (lambda (obj) - (let* ((all-tests (tests:get-all)) - (editor-rx (or (configf:lookup *configdat* "setup" "editor-regex") - "\\b(vim?|nano|pico)\\b")) - (editor (or (configf:lookup *configdat* "setup" "editor") - (get-environment-variable "VISUAL") - (get-environment-variable "EDITOR") "vi")) - (tconfig (conc (hash-table-ref all-tests test-name) "/testconfig")) - (cmd (conc (if (string-search editor-rx editor) - (conc "xterm -e " editor) - editor) - " " tconfig " &"))) - (system cmd)))))) - -(define (dashboard:step-logs-menu-item run-id test-id target runname test-name testpatt item-test-path test-info) - (let* ((steps (tests:get-compressed-steps run-id test-id)) ;; # - (rundir (db:test-get-rundir test-info))) - - (iup:menu-item - "Step logs" - (apply iup:menu - (map (lambda (step) - (let ((stepname (vector-ref step 0)) - (logfile (vector-ref step 5)) - (status (vector-ref step 3))) - (iup:menu-item - (conc stepname "/" (if (string=? logfile "") "no log!" logfile) " (" status ")") - #:action (lambda (obj) - (let ((fullfile (conc rundir "/" logfile))) - (if (common:file-exists? fullfile) - (dcommon:run-html-viewer fullfile) - (message-window (conc "file " fullfile " not found")))))))) - steps))))) - -(define (dashboard:toplevel-menu-items run-id test-id target runname test-name testpatt item-test-path test-info) - (list - - (iup:menu-item - "Test Control Panel" - #:action - (lambda (obj) - (dboard:launch-testpanel run-id test-id))) - - (dashboard:step-logs-menu-item run-id test-id target runname test-name testpatt item-test-path test-info) - - (iup:menu-item - (conc "Rerun " item-test-path) - #:action - (lambda (obj) - (common:run-a-command - (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target - " -runname " runname - " -testpatt " item-test-path - " -preclean -clean-cache")))) - - (iup:menu-item - "Start xterm" - #:action - (lambda (obj) - (dcommon:examine-xterm run-id test-id))) - - (iup:menu-item - (conc "Kill " item-test-path) - #:action - (lambda (obj) - ;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f) - (common:run-a-command - (conc "megatest -set-state-status KILLREQ,n/a -target " target - " -runname " runname - " -testpatt " item-test-path - " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED")))) - - (let* ((rundir (db:test-get-rundir test-info)) - (has-subrun (subrun:subrun-test-initialized? rundir))) - (if has-subrun - (iup:menu-item - "Launch subrun dashboard" - #:action - (lambda (obj) - (subrun:launch-dashboard rundir))) - (iup:vbox))) - - (iup:menu-item - (conc "View Log " item-test-path) - #:action - (lambda (obj) - (let* ((rundir (db:test-get-rundir test-info)) - (logf (db:test-get-final_logf test-info)) - (fullfile (conc rundir "/" logf))) - (if (common:file-exists? fullfile) - (dcommon:run-html-viewer fullfile) - (message-window (conc "file " fullfile " not found."))))) - ) - )) -;; example section for megatest.config: -;; -;; -;; [custom-context-menu-items] -;; # : -;; item1 custom show run-id (%run-id%):echo "%run-id%" -;; item2 custom show test-id (%test-id%):echo "%test-id%" -;; item3 custom show target (%target%):echo "%target%" -;; item4 custom show test-name (%test-name%):echo "%test-name%" -;; item5 custom show test-patt (%test-patt%):echo "%test-patt%" -;; item6 custom show test-run-dir (%test-run-dir%):echo "%test-run-dir%" -;; item7 custom show run-area-home (%run-area-home%):echo "%run-area-home%" -;; item8 custom show megatest root (%mt-root%):echo "%mt-root%" -;; item9 custom ls : ls -lrt -;; item10 custom see $MT_RUN_AREA_HOME (not yet implemented) : echo $MT_RUN_AREA_HOME - -(define (dashboard:custom-menu-items run-id test-id target run-name test-name testpatt item-test-path test-info) - (let* ((vars (configf:section-vars *configdat* "custom-context-menu-items")) - (item-path (db:test-get-item-path test-info)) - (mt-root (pathname-directory (pathname-directory *common:this-exe-dir* )))) - (filter-map - (lambda (var) - (let* ((val (configf:lookup *configdat* "custom-context-menu-items" var)) - (m (string-match "^\\s*([^:]+?)\\s*:\\s*(.*?)\\s*$" val))) - (if m - (let* ((menu-item-text-raw (list-ref m 1)) - (command-line-raw (list-ref m 2)) - (subst-alist ;; template vars - `(( "%run-id%" . ,run-id ) - ( "%test-id%" . ,test-id ) - ( "%target%" . ,target ) - ( "%test-name%" . ,test-name) - ( "%test-patt%" . ,testpatt) - ( "%test-run-dir%" . ,(db:test-get-rundir test-info)) - ( "%mt-root%" . ,mt-root) - ( "%run-name%" . ,run-name) - ( "%run-area-home%" . ,*toppath*) - ( "%item-path%" . ,item-path) - ( "%item-test-patt%" . ,item-test-path ))) - (command-line ;; replace template vars - (foldr - (lambda (x i) - (string-substitute - (car x) - (->string (cdr x)) - i - #t)) - command-line-raw - subst-alist)) - (menu-item-text ;; replace template vars - (foldr - (lambda (x i) - (string-substitute - (car x) - (->string (cdr x)) - i - #t)) - menu-item-text-raw - subst-alist))) - (iup:menu-item - (conc "*"menu-item-text) - #:action - (lambda (obj) - - (let* ((scheme-match (string-match "^#(\\(.*)" command-line))) - ;;(BB> "cmdline is >"command-line"<") - (common:with-env-vars - ;; TODO: with-env-vars - ;; TODO: with-env-vars MT_* - (runs:get-mt-env-alist run-id run-name target test-name item-path) - - (lambda () - (if scheme-match - (begin - (handle-exceptions - exn - (debug:print 0 *default-log-port* "error with custom menu scheme, exn=" exn) - (begin - ;;(BB> "gonna eval it!") - (eval (with-input-from-string (cadr scheme-match) read))))) - (common:run-a-command command-line with-vars: #t)))))))) - #f))) - vars))) - -(define (dashboard:context-menu run-id test-id target runname test-name testpatt item-test-path test-info) - (let* ((run-menu-items - (dashboard:run-menu-items run-id test-id target runname test-name testpatt item-test-path test-info)) - (test-menu-items - (dashboard:test-menu-items run-id test-id target runname test-name testpatt item-test-path test-info)) - (custom-menu-items - (dashboard:custom-menu-items run-id test-id target runname test-name testpatt item-test-path test-info)) - (toplevel-menu-items - (dashboard:toplevel-menu-items run-id test-id target runname test-name testpatt item-test-path test-info)) - ) - (apply iup:menu - `(,@toplevel-menu-items - ,(iup:menu-item - "Run" - (apply iup:menu run-menu-items)) - ,(iup:menu-item - "Test" - (apply iup:menu test-menu-items)) - ,@custom-menu-items)))) Index: dashboard-guimonitor.scm ================================================================== --- dashboard-guimonitor.scm +++ dashboard-guimonitor.scm @@ -30,16 +30,16 @@ (use sqlite3 srfi-1 posix regex regex-case srfi-69) (import (prefix sqlite3 sqlite3:)) (declare (unit dashboard-guimonitor)) -(declare (uses common)) +;; (declare (uses common)) (declare (uses keys)) (declare (uses commonmod)) (import commonmod) -(include "common_records.scm") +;; (include "common_records.scm") ;; (include "db_records.scm") (include "run_records.scm") (include "task_records.scm") (define (control-panel db tdb keys) DELETED dashboard-tests.scm Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ /dev/null @@ -1,980 +0,0 @@ -;;====================================================================== -;; Copyright 2006-2012, 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 . - -;;====================================================================== - -;;====================================================================== -;; Test info panel -;;====================================================================== - -(declare (unit dashboard-tests)) -(declare (uses common)) -(declare (uses commonmod)) -(declare (uses configfmod)) -(declare (uses debugprint)) -(declare (uses rmtmod)) -(declare (uses megatestmod)) -(declare (uses dbmod)) -(declare (uses dbfile)) -(declare (uses tasksmod)) -(declare (uses testsmod)) - -(declare (uses dcommon)) -(declare (uses gutils)) -(declare (uses ezsteps)) -(declare (uses subrun)) -(declare (uses runsmod)) -(declare (uses subrunmod)) - -(use format fmt) -(require-library iup) -(import (prefix iup iup:)) - -(use canvas-draw) - -(use srfi-1 posix regex regex-case srfi-69) -(use (prefix sqlite3 sqlite3:)) - -(import commonmod - configfmod - rmtmod - debugprint - megatestmod - dbmod - dbfile - tasksmod - testsmod - runsmod - subrunmod - ) - -(include "common_records.scm") -;; (include "db_records.scm") -(include "run_records.scm") - -;;====================================================================== -;; 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)) - (cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command"))) - (or cfg-ovrd default-override default-pre-command))) ;; "xterm -geometry 180x20 -e \"")) - - -(define (dtests:get-post-command #!key (default-override #f)) - (let* ((orig-post-command (conc "';xterm -geometry 180x20 -e \"(echo; echo -n START:;date +ww%U.%w-$H:%M:%S;echo;echo $CMD;echo;$CMD)|&" - "tee -a runlog-`date +ww%U.%w-%H:%M`.log;echo Press any key to continue;bash -c 'read -n 1 -s'\" &")) - (viewscreen-post-command "") - (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen")) - (default-post-command (if use-viewscreen viewscreen-post-command orig-post-command)) - (cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command"))) - (or cfg-ovrd default-override default-post-command))) ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) - - -(define (test-info-panel testdat store-label widgets) - (iup:frame - #:title "Test Info" ; #:expand "YES" - (iup:hbox ; #:expand "YES" - (apply iup:vbox ; #:expand "YES" - (append (map (lambda (val) - (iup:label val ; #:expand "HORIZONTAL" - )) - (list "Testname: " - "Item path: " - "Current state: " - "Current status: " - "Test comment: " - "Test id: " - "Test date: ")) - (list (iup:label "" #:expand "VERTICAL")))) - (apply iup:vbox ; #:expand "YES" - (list - (store-label "testname" - (iup:label (db:test-get-testname testdat) #:expand "HORIZONTAL") - (lambda (testdat)(db:test-get-testname testdat))) - (store-label "item-path" - (iup:label (db:test-get-item-path testdat) #:expand "HORIZONTAL") - (lambda (testdat)(db:test-get-item-path testdat))) - (store-label "teststate" - (iup:label (db:test-get-state testdat) #:expand "HORIZONTAL") - (lambda (testdat) - (db:test-get-state testdat))) - (let ((lbl (iup:label (db:test-get-status testdat) #:expand "HORIZONTAL"))) - (hash-table-set! widgets "teststatus" - (lambda (testdat) - (let ((newstatus (db:test-get-status testdat)) - (oldstatus (iup:attribute lbl "TITLE"))) - (if (not (equal? oldstatus newstatus)) - (begin - (iup:attribute-set! lbl "FGCOLOR" (car (gutils:get-color-for-state-status (db:test-get-state testdat) - (db:test-get-status testdat)))) - (iup:attribute-set! lbl "TITLE" (db:test-get-status testdat))))))) - lbl) - (store-label "testcomment" - (iup:label "TestComment " - #:expand "HORIZONTAL") - (lambda (testdat) - (let ((newcomment (db:test-get-comment testdat))) - (if *dashboard-comment-share-slot* - (if (not (equal? (iup:attribute *dashboard-comment-share-slot* "VALUE") - newcomment)) - (iup:attribute-set! *dashboard-comment-share-slot* - "VALUE" - newcomment))) - newcomment))) - (store-label "testid" - (iup:label "TestId " - #:expand "HORIZONTAL") - (lambda (testdat) - (db:test-get-id testdat))) - (store-label "testdate" - (iup:label "TestDate " - #:expand "HORIZONTAL") - (lambda (testdat) - (seconds->work-week/day-time (db:test-get-event_time testdat)))) - ))))) - -;;====================================================================== -;; Test meta panel -;;====================================================================== - -(define (test-meta-panel-get-description testmeta) - (fmt #f (with-width 40 (wrap-lines (db:testmeta-get-description testmeta))))) - -(define (test-meta-panel testmeta store-meta) - (iup:frame - #:title "Test Meta Data" ; #:expand "YES" - (iup:hbox ; #:expand "YES" - (apply iup:vbox ; #:expand "YES" - (append (map (lambda (val) - (iup:label val ; #:expand "HORIZONTAL" - )) - (list "Author: " - "Owner: " - "Reviewed: " - "Tags: " - "Description: ")) - (list (iup:label "" #:expand "VERTICAL")))) - (apply iup:vbox ; #:expand "YES" - (list - (store-meta "author" - (iup:label (db:testmeta-get-author testmeta) #:expand "HORIZONTAL") - (lambda (testmeta)(db:testmeta-get-author testmeta))) - (store-meta "owner" - (iup:label (db:testmeta-get-owner testmeta) #:expand "HORIZONTAL") - (lambda (testmeta)(db:testmeta-get-owner testmeta))) - (store-meta "reviewed" - (iup:label (db:testmeta-get-reviewed testmeta) #:expand "HORIZONTAL") - (lambda (testmeta)(db:testmeta-get-reviewed testmeta))) - (store-meta "tags" - (iup:label (db:testmeta-get-tags testmeta) #:expand "HORIZONTAL") - (lambda (testmeta)(db:testmeta-get-tags testmeta))) - (store-meta "description" - (iup:label (test-meta-panel-get-description testmeta) #:size "x50"); #:expand "HORIZONTAL") - (lambda (testmeta) - (test-meta-panel-get-description testmeta))) - ))))) - - -;;====================================================================== -;; Run info panel -;;====================================================================== -(define (run-info-panel db keydat testdat runname) - (let* ((run-id (db:test-get-run_id testdat)) - (rundat (rmt:get-run-info run-id)) - (header (db:get-header rundat)) - (event_time (db:get-value-by-header (db:get-rows rundat) - (db:get-header rundat) - "event_time"))) - (iup:frame - #:title "Megatest Run Info" ; #:expand "YES" - (iup:hbox ; #:expand "YES" - (apply iup:vbox ; #:expand "YES" - (append (map (lambda (keyval) - (iup:label (conc (car keyval) " "))) - keydat) - (list (iup:label "runname ") - (iup:label "run-id") - (iup:label "run-date")))) - (apply iup:vbox - (append (map (lambda (keyval) - (iup:label (cadr keyval) #:expand "HORIZONTAL")) - keydat) - (list (iup:label runname) - (iup:label (conc run-id)) - (iup:label (seconds->year-work-week/day-time event_time)) - (iup:label "" #:expand "VERTICAL")))))))) - -;;====================================================================== -;; Host info panel -;;====================================================================== -(define (host-info-panel testdat store-label) - (iup:frame - #:title "Remote host and Test Run Info" ; #:expand "YES" - (iup:hbox ; #:expand "YES" - (apply iup:vbox ; #:expand "YES" ;; The heading labels - (append (map (lambda (val) - (iup:label val ; #:expand "HORIZONTAL" - )) - (list "Hostname: " - "Disk free: " - "CPU Load: " - "Run duration: " - "Logfile: " - "Top process id: " - "Uname -a: ")) - (iup:label "" #:expand "VERTICAL"))) - (apply iup:vbox ; #:expand "YES" - (list - ;; NOTE: Yes, the host can change! - (store-label "HostName" - (iup:label ;; (sdb:qry 'getstr - (db:test-get-host testdat) ;; ) - #:expand "HORIZONTAL") - (lambda (testdat)(db:test-get-host testdat))) - (store-label "DiskFree" - (iup:label (conc (db:test-get-diskfree testdat)) #:expand "HORIZONTAL") - (lambda (testdat)(conc (db:test-get-diskfree testdat)))) - (store-label "CPULoad" - (iup:label (conc (db:test-get-cpuload testdat)) #:expand "HORIZONTAL") - (lambda (testdat)(conc (db:test-get-cpuload testdat)))) - (store-label "RunDuration" - (iup:label (conc (seconds->hr-min-sec (db:test-get-run_duration testdat))) #:expand "HORIZONTAL") - (lambda (testdat)(conc (seconds->hr-min-sec (db:test-get-run_duration testdat))))) - (store-label "LogFile" - (iup:label (conc (db:test-get-final_logf testdat)) #:expand "HORIZONTAL") - (lambda (testdat)(conc (db:test-get-final_logf testdat)))) - (store-label "ProcessId" - (iup:label (conc (db:test-get-process_id testdat)) #:expand "HORIZONTAL") - (lambda (testdat)(conc (db:test-get-process_id testdat)))) - (store-label "Uname" - (iup:label " " #:expand "HORIZONTAL") ;; #:wordwrap "YES") - (lambda (testdat) ;; (sdb:qry 'getstr - (db:test-get-uname testdat))) ;; ) - ))))) - -;; if there is a submegatest create a button to launch dashboard in that area -;; -(define (submegatest-panel dbstruct keydat testdat runname testconfig) - (let* ((test-run-dir (db:test-get-rundir testdat)) - (subarea (subrun:get-runarea test-run-dir)) - (area-exists (and subarea (common:file-exists? subarea silent: #t)))) - (if subarea - (iup:frame - #:title "Megatest Run Info" ; #:expand "YES" - (iup:button - "Launch Dashboard" - #:action (lambda (obj) - (subrun:launch-dashboard test-run-dir)))) - (iup:vbox)))) - -;; use a global for setting the buttons colors -;; state status teststeps -(define *state-status* (vector #f #f #f)) -(define (update-state-status-buttons testdat) - (let* ((state (db:test-get-state testdat)) - (status (db:test-get-status testdat)) - (color (car (gutils:get-color-for-state-status state status)))) - ((vector-ref *state-status* 0) state color) - ((vector-ref *state-status* 1) status color))) - -(define *dashboard-test-db* #t) -(define *dashboard-comment-share-slot* #f) - -;;====================================================================== -;; Set fields -;;====================================================================== -(define (set-fields-panel dbstruct run-id test-id testdat #!key (db #f)) - (let ((newcomment #f) - (newstatus #f) - (newstate #f) - (wtxtbox #f)) - (iup:frame - #:title "Set fields" - (iup:vbox - (iup:hbox (iup:label "Comment:") - (let ((txtbox (iup:textbox #:action (lambda (val a b) - ;; (rmt:test-set-state-status-by-id run-id test-id #f #f b) - (rmt:test-set-state-status run-id test-id #f #f b) - ;; IDEA: Just set a variable with the proc to call? - ;; (rmt:test-set-state-status-by-id run-id test-id #f #f b) - (set! newcomment b)) - #:value (db:test-get-comment testdat) - #:expand "HORIZONTAL"))) - (set! wtxtbox txtbox) - txtbox)) - - (apply iup:hbox - (iup:label "STATE:" #:size "30x") - (let* ((btns (map (lambda (state) - (let ((btn (iup:button state - #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" - #:action (lambda (x) - ;; (rmt:test-set-state-status-by-id run-id test-id state #f #f) - (rmt:set-state-status-and-roll-up-items run-id test-id #f state #f #f) ;; test-name passed in as test-id is respected - (db:test-set-state! testdat state))))) - btn)) - (map cadr *common:std-states*)))) ;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ")))) - (vector-set! *state-status* 0 - (lambda (state color) - (for-each - (lambda (btn) - (let* ((name (iup:attribute btn "TITLE")) - (newcolor (if (equal? name state) color "192 192 192"))) - (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR"))) - (iup:attribute-set! btn "BGCOLOR" newcolor)))) - btns))) - btns)) - (apply iup:hbox - (iup:label "STATUS:" #:size "30x") - (let* ((btns (map (lambda (status) - (let ((btn (iup:button status - #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" - #:action (lambda (x) - (let ((t (iup:attribute x "TITLE"))) - (if (equal? t "WAIVED") - (iup:show (dashboard-tests:waiver run-id testdat - (if wtxtbox (iup:attribute wtxtbox "VALUE") #f) - (lambda (c) - (set! newcomment c) - (if wtxtbox - (begin - (iup:attribute-set! wtxtbox "VALUE" c) - (if (not *dashboard-comment-share-slot*) - (set! *dashboard-comment-share-slot* wtxtbox))) - )))) - (begin - ;; (rmt:test-set-state-status-by-id run-id test-id #f status #f) - (rmt:set-state-status-and-roll-up-items run-id test-id #f #f status #f) ;; test-name passed in as test-id is respected - (db:test-set-status! testdat status)))))))) - btn)) - (map cadr *common:std-statuses*)))) ;; (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP")))) - (vector-set! *state-status* 1 - (lambda (status color) - (for-each - (lambda (btn) - (let* ((name (iup:attribute btn "TITLE")) - (newcolor (if (equal? name status) color "192 192 192"))) - (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR"))) - (iup:attribute-set! btn "BGCOLOR" newcolor)))) - btns))) - btns)))))) - -(define (dashboard-tests:run-a-step info) - #t) - -;; (define (dashboard-tests:step-run-control testdat stepname testconfig) -;; (let* ((mutex (make-mutex))) -;; (letrec ((dlg -;; (iup:dialog ;; #:close_cb (lambda (a)(exit)) ; #:expand "YES" -;; #:title stepname -;; (iup:vbox ; #:expand "YES" -;; (iup:label (conc "Step: " stepname "\nNB// These buttons only run the test step\nfor the purpose of debugging.\nNot all database updates are done.")) -;; (iup:button "Re-run" -;; #:expand "HORIZONTAL" -;; #:action (lambda (obj) -;; (debug:catch-and-dump (lambda () -;; (thread-start! -;; (make-thread -;; (lambda () -;; (print "BB> started ezsteps:run-from") -;; (debug:catch-and-dump -;; (lambda () -;; (ezsteps:run-from testdat stepname #t)) -;; "dashboard-tests:step-run-control -> ezstep:run-from (1)") -;; (print "BB> done ezsteps:run-from") -;; 'foo) -;; (conc "ezstep run single step " stepname))) -;; ) -;; "step-run-control action"))) -;; (iup:button "Re-run and continue" -;; #:expand "HORIZONTAL" -;; #:action (lambda (obj) -;; (debug:catch-and-dump -;; (lambda () -;; (thread-start! -;; (make-thread (lambda () -;; (ezsteps:run-from testdat stepname #f)) -;; (conc "ezstep run from step " stepname)))) -;; "dashboard-tests:step-run-control -> ezstep:run-from (2)"))) -;; (iup:button "Close" -;; #:action (lambda (obj) -;; (iup:destroy! dlg))) -;; ;; (iup:button "Refresh test data" -;; ;; #:expand "HORIZONTAL" -;; ;; #:action (lambda (obj) -;; ;; (print "Refresh test data " stepname)) -;; )))) -;; dlg))) - -(define (dashboard-tests:waiver run-id testdat ovrdval cmtcmd) - (let* ((wpatt (configf:lookup *configdat* "setup" "waivercommentpatt")) - (wregx (if (string? wpatt)(regexp wpatt) #f)) - (wmesg (iup:label (if wpatt (conc "Comment must match pattern " wpatt) ""))) - (comnt (iup:textbox #:action (lambda (val a b) - (if wpatt - (if (string-match wregx b) - (iup:attribute-set! wmesg "TITLE" (conc "Comment matches " wpatt)) - (iup:attribute-set! wmesg "TITLE" (conc "Comment does not match " wpatt)) - ))) - #:value (if ovrdval ovrdval (db:test-get-comment testdat)) - #:expand "HORIZONTAL")) - (dlog #f)) - (set! dlog (iup:dialog ;; #:close_cb (lambda (a)(exit)) ; #:expand "YES" - #:title "SET WAIVER" - (iup:vbox ; #:expand "YES" - (iup:label (conc "Enter justification for waiving test " - (db:test-get-testname testdat) - (if (equal? (db:test-get-item-path testdat) "") - "" - (conc "/" (db:test-get-item-path testdat))))) - wmesg ;; the informational msg on whether it matches - comnt - (iup:hbox - (iup:button "Apply and Close " - #:expand "HORIZONTAL" - #:action (lambda (obj) - (let ((comment (iup:attribute comnt "VALUE")) - (test-id (db:test-get-id testdat))) - (if (or (not wpatt) - (string-match wregx comment)) - (begin - ;; (rmt:test-set-state-status-by-id run-id test-id #f "WAIVED" comment) - (rmt:test-set-state-status run-id test-id #f "WAIVED" comment) - (db:test-set-status! testdat "WAIVED") - (cmtcmd comment) - (iup:destroy! dlog)))))) - (iup:button "Cancel" - #:expand "HORIZONTAL" - #:action (lambda (obj) - (iup:destroy! dlog))))))) - dlog)) - - -;;====================================================================== -;; -;;====================================================================== -(define (dashboard-tests:examine-test run-id test-id) ;; run-id run-key origtest) - (let* ((db-path (common:make-tmpdir-name *toppath* "")) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db")) - (dbstruct #f) ;; NOT USED - (testdat (rmt:get-test-info-by-id run-id test-id)) ;; (db:get-test-info-by-id dbstruct run-id test-id)) - (db-mod-time 0) ;; (file-modification-time db-path)) - (last-update 0) ;; (current-seconds)) - (request-update #t)) - (if (not testdat) - (begin - (debug:print 2 *default-log-port* "ERROR: No test data found for test " test-id ", exiting") - (exit 1)) - (let* (;; (run-id (if testdat (db:test-get-run_id testdat) #f)) - (test-registry (tests:get-all)) - (keydat (if testdat (rmt:get-key-val-pairs run-id) #f)) - (rundat (if testdat (rmt:get-run-info run-id) #f)) - (runname (if testdat (db:get-value-by-header (db:get-rows rundat) - (db:get-header rundat) - "runname") #f)) - ;; (tdb (tdb:open-test-db-by-test-id-local dbstruct run-id test-id)) - ;; These next two are intentional bad values to ensure errors if they should not - ;; get filled in properly. - (logfile "/this/dir/better/not/exist") - (rundir (if testdat - (db:test-get-rundir testdat) - logfile)) - ;; (testdat-path (conc rundir "/testdat.db")) ;; this gets recalculated until found - (augment-teststeps (lambda (inlov) - (map - (lambda (invec) - (list->vector - `( - ,@(reverse (cdr (reverse (vector->list invec)))) - "rerun this step" "restart from here" ))) - inlov))) - (teststeps (if testdat (augment-teststeps (tests:get-compressed-steps run-id test-id)) '())) - (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ...")) - (testname (if testdat (db:test-get-testname testdat) "n/a")) - ;; (tests:get-testconfig testdat testname 'return-procs)) - (testmeta (if testdat - (let ((tm (rmt:testmeta-get-record testname))) - (if tm tm (make-db:testmeta))) - (make-db:testmeta))) - - (keystring (string-intersperse - (map (lambda (keyval) - ;; (conc ":" (car keyval) " " (cadr keyval))) - (cadr keyval)) - keydat) - "/")) - (item-path (db:test-get-item-path testdat)) - ;; this next block was added to fix a bug where variables were - ;; needed. Revisit this. - (runconfig (let ((runconfigf (conc *toppath* "/runconfigs.config"))) ;; no rush but it would be good to convert this call to use runconfig:read - (if (common:file-exists? runconfigf) - (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* "failed to set up environment for " runconfigf ", exn=" exn) - #f) ;; do nothing, just keep on trucking .... - (setup-env-defaults runconfigf run-id (make-hash-table) keydat environ-patt: keystring)) - (make-hash-table)))) - (testconfig (begin - ;; (runs:set-megatest-env-vars run-id inrunname: runname testname: test-name itempath: item-path) - (runs:set-megatest-env-vars run-id inkeyvals: keydat inrunname: runname intarget: keystring testname: testname itempath: item-path) ;; these may be needed by the launching process - (handle-exceptions - exn ;; NOTE: I've no idea why this was written this way. Research, study and fix needed! - (begin - (debug:print 0 *default-log-port* "testconfig load using " item-path " failed, trying " (db:test-get-item-path testdat) ", exn=" exn) - (tests:get-testconfig (db:test-get-testname testdat) (db:test-get-item-path testdat) test-registry #f allow-write-cache: #f)) - (tests:get-testconfig (db:test-get-testname testdat) item-path test-registry #t allow-write-cache: #f)))) - (viewlog (lambda (x) - (if (common:file-exists? logfile) - ;(system (conc "firefox " logfile "&")) - (dcommon:run-html-viewer logfile) - (message-window (conc "File " logfile " not found"))))) - (view-a-log (lambda (lfile) - (let ((lfilename (conc rundir "/" lfile))) - ;; (print "lfilename: " lfilename) - (if (common:file-exists? lfilename) - ;(system (conc "firefox " logfile "&")) - (dcommon:run-html-viewer lfilename) - (message-window (conc "File " lfilename " not found")))))) - (xterm (lambda (x) - (if (directory-exists? rundir) - (let ((shell (if (get-environment-variable "SHELL") - (conc "-e " (get-environment-variable "SHELL")) - ""))) - (common:without-vars - (conc "cd " rundir - ";mt_xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&") - "MT_.*")) - (message-window (conc "Directory " rundir " not found"))))) - (widgets (make-hash-table)) - (refreshdat (lambda () - (let* ((curr-mod-time (file-modification-time db-path)) - ;; (max ..... (if (common:file-exists? testdat-path) - ;; (file-modification-time testdat-path) - ;; (begin - ;; (set! testdat-path (conc rundir "/testdat.db")) - ;; 0)))) - (need-update (or (and (>= curr-mod-time db-mod-time) - (> (current-milliseconds)(+ last-update 250))) ;; every half seconds if db touched - (> (current-milliseconds)(+ last-update 10000)) ;; force update even 10 seconds - request-update)) - (newtestdat (if need-update - ;; NOTE: BUG HIDER, try to eliminate this exception handler - (handle-exceptions - exn - (begin - (debug:print-info 0 *default-log-port* "test db access issue in examine test for run-id " run-id - ", test-id " test-id ": " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) - #f) - (rmt:get-test-info-by-id run-id test-id))))) - ;; (print "INFO: need-update= " need-update " curr-mod-time = " curr-mod-time) - (cond - ((and need-update newtestdat) - (set! testdat newtestdat) - (set! teststeps (augment-teststeps (tests:get-compressed-steps run-id test-id))) - (set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat))) - (set! rundir ;; (filedb:get-path *fdb* - (db:test-get-rundir testdat)) ;; ) - (set! testfullname (db:test-get-fullname testdat)) - ;; (debug:print 0 *default-log-port* "INFO: teststeps=" (intersperse teststeps "\n ")) - - ;; I don't see why this was implemented this way. Please comment it ... - ;; (if (eq? curr-mod-time db-mod-time) ;; do only once if same - ;; (set! db-mod-time (+ curr-mod-time 1)) - ;; (set! db-mod-time curr-mod-time)) - - (if (not (eq? curr-mod-time db-mod-time)) - (set! db-mod-time curr-mod-time)) - (set! last-update (current-milliseconds)) - (set! request-update #f) ;; met the need ... - ) - (need-update ;; if this was true and yet there is no data .... - (db:test-set-testname! testdat "DEAD OR DELETED TEST"))) - (if need-update - (begin - ;; update the gui elements here - (for-each - (lambda (key) - ;; (print "Updating " key) - ((hash-table-ref widgets key) testdat)) - (hash-table-keys widgets)) - (update-state-status-buttons testdat))) - ;; (iup:refresh self) - ))) - (meta-widgets (make-hash-table)) - (self #f) - (store-label (lambda (name lbl cmd) - (hash-table-set! widgets name - (lambda (testdat) - (let ((newval (cmd testdat)) - (oldval (iup:attribute lbl "TITLE"))) - (if (not (equal? newval oldval)) - (begin - ;(mutex-lock! mx1) - (iup:attribute-set! lbl "TITLE" newval) - ;(mutex-unlock! mx1) - ))))) - lbl)) - (store-meta (lambda (name lbl cmd) - (hash-table-set! meta-widgets name - (lambda (testmeta) - (let ((newval (cmd testmeta)) - (oldval (iup:attribute lbl "TITLE"))) - (if (not (equal? newval oldval)) - (begin - ;(mutex-lock! mx1) - (iup:attribute-set! lbl "TITLE" newval) - ;(mutex-unlock! mx1) - ))))) - lbl)) - (store-button store-label) - (command-proc (lambda (command-text-box) - (let* ((cmd (iup:attribute command-text-box "VALUE"))) - (common:run-a-command cmd with-orig-env: #t)))) - (command-text-box (iup:textbox - #:expand "HORIZONTAL" - #:font "Courier New, -10" - #:action (lambda (obj cnum val) - ;; (print "cnum=" cnum) - (if (eq? cnum 13) - (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")) - ;; (fullcmd (conc (dtests:get-pre-command) - ;; cmd - ;; (dtests:get-post-command)))) - ;; (debug:print-info 02 *default-log-port* "Running command: " fullcmd) - ;; (common:without-vars fullcmd "MT_.*"))))) - (kill-jobs (lambda (x) - (iup:attribute-set! - command-text-box "VALUE" - (conc "megatest -target " keystring " -runname " runname - " -set-state-status KILLREQ,n/a -testpatt %/% " - " -state RUNNING,REMOTEHOSTSTART,LAUNCHED")))) - (run-test (lambda (x) - (iup:attribute-set! - command-text-box "VALUE" - (conc "megatest -target " keystring " -runname " runname - " -run -testpatt " (conc testname "/" (if (equal? item-path "") - "%" - item-path)) - " -clean-cache" - )))) - (remove-test (lambda (x) - (iup:attribute-set! - command-text-box "VALUE" - (conc "megatest -remove-runs -target " keystring " -runname " runname - " -testpatt " (conc testname "/" (if (equal? item-path "") - "%" - item-path)) - " -v")))) - (clean-run-execute (lambda (x) - (let ((cmd (conc ;; "megatest -remove-runs -target " keystring " -runname " runname - "megatest -set-state-status NOT_STARTED,n/a -target " keystring " -runname " runname - " -testpatt " (conc testname "/" (if (equal? item-path "") - "%" - item-path)) - ";megatest -target " keystring " -runname " runname - " -run -preclean -testpatt " (conc testname "/" (if (equal? item-path "") - "%" - item-path)) - " -clean-cache" - ))) - (thread-start! (make-thread (lambda () - (common:run-a-command cmd)) - "clean-run-execute"))))) - (remove-test (lambda (x) - (iup:attribute-set! - command-text-box "VALUE" - (conc "megatest -remove-runs -target " keystring " -runname " runname - " -testpatt " (conc testname "/" (if (equal? item-path "") - "%" - item-path)) - " -v")))) - (archive-test (lambda (x) - (iup:attribute-set! - command-text-box "VALUE" - (conc "megatest -target " keystring " -runname " runname - " -archive save-remove -testpatt " (conc testname "/" (if (equal? item-path "") - "%" - item-path)) - ))))) - (cond - ((not testdat)(begin (debug:print 0 *default-log-port* "ERROR: bad test info for " test-id)(exit 1))) - ((not rundat)(begin (debug:print 0 *default-log-port* "ERROR: found test info but there is a problem with the run info for " run-id)(exit 1))) - (else - ;; (test-set-status! db run-id test-name state status itemdat) - (set! self ; - (iup:dialog #:close_cb (lambda (a)(exit)) ; #:expand "YES" - #:title testfullname - (iup:vbox ; #:expand "YES" - ;; The run and test info - (iup:hbox ; #:expand "YES" - (run-info-panel dbstruct keydat testdat runname) - (test-info-panel testdat store-label widgets) - (test-meta-panel testmeta store-meta)) - (iup:hbox - (host-info-panel testdat store-label) - (submegatest-panel dbstruct keydat testdat runname testconfig)) - ;; The controls - (iup:frame #:title "Actions" - (iup:vbox - (iup:hbox - (iup:button "View Log" #:action viewlog #:size "80x") - (iup:button "Start Xterm" #:action xterm #:size "80x") - (iup:button "Run Test" #:action run-test #:size "80x") - (iup:button "Clean Test" #:action remove-test #:size "80x") - (iup:button "CleanRunExecute!" #:action clean-run-execute #:size "80x") - (iup:button "Kill All Jobs" #:action kill-jobs #:size "80x") - (iup:button "Archive Test" #:action archive-test #:size "80x") - (iup:button "Close" #:action (lambda (x)(exit)) #:size "80x")) - (apply - iup:hbox - (list command-text-box command-launch-button)))) - (set-fields-panel dbstruct run-id test-id testdat) - (let ((tabs - (iup:tabs - ;; Replace here with matrix - (let ((steps-matrix (iup:matrix - #:font "Courier New, -8" - #:expand "YES" - #:scrollbar "YES" - #:numcol 9 - #:numlin 100 - #:numcol-visible 9 - #:numlin-visible 5 - #:click-cb (lambda (obj lin col status) - ;; (if (equal? col 6) - (let* ((mtrx-rc (conc lin ":" 6)) - (fname (iup:attribute obj mtrx-rc)) - (stepname (iup:attribute obj (conc lin ":" 1))) (comment (iup:attribute obj (conc lin ":" 7)))) - (case col - - ((7) (debug:print 0 *default-log-port* "Comment from step "stepname": "comment)) - ((8) (ezsteps:spawn-run-from testdat stepname #t)) - ((9) (ezsteps:spawn-run-from testdat stepname #f)) - (else (view-a-log fname)))))))) - ;; (let loop ((count 0)) - ;; (iup:attribute-set! steps-matrix "FITTOTEXT" (conc "L" count)) - ;; (if (< count 30) - ;; (loop (+ count 1)))) - (iup:attribute-set! steps-matrix "0:1" "Step Name") - (iup:attribute-set! steps-matrix "0:2" "Start") - (iup:attribute-set! steps-matrix "0:3" "End") - (iup:attribute-set! steps-matrix "WIDTH3" "50") - (iup:attribute-set! steps-matrix "0:4" "Status") - (iup:attribute-set! steps-matrix "WIDTH4" "50") - (iup:attribute-set! steps-matrix "0:5" "Duration") - (iup:attribute-set! steps-matrix "0:6" "Log File") - (iup:attribute-set! steps-matrix "0:7" "Comment") - (iup:attribute-set! steps-matrix "0:8" "rerun only") - (iup:attribute-set! steps-matrix "BGCOLOR0:9" "149 208 252") - (iup:attribute-set! steps-matrix "BGCOLOR0:8" "149 208 252") - (iup:attribute-set! steps-matrix "BGCOLOR0:7" "149 208 252") - (iup:attribute-set! steps-matrix "0:9" "rerun & continue") - (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT") - ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1") - (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES") - (let ((proc - (lambda (testdat) - (dcommon:populate-steps teststeps steps-matrix run-id test-id)))) - (hash-table-set! widgets "StepsMatrix" proc) - (proc testdat)) - steps-matrix) - ;; populate the Test Data panel - (iup:frame - #:title "Test Data" - (let ((test-data - (iup:textbox ;; #:action (lambda (obj char val) - ;; #f) - #:expand "YES" - #:multiline "YES" - #:font "Courier New, -10" - #:size "100x100"))) - (hash-table-set! widgets "Test Data" - (lambda (testdat) ;; - (let* ((currval (iup:attribute test-data "VALUE")) ;; "TITLE")) - (fmtstr "~10a~10a~10a~10a~7a~7a~6a~7a~a") ;; category,variable,value,expected,tol,units,type,comment - (newval (string-intersperse - (append - (list - (format #f fmtstr "Category" "Variable" "Value" "Expected" "Tol" "Status" "Units" "Type" "Comment") - (format #f fmtstr "========" "========" "=====" "========" "===" "======" "=====" "====" "=======")) - (map (lambda (x) - (format #f fmtstr - (db:test-data-get-category x) - (db:test-data-get-variable x) - (db:test-data-get-value x) - (db:test-data-get-expected x) - (db:test-data-get-tol x) - (db:test-data-get-status x) - (db:test-data-get-units x) - (db:test-data-get-type x) - (db:test-data-get-comment x))) - (rmt:read-test-data run-id test-id "%"))) - "\n"))) - (if (not (equal? currval newval)) - (iup:attribute-set! test-data "VALUE" newval ))))) ;; "TITLE" newval))))) - test-data)) - ;;(dashboard:run-controls) - ))) - (iup:attribute-set! tabs "TABTITLE0" "Steps") - (iup:attribute-set! tabs "TABTITLE1" "Test Data") - tabs)))) - (iup:show self) - (iup:callback-set! *tim* "ACTION_CB" - (lambda (x) - ;; 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)))) - -(define (common:run-a-command cmd #!key (with-vars #f) (with-orig-env #f)) - (let* ((pre-cmd (dtests:get-pre-command)) - (post-cmd (dtests:get-post-command)) - (fullcmd (if (or pre-cmd post-cmd) - (conc pre-cmd cmd post-cmd) - (conc "viewscreen " cmd)))) - (debug:print-info 02 *default-log-port* "Running command: " fullcmd) - (cond - (with-vars (common:without-vars fullcmd)) - (with-orig-env (common:with-orig-env fullcmd)) - (else (common:without-vars fullcmd "MT_.*"))))) - Index: dashboard-transport-mode.scm ================================================================== --- dashboard-transport-mode.scm +++ dashboard-transport-mode.scm @@ -3,20 +3,22 @@ ;; ;; sync-method: 'original, 'attach or 'none ;; cache-method: 'tmp or 'none ;; rmt:transport-mode: 'http, 'tcp, 'nfs ;; +;; 'auto +;; read-only query and no servers started - mrah/ +;; ;; NOTE: NOT ALL COMBINATIONS WORK ;; ;;====================================================================== ;; uncomment this block to test without tcp or cachedb -;; (dbfile:sync-method 'none) -;; (dbfile:cache-method 'none) -;; (rmt:transport-mode 'nfs) +(dbfile:sync-method 'none) +(dbfile:cache-method 'none) +(rmt:transport-mode 'nfs) ;; uncomment this block to test with tcp and cachedb -(dbfile:sync-method 'none) ;; original was causing crash on start. -(dbfile:cache-method 'none) -(rmt:transport-mode 'tcp) -;; (rmt:transport-mode 'nfs) +;; (dbfile:sync-method 'none) ;; original was causing crash on start. +;; (dbfile:cache-method 'none) +;; (rmt:transport-mode 'tcp) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -65,24 +65,14 @@ (declare (uses runsmod)) (declare (uses runsmod.import)) (declare (uses launchmod)) (declare (uses launchmod.import)) -(declare (uses configf)) -(declare (uses common)) (declare (uses keys)) -(declare (uses process)) -(declare (uses launch)) -(declare (uses runs)) -(declare (uses dashboard-tests)) -(declare (uses tree)) (declare (uses dcommon)) -(declare (uses dashboard-context-menu)) -(declare (uses vg)) -(declare (uses subrun)) -(declare (uses mt)) +(declare (uses vgmod)) (use format) (require-library iup) (import (prefix iup iup:)) @@ -105,19 +95,20 @@ stml2 megatestmod tasksmod runsmod testsmod + vgmod + dcommon ) (include "common_records.scm") ;; (include "db_records.scm") (include "run_records.scm") (include "task_records.scm") -(include "megatest-version.scm") +;; (include "megatest-version.scm") (include "megatest-fossil-hash.scm") -(include "vg_records.scm") ;; set some parameters here - these need to be put in something that can be loaded from other ;; executables such as dashboard and mtutil ;; (include "dashboard-transport-mode.scm") @@ -127,3935 +118,11 @@ ;; remove when configf fully modularized (read-config-set! configf:read-file) (debug:print-info 0 *default-log-port* "transport-mode="(rmt:transport-mode)) -(define help (conc - "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version - " license GPL, Copyright (C) Matt Welland 2012-2017 - -Usage: dashboard [options] - -h : this help - -test run-id test-id : open a test control panel on this test - -skip-version-check : skip the version check - -rows R : set number of rows - -cols C : set number of columns - -start-dir dir : start dashboard in the given directory - -target target : filter runs tab to given target. - -debug n[,n] : set debug level(s) e.g. -debug 4 or -debug 0,9 - -repl : Start a chicken scheme interpreter - -mode MODE : tcp or nfs -" -)) - - -;; process args -(define remargs (args:get-args - (argv) - ;; parameters (need arguments) - (list "-rows" - "-cols" - "-test" ;; given a run id and test id, open only a test control panel on that test.. - "-debug" - "-start-dir" - "-target" - "-mode" ;; tcp or nfs - ) - ;; switches (don't take arguments) - (list "-h" - "-skip-version-check" - "-repl" - "-: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 '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 -;; -;;;(if (file-write-access? (conc *toppath* "/megatest.db")) -;;(debug:print-info 13 *default-log-port* "Before common:watchdog spawn") - -;; (thread-start! (make-thread common:watchdog "Watchdog thread")) -;;(debug:print-info 13 *default-log-port* "After common:watchdog spawn") -;; (if (not (args:get-arg "-use-db-cache")) -;; (begin -;; (debug:print-info 0 *default-log-port* "Forcing db-cache mode due to read-only access to megatest.db") -;; (hash-table-set! args:arg-hash "-use-db-cache" #t)));;;) -;;) - -;; data common to all tabs goes here -;; -;; Moved to dcommon.scm -;; -;; (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 -;; target -;; ) -;; -;; (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 -;; target: "" -;; )) - -;;====================================================================== -;; buttons color using image -;;====================================================================== - -(define *images* (make-hash-table)) - -(define (make-image images name color) - (if (hash-table-exists? images name) - name - (let* ((img-bits1 (u8vector->blob (u8vector - 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 - 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 - 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 - 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 - 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 - 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 - 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 - 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 - 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 - 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 - 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 - 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 - 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 - 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 - 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 - 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 - 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 - 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 - 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 - 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 - 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 - 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 - 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 - 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 - ))) - ;; w h - (img1 (iup:image/palette 16 24 img-bits1))) - (iup:handle-name-set! img1 name) - ;; (iup:attribute-set! img1 "0" "0 0 0") - (iup:attribute-set! img1 "1" color) ;; "BGCOLOR") - ;; (iup:attribute-set! img1 "2" "255 0 0") - (hash-table-set! images name img1) - name))) - - -;; gets and calls updater list based on curr-tab-num -;; -(define (dboard:common-run-curr-updaters commondat #!key (tab-num #f)) - ;; (sync-db-to-tmp (dboard:common-get-tabdat commondat tab-num: tab-num)) ;; no longer applies - - ;; maybe need sleep here? - - (if (dboard:common-get-tabdat commondat tab-num: tab-num) ;; only update if there is a tabdat - (let* ((tnum (or tab-num (dboard:commondat-curr-tab-num commondat))) - (updaters (hash-table-ref/default (dboard:commondat-updaters commondat) - tnum - '()))) - (debug:print 4 *default-log-port* "Found these updaters: " updaters " for tab-num: " tnum) - (for-each ;; perform the function calls for the complete updaters list - (lambda (updater) - ;; (debug:print 3 *default-log-port* "Running " updater) - (updater)) - updaters)))) - -;; 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)))) - -;; data for each specific tab goes here -;; -(defstruct dboard:tabdat - ;; runs - ((allruns '()) : list) ;; list of dboard:rundat records - ((allruns-by-id (make-hash-table)) : hash-table) ;; hash of run-id -> dboard:rundat records - ((done-runs '()) : list) ;; list of runs already drawn - ((not-done-runs '()) : list) ;; list of runs not yet drawn - (header #f) ;; header for decoding the run records - (keys #f) ;; keys for this run (i.e. target components) - ((numruns (string->number (or (args:get-arg "-cols") - (configf:lookup *configdat* "dashboard" "cols") - "8"))) : number) ;; - ((tot-runs 0) : number) - ((last-data-update 0) : number) ;; last time the data in allruns was updated - ((last-runs-update 0) : number) ;; last time we pulled the runs info to update the tree - (runs-mutex (make-mutex)) ;; use to prevent parallel access to draw objects - ((run-update-times (make-hash-table)) : hash-table) ;; update times indexed by run-id - ((last-test-dat (make-hash-table)) : hash-table) ;; cache last tests dat by run-id - ((run-db-paths (make-hash-table)) : hash-table) ;; cache the paths to the run db files - - ;; Runs view - ((buttondat (make-hash-table)) : hash-table) ;; - ((item-test-names '()) : list) ;; list of itemized tests - ((run-keys (make-hash-table)) : hash-table) - (runs-matrix #f) ;; used in newdashboard - ((start-run-offset 0) : number) ;; left-right slider value - ((start-test-offset 0) : number) ;; up-down slider value - ((runs-btn-height (or (configf:lookup *configdat* "dashboard" "btn-height") "x16")) : string) ;; was 12 - ((runs-btn-fontsz (or (configf:lookup *configdat* "dashboard" "btn-fontsz") "10")) : string) ;; was 8 - ((runs-cell-width (or (configf:lookup *configdat* "dashboard" "cell-width") "50")) : string) ;; was 50 - ((all-test-names '()) : list) - - ;; Canvas and drawing data - (cnv #f) - (cnv-obj #f) - (drawing #f) - ((run-start-row 0) : number) - ((max-row 0) : number) - ((running-layout #f) : boolean) - (originx #f) - (originy #f) - ((layout-update-ok #t) : boolean) - ((compact-layout #t) : boolean) - - ;; Run times layout - ;; (graph-button-box #f) ;; RA => Think it is not referenced anywhere - (graph-matrix #f) - ((graph-matrix-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru graph name info - ((graph-cell-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru matrix cell info - ((graph-matrix-row 1) : number) - ((graph-matrix-col 1) : number) - - ;; Controls used to launch runs etc. - ((command "") : string) ;; for run control this is the command being built up - (command-tb #f) ;; widget for the type of command; run, remove-runs etc. - (test-patterns-textbox #f) ;; text box widget for editing a list of test patterns - (key-listboxes #f) - (key-lbs #f) - run-name ;; from run name setting widget - states ;; states for -state s1,s2 ... - statuses ;; statuses for -status s1,s2 ... - - ;; Selector variables - curr-run-id ;; current row to display in Run summary view - prev-run-id ;; previous runid selected before current runid was selected (used in xor-two-runs runs summary mode - curr-test-ids ;; used only in dcommon:run-update which is used in newdashboard - ((filters-changed #t) : boolean) ;; to indicate that the user changed filters for this tab - ((last-filter-str "") : string) ;; conc the target runname and testpatt for a signature of changed filters - ((hide-empty-runs #f) : boolean) - ((hide-not-hide #t) : boolean) ;; toggle for hide/not hide empty runs - (hide-not-hide-button #f) - ((searchpatts (make-hash-table)) : hash-table) ;; - ((state-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATE => #t/#f for display control - ((status-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATUS => #t/#f - (target #f) - (test-patts #f) - - ;; db info to file the .db files for the area - (access-mode (db:get-access-mode)) ;; use cached db or not - (dbdir #f) - (dbfpath #f) - (dbkeys #f) - ((last-db-update (make-hash-table)) : hash-table) ;; last db file timestamp - (monitor-db-path #f) ;; where to find monitor.db - ro ;; is the database read-only? - - ;; tests data - ((num-tests 10) : number) ;; total number of tests to show (used in the old runs display) - - ;; runs tree - ((path-run-ids (make-hash-table)) : hash-table) ;; path (target / runname) => id - (runs-tree #f) - ((runs-tree-ht (make-hash-table)) : hash-table) ;; track which targets added to tree (merge functionality with path-run-ids?) - - ;; tab data - ((view-changed #t) : boolean) - ((xadj 0) : number) ;; x slider number (if using canvas) - ((yadj 0) : number) ;; y slider number (if using canvas) - ;; runs-summary tab state - ((runs-summary-modes '((one-run . "Show One Run") (xor-two-runs . "XOR Two Runs") (xor-two-runs-hide-clean . "XOR; Hide Clean")) ) : list) - ((runs-summary-mode-buttons '()) : list) - ((runs-summary-mode 'one-run) : symbol) - ((runs-summary-mode-change-callbacks '()) : list) - (runs-summary-source-runname-label #f) - (runs-summary-dest-runname-label #f) - ;; runs summary view - - tests-tree ;; used in newdashboard - ) - -;; register tabdat with BBpp -;; this is used by BBpp (Brandon's pretty printer) to convert dboard:tabdat into a composition of lists that pp will handle -;; (hash-table-set! *BBpp_custom_expanders_list* TABDAT: -;; (cons dboard:tabdat? -;; (lambda (tabdat-item) -;; (filter -;; (lambda (alist-entry) -;; (member (car alist-entry) -;; '(allruns-by-id allruns))) ;; FIELDS OF INTEREST -;; (dboard:tabdat->alist tabdat-item))))) - - - -(define (dboard:tabdat-target-string vec) - (let ((targ (dboard:tabdat-target vec))) - (if (list? targ)(string-intersperse targ "/") "no-target-specified"))) - -(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))) - -(define (dboard:tabdat-make-data) - (let ((dat (make-dboard:tabdat))) - (dboard:setup-tabdat dat) - (dboard:setup-num-rows dat) - dat)) - -(define (dboard:setup-tabdat tabdat) - (dboard:tabdat-dbdir-set! tabdat (common:make-tmpdir-name *toppath* "")) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) - (dboard:tabdat-dbfpath-set! tabdat (common:make-tmpdir-name *toppath* "")) - (dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db")) - - - ;; HACK ALERT: this is a hack, please fix. - (dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat)))) - (dboard:tabdat-keys-set! tabdat (rmt:get-keys)) - (dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname"))) - (dboard:tabdat-tot-runs-set! tabdat (rmt:get-num-runs "%")) - ) - -;; 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))) - -;; duplicated in dcommon.scm -;; -;; ;; 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 main.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)) - -;; for the new runs view lets build up a few new record types and then consolidate later -;; -;; this is a two level deep pipeline for the incoming data: -;; sql query data ==> filters ==> data for display -;; -(defstruct dboard:rdat - ;; view related items - (runnum 0) ;; which column we are processing, index into runsbynum, we sweep across all these runs then start over - (leftcol 0) ;; number of the leftmost visible column - (toprow 0) ;; topmost visible row - (numcols 24) ;; number of columns visible - (numrows 20) ;; number of rows visible - - ;; data from sql db - (keys (rmt:get-keys)) ;; to be removed when targets handling is refactored - (runs (make-sparse-vector)) ;; id => runrec - (runsbynum (make-vector 100 #f)) ;; vector num => runrec - (targ-runid (make-hash-table)) ;; area/target/runname => run-id ;; not sure this will be needed - (tests (make-hash-table)) ;; test[/itempath] => list of test rec - - ;; run sql filters - (targ-sql-filt "%") - (runname-sql-filt "%") - (run-state-sql-filt "%") - (run-status-sql-filt "%") - - ;; test sql filter - (testname-sql-filt "%") - (itempath-sql-filt "%") - (test-state-sql-filt "%") - (test-status-sql-filt "%") - - ;; other sql related fields - (last-updates (make-sparse-vector 0)) ;; run-id -> timestamp of the last update from sql db, set to zero on any field changes - - ;; filtered data - (cols (make-sparse-vector)) ;; columnnum => run-id - (tests (make-hash-table)) ;; test[/itempath] => (vector columnnum => test rec) - - ;; various - (prev-run-ids '()) ;; push previously looked at runs on this - (view-changed #f) - - ;; widgets - (runs-tree #f) ;; - ) - -(define (dboard:rdat-push-run-id rdat run-id) - (dboard:rdat-prev-run-ids-set! rdat (cons run-id (dboard:rdat-prev-run-ids rdat)))) - -(defstruct dboard:runrec - id - target ;; a/b/c... - tdef ;; for future use - ) - -(defstruct dboard:testrec - id - runid - testname ;; test[/itempath] - state - status - start-time - duration - ) - -;; register dboard:rundat with BBpp -;; this is used by BBpp (Brandon's pretty printer) to convert dboard:rundat into a composition of lists that pp will handle -;; (hash-table-set! *BBpp_custom_expanders_list* RUNDAT: -;; (cons dboard:rundat? -;; (lambda (tabdat-item) -;; (filter -;; (lambda (alist-entry) -;; (member (car alist-entry) -;; '(run run-data-offset ))) ;; FIELDS OF INTEREST -;; (dboard:rundat->alist tabdat-item))))) - - - - -(define (dboard:rundat-make-init #!key (run #f)(key-vals #f)(tests #f));; -100 is before time began - (make-dboard:rundat - run: run - tests: (or tests (make-hash-table)) - key-vals: key-vals - )) - -(defstruct dboard:testdat - id ;; testid - state ;; test state - status ;; test status - ) - -;; default is to NOT set the cell if the column and row names are not pre-existing -;; -(define (dboard:runsdat-set-test-cell dat target runname testname itempath test-id state status #!key (force-set #f)) - (let* ((col-num (dcommon:runsdat-get-col-num dat target runname force-set)) - (row-num (dcommon:runsdat-get-row-num dat testname itempath force-set))) - (if (and row-num col-num) - (let ((tdat (dboard:testdat - id: test-id - state: state - status: status))) - (sparse-array-set! (dboard:runsdat-matrix-dat dat) col-num row-num tdat) - tdat) - #f))) - -(define *dashboard-mode* (string->symbol (or (configf:lookup *configdat* "dashboard" "mode") "dashboard"))) - - -(define *exit-started* #f) - -;; sorting global data (would apply to many testsuites so leave it global for now) -;; -(define *tests-sort-options* (vector (vector "Sort +a" 'testname "ASC") - (vector "Sort -a" 'testname "DESC") - (vector "Sort +t" 'event_time "ASC") - (vector "Sort -t" 'event_time "DESC") - (vector "Sort +s" 'statestatus "ASC") - (vector "Sort -s" 'statestatus "DESC") - (vector "Sort +a" 'testname "ASC"))) - -(define *tests-sort-type-index* '(("+testname" 0) - ("-testname" 1) - ("+event_time" 2) - ("-event_time" 3) - ("+statestatus" 4) - ("-statestatus" 5))) - -;; Don't forget to adjust the >= below if you add to the sort-options above -(define (next-sort-option) - (if (>= *tests-sort-reverse* 5) - (set! *tests-sort-reverse* 0) - (set! *tests-sort-reverse* (+ *tests-sort-reverse* 1))) - *tests-sort-reverse*) - -(define *tests-sort-reverse* - (let ((t-sort (assoc (configf:lookup *configdat* "dashboard" "testsort") *tests-sort-type-index*))) - (if t-sort - (cadr t-sort) - 3))) - -(define (get-curr-sort) - (vector-ref *tests-sort-options* *tests-sort-reverse*)) - -;;====================================================================== - -(debug:setup) - -;; (define uidat #f) - -(define-inline (dboard:uidat-get-keycol vec)(vector-ref vec 0)) -(define-inline (dboard:uidat-get-lftcol vec)(vector-ref vec 1)) -(define-inline (dboard:uidat-get-header vec)(vector-ref vec 2)) -(define-inline (dboard:uidat-get-runsvec vec)(vector-ref vec 3)) - -(if (get-environment-variable "MT_RUN_AREA_HOME")(change-directory (get-environment-variable "MT_RUN_AREA_HOME"))) - -(define (message-window msg) - (iup:show - (iup:dialog - (iup:vbox - (iup:label msg #:margin "40x40"))))) - -(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)) - -(define (pad-list l n)(append l (make-list (- n (length l))))) - -(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)))) - -(define (dboard:compare-tests test1 test2) - (let* ((test-name1 (db:test-get-testname test1)) - (item-path1 (db:test-get-item-path test1)) - (eventtime1 (db:test-get-event_time test1)) - (test-name2 (db:test-get-testname test2)) - (item-path2 (db:test-get-item-path test2)) - (eventtime2 (db:test-get-event_time test2)) - (same-name (equal? test-name1 test-name2)) - (test1-top (equal? item-path1 "")) - (test2-top (equal? item-path2 "")) - (test1-older (> eventtime1 eventtime2)) - (same-time (equal? eventtime1 eventtime2))) - (if same-name - (if same-time - (string>? item-path1 item-path2) - test1-older) - (if same-time - (string>? test-name1 test-name2) - test1-older)))) - -;; This is roughly the same as dboard:get-tests-dat, should merge them if possible -;; -;; gets all the tests for run-id that match testnamepatt and key-vals, merges them -;; -;; NOTE: Yes, this is used -;; -(define (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals) - (let* ((start-time (current-seconds)) - (access-mode (dboard:tabdat-access-mode tabdat)) - (num-to-get (string->number (or (configf:lookup *configdat* "setup" "num-tests-to-get") - "1000"))) - (states (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat))) - (statuses (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat))) - (do-not-use-db-file-timestamps #f) ;; (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps")) ;; this still hosts runs-summary-tab - (do-not-use-query-timestamps #t) ;; (configf:lookup *configdat* "setup" "do-not-use-query-timestamps")) ;; this no longer troubles runs-summary-tab - (sort-info (get-curr-sort)) - (sort-by (vector-ref sort-info 1)) - (sort-order (vector-ref sort-info 2)) - (bubble-type (if (member sort-order '(testname)) - 'testname - 'itempath)) - ;; note: the rundat is normally created in "update-rundat". - (run-dat (or (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f) - (let ((rd (dboard:rundat-make-init run: run key-vals: key-vals))) - (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id rd) - rd))) - ;; (prev-tests (dboard:rundat-tests prev-dat)) ;; (vector-ref prev-dat 1)) - (last-update (if ;;(or - do-not-use-query-timestamps - ;;(dboard:tabdat-filters-changed tabdat)) - 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/*.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) - (rmt:get-tests-for-run run-id testnamepatt states statuses ;; run-id testpatt states statuses - (dboard:rundat-run-data-offset run-dat) ;; query offset - num-to-get - (dboard:tabdat-hide-not-hide tabdat) ;; no-in - sort-by ;; sort-by - sort-order ;; sort-order - 'shortlist ;; qrytype (was #f) - last-update ;; last-update - *dashboard-mode*) ;; use dashboard mode - '())) - (use-new (dboard:tabdat-hide-not-hide tabdat)) - (tests-ht (if (dboard:tabdat-filters-changed tabdat) - (let ((ht (make-hash-table))) - (dboard:rundat-tests-set! run-dat ht) - ht) - (dboard:rundat-tests run-dat))) - (got-all (< (length tmptests) num-to-get)) ;; got all for this round - ) - ;; (debug:print-info 0 *default-log-port* "got-all="got-all", (hash-table-size tests-ht)="(hash-table-size tests-ht)) - ;; if we saw the db modified, reset it (the signal has already been used) - (if (and got-all ;; (not multi-get) - db-modified) - (dboard:rundat-last-db-time-set! run-dat (- start-time 2))) - - ;; to limit the amount of data transferred each cycle use limit of num-to-get and offset - ;; DO NOT bump time indexes last-update and last-db-time until all the first pass of the - ;; data has been read - ;; set last-update to 0 if still getting data incrementally ;; NO NEED, handled above - ;; - ;; (debug:print 0 *default-log-port* "got-all: " got-all " multi-get: " multi-get " num-to-get: " num-to-get " (length tmptests): " (length tmptests) " db-modified: " db-modified " db-mod-time: " db-mod-time " db-path: " db-path) - (if got-all - (begin - (dboard:rundat-last-update-set! run-dat (- start-time 2)) - (dboard:rundat-run-data-offset-set! run-dat 0)) - (begin - (dboard:rundat-run-data-offset-set! run-dat - (+ num-to-get (dboard:rundat-run-data-offset run-dat))))) - - (for-each - (lambda (tdat) - (let ((test-id (db:test-get-id tdat)) - (state (db:test-get-state tdat))) - (dboard:rundat-data-changed-set! run-dat #t) - (if (equal? state "DELETED") - (hash-table-delete! tests-ht test-id) - (hash-table-set! tests-ht test-id tdat)))) - tmptests) - - tests-ht)) - -;; tmptests - new tests data -;; prev-tests - old tests data -;; -;; (define (dashboard:merge-changed-tests tabdat tests tmptests) ;; use-new prev-tests) -;; (let* ((newdat (filter -;; (lambda (x) -;; (not (equal? (db:test-get-state x) "DELETED"))) ;; remove deleted tests but do it after merging -;; (delete-duplicates (if use-new ;; (dboard:tabdat-filters-changed tabdat) -;; tmptests -;; (append tmptests prev-tests)) -;; (lambda (a b) -;; (eq? (db:test-get-id a)(db:test-get-id b))))))) -;; (print "Time took: " (- (current-seconds) start-time)) -;; (if (eq? *tests-sort-reverse* 3) ;; +event_time -;; (sort newdat dboard:compare-tests) -;; newdat))) - -;; this calls dboard:get-tests-for-run-duplicate for each run -;; -;; create a virtual table of all the tests -;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) -;; -(define (update-rundat tabdat runnamepatt numruns testnamepatt keypatts) - (let* ((access-mode (dboard:tabdat-access-mode tabdat)) - (keys (rmt:get-keys)) - (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2)) - (allruns (rmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) - ;;(allruns-tree (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) - (allruns-tree (rmt:get-runs-by-patt keys "%" #f #f #f #f last-runs-update)) ;;'("id" "runname") - (header (db:get-header allruns)) - (runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected - (runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs - (start-time (current-seconds)) - (runs-hash (let ((ht (make-hash-table))) - (for-each (lambda (run) - (hash-table-set! ht (db:get-value-by-header run header "id") run)) - runs-tree) ;; (vector-ref runs-dat 1)) - ht)) - (tb (dboard:tabdat-runs-tree tabdat))) - ;;(BB> "In update-rundat") - ;;(inspect allruns runs-hash) - (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) - (dboard:tabdat-header-set! tabdat header) - ;; - ;; trim runs to only those that are changing often here - ;; - (if (null? runs) - (begin - (dboard:tabdat-allruns-set! tabdat '()) - (dboard:tabdat-all-test-names-set! tabdat '()) - (dboard:tabdat-item-test-names-set! tabdat '()) - (hash-table-clear! (dboard:tabdat-allruns-by-id tabdat))) - (let loop ((run (car runs)) - (tal (cdr runs)) - (res '()) - (maxtests 0)) - (let* ((run-id (db:get-value-by-header run header "id")) - (run-struct (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)) - (last-update (if run-struct (dboard:rundat-last-update run-struct) 0)) - (key-vals (rmt:get-key-vals run-id)) - (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)) - ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate - ;; dboard:get-tests-for-run-duplicate - returns a hash table - ;; (dboard:get-tests-dat tabdat run-id last-update)) - (all-test-ids (hash-table-keys tests-ht)) - (num-tests (length all-test-ids))) - ;; (print "run-struct: " run-struct) - ;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat) - ;; (tests (bubble-up tmptests priority: bubble-type)) - ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively. - ;; (debug:print 0 *default-log-port* "Getting data for run " run-id " with key-vals=" key-vals) - ;; Not sure this is needed? - (let* ((newmaxtests (max num-tests maxtests)) - (last-update (- (current-seconds) 10)) - (run-struct (or run-struct - (dboard:rundat-make-init - run: run - tests: tests-ht - key-vals: key-vals))) - (new-res (if (null? all-test-ids) res (cons run-struct res))) - (elapsed-time (- (current-seconds) start-time))) - (if (null? all-test-ids) - (hash-table-delete! (dboard:tabdat-allruns-by-id tabdat) run-id) - (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id run-struct)) - (if (or (null? tal) - (> elapsed-time 2)) ;; stop loading data after 5 seconds, on the next call more data *should* be loaded since get-tests-for-run uses last update - (begin - (if (> elapsed-time 2)(debug:print 0 *default-log-port* "WARNING: timed out in update-testdat " elapsed-time "s")) - (dboard:tabdat-allruns-set! tabdat new-res) - maxtests) - (if (> (dboard:rundat-run-data-offset run-struct) 0) - (loop run tal new-res newmaxtests) ;; not done getting data for this run - (loop (car tal)(cdr tal) new-res newmaxtests))))))) - (dboard:tabdat-filters-changed-set! tabdat #f) - (dboard:update-tree tabdat runs-hash header tb))) - - -(define *dashboard-last-run-id-update* (make-hash-table)) ;; id => seconds - -(define (dboard:clear-run-id-update-hash) - (hash-table-clear! *dashboard-last-run-id-update*)) - -;; this calls dboard:get-tests-for-run-duplicate for each run -;; -;; create a virtual table of all the tests -;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) -;; -(define (dboard:update-rundat tabdat runnamepatt numruns testnamepatt keypatts) - (let* ((access-mode (dboard:tabdat-access-mode tabdat)) - (keys (dboard:tabdat-keys tabdat)) ;; (db:dispatch-query access-mode rmt:get-keys db:get-keys))) - (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2)) - (allruns (rmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) - ;;(allruns-tree (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) - (allruns-tree (rmt:get-runs-by-patt keys "%" #f #f #f #f 0)) ;; last-runs-update));;'("id" "runname") - (header (db:get-header allruns)) - (runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected - (runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs - (start-time (current-seconds)) - (runs-hash (let ((ht (make-hash-table))) - (for-each (lambda (run) - (hash-table-set! ht (db:get-value-by-header run header "id") run)) - runs-tree) ;; (vector-ref runs-dat 1)) - ht)) - (tb (dboard:tabdat-runs-tree tabdat))) - (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) - (dboard:tabdat-header-set! tabdat header) - ;; - ;; trim runs to only those that are changing often here - ;; - (if (null? runs) - (begin - (dboard:tabdat-allruns-set! tabdat '()) - (dboard:tabdat-all-test-names-set! tabdat '()) - (dboard:tabdat-item-test-names-set! tabdat '()) - (hash-table-clear! (dboard:tabdat-allruns-by-id tabdat))) - (let loop ((run (car runs)) - (tal (cdr runs)) - (res '()) - (maxtests 0) - (cont-run #f)) - (let* ((run-id (db:get-value-by-header run header "id")) - (recently-done (< (- (current-seconds) - (hash-table-ref/default *dashboard-last-run-id-update* run-id 0)) 1)) - (run-struct (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)) - ;; (last-update (if run-struct (dboard:rundat-last-update run-struct) 0)) - (key-vals (rmt:get-key-vals run-id)) - (tests-ht (let* ((tht (if (and recently-done run-struct) - (let ((rht (dboard:rundat-tests run-struct))) ;; (dboard:tabdat-allruns-by-id tabdat))) - (or rht - (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))) - (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)))) - (assert (hash-table? tht) "FATAL: But here tht should be a hash-table") - tht)) - ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate - ;; dboard:get-tests-for-run-duplicate - returns a hash table - ;; (dboard:get-tests-dat tabdat run-id last-update)) - (all-test-ids (hash-table-keys tests-ht)) - (num-tests (length all-test-ids)) - ;; (print "run-struct: " run-struct) - ;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat) - ;; (tests (bubble-up tmptests priority: bubble-type)) - ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively. - ;; (debug:print 0 *default-log-port* "Getting data for run " run-id " with key-vals=" key-vals) - ;; Not sure this is needed? - (newmaxtests (max num-tests maxtests)) - ;; (last-update (- (current-seconds) 10)) - (run-struct (or run-struct - (dboard:rundat-make-init - run: run - tests: tests-ht - key-vals: key-vals))) - (new-res (if (null? all-test-ids) - res - (delete-duplicates - (cons run-struct res) - (lambda (a b) - (eq? (db:get-value-by-header (dboard:rundat-run a) header "id") - (db:get-value-by-header (dboard:rundat-run b) header "id")))))) - (elapsed-time (- (current-seconds) start-time))) - (if (null? all-test-ids) - (hash-table-delete! (dboard:tabdat-allruns-by-id tabdat) run-id) - (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id run-struct)) - - (if (or (null? tal) - (> elapsed-time 2)) ;; stop loading data after 5 - ;; seconds, on the next call - ;; more data *should* be - ;; loaded since - ;; get-tests-for-run uses last - ;; update - (begin - (when (> elapsed-time 2) - (debug:print 2 *default-log-port* "NOTE: updates are taking a long time, " elapsed-time "s elapsed.") - (let* ((old-val (iup:attribute *tim* "TIME")) - (new-val (number->string (inexact->exact (floor (* 2 (string->number old-val))))))) - (if (< (string->number new-val) 5000) - (begin - (debug:print 2 *default-log-port* "NOTE: increasing poll interval from "old-val" to "new-val) - (iup:attribute-set! *tim* "TIME" new-val))))) - (dboard:tabdat-allruns-set! tabdat new-res) - maxtests) - (if (> (dboard:rundat-run-data-offset run-struct) 0) - (begin - (thread-sleep! 0.2) ;; let the gui re-draw - (loop run tal new-res newmaxtests #t)) ;; not done getting data for this run - (begin - (hash-table-set! *dashboard-last-run-id-update* run-id (current-seconds)) - (loop (car tal)(cdr tal) new-res newmaxtests #f))))))) - (dboard:tabdat-filters-changed-set! tabdat #f) - (dboard:update-tree tabdat runs-hash header tb))) - -(define *collapsed* (make-hash-table)) - -(define (toggle-hide lnum uidat) ; fulltestname) - (let* ((btn (vector-ref (dboard:uidat-get-lftcol uidat) lnum)) - (fulltestname (iup:attribute btn "TITLE")) - (parts (string-split fulltestname "(")) - (basetestname (if (null? parts) "" (car parts)))) - ;(print "Toggling " basetestname " currently " (hash-table-ref/default *collapsed* basetestname #f)) - (if (hash-table-ref/default *collapsed* basetestname #f) - (begin - ;(iup:attribute-set! btn "FGCOLOR" "0 0 0")s - (hash-table-delete! *collapsed* basetestname)) - (begin - ;(iup:attribute-set! btn "FGCOLOR" "0 192 192") - (hash-table-set! *collapsed* basetestname #t))))) - -(define blank-line-rx (regexp "^\\s*$")) - -(define (run-item-name->vectors lst) - (map (lambda (x) - (let ((splst (string-split x "(")) - (res (vector "" ""))) - (vector-set! res 0 (car splst)) - (if (> (length splst) 1) - (vector-set! res 1 (car (string-split (cadr splst) ")")))) - res)) - lst)) - -(define (collapse-rows tabdat inlst) - (let* ((sort-info (get-curr-sort)) - (sort-by (vector-ref sort-info 1)) - (sort-order (vector-ref sort-info 2)) - (bubble-type (if (member sort-order '(testname)) - 'testname - 'itempath)) - (newlst (filter (lambda (x) - (let* ((tparts (string-split x "(")) - (basetname (if (null? tparts) x (car tparts)))) - ;(print "x " x " tparts: " tparts " basetname: " basetname) - (cond - ((string-match blank-line-rx x) #f) - ((equal? x basetname) #t) - ((hash-table-ref/default *collapsed* basetname #f) - ;(print "Removing " basetname " from items") - #f) - (else #t)))) - inlst)) - (vlst (run-item-name->vectors newlst)) - (vlst2 (bubble-up tabdat vlst priority: bubble-type))) - (map (lambda (x) - (if (equal? (vector-ref x 1) "") - (vector-ref x 0) - (conc (vector-ref x 0) "(" (vector-ref x 1) ")"))) - vlst2))) - -(define (update-labels uidat alltestnames) - (let* ((rown 0) - (keycol (dboard:uidat-get-keycol uidat)) - (lftcol (dboard:uidat-get-lftcol uidat)) - (numcols (vector-length lftcol)) - (maxn (- numcols 1)) - (allvals (make-vector numcols ""))) - (for-each (lambda (name) - (if (<= rown maxn) - (vector-set! allvals rown name)) ;) - (set! rown (+ 1 rown))) - alltestnames) - (let loop ((i 0)) - (let* ((lbl (vector-ref lftcol i)) - (keyval (vector-ref keycol i)) - (oldval (iup:attribute lbl "TITLE")) - (newval (vector-ref allvals i))) - (if (not (equal? oldval newval)) - (let ((munged-val (let ((parts (string-split newval "("))) - (if (> (length parts) 1)(conc " " (car (string-split (cadr parts) ")"))) newval)))) - (vector-set! keycol i newval) - (iup:attribute-set! lbl "TITLE" munged-val))) - (iup:attribute-set! lbl "FGCOLOR" (if (hash-table-ref/default *collapsed* newval #f) "0 112 112" "0 0 0")) - (if (< i maxn) - (loop (+ i 1))))))) - - -(define (get-itemized-tests test-dats) - (let ((tnames '())) - (for-each (lambda (tdat) - (let ((tname (vector-ref tdat 0)) ;; (db:test-get-testname tdat)) - (ipath (vector-ref tdat 1))) ;; (db:test-get-item-path tdat))) - (if (not (equal? ipath "")) - (if (and (list? tnames) - (string? tname) - (not (member tname tnames))) - (set! tnames (cons tname tnames)))))) - test-dats) - (reverse tnames))) - -;; Bubble up the top tests to above the items, collect the items underneath -;; all while preserving the sort order from the SQL query as best as possible. -;; -(define (bubble-up tabdat test-dats #!key (priority 'itempath)) - (if (null? test-dats) - test-dats - (begin - (let* ((tnames '()) ;; list of names used to reserve order - (tests-ht (make-hash-table)) ;; hash of lists, used to build as we go - (itemized (get-itemized-tests test-dats))) - #;(for-each - (lambda (testdat) - (let* ((tname (vector-ref testdat 0)) ;; db:test-get-testname testdat)) - (ipath (vector-ref testdat 1))) ;; db:test-get-item-path testdat))) - ;; (seen (hash-table-ref/default tests-th tname #f))) - (if (not (member tname tnames)) - (if (or (and (eq? priority 'itempath) - (not (equal? ipath ""))) - (and (eq? priority 'testname) - (equal? ipath "")) - (not (member tname itemized))) - (set! tnames (append tnames (list tname))))) - (if (equal? ipath "") - ;; This a top level, prepend it - (hash-table-set! tests-ht tname (cons testdat (hash-table-ref/default tests-ht tname '()))) - ;; This is item, append it - (hash-table-set! tests-ht tname (append (hash-table-ref/default tests-ht tname '())(list testdat)))))) - test-dats) - ;; 1. put all test/items into lists in tests-ht - (for-each - (lambda (testdat) - (let* ((tname (vector-ref testdat 0)) ;; db:test-get-testname testdat)) - (ipath (vector-ref testdat 1))) ;; db:test-get-item-path testdat))) - ;; (seen (hash-table-ref/default tests-ht tname #f))) - (if (not (member tname tnames)) - (if (or (and (eq? priority 'itempath) - (not (equal? ipath ""))) - (and (eq? priority 'testname) - (equal? ipath "")) - (not (member tname itemized))) - (set! tnames (append tnames (list tname))))) - (hash-table-set! tests-ht tname (cons testdat (hash-table-ref/default tests-ht tname '()))))) - test-dats) - ;; now bubble up the non-item test in itemized tests - (hash-table-for-each - tests-ht - (lambda (k v) - (if (> (length v) 1) ;; must be itemized, push the no-item to the front - (hash-table-set! tests-ht k (sort v (lambda (a b)(not (equal? (vector-ref b 1) "")))))))) - ;; Set all tests with items - (dboard:tabdat-item-test-names-set! tabdat (append (if (null? tnames) - '() - (filter (lambda (tname) - (let ((tlst (hash-table-ref tests-ht tname))) - (and (list tlst) - (> (length tlst) 1)))) - tnames)) - (dboard:tabdat-item-test-names tabdat))) - (let loop ((hed (car tnames)) - (tal (cdr tnames)) - (res '())) - (let ((newres (append res (hash-table-ref tests-ht hed)))) - (if (null? tal) - newres - (loop (car tal)(cdr tal) newres)))))))) - -;; optimized to get runs constrained by what is visible on the screen -;; - not appropriate for where all the runs are needed -;; -(define (update-buttons tabdat uidat numruns numtests) - (let* ((runs (if (> (length (dboard:tabdat-allruns tabdat)) numruns) - (take-right (dboard:tabdat-allruns tabdat) numruns) - (pad-list (dboard:tabdat-allruns tabdat) numruns))) - (lftcol (dboard:uidat-get-lftcol uidat)) - (tableheader (dboard:uidat-get-header uidat)) - (table (dboard:uidat-get-runsvec uidat)) - (coln 0) - (all-test-names (make-hash-table)) - (use-bgcolor (equal? (configf:lookup *configdat* "dashboard" "use-bgcolor") "yes")) ;; doesn't work - ) - ;; create a concise list of test names - ;; - (for-each - (lambda (rundat) - (if rundat - (let* ((testdats (dboard:rundat-tests rundat)) - (testnames (map test:test-get-fullname (hash-table-values testdats)))) - (dcommon:rundat-copy-tests-to-by-name rundat) - ;; for the normalized list of testnames (union of all runs) - (if (not (and (dboard:tabdat-hide-empty-runs tabdat) - (null? testnames))) - (for-each (lambda (testname) - (hash-table-set! all-test-names testname #t)) - testnames))))) - runs) - - ;; create the minimize list of testnames to be displayed. Sorting - ;; happens here *before* trimming - ;; - (dboard:tabdat-all-test-names-set! - tabdat - (collapse-rows - tabdat - (sort (hash-table-keys all-test-names) string>?))) ;; FIXME: Sorting needs to happen here - - ;; Trim the names list to fit the matrix of buttons - ;; - (dboard:tabdat-all-test-names-set! - tabdat - (let ((xl (if (> (length (dboard:tabdat-all-test-names tabdat)) (dboard:tabdat-start-test-offset tabdat)) - (drop (dboard:tabdat-all-test-names tabdat) - (dboard:tabdat-start-test-offset tabdat)) - '()))) - (append xl (make-list (- (dboard:tabdat-num-tests tabdat) (length xl)) "")))) - (update-labels uidat (dboard:tabdat-all-test-names tabdat)) - (for-each ;;run - (lambda (rundat) - (if (or (not rundat) ;; handle padded runs - (not (dboard:rundat-run rundat))) - ;; Need to put an empty column in to erase previous contents. - (set! rundat (dboard:rundat-make-init - key-vals: (map (lambda (x) "")(dboard:tabdat-keys tabdat))))) - (let* ((run (dboard:rundat-run rundat)) - (testsdat-by-name (dboard:rundat-tests-by-name rundat)) - (key-val-dat (dboard:rundat-key-vals rundat)) - (run-id (db:get-value-by-header run (dboard:tabdat-header tabdat) "id")) - (key-vals (append key-val-dat - (list (let ((x (db:get-value-by-header run (dboard:tabdat-header tabdat) "runname"))) - (if (string? x) x ""))))) - (run-key (string-intersperse key-vals "\n"))) - - ;; fill in the run header key values - ;; - (let ((rown 0) - (headercol (vector-ref tableheader coln))) - (for-each (lambda (kval) - (let* ((labl (vector-ref headercol rown))) - (if (not (equal? kval (iup:attribute labl "TITLE"))) - (iup:attribute-set! (vector-ref headercol rown) "TITLE" kval)) - (set! rown (+ rown 1)))) - key-vals)) - ;; For this run now fill in the buttons for each test - ;; - (let ((rown 0) - (columndat (vector-ref table coln))) - (for-each - (lambda (testname) - (let ((buttondat (hash-table-ref/default (dboard:tabdat-buttondat tabdat) (mkstr coln rown) #f))) - (if (and buttondat - (hash-table? testsdat-by-name)) - (let* ((testdat (let ((matching (hash-table-ref/default testsdat-by-name testname #f))) - ;; (filter - ;; (lambda (x)(equal? (test:test-get-fullname x) testname)) - ;; testsdat))) - (if (not matching) - (vector -1 -1 "" "" "" 0 "" "" 0 "" "" "" 0 "" "") - ;; (car matching)))) - matching))) - (teststatus (db:test-get-status testdat)) - (teststate (db:test-get-state testdat)) - (buttontxt (cond - ((member teststate '("COMPLETED" "ARCHIVED")) teststatus) - ((and (equal? teststate "NOT_STARTED") - (member teststatus '("ZERO_ITEMS" "BLOCKED" "PREQ_FAIL" "PREQ_DISCARDED" "TIMED_OUT" "KEEP_TRYING" "TEN_STRIKES"))) - teststatus) - (else - teststate))) - (button (vector-ref columndat rown)) - (color (car (gutils:get-color-for-state-status teststate teststatus))) - (curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR")) - (curr-title (vector-ref buttondat 2))) ;; (iup:attribute button "TITLE"))) - (if (not (equal? curr-color color)) - (if use-bgcolor - (iup:attribute-set! button "BGCOLOR" color) - (iup:attribute-set! button "IMAGE" (make-image *images* buttontxt color)))) - (if (and (not use-bgcolor) ;; bgcolor does not work with text - (not (equal? curr-title buttontxt))) - (iup:attribute-set! button "TITLE" buttontxt)) - (vector-set! buttondat 0 run-id) - (vector-set! buttondat 1 color) - (vector-set! buttondat 2 buttontxt) - (vector-set! buttondat 3 testdat) - (vector-set! buttondat 4 run-key))) - (set! rown (+ rown 1)))) - (dboard:tabdat-all-test-names tabdat))) - (set! coln (+ coln 1)))) - runs))) - -(define (mkstr . x) - (string-intersperse (map conc x) ",")) - -(define (set-bg-on-filter commondat tabdat) - (let ((search-changed (not (null? (filter (lambda (key) - (not (equal? (hash-table-ref (dboard:tabdat-searchpatts tabdat) key) "%"))) - (hash-table-keys (dboard:tabdat-searchpatts tabdat)))))) - (state-changed (not (null? (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat))))) - (status-changed (not (null? (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)))))) - (iup:attribute-set! (dboard:commondat-hide-not-hide-tabs commondat) "BGCOLOR" - (if (or search-changed - state-changed - status-changed) - "190 180 190" - "190 190 190" - )) - (dboard:tabdat-filters-changed-set! tabdat #t))) - -(define (update-search commondat tabdat x val) - (hash-table-set! (dboard:tabdat-searchpatts tabdat) x val) - (dboard:tabdat-filters-changed-set! tabdat #t) - (mark-for-update tabdat) - (set-bg-on-filter commondat tabdat)) - -;; force ALL updates to zero (effectively) -;; -(define (mark-for-update tabdat) - (dboard:tabdat-last-db-update-set! tabdat (make-hash-table))) - -;;====================================================================== -;; R U N C O N T R O L -;;====================================================================== - -;; target populating logic -;; -;; lb = -;; field = target field name for this dropdown -;; referent-vals = selected value in the left dropdown -;; targets = list of targets to use to build the dropdown -;; -;; each node is chained: key1 -> key2 -> key3 -;; -;; must select values from only apropriate targets -;; a b c -;; a d e -;; a b f -;; a/b => c f -;; -(define (dashboard:populate-target-dropdown lb referent-vals targets) ;; runconf-targs) - ;; is the current value in the new list? choose new default if not - (let* ((remvalues (map (lambda (row) - (common:list-is-sublist referent-vals (vector->list row))) - targets)) - (values (delete-duplicates (map car (filter list? remvalues)))) - (sel-valnum (iup:attribute lb "VALUE")) - (sel-val (iup:attribute lb sel-valnum)) - (val-num 1)) - ;; first check if the current value is in the new list, otherwise replace with - ;; first value from values - (iup:attribute-set! lb "REMOVEITEM" "ALL") - (for-each (lambda (val) - ;; (iup:attribute-set! lb "APPENDITEM" val) - (iup:attribute-set! lb (conc val-num) val) - (if (equal? sel-val val) - (iup:attribute-set! lb "VALUE" val-num)) - (set! val-num (+ val-num 1))) - values) - (let ((val (iup:attribute lb "VALUE"))) - (if val - val - (if (not (null? values)) - (let ((newval (car values))) - (iup:attribute-set! lb "VALUE" newval) - newval)))))) - -(define (dashboard:update-target-selector tabdat #!key (action-proc #f)) - (let* ((runconf-targs (common:get-runconfig-targets)) - (key-lbs (dboard:tabdat-key-listboxes tabdat)) - (db-target-dat (rmt:get-targets)) - (header (vector-ref db-target-dat 0)) - (db-targets (vector-ref db-target-dat 1)) - (munge-target (lambda (x) ;; create a target vector from a string. Pad with na if needed. - (list->vector - (take (append (string-split x "/") - (make-list (length header) "na")) - (length header))))) - (all-targets (append (list (munge-target (string-intersperse - (map (lambda (x) "%") header) - "/"))) - db-targets - (map munge-target - runconf-targs) - )) - (key-listboxes (if key-lbs key-lbs (make-list (length header) #f)))) - (if (not (dboard:tabdat-key-listboxes tabdat))(dboard:tabdat-key-listboxes-set! tabdat key-listboxes)) - (let loop ((key (car header)) - (remkeys (cdr header)) - (refvals '()) - (indx 0) - (lbs '())) - (let* ((lb (let ((lb (list-ref key-listboxes indx))) - (if lb - lb - (iup:listbox - #:size "x60" - #:fontsize "10" - #:expand "YES" ;; "VERTICAL" - ;; #:dropdown "YES" - #:editbox "YES" - #:action (lambda (obj a b c) - (debug:catch-and-dump action-proc "update-target-selector")) - #:caret_cb (lambda (obj a b c) - (debug:catch-and-dump action-proc "update-target-selector")) - )))) - ;; loop though all the targets and build the list for this dropdown - (selected-value (dashboard:populate-target-dropdown lb refvals all-targets))) - (if (null? remkeys) - ;; return a list of the listbox items and an iup:hbox with the labels and listboxes - (let* ((listboxes (append lbs (list lb))) - (res (list listboxes - (map (lambda (htxt lb) - (iup:vbox - (iup:label htxt) - lb)) - header - listboxes)))) - (dboard:tabdat-key-listboxes-set! tabdat res) - res) - (loop (car remkeys) - (cdr remkeys) - (append refvals (list selected-value)) - (+ indx 1) - (append lbs (list lb)))))))) - -;; Make a vertical list of toggles using items, when toggled call proc with the conc'd string -;; interspersed with commas -;; -(define (dashboard:text-list-toggle-box items proc) - (let ((alltgls (make-hash-table))) - (apply iup:vbox - (map (lambda (item) - (iup:toggle - item - #:fontsize 8 - #:expand "YES" - #:action (lambda (obj tstate) - (debug:catch-and-dump - (lambda () - (if (eq? tstate 0) - (hash-table-delete! alltgls item) - (hash-table-set! alltgls item #t)) - (let ((all (hash-table-keys alltgls))) - (proc all))) - "text-list-toggle-box")))) - items)))) - -;; 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 (let ((run-input (dboard:tabdat-run-name tabdat)) - ) - (if (equal? run-input "") - "no-runname-specified" - run-input))) - (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))) - -;; 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)) - )) - -;;====================================================================== -;; R U N C O N T R O L S -;;====================================================================== -;; -;; A gui for launching tests -;; - -(define (dboard:target-updater tabdat) ;; key-listboxes) - (let ((targ (map (lambda (x) - (iup:attribute x "VALUE")) - (car (dashboard:update-target-selector tabdat)))) - (curr-runname (dboard:tabdat-run-name tabdat))) - (dboard:tabdat-target-set! tabdat targ) - ;; (if (dboard:tabdat-updater-for-runs tabdat) - ;; ((dboard:tabdat-updater-for-runs tabdat))) - (if (or (not (equal? curr-runname (dboard:tabdat-run-name tabdat))) - (equal? (dboard:tabdat-run-name tabdat) "")) - (dboard:tabdat-run-name-set! tabdat curr-runname)) - (dashboard:update-run-command tabdat))) - -;; used by run-controls -;; -(define (dashboard:update-tree-selector tabdat #!key (action-proc #f)) - (let* ((tb (dboard:tabdat-runs-tree tabdat)) - (runconf-targs (common:get-runconfig-targets)) - (db-target-dat (rmt:get-targets)) - (runs-tree-ht (dboard:tabdat-runs-tree-ht tabdat)) - (header (vector-ref db-target-dat 0)) - (db-targets (vector-ref db-target-dat 1)) - (munge-target (lambda (x) ;; create a target vector from a string. Pad with na if needed. - (take (append (string-split x "/") - (make-list (length header) "na")) - (length header)))) - (all-targets (append (list (munge-target (string-intersperse - (map (lambda (x) "%") header) - "/"))) - (map vector->list db-targets) - (map munge-target - runconf-targs) - ))) - (for-each - (lambda (target) - (if (not (hash-table-ref/default runs-tree-ht target #f)) - ;; (let ((existing (tree:find-node tb target))) - ;; (if (not existing) - (begin - (tree:add-node tb "Runs" target) ;; (append key-vals (list run-name)) - (hash-table-set! runs-tree-ht target #t)))) - all-targets))) - -;; Run controls panel -;; -(define (dashboard:run-controls commondat tabdat #!key (tab-num #f)) - (let* ((targets (make-hash-table)) - (test-records (make-hash-table)) - (all-tests-registry (tests:get-all)) ;; (tests:get-valid-tests *toppath* '())) - (test-names (hash-table-keys all-tests-registry)) - (sorted-testnames #f) - (action "-run") - (cmdln "") - (runlogs (make-hash-table)) - ;;; (key-listboxes #f) - (update-keyvals (lambda () ;; gets called in dashboard:update-target-selector as "action-proc" - (dboard:target-updater (dboard:tabdat-key-listboxes tabdat)))) - (tests-draw-state (make-hash-table)) ;; use for keeping state of the test canvas - (test-patterns-textbox #f)) - (hash-table-set! tests-draw-state 'first-time #t) - ;; (hash-table-set! tests-draw-state 'scalef 1) - (tests:get-full-data test-names test-records '() all-tests-registry) - (set! sorted-testnames (tests:sort-by-priority-and-waiton test-records)) - - ;; refer to (dboard:tabdat-keys tabdat), (dboard:tabdat-dbkeys tabdat) for keys - (let* ((result - (iup:vbox - (dcommon:command-execution-control tabdat) - (iup:split - #:orientation "VERTICAL" ;; "HORIZONTAL" - #:value 200 - ;; - ;; (iup:split - ;; #:value 300 - - ;; Target, testpatt, state and status input boxes - ;; - (iup:split - #:orientation "HORIZONTAL" - (iup:vbox - ;; Command to run, placed over the top of the canvas - (dcommon:command-action-selector commondat tabdat tab-num: tab-num) - (dboard:runs-tree-browser commondat tabdat)) - (iup:vbox - (dcommon:command-runname-selector commondat tabdat tab-num: tab-num) - (dcommon:command-testname-selector commondat tabdat update-keyvals))) - ;; key-listboxes)) - (dcommon:command-tests-tasks-canvas tabdat test-records sorted-testnames tests-draw-state)))) - (tb (dboard:tabdat-runs-tree tabdat))) - (dboard:commondat-add-updater - commondat - (lambda () - (if (dashboard:database-changed? commondat tabdat context-key: 'run-control) - (dashboard:update-tree-selector tabdat))) - tab-num: tab-num) - result))) - - ;;(iup:frame - ;; #:title "Logs" ;; To be replaced with tabs - ;; (let ((logs-tb (iup:textbox #:expand "YES" - ;; #:multiline "YES"))) - ;; (dboard:tabdat-logs-textbox-set! tabdat logs-tb) - ;; logs-tb)) - -;; browse runs as a tree. Used in both "Runs" tab and -;; in the runs control panel. -;; -(define (dboard:runs-tree-browser commondat tabdat) - (let* ((txtbox (iup:textbox - #:action (lambda (val a b) - (debug:catch-and-dump - (lambda () - ;; for the Runs view we put the list - ;; of keyvals into tabdat target for - ;; the Run Controls we put then update - ;; the run-command - (if b (dboard:tabdat-target-set! tabdat - (string-split b "/"))) - (dashboard:update-run-command tabdat)) - "command-testname-selector tb action")) - #:value (dboard:test-patt->lines - (dboard:tabdat-test-patts-use tabdat)) - #:expand "HORIZONTAL" - ;; #:size "10x30" - )) - (tb - (iup:treebox - #:value 0 - #:title "Runs" ;; was #:name -- iup 3.19 changed - ;; this... "Changed: [DEPRECATED - ;; REMOVED] removed the old attribute - ;; NAMEid from IupTree to avoid - ;; conflict with the common attribute - ;; NAME. Use the TITLEid attribute." - #:expand "YES" - #:addexpanded "YES" - #:size "10x" - #:selection-cb - (lambda (obj id state) - (debug:catch-and-dump - (lambda () - (let* ((run-path (tree:node->path obj id)) - (run-id (tree-path->run-id tabdat (cdr run-path)))) - ;; (dboard:tabdat-view-changed-set! tabdat #t) ;; ?? - ;; done below when run-id is a number - (dboard:tabdat-target-set! tabdat (cdr run-path)) ;; (print - ;; "run-path: - ;; " - ;; run-path) - (iup:attribute-set! txtbox "VALUE" - (string-intersperse (cdr run-path) "/")) - (dashboard:update-run-command tabdat) - (dboard:tabdat-layout-update-ok-set! tabdat #f) - (if (number? run-id) - (begin - ;; capture last two in tabdat. - (dboard:tabdat-prev-run-id-set! - tabdat - (dboard:tabdat-curr-run-id tabdat)) - (dboard:tabdat-curr-run-id-set! tabdat run-id) - (dboard:tabdat-view-changed-set! tabdat #t)) - (debug:print-error 5 *default-log-port* "tree-path->run-id returned non-number " run-id)))) - "treebox")) - ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) - ))) - (dboard:tabdat-runs-tree-set! tabdat tb) - (iup:detachbox - (iup:vbox - txtbox - tb - )))) - -;; browse runs as a tree. Used in both "Runs" tab and -;; in the runs control panel. -;; -;; THIS IS THE NEW ONE -;; -(define (dboard:runs-tree-new-browser commondat rdat) - (let* ((txtbox (iup:textbox - #:action (lambda (val a b) - (debug:catch-and-dump - (lambda () - ;; for the Runs view we put the list - ;; of keyvals into tabdat target for - ;; the Run Controls we put then update - ;; the run-command - (if b (dboard:rdat-targ-sql-filt-set! rdat - (string-split b "/"))) - #;(dashboard:update-run-command tabdat)) - "command-testname-selector tb action")) - ;; #:value (dboard:test-patt->lines ;; This seems like it was wrong, BUG in code where it was copied from? - ;; (dboard:tabdat-test-patts-use tabdat)) - #:expand "HORIZONTAL" - ;; #:size "10x30" - )) - (tb - (iup:treebox - #:value 0 - #:title "Runs" ;; was #:name -- iup 3.19 changed - ;; this... "Changed: [DEPRECATED - ;; REMOVED] removed the old attribute - ;; NAMEid from IupTree to avoid - ;; conflict with the common attribute - ;; NAME. Use the TITLEid attribute." - #:expand "YES" - #:addexpanded "YES" - ;; #:size "10x" - #:selection-cb - (lambda (obj id state) - (debug:catch-and-dump - (lambda () - (let* ((run-path (tree:node->path obj id)) - (run-id (new-tree-path->run-id rdat (cdr run-path)))) - ;; (dboard:tabdat-view-changed-set! tabdat #t) ;; ?? - ;; done below when run-id is a number - (dboard:rdat-targ-sql-filt-set! rdat (cdr run-path)) ;; (print - ;; "run-path: - ;; " - ;; run-path) - (iup:attribute-set! txtbox "VALUE" - (string-intersperse (cdr run-path) "/")) - #;(dashboard:update-run-command tabdat) - #;(dboard:tabdat-layout-update-ok-set! tabdat #f) - (if (number? run-id) - (begin - ;; capture last two in tabdat. - (dboard:rdat-push-run-id rdat run-id) - (dboard:rdat-view-changed-set! rdat #t)) - (debug:print-error 5 *default-log-port* "tree-path->run-id returned non-number " run-id)))) - "treebox")) - ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) - ))) - (dboard:rdat-runs-tree-set! rdat tb) - (iup:detachbox - (iup:vbox - txtbox - tb - )))) - -;;====================================================================== -;; R U N C O N T R O L S -;;====================================================================== -;; -;; A gui for launching tests -;; -(define (dashboard:run-times commondat tabdat #!key (tab-num #f)) - (let* ((drawing (vg:drawing-new)) - (run-times-tab-updater (lambda () - (debug:catch-and-dump - (lambda () - (let ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))) - (if tabdat - (let ((last-data-update (dboard:tabdat-last-data-update tabdat)) - (now-time (current-seconds))) - (dashboard:run-times-tab-canvas-updater commondat tabdat tab-num) - (if (> (- now-time last-data-update) 5) - (if (not (dboard:tabdat-running-layout tabdat)) - (begin - (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num) - (dboard:tabdat-last-data-update-set! tabdat now-time) - ;; this is threadified to return control to the gui for a redraw. - ;; it relies on the running-layout flag to prevent overlapping - ;; calls. - (thread-start! (make-thread - (lambda () - (dboard:tabdat-running-layout-set! tabdat #t) - (dashboard:run-times-tab-layout-updater commondat tabdat tab-num) - (dboard:tabdat-running-layout-set! tabdat #f)) - "run-times-tab-layout-updater"))) - )))))) - "dashboard:run-times-tab-updater"))) - (key-listboxes #f) ;; - (update-keyvals (lambda () - (dboard:target-updater tabdat)))) - (dboard:tabdat-drawing-set! tabdat drawing) - (dboard:commondat-add-updater commondat run-times-tab-updater tab-num: tab-num) - (iup:split - #:orientation "VERTICAL" ;; "HORIZONTAL" - #:value 150 - (iup:vbox - - (dboard:runs-tree-browser commondat tabdat) - - (iup:hbox - (iup:toggle - "Compact layout" - #:fontsize 8 - #:expand "HORIZONTAL" - #:value 1 - #:action (lambda (obj tstate) - (debug:catch-and-dump - (lambda () - ;; (print "tstate: " tstate) - (if (eq? tstate 0) - (dboard:tabdat-compact-layout-set! tabdat #f) - (dboard:tabdat-compact-layout-set! tabdat #t)) - (dboard:tabdat-last-filter-str-set! tabdat "") - ) - "text-list-toggle-box")))) - (dcommon:command-runname-selector commondat tabdat tab-num: tab-num) - (dcommon:command-testname-selector commondat tabdat update-keyvals)) - (iup:vbox - (iup:split - #:orientation "HORIZONTAL" - #:value 800 - (let* ((cnv-obj (iup:canvas - ;; #:size "250x250" ;; "500x400" - #:expand "YES" - #:scrollbar "YES" - #:posx "0.5" - #:posy "0.5" - #:action (make-canvas-action - (lambda (c xadj yadj) - (debug:catch-and-dump - (lambda () - (if (not (dboard:tabdat-cnv tabdat)) - (let ((cnv (dboard:tabdat-cnv tabdat))) - (dboard:tabdat-cnv-set! tabdat c) - (vg:drawing-cnv-set! (dboard:tabdat-drawing tabdat) - (dboard:tabdat-cnv tabdat)))) - (let ((drawing (dboard:tabdat-drawing tabdat)) - (old-xadj (dboard:tabdat-xadj tabdat)) - (old-yadj (dboard:tabdat-yadj tabdat))) - (if (not (and (eq? xadj old-xadj)(eq? yadj old-yadj))) - (begin - ;; (print "xadj: " xadj " yadj: " yadj "changed: "(eq? xadj old-xadj) " " (eq? yadj old-yadj)) - (dboard:tabdat-view-changed-set! tabdat #t) - (dboard:tabdat-xadj-set! tabdat (* -2000 (- xadj 0.5))) - (dboard:tabdat-yadj-set! tabdat (* 2000 (- yadj 0.5))) - )))) - "iup:canvas action"))) - #:wheel-cb (lambda (obj step x y dir) ;; dir is 4 for up and 5 for down. I think. - (debug:catch-and-dump - (lambda () - (let* ((drawing (dboard:tabdat-drawing tabdat)) - (scalex (vg:drawing-scalex drawing))) - (dboard:tabdat-view-changed-set! tabdat #t) - ;; (print "step: " step " x: " x " y: " y " dir: " dir " scalex: " scalex) - (vg:drawing-scalex-set! drawing - (+ scalex - (if (> step 0) - (* scalex 0.02) - (* scalex -0.02)))))) - "wheel-cb")) - ))) - cnv-obj) - (let* ((hb1 (iup:hbox)) - (graph-cell-table (dboard:tabdat-graph-cell-table tabdat)) - (changed #f) - (graph-matrix (iup:matrix - #:alignment1 "ALEFT" - ;; #:expand "YES" ;; "HORIZONTAL" - #:scrollbar "YES" - #:numcol 10 - #:numlin 20 - #:numcol-visible 5 ;; (min 8) - #:numlin-visible 1 - #:click-cb - (lambda (obj row col status) - (let* - ((graph-cell (conc row ":" col)) - (graph-dat (hash-table-ref/default graph-cell-table graph-cell #f)) - (graph-flag (dboard:graph-dat-flag graph-dat))) - (if graph-flag - (dboard:graph-dat-flag-set! graph-dat #f) - (dboard:graph-dat-flag-set! graph-dat #t)) - (if (not (dboard:tabdat-running-layout tabdat)) - (begin - (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num) - (dboard:tabdat-last-data-update-set! tabdat (current-seconds)) - (thread-start! (make-thread - (lambda () - (dboard:tabdat-running-layout-set! tabdat #t) - (dashboard:run-times-tab-layout-updater commondat tabdat tab-num) - (dboard:tabdat-running-layout-set! tabdat #f)) - "run-times-tab-layout-updater")))) - ;;(dboard:tabdat-view-changed-set! tabdat #t) - ))))) - (dboard:tabdat-graph-matrix-set! tabdat graph-matrix) - (iup:attribute-set! graph-matrix "WIDTH0" 0) - (iup:attribute-set! graph-matrix "HEIGHT0" 0) - graph-matrix)) - (iup:hbox - (iup:vbox - (iup:button "Show All" #:action (lambda (obj) - (for-each (lambda (graph-cell) - (let* ((graph-dat (hash-table-ref (dboard:tabdat-graph-cell-table tabdat) graph-cell))) - (dboard:graph-dat-flag-set! graph-dat #t))) - (hash-table-keys (dboard:tabdat-graph-cell-table tabdat)))))) - (iup:hbox - (iup:button "Hide All" #:action (lambda (obj) - (for-each (lambda (graph-cell) - (let* ((graph-dat (hash-table-ref (dboard:tabdat-graph-cell-table tabdat) graph-cell))) - (dboard:graph-dat-flag-set! graph-dat #f))) - (hash-table-keys (dboard:tabdat-graph-cell-table tabdat))))))) - )))) - -;;====================================================================== -;; R U N -;;====================================================================== -;; -;; display and manage a single run at a time - -(define (tree-path->run-id tabdat path) - (if (not (null? path)) - (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) path #f) - #f)) - -(define (new-tree-path->run-id rdat path) - (if (not (null? path)) - (hash-table-ref/default (dboard:rdat-path-run-ids tabdat) path #f) - #f)) - -;; (define (dboard:get-tests-dat tabdat run-id last-update) -;; (let* ((access-mode (dboard:tabdat-access-mode tabdat)) -;; (tdat (if run-id (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run -;; run-id -;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") -;; (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)) ;; '() -;; (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)) ;; '() -;; #f #f ;; offset limit -;; (dboard:tabdat-hide-not-hide tabdat) ;; not-in -;; #f #f ;; sort-by sort-order -;; #f ;; get all? "id,testname,item_path,state,status,event_time,run_duration" ;; qryval -;; (if (dboard:tabdat-filters-changed tabdat) -;; 0 -;; last-update) -;; *dashboard-mode*) -;; '()))) ;; get 'em all -;; ;; (debug:print 0 *default-log-port* "dboard:get-tests-dat: got " (length tdat) " test records for run " run-id) -;; (sort tdat (lambda (a b) -;; (let* ((aval (vector-ref a 2)) -;; (bval (vector-ref b 2)) -;; (anum (string->number aval)) -;; (bnum (string->number bval))) -;; (if (and anum bnum) -;; (< anum bnum) -;; (string<= aval bval))))))) - - -(define (dashboard:safe-cadr-assoc name lst) - (let ((res (assoc name lst))) - (if (and res (> (length res) 1)) - (cadr res) - #f))) - -(define (dboard:update-tree tabdat runs-hash runs-header tb) - (let* ((access-mode (dboard:tabdat-access-mode tabdat)) - (run-ids (sort (filter number? (hash-table-keys runs-hash)) - (lambda (a b) - (let* ((record-a (hash-table-ref runs-hash a)) - (record-b (hash-table-ref runs-hash b)) - (time-a (db:get-value-by-header record-a runs-header "event_time")) - (time-b (db:get-value-by-header record-b runs-header "event_time"))) - (< time-a time-b))))) - (changed #f) - (last-runs-update (dboard:tabdat-last-runs-update tabdat)) - (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))) - (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) - (for-each (lambda (run-id) - (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) - (key-vals (map (lambda (key) - (let ((val (db:get-value-by-header run-record runs-header key))) - (if (string? val) val ""))) - (dboard:tabdat-keys tabdat))) - (run-name (db:get-value-by-header run-record runs-header "runname")) - (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) - (run-path (append key-vals (list run-name)))) - (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f)) - ;; (let ((existing (tree:find-node tb run-path))) - ;; (if (not existing) - (begin - (hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path) - ;; (iup:attribute-set! (dboard:tabdat-runs-matrix tabdat) - ;; (conc rownum ":" colnum) col-name) - ;; (hash-table-set! runid-to-col run-id (list colnum run-record)) - ;; Here we update the tests treebox and tree keys - (tree:add-node tb "Runs" run-path) ;; (append key-vals (list run-name)) - ;; userdata: (conc "run-id: " run-id)))) - (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id) - ;; (set! colnum (+ colnum 1)) - )))) - run-ids))) - -(define (dashboard:tests-ht->tests-dat tests-ht) - (reverse - (sort - (hash-table-values tests-ht) - (lambda (a b) - (let ((a-test-name (db:test-get-testname a)) - (a-item-path (db:test-get-item-path a)) - (b-test-name (db:test-get-testname b)) - (b-item-path (db:test-get-item-path b)) - (a-event-time (db:test-get-event_time a)) - (b-event-time (db:test-get-event_time b))) - (if (not (equal? a-test-name b-test-name)) - (> a-event-time b-event-time) - (cond - ((< 0 (string-compare3 a-test-name b-test-name)) #t) - ((> 0 (string-compare3 a-test-name b-test-name)) #f) - ((< 0 (string-compare3 a-item-path b-item-path)) #t) - (else #f)))))))) - - -(define (dashboard:run-id->tests-mindat run-id tabdat runs-hash) - (let* ((run (hash-table-ref/default runs-hash run-id #f)) - (key-vals (rmt:get-key-vals run-id)) - (testnamepatt (or (dboard:tabdat-test-patts tabdat) "%/%")) - (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)) - (tests-dat (dashboard:tests-ht->tests-dat tests-ht)) - (tests-mindat (dcommon:minimize-test-data tests-dat))) ;; reduces data for display - (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) - (hash-table-set! (dboard:tabdat-last-test-dat tabdat) run-id tests-dat) - (hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- (current-seconds) 10)) - (when (not run) - (debug:print-info 13 *default-log-port* "ERROR: NO RUN FOR RUN-ID run-id="run-id) - (debug:print-info 13 *default-log-port* "runs-hash-> " (hash-table->alist runs-hash)) - ) - tests-mindat)) - -(define (dashboard:runs-summary-xor-matrix-content tabdat runs-hash #!key (hide-clean #f)) - (let* ((src-run-id (dboard:tabdat-prev-run-id tabdat)) - (dest-run-id (dboard:tabdat-curr-run-id tabdat))) - (if (and src-run-id dest-run-id) - (dcommon:xor-tests-mindat - (dashboard:run-id->tests-mindat src-run-id tabdat runs-hash) - (dashboard:run-id->tests-mindat dest-run-id tabdat runs-hash) - hide-clean: hide-clean) - #f))) - - -(define (dashboard:get-runs-hash tabdat) - (let* ((access-mode (dboard:tabdat-access-mode tabdat)) - (last-runs-update 0);;(dboard:tabdat-last-runs-update tabdat)) - (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) - (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records - (runs (vector-ref runs-dat 1)) - (run-id (dboard:tabdat-curr-run-id tabdat)) - (runs-hash (let ((ht (make-hash-table))) - (for-each (lambda (run) - (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) - runs) ht))) - runs-hash)) - - -(define (dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix) - ;; (if (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-rundat) - (dashboard:do-update-rundat tabdat) ;; ) - (dboard:runs-summary-control-panel-updater tabdat) - (let* ((last-runs-update (dboard:tabdat-last-runs-update tabdat)) - (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) - (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records - (runs (vector-ref runs-dat 1)) - (run-id (dboard:tabdat-curr-run-id tabdat)) - (runs-hash (dashboard:get-runs-hash tabdat)) - ;; (runs-hash (let ((ht (make-hash-table))) - ;; (for-each (lambda (run) - ;; (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) - ;; runs) - ;; ht)) - ) - (if (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-tree) - (dboard:update-tree tabdat runs-hash runs-header tb)) - (if run-id - (let* ((matrix-content - (case (dboard:tabdat-runs-summary-mode tabdat) - ((one-run) (dashboard:run-id->tests-mindat run-id tabdat runs-hash)) - ((xor-two-runs) (dashboard:runs-summary-xor-matrix-content tabdat runs-hash)) - ((xor-two-runs-hide-clean) (dashboard:runs-summary-xor-matrix-content tabdat runs-hash hide-clean: #t)) - (else (dashboard:run-id->tests-mindat run-id tabdat runs-hash))))) - (when matrix-content - (let* ((indices (common:sparse-list-generate-index matrix-content)) ;; proc: set-cell)) - (row-indices (cadr indices)) - (col-indices (car indices)) - (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) - (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices)))) - (max-visible (max (- (dboard:tabdat-num-tests tabdat) 15) 3)) ;; (dboard:tabdat-num-tests tabdat) is proportional to the size of the window - (numrows 1) - (numcols 1) - (changed #f) - ) - - (dboard:tabdat-filters-changed-set! tabdat #f) - (let loop ((pass-num 0) - (changed #f)) - ;; Update the runs tree - ;; (dboard:update-tree tabdat runs-hash runs-header tb) - - (if (eq? pass-num 1) - (begin ;; big reset - (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS - (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS") - (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES"))) - - (if (> max-col (string->number (iup:attribute run-matrix "NUMCOL"))) - (iup:attribute-set! run-matrix "NUMCOL" max-col )) - - (let ((effective-max-row (if (< max-row max-visible) max-visible max-row))) - (if (> effective-max-row (string->number (iup:attribute run-matrix "NUMLIN"))) - (iup:attribute-set! run-matrix "NUMLIN" effective-max-row ))) - - ;; Row labels - (for-each (lambda (ind) - (let* ((name (car ind)) - (num (cadr ind)) - (key (conc num ":0"))) - (if (not (equal? (iup:attribute run-matrix key) name)) - (begin - (set! changed #t) - (iup:attribute-set! run-matrix key name))))) - row-indices) - ;; (print "row-indices: " row-indices " col-indices: " col-indices) - (if (and (eq? pass-num 0) changed) - (loop 1 #t)) ;; force second pass - - ;; Cell contents - (for-each (lambda (entry) - ;; (print "entry: " entry) - (let* ((row-name (cadr entry)) - (col-name (car entry)) - (valuedat (caddr entry)) - (test-id (list-ref valuedat 0)) - (test-name row-name) ;; (list-ref valuedat 1)) - (item-path col-name) ;; (list-ref valuedat 2)) - (state (list-ref valuedat 1)) - (status (list-ref valuedat 2)) - (value (gutils:get-color-for-state-status state status)) - (row-num (cadr (assoc row-name row-indices))) - (col-num (cadr (assoc col-name col-indices))) - (key (conc row-num ":" col-num))) - (hash-table-set! cell-lookup key test-id) - (if (not (equal? (iup:attribute run-matrix key) (cadr value))) - (begin - (set! changed #t) - (iup:attribute-set! run-matrix key (cadr value)) - (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value)))))) - matrix-content) - - ;; Col labels - do after setting Cell contents so they are accounted for in the size calc. - - (for-each (lambda (ind) - (let* ((name (car ind)) - (num (cadr ind)) - (key (conc "0:" num))) - (if (not (equal? (iup:attribute run-matrix key) name)) - (begin - (set! changed #t) - (iup:attribute-set! run-matrix key name) - (if (<= num max-col) - (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num))))))) - col-indices) - - (if (and (eq? pass-num 0) changed) - (loop 1 #t)) ;; force second pass due to column labels changing - - ;; (debug:print 0 *default-log-port* "runs-summary-updater, changed: " changed " pass-num: " pass-num) - ;; (print "runs-summary-updater, changed: " changed " pass-num: " pass-num) - (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL"))))))))) - -;;====================================================================== -;; S U M M A R Y -;;====================================================================== -;; -;; General info about the run(s) and megatest area -(define (dashboard:summary commondat tabdat #!key (tab-num #f)) - (let* ((rawconfig (read-config (conc *toppath* "/megatest.config") #f #f)) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string))) - (changed #f)) - (iup:vbox - (iup:split - #:value 300 - (iup:frame - #:title "General Info" - (iup:vbox - (iup:hbox - (iup:label "Area Path") - (iup:textbox #:value *toppath* #:expand "HORIZONTAL")) - (iup:hbox - (dcommon:keys-matrix rawconfig) - (dcommon:general-info) - ))) - (iup:frame - #:title "Server" - (dcommon:servers-table commondat tabdat))) - (iup:frame - #:title "Megatest config settings" - (iup:hbox - (dcommon:section-matrix rawconfig "setup" "Varname" "Value") - (iup:vbox - (dcommon:section-matrix rawconfig "server" "Varname" "Value") - ;; (iup:frame - ;; #:title "Disks Areas" - (dcommon:section-matrix rawconfig "disks" "Disk area" "Path")))) - (iup:frame - #:title "Run statistics" - (dcommon:run-stats commondat tabdat tab-num: tab-num))))) - -;;====================================================================== -;; H A N D L E U S E R C O N T R I B U T E D V I E W S -;;====================================================================== - -(define (dboard:add-external-tab commondat view-name views-cfgdat tabs tab-num) - (let* ((success #t) ;; at any stage of the process set this flag to #f to skip downstream steps. Intention here is to recover gracefully if user provided tabs fail to load. - (source (configf:lookup views-cfgdat view-name "source")) - (viewgen (configf:lookup views-cfgdat view-name "viewgen")) - (updater (configf:lookup views-cfgdat view-name "updater")) - (result-child #f)) - (if (and (common:file-exists? source) - (file-read-access? source)) - (handle-exceptions - exn - (begin - (print-call-chain) - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) - (debug:print 0 *default-log-port* "ERROR: failed to load " source ", try loading in the repl: megatest -repl") - (set! success #f)) - (load source)) - (begin - (debug:print 0 *default-log-port* "ERROR: cannot find file to load: \"" source "\" for user view " view-name))) - ;; now run the user supplied definition for the tab view - (if success - (handle-exceptions - exn - (begin - (print-call-chain) - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) - (debug:print 0 *default-log-port* "ERROR: failed call procedure " viewgen - ", with; tab-num=" tab-num ", view-name=" view-name - ", and views-cfgdat and megatest configdat as parameters. To debug try loading in the repl: megatest -repl") - (set! success #f)) - (debug:print 0 *default-log-port* "Adding tab " view-name " with proc " viewgen) - ;; (iup:child-add! tabs - (set! result-child - ((eval (string->symbol viewgen)) commondat tabs tab-num view-name views-cfgdat *configdat*)))) - ;; and finally set the updater - (if success - (dboard:commondat-add-updater commondat - (lambda () - (handle-exceptions - exn - (begin - (print-call-chain) - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) - (debug:print 0 *default-log-port* "ERROR: failed call procedure \"" updater - "\", with; tabnum=" tab-num ", view-name=" view-name - ", and views-cfgdat and megatest configdat as parameters. To debug try loading in the repl: megatest -repl") - (set! success #f)) - (debug:print 4 *default-log-port* "Running updater for tab " view-name " with proc " updater " and tab-num: " tab-num) - ((eval (string->symbol updater)) commondat tabs tab-num view-name views-cfgdat *configdat*))) - tab-num: tab-num)) - ;;(if success - ;; (begin - ;; ;; (iup:attribute-set! tabs (conc "TABTITLE" tab-num) view-name) - ;; (dboard:common-set-tabdat! commondat tab-num (dboard:tabdat-make-data)))) - result-child)) - - - -(define (dboard:runs-summary-buttons-updater tabdat) - (let loop ((buttons-left (dboard:tabdat-runs-summary-mode-buttons tabdat)) - (modes-left (dboard:tabdat-runs-summary-modes tabdat))) - (if (or (null? buttons-left) (null? modes-left)) - #t - (let* ((this-button (car buttons-left)) - (mode-item (car modes-left)) - (this-mode (car mode-item)) - (sel-color "180 100 100") - (nonsel-color "170 170 170") - (current-mode (dboard:tabdat-runs-summary-mode tabdat))) - (if (eq? this-mode current-mode) - (iup:attribute-set! this-button "BGCOLOR" sel-color) - (iup:attribute-set! this-button "BGCOLOR" nonsel-color)) - (loop (cdr buttons-left) (cdr modes-left)))))) - -(define (dboard:runs-summary-xor-labels-updater tabdat) - (let ((source-runname-label (dboard:tabdat-runs-summary-source-runname-label tabdat)) - (dest-runname-label (dboard:tabdat-runs-summary-dest-runname-label tabdat)) - (mode (dboard:tabdat-runs-summary-mode tabdat))) - (when (and source-runname-label dest-runname-label) - (case mode - ((xor-two-runs xor-two-runs-hide-clean) - (let* ((curr-run-id (dboard:tabdat-curr-run-id tabdat)) - (prev-run-id (dboard:tabdat-prev-run-id tabdat)) - (curr-runname (if curr-run-id - (rmt:get-run-name-from-id curr-run-id) - "None")) - (prev-runname (if prev-run-id - (rmt:get-run-name-from-id prev-run-id) - "None"))) - (iup:attribute-set! source-runname-label "TITLE" (conc " SRC: "prev-runname" ")) - (iup:attribute-set! dest-runname-label "TITLE" (conc "DEST: "curr-runname" ")))) - (else - (iup:attribute-set! source-runname-label "TITLE" "") - (iup:attribute-set! dest-runname-label "TITLE" "")))))) - -(define (dboard:runs-summary-control-panel-updater tabdat) - (dboard:runs-summary-xor-labels-updater tabdat) - (dboard:runs-summary-buttons-updater tabdat)) - - -;; setup buttons and callbacks to switch between modes in runs summary tab -;; -(define (dashboard:runs-summary-control-panel tabdat) - (let* ((summary-buttons ;; build buttons - (map - (lambda (mode-item) - (let* ((this-mode (car mode-item)) - (this-mode-label (cdr mode-item))) - (iup:button this-mode-label - #:action - (lambda (obj) - (debug:catch-and-dump - (lambda () - (dboard:tabdat-runs-summary-mode-set! tabdat this-mode) - (dboard:runs-summary-control-panel-updater tabdat)) - "runs summary control panel updater"))))) - (dboard:tabdat-runs-summary-modes tabdat))) - (summary-buttons-hbox (apply iup:hbox summary-buttons)) - (xor-runname-labels-hbox - (iup:hbox - (let ((temp-label - (iup:label "" #:size "125x15" #:fontsize "10" ))) - (dboard:tabdat-runs-summary-source-runname-label-set! tabdat temp-label) - temp-label - ) - (let ((temp-label - (iup:label "" #:size "125x15" #:fontsize "10"))) - (dboard:tabdat-runs-summary-dest-runname-label-set! tabdat temp-label) - temp-label)))) - (dboard:tabdat-runs-summary-mode-buttons-set! tabdat summary-buttons) - - ;; maybe wrap in a frame - (let ((res (iup:vbox summary-buttons-hbox xor-runname-labels-hbox ))) - (dboard:runs-summary-control-panel-updater tabdat) - res - ))) - - - -;;====================================================================== -;; R U N -;;====================================================================== -;; -;; display and manage a single run at a time - -;; This is the Run Summary tab -;; -(define (dashboard:runs-summary commondat tabdat #!key (tab-num #f)) - (let* ((update-mutex (dboard:commondat-update-mutex commondat)) - (tb (iup:treebox - #:value 0 - ;;#:name "Runs" - #:title "Runs" - #:expand "YES" - #:addexpanded "YES" - #:selection-cb - (lambda (obj id state) - (debug:catch-and-dump - (lambda () - ;; (print "obj: " obj ", id: " id ", state: " state) - (let* ((run-path (tree:node->path obj id)) - (run-id (tree-path->run-id tabdat (cdr run-path)))) - (if (number? run-id) - (begin - (dboard:tabdat-prev-run-id-set! - tabdat - (dboard:tabdat-curr-run-id tabdat)) - - (dboard:tabdat-curr-run-id-set! tabdat run-id) - (dboard:tabdat-layout-update-ok-set! tabdat #f) - ;; (dashboard:update-run-summary-tab) - ) - ;; (debug:print-error 0 *default-log-port* "tree-path->run-id returned non-number " run-id) - ))) - "selection-cb in runs-summary") - ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) - ))) - (cell-lookup (make-hash-table)) - (run-matrix (iup:matrix - #:expand "YES" - #:click-cb - - (lambda (obj lin col status) - (debug:catch-and-dump - (lambda () - - ;; Bummer - we dont have the global get/set api mapped in chicken - ;; (let* ((modkeys (iup:global "MODKEYSTATE"))) - ;; (BB> "modkeys="modkeys)) - - (debug:print-info 13 *default-log-port* "click-cb: obj="obj" lin="lin" col="col" status="status) - ;; status is corrupted on Brandon's home machine. will have to wait until after shutdown to see if it is still broken in PDX SLES - (let* ((toolpath (car (argv))) - (key (conc lin ":" col)) - (test-id (hash-table-ref/default cell-lookup key -1)) - (run-id (dboard:tabdat-curr-run-id tabdat)) - (run-info (rmt:get-run-info run-id)) - (target (rmt:get-target run-id)) - (runname (db:get-value-by-header (db:get-rows run-info) - (db:get-header run-info) "runname")) - (test-info (rmt:get-test-info-by-id run-id test-id)) - (test-name (db:test-get-testname test-info)) - (testpatt (let ((tlast (rmt:tasks-get-last target runname))) - (if tlast - (let ((tpatt (tasks:task-get-testpatt tlast))) - (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017 - "%" - tpatt)) - "%"))) - (item-path (db:test-get-item-path (rmt:get-test-info-by-id run-id test-id))) - (item-test-path (conc test-name "/" (if (equal? item-path "") - "%" - item-path))) - (status-chars (char-set->list (string->char-set status))) - (run-id (dboard:tabdat-curr-run-id tabdat))) - (debug:print-info 13 *default-log-port* "status-chars=["status-chars"] status=["status"]") - (cond - ((member #\1 status-chars) ;; 1 is left mouse button - (dboard:launch-testpanel run-id test-id)) - - ((member #\2 status-chars) ;; 2 is middle mouse button - - (debug:print-info 13 *default-log-port* "mmb- test-name="test-name" testpatt="testpatt) - (iup:show (dashboard:context-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu - #:x 'mouse - #:y 'mouse - #:modal? "NO") - ) - (else - (debug:print-info 13 *default-log-port* "unhandled status in run-summary-click-cb. Doing right click action. (status is corrupted on Brandon's ubuntu host - bad/buggy iup install??" ) - (iup:show (dashboard:context-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu - #:x 'mouse - #:y 'mouse - #:modal? "NO") - ) - ) - - )) "runs-summary-click-callback")))) - (runs-summary-updater - (lambda () - ;; (mutex-lock! update-mutex) - (if (or (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-updater) - (dboard:tabdat-view-changed tabdat)) - (debug:catch-and-dump - (lambda () ;; check that run-matrix is initialized before calling the updater - (if run-matrix - (dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix))) - "dashboard:runs-summary-updater") - ) - #;(mutex-unlock! update-mutex) - )) - (runs-summary-control-panel (dashboard:runs-summary-control-panel tabdat)) - ) - (dboard:commondat-add-updater commondat runs-summary-updater tab-num: tab-num) - (dboard:tabdat-runs-tree-set! tabdat tb) - (iup:vbox - (iup:split - #:value 200 - tb - run-matrix) - (dboard:make-controls commondat tabdat extra-widget: runs-summary-control-panel)))) - -;;====================================================================== -;; R U N S -;;====================================================================== - -(define (dboard:squarify toggles size) - (let loop ((hed (car toggles)) - (tal (cdr toggles)) - (cur '()) - (res '())) - (let* ((ovrflo (>= (length cur) size)) - (newcur (if ovrflo - (list hed) - (cons hed cur))) - (newres (if ovrflo - (cons cur res) - res))) - (if (null? tal) - (if ovrflo - newres - (cons newcur res)) - (loop (car tal)(cdr tal) newcur newres))))) - -(define (dboard:make-controls commondat tabdat #!key (extra-widget #f) ) - (let ((btn-fontsz (dboard:tabdat-runs-btn-fontsz tabdat))) - (iup:hbox - (iup:vbox - (iup:frame - #:title "filter test and items" - (iup:vbox - (iup:hbox - (iup:vbox - (iup:textbox #:size "120x15" #:fontsize "10" #:value "%" - #:expand "NO" - #:action (lambda (obj unk val) - (debug:catch-and-dump - (lambda ()57 - (mark-for-update tabdat) - (update-search commondat tabdat "test-name" val)) - "make-controls"))) - (iup:hbox - (iup:button "Quit" #:action (lambda (obj) - (exit)) - #:expand "NO" #:size "40x15") - (iup:button "Refresh" #:action (lambda (obj) - (dboard:tabdat-last-data-update-set! tabdat 0) - (dboard:tabdat-last-runs-update-set! tabdat 0) - (dboard:tabdat-run-update-times-set! tabdat (make-hash-table)) - (dboard:tabdat-last-test-dat-set! tabdat (make-hash-table)) - (dboard:tabdat-allruns-set! tabdat '()) - (dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table)) - (dboard:tabdat-done-runs-set! tabdat '()) - (dboard:tabdat-not-done-runs-set! tabdat '()) - (dboard:tabdat-view-changed-set! tabdat #t) - (dboard:commondat-please-update-set! commondat #t) - (dboard:clear-run-id-update-hash) - (mark-for-update tabdat)) - #:expand "NO" #:size "40x15") - (iup:button "Collapse" #:action (lambda (obj) - (debug:catch-and-dump - (lambda () - (let ((myname (iup:attribute obj "TITLE"))) - (if (equal? myname "Collapse") - (begin - (for-each (lambda (tname) - (hash-table-set! *collapsed* tname #t)) - (dboard:tabdat-item-test-names tabdat)) - (iup:attribute-set! obj "TITLE" "Expand")) - (begin - (for-each (lambda (tname) - (hash-table-delete! *collapsed* tname)) - (hash-table-keys *collapsed*)) - (iup:attribute-set! obj "TITLE" "Collapse")))) - (mark-for-update tabdat)) - "make-controls collapse button")) - #:expand "NO" #:size "40x15"))) - (iup:vbox - ;; (iup:button "Sort -t" #:action (lambda (obj) - ;; (next-sort-option) - ;; (iup:attribute-set! obj "TITLE" (vector-ref (vector-ref *tests-sort-options* *tests-sort-reverse*) 0)) - ;; (mark-for-update tabdat))) - - (let* ((hide #f) - (show #f) - (hide-empty #f) - (sel-color "180 100 100") - (nonsel-color "170 170 170") - (cmds-list '("+testname" "-testname" "+event_time" "-event_time" "+statestatus" "-statestatus")) - (sort-lb (iup:listbox #:expand "NO" ;; "HORIZONTAL" - #:size "80x15" - #:dropdown "YES" - #:action (lambda (obj val index lbstate) - (set! *tests-sort-reverse* index) - (mark-for-update tabdat)))) - (default-cmd (car (list-ref *tests-sort-type-index* *tests-sort-reverse*)))) - - (iuplistbox-fill-list sort-lb cmds-list selected-item: default-cmd) - - ;; (set! hide-empty (iup:button "HideEmpty" - ;; ;; #:expand HORIZONTAL" - ;; #:expand "NO" #:size "80x15" - ;; #:action (lambda (obj) - ;; (dboard:tabdat-hide-empty-runs-set! tabdat (not (dboard:tabdat-hide-empty-runs tabdat))) - ;; (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-empty-runs tabdat) "+HideE" "-HideE")) - ;; (mark-for-update tabdat)))) - (set! hide (iup:button "Hide" - #:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL" - #:action (lambda (obj) - (dboard:tabdat-hide-not-hide-set! tabdat #t) ;; (not (dboard:tabdat-hide-not-hide tabdat))) - ;; (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-not-hide tabdat) "HideTests" "NotHide")) - (iup:attribute-set! hide "BGCOLOR" sel-color) - (iup:attribute-set! show "BGCOLOR" nonsel-color) - (mark-for-update tabdat)))) - (set! show (iup:button "Show" - #:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL" - #:action (lambda (obj) - (dboard:tabdat-hide-not-hide-set! tabdat #f) ;; (not (dboard:tabdat-hide-not-hide tabdat))) - (iup:attribute-set! show "BGCOLOR" sel-color) - (iup:attribute-set! hide "BGCOLOR" nonsel-color) - (mark-for-update tabdat)))) - (iup:attribute-set! hide "BGCOLOR" sel-color) - (iup:attribute-set! show "BGCOLOR" nonsel-color) - ;; (dboard:tabdat-hide-not-hide-button-set! tabdat hideit) ;; never used, can eliminate ... - (iup:vbox - (iup:hbox hide show) - sort-lb))) - ) - - ;; insert extra widget here - (if extra-widget - extra-widget - (iup:hbox)) ;; empty widget - - - - - ))) - - (let* ((status-toggles (map (lambda (status) - (iup:toggle (conc status) - #:fontsize 8 ;; btn-fontsz ;; "10" - ;; #:expand "HORIZONTAL" - #:action (lambda (obj val) - (mark-for-update tabdat) - (if (eq? val 1) - (hash-table-set! (dboard:tabdat-status-ignore-hash tabdat) status #t) - (hash-table-delete! (dboard:tabdat-status-ignore-hash tabdat) status)) - (set-bg-on-filter commondat tabdat)))) - (map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP"))) - (state-toggles (map (lambda (state) - (iup:toggle (conc state) - #:fontsize 8 ;; btn-fontsz - ;; #:expand "HORIZONTAL" - #:action (lambda (obj val) - (mark-for-update tabdat) - (if (eq? val 1) - (hash-table-set! (dboard:tabdat-state-ignore-hash tabdat) state #t) - (hash-table-delete! (dboard:tabdat-state-ignore-hash tabdat) state)) - (set-bg-on-filter commondat tabdat)))) - (map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED"))) - (num-toggle-cols (inexact->exact (round (/ (max (length status-toggles)(length state-toggles)) 3))))) - (iup:vbox - (iup:hbox - (iup:frame - #:title "states" - (apply - iup:hbox - (map (lambda (colgrp) - (apply iup:vbox colgrp)) - (dboard:squarify state-toggles 3)))) - (iup:frame - #:title "statuses" - (apply - iup:hbox - (map (lambda (colgrp) - (apply iup:vbox colgrp)) - (dboard:squarify status-toggles 3))))) - ;; - ;; (iup:frame - ;; #:title "state/status filter" - ;; (iup:vbox - ;; (apply - ;; iup:hbox - ;; (map - ;; (lambda (status-toggle state-toggle) - ;; (iup:vbox - ;; status-toggle - ;; state-toggle)) - ;; status-toggles state-toggles)) - - ;; horizontal slider was here - - ))))) - -(define (dashboard:runs-horizontal-slider tabdat ) - (iup:valuator #:valuechanged_cb (lambda (obj) - (let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10)))) - (oldmax (string->number (iup:attribute obj "MAX"))) - (maxruns (dboard:tabdat-tot-runs tabdat))) - (dboard:tabdat-start-run-offset-set! tabdat val) - (mark-for-update tabdat) - (debug:print 6 *default-log-port* "(dboard:tabdat-start-run-offset tabdat) " (dboard:tabdat-start-run-offset tabdat) " maxruns: " maxruns ", val: " val " oldmax: " oldmax) - (iup:attribute-set! obj "MAX" (* maxruns 10)))) - #:expand "HORIZONTAL" - #:max (* 10 (max (hash-table-size (dboard:tabdat-allruns-by-id tabdat)) 10)) - #:min 0 - #:step 0.01)) - -;; make-simple-run procedure (target3772 id3773 runname3774 state3775 status3776 owner3777 event_time3778) -;; rmt:simple-get-runs procedure (runpatt1001 count1002 offset1003 target1004) -;; simple-run-event_time procedure (x3834) -;; simple-run-event_time-set! procedure (x3830 val3831) -;; simple-run-id procedure (x3794) -;; simple-run-id-set! procedure (x3790 val3791) -;; simple-run-owner procedure (x3826) -;; simple-run-owner-set! procedure (x3822 val3823) -;; simple-run-runname procedure (x3802) -;; simple-run-runname-set! procedure (x3798 val3799) -;; simple-run-state procedure (x3810) -;; simple-run-state-set! procedure (x3806 val3807) -;; simple-run-status procedure (x3818) -;; simple-run-status-set! procedure (x3814 val3815) -;; simple-run-target procedure (x3786) -;; simple-run-target-set! procedure (x3782 val3783) -;; simple-run? procedure (x3780) - - -;;====================================================================== -;; Extracting the data to display for runs -;; -;; This needs to be re-entrant such that it does one column per call -;; on the zeroeth call update runs data -;; on each subsequent call update one run (configurable - could do two, three ... or update until tdelta exceeded -;; on last run reset to zeroeth -;; -;; 1. select with run filters; area, target, runname, runstate, runstatus, starttime, duration -;; - put this information into two data structures: -;; a. hash of area/target/runname => runstruct #< ordernun, id, area, target, runname, state, -;; status, starttime, duration, non-deleted testcount> -;; ordernum reflects order as received from sql query -;; b. sparsevec of id => runstruct -;; 2. for each run in runshash ordered by ordernum do: -;; retrieve data since last update for that run -;; if there is a deleted test - retrieve full data -;; if there are non-deleted tests register this run in the columns sparsevec -;; if this is the zeroeth column regenerate the rows sparsevec -;; if this column is in the visible zone update visible cells -;; -;; Other factors: -;; 1. left index handling: -;; - add test/itempaths to left index as discovered, re-order and -;; update row -> test/itempath mapping on each read run -;;====================================================================== - -;; runs is -;; get ALL runs info -;; update rdat-targ-run-id -;; update rdat-runs -;; -(define (dashboard:update-runs-data rdat) - (let* ((tb (dboard:rdat-runs-tree rdat)) - (targ-sql-filt (dboard:rdat-targ-sql-filt rdat)) - (runname-sql-filt (dboard:rdat-runname-sql-filt rdat)) - (state-sql-filt (dboard:rdat-run-state-sql-filt rdat)) - (status-sql-filt (dboard:rdat-run-status-sql-filt rdat)) - ;; Use (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) - (data (rmt:simple-get-runs runname-sql-filt #f #f targ-sql-filt #f)) - (numruns (length data))) - ;; store in the runsbynum vector - (dboard:rdat-runsbynum-set! rdat (list->vector data)) - ;; update runs id => runrec - ;; update targ-runid target/runname => run-id - (for-each - (lambda (runrec) - (let* ((run-id (simple-run-id runrec)) - (full-targ-runname (conc (simple-run-target runrec) "/" - (simple-run-runname runrec)))) - (debug:print 0 *default-log-port* "Update run " run-id) - (sparse-vector-set! (dboard:rdat-runs rdat) run-id runrec) - (hash-table-set! (dboard:rdat-targ-runid rdat) full-targ-runname run-id) - )) - data) - numruns)) - -;; NOTE: runnum is NOT the run-id, it is a pointer into the runsbynum vector -;; -(define (dashboard:update-run-data runnum rdat) - (let* ((curr-time (current-seconds)) - (runrec (vector-ref (dboard:rdat-runsbynum rdat) runnum)) - (run-id (simple-run-id runrec)) - (last-update (sparse-vector-ref (dboard:rdat-last-updates rdat) run-id)) - ;; filters - (testname-sql-filt (dboard:rdat-testname-sql-filt rdat)) - ;; (itempath-sql-filt (dboard:rdat-itempath-sql-filt rdat)) - (test-state-sql-filt (dboard:rdat-test-state-sql-filt rdat)) ;; not used yet - (test-status-sql-filt (dboard:rdat-test-status-sql-filt rdat)) ;; not used yet - (tests (rmt:get-tests-for-run-state-status run-id - testname-sql-filt - last-update ;; last-update - ))) - (sparse-vector-set! (dboard:rdat-last-updates rdat) run-id (- curr-time 1)) - (debug:print 0 *default-log-port* "Got " (length tests) " tests for run-id " - run-id " testname-sql-filt " testname-sql-filt " and last-update " last-update) - (length tests))) - -(define (new-runs-updater commondat rdat) - (let* ((runnum (dboard:rdat-runnum rdat)) - (start-time (current-milliseconds)) - (tot-runs #f)) - (if (eq? runnum 0)(dashboard:update-runs-data rdat)) - (set! tot-runs (vector-length (dboard:rdat-runsbynum rdat))) - (let loop ((rn runnum)) - (if (and (< (- (current-milliseconds) start-time) 250) - (< rn tot-runs)) - (let* ((newrn (if (>= runnum (vector-length (dboard:rdat-runsbynum rdat))) - 0 ;; start over - (+ rn 1)))) ;; (+ runnum 1))) - (dashboard:update-run-data rn rdat) - (dboard:rdat-runnum-set! rdat newrn) - (if (> newrn 0) - (loop newrn))))) - (if (>= (dboard:rdat-runnum rdat) tot-runs) - (dboard:rdat-runnum-set! rdat 0)) - ;; (dboard:rdat-runnum-set! rdat rn))) ;; not needed as it is set above - ;; (dboard:rdat-last-update-set! rdat (- (current-seconds) 10)) - ;; (tree:add-node tb "Runs" (string-split full-targ-runname "/")) - '())) - -(define (dboard:runs-new-matrix commondat rdat) - (iup:matrix - #:alignment1 "ALEFT" - ;; #:expand "YES" ;; "HORIZONTAL" - #:scrollbar "YES" - #:numcol 10 - #:numlin 20 - #:numcol-visible 5 ;; (min 8) - #:numlin-visible 1 - #:click-cb - (lambda (obj row col status) - (let* ((cell (conc row ":" col))) - #f)) - )) - -(define (make-runs-view commondat rdat tab-num) - ;; register an updater - (dboard:commondat-add-updater - commondat - (lambda () - (new-runs-updater commondat rdat)) - tab-num: tab-num) - - (iup:vbox - (iup:split - #:orientation "VERTICAL" ;; "HORIZONTAL" - #:value 100 - (dboard:runs-tree-new-browser commondat rdat) - (dboard:runs-new-matrix commondat rdat) - ))) - -(define (make-dashboard-buttons commondat) ;; runs-sum-dat new-view-dat) - (let* ( - (stats-dat (dboard:tabdat-make-data)) - (runs-dat (dboard:tabdat-make-data)) - (runs2-dat (make-dboard:rdat)) ;; (dboard:tabdat-make-data)) - (onerun-dat (dboard:tabdat-make-data)) ;; name for run-summary structure - (runcontrols-dat (dboard:tabdat-make-data)) - (runtimes-dat (dboard:tabdat-make-data)) - (nruns (dboard:tabdat-numruns runs-dat)) - (ntests (dboard:tabdat-num-tests runs-dat)) - (keynames (dboard:tabdat-dbkeys runs-dat)) - (nkeys (length keynames)) - (runsvec (make-vector nruns)) - (header (make-vector nruns)) - (lftcol (make-vector ntests)) - (keycol (make-vector ntests)) - (controls (dboard:make-controls commondat runs-dat)) ;; '()) - (lftlst '()) - (hdrlst '()) - (bdylst '()) - (result '()) - (i 0) - (btn-height (dboard:tabdat-runs-btn-height runs-dat)) - (btn-fontsz (dboard:tabdat-runs-btn-fontsz runs-dat)) - (cell-width (dboard:tabdat-runs-cell-width runs-dat)) - (use-bgcolor (equal? (configf:lookup *configdat* "dashboard" "use-bgcolor") "yes"))) - ;; controls (along bottom) - ;; (set! controls (dboard:make-controls commondat runs-dat)) - - - - ;; create the left most column for the run key names and the test names - (set! lftlst - (list (iup:hbox - (iup:label) ;; (iup:valuator) - (apply iup:vbox - (map (lambda (x) - (let ((res (iup:hbox - #:expand "HORIZONTAL" - (iup:label x - #:size (conc 40 btn-height) - #:fontsize btn-fontsz - #:expand "NO") ;; "HORIZONTAL") - (iup:textbox - #:size (conc 35 btn-height) - #:fontsize btn-fontsz - #:value "%" - #:expand "NO" ;; "HORIZONTAL" - #:action (lambda (obj unk val) - ;; each field - ;; (field name is "x" var) live updates - ;; the search filter as it is typed - (dboard:tabdat-target-set! runs-dat #f) - ;; ensure fields text boxes are used - ;; and not the info from the tree - (mark-for-update runs-dat) - (update-search commondat runs-dat x val)))))) - (set! i (+ i 1)) - res)) - keynames))))) - (let loop ((testnum 0) - (res '())) - (cond - ((>= testnum ntests) - ;; now lftlst will be an hbox with the test keys and the test name labels - (set! lftlst - (append - lftlst - (list - (iup:hbox - #:expand "HORIZONTAL" - (iup:valuator - #:valuechanged_cb - (lambda (obj) - (let ((val (string->number (iup:attribute obj "VALUE"))) - (oldmax (string->number (iup:attribute obj "MAX"))) - (newmax (* 10 (length (dboard:tabdat-all-test-names runs-dat))))) - (dboard:commondat-please-update-set! commondat #t) - (dboard:tabdat-start-test-offset-set! runs-dat - (inexact->exact (round (/ val 10)))) - (debug:print 6 *default-log-port* - "(dboard:tabdat-start-test-offset runs-dat) " - (dboard:tabdat-start-test-offset runs-dat) " val: " val - " newmax: " newmax " oldmax: " oldmax) - (if (< val 10) - (iup:attribute-set! obj "MAX" newmax)) - )) - #:expand "VERTICAL" - #:orientation "VERTICAL" - #:min 0 - #:step 0.01) - (apply iup:vbox (reverse res))))))) - (else - (let ((labl (iup:button - "" ;; the testname labels - #:flat "YES" - #:alignment "ALEFT" - ; #:image img1 - ; #:impress img2 - #:size (conc cell-width btn-height) - #:expand "HORIZONTAL" - #:fontsize btn-fontsz - #:action (lambda (obj) - (mark-for-update runs-dat) - (toggle-hide testnum (dboard:commondat-uidat commondat)))))) - (vector-set! lftcol testnum labl) - (loop (+ testnum 1)(cons labl res)))))) - ;; These are the headers for each row - (let loop ((runnum 0) - (keynum 0) - (keyvec (make-vector nkeys)) - (res '())) - (cond ;; nb// no else for this approach. - ((>= runnum nruns) #f) - ((>= keynum nkeys) - (vector-set! header runnum keyvec) - (set! hdrlst (cons (apply iup:vbox (reverse res)) hdrlst)) - (loop (+ runnum 1) 0 (make-vector nkeys) '())) - (else - (let ((labl (iup:label "" #:size (conc cell-width btn-height) #:fontsize btn-fontsz #:expand "HORIZONTAL"))) ;; #:expand "HORIZONTAL" "60x15" - (vector-set! keyvec keynum labl) - (loop runnum (+ keynum 1) keyvec (cons labl res)))))) - ;; By here the hdrlst contains a list of vboxes containing nkeys labels - (let loop ((runnum 0) - (testnum 0) - (testvec (make-vector ntests)) - (res '())) - (cond - ((>= runnum nruns) #f) ;; (vector tableheader runsvec)) - ((>= testnum ntests) - (vector-set! runsvec runnum testvec) - (set! bdylst (cons (apply iup:vbox (reverse res)) bdylst)) - (loop (+ runnum 1) 0 (make-vector ntests) '())) - (else - (let* ((button-key (mkstr runnum testnum)) - (butn (iup:button - (if use-bgcolor #f " ") ;; button-key - #:size (conc cell-width btn-height ) - #:expand "HORIZONTAL" - #:fontsize btn-fontsz - #:button-cb - (lambda (obj a pressed x y btn . rem) - ;; (print "pressed= " pressed " x= " x " y= " y " rem=" rem " btn=" btn " string? " (string? btn)) - (if (substring-index "3" btn) - (if (eq? pressed 1) - (let* ((toolpath (car (argv))) - (buttndat (hash-table-ref (dboard:tabdat-buttondat runs-dat) button-key)) - (test-id (db:test-get-id (vector-ref buttndat 3))) - (run-id (db:test-get-run_id (vector-ref buttndat 3))) - (run-info (rmt:get-run-info run-id)) - (target (rmt:get-target run-id)) - (runname (db:get-value-by-header (db:get-rows run-info) - (db:get-header run-info) "runname")) - (test-info (rmt:get-test-info-by-id run-id test-id)) - (test-name (db:test-get-testname test-info)) - (testpatt (let ((tlast (rmt:tasks-get-last target runname))) - (if tlast - (let ((tpatt (tasks:task-get-testpatt tlast))) - (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017 - "%" - tpatt)) - "%"))) - (item-path (db:test-get-item-path (rmt:get-test-info-by-id run-id test-id))) - (item-test-path (conc test-name "/" (if (equal? item-path "") - "%" - item-path)))) - (iup:show (dashboard:context-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu - #:x 'mouse - #:y 'mouse - #:modal? "NO") - ;; (print "got here") - )) - (if (eq? pressed 0) - (let* ((toolpath (car (argv))) - (buttndat (hash-table-ref (dboard:tabdat-buttondat runs-dat) button-key)) - (test-id (db:test-get-id (vector-ref buttndat 3))) - (run-id (db:test-get-run_id (vector-ref buttndat 3)))) - (dboard:launch-testpanel run-id test-id)))))))) - (iup:attribute-set! butn "IMAGE" (make-image *images* "BGCOLOR" "222 222 221")) ;;; "BGCOLOR" "BGCOLOR") - (hash-table-set! (dboard:tabdat-buttondat runs-dat) button-key (vector 0 "100 100 100" button-key #f #f)) - (vector-set! testvec testnum butn) - (loop runnum (+ testnum 1) testvec (cons butn res)))))) - ;; now assemble the hdrlst and bdylst and kick off the dialog - (iup:show - (iup:dialog - #:title (conc "Megatest dashboard " (current-user-name) ":" *toppath*) - #:menu (dcommon:main-menu) - (let* ((runs-view (iup:vbox - (iup:split - #:orientation "VERTICAL" ;; "HORIZONTAL" - #:value 250 - (dboard:runs-tree-browser commondat runs-dat) - (iup:split - #:value 200 - ;; left most block, including row names - (apply iup:vbox lftlst) - ;; right hand block, including cells - (iup:vbox - #:expand "YES" - ;; the header - (apply iup:hbox (reverse hdrlst)) - (apply iup:hbox (reverse bdylst)) - (dashboard:runs-horizontal-slider runs-dat)))) - controls - )) - (views-cfgdat (common:load-views-config)) - (additional-tabnames '()) - (tab-start-num 5) ;; DON'T FORGET TO UPDATE THIS WHEN CHANGING THE STANDARD TABS BELOW - ;; (data (dboard:tabdat-init (make-d:data))) - (additional-views ;; process views-dat - (let ((tab-num tab-start-num) - (result '())) - (for-each - (lambda (view-name) - (debug:print 0 *default-log-port* "Adding view " view-name) - (let* ((cfgtype (configf:lookup views-cfgdat view-name "type"))) ;; what type of view? - (if (not (string? cfgtype)) - (debug:print-info 0 *default-log-port* "WARNING: view \"" view-name - "\" is missing needed sections. " - "Please consult the documenation and update ~/.mtviews.config or " - *toppath* "/.mtviews.config") - (case (string->symbol cfgtype) - ;; user supplied source for a tab - ;; - ((external) ;; was tabs - (let ((tab-content (dboard:add-external-tab commondat view-name views-cfgdat #f tab-num))) - (set! additional-tabnames (cons (cons tab-num view-name) additional-tabnames)) - (set! tab-num (+ tab-num 1)) - (set! result (append result (list tab-content))))))))) - (sort (hash-table-keys views-cfgdat) - (lambda (a b) - (let ((order-a (or (any->number (configf:lookup views-cfgdat a "order")) 999)) - (order-b (or (any->number (configf:lookup views-cfgdat b "order")) 999))) - (> order-a order-b))))) - result)) - (tabs (apply iup:tabs - #:tabchangepos-cb (lambda (obj curr prev) - (debug:catch-and-dump - (lambda () - (let* ((tab-num (dboard:commondat-curr-tab-num commondat)) - (tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))) - (dboard:tabdat-layout-update-ok-set! tabdat #f)) - (dboard:commondat-curr-tab-num-set! commondat curr) - (let* ((tab-num (dboard:commondat-curr-tab-num commondat)) - (tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))) - (dboard:commondat-please-update-set! commondat #t) - (dboard:tabdat-layout-update-ok-set! tabdat #t))) - "tabchangepos")) - runs-view - (dashboard:summary commondat stats-dat tab-num: 1) - ;; (make-runs-view commondat runs2-dat 2) - (dashboard:runs-summary commondat onerun-dat tab-num: 2) - (dashboard:run-controls commondat runcontrols-dat tab-num: 3) - (dashboard:run-times commondat runtimes-dat tab-num: 4) - additional-views)) - (target-run (dboard:commondat-target commondat)) - ) - ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c))) - (iup:attribute-set! tabs "TABTITLE0" "Runs") - (iup:attribute-set! tabs "TABTITLE1" "Summary") - ;; (iup:attribute-set! tabs "TABTITLE2" "Runs2") - (iup:attribute-set! tabs "TABTITLE2" "Run Summary") - (iup:attribute-set! tabs "TABTITLE3" "Run Control") - (iup:attribute-set! tabs "TABTITLE4" "Run Times") - ;; (iup:attribute-set! tabs "TABTITLE3" "New View") - ;; (iup:attribute-set! tabs "TABTITLE4" "Run Control") - - ;; set the tab names for user added tabs - (for-each - (lambda (tab-info) - (iup:attribute-set! tabs (conc "TABTITLE" (car tab-info)) (cdr tab-info))) - additional-tabnames) - - (iup:attribute-set! tabs "BGCOLOR" "190 190 190") - ;; make the iup tabs object available (for changing color for example) - (dboard:commondat-hide-not-hide-tabs-set! commondat tabs) - ;; now set up the tabdat lookup - ;; (dboard:common-set-tabdat! commondat 0 stats-dat) - - (if target-run - (begin - (dboard:tabdat-target-set! runs-dat (string-split target-run "/")) - ) - ) - (dboard:common-set-tabdat! commondat 0 runs-dat) - ;;(dboard:common-set-tabdat! commondat 2 runs2-dat) - (dboard:common-set-tabdat! commondat 2 onerun-dat) - (dboard:common-set-tabdat! commondat 3 runcontrols-dat) - (dboard:common-set-tabdat! commondat 4 runtimes-dat) - - (iup:vbox - tabs - ;; controls - )))) - (vector keycol lftcol header runsvec))) - -(define (dboard:setup-num-rows tabdat) - (dboard:tabdat-num-tests-set! tabdat (string->number - (or (args:get-arg "-rows") - (get-environment-variable "DASHBOARDROWS") - "15")))) - -(define *tim* (iup:timer)) -(define *ord* #f) -(iup:attribute-set! *tim* "TIME" (or (configf:lookup *configdat* "dashboard" "poll-interval") "1000")) -(iup:attribute-set! *tim* "RUN" "YES") - -(define *last-recalc-ended-time* 0) - -(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))))) - -;; (define *monitor-db-path* #f) -(define *last-monitor-update-time* 0) - -;; Force creation of the db in case it isn't already there. -;; (tasks:open-db) - -(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 ", exn=" exn) - (current-seconds)) ;; something went wrong - just print an error and return current-seconds - (common:max (map (lambda (filen) - (file-modification-time filen)) - (cons (conc dbdir "/main.db") (glob (conc dbdir "/?.db"))))))) - -(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))) - -(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)) - -;; -(define (dashboard:database-changed? commondat tabdat #!key (context-key 'default)) - (let* ((run-update-time (current-seconds)) - (dbdir (conc *toppath* "/.mtdb")) - (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)))) - (if recalc - (dboard:set-last-db-update! tabdat context-key run-update-time)) - (dboard:commondat-please-update-set! commondat #f) - recalc)) - -;; point inside line -;; -(define-inline (dashboard:px-between px lx1 lx2) - (and (< lx1 px)(> lx2 px))) - -;;Not reference anywhere -;; -;; can a bar be placed in row "rownum" covering x1 to x2 without overlapping with existing -;; bars? Use num-rows to check that a block will fit from rownum to (+ rownum num-rows) -;; -(define (dashboard:row-collision rowhash rownum x1 x2 #!key (num-rows #f)) - (let ((lastrow (if num-rows (+ rownum num-rows) rownum))) - (let loop ((i 0) - (rowdat (hash-table-ref/default rowhash rownum '()))) - (if (null? rowdat) - #f - (let rowloop ((bar (car rowdat)) - (tal (cdr rowdat))) - (let ((bx1 (car bar)) - (bx2 (cdr bar))) - (cond - ;; newbar x1 inside bar - ((dashboard:px-between x1 bx1 bx2) #t) - ((dashboard:px-between x2 bx1 bx2) #t) - ((and (<= x1 bx1)(>= x2 bx2)) #t) - (else (if (null? tal) - (if (< i lastrow) - (loop (+ i 1) - (hash-table-ref/default rowhash (+ rownum i) '())) - #f) - (rowloop (car tal)(cdr tal))))))))))) - -(define (dashboard:add-bar rowhash rownum x1 x2 #!key (num-rows 0)) - (let loop ((i 0)) - (hash-table-set! rowhash - (+ i rownum) - (cons (cons x1 x2) - (hash-table-ref/default rowhash (+ i rownum) '()))) - (if (< i num-rows) - (loop (+ i 1))))) - -;; sort a list of test-ids by the event _time using a hash table of id => testdat -;; -(define-inline (dboard:sort-testsdat-by-event-time test-ids tests-ht) - (sort test-ids - (lambda (a b) - (< (db:test-get-event_time (hash-table-ref tests-ht a)) - (db:test-get-event_time (hash-table-ref tests-ht b)))))) - -;; first group items into lists, then sort by time -;; finally sort by first item time -;; -;; NOTE: we are returning lists of lists of ids! -;; -(define (dboard:tests-sort-by-time-group-by-item testsdat) - (let ((test-ids (hash-table-keys testsdat))) - (if (null? test-ids) - test-ids - ;; now group all tests by testname tname => (id1 id2 ...), tname2 => ( ... - (let* ((test-ids-by-name - (let ((ht (make-hash-table))) - (for-each - (lambda (tdat) - (let ((testname (db:test-get-testname tdat)) - (test-id (db:test-get-id tdat))) - (hash-table-set! - ht - testname - (cons test-id (hash-table-ref/default ht testname '()))))) - (hash-table-values testsdat)) - ht))) - ;; remove toplevel tests from iterated tests, sort tests in the list by event time - (for-each - (lambda (testname) - (let ((tests-id-lst (hash-table-ref test-ids-by-name testname))) - (if (> (length tests-id-lst) 1) ;; must be iterated - (let ((item-tests (filter (lambda (tid) ;; filter out toplevel tests - (let ((tdat (hash-table-ref testsdat tid))) - (not (equal? (db:test-get-item-path tdat) "")))) - tests-id-lst))) - (if (not (null? item-tests)) ;; resist bad data, generally should not fail this condition - (hash-table-set! test-ids-by-name - testname - (dboard:sort-testsdat-by-event-time item-tests testsdat))))))) - (hash-table-keys test-ids-by-name)) - ;; finally sort by the event time of the first test - (sort (hash-table-values test-ids-by-name) - (lambda (a b) - (< (db:test-get-event_time (hash-table-ref testsdat (car a))) - (db:test-get-event_time (hash-table-ref testsdat (car b)))))))))) - -;; run times tab data updater -;; -(define (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num) - (let* ((access-mode (dboard:tabdat-access-mode tabdat)) - (last-runs-update (dboard:tabdat-last-runs-update tabdat)) - (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) - (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records - (runs-hash (let ((ht (make-hash-table))) - (for-each (lambda (run) - (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) - (vector-ref runs-dat 1)) - ht)) - (run-ids (sort (filter number? (hash-table-keys runs-hash)) - (lambda (a b) - (let* ((record-a (hash-table-ref runs-hash a)) - (record-b (hash-table-ref runs-hash b)) - (time-a (db:get-value-by-header record-a runs-header "event_time")) - (time-b (db:get-value-by-header record-b runs-header "event_time"))) - (< time-a time-b))))) - (tb (dboard:tabdat-runs-tree tabdat)) - (num-runs (length (hash-table-keys runs-hash))) - (update-start-time (current-seconds)) - (inc-mode #f)) - (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) - ;; fill in the tree - (if (and tb - (not inc-mode)) - (for-each - (lambda (run-id) - (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) - (key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key)) - (dboard:tabdat-keys tabdat))) - (run-name (db:get-value-by-header run-record runs-header "runname")) - (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) - (run-path (append key-vals (list run-name)))) - ;; (existing (tree:find-node tb run-path))) - (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f)) - (begin - (hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path) - ;; Here we update the tests treebox and tree keys - (tree:add-node tb "Runs" run-path) ;; (append key-vals (list run-name)) - ;; userdata: (conc "run-id: " run-id)) - (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id) - ;; (set! colnum (+ colnum 1)) - )))) - run-ids)) - ;; (print "Updating rundat") - (if (dboard:tabdat-keys tabdat) ;; have keys yet? - (let* ((num-keys (length (dboard:tabdat-keys tabdat))) - (targpatt (map (lambda (k v) - (list k v)) - (dboard:tabdat-keys tabdat) - (take (append (or (dboard:tabdat-target tabdat);; (string-split (dboard: "/") - '("%" "%")) - (make-list num-keys "%")) - num-keys) - )) - (runpatt (if (and (dboard:tabdat-target tabdat) - (list? (dboard:tabdat-target tabdat)) - (not (null? (dboard:tabdat-target tabdat)))) - (last (dboard:tabdat-target tabdat)) - "%")) - (testpatt (or (dboard:tabdat-test-patts tabdat) "%")) - (filtrstr (conc targpatt "/" runpatt "/" testpatt))) - ;; (print "targpatt: " targpatt " runpatt: " runpatt " testpatt: " testpatt) - - (if (not (equal? (dboard:tabdat-last-filter-str tabdat) filtrstr)) - (let ((dwg (dboard:tabdat-drawing tabdat))) - (dboard:tabdat-layout-update-ok-set! tabdat #f) - (vg:drawing-libs-set! dwg (make-hash-table)) - (vg:drawing-insts-set! dwg (make-hash-table)) - (vg:drawing-cache-set! dwg '()) - (dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table)) - ;; (dboard:tabdat-allruns-set! tabdat '()) - (dboard:tabdat-max-row-set! tabdat 0) - (dboard:tabdat-last-filter-str-set! tabdat filtrstr))) - (update-rundat tabdat - runpatt - ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") - (dboard:tabdat-numruns tabdat) - testpatt ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") - ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%") - - targpatt - - ;; old method - ;; (let ((res '())) - ;; (for-each (lambda (key) - ;; (if (not (equal? key "runname")) - ;; (let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f))) - ;; (if val (set! res (cons (list key val) res)))))) - ;; (dboard:tabdat-dbkeys tabdat)) - ;; res) - ))))) - -;; run times canvas updater -;; -(define (dashboard:run-times-tab-canvas-updater commondat tabdat tab-num) - (let ((cnv (dboard:tabdat-cnv tabdat)) - (dwg (dboard:tabdat-drawing tabdat)) - (mtx (dboard:tabdat-runs-mutex tabdat)) - (vch (dboard:tabdat-view-changed tabdat))) - (if (and cnv dwg vch) - (begin - (vg:drawing-xoff-set! dwg (dboard:tabdat-xadj tabdat)) - (vg:drawing-yoff-set! dwg (dboard:tabdat-yadj tabdat)) - ;; (mutex-lock! mtx) - (canvas-clear! cnv) - (vg:draw dwg tabdat) - ;; (mutex-unlock! mtx) - (dboard:tabdat-view-changed-set! tabdat #f))))) - -;; doesn't work. -;; -;;(define (gotoescape tabdat escape) -;; (or (dboard:tabdat-layout-update-ok tabdat) -;; (escape #t))) - -(define (dboard:graph-db-open dbstr) - (let* ((parts (string-split dbstr ":")) - (dbpth (if (< (length parts) 2) ;; assume then a filename was provided - dbstr - (if (equal? (car parts) "sqlite3") - (cadr parts) - (begin - (debug:print 0 *default-log-port* "ERROR: I only know sqlite3 databases for now: " dbstr) - #f))))) - (if (and dbpth (file-read-access? dbpth)) - (let ((db (sqlite3:open-database dbpth))) ;; (open-database dbpth))) - (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 10000)) - db) - #f))) - -;; sqlite3:path tablename timefieldname varfieldname field1 field2 ... -;; -(define (dboard:graph-read-data cmdstring tstart tend) - (let* ((parts (string-split cmdstring))) ;; spaces not allowed - (if (< (length parts) 6) ;; sqlite3:path tablename timefieldname varfname valfname field1 field2 ... - (debug:print 0 *default-log-port* "ERROR: malformed graph line: " cmdstring) - (let* ((dbdef (list-ref parts 0)) - (tablen (list-ref parts 1)) - (timef (list-ref parts 2)) - (varfn (list-ref parts 3)) - (valfn (list-ref parts 4)) - (fields (cdr (cddddr parts))) - (db (dboard:graph-db-open dbdef)) - (res-ht (make-hash-table))) - (if db - (begin - (for-each - (lambda (fieldname) ;; fields - (let ((all-dat-qrystr (conc "SELECT " timef "," varfn "," valfn " FROM " tablen " WHERE " varfn "='" fieldname "' AND " timef " >= " tstart " AND " timef " <= " tend " ORDER BY " timef " ASC")) - (zeroth-point (conc "SELECT " timef "," varfn "," valfn " FROM " tablen " WHERE " varfn "='" fieldname "' AND " timef " < " tstart " LIMIT 1"))) - (hash-table-set! res-ht fieldname ;; (fetch-rows (sql db qrystr))))) - (reverse - (sqlite3:fold-row - (lambda (res t var val) - (cons (vector t var val) res)) - '() db all-dat-qrystr))) - (let ((zeropt (handle-exceptions - exn - #f - (sqlite3:first-row db all-dat-qrystr)))) - (if zeropt ;; NOTE: Add zeropt to the beginning of the list as the list was reversed above. - (hash-table-set! res-ht - fieldname - (cons - (apply vector tstart (cdr zeropt)) - (hash-table-ref/default res-ht fieldname '()))))))) - fields) - res-ht) - #f))))) - -;; graph data -;; tsc=timescale, tfn=function; time->x -;; -(define (dboard:graph commondat tabdat tabnum llx lly ulx uly tstart tend tsc tfn compname cmargin) - (let* ((dwg (dboard:tabdat-drawing tabdat)) - (lib (vg:get/create-lib dwg "runslib")) - (cnv (dboard:tabdat-cnv tabdat)) - (dur (- tstart tend)) ;; time duration - (cmp (vg:get-component dwg "runslib" compname)) - (cfg (configf:get-section *configdat* "graph")) - (stdcolor (vg:rgb->number 120 130 140)) - (delta-y (- uly lly)) - (graph-matrix-table (dboard:tabdat-graph-matrix-table tabdat)) - (graph-cell-table (dboard:tabdat-graph-cell-table tabdat)) - (graph-matrix (dboard:tabdat-graph-matrix tabdat)) - (changed #f)) - (vg:add-obj-to-comp - cmp - (vg:make-rect-obj llx lly ulx uly)) - (vg:add-obj-to-comp - cmp - (vg:make-text-obj (- (tfn tstart) 10)(- lly 10)(seconds->year-week/day-time tstart))) - (let*-values (((span timeunit time-blk first timesym) (common:find-start-mark-and-mark-delta tstart tend))) - (let loop ((mark first) - (count 0)) - (let* ((smark (tfn mark)) ;; scale the mark - (mark-delta (quotient (- mark tstart) time-blk)) ;; how far from first mark - (label (conc (* count span) timesym))) ;; was mark-delta - (if (> count 2) - (begin - (vg:add-obj-to-comp - cmp - (vg:make-rect-obj (- smark 1)(- lly 2)(+ smark 1) lly)) - (vg:add-obj-to-comp - cmp - (vg:make-text-obj (- smark 1)(- lly 10) label)))) - (if (< mark (- tend time-blk)) - (loop (+ mark time-blk)(+ count 1)))))) - (for-each - (lambda (cf) - (let* ((alldat (dboard:graph-read-data (cadr cf) tstart tend))) - (if alldat - (for-each - (lambda (fieldn) - (let*-values (((dat) (hash-table-ref alldat fieldn)) - ((vals minval maxval) (if (null? dat) - (values '() #f #f) - (let loop ((hed (car dat)) - (tal (cdr dat)) - (res '()) - (min (vector-ref (car dat) 2)) - (max (vector-ref (car dat) 2))) - (let* ((val (vector-ref hed 2)) - (newmin (if (< val min) val min)) - (newmax (if (> val max) val max)) - (newres (cons val res))) - (if (null? tal) - (values (reverse res) (- newmin 2) (+ newmax 2)) - (loop (car tal)(cdr tal) newres newmin newmax))))))) - (if (not (hash-table-exists? graph-matrix-table fieldn)) - (begin - (let* ((graph-color-rgb (vg:generate-color-rgb)) - (graph-color (vg:iup-color->number graph-color-rgb)) - (graph-matrix-col (dboard:tabdat-graph-matrix-col tabdat)) - (graph-matrix-row (dboard:tabdat-graph-matrix-row tabdat)) - (graph-cell (conc graph-matrix-row ":" graph-matrix-col)) - (graph-dat (make-dboard:graph-dat - id: fieldn - color: graph-color - flag: #t - cell: graph-cell - ))) - (hash-table-set! graph-matrix-table fieldn graph-dat) - (hash-table-set! graph-cell-table graph-cell graph-dat) - ;; (print "Graph data " graph-matrix-row " " graph-matrix-col " " fieldn " " graph-color " " graph-color-rgb " ") - ;; (print "Graph data " graph-matrix-row " " graph-matrix-col " " fieldn " " graph-color " " graph-color-rgb " ") - (set! changed #t) - (iup:attribute-set! graph-matrix (conc graph-matrix-row ":" graph-matrix-col) fieldn) - (iup:attribute-set! graph-matrix (conc "BGCOLOR" (conc graph-matrix-row ":" graph-matrix-col)) graph-color-rgb) - (if (> graph-matrix-col 10) - (begin - (dboard:tabdat-graph-matrix-col-set! tabdat 1) - (dboard:tabdat-graph-matrix-row-set! tabdat (+ graph-matrix-row 1))) - (dboard:tabdat-graph-matrix-col-set! tabdat (+ graph-matrix-col 1))) - ))) - (if (not (null? vals)) - (let* (;; (maxval (apply max vals)) - ;; (minval (min 0 (apply min vals))) - (yoff (- minval lly)) ;; minval)) - (deltaval (- maxval minval)) - (yscale (/ delta-y (if (zero? deltaval) 1 deltaval))) - (yfunc (lambda (y)(+ lly (* yscale (- y minval))))) ;; (lambda (y)(* (+ y yoff) yscale)))) - (graph-dat (hash-table-ref graph-matrix-table fieldn)) - (graph-color (dboard:graph-dat-color graph-dat)) - (graph-flag (dboard:graph-dat-flag graph-dat))) - (if graph-flag - (begin - (vg:add-obj-to-comp - cmp - (vg:make-text-obj (- llx 10)(yfunc maxval) (conc maxval))) - (vg:add-obj-to-comp - cmp - (vg:make-text-obj (- llx 10)(yfunc minval) (conc minval))) - (fold - (lambda (next prev) ;; #(time ? val) #(time ? val) - (if prev - (let* ((yval (vector-ref prev 2)) - (yval-next (vector-ref next 2)) - (last-tval (tfn (vector-ref prev 0))) - (last-yval (yfunc yval)) ;; (+ lly (* yscale (vector-ref prev 2)))) - (next-yval (yfunc yval-next)) - (curr-tval (tfn (vector-ref next 0)))) - (if (>= curr-tval last-tval) - (begin - (vg:add-obj-to-comp - cmp - ;;(vg:make-rect-obj last-tval lly curr-tval last-yval ;; (- stval 2) lly (+ stval 2)(+ lly (* yval yscale)) - (vg:make-line-obj last-tval last-yval curr-tval last-yval - line-color: graph-color)) - (vg:add-obj-to-comp - cmp - ;;(vg:make-rect-obj last-tval lly curr-tval last-yval ;; (- stval 2) lly (+ stval 2)(+ lly (* yval yscale)) - (vg:make-line-obj curr-tval last-yval curr-tval next-yval - line-color: graph-color))) - (debug:print 0 *default-log-port* "ERROR: curr-tval is not > last-tval; curr-tval " curr-tval ", last-tval " last-tval)))) - next) - #f ;; (vector tstart minval minval) - dat) - )))))) ;; for each data point in the series - (hash-table-keys alldat))))) - cfg) - (if changed (iup:attribute-set! graph-matrix "REDRAW" "ALL")))) - -;; run times tab -;; -(define (dashboard:run-times-tab-layout-updater commondat tabdat tab-num) - ;; each test is an object in the run component - ;; each run is a component - ;; all runs stored in runslib library - (let escapeloop ((escape #f)) - (if (and (not escape) - tabdat) - (let* ((canvas-margin 10) - (not-done-runs (dboard:tabdat-not-done-runs tabdat)) - (mtx (dboard:tabdat-runs-mutex tabdat)) - (drawing (dboard:tabdat-drawing tabdat)) - (runslib (vg:get/create-lib drawing "runslib")) ;; creates and adds lib - (allruns (dboard:tabdat-allruns tabdat)) - (num-runs (length allruns)) - (cnv (dboard:tabdat-cnv tabdat)) - (compact-layout (dboard:tabdat-compact-layout tabdat)) - (row-height (if compact-layout 2 10)) - (graph-height 120) - (run-to-run-margin 25)) - (dboard:tabdat-layout-update-ok-set! tabdat #t) - (if (and (canvas? cnv) - (not (null? allruns))) ;; allruns can go null when browsing the runs tree - (let*-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv)) - ((originx originy) (canvas-origin cnv)) - ((calc-y) (lambda (rownum) - (- (/ sizey 2) - (* rownum row-height)))) - ((fixed-originx) (if (dboard:tabdat-originx tabdat) - (dboard:tabdat-originx tabdat) - (begin - (dboard:tabdat-originx-set! tabdat originx) - originx))) - ((fixed-originy) (if (dboard:tabdat-originy tabdat) - (dboard:tabdat-originy tabdat) - (begin - (dboard:tabdat-originy-set! tabdat originy) - originy)))) - ;; (print "allruns: " allruns) - (let runloop ((rundat (car allruns)) - (runtal (cdr allruns)) - (run-num 1) - (doneruns '())) - (let* ((run (dboard:rundat-run rundat)) - (rowhash (make-hash-table)) ;; store me in tabdat - (key-val-dat (dboard:rundat-key-vals rundat)) - (run-id (db:get-value-by-header run (dboard:tabdat-header tabdat) "id")) - (key-vals (append key-val-dat - (list (let ((x (db:get-value-by-header run (dboard:tabdat-header tabdat) "runname"))) - (if x x ""))))) - (run-key (string-intersperse key-vals "\n")) - (run-full-name (string-intersperse key-vals "/")) - (curr-run-start-row (dboard:tabdat-max-row tabdat))) - ;; (print "run: " run-full-name " curr-run-start-row: " curr-run-start-row) - (if (not (vg:lib-get-component runslib run-full-name)) - (let* ((hierdat (if (or (dboard:rundat-data-changed rundat) ;; attempt to not sort when possible. - (not (dboard:rundat-hierdat rundat))) - (let ((hd (dboard:tests-sort-by-time-group-by-item (dboard:rundat-tests rundat)))) ;; hierarchial list of ids - (dboard:rundat-hierdat-set! rundat hd) - hd) - (dboard:rundat-hierdat rundat))) - (tests-ht (dboard:rundat-tests rundat)) - (all-tids (hash-table-keys tests-ht)) ;; (apply append hierdat)) ;; was testsdat - (testsdat (hash-table-values tests-ht)) - (runcomp (vg:comp-new));; new component for this run - (rows-used (make-hash-table)) ;; keep track of what parts of the rows are used here row1 = (obj1 obj2 ...) - ;; (row-height 4) - (run-start (common:min-max < (map db:test-get-event_time testsdat))) - (run-end (let ((re (common:min-max > (map (lambda (t)(+ (db:test-get-event_time t)(db:test-get-run_duration t))) testsdat)))) - (max re (+ 1 run-start)))) ;; use run-start+1 if run-start == run-end so delta is not zero - (timeoffset (- run-start)) ;; (+ fixed-originx canvas-margin) run-start)) - (run-duration (- run-end run-start)) - (timescale (/ (- sizex (* 2 canvas-margin)) - (if (> run-duration 0) - run-duration - (current-seconds)))) ;; a least lously guess - (maptime (lambda (tsecs)(* timescale (+ tsecs timeoffset)))) - (num-tests (length hierdat)) - (tot-tests (length testsdat)) - (width (* timescale run-duration)) - (graph-lly (calc-y (/ -50 row-height))) - (graph-uly (- (calc-y 0) canvas-margin)) - (sec-per-50pt (/ 50 timescale)) - ) - ;; (print "timeoffset: " timeoffset " timescale: " timescale " run-duration: " (seconds->hr-min-sec run-duration) " width: " width " sec-per-50pt: " sec-per-50pt) - ;; (print "timescale: " timescale " timeoffset: " timeoffset " sizex: " sizex " originx: " originx) - ;; (mutex-lock! mtx) - (vg:add-comp-to-lib runslib run-full-name runcomp) - ;; Have to keep moving the instantiated box as it is anchored at the lower left - ;; this should have worked for x in next statement? (maptime run-start) - ;; add 60 to make room for the graph - (vg:instantiate drawing "runslib" run-full-name run-full-name 8 (- (calc-y curr-run-start-row) (+ 5 graph-height run-to-run-margin))) - ;; (mutex-unlock! mtx) - ;; (set! run-start-row (+ max-row 2)) - ;; (dboard:tabdat-start-row-set! tabdat (+ new-run-start-row 1)) - ;; get tests in list sorted by event time ascending - (let testsloop ((test-ids (car hierdat)) ;; loop on tests (NOTE: not items!) - (tests-tal (cdr hierdat)) - (test-num 1)) - (let ((iterated (> (length test-ids) 1)) - (first-rownum #f) - (num-items (length test-ids))) - (let testitemloop ((test-id (car test-ids)) ;; loop on test or test items - (tidstal (cdr test-ids)) - (item-num 1) - (test-objs '())) - (let* ((testdat (hash-table-ref tests-ht test-id)) - (event-time (maptime (db:test-get-event_time testdat))) - (test-duration (* timescale (db:test-get-run_duration testdat))) - (end-time (+ event-time test-duration)) - (test-name (db:test-get-testname testdat)) - (item-path (db:test-get-item-path testdat)) - (state (db:test-get-state testdat)) - (status (db:test-get-status testdat)) - (test-fullname (conc test-name "/" item-path)) - (name-color (gutils:get-color-for-state-status state status)) - (new-test-objs - (let loop ((rownum 0)) ;; new-run-start-row)) ;; (+ start-row 1))) - (if (dashboard:row-collision rowhash rownum event-time end-time) - (loop (+ rownum 1)) - (let* ((title (if iterated (if compact-layout #f item-path) test-name)) - (lly (calc-y rownum)) ;; (- sizey (* rownum row-height))) - (uly (+ lly row-height)) - (use-end (if (< (- end-time event-time) 2)(+ event-time 2) end-time)) ;; if short grow it a little to give the user something to click on - (obj (vg:make-rect-obj event-time lly use-end uly - fill-color: (vg:iup-color->number (car name-color)) - text: title - font: "Helvetica -10")) - (bar-end (max use-end - (+ event-time - (if compact-layout - 1 - (+ 7 (* (string-length title) 10))))))) ;; 8 pixels per letter - ;; (if iterated - ;; (dashboard:add-bar rowhash (- rownum 1) event-time end-time num-rows: (+ 1 num-items)) - ;; (if (not first-rownum) - ;; (begin - ;; (dashboard:row-collision rowhash (- rownum 1) event-time end-time num-rows: num-items) - ;; (set! first-rownum rownum))) - (dboard:tabdat-max-row-set! tabdat (max (+ curr-run-start-row rownum) - (dboard:tabdat-max-row tabdat))) ;; track the max row used - ;; bar-end has some margin for text - accounting for text in extents not yet working. - (dashboard:add-bar rowhash rownum event-time bar-end) ;; (+ end-time 5)) - (vg:add-obj-to-comp runcomp obj) - ;; (vg:instance-move drawing run-full-name 0 (calc-y (dboard:tabdat-max-row tabdat))) - (dboard:tabdat-view-changed-set! tabdat #t) - (cons obj test-objs)))))) - ;; (print "event_time: " (db:test-get-event_time testdat) " mapped event_time: " event-time) - ;; (print "run-duration: " (db:test-get-run_duration testdat) " mapped run_duration: " run-duration) - (if (> item-num 50) - (if (eq? 0 (modulo item-num 50)) - (debug:print 0 *default-log-port* "processing " run-num " of " num-runs " runs " item-num " of " num-items " of test " test-name ", " test-num " of " num-tests " tests"))) - ;; (print "test-name: " test-name " event-time: " event-time " run-duration: " run-duration) - (let ((newdoneruns (cons rundat doneruns))) - (if (null? tidstal) - (if iterated - (let* ((xtents (vg:get-extents-for-objs drawing new-test-objs)) - (llx (- (car xtents) 10)) - (lly (- (cadr xtents) 10)) - (ulx (+ 5 (caddr xtents))) - (uly (+ 10 (cadddr xtents)))) - ;; (dashboard:add-bar rowhash 0 llx ulx num-rows: num-items) - ;; This is the box around the tests of an iterated test - (vg:add-obj-to-comp runcomp (vg:make-rect-obj llx lly ulx uly - text: (db:test-get-testname (hash-table-ref tests-ht (car test-ids))) - line-color: (vg:rgb->number 0 0 255 a: 128) - font: "Helvetica -10")) - ;; (vg:instance-move drawing run-full-name 0 (dboard:tabdat-max-row tabdat)) - (dboard:tabdat-view-changed-set! tabdat #t))) ;; trigger a redraw - (if (dboard:tabdat-layout-update-ok tabdat) - (testitemloop (car tidstal)(cdr tidstal)(+ item-num 1) new-test-objs) - (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat) - ))))) - ;; If it is an iterated test put box around it now. - (if (not (null? tests-tal)) - (if #f ;; (> (- (current-seconds) update-start-time) 5) - (debug:print 0 *default-log-port* "drawing runs taking too long") - (if (dboard:tabdat-layout-update-ok tabdat) - (testsloop (car tests-tal)(cdr tests-tal)(+ test-num 1)) - (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat) - ))))) - ;; placeholder box - (dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat) 1)) - ;; (let ((y (calc-y (dboard:tabdat-max-row tabdat)))) ;; (- sizey (* (dboard:tabdat-max-row tabdat) row-height)))) - ;; (vg:add-obj-to-comp runcomp (vg:make-rect-obj 0 y 0 y))) - ;; instantiate the component - (let* ((extents (vg:components-get-extents drawing runcomp)) - (new-xtnts (apply vg:grow-rect 5 5 extents)) - (llx (list-ref new-xtnts 0)) - (lly (list-ref new-xtnts 1)) - (ulx (list-ref new-xtnts 2)) - (uly (list-ref new-xtnts 3)) - (outln (vg:make-rect-obj -5 lly ulx uly - text: run-full-name - line-color: (vg:rgb->number 255 0 255 a: 128)))) - ; (vg:components-get-extents d1 c1))) - ;; this is the box around the run - ;; (mutex-lock! mtx) - (vg:add-obj-to-comp runcomp outln) - ;; (mutex-unlock! mtx) - ;; this is where we have enough info to place the graph - (dboard:graph commondat tabdat tab-num -5 (+ uly 10) ulx (+ uly graph-height 3) run-start run-end timescale maptime run-full-name canvas-margin) - (dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat)(quotient (+ graph-height 40 3) row-height))) - ;; (vg:instance-move drawing run-full-name 0 (dboard:tabdat-max-row tabdat)) - )) - ;; end of the run handling loop - (if (not (dboard:tabdat-layout-update-ok tabdat)) - (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat) - (let ((newdoneruns (cons rundat doneruns))) - (if (null? runtal) - (begin - (dboard:rundat-data-changed-set! rundat #f) - (dboard:tabdat-not-done-runs-set! tabdat '()) - (dboard:tabdat-done-runs-set! tabdat allruns)) - (if #f ;; (> (- (current-seconds) update-start-time) 5) - (begin - (debug:print 0 *default-log-port* "drawing runs taking too long.... have " (length runtal) " remaining") - ;; (dboard:tabdat-done-runs-set! tabdat newdoneruns) ;; taking too long? stop here! - ;; (time (vg:draw (dboard:tabdat-drawing tabdat) #t)) - (dboard:tabdat-not-done-runs-set! tabdat runtal)) - (begin - (if (dboard:tabdat-layout-update-ok tabdat) - (runloop (car runtal)(cdr runtal) (+ run-num 1) newdoneruns) - (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat) - ))))))))) ;; new-run-start-row - ))) - (debug:print 2 *default-log-port* "no tabdat for run-times-tab-updater")))) - -;; handy trick for printing a record -;; -;; (pp (dboard:tabdat->alist tabdat)) -;; -;; removing the tabdat-values proc -;; -;; (define (tabdat-values tabdat) - -;; runs update-rundat using the various filters from the gui -;; -(define (dashboard:do-update-rundat tabdat) - (dboard:update-rundat - tabdat - (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") - (dboard:tabdat-numruns tabdat) - (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") - ;; generate key patterns from the target stored in tabdat - (let* ((dbkeys (dboard:tabdat-dbkeys tabdat))) - (let ((fres (if (dboard:tabdat-target tabdat) - (let ((ptparts (append (dboard:tabdat-target tabdat)(make-list (length dbkeys) "%")))) - (map (lambda (k v)(list k v)) dbkeys ptparts)) - (let ((res '())) - (for-each (lambda (key) - (if (not (equal? key "runname")) - (let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f))) - (if val (set! res (cons (list key val) res)))))) - dbkeys) - res)))) - fres)))) - -(define (dashboard:runs-tab-updater commondat tab-num) - (debug:catch-and-dump - (lambda () - (let* ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num)) - (dbkeys (dboard:tabdat-dbkeys tabdat))) - (dashboard:do-update-rundat tabdat) - (let ((uidat (dboard:commondat-uidat commondat))) - (update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat))) - )) - "dashboard:runs-tab-updater")) - -;;====================================================================== -;; The heavy lifting starts here -;;====================================================================== - -(stop-the-train) - -(define (main) - ;; (print "Starting dashboard main") - - (let* ((mtdb-path (conc *toppath* "/.mtdb/main.db")) - (target (args:get-arg "-target")) - (commondat (dboard:commondat-make))) - (if target - (begin - (args:remove-arg-from-ht "-target") - (dboard:commondat-target-set! commondat target) - ) - ) - - (if (not (launch:setup)) - (begin - (debug:print 0 *default-log-port* "Failed to find megatest.config, exiting") - (exit 1) - ) - ) - - #;(if (not (rmt:on-homehost?)) - (begin - (debug:print 0 *default-log-port* "WARNING: You are starting the dashboard on a machine that is not the homehost:" (server:get-homehost)) - (debug:print 0 *default-log-port* "It will be slower.") - )) - - - (if (and (common:file-exists? mtdb-path) - (file-write-access? mtdb-path)) - (if (not (args:get-arg "-skip-version-check")) - (common:exit-on-version-changed))) - - (let* () - ;; Move this stuff to db.scm? I'm not sure that is the right thing to do... - (cond - ((args:get-arg "-test") ;; run-id,test-id - (let* ((dat (let ((d (map string->number (string-split (args:get-arg "-test") ",")))) - (if (> (length d) 1) - d - (list #f #f)))) - (run-id (car dat)) - (test-id (cadr dat))) - (if (and (number? run-id) - (number? test-id) - (>= test-id 0)) - (dashboard-tests:examine-test run-id test-id) - (begin - (debug:print 3 *default-log-port* "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test")) - (exit 1))))) - (else - (dboard:commondat-uidat-set! commondat (make-dashboard-buttons commondat)) - (dboard:commondat-curr-tab-num-set! commondat 0) - (dboard:commondat-add-updater - commondat - (lambda () - (dashboard:runs-tab-updater commondat 0)) - tab-num: 0) - ;; may not want this alive (manually merged it from v1.66) - ;; (dboard:commondat-add-updater - ;; commondat - ;; (lambda () - ;; (dashboard:runs-tab-updater commondat 1)) - ;; tab-num: 2) - (iup:callback-set! *tim* - "ACTION_CB" - (lambda (time-obj) - (let ((update-is-running #f)) - ;; (mutex-lock! (dboard:commondat-update-mutex commondat)) - (set! update-is-running (dboard:commondat-updating commondat)) - (if (not update-is-running) - (dboard:commondat-updating-set! commondat #t)) - ;; (mutex-unlock! (dboard:commondat-update-mutex commondat)) - (if (not update-is-running) ;; we know that the update was not running and we now have a lock on doing an update - (begin - (dboard:common-run-curr-updaters commondat) ;; (dashboard:run-update commondat) - ;; (mutex-lock! (dboard:commondat-update-mutex commondat)) - (dboard:commondat-updating-set! commondat #f) - ;; (mutex-unlock! (dboard:commondat-update-mutex commondat)) - ))) - 1)))) - ;; (debug:print 0 *default-log-port* "Starting updaters") - (let ((th1 (make-thread (lambda () - (thread-sleep! 1) - (dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab - ) "update buttons once")) - (th2 (make-thread iup:main-loop "Main loop"))) - ;; (print "Starting main loop") - (thread-start! th2) - (thread-join! th2) - ) - ) - ) -) - -(define last-copy-time 0) - - -;; Sync to tmp only if in read-only mode. - -(define (sync-db-to-tmp tabdat) - (let* ((db-file "./.mtdb/main.db")) - (if (and (not (file-write-access? db-file)) ( > (current-seconds) (+ last-copy-time 5))) - (begin - (db:multi-db-sync (db:setup) 'old2new) - (set! last-copy-time (current-seconds)) - ) - ) - ) -) - -;; ########################### top level code ######################## -;; check for MT_* environment variables and exit if found -(if (not (args:get-arg "-test")) - (begin - (for-each (lambda (var) - ;; (display " ")(display var) - (if (get-environment-variable var) - (begin - (debug:print 0 *default-log-port* "ERROR: environment variable " var " is set in this terminal, this will cause you problems. Exiting now.") - (exit 1)))) - '("MT_RUN_AREA_HOME" "MT_MEGATEST" "MT_CMDINFO" "MT_TEST_RUN_DIR" "MT_LINKTREE" "MT_TESTSUITENAME")) - ) -) - -;; This is NOT good -;; (setenv "MT_RUN_AREA_HOME" (get-environment-variable "PWD")) -;; This should be OK but it really should not be necessary -(setenv "MT_RUN_AREA_HOME" (current-directory)) - -(if (not (null? remargs)) - (if remargs - (begin - (debug:print 0 *default-log-port* "Unrecognised arguments: " (string-intersperse remargs " ")) - (exit) - ) - (begin - (print help) - (exit) - ) - ) -) - -(if (args:get-arg "-h") - (begin - (print help) - (exit))) - - - - -(if (args:get-arg "-start-dir") - (if (directory-exists? (args:get-arg "-start-dir")) - (let ((fullpath (common:real-path (args:get-arg "-start-dir")))) - (setenv "PWD" fullpath) - (change-directory fullpath)) - (begin - (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.") - (exit 1)))) - - -;; deal with RH 5.11 gtk lib or iup lib missing detachbox feature -;; first check for the switch -;; -(if (or - (configf:lookup *configdat* "dashboard" "no-detachbox") - (not (file-exists? "/etc/os-release"))) - (set! iup:detachbox iup:vbox)) - - - -;; ease debugging by loading ~/.dashboardrc -(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) - (if (common:file-exists? debugcontrolf) - (load debugcontrolf))) - +(dcommon-main) (if (args:get-arg "-repl") (repl) (main)) Index: db_records.scm ================================================================== --- db_records.scm +++ db_records.scm @@ -13,181 +13,5 @@ ;; 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 . -;;====================================================================== -;; dbstruct -;;====================================================================== - -(define (make-db:test)(make-vector 20)) -(define (db:test-get-id vec) (vector-ref vec 0)) -(define (db:test-get-run_id vec) (vector-ref vec 1)) -(define (db:test-get-testname vec) (vector-ref vec 2)) -(define (db:test-get-state vec) (vector-ref vec 3)) -(define (db:test-get-status vec) (vector-ref vec 4)) -(define (db:test-get-event_time vec) (vector-ref vec 5)) -(define (db:test-get-host vec) (vector-ref vec 6)) -(define (db:test-get-cpuload vec) (vector-ref vec 7)) -(define (db:test-get-diskfree vec) (vector-ref vec 8)) -(define (db:test-get-uname vec) (vector-ref vec 9)) -;; (define (db:test-get-rundir vec) (sdb:qry 'getstr (vector-ref vec 10))) -(define (db:test-get-rundir vec) (vector-ref vec 10)) -(define (db:test-get-item-path vec) (vector-ref vec 11)) -(define (db:test-get-run_duration vec) (vector-ref vec 12)) -(define (db:test-get-final_logf vec) (vector-ref vec 13)) -(define (db:test-get-comment vec) (vector-ref vec 14)) -(define (db:test-get-process_id vec) (vector-ref vec 16)) -(define (db:test-get-archived vec) (vector-ref vec 17)) -(define (db:test-get-last_update vec) (vector-ref vec 18)) - -;; (define (db:test-get-pass_count vec) (vector-ref vec 15)) -;; (define (db:test-get-fail_count vec) (vector-ref vec 16)) -(define (db:test-get-fullname vec) - (conc (db:test-get-testname vec) "/" (db:test-get-item-path vec))) - -;; replace runs:make-full-test-name with this routine -(define (db:test-make-full-name testname itempath) - (if (equal? itempath "") testname (conc testname "/" itempath))) - -;; (define (db:test-get-first_err vec) (printable (vector-ref vec 15))) -;; (define (db:test-get-first_warn vec) (printable (vector-ref vec 16))) ;; RADT => reference 16 is repeated - -(define (db:test-set-cpuload! vec val)(vector-set! vec 7 val)) -(define (db:test-set-diskfree! vec val)(vector-set! vec 8 val)) -(define (db:test-set-testname! vec val)(vector-set! vec 2 val)) -(define (db:test-set-state! vec val)(vector-set! vec 3 val)) -(define (db:test-set-status! vec val)(vector-set! vec 4 val)) -(define (db:test-set-run_duration! vec val)(vector-set! vec 12 val)) -(define (db:test-set-final_logf! vec val)(vector-set! vec 13 val)) - -;; Test record utility functions - -;; Is a test a toplevel? -;; -(define (db:test-get-is-toplevel vec) - (and (equal? (db:test-get-item-path vec) "") ;; test is not an item - (equal? (db:test-get-uname vec) "n/a"))) ;; test has never been run - -;; make-vector-record "" db mintest id run_id testname state status event_time item_path -;; RADT => purpose of mintest?? -;; -(define (make-db:mintest)(make-vector 7)) -(define (db:mintest-get-id vec) (vector-ref vec 0)) -(define (db:mintest-get-run_id vec) (vector-ref vec 1)) -(define (db:mintest-get-testname vec) (vector-ref vec 2)) -(define (db:mintest-get-state vec) (vector-ref vec 3)) -(define (db:mintest-get-status vec) (vector-ref vec 4)) -(define (db:mintest-get-event_time vec) (vector-ref vec 5)) -(define (db:mintest-get-item_path vec) (vector-ref vec 6)) - -;; make-vector-record db testmeta id testname author owner description reviewed iterated avg_runtime avg_disk -(define (make-db:testmeta)(make-vector 10 "")) -(define (db:testmeta-get-id vec) (vector-ref vec 0)) -(define (db:testmeta-get-testname vec) (vector-ref vec 1)) -(define (db:testmeta-get-author vec) (vector-ref vec 2)) -(define (db:testmeta-get-owner vec) (vector-ref vec 3)) -(define (db:testmeta-get-description vec) (vector-ref vec 4)) -(define (db:testmeta-get-reviewed vec) (vector-ref vec 5)) -(define (db:testmeta-get-iterated vec) (vector-ref vec 6)) -(define (db:testmeta-get-avg_runtime vec) (vector-ref vec 7)) -(define (db:testmeta-get-avg_disk vec) (vector-ref vec 8)) -(define (db:testmeta-get-tags vec) (vector-ref vec 9)) -(define (db:testmeta-set-id! vec val)(vector-set! vec 0 val)) -(define (db:testmeta-set-testname! vec val)(vector-set! vec 1 val)) -(define (db:testmeta-set-author! vec val)(vector-set! vec 2 val)) -(define (db:testmeta-set-owner! vec val)(vector-set! vec 3 val)) -(define (db:testmeta-set-description! vec val)(vector-set! vec 4 val)) -(define (db:testmeta-set-reviewed! vec val)(vector-set! vec 5 val)) -(define (db:testmeta-set-iterated! vec val)(vector-set! vec 6 val)) -(define (db:testmeta-set-avg_runtime! vec val)(vector-set! vec 7 val)) -(define (db:testmeta-set-avg_disk! vec val)(vector-set! vec 8 val)) - -;;====================================================================== -;; S I M P L E R U N -;;====================================================================== - -;; (defstruct id "runname" "state" "status" "owner" "event_time" - -;;====================================================================== -;; T E S T D A T A -;;====================================================================== -(define (make-db:test-data)(make-vector 10)) -(define (db:test-data-get-id vec) (vector-ref vec 0)) -(define (db:test-data-get-test_id vec) (vector-ref vec 1)) -(define (db:test-data-get-category vec) (vector-ref vec 2)) -(define (db:test-data-get-variable vec) (vector-ref vec 3)) -(define (db:test-data-get-value vec) (vector-ref vec 4)) -(define (db:test-data-get-expected vec) (vector-ref vec 5)) -(define (db:test-data-get-tol vec) (vector-ref vec 6)) -(define (db:test-data-get-units vec) (vector-ref vec 7)) -(define (db:test-data-get-comment vec) (vector-ref vec 8)) -(define (db:test-data-get-status vec) (vector-ref vec 9)) -(define (db:test-data-get-type vec) (vector-ref vec 10)) -(define (db:test-data-get-last_update vec) (vector-ref vec 11)) - -(define (db:test-data-set-id! vec val)(vector-set! vec 0 val)) -(define (db:test-data-set-test_id! vec val)(vector-set! vec 1 val)) -(define (db:test-data-set-category! vec val)(vector-set! vec 2 val)) -(define (db:test-data-set-variable! vec val)(vector-set! vec 3 val)) -(define (db:test-data-set-value! vec val)(vector-set! vec 4 val)) -(define (db:test-data-set-expected! vec val)(vector-set! vec 5 val)) -(define (db:test-data-set-tol! vec val)(vector-set! vec 6 val)) -(define (db:test-data-set-units! vec val)(vector-set! vec 7 val)) -(define (db:test-data-set-comment! vec val)(vector-set! vec 8 val)) -(define (db:test-data-set-status! vec val)(vector-set! vec 9 val)) -(define (db:test-data-set-type! vec val)(vector-set! vec 10 val)) - -;;====================================================================== -;; S T E P S -;;====================================================================== -;; Run steps -;; make-vector-record "Run steps" db step id test_id stepname step_complete step_pass event_time -(define (make-db:step)(make-vector 9)) -(define (tdb:step-get-id vec) (vector-ref vec 0)) -(define (tdb:step-get-test_id vec) (vector-ref vec 1)) -(define (tdb:step-get-stepname vec) (vector-ref vec 2)) -(define (tdb:step-get-state vec) (vector-ref vec 3)) -(define (tdb:step-get-status vec) (vector-ref vec 4)) -(define (tdb:step-get-event_time vec) (vector-ref vec 5)) -(define (tdb:step-get-logfile vec) (vector-ref vec 6)) -(define (tdb:step-get-comment vec) (vector-ref vec 7)) -(define (tdb:step-get-last_update vec) (vector-ref vec 8)) -(define (tdb:step-set-id! vec val)(vector-set! vec 0 val)) -(define (tdb:step-set-test_id! vec val)(vector-set! vec 1 val)) -(define (tdb:step-set-stepname! vec val)(vector-set! vec 2 val)) -(define (tdb:step-set-state! vec val)(vector-set! vec 3 val)) -(define (tdb:step-set-status! vec val)(vector-set! vec 4 val)) -(define (tdb:step-set-event_time! vec val)(vector-set! vec 5 val)) -(define (tdb:step-set-logfile! vec val)(vector-set! vec 6 val)) -(define (tdb:step-set-comment! vec val)(vector-set! vec 7 val)) - - -;; The steps table -(define (make-db:steps-table)(make-vector 5)) -(define (tdb:steps-table-get-stepname vec) (vector-ref vec 0)) -(define (tdb:steps-table-get-start vec) (vector-ref vec 1)) -(define (tdb:steps-table-get-end vec) (vector-ref vec 2)) -(define (tdb:steps-table-get-status vec) (vector-ref vec 3)) -(define (tdb:steps-table-get-runtime vec) (vector-ref vec 4)) -(define (tdb:steps-table-get-log-file vec) (vector-ref vec 5)) - -(define (tdb:step-stable-set-stepname! vec val)(vector-set! vec 0 val)) -(define (tdb:step-stable-set-start! vec val)(vector-set! vec 1 val)) -(define (tdb:step-stable-set-end! vec val)(vector-set! vec 2 val)) -(define (tdb:step-stable-set-status! vec val)(vector-set! vec 3 val)) -(define (tdb:step-stable-set-runtime! vec val)(vector-set! vec 4 val)) - -;; ;; The data structure for handing off requests via wire -;; (define (make-cdb:packet)(make-vector 6)) -;; (define (cdb:packet-get-client-sig vec) (vector-ref vec 0)) -;; (define (cdb:packet-get-qtype vec) (vector-ref vec 1)) -;; (define (cdb:packet-get-immediate vec) (vector-ref vec 2)) -;; (define (cdb:packet-get-query-sig vec) (vector-ref vec 3)) -;; (define (cdb:packet-get-params vec) (vector-ref vec 4)) -;; (define (cdb:packet-get-qtime vec) (vector-ref vec 5)) -;; (define (cdb:packet-set-client-sig! vec val)(vector-set! vec 0 val)) -;; (define (cdb:packet-set-qtype! vec val)(vector-set! vec 1 val)) -;; (define (cdb:packet-set-immediate! vec val)(vector-set! vec 2 val)) -;; (define (cdb:packet-set-query-sig! vec val)(vector-set! vec 3 val)) -;; (define (cdb:packet-set-params! vec val)(vector-set! vec 4 val)) -;; (define (cdb:packet-set-qtime! vec val)(vector-set! vec 5 val)) Index: dbfile.scm ================================================================== --- dbfile.scm +++ dbfile.scm @@ -496,11 +496,11 @@ (sqlite3:execute db (conc "PRAGMA journal_mode = "journal-mode";"))) (if (and init-proc (or force-init (not db-exists))) (init-proc db)) db)) - expire-time: 5) + expire-time: 15) (begin (if (file-exists? fname ) (let ((db (sqlite3:open-database fname))) ;; pragmas synchronous not needed because this db is used read-only ;; (sqlite3:execute db (conc "PRAGMA synchronous = "mode";") Index: dbmod.scm ================================================================== --- dbmod.scm +++ dbmod.scm @@ -26,11 +26,162 @@ (declare (uses debugprint)) (declare (uses mtargs)) (declare (uses mtmod)) (module dbmod - * + ( + ;; for debug, can be commented out + dbmod:safely-open-db + + dbmod:db-to-db-sync + + db:test-get-event_time + db:test-get-item-path + db:test-get-testname + db:get-value-by-header + + db:get-subdb + + db:multi-db-sync + + dbmod:open-dbmoddb + dbmod:run-id->dbfname + + db:roll-up-rules + db:get-all-state-status-counts-for-test + db:test-set-state-status-db + db:general-call + db:cache-for-read-only + db:convert-test-itempath + + db:test-data-rollup + db:keep-trying-until-true + db:get-test-info-by-id + db:with-db + db:get-test-id + db:get-test-info + + dbmod:print-db-stats + db:get-keys + db:open-no-sync-db + db:add-stats + + ;; dbr:counts record accessors + dbr:counts->alist + + db:add-var + db:archive-register-block-name + db:archive-register-disk + db:create-all-triggers + db:csv->test-data + db:dec-var + db:del-var + db:delete-old-deleted-test-records + db:delete-run + db:delete-steps-for-test! + db:delete-test-records + db:drop-all-triggers + db:get-all-run-ids + db:get-all-runids + db:get-changed-record-ids + db:get-changed-record-run-ids + db:get-changed-record-test-ids + db:get-count-tests-running + db:get-count-tests-running-for-run-id + db:get-count-tests-running-for-testname + db:get-count-tests-running-in-jobgroup + db:get-data-info-by-id + db:get-key-val-pairs + db:get-key-vals + db:get-latest-host-load + db:get-main-run-stats + db:get-matching-previous-test-run-records + db:get-not-completed-cnt + db:get-num-runs + db:get-prereqs-not-met + db:get-prev-run-ids + db:get-raw-run-stats + db:get-run-ids-matching-target + db:get-run-info + db:get-run-name-from-id + db:get-run-record-ids + db:get-run-state + db:get-run-state-status + db:get-run-stats + db:get-run-status + db:get-run-times + db:get-runs + db:get-runs-by-patt + db:get-runs-cnt-by-patt + db:get-steps-data + db:get-steps-for-test + db:get-steps-info-by-id + db:get-target + db:get-targets + db:get-test-state-status-by-id + db:get-test-times + db:get-testinfo-state-status + db:get-tests-for-run + db:get-tests-for-run-mindata + db:get-tests-for-run-state-status + db:get-tests-tags + db:get-toplevels-and-incompletes + db:get-var + db:have-incompletes? + db:inc-var + db:initialize-main-db + db:insert-run + db:insert-test + db:lock/unlock-run + db:login + db:read-test-data + db:read-test-data-varpatt + db:register-run + db:set-run-state-status + db:set-run-status + db:set-state-status-and-roll-up-run + db:set-var + db:simple-get-runs + db:test-get-archive-block-info + db:test-get-logfile-info + db:test-get-paths-matching-keynames-target-new + db:test-get-records-for-index-file + db:test-get-rundir-from-test-id + db:test-get-top-process-pid + db:test-set-archive-block-id + db:test-set-state-status + db:test-set-top-process-pid + db:test-toplevel-num-items + db:testmeta-add-record + db:testmeta-get-record + db:testmeta-update-field + db:teststep-set-status! + db:top-test-set-per-pf-counts + db:update-run-event_time + db:update-run-stats + db:update-tesdata-on-repilcate-db + tasks:add + tasks:find-task-queue-records + tasks:get-last + tasks:set-state-given-param-key + + *db-stats* + dbmod:nfs-get-dbstruct + *db-stats-mutex* + + db:get-header + db:get-rows + db:get-changed-run-ids + + db:set-sync + db:setup + db:get-access-mode + db:test-record-fields + + db:logpro-dat->csv + std-exit-procedure + ) (import scheme) (cond-expand (chicken-4 @@ -79,11 +230,11 @@ dbfile debugprint mtmod ) -(include "common_records.scm") +;; (include "common_records.scm") ;; (include "db_records.scm") ;; (include "key_records.scm") (include "run_records.scm") (define *number-of-writes* 0) @@ -1401,62 +1552,62 @@ (hash-table-set! sync-durations (conc srcfile ".db") (- (current-milliseconds) start-time))) (debug:print-info 2 *default-log-port* "skipping delta sync. " srcfile " is up to date")))) dbfiles)) data-synced)) -;; Sync all changed db's -;; -(define (db:tmp->megatest.db-sync dbstruct run-id last-update) - (let* ((subdbs (hash-table-values (dbr:dbstruct-subdbs dbstruct))) - (res '())) - (for-each - (lambda (subdb) - (let* ((mtdb (dbr:subdb-mtdbdat subdb)) - (tmpdb (db:get-subdb dbstruct run-id)) - (refndb (dbr:subdb-refndb subdb)) - (newres (db:sync-tables (db:sync-all-tables-list (db:get-keys dbstruct)) last-update tmpdb refndb mtdb))) - ;; (stack-push! (dbr:subdb-dbstack subdb) tmpdb) - ;; BUG: verify this is really needed - (dbfile:add-dbdat dbstruct run-id tmpdb) - (set! res (cons newres res)))) - subdbs) - res)) +;; ;; Sync all changed db's +;; ;; +;; (define (db:tmp->megatest.db-sync dbstruct run-id last-update) +;; (let* ((subdbs (hash-table-values (dbr:dbstruct-subdbs dbstruct))) +;; (res '())) +;; (for-each +;; (lambda (subdb) +;; (let* ((mtdb (dbr:subdb-mtdbdat subdb)) +;; (tmpdb (db:get-subdb dbstruct run-id)) +;; (refndb (dbr:subdb-refndb subdb)) +;; (newres (db:sync-tables (db:sync-all-tables-list (db:get-keys dbstruct)) last-update tmpdb refndb mtdb))) +;; ;; (stack-push! (dbr:subdb-dbstack subdb) tmpdb) +;; ;; BUG: verify this is really needed +;; (dbfile:add-dbdat dbstruct run-id tmpdb) +;; (set! res (cons newres res)))) +;; subdbs) +;; res)) ;;;; run-ids ;; if #f use *db-local-sync* : or 'local-sync-flags ;; if #t use timestamps : or 'timestamps ;; ;; NB// no-sync-db is the db handle, not a flag! ;; -(define (db:sync-to-megatest.db dbstruct #!key (no-sync-db #f)) - (let* ((start-time (current-seconds)) - (last-full-update (if no-sync-db - (db:no-sync-get/default no-sync-db "LAST_FULL_UPDATE" 0) - 0)) - (full-sync-needed (> (- start-time last-full-update) 3600)) ;; every hour do a full sync - (last-update (if full-sync-needed - 0 - (if no-sync-db - (db:no-sync-get/default no-sync-db "LAST_UPDATE" 0) - 0))) ;; (or (db:get-var dbstruct "LAST_UPDATE") 0)) - (sync-needed (> (- start-time last-update) 6)) - (res (if (or sync-needed ;; don't sync if a sync already occurred in the past 6 seconds - full-sync-needed) - (begin - (if no-sync-db - (begin - (if full-sync-needed (db:no-sync-set no-sync-db "LAST_FULL_UPDATE" start-time)) - (db:no-sync-set no-sync-db "LAST_UPDATE" start-time))) - (db:tmp->megatest.db-sync dbstruct last-update)) - 0)) - (sync-time (- (current-seconds) start-time))) - (debug:print-info 3 *default-log-port* "Sync of newdb to olddb completed in " sync-time " seconds pid="(current-process-id)) - (if (common:low-noise-print 30 "sync new to old") - (if sync-needed - (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)) +;; (define (db:sync-to-megatest.db dbstruct #!key (no-sync-db #f)) +;; (let* ((start-time (current-seconds)) +;; (last-full-update (if no-sync-db +;; (db:no-sync-get/default no-sync-db "LAST_FULL_UPDATE" 0) +;; 0)) +;; (full-sync-needed (> (- start-time last-full-update) 3600)) ;; every hour do a full sync +;; (last-update (if full-sync-needed +;; 0 +;; (if no-sync-db +;; (db:no-sync-get/default no-sync-db "LAST_UPDATE" 0) +;; 0))) ;; (or (db:get-var dbstruct "LAST_UPDATE") 0)) +;; (sync-needed (> (- start-time last-update) 6)) +;; (res (if (or sync-needed ;; don't sync if a sync already occurred in the past 6 seconds +;; full-sync-needed) +;; (begin +;; (if no-sync-db +;; (begin +;; (if full-sync-needed (db:no-sync-set no-sync-db "LAST_FULL_UPDATE" start-time)) +;; (db:no-sync-set no-sync-db "LAST_UPDATE" start-time))) +;; (db:tmp->megatest.db-sync dbstruct run-id last-update)) +;; 0)) +;; (sync-time (- (current-seconds) start-time))) +;; (debug:print-info 3 *default-log-port* "Sync of newdb to olddb completed in " sync-time " seconds pid="(current-process-id)) +;; (if (common:low-noise-print 30 "sync new to old") +;; (if sync-needed +;; (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)) (define (db:initialize-main-db db #!key (launch-setup #f)) (when (not *configinfo*) (if launch-setup @@ -3056,11 +3207,13 @@ #t (lambda (dbdat db) (delproc db))) (if (and (file-exists? mtdbfile) (file-write-access? mtdbfile)) - (let* ((db (sqlite3:open-database mtdbfile))) + (let* ((db (sqlite3:open-database mtdbfile)) + (handler (sqlite3:make-busy-timeout 136000))) + (sqlite3:set-busy-handler! db handler) (delproc db) (sqlite3:finalize! db))))) ;; ;; speed up for common cases with a little logic ;; ;; NB// Ultimately this will be deprecated in deference to mt:test-set-state-status-by-id Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -18,30 +18,77 @@ ;; ;;====================================================================== (declare (unit dcommon)) -(declare (uses gutils)) (declare (uses dbmod)) (declare (uses commonmod)) (declare (uses configfmod)) (declare (uses rmtmod)) (declare (uses testsmod)) - -(use format) -(require-library iup) -(import (prefix iup iup:)) -(use canvas-draw) -(import canvas-draw-iup) -(use regex typed-records matchable) - -(import commonmod +(declare (uses mtargs)) +(declare (uses vgmod)) +(declare (uses ezstepsmod)) +(declare (uses rmtmod)) +(declare (uses subrunmod)) +(declare (uses megatestmod)) +(declare (uses runsmod)) +(declare (uses tasksmod)) +(declare (uses dbfile)) +(declare (uses servermod)) + +;; needed but dunno why +(use iup canvas-draw fmt) + +(module dcommon + * + +(import scheme + chicken + + ports + posix + extras + format + fmt + srfi-1 + srfi-4 + srfi-13 + srfi-14 + srfi-18 + srfi-69 + sparse-vectors + files + format + (prefix iup iup:) + canvas-draw + canvas-draw-iup + regex + data-structures + directory-utils + pathname-expand + typed-records + matchable + (prefix sqlite3 sqlite3:) + + (prefix mtargs args:) + commonmod configfmod rmtmod testsmod dbmod - debugprint) + debugprint + vgmod + ezstepsmod + rmtmod + subrunmod + megatestmod + runsmod + tasksmod + dbfile + servermod + ) (include "megatest-version.scm") (include "common_records.scm") ;; (include "db_records.scm") ;; (include "key_records.scm") @@ -368,31 +415,31 @@ ;; (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 (if force-set - (let ((max-col-num (+ 1 (common:max (cons-1 (hash-table-values runs-index)))))) + (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) - (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 - (if force-set - (let ((max-row-num (+ 1 (common:max (cons -1 (hash-table-values tests-index)))))) - (hash-table-set! runs-index row-name max-row-num) - max-row-num))))) +;; (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 +;; (if force-set +;; (let ((max-row-num (+ 1 (common:max (cons -1 (hash-table-values tests-index)))))) +;; (hash-table-set! runs-index row-name max-row-num) +;; max-row-num))))) (define (dcommon:rundat-copy-tests-to-by-name rundat) (let ((src-ht (dboard:rundat-tests rundat)) (trg-ht (dboard:rundat-tests-by-name rundat))) (if (and (hash-table? src-ht)(hash-table? trg-ht)) @@ -739,11 +786,11 @@ )) (colnames (list "Id" "MTver" "Pid" "Host" "Interface:OutPort" "RunTime" "State" "RunId")) (updater (lambda () (if (dashboard:monitor-changed? commondat tabdat) (let ((servers (case (rmt:transport-mode) - ((http)(server:choose-server *toppath* 'all-valid)) ;; (server:get-list *toppath* limit: 10))) + ;; ((http)(server:choose-server *toppath* 'all-valid)) ;; (server:get-list *toppath* limit: 10))) (else '())))) (iup:attribute-set! servers-matrix "NUMLIN" (length servers)) ;; (set! colnum 0) ;; (for-each (lambda (colname) ;; ;; (print "colnum: " colnum " colname: " colname) @@ -1484,5 +1531,5342 @@ (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))))) +;;====================================================================== +;; from dashboard +;;====================================================================== + +(define help (conc + "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version + " license GPL, Copyright (C) Matt Welland 2012-2017 + +Usage: dashboard [options] + -h : this help + -test run-id test-id : open a test control panel on this test + -skip-version-check : skip the version check + -rows R : set number of rows + -cols C : set number of columns + -start-dir dir : start dashboard in the given directory + -target target : filter runs tab to given target. + -debug n[,n] : set debug level(s) e.g. -debug 4 or -debug 0,9 + -repl : Start a chicken scheme interpreter + -mode MODE : tcp or nfs +" +)) + + +;; process args +(define remargs (args:get-args + (argv) + ;; parameters (need arguments) + (list "-rows" + "-cols" + "-test" ;; given a run id and test id, open only a test control panel on that test.. + "-debug" + "-start-dir" + "-target" + "-mode" ;; tcp or nfs + ) + ;; switches (don't take arguments) + (list "-h" + "-skip-version-check" + "-repl" + "-: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 '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 +;; +;;;(if (file-write-access? (conc *toppath* "/megatest.db")) +;;(debug:print-info 13 *default-log-port* "Before common:watchdog spawn") + +;; (thread-start! (make-thread common:watchdog "Watchdog thread")) +;;(debug:print-info 13 *default-log-port* "After common:watchdog spawn") +;; (if (not (args:get-arg "-use-db-cache")) +;; (begin +;; (debug:print-info 0 *default-log-port* "Forcing db-cache mode due to read-only access to megatest.db") +;; (hash-table-set! args:arg-hash "-use-db-cache" #t)));;;) +;;) + +;; data common to all tabs goes here +;; +;; Moved to dcommon.scm +;; +;; (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 +;; target +;; ) +;; +;; (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 +;; target: "" +;; )) + +;;====================================================================== +;; buttons color using image +;;====================================================================== + +(define *images* (make-hash-table)) + +(define (make-image images name color) + (if (hash-table-exists? images name) + name + (let* ((img-bits1 (u8vector->blob (u8vector + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + ))) + ;; w h + (img1 (iup:image/palette 16 24 img-bits1))) + (iup:handle-name-set! img1 name) + ;; (iup:attribute-set! img1 "0" "0 0 0") + (iup:attribute-set! img1 "1" color) ;; "BGCOLOR") + ;; (iup:attribute-set! img1 "2" "255 0 0") + (hash-table-set! images name img1) + name))) + + +;; gets and calls updater list based on curr-tab-num +;; +(define (dboard:common-run-curr-updaters commondat #!key (tab-num #f)) + ;; (sync-db-to-tmp (dboard:common-get-tabdat commondat tab-num: tab-num)) ;; no longer applies + + ;; maybe need sleep here? + + (if (dboard:common-get-tabdat commondat tab-num: tab-num) ;; only update if there is a tabdat + (let* ((tnum (or tab-num (dboard:commondat-curr-tab-num commondat))) + (updaters (hash-table-ref/default (dboard:commondat-updaters commondat) + tnum + '()))) + (debug:print 4 *default-log-port* "Found these updaters: " updaters " for tab-num: " tnum) + (for-each ;; perform the function calls for the complete updaters list + (lambda (updater) + ;; (debug:print 3 *default-log-port* "Running " updater) + (updater)) + updaters)))) + +;; 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)))) + +;; data for each specific tab goes here +;; +(defstruct dboard:tabdat + ;; runs + ((allruns '()) : list) ;; list of dboard:rundat records + ((allruns-by-id (make-hash-table)) : hash-table) ;; hash of run-id -> dboard:rundat records + ((done-runs '()) : list) ;; list of runs already drawn + ((not-done-runs '()) : list) ;; list of runs not yet drawn + (header #f) ;; header for decoding the run records + (keys #f) ;; keys for this run (i.e. target components) + ((numruns (string->number (or (args:get-arg "-cols") + (configf:lookup *configdat* "dashboard" "cols") + "8"))) : number) ;; + ((tot-runs 0) : number) + ((last-data-update 0) : number) ;; last time the data in allruns was updated + ((last-runs-update 0) : number) ;; last time we pulled the runs info to update the tree + (runs-mutex (make-mutex)) ;; use to prevent parallel access to draw objects + ((run-update-times (make-hash-table)) : hash-table) ;; update times indexed by run-id + ((last-test-dat (make-hash-table)) : hash-table) ;; cache last tests dat by run-id + ((run-db-paths (make-hash-table)) : hash-table) ;; cache the paths to the run db files + + ;; Runs view + ((buttondat (make-hash-table)) : hash-table) ;; + ((item-test-names '()) : list) ;; list of itemized tests + ((run-keys (make-hash-table)) : hash-table) + (runs-matrix #f) ;; used in newdashboard + ((start-run-offset 0) : number) ;; left-right slider value + ((start-test-offset 0) : number) ;; up-down slider value + ((runs-btn-height (or (configf:lookup *configdat* "dashboard" "btn-height") "x16")) : string) ;; was 12 + ((runs-btn-fontsz (or (configf:lookup *configdat* "dashboard" "btn-fontsz") "10")) : string) ;; was 8 + ((runs-cell-width (or (configf:lookup *configdat* "dashboard" "cell-width") "50")) : string) ;; was 50 + ((all-test-names '()) : list) + + ;; Canvas and drawing data + (cnv #f) + (cnv-obj #f) + (drawing #f) + ((run-start-row 0) : number) + ((max-row 0) : number) + ((running-layout #f) : boolean) + (originx #f) + (originy #f) + ((layout-update-ok #t) : boolean) + ((compact-layout #t) : boolean) + + ;; Run times layout + ;; (graph-button-box #f) ;; RA => Think it is not referenced anywhere + (graph-matrix #f) + ((graph-matrix-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru graph name info + ((graph-cell-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru matrix cell info + ((graph-matrix-row 1) : number) + ((graph-matrix-col 1) : number) + + ;; Controls used to launch runs etc. + ((command "") : string) ;; for run control this is the command being built up + (command-tb #f) ;; widget for the type of command; run, remove-runs etc. + (test-patterns-textbox #f) ;; text box widget for editing a list of test patterns + (key-listboxes #f) + (key-lbs #f) + run-name ;; from run name setting widget + states ;; states for -state s1,s2 ... + statuses ;; statuses for -status s1,s2 ... + + ;; Selector variables + curr-run-id ;; current row to display in Run summary view + prev-run-id ;; previous runid selected before current runid was selected (used in xor-two-runs runs summary mode + curr-test-ids ;; used only in dcommon:run-update which is used in newdashboard + ((filters-changed #t) : boolean) ;; to indicate that the user changed filters for this tab + ((last-filter-str "") : string) ;; conc the target runname and testpatt for a signature of changed filters + ((hide-empty-runs #f) : boolean) + ((hide-not-hide #t) : boolean) ;; toggle for hide/not hide empty runs + (hide-not-hide-button #f) + ((searchpatts (make-hash-table)) : hash-table) ;; + ((state-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATE => #t/#f for display control + ((status-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATUS => #t/#f + (target #f) + (test-patts #f) + + ;; db info to file the .db files for the area + (access-mode (db:get-access-mode)) ;; use cached db or not + (dbdir #f) + (dbfpath #f) + (dbkeys #f) + ((last-db-update (make-hash-table)) : hash-table) ;; last db file timestamp + (monitor-db-path #f) ;; where to find monitor.db + ro ;; is the database read-only? + + ;; tests data + ((num-tests 10) : number) ;; total number of tests to show (used in the old runs display) + + ;; runs tree + ((path-run-ids (make-hash-table)) : hash-table) ;; path (target / runname) => id + (runs-tree #f) + ((runs-tree-ht (make-hash-table)) : hash-table) ;; track which targets added to tree (merge functionality with path-run-ids?) + + ;; tab data + ((view-changed #t) : boolean) + ((xadj 0) : number) ;; x slider number (if using canvas) + ((yadj 0) : number) ;; y slider number (if using canvas) + ;; runs-summary tab state + ((runs-summary-modes '((one-run . "Show One Run") (xor-two-runs . "XOR Two Runs") (xor-two-runs-hide-clean . "XOR; Hide Clean")) ) : list) + ((runs-summary-mode-buttons '()) : list) + ((runs-summary-mode 'one-run) : symbol) + ((runs-summary-mode-change-callbacks '()) : list) + (runs-summary-source-runname-label #f) + (runs-summary-dest-runname-label #f) + ;; runs summary view + + tests-tree ;; used in newdashboard + ) + +;; register tabdat with BBpp +;; this is used by BBpp (Brandon's pretty printer) to convert dboard:tabdat into a composition of lists that pp will handle +;; (hash-table-set! *BBpp_custom_expanders_list* TABDAT: +;; (cons dboard:tabdat? +;; (lambda (tabdat-item) +;; (filter +;; (lambda (alist-entry) +;; (member (car alist-entry) +;; '(allruns-by-id allruns))) ;; FIELDS OF INTEREST +;; (dboard:tabdat->alist tabdat-item))))) + + + +(define (dboard:tabdat-target-string vec) + (let ((targ (dboard:tabdat-target vec))) + (if (list? targ)(string-intersperse targ "/") "no-target-specified"))) + +(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))) + +(define (dboard:tabdat-make-data) + (let ((dat (make-dboard:tabdat))) + (dboard:setup-tabdat dat) + (dboard:setup-num-rows dat) + dat)) + +(define (dboard:setup-tabdat tabdat) + (dboard:tabdat-dbdir-set! tabdat (common:make-tmpdir-name *toppath* "")) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) + (dboard:tabdat-dbfpath-set! tabdat (common:make-tmpdir-name *toppath* "")) + (dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db")) + + + ;; HACK ALERT: this is a hack, please fix. + (dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat)))) + (dboard:tabdat-keys-set! tabdat (rmt:get-keys)) + (dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname"))) + (dboard:tabdat-tot-runs-set! tabdat (rmt:get-num-runs "%")) + ) + +;; 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))) + +;; duplicated in dcommon.scm +;; +;; ;; 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 main.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)) + +;; for the new runs view lets build up a few new record types and then consolidate later +;; +;; this is a two level deep pipeline for the incoming data: +;; sql query data ==> filters ==> data for display +;; +(defstruct dboard:rdat + ;; view related items + (runnum 0) ;; which column we are processing, index into runsbynum, we sweep across all these runs then start over + (leftcol 0) ;; number of the leftmost visible column + (toprow 0) ;; topmost visible row + (numcols 24) ;; number of columns visible + (numrows 20) ;; number of rows visible + + ;; data from sql db + (keys (rmt:get-keys)) ;; to be removed when targets handling is refactored + (runs (make-sparse-vector)) ;; id => runrec + (runsbynum (make-vector 100 #f)) ;; vector num => runrec + (targ-runid (make-hash-table)) ;; area/target/runname => run-id ;; not sure this will be needed + (tests (make-hash-table)) ;; test[/itempath] => list of test rec + (path-run-ids (make-hash-table)) ;; referenced but not set anywhere in new run viewer, maybe get rid of this whole attempt? + + ;; run sql filters + (targ-sql-filt "%") + (runname-sql-filt "%") + (run-state-sql-filt "%") + (run-status-sql-filt "%") + + ;; test sql filter + (testname-sql-filt "%") + (itempath-sql-filt "%") + (test-state-sql-filt "%") + (test-status-sql-filt "%") + + ;; other sql related fields + (last-updates (make-sparse-vector 0)) ;; run-id -> timestamp of the last update from sql db, set to zero on any field changes + + ;; filtered data + (cols (make-sparse-vector)) ;; columnnum => run-id + (tests (make-hash-table)) ;; test[/itempath] => (vector columnnum => test rec) + + ;; various + (prev-run-ids '()) ;; push previously looked at runs on this + (view-changed #f) + + ;; widgets + (runs-tree #f) ;; + ) + +(define (dboard:rdat-push-run-id rdat run-id) + (dboard:rdat-prev-run-ids-set! rdat (cons run-id (dboard:rdat-prev-run-ids rdat)))) + +(defstruct dboard:runrec + id + target ;; a/b/c... + tdef ;; for future use + ) + +(defstruct dboard:testrec + id + runid + testname ;; test[/itempath] + state + status + start-time + duration + ) + +;; register dboard:rundat with BBpp +;; this is used by BBpp (Brandon's pretty printer) to convert dboard:rundat into a composition of lists that pp will handle +;; (hash-table-set! *BBpp_custom_expanders_list* RUNDAT: +;; (cons dboard:rundat? +;; (lambda (tabdat-item) +;; (filter +;; (lambda (alist-entry) +;; (member (car alist-entry) +;; '(run run-data-offset ))) ;; FIELDS OF INTEREST +;; (dboard:rundat->alist tabdat-item))))) + + + + +(define (dboard:rundat-make-init #!key (run #f)(key-vals #f)(tests #f));; -100 is before time began + (make-dboard:rundat + run: run + tests: (or tests (make-hash-table)) + key-vals: key-vals + )) + +(defstruct dboard:testdat + id ;; testid + state ;; test state + status ;; test status + ) + +;; default is to NOT set the cell if the column and row names are not pre-existing +;; +;; (define (dboard:runsdat-set-test-cell dat target runname testname itempath test-id state status #!key (force-set #f)) +;; (let* ((col-num (dcommon:runsdat-get-col-num dat target runname force-set)) +;; (row-num (dcommon:runsdat-get-row-num dat testname itempath force-set))) +;; (if (and row-num col-num) +;; (let ((tdat (make-dboard:testdat +;; id: test-id +;; state: state +;; status: status))) +;; (sparse-array-set! (dboard:runsdat-matrix-dat dat) col-num row-num tdat) +;; tdat) +;; #f))) + +(define *dashboard-mode* (string->symbol (or (configf:lookup *configdat* "dashboard" "mode") "dashboard"))) + + +(define *exit-started* #f) + +;; sorting global data (would apply to many testsuites so leave it global for now) +;; +(define *tests-sort-options* (vector (vector "Sort +a" 'testname "ASC") + (vector "Sort -a" 'testname "DESC") + (vector "Sort +t" 'event_time "ASC") + (vector "Sort -t" 'event_time "DESC") + (vector "Sort +s" 'statestatus "ASC") + (vector "Sort -s" 'statestatus "DESC") + (vector "Sort +a" 'testname "ASC"))) + +(define *tests-sort-type-index* '(("+testname" 0) + ("-testname" 1) + ("+event_time" 2) + ("-event_time" 3) + ("+statestatus" 4) + ("-statestatus" 5))) + +;; Don't forget to adjust the >= below if you add to the sort-options above +(define (next-sort-option) + (if (>= *tests-sort-reverse* 5) + (set! *tests-sort-reverse* 0) + (set! *tests-sort-reverse* (+ *tests-sort-reverse* 1))) + *tests-sort-reverse*) + +(define *tests-sort-reverse* + (let ((t-sort (assoc (configf:lookup *configdat* "dashboard" "testsort") *tests-sort-type-index*))) + (if t-sort + (cadr t-sort) + 3))) + +(define (get-curr-sort) + (vector-ref *tests-sort-options* *tests-sort-reverse*)) + +;;====================================================================== + +(debug:setup) + +;; (define uidat #f) + +(define-inline (dboard:uidat-get-keycol vec)(vector-ref vec 0)) +(define-inline (dboard:uidat-get-lftcol vec)(vector-ref vec 1)) +(define-inline (dboard:uidat-get-header vec)(vector-ref vec 2)) +(define-inline (dboard:uidat-get-runsvec vec)(vector-ref vec 3)) + +(if (get-environment-variable "MT_RUN_AREA_HOME")(change-directory (get-environment-variable "MT_RUN_AREA_HOME"))) + +(define (message-window msg) + (iup:show + (iup:dialog + (iup:vbox + (iup:label msg #:margin "40x40"))))) + +(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)) + +(define (pad-list l n)(append l (make-list (- n (length l))))) + +(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)))) + +(define (dboard:compare-tests test1 test2) + (let* ((test-name1 (db:test-get-testname test1)) + (item-path1 (db:test-get-item-path test1)) + (eventtime1 (db:test-get-event_time test1)) + (test-name2 (db:test-get-testname test2)) + (item-path2 (db:test-get-item-path test2)) + (eventtime2 (db:test-get-event_time test2)) + (same-name (equal? test-name1 test-name2)) + (test1-top (equal? item-path1 "")) + (test2-top (equal? item-path2 "")) + (test1-older (> eventtime1 eventtime2)) + (same-time (equal? eventtime1 eventtime2))) + (if same-name + (if same-time + (string>? item-path1 item-path2) + test1-older) + (if same-time + (string>? test-name1 test-name2) + test1-older)))) + +;; This is roughly the same as dboard:get-tests-dat, should merge them if possible +;; +;; gets all the tests for run-id that match testnamepatt and key-vals, merges them +;; +;; NOTE: Yes, this is used +;; +(define (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals) + (let* ((start-time (current-seconds)) + (access-mode (dboard:tabdat-access-mode tabdat)) + (num-to-get (string->number (or (configf:lookup *configdat* "setup" "num-tests-to-get") + "1000"))) + (states (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat))) + (statuses (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat))) + (do-not-use-db-file-timestamps #f) ;; (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps")) ;; this still hosts runs-summary-tab + (do-not-use-query-timestamps #t) ;; (configf:lookup *configdat* "setup" "do-not-use-query-timestamps")) ;; this no longer troubles runs-summary-tab + (sort-info (get-curr-sort)) + (sort-by (vector-ref sort-info 1)) + (sort-order (vector-ref sort-info 2)) + (bubble-type (if (member sort-order '(testname)) + 'testname + 'itempath)) + ;; note: the rundat is normally created in "update-rundat". + (run-dat (or (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f) + (let ((rd (dboard:rundat-make-init run: run key-vals: key-vals))) + (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id rd) + rd))) + ;; (prev-tests (dboard:rundat-tests prev-dat)) ;; (vector-ref prev-dat 1)) + (last-update (if ;;(or + do-not-use-query-timestamps + ;;(dboard:tabdat-filters-changed tabdat)) + 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/*.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) + (rmt:get-tests-for-run run-id testnamepatt states statuses ;; run-id testpatt states statuses + (dboard:rundat-run-data-offset run-dat) ;; query offset + num-to-get + (dboard:tabdat-hide-not-hide tabdat) ;; no-in + sort-by ;; sort-by + sort-order ;; sort-order + 'shortlist ;; qrytype (was #f) + last-update ;; last-update + *dashboard-mode*) ;; use dashboard mode + '())) + (use-new (dboard:tabdat-hide-not-hide tabdat)) + (tests-ht (if (dboard:tabdat-filters-changed tabdat) + (let ((ht (make-hash-table))) + (dboard:rundat-tests-set! run-dat ht) + ht) + (dboard:rundat-tests run-dat))) + (got-all (< (length tmptests) num-to-get)) ;; got all for this round + ) + ;; (debug:print-info 0 *default-log-port* "got-all="got-all", (hash-table-size tests-ht)="(hash-table-size tests-ht)) + ;; if we saw the db modified, reset it (the signal has already been used) + (if (and got-all ;; (not multi-get) + db-modified) + (dboard:rundat-last-db-time-set! run-dat (- start-time 2))) + + ;; to limit the amount of data transferred each cycle use limit of num-to-get and offset + ;; DO NOT bump time indexes last-update and last-db-time until all the first pass of the + ;; data has been read + ;; set last-update to 0 if still getting data incrementally ;; NO NEED, handled above + ;; + ;; (debug:print 0 *default-log-port* "got-all: " got-all " multi-get: " multi-get " num-to-get: " num-to-get " (length tmptests): " (length tmptests) " db-modified: " db-modified " db-mod-time: " db-mod-time " db-path: " db-path) + (if got-all + (begin + (dboard:rundat-last-update-set! run-dat (- start-time 2)) + (dboard:rundat-run-data-offset-set! run-dat 0)) + (begin + (dboard:rundat-run-data-offset-set! run-dat + (+ num-to-get (dboard:rundat-run-data-offset run-dat))))) + + (for-each + (lambda (tdat) + (let ((test-id (db:test-get-id tdat)) + (state (db:test-get-state tdat))) + (dboard:rundat-data-changed-set! run-dat #t) + (if (equal? state "DELETED") + (hash-table-delete! tests-ht test-id) + (hash-table-set! tests-ht test-id tdat)))) + tmptests) + + tests-ht)) + +;; tmptests - new tests data +;; prev-tests - old tests data +;; +;; (define (dashboard:merge-changed-tests tabdat tests tmptests) ;; use-new prev-tests) +;; (let* ((newdat (filter +;; (lambda (x) +;; (not (equal? (db:test-get-state x) "DELETED"))) ;; remove deleted tests but do it after merging +;; (delete-duplicates (if use-new ;; (dboard:tabdat-filters-changed tabdat) +;; tmptests +;; (append tmptests prev-tests)) +;; (lambda (a b) +;; (eq? (db:test-get-id a)(db:test-get-id b))))))) +;; (print "Time took: " (- (current-seconds) start-time)) +;; (if (eq? *tests-sort-reverse* 3) ;; +event_time +;; (sort newdat dboard:compare-tests) +;; newdat))) + +;; this calls dboard:get-tests-for-run-duplicate for each run +;; +;; create a virtual table of all the tests +;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) +;; +(define (update-rundat tabdat runnamepatt numruns testnamepatt keypatts) + (let* ((access-mode (dboard:tabdat-access-mode tabdat)) + (keys (rmt:get-keys)) + (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2)) + (allruns (rmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) + ;;(allruns-tree (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) + (allruns-tree (rmt:get-runs-by-patt keys "%" #f #f #f #f last-runs-update)) ;;'("id" "runname") + (header (db:get-header allruns)) + (runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected + (runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs + (start-time (current-seconds)) + (runs-hash (let ((ht (make-hash-table))) + (for-each (lambda (run) + (hash-table-set! ht (db:get-value-by-header run header "id") run)) + runs-tree) ;; (vector-ref runs-dat 1)) + ht)) + (tb (dboard:tabdat-runs-tree tabdat))) + ;;(BB> "In update-rundat") + ;;(inspect allruns runs-hash) + (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) + (dboard:tabdat-header-set! tabdat header) + ;; + ;; trim runs to only those that are changing often here + ;; + (if (null? runs) + (begin + (dboard:tabdat-allruns-set! tabdat '()) + (dboard:tabdat-all-test-names-set! tabdat '()) + (dboard:tabdat-item-test-names-set! tabdat '()) + (hash-table-clear! (dboard:tabdat-allruns-by-id tabdat))) + (let loop ((run (car runs)) + (tal (cdr runs)) + (res '()) + (maxtests 0)) + (let* ((run-id (db:get-value-by-header run header "id")) + (run-struct (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)) + (last-update (if run-struct (dboard:rundat-last-update run-struct) 0)) + (key-vals (rmt:get-key-vals run-id)) + (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)) + ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate + ;; dboard:get-tests-for-run-duplicate - returns a hash table + ;; (dboard:get-tests-dat tabdat run-id last-update)) + (all-test-ids (hash-table-keys tests-ht)) + (num-tests (length all-test-ids))) + ;; (print "run-struct: " run-struct) + ;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat) + ;; (tests (bubble-up tmptests priority: bubble-type)) + ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively. + ;; (debug:print 0 *default-log-port* "Getting data for run " run-id " with key-vals=" key-vals) + ;; Not sure this is needed? + (let* ((newmaxtests (max num-tests maxtests)) + (last-update (- (current-seconds) 10)) + (run-struct (or run-struct + (dboard:rundat-make-init + run: run + tests: tests-ht + key-vals: key-vals))) + (new-res (if (null? all-test-ids) res (cons run-struct res))) + (elapsed-time (- (current-seconds) start-time))) + (if (null? all-test-ids) + (hash-table-delete! (dboard:tabdat-allruns-by-id tabdat) run-id) + (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id run-struct)) + (if (or (null? tal) + (> elapsed-time 2)) ;; stop loading data after 5 seconds, on the next call more data *should* be loaded since get-tests-for-run uses last update + (begin + (if (> elapsed-time 2)(debug:print 0 *default-log-port* "WARNING: timed out in update-testdat " elapsed-time "s")) + (dboard:tabdat-allruns-set! tabdat new-res) + maxtests) + (if (> (dboard:rundat-run-data-offset run-struct) 0) + (loop run tal new-res newmaxtests) ;; not done getting data for this run + (loop (car tal)(cdr tal) new-res newmaxtests))))))) + (dboard:tabdat-filters-changed-set! tabdat #f) + (dboard:update-tree tabdat runs-hash header tb))) + + +(define *dashboard-last-run-id-update* (make-hash-table)) ;; id => seconds + +(define (dboard:clear-run-id-update-hash) + (hash-table-clear! *dashboard-last-run-id-update*)) + +;; this calls dboard:get-tests-for-run-duplicate for each run +;; +;; create a virtual table of all the tests +;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) +;; +(define (dboard:update-rundat tabdat runnamepatt numruns testnamepatt keypatts) + (let* ((access-mode (dboard:tabdat-access-mode tabdat)) + (keys (dboard:tabdat-keys tabdat)) ;; (db:dispatch-query access-mode rmt:get-keys db:get-keys))) + (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2)) + (allruns (rmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) + ;;(allruns-tree (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) + (allruns-tree (rmt:get-runs-by-patt keys "%" #f #f #f #f 0)) ;; last-runs-update));;'("id" "runname") + (header (db:get-header allruns)) + (runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected + (runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs + (start-time (current-seconds)) + (runs-hash (let ((ht (make-hash-table))) + (for-each (lambda (run) + (hash-table-set! ht (db:get-value-by-header run header "id") run)) + runs-tree) ;; (vector-ref runs-dat 1)) + ht)) + (tb (dboard:tabdat-runs-tree tabdat))) + (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) + (dboard:tabdat-header-set! tabdat header) + ;; + ;; trim runs to only those that are changing often here + ;; + (if (null? runs) + (begin + (dboard:tabdat-allruns-set! tabdat '()) + (dboard:tabdat-all-test-names-set! tabdat '()) + (dboard:tabdat-item-test-names-set! tabdat '()) + (hash-table-clear! (dboard:tabdat-allruns-by-id tabdat))) + (let loop ((run (car runs)) + (tal (cdr runs)) + (res '()) + (maxtests 0) + (cont-run #f)) + (let* ((run-id (db:get-value-by-header run header "id")) + (recently-done (< (- (current-seconds) + (hash-table-ref/default *dashboard-last-run-id-update* run-id 0)) 1)) + (run-struct (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)) + ;; (last-update (if run-struct (dboard:rundat-last-update run-struct) 0)) + (key-vals (rmt:get-key-vals run-id)) + (tests-ht (let* ((tht (if (and recently-done run-struct) + (let ((rht (dboard:rundat-tests run-struct))) ;; (dboard:tabdat-allruns-by-id tabdat))) + (or rht + (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))) + (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)))) + (assert (hash-table? tht) "FATAL: But here tht should be a hash-table") + tht)) + ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate + ;; dboard:get-tests-for-run-duplicate - returns a hash table + ;; (dboard:get-tests-dat tabdat run-id last-update)) + (all-test-ids (hash-table-keys tests-ht)) + (num-tests (length all-test-ids)) + ;; (print "run-struct: " run-struct) + ;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat) + ;; (tests (bubble-up tmptests priority: bubble-type)) + ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively. + ;; (debug:print 0 *default-log-port* "Getting data for run " run-id " with key-vals=" key-vals) + ;; Not sure this is needed? + (newmaxtests (max num-tests maxtests)) + ;; (last-update (- (current-seconds) 10)) + (run-struct (or run-struct + (dboard:rundat-make-init + run: run + tests: tests-ht + key-vals: key-vals))) + (new-res (if (null? all-test-ids) + res + (delete-duplicates + (cons run-struct res) + (lambda (a b) + (eq? (db:get-value-by-header (dboard:rundat-run a) header "id") + (db:get-value-by-header (dboard:rundat-run b) header "id")))))) + (elapsed-time (- (current-seconds) start-time))) + (if (null? all-test-ids) + (hash-table-delete! (dboard:tabdat-allruns-by-id tabdat) run-id) + (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id run-struct)) + + (if (or (null? tal) + (> elapsed-time 2)) ;; stop loading data after 5 + ;; seconds, on the next call + ;; more data *should* be + ;; loaded since + ;; get-tests-for-run uses last + ;; update + (begin + (when (> elapsed-time 2) + (debug:print 2 *default-log-port* "NOTE: updates are taking a long time, " elapsed-time "s elapsed.") + (let* ((old-val (iup:attribute *tim* "TIME")) + (new-val (number->string (inexact->exact (floor (* 2 (string->number old-val))))))) + (if (< (string->number new-val) 5000) + (begin + (debug:print 2 *default-log-port* "NOTE: increasing poll interval from "old-val" to "new-val) + (iup:attribute-set! *tim* "TIME" new-val))))) + (dboard:tabdat-allruns-set! tabdat new-res) + maxtests) + (if (> (dboard:rundat-run-data-offset run-struct) 0) + (begin + (thread-sleep! 0.2) ;; let the gui re-draw + (loop run tal new-res newmaxtests #t)) ;; not done getting data for this run + (begin + (hash-table-set! *dashboard-last-run-id-update* run-id (current-seconds)) + (loop (car tal)(cdr tal) new-res newmaxtests #f))))))) + (dboard:tabdat-filters-changed-set! tabdat #f) + (dboard:update-tree tabdat runs-hash header tb))) + +(define *collapsed* (make-hash-table)) + +(define (toggle-hide lnum uidat) ; fulltestname) + (let* ((btn (vector-ref (dboard:uidat-get-lftcol uidat) lnum)) + (fulltestname (iup:attribute btn "TITLE")) + (parts (string-split fulltestname "(")) + (basetestname (if (null? parts) "" (car parts)))) + ;(print "Toggling " basetestname " currently " (hash-table-ref/default *collapsed* basetestname #f)) + (if (hash-table-ref/default *collapsed* basetestname #f) + (begin + ;(iup:attribute-set! btn "FGCOLOR" "0 0 0")s + (hash-table-delete! *collapsed* basetestname)) + (begin + ;(iup:attribute-set! btn "FGCOLOR" "0 192 192") + (hash-table-set! *collapsed* basetestname #t))))) + +(define blank-line-rx (regexp "^\\s*$")) + +(define (run-item-name->vectors lst) + (map (lambda (x) + (let ((splst (string-split x "(")) + (res (vector "" ""))) + (vector-set! res 0 (car splst)) + (if (> (length splst) 1) + (vector-set! res 1 (car (string-split (cadr splst) ")")))) + res)) + lst)) + +(define (collapse-rows tabdat inlst) + (let* ((sort-info (get-curr-sort)) + (sort-by (vector-ref sort-info 1)) + (sort-order (vector-ref sort-info 2)) + (bubble-type (if (member sort-order '(testname)) + 'testname + 'itempath)) + (newlst (filter (lambda (x) + (let* ((tparts (string-split x "(")) + (basetname (if (null? tparts) x (car tparts)))) + ;(print "x " x " tparts: " tparts " basetname: " basetname) + (cond + ((string-match blank-line-rx x) #f) + ((equal? x basetname) #t) + ((hash-table-ref/default *collapsed* basetname #f) + ;(print "Removing " basetname " from items") + #f) + (else #t)))) + inlst)) + (vlst (run-item-name->vectors newlst)) + (vlst2 (bubble-up tabdat vlst priority: bubble-type))) + (map (lambda (x) + (if (equal? (vector-ref x 1) "") + (vector-ref x 0) + (conc (vector-ref x 0) "(" (vector-ref x 1) ")"))) + vlst2))) + +(define (update-labels uidat alltestnames) + (let* ((rown 0) + (keycol (dboard:uidat-get-keycol uidat)) + (lftcol (dboard:uidat-get-lftcol uidat)) + (numcols (vector-length lftcol)) + (maxn (- numcols 1)) + (allvals (make-vector numcols ""))) + (for-each (lambda (name) + (if (<= rown maxn) + (vector-set! allvals rown name)) ;) + (set! rown (+ 1 rown))) + alltestnames) + (let loop ((i 0)) + (let* ((lbl (vector-ref lftcol i)) + (keyval (vector-ref keycol i)) + (oldval (iup:attribute lbl "TITLE")) + (newval (vector-ref allvals i))) + (if (not (equal? oldval newval)) + (let ((munged-val (let ((parts (string-split newval "("))) + (if (> (length parts) 1)(conc " " (car (string-split (cadr parts) ")"))) newval)))) + (vector-set! keycol i newval) + (iup:attribute-set! lbl "TITLE" munged-val))) + (iup:attribute-set! lbl "FGCOLOR" (if (hash-table-ref/default *collapsed* newval #f) "0 112 112" "0 0 0")) + (if (< i maxn) + (loop (+ i 1))))))) + + +(define (get-itemized-tests test-dats) + (let ((tnames '())) + (for-each (lambda (tdat) + (let ((tname (vector-ref tdat 0)) ;; (db:test-get-testname tdat)) + (ipath (vector-ref tdat 1))) ;; (db:test-get-item-path tdat))) + (if (not (equal? ipath "")) + (if (and (list? tnames) + (string? tname) + (not (member tname tnames))) + (set! tnames (cons tname tnames)))))) + test-dats) + (reverse tnames))) + +;; Bubble up the top tests to above the items, collect the items underneath +;; all while preserving the sort order from the SQL query as best as possible. +;; +(define (bubble-up tabdat test-dats #!key (priority 'itempath)) + (if (null? test-dats) + test-dats + (begin + (let* ((tnames '()) ;; list of names used to reserve order + (tests-ht (make-hash-table)) ;; hash of lists, used to build as we go + (itemized (get-itemized-tests test-dats))) + #;(for-each + (lambda (testdat) + (let* ((tname (vector-ref testdat 0)) ;; db:test-get-testname testdat)) + (ipath (vector-ref testdat 1))) ;; db:test-get-item-path testdat))) + ;; (seen (hash-table-ref/default tests-th tname #f))) + (if (not (member tname tnames)) + (if (or (and (eq? priority 'itempath) + (not (equal? ipath ""))) + (and (eq? priority 'testname) + (equal? ipath "")) + (not (member tname itemized))) + (set! tnames (append tnames (list tname))))) + (if (equal? ipath "") + ;; This a top level, prepend it + (hash-table-set! tests-ht tname (cons testdat (hash-table-ref/default tests-ht tname '()))) + ;; This is item, append it + (hash-table-set! tests-ht tname (append (hash-table-ref/default tests-ht tname '())(list testdat)))))) + test-dats) + ;; 1. put all test/items into lists in tests-ht + (for-each + (lambda (testdat) + (let* ((tname (vector-ref testdat 0)) ;; db:test-get-testname testdat)) + (ipath (vector-ref testdat 1))) ;; db:test-get-item-path testdat))) + ;; (seen (hash-table-ref/default tests-ht tname #f))) + (if (not (member tname tnames)) + (if (or (and (eq? priority 'itempath) + (not (equal? ipath ""))) + (and (eq? priority 'testname) + (equal? ipath "")) + (not (member tname itemized))) + (set! tnames (append tnames (list tname))))) + (hash-table-set! tests-ht tname (cons testdat (hash-table-ref/default tests-ht tname '()))))) + test-dats) + ;; now bubble up the non-item test in itemized tests + (hash-table-for-each + tests-ht + (lambda (k v) + (if (> (length v) 1) ;; must be itemized, push the no-item to the front + (hash-table-set! tests-ht k (sort v (lambda (a b)(not (equal? (vector-ref b 1) "")))))))) + ;; Set all tests with items + (dboard:tabdat-item-test-names-set! tabdat (append (if (null? tnames) + '() + (filter (lambda (tname) + (let ((tlst (hash-table-ref tests-ht tname))) + (and (list tlst) + (> (length tlst) 1)))) + tnames)) + (dboard:tabdat-item-test-names tabdat))) + (let loop ((hed (car tnames)) + (tal (cdr tnames)) + (res '())) + (let ((newres (append res (hash-table-ref tests-ht hed)))) + (if (null? tal) + newres + (loop (car tal)(cdr tal) newres)))))))) + +;; optimized to get runs constrained by what is visible on the screen +;; - not appropriate for where all the runs are needed +;; +(define (update-buttons tabdat uidat numruns numtests) + (let* ((runs (if (> (length (dboard:tabdat-allruns tabdat)) numruns) + (take-right (dboard:tabdat-allruns tabdat) numruns) + (pad-list (dboard:tabdat-allruns tabdat) numruns))) + (lftcol (dboard:uidat-get-lftcol uidat)) + (tableheader (dboard:uidat-get-header uidat)) + (table (dboard:uidat-get-runsvec uidat)) + (coln 0) + (all-test-names (make-hash-table)) + (use-bgcolor (equal? (configf:lookup *configdat* "dashboard" "use-bgcolor") "yes")) ;; doesn't work + ) + ;; create a concise list of test names + ;; + (for-each + (lambda (rundat) + (if rundat + (let* ((testdats (dboard:rundat-tests rundat)) + (testnames (map test:test-get-fullname (hash-table-values testdats)))) + (dcommon:rundat-copy-tests-to-by-name rundat) + ;; for the normalized list of testnames (union of all runs) + (if (not (and (dboard:tabdat-hide-empty-runs tabdat) + (null? testnames))) + (for-each (lambda (testname) + (hash-table-set! all-test-names testname #t)) + testnames))))) + runs) + + ;; create the minimize list of testnames to be displayed. Sorting + ;; happens here *before* trimming + ;; + (dboard:tabdat-all-test-names-set! + tabdat + (collapse-rows + tabdat + (sort (hash-table-keys all-test-names) string>?))) ;; FIXME: Sorting needs to happen here + + ;; Trim the names list to fit the matrix of buttons + ;; + (dboard:tabdat-all-test-names-set! + tabdat + (let ((xl (if (> (length (dboard:tabdat-all-test-names tabdat)) (dboard:tabdat-start-test-offset tabdat)) + (drop (dboard:tabdat-all-test-names tabdat) + (dboard:tabdat-start-test-offset tabdat)) + '()))) + (append xl (make-list (- (dboard:tabdat-num-tests tabdat) (length xl)) "")))) + (update-labels uidat (dboard:tabdat-all-test-names tabdat)) + (for-each ;;run + (lambda (rundat) + (if (or (not rundat) ;; handle padded runs + (not (dboard:rundat-run rundat))) + ;; Need to put an empty column in to erase previous contents. + (set! rundat (dboard:rundat-make-init + key-vals: (map (lambda (x) "")(dboard:tabdat-keys tabdat))))) + (let* ((run (dboard:rundat-run rundat)) + (testsdat-by-name (dboard:rundat-tests-by-name rundat)) + (key-val-dat (dboard:rundat-key-vals rundat)) + (run-id (db:get-value-by-header run (dboard:tabdat-header tabdat) "id")) + (key-vals (append key-val-dat + (list (let ((x (db:get-value-by-header run (dboard:tabdat-header tabdat) "runname"))) + (if (string? x) x ""))))) + (run-key (string-intersperse key-vals "\n"))) + + ;; fill in the run header key values + ;; + (let ((rown 0) + (headercol (vector-ref tableheader coln))) + (for-each (lambda (kval) + (let* ((labl (vector-ref headercol rown))) + (if (not (equal? kval (iup:attribute labl "TITLE"))) + (iup:attribute-set! (vector-ref headercol rown) "TITLE" kval)) + (set! rown (+ rown 1)))) + key-vals)) + ;; For this run now fill in the buttons for each test + ;; + (let ((rown 0) + (columndat (vector-ref table coln))) + (for-each + (lambda (testname) + (let ((buttondat (hash-table-ref/default (dboard:tabdat-buttondat tabdat) (mkstr coln rown) #f))) + (if (and buttondat + (hash-table? testsdat-by-name)) + (let* ((testdat (let ((matching (hash-table-ref/default testsdat-by-name testname #f))) + ;; (filter + ;; (lambda (x)(equal? (test:test-get-fullname x) testname)) + ;; testsdat))) + (if (not matching) + (vector -1 -1 "" "" "" 0 "" "" 0 "" "" "" 0 "" "") + ;; (car matching)))) + matching))) + (teststatus (db:test-get-status testdat)) + (teststate (db:test-get-state testdat)) + (buttontxt (cond + ((member teststate '("COMPLETED" "ARCHIVED")) teststatus) + ((and (equal? teststate "NOT_STARTED") + (member teststatus '("ZERO_ITEMS" "BLOCKED" "PREQ_FAIL" "PREQ_DISCARDED" "TIMED_OUT" "KEEP_TRYING" "TEN_STRIKES"))) + teststatus) + (else + teststate))) + (button (vector-ref columndat rown)) + (color (car (gutils:get-color-for-state-status teststate teststatus))) + (curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR")) + (curr-title (vector-ref buttondat 2))) ;; (iup:attribute button "TITLE"))) + (if (not (equal? curr-color color)) + (if use-bgcolor + (iup:attribute-set! button "BGCOLOR" color) + (iup:attribute-set! button "IMAGE" (make-image *images* buttontxt color)))) + (if (and (not use-bgcolor) ;; bgcolor does not work with text + (not (equal? curr-title buttontxt))) + (iup:attribute-set! button "TITLE" buttontxt)) + (vector-set! buttondat 0 run-id) + (vector-set! buttondat 1 color) + (vector-set! buttondat 2 buttontxt) + (vector-set! buttondat 3 testdat) + (vector-set! buttondat 4 run-key))) + (set! rown (+ rown 1)))) + (dboard:tabdat-all-test-names tabdat))) + (set! coln (+ coln 1)))) + runs))) + +(define (mkstr . x) + (string-intersperse (map conc x) ",")) + +(define (set-bg-on-filter commondat tabdat) + (let ((search-changed (not (null? (filter (lambda (key) + (not (equal? (hash-table-ref (dboard:tabdat-searchpatts tabdat) key) "%"))) + (hash-table-keys (dboard:tabdat-searchpatts tabdat)))))) + (state-changed (not (null? (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat))))) + (status-changed (not (null? (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)))))) + (iup:attribute-set! (dboard:commondat-hide-not-hide-tabs commondat) "BGCOLOR" + (if (or search-changed + state-changed + status-changed) + "190 180 190" + "190 190 190" + )) + (dboard:tabdat-filters-changed-set! tabdat #t))) + +(define (update-search commondat tabdat x val) + (hash-table-set! (dboard:tabdat-searchpatts tabdat) x val) + (dboard:tabdat-filters-changed-set! tabdat #t) + (mark-for-update tabdat) + (set-bg-on-filter commondat tabdat)) + +;; force ALL updates to zero (effectively) +;; +(define (mark-for-update tabdat) + (dboard:tabdat-last-db-update-set! tabdat (make-hash-table))) + +;;====================================================================== +;; R U N C O N T R O L +;;====================================================================== + +;; target populating logic +;; +;; lb = +;; field = target field name for this dropdown +;; referent-vals = selected value in the left dropdown +;; targets = list of targets to use to build the dropdown +;; +;; each node is chained: key1 -> key2 -> key3 +;; +;; must select values from only apropriate targets +;; a b c +;; a d e +;; a b f +;; a/b => c f +;; +(define (dashboard:populate-target-dropdown lb referent-vals targets) ;; runconf-targs) + ;; is the current value in the new list? choose new default if not + (let* ((remvalues (map (lambda (row) + (common:list-is-sublist referent-vals (vector->list row))) + targets)) + (values (delete-duplicates (map car (filter list? remvalues)))) + (sel-valnum (iup:attribute lb "VALUE")) + (sel-val (iup:attribute lb sel-valnum)) + (val-num 1)) + ;; first check if the current value is in the new list, otherwise replace with + ;; first value from values + (iup:attribute-set! lb "REMOVEITEM" "ALL") + (for-each (lambda (val) + ;; (iup:attribute-set! lb "APPENDITEM" val) + (iup:attribute-set! lb (conc val-num) val) + (if (equal? sel-val val) + (iup:attribute-set! lb "VALUE" val-num)) + (set! val-num (+ val-num 1))) + values) + (let ((val (iup:attribute lb "VALUE"))) + (if val + val + (if (not (null? values)) + (let ((newval (car values))) + (iup:attribute-set! lb "VALUE" newval) + newval)))))) + +(define (dashboard:update-target-selector tabdat #!key (action-proc #f)) + (let* ((runconf-targs (common:get-runconfig-targets)) + (key-lbs (dboard:tabdat-key-listboxes tabdat)) + (db-target-dat (rmt:get-targets)) + (header (vector-ref db-target-dat 0)) + (db-targets (vector-ref db-target-dat 1)) + (munge-target (lambda (x) ;; create a target vector from a string. Pad with na if needed. + (list->vector + (take (append (string-split x "/") + (make-list (length header) "na")) + (length header))))) + (all-targets (append (list (munge-target (string-intersperse + (map (lambda (x) "%") header) + "/"))) + db-targets + (map munge-target + runconf-targs) + )) + (key-listboxes (if key-lbs key-lbs (make-list (length header) #f)))) + (if (not (dboard:tabdat-key-listboxes tabdat))(dboard:tabdat-key-listboxes-set! tabdat key-listboxes)) + (let loop ((key (car header)) + (remkeys (cdr header)) + (refvals '()) + (indx 0) + (lbs '())) + (let* ((lb (let ((lb (list-ref key-listboxes indx))) + (if lb + lb + (iup:listbox + #:size "x60" + #:fontsize "10" + #:expand "YES" ;; "VERTICAL" + ;; #:dropdown "YES" + #:editbox "YES" + #:action (lambda (obj a b c) + (debug:catch-and-dump action-proc "update-target-selector")) + #:caret_cb (lambda (obj a b c) + (debug:catch-and-dump action-proc "update-target-selector")) + )))) + ;; loop though all the targets and build the list for this dropdown + (selected-value (dashboard:populate-target-dropdown lb refvals all-targets))) + (if (null? remkeys) + ;; return a list of the listbox items and an iup:hbox with the labels and listboxes + (let* ((listboxes (append lbs (list lb))) + (res (list listboxes + (map (lambda (htxt lb) + (iup:vbox + (iup:label htxt) + lb)) + header + listboxes)))) + (dboard:tabdat-key-listboxes-set! tabdat res) + res) + (loop (car remkeys) + (cdr remkeys) + (append refvals (list selected-value)) + (+ indx 1) + (append lbs (list lb)))))))) + +;; Make a vertical list of toggles using items, when toggled call proc with the conc'd string +;; interspersed with commas +;; +(define (dashboard:text-list-toggle-box items proc) + (let ((alltgls (make-hash-table))) + (apply iup:vbox + (map (lambda (item) + (iup:toggle + item + #:fontsize 8 + #:expand "YES" + #:action (lambda (obj tstate) + (debug:catch-and-dump + (lambda () + (if (eq? tstate 0) + (hash-table-delete! alltgls item) + (hash-table-set! alltgls item #t)) + (let ((all (hash-table-keys alltgls))) + (proc all))) + "text-list-toggle-box")))) + items)))) + +;; 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 (let ((run-input (dboard:tabdat-run-name tabdat)) + ) + (if (equal? run-input "") + "no-runname-specified" + run-input))) + (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))) + +;; 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)) + )) + +;;====================================================================== +;; R U N C O N T R O L S +;;====================================================================== +;; +;; A gui for launching tests +;; + +(define (dboard:target-updater tabdat) ;; key-listboxes) + (let ((targ (map (lambda (x) + (iup:attribute x "VALUE")) + (car (dashboard:update-target-selector tabdat)))) + (curr-runname (dboard:tabdat-run-name tabdat))) + (dboard:tabdat-target-set! tabdat targ) + ;; (if (dboard:tabdat-updater-for-runs tabdat) + ;; ((dboard:tabdat-updater-for-runs tabdat))) + (if (or (not (equal? curr-runname (dboard:tabdat-run-name tabdat))) + (equal? (dboard:tabdat-run-name tabdat) "")) + (dboard:tabdat-run-name-set! tabdat curr-runname)) + (dashboard:update-run-command tabdat))) + +;; used by run-controls +;; +(define (dashboard:update-tree-selector tabdat #!key (action-proc #f)) + (let* ((tb (dboard:tabdat-runs-tree tabdat)) + (runconf-targs (common:get-runconfig-targets)) + (db-target-dat (rmt:get-targets)) + (runs-tree-ht (dboard:tabdat-runs-tree-ht tabdat)) + (header (vector-ref db-target-dat 0)) + (db-targets (vector-ref db-target-dat 1)) + (munge-target (lambda (x) ;; create a target vector from a string. Pad with na if needed. + (take (append (string-split x "/") + (make-list (length header) "na")) + (length header)))) + (all-targets (append (list (munge-target (string-intersperse + (map (lambda (x) "%") header) + "/"))) + (map vector->list db-targets) + (map munge-target + runconf-targs) + ))) + (for-each + (lambda (target) + (if (not (hash-table-ref/default runs-tree-ht target #f)) + ;; (let ((existing (tree:find-node tb target))) + ;; (if (not existing) + (begin + (tree:add-node tb "Runs" target) ;; (append key-vals (list run-name)) + (hash-table-set! runs-tree-ht target #t)))) + all-targets))) + +;; Run controls panel +;; +(define (dashboard:run-controls commondat tabdat #!key (tab-num #f)) + (let* ((targets (make-hash-table)) + (test-records (make-hash-table)) + (all-tests-registry (tests:get-all)) ;; (tests:get-valid-tests *toppath* '())) + (test-names (hash-table-keys all-tests-registry)) + (sorted-testnames #f) + (action "-run") + (cmdln "") + (runlogs (make-hash-table)) + ;;; (key-listboxes #f) + (update-keyvals (lambda () ;; gets called in dashboard:update-target-selector as "action-proc" + (dboard:target-updater (dboard:tabdat-key-listboxes tabdat)))) + (tests-draw-state (make-hash-table)) ;; use for keeping state of the test canvas + (test-patterns-textbox #f)) + (hash-table-set! tests-draw-state 'first-time #t) + ;; (hash-table-set! tests-draw-state 'scalef 1) + (tests:get-full-data test-names test-records '() all-tests-registry) + (set! sorted-testnames (tests:sort-by-priority-and-waiton test-records)) + + ;; refer to (dboard:tabdat-keys tabdat), (dboard:tabdat-dbkeys tabdat) for keys + (let* ((result + (iup:vbox + (dcommon:command-execution-control tabdat) + (iup:split + #:orientation "VERTICAL" ;; "HORIZONTAL" + #:value 200 + ;; + ;; (iup:split + ;; #:value 300 + + ;; Target, testpatt, state and status input boxes + ;; + (iup:split + #:orientation "HORIZONTAL" + (iup:vbox + ;; Command to run, placed over the top of the canvas + (dcommon:command-action-selector commondat tabdat tab-num: tab-num) + (dboard:runs-tree-browser commondat tabdat)) + (iup:vbox + (dcommon:command-runname-selector commondat tabdat tab-num: tab-num) + (dcommon:command-testname-selector commondat tabdat update-keyvals))) + ;; key-listboxes)) + (dcommon:command-tests-tasks-canvas tabdat test-records sorted-testnames tests-draw-state)))) + (tb (dboard:tabdat-runs-tree tabdat))) + (dboard:commondat-add-updater + commondat + (lambda () + (if (dashboard:database-changed? commondat tabdat context-key: 'run-control) + (dashboard:update-tree-selector tabdat))) + tab-num: tab-num) + result))) + + ;;(iup:frame + ;; #:title "Logs" ;; To be replaced with tabs + ;; (let ((logs-tb (iup:textbox #:expand "YES" + ;; #:multiline "YES"))) + ;; (dboard:tabdat-logs-textbox-set! tabdat logs-tb) + ;; logs-tb)) + +;; browse runs as a tree. Used in both "Runs" tab and +;; in the runs control panel. +;; +(define (dboard:runs-tree-browser commondat tabdat) + (let* ((txtbox (iup:textbox + #:action (lambda (val a b) + (debug:catch-and-dump + (lambda () + ;; for the Runs view we put the list + ;; of keyvals into tabdat target for + ;; the Run Controls we put then update + ;; the run-command + (if b (dboard:tabdat-target-set! tabdat + (string-split b "/"))) + (dashboard:update-run-command tabdat)) + "command-testname-selector tb action")) + #:value (dboard:test-patt->lines + (dboard:tabdat-test-patts-use tabdat)) + #:expand "HORIZONTAL" + ;; #:size "10x30" + )) + (tb + (iup:treebox + #:value 0 + #:title "Runs" ;; was #:name -- iup 3.19 changed + ;; this... "Changed: [DEPRECATED + ;; REMOVED] removed the old attribute + ;; NAMEid from IupTree to avoid + ;; conflict with the common attribute + ;; NAME. Use the TITLEid attribute." + #:expand "YES" + #:addexpanded "YES" + #:size "10x" + #:selection-cb + (lambda (obj id state) + (debug:catch-and-dump + (lambda () + (let* ((run-path (tree:node->path obj id)) + (run-id (tree-path->run-id tabdat (cdr run-path)))) + ;; (dboard:tabdat-view-changed-set! tabdat #t) ;; ?? + ;; done below when run-id is a number + (dboard:tabdat-target-set! tabdat (cdr run-path)) ;; (print + ;; "run-path: + ;; " + ;; run-path) + (iup:attribute-set! txtbox "VALUE" + (string-intersperse (cdr run-path) "/")) + (dashboard:update-run-command tabdat) + (dboard:tabdat-layout-update-ok-set! tabdat #f) + (if (number? run-id) + (begin + ;; capture last two in tabdat. + (dboard:tabdat-prev-run-id-set! + tabdat + (dboard:tabdat-curr-run-id tabdat)) + (dboard:tabdat-curr-run-id-set! tabdat run-id) + (dboard:tabdat-view-changed-set! tabdat #t)) + (debug:print-error 5 *default-log-port* "tree-path->run-id returned non-number " run-id)))) + "treebox")) + ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) + ))) + (dboard:tabdat-runs-tree-set! tabdat tb) + (iup:detachbox + (iup:vbox + txtbox + tb + )))) + +;; browse runs as a tree. Used in both "Runs" tab and +;; in the runs control panel. +;; +;; THIS IS THE NEW ONE +;; +(define (dboard:runs-tree-new-browser commondat rdat) + (let* ((txtbox (iup:textbox + #:action (lambda (val a b) + (debug:catch-and-dump + (lambda () + ;; for the Runs view we put the list + ;; of keyvals into tabdat target for + ;; the Run Controls we put then update + ;; the run-command + (if b (dboard:rdat-targ-sql-filt-set! rdat + (string-split b "/"))) + #;(dashboard:update-run-command tabdat)) + "command-testname-selector tb action")) + ;; #:value (dboard:test-patt->lines ;; This seems like it was wrong, BUG in code where it was copied from? + ;; (dboard:tabdat-test-patts-use tabdat)) + #:expand "HORIZONTAL" + ;; #:size "10x30" + )) + (tb + (iup:treebox + #:value 0 + #:title "Runs" ;; was #:name -- iup 3.19 changed + ;; this... "Changed: [DEPRECATED + ;; REMOVED] removed the old attribute + ;; NAMEid from IupTree to avoid + ;; conflict with the common attribute + ;; NAME. Use the TITLEid attribute." + #:expand "YES" + #:addexpanded "YES" + ;; #:size "10x" + #:selection-cb + (lambda (obj id state) + (debug:catch-and-dump + (lambda () + (let* ((run-path (tree:node->path obj id)) + (run-id (new-tree-path->run-id rdat (cdr run-path)))) + ;; (dboard:tabdat-view-changed-set! tabdat #t) ;; ?? + ;; done below when run-id is a number + (dboard:rdat-targ-sql-filt-set! rdat (cdr run-path)) ;; (print + ;; "run-path: + ;; " + ;; run-path) + (iup:attribute-set! txtbox "VALUE" + (string-intersperse (cdr run-path) "/")) + #;(dashboard:update-run-command tabdat) + #;(dboard:tabdat-layout-update-ok-set! tabdat #f) + (if (number? run-id) + (begin + ;; capture last two in tabdat. + (dboard:rdat-push-run-id rdat run-id) + (dboard:rdat-view-changed-set! rdat #t)) + (debug:print-error 5 *default-log-port* "tree-path->run-id returned non-number " run-id)))) + "treebox")) + ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) + ))) + (dboard:rdat-runs-tree-set! rdat tb) + (iup:detachbox + (iup:vbox + txtbox + tb + )))) + +;;====================================================================== +;; R U N C O N T R O L S +;;====================================================================== +;; +;; A gui for launching tests +;; +(define (dashboard:run-times commondat tabdat #!key (tab-num #f)) + (let* ((drawing (vg:drawing-new)) + (run-times-tab-updater (lambda () + (debug:catch-and-dump + (lambda () + (let ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))) + (if tabdat + (let ((last-data-update (dboard:tabdat-last-data-update tabdat)) + (now-time (current-seconds))) + (dashboard:run-times-tab-canvas-updater commondat tabdat tab-num) + (if (> (- now-time last-data-update) 5) + (if (not (dboard:tabdat-running-layout tabdat)) + (begin + (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num) + (dboard:tabdat-last-data-update-set! tabdat now-time) + ;; this is threadified to return control to the gui for a redraw. + ;; it relies on the running-layout flag to prevent overlapping + ;; calls. + (thread-start! (make-thread + (lambda () + (dboard:tabdat-running-layout-set! tabdat #t) + (dashboard:run-times-tab-layout-updater commondat tabdat tab-num) + (dboard:tabdat-running-layout-set! tabdat #f)) + "run-times-tab-layout-updater"))) + )))))) + "dashboard:run-times-tab-updater"))) + (key-listboxes #f) ;; + (update-keyvals (lambda () + (dboard:target-updater tabdat)))) + (dboard:tabdat-drawing-set! tabdat drawing) + (dboard:commondat-add-updater commondat run-times-tab-updater tab-num: tab-num) + (iup:split + #:orientation "VERTICAL" ;; "HORIZONTAL" + #:value 150 + (iup:vbox + + (dboard:runs-tree-browser commondat tabdat) + + (iup:hbox + (iup:toggle + "Compact layout" + #:fontsize 8 + #:expand "HORIZONTAL" + #:value 1 + #:action (lambda (obj tstate) + (debug:catch-and-dump + (lambda () + ;; (print "tstate: " tstate) + (if (eq? tstate 0) + (dboard:tabdat-compact-layout-set! tabdat #f) + (dboard:tabdat-compact-layout-set! tabdat #t)) + (dboard:tabdat-last-filter-str-set! tabdat "") + ) + "text-list-toggle-box")))) + (dcommon:command-runname-selector commondat tabdat tab-num: tab-num) + (dcommon:command-testname-selector commondat tabdat update-keyvals)) + (iup:vbox + (iup:split + #:orientation "HORIZONTAL" + #:value 800 + (let* ((cnv-obj (iup:canvas + ;; #:size "250x250" ;; "500x400" + #:expand "YES" + #:scrollbar "YES" + #:posx "0.5" + #:posy "0.5" + #:action (make-canvas-action + (lambda (c xadj yadj) + (debug:catch-and-dump + (lambda () + (if (not (dboard:tabdat-cnv tabdat)) + (let ((cnv (dboard:tabdat-cnv tabdat))) + (dboard:tabdat-cnv-set! tabdat c) + (vg:drawing-cnv-set! (dboard:tabdat-drawing tabdat) + (dboard:tabdat-cnv tabdat)))) + (let ((drawing (dboard:tabdat-drawing tabdat)) + (old-xadj (dboard:tabdat-xadj tabdat)) + (old-yadj (dboard:tabdat-yadj tabdat))) + (if (not (and (eq? xadj old-xadj)(eq? yadj old-yadj))) + (begin + ;; (print "xadj: " xadj " yadj: " yadj "changed: "(eq? xadj old-xadj) " " (eq? yadj old-yadj)) + (dboard:tabdat-view-changed-set! tabdat #t) + (dboard:tabdat-xadj-set! tabdat (* -2000 (- xadj 0.5))) + (dboard:tabdat-yadj-set! tabdat (* 2000 (- yadj 0.5))) + )))) + "iup:canvas action"))) + #:wheel-cb (lambda (obj step x y dir) ;; dir is 4 for up and 5 for down. I think. + (debug:catch-and-dump + (lambda () + (let* ((drawing (dboard:tabdat-drawing tabdat)) + (scalex (vg:drawing-scalex drawing))) + (dboard:tabdat-view-changed-set! tabdat #t) + ;; (print "step: " step " x: " x " y: " y " dir: " dir " scalex: " scalex) + (vg:drawing-scalex-set! drawing + (+ scalex + (if (> step 0) + (* scalex 0.02) + (* scalex -0.02)))))) + "wheel-cb")) + ))) + cnv-obj) + (let* ((hb1 (iup:hbox)) + (graph-cell-table (dboard:tabdat-graph-cell-table tabdat)) + (changed #f) + (graph-matrix (iup:matrix + #:alignment1 "ALEFT" + ;; #:expand "YES" ;; "HORIZONTAL" + #:scrollbar "YES" + #:numcol 10 + #:numlin 20 + #:numcol-visible 5 ;; (min 8) + #:numlin-visible 1 + #:click-cb + (lambda (obj row col status) + (let* + ((graph-cell (conc row ":" col)) + (graph-dat (hash-table-ref/default graph-cell-table graph-cell #f)) + (graph-flag (dboard:graph-dat-flag graph-dat))) + (if graph-flag + (dboard:graph-dat-flag-set! graph-dat #f) + (dboard:graph-dat-flag-set! graph-dat #t)) + (if (not (dboard:tabdat-running-layout tabdat)) + (begin + (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num) + (dboard:tabdat-last-data-update-set! tabdat (current-seconds)) + (thread-start! (make-thread + (lambda () + (dboard:tabdat-running-layout-set! tabdat #t) + (dashboard:run-times-tab-layout-updater commondat tabdat tab-num) + (dboard:tabdat-running-layout-set! tabdat #f)) + "run-times-tab-layout-updater")))) + ;;(dboard:tabdat-view-changed-set! tabdat #t) + ))))) + (dboard:tabdat-graph-matrix-set! tabdat graph-matrix) + (iup:attribute-set! graph-matrix "WIDTH0" 0) + (iup:attribute-set! graph-matrix "HEIGHT0" 0) + graph-matrix)) + (iup:hbox + (iup:vbox + (iup:button "Show All" #:action (lambda (obj) + (for-each (lambda (graph-cell) + (let* ((graph-dat (hash-table-ref (dboard:tabdat-graph-cell-table tabdat) graph-cell))) + (dboard:graph-dat-flag-set! graph-dat #t))) + (hash-table-keys (dboard:tabdat-graph-cell-table tabdat)))))) + (iup:hbox + (iup:button "Hide All" #:action (lambda (obj) + (for-each (lambda (graph-cell) + (let* ((graph-dat (hash-table-ref (dboard:tabdat-graph-cell-table tabdat) graph-cell))) + (dboard:graph-dat-flag-set! graph-dat #f))) + (hash-table-keys (dboard:tabdat-graph-cell-table tabdat))))))) + )))) + +;;====================================================================== +;; R U N +;;====================================================================== +;; +;; display and manage a single run at a time + +(define (tree-path->run-id tabdat path) + (if (not (null? path)) + (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) path #f) + #f)) + +(define (new-tree-path->run-id rdat path) + (if (not (null? path)) + (hash-table-ref/default (dboard:rdat-path-run-ids rdat) path #f) + #f)) + +;; (define (dboard:get-tests-dat tabdat run-id last-update) +;; (let* ((access-mode (dboard:tabdat-access-mode tabdat)) +;; (tdat (if run-id (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run +;; run-id +;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") +;; (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)) ;; '() +;; (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)) ;; '() +;; #f #f ;; offset limit +;; (dboard:tabdat-hide-not-hide tabdat) ;; not-in +;; #f #f ;; sort-by sort-order +;; #f ;; get all? "id,testname,item_path,state,status,event_time,run_duration" ;; qryval +;; (if (dboard:tabdat-filters-changed tabdat) +;; 0 +;; last-update) +;; *dashboard-mode*) +;; '()))) ;; get 'em all +;; ;; (debug:print 0 *default-log-port* "dboard:get-tests-dat: got " (length tdat) " test records for run " run-id) +;; (sort tdat (lambda (a b) +;; (let* ((aval (vector-ref a 2)) +;; (bval (vector-ref b 2)) +;; (anum (string->number aval)) +;; (bnum (string->number bval))) +;; (if (and anum bnum) +;; (< anum bnum) +;; (string<= aval bval))))))) + + +(define (dashboard:safe-cadr-assoc name lst) + (let ((res (assoc name lst))) + (if (and res (> (length res) 1)) + (cadr res) + #f))) + +(define (dboard:update-tree tabdat runs-hash runs-header tb) + (let* ((access-mode (dboard:tabdat-access-mode tabdat)) + (run-ids (sort (filter number? (hash-table-keys runs-hash)) + (lambda (a b) + (let* ((record-a (hash-table-ref runs-hash a)) + (record-b (hash-table-ref runs-hash b)) + (time-a (db:get-value-by-header record-a runs-header "event_time")) + (time-b (db:get-value-by-header record-b runs-header "event_time"))) + (< time-a time-b))))) + (changed #f) + (last-runs-update (dboard:tabdat-last-runs-update tabdat)) + (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))) + (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) + (for-each (lambda (run-id) + (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) + (key-vals (map (lambda (key) + (let ((val (db:get-value-by-header run-record runs-header key))) + (if (string? val) val ""))) + (dboard:tabdat-keys tabdat))) + (run-name (db:get-value-by-header run-record runs-header "runname")) + (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) + (run-path (append key-vals (list run-name)))) + (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f)) + ;; (let ((existing (tree:find-node tb run-path))) + ;; (if (not existing) + (begin + (hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path) + ;; (iup:attribute-set! (dboard:tabdat-runs-matrix tabdat) + ;; (conc rownum ":" colnum) col-name) + ;; (hash-table-set! runid-to-col run-id (list colnum run-record)) + ;; Here we update the tests treebox and tree keys + (tree:add-node tb "Runs" run-path) ;; (append key-vals (list run-name)) + ;; userdata: (conc "run-id: " run-id)))) + (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id) + ;; (set! colnum (+ colnum 1)) + )))) + run-ids))) + +(define (dashboard:tests-ht->tests-dat tests-ht) + (reverse + (sort + (hash-table-values tests-ht) + (lambda (a b) + (let ((a-test-name (db:test-get-testname a)) + (a-item-path (db:test-get-item-path a)) + (b-test-name (db:test-get-testname b)) + (b-item-path (db:test-get-item-path b)) + (a-event-time (db:test-get-event_time a)) + (b-event-time (db:test-get-event_time b))) + (if (not (equal? a-test-name b-test-name)) + (> a-event-time b-event-time) + (cond + ((< 0 (string-compare3 a-test-name b-test-name)) #t) + ((> 0 (string-compare3 a-test-name b-test-name)) #f) + ((< 0 (string-compare3 a-item-path b-item-path)) #t) + (else #f)))))))) + + +(define (dashboard:run-id->tests-mindat run-id tabdat runs-hash) + (let* ((run (hash-table-ref/default runs-hash run-id #f)) + (key-vals (rmt:get-key-vals run-id)) + (testnamepatt (or (dboard:tabdat-test-patts tabdat) "%/%")) + (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)) + (tests-dat (dashboard:tests-ht->tests-dat tests-ht)) + (tests-mindat (dcommon:minimize-test-data tests-dat))) ;; reduces data for display + (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) + (hash-table-set! (dboard:tabdat-last-test-dat tabdat) run-id tests-dat) + (hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- (current-seconds) 10)) + (when (not run) + (debug:print-info 13 *default-log-port* "ERROR: NO RUN FOR RUN-ID run-id="run-id) + (debug:print-info 13 *default-log-port* "runs-hash-> " (hash-table->alist runs-hash)) + ) + tests-mindat)) + +(define (dashboard:runs-summary-xor-matrix-content tabdat runs-hash #!key (hide-clean #f)) + (let* ((src-run-id (dboard:tabdat-prev-run-id tabdat)) + (dest-run-id (dboard:tabdat-curr-run-id tabdat))) + (if (and src-run-id dest-run-id) + (dcommon:xor-tests-mindat + (dashboard:run-id->tests-mindat src-run-id tabdat runs-hash) + (dashboard:run-id->tests-mindat dest-run-id tabdat runs-hash) + hide-clean: hide-clean) + #f))) + + +(define (dashboard:get-runs-hash tabdat) + (let* ((access-mode (dboard:tabdat-access-mode tabdat)) + (last-runs-update 0);;(dboard:tabdat-last-runs-update tabdat)) + (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) + (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records + (runs (vector-ref runs-dat 1)) + (run-id (dboard:tabdat-curr-run-id tabdat)) + (runs-hash (let ((ht (make-hash-table))) + (for-each (lambda (run) + (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) + runs) ht))) + runs-hash)) + + +(define (dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix) + ;; (if (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-rundat) + (dashboard:do-update-rundat tabdat) ;; ) + (dboard:runs-summary-control-panel-updater tabdat) + (let* ((last-runs-update (dboard:tabdat-last-runs-update tabdat)) + (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) + (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records + (runs (vector-ref runs-dat 1)) + (run-id (dboard:tabdat-curr-run-id tabdat)) + (runs-hash (dashboard:get-runs-hash tabdat)) + ;; (runs-hash (let ((ht (make-hash-table))) + ;; (for-each (lambda (run) + ;; (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) + ;; runs) + ;; ht)) + ) + (if (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-tree) + (dboard:update-tree tabdat runs-hash runs-header tb)) + (if run-id + (let* ((matrix-content + (case (dboard:tabdat-runs-summary-mode tabdat) + ((one-run) (dashboard:run-id->tests-mindat run-id tabdat runs-hash)) + ((xor-two-runs) (dashboard:runs-summary-xor-matrix-content tabdat runs-hash)) + ((xor-two-runs-hide-clean) (dashboard:runs-summary-xor-matrix-content tabdat runs-hash hide-clean: #t)) + (else (dashboard:run-id->tests-mindat run-id tabdat runs-hash))))) + (when matrix-content + (let* ((indices (common:sparse-list-generate-index matrix-content)) ;; proc: set-cell)) + (row-indices (cadr indices)) + (col-indices (car indices)) + (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) + (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices)))) + (max-visible (max (- (dboard:tabdat-num-tests tabdat) 15) 3)) ;; (dboard:tabdat-num-tests tabdat) is proportional to the size of the window + (numrows 1) + (numcols 1) + (changed #f) + ) + + (dboard:tabdat-filters-changed-set! tabdat #f) + (let loop ((pass-num 0) + (changed #f)) + ;; Update the runs tree + ;; (dboard:update-tree tabdat runs-hash runs-header tb) + + (if (eq? pass-num 1) + (begin ;; big reset + (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS + (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS") + (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES"))) + + (if (> max-col (string->number (iup:attribute run-matrix "NUMCOL"))) + (iup:attribute-set! run-matrix "NUMCOL" max-col )) + + (let ((effective-max-row (if (< max-row max-visible) max-visible max-row))) + (if (> effective-max-row (string->number (iup:attribute run-matrix "NUMLIN"))) + (iup:attribute-set! run-matrix "NUMLIN" effective-max-row ))) + + ;; Row labels + (for-each (lambda (ind) + (let* ((name (car ind)) + (num (cadr ind)) + (key (conc num ":0"))) + (if (not (equal? (iup:attribute run-matrix key) name)) + (begin + (set! changed #t) + (iup:attribute-set! run-matrix key name))))) + row-indices) + ;; (print "row-indices: " row-indices " col-indices: " col-indices) + (if (and (eq? pass-num 0) changed) + (loop 1 #t)) ;; force second pass + + ;; Cell contents + (for-each (lambda (entry) + ;; (print "entry: " entry) + (let* ((row-name (cadr entry)) + (col-name (car entry)) + (valuedat (caddr entry)) + (test-id (list-ref valuedat 0)) + (test-name row-name) ;; (list-ref valuedat 1)) + (item-path col-name) ;; (list-ref valuedat 2)) + (state (list-ref valuedat 1)) + (status (list-ref valuedat 2)) + (value (gutils:get-color-for-state-status state status)) + (row-num (cadr (assoc row-name row-indices))) + (col-num (cadr (assoc col-name col-indices))) + (key (conc row-num ":" col-num))) + (hash-table-set! cell-lookup key test-id) + (if (not (equal? (iup:attribute run-matrix key) (cadr value))) + (begin + (set! changed #t) + (iup:attribute-set! run-matrix key (cadr value)) + (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value)))))) + matrix-content) + + ;; Col labels - do after setting Cell contents so they are accounted for in the size calc. + + (for-each (lambda (ind) + (let* ((name (car ind)) + (num (cadr ind)) + (key (conc "0:" num))) + (if (not (equal? (iup:attribute run-matrix key) name)) + (begin + (set! changed #t) + (iup:attribute-set! run-matrix key name) + (if (<= num max-col) + (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num))))))) + col-indices) + + (if (and (eq? pass-num 0) changed) + (loop 1 #t)) ;; force second pass due to column labels changing + + ;; (debug:print 0 *default-log-port* "runs-summary-updater, changed: " changed " pass-num: " pass-num) + ;; (print "runs-summary-updater, changed: " changed " pass-num: " pass-num) + (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL"))))))))) + +;;====================================================================== +;; S U M M A R Y +;;====================================================================== +;; +;; General info about the run(s) and megatest area +(define (dashboard:summary commondat tabdat #!key (tab-num #f)) + (let* ((rawconfig (read-config (conc *toppath* "/megatest.config") #f #f)) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string))) + (changed #f)) + (iup:vbox + (iup:split + #:value 300 + (iup:frame + #:title "General Info" + (iup:vbox + (iup:hbox + (iup:label "Area Path") + (iup:textbox #:value *toppath* #:expand "HORIZONTAL")) + (iup:hbox + (dcommon:keys-matrix rawconfig) + (dcommon:general-info) + ))) + (iup:frame + #:title "Server" + (dcommon:servers-table commondat tabdat))) + (iup:frame + #:title "Megatest config settings" + (iup:hbox + (dcommon:section-matrix rawconfig "setup" "Varname" "Value") + (iup:vbox + (dcommon:section-matrix rawconfig "server" "Varname" "Value") + ;; (iup:frame + ;; #:title "Disks Areas" + (dcommon:section-matrix rawconfig "disks" "Disk area" "Path")))) + (iup:frame + #:title "Run statistics" + (dcommon:run-stats commondat tabdat tab-num: tab-num))))) + +;;====================================================================== +;; H A N D L E U S E R C O N T R I B U T E D V I E W S +;;====================================================================== + +(define (dboard:add-external-tab commondat view-name views-cfgdat tabs tab-num) + (let* ((success #t) ;; at any stage of the process set this flag to #f to skip downstream steps. Intention here is to recover gracefully if user provided tabs fail to load. + (source (configf:lookup views-cfgdat view-name "source")) + (viewgen (configf:lookup views-cfgdat view-name "viewgen")) + (updater (configf:lookup views-cfgdat view-name "updater")) + (result-child #f)) + (if (and (common:file-exists? source) + (file-read-access? source)) + (handle-exceptions + exn + (begin + (print-call-chain) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) + (debug:print 0 *default-log-port* "ERROR: failed to load " source ", try loading in the repl: megatest -repl") + (set! success #f)) + (load source)) + (begin + (debug:print 0 *default-log-port* "ERROR: cannot find file to load: \"" source "\" for user view " view-name))) + ;; now run the user supplied definition for the tab view + (if success + (handle-exceptions + exn + (begin + (print-call-chain) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) + (debug:print 0 *default-log-port* "ERROR: failed call procedure " viewgen + ", with; tab-num=" tab-num ", view-name=" view-name + ", and views-cfgdat and megatest configdat as parameters. To debug try loading in the repl: megatest -repl") + (set! success #f)) + (debug:print 0 *default-log-port* "Adding tab " view-name " with proc " viewgen) + ;; (iup:child-add! tabs + (set! result-child + ((eval (string->symbol viewgen)) commondat tabs tab-num view-name views-cfgdat *configdat*)))) + ;; and finally set the updater + (if success + (dboard:commondat-add-updater commondat + (lambda () + (handle-exceptions + exn + (begin + (print-call-chain) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) + (debug:print 0 *default-log-port* "ERROR: failed call procedure \"" updater + "\", with; tabnum=" tab-num ", view-name=" view-name + ", and views-cfgdat and megatest configdat as parameters. To debug try loading in the repl: megatest -repl") + (set! success #f)) + (debug:print 4 *default-log-port* "Running updater for tab " view-name " with proc " updater " and tab-num: " tab-num) + ((eval (string->symbol updater)) commondat tabs tab-num view-name views-cfgdat *configdat*))) + tab-num: tab-num)) + ;;(if success + ;; (begin + ;; ;; (iup:attribute-set! tabs (conc "TABTITLE" tab-num) view-name) + ;; (dboard:common-set-tabdat! commondat tab-num (dboard:tabdat-make-data)))) + result-child)) + + + +(define (dboard:runs-summary-buttons-updater tabdat) + (let loop ((buttons-left (dboard:tabdat-runs-summary-mode-buttons tabdat)) + (modes-left (dboard:tabdat-runs-summary-modes tabdat))) + (if (or (null? buttons-left) (null? modes-left)) + #t + (let* ((this-button (car buttons-left)) + (mode-item (car modes-left)) + (this-mode (car mode-item)) + (sel-color "180 100 100") + (nonsel-color "170 170 170") + (current-mode (dboard:tabdat-runs-summary-mode tabdat))) + (if (eq? this-mode current-mode) + (iup:attribute-set! this-button "BGCOLOR" sel-color) + (iup:attribute-set! this-button "BGCOLOR" nonsel-color)) + (loop (cdr buttons-left) (cdr modes-left)))))) + +(define (dboard:runs-summary-xor-labels-updater tabdat) + (let ((source-runname-label (dboard:tabdat-runs-summary-source-runname-label tabdat)) + (dest-runname-label (dboard:tabdat-runs-summary-dest-runname-label tabdat)) + (mode (dboard:tabdat-runs-summary-mode tabdat))) + (when (and source-runname-label dest-runname-label) + (case mode + ((xor-two-runs xor-two-runs-hide-clean) + (let* ((curr-run-id (dboard:tabdat-curr-run-id tabdat)) + (prev-run-id (dboard:tabdat-prev-run-id tabdat)) + (curr-runname (if curr-run-id + (rmt:get-run-name-from-id curr-run-id) + "None")) + (prev-runname (if prev-run-id + (rmt:get-run-name-from-id prev-run-id) + "None"))) + (iup:attribute-set! source-runname-label "TITLE" (conc " SRC: "prev-runname" ")) + (iup:attribute-set! dest-runname-label "TITLE" (conc "DEST: "curr-runname" ")))) + (else + (iup:attribute-set! source-runname-label "TITLE" "") + (iup:attribute-set! dest-runname-label "TITLE" "")))))) + +(define (dboard:runs-summary-control-panel-updater tabdat) + (dboard:runs-summary-xor-labels-updater tabdat) + (dboard:runs-summary-buttons-updater tabdat)) + + +;; setup buttons and callbacks to switch between modes in runs summary tab +;; +(define (dashboard:runs-summary-control-panel tabdat) + (let* ((summary-buttons ;; build buttons + (map + (lambda (mode-item) + (let* ((this-mode (car mode-item)) + (this-mode-label (cdr mode-item))) + (iup:button this-mode-label + #:action + (lambda (obj) + (debug:catch-and-dump + (lambda () + (dboard:tabdat-runs-summary-mode-set! tabdat this-mode) + (dboard:runs-summary-control-panel-updater tabdat)) + "runs summary control panel updater"))))) + (dboard:tabdat-runs-summary-modes tabdat))) + (summary-buttons-hbox (apply iup:hbox summary-buttons)) + (xor-runname-labels-hbox + (iup:hbox + (let ((temp-label + (iup:label "" #:size "125x15" #:fontsize "10" ))) + (dboard:tabdat-runs-summary-source-runname-label-set! tabdat temp-label) + temp-label + ) + (let ((temp-label + (iup:label "" #:size "125x15" #:fontsize "10"))) + (dboard:tabdat-runs-summary-dest-runname-label-set! tabdat temp-label) + temp-label)))) + (dboard:tabdat-runs-summary-mode-buttons-set! tabdat summary-buttons) + + ;; maybe wrap in a frame + (let ((res (iup:vbox summary-buttons-hbox xor-runname-labels-hbox ))) + (dboard:runs-summary-control-panel-updater tabdat) + res + ))) + + + +;;====================================================================== +;; R U N +;;====================================================================== +;; +;; display and manage a single run at a time + +;; This is the Run Summary tab +;; +(define (dashboard:runs-summary commondat tabdat #!key (tab-num #f)) + (let* ((update-mutex (dboard:commondat-update-mutex commondat)) + (tb (iup:treebox + #:value 0 + ;;#:name "Runs" + #:title "Runs" + #:expand "YES" + #:addexpanded "YES" + #:selection-cb + (lambda (obj id state) + (debug:catch-and-dump + (lambda () + ;; (print "obj: " obj ", id: " id ", state: " state) + (let* ((run-path (tree:node->path obj id)) + (run-id (tree-path->run-id tabdat (cdr run-path)))) + (if (number? run-id) + (begin + (dboard:tabdat-prev-run-id-set! + tabdat + (dboard:tabdat-curr-run-id tabdat)) + + (dboard:tabdat-curr-run-id-set! tabdat run-id) + (dboard:tabdat-layout-update-ok-set! tabdat #f) + ;; (dashboard:update-run-summary-tab) + ) + ;; (debug:print-error 0 *default-log-port* "tree-path->run-id returned non-number " run-id) + ))) + "selection-cb in runs-summary") + ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) + ))) + (cell-lookup (make-hash-table)) + (run-matrix (iup:matrix + #:expand "YES" + #:click-cb + + (lambda (obj lin col status) + (debug:catch-and-dump + (lambda () + + ;; Bummer - we dont have the global get/set api mapped in chicken + ;; (let* ((modkeys (iup:global "MODKEYSTATE"))) + ;; (BB> "modkeys="modkeys)) + + (debug:print-info 13 *default-log-port* "click-cb: obj="obj" lin="lin" col="col" status="status) + ;; status is corrupted on Brandon's home machine. will have to wait until after shutdown to see if it is still broken in PDX SLES + (let* ((toolpath (car (argv))) + (key (conc lin ":" col)) + (test-id (hash-table-ref/default cell-lookup key -1)) + (run-id (dboard:tabdat-curr-run-id tabdat)) + (run-info (rmt:get-run-info run-id)) + (target (rmt:get-target run-id)) + (runname (db:get-value-by-header (db:get-rows run-info) + (db:get-header run-info) "runname")) + (test-info (rmt:get-test-info-by-id run-id test-id)) + (test-name (db:test-get-testname test-info)) + (testpatt (let ((tlast (rmt:tasks-get-last target runname))) + (if tlast + (let ((tpatt (tasks:task-get-testpatt tlast))) + (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017 + "%" + tpatt)) + "%"))) + (item-path (db:test-get-item-path (rmt:get-test-info-by-id run-id test-id))) + (item-test-path (conc test-name "/" (if (equal? item-path "") + "%" + item-path))) + (status-chars (char-set->list (string->char-set status))) + (run-id (dboard:tabdat-curr-run-id tabdat))) + (debug:print-info 13 *default-log-port* "status-chars=["status-chars"] status=["status"]") + (cond + ((member #\1 status-chars) ;; 1 is left mouse button + (dboard:launch-testpanel run-id test-id)) + + ((member #\2 status-chars) ;; 2 is middle mouse button + + (debug:print-info 13 *default-log-port* "mmb- test-name="test-name" testpatt="testpatt) + (iup:show (dashboard:context-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu + #:x 'mouse + #:y 'mouse + #:modal? "NO") + ) + (else + (debug:print-info 13 *default-log-port* "unhandled status in run-summary-click-cb. Doing right click action. (status is corrupted on Brandon's ubuntu host - bad/buggy iup install??" ) + (iup:show (dashboard:context-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu + #:x 'mouse + #:y 'mouse + #:modal? "NO") + ) + ) + + )) "runs-summary-click-callback")))) + (runs-summary-updater + (lambda () + ;; (mutex-lock! update-mutex) + (if (or (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-updater) + (dboard:tabdat-view-changed tabdat)) + (debug:catch-and-dump + (lambda () ;; check that run-matrix is initialized before calling the updater + (if run-matrix + (dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix))) + "dashboard:runs-summary-updater") + ) + #;(mutex-unlock! update-mutex) + )) + (runs-summary-control-panel (dashboard:runs-summary-control-panel tabdat)) + ) + (dboard:commondat-add-updater commondat runs-summary-updater tab-num: tab-num) + (dboard:tabdat-runs-tree-set! tabdat tb) + (iup:vbox + (iup:split + #:value 200 + tb + run-matrix) + (dboard:make-controls commondat tabdat extra-widget: runs-summary-control-panel)))) + +;;====================================================================== +;; R U N S +;;====================================================================== + +(define (dboard:squarify toggles size) + (let loop ((hed (car toggles)) + (tal (cdr toggles)) + (cur '()) + (res '())) + (let* ((ovrflo (>= (length cur) size)) + (newcur (if ovrflo + (list hed) + (cons hed cur))) + (newres (if ovrflo + (cons cur res) + res))) + (if (null? tal) + (if ovrflo + newres + (cons newcur res)) + (loop (car tal)(cdr tal) newcur newres))))) + +(define (dboard:make-controls commondat tabdat #!key (extra-widget #f) ) + (let ((btn-fontsz (dboard:tabdat-runs-btn-fontsz tabdat))) + (iup:hbox + (iup:vbox + (iup:frame + #:title "filter test and items" + (iup:vbox + (iup:hbox + (iup:vbox + (iup:textbox #:size "120x15" #:fontsize "10" #:value "%" + #:expand "NO" + #:action (lambda (obj unk val) + (debug:catch-and-dump + (lambda ()57 + (mark-for-update tabdat) + (update-search commondat tabdat "test-name" val)) + "make-controls"))) + (iup:hbox + (iup:button "Quit" #:action (lambda (obj) + (exit)) + #:expand "NO" #:size "40x15") + (iup:button "Refresh" #:action (lambda (obj) + (dboard:tabdat-last-data-update-set! tabdat 0) + (dboard:tabdat-last-runs-update-set! tabdat 0) + (dboard:tabdat-run-update-times-set! tabdat (make-hash-table)) + (dboard:tabdat-last-test-dat-set! tabdat (make-hash-table)) + (dboard:tabdat-allruns-set! tabdat '()) + (dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table)) + (dboard:tabdat-done-runs-set! tabdat '()) + (dboard:tabdat-not-done-runs-set! tabdat '()) + (dboard:tabdat-view-changed-set! tabdat #t) + (dboard:commondat-please-update-set! commondat #t) + (dboard:clear-run-id-update-hash) + (mark-for-update tabdat)) + #:expand "NO" #:size "40x15") + (iup:button "Collapse" #:action (lambda (obj) + (debug:catch-and-dump + (lambda () + (let ((myname (iup:attribute obj "TITLE"))) + (if (equal? myname "Collapse") + (begin + (for-each (lambda (tname) + (hash-table-set! *collapsed* tname #t)) + (dboard:tabdat-item-test-names tabdat)) + (iup:attribute-set! obj "TITLE" "Expand")) + (begin + (for-each (lambda (tname) + (hash-table-delete! *collapsed* tname)) + (hash-table-keys *collapsed*)) + (iup:attribute-set! obj "TITLE" "Collapse")))) + (mark-for-update tabdat)) + "make-controls collapse button")) + #:expand "NO" #:size "40x15"))) + (iup:vbox + ;; (iup:button "Sort -t" #:action (lambda (obj) + ;; (next-sort-option) + ;; (iup:attribute-set! obj "TITLE" (vector-ref (vector-ref *tests-sort-options* *tests-sort-reverse*) 0)) + ;; (mark-for-update tabdat))) + + (let* ((hide #f) + (show #f) + (hide-empty #f) + (sel-color "180 100 100") + (nonsel-color "170 170 170") + (cmds-list '("+testname" "-testname" "+event_time" "-event_time" "+statestatus" "-statestatus")) + (sort-lb (iup:listbox #:expand "NO" ;; "HORIZONTAL" + #:size "80x15" + #:dropdown "YES" + #:action (lambda (obj val index lbstate) + (set! *tests-sort-reverse* index) + (mark-for-update tabdat)))) + (default-cmd (car (list-ref *tests-sort-type-index* *tests-sort-reverse*)))) + + (iuplistbox-fill-list sort-lb cmds-list selected-item: default-cmd) + + ;; (set! hide-empty (iup:button "HideEmpty" + ;; ;; #:expand HORIZONTAL" + ;; #:expand "NO" #:size "80x15" + ;; #:action (lambda (obj) + ;; (dboard:tabdat-hide-empty-runs-set! tabdat (not (dboard:tabdat-hide-empty-runs tabdat))) + ;; (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-empty-runs tabdat) "+HideE" "-HideE")) + ;; (mark-for-update tabdat)))) + (set! hide (iup:button "Hide" + #:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL" + #:action (lambda (obj) + (dboard:tabdat-hide-not-hide-set! tabdat #t) ;; (not (dboard:tabdat-hide-not-hide tabdat))) + ;; (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-not-hide tabdat) "HideTests" "NotHide")) + (iup:attribute-set! hide "BGCOLOR" sel-color) + (iup:attribute-set! show "BGCOLOR" nonsel-color) + (mark-for-update tabdat)))) + (set! show (iup:button "Show" + #:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL" + #:action (lambda (obj) + (dboard:tabdat-hide-not-hide-set! tabdat #f) ;; (not (dboard:tabdat-hide-not-hide tabdat))) + (iup:attribute-set! show "BGCOLOR" sel-color) + (iup:attribute-set! hide "BGCOLOR" nonsel-color) + (mark-for-update tabdat)))) + (iup:attribute-set! hide "BGCOLOR" sel-color) + (iup:attribute-set! show "BGCOLOR" nonsel-color) + ;; (dboard:tabdat-hide-not-hide-button-set! tabdat hideit) ;; never used, can eliminate ... + (iup:vbox + (iup:hbox hide show) + sort-lb))) + ) + + ;; insert extra widget here + (if extra-widget + extra-widget + (iup:hbox)) ;; empty widget + + + + + ))) + + (let* ((status-toggles (map (lambda (status) + (iup:toggle (conc status) + #:fontsize 8 ;; btn-fontsz ;; "10" + ;; #:expand "HORIZONTAL" + #:action (lambda (obj val) + (mark-for-update tabdat) + (if (eq? val 1) + (hash-table-set! (dboard:tabdat-status-ignore-hash tabdat) status #t) + (hash-table-delete! (dboard:tabdat-status-ignore-hash tabdat) status)) + (set-bg-on-filter commondat tabdat)))) + (map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP"))) + (state-toggles (map (lambda (state) + (iup:toggle (conc state) + #:fontsize 8 ;; btn-fontsz + ;; #:expand "HORIZONTAL" + #:action (lambda (obj val) + (mark-for-update tabdat) + (if (eq? val 1) + (hash-table-set! (dboard:tabdat-state-ignore-hash tabdat) state #t) + (hash-table-delete! (dboard:tabdat-state-ignore-hash tabdat) state)) + (set-bg-on-filter commondat tabdat)))) + (map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED"))) + (num-toggle-cols (inexact->exact (round (/ (max (length status-toggles)(length state-toggles)) 3))))) + (iup:vbox + (iup:hbox + (iup:frame + #:title "states" + (apply + iup:hbox + (map (lambda (colgrp) + (apply iup:vbox colgrp)) + (dboard:squarify state-toggles 3)))) + (iup:frame + #:title "statuses" + (apply + iup:hbox + (map (lambda (colgrp) + (apply iup:vbox colgrp)) + (dboard:squarify status-toggles 3))))) + ;; + ;; (iup:frame + ;; #:title "state/status filter" + ;; (iup:vbox + ;; (apply + ;; iup:hbox + ;; (map + ;; (lambda (status-toggle state-toggle) + ;; (iup:vbox + ;; status-toggle + ;; state-toggle)) + ;; status-toggles state-toggles)) + + ;; horizontal slider was here + + ))))) + +(define (dashboard:runs-horizontal-slider tabdat ) + (iup:valuator #:valuechanged_cb (lambda (obj) + (let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10)))) + (oldmax (string->number (iup:attribute obj "MAX"))) + (maxruns (dboard:tabdat-tot-runs tabdat))) + (dboard:tabdat-start-run-offset-set! tabdat val) + (mark-for-update tabdat) + (debug:print 6 *default-log-port* "(dboard:tabdat-start-run-offset tabdat) " (dboard:tabdat-start-run-offset tabdat) " maxruns: " maxruns ", val: " val " oldmax: " oldmax) + (iup:attribute-set! obj "MAX" (* maxruns 10)))) + #:expand "HORIZONTAL" + #:max (* 10 (max (hash-table-size (dboard:tabdat-allruns-by-id tabdat)) 10)) + #:min 0 + #:step 0.01)) + +;; make-simple-run procedure (target3772 id3773 runname3774 state3775 status3776 owner3777 event_time3778) +;; rmt:simple-get-runs procedure (runpatt1001 count1002 offset1003 target1004) +;; simple-run-event_time procedure (x3834) +;; simple-run-event_time-set! procedure (x3830 val3831) +;; simple-run-id procedure (x3794) +;; simple-run-id-set! procedure (x3790 val3791) +;; simple-run-owner procedure (x3826) +;; simple-run-owner-set! procedure (x3822 val3823) +;; simple-run-runname procedure (x3802) +;; simple-run-runname-set! procedure (x3798 val3799) +;; simple-run-state procedure (x3810) +;; simple-run-state-set! procedure (x3806 val3807) +;; simple-run-status procedure (x3818) +;; simple-run-status-set! procedure (x3814 val3815) +;; simple-run-target procedure (x3786) +;; simple-run-target-set! procedure (x3782 val3783) +;; simple-run? procedure (x3780) + + +;;====================================================================== +;; Extracting the data to display for runs +;; +;; This needs to be re-entrant such that it does one column per call +;; on the zeroeth call update runs data +;; on each subsequent call update one run (configurable - could do two, three ... or update until tdelta exceeded +;; on last run reset to zeroeth +;; +;; 1. select with run filters; area, target, runname, runstate, runstatus, starttime, duration +;; - put this information into two data structures: +;; a. hash of area/target/runname => runstruct #< ordernun, id, area, target, runname, state, +;; status, starttime, duration, non-deleted testcount> +;; ordernum reflects order as received from sql query +;; b. sparsevec of id => runstruct +;; 2. for each run in runshash ordered by ordernum do: +;; retrieve data since last update for that run +;; if there is a deleted test - retrieve full data +;; if there are non-deleted tests register this run in the columns sparsevec +;; if this is the zeroeth column regenerate the rows sparsevec +;; if this column is in the visible zone update visible cells +;; +;; Other factors: +;; 1. left index handling: +;; - add test/itempaths to left index as discovered, re-order and +;; update row -> test/itempath mapping on each read run +;;====================================================================== + +;; runs is +;; get ALL runs info +;; update rdat-targ-run-id +;; update rdat-runs +;; +(define (dashboard:update-runs-data rdat) + (let* ((tb (dboard:rdat-runs-tree rdat)) + (targ-sql-filt (dboard:rdat-targ-sql-filt rdat)) + (runname-sql-filt (dboard:rdat-runname-sql-filt rdat)) + (state-sql-filt (dboard:rdat-run-state-sql-filt rdat)) + (status-sql-filt (dboard:rdat-run-status-sql-filt rdat)) + ;; Use (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) + (data (rmt:simple-get-runs runname-sql-filt #f #f targ-sql-filt #f)) + (numruns (length data))) + ;; store in the runsbynum vector + (dboard:rdat-runsbynum-set! rdat (list->vector data)) + ;; update runs id => runrec + ;; update targ-runid target/runname => run-id + (for-each + (lambda (runrec) + (let* ((run-id (simple-run-id runrec)) + (full-targ-runname (conc (simple-run-target runrec) "/" + (simple-run-runname runrec)))) + (debug:print 0 *default-log-port* "Update run " run-id) + (sparse-vector-set! (dboard:rdat-runs rdat) run-id runrec) + (hash-table-set! (dboard:rdat-targ-runid rdat) full-targ-runname run-id) + )) + data) + numruns)) + +;; NOTE: runnum is NOT the run-id, it is a pointer into the runsbynum vector +;; +(define (dashboard:update-run-data runnum rdat) + (let* ((curr-time (current-seconds)) + (runrec (vector-ref (dboard:rdat-runsbynum rdat) runnum)) + (run-id (simple-run-id runrec)) + (last-update (sparse-vector-ref (dboard:rdat-last-updates rdat) run-id)) + ;; filters + (testname-sql-filt (dboard:rdat-testname-sql-filt rdat)) + ;; (itempath-sql-filt (dboard:rdat-itempath-sql-filt rdat)) + (test-state-sql-filt (dboard:rdat-test-state-sql-filt rdat)) ;; not used yet + (test-status-sql-filt (dboard:rdat-test-status-sql-filt rdat)) ;; not used yet + (tests (rmt:get-tests-for-run-state-status run-id + testname-sql-filt + last-update ;; last-update + ))) + (sparse-vector-set! (dboard:rdat-last-updates rdat) run-id (- curr-time 1)) + (debug:print 0 *default-log-port* "Got " (length tests) " tests for run-id " + run-id " testname-sql-filt " testname-sql-filt " and last-update " last-update) + (length tests))) + +(define (new-runs-updater commondat rdat) + (let* ((runnum (dboard:rdat-runnum rdat)) + (start-time (current-milliseconds)) + (tot-runs #f)) + (if (eq? runnum 0)(dashboard:update-runs-data rdat)) + (set! tot-runs (vector-length (dboard:rdat-runsbynum rdat))) + (let loop ((rn runnum)) + (if (and (< (- (current-milliseconds) start-time) 250) + (< rn tot-runs)) + (let* ((newrn (if (>= runnum (vector-length (dboard:rdat-runsbynum rdat))) + 0 ;; start over + (+ rn 1)))) ;; (+ runnum 1))) + (dashboard:update-run-data rn rdat) + (dboard:rdat-runnum-set! rdat newrn) + (if (> newrn 0) + (loop newrn))))) + (if (>= (dboard:rdat-runnum rdat) tot-runs) + (dboard:rdat-runnum-set! rdat 0)) + ;; (dboard:rdat-runnum-set! rdat rn))) ;; not needed as it is set above + ;; (dboard:rdat-last-update-set! rdat (- (current-seconds) 10)) + ;; (tree:add-node tb "Runs" (string-split full-targ-runname "/")) + '())) + +(define (dboard:runs-new-matrix commondat rdat) + (iup:matrix + #:alignment1 "ALEFT" + ;; #:expand "YES" ;; "HORIZONTAL" + #:scrollbar "YES" + #:numcol 10 + #:numlin 20 + #:numcol-visible 5 ;; (min 8) + #:numlin-visible 1 + #:click-cb + (lambda (obj row col status) + (let* ((cell (conc row ":" col))) + #f)) + )) + +(define (make-runs-view commondat rdat tab-num) + ;; register an updater + (dboard:commondat-add-updater + commondat + (lambda () + (new-runs-updater commondat rdat)) + tab-num: tab-num) + + (iup:vbox + (iup:split + #:orientation "VERTICAL" ;; "HORIZONTAL" + #:value 100 + (dboard:runs-tree-new-browser commondat rdat) + (dboard:runs-new-matrix commondat rdat) + ))) + +(define (make-dashboard-buttons commondat) ;; runs-sum-dat new-view-dat) + (let* ( + (stats-dat (dboard:tabdat-make-data)) + (runs-dat (dboard:tabdat-make-data)) + (runs2-dat (make-dboard:rdat)) ;; (dboard:tabdat-make-data)) + (onerun-dat (dboard:tabdat-make-data)) ;; name for run-summary structure + (runcontrols-dat (dboard:tabdat-make-data)) + (runtimes-dat (dboard:tabdat-make-data)) + (nruns (dboard:tabdat-numruns runs-dat)) + (ntests (dboard:tabdat-num-tests runs-dat)) + (keynames (dboard:tabdat-dbkeys runs-dat)) + (nkeys (length keynames)) + (runsvec (make-vector nruns)) + (header (make-vector nruns)) + (lftcol (make-vector ntests)) + (keycol (make-vector ntests)) + (controls (dboard:make-controls commondat runs-dat)) ;; '()) + (lftlst '()) + (hdrlst '()) + (bdylst '()) + (result '()) + (i 0) + (btn-height (dboard:tabdat-runs-btn-height runs-dat)) + (btn-fontsz (dboard:tabdat-runs-btn-fontsz runs-dat)) + (cell-width (dboard:tabdat-runs-cell-width runs-dat)) + (use-bgcolor (equal? (configf:lookup *configdat* "dashboard" "use-bgcolor") "yes"))) + ;; controls (along bottom) + ;; (set! controls (dboard:make-controls commondat runs-dat)) + + + + ;; create the left most column for the run key names and the test names + (set! lftlst + (list (iup:hbox + (iup:label) ;; (iup:valuator) + (apply iup:vbox + (map (lambda (x) + (let ((res (iup:hbox + #:expand "HORIZONTAL" + (iup:label x + #:size (conc 40 btn-height) + #:fontsize btn-fontsz + #:expand "NO") ;; "HORIZONTAL") + (iup:textbox + #:size (conc 35 btn-height) + #:fontsize btn-fontsz + #:value "%" + #:expand "NO" ;; "HORIZONTAL" + #:action (lambda (obj unk val) + ;; each field + ;; (field name is "x" var) live updates + ;; the search filter as it is typed + (dboard:tabdat-target-set! runs-dat #f) + ;; ensure fields text boxes are used + ;; and not the info from the tree + (mark-for-update runs-dat) + (update-search commondat runs-dat x val)))))) + (set! i (+ i 1)) + res)) + keynames))))) + (let loop ((testnum 0) + (res '())) + (cond + ((>= testnum ntests) + ;; now lftlst will be an hbox with the test keys and the test name labels + (set! lftlst + (append + lftlst + (list + (iup:hbox + #:expand "HORIZONTAL" + (iup:valuator + #:valuechanged_cb + (lambda (obj) + (let ((val (string->number (iup:attribute obj "VALUE"))) + (oldmax (string->number (iup:attribute obj "MAX"))) + (newmax (* 10 (length (dboard:tabdat-all-test-names runs-dat))))) + (dboard:commondat-please-update-set! commondat #t) + (dboard:tabdat-start-test-offset-set! runs-dat + (inexact->exact (round (/ val 10)))) + (debug:print 6 *default-log-port* + "(dboard:tabdat-start-test-offset runs-dat) " + (dboard:tabdat-start-test-offset runs-dat) " val: " val + " newmax: " newmax " oldmax: " oldmax) + (if (< val 10) + (iup:attribute-set! obj "MAX" newmax)) + )) + #:expand "VERTICAL" + #:orientation "VERTICAL" + #:min 0 + #:step 0.01) + (apply iup:vbox (reverse res))))))) + (else + (let ((labl (iup:button + "" ;; the testname labels + #:flat "YES" + #:alignment "ALEFT" + ; #:image img1 + ; #:impress img2 + #:size (conc cell-width btn-height) + #:expand "HORIZONTAL" + #:fontsize btn-fontsz + #:action (lambda (obj) + (mark-for-update runs-dat) + (toggle-hide testnum (dboard:commondat-uidat commondat)))))) + (vector-set! lftcol testnum labl) + (loop (+ testnum 1)(cons labl res)))))) + ;; These are the headers for each row + (let loop ((runnum 0) + (keynum 0) + (keyvec (make-vector nkeys)) + (res '())) + (cond ;; nb// no else for this approach. + ((>= runnum nruns) #f) + ((>= keynum nkeys) + (vector-set! header runnum keyvec) + (set! hdrlst (cons (apply iup:vbox (reverse res)) hdrlst)) + (loop (+ runnum 1) 0 (make-vector nkeys) '())) + (else + (let ((labl (iup:label "" #:size (conc cell-width btn-height) #:fontsize btn-fontsz #:expand "HORIZONTAL"))) ;; #:expand "HORIZONTAL" "60x15" + (vector-set! keyvec keynum labl) + (loop runnum (+ keynum 1) keyvec (cons labl res)))))) + ;; By here the hdrlst contains a list of vboxes containing nkeys labels + (let loop ((runnum 0) + (testnum 0) + (testvec (make-vector ntests)) + (res '())) + (cond + ((>= runnum nruns) #f) ;; (vector tableheader runsvec)) + ((>= testnum ntests) + (vector-set! runsvec runnum testvec) + (set! bdylst (cons (apply iup:vbox (reverse res)) bdylst)) + (loop (+ runnum 1) 0 (make-vector ntests) '())) + (else + (let* ((button-key (mkstr runnum testnum)) + (butn (iup:button + (if use-bgcolor #f " ") ;; button-key + #:size (conc cell-width btn-height ) + #:expand "HORIZONTAL" + #:fontsize btn-fontsz + #:button-cb + (lambda (obj a pressed x y btn . rem) + ;; (print "pressed= " pressed " x= " x " y= " y " rem=" rem " btn=" btn " string? " (string? btn)) + (if (substring-index "3" btn) + (if (eq? pressed 1) + (let* ((toolpath (car (argv))) + (buttndat (hash-table-ref (dboard:tabdat-buttondat runs-dat) button-key)) + (test-id (db:test-get-id (vector-ref buttndat 3))) + (run-id (db:test-get-run_id (vector-ref buttndat 3))) + (run-info (rmt:get-run-info run-id)) + (target (rmt:get-target run-id)) + (runname (db:get-value-by-header (db:get-rows run-info) + (db:get-header run-info) "runname")) + (test-info (rmt:get-test-info-by-id run-id test-id)) + (test-name (db:test-get-testname test-info)) + (testpatt (let ((tlast (rmt:tasks-get-last target runname))) + (if tlast + (let ((tpatt (tasks:task-get-testpatt tlast))) + (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017 + "%" + tpatt)) + "%"))) + (item-path (db:test-get-item-path (rmt:get-test-info-by-id run-id test-id))) + (item-test-path (conc test-name "/" (if (equal? item-path "") + "%" + item-path)))) + (iup:show (dashboard:context-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu + #:x 'mouse + #:y 'mouse + #:modal? "NO") + ;; (print "got here") + )) + (if (eq? pressed 0) + (let* ((toolpath (car (argv))) + (buttndat (hash-table-ref (dboard:tabdat-buttondat runs-dat) button-key)) + (test-id (db:test-get-id (vector-ref buttndat 3))) + (run-id (db:test-get-run_id (vector-ref buttndat 3)))) + (dboard:launch-testpanel run-id test-id)))))))) + (iup:attribute-set! butn "IMAGE" (make-image *images* "BGCOLOR" "222 222 221")) ;;; "BGCOLOR" "BGCOLOR") + (hash-table-set! (dboard:tabdat-buttondat runs-dat) button-key (vector 0 "100 100 100" button-key #f #f)) + (vector-set! testvec testnum butn) + (loop runnum (+ testnum 1) testvec (cons butn res)))))) + ;; now assemble the hdrlst and bdylst and kick off the dialog + (iup:show + (iup:dialog + #:title (conc "Megatest dashboard " (current-user-name) ":" *toppath*) + #:menu (dcommon:main-menu) + (let* ((runs-view (iup:vbox + (iup:split + #:orientation "VERTICAL" ;; "HORIZONTAL" + #:value 250 + (dboard:runs-tree-browser commondat runs-dat) + (iup:split + #:value 200 + ;; left most block, including row names + (apply iup:vbox lftlst) + ;; right hand block, including cells + (iup:vbox + #:expand "YES" + ;; the header + (apply iup:hbox (reverse hdrlst)) + (apply iup:hbox (reverse bdylst)) + (dashboard:runs-horizontal-slider runs-dat)))) + controls + )) + (views-cfgdat (common:load-views-config)) + (additional-tabnames '()) + (tab-start-num 5) ;; DON'T FORGET TO UPDATE THIS WHEN CHANGING THE STANDARD TABS BELOW + ;; (data (dboard:tabdat-init (make-d:data))) + (additional-views ;; process views-dat + (let ((tab-num tab-start-num) + (result '())) + (for-each + (lambda (view-name) + (debug:print 0 *default-log-port* "Adding view " view-name) + (let* ((cfgtype (configf:lookup views-cfgdat view-name "type"))) ;; what type of view? + (if (not (string? cfgtype)) + (debug:print-info 0 *default-log-port* "WARNING: view \"" view-name + "\" is missing needed sections. " + "Please consult the documenation and update ~/.mtviews.config or " + *toppath* "/.mtviews.config") + (case (string->symbol cfgtype) + ;; user supplied source for a tab + ;; + ((external) ;; was tabs + (let ((tab-content (dboard:add-external-tab commondat view-name views-cfgdat #f tab-num))) + (set! additional-tabnames (cons (cons tab-num view-name) additional-tabnames)) + (set! tab-num (+ tab-num 1)) + (set! result (append result (list tab-content))))))))) + (sort (hash-table-keys views-cfgdat) + (lambda (a b) + (let ((order-a (or (any->number (configf:lookup views-cfgdat a "order")) 999)) + (order-b (or (any->number (configf:lookup views-cfgdat b "order")) 999))) + (> order-a order-b))))) + result)) + (tabs (apply iup:tabs + #:tabchangepos-cb (lambda (obj curr prev) + (debug:catch-and-dump + (lambda () + (let* ((tab-num (dboard:commondat-curr-tab-num commondat)) + (tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))) + (dboard:tabdat-layout-update-ok-set! tabdat #f)) + (dboard:commondat-curr-tab-num-set! commondat curr) + (let* ((tab-num (dboard:commondat-curr-tab-num commondat)) + (tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))) + (dboard:commondat-please-update-set! commondat #t) + (dboard:tabdat-layout-update-ok-set! tabdat #t))) + "tabchangepos")) + runs-view + (dashboard:summary commondat stats-dat tab-num: 1) + ;; (make-runs-view commondat runs2-dat 2) + (dashboard:runs-summary commondat onerun-dat tab-num: 2) + (dashboard:run-controls commondat runcontrols-dat tab-num: 3) + (dashboard:run-times commondat runtimes-dat tab-num: 4) + additional-views)) + (target-run (dboard:commondat-target commondat)) + ) + ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c))) + (iup:attribute-set! tabs "TABTITLE0" "Runs") + (iup:attribute-set! tabs "TABTITLE1" "Summary") + ;; (iup:attribute-set! tabs "TABTITLE2" "Runs2") + (iup:attribute-set! tabs "TABTITLE2" "Run Summary") + (iup:attribute-set! tabs "TABTITLE3" "Run Control") + (iup:attribute-set! tabs "TABTITLE4" "Run Times") + ;; (iup:attribute-set! tabs "TABTITLE3" "New View") + ;; (iup:attribute-set! tabs "TABTITLE4" "Run Control") + + ;; set the tab names for user added tabs + (for-each + (lambda (tab-info) + (iup:attribute-set! tabs (conc "TABTITLE" (car tab-info)) (cdr tab-info))) + additional-tabnames) + + (iup:attribute-set! tabs "BGCOLOR" "190 190 190") + ;; make the iup tabs object available (for changing color for example) + (dboard:commondat-hide-not-hide-tabs-set! commondat tabs) + ;; now set up the tabdat lookup + ;; (dboard:common-set-tabdat! commondat 0 stats-dat) + + (if target-run + (begin + (dboard:tabdat-target-set! runs-dat (string-split target-run "/")) + ) + ) + (dboard:common-set-tabdat! commondat 0 runs-dat) + ;;(dboard:common-set-tabdat! commondat 2 runs2-dat) + (dboard:common-set-tabdat! commondat 2 onerun-dat) + (dboard:common-set-tabdat! commondat 3 runcontrols-dat) + (dboard:common-set-tabdat! commondat 4 runtimes-dat) + + (iup:vbox + tabs + ;; controls + )))) + (vector keycol lftcol header runsvec))) + +(define (dboard:setup-num-rows tabdat) + (dboard:tabdat-num-tests-set! tabdat (string->number + (or (args:get-arg "-rows") + (get-environment-variable "DASHBOARDROWS") + "15")))) + +(define *tim* (iup:timer)) +(define *ord* #f) +(iup:attribute-set! *tim* "TIME" (or (configf:lookup *configdat* "dashboard" "poll-interval") "1000")) +(iup:attribute-set! *tim* "RUN" "YES") + +(define *last-recalc-ended-time* 0) + +(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))))) + +;; (define *monitor-db-path* #f) +(define *last-monitor-update-time* 0) + +;; Force creation of the db in case it isn't already there. +;; (tasks:open-db) + +(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 ", exn=" exn) + (current-seconds)) ;; something went wrong - just print an error and return current-seconds + (common:max (map (lambda (filen) + (file-modification-time filen)) + (cons (conc dbdir "/main.db") (glob (conc dbdir "/?.db"))))))) + +(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))) + +(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)) + +;; +(define (dashboard:database-changed? commondat tabdat #!key (context-key 'default)) + (let* ((run-update-time (current-seconds)) + (dbdir (conc *toppath* "/.mtdb")) + (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)))) + (if recalc + (dboard:set-last-db-update! tabdat context-key run-update-time)) + (dboard:commondat-please-update-set! commondat #f) + recalc)) + +;; point inside line +;; +(define-inline (dashboard:px-between px lx1 lx2) + (and (< lx1 px)(> lx2 px))) + +;;Not reference anywhere +;; +;; can a bar be placed in row "rownum" covering x1 to x2 without overlapping with existing +;; bars? Use num-rows to check that a block will fit from rownum to (+ rownum num-rows) +;; +(define (dashboard:row-collision rowhash rownum x1 x2 #!key (num-rows #f)) + (let ((lastrow (if num-rows (+ rownum num-rows) rownum))) + (let loop ((i 0) + (rowdat (hash-table-ref/default rowhash rownum '()))) + (if (null? rowdat) + #f + (let rowloop ((bar (car rowdat)) + (tal (cdr rowdat))) + (let ((bx1 (car bar)) + (bx2 (cdr bar))) + (cond + ;; newbar x1 inside bar + ((dashboard:px-between x1 bx1 bx2) #t) + ((dashboard:px-between x2 bx1 bx2) #t) + ((and (<= x1 bx1)(>= x2 bx2)) #t) + (else (if (null? tal) + (if (< i lastrow) + (loop (+ i 1) + (hash-table-ref/default rowhash (+ rownum i) '())) + #f) + (rowloop (car tal)(cdr tal))))))))))) + +(define (dashboard:add-bar rowhash rownum x1 x2 #!key (num-rows 0)) + (let loop ((i 0)) + (hash-table-set! rowhash + (+ i rownum) + (cons (cons x1 x2) + (hash-table-ref/default rowhash (+ i rownum) '()))) + (if (< i num-rows) + (loop (+ i 1))))) + +;; sort a list of test-ids by the event _time using a hash table of id => testdat +;; +(define-inline (dboard:sort-testsdat-by-event-time test-ids tests-ht) + (sort test-ids + (lambda (a b) + (< (db:test-get-event_time (hash-table-ref tests-ht a)) + (db:test-get-event_time (hash-table-ref tests-ht b)))))) + +;; first group items into lists, then sort by time +;; finally sort by first item time +;; +;; NOTE: we are returning lists of lists of ids! +;; +(define (dboard:tests-sort-by-time-group-by-item testsdat) + (let ((test-ids (hash-table-keys testsdat))) + (if (null? test-ids) + test-ids + ;; now group all tests by testname tname => (id1 id2 ...), tname2 => ( ... + (let* ((test-ids-by-name + (let ((ht (make-hash-table))) + (for-each + (lambda (tdat) + (let ((testname (db:test-get-testname tdat)) + (test-id (db:test-get-id tdat))) + (hash-table-set! + ht + testname + (cons test-id (hash-table-ref/default ht testname '()))))) + (hash-table-values testsdat)) + ht))) + ;; remove toplevel tests from iterated tests, sort tests in the list by event time + (for-each + (lambda (testname) + (let ((tests-id-lst (hash-table-ref test-ids-by-name testname))) + (if (> (length tests-id-lst) 1) ;; must be iterated + (let ((item-tests (filter (lambda (tid) ;; filter out toplevel tests + (let ((tdat (hash-table-ref testsdat tid))) + (not (equal? (db:test-get-item-path tdat) "")))) + tests-id-lst))) + (if (not (null? item-tests)) ;; resist bad data, generally should not fail this condition + (hash-table-set! test-ids-by-name + testname + (dboard:sort-testsdat-by-event-time item-tests testsdat))))))) + (hash-table-keys test-ids-by-name)) + ;; finally sort by the event time of the first test + (sort (hash-table-values test-ids-by-name) + (lambda (a b) + (< (db:test-get-event_time (hash-table-ref testsdat (car a))) + (db:test-get-event_time (hash-table-ref testsdat (car b)))))))))) + +;; run times tab data updater +;; +(define (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num) + (let* ((access-mode (dboard:tabdat-access-mode tabdat)) + (last-runs-update (dboard:tabdat-last-runs-update tabdat)) + (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) + (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records + (runs-hash (let ((ht (make-hash-table))) + (for-each (lambda (run) + (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) + (vector-ref runs-dat 1)) + ht)) + (run-ids (sort (filter number? (hash-table-keys runs-hash)) + (lambda (a b) + (let* ((record-a (hash-table-ref runs-hash a)) + (record-b (hash-table-ref runs-hash b)) + (time-a (db:get-value-by-header record-a runs-header "event_time")) + (time-b (db:get-value-by-header record-b runs-header "event_time"))) + (< time-a time-b))))) + (tb (dboard:tabdat-runs-tree tabdat)) + (num-runs (length (hash-table-keys runs-hash))) + (update-start-time (current-seconds)) + (inc-mode #f)) + (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) + ;; fill in the tree + (if (and tb + (not inc-mode)) + (for-each + (lambda (run-id) + (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) + (key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key)) + (dboard:tabdat-keys tabdat))) + (run-name (db:get-value-by-header run-record runs-header "runname")) + (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) + (run-path (append key-vals (list run-name)))) + ;; (existing (tree:find-node tb run-path))) + (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f)) + (begin + (hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path) + ;; Here we update the tests treebox and tree keys + (tree:add-node tb "Runs" run-path) ;; (append key-vals (list run-name)) + ;; userdata: (conc "run-id: " run-id)) + (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id) + ;; (set! colnum (+ colnum 1)) + )))) + run-ids)) + ;; (print "Updating rundat") + (if (dboard:tabdat-keys tabdat) ;; have keys yet? + (let* ((num-keys (length (dboard:tabdat-keys tabdat))) + (targpatt (map (lambda (k v) + (list k v)) + (dboard:tabdat-keys tabdat) + (take (append (or (dboard:tabdat-target tabdat);; (string-split (dboard: "/") + '("%" "%")) + (make-list num-keys "%")) + num-keys) + )) + (runpatt (if (and (dboard:tabdat-target tabdat) + (list? (dboard:tabdat-target tabdat)) + (not (null? (dboard:tabdat-target tabdat)))) + (last (dboard:tabdat-target tabdat)) + "%")) + (testpatt (or (dboard:tabdat-test-patts tabdat) "%")) + (filtrstr (conc targpatt "/" runpatt "/" testpatt))) + ;; (print "targpatt: " targpatt " runpatt: " runpatt " testpatt: " testpatt) + + (if (not (equal? (dboard:tabdat-last-filter-str tabdat) filtrstr)) + (let ((dwg (dboard:tabdat-drawing tabdat))) + (dboard:tabdat-layout-update-ok-set! tabdat #f) + (vg:drawing-libs-set! dwg (make-hash-table)) + (vg:drawing-insts-set! dwg (make-hash-table)) + (vg:drawing-cache-set! dwg '()) + (dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table)) + ;; (dboard:tabdat-allruns-set! tabdat '()) + (dboard:tabdat-max-row-set! tabdat 0) + (dboard:tabdat-last-filter-str-set! tabdat filtrstr))) + (update-rundat tabdat + runpatt + ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") + (dboard:tabdat-numruns tabdat) + testpatt ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") + ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%") + + targpatt + + ;; old method + ;; (let ((res '())) + ;; (for-each (lambda (key) + ;; (if (not (equal? key "runname")) + ;; (let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f))) + ;; (if val (set! res (cons (list key val) res)))))) + ;; (dboard:tabdat-dbkeys tabdat)) + ;; res) + ))))) + +;; run times canvas updater +;; +(define (dashboard:run-times-tab-canvas-updater commondat tabdat tab-num) + (let ((cnv (dboard:tabdat-cnv tabdat)) + (dwg (dboard:tabdat-drawing tabdat)) + (mtx (dboard:tabdat-runs-mutex tabdat)) + (vch (dboard:tabdat-view-changed tabdat))) + (if (and cnv dwg vch) + (begin + (vg:drawing-xoff-set! dwg (dboard:tabdat-xadj tabdat)) + (vg:drawing-yoff-set! dwg (dboard:tabdat-yadj tabdat)) + ;; (mutex-lock! mtx) + (canvas-clear! cnv) + (vg:draw dwg tabdat) + ;; (mutex-unlock! mtx) + (dboard:tabdat-view-changed-set! tabdat #f))))) + +;; doesn't work. +;; +;;(define (gotoescape tabdat escape) +;; (or (dboard:tabdat-layout-update-ok tabdat) +;; (escape #t))) + +(define (dboard:graph-db-open dbstr) + (let* ((parts (string-split dbstr ":")) + (dbpth (if (< (length parts) 2) ;; assume then a filename was provided + dbstr + (if (equal? (car parts) "sqlite3") + (cadr parts) + (begin + (debug:print 0 *default-log-port* "ERROR: I only know sqlite3 databases for now: " dbstr) + #f))))) + (if (and dbpth (file-read-access? dbpth)) + (let ((db (sqlite3:open-database dbpth))) ;; (open-database dbpth))) + (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 10000)) + db) + #f))) + +;; sqlite3:path tablename timefieldname varfieldname field1 field2 ... +;; +(define (dboard:graph-read-data cmdstring tstart tend) + (let* ((parts (string-split cmdstring))) ;; spaces not allowed + (if (< (length parts) 6) ;; sqlite3:path tablename timefieldname varfname valfname field1 field2 ... + (debug:print 0 *default-log-port* "ERROR: malformed graph line: " cmdstring) + (let* ((dbdef (list-ref parts 0)) + (tablen (list-ref parts 1)) + (timef (list-ref parts 2)) + (varfn (list-ref parts 3)) + (valfn (list-ref parts 4)) + (fields (cdr (cddddr parts))) + (db (dboard:graph-db-open dbdef)) + (res-ht (make-hash-table))) + (if db + (begin + (for-each + (lambda (fieldname) ;; fields + (let ((all-dat-qrystr (conc "SELECT " timef "," varfn "," valfn " FROM " tablen " WHERE " varfn "='" fieldname "' AND " timef " >= " tstart " AND " timef " <= " tend " ORDER BY " timef " ASC")) + (zeroth-point (conc "SELECT " timef "," varfn "," valfn " FROM " tablen " WHERE " varfn "='" fieldname "' AND " timef " < " tstart " LIMIT 1"))) + (hash-table-set! res-ht fieldname ;; (fetch-rows (sql db qrystr))))) + (reverse + (sqlite3:fold-row + (lambda (res t var val) + (cons (vector t var val) res)) + '() db all-dat-qrystr))) + (let ((zeropt (handle-exceptions + exn + #f + (sqlite3:first-row db all-dat-qrystr)))) + (if zeropt ;; NOTE: Add zeropt to the beginning of the list as the list was reversed above. + (hash-table-set! res-ht + fieldname + (cons + (apply vector tstart (cdr zeropt)) + (hash-table-ref/default res-ht fieldname '()))))))) + fields) + res-ht) + #f))))) + +;; graph data +;; tsc=timescale, tfn=function; time->x +;; +(define (dboard:graph commondat tabdat tabnum llx lly ulx uly tstart tend tsc tfn compname cmargin) + (let* ((dwg (dboard:tabdat-drawing tabdat)) + (lib (vg:get/create-lib dwg "runslib")) + (cnv (dboard:tabdat-cnv tabdat)) + (dur (- tstart tend)) ;; time duration + (cmp (vg:get-component dwg "runslib" compname)) + (cfg (configf:get-section *configdat* "graph")) + (stdcolor (vg:rgb->number 120 130 140)) + (delta-y (- uly lly)) + (graph-matrix-table (dboard:tabdat-graph-matrix-table tabdat)) + (graph-cell-table (dboard:tabdat-graph-cell-table tabdat)) + (graph-matrix (dboard:tabdat-graph-matrix tabdat)) + (changed #f)) + (vg:add-obj-to-comp + cmp + (vg:make-rect-obj llx lly ulx uly)) + (vg:add-obj-to-comp + cmp + (vg:make-text-obj (- (tfn tstart) 10)(- lly 10)(seconds->year-week/day-time tstart))) + (let*-values (((span timeunit time-blk first timesym) (common:find-start-mark-and-mark-delta tstart tend))) + (let loop ((mark first) + (count 0)) + (let* ((smark (tfn mark)) ;; scale the mark + (mark-delta (quotient (- mark tstart) time-blk)) ;; how far from first mark + (label (conc (* count span) timesym))) ;; was mark-delta + (if (> count 2) + (begin + (vg:add-obj-to-comp + cmp + (vg:make-rect-obj (- smark 1)(- lly 2)(+ smark 1) lly)) + (vg:add-obj-to-comp + cmp + (vg:make-text-obj (- smark 1)(- lly 10) label)))) + (if (< mark (- tend time-blk)) + (loop (+ mark time-blk)(+ count 1)))))) + (for-each + (lambda (cf) + (let* ((alldat (dboard:graph-read-data (cadr cf) tstart tend))) + (if alldat + (for-each + (lambda (fieldn) + (let*-values (((dat) (hash-table-ref alldat fieldn)) + ((vals minval maxval) (if (null? dat) + (values '() #f #f) + (let loop ((hed (car dat)) + (tal (cdr dat)) + (res '()) + (min (vector-ref (car dat) 2)) + (max (vector-ref (car dat) 2))) + (let* ((val (vector-ref hed 2)) + (newmin (if (< val min) val min)) + (newmax (if (> val max) val max)) + (newres (cons val res))) + (if (null? tal) + (values (reverse res) (- newmin 2) (+ newmax 2)) + (loop (car tal)(cdr tal) newres newmin newmax))))))) + (if (not (hash-table-exists? graph-matrix-table fieldn)) + (begin + (let* ((graph-color-rgb (vg:generate-color-rgb)) + (graph-color (vg:iup-color->number graph-color-rgb)) + (graph-matrix-col (dboard:tabdat-graph-matrix-col tabdat)) + (graph-matrix-row (dboard:tabdat-graph-matrix-row tabdat)) + (graph-cell (conc graph-matrix-row ":" graph-matrix-col)) + (graph-dat (make-dboard:graph-dat + id: fieldn + color: graph-color + flag: #t + cell: graph-cell + ))) + (hash-table-set! graph-matrix-table fieldn graph-dat) + (hash-table-set! graph-cell-table graph-cell graph-dat) + ;; (print "Graph data " graph-matrix-row " " graph-matrix-col " " fieldn " " graph-color " " graph-color-rgb " ") + ;; (print "Graph data " graph-matrix-row " " graph-matrix-col " " fieldn " " graph-color " " graph-color-rgb " ") + (set! changed #t) + (iup:attribute-set! graph-matrix (conc graph-matrix-row ":" graph-matrix-col) fieldn) + (iup:attribute-set! graph-matrix (conc "BGCOLOR" (conc graph-matrix-row ":" graph-matrix-col)) graph-color-rgb) + (if (> graph-matrix-col 10) + (begin + (dboard:tabdat-graph-matrix-col-set! tabdat 1) + (dboard:tabdat-graph-matrix-row-set! tabdat (+ graph-matrix-row 1))) + (dboard:tabdat-graph-matrix-col-set! tabdat (+ graph-matrix-col 1))) + ))) + (if (not (null? vals)) + (let* (;; (maxval (apply max vals)) + ;; (minval (min 0 (apply min vals))) + (yoff (- minval lly)) ;; minval)) + (deltaval (- maxval minval)) + (yscale (/ delta-y (if (zero? deltaval) 1 deltaval))) + (yfunc (lambda (y)(+ lly (* yscale (- y minval))))) ;; (lambda (y)(* (+ y yoff) yscale)))) + (graph-dat (hash-table-ref graph-matrix-table fieldn)) + (graph-color (dboard:graph-dat-color graph-dat)) + (graph-flag (dboard:graph-dat-flag graph-dat))) + (if graph-flag + (begin + (vg:add-obj-to-comp + cmp + (vg:make-text-obj (- llx 10)(yfunc maxval) (conc maxval))) + (vg:add-obj-to-comp + cmp + (vg:make-text-obj (- llx 10)(yfunc minval) (conc minval))) + (fold + (lambda (next prev) ;; #(time ? val) #(time ? val) + (if prev + (let* ((yval (vector-ref prev 2)) + (yval-next (vector-ref next 2)) + (last-tval (tfn (vector-ref prev 0))) + (last-yval (yfunc yval)) ;; (+ lly (* yscale (vector-ref prev 2)))) + (next-yval (yfunc yval-next)) + (curr-tval (tfn (vector-ref next 0)))) + (if (>= curr-tval last-tval) + (begin + (vg:add-obj-to-comp + cmp + ;;(vg:make-rect-obj last-tval lly curr-tval last-yval ;; (- stval 2) lly (+ stval 2)(+ lly (* yval yscale)) + (vg:make-line-obj last-tval last-yval curr-tval last-yval + line-color: graph-color)) + (vg:add-obj-to-comp + cmp + ;;(vg:make-rect-obj last-tval lly curr-tval last-yval ;; (- stval 2) lly (+ stval 2)(+ lly (* yval yscale)) + (vg:make-line-obj curr-tval last-yval curr-tval next-yval + line-color: graph-color))) + (debug:print 0 *default-log-port* "ERROR: curr-tval is not > last-tval; curr-tval " curr-tval ", last-tval " last-tval)))) + next) + #f ;; (vector tstart minval minval) + dat) + )))))) ;; for each data point in the series + (hash-table-keys alldat))))) + cfg) + (if changed (iup:attribute-set! graph-matrix "REDRAW" "ALL")))) + +;; run times tab +;; +(define (dashboard:run-times-tab-layout-updater commondat tabdat tab-num) + ;; each test is an object in the run component + ;; each run is a component + ;; all runs stored in runslib library + (let escapeloop ((escape #f)) + (if (and (not escape) + tabdat) + (let* ((canvas-margin 10) + (not-done-runs (dboard:tabdat-not-done-runs tabdat)) + (mtx (dboard:tabdat-runs-mutex tabdat)) + (drawing (dboard:tabdat-drawing tabdat)) + (runslib (vg:get/create-lib drawing "runslib")) ;; creates and adds lib + (allruns (dboard:tabdat-allruns tabdat)) + (num-runs (length allruns)) + (cnv (dboard:tabdat-cnv tabdat)) + (compact-layout (dboard:tabdat-compact-layout tabdat)) + (row-height (if compact-layout 2 10)) + (graph-height 120) + (run-to-run-margin 25)) + (dboard:tabdat-layout-update-ok-set! tabdat #t) + (if (and (canvas? cnv) + (not (null? allruns))) ;; allruns can go null when browsing the runs tree + (let*-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv)) + ((originx originy) (canvas-origin cnv)) + ((calc-y) (lambda (rownum) + (- (/ sizey 2) + (* rownum row-height)))) + ((fixed-originx) (if (dboard:tabdat-originx tabdat) + (dboard:tabdat-originx tabdat) + (begin + (dboard:tabdat-originx-set! tabdat originx) + originx))) + ((fixed-originy) (if (dboard:tabdat-originy tabdat) + (dboard:tabdat-originy tabdat) + (begin + (dboard:tabdat-originy-set! tabdat originy) + originy)))) + ;; (print "allruns: " allruns) + (let runloop ((rundat (car allruns)) + (runtal (cdr allruns)) + (run-num 1) + (doneruns '())) + (let* ((run (dboard:rundat-run rundat)) + (rowhash (make-hash-table)) ;; store me in tabdat + (key-val-dat (dboard:rundat-key-vals rundat)) + (run-id (db:get-value-by-header run (dboard:tabdat-header tabdat) "id")) + (key-vals (append key-val-dat + (list (let ((x (db:get-value-by-header run (dboard:tabdat-header tabdat) "runname"))) + (if x x ""))))) + (run-key (string-intersperse key-vals "\n")) + (run-full-name (string-intersperse key-vals "/")) + (curr-run-start-row (dboard:tabdat-max-row tabdat))) + ;; (print "run: " run-full-name " curr-run-start-row: " curr-run-start-row) + (if (not (vg:lib-get-component runslib run-full-name)) + (let* ((hierdat (if (or (dboard:rundat-data-changed rundat) ;; attempt to not sort when possible. + (not (dboard:rundat-hierdat rundat))) + (let ((hd (dboard:tests-sort-by-time-group-by-item (dboard:rundat-tests rundat)))) ;; hierarchial list of ids + (dboard:rundat-hierdat-set! rundat hd) + hd) + (dboard:rundat-hierdat rundat))) + (tests-ht (dboard:rundat-tests rundat)) + (all-tids (hash-table-keys tests-ht)) ;; (apply append hierdat)) ;; was testsdat + (testsdat (hash-table-values tests-ht)) + (runcomp (vg:comp-new));; new component for this run + (rows-used (make-hash-table)) ;; keep track of what parts of the rows are used here row1 = (obj1 obj2 ...) + ;; (row-height 4) + (run-start (common:min-max < (map db:test-get-event_time testsdat))) + (run-end (let ((re (common:min-max > (map (lambda (t)(+ (db:test-get-event_time t)(db:test-get-run_duration t))) testsdat)))) + (max re (+ 1 run-start)))) ;; use run-start+1 if run-start == run-end so delta is not zero + (timeoffset (- run-start)) ;; (+ fixed-originx canvas-margin) run-start)) + (run-duration (- run-end run-start)) + (timescale (/ (- sizex (* 2 canvas-margin)) + (if (> run-duration 0) + run-duration + (current-seconds)))) ;; a least lously guess + (maptime (lambda (tsecs)(* timescale (+ tsecs timeoffset)))) + (num-tests (length hierdat)) + (tot-tests (length testsdat)) + (width (* timescale run-duration)) + (graph-lly (calc-y (/ -50 row-height))) + (graph-uly (- (calc-y 0) canvas-margin)) + (sec-per-50pt (/ 50 timescale)) + ) + ;; (print "timeoffset: " timeoffset " timescale: " timescale " run-duration: " (seconds->hr-min-sec run-duration) " width: " width " sec-per-50pt: " sec-per-50pt) + ;; (print "timescale: " timescale " timeoffset: " timeoffset " sizex: " sizex " originx: " originx) + ;; (mutex-lock! mtx) + (vg:add-comp-to-lib runslib run-full-name runcomp) + ;; Have to keep moving the instantiated box as it is anchored at the lower left + ;; this should have worked for x in next statement? (maptime run-start) + ;; add 60 to make room for the graph + (vg:instantiate drawing "runslib" run-full-name run-full-name 8 (- (calc-y curr-run-start-row) (+ 5 graph-height run-to-run-margin))) + ;; (mutex-unlock! mtx) + ;; (set! run-start-row (+ max-row 2)) + ;; (dboard:tabdat-start-row-set! tabdat (+ new-run-start-row 1)) + ;; get tests in list sorted by event time ascending + (let testsloop ((test-ids (car hierdat)) ;; loop on tests (NOTE: not items!) + (tests-tal (cdr hierdat)) + (test-num 1)) + (let ((iterated (> (length test-ids) 1)) + (first-rownum #f) + (num-items (length test-ids))) + (let testitemloop ((test-id (car test-ids)) ;; loop on test or test items + (tidstal (cdr test-ids)) + (item-num 1) + (test-objs '())) + (let* ((testdat (hash-table-ref tests-ht test-id)) + (event-time (maptime (db:test-get-event_time testdat))) + (test-duration (* timescale (db:test-get-run_duration testdat))) + (end-time (+ event-time test-duration)) + (test-name (db:test-get-testname testdat)) + (item-path (db:test-get-item-path testdat)) + (state (db:test-get-state testdat)) + (status (db:test-get-status testdat)) + (test-fullname (conc test-name "/" item-path)) + (name-color (gutils:get-color-for-state-status state status)) + (new-test-objs + (let loop ((rownum 0)) ;; new-run-start-row)) ;; (+ start-row 1))) + (if (dashboard:row-collision rowhash rownum event-time end-time) + (loop (+ rownum 1)) + (let* ((title (if iterated (if compact-layout #f item-path) test-name)) + (lly (calc-y rownum)) ;; (- sizey (* rownum row-height))) + (uly (+ lly row-height)) + (use-end (if (< (- end-time event-time) 2)(+ event-time 2) end-time)) ;; if short grow it a little to give the user something to click on + (obj (vg:make-rect-obj event-time lly use-end uly + fill-color: (vg:iup-color->number (car name-color)) + text: title + font: "Helvetica -10")) + (bar-end (max use-end + (+ event-time + (if compact-layout + 1 + (+ 7 (* (string-length title) 10))))))) ;; 8 pixels per letter + ;; (if iterated + ;; (dashboard:add-bar rowhash (- rownum 1) event-time end-time num-rows: (+ 1 num-items)) + ;; (if (not first-rownum) + ;; (begin + ;; (dashboard:row-collision rowhash (- rownum 1) event-time end-time num-rows: num-items) + ;; (set! first-rownum rownum))) + (dboard:tabdat-max-row-set! tabdat (max (+ curr-run-start-row rownum) + (dboard:tabdat-max-row tabdat))) ;; track the max row used + ;; bar-end has some margin for text - accounting for text in extents not yet working. + (dashboard:add-bar rowhash rownum event-time bar-end) ;; (+ end-time 5)) + (vg:add-obj-to-comp runcomp obj) + ;; (vg:instance-move drawing run-full-name 0 (calc-y (dboard:tabdat-max-row tabdat))) + (dboard:tabdat-view-changed-set! tabdat #t) + (cons obj test-objs)))))) + ;; (print "event_time: " (db:test-get-event_time testdat) " mapped event_time: " event-time) + ;; (print "run-duration: " (db:test-get-run_duration testdat) " mapped run_duration: " run-duration) + (if (> item-num 50) + (if (eq? 0 (modulo item-num 50)) + (debug:print 0 *default-log-port* "processing " run-num " of " num-runs " runs " item-num " of " num-items " of test " test-name ", " test-num " of " num-tests " tests"))) + ;; (print "test-name: " test-name " event-time: " event-time " run-duration: " run-duration) + (let ((newdoneruns (cons rundat doneruns))) + (if (null? tidstal) + (if iterated + (let* ((xtents (vg:get-extents-for-objs drawing new-test-objs)) + (llx (- (car xtents) 10)) + (lly (- (cadr xtents) 10)) + (ulx (+ 5 (caddr xtents))) + (uly (+ 10 (cadddr xtents)))) + ;; (dashboard:add-bar rowhash 0 llx ulx num-rows: num-items) + ;; This is the box around the tests of an iterated test + (vg:add-obj-to-comp runcomp (vg:make-rect-obj llx lly ulx uly + text: (db:test-get-testname (hash-table-ref tests-ht (car test-ids))) + line-color: (vg:rgb->number 0 0 255 a: 128) + font: "Helvetica -10")) + ;; (vg:instance-move drawing run-full-name 0 (dboard:tabdat-max-row tabdat)) + (dboard:tabdat-view-changed-set! tabdat #t))) ;; trigger a redraw + (if (dboard:tabdat-layout-update-ok tabdat) + (testitemloop (car tidstal)(cdr tidstal)(+ item-num 1) new-test-objs) + (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat) + ))))) + ;; If it is an iterated test put box around it now. + (if (not (null? tests-tal)) + (if #f ;; (> (- (current-seconds) update-start-time) 5) + (debug:print 0 *default-log-port* "drawing runs taking too long") + (if (dboard:tabdat-layout-update-ok tabdat) + (testsloop (car tests-tal)(cdr tests-tal)(+ test-num 1)) + (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat) + ))))) + ;; placeholder box + (dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat) 1)) + ;; (let ((y (calc-y (dboard:tabdat-max-row tabdat)))) ;; (- sizey (* (dboard:tabdat-max-row tabdat) row-height)))) + ;; (vg:add-obj-to-comp runcomp (vg:make-rect-obj 0 y 0 y))) + ;; instantiate the component + (let* ((extents (vg:components-get-extents drawing runcomp)) + (new-xtnts (apply vg:grow-rect 5 5 extents)) + (llx (list-ref new-xtnts 0)) + (lly (list-ref new-xtnts 1)) + (ulx (list-ref new-xtnts 2)) + (uly (list-ref new-xtnts 3)) + (outln (vg:make-rect-obj -5 lly ulx uly + text: run-full-name + line-color: (vg:rgb->number 255 0 255 a: 128)))) + ; (vg:components-get-extents d1 c1))) + ;; this is the box around the run + ;; (mutex-lock! mtx) + (vg:add-obj-to-comp runcomp outln) + ;; (mutex-unlock! mtx) + ;; this is where we have enough info to place the graph + (dboard:graph commondat tabdat tab-num -5 (+ uly 10) ulx (+ uly graph-height 3) run-start run-end timescale maptime run-full-name canvas-margin) + (dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat)(quotient (+ graph-height 40 3) row-height))) + ;; (vg:instance-move drawing run-full-name 0 (dboard:tabdat-max-row tabdat)) + )) + ;; end of the run handling loop + (if (not (dboard:tabdat-layout-update-ok tabdat)) + (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat) + (let ((newdoneruns (cons rundat doneruns))) + (if (null? runtal) + (begin + (dboard:rundat-data-changed-set! rundat #f) + (dboard:tabdat-not-done-runs-set! tabdat '()) + (dboard:tabdat-done-runs-set! tabdat allruns)) + (if #f ;; (> (- (current-seconds) update-start-time) 5) + (begin + (debug:print 0 *default-log-port* "drawing runs taking too long.... have " (length runtal) " remaining") + ;; (dboard:tabdat-done-runs-set! tabdat newdoneruns) ;; taking too long? stop here! + ;; (time (vg:draw (dboard:tabdat-drawing tabdat) #t)) + (dboard:tabdat-not-done-runs-set! tabdat runtal)) + (begin + (if (dboard:tabdat-layout-update-ok tabdat) + (runloop (car runtal)(cdr runtal) (+ run-num 1) newdoneruns) + (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat) + ))))))))) ;; new-run-start-row + ))) + (debug:print 2 *default-log-port* "no tabdat for run-times-tab-updater")))) + +;; handy trick for printing a record +;; +;; (pp (dboard:tabdat->alist tabdat)) +;; +;; removing the tabdat-values proc +;; +;; (define (tabdat-values tabdat) + +;; runs update-rundat using the various filters from the gui +;; +(define (dashboard:do-update-rundat tabdat) + (dboard:update-rundat + tabdat + (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") + (dboard:tabdat-numruns tabdat) + (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") + ;; generate key patterns from the target stored in tabdat + (let* ((dbkeys (dboard:tabdat-dbkeys tabdat))) + (let ((fres (if (dboard:tabdat-target tabdat) + (let ((ptparts (append (dboard:tabdat-target tabdat)(make-list (length dbkeys) "%")))) + (map (lambda (k v)(list k v)) dbkeys ptparts)) + (let ((res '())) + (for-each (lambda (key) + (if (not (equal? key "runname")) + (let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f))) + (if val (set! res (cons (list key val) res)))))) + dbkeys) + res)))) + fres)))) + +(define (dashboard:runs-tab-updater commondat tab-num) + (debug:catch-and-dump + (lambda () + (let* ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num)) + (dbkeys (dboard:tabdat-dbkeys tabdat))) + (dashboard:do-update-rundat tabdat) + (let ((uidat (dboard:commondat-uidat commondat))) + (update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat))) + )) + "dashboard:runs-tab-updater")) + +;;====================================================================== +;; The heavy lifting starts here +;;====================================================================== + +(stop-the-train) + +(define (dcommon-main) +(define last-copy-time 0) + + +;; Sync to tmp only if in read-only mode. + +(define (sync-db-to-tmp tabdat) + (let* ((db-file "./.mtdb/main.db")) + (if (and (not (file-write-access? db-file)) ( > (current-seconds) (+ last-copy-time 5))) + (begin + (db:multi-db-sync (db:setup) 'old2new) + (set! last-copy-time (current-seconds)) + ) + ) + ) +) + +;; ########################### top level code ######################## +;; check for MT_* environment variables and exit if found +(if (not (args:get-arg "-test")) + (begin + (for-each (lambda (var) + ;; (display " ")(display var) + (if (get-environment-variable var) + (begin + (debug:print 0 *default-log-port* "ERROR: environment variable " var " is set in this terminal, this will cause you problems. Exiting now.") + (exit 1)))) + '("MT_RUN_AREA_HOME" "MT_MEGATEST" "MT_CMDINFO" "MT_TEST_RUN_DIR" "MT_LINKTREE" "MT_TESTSUITENAME")) + ) +) + +;; This is NOT good +;; (setenv "MT_RUN_AREA_HOME" (get-environment-variable "PWD")) +;; This should be OK but it really should not be necessary +(setenv "MT_RUN_AREA_HOME" (current-directory)) + +(if (not (null? remargs)) + (if remargs + (begin + (debug:print 0 *default-log-port* "Unrecognised arguments: " (string-intersperse remargs " ")) + (exit) + ) + (begin + (print help) + (exit) + ) + ) +) + +(if (args:get-arg "-h") + (begin + (print help) + (exit))) + + + + +(if (args:get-arg "-start-dir") + (if (directory-exists? (args:get-arg "-start-dir")) + (let ((fullpath (common:real-path (args:get-arg "-start-dir")))) + (setenv "PWD" fullpath) + (change-directory fullpath)) + (begin + (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.") + (exit 1)))) + + +;; deal with RH 5.11 gtk lib or iup lib missing detachbox feature +;; first check for the switch +;; +(if (or + (configf:lookup *configdat* "dashboard" "no-detachbox") + (not (file-exists? "/etc/os-release"))) + (set! iup:detachbox iup:vbox)) + + + +;; ease debugging by loading ~/.dashboardrc +(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) + (if (common:file-exists? debugcontrolf) + (load debugcontrolf))) +) + +;;====================================================================== +;; 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)) + (cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command"))) + (or cfg-ovrd default-override default-pre-command))) ;; "xterm -geometry 180x20 -e \"")) + + +(define (dtests:get-post-command #!key (default-override #f)) + (let* ((orig-post-command (conc "';xterm -geometry 180x20 -e \"(echo; echo -n START:;date +ww%U.%w-$H:%M:%S;echo;echo $CMD;echo;$CMD)|&" + "tee -a runlog-`date +ww%U.%w-%H:%M`.log;echo Press any key to continue;bash -c 'read -n 1 -s'\" &")) + (viewscreen-post-command "") + (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen")) + (default-post-command (if use-viewscreen viewscreen-post-command orig-post-command)) + (cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command"))) + (or cfg-ovrd default-override default-post-command))) ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) + + +(define (test-info-panel testdat store-label widgets) + (iup:frame + #:title "Test Info" ; #:expand "YES" + (iup:hbox ; #:expand "YES" + (apply iup:vbox ; #:expand "YES" + (append (map (lambda (val) + (iup:label val ; #:expand "HORIZONTAL" + )) + (list "Testname: " + "Item path: " + "Current state: " + "Current status: " + "Test comment: " + "Test id: " + "Test date: ")) + (list (iup:label "" #:expand "VERTICAL")))) + (apply iup:vbox ; #:expand "YES" + (list + (store-label "testname" + (iup:label (db:test-get-testname testdat) #:expand "HORIZONTAL") + (lambda (testdat)(db:test-get-testname testdat))) + (store-label "item-path" + (iup:label (db:test-get-item-path testdat) #:expand "HORIZONTAL") + (lambda (testdat)(db:test-get-item-path testdat))) + (store-label "teststate" + (iup:label (db:test-get-state testdat) #:expand "HORIZONTAL") + (lambda (testdat) + (db:test-get-state testdat))) + (let ((lbl (iup:label (db:test-get-status testdat) #:expand "HORIZONTAL"))) + (hash-table-set! widgets "teststatus" + (lambda (testdat) + (let ((newstatus (db:test-get-status testdat)) + (oldstatus (iup:attribute lbl "TITLE"))) + (if (not (equal? oldstatus newstatus)) + (begin + (iup:attribute-set! lbl "FGCOLOR" (car (gutils:get-color-for-state-status (db:test-get-state testdat) + (db:test-get-status testdat)))) + (iup:attribute-set! lbl "TITLE" (db:test-get-status testdat))))))) + lbl) + (store-label "testcomment" + (iup:label "TestComment " + #:expand "HORIZONTAL") + (lambda (testdat) + (let ((newcomment (db:test-get-comment testdat))) + (if *dashboard-comment-share-slot* + (if (not (equal? (iup:attribute *dashboard-comment-share-slot* "VALUE") + newcomment)) + (iup:attribute-set! *dashboard-comment-share-slot* + "VALUE" + newcomment))) + newcomment))) + (store-label "testid" + (iup:label "TestId " + #:expand "HORIZONTAL") + (lambda (testdat) + (db:test-get-id testdat))) + (store-label "testdate" + (iup:label "TestDate " + #:expand "HORIZONTAL") + (lambda (testdat) + (seconds->work-week/day-time (db:test-get-event_time testdat)))) + ))))) + +;;====================================================================== +;; Test meta panel +;;====================================================================== + +(define (test-meta-panel-get-description testmeta) + (fmt #f (with-width 40 (wrap-lines (db:testmeta-get-description testmeta))))) + +(define (test-meta-panel testmeta store-meta) + (iup:frame + #:title "Test Meta Data" ; #:expand "YES" + (iup:hbox ; #:expand "YES" + (apply iup:vbox ; #:expand "YES" + (append (map (lambda (val) + (iup:label val ; #:expand "HORIZONTAL" + )) + (list "Author: " + "Owner: " + "Reviewed: " + "Tags: " + "Description: ")) + (list (iup:label "" #:expand "VERTICAL")))) + (apply iup:vbox ; #:expand "YES" + (list + (store-meta "author" + (iup:label (db:testmeta-get-author testmeta) #:expand "HORIZONTAL") + (lambda (testmeta)(db:testmeta-get-author testmeta))) + (store-meta "owner" + (iup:label (db:testmeta-get-owner testmeta) #:expand "HORIZONTAL") + (lambda (testmeta)(db:testmeta-get-owner testmeta))) + (store-meta "reviewed" + (iup:label (db:testmeta-get-reviewed testmeta) #:expand "HORIZONTAL") + (lambda (testmeta)(db:testmeta-get-reviewed testmeta))) + (store-meta "tags" + (iup:label (db:testmeta-get-tags testmeta) #:expand "HORIZONTAL") + (lambda (testmeta)(db:testmeta-get-tags testmeta))) + (store-meta "description" + (iup:label (test-meta-panel-get-description testmeta) #:size "x50"); #:expand "HORIZONTAL") + (lambda (testmeta) + (test-meta-panel-get-description testmeta))) + ))))) + + +;;====================================================================== +;; Run info panel +;;====================================================================== +(define (run-info-panel db keydat testdat runname) + (let* ((run-id (db:test-get-run_id testdat)) + (rundat (rmt:get-run-info run-id)) + (header (db:get-header rundat)) + (event_time (db:get-value-by-header (db:get-rows rundat) + (db:get-header rundat) + "event_time"))) + (iup:frame + #:title "Megatest Run Info" ; #:expand "YES" + (iup:hbox ; #:expand "YES" + (apply iup:vbox ; #:expand "YES" + (append (map (lambda (keyval) + (iup:label (conc (car keyval) " "))) + keydat) + (list (iup:label "runname ") + (iup:label "run-id") + (iup:label "run-date")))) + (apply iup:vbox + (append (map (lambda (keyval) + (iup:label (cadr keyval) #:expand "HORIZONTAL")) + keydat) + (list (iup:label runname) + (iup:label (conc run-id)) + (iup:label (seconds->year-work-week/day-time event_time)) + (iup:label "" #:expand "VERTICAL")))))))) + +;;====================================================================== +;; Host info panel +;;====================================================================== +(define (host-info-panel testdat store-label) + (iup:frame + #:title "Remote host and Test Run Info" ; #:expand "YES" + (iup:hbox ; #:expand "YES" + (apply iup:vbox ; #:expand "YES" ;; The heading labels + (append (map (lambda (val) + (iup:label val ; #:expand "HORIZONTAL" + )) + (list "Hostname: " + "Disk free: " + "CPU Load: " + "Run duration: " + "Logfile: " + "Top process id: " + "Uname -a: ")) + (iup:label "" #:expand "VERTICAL"))) + (apply iup:vbox ; #:expand "YES" + (list + ;; NOTE: Yes, the host can change! + (store-label "HostName" + (iup:label ;; (sdb:qry 'getstr + (db:test-get-host testdat) ;; ) + #:expand "HORIZONTAL") + (lambda (testdat)(db:test-get-host testdat))) + (store-label "DiskFree" + (iup:label (conc (db:test-get-diskfree testdat)) #:expand "HORIZONTAL") + (lambda (testdat)(conc (db:test-get-diskfree testdat)))) + (store-label "CPULoad" + (iup:label (conc (db:test-get-cpuload testdat)) #:expand "HORIZONTAL") + (lambda (testdat)(conc (db:test-get-cpuload testdat)))) + (store-label "RunDuration" + (iup:label (conc (seconds->hr-min-sec (db:test-get-run_duration testdat))) #:expand "HORIZONTAL") + (lambda (testdat)(conc (seconds->hr-min-sec (db:test-get-run_duration testdat))))) + (store-label "LogFile" + (iup:label (conc (db:test-get-final_logf testdat)) #:expand "HORIZONTAL") + (lambda (testdat)(conc (db:test-get-final_logf testdat)))) + (store-label "ProcessId" + (iup:label (conc (db:test-get-process_id testdat)) #:expand "HORIZONTAL") + (lambda (testdat)(conc (db:test-get-process_id testdat)))) + (store-label "Uname" + (iup:label " " #:expand "HORIZONTAL") ;; #:wordwrap "YES") + (lambda (testdat) ;; (sdb:qry 'getstr + (db:test-get-uname testdat))) ;; ) + ))))) + +;; if there is a submegatest create a button to launch dashboard in that area +;; +(define (submegatest-panel dbstruct keydat testdat runname testconfig) + (let* ((test-run-dir (db:test-get-rundir testdat)) + (subarea (subrun:get-runarea test-run-dir)) + (area-exists (and subarea (common:file-exists? subarea silent: #t)))) + (if subarea + (iup:frame + #:title "Megatest Run Info" ; #:expand "YES" + (iup:button + "Launch Dashboard" + #:action (lambda (obj) + (subrun:launch-dashboard test-run-dir)))) + (iup:vbox)))) + +;; use a global for setting the buttons colors +;; state status teststeps +(define *state-status* (vector #f #f #f)) +(define (update-state-status-buttons testdat) + (let* ((state (db:test-get-state testdat)) + (status (db:test-get-status testdat)) + (color (car (gutils:get-color-for-state-status state status)))) + ((vector-ref *state-status* 0) state color) + ((vector-ref *state-status* 1) status color))) + +(define *dashboard-test-db* #t) +(define *dashboard-comment-share-slot* #f) + +;;====================================================================== +;; Set fields +;;====================================================================== +(define (set-fields-panel dbstruct run-id test-id testdat #!key (db #f)) + (let ((newcomment #f) + (newstatus #f) + (newstate #f) + (wtxtbox #f)) + (iup:frame + #:title "Set fields" + (iup:vbox + (iup:hbox (iup:label "Comment:") + (let ((txtbox (iup:textbox #:action (lambda (val a b) + ;; (rmt:test-set-state-status-by-id run-id test-id #f #f b) + (rmt:test-set-state-status run-id test-id #f #f b) + ;; IDEA: Just set a variable with the proc to call? + ;; (rmt:test-set-state-status-by-id run-id test-id #f #f b) + (set! newcomment b)) + #:value (db:test-get-comment testdat) + #:expand "HORIZONTAL"))) + (set! wtxtbox txtbox) + txtbox)) + + (apply iup:hbox + (iup:label "STATE:" #:size "30x") + (let* ((btns (map (lambda (state) + (let ((btn (iup:button state + #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" + #:action (lambda (x) + ;; (rmt:test-set-state-status-by-id run-id test-id state #f #f) + (rmt:set-state-status-and-roll-up-items run-id test-id #f state #f #f) ;; test-name passed in as test-id is respected + (db:test-set-state! testdat state))))) + btn)) + (map cadr *common:std-states*)))) ;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ")))) + (vector-set! *state-status* 0 + (lambda (state color) + (for-each + (lambda (btn) + (let* ((name (iup:attribute btn "TITLE")) + (newcolor (if (equal? name state) color "192 192 192"))) + (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR"))) + (iup:attribute-set! btn "BGCOLOR" newcolor)))) + btns))) + btns)) + (apply iup:hbox + (iup:label "STATUS:" #:size "30x") + (let* ((btns (map (lambda (status) + (let ((btn (iup:button status + #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" + #:action (lambda (x) + (let ((t (iup:attribute x "TITLE"))) + (if (equal? t "WAIVED") + (iup:show (dashboard-tests:waiver run-id testdat + (if wtxtbox (iup:attribute wtxtbox "VALUE") #f) + (lambda (c) + (set! newcomment c) + (if wtxtbox + (begin + (iup:attribute-set! wtxtbox "VALUE" c) + (if (not *dashboard-comment-share-slot*) + (set! *dashboard-comment-share-slot* wtxtbox))) + )))) + (begin + ;; (rmt:test-set-state-status-by-id run-id test-id #f status #f) + (rmt:set-state-status-and-roll-up-items run-id test-id #f #f status #f) ;; test-name passed in as test-id is respected + (db:test-set-status! testdat status)))))))) + btn)) + (map cadr *common:std-statuses*)))) ;; (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP")))) + (vector-set! *state-status* 1 + (lambda (status color) + (for-each + (lambda (btn) + (let* ((name (iup:attribute btn "TITLE")) + (newcolor (if (equal? name status) color "192 192 192"))) + (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR"))) + (iup:attribute-set! btn "BGCOLOR" newcolor)))) + btns))) + btns)))))) + +(define (dashboard-tests:run-a-step info) + #t) + +;; (define (dashboard-tests:step-run-control testdat stepname testconfig) +;; (let* ((mutex (make-mutex))) +;; (letrec ((dlg +;; (iup:dialog ;; #:close_cb (lambda (a)(exit)) ; #:expand "YES" +;; #:title stepname +;; (iup:vbox ; #:expand "YES" +;; (iup:label (conc "Step: " stepname "\nNB// These buttons only run the test step\nfor the purpose of debugging.\nNot all database updates are done.")) +;; (iup:button "Re-run" +;; #:expand "HORIZONTAL" +;; #:action (lambda (obj) +;; (debug:catch-and-dump (lambda () +;; (thread-start! +;; (make-thread +;; (lambda () +;; (print "BB> started ezsteps:run-from") +;; (debug:catch-and-dump +;; (lambda () +;; (ezsteps:run-from testdat stepname #t)) +;; "dashboard-tests:step-run-control -> ezstep:run-from (1)") +;; (print "BB> done ezsteps:run-from") +;; 'foo) +;; (conc "ezstep run single step " stepname))) +;; ) +;; "step-run-control action"))) +;; (iup:button "Re-run and continue" +;; #:expand "HORIZONTAL" +;; #:action (lambda (obj) +;; (debug:catch-and-dump +;; (lambda () +;; (thread-start! +;; (make-thread (lambda () +;; (ezsteps:run-from testdat stepname #f)) +;; (conc "ezstep run from step " stepname)))) +;; "dashboard-tests:step-run-control -> ezstep:run-from (2)"))) +;; (iup:button "Close" +;; #:action (lambda (obj) +;; (iup:destroy! dlg))) +;; ;; (iup:button "Refresh test data" +;; ;; #:expand "HORIZONTAL" +;; ;; #:action (lambda (obj) +;; ;; (print "Refresh test data " stepname)) +;; )))) +;; dlg))) + +(define (dashboard-tests:waiver run-id testdat ovrdval cmtcmd) + (let* ((wpatt (configf:lookup *configdat* "setup" "waivercommentpatt")) + (wregx (if (string? wpatt)(regexp wpatt) #f)) + (wmesg (iup:label (if wpatt (conc "Comment must match pattern " wpatt) ""))) + (comnt (iup:textbox #:action (lambda (val a b) + (if wpatt + (if (string-match wregx b) + (iup:attribute-set! wmesg "TITLE" (conc "Comment matches " wpatt)) + (iup:attribute-set! wmesg "TITLE" (conc "Comment does not match " wpatt)) + ))) + #:value (if ovrdval ovrdval (db:test-get-comment testdat)) + #:expand "HORIZONTAL")) + (dlog #f)) + (set! dlog (iup:dialog ;; #:close_cb (lambda (a)(exit)) ; #:expand "YES" + #:title "SET WAIVER" + (iup:vbox ; #:expand "YES" + (iup:label (conc "Enter justification for waiving test " + (db:test-get-testname testdat) + (if (equal? (db:test-get-item-path testdat) "") + "" + (conc "/" (db:test-get-item-path testdat))))) + wmesg ;; the informational msg on whether it matches + comnt + (iup:hbox + (iup:button "Apply and Close " + #:expand "HORIZONTAL" + #:action (lambda (obj) + (let ((comment (iup:attribute comnt "VALUE")) + (test-id (db:test-get-id testdat))) + (if (or (not wpatt) + (string-match wregx comment)) + (begin + ;; (rmt:test-set-state-status-by-id run-id test-id #f "WAIVED" comment) + (rmt:test-set-state-status run-id test-id #f "WAIVED" comment) + (db:test-set-status! testdat "WAIVED") + (cmtcmd comment) + (iup:destroy! dlog)))))) + (iup:button "Cancel" + #:expand "HORIZONTAL" + #:action (lambda (obj) + (iup:destroy! dlog))))))) + dlog)) + + +;;====================================================================== +;; +;;====================================================================== +(define (dashboard-tests:examine-test run-id test-id) ;; run-id run-key origtest) + (let* ((db-path (common:make-tmpdir-name *toppath* "")) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db")) + (dbstruct #f) ;; NOT USED + (testdat (rmt:get-test-info-by-id run-id test-id)) ;; (db:get-test-info-by-id dbstruct run-id test-id)) + (db-mod-time 0) ;; (file-modification-time db-path)) + (last-update 0) ;; (current-seconds)) + (request-update #t)) + (if (not testdat) + (begin + (debug:print 2 *default-log-port* "ERROR: No test data found for test " test-id ", exiting") + (exit 1)) + (let* (;; (run-id (if testdat (db:test-get-run_id testdat) #f)) + (test-registry (tests:get-all)) + (keydat (if testdat (rmt:get-key-val-pairs run-id) #f)) + (rundat (if testdat (rmt:get-run-info run-id) #f)) + (runname (if testdat (db:get-value-by-header (db:get-rows rundat) + (db:get-header rundat) + "runname") #f)) + ;; (tdb (tdb:open-test-db-by-test-id-local dbstruct run-id test-id)) + ;; These next two are intentional bad values to ensure errors if they should not + ;; get filled in properly. + (logfile "/this/dir/better/not/exist") + (rundir (if testdat + (db:test-get-rundir testdat) + logfile)) + ;; (testdat-path (conc rundir "/testdat.db")) ;; this gets recalculated until found + (augment-teststeps (lambda (inlov) + (map + (lambda (invec) + (list->vector + `( + ,@(reverse (cdr (reverse (vector->list invec)))) + "rerun this step" "restart from here" ))) + inlov))) + (teststeps (if testdat (augment-teststeps (tests:get-compressed-steps run-id test-id)) '())) + (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ...")) + (testname (if testdat (db:test-get-testname testdat) "n/a")) + ;; (tests:get-testconfig testdat testname 'return-procs)) + (testmeta (if testdat + (let ((tm (rmt:testmeta-get-record testname))) + (if tm tm (make-db:testmeta))) + (make-db:testmeta))) + + (keystring (string-intersperse + (map (lambda (keyval) + ;; (conc ":" (car keyval) " " (cadr keyval))) + (cadr keyval)) + keydat) + "/")) + (item-path (db:test-get-item-path testdat)) + ;; this next block was added to fix a bug where variables were + ;; needed. Revisit this. + (runconfig (let ((runconfigf (conc *toppath* "/runconfigs.config"))) ;; no rush but it would be good to convert this call to use runconfig:read + (if (common:file-exists? runconfigf) + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "failed to set up environment for " runconfigf ", exn=" exn) + #f) ;; do nothing, just keep on trucking .... + (setup-env-defaults runconfigf run-id (make-hash-table) keydat environ-patt: keystring)) + (make-hash-table)))) + (testconfig (begin + ;; (runs:set-megatest-env-vars run-id inrunname: runname testname: test-name itempath: item-path) + (runs:set-megatest-env-vars run-id inkeyvals: keydat inrunname: runname intarget: keystring testname: testname itempath: item-path) ;; these may be needed by the launching process + (handle-exceptions + exn ;; NOTE: I've no idea why this was written this way. Research, study and fix needed! + (begin + (debug:print 0 *default-log-port* "testconfig load using " item-path " failed, trying " (db:test-get-item-path testdat) ", exn=" exn) + (tests:get-testconfig (db:test-get-testname testdat) (db:test-get-item-path testdat) test-registry #f allow-write-cache: #f)) + (tests:get-testconfig (db:test-get-testname testdat) item-path test-registry #t allow-write-cache: #f)))) + (viewlog (lambda (x) + (if (common:file-exists? logfile) + ;(system (conc "firefox " logfile "&")) + (dcommon:run-html-viewer logfile) + (message-window (conc "File " logfile " not found"))))) + (view-a-log (lambda (lfile) + (let ((lfilename (conc rundir "/" lfile))) + ;; (print "lfilename: " lfilename) + (if (common:file-exists? lfilename) + ;(system (conc "firefox " logfile "&")) + (dcommon:run-html-viewer lfilename) + (message-window (conc "File " lfilename " not found")))))) + (xterm (lambda (x) + (if (directory-exists? rundir) + (let ((shell (if (get-environment-variable "SHELL") + (conc "-e " (get-environment-variable "SHELL")) + ""))) + (common:without-vars + (conc "cd " rundir + ";mt_xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&") + "MT_.*")) + (message-window (conc "Directory " rundir " not found"))))) + (widgets (make-hash-table)) + (refreshdat (lambda () + (let* ((curr-mod-time (file-modification-time db-path)) + ;; (max ..... (if (common:file-exists? testdat-path) + ;; (file-modification-time testdat-path) + ;; (begin + ;; (set! testdat-path (conc rundir "/testdat.db")) + ;; 0)))) + (need-update (or (and (>= curr-mod-time db-mod-time) + (> (current-milliseconds)(+ last-update 250))) ;; every half seconds if db touched + (> (current-milliseconds)(+ last-update 10000)) ;; force update even 10 seconds + request-update)) + (newtestdat (if need-update + ;; NOTE: BUG HIDER, try to eliminate this exception handler + (handle-exceptions + exn + (begin + (debug:print-info 0 *default-log-port* "test db access issue in examine test for run-id " run-id + ", test-id " test-id ": " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) + #f) + (rmt:get-test-info-by-id run-id test-id))))) + ;; (print "INFO: need-update= " need-update " curr-mod-time = " curr-mod-time) + (cond + ((and need-update newtestdat) + (set! testdat newtestdat) + (set! teststeps (augment-teststeps (tests:get-compressed-steps run-id test-id))) + (set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat))) + (set! rundir ;; (filedb:get-path *fdb* + (db:test-get-rundir testdat)) ;; ) + (set! testfullname (db:test-get-fullname testdat)) + ;; (debug:print 0 *default-log-port* "INFO: teststeps=" (intersperse teststeps "\n ")) + + ;; I don't see why this was implemented this way. Please comment it ... + ;; (if (eq? curr-mod-time db-mod-time) ;; do only once if same + ;; (set! db-mod-time (+ curr-mod-time 1)) + ;; (set! db-mod-time curr-mod-time)) + + (if (not (eq? curr-mod-time db-mod-time)) + (set! db-mod-time curr-mod-time)) + (set! last-update (current-milliseconds)) + (set! request-update #f) ;; met the need ... + ) + (need-update ;; if this was true and yet there is no data .... + (db:test-set-testname! testdat "DEAD OR DELETED TEST"))) + (if need-update + (begin + ;; update the gui elements here + (for-each + (lambda (key) + ;; (print "Updating " key) + ((hash-table-ref widgets key) testdat)) + (hash-table-keys widgets)) + (update-state-status-buttons testdat))) + ;; (iup:refresh self) + ))) + (meta-widgets (make-hash-table)) + (self #f) + (store-label (lambda (name lbl cmd) + (hash-table-set! widgets name + (lambda (testdat) + (let ((newval (cmd testdat)) + (oldval (iup:attribute lbl "TITLE"))) + (if (not (equal? newval oldval)) + (begin + ;(mutex-lock! mx1) + (iup:attribute-set! lbl "TITLE" newval) + ;(mutex-unlock! mx1) + ))))) + lbl)) + (store-meta (lambda (name lbl cmd) + (hash-table-set! meta-widgets name + (lambda (testmeta) + (let ((newval (cmd testmeta)) + (oldval (iup:attribute lbl "TITLE"))) + (if (not (equal? newval oldval)) + (begin + ;(mutex-lock! mx1) + (iup:attribute-set! lbl "TITLE" newval) + ;(mutex-unlock! mx1) + ))))) + lbl)) + (store-button store-label) + (command-proc (lambda (command-text-box) + (let* ((cmd (iup:attribute command-text-box "VALUE"))) + (common:run-a-command cmd with-orig-env: #t)))) + (command-text-box (iup:textbox + #:expand "HORIZONTAL" + #:font "Courier New, -10" + #:action (lambda (obj cnum val) + ;; (print "cnum=" cnum) + (if (eq? cnum 13) + (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")) + ;; (fullcmd (conc (dtests:get-pre-command) + ;; cmd + ;; (dtests:get-post-command)))) + ;; (debug:print-info 02 *default-log-port* "Running command: " fullcmd) + ;; (common:without-vars fullcmd "MT_.*"))))) + (kill-jobs (lambda (x) + (iup:attribute-set! + command-text-box "VALUE" + (conc "megatest -target " keystring " -runname " runname + " -set-state-status KILLREQ,n/a -testpatt %/% " + " -state RUNNING,REMOTEHOSTSTART,LAUNCHED")))) + (run-test (lambda (x) + (iup:attribute-set! + command-text-box "VALUE" + (conc "megatest -target " keystring " -runname " runname + " -run -testpatt " (conc testname "/" (if (equal? item-path "") + "%" + item-path)) + " -clean-cache" + )))) + (remove-test (lambda (x) + (iup:attribute-set! + command-text-box "VALUE" + (conc "megatest -remove-runs -target " keystring " -runname " runname + " -testpatt " (conc testname "/" (if (equal? item-path "") + "%" + item-path)) + " -v")))) + (clean-run-execute (lambda (x) + (let ((cmd (conc ;; "megatest -remove-runs -target " keystring " -runname " runname + "megatest -set-state-status NOT_STARTED,n/a -target " keystring " -runname " runname + " -testpatt " (conc testname "/" (if (equal? item-path "") + "%" + item-path)) + ";megatest -target " keystring " -runname " runname + " -run -preclean -testpatt " (conc testname "/" (if (equal? item-path "") + "%" + item-path)) + " -clean-cache" + ))) + (thread-start! (make-thread (lambda () + (common:run-a-command cmd)) + "clean-run-execute"))))) + (remove-test (lambda (x) + (iup:attribute-set! + command-text-box "VALUE" + (conc "megatest -remove-runs -target " keystring " -runname " runname + " -testpatt " (conc testname "/" (if (equal? item-path "") + "%" + item-path)) + " -v")))) + (archive-test (lambda (x) + (iup:attribute-set! + command-text-box "VALUE" + (conc "megatest -target " keystring " -runname " runname + " -archive save-remove -testpatt " (conc testname "/" (if (equal? item-path "") + "%" + item-path)) + ))))) + (cond + ((not testdat)(begin (debug:print 0 *default-log-port* "ERROR: bad test info for " test-id)(exit 1))) + ((not rundat)(begin (debug:print 0 *default-log-port* "ERROR: found test info but there is a problem with the run info for " run-id)(exit 1))) + (else + ;; (test-set-status! db run-id test-name state status itemdat) + (set! self ; + (iup:dialog #:close_cb (lambda (a)(exit)) ; #:expand "YES" + #:title testfullname + (iup:vbox ; #:expand "YES" + ;; The run and test info + (iup:hbox ; #:expand "YES" + (run-info-panel dbstruct keydat testdat runname) + (test-info-panel testdat store-label widgets) + (test-meta-panel testmeta store-meta)) + (iup:hbox + (host-info-panel testdat store-label) + (submegatest-panel dbstruct keydat testdat runname testconfig)) + ;; The controls + (iup:frame #:title "Actions" + (iup:vbox + (iup:hbox + (iup:button "View Log" #:action viewlog #:size "80x") + (iup:button "Start Xterm" #:action xterm #:size "80x") + (iup:button "Run Test" #:action run-test #:size "80x") + (iup:button "Clean Test" #:action remove-test #:size "80x") + (iup:button "CleanRunExecute!" #:action clean-run-execute #:size "80x") + (iup:button "Kill All Jobs" #:action kill-jobs #:size "80x") + (iup:button "Archive Test" #:action archive-test #:size "80x") + (iup:button "Close" #:action (lambda (x)(exit)) #:size "80x")) + (apply + iup:hbox + (list command-text-box command-launch-button)))) + (set-fields-panel dbstruct run-id test-id testdat) + (let ((tabs + (iup:tabs + ;; Replace here with matrix + (let ((steps-matrix (iup:matrix + #:font "Courier New, -8" + #:expand "YES" + #:scrollbar "YES" + #:numcol 9 + #:numlin 100 + #:numcol-visible 9 + #:numlin-visible 5 + #:click-cb (lambda (obj lin col status) + ;; (if (equal? col 6) + (let* ((mtrx-rc (conc lin ":" 6)) + (fname (iup:attribute obj mtrx-rc)) + (stepname (iup:attribute obj (conc lin ":" 1))) (comment (iup:attribute obj (conc lin ":" 7)))) + (case col + + ((7) (debug:print 0 *default-log-port* "Comment from step "stepname": "comment)) + ((8) (ezsteps:spawn-run-from testdat stepname #t)) + ((9) (ezsteps:spawn-run-from testdat stepname #f)) + (else (view-a-log fname)))))))) + ;; (let loop ((count 0)) + ;; (iup:attribute-set! steps-matrix "FITTOTEXT" (conc "L" count)) + ;; (if (< count 30) + ;; (loop (+ count 1)))) + (iup:attribute-set! steps-matrix "0:1" "Step Name") + (iup:attribute-set! steps-matrix "0:2" "Start") + (iup:attribute-set! steps-matrix "0:3" "End") + (iup:attribute-set! steps-matrix "WIDTH3" "50") + (iup:attribute-set! steps-matrix "0:4" "Status") + (iup:attribute-set! steps-matrix "WIDTH4" "50") + (iup:attribute-set! steps-matrix "0:5" "Duration") + (iup:attribute-set! steps-matrix "0:6" "Log File") + (iup:attribute-set! steps-matrix "0:7" "Comment") + (iup:attribute-set! steps-matrix "0:8" "rerun only") + (iup:attribute-set! steps-matrix "BGCOLOR0:9" "149 208 252") + (iup:attribute-set! steps-matrix "BGCOLOR0:8" "149 208 252") + (iup:attribute-set! steps-matrix "BGCOLOR0:7" "149 208 252") + (iup:attribute-set! steps-matrix "0:9" "rerun & continue") + (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT") + ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1") + (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES") + (let ((proc + (lambda (testdat) + (dcommon:populate-steps teststeps steps-matrix run-id test-id)))) + (hash-table-set! widgets "StepsMatrix" proc) + (proc testdat)) + steps-matrix) + ;; populate the Test Data panel + (iup:frame + #:title "Test Data" + (let ((test-data + (iup:textbox ;; #:action (lambda (obj char val) + ;; #f) + #:expand "YES" + #:multiline "YES" + #:font "Courier New, -10" + #:size "100x100"))) + (hash-table-set! widgets "Test Data" + (lambda (testdat) ;; + (let* ((currval (iup:attribute test-data "VALUE")) ;; "TITLE")) + (fmtstr "~10a~10a~10a~10a~7a~7a~6a~7a~a") ;; category,variable,value,expected,tol,units,type,comment + (newval (string-intersperse + (append + (list + (format #f fmtstr "Category" "Variable" "Value" "Expected" "Tol" "Status" "Units" "Type" "Comment") + (format #f fmtstr "========" "========" "=====" "========" "===" "======" "=====" "====" "=======")) + (map (lambda (x) + (format #f fmtstr + (db:test-data-get-category x) + (db:test-data-get-variable x) + (db:test-data-get-value x) + (db:test-data-get-expected x) + (db:test-data-get-tol x) + (db:test-data-get-status x) + (db:test-data-get-units x) + (db:test-data-get-type x) + (db:test-data-get-comment x))) + (rmt:read-test-data run-id test-id "%"))) + "\n"))) + (if (not (equal? currval newval)) + (iup:attribute-set! test-data "VALUE" newval ))))) ;; "TITLE" newval))))) + test-data)) + ;;(dashboard:run-controls) + ))) + (iup:attribute-set! tabs "TABTITLE0" "Steps") + (iup:attribute-set! tabs "TABTITLE1" "Test Data") + tabs)))) + (iup:show self) + (iup:callback-set! *tim* "ACTION_CB" + (lambda (x) + ;; 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)))) + +(define (common:run-a-command cmd #!key (with-vars #f) (with-orig-env #f)) + (let* ((pre-cmd (dtests:get-pre-command)) + (post-cmd (dtests:get-post-command)) + (fullcmd (if (or pre-cmd post-cmd) + (conc pre-cmd cmd post-cmd) + (conc "viewscreen " cmd)))) + (debug:print-info 02 *default-log-port* "Running command: " fullcmd) + (cond + (with-vars (common:without-vars fullcmd)) + (with-orig-env (common:with-orig-env fullcmd)) + (else (common:without-vars fullcmd "MT_.*"))))) + +(define (main) + ;; (print "Starting dashboard main") + + (let* ((mtdb-path (conc *toppath* "/.mtdb/main.db")) + (target (args:get-arg "-target")) + (commondat (dboard:commondat-make))) + (if target + (begin + (args:remove-arg-from-ht "-target") + (dboard:commondat-target-set! commondat target) + ) + ) + + (if (not (launch:setup)) + (begin + (debug:print 0 *default-log-port* "Failed to find megatest.config, exiting") + (exit 1) + ) + ) + + #;(if (not (rmt:on-homehost?)) + (begin + (debug:print 0 *default-log-port* "WARNING: You are starting the dashboard on a machine that is not the homehost:" (server:get-homehost)) + (debug:print 0 *default-log-port* "It will be slower.") + )) + + + (if (and (common:file-exists? mtdb-path) + (file-write-access? mtdb-path)) + (if (not (args:get-arg "-skip-version-check")) + (common:exit-on-version-changed))) + + (let* () + ;; Move this stuff to db.scm? I'm not sure that is the right thing to do... + (cond + ((args:get-arg "-test") ;; run-id,test-id + (let* ((dat (let ((d (map string->number (string-split (args:get-arg "-test") ",")))) + (if (> (length d) 1) + d + (list #f #f)))) + (run-id (car dat)) + (test-id (cadr dat))) + (if (and (number? run-id) + (number? test-id) + (>= test-id 0)) + (dashboard-tests:examine-test run-id test-id) + (begin + (debug:print 3 *default-log-port* "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test")) + (exit 1))))) + (else + (dboard:commondat-uidat-set! commondat (make-dashboard-buttons commondat)) + (dboard:commondat-curr-tab-num-set! commondat 0) + (dboard:commondat-add-updater + commondat + (lambda () + (dashboard:runs-tab-updater commondat 0)) + tab-num: 0) + ;; may not want this alive (manually merged it from v1.66) + ;; (dboard:commondat-add-updater + ;; commondat + ;; (lambda () + ;; (dashboard:runs-tab-updater commondat 1)) + ;; tab-num: 2) + (iup:callback-set! *tim* + "ACTION_CB" + (lambda (time-obj) + (let ((update-is-running #f)) + ;; (mutex-lock! (dboard:commondat-update-mutex commondat)) + (set! update-is-running (dboard:commondat-updating commondat)) + (if (not update-is-running) + (dboard:commondat-updating-set! commondat #t)) + ;; (mutex-unlock! (dboard:commondat-update-mutex commondat)) + (if (not update-is-running) ;; we know that the update was not running and we now have a lock on doing an update + (begin + (dboard:common-run-curr-updaters commondat) ;; (dashboard:run-update commondat) + ;; (mutex-lock! (dboard:commondat-update-mutex commondat)) + (dboard:commondat-updating-set! commondat #f) + ;; (mutex-unlock! (dboard:commondat-update-mutex commondat)) + ))) + 1)))) + ;; (debug:print 0 *default-log-port* "Starting updaters") + (let ((th1 (make-thread (lambda () + (thread-sleep! 1) + (dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab + ) "update buttons once")) + (th2 (make-thread iup:main-loop "Main loop"))) + ;; (print "Starting main loop") + (thread-start! th2) + (thread-join! th2) + ) + ) + ) +) + +;;====================================================================== +;; T R E E S T U F F +;;====================================================================== + +;; path is a list of nodes, each the child of the previous +;; this routine returns the id so another node can be added +;; either as a leaf or as a branch +;; +;; BUG: This needs a stop sensor for when a branch is exhausted +;; +(define (tree:find-node obj path) + ;; start at the base of the tree + (if (null? path) + #f ;; or 0 ???? + (let loop ((hed (car path)) + (tal (cdr path)) + (depth 0) + (nodenum 0)) + ;; nodes in iup tree are 100% sequential so iterate over nodenum + (if (iup:attribute obj (conc "DEPTH" nodenum)) ;; end when no more nodes + (let ((node-depth (string->number (iup:attribute obj (conc "DEPTH" nodenum)))) + (node-title (iup:attribute obj (conc "TITLE" nodenum)))) + (if (and (equal? depth node-depth) + (equal? hed node-title)) ;; yep, this is the one! + (if (null? tal) ;; end of the line + nodenum + (loop (car tal)(cdr tal)(+ depth 1)(+ 1 nodenum))) + ;; this is the case where we found part of the hierarchy but not + ;; all of it, i.e. the node-depth went from deep to less deep + (if (> depth node-depth) ;; (+ 1 node-depth)) + #f + (loop hed tal depth (+ nodenum 1))))) + #f)))) + +;; top is the top node name zeroeth node VALUE=0 +(define (tree:add-node obj top nodelst #!key (userdata #f)) + (let ((curr-top (iup:attribute obj "TITLE0"))) + (if (or (not (string? curr-top)) + (string-null? curr-top) + (string-match "^\\s*$" curr-top)) + (iup:attribute-set! obj "ADDBRANCH0" top)) + + + + (cond + ((not (equal? top (iup:attribute obj "TITLE0"))) + (debug:print 0 *default-log-port* "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0"))) + ((null? nodelst)) + (else + (let loop ((hed (car nodelst)) + (tal (cdr nodelst)) + (depth 1) + (pathl (list top))) + ;; Because the tree dialog changes node numbers when + ;; nodes are added or removed we must look up nodes + ;; each and every time. 0 is the top node so default + ;; to that. + (let* ((newpath (append pathl (list hed))) + (parentnode (tree:find-node obj pathl)) + (nodenum (tree:find-node obj newpath))) + ;; Add the branch under lastnode if not found + (if (not nodenum) + (begin + (iup:attribute-set! obj (conc "ADDBRANCH" parentnode) hed) + ;; ERROR? ADDING DATA TO PARENT, DONT WE WANT IT ON CREATED NODE? + (if userdata + (iup:attribute-set! obj (conc "USERDATA" parentnode) userdata)) + (if (null? tal) + #t + ;; reset to top + (loop (car nodelst)(cdr nodelst) 1 (list top)))) + (if (null? tal) ;; if null here then this path has already been added + #t + (loop (car tal)(cdr tal)(+ depth 1) newpath))))))))) + +(define (tree:node->path obj nodenum) + (let loop ((currnode 0) + (path '())) + (let* ((node-depth (string->number (iup:attribute obj (conc "DEPTH" currnode)))) + (node-title (iup:attribute obj (conc "TITLE" currnode))) + (trimpath (if (and (not (null? path)) + (> (length path) node-depth)) + (take path node-depth) + path)) + (newpath (append trimpath (list node-title)))) + (if (>= currnode nodenum) + newpath + (loop (+ currnode 1) + newpath))))) + +(define (tree:delete-node obj top node-path) ;; node-path is a list of strings + (let ((id (tree:find-node obj (cons top node-path)))) + (debug:print 0 *default-log-port* "Found node to remove " id " for path " top " " node-path) + (iup:attribute-set! obj (conc "DELNODE" id) "SELECTED"))) + +#| + + (let* ((tb (iup:treebox + #:value 0 + #:name "Runs" + #:expand "YES" + #:addexpanded "NO" + #:selection-cb + (lambda (obj id state) + ;; (print "obj: " obj ", id: " id ", state: " state) + (let* ((run-path (tree:node->path obj id)) + (run-id (tree-path->run-id (cdr run-path)))) + (if run-id + (begin + (dboard:data-curr-run-id-set! data run-id) + (dashboard:update-run-summary-tab))) + ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) + )))) +|# + +;;====================================================================== +;; gutils +;; +;; NOTE: These functions will move to iuputils +;;====================================================================== + +(define (gutils: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)))) + +(define gutils:colors + '((PASS . "70 249 73") + (FAIL . "253 33 49") + (SKIP . "230 230 0"))) + +(define (gutils:get-color-spec effective-state) + (or (alist-ref effective-state gutils:colors) + (alist-ref 'FAIL gutils:colors))) + +;; BBnote - state status dashboard button color / text defined here +(define (gutils:get-color-for-state-status state status);; #!key (get-label #f)) + ;; ((if get-label cadr car) + (case (string->symbol state) + ((COMPLETED) ;; ARCHIVED) + (case (string->symbol status) + ((PASS) (list "70 249 73" status)) + ((PREQ_FAIL PREQ_DISCARDED) (list "255 127 127" status)) + ((WARN WAIVED) (list "255 172 13" status)) + ((SKIP) (list (gutils:get-color-spec 'SKIP) status)) + ((ABORT) (list "198 36 166" status)) + (else (list "253 33 49" status)))) + ((ARCHIVED) + (case (string->symbol status) + ((PASS) (list "70 170 73" status)) + ((WARN WAIVED) (list "200 130 13" status)) + ((SKIP) (list (gutils:get-color-spec 'SKIP) status)) + (else (list "180 33 49" status)))) + ;; (if (equal? status "PASS") + ;; '("70 249 73" "PASS") + ;; (if (or (equal? status "WARN") + ;; (equal? status "WAIVED")) + ;; (list "255 172 13" status) + ;; (list "223 33 49" status)))) ;; greenish orangeish redish + ((LAUNCHED) (list "101 123 142" state)) + ((CHECK) (list "255 100 50" state)) + ((REMOTEHOSTSTART) (list "50 130 195" state)) + ((RUNNING STARTED) (list "9 131 232" state)) + ((KILLREQ) (list "39 82 206" state)) + ((KILLED) (list "234 101 17" state)) + ((NOT_STARTED) (case (string->symbol status) + ((CHECK STARTED)(list (gutils:get-color-spec 'SKIP) state)) + (else (list "240 240 240" state)))) + ;; for xor mode below + ;; + ((CLEAN) + (case (string->symbol status) + ((CLEAN-FAIL CLEAN-CHECK CLEAN-ABORT) (list "200 130 13" status)) ;; orange requested for these + (else (list "60 235 63" status)))) + ((DIRTY-BETTER) (list "160 255 153" status)) + ((DIRTY-WORSE) (list "165 42 42" status)) + ((BOTH-BAD) (list "180 33 49" status)) + + (else (list + ;; "192 192 192" + "222 222 221" + state)))) + +;;====================================================================== +;; implementation of context menu that pops up on +;; right click on test cell in Runs & Runs Summary Tabs +;;====================================================================== + +(define (dboard:launch-testpanel run-id test-id) + (let* ((dboardexe (common:find-local-megatest "dashboard")) + (cmd (conc dboardexe + " -test " run-id "," test-id + " &"))) + (system cmd))) + + +(define (dashboard:run-menu-items run-id test-id target runname test-name testpatt item-test-path test-info) + (list + (iup:menu-item + (conc "Rerun " testpatt) + #:action + (lambda (obj) + ;; (print " run-id: " run-id " test-id: " test-id " target: " target " runname: " runname " test-name: " test-name " testpatt: " testpatt "item-path : " item-path) + (common:run-a-command + (conc "megatest -run -target " target + " -runname " runname + " -testpatt " testpatt + " -preclean -clean-cache") + ))) + (iup:menu-item + "Rerun Complete Run" + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target + " -runname " runname + " -testpatt % " + " -preclean -clean-cache")))) + (iup:menu-item + "Clean Complete Run" + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -remove-runs -target " target + " -runname " runname + " -testpatt % ")))) + (iup:menu-item + "Kill Complete Run" + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -set-state-status KILLREQ,n/a -target " target + " -runname " runname + " -testpatt % " + " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED")))) + (iup:menu-item + "Delete Run Data" + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -remove-runs -target " target + " -runname " runname + " -testpatt % " + " -keep-records")))))) + +(define (dashboard:test-menu-items run-id test-id target runname test-name testpatt item-test-path test-info) + (list + (iup:menu-item + (conc "Rerun " item-test-path) + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target + " -runname " runname + " -testpatt " item-test-path + " -preclean -clean-cache")))) + (iup:menu-item + (conc "Kill " item-test-path) + #:action + (lambda (obj) + ;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f) + (common:run-a-command + (conc "megatest -set-state-status KILLREQ,n/a -target " target + " -runname " runname + " -testpatt " item-test-path + " -state RUNNING,REMOTEHOSTSTART,LAUNCHED")))) + (iup:menu-item + (conc "Delete data : " item-test-path) + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -remove-runs -target " target + " -runname " runname + " -testpatt " item-test-path + " -keep-records")))) + (iup:menu-item + (conc "Clean "item-test-path) + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -remove-runs -target " target + " -runname " runname + " -testpatt " item-test-path)))) + (iup:menu-item + "Start xterm" + #:action + (lambda (obj) + (dcommon:examine-xterm run-id test-id))) + ;;(let* ((cmd (conc (car (argv)) " -xterm " run-id "," test-id "&"))) + ;; (system cmd)))) + (iup:menu-item + "Edit testconfig" + #:action + (lambda (obj) + (let* ((all-tests (tests:get-all)) + (editor-rx (or (configf:lookup *configdat* "setup" "editor-regex") + "\\b(vim?|nano|pico)\\b")) + (editor (or (configf:lookup *configdat* "setup" "editor") + (get-environment-variable "VISUAL") + (get-environment-variable "EDITOR") "vi")) + (tconfig (conc (hash-table-ref all-tests test-name) "/testconfig")) + (cmd (conc (if (string-search editor-rx editor) + (conc "xterm -e " editor) + editor) + " " tconfig " &"))) + (system cmd)))))) + +(define (dashboard:step-logs-menu-item run-id test-id target runname test-name testpatt item-test-path test-info) + (let* ((steps (tests:get-compressed-steps run-id test-id)) ;; # + (rundir (db:test-get-rundir test-info))) + + (iup:menu-item + "Step logs" + (apply iup:menu + (map (lambda (step) + (let ((stepname (vector-ref step 0)) + (logfile (vector-ref step 5)) + (status (vector-ref step 3))) + (iup:menu-item + (conc stepname "/" (if (string=? logfile "") "no log!" logfile) " (" status ")") + #:action (lambda (obj) + (let ((fullfile (conc rundir "/" logfile))) + (if (common:file-exists? fullfile) + (dcommon:run-html-viewer fullfile) + (message-window (conc "file " fullfile " not found")))))))) + steps))))) + +(define (dashboard:toplevel-menu-items run-id test-id target runname test-name testpatt item-test-path test-info) + (list + + (iup:menu-item + "Test Control Panel" + #:action + (lambda (obj) + (dboard:launch-testpanel run-id test-id))) + + (dashboard:step-logs-menu-item run-id test-id target runname test-name testpatt item-test-path test-info) + + (iup:menu-item + (conc "Rerun " item-test-path) + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target + " -runname " runname + " -testpatt " item-test-path + " -preclean -clean-cache")))) + + (iup:menu-item + "Start xterm" + #:action + (lambda (obj) + (dcommon:examine-xterm run-id test-id))) + + (iup:menu-item + (conc "Kill " item-test-path) + #:action + (lambda (obj) + ;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f) + (common:run-a-command + (conc "megatest -set-state-status KILLREQ,n/a -target " target + " -runname " runname + " -testpatt " item-test-path + " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED")))) + + (let* ((rundir (db:test-get-rundir test-info)) + (has-subrun (subrun:subrun-test-initialized? rundir))) + (if has-subrun + (iup:menu-item + "Launch subrun dashboard" + #:action + (lambda (obj) + (subrun:launch-dashboard rundir))) + (iup:vbox))) + + (iup:menu-item + (conc "View Log " item-test-path) + #:action + (lambda (obj) + (let* ((rundir (db:test-get-rundir test-info)) + (logf (db:test-get-final_logf test-info)) + (fullfile (conc rundir "/" logf))) + (if (common:file-exists? fullfile) + (dcommon:run-html-viewer fullfile) + (message-window (conc "file " fullfile " not found."))))) + ) + )) +;; example section for megatest.config: +;; +;; +;; [custom-context-menu-items] +;; # : +;; item1 custom show run-id (%run-id%):echo "%run-id%" +;; item2 custom show test-id (%test-id%):echo "%test-id%" +;; item3 custom show target (%target%):echo "%target%" +;; item4 custom show test-name (%test-name%):echo "%test-name%" +;; item5 custom show test-patt (%test-patt%):echo "%test-patt%" +;; item6 custom show test-run-dir (%test-run-dir%):echo "%test-run-dir%" +;; item7 custom show run-area-home (%run-area-home%):echo "%run-area-home%" +;; item8 custom show megatest root (%mt-root%):echo "%mt-root%" +;; item9 custom ls : ls -lrt +;; item10 custom see $MT_RUN_AREA_HOME (not yet implemented) : echo $MT_RUN_AREA_HOME + +(define (dashboard:custom-menu-items run-id test-id target run-name test-name testpatt item-test-path test-info) + (let* ((vars (configf:section-vars *configdat* "custom-context-menu-items")) + (item-path (db:test-get-item-path test-info)) + (mt-root (pathname-directory (pathname-directory *common:this-exe-dir* )))) + (filter-map + (lambda (var) + (let* ((val (configf:lookup *configdat* "custom-context-menu-items" var)) + (m (string-match "^\\s*([^:]+?)\\s*:\\s*(.*?)\\s*$" val))) + (if m + (let* ((menu-item-text-raw (list-ref m 1)) + (command-line-raw (list-ref m 2)) + (subst-alist ;; template vars + `(( "%run-id%" . ,run-id ) + ( "%test-id%" . ,test-id ) + ( "%target%" . ,target ) + ( "%test-name%" . ,test-name) + ( "%test-patt%" . ,testpatt) + ( "%test-run-dir%" . ,(db:test-get-rundir test-info)) + ( "%mt-root%" . ,mt-root) + ( "%run-name%" . ,run-name) + ( "%run-area-home%" . ,*toppath*) + ( "%item-path%" . ,item-path) + ( "%item-test-patt%" . ,item-test-path ))) + (command-line ;; replace template vars + (foldr + (lambda (x i) + (string-substitute + (car x) + (->string (cdr x)) + i + #t)) + command-line-raw + subst-alist)) + (menu-item-text ;; replace template vars + (foldr + (lambda (x i) + (string-substitute + (car x) + (->string (cdr x)) + i + #t)) + menu-item-text-raw + subst-alist))) + (iup:menu-item + (conc "*"menu-item-text) + #:action + (lambda (obj) + + (let* ((scheme-match (string-match "^#(\\(.*)" command-line))) + ;;(BB> "cmdline is >"command-line"<") + (common:with-env-vars + ;; TODO: with-env-vars + ;; TODO: with-env-vars MT_* + (runs:get-mt-env-alist run-id run-name target test-name item-path) + + (lambda () + (if scheme-match + (begin + (handle-exceptions + exn + (debug:print 0 *default-log-port* "error with custom menu scheme, exn=" exn) + (begin + ;;(BB> "gonna eval it!") + (eval (with-input-from-string (cadr scheme-match) read))))) + (common:run-a-command command-line with-vars: #t)))))))) + #f))) + vars))) + +(define (dashboard:context-menu run-id test-id target runname test-name testpatt item-test-path test-info) + (let* ((run-menu-items + (dashboard:run-menu-items run-id test-id target runname test-name testpatt item-test-path test-info)) + (test-menu-items + (dashboard:test-menu-items run-id test-id target runname test-name testpatt item-test-path test-info)) + (custom-menu-items + (dashboard:custom-menu-items run-id test-id target runname test-name testpatt item-test-path test-info)) + (toplevel-menu-items + (dashboard:toplevel-menu-items run-id test-id target runname test-name testpatt item-test-path test-info)) + ) + (apply iup:menu + `(,@toplevel-menu-items + ,(iup:menu-item + "Run" + (apply iup:menu run-menu-items)) + ,(iup:menu-item + "Test" + (apply iup:menu test-menu-items)) + ,@custom-menu-items)))) + + +) Index: diff-report.scm ================================================================== --- diff-report.scm +++ diff-report.scm @@ -15,19 +15,34 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; (declare (unit diff-report)) -(declare (uses common)) +;; (declare (uses common)) (declare (uses debugprint)) (declare (uses rmtmod)) (declare (uses commonmod)) -(import commonmod +(declare (uses stml2)) + +(module diff-report + * +(import scheme + chicken + posix + debugprint + ports + srfi-1 + srfi-13 + srfi-69 + data-structures + + stml2 + commonmod rmtmod - debugprint) + ) -(include "common_records.scm") +;; (include "common_records.scm") (use matchable) (use fmt) (use ducttape-lib) (define css "") @@ -414,5 +429,6 @@ #f) (else (diff:deliver-diff-report src-run-id dest-run-id email-recipients-list: to-list html-output-file: html-file))))) +) Index: env.scm ================================================================== --- env.scm +++ env.scm @@ -21,238 +21,239 @@ (declare (unit env)) (declare (uses debugprint)) (declare (uses mtargs)) -(import (prefix mtargs args:) - debugprint) - -(use sql-de-lite) ;; srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables) - -(define (env:open-db fname) - (let* ((db-exists (common:file-exists? fname)) - (db (open-database fname))) - (if (not db-exists) - (begin - (exec (sql db "CREATE TABLE envvars ( - id INTEGER PRIMARY KEY, - context TEXT NOT NULL, - var TEXT NOT NULL, - val TEXT NOT NULL, - CONSTRAINT envvars_constraint UNIQUE (context,var))")))) - (set-busy-handler! db (busy-timeout 10000)) - db)) - -;; save vars in given context, this is NOT incremental by default -;; -(define (env:save-env-vars db context #!key (incremental #f)(vardat #f)) - (with-transaction - db - (lambda () - ;; first clear out any vars for this context - (if (not incremental)(exec (sql db "DELETE FROM envvars WHERE context=?") context)) - (for-each - (lambda (varval) - (let ((var (car varval)) - (val (cdr varval))) - (if incremental (exec (sql db "DELETE FROM envvars WHERE context=? AND var=?") context var)) - (exec (sql db "INSERT INTO envvars (context,var,val) VALUES (?,?,?)") context var val))) - (if vardat - (hash-table->alist vardat) - (get-environment-variables)))))) - -;; merge contexts in the order given -;; - each context is applied in the given order -;; - variables in the paths list are split on the separator and the components -;; merged using simple delta addition -;; returns a hash of the merged vars -;; -(define (env:merge-contexts db basecontext contexts paths) - (let ((result (make-hash-table))) - (for-each - (lambda (context) - (query - (for-each-row - (lambda (row) - (let ((var (car row)) - (val (cadr row))) - (hash-table-set! result var - (if (and (hash-table-ref/default result var #f) - (assoc var paths)) ;; this var is a path and there is a previous path - (let ((sep (cadr (assoc var paths)))) - (env:merge-path-envvar sep (hash-table-ref result var) val)) - val))))) - (sql db "SELECT var,val FROM envvars WHERE context=?") - context)) - contexts) - result)) - -;; get list of removed variables between two contexts -;; -(define (env:get-removed db contexta contextb) - (let ((result (make-hash-table))) - (query - (for-each-row - (lambda (row) - (let ((var (car row)) - (val (cadr row))) - (hash-table-set! result var val)))) - (sql db "SELECT var,val FROM envvars WHERE context=? AND var NOT IN (SELECT var FROM envvars WHERE context=?)") - contexta contextb) - result)) - -;; get list of variables added to contextb from contexta -;; -(define (env:get-added db contexta contextb) - (let ((result (make-hash-table))) - (query - (for-each-row - (lambda (row) - (let ((var (car row)) - (val (cadr row))) - (hash-table-set! result var val)))) - (sql db "SELECT var,val FROM envvars WHERE context=? AND var NOT IN (SELECT var FROM envvars WHERE context=?)") - contextb contexta) - result)) - -;; get list of variables in both contexta and contexb that have been changed -;; -(define (env:get-changed db contexta contextb) - (let ((result (make-hash-table))) - (query - (for-each-row - (lambda (row) - (let ((var (car row)) - (val (cadr row))) - (hash-table-set! result var val)))) - (sql db "SELECT var,val FROM envvars AS a WHERE context=? AND val != (SELECT val FROM envvars WHERE var=a.var AND context=?)") - contextb contexta) - result)) - -;; -(define (env:blind-merge l1 l2) - (if (null? l1) l2 - (if (null? l2) l1 - (cons (car l1) (cons (car l2) (env:blind-merge (cdr l1) (cdr l2))))))) - -;; given a before and an after envvar calculate a new merged path -;; -(define (env:merge-path-envvar separator patha pathb) - (let* ((patha-parts (string-split patha separator)) - (pathb-parts (string-split pathb separator)) - (common-parts (lset-intersection equal? patha-parts pathb-parts)) - (final (delete-duplicates ;; env:blind-merge - (append pathb-parts common-parts patha-parts)))) -;; (print "BEFORE: " (string-intersperse patha-parts "\n ")) -;; (print "AFTER: " (string-intersperse pathb-parts "\n ")) -;; (print "COMMON: " (string-intersperse common-parts "\n ")) - (string-intersperse final separator))) - -(define (env:process-path-envvar varname separator patha pathb) - (let ((newpath (env:merge-path-envvar separator patha pathb))) - (setenv varname newpath))) - -(define (env:have-context db context) - (> (query fetch-value (sql db "SELECT count(id) FROM envvars WHERE context=?") context) - 0)) - -;; this is so the calling block does not need to import sql-de-lite -(define (env:close-database db) - (close-database db)) - -(define (env:lazy-hash-table->alist indat) - (if (hash-table? indat) - (let ((dat (hash-table->alist indat))) - (if (null? dat) - #f - dat)) - #f)) - -(define (env:inc-path path) - (print "PATH " - (conc "#{scheme (env:min-path \"" path "\" \"#{getenv PATH}\")}"))) -;; (conc -;; "#{scheme (string-intersperse " -;; "(delete-duplicates " -;; "(append (string-split \"" path "\" \":\") " -;; "(string-split \"#{getenv PATH}\" \":\")))" -;; " \":\")}"))) - -(define (env:min-path path1 path2) - (string-intersperse - (delete-duplicates - (append - (string-split path1 ":") - (string-split path2 ":"))) - ":")) - -;; inc path will set a PATH that is incrementally modified when read - config mode only -;; -(define (env:print added removed changed #!key (inc-path #t)) - (let ((a (env:lazy-hash-table->alist added)) - (r (env:lazy-hash-table->alist removed)) - (c (env:lazy-hash-table->alist changed))) - (case (if (args:get-arg "-dumpmode") - (string->symbol (args:get-arg "-dumpmode")) - 'bash) - ((bash) - (if a - (begin - (print "# Added vars") - (map (lambda (dat)(print "export " (car dat) "=" (cdr dat))) - (hash-table->alist added)))) - (if r - (begin - (print "# Removed vars") - (map (lambda (dat)(print "unset " (car dat))) - (hash-table->alist removed)))) - (if c - (begin - (print "# Changed vars") - (map (lambda (dat)(print "export " (car dat) "=" (cdr dat))) - (hash-table->alist changed))))) - ((csh) - (if a - (begin - (print "# Added vars") - (map (lambda (dat)(print "setenv " (car dat) " " (cdr dat))) - (hash-table->alist added)))) - (if r - (begin - (print "# Removed vars") - (map (lambda (dat)(print "unsetenv " (car dat))) - (hash-table->alist removed)))) - (if c - (begin - (print "# Changed vars") - (map (lambda (dat)(print "setenv " (car dat) " " (cdr dat))) - (hash-table->alist changed))))) - ((config ini) - (if a - (begin - (print "# Added vars") - (map (lambda (dat) - (let ((var (car dat)) - (val (cdr dat))) - (if (and inc-path - (equal? var "PATH")) - (env:inc-path val) - (print var " " val)))) - (hash-table->alist added)))) - (if r - (begin - (print "# Removed vars") - (map (lambda (dat)(print "#{scheme (unsetenv \"" (car dat) "\")}")) - (hash-table->alist removed)))) - (if c - (begin - (print "# Changed vars") - (map (lambda (dat) - (let ((var (car dat)) - (val (cdr dat))) - (if (and inc-path - (equal? var "PATH")) - (env:inc-path val) - (print var " " val)))) - (hash-table->alist changed))))) - (else - (debug:print-error 0 *default-log-port* "No dumpmode specified, use -dumpmode [bash|csh|config]"))))) +;; (import (prefix mtargs args:) +;; debugprint) +;; +;; (use sql-de-lite) ;; srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables) +;; +;; (define (env:open-db fname) +;; (let* ((db-exists (common:file-exists? fname)) +;; (db (open-database fname))) +;; (if (not db-exists) +;; (begin +;; (exec (sql db "CREATE TABLE envvars ( +;; id INTEGER PRIMARY KEY, +;; context TEXT NOT NULL, +;; var TEXT NOT NULL, +;; val TEXT NOT NULL, +;; CONSTRAINT envvars_constraint UNIQUE (context,var))")))) +;; (set-busy-handler! db (busy-timeout 10000)) +;; db)) +;; +;; ;; save vars in given context, this is NOT incremental by default +;; ;; +;; (define (env:save-env-vars db context #!key (incremental #f)(vardat #f)) +;; (with-transaction +;; db +;; (lambda () +;; ;; first clear out any vars for this context +;; (if (not incremental)(exec (sql db "DELETE FROM envvars WHERE context=?") context)) +;; (for-each +;; (lambda (varval) +;; (let ((var (car varval)) +;; (val (cdr varval))) +;; (if incremental (exec (sql db "DELETE FROM envvars WHERE context=? AND var=?") context var)) +;; (exec (sql db "INSERT INTO envvars (context,var,val) VALUES (?,?,?)") context var val))) +;; (if vardat +;; (hash-table->alist vardat) +;; (get-environment-variables)))))) +;; +;; ;; merge contexts in the order given +;; ;; - each context is applied in the given order +;; ;; - variables in the paths list are split on the separator and the components +;; ;; merged using simple delta addition +;; ;; returns a hash of the merged vars +;; ;; +;; (define (env:merge-contexts db basecontext contexts paths) +;; (let ((result (make-hash-table))) +;; (for-each +;; (lambda (context) +;; (query +;; (for-each-row +;; (lambda (row) +;; (let ((var (car row)) +;; (val (cadr row))) +;; (hash-table-set! result var +;; (if (and (hash-table-ref/default result var #f) +;; (assoc var paths)) ;; this var is a path and there is a previous path +;; (let ((sep (cadr (assoc var paths)))) +;; (env:merge-path-envvar sep (hash-table-ref result var) val)) +;; val))))) +;; (sql db "SELECT var,val FROM envvars WHERE context=?") +;; context)) +;; contexts) +;; result)) +;; +;; ;; get list of removed variables between two contexts +;; ;; +;; (define (env:get-removed db contexta contextb) +;; (let ((result (make-hash-table))) +;; (query +;; (for-each-row +;; (lambda (row) +;; (let ((var (car row)) +;; (val (cadr row))) +;; (hash-table-set! result var val)))) +;; (sql db "SELECT var,val FROM envvars WHERE context=? AND var NOT IN (SELECT var FROM envvars WHERE context=?)") +;; contexta contextb) +;; result)) +;; +;; ;; get list of variables added to contextb from contexta +;; ;; +;; (define (env:get-added db contexta contextb) +;; (let ((result (make-hash-table))) +;; (query +;; (for-each-row +;; (lambda (row) +;; (let ((var (car row)) +;; (val (cadr row))) +;; (hash-table-set! result var val)))) +;; (sql db "SELECT var,val FROM envvars WHERE context=? AND var NOT IN (SELECT var FROM envvars WHERE context=?)") +;; contextb contexta) +;; result)) +;; +;; ;; get list of variables in both contexta and contexb that have been changed +;; ;; +;; (define (env:get-changed db contexta contextb) +;; (let ((result (make-hash-table))) +;; (query +;; (for-each-row +;; (lambda (row) +;; (let ((var (car row)) +;; (val (cadr row))) +;; (hash-table-set! result var val)))) +;; (sql db "SELECT var,val FROM envvars AS a WHERE context=? AND val != (SELECT val FROM envvars WHERE var=a.var AND context=?)") +;; contextb contexta) +;; result)) +;; +;; ;; +;; (define (env:blind-merge l1 l2) +;; (if (null? l1) l2 +;; (if (null? l2) l1 +;; (cons (car l1) (cons (car l2) (env:blind-merge (cdr l1) (cdr l2))))))) +;; +;; ;; given a before and an after envvar calculate a new merged path +;; ;; +;; (define (env:merge-path-envvar separator patha pathb) +;; (let* ((patha-parts (string-split patha separator)) +;; (pathb-parts (string-split pathb separator)) +;; (common-parts (lset-intersection equal? patha-parts pathb-parts)) +;; (final (delete-duplicates ;; env:blind-merge +;; (append pathb-parts common-parts patha-parts)))) +;; ;; (print "BEFORE: " (string-intersperse patha-parts "\n ")) +;; ;; (print "AFTER: " (string-intersperse pathb-parts "\n ")) +;; ;; (print "COMMON: " (string-intersperse common-parts "\n ")) +;; (string-intersperse final separator))) +;; +;; (define (env:process-path-envvar varname separator patha pathb) +;; (let ((newpath (env:merge-path-envvar separator patha pathb))) +;; (setenv varname newpath))) +;; +;; (define (env:have-context db context) +;; (> (query fetch-value (sql db "SELECT count(id) FROM envvars WHERE context=?") context) +;; 0)) +;; +;; ;; this is so the calling block does not need to import sql-de-lite +;; (define (env:close-database db) +;; (close-database db)) +;; +;; (define (env:lazy-hash-table->alist indat) +;; (if (hash-table? indat) +;; (let ((dat (hash-table->alist indat))) +;; (if (null? dat) +;; #f +;; dat)) +;; #f)) +;; +;; (define (env:inc-path path) +;; (print "PATH " +;; (conc "#{scheme (env:min-path \"" path "\" \"#{getenv PATH}\")}"))) +;; ;; (conc +;; ;; "#{scheme (string-intersperse " +;; ;; "(delete-duplicates " +;; ;; "(append (string-split \"" path "\" \":\") " +;; ;; "(string-split \"#{getenv PATH}\" \":\")))" +;; ;; " \":\")}"))) +;; +;; (define (env:min-path path1 path2) +;; (string-intersperse +;; (delete-duplicates +;; (append +;; (string-split path1 ":") +;; (string-split path2 ":"))) +;; ":")) +;; +;; ;; inc path will set a PATH that is incrementally modified when read - config mode only +;; ;; +;; (define (env:print added removed changed #!key (inc-path #t)) +;; (let ((a (env:lazy-hash-table->alist added)) +;; (r (env:lazy-hash-table->alist removed)) +;; (c (env:lazy-hash-table->alist changed))) +;; (case (if (args:get-arg "-dumpmode") +;; (string->symbol (args:get-arg "-dumpmode")) +;; 'bash) +;; ((bash) +;; (if a +;; (begin +;; (print "# Added vars") +;; (map (lambda (dat)(print "export " (car dat) "=" (cdr dat))) +;; (hash-table->alist added)))) +;; (if r +;; (begin +;; (print "# Removed vars") +;; (map (lambda (dat)(print "unset " (car dat))) +;; (hash-table->alist removed)))) +;; (if c +;; (begin +;; (print "# Changed vars") +;; (map (lambda (dat)(print "export " (car dat) "=" (cdr dat))) +;; (hash-table->alist changed))))) +;; ((csh) +;; (if a +;; (begin +;; (print "# Added vars") +;; (map (lambda (dat)(print "setenv " (car dat) " " (cdr dat))) +;; (hash-table->alist added)))) +;; (if r +;; (begin +;; (print "# Removed vars") +;; (map (lambda (dat)(print "unsetenv " (car dat))) +;; (hash-table->alist removed)))) +;; (if c +;; (begin +;; (print "# Changed vars") +;; (map (lambda (dat)(print "setenv " (car dat) " " (cdr dat))) +;; (hash-table->alist changed))))) +;; ((config ini) +;; (if a +;; (begin +;; (print "# Added vars") +;; (map (lambda (dat) +;; (let ((var (car dat)) +;; (val (cdr dat))) +;; (if (and inc-path +;; (equal? var "PATH")) +;; (env:inc-path val) +;; (print var " " val)))) +;; (hash-table->alist added)))) +;; (if r +;; (begin +;; (print "# Removed vars") +;; (map (lambda (dat)(print "#{scheme (unsetenv \"" (car dat) "\")}")) +;; (hash-table->alist removed)))) +;; (if c +;; (begin +;; (print "# Changed vars") +;; (map (lambda (dat) +;; (let ((var (car dat)) +;; (val (cdr dat))) +;; (if (and inc-path +;; (equal? var "PATH")) +;; (env:inc-path val) +;; (print var " " val)))) +;; (hash-table->alist changed))))) +;; (else +;; (debug:print-error 0 *default-log-port* "No dumpmode specified, use -dumpmode [bash|csh|config]"))))) +;; ADDED envmod.scm Index: envmod.scm ================================================================== --- /dev/null +++ envmod.scm @@ -0,0 +1,275 @@ +;;====================================================================== +;; Copyright 2006-2013, 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 . + +;;====================================================================== + +(use sql-de-lite) + +(declare (unit envmod)) + +(declare (uses debugprint)) +(declare (uses mtargs)) +(declare (uses commonmod)) + +(module envmod + * + +(import scheme + chicken + + posix + srfi-1 + data-structures + srfi-69) + +(import (prefix mtargs args:) + debugprint + commonmod) + +(import sql-de-lite) ;; srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables) + +(define (env:open-db fname) + (let* ((db-exists (common:file-exists? fname)) + (db (open-database fname))) + (if (not db-exists) + (begin + (exec (sql db "CREATE TABLE envvars ( + id INTEGER PRIMARY KEY, + context TEXT NOT NULL, + var TEXT NOT NULL, + val TEXT NOT NULL, + CONSTRAINT envvars_constraint UNIQUE (context,var))")))) + (set-busy-handler! db (busy-timeout 10000)) + db)) + +;; save vars in given context, this is NOT incremental by default +;; +(define (env:save-env-vars db context #!key (incremental #f)(vardat #f)) + (with-transaction + db + (lambda () + ;; first clear out any vars for this context + (if (not incremental)(exec (sql db "DELETE FROM envvars WHERE context=?") context)) + (for-each + (lambda (varval) + (let ((var (car varval)) + (val (cdr varval))) + (if incremental (exec (sql db "DELETE FROM envvars WHERE context=? AND var=?") context var)) + (exec (sql db "INSERT INTO envvars (context,var,val) VALUES (?,?,?)") context var val))) + (if vardat + (hash-table->alist vardat) + (get-environment-variables)))))) + +;; merge contexts in the order given +;; - each context is applied in the given order +;; - variables in the paths list are split on the separator and the components +;; merged using simple delta addition +;; returns a hash of the merged vars +;; +(define (env:merge-contexts db basecontext contexts paths) + (let ((result (make-hash-table))) + (for-each + (lambda (context) + (query + (for-each-row + (lambda (row) + (let ((var (car row)) + (val (cadr row))) + (hash-table-set! result var + (if (and (hash-table-ref/default result var #f) + (assoc var paths)) ;; this var is a path and there is a previous path + (let ((sep (cadr (assoc var paths)))) + (env:merge-path-envvar sep (hash-table-ref result var) val)) + val))))) + (sql db "SELECT var,val FROM envvars WHERE context=?") + context)) + contexts) + result)) + +;; get list of removed variables between two contexts +;; +(define (env:get-removed db contexta contextb) + (let ((result (make-hash-table))) + (query + (for-each-row + (lambda (row) + (let ((var (car row)) + (val (cadr row))) + (hash-table-set! result var val)))) + (sql db "SELECT var,val FROM envvars WHERE context=? AND var NOT IN (SELECT var FROM envvars WHERE context=?)") + contexta contextb) + result)) + +;; get list of variables added to contextb from contexta +;; +(define (env:get-added db contexta contextb) + (let ((result (make-hash-table))) + (query + (for-each-row + (lambda (row) + (let ((var (car row)) + (val (cadr row))) + (hash-table-set! result var val)))) + (sql db "SELECT var,val FROM envvars WHERE context=? AND var NOT IN (SELECT var FROM envvars WHERE context=?)") + contextb contexta) + result)) + +;; get list of variables in both contexta and contexb that have been changed +;; +(define (env:get-changed db contexta contextb) + (let ((result (make-hash-table))) + (query + (for-each-row + (lambda (row) + (let ((var (car row)) + (val (cadr row))) + (hash-table-set! result var val)))) + (sql db "SELECT var,val FROM envvars AS a WHERE context=? AND val != (SELECT val FROM envvars WHERE var=a.var AND context=?)") + contextb contexta) + result)) + +;; +(define (env:blind-merge l1 l2) + (if (null? l1) l2 + (if (null? l2) l1 + (cons (car l1) (cons (car l2) (env:blind-merge (cdr l1) (cdr l2))))))) + +;; given a before and an after envvar calculate a new merged path +;; +(define (env:merge-path-envvar separator patha pathb) + (let* ((patha-parts (string-split patha separator)) + (pathb-parts (string-split pathb separator)) + (common-parts (lset-intersection equal? patha-parts pathb-parts)) + (final (delete-duplicates ;; env:blind-merge + (append pathb-parts common-parts patha-parts)))) +;; (print "BEFORE: " (string-intersperse patha-parts "\n ")) +;; (print "AFTER: " (string-intersperse pathb-parts "\n ")) +;; (print "COMMON: " (string-intersperse common-parts "\n ")) + (string-intersperse final separator))) + +(define (env:process-path-envvar varname separator patha pathb) + (let ((newpath (env:merge-path-envvar separator patha pathb))) + (setenv varname newpath))) + +(define (env:have-context db context) + (> (query fetch-value (sql db "SELECT count(id) FROM envvars WHERE context=?") context) + 0)) + +;; this is so the calling block does not need to import sql-de-lite +(define (env:close-database db) + (close-database db)) + +(define (env:lazy-hash-table->alist indat) + (if (hash-table? indat) + (let ((dat (hash-table->alist indat))) + (if (null? dat) + #f + dat)) + #f)) + +(define (env:inc-path path) + (print "PATH " + (conc "#{scheme (env:min-path \"" path "\" \"#{getenv PATH}\")}"))) +;; (conc +;; "#{scheme (string-intersperse " +;; "(delete-duplicates " +;; "(append (string-split \"" path "\" \":\") " +;; "(string-split \"#{getenv PATH}\" \":\")))" +;; " \":\")}"))) + +(define (env:min-path path1 path2) + (string-intersperse + (delete-duplicates + (append + (string-split path1 ":") + (string-split path2 ":"))) + ":")) + +;; inc path will set a PATH that is incrementally modified when read - config mode only +;; +(define (env:print added removed changed #!key (inc-path #t)) + (let ((a (env:lazy-hash-table->alist added)) + (r (env:lazy-hash-table->alist removed)) + (c (env:lazy-hash-table->alist changed))) + (case (if (args:get-arg "-dumpmode") + (string->symbol (args:get-arg "-dumpmode")) + 'bash) + ((bash) + (if a + (begin + (print "# Added vars") + (map (lambda (dat)(print "export " (car dat) "=" (cdr dat))) + (hash-table->alist added)))) + (if r + (begin + (print "# Removed vars") + (map (lambda (dat)(print "unset " (car dat))) + (hash-table->alist removed)))) + (if c + (begin + (print "# Changed vars") + (map (lambda (dat)(print "export " (car dat) "=" (cdr dat))) + (hash-table->alist changed))))) + ((csh) + (if a + (begin + (print "# Added vars") + (map (lambda (dat)(print "setenv " (car dat) " " (cdr dat))) + (hash-table->alist added)))) + (if r + (begin + (print "# Removed vars") + (map (lambda (dat)(print "unsetenv " (car dat))) + (hash-table->alist removed)))) + (if c + (begin + (print "# Changed vars") + (map (lambda (dat)(print "setenv " (car dat) " " (cdr dat))) + (hash-table->alist changed))))) + ((config ini) + (if a + (begin + (print "# Added vars") + (map (lambda (dat) + (let ((var (car dat)) + (val (cdr dat))) + (if (and inc-path + (equal? var "PATH")) + (env:inc-path val) + (print var " " val)))) + (hash-table->alist added)))) + (if r + (begin + (print "# Removed vars") + (map (lambda (dat)(print "#{scheme (unsetenv \"" (car dat) "\")}")) + (hash-table->alist removed)))) + (if c + (begin + (print "# Changed vars") + (map (lambda (dat) + (let ((var (car dat)) + (val (cdr dat))) + (if (and inc-path + (equal? var "PATH")) + (env:inc-path val) + (print var " " val)))) + (hash-table->alist changed))))) + (else + (debug:print-error 0 *default-log-port* "No dumpmode specified, use -dumpmode [bash|csh|config]"))))) + +) Index: ezsteps.scm ================================================================== --- ezsteps.scm +++ ezsteps.scm @@ -19,11 +19,11 @@ ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') (declare (unit ezsteps)) (declare (uses commonmod)) -(declare (uses common)) +;; (declare (uses common)) (declare (uses configfmod)) (declare (uses debugprint)) (declare (uses runconfig)) (declare (uses rmtmod)) Index: ezstepsmod.scm ================================================================== --- ezstepsmod.scm +++ ezstepsmod.scm @@ -45,11 +45,13 @@ (declare (uses fsmod)) (use srfi-69) (module ezstepsmod - * + ( + ezsteps:spawn-run-from + ) (import scheme) (cond-expand (chicken-4 @@ -63,11 +65,10 @@ posix posix-extras regex regex-case sparse-vectors - ) (use srfi-69)) (chicken-5 (import (prefix sqlite3 sqlite3:) chicken.base @@ -126,11 +127,11 @@ testsmod runsmod fsmod ) -(include "common_records.scm") +;; (include "common_records.scm") ;; (include "key_records.scm") ;; (include "db_records.scm") (include "run_records.scm") Index: fsmod.scm ================================================================== --- fsmod.scm +++ fsmod.scm @@ -33,11 +33,18 @@ (declare (uses processmod)) (use srfi-69) (module fsmod - * + ( + get-df + get-uname + common:get-disk-with-most-free-space + common:get-disk-space-used + common:check-db-dir-and-exit-if-insufficient + + ) (import scheme) (cond-expand (chicken-4 Index: genexample.scm ================================================================== --- genexample.scm +++ genexample.scm @@ -19,21 +19,42 @@ ;;====================================================================== (declare (unit genexample)) (declare (uses mtargs)) (declare (uses debugprint)) -(declare (uses common)) +;; (declare (uses common)) (declare (uses commonmod)) (declare (uses configfmod)) (declare (uses rmtmod)) +(declare (uses testsmod)) +(declare (uses dbfile)) +(declare (uses tasksmod)) (use posix regex matchable) -(import (prefix mtargs args:) + +(module genexample + * + +(import scheme + chicken + + data-structures + extras + srfi-1 + srfi-13 + srfi-69 + posix + regex + matchable + (prefix mtargs args:) commonmod configfmod + testsmod rmtmod - debugprint) + debugprint + tasksmod + dbfile) ;; (include "db_records.scm") (define genexample:example-logpro #<. -;; -;;====================================================================== - -(require-library iup) -(import (prefix iup iup:)) -(use canvas-draw) - -(use srfi-1 regex regex-case srfi-69) -(declare (unit gutils)) - -;; NOTE: These functions will move to iuputils - -(define (gutils: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)))) - -(define gutils:colors - '((PASS . "70 249 73") - (FAIL . "253 33 49") - (SKIP . "230 230 0"))) - -(define (gutils:get-color-spec effective-state) - (or (alist-ref effective-state gutils:colors) - (alist-ref 'FAIL gutils:colors))) - -;; BBnote - state status dashboard button color / text defined here -(define (gutils:get-color-for-state-status state status);; #!key (get-label #f)) - ;; ((if get-label cadr car) - (case (string->symbol state) - ((COMPLETED) ;; ARCHIVED) - (case (string->symbol status) - ((PASS) (list "70 249 73" status)) - ((PREQ_FAIL PREQ_DISCARDED) (list "255 127 127" status)) - ((WARN WAIVED) (list "255 172 13" status)) - ((SKIP) (list (gutils:get-color-spec 'SKIP) status)) - ((ABORT) (list "198 36 166" status)) - (else (list "253 33 49" status)))) - ((ARCHIVED) - (case (string->symbol status) - ((PASS) (list "70 170 73" status)) - ((WARN WAIVED) (list "200 130 13" status)) - ((SKIP) (list (gutils:get-color-spec 'SKIP) status)) - (else (list "180 33 49" status)))) - ;; (if (equal? status "PASS") - ;; '("70 249 73" "PASS") - ;; (if (or (equal? status "WARN") - ;; (equal? status "WAIVED")) - ;; (list "255 172 13" status) - ;; (list "223 33 49" status)))) ;; greenish orangeish redish - ((LAUNCHED) (list "101 123 142" state)) - ((CHECK) (list "255 100 50" state)) - ((REMOTEHOSTSTART) (list "50 130 195" state)) - ((RUNNING STARTED) (list "9 131 232" state)) - ((KILLREQ) (list "39 82 206" state)) - ((KILLED) (list "234 101 17" state)) - ((NOT_STARTED) (case (string->symbol status) - ((CHECK STARTED)(list (gutils:get-color-spec 'SKIP) state)) - (else (list "240 240 240" state)))) - ;; for xor mode below - ;; - ((CLEAN) - (case (string->symbol status) - ((CLEAN-FAIL CLEAN-CHECK CLEAN-ABORT) (list "200 130 13" status)) ;; orange requested for these - (else (list "60 235 63" status)))) - ((DIRTY-BETTER) (list "160 255 153" status)) - ((DIRTY-WORSE) (list "165 42 42" status)) - ((BOTH-BAD) (list "180 33 49" status)) - - (else (list - ;; "192 192 192" - "222 222 221" - state)))) - Index: key_records.scm ================================================================== --- key_records.scm +++ key_records.scm @@ -16,17 +16,5 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;;====================================================================== -(define (keys->valslots keys) ;; => ?,?,? .... - (string-intersperse (map (lambda (x) "?") keys) ",")) - -;; (define (keys->key/field keys . additional) -;; (string-join (map (lambda (k)(conc k " TEXT")) -;; (append keys additional)) ",")) - -(define (item-list->path itemdat) - (if (list? itemdat) - (string-intersperse (map cadr itemdat) "/") - "")) - Index: keys.scm ================================================================== --- keys.scm +++ keys.scm @@ -20,11 +20,11 @@ ;;====================================================================== ;; Run keys, these are used to hierarchially organise tests and run areas ;;====================================================================== (declare (unit keys)) -(declare (uses common)) +;; (declare (uses common)) (declare (uses debugprint)) (declare (uses commonmod)) (declare (uses configfmod)) (declare (uses mtargs)) DELETED launch.scm Index: launch.scm ================================================================== --- launch.scm +++ /dev/null @@ -1,67 +0,0 @@ - -;; Copyright 2006-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 . - -;;====================================================================== -;; launch a task - this runs on the originating host, tests themselves -;; -;;====================================================================== - -(declare (unit launch)) -(declare (uses subrun)) -(declare (uses common)) -(declare (uses debugprint)) -(declare (uses commonmod)) -(declare (uses processmod)) -(declare (uses configfmod)) -(declare (uses configf)) -(declare (uses rmtmod)) -(declare (uses ezsteps)) -;; (declare (uses dbmod)) -(declare (uses dbfile)) -(declare (uses dbmod)) -(declare (uses mtargs)) -(declare (uses mtmod)) -(declare (uses megatestmod)) -(declare (uses tasksmod)) - -(use regex regex-case base64 sqlite3 srfi-18 directory-utils posix posix-extras z3 - call-with-environment-variables csv hostinfo - typed-records pathname-expand matchable) - -(import (prefix base64 base64:) - (prefix sqlite3 sqlite3:) - (prefix mtargs args:) -) - -(include "common_records.scm") -;; (include "key_records.scm") -;; (include "db_records.scm") -(include "megatest-fossil-hash.scm") - -(import commonmod - processmod - configfmod - rmtmod - debugprint - dbmod - dbfile - mtmod - megatestmod - tasksmod - ) - Index: launchmod.scm ================================================================== --- launchmod.scm +++ launchmod.scm @@ -41,14 +41,17 @@ (declare (uses subrunmod)) (declare (uses testsmod)) (declare (uses runsmod)) (declare (uses fsmod)) -(use srfi-69) - (module launchmod - * + ( + launch:load-logpro-dat + launch:recover-test + launch:execute + launch:extract-scripts-logpro + ) (import scheme) (cond-expand (chicken-4 @@ -126,11 +129,11 @@ testsmod runsmod fsmod ) -(include "common_records.scm") +;; (include "common_records.scm") ;; (include "key_records.scm") ;; (include "db_records.scm") (include "megatest-fossil-hash.scm") ;;====================================================================== @@ -979,96 +982,10 @@ ;; periodically update the db with runtime ;; when the process exits look at the db, if still RUNNING after 10 seconds set ;; state/status appropriately (process-wait pid))) -;;====================================================================== -;; Maintenance -;;====================================================================== - -(define (rmt:find-and-mark-incomplete run-id ovr-deadtime) - (let* ((cfg-deadtime (configf:lookup-number *configdat* "setup" "deadtime")) - (test-stats-update-period (configf:lookup-number *configdat* "setup" "test-stats-update-period"))) - (rmt:find-and-mark-incomplete-engine run-id ovr-deadtime cfg-deadtime test-stats-update-period) - ;;call end of eud of run detection for posthook - (launch:end-of-run-check run-id))) - -;; select end_time-now from -;; (select testname,item_path,event_time+run_duration as -;; end_time,strftime('%s','now') as now from tests where state in -;; ('RUNNING','REMOTEHOSTSTART','LAUNCHED')); -;; -;; NOT EASY TO MIGRATE TO db{file,mod} -;; -(define (rmt:find-and-mark-incomplete-engine run-id ovr-deadtime cfg-deadtime test-stats-update-period) - (let* ((incompleted '()) - (oldlaunched '()) - (toplevels '()) - ;; The default running-deadtime is 720 seconds = 12 minutes. - ;; "(running-deadtime-default (+ server-start-allowance (* 2 launch-monitor-period)))" = 200 + (2 * (200 + 30 + 30)) - (deadtime-trim (or ovr-deadtime cfg-deadtime)) - (server-start-allowance 200) - (server-overloaded-budget 200) - (launch-monitor-off-time (or test-stats-update-period 30)) - (launch-monitor-on-time-budget 30) - (launch-monitor-period (+ launch-monitor-off-time launch-monitor-on-time-budget server-overloaded-budget)) - (remotehoststart-deadtime-default (+ server-start-allowance server-overloaded-budget 30)) - (remotehoststart-deadtime (or deadtime-trim remotehoststart-deadtime-default)) - (running-deadtime-default (+ server-start-allowance (* 2 launch-monitor-period))) - (running-deadtime (or deadtime-trim running-deadtime-default))) ;; two minutes (30 seconds between updates, this leaves 3x grace period) - - (debug:print-info 4 *default-log-port* "running-deadtime = " running-deadtime) - (debug:print-info 4 *default-log-port* "deadtime-trim = " deadtime-trim) - - (let* ((dat (rmt:get-toplevels-and-incompletes run-id running-deadtime remotehoststart-deadtime))) - (set! oldlaunched (list-ref dat 1)) - (set! toplevels (list-ref dat 2)) - (set! incompleted (list-ref dat 0))) - - (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, " - (length toplevels) " old LAUNCHED toplevel tests and " - (length incompleted) " tests marked RUNNING but apparently dead.") - - ;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE. - ;; - ;; (db:delay-if-busy dbdat) - (let* ((min-incompleted-ids (map car incompleted)) ;; do 'em all - (all-ids (append min-incompleted-ids (map car oldlaunched)))) - (if (> (length all-ids) 0) - (begin - ;; (launch:is-test-alive "localhost" 435) - (debug:print 0 *default-log-port* "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") - " as DEAD") - (for-each - (lambda (test-id) - (let* ((tinfo (rmt:get-test-info-by-id run-id test-id)) - (run-dir (db:test-get-rundir tinfo)) - (host (db:test-get-host tinfo)) - (pid (db:test-get-process_id tinfo)) - (result (rmt:get-status-from-final-status-file run-dir))) - (if (and (list? result) (> (length result) 1) (equal? "PASS" (cadr result)) (equal? "COMPLETED" (car result))) - (begin - (debug:print 0 *default-log-port* "INFO: test " test-id " actually passed, so marking PASS not DEAD") - (rmt:set-state-status-and-roll-up-items - run-id test-id 'foo "COMPLETED" "PASS" - "Test stopped responding but it has PASSED; marking it PASS in the DB.")) - (let ((is-alive (and (not (eq? pid 0)) ;; 0 is default in re-used field "attemptnum" where pid stored. - (commonmod:is-test-alive host pid)))) - (if is-alive - (debug:print 0 *default-log-port* "INFO: test " test-id " on host " host - " has a process on pid " pid ", NOT setting to DEAD.") - (begin - (debug:print 0 *default-log-port* "INFO: test " test-id - " final state/status is not COMPLETED/PASS. It is " result) - (rmt:set-state-status-and-roll-up-items - run-id test-id 'foo "COMPLETED" "DEAD" - "Test stopped responding while in RUNNING or REMOTEHOSTSTART; presumed dead."))))))) - ;; call end of eud of run detection for posthook - from merge, is it needed? - ;; (launch:end-of-run-check run-id) - all-ids) - ))))) - ;; TODO: deprecate me in favor of ezsteps.scm ;; (define (ezsteps:runstep ezstep run-id test-id exit-info m tal testconfig all-steps-dat) (let* ((stepname (car ezstep)) ;; do stuff to run the step Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -15,16 +15,13 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; ;; (include "common.scm") -(include "megatest-version.scm") +;; (include "megatest-version.scm") -;; fake out readline usage of toplevel-command -(define (toplevel-command . a) #f) - -(declare (uses common)) +;; (declare (uses common)) ;; (declare (uses megatest-version)) ;; (declare (uses margs)) (declare (uses mtargs)) (declare (uses mtargs.import)) (declare (uses debugprint)) @@ -38,11 +35,11 @@ (declare (uses processmod)) (declare (uses processmod.import)) (declare (uses configfmod)) (declare (uses configfmod.import)) (declare (uses pgdb)) -(declare (uses pgdb.import)) +;; (declare (uses pgdb.import)) (declare (uses mtmod)) (declare (uses mtmod.import)) (declare (uses servermod)) (declare (uses servermod.import)) (declare (uses dbfile)) @@ -60,2766 +57,47 @@ (declare (uses apimod)) (declare (uses apimod.import)) (declare (uses rmtmod)) (declare (uses rmtmod.import)) (declare (uses tasksmod)) -(declare (uses tasksmod.import)) +;; (declare (uses tasksmod.import)) (declare (uses testsmod)) -(declare (uses testsmod.import)) +;; (declare (uses testsmod.import)) (declare (uses subrunmod)) -(declare (uses subrunmod.import)) +;; (declare (uses subrunmod.import)) (declare (uses archivemod)) -(declare (uses archivemod.import)) +;; (declare (uses archivemod.import)) (declare (uses runsmod)) ;; comment out following line for performance, but debug result. (declare (uses runsmod.import)) (declare (uses cpumod)) -(declare (uses cpumod.import)) +;; (declare (uses cpumod.import)) (declare (uses runsmod)) (declare (uses ezstepsmod)) (declare (uses launchmod)) (declare (uses tdb)) -(declare (uses mt)) (declare (uses api)) (declare (uses env)) (declare (uses diff-report)) -(declare (uses runs)) -(declare (uses launch)) (declare (uses server)) (declare (uses genexample)) -;; (declare (uses daemon)) - -;; (declare (uses dcommon)) - -;; (declare (uses debugprint)) -;; (declare (uses debugprint.import)) - -;; (declare (uses ftail)) -;; (import ftail) - -(import (prefix mtargs args:) - debugprint - dbmod - commonmod - processmod - configfmod - dbfile - portlogger - tcp-transportmod - rmtmod - apimod - stml2 - mtmod - megatestmod - servermod - tasksmod - runsmod - rmtmod - launchmod - fsmod - ) - -(define *db* #f) ;; this is only for the repl, do not use in general!!!! - -(include "common_records.scm") -;; (include "key_records.scm") -;; (include "db_records.scm") -(include "run_records.scm") -(include "megatest-fossil-hash.scm") - -(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:)) -(use readline apropos json http-client directory-utils typed-records) -(use http-client srfi-18 extras format tcp-server tcp) - -;; Added for csv stuff - will be removed -;; -(use sparse-vectors) - -(require-library mutils) - -;; remove when configf fully modularized -(read-config-set! configf:read-file) - -(define *usage-log-file* #f) ;; put path to file for logging usage in this var in the ~/.megatestrc file -(define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file - -;; set some parameters here - these need to be put in something that can be loaded from other -;; executables such as dashboard and mtutil -;; -(include "transport-mode.scm") -(dbfile:db-init-proc db:initialize-main-db) -(debug:enable-timestamp #t) - - -(set! rmtmod:send-receive rmt:send-receive) - ;;(lambda params (apply rmt:send-receive params))) ;; make send-receive available to rmtmod via parameter - - -;; load the ~/.megatestrc file, put (use trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file -;; -(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc"))) - (if (common:file-exists? debugcontrolf) - (load debugcontrolf))) - -;; usage logging, careful with this, it is not designed to deal with all real world challenges! -;; -(if (and *usage-log-file* - (file-write-access? *usage-log-file*)) - (with-output-to-file - *usage-log-file* - (lambda () - (print (if *usage-use-seconds* - (current-seconds) - (time->string - (seconds->local-time (current-seconds)) - "%Yww%V.%w %H:%M:%S")) - " " - (current-user-name) " " - (current-directory) " " - "\"" (string-intersperse (argv) " ") "\"")) - #:append)) - -;; Disabled help items -;; -rollup : (currently disabled) fill run (set by :runname) with latest test(s) -;; from prior runs with same keys -;; -daemonize : fork into background and disconnect from stdin/out - -(define help (conc " -Megatest, documentation at http://www.kiatoa.com/fossils/megatest - version " megatest-version " - license GPL, Copyright Matt Welland 2006-2017 - -Usage: megatest [options] - -h : this help - -manual : show the Megatest user manual - -version : print megatest version (currently " megatest-version ") - -Launching and managing runs - -run : run all tests or as specified by -testpatt - -remove-runs : remove the data for a run, requires -runname and -testpatt - Optionally use :state and :status, use -keep-records to remove only - the run data. Use -kill-wait to override the 10 second - per test wait after kill delay (e.g. -kill-wait 0). - -kill-runs : kill existing run(s) (all incomplete tests killed) - -kill-rerun : kill an existing run (all incomplete tests killed and run is rerun) - -set-state-status X,Y : set state to X and status to Y, requires controls per -remove-runs - -rerun FAIL,WARN... : force re-run for tests with specificed status(s) - -rerun-clean : set all tests not COMPLETED+PASS,WARN,WAIVED to NOT_STARTED,n/a - and then run the specified testpatt with -preclean - -rerun-all : set all tests to NOT_STARTED,n/a and run with -preclean - -lock : lock run specified by target and runname - -unlock : unlock run specified by target and runname - -set-run-status status : sets status for run to status, requires -target and -runname - -get-run-status : gets status for run specified by target and runname - -run-wait : wait on run specified by target and runname - -preclean : remove the existing test directory before running the test - -clean-cache : remove the cached megatest.config and runconfigs.config files - -no-cache : do not use the cached config files. - -one-pass : launch as many tests as you can but do not wait for more to be ready - -remove-keep N : remove all but N most recent runs per target; use '-actions, -age, -precmd' - -age : 120d,3h,20m to apply only to runs older than the - specified age. NB// M=month, m=minute - -actions [,...] : actions to take; print,remove-runs,archive,kill-runs - -precmd : insert a wrapper command in front of the commands run - -Selectors (e.g. use for -runtests, -remove-runs, -set-state-status, -list-runs etc.) - -target key1/key2/... : run for key1, key2, etc. - -reqtarg key1/key2/... : run for key1, key2, etc. but key1/key2 must be in runconfigs - -testpatt patt1/patt2,patt3/... : % is wildcard - -runname : required, name for this particular test run - -state : Applies to runs, tests or steps depending on context - -status : Applies to runs, tests or steps depending on context - -modepatt key : load testpatt from in runconfigs instead of default TESTPATT if -testpatt and -tagexpr are not specified - -tagexpr tag1,tag2%,.. : select tests with tags matching expression - - -Test helpers (for use inside tests) - -step stepname - -test-status : set the state and status of a test (use :state and :status) - -setlog logfname : set the path/filename to the final log relative to the test - directory. may be used with -test-status - -set-toplog logfname : set the overall log for a suite of sub-tests - -summarize-items : for an itemized test create a summary html - -m comment : insert a comment for this test - -Test data capture - -set-values : update or set values in the testdata table - :category : set the category field (optional) - :variable : set the variable name (optional) - :value : value measured (required) - :expected : value expected (required) - :tol : |value-expect| <= tol (required, can be <, >, >=, <= or number) - :units : name of the units for value, expected_value etc. (optional) - -load-test-data : read test specific data for storage in the test_data table - from standard in. Each line is comma delimited with four - fields category,variable,value,comment - -Queries - -list-runs patt : list runs matching pattern \"patt\", % is the wildcard - -show-keys : show the keys used in this megatest setup - -test-files targpatt : get the most recent test path/file matching targpatt e.g. %/% or '*.log' - returns list sorted by age ascending, see examples below - -test-paths : get the test paths matching target, runname, item and test - patterns. - -list-disks : list the disks available for storing runs - -list-targets : list the targets in runconfigs.config - -list-db-targets : list the target combinations used in the db - -show-config : dump the internal representation of the megatest.config file - -show-runconfig : dump the internal representation of the runconfigs.config file - -dumpmode MODE : dump in MODE format instead of sexpr, MODE=json,ini,sexp etc. (add -debug 0,9 to see which file contributes each line) - -show-cmdinfo : dump the command info for a test (run in test environment) - -section sectionName - -var varName : for config and runconfig lookup value for sectionName varName - -since N : get list of runs changed since time N (Unix seconds) - -fields fieldspec : fields to include in json dump; runs:id,runame+tests:testname+steps - -sort fieldname : in -list-runs sort tests by this field - -testdata-csv [categorypatt/]varpatt : dump testdata for given category - -Misc - -start-dir path : switch to this directory before running megatest - -contour cname : add a level of hierarcy to the linktree and run paths - -area-tag tagname : add a tag to an area while syncing to pgdb - -run-tag tagname : add a tag to a run while syncing to pgdb - -rebuild-db : bring the database schema up to date - -cleanup-db : remove any orphan records, vacuum the db - -import-megatest.db : push data from megatest.db to cache db files in /tmp/$USER - -sync-to-megatest.db : pull data from cache files in /tmp/$USER to megatest.db - -sync-to dest : sync to new postgresql central style database - -update-meta : update the tests metadata for all tests - -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are - overwritten by values set in config files. - -server -|hostname : start the server (reduces contention on megatest.db), use - - to automatically figure out hostname - -adjutant C,M : start the server/adjutant with allocated cores C and Mem M (Gig), - use 0,0 to auto use full machine - -transport http|rpc : use http or rpc for transport (default is http) - -log logfile : send stdout and stderr to logfile - -list-servers : list the servers - -kill-servers : kill all servers - -repl : start a repl (useful for extending megatest) - -load file.scm : load and run file.scm - -mark-incompletes : find and mark incomplete tests - -ping run-id|host:port : ping server, exit with 0 if found - -debug N|N,M,O... : enable debug 0-N or N and M and O ... - -debug-noprop N|M,M,O...: enable debug but do not propagate to subprocesses via MT_DEBUG - -config fname : override the megatest.config file with fname - -append-config fname : append fname to the megatest.config file - -import-sexpr fname : import a sexpr file (use -list-runs % -dumpmode sexpr to create) - -remove-dbs all : remove Megatest DBs before importing sexpr. (Use only with -import-sexpr) - -regen-testfiles : regenerate scripts and logpro files from testconfig, run in test context - -Utilities - -env2file fname : write the environment to fname.csh and fname.sh - -envcap a : save current variables labeled as context 'a' in file envdat.db - -envdelta a-b : output enviroment delta from context a to context b to -o fname - set the output mode with -dumpmode csh, bash or ini - note: ini format will use calls to use curr and minimize path - -refdb2dat refdb : convert refdb to sexp or to format specified by s-dumpmode - formats: perl, ruby, sqlite3, csv (for csv the -o param - will substitute %s for the sheet name in generating - multiple sheets) - -o : output file for refdb2dat (defaults to stdout) - -archive cmd : archive runs specified by selectors to one of disks specified - in the [archive-disks] section. - cmd: keep-html, restore, save, save-remove, get, replicate-db (use - -dest to set destination), -include path1,path2... to get or save specific files - -generate-html : create a simple html dashboard for browsing your runs - -generate-html-structure : create a top level html veiw to list targets/runs and a Run view within each run directory. - -list-run-time : list time requered to complete runs. It supports following switches - -run-patt -target-patt -dumpmode - -list-test-time : list time requered to complete each test in a run. It following following arguments - -runname -target -dumpmode - -syscheck : do some very basic checks; write access and space in tmp, home, runs, links and - is $DISPLAY valid - -list-waivers : dump waivers for specified target, runname, testpatt to stdout - -db2db : sync db to db, use -from, -to for dbs, -period and -timeout for continuous sync - -Diff report - -diff-rep : generate diff report (must include -src-target, -src-runname, -target, -runname - and either -diff-email or -diff-html) - -src-target - -src-runname - -diff-email : comma separated list of email addresses to send diff report - -diff-html : path to html file to generate - -Spreadsheet generation - -extract-ods fname.ods : extract an open document spreadsheet from the database - -pathmod path : insert path, i.e. path/runame/itempath/logfile.html - will clear the field if no rundir/testname/itempath/logfile - if it contains forward slashes the path will be converted - to windows style -Getting started - -create-megatest-area : create a skeleton megatest area. You will be prompted for paths - -create-test testname : create a skeleton megatest test. You will be prompted for info - -Examples - -# Get test path, use '.' to get a single path or a specific path/file pattern -megatest -test-files 'logs/*.log' -target ubuntu/n%/no% -runname w49% -testpatt test_mt% - -Called as " (string-intersperse (argv) " ") " -Version " megatest-version ", built from " megatest-fossil-hash )) - -;; -gui : start a gui interface -;; -config fname : override the runconfigs file with fname - -;; process args -(define remargs (args:get-args - (argv) - (list "-runtests" ;; run a specific test - "-config" ;; override the config file name - "-append-config" - "-execute" ;; run the command encoded in the base64 parameter - "-step" - "-target" - "-reqtarg" - ":runname" - "-runname" - ":state" - "-state" - ":status" - "-status" - "-list-runs" - "-testdata-csv" - "-testpatt" - ;; "--modepatt" - "-modepatt" - "-tagexpr" - "-itempatt" - "-setlog" - "-set-toplog" - "-runstep" - "-logpro" - "-m" - "-rerun" - - "-days" - "-rename-run" - "-from" - "-to" - "-dest" - "-source" - "-time-stamp" - ;; values and messages - ":category" - ":variable" - ":value" - ":expected" - ":tol" - ":units" - - ;; misc - "-start-dir" - "-run-patt" - "-target-patt" - "-contour" - "-area-tag" - "-area" - "-run-tag" - "-server" - "-adjutant" - "-transport" - "-port" - "-extract-ods" - "-pathmod" - "-env2file" - "-envcap" - "-envdelta" - "-setvars" - "-set-state-status" - "-import-sexpr" - "-remove-dbs" ;; to be used only with -import-sexpr to remove megatest dbs first. - "-period" ;; sync period in seconds - "-timeout" ;; exit sync if timeout in seconds exceeded since last change - - ;; move runs stuff here - "-remove-keep" - "-set-run-status" - "-age" - - ;; archive - "-archive" - "-actions" - "-precmd" - "-include" - "-exclude-rx" - "-exclude-rx-from" - - "-debug" ;; for *verbosity* > 2 - "-debug-noprop" - "-create-test" - "-override-timeout" - "-test-files" ;; -test-paths is for listing all - "-load" ;; load and exectute a scheme file - "-section" - "-var" - "-dumpmode" - "-run-id" - "-db" - "-ping" - "-refdb2dat" - "-o" - "-log" - "-sync-log" - "-since" - "-fields" - "-recover-test" ;; run-id,test-id - used internally to recover a test stuck in RUNNING state - "-sort" - "-target-db" - "-source-db" - "-prefix-target" - - "-src-target" - "-src-runname" - "-diff-email" - "-sync-to" - "-pgsync" - "-kill-wait" ;; wait this long before removing test (default is 10 sec) - "-diff-html" - - ;; wizards, area capture, setup new ... - "-extract-skeleton" - ) - (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" - "-no-cache" - "-cache-db" - "-cp-eventtime-to-publishtime" - "-use-db-cache" - "-prepend-contour" - - - ;; misc - "-repl" - "-lock" - "-unlock" - "-list-servers" - "-kill-servers" - "-run-wait" ;; wait on a run to complete (i.e. no RUNNING) - "-one-pass" ;; - "-local" ;; run some commands using local db access - "-generate-html" - "-generate-html-structure" - "-list-run-time" - "-list-test-time" - "-regen-testfiles" - - ;; misc queries - "-list-disks" - "-list-targets" - "-list-db-targets" - "-show-runconfig" - "-show-config" - "-show-cmdinfo" - "-get-run-status" - "-list-waivers" - - ;; queries - "-test-paths" ;; get path(s) to a test, ordered by youngest first - - "-runall" ;; run all tests, respects -testpatt, defaults to % - "-run" ;; alias for -runall - "-remove-runs" - "-kill-runs" - "-kill-rerun" - "-keep-records" ;; use with -remove-runs to remove only the run data - "-rebuild-db" - "-cleanup-db" - "-rollup" - "-update-meta" - "-create-megatest-area" - "-mark-incompletes" - - "-convert-to-norm" - "-convert-to-old" - "-import-megatest.db" - "-sync-to-megatest.db" - "-db2db" - "-sync-brute-force" - "-logging" - "-v" ;; verbose 2, more than normal (normal is 1) - "-q" ;; quiet 0, errors/warnings only - - "-diff-rep" - - "-syscheck" - "-obfuscate" - ;; junk placeholder - ;; "-:p" - - ) - args:arg-hash - 0)) - -;; Add args that use remargs here -;; -(if (and (not (null? remargs)) - (not (or - (args:get-arg "-runstep") - (args:get-arg "-envcap") - (args:get-arg "-envdelta") - ) - )) - (debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " "))) - -;; before doing anything else change to the start-dir if provided -;; -(if (args:get-arg "-start-dir") - (if (common:file-exists? (args:get-arg "-start-dir")) - (let ((fullpath (common:real-path (args:get-arg "-start-dir")))) - (setenv "PWD" fullpath) - (change-directory fullpath)) - (begin - (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.") - (exit 1)))) - -;; immediately set MT_TARGET if -reqtarg or -target are available -;; -(let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target")))) - (if targ (setenv "MT_TARGET" targ))) - -;; set the purpose field in procinf - -(procinf-purpose-set! *procinf* (get-purpose args:arg-hash)) -(procinf-mtversion-set! *procinf* megatest-version) - -;; The watchdog is to keep an eye on things like db sync etc. -;; - -;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage -;;(define *watchdog* (make-thread -;; (lambda () -;; (handle-exceptions -;; exn -;; (begin -;; (print-call-chain) -;; (print " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)) -;; (common:watchdog))) -;; "Watchdog thread")) - -;;(if (not (args:get-arg "-server")) -;; (thread-start! *watchdog*)) ;; if starting a server; wait till we get to running state before kicking off watchdog -(let* ((no-watchdog-args - '("-list-runs" - "-testdata-csv" - "-list-servers" - "-server" - "-adjutant" - "-list-disks" - "-list-targets" - "-show-runconfig" - ;;"-list-db-targets" - "-show-runconfig" - "-show-config" - "-show-cmdinfo" - "-cleanup-db" - )) - (no-watchdog-argvals (list '("-archive" . "replicate-db"))) - (start-watchdog-specail-arg-val (let loop ((hed (car no-watchdog-argvals)) - (tail (cdr no-watchdog-argvals))) - ;; (print "hed" hed " arg " (args:get-arg (car hed)) " val:" (cdr hed) " eql" (equal? (args:get-arg (car hed)) (cdr hed))) - (if (equal? (args:get-arg (car hed)) (cdr hed)) - #f - (if (null? tail) - #t - (loop (car tail) (cdr tail)))))) - (no-watchdog-args-vals (filter (lambda (x) x) - (map args:get-arg no-watchdog-args))) - (start-watchdog (and (null? no-watchdog-args-vals) start-watchdog-specail-arg-val))) - ;(print "no-watchdog-args="no-watchdog-args "no-watchdog-args-vals="no-watchdog-args-vals " start-watchdog-specail-arg-val:" start-watchdog-specail-arg-val " start-watchdog:" start-watchdog) -;; (if start-watchdog -;; (thread-start! *watchdog*)) - #t -) - -;; stop the train watchdog -(stop-the-train) - -;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions -(define (open-logfile logpath-in) - (condition-case - (let* ((log-dir (or (pathname-directory logpath-in) ".")) - (fname (pathname-strip-directory logpath-in)) - (logpath (if (> (string-length fname) 250) - (let ((newlogf (conc log-dir "/" (common:get-signature fname) ".log"))) - (debug:print 0 *default-log-port* "WARNING: log file " logpath-in " path too long, converted to " newlogf) - newlogf) - logpath-in))) - (if (not (directory-exists? log-dir)) - (system (conc "mkdir -p " log-dir))) - (open-output-file logpath)) - (exn () - (debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath) - (define *didsomething* #t) - (exit 1)))) - -;; this segment will run launch:setup only if -log is not set. This is fairly safe as servers are not -;; manually started and thus should never be started in a non-megatest area. Thus no need to handle situation -;; where (launch:setup) returns #f? -;; -(if (or (args:get-arg "-log")#;(args:get-arg "-server")) ;; redirect the log always when a server - (handle-exceptions - exn - (begin - (print "ERROR: Failed to switch to log output. " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)) - (let* ((tl (or (args:get-arg "-log")(launch:setup))) ;; run launch:setup if -server, ensure we do NOT run launch:setup if -log specified - (dbname (args:get-arg "-db")) ;; for the server logfile name - (logf (or (args:get-arg "-log") ;; use -log unless we are a server, then craft a logfile name - (conc tl "/logs/server-"(or dbname "unk")"-"(current-process-id) "-" (get-host-name) ".log"))) - (oup (open-logfile logf))) - (if (not (args:get-arg "-log")) - (hash-table-set! args:arg-hash "-log" logf)) ;; fake out future queries of -log - (debug:print-info 0 *default-log-port* "Sending log output to " logf) - (set! *default-log-port* oup)))) - -(if (or (args:get-arg "-h") - (args:get-arg "-help") - (args:get-arg "--help")) - (begin - (print help) - (exit))) - -(if (args:get-arg "-manual") - (let* ((htmlviewercmd (or (configf:lookup *configdat* "setup" "htmlviewercmd") - (common:which '("firefox" "arora")))) - (install-home (common:get-install-area)) - (manual-html (conc install-home "/share/docs/megatest_manual.html"))) - (if (and install-home - (common:file-exists? manual-html)) - (system (conc "(" htmlviewercmd " " manual-html " ) &")) - (system (conc "(" htmlviewercmd " http://www.kiatoa.com/cgi-bin/fossils/megatest/doc/tip/docs/manual/megatest_manual.html ) &"))) - (exit))) - -(if (args:get-arg "-version") - (begin - (print (common:version-signature)) ;; (print megatest-version) - (exit))) - -(define *didsomething* #f) - -;; Overall exit handling setup immediately -;; -(if (or (args:get-arg "-process-reap")) - ;; (args:get-arg "-runtests") - ;; (args:get-arg "-execute") - ;; (args:get-arg "-remove-runs") - ;; (args:get-arg "-runstep")) - (let ((original-exit (exit-handler))) - (exit-handler (lambda (#!optional (exit-code 0)) - (printf "Preparing to exit with exit code ~A ...\n" exit-code) - (for-each - - (lambda (pid) - (handle-exceptions - exn - (begin - (printf "process reap failed. exn=~A\n" exn) - #t) - (let-values (((pid-val exit-status exit-code) (process-wait pid #t))) - (if (or (eq? pid-val pid) - (eq? pid-val 0)) - (begin - (printf "Sending signal/term to ~A\n" pid) - (process-signal pid signal/term)))))) - (process:children #f)) - (original-exit exit-code))))) - -;; for some switches always print the command to stderr -;; -(if (args:any-defined? "-run" "-runall" "-remove-runs" "-set-state-status" "-kill-runs" "-kill-rerun") - (debug:print 0 *default-log-port* (string-intersperse (argv) " "))) - - -;;====================================================================== -;; Misc setup stuff -;;====================================================================== - -(debug:setup) - -(if (args:get-arg "-logging")(set! *logging* #t)) - -;;(if (debug:debug-mode 3) ;; we are obviously debugging -;; (set! open-run-close open-run-close-no-exception-handling)) - -(if (args:get-arg "-itempatt") - (let ((newval (conc (args:get-arg "-testpatt") "/" (args:get-arg "-itempatt")))) - (debug:print 0 *default-log-port* "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval) - (hash-table-set! args:arg-hash "-testpatt" newval) - (hash-table-delete! args:arg-hash "-itempatt"))) - -(if (args:get-arg "-runtests") - (debug:print 0 *default-log-port* "WARNING: \"-runtests\" is deprecated. Use \"-run\" with \"-testpatt\" instead")) - -(on-exit std-exit-procedure) - -;;====================================================================== -;; Misc general calls -;;====================================================================== - -(if (and (args:get-arg "-cache-db") - (args:get-arg "-source-db")) - (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) - (set! *didsomething* #t))) - -;; handle a clean-cache request as early as possible -;; -(if (args:get-arg "-clean-cache") - (let ((toppath (launch:setup))) - (set! *didsomething* #t) ;; suppress the help output. - (runs:clean-cache (common:args-get-target) - (args:get-arg "-runname") - toppath))) - -(if (args:get-arg "-env2file") - (begin - (save-environment-as-files (args:get-arg "-env2file")) - (set! *didsomething* #t))) - -(if (args:get-arg "-list-disks") - (let ((toppath (launch:setup))) - (print (string-intersperse - (map (lambda (x) - (string-intersperse - x - " => ")) - (common:get-disks *configdat*)) - "\n")) - (set! *didsomething* #t))) - -;; csv processing record -(define (make-refdb:csv) - (vector - (make-sparse-array) - (make-hash-table) - (make-hash-table) - 0 - 0)) -(define-inline (refdb:csv-get-svec vec) (vector-ref vec 0)) -(define-inline (refdb:csv-get-rows vec) (vector-ref vec 1)) -(define-inline (refdb:csv-get-cols vec) (vector-ref vec 2)) -(define-inline (refdb:csv-get-maxrow vec) (vector-ref vec 3)) -(define-inline (refdb:csv-get-maxcol vec) (vector-ref vec 4)) -(define-inline (refdb:csv-set-svec! vec val)(vector-set! vec 0 val)) -(define-inline (refdb:csv-set-rows! vec val)(vector-set! vec 1 val)) -(define-inline (refdb:csv-set-cols! vec val)(vector-set! vec 2 val)) -(define-inline (refdb:csv-set-maxrow! vec val)(vector-set! vec 3 val)) -(define-inline (refdb:csv-set-maxcol! vec val)(vector-set! vec 4 val)) - -(define (get-dat results sheetname) - (or (hash-table-ref/default results sheetname #f) - (let ((tmp-vec (make-refdb:csv))) - (hash-table-set! results sheetname tmp-vec) - tmp-vec))) - -(if (args:get-arg "-refdb2dat") - (let* ((input-db (args:get-arg "-refdb2dat")) - (out-file (args:get-arg "-o")) - (out-fmt (or (args:get-arg "-dumpmode") "scheme")) - (out-port (if (and out-file - (not (member out-fmt '("sqlite3" "csv")))) - (open-output-file out-file) - (current-output-port))) - (res-data (configf:read-refdb input-db)) - (data (car res-data)) - (msg (cadr res-data))) - (if (not data) - (debug:print 0 *default-log-port* "Bad input? data=" data) ;; some error occurred - (with-output-to-port out-port - (lambda () - (case (string->symbol out-fmt) - ((scheme)(pp data)) - ((perl) - ;; (print "%hash = (") - ;; key1 => 'value1', - ;; key2 => 'value2', - ;; key3 => 'value3', - ;; ); - (configf:map-all-hier-alist - data - (lambda (sheetname sectionname varname val) - (print "$data{\"" sheetname "\"}{\"" sectionname "\"}{\"" varname "\"} = \"" val "\";")))) - ((python ruby) - (print "data={}") - (configf:map-all-hier-alist - data - (lambda (sheetname sectionname varname val) - (print "data[\"" sheetname "\"][\"" sectionname "\"][\"" varname "\"] = \"" val "\"")) - initproc1: - (lambda (sheetname) - (print "data[\"" sheetname "\"] = {}")) - initproc2: - (lambda (sheetname sectionname) - (print "data[\"" sheetname "\"][\"" sectionname "\"] = {}")))) - ((csv) - (let* ((results (make-hash-table)) ;; (make-sparse-array))) - (row-cols (make-hash-table))) ;; hash of hashes where section => ht { row- => num or col- => num - ;; (print "data=") - ;; (pp data) - (configf:map-all-hier-alist - data - (lambda (sheetname sectionname varname val) - ;; (print "sheetname: " sheetname ", sectionname: " sectionname ", varname: " varname ", val: " val) - (let* ((dat (get-dat results sheetname)) - (vec (refdb:csv-get-svec dat)) - (rownames (refdb:csv-get-rows dat)) - (colnames (refdb:csv-get-cols dat)) - (currrown (hash-table-ref/default rownames varname #f)) - (currcoln (hash-table-ref/default colnames sectionname #f)) - (rown (or currrown - (let* ((lastn (refdb:csv-get-maxrow dat)) - (newrown (+ lastn 1))) - (refdb:csv-set-maxrow! dat newrown) - newrown))) - (coln (or currcoln - (let* ((lastn (refdb:csv-get-maxcol dat)) - (newcoln (+ lastn 1))) - (refdb:csv-set-maxcol! dat newcoln) - newcoln)))) - (if (not (sparse-array-ref vec 0 coln)) ;; (eq? rown 0) - (begin - (sparse-array-set! vec 0 coln sectionname) - ;; (print "sparse-array-ref " 0 "," coln "=" (sparse-array-ref vec 0 coln)) - )) - (if (not (sparse-array-ref vec rown 0)) ;; (eq? coln 0) - (begin - (sparse-array-set! vec rown 0 varname) - ;; (print "sparse-array-ref " rown "," 0 "=" (sparse-array-ref vec rown 0)) - )) - (if (not currrown)(hash-table-set! rownames varname rown)) - (if (not currcoln)(hash-table-set! colnames sectionname coln)) - ;; (print "dat=" dat ", rown=" rown ", coln=" coln) - (sparse-array-set! vec rown coln val) - ;; (print "sparse-array-ref " rown "," coln "=" (sparse-array-ref vec rown coln)) - ))) - (for-each - (lambda (sheetname) - (let* ((sheetdat (get-dat results sheetname)) - (svec (refdb:csv-get-svec sheetdat)) - (maxrow (refdb:csv-get-maxrow sheetdat)) - (maxcol (refdb:csv-get-maxcol sheetdat)) - (fname (if out-file - (string-substitute "%s" sheetname out-file) ;; "/foo/bar/%s.csv") - (conc sheetname ".csv")))) - (with-output-to-file fname - (lambda () - ;; (print "Sheetname: " sheetname) - (let loop ((row 0) - (col 0) - (curr-row '()) - (result '())) - (let* ((val (sparse-array-ref svec row col)) - (disp-val (if val - (conc "\"" val "\"") - ""))) - (if (> col 0)(display ",")) - (display disp-val) - (cond - ((> row maxrow)(display "\n") result) - ((>= col maxcol) - (display "\n") - (loop (+ row 1) 0 '() (append result (list curr-row)))) - (else - (loop row (+ col 1) (append curr-row (list val)) result))))))))) - (hash-table-keys results)))) - ((sqlite3) - (let* ((db-file (or out-file (pathname-file input-db))) - (db-exists (common:file-exists? db-file)) - (db (sqlite3:open-database db-file))) - (if (not db-exists)(sqlite3:execute db "CREATE TABLE data (sheet,section,var,val);")) - (configf:map-all-hier-alist - data - (lambda (sheetname sectionname varname val) - (sqlite3:execute db - "INSERT OR REPLACE INTO data (sheet,section,var,val) VALUES (?,?,?,?);" - sheetname sectionname varname val))) - (sqlite3:finalize! db))) - (else - (pp data)))))) - (if out-file (close-output-port out-port)) - (exit) ;; yes, bending the rules here - need to exit since this is a utility - )) - -(if (args:get-arg "-ping") - (let* ((server-id (string->number (args:get-arg "-ping"))) ;; extract run-id (i.e. no ":" - (host:port (args:get-arg "-ping"))) - (debug:print 0 *default-log-port* "NOT YET REIMPLEMENTED FOR TCP/INMEM") ;; bug - (exit))) - ;; (server:ping (or server-id host:port) #f do-exit: #t))) - -;;====================================================================== -;; Capture, save and manipulate environments -;;====================================================================== - -;; NOTE: Keep these above the section where the server or client code is setup - -(let ((envcap (args:get-arg "-envcap"))) - (if envcap - (let* ((db (env:open-db (if (null? remargs) "envdat.db" (car remargs))))) - (env:save-env-vars db envcap) - (env:close-database db) - (set! *didsomething* #t)))) - -;; delta "language" will eventually be res=a+b-c but for now it is just res=a-b -;; -(let ((envdelta (args:get-arg "-envdelta"))) - (if envdelta - (let ((match (string-split envdelta "-")));; (string-match "([a-z0-9_]+)=([a-z0-9_\\-,]+)" envdelta))) - (if (not (null? match)) - (let* ((db (env:open-db (if (null? remargs) "envdat.db" (car remargs)))) - ;; (resctx (cadr match)) - ;; (equn (caddr match)) - (parts match) ;; (string-split equn "-")) - (minuend (car parts)) - (subtraend (cadr parts)) - (added (env:get-added db minuend subtraend)) - (removed (env:get-removed db minuend subtraend)) - (changed (env:get-changed db minuend subtraend))) - ;; (pp (hash-table->alist added)) - ;; (pp (hash-table->alist removed)) - ;; (pp (hash-table->alist changed)) - (if (args:get-arg "-o") - (with-output-to-file - (args:get-arg "-o") - (lambda () - (env:print added removed changed))) - (env:print added removed changed)) - (env:close-database db) - (set! *didsomething* #t)) - (debug:print-error 0 *default-log-port* "Parameter to -envdelta should be new=start-end"))))) - -;;====================================================================== -;; Start the server - can be done in conjunction with -runall or -runtests (one day...) -;; we start the server if not running else start the client thread -;;====================================================================== - -;; Server? Start up here. -;; -(if (args:get-arg "-server") - (let* (;; (run-id (args:get-arg "-run-id")) - (dbfname (args:get-arg "-db")) - (tl (launch:setup)) - (keys (keys:config-get-fields *configdat*))) - (case (rmt:transport-mode) - ((tcp) - (let* ((timeout (server:expiration-timeout))) - (debug:print 0 *default-log-port* "INFO: megatest -server starting on " (get-host-name) " for " dbfname " using tcp method with timeout of "timeout) - (tt-server-timeout-param timeout) - (api:queue-processor) - (thread-start! (make-thread api:print-db-stats "print-db-stats")) - (if dbfname - (tt:start-server tl #f dbfname api:tcp-dispatch-request-make-handler keys) - (begin - (debug:print 0 *default-log-port* "ERROR: transport mode is tcp - -db is required.") - (exit 1))))) - (else (debug:print 0 *default-log-port* "ERROR: rmt:transport-mode value not recognised "(rmt:transport-mode)))) - (set! *didsomething* #t))) - -;; The adjutant is a bit different, it does NOT run (launch:setup) as it is not necessarily tied to -;; a specific Megatest area. Detail are being hashed out and this may change. -;; -(if (args:get-arg "-adjutant") - (begin - (adjutant-run) - (set! *didsomething* #t))) - -(if (args:get-arg "-list-servers") - (let* ((tl (launch:setup)) ;; need this to initialize *toppath* - (servdir (tt:get-servinfo-dir *toppath*)) - (servfiles (glob (conc servdir "/*:*.db"))) - (fmtstr "~10a~22a~10a~25a~25a~8a\n") - (dbfiles (append (glob (conc *toppath* "/.mtdb/main.db")) (glob (conc *toppath* "/.mtdb/?.db"))(glob (conc *toppath* "/.mtdb/??.db")))) - (ttdat (make-tt areapath: *toppath*)) - ) - (format #t fmtstr "DB" "host:port" "PID" "age" "last mod" "state") - (for-each - (lambda (dbfile) - (let* ( - (dbfname (conc (pathname-file dbfile) ".db")) - (sfiles (tt:find-server *toppath* dbfname)) - ) - (for-each - (lambda (sfile) - (let ( - (sinfos (tt:get-server-info-sorted ttdat dbfname)) - ) - (for-each - (lambda (sinfo) - (let* ( - (db (list-ref sinfo 5)) - (pid (list-ref sinfo 4)) - (host (list-ref sinfo 0)) - (port (list-ref sinfo 1)) - (server-id (list-ref sinfo 3)) - (age (seconds->hr-min-sec (- (current-seconds) (list-ref sinfo 2)))) - (last-mod (seconds->string (list-ref sinfo 2))) - (status (system (conc "ssh " host " ps " pid " > /dev/null"))) - (state (if (> status 0) - "dead" - (tt:ping host port server-id 0) - )) - ) - (format #t fmtstr db (conc host ":" port) pid age last-mod state) - ) - ) - sinfos - ) - ) - ) - sfiles - ) - ) - ) - dbfiles - ) - (set! *didsomething* #t) - (exit) - ) -) - - - - -(if (args:get-arg "-kill-servers") - - (let* ((tl (launch:setup)) ;; need this to initialize *toppath* - (servdir (tt:get-servinfo-dir *toppath*)) - (servfiles (glob (conc servdir "/*:*.db"))) - (fmtstr "~10a~22a~10a~25a~25a~8a\n") - (dbfiles (if (file-exists? (conc *toppath* "/.mtdb/main.db")) (append (glob (conc *toppath* "/.mtdb/main.db")) (glob (conc *toppath* "/.mtdb/?.db"))(glob (conc *toppath* "/.mtdb/??.db"))) '())) - (ttdat (make-tt areapath: *toppath*)) - ) - (format #t fmtstr "DB" "host:port" "PID" "age" "last mod" "state") - (for-each - (lambda (dbfile) - (let* ( - (dbfname (conc (pathname-file dbfile) ".db")) - (sfiles (tt:find-server *toppath* dbfname)) - ) - (for-each - (lambda (sfile) - (let ( - (sinfos (tt:get-server-info-sorted ttdat dbfname)) - ) - (for-each - (lambda (sinfo) - (let* ( - (db (list-ref sinfo 5)) - (pid (list-ref sinfo 4)) - (host (list-ref sinfo 0)) - (port (list-ref sinfo 1)) - (server-id (list-ref sinfo 3)) - (age (seconds->hr-min-sec (- (current-seconds) (list-ref sinfo 2)))) - (last-mod (seconds->string (list-ref sinfo 2))) - (killed (system (conc "ssh " host " kill " pid " > /dev/null"))) - (dummy2 (sleep 1)) - (state (if (> (system (conc "ssh " host " ps " pid " > /dev/null")) 0) "dead" "alive")) - ) - (format #t fmtstr db (conc host ":" port) pid age last-mod state) - (system (conc "rm " sfile)) - ) - ) - sinfos - ) - ) - ) - sfiles - ) - ) - ) - dbfiles - ) - ;; remove this db, because otherwise metadata contains records for old servers, and this causes a problem with db:no-sync-get-lock-with-id. - (if (file-exists? (conc *toppath* "/.mtdb/no-sync.db")) - (delete-file (conc *toppath* "/.mtdb/no-sync.db")) - ) - (set! *didsomething* #t) - (exit) - ) -) - -;;====================================================================== -;; Weird special calls that need to run *after* the server has started? -;;====================================================================== - -(if (args:get-arg "-list-targets") - (if (launch:setup) - (let ((targets (common:get-runconfig-targets))) - ;; (debug:print 1 *default-log-port* "Found "(length targets) " targets") - (case (string->symbol (or (args:get-arg "-dumpmode") "alist")) - ((alist) - (for-each (lambda (x) - ;; (print "[" x "]")) - (print x)) - targets)) - ((json) - (json-write targets)) - (else - (debug:print-error 0 *default-log-port* "dump output format " (args:get-arg "-dumpmode") " not supported for -list-targets"))) - (set! *didsomething* #t)))) - -(if (args:get-arg "-show-runconfig") - (let ((tl (launch:setup))) - (push-directory *toppath*) - (let ((data (full-runconfigs-read))) - ;; keep this one local - (cond - ((and (args:get-arg "-section") - (args:get-arg "-var")) - (let ((val (or (configf:lookup data (args:get-arg "-section")(args:get-arg "-var")) - (configf:lookup data "default" (args:get-arg "-var"))))) - (if val (print val)))) - ((or (not (args:get-arg "-dumpmode")) - (string=? (args:get-arg "-dumpmode") "ini")) - (configf:config->ini data)) - ((string=? (args:get-arg "-dumpmode") "sexp") - (pp (hash-table->alist data))) - ((string=? (args:get-arg "-dumpmode") "json") - (json-write data)) - (else - (debug:print-error 0 *default-log-port* "-dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) - (set! *didsomething* #t)) - (pop-directory))) - -(if (args:get-arg "-show-config") - (let ((tl (launch:setup)) - (data *configdat*)) ;; (read-config "megatest.config" #f #t))) - (push-directory *toppath*) - ;; keep this one local - (cond - ((and (args:get-arg "-section") - (args:get-arg "-var")) - (let ((val (configf:lookup data (args:get-arg "-section")(args:get-arg "-var")))) - (if val (print val)))) - - ;; print just a section if only -section - - ((equal? (args:get-arg "-dumpmode") "sexp") - (pp (hash-table->alist data))) - ((equal? (args:get-arg "-dumpmode") "json") - (json-write data)) - ((or (not (args:get-arg "-dumpmode")) - (string=? (args:get-arg "-dumpmode") "ini")) - (configf:config->ini data)) - (else - (debug:print-error 0 *default-log-port* "-dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) - (set! *didsomething* #t) - (pop-directory) - (set! *time-to-exit* #t))) - -(if (args:get-arg "-show-cmdinfo") - (if (or (args:get-arg ":value")(getenv "MT_CMDINFO")) - (let ((data (common:read-encoded-string (or (args:get-arg ":value")(getenv "MT_CMDINFO"))))) - (if (equal? (args:get-arg "-dumpmode") "json") - (json-write data) - (pp data)) - (set! *didsomething* #t)) - (debug:print-info 0 *default-log-port* "environment variable MT_CMDINFO is not set"))) - -;;====================================================================== -;; Remove old run(s) -;;====================================================================== - -;; since several actions can be specified on the command line the removal -;; is done first -(define (operate-on action #!key (mode #f)(target-in #f)(runname-in #f)(keys-in #f)(keyvals-in #f)) ;; #f is "use default" - (let* ((runrec (runs:runrec-make-record)) - (target (or target-in (common:args-get-target))) ;; eventually get rid of the call to common:args-get-target - (runname (or runname-in - (args:get-arg "-runname"))) ;; eventually get rid of the get-arg calls - (testpatt (or (args:get-arg "-testpatt") - (and (eq? action 'archive) ;; if it is an archive command fallback to MT_TEST_NAME and MT_ITEMPATH - (common:get-full-test-name)) - (and (eq? action 'kill-runs) - "%/%") ;; I'm just guessing that this is correct :( - (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt"))) - ))) ;; - (cond - ((not target) - (debug:print-error 0 *default-log-port* "Missing required parameter for " - action ", you must specify -target or -reqtarg") - (exit 1)) - ((not runname) - (debug:print-error 0 *default-log-port* "Missing required parameter for " - action ", you must specify the run name pattern with -runname patt") - (exit 2)) - ((not testpatt) - (debug:print-error 0 *default-log-port* "Missing required parameter for " - action ", you must specify the test pattern with -testpatt") - (exit 3)) - (else - (if (not (car *configinfo*)) - (begin - (debug:print-error 0 *default-log-port* "Attempted " action "on test(s) but run area config file not found") - (exit 1)) - ;; put test parameters into convenient variables - (begin - ;; check for correct version, exit with message if not correct - (common:exit-on-version-changed) - (runs:operate-on action - target - runname - testpatt - state: (common:args-get-state) - status: (common:args-get-status) - new-state-status: (args:get-arg "-set-state-status") - mode: mode))) - (set! *didsomething* #t))))) - -(if (args:get-arg "-kill-runs") - (general-run-call - "-kill-runs" - "kill runs" - (lambda (target runname keys keyvals) - (operate-on 'kill-runs mode: #f) - ))) - -(if (args:get-arg "-kill-rerun") - (let* ((target-patt (common:args-get-target)) - (runname-patt (args:get-arg "-runname"))) - (cond ((not target-patt) - (debug:print-error 0 *default-log-port* "Missing target, must specify target for -kill-rerun with -target ") - (exit 1)) - ((not runname-patt) - (debug:print-error 0 *default-log-port* "Missing runname, must specify runname for -kill-rerun with -runname ") - (exit 1)) - ((string-search "[ ,%]" target-patt) - (debug:print-error 0 *default-log-port* "Invalid target ["target-patt"], must specify exact target (no wildcards) for -kill-rerun with -target ") - (exit 1)) - ((string-search "[ ,%]" runname-patt) - (debug:print-error 0 *default-log-port* "Invalid runname ["runname-patt"], must specify exact runname (no wildcards) for -kill-rerun with -runname ") - (exit 1)) - (else - (general-run-call - "-kill-runs" - "kill runs" - (lambda (target runname keys keyvals) - (operate-on 'kill-runs mode: #f) - )) - - (thread-sleep! 15)) - ;; fall thru and let "-run" loop fire - ))) - - -(if (args:get-arg "-remove-runs") - (general-run-call - "-remove-runs" - "remove runs" - (lambda (target runname keys keyvals) - (operate-on 'remove-runs mode: (if (args:get-arg "-keep-records") - 'remove-data-only - 'remove-all))))) - -(if (args:get-arg "-remove-keep") - (general-run-call - "-remove-keep" - "remove keep" - (lambda (target runname keys keyvals) - (let ((actions (map string->symbol - (string-split - (or (args:get-arg "-actions") - "print") - ",")))) ;; default to printing the output - (runs:remove-all-but-last-n-runs-per-target target runname - (string->number (args:get-arg "-remove-keep")) - actions: actions))))) - -(if (args:get-arg "-set-state-status") - (general-run-call - "-set-state-status" - "set state and status" - (lambda (target runname keys keyvals) - (operate-on 'set-state-status)))) - -(if (or (args:get-arg "-set-run-status") - (args:get-arg "-get-run-status")) - (general-run-call - "-set-run-status" - "set run status" - (lambda (target runname keys keyvals) - (let* ((runsdat (rmt:get-runs-by-patt keys runname - (common:args-get-target) - #f #f #f #f)) - (header (vector-ref runsdat 0)) - (rows (vector-ref runsdat 1))) - (if (null? rows) - (begin - (debug:print-info 0 *default-log-port* "No matching run found.") - (exit 1)) - (let* ((row (car (vector-ref runsdat 1))) - (run-id (db:get-value-by-header row header "id"))) - (if (args:get-arg "-set-run-status") - (rmt:set-run-status run-id (args:get-arg "-set-run-status") msg: (args:get-arg "-m")) - (print (rmt:get-run-status run-id)) - ))))))) - -;;====================================================================== -;; Query runs -;;====================================================================== - -;; -fields runs:id,target,runname,comment+tests:id,testname,item_path+steps -;; -;; csi> (extract-fields-constraints "runs:id,target,runname,comment+tests:id,testname,item_path+steps") -;; => (("runs" "id" "target" "runname" "comment") ("tests" "id" "testname" "item_path") ("steps")) -;; -;; NOTE: remember that the cdr will be the list you expect (cdr ("runs" "id" "target" "runname" "comment")) => ("id" "target" "runname" "comment") -;; and so alist-ref will yield what you expect -;; -(define (extract-fields-constraints fields-spec) - (map (lambda (table-spec) ;; runs:id,target,runname - (let ((dat (string-split table-spec ":"))) ;; ("runs" "id,target,runname") - (if (> (length dat) 1) - (cons (car dat)(string-split (cadr dat) ",")) ;; "id,target,runname" - dat))) - (string-split fields-spec "+"))) - -(define (get-value-by-fieldname datavec test-field-index fieldname) - (let ((indx (hash-table-ref/default test-field-index fieldname #f))) - (if indx - (if (>= indx (vector-length datavec)) - #f ;; index too high, should raise an error I suppose - (vector-ref datavec indx)) - #f))) - - - - - -(when (args:get-arg "-testdata-csv") - (if (launch:setup) - (let* ((keys (rmt:get-keys)) ;; (db:get-keys dbstruct)) - (runpatt (or (args:get-arg "-runname") "%")) - (testpatt (common:args-get-testpatt #f)) - (datapatt (args:get-arg "-testdata-csv")) - (match-data (string-match "^([^/]+)/(.*)" (args:get-arg "-testdata-csv"))) - (categorypatt (if match-data (list-ref match-data 1) "%")) - (setvarpatt (if match-data - (list-ref match-data 2) - (args:get-arg "-testdata-csv"))) - (runsdat (rmt:get-runs-by-patt keys (or runpatt "%") - (common:args-get-target) #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0)) - (header (db:get-header runsdat)) - (access-mode (db:get-access-mode)) - (testpatt (common:args-get-testpatt #f)) - (fields-spec (if (args:get-arg "-fields") - (extract-fields-constraints (args:get-arg "-fields")) - (list (cons "runs" (append keys (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count"))) - (cons "tests" db:test-record-fields) ;; "id" "testname" "test_path") - (list "steps" "id" "stepname")))) - (tests-spec (let ((t (alist-ref "tests" fields-spec equal?))) - (if (and t (null? t)) ;; all fields - db:test-record-fields - t))) - (adj-tests-spec (delete-duplicates (if tests-spec (cons "id" tests-spec) db:test-record-fields))) - (test-field-index (make-hash-table)) - (runs (db:get-rows runsdat)) - ) - (if (and tests-spec (not (null? tests-spec))) ;; do some validation and processing of the test-spec - (let ((invalid-tests-spec (filter (lambda (x)(not (member x db:test-record-fields))) tests-spec))) - (if (null? invalid-tests-spec) - ;; generate the lookup map test-field-name => index-number - (let loop ((hed (car adj-tests-spec)) - (tal (cdr adj-tests-spec)) - (idx 0)) - (hash-table-set! test-field-index hed idx) - (if (not (null? tal))(loop (car tal)(cdr tal)(+ idx 1)))) - (begin - (debug:print-error 0 *default-log-port* "Invalid test fields specified: " (string-intersperse invalid-tests-spec ", ")) - (exit))))) - (let* ((table-header (string-split "target,run,test,itempath,category,var,value,comment" ",")) - (table-rows - (apply append (map - (lambda (run) - (let* ((target (string-intersperse (map (lambda (x) - (db:get-value-by-header run header x)) - keys) "/")) - (statuses (string-split (or (args:get-arg "-status") "") ",")) - (run-id (db:get-value-by-header run header "id")) - (runname (db:get-value-by-header run header "runname")) - (states (string-split (or (args:get-arg "-state") "") ",")) - (tests (if tests-spec - (rmt:get-tests-for-run run-id testpatt states statuses #f #f #f 'testname 'asc ;; (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc - ;; use qryvals if test-spec provided - (if tests-spec - (string-intersperse adj-tests-spec ",") - ;; db:test-record-fields - #f) - #f - 'normal) - '()))) - (apply append - (map - (lambda (test) - (let* ( - (test-id (if (member "id" tests-spec)(get-value-by-fieldname test test-field-index "id" ) #f)) ;; (db:test-get-id test)) - (testname (if (member "testname" tests-spec)(get-value-by-fieldname test test-field-index "testname" ) #f)) ;; (db:test-get-testname test)) - (itempath (if (member "item_path" tests-spec)(get-value-by-fieldname test test-field-index "item_path" ) #f)) ;; (db:test-get-item-path test)) - (fullname (conc testname - (if (equal? itempath "") - "" - (conc "/" itempath )))) - (testdat-raw (map vector->list (rmt:read-test-data-varpatt run-id test-id categorypatt setvarpatt))) - (testdat (filter - (lambda (x) - (not (equal? "logpro" - (list-ref x 10)))) - testdat-raw))) - (map - (lambda (item) - (receive (id test_id category - variable value expected - tol units comment status type) - (apply values item) - (list target runname testname itempath category variable value comment))) - testdat))) - tests)))) - runs)))) - (print (string-join table-header ",")) - (for-each (lambda(table-row) - (print (string-join (map ->string table-row) ","))) - - - table-rows)))) - (set! *didsomething* #t) - (set! *time-to-exit* #t)) - - - -;; NOTE: list-runs and list-db-targets operate on local db!!! -;; -;; IDEA: megatest list -runname blah% ... -;; -(if (or (args:get-arg "-list-runs") - (args:get-arg "-list-db-targets")) - (if (launch:setup) - (let* ((runpatt (args:get-arg "-list-runs")) - (access-mode (db:get-access-mode)) - (testpatt (common:args-get-testpatt #f)) - ;; (if (args:get-arg "-testpatt") - ;; (args:get-arg "-testpatt") - ;; "%")) - (keys (rmt:get-keys)) ;; (db:get-keys dbstruct)) - ;; (runsdat (db:get-runs dbstruct runpatt #f #f '())) - ;; (runsdat (rmt:get-runs-by-patt keys (or runpatt "%") (common:args-get-target) ;; (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target) - ;; #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0)) - (runsdat (rmt:get-runs-by-patt keys (or runpatt "%") - (common:args-get-target) #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0)) - (runstmp (db:get-rows runsdat)) - (header (db:get-header runsdat)) - ;; this is "-since" support. This looks at last mod times of .db files - ;; and collects those modified since the -since time. - (runs runstmp) - ;; (if (and (not (null? runstmp)) - ;; (args:get-arg "-since")) - ;; (let ((changed-ids (db:get-changed-run-ids (string->number (args:get-arg "-since"))))) - ;; (let loop ((hed (car runstmp)) - ;; (tal (cdr runstmp)) - ;; (res '())) - ;; (let ((new-res (if (member (db:get-value-by-header hed header "id") changed-ids) - ;; (cons hed res) - ;; res))) - ;; (if (null? tal) - ;; (reverse new-res) - ;; (loop (car tal)(cdr tal) new-res))))) - ;; runstmp)) - (db-targets (args:get-arg "-list-db-targets")) - (seen (make-hash-table)) - (dmode (let ((d (args:get-arg "-dumpmode"))) ;; json, sexpr - (if d (string->symbol d) #f))) - (data (make-hash-table)) - (fields-spec (if (args:get-arg "-fields") - (extract-fields-constraints (args:get-arg "-fields")) - (list (cons "runs" (append keys (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count"))) - (cons "tests" db:test-record-fields) ;; "id" "testname" "test_path") - (list "steps" "id" "stepname")))) - (runs-spec (let ((r (alist-ref "runs" fields-spec equal?))) ;; the check is now unnecessary - (if (and r (not (null? r))) r (list "id" )))) - (tests-spec (let ((t (alist-ref "tests" fields-spec equal?))) - (if (and t (null? t)) ;; all fields - db:test-record-fields - t))) - (adj-tests-spec (delete-duplicates (if tests-spec (cons "id" tests-spec) db:test-record-fields))) ;; '("id")))) - (steps-spec (alist-ref "steps" fields-spec equal?)) - (test-field-index (make-hash-table))) - (if (and (args:get-arg "-dumpmode") - (not (member (args:get-arg "-dumpmode") '("sexpr" "json" "ods" "list")))) - (begin - (debug:print 0 *default-log-port* "ERROR: dumpmode "(args:get-arg "-dumpmode")" not recognised. Use sexpr, json, ods or list") - (exit))) - (if (and tests-spec (not (null? tests-spec))) ;; do some validation and processing of the test-spec - (let ((invalid-tests-spec (filter (lambda (x)(not (member x db:test-record-fields))) tests-spec))) - (if (null? invalid-tests-spec) - ;; generate the lookup map test-field-name => index-number - (let loop ((hed (car adj-tests-spec)) - (tal (cdr adj-tests-spec)) - (idx 0)) - (hash-table-set! test-field-index hed idx) - (if (not (null? tal))(loop (car tal)(cdr tal)(+ idx 1)))) - (begin - (debug:print-error 0 *default-log-port* "Invalid test fields specified: " (string-intersperse invalid-tests-spec ", ")) - (exit))))) - ;; Each run - (for-each - (lambda (run) - (let ((targetstr (string-intersperse (map (lambda (x) - (db:get-value-by-header run header x)) - keys) "/"))) - (if db-targets - (if (not (hash-table-ref/default seen targetstr #f)) - (begin - (hash-table-set! seen targetstr #t) - ;; (print "[" targetstr "]")))) - (if (not dmode) - (print targetstr) - (hash-table-set! data "targets" (cons targetstr (hash-table-ref/default data "targets" '()))) - ))) - (let* ((run-id (db:get-value-by-header run header "id")) - (runname (db:get-value-by-header run header "runname")) - (states (string-split (or (args:get-arg "-state") "") ",")) - (statuses (string-split (or (args:get-arg "-status") "") ",")) - (tests (if tests-spec - (rmt:get-tests-for-run run-id testpatt states statuses #f #f #f 'testname 'asc ;; (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc - ;; use qryvals if test-spec provided - (if tests-spec - (string-intersperse adj-tests-spec ",") - ;; db:test-record-fields - #f) - #f - 'normal) - '()))) - (case dmode - ((json ods sexpr) - (if runs-spec - (for-each - (lambda (field-name) - (mutils:hierhash-set! data (conc (db:get-value-by-header run header field-name)) targetstr runname "meta" field-name)) - runs-spec))) - ;; (mutils:hierhash-set! data (db:get-value-by-header run header "status") targetstr runname "meta" "status" ) - ;; (mutils:hierhash-set! data (db:get-value-by-header run header "state") targetstr runname "meta" "state" ) - ;; (mutils:hierhash-set! data (conc (db:get-value-by-header run header "id")) targetstr runname "meta" "id" ) - ;; (mutils:hierhash-set! data (db:get-value-by-header run header "event_time") targetstr runname "meta" "event_time" ) - ;; (mutils:hierhash-set! data (db:get-value-by-header run header "comment") targetstr runname "meta" "comment" ) - ;; ;; add last entry twice - seems to be a bug in hierhash? - ;; (mutils:hierhash-set! data (db:get-value-by-header run header "comment") targetstr runname "meta" "comment" ) - ((#f list) - (if (null? runs-spec) - (print "Run: " targetstr "/" runname - " status: " (db:get-value-by-header run header "state") - " run-id: " run-id ", number tests: " (length tests) - " event_time: " (db:get-value-by-header run header "event_time")) - (begin - (if (not (member "target" runs-spec)) - ;; (display (conc "Target: " targetstr)) - (display (conc "Run: " targetstr "/" runname " "))) - (for-each - (lambda (field-name) - (if (equal? field-name "target") - (display (conc "target: " targetstr " ")) - (display (conc field-name ": " (db:get-value-by-header run header (conc field-name)) " ")))) - runs-spec) - (newline)))) - (else - (debug:print 0 *default-log-port* "ERROR: dumpmode "(args:get-arg "-dumpmode")" not recognised. Use sexpr, json, ods or list") - )) - - (for-each - (lambda (test) - (common:debug-handle-exceptions #f - exn - (begin - (debug:print-error 0 *default-log-port* "Bad data in test record? " test) - (debug:print-error 5 *default-log-port* "exn=" (condition->list exn)) - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - (print-call-chain (current-error-port))) - (let* ((test-id (if (member "id" tests-spec)(get-value-by-fieldname test test-field-index "id" ) #f)) ;; (db:test-get-id test)) - (testname (if (member "testname" tests-spec)(get-value-by-fieldname test test-field-index "testname" ) #f)) ;; (db:test-get-testname test)) - (itempath (if (member "item_path" tests-spec)(get-value-by-fieldname test test-field-index "item_path" ) #f)) ;; (db:test-get-item-path test)) - (comment (if (member "comment" tests-spec)(get-value-by-fieldname test test-field-index "comment" ) #f)) ;; (db:test-get-comment test)) - (tstate (if (member "state" tests-spec)(get-value-by-fieldname test test-field-index "state" ) #f)) ;; (db:test-get-state test)) - (tstatus (if (member "status" tests-spec)(get-value-by-fieldname test test-field-index "status" ) #f)) ;; (db:test-get-status test)) - (event-time (if (member "event_time" tests-spec)(get-value-by-fieldname test test-field-index "event_time" ) #f)) ;; (db:test-get-event_time test)) - (rundir (if (member "rundir" tests-spec)(get-value-by-fieldname test test-field-index "rundir" ) #f)) ;; (db:test-get-rundir test)) - (final_logf (if (member "final_logf" tests-spec)(get-value-by-fieldname test test-field-index "final_logf" ) #f)) ;; (db:test-get-final_logf test)) - (run_duration (if (member "run_duration" tests-spec)(get-value-by-fieldname test test-field-index "run_duration") #f)) ;; (db:test-get-run_duration test)) - (fullname (conc testname - (if (equal? itempath "") - "" - (conc "(" itempath ")"))))) - (case dmode - ((json ods sexpr) - (if tests-spec - (for-each - (lambda (field-name) - (mutils:hierhash-set! data (get-value-by-fieldname test test-field-index field-name) targetstr runname "data" (conc test-id) field-name)) - tests-spec))) - ;; ;; (mutils:hierhash-set! data fullname targetstr runname "data" (conc test-id) "tname" ) - ;; (mutils:hierhash-set! data testname targetstr runname "data" (conc test-id) "testname" ) - ;; (mutils:hierhash-set! data itempath targetstr runname "data" (conc test-id) "itempath" ) - ;; (mutils:hierhash-set! data comment targetstr runname "data" (conc test-id) "comment" ) - ;; (mutils:hierhash-set! data tstate targetstr runname "data" (conc test-id) "state" ) - ;; (mutils:hierhash-set! data tstatus targetstr runname "data" (conc test-id) "status" ) - ;; (mutils:hierhash-set! data rundir targetstr runname "data" (conc test-id) "rundir" ) - ;; (mutils:hierhash-set! data final_logf targetstr runname "data" (conc test-id) "final_logf") - ;; (mutils:hierhash-set! data run_duration targetstr runname "data" (conc test-id) "run_duration") - ;; (mutils:hierhash-set! data event-time targetstr runname "data" (conc test-id) "event_time") - ;; ;; add last entry twice - seems to be a bug in hierhash? - ;; (mutils:hierhash-set! data event-time targetstr runname "data" (conc test-id) "event_time") - ;; ) - (else - (if (and tstate tstatus event-time) - (format #t - " Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n" - (if fullname fullname "") - (if tstate tstate "") - (if tstatus tstatus "") - (get-value-by-fieldname test test-field-index "run_duration");;(if test (db:test-get-run_duration test) "") - (if event-time event-time "") - (get-value-by-fieldname test test-field-index "host")) ;;(if test (db:test-get-host test)) "") - (print " Test: " fullname - (if tstate (conc " State: " tstate) "") - (if tstatus (conc " Status: " tstatus) "") - (if (get-value-by-fieldname test test-field-index "run_duration") - (conc " Runtime: " (get-value-by-fieldname test test-field-index "run_duration")) - "") - (if event-time (conc " Time: " event-time) "") - (if (get-value-by-fieldname test test-field-index "host") - (conc " Host: " (get-value-by-fieldname test test-field-index "host")) - ""))) - (if (not (or (equal? (get-value-by-fieldname test test-field-index "status") "PASS") - (equal? (get-value-by-fieldname test test-field-index "status") "WARN") - (equal? (get-value-by-fieldname test test-field-index "state") "NOT_STARTED"))) - (begin - (print (if (get-value-by-fieldname test test-field-index "cpuload") - (conc " cpuload: " (get-value-by-fieldname test test-field-index "cpuload")) - "") ;; (db:test-get-cpuload test) - (if (get-value-by-fieldname test test-field-index "diskfree") - (conc "\n diskfree: " (get-value-by-fieldname test test-field-index "diskfree")) ;; (db:test-get-diskfree test) - "") - (if (get-value-by-fieldname test test-field-index "uname") - (conc "\n uname: " (get-value-by-fieldname test test-field-index "uname")) ;; (db:test-get-uname test) - "") - (if (get-value-by-fieldname test test-field-index "rundir") - (conc "\n rundir: " (get-value-by-fieldname test test-field-index "rundir")) ;; (db:test-get-rundir test) - "") -;; "\n rundir: " (get-value-by-fieldname test test-field-index "") ;; (sdb:qry 'getstr ;; (filedb:get-path *fdb* -;; (db:test-get-rundir test) ;; ) - ) - ;; Each test - ;; DO NOT remote run - (let ((steps (rmt:get-steps-for-test run-id (db:test-get-id test)))) ;; (db:get-steps-for-test dbstruct run-id (db:test-get-id test)))) - (for-each - (lambda (step) - (format #t - " Step: ~20a State: ~10a Status: ~10a Time ~22a\n" - (tdb:step-get-stepname step) - (tdb:step-get-state step) - (tdb:step-get-status step) - (tdb:step-get-event_time step))) - steps))))))))) - (if (args:get-arg "-sort") - (sort tests - (lambda (a-test b-test) - (let* ((key (args:get-arg "-sort")) - (first (get-value-by-fieldname a-test test-field-index key)) - (second (get-value-by-fieldname b-test test-field-index key))) - ((cond - ((and (number? first)(number? second)) <) - ((and (string? first)(string? second)) string<=?) - (else equal?)) - first second)))) - tests)))))) - runs) - (case dmode - ((json) (json-write data)) - ((sexpr) (pp (common:to-alist data)))) - (let* ((metadat-fields (delete-duplicates - (append keys '( "runname" "time" "owner" "pass_count" "fail_count" "state" "status" "comment" "id")))) - (run-fields '( - "testname" - "item_path" - "state" - "status" - "comment" - "event_time" - "host" - "run_id" - "run_duration" - "attemptnum" - "id" - "archived" - "diskfree" - "cpuload" - "final_logf" - "shortdir" - "rundir" - "uname" - ) - ) - (newdat (common:to-alist data)) - (allrundat (if (null? newdat) - '() - (car (map cdr newdat)))) ;; (car (map cdr (car (map cdr newdat))))) - (runs (append - (list "runs" ;; sheetname - metadat-fields) - (map (lambda (run) - ;; (print "run: " run) - (let* ((runname (car run)) - (rundat (cdr run)) - (metadat (let ((tmp (assoc "meta" rundat))) - (if tmp (cdr tmp) #f)))) - ;; (print "runname: " runname "\n\nrundat: " )(pp rundat)(print "\n\nmetadat: ")(pp metadat) - (if metadat - (map (lambda (field) - (let ((tmp (assoc field metadat))) - (if tmp (cdr tmp) ""))) - metadat-fields) - (begin - (debug:print 0 *default-log-port* "WARNING: meta data for run " runname " not found") - '())))) - allrundat))) - ;; '( ( "target" ( "runname" ( "data" ( "runid" ( "id . "37" ) ( ... )))) - (run-pages (map (lambda (targdat) - (let* ((target (car targdat)) - (runsdat (cdr targdat))) - (if runsdat - (map (lambda (rundat) - (let* ((runname (car rundat)) - (rundat (cdr rundat)) - (testsdat (let ((tmp (assoc "data" rundat))) - (if tmp (cdr tmp) #f)))) - (if testsdat - (let ((tests (map (lambda (test) - (let* ((test-id (car test)) - (test-dat (cdr test))) - (map (lambda (field) - (let ((tmp (assoc field test-dat))) - (if tmp (cdr tmp) ""))) - run-fields))) - testsdat))) - ;; (print "Target: " target "/" runname " tests:") - ;; (pp tests) - (cons (conc target "/" runname) - (cons (list (conc target "/" runname)) - (cons '() - (cons run-fields tests))))) - (begin - (debug:print 4 *default-log-port* "WARNING: run " target "/" runname " appears to have no data") - ;; (pp rundat) - '())))) - runsdat) - '()))) - newdat)) ;; we use newdat to get target - (sheets (filter (lambda (x) - (not (null? x))) - (cons runs (map car run-pages))))) - ;; (print "allrundat:") - ;; (pp allrundat) - ;; (print "runs:") - ;; (pp runs) - ;(print "sheets: ") - ;; (pp sheets) - (if (eq? dmode 'ods) - (let* ((tempdir (conc "/tmp/" (current-user-name) "/" (random 10000) "_" (current-process-id))) - (outputfile (or (args:get-arg "-o") "out.ods")) - (ouf (if (string-match (regexp "^[/~]+.*") outputfile) ;; full path? - outputfile - (begin - (debug:print 0 *default-log-port* "WARNING: path given, " outputfile " is relative, prefixing with current directory") - (conc (current-directory) "/" outputfile))))) - (create-directory tempdir #t) - (ods:list->ods tempdir ouf sheets)))) - ;; (system (conc "rm -rf " tempdir)) - (set! *didsomething* #t) - (set! *time-to-exit* #t) - ) ;; end if true branch (end of a let) - ) ;; end if - ) ;; end if -list-runs - -;; list-waivers -(if (and (args:get-arg "-list-waivers") - (launch:setup)) - (let* ((runpatt (or (args:get-arg "-runname") "%")) - (testpatt (common:args-get-testpatt #f)) - (keys (rmt:get-keys)) - (runsdat (rmt:get-runs-by-patt - keys runpatt - (common:args-get-target) #f #f - '("id" "runname" "state" "status" "owner" "event_time" "comment") 0)) - (runs (db:get-rows runsdat)) - (header (db:get-header runsdat)) - (results (make-hash-table)) ;; [target] ( (testname/itempath . "comment") ... ) - (addtest (lambda (target testname itempath comment) - (hash-table-set! results target (cons (cons (conc testname "/" itempath) comment) - (hash-table-ref/default results target '()))))) - (last-target #f)) - (for-each - (lambda (run) - (let* ((run-id (db:get-value-by-header run header "id")) - (target (rmt:get-target run-id)) - (runname (db:get-value-by-header run header "runname")) - (tests (rmt:get-tests-for-run - run-id testpatt '("COMPLETED") '("WAIVED") #f #f #f 'testname 'asc ;; use qryvals if test-spec provided - #f #f #f))) - (if (not (equal? target last-target)) - (print "[" target "]")) - (set! last-target target) - (print "# " runname) - (for-each - (lambda (testdat) - (let* ((testfullname (conc (db:test-get-testname testdat) - (if (equal? "" (db:test-get-item-path testdat)) - "" - (conc "/" (db:test-get-item-path testdat))) - ))) - (print testfullname " " (db:test-get-comment testdat)))) - tests))) - runs) - (set! *didsomething* #t))) - -;;====================================================================== -;; full run -;;====================================================================== - -(define (handle-run-requests target runname keys keyvals need-clean) - (if (or (args:get-arg "-kill-rerun") (args:get-arg "-rerun-clean")) ;; first set states/statuses correct - ;; For rerun-clean do we or do we not support the testpatt? - (let ((states (or (configf:lookup *configdat* "validvalues" "cleanrerun-states") - "KILLREQ,KILLED,UNKNOWN,INCOMPLETE,STUCK,NOT_STARTED")) - (statuses (or (configf:lookup *configdat* "validvalues" "cleanrerun-statuses") - "FAIL,INCOMPLETE,ABORT,CHECK,DEAD,PREQ_FAIL,PREQ_DISCARDED"))) - (hash-table-set! args:arg-hash "-preclean" #t) - (runs:operate-on 'set-state-status - target - (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) - ;; "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") - (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") - state: states - ;; status: statuses - new-state-status: "NOT_STARTED,n/a") - (runs:clean-cache target runname *toppath*) - (runs:operate-on 'set-state-status - target - (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) - ;; "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") - (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") - ;; state: states - status: statuses - new-state-status: "NOT_STARTED,n/a"))) - ;; RERUN ALL - (if (args:get-arg "-rerun-all") ;; first set states/statuses correct - (let* ((rconfig (full-runconfigs-read))) - (hash-table-set! args:arg-hash "-preclean" #t) - (runs:operate-on 'set-state-status - target - (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) - (common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt") - state: #f - ;; status: statuses - new-state-status: "NOT_STARTED,n/a") - (runs:clean-cache target runname *toppath*) - (runs:operate-on 'set-state-status - target - (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) - (common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt") - ;; state: states - status: #f - new-state-status: "NOT_STARTED,n/a"))) - (let* ((config-reruns (let ((x (configf:lookup *configdat* "setup" "reruns"))) - (if x (string->number x) #f))) - (rerun-cnt (if config-reruns - config-reruns - 1))) - - (runs:run-tests target - runname - #f ;; (common:args-get-testpatt #f) - ;; (or (args:get-arg "-testpatt") - ;; "%") - user - args:arg-hash - run-count: rerun-cnt))) - -;; get lock in db for full run for this directory -;; for all tests with deps -;; walk tree of tests to find head tasks -;; add head tasks to task queue -;; add dependant tasks to task queue -;; add remaining tasks to task queue -;; for each task in task queue -;; if have adequate resources -;; launch task -;; else -;; put task in deferred queue -;; if still ok to run tasks -;; process deferred tasks per above steps - -;; run all tests are are Not COMPLETED and PASS or CHECK -(if (or (args:get-arg "-runall") - (args:get-arg "-run") - (args:get-arg "-rerun-clean") - (args:get-arg "-rerun-all") - (args:get-arg "-runtests") - (args:get-arg "-kill-rerun")) - (let ((need-clean (or (args:get-arg "-rerun-clean") - (args:get-arg "-rerun-all"))) - (orig-cmdline (string-intersperse (argv) " "))) - (general-run-call - "-runall" - "run all tests" - (lambda (target runname keys keyvals) - (if (or (string-search "%" target) - (string-search "%" runname)) ;; we are being asked to re-run multiple runs - (let* ((run-specs (rmt:simple-get-runs runname #f #f target #f))) ;; list of simple-run records - (debug:print-info 0 *default-log-port* "Pattern supplied for target or runname with " - (length run-specs) " matches found. Running each in turn.") - (if (null? run-specs) - (debug:print 0 *default-log-port* "WARNING: No runs match target " target " and runname " runname)) - (for-each (lambda (spec) - (let* ((precmd (if (args:get-arg "-precmd")(conc (args:get-arg "-precmd") " ") "")) - (newcmdline (conc - precmd - (string-substitute - (conc "target " target) - (conc "target " (simple-run-target spec)) - (string-substitute - (conc "runname " runname) - (conc "runname " (simple-run-runname spec)) - orig-cmdline))))) - (debug:print 0 *default-log-port* "ORIG: " orig-cmdline) - (debug:print 0 *default-log-port* "NEW: " newcmdline) - (system newcmdline))) - run-specs)) - (handle-run-requests target runname keys keyvals need-clean)))) - (set! *didsomething* #t))) - -;;====================================================================== -;; run one test -;;====================================================================== - -;; 1. find the config file -;; 2. change to the test directory -;; 3. update the db with "test started" status, set running host -;; 4. process launch the test -;; - monitor the process, update stats in the db every 2^n minutes -;; 5. as the test proceeds internally it calls megatest as each step is -;; started and completed -;; - step started, timestamp -;; - step completed, exit status, timestamp -;; 6. test phone home -;; - if test run time > allowed run time then kill job -;; - if cannot access db > allowed disconnect time then kill job - -;; == duplicated == (if (or (args:get-arg "-run")(args:get-arg "-runtests")) -;; == duplicated == (general-run-call -;; == duplicated == "-runtests" -;; == duplicated == "run a test" -;; == duplicated == (lambda (target runname keys keyvals) -;; == duplicated == ;; -;; == duplicated == ;; May or may not implement it this way ... -;; == duplicated == ;; -;; == duplicated == ;; Insert this run into the tasks queue -;; == duplicated == ;; (open-run-close tasks:add tasks:open-db -;; == duplicated == ;; "runtests" -;; == duplicated == ;; user -;; == duplicated == ;; target -;; == duplicated == ;; runname -;; == duplicated == ;; (args:get-arg "-runtests") -;; == duplicated == ;; #f)))) -;; == duplicated == (runs:run-tests target -;; == duplicated == runname -;; == duplicated == (common:args-get-testpatt #f) ;; (args:get-arg "-runtests") -;; == duplicated == user -;; == duplicated == args:arg-hash)))) - -;;====================================================================== -;; Rollup into a run -;;====================================================================== - -(if (args:get-arg "-rollup") - (general-run-call - "-rollup" - "rollup tests" - (lambda (target runname keys keyvals) - (runs:rollup-run keys - keyvals - (or (args:get-arg "-runname")(args:get-arg ":runname") ) - user)))) - -;;====================================================================== -;; Lock or unlock a run -;;====================================================================== - -(if (or (args:get-arg "-lock")(args:get-arg "-unlock")) - (general-run-call - (if (args:get-arg "-lock") "-lock" "-unlock") - "lock/unlock tests" - (lambda (target runname keys keyvals) - (runs:handle-locking - target - keys - (or (args:get-arg "-runname")(args:get-arg ":runname") ) - (args:get-arg "-lock") - (args:get-arg "-unlock") - user)))) - -;;====================================================================== -;; Get paths to tests -;;====================================================================== -;; Get test paths matching target, runname, and testpatt -(if (or (args:get-arg "-test-files")(args:get-arg "-test-paths")) - ;; if we are in a test use the MT_CMDINFO data - (if (getenv "MT_CMDINFO") - (let* ((startingdir (current-directory)) - (cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) - (transport (assoc/default 'transport cmdinfo)) - (testpath (assoc/default 'testpath cmdinfo)) - (test-name (assoc/default 'test-name cmdinfo)) - (runscript (assoc/default 'runscript cmdinfo)) - (db-host (assoc/default 'db-host cmdinfo)) - (run-id (assoc/default 'run-id cmdinfo)) - (itemdat (assoc/default 'itemdat cmdinfo)) - (state (args:get-arg ":state")) - (status (args:get-arg ":status")) - ;;(target (args:get-arg "-target")) - (target (common:args-get-target)) - (toppath (assoc/default 'toppath cmdinfo))) - (change-directory toppath) - (if (not target) - (begin - (debug:print-error 0 *default-log-port* "-target is required.") - (exit 1))) - (if (not (launch:setup)) - (begin - (debug:print 0 *default-log-port* "Failed to setup, giving up on -test-paths or -test-files, exiting") - (exit 1))) - (let* ((keys (rmt:get-keys)) - ;; db:test-get-paths must not be run remote - (paths (tests:test-get-paths-matching keys target (args:get-arg "-test-files")))) - (set! *didsomething* #t) - (for-each (lambda (path) - (if (common:file-exists? path) - (print path))) - paths))) - ;; else do a general-run-call - (general-run-call - "-test-files" - "Get paths to test" - (lambda (target runname keys keyvals) - (let* ((db #f) - ;; DO NOT run remote - (paths (tests:test-get-paths-matching keys target (args:get-arg "-test-files")))) - (for-each (lambda (path) - (print path)) - paths)))))) - -;;====================================================================== -;; Utils for test areas -;;====================================================================== - -(if (args:get-arg "-regen-testfiles") - (if (getenv "MT_TEST_RUN_DIR") - (begin - (launch:setup) - (change-directory (getenv "MT_TEST_RUN_DIR")) - (let* ((testname (getenv "MT_TEST_NAME")) - (itempath (getenv "MT_ITEMPATH"))) - (launch:extract-scripts-logpro (getenv "MT_TEST_RUN_DIR") testname itempath #f)) - (set! *didsomething* #t)) - (debug:print 0 *default-log-port* "ERROR: Must run -regen-testfiles in a test environment (i.e. test xterm from dashboard)"))) - -;;====================================================================== -;; Archive tests -;;====================================================================== -;; Archive tests matching target, runname, and testpatt -(if (equal? (args:get-arg "-archive") "replicate-db") - (begin - ;; check if source - ;; check if megatest.db exist - (launch:setup) - (if (not (args:get-arg "-source")) - (begin - (debug:print-info 1 *default-log-port* "Missing required argument -source ") - (exit 1))) - (if (common:file-exists? (conc *toppath* "/megatest.db")) - (begin - (debug:print-info 1 *default-log-port* "File " (conc *toppath* "/megatest.db") " already exists. Please remove it before trying to replicate db") - (exit 1))) - (if (and (common:make-tmpdir-name *toppath* "") (> (length (directory (common:make-tmpdir-name *toppath* "") #f)) 0)) - (begin - (debug:print-info 1 *default-log-port* (common:make-tmpdir-name *toppath* "") " not empty. Please remove it before trying to replicate db") - (exit 1))) - ;; check if timestamp - (let* ((source (args:get-arg "-source")) - (src (if (not (equal? (substring source 0 1) "/")) - (conc (current-directory) "/" source) - source)) - (ts (if (args:get-arg "-time-stamp") (args:get-arg "-time-stamp") "latest"))) - (if (common:directory-exists? src) - (begin - (archive:restore-db src ts) - (set! *didsomething* #t)) - (begin - (debug:print-error 1 *default-log-port* "Path " source " not found") - (exit 1)))))) - ;; else do a general-run-call - (if (and (args:get-arg "-archive") (not (equal? (args:get-arg "-archive") "replicate-db"))) - (begin - ;; for the archive get we need to preserve the starting dir as part of the target path - (if (and (args:get-arg "-dest") - (not (equal? (substring (args:get-arg "-dest") 0 1) "/"))) - (let ((newpath (conc (current-directory) "/" (args:get-arg "-dest")))) - (debug:print-info 1 *default-log-port* "Preserving original path to destination, was " (args:get-arg "-dest") ", now " newpath) - (hash-table-set! args:arg-hash "-dest" newpath))) - (general-run-call - "-archive" - "Archive" - (lambda (target runname keys keyvals) - (operate-on 'archive target-in: target runname-in: runname ))))) - -;;====================================================================== -;; Extract a spreadsheet from the runs database -;;====================================================================== - -(if (args:get-arg "-extract-ods") - (general-run-call - "-extract-ods" - "Make ods spreadsheet" - (lambda (target runname keys keyvals) - (let ((dbstruct (make-dbr:dbstruct areapath: *toppath* local: #t)) - (outputfile (args:get-arg "-extract-ods")) - (runspatt (or (args:get-arg "-runname")(args:get-arg ":runname"))) - (pathmod (args:get-arg "-pathmod"))) - ;; (keyvalalist (keys->alist keys "%"))) - (debug:print 2 *default-log-port* "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvals: " keyvals) - (db:extract-ods-file dbstruct outputfile keyvals (if runspatt runspatt "%") pathmod) - (db:close-all dbstruct) - (set! *didsomething* #t))))) - -;;====================================================================== -;; execute the test -;; - gets called on remote host -;; - receives info from the -execute param -;; - passes info to steps via MT_CMDINFO env var (future is to use a dot file) -;; - gathers host info and -;;====================================================================== - -(if (args:get-arg "-execute") - (begin - (launch:execute (args:get-arg "-execute")) - (set! *didsomething* #t))) - -;;====================================================================== -;; recover from a test where the managing mtest was killed but the underlying -;; process might still be salvageable -;;====================================================================== - -(if (args:get-arg "-recover-test") - (let* ((params (string-split (args:get-arg "-recover-test") ","))) - (if (> (length params) 1) ;; run-id and test-id - (let ((run-id (string->number (car params))) - (test-id (string->number (cadr params)))) - (if (and run-id test-id) - (begin - (launch:recover-test run-id test-id) - (set! *didsomething* #t)) - (begin - (debug:print-error 0 *default-log-port* "bad run-id or test-id, must be integers") - (exit 1))))))) - -;;====================================================================== -;; Test commands (i.e. for use inside tests) -;;====================================================================== - -(define (megatest:step step state status logfile msg) - (if (not (getenv "MT_CMDINFO")) - (begin - (debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!") - (exit 5)) - (let* ((cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) - (transport (assoc/default 'transport cmdinfo)) - (testpath (assoc/default 'testpath cmdinfo)) - (test-name (assoc/default 'test-name cmdinfo)) - (runscript (assoc/default 'runscript cmdinfo)) - (db-host (assoc/default 'db-host cmdinfo)) - (run-id (assoc/default 'run-id cmdinfo)) - (test-id (assoc/default 'test-id cmdinfo)) - (itemdat (assoc/default 'itemdat cmdinfo)) - (work-area (assoc/default 'work-area cmdinfo)) - (db #f)) - (change-directory testpath) - (if (not (launch:setup)) - (begin - (debug:print 0 *default-log-port* "Failed to setup, exiting") - (exit 1))) - (if (and state status) - (let ((comment (launch:load-logpro-dat run-id test-id step))) - ;; (rmt:test-set-log! run-id test-id (conc stepname ".html")))) - (rmt:teststep-set-status! run-id test-id step state status (or comment msg) logfile)) - (begin - (debug:print-error 0 *default-log-port* "You must specify :state and :status with every call to -step") - (exit 6)))))) - -(if (args:get-arg "-step") - (begin - (thread-sleep! 1.5) - (megatest:step - (args:get-arg "-step") - (or (args:get-arg "-state")(args:get-arg ":state")) - (or (args:get-arg "-status")(args:get-arg ":status")) - (args:get-arg "-setlog") - (args:get-arg "-m")) - ;; (if db (sqlite3:finalize! db)) - (set! *didsomething* #t) - (thread-sleep! 1.5))) - -(if (or (args:get-arg "-setlog") ;; since setting up is so costly lets piggyback on -test-status - ;; (not (args:get-arg "-step"))) ;; -setlog may have been processed already in the "-step" previous - ;; NEW POLICY - -setlog sets test overall log on every call. - (args:get-arg "-set-toplog") - (args:get-arg "-test-status") - (args:get-arg "-set-values") - (args:get-arg "-load-test-data") - (args:get-arg "-runstep") - (args:get-arg "-summarize-items")) - (if (not (getenv "MT_CMDINFO")) - (begin - (debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!") - (exit 5)) - (let* ((startingdir (current-directory)) - (cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) - (transport (assoc/default 'transport cmdinfo)) - (testpath (assoc/default 'testpath cmdinfo)) - (test-name (assoc/default 'test-name cmdinfo)) - (runscript (assoc/default 'runscript cmdinfo)) - (db-host (assoc/default 'db-host cmdinfo)) - (run-id (assoc/default 'run-id cmdinfo)) - (test-id (assoc/default 'test-id cmdinfo)) - (itemdat (assoc/default 'itemdat cmdinfo)) - (work-area (assoc/default 'work-area cmdinfo)) - (db #f) ;; (open-db)) - (state (args:get-arg ":state")) - (status (args:get-arg ":status")) - (stepname (args:get-arg "-step"))) - (if (not (launch:setup)) - (begin - (debug:print 0 *default-log-port* "Failed to setup, exiting") - (exit 1))) - - (if (args:get-arg "-runstep")(debug:print-info 1 *default-log-port* "Running -runstep, first change to directory " work-area)) - (change-directory work-area) - ;; can setup as client for server mode now - - (if (args:get-arg "-load-test-data") - ;; has sub commands that are rdb: - ;; DO NOT put this one into either rmt: or open-run-close - (tdb:load-test-data run-id test-id)) - (if (args:get-arg "-setlog") - (let ((logfname (args:get-arg "-setlog"))) - (rmt:test-set-log! run-id test-id logfname))) - (if (args:get-arg "-set-toplog") - ;; DO NOT run remote - (tests:test-set-toplog! run-id test-name (args:get-arg "-set-toplog"))) - (if (args:get-arg "-summarize-items") - ;; DO NOT run remote - (tests:summarize-items run-id test-id test-name #t)) ;; do force here - (if (args:get-arg "-runstep") - (if (null? remargs) - (begin - (debug:print-error 0 *default-log-port* "nothing specified to run!") - (if db (sqlite3:finalize! db)) - (exit 6)) - (let* ((stepname (args:get-arg "-runstep")) - (logprofile (args:get-arg "-logpro")) - (logfile (conc stepname ".log")) - (cmd (if (null? remargs) #f (car remargs))) - (params (if cmd (cdr remargs) '())) - (exitstat #f) - (shell (let ((sh (get-environment-variable "SHELL") )) - (if sh - (last (string-split sh "/")) - "bash"))) - (redir (case (string->symbol shell) - ((tcsh csh ksh) ">&") - ((zsh bash sh ash) "2>&1 >") - (else ">&"))) - (fullcmd (conc "(" (string-intersperse - (cons cmd params) " ") - ") " redir " " logfile))) - ;; mark the start of the test - (rmt:teststep-set-status! run-id test-id stepname "start" "n/a" (args:get-arg "-m") logfile) - ;; run the test step - (debug:print-info 2 *default-log-port* "Running \"" fullcmd "\" in directory \"" startingdir) - (change-directory startingdir) - (set! exitstat (system fullcmd)) - (set! *globalexitstatus* exitstat) - ;; (change-directory testpath) - ;; run logpro if applicable ;; (process-run "ls" (list "/foo" "2>&1" "blah.log")) - (if logprofile - (let* ((htmllogfile (conc stepname ".html")) - (oldexitstat exitstat) - (cmd (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " "))) - (debug:print-info 2 *default-log-port* "running \"" cmd "\"") - (change-directory startingdir) - (set! exitstat (system cmd)) - (set! *globalexitstatus* exitstat) ;; no necessary - (change-directory testpath) - (rmt:test-set-log! run-id test-id htmllogfile))) - (let ((msg (args:get-arg "-m"))) - (rmt:teststep-set-status! run-id test-id stepname "end" exitstat msg logfile)) - ))) - (if (or (args:get-arg "-test-status") - (args:get-arg "-set-values")) - (let ((newstatus (cond - ((number? status) (if (equal? status 0) "PASS" "FAIL")) - ((and (string? status) - (string->number status))(if (equal? (string->number status) 0) "PASS" "FAIL")) - (else status))) - ;; transfer relevant keys into a hash to be passed to test-set-status! - ;; could use an assoc list I guess. - (otherdata (let ((res (make-hash-table))) - (for-each (lambda (key) - (if (args:get-arg key) - (hash-table-set! res key (args:get-arg key)))) - (list ":value" ":tol" ":expected" ":first_err" ":first_warn" ":units" ":category" ":variable")) - res))) - (if (and (args:get-arg "-test-status") - (or (not state) - (not status))) - (begin - (debug:print-error 0 *default-log-port* "You must specify :state and :status with every call to -test-status\n" help) - (if (sqlite3:database? db)(sqlite3:finalize! db)) - (exit 6))) - (let* ((msg (args:get-arg "-m")) - (numoth (length (hash-table-keys otherdata)))) - ;; Convert to rpc inside the tests:test-set-status! call, not here - (tests:test-set-status! run-id test-id state newstatus msg otherdata work-area: work-area)))) - (if (sqlite3:database? db)(sqlite3:finalize! db)) - (set! *didsomething* #t)))) - -;;====================================================================== -;; Various helper commands can go below here -;;====================================================================== - -(if (or (args:get-arg "-showkeys") - (args:get-arg "-show-keys")) - (let ((db #f) - (keys #f)) - (if (not (launch:setup)) - (begin - (debug:print 0 *default-log-port* "Failed to setup, exiting") - (exit 1))) - (set! keys (rmt:get-keys)) ;; db)) - (debug:print 1 *default-log-port* "Keys: " (string-intersperse keys ", ")) - (if (sqlite3:database? db)(sqlite3:finalize! db)) - (set! *didsomething* #t))) - -(if (args:get-arg "-gui") - (begin - (debug:print 0 *default-log-port* "Look at the dashboard for now") - ;; (megatest-gui) - (set! *didsomething* #t))) - -(if (args:get-arg "-create-megatest-area") - (begin - (genexample:mk-megatest.config) - (set! *didsomething* #t))) - -(if (args:get-arg "-create-test") - (let ((testname (args:get-arg "-create-test"))) - (genexample:mk-megatest-test testname) - (set! *didsomething* #t))) - -;;====================================================================== -;; Update the database schema, clean up the db -;;====================================================================== - -(if (args:get-arg "-rebuild-db") - (begin - (if (not (launch:setup)) - (begin - (debug:print 0 *default-log-port* "Failed to setup, exiting") - (exit 1))) - ;; keep this one local - ;; (open-run-close patch-db #f) - (let ((dbstructs (db:setup))) - (common:cleanup-db dbstructs full: #t)) - (set! *didsomething* #t))) - -(if (args:get-arg "-cleanup-db") - (begin - (if (not (launch:setup)) - (begin - (debug:print 0 *default-log-port* "Failed to setup, exiting") - (exit 1))) - -;; (if (not (server:choose-server *toppath* 'home?)) -;; (begin -;; (debug:print 0 *default-log-port* "Servers are not running on this host or no servers alive. Cannot run cleanup-db") -;; (exit 1))) - - (let ((dbstructs (db:setup))) - (common:cleanup-db dbstructs)) - (set! *didsomething* #t))) - -(if (args:get-arg "-mark-incompletes") - (begin - (if (not (launch:setup)) - (begin - (debug:print 0 *default-log-port* "Failed to setup, exiting") - (exit 1))) - (open-run-close db:find-and-mark-incomplete #f) - (set! *didsomething* #t))) - -;;====================================================================== -;; Update the tests meta data from the testconfig files -;;====================================================================== - -(if (args:get-arg "-update-meta") - (begin - (if (not (launch:setup)) - (begin - (debug:print 0 *default-log-port* "Failed to setup, exiting") - (exit 1))) - (runs:update-all-test_meta #f) - (set! *didsomething* #t))) - -;;====================================================================== -;; Start a repl -;;====================================================================== - -;; fakeout readline -(include "readline-fix.scm") - - -(when (args:get-arg "-diff-rep") - (when (and - (not (args:get-arg "-diff-html")) - (not (args:get-arg "-diff-email"))) - (debug:print 0 *default-log-port* "Must specify -diff-html or -diff-email with -diff-rep") - (set! *didsomething* 1) - (exit 1)) - - (let* ((toppath (launch:setup))) - (do-diff-report - (args:get-arg "-src-target") - (args:get-arg "-src-runname") - (args:get-arg "-target") - (args:get-arg "-runname") - (args:get-arg "-diff-html") - (args:get-arg "-diff-email")) - (set! *didsomething* #t) - (exit 0))) - -(if (or (getenv "MT_RUNSCRIPT") - (args:get-arg "-repl") - (args:get-arg "-load")) - (let* ((toppath (launch:setup)) - (dbstructs (if (and toppath - ;; NOTE: server:choose-server is starting a server - ;; either add equivalent for tcp mode or ???? - #;(server:choose-server toppath 'home?)) - (db:setup) - #f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f))) - (if *toppath* - (cond - ((getenv "MT_RUNSCRIPT") - ;; How to run megatest scripts - ;; - ;; #!/bin/bash - ;; - ;; export MT_RUNSCRIPT=yes - ;; megatest << EOF - ;; (print "Hello world") - ;; (exit) - ;; EOF - - (repl)) - (else - (begin - (set! *db* dbstructs) - (import extras) ;; might not be needed - ;; (import csi) - (import readline) - (import apropos) - (import dbfile) - ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ... - - (if *use-new-readline* - (begin - (install-history-file (get-environment-variable "HOME") ".megatest_history") ;; [homedir] [filename] [nlines]) - (current-input-port (make-readline-port "megatest> "))) - (begin - (gnu-history-install-file-manager - (string-append - (or (get-environment-variable "HOME") ".") "/.megatest_history")) - (current-input-port (make-gnu-readline-port "megatest> ")))) - (if (args:get-arg "-repl") - (repl) - (load (args:get-arg "-load"))) - ;; (db:close-all dbstruct) <= taken care of by on-exit call - ) - (exit))) - (set! *didsomething* #t)))) - -;;====================================================================== -;; Wait on a run to complete -;;====================================================================== - -(if (and (args:get-arg "-run-wait") - (not (or (args:get-arg "-run") - (args:get-arg "-runtests")))) ;; run-wait is built into runtests now - (begin - (if (not (launch:setup)) - (begin - (debug:print 0 *default-log-port* "Failed to setup, exiting") - (exit 1))) - (operate-on 'run-wait) - (set! *didsomething* #t))) - -;; ;; ;; redo me ;; Not converted to use dbstruct yet -;; ;; ;; redo me ;; -;; ;; ;; redo me (if (args:get-arg "-convert-to-norm") -;; ;; ;; redo me (let* ((toppath (setup-for-run)) -;; ;; ;; redo me (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t)))) -;; ;; ;; redo me (for-each -;; ;; ;; redo me (lambda (field) -;; ;; ;; redo me (let ((dat '())) -;; ;; ;; redo me (debug:print-info 0 *default-log-port* "Getting data for field " field) -;; ;; ;; redo me (sqlite3:for-each-row -;; ;; ;; redo me (lambda (id val) -;; ;; ;; redo me (set! dat (cons (list id val) dat))) -;; ;; ;; redo me (db:get-db db run-id) -;; ;; ;; redo me (conc "SELECT id," field " FROM tests;")) -;; ;; ;; redo me (debug:print-info 0 *default-log-port* "found " (length dat) " items for field " field) -;; ;; ;; redo me (let ((qry (sqlite3:prepare db (conc "UPDATE tests SET " field "=? WHERE id=?;")))) -;; ;; ;; redo me (for-each -;; ;; ;; redo me (lambda (item) -;; ;; ;; redo me (let ((newval ;; (sdb:qry 'getid -;; ;; ;; redo me (cadr item))) ;; ) -;; ;; ;; redo me (if (not (equal? newval (cadr item))) -;; ;; ;; redo me (debug:print-info 0 *default-log-port* "Converting " (cadr item) " to " newval " for test #" (car item))) -;; ;; ;; redo me (sqlite3:execute qry newval (car item)))) -;; ;; ;; redo me dat) -;; ;; ;; redo me (sqlite3:finalize! qry)))) -;; ;; ;; redo me (db:close-all dbstruct) -;; ;; ;; redo me (list "uname" "rundir" "final_logf" "comment")) -;; ;; ;; redo me (set! *didsomething* #t))) - -(if (args:get-arg "-import-megatest.db") - (begin - (launch:setup) - (db:multi-db-sync - (db:setup) - 'killservers - 'dejunk - 'adj-testids - 'old2new - ) - (set! *didsomething* #t))) - -(if (args:get-arg "-import-sexpr") - (let*( - (toppath (launch:setup)) - (tmppath (common:make-tmpdir-name toppath ""))) - (if (file-exists? (conc toppath "/.mtdb")) - (if (args:get-arg "-remove-dbs") - (let* ((dbfiles (conc toppath "/.mtdb/* " tmppath "/*"))) - (debug:print 0 *default-log-port* "Removing db files: " dbfiles) - (system (conc "rm -rvf " dbfiles)) - ) - (begin - (debug:print 0 *default-log-port* "ERROR: Cannot import sexpr with an existing DB present.") - (debug:print 0 *default-log-port* "Add '-remove-dbs all' to remove the current Megatest DBs.") - (set! *didsomething* #t) - (exit) - ) - ) - (debug:print 0 *default-log-port* "Did not find " (conc toppath "/.mtdb")) - ) - (db:setup) - (rmt:import-sexpr (args:get-arg "-import-sexpr")) - (set! *didsomething* #t))) - -(if (args:get-arg "-sync-to-megatest.db") - (let* ((duh (launch:setup)) - (dbstruct (db:setup)) - (tmpdbpth (dbr:dbstruct-tmppath dbstruct)) - (lockfile (conc tmpdbpth ".lock")) - (locked (common:simple-file-lock lockfile)) - (res (if locked - (db:multi-db-sync - dbstruct - 'new2old) - #f))) - (if res - (begin - (common:simple-file-release-lock lockfile) - (debug:print 0 *default-log-port* "Synced " res " records to megatest.db")) - (debug:print 0 *default-log-port* "Skipping sync, there is a sync in progress.")) - (set! *didsomething* #t))) - -(if (args:get-arg "-sync-to") - (let ((toppath (launch:setup))) - (tasks:sync-to-postgres *configdat* (args:get-arg "-sync-to")) - (set! *didsomething* #t))) - - -;; use with -from and -to -;; -(if (args:get-arg "-db2db") - (let* ((duh (launch:setup)) - (src-db (args:get-arg "-from")) - (dest-db (args:get-arg "-to")) - ;; (sync-period (args:get-arg-number "-period")) - ;; (sync-timeout (args:get-arg-number "-timeout")) - (sync-period-in (args:get-arg "-period")) - (sync-timeout-in (args:get-arg "-timeout")) - (sync-period (if sync-period-in (string->number sync-period-in) #f)) - (sync-timeout (if sync-timeout-in (string->number sync-timeout-in) #f)) - (lockfile (conc dest-db".sync-lock")) - (keys (db:get-keys #f)) - (thesync (lambda (last-update) - (debug:print-info 0 *default-log-port* "Attempting to sync data from "src-db" to "dest-db"...") - (debug:print-info 0 *default-log-port* "PID = " (current-process-id)) - (if (not (file-exists? dest-db)) - (begin - (debug:print 0 *default-log-port* "Using copy to create "dest-db" from "src-db) - (file-copy src-db dest-db) - 1) - (let ((res (dbmod:db-to-db-sync src-db dest-db last-update (dbfile:db-init-proc) keys))) - (if res - (debug:print-info 2 *default-log-port* "Synced " res " records from "src-db" to "dest-db) - (debug:print-info 0 *default-log-port* "No sync due to permissions or other issue.")) - res)))) - (start-time (current-seconds)) - (synclock-mod-time (if (file-exists? lockfile) - (handle-exceptions - exn - #f - (file-modification-time synclock-file)) - #f)) - (age (if synclock-mod-time (- (current-seconds) synclock-mod-time) 1000)) - ) - (if (and src-db dest-db) - (if (file-exists? src-db) - (if (and (file-exists? lockfile) (< age 20)) - (debug:print 0 *default-log-port* "Lock "lockfile" exists, skipping sync...") - (begin - (if (file-exists? lockfile) - (begin - (debug:print 0 *default-log-port* "Deleting old lock file " lockfile) - (delete-file lockfile) - ) - ) - (dbfile:with-simple-file-lock - lockfile - (lambda () - (let loop ((last-changed (current-seconds)) - (last-update 0)) - (let* ((changes (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* "Exception in sync: "(condition->list exn)) - (delete-file lockfile) - (exit)) - (thesync last-update))) - (now-time (current-seconds))) - (if (and sync-period sync-timeout) ;; - (if (and (< (- now-time start-time) 600) ;; hard limit on how long we run for - (> sync-timeout (- now-time last-changed))) - (begin - (if sync-period (thread-sleep! sync-period)) - (loop (if (> changes 0) now-time last-changed) now-time)))))))) - (debug:print 0 *default-log-port* "Releasing lock file " lockfile) - ) - ) - (debug:print 0 *default-log-port* "No sync due to unreadble or non-existant source file"src-db)) - (debug:print 0 *default-log-port* "Usage for -db2db; -to and -from must be specified")) - (set! *didsomething* #t))) - -(if (args:get-arg "-list-test-time") - (let* ((toppath (launch:setup))) - (task:get-test-times) - (set! *didsomething* #t))) - -(if (args:get-arg "-list-run-time") - (let* ((toppath (launch:setup))) - (task:get-run-times) - (set! *didsomething* #t))) - -(if (args:get-arg "-generate-html") - (let* ((toppath (launch:setup))) - (if (tests:create-html-tree #f) - (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/page0.html") - (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html")) - (set! *didsomething* #t))) - -(if (args:get-arg "-generate-html-structure") - (let* ((toppath (launch:setup))) - ;(if (tests:create-html-tree #f) - (if (tests:create-html-summary #f) - (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/targets.html") - (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html")) - (set! *didsomething* #t))) - -(if (args:get-arg "-syscheck") - (begin - (mutils:syscheck common:raw-get-remote-host-load - server:get-best-guess-address - read-config) - (set! *didsomething* #t))) - -(if (args:get-arg "-extract-skeleton") - (let* ((toppath (launch:setup))) - (genexample:extract-skeleton-area (args:get-arg "-extract-skeleton")) - (set! *didsomething* #t))) - -;;====================================================================== -;; Exit and clean up -;;====================================================================== - -(if (not *didsomething*) - (debug:print 0 *default-log-port* help) - (set! *time-to-exit* #t) - ) -;;(debug:print-info 13 *default-log-port* "thread-join! watchdog") - -;; join the watchdog thread if it has been thread-start!ed (it may not have been started in the case of a server that never enters running state) -;; (symbols returned by thread-state: created ready running blocked suspended sleeping terminated dead) -;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage -;;(if (thread? *watchdog*) -;; (case (thread-state *watchdog*) -;; ((ready running blocked sleeping terminated dead) -;; (thread-join! *watchdog*)))) - -(set! *time-to-exit* #t) - -(if (not (eq? *globalexitstatus* 0)) - (if (or (args:get-arg "-run")(args:get-arg "-runtests")(args:get-arg "-runall")) - (begin - (debug:print 0 *default-log-port* "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*) - (exit 0)) - (case *globalexitstatus* - ((0)(exit 0)) - ((1)(exit 1)) - ((2)(exit 2)) - (else (exit 3))))) +(declare (uses mtbody)) + +(import csi) +;; fake out readline usage of toplevel-command +(set! toplevel-command (lambda (a b) #f)) + +;; required for chicken 4 +(use srfi-69 + call-with-environment-variables + csv + regex + regex-case + sparse-vectors + format + fmt + ) + +(import mtbody) + +(main) Index: megatestmod.scm ================================================================== --- megatestmod.scm +++ megatestmod.scm @@ -38,11 +38,34 @@ (declare (uses fsmod)) (use srfi-69) (module megatestmod - * + ( + common:get-disks + db:set-tests-state-status + db:set-state-status-and-roll-up-items + common:get-install-area + tests:get-all + common:use-cache? + + mt:lazy-read-test-config + common:get-full-test-name + tests:extend-test-patts + tests:get-itemmaps + tests:get-items + tests:get-global-waitons + tests:get-tests-search-path + tests:filter-test-names + common:args-get-testpatt + tests:filter-test-names-not-matched + common:args-get-runname + common:load-views-config + common:args-get-state + common:args-get-status + common:get-runconfig-targets + ) (import scheme) (cond-expand (chicken-4 @@ -197,34 +220,10 @@ (args:get-arg ":runname") (getenv "MT_RUNNAME")))) ;; (if res (set-environment-variable "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ... res)) -(define (common:args-get-target #!key (split #f)(exit-if-bad #f)) - (let* ((keys (if (hash-table? *configdat*) (common:get-fields *configdat*) '())) - (numkeys (length keys)) - (target (or (args:get-arg "-reqtarg") - (args:get-arg "-target") - (getenv "MT_TARGET"))) - (tlist (if target (string-split target "/" #t) '())) - (valid (if target - (or (null? keys) ;; probably don't know our keys yet - (and (not (null? tlist)) - (eq? numkeys (length tlist)) - (null? (filter string-null? tlist)))) - #f))) - (if valid - (if split - tlist - target) - (if target - (begin - (debug:print-error 0 *default-log-port* "Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements") - (if exit-if-bad (exit 1)) - #f) - #f)))) - ;;====================================================================== ;; looking only (at least for now) at the MT_ variables craft the full testname ;; (define (common:get-full-test-name) (if (getenv "MT_TEST_NAME") @@ -420,20 +419,10 @@ (with-output-to-file (conc pktsdir "/" uuid ".pkt") (lambda () (print pkt))))))))) -;;====================================================================== -;; Lookup a value in runconfigs based on -reqtarg or -target -;; -(define (runconfigs-get config var) - (let ((targ (common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET")))) - (if targ - (or (configf:lookup config targ var) - (configf:lookup config "default" var)) - (configf:lookup config "default" var)))) - ;;====================================================================== ;; R U N S ;;====================================================================== ;; set tests with state currstate and status currstatus to newstate and newstatus Index: monitor.scm ================================================================== --- monitor.scm +++ monitor.scm @@ -19,16 +19,16 @@ (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking) (import (prefix sqlite3 sqlite3:)) (declare (unit runs)) -(declare (uses common)) +;; (declare (uses common)) (declare (uses runconfig)) (declare (uses commonmod)) (import commonmod) -(include "common_records.scm") +;; (include "common_records.scm") ;; (include "key_records.scm") ;; (include "db_records.scm") (include "run_records.scm") DELETED mt.scm Index: mt.scm ================================================================== --- mt.scm +++ /dev/null @@ -1,54 +0,0 @@ -;; Copyright 2006-2013, 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 . -;; - - -(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) posix-extras directory-utils - call-with-environment-variables) - -(import (prefix sqlite3 sqlite3:)) - -(declare (unit mt)) -(declare (uses debugprint)) -(declare (uses common)) -(declare (uses commonmod)) -(declare (uses configfmod)) - -(declare (uses runconfig)) -(declare (uses server)) -(declare (uses runs)) -(declare (uses rmtmod)) -(declare (uses megatestmod)) - -(import debugprint - commonmod - configfmod - rmtmod - megatestmod) - -;; make mt: calls in megatestmod work -;; (read-config-set! read-config) - -(include "common_records.scm") -;; (include "key_records.scm") -;; (include "db_records.scm") -(include "run_records.scm") -;; (include "test_records.scm") - -;; This is the Megatest API. All generally "useful" routines will be wrapped or extended -;; here. - Index: mtargs/mtargs.scm ================================================================== --- mtargs/mtargs.scm +++ mtargs/mtargs.scm @@ -24,10 +24,11 @@ get-arg-from get-args usage print-args any-defined? + remove-arg-from-ht ) (import scheme) ;; gives us cond-expand in chicken-4 (cond-expand @@ -103,6 +104,9 @@ (define (any-defined? . args) (not (null? (filter (lambda (x) x) (map get-arg args))))) +(define (remove-arg-from-ht arg) + (hash-table-delete! arg-hash arg)) + ) ADDED mtbody.scm Index: mtbody.scm ================================================================== --- /dev/null +++ mtbody.scm @@ -0,0 +1,2965 @@ +;;====================================================================== +;; 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 . + +;;====================================================================== + +;;====================================================================== +;; All the crud that was in megatest.scm +;;====================================================================== + +(declare (unit mtbody)) +(declare (uses debugprint)) +(declare (uses mtargs)) +(declare (uses commonmod)) +(declare (uses configfmod)) +(declare (uses dbmod)) +(declare (uses dbfile)) +(declare (uses envmod)) +(declare (uses apimod)) +(declare (uses genexample)) +(declare (uses rmtmod)) +(declare (uses archivemod)) +(declare (uses mutils)) +(declare (uses odsmod)) +(declare (uses testsmod)) +(declare (uses diff-report)) +(declare (uses tdb)) + +(use srfi-69) +(import csi) + +(module mtbody + * + +(import scheme) +(cond-expand + (chicken-4 + + (import chicken + ports + (prefix base64 base64:) + + (prefix sqlite3 sqlite3:) + data-structures + directory-utils + extras + files + matchable + md5 + message-digest + pathname-expand + posix + posix-extras + ;; readline + regex + regex-case + sparse-vectors + srfi-1 + srfi-18 + srfi-69 + typed-records + z3 + + debugprint + commonmod + configfmod + ;; tcp-transportmod + (prefix mtargs args:) + ) + (use srfi-69)) + (chicken-5 + (import (prefix sqlite3 sqlite3:) + ;; data-structures + ;; extras + ;; files + ;; posix + ;; posix-extras + chicken.base + chicken.condition + chicken.file + chicken.file.posix + chicken.io + chicken.pathname + chicken.port + chicken.process + chicken.process-context + chicken.process-context.posix + chicken.sort + chicken.string + chicken.time + chicken.time.posix + + matchable + md5 + message-digest + pathname-expand + regex + regex-case + srfi-1 + srfi-18 + srfi-69 + typed-records + system-information + + debugprint + ))) + +;; imports common to chk5 and ck4 +(import srfi-13 + csi) + +(import (prefix mtargs args:) + archivemod + debugprint + dbmod + commonmod + processmod + configfmod + dbfile + dbmod + portlogger + tcp-transportmod + rmtmod + apimod + stml2 + mtmod + megatestmod + servermod + tasksmod + runsmod + rmtmod + launchmod + fsmod + envmod + apimod + genexample + mutils + odsmod + testsmod + diff-report + tdb + ) + +(include "common_records.scm") + +(define *db* #f) ;; this is only for the repl, do not use in general!!!! + +;; (set! toplevel-command toplevel-command) + +;; (include "common_records.scm") +;; (include "key_records.scm") +;; (include "db_records.scm") +(include "run_records.scm") +(include "megatest-fossil-hash.scm") + +(import (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:)) +(import + ;; readline + apropos json http-client directory-utils typed-records) +(import http-client srfi-18 extras format tcp-server tcp) + +;; Added for csv stuff - will be removed +;; +(use sparse-vectors) + +(require-library mutils) + +;;====================================================================== +;; api handler stuff +;;====================================================================== + +;; QUEUE METHOD + +(define (api:tcp-dispatch-request-make-handler-new dbstruct) ;; cmd run-id params) + (api:tcp-dispatch-request-make-handler-core dbstruct api:dispatch-request)) + + +;; indat is (cmd run-id params meta) +;; +;; WARNING: Do not print anything in the lambda of this function as it +;; reads/writes to current in/out port +;; +(define (api:tcp-dispatch-request-make-handler-old dbstruct) ;; cmd run-id params) + (assert *toppath* "FATAL: api:tcp-dispatch-request-make-handler called but *toppath* not set.") + (if (not *server-signature*) + (set! *server-signature* (tt:mk-signature *toppath*))) + (lambda (indat) + (api:register-thread (current-thread)) + (let* ((result + (let* ((numthreads (api:get-count-threads-alive)) + (delay-wait (if (> numthreads 10) + (- numthreads 10) + 0)) + (normal-proc (lambda (cmd run-id params) + (case cmd + ((ping) *server-signature*) + (else + (api:dispatch-request dbstruct cmd run-id params)))))) + (set! *api-process-request-count* numthreads) + (set! *db-last-access* (current-seconds)) +;; (if (not (eq? numthreads numthreads)) +;; (begin +;; (api:remove-dead-or-terminated) +;; (let ((threads-now (api:get-count-threads-alive))) +;; (debug:print 0 *default-log-port* "WARNING: numthreads="numthreads", numthreads="numthreads", remaining="threads-now) +;; (set! numthreads threads-now)))) + (match indat + ((cmd run-id params meta) + (let* ((start-t (current-milliseconds)) + (db-ok (let* ((dbfname (dbmod:run-id->dbfname run-id)) + (ok (equal? dbfname (dbr:dbstruct-dbfname dbstruct)))) + (case cmd + ((ping) #t) ;; we are fine + (else + (assert ok "FATAL: database file and run-id not aligned."))))) + (ttdat *server-info*) + (server-state (tt-state ttdat)) + (maxthreads 20) ;; make this a parameter? + (status (cond + ((and (> numthreads maxthreads) + (> (random 100) 70)) ;; allow a 30% probability to go through so we can figure out what is going wrong in main.db server. + 'busy) + ;; ((> numthreads 5) 'loaded) ;; this gets transmitted to the client which calls tt:backoff-incr to slow stuff down. + (else 'ok))) + (errmsg (case status + ((busy) (conc "Server overloaded, "numthreads" threads in flight")) + ((loaded) (conc "Server loaded, "numthreads" threads in flight")) + (else #f))) + (result (case status + ((busy) + (if (eq? cmd 'ping) + (normal-proc cmd run-id params) + ;; numthreads must be greater than 5 for busy + (* 0.1 (- numthreads maxthreads)) ;; was 15 - return a number for the remote to delay + )) ;; (- numthreads 29)) ;; call back in as many seconds + ((loaded) + (normal-proc cmd run-id params)) + (else + (normal-proc cmd run-id params)))) + (meta (case cmd + ((ping) `((sstate . ,server-state))) + (else `((wait . ,delay-wait))))) + (payload (list status errmsg result meta))) + ;; (cmd run-id params meta) + (db:add-stats cmd run-id params (- (current-milliseconds) start-t)) + payload)) + (else + (assert #f "FATAL: failed to deserialize indat "indat)))))) + ;; (set! *api-process-request-count* (- *api-process-request-count* 1)) + ;; (serialize payload) + + (api:unregister-thread (current-thread)) + result))) + +(define api:tcp-dispatch-request-make-handler api:tcp-dispatch-request-make-handler-new) ;; choose -old or -new + +;; end api stuff + +;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions +(define (open-logfile logpath-in) + (let ((lpath #f)) + (condition-case + (let* ((log-dir (or (pathname-directory logpath-in) ".")) + (fname (pathname-strip-directory logpath-in)) + (logpath (if (> (string-length fname) 250) + (let ((newlogf (conc log-dir "/" (common:get-signature fname) ".log"))) + (debug:print 0 *default-log-port* "WARNING: log file " logpath-in " path too long, converted to " newlogf) + newlogf) + logpath-in))) + (set! lpath logpath) ;; just for printing if error + (if (not (directory-exists? log-dir)) + (system (conc "mkdir -p " log-dir))) + (open-output-file logpath)) + (exn () + (debug:print-error 0 *default-log-port* "Could not open log file for write: "lpath) + (define *didsomething* #t) + (exit 1))))) + +(define (main) + ;; remove when configf fully modularized + (read-config-set! configf:read-file) + + (define *usage-log-file* #f) ;; put path to file for logging usage in this var in the ~/.megatestrc file + (define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file + + ;; set some parameters here - these need to be put in something that can be loaded from other + ;; executables such as dashboard and mtutil + ;; + (include "transport-mode.scm") + (dbfile:db-init-proc db:initialize-main-db) + (debug:enable-timestamp #t) + + + (set! rmtmod:send-receive rmt:send-receive) + ;;(lambda params (apply rmt:send-receive params))) ;; make send-receive available to rmtmod via parameter + + + ;; load the ~/.megatestrc file, put (use trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file + ;; + (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc"))) + (if (common:file-exists? debugcontrolf) + (load debugcontrolf))) + + ;; usage logging, careful with this, it is not designed to deal with all real world challenges! + ;; + (if (and (string? *usage-log-file*) + (file-write-access? *usage-log-file*)) + (with-output-to-file + *usage-log-file* + (lambda () + (print (if *usage-use-seconds* + (current-seconds) + (time->string + (seconds->local-time (current-seconds)) + "%Yww%V.%w %H:%M:%S")) + " " + (current-user-name) " " + (current-directory) " " + "\"" (string-intersperse (argv) " ") "\"")) + #:append)) + + ;; Disabled help items + ;; -rollup : (currently disabled) fill run (set by :runname) with latest test(s) + ;; from prior runs with same keys + ;; -daemonize : fork into background and disconnect from stdin/out + + (define help (conc " +Megatest, documentation at http://www.kiatoa.com/fossils/megatest + version " megatest-version " + license GPL, Copyright Matt Welland 2006-2017 + +Usage: megatest [options] + -h : this help + -manual : show the Megatest user manual + -version : print megatest version (currently " megatest-version ") + +Launching and managing runs + -run : run all tests or as specified by -testpatt + -remove-runs : remove the data for a run, requires -runname and -testpatt + Optionally use :state and :status, use -keep-records to remove only + the run data. Use -kill-wait to override the 10 second + per test wait after kill delay (e.g. -kill-wait 0). + -kill-runs : kill existing run(s) (all incomplete tests killed) + -kill-rerun : kill an existing run (all incomplete tests killed and run is rerun) + -set-state-status X,Y : set state to X and status to Y, requires controls per -remove-runs + -rerun FAIL,WARN... : force re-run for tests with specificed status(s) + -rerun-clean : set all tests not COMPLETED+PASS,WARN,WAIVED to NOT_STARTED,n/a + and then run the specified testpatt with -preclean + -rerun-all : set all tests to NOT_STARTED,n/a and run with -preclean + -lock : lock run specified by target and runname + -unlock : unlock run specified by target and runname + -set-run-status status : sets status for run to status, requires -target and -runname + -get-run-status : gets status for run specified by target and runname + -run-wait : wait on run specified by target and runname + -preclean : remove the existing test directory before running the test + -clean-cache : remove the cached megatest.config and runconfigs.config files + -no-cache : do not use the cached config files. + -one-pass : launch as many tests as you can but do not wait for more to be ready + -remove-keep N : remove all but N most recent runs per target; use '-actions, -age, -precmd' + -age : 120d,3h,20m to apply only to runs older than the + specified age. NB// M=month, m=minute + -actions [,...] : actions to take; print,remove-runs,archive,kill-runs + -precmd : insert a wrapper command in front of the commands run + +Selectors (e.g. use for -runtests, -remove-runs, -set-state-status, -list-runs etc.) + -target key1/key2/... : run for key1, key2, etc. + -reqtarg key1/key2/... : run for key1, key2, etc. but key1/key2 must be in runconfigs + -testpatt patt1/patt2,patt3/... : % is wildcard + -runname : required, name for this particular test run + -state : Applies to runs, tests or steps depending on context + -status : Applies to runs, tests or steps depending on context + -modepatt key : load testpatt from in runconfigs instead of default TESTPATT if -testpatt and -tagexpr are not specified + -tagexpr tag1,tag2%,.. : select tests with tags matching expression + + +Test helpers (for use inside tests) + -step stepname + -test-status : set the state and status of a test (use :state and :status) + -setlog logfname : set the path/filename to the final log relative to the test + directory. may be used with -test-status + -set-toplog logfname : set the overall log for a suite of sub-tests + -summarize-items : for an itemized test create a summary html + -m comment : insert a comment for this test + +Test data capture + -set-values : update or set values in the testdata table + :category : set the category field (optional) + :variable : set the variable name (optional) + :value : value measured (required) + :expected : value expected (required) + :tol : |value-expect| <= tol (required, can be <, >, >=, <= or number) + :units : name of the units for value, expected_value etc. (optional) + -load-test-data : read test specific data for storage in the test_data table + from standard in. Each line is comma delimited with four + fields category,variable,value,comment + +Queries + -list-runs patt : list runs matching pattern \"patt\", % is the wildcard + -show-keys : show the keys used in this megatest setup + -test-files targpatt : get the most recent test path/file matching targpatt e.g. %/% or '*.log' + returns list sorted by age ascending, see examples below + -test-paths : get the test paths matching target, runname, item and test + patterns. + -list-disks : list the disks available for storing runs + -list-targets : list the targets in runconfigs.config + -list-db-targets : list the target combinations used in the db + -show-config : dump the internal representation of the megatest.config file + -show-runconfig : dump the internal representation of the runconfigs.config file + -dumpmode MODE : dump in MODE format instead of sexpr, MODE=json,ini,sexp etc. (add -debug 0,9 to see which file contributes each line) + -show-cmdinfo : dump the command info for a test (run in test environment) + -section sectionName + -var varName : for config and runconfig lookup value for sectionName varName + -since N : get list of runs changed since time N (Unix seconds) + -fields fieldspec : fields to include in json dump; runs:id,runame+tests:testname+steps + -sort fieldname : in -list-runs sort tests by this field + -testdata-csv [categorypatt/]varpatt : dump testdata for given category + +Misc + -start-dir path : switch to this directory before running megatest + -contour cname : add a level of hierarcy to the linktree and run paths + -area-tag tagname : add a tag to an area while syncing to pgdb + -run-tag tagname : add a tag to a run while syncing to pgdb + -rebuild-db : bring the database schema up to date + -cleanup-db : remove any orphan records, vacuum the db + -import-megatest.db : push data from megatest.db to cache db files in /tmp/$USER + -sync-to-megatest.db : pull data from cache files in /tmp/$USER to megatest.db + -sync-to dest : sync to new postgresql central style database + -update-meta : update the tests metadata for all tests + -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are + overwritten by values set in config files. + -server -|hostname : start the server (reduces contention on megatest.db), use + - to automatically figure out hostname + -adjutant C,M : start the server/adjutant with allocated cores C and Mem M (Gig), + use 0,0 to auto use full machine + -transport http|rpc : use http or rpc for transport (default is http) + -log logfile : send stdout and stderr to logfile + -list-servers : list the servers + -kill-servers : kill all servers + -repl : start a repl (useful for extending megatest) + -load file.scm : load and run file.scm + -mark-incompletes : find and mark incomplete tests + -ping run-id|host:port : ping server, exit with 0 if found + -debug N|N,M,O... : enable debug 0-N or N and M and O ... + -debug-noprop N|M,M,O...: enable debug but do not propagate to subprocesses via MT_DEBUG + -config fname : override the megatest.config file with fname + -append-config fname : append fname to the megatest.config file + -import-sexpr fname : import a sexpr file (use -list-runs % -dumpmode sexpr to create) + -remove-dbs all : remove Megatest DBs before importing sexpr. (Use only with -import-sexpr) + -regen-testfiles : regenerate scripts and logpro files from testconfig, run in test context + +Utilities + -env2file fname : write the environment to fname.csh and fname.sh + -envcap a : save current variables labeled as context 'a' in file envdat.db + -envdelta a-b : output enviroment delta from context a to context b to -o fname + set the output mode with -dumpmode csh, bash or ini + note: ini format will use calls to use curr and minimize path + -refdb2dat refdb : convert refdb to sexp or to format specified by s-dumpmode + formats: perl, ruby, sqlite3, csv (for csv the -o param + will substitute %s for the sheet name in generating + multiple sheets) + -o : output file for refdb2dat (defaults to stdout) + -archive cmd : archive runs specified by selectors to one of disks specified + in the [archive-disks] section. + cmd: keep-html, restore, save, save-remove, get, replicate-db (use + -dest to set destination), -include path1,path2... to get or save specific files + -generate-html : create a simple html dashboard for browsing your runs + -generate-html-structure : create a top level html veiw to list targets/runs and a Run view within each run directory. + -list-run-time : list time requered to complete runs. It supports following switches + -run-patt -target-patt -dumpmode + -list-test-time : list time requered to complete each test in a run. It following following arguments + -runname -target -dumpmode + -syscheck : do some very basic checks; write access and space in tmp, home, runs, links and + is $DISPLAY valid + -list-waivers : dump waivers for specified target, runname, testpatt to stdout + -db2db : sync db to db, use -from, -to for dbs, -period and -timeout for continuous sync + +Diff report + -diff-rep : generate diff report (must include -src-target, -src-runname, -target, -runname + and either -diff-email or -diff-html) + -src-target + -src-runname + -diff-email : comma separated list of email addresses to send diff report + -diff-html : path to html file to generate + +Spreadsheet generation + -extract-ods fname.ods : extract an open document spreadsheet from the database + -pathmod path : insert path, i.e. path/runame/itempath/logfile.html + will clear the field if no rundir/testname/itempath/logfile + if it contains forward slashes the path will be converted + to windows style +Getting started + -create-megatest-area : create a skeleton megatest area. You will be prompted for paths + -create-test testname : create a skeleton megatest test. You will be prompted for info + +Examples + +# Get test path, use '.' to get a single path or a specific path/file pattern +megatest -test-files 'logs/*.log' -target ubuntu/n%/no% -runname w49% -testpatt test_mt% + +Called as " (string-intersperse (argv) " ") " +Version " megatest-version ", built from " megatest-fossil-hash )) + + ;; -gui : start a gui interface + ;; -config fname : override the runconfigs file with fname + + ;; process args + (define remargs (args:get-args + (argv) + (list "-runtests" ;; run a specific test + "-config" ;; override the config file name + "-append-config" + "-execute" ;; run the command encoded in the base64 parameter + "-step" + "-target" + "-reqtarg" + ":runname" + "-runname" + ":state" + "-state" + ":status" + "-status" + "-list-runs" + "-testdata-csv" + "-testpatt" + ;; "--modepatt" + "-modepatt" + "-tagexpr" + "-itempatt" + "-setlog" + "-set-toplog" + "-runstep" + "-logpro" + "-m" + "-rerun" + + "-days" + "-rename-run" + "-from" + "-to" + "-dest" + "-source" + "-time-stamp" + ;; values and messages + ":category" + ":variable" + ":value" + ":expected" + ":tol" + ":units" + + ;; misc + "-start-dir" + "-run-patt" + "-target-patt" + "-contour" + "-area-tag" + "-area" + "-run-tag" + "-server" + "-adjutant" + "-transport" + "-port" + "-extract-ods" + "-pathmod" + "-env2file" + "-envcap" + "-envdelta" + "-setvars" + "-set-state-status" + "-import-sexpr" + "-remove-dbs" ;; to be used only with -import-sexpr to remove megatest dbs first. + "-period" ;; sync period in seconds + "-timeout" ;; exit sync if timeout in seconds exceeded since last change + + ;; move runs stuff here + "-remove-keep" + "-set-run-status" + "-age" + + ;; archive + "-archive" + "-actions" + "-precmd" + "-include" + "-exclude-rx" + "-exclude-rx-from" + + "-debug" ;; for *verbosity* > 2 + "-debug-noprop" + "-create-test" + "-override-timeout" + "-test-files" ;; -test-paths is for listing all + "-load" ;; load and exectute a scheme file + "-section" + "-var" + "-dumpmode" + "-run-id" + "-db" + "-ping" + "-refdb2dat" + "-o" + "-log" + "-sync-log" + "-since" + "-fields" + "-recover-test" ;; run-id,test-id - used internally to recover a test stuck in RUNNING state + "-sort" + "-target-db" + "-source-db" + "-prefix-target" + + "-src-target" + "-src-runname" + "-diff-email" + "-sync-to" + "-pgsync" + "-kill-wait" ;; wait this long before removing test (default is 10 sec) + "-diff-html" + + ;; wizards, area capture, setup new ... + "-extract-skeleton" + ) + (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" + "-no-cache" + "-cache-db" + "-cp-eventtime-to-publishtime" + "-use-db-cache" + "-prepend-contour" + + + ;; misc + "-repl" + "-lock" + "-unlock" + "-list-servers" + "-kill-servers" + "-run-wait" ;; wait on a run to complete (i.e. no RUNNING) + "-one-pass" ;; + "-local" ;; run some commands using local db access + "-generate-html" + "-generate-html-structure" + "-list-run-time" + "-list-test-time" + "-regen-testfiles" + + ;; misc queries + "-list-disks" + "-list-targets" + "-list-db-targets" + "-show-runconfig" + "-show-config" + "-show-cmdinfo" + "-get-run-status" + "-list-waivers" + + ;; queries + "-test-paths" ;; get path(s) to a test, ordered by youngest first + + "-runall" ;; run all tests, respects -testpatt, defaults to % + "-run" ;; alias for -runall + "-remove-runs" + "-kill-runs" + "-kill-rerun" + "-keep-records" ;; use with -remove-runs to remove only the run data + "-rebuild-db" + "-cleanup-db" + "-rollup" + "-update-meta" + "-create-megatest-area" + "-mark-incompletes" + + "-convert-to-norm" + "-convert-to-old" + "-import-megatest.db" + "-sync-to-megatest.db" + "-db2db" + "-sync-brute-force" + "-logging" + "-v" ;; verbose 2, more than normal (normal is 1) + "-q" ;; quiet 0, errors/warnings only + + "-diff-rep" + + "-syscheck" + "-obfuscate" + ;; junk placeholder + ;; "-:p" + + ) + args:arg-hash + 0)) + + ;; Add args that use remargs here + ;; + (if (and (not (null? remargs)) + (not (or + (args:get-arg "-runstep") + (args:get-arg "-envcap") + (args:get-arg "-envdelta") + ) + )) + (debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " "))) + + ;; before doing anything else change to the start-dir if provided + ;; + (if (args:get-arg "-start-dir") + (if (common:file-exists? (args:get-arg "-start-dir")) + (let ((fullpath (common:real-path (args:get-arg "-start-dir")))) + (setenv "PWD" fullpath) + (change-directory fullpath)) + (begin + (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.") + (exit 1)))) + + ;; immediately set MT_TARGET if -reqtarg or -target are available + ;; + (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target")))) + (if targ (setenv "MT_TARGET" targ))) + + ;; set the purpose field in procinf + + (procinf-purpose-set! *procinf* (get-purpose args:arg-hash)) + (procinf-mtversion-set! *procinf* megatest-version) + + ;; The watchdog is to keep an eye on things like db sync etc. + ;; + + ;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage + ;;(define *watchdog* (make-thread + ;; (lambda () + ;; (handle-exceptions + ;; exn + ;; (begin + ;; (print-call-chain) + ;; (print " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)) + ;; (common:watchdog))) + ;; "Watchdog thread")) + + ;;(if (not (args:get-arg "-server")) + ;; (thread-start! *watchdog*)) ;; if starting a server; wait till we get to running state before kicking off watchdog + (let* ((no-watchdog-args + '("-list-runs" + "-testdata-csv" + "-list-servers" + "-server" + "-adjutant" + "-list-disks" + "-list-targets" + "-show-runconfig" + ;;"-list-db-targets" + "-show-runconfig" + "-show-config" + "-show-cmdinfo" + "-cleanup-db" + )) + (no-watchdog-argvals (list '("-archive" . "replicate-db"))) + (start-watchdog-specail-arg-val (let loop ((hed (car no-watchdog-argvals)) + (tail (cdr no-watchdog-argvals))) + ;; (print "hed" hed " arg " (args:get-arg (car hed)) " val:" (cdr hed) " eql" (equal? (args:get-arg (car hed)) (cdr hed))) + (if (equal? (args:get-arg (car hed)) (cdr hed)) + #f + (if (null? tail) + #t + (loop (car tail) (cdr tail)))))) + (no-watchdog-args-vals (filter (lambda (x) x) + (map args:get-arg no-watchdog-args))) + (start-watchdog (and (null? no-watchdog-args-vals) start-watchdog-specail-arg-val))) + ;(print "no-watchdog-args="no-watchdog-args "no-watchdog-args-vals="no-watchdog-args-vals " start-watchdog-specail-arg-val:" start-watchdog-specail-arg-val " start-watchdog:" start-watchdog) + ;; (if start-watchdog + ;; (thread-start! *watchdog*)) + #t + ) + + ;; stop the train watchdog + (stop-the-train) + + ;; this segment will run launch:setup only if -log is not set. This is fairly safe as servers are not + ;; manually started and thus should never be started in a non-megatest area. Thus no need to handle situation + ;; where (launch:setup) returns #f? + ;; + (if (or (args:get-arg "-log")#;(args:get-arg "-server")) ;; redirect the log always when a server + (handle-exceptions + exn + (begin + (print "ERROR: Failed to switch to log output. " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)) + (let* ((tl (or (args:get-arg "-log")(launch:setup))) ;; run launch:setup if -server, ensure we do NOT run launch:setup if -log specified + (dbname (args:get-arg "-db")) ;; for the server logfile name + (logf (or (args:get-arg "-log") ;; use -log unless we are a server, then craft a logfile name + (conc tl "/logs/server-"(or dbname "unk")"-"(current-process-id) "-" (get-host-name) ".log"))) + (oup (open-logfile logf))) + (if (not (args:get-arg "-log")) + (hash-table-set! args:arg-hash "-log" logf)) ;; fake out future queries of -log + (debug:print-info 0 *default-log-port* "Sending log output to " logf) + (set! *default-log-port* oup)))) + + (if (or (args:get-arg "-h") + (args:get-arg "-help") + (args:get-arg "--help")) + (begin + (print help) + (exit))) + + (if (args:get-arg "-manual") + (let* ((htmlviewercmd (or (configf:lookup *configdat* "setup" "htmlviewercmd") + (common:which '("firefox" "arora")))) + (install-home (common:get-install-area)) + (manual-html (conc install-home "/share/docs/megatest_manual.html"))) + (if (and install-home + (common:file-exists? manual-html)) + (system (conc "(" htmlviewercmd " " manual-html " ) &")) + (system (conc "(" htmlviewercmd " http://www.kiatoa.com/cgi-bin/fossils/megatest/doc/tip/docs/manual/megatest_manual.html ) &"))) + (exit))) + + (if (args:get-arg "-version") + (begin + (print (common:version-signature)) ;; (print megatest-version) + (exit))) + + (define *didsomething* #f) + + ;; Overall exit handling setup immediately + ;; + (if (or (args:get-arg "-process-reap")) + ;; (args:get-arg "-runtests") + ;; (args:get-arg "-execute") + ;; (args:get-arg "-remove-runs") + ;; (args:get-arg "-runstep")) + (let ((original-exit (exit-handler))) + (exit-handler (lambda (#!optional (exit-code 0)) + (printf "Preparing to exit with exit code ~A ...\n" exit-code) + (for-each + + (lambda (pid) + (handle-exceptions + exn + (begin + (printf "process reap failed. exn=~A\n" exn) + #t) + (let-values (((pid-val exit-status exit-code) (process-wait pid #t))) + (if (or (eq? pid-val pid) + (eq? pid-val 0)) + (begin + (printf "Sending signal/term to ~A\n" pid) + (process-signal pid signal/term)))))) + (process:children #f)) + (original-exit exit-code))))) + + ;; for some switches always print the command to stderr + ;; + (if (args:any-defined? "-run" "-runall" "-remove-runs" "-set-state-status" "-kill-runs" "-kill-rerun") + (debug:print 0 *default-log-port* (string-intersperse (argv) " "))) + + + ;;====================================================================== + ;; Misc setup stuff + ;;====================================================================== + + (debug:setup) + + (if (args:get-arg "-logging")(set! *logging* #t)) + + ;;(if (debug:debug-mode 3) ;; we are obviously debugging + ;; (set! open-run-close open-run-close-no-exception-handling)) + + (if (args:get-arg "-itempatt") + (let ((newval (conc (args:get-arg "-testpatt") "/" (args:get-arg "-itempatt")))) + (debug:print 0 *default-log-port* "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval) + (hash-table-set! args:arg-hash "-testpatt" newval) + (hash-table-delete! args:arg-hash "-itempatt"))) + + (if (args:get-arg "-runtests") + (debug:print 0 *default-log-port* "WARNING: \"-runtests\" is deprecated. Use \"-run\" with \"-testpatt\" instead")) + + (on-exit std-exit-procedure) + + ;;====================================================================== + ;; Misc general calls + ;;====================================================================== + + (if (and (args:get-arg "-cache-db") + (args:get-arg "-source-db")) + (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) + (set! *didsomething* #t))) + + ;; handle a clean-cache request as early as possible + ;; + (if (args:get-arg "-clean-cache") + (let ((toppath (launch:setup))) + (set! *didsomething* #t) ;; suppress the help output. + (runs:clean-cache (common:args-get-target) + (args:get-arg "-runname") + toppath))) + + (if (args:get-arg "-env2file") + (begin + (save-environment-as-files (args:get-arg "-env2file")) + (set! *didsomething* #t))) + + (if (args:get-arg "-list-disks") + (let ((toppath (launch:setup))) + (print (string-intersperse + (map (lambda (x) + (string-intersperse + x + " => ")) + (common:get-disks *configdat*)) + "\n")) + (set! *didsomething* #t))) + + ;; csv processing record + (define (make-refdb:csv) + (vector + (make-sparse-array) + (make-hash-table) + (make-hash-table) + 0 + 0)) + (define-inline (refdb:csv-get-svec vec) (vector-ref vec 0)) + (define-inline (refdb:csv-get-rows vec) (vector-ref vec 1)) + (define-inline (refdb:csv-get-cols vec) (vector-ref vec 2)) + (define-inline (refdb:csv-get-maxrow vec) (vector-ref vec 3)) + (define-inline (refdb:csv-get-maxcol vec) (vector-ref vec 4)) + (define-inline (refdb:csv-set-svec! vec val)(vector-set! vec 0 val)) + (define-inline (refdb:csv-set-rows! vec val)(vector-set! vec 1 val)) + (define-inline (refdb:csv-set-cols! vec val)(vector-set! vec 2 val)) + (define-inline (refdb:csv-set-maxrow! vec val)(vector-set! vec 3 val)) + (define-inline (refdb:csv-set-maxcol! vec val)(vector-set! vec 4 val)) + + (define (get-dat results sheetname) + (or (hash-table-ref/default results sheetname #f) + (let ((tmp-vec (make-refdb:csv))) + (hash-table-set! results sheetname tmp-vec) + tmp-vec))) + + (if (args:get-arg "-refdb2dat") + (let* ((input-db (args:get-arg "-refdb2dat")) + (out-file (args:get-arg "-o")) + (out-fmt (or (args:get-arg "-dumpmode") "scheme")) + (out-port (if (and out-file + (not (member out-fmt '("sqlite3" "csv")))) + (open-output-file out-file) + (current-output-port))) + (res-data (configf:read-refdb input-db)) + (data (car res-data)) + (msg (cadr res-data))) + (if (not data) + (debug:print 0 *default-log-port* "Bad input? data=" data) ;; some error occurred + (with-output-to-port out-port + (lambda () + (case (string->symbol out-fmt) + ((scheme)(pp data)) + ((perl) + ;; (print "%hash = (") + ;; key1 => 'value1', + ;; key2 => 'value2', + ;; key3 => 'value3', + ;; ); + (configf:map-all-hier-alist + data + (lambda (sheetname sectionname varname val) + (print "$data{\"" sheetname "\"}{\"" sectionname "\"}{\"" varname "\"} = \"" val "\";")))) + ((python ruby) + (print "data={}") + (configf:map-all-hier-alist + data + (lambda (sheetname sectionname varname val) + (print "data[\"" sheetname "\"][\"" sectionname "\"][\"" varname "\"] = \"" val "\"")) + initproc1: + (lambda (sheetname) + (print "data[\"" sheetname "\"] = {}")) + initproc2: + (lambda (sheetname sectionname) + (print "data[\"" sheetname "\"][\"" sectionname "\"] = {}")))) + ((csv) + (let* ((results (make-hash-table)) ;; (make-sparse-array))) + (row-cols (make-hash-table))) ;; hash of hashes where section => ht { row- => num or col- => num + ;; (print "data=") + ;; (pp data) + (configf:map-all-hier-alist + data + (lambda (sheetname sectionname varname val) + ;; (print "sheetname: " sheetname ", sectionname: " sectionname ", varname: " varname ", val: " val) + (let* ((dat (get-dat results sheetname)) + (vec (refdb:csv-get-svec dat)) + (rownames (refdb:csv-get-rows dat)) + (colnames (refdb:csv-get-cols dat)) + (currrown (hash-table-ref/default rownames varname #f)) + (currcoln (hash-table-ref/default colnames sectionname #f)) + (rown (or currrown + (let* ((lastn (refdb:csv-get-maxrow dat)) + (newrown (+ lastn 1))) + (refdb:csv-set-maxrow! dat newrown) + newrown))) + (coln (or currcoln + (let* ((lastn (refdb:csv-get-maxcol dat)) + (newcoln (+ lastn 1))) + (refdb:csv-set-maxcol! dat newcoln) + newcoln)))) + (if (not (sparse-array-ref vec 0 coln)) ;; (eq? rown 0) + (begin + (sparse-array-set! vec 0 coln sectionname) + ;; (print "sparse-array-ref " 0 "," coln "=" (sparse-array-ref vec 0 coln)) + )) + (if (not (sparse-array-ref vec rown 0)) ;; (eq? coln 0) + (begin + (sparse-array-set! vec rown 0 varname) + ;; (print "sparse-array-ref " rown "," 0 "=" (sparse-array-ref vec rown 0)) + )) + (if (not currrown)(hash-table-set! rownames varname rown)) + (if (not currcoln)(hash-table-set! colnames sectionname coln)) + ;; (print "dat=" dat ", rown=" rown ", coln=" coln) + (sparse-array-set! vec rown coln val) + ;; (print "sparse-array-ref " rown "," coln "=" (sparse-array-ref vec rown coln)) + ))) + (for-each + (lambda (sheetname) + (let* ((sheetdat (get-dat results sheetname)) + (svec (refdb:csv-get-svec sheetdat)) + (maxrow (refdb:csv-get-maxrow sheetdat)) + (maxcol (refdb:csv-get-maxcol sheetdat)) + (fname (if out-file + (string-substitute "%s" sheetname out-file) ;; "/foo/bar/%s.csv") + (conc sheetname ".csv")))) + (with-output-to-file fname + (lambda () + ;; (print "Sheetname: " sheetname) + (let loop ((row 0) + (col 0) + (curr-row '()) + (result '())) + (let* ((val (sparse-array-ref svec row col)) + (disp-val (if val + (conc "\"" val "\"") + ""))) + (if (> col 0)(display ",")) + (display disp-val) + (cond + ((> row maxrow)(display "\n") result) + ((>= col maxcol) + (display "\n") + (loop (+ row 1) 0 '() (append result (list curr-row)))) + (else + (loop row (+ col 1) (append curr-row (list val)) result))))))))) + (hash-table-keys results)))) + ((sqlite3) + (let* ((db-file (or out-file (pathname-file input-db))) + (db-exists (common:file-exists? db-file)) + (db (sqlite3:open-database db-file))) + (if (not db-exists)(sqlite3:execute db "CREATE TABLE data (sheet,section,var,val);")) + (configf:map-all-hier-alist + data + (lambda (sheetname sectionname varname val) + (sqlite3:execute db + "INSERT OR REPLACE INTO data (sheet,section,var,val) VALUES (?,?,?,?);" + sheetname sectionname varname val))) + (sqlite3:finalize! db))) + (else + (pp data)))))) + (if out-file (close-output-port out-port)) + (exit) ;; yes, bending the rules here - need to exit since this is a utility + )) + + (if (args:get-arg "-ping") + (let* ((server-id (string->number (args:get-arg "-ping"))) ;; extract run-id (i.e. no ":" + (host:port (args:get-arg "-ping"))) + (debug:print 0 *default-log-port* "NOT YET REIMPLEMENTED FOR TCP/INMEM") ;; bug + (exit))) + ;; (server:ping (or server-id host:port) #f do-exit: #t))) + + ;;====================================================================== + ;; Capture, save and manipulate environments + ;;====================================================================== + + ;; NOTE: Keep these above the section where the server or client code is setup + + (let ((envcap (args:get-arg "-envcap"))) + (if envcap + (let* ((db (env:open-db (if (null? remargs) "envdat.db" (car remargs))))) + (env:save-env-vars db envcap) + (env:close-database db) + (set! *didsomething* #t)))) + + ;; delta "language" will eventually be res=a+b-c but for now it is just res=a-b + ;; + (let ((envdelta (args:get-arg "-envdelta"))) + (if envdelta + (let ((match (string-split envdelta "-")));; (string-match "([a-z0-9_]+)=([a-z0-9_\\-,]+)" envdelta))) + (if (not (null? match)) + (let* ((db (env:open-db (if (null? remargs) "envdat.db" (car remargs)))) + ;; (resctx (cadr match)) + ;; (equn (caddr match)) + (parts match) ;; (string-split equn "-")) + (minuend (car parts)) + (subtraend (cadr parts)) + (added (env:get-added db minuend subtraend)) + (removed (env:get-removed db minuend subtraend)) + (changed (env:get-changed db minuend subtraend))) + ;; (pp (hash-table->alist added)) + ;; (pp (hash-table->alist removed)) + ;; (pp (hash-table->alist changed)) + (if (args:get-arg "-o") + (with-output-to-file + (args:get-arg "-o") + (lambda () + (env:print added removed changed))) + (env:print added removed changed)) + (env:close-database db) + (set! *didsomething* #t)) + (debug:print-error 0 *default-log-port* "Parameter to -envdelta should be new=start-end"))))) + + ;;====================================================================== + ;; Start the server - can be done in conjunction with -runall or -runtests (one day...) + ;; we start the server if not running else start the client thread + ;;====================================================================== + + ;; Server? Start up here. + ;; + (if (args:get-arg "-server") + (let* (;; (run-id (args:get-arg "-run-id")) + (dbfname (args:get-arg "-db")) + (tl (launch:setup)) + (keys (keys:config-get-fields *configdat*))) + (case (rmt:transport-mode) + ((tcp) + (let* ((timeout (server:expiration-timeout))) + (debug:print 0 *default-log-port* "INFO: megatest -server starting on " (get-host-name) " for " dbfname " using tcp method with timeout of "timeout) + (tt-server-timeout-param timeout) + (api:queue-processor) + (thread-start! (make-thread api:print-db-stats "print-db-stats")) + (if dbfname + (tt:start-server tl #f dbfname api:tcp-dispatch-request-make-handler keys) + (begin + (debug:print 0 *default-log-port* "ERROR: transport mode is tcp - -db is required.") + (exit 1))))) + ((nfs)(debug:print 0 *default-log-port* "WARNING: server start called in nfs mode '"(rmt:transport-mode))) + (else (debug:print 0 *default-log-port* "ERROR: rmt:transport-mode value not recognised "(rmt:transport-mode)))) + (set! *didsomething* #t))) + + ;; The adjutant is a bit different, it does NOT run (launch:setup) as it is not necessarily tied to + ;; a specific Megatest area. Detail are being hashed out and this may change. + ;; + (if (args:get-arg "-adjutant") + (begin + ;; (adjutant-run) + (set! *didsomething* #t))) + + (if (args:get-arg "-list-servers") + (let* ((tl (launch:setup)) ;; need this to initialize *toppath* + (servdir (tt:get-servinfo-dir *toppath*)) + (servfiles (glob (conc servdir "/*:*.db"))) + (fmtstr "~10a~22a~10a~25a~25a~8a\n") + (dbfiles (append (glob (conc *toppath* "/.mtdb/main.db")) (glob (conc *toppath* "/.mtdb/?.db"))(glob (conc *toppath* "/.mtdb/??.db")))) + (ttdat (make-tt areapath: *toppath*)) + ) + (format #t fmtstr "DB" "host:port" "PID" "age" "last mod" "state") + (for-each + (lambda (dbfile) + (let* ( + (dbfname (conc (pathname-file dbfile) ".db")) + (sfiles (tt:find-server *toppath* dbfname)) + ) + (for-each + (lambda (sfile) + (let ( + (sinfos (tt:get-server-info-sorted ttdat dbfname)) + ) + (for-each + (lambda (sinfo) + (let* ( + (db (list-ref sinfo 5)) + (pid (list-ref sinfo 4)) + (host (list-ref sinfo 0)) + (port (list-ref sinfo 1)) + (server-id (list-ref sinfo 3)) + (age (seconds->hr-min-sec (- (current-seconds) (list-ref sinfo 2)))) + (last-mod (seconds->string (list-ref sinfo 2))) + (status (system (conc "ssh " host " ps " pid " > /dev/null"))) + (state (if (> status 0) + "dead" + (tt:ping host port server-id 0) + )) + ) + (format #t fmtstr db (conc host ":" port) pid age last-mod state) + ) + ) + sinfos + ) + ) + ) + sfiles + ) + ) + ) + dbfiles + ) + (set! *didsomething* #t) + (exit) + ) + ) + + + + + (if (args:get-arg "-kill-servers") + + (let* ((tl (launch:setup)) ;; need this to initialize *toppath* + (servdir (tt:get-servinfo-dir *toppath*)) + (servfiles (glob (conc servdir "/*:*.db"))) + (fmtstr "~10a~22a~10a~25a~25a~8a\n") + (dbfiles (if (file-exists? (conc *toppath* "/.mtdb/main.db")) (append (glob (conc *toppath* "/.mtdb/main.db")) (glob (conc *toppath* "/.mtdb/?.db"))(glob (conc *toppath* "/.mtdb/??.db"))) '())) + (ttdat (make-tt areapath: *toppath*)) + ) + (format #t fmtstr "DB" "host:port" "PID" "age" "last mod" "state") + (for-each + (lambda (dbfile) + (let* ( + (dbfname (conc (pathname-file dbfile) ".db")) + (sfiles (tt:find-server *toppath* dbfname)) + ) + (for-each + (lambda (sfile) + (let ( + (sinfos (tt:get-server-info-sorted ttdat dbfname)) + ) + (for-each + (lambda (sinfo) + (let* ( + (db (list-ref sinfo 5)) + (pid (list-ref sinfo 4)) + (host (list-ref sinfo 0)) + (port (list-ref sinfo 1)) + (server-id (list-ref sinfo 3)) + (age (seconds->hr-min-sec (- (current-seconds) (list-ref sinfo 2)))) + (last-mod (seconds->string (list-ref sinfo 2))) + (killed (system (conc "ssh " host " kill " pid " > /dev/null"))) + (dummy2 (sleep 1)) + (state (if (> (system (conc "ssh " host " ps " pid " > /dev/null")) 0) "dead" "alive")) + ) + (format #t fmtstr db (conc host ":" port) pid age last-mod state) + (system (conc "rm " sfile)) + ) + ) + sinfos + ) + ) + ) + sfiles + ) + ) + ) + dbfiles + ) + ;; remove this db, because otherwise metadata contains records for old servers, and this causes a problem with db:no-sync-get-lock-with-id. + (if (file-exists? (conc *toppath* "/.mtdb/no-sync.db")) + (delete-file (conc *toppath* "/.mtdb/no-sync.db")) + ) + (set! *didsomething* #t) + (exit) + ) + ) + + ;;====================================================================== + ;; Weird special calls that need to run *after* the server has started? + ;;====================================================================== + + (if (args:get-arg "-list-targets") + (if (launch:setup) + (let ((targets (common:get-runconfig-targets))) + ;; (debug:print 1 *default-log-port* "Found "(length targets) " targets") + (case (string->symbol (or (args:get-arg "-dumpmode") "alist")) + ((alist) + (for-each (lambda (x) + ;; (print "[" x "]")) + (print x)) + targets)) + ((json) + (json-write targets)) + (else + (debug:print-error 0 *default-log-port* "dump output format " (args:get-arg "-dumpmode") " not supported for -list-targets"))) + (set! *didsomething* #t)))) + + (if (args:get-arg "-show-runconfig") + (let ((tl (launch:setup))) + (push-directory *toppath*) + (let ((data (full-runconfigs-read))) + ;; keep this one local + (cond + ((and (args:get-arg "-section") + (args:get-arg "-var")) + (let ((val (or (configf:lookup data (args:get-arg "-section")(args:get-arg "-var")) + (configf:lookup data "default" (args:get-arg "-var"))))) + (if val (print val)))) + ((or (not (args:get-arg "-dumpmode")) + (string=? (args:get-arg "-dumpmode") "ini")) + (configf:config->ini data)) + ((string=? (args:get-arg "-dumpmode") "sexp") + (pp (hash-table->alist data))) + ((string=? (args:get-arg "-dumpmode") "json") + (json-write data)) + (else + (debug:print-error 0 *default-log-port* "-dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) + (set! *didsomething* #t)) + (pop-directory))) + + (if (args:get-arg "-show-config") + (let ((tl (launch:setup)) + (data *configdat*)) ;; (read-config "megatest.config" #f #t))) + (push-directory *toppath*) + ;; keep this one local + (cond + ((and (args:get-arg "-section") + (args:get-arg "-var")) + (let ((val (configf:lookup data (args:get-arg "-section")(args:get-arg "-var")))) + (if val (print val)))) + + ;; print just a section if only -section + + ((equal? (args:get-arg "-dumpmode") "sexp") + (pp (hash-table->alist data))) + ((equal? (args:get-arg "-dumpmode") "json") + (json-write data)) + ((or (not (args:get-arg "-dumpmode")) + (string=? (args:get-arg "-dumpmode") "ini")) + (configf:config->ini data)) + (else + (debug:print-error 0 *default-log-port* "-dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) + (set! *didsomething* #t) + (pop-directory) + (set! *time-to-exit* #t))) + + (if (args:get-arg "-show-cmdinfo") + (if (or (args:get-arg ":value")(getenv "MT_CMDINFO")) + (let ((data (common:read-encoded-string (or (args:get-arg ":value")(getenv "MT_CMDINFO"))))) + (if (equal? (args:get-arg "-dumpmode") "json") + (json-write data) + (pp data)) + (set! *didsomething* #t)) + (debug:print-info 0 *default-log-port* "environment variable MT_CMDINFO is not set"))) + + ;;====================================================================== + ;; Remove old run(s) + ;;====================================================================== + + ;; since several actions can be specified on the command line the removal + ;; is done first + (define (operate-on action #!key (mode #f)(target-in #f)(runname-in #f)(keys-in #f)(keyvals-in #f)) ;; #f is "use default" + (let* ((runrec (runs:runrec-make-record)) + (target (or target-in (common:args-get-target))) ;; eventually get rid of the call to common:args-get-target + (runname (or runname-in + (args:get-arg "-runname"))) ;; eventually get rid of the get-arg calls + (testpatt (or (args:get-arg "-testpatt") + (and (eq? action 'archive) ;; if it is an archive command fallback to MT_TEST_NAME and MT_ITEMPATH + (common:get-full-test-name)) + (and (eq? action 'kill-runs) + "%/%") ;; I'm just guessing that this is correct :( + (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt"))) + ))) ;; + (cond + ((not target) + (debug:print-error 0 *default-log-port* "Missing required parameter for " + action ", you must specify -target or -reqtarg") + (exit 1)) + ((not runname) + (debug:print-error 0 *default-log-port* "Missing required parameter for " + action ", you must specify the run name pattern with -runname patt") + (exit 2)) + ((not testpatt) + (debug:print-error 0 *default-log-port* "Missing required parameter for " + action ", you must specify the test pattern with -testpatt") + (exit 3)) + (else + (if (not (car *configinfo*)) + (begin + (debug:print-error 0 *default-log-port* "Attempted " action "on test(s) but run area config file not found") + (exit 1)) + ;; put test parameters into convenient variables + (begin + ;; check for correct version, exit with message if not correct + (common:exit-on-version-changed) + (runs:operate-on action + target + runname + testpatt + state: (common:args-get-state) + status: (common:args-get-status) + new-state-status: (args:get-arg "-set-state-status") + mode: mode))) + (set! *didsomething* #t))))) + + (if (args:get-arg "-kill-runs") + (general-run-call + "-kill-runs" + "kill runs" + (lambda (target runname keys keyvals) + (operate-on 'kill-runs mode: #f) + ))) + + (if (args:get-arg "-kill-rerun") + (let* ((target-patt (common:args-get-target)) + (runname-patt (args:get-arg "-runname"))) + (cond ((not target-patt) + (debug:print-error 0 *default-log-port* "Missing target, must specify target for -kill-rerun with -target ") + (exit 1)) + ((not runname-patt) + (debug:print-error 0 *default-log-port* "Missing runname, must specify runname for -kill-rerun with -runname ") + (exit 1)) + ((string-search "[ ,%]" target-patt) + (debug:print-error 0 *default-log-port* "Invalid target ["target-patt"], must specify exact target (no wildcards) for -kill-rerun with -target ") + (exit 1)) + ((string-search "[ ,%]" runname-patt) + (debug:print-error 0 *default-log-port* "Invalid runname ["runname-patt"], must specify exact runname (no wildcards) for -kill-rerun with -runname ") + (exit 1)) + (else + (general-run-call + "-kill-runs" + "kill runs" + (lambda (target runname keys keyvals) + (operate-on 'kill-runs mode: #f) + )) + + (thread-sleep! 15)) + ;; fall thru and let "-run" loop fire + ))) + + + (if (args:get-arg "-remove-runs") + (general-run-call + "-remove-runs" + "remove runs" + (lambda (target runname keys keyvals) + (operate-on 'remove-runs mode: (if (args:get-arg "-keep-records") + 'remove-data-only + 'remove-all))))) + + (if (args:get-arg "-remove-keep") + (general-run-call + "-remove-keep" + "remove keep" + (lambda (target runname keys keyvals) + (let ((actions (map string->symbol + (string-split + (or (args:get-arg "-actions") + "print") + ",")))) ;; default to printing the output + (runs:remove-all-but-last-n-runs-per-target target runname + (string->number (args:get-arg "-remove-keep")) + actions: actions))))) + + (if (args:get-arg "-set-state-status") + (general-run-call + "-set-state-status" + "set state and status" + (lambda (target runname keys keyvals) + (operate-on 'set-state-status)))) + + (if (or (args:get-arg "-set-run-status") + (args:get-arg "-get-run-status")) + (general-run-call + "-set-run-status" + "set run status" + (lambda (target runname keys keyvals) + (let* ((runsdat (rmt:get-runs-by-patt keys runname + (common:args-get-target) + #f #f #f #f)) + (header (vector-ref runsdat 0)) + (rows (vector-ref runsdat 1))) + (if (null? rows) + (begin + (debug:print-info 0 *default-log-port* "No matching run found.") + (exit 1)) + (let* ((row (car (vector-ref runsdat 1))) + (run-id (db:get-value-by-header row header "id"))) + (if (args:get-arg "-set-run-status") + (rmt:set-run-status run-id (args:get-arg "-set-run-status") msg: (args:get-arg "-m")) + (print (rmt:get-run-status run-id)) + ))))))) + + ;;====================================================================== + ;; Query runs + ;;====================================================================== + + ;; -fields runs:id,target,runname,comment+tests:id,testname,item_path+steps + ;; + ;; csi> (extract-fields-constraints "runs:id,target,runname,comment+tests:id,testname,item_path+steps") + ;; => (("runs" "id" "target" "runname" "comment") ("tests" "id" "testname" "item_path") ("steps")) + ;; + ;; NOTE: remember that the cdr will be the list you expect (cdr ("runs" "id" "target" "runname" "comment")) => ("id" "target" "runname" "comment") + ;; and so alist-ref will yield what you expect + ;; + (define (extract-fields-constraints fields-spec) + (map (lambda (table-spec) ;; runs:id,target,runname + (let ((dat (string-split table-spec ":"))) ;; ("runs" "id,target,runname") + (if (> (length dat) 1) + (cons (car dat)(string-split (cadr dat) ",")) ;; "id,target,runname" + dat))) + (string-split fields-spec "+"))) + + (define (get-value-by-fieldname datavec test-field-index fieldname) + (let ((indx (hash-table-ref/default test-field-index fieldname #f))) + (if indx + (if (>= indx (vector-length datavec)) + #f ;; index too high, should raise an error I suppose + (vector-ref datavec indx)) + #f))) + + + + + + (when (args:get-arg "-testdata-csv") + (if (launch:setup) + (let* ((keys (rmt:get-keys)) ;; (db:get-keys dbstruct)) + (runpatt (or (args:get-arg "-runname") "%")) + (testpatt (common:args-get-testpatt #f)) + (datapatt (args:get-arg "-testdata-csv")) + (match-data (string-match "^([^/]+)/(.*)" (args:get-arg "-testdata-csv"))) + (categorypatt (if match-data (list-ref match-data 1) "%")) + (setvarpatt (if match-data + (list-ref match-data 2) + (args:get-arg "-testdata-csv"))) + (runsdat (rmt:get-runs-by-patt keys (or runpatt "%") + (common:args-get-target) #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0)) + (header (db:get-header runsdat)) + (access-mode (db:get-access-mode)) + (testpatt (common:args-get-testpatt #f)) + (fields-spec (if (args:get-arg "-fields") + (extract-fields-constraints (args:get-arg "-fields")) + (list (cons "runs" (append keys (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count"))) + (cons "tests" db:test-record-fields) ;; "id" "testname" "test_path") + (list "steps" "id" "stepname")))) + (tests-spec (let ((t (alist-ref "tests" fields-spec equal?))) + (if (and t (null? t)) ;; all fields + db:test-record-fields + t))) + (adj-tests-spec (delete-duplicates (if tests-spec (cons "id" tests-spec) db:test-record-fields))) + (test-field-index (make-hash-table)) + (runs (db:get-rows runsdat)) + ) + (if (and tests-spec (not (null? tests-spec))) ;; do some validation and processing of the test-spec + (let ((invalid-tests-spec (filter (lambda (x)(not (member x db:test-record-fields))) tests-spec))) + (if (null? invalid-tests-spec) + ;; generate the lookup map test-field-name => index-number + (let loop ((hed (car adj-tests-spec)) + (tal (cdr adj-tests-spec)) + (idx 0)) + (hash-table-set! test-field-index hed idx) + (if (not (null? tal))(loop (car tal)(cdr tal)(+ idx 1)))) + (begin + (debug:print-error 0 *default-log-port* "Invalid test fields specified: " (string-intersperse invalid-tests-spec ", ")) + (exit))))) + (let* ((table-header (string-split "target,run,test,itempath,category,var,value,comment" ",")) + (table-rows + (apply append (map + (lambda (run) + (let* ((target (string-intersperse (map (lambda (x) + (db:get-value-by-header run header x)) + keys) "/")) + (statuses (string-split (or (args:get-arg "-status") "") ",")) + (run-id (db:get-value-by-header run header "id")) + (runname (db:get-value-by-header run header "runname")) + (states (string-split (or (args:get-arg "-state") "") ",")) + (tests (if tests-spec + (rmt:get-tests-for-run run-id testpatt states statuses #f #f #f 'testname 'asc ;; (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc + ;; use qryvals if test-spec provided + (if tests-spec + (string-intersperse adj-tests-spec ",") + ;; db:test-record-fields + #f) + #f + 'normal) + '()))) + (apply append + (map + (lambda (test) + (let* ( + (test-id (if (member "id" tests-spec)(get-value-by-fieldname test test-field-index "id" ) #f)) ;; (db:test-get-id test)) + (testname (if (member "testname" tests-spec)(get-value-by-fieldname test test-field-index "testname" ) #f)) ;; (db:test-get-testname test)) + (itempath (if (member "item_path" tests-spec)(get-value-by-fieldname test test-field-index "item_path" ) #f)) ;; (db:test-get-item-path test)) + (fullname (conc testname + (if (equal? itempath "") + "" + (conc "/" itempath )))) + (testdat-raw (map vector->list (rmt:read-test-data-varpatt run-id test-id categorypatt setvarpatt))) + (testdat (filter + (lambda (x) + (not (equal? "logpro" + (list-ref x 10)))) + testdat-raw))) + (map + (lambda (item) + (receive (id test_id category + variable value expected + tol units comment status type) + (apply values item) + (list target runname testname itempath category variable value comment))) + testdat))) + tests)))) + runs)))) + (print (string-join table-header ",")) + (for-each (lambda(table-row) + (print (string-join (map ->string table-row) ","))) + + + table-rows)))) + (set! *didsomething* #t) + (set! *time-to-exit* #t)) + + + + ;; NOTE: list-runs and list-db-targets operate on local db!!! + ;; + ;; IDEA: megatest list -runname blah% ... + ;; + (if (or (args:get-arg "-list-runs") + (args:get-arg "-list-db-targets")) + (if (launch:setup) + (let* ((runpatt (args:get-arg "-list-runs")) + (access-mode (db:get-access-mode)) + (testpatt (common:args-get-testpatt #f)) + ;; (if (args:get-arg "-testpatt") + ;; (args:get-arg "-testpatt") + ;; "%")) + (keys (rmt:get-keys)) ;; (db:get-keys dbstruct)) + ;; (runsdat (db:get-runs dbstruct runpatt #f #f '())) + ;; (runsdat (rmt:get-runs-by-patt keys (or runpatt "%") (common:args-get-target) ;; (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target) + ;; #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0)) + (runsdat (rmt:get-runs-by-patt keys (or runpatt "%") + (common:args-get-target) #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0)) + (runstmp (db:get-rows runsdat)) + (header (db:get-header runsdat)) + ;; this is "-since" support. This looks at last mod times of .db files + ;; and collects those modified since the -since time. + (runs runstmp) + ;; (if (and (not (null? runstmp)) + ;; (args:get-arg "-since")) + ;; (let ((changed-ids (db:get-changed-run-ids (string->number (args:get-arg "-since"))))) + ;; (let loop ((hed (car runstmp)) + ;; (tal (cdr runstmp)) + ;; (res '())) + ;; (let ((new-res (if (member (db:get-value-by-header hed header "id") changed-ids) + ;; (cons hed res) + ;; res))) + ;; (if (null? tal) + ;; (reverse new-res) + ;; (loop (car tal)(cdr tal) new-res))))) + ;; runstmp)) + (db-targets (args:get-arg "-list-db-targets")) + (seen (make-hash-table)) + (dmode (let ((d (args:get-arg "-dumpmode"))) ;; json, sexpr + (if d (string->symbol d) #f))) + (data (make-hash-table)) + (fields-spec (if (args:get-arg "-fields") + (extract-fields-constraints (args:get-arg "-fields")) + (list (cons "runs" (append keys (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count"))) + (cons "tests" db:test-record-fields) ;; "id" "testname" "test_path") + (list "steps" "id" "stepname")))) + (runs-spec (let ((r (alist-ref "runs" fields-spec equal?))) ;; the check is now unnecessary + (if (and r (not (null? r))) r (list "id" )))) + (tests-spec (let ((t (alist-ref "tests" fields-spec equal?))) + (if (and t (null? t)) ;; all fields + db:test-record-fields + t))) + (adj-tests-spec (delete-duplicates (if tests-spec (cons "id" tests-spec) db:test-record-fields))) ;; '("id")))) + (steps-spec (alist-ref "steps" fields-spec equal?)) + (test-field-index (make-hash-table))) + (if (and (args:get-arg "-dumpmode") + (not (member (args:get-arg "-dumpmode") '("sexpr" "json" "ods" "list")))) + (begin + (debug:print 0 *default-log-port* "ERROR: dumpmode "(args:get-arg "-dumpmode")" not recognised. Use sexpr, json, ods or list") + (exit))) + (if (and tests-spec (not (null? tests-spec))) ;; do some validation and processing of the test-spec + (let ((invalid-tests-spec (filter (lambda (x)(not (member x db:test-record-fields))) tests-spec))) + (if (null? invalid-tests-spec) + ;; generate the lookup map test-field-name => index-number + (let loop ((hed (car adj-tests-spec)) + (tal (cdr adj-tests-spec)) + (idx 0)) + (hash-table-set! test-field-index hed idx) + (if (not (null? tal))(loop (car tal)(cdr tal)(+ idx 1)))) + (begin + (debug:print-error 0 *default-log-port* "Invalid test fields specified: " (string-intersperse invalid-tests-spec ", ")) + (exit))))) + ;; Each run + (for-each + (lambda (run) + (let ((targetstr (string-intersperse (map (lambda (x) + (db:get-value-by-header run header x)) + keys) "/"))) + (if db-targets + (if (not (hash-table-ref/default seen targetstr #f)) + (begin + (hash-table-set! seen targetstr #t) + ;; (print "[" targetstr "]")))) + (if (not dmode) + (print targetstr) + (hash-table-set! data "targets" (cons targetstr (hash-table-ref/default data "targets" '()))) + ))) + (let* ((run-id (db:get-value-by-header run header "id")) + (runname (db:get-value-by-header run header "runname")) + (states (string-split (or (args:get-arg "-state") "") ",")) + (statuses (string-split (or (args:get-arg "-status") "") ",")) + (tests (if tests-spec + (rmt:get-tests-for-run run-id testpatt states statuses #f #f #f 'testname 'asc ;; (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc + ;; use qryvals if test-spec provided + (if tests-spec + (string-intersperse adj-tests-spec ",") + ;; db:test-record-fields + #f) + #f + 'normal) + '()))) + (case dmode + ((json ods sexpr) + (if runs-spec + (for-each + (lambda (field-name) + (mutils:hierhash-set! data (conc (db:get-value-by-header run header field-name)) targetstr runname "meta" field-name)) + runs-spec))) + ;; (mutils:hierhash-set! data (db:get-value-by-header run header "status") targetstr runname "meta" "status" ) + ;; (mutils:hierhash-set! data (db:get-value-by-header run header "state") targetstr runname "meta" "state" ) + ;; (mutils:hierhash-set! data (conc (db:get-value-by-header run header "id")) targetstr runname "meta" "id" ) + ;; (mutils:hierhash-set! data (db:get-value-by-header run header "event_time") targetstr runname "meta" "event_time" ) + ;; (mutils:hierhash-set! data (db:get-value-by-header run header "comment") targetstr runname "meta" "comment" ) + ;; ;; add last entry twice - seems to be a bug in hierhash? + ;; (mutils:hierhash-set! data (db:get-value-by-header run header "comment") targetstr runname "meta" "comment" ) + ((#f list) + (if (null? runs-spec) + (print "Run: " targetstr "/" runname + " status: " (db:get-value-by-header run header "state") + " run-id: " run-id ", number tests: " (length tests) + " event_time: " (db:get-value-by-header run header "event_time")) + (begin + (if (not (member "target" runs-spec)) + ;; (display (conc "Target: " targetstr)) + (display (conc "Run: " targetstr "/" runname " "))) + (for-each + (lambda (field-name) + (if (equal? field-name "target") + (display (conc "target: " targetstr " ")) + (display (conc field-name ": " (db:get-value-by-header run header (conc field-name)) " ")))) + runs-spec) + (newline)))) + (else + (debug:print 0 *default-log-port* "ERROR: dumpmode "(args:get-arg "-dumpmode")" not recognised. Use sexpr, json, ods or list") + )) + + (for-each + (lambda (test) + (common:debug-handle-exceptions #f + exn + (begin + (debug:print-error 0 *default-log-port* "Bad data in test record? " test) + (debug:print-error 5 *default-log-port* "exn=" (condition->list exn)) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (print-call-chain (current-error-port))) + (let* ((test-id (if (member "id" tests-spec)(get-value-by-fieldname test test-field-index "id" ) #f)) ;; (db:test-get-id test)) + (testname (if (member "testname" tests-spec)(get-value-by-fieldname test test-field-index "testname" ) #f)) ;; (db:test-get-testname test)) + (itempath (if (member "item_path" tests-spec)(get-value-by-fieldname test test-field-index "item_path" ) #f)) ;; (db:test-get-item-path test)) + (comment (if (member "comment" tests-spec)(get-value-by-fieldname test test-field-index "comment" ) #f)) ;; (db:test-get-comment test)) + (tstate (if (member "state" tests-spec)(get-value-by-fieldname test test-field-index "state" ) #f)) ;; (db:test-get-state test)) + (tstatus (if (member "status" tests-spec)(get-value-by-fieldname test test-field-index "status" ) #f)) ;; (db:test-get-status test)) + (event-time (if (member "event_time" tests-spec)(get-value-by-fieldname test test-field-index "event_time" ) #f)) ;; (db:test-get-event_time test)) + (rundir (if (member "rundir" tests-spec)(get-value-by-fieldname test test-field-index "rundir" ) #f)) ;; (db:test-get-rundir test)) + (final_logf (if (member "final_logf" tests-spec)(get-value-by-fieldname test test-field-index "final_logf" ) #f)) ;; (db:test-get-final_logf test)) + (run_duration (if (member "run_duration" tests-spec)(get-value-by-fieldname test test-field-index "run_duration") #f)) ;; (db:test-get-run_duration test)) + (fullname (conc testname + (if (equal? itempath "") + "" + (conc "(" itempath ")"))))) + (case dmode + ((json ods sexpr) + (if tests-spec + (for-each + (lambda (field-name) + (mutils:hierhash-set! data (get-value-by-fieldname test test-field-index field-name) targetstr runname "data" (conc test-id) field-name)) + tests-spec))) + ;; ;; (mutils:hierhash-set! data fullname targetstr runname "data" (conc test-id) "tname" ) + ;; (mutils:hierhash-set! data testname targetstr runname "data" (conc test-id) "testname" ) + ;; (mutils:hierhash-set! data itempath targetstr runname "data" (conc test-id) "itempath" ) + ;; (mutils:hierhash-set! data comment targetstr runname "data" (conc test-id) "comment" ) + ;; (mutils:hierhash-set! data tstate targetstr runname "data" (conc test-id) "state" ) + ;; (mutils:hierhash-set! data tstatus targetstr runname "data" (conc test-id) "status" ) + ;; (mutils:hierhash-set! data rundir targetstr runname "data" (conc test-id) "rundir" ) + ;; (mutils:hierhash-set! data final_logf targetstr runname "data" (conc test-id) "final_logf") + ;; (mutils:hierhash-set! data run_duration targetstr runname "data" (conc test-id) "run_duration") + ;; (mutils:hierhash-set! data event-time targetstr runname "data" (conc test-id) "event_time") + ;; ;; add last entry twice - seems to be a bug in hierhash? + ;; (mutils:hierhash-set! data event-time targetstr runname "data" (conc test-id) "event_time") + ;; ) + (else + (if (and tstate tstatus event-time) + (format #t + " Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n" + (if fullname fullname "") + (if tstate tstate "") + (if tstatus tstatus "") + (get-value-by-fieldname test test-field-index "run_duration");;(if test (db:test-get-run_duration test) "") + (if event-time event-time "") + (get-value-by-fieldname test test-field-index "host")) ;;(if test (db:test-get-host test)) "") + (print " Test: " fullname + (if tstate (conc " State: " tstate) "") + (if tstatus (conc " Status: " tstatus) "") + (if (get-value-by-fieldname test test-field-index "run_duration") + (conc " Runtime: " (get-value-by-fieldname test test-field-index "run_duration")) + "") + (if event-time (conc " Time: " event-time) "") + (if (get-value-by-fieldname test test-field-index "host") + (conc " Host: " (get-value-by-fieldname test test-field-index "host")) + ""))) + (if (not (or (equal? (get-value-by-fieldname test test-field-index "status") "PASS") + (equal? (get-value-by-fieldname test test-field-index "status") "WARN") + (equal? (get-value-by-fieldname test test-field-index "state") "NOT_STARTED"))) + (begin + (print (if (get-value-by-fieldname test test-field-index "cpuload") + (conc " cpuload: " (get-value-by-fieldname test test-field-index "cpuload")) + "") ;; (db:test-get-cpuload test) + (if (get-value-by-fieldname test test-field-index "diskfree") + (conc "\n diskfree: " (get-value-by-fieldname test test-field-index "diskfree")) ;; (db:test-get-diskfree test) + "") + (if (get-value-by-fieldname test test-field-index "uname") + (conc "\n uname: " (get-value-by-fieldname test test-field-index "uname")) ;; (db:test-get-uname test) + "") + (if (get-value-by-fieldname test test-field-index "rundir") + (conc "\n rundir: " (get-value-by-fieldname test test-field-index "rundir")) ;; (db:test-get-rundir test) + "") + ;; "\n rundir: " (get-value-by-fieldname test test-field-index "") ;; (sdb:qry 'getstr ;; (filedb:get-path *fdb* + ;; (db:test-get-rundir test) ;; ) + ) + ;; Each test + ;; DO NOT remote run + (let ((steps (rmt:get-steps-for-test run-id (db:test-get-id test)))) ;; (db:get-steps-for-test dbstruct run-id (db:test-get-id test)))) + (for-each + (lambda (step) + (format #t + " Step: ~20a State: ~10a Status: ~10a Time ~22a\n" + (tdb:step-get-stepname step) + (tdb:step-get-state step) + (tdb:step-get-status step) + (tdb:step-get-event_time step))) + steps))))))))) + (if (args:get-arg "-sort") + (sort tests + (lambda (a-test b-test) + (let* ((key (args:get-arg "-sort")) + (first (get-value-by-fieldname a-test test-field-index key)) + (second (get-value-by-fieldname b-test test-field-index key))) + ((cond + ((and (number? first)(number? second)) <) + ((and (string? first)(string? second)) string<=?) + (else equal?)) + first second)))) + tests)))))) + runs) + (case dmode + ((json) (json-write data)) + ((sexpr) (pp (common:to-alist data)))) + (let* ((metadat-fields (delete-duplicates + (append keys '( "runname" "time" "owner" "pass_count" "fail_count" "state" "status" "comment" "id")))) + (run-fields '( + "testname" + "item_path" + "state" + "status" + "comment" + "event_time" + "host" + "run_id" + "run_duration" + "attemptnum" + "id" + "archived" + "diskfree" + "cpuload" + "final_logf" + "shortdir" + "rundir" + "uname" + ) + ) + (newdat (common:to-alist data)) + (allrundat (if (null? newdat) + '() + (car (map cdr newdat)))) ;; (car (map cdr (car (map cdr newdat))))) + (runs (append + (list "runs" ;; sheetname + metadat-fields) + (map (lambda (run) + ;; (print "run: " run) + (let* ((runname (car run)) + (rundat (cdr run)) + (metadat (let ((tmp (assoc "meta" rundat))) + (if tmp (cdr tmp) #f)))) + ;; (print "runname: " runname "\n\nrundat: " )(pp rundat)(print "\n\nmetadat: ")(pp metadat) + (if metadat + (map (lambda (field) + (let ((tmp (assoc field metadat))) + (if tmp (cdr tmp) ""))) + metadat-fields) + (begin + (debug:print 0 *default-log-port* "WARNING: meta data for run " runname " not found") + '())))) + allrundat))) + ;; '( ( "target" ( "runname" ( "data" ( "runid" ( "id . "37" ) ( ... )))) + (run-pages (map (lambda (targdat) + (let* ((target (car targdat)) + (runsdat (cdr targdat))) + (if runsdat + (map (lambda (rundat) + (let* ((runname (car rundat)) + (rundat (cdr rundat)) + (testsdat (let ((tmp (assoc "data" rundat))) + (if tmp (cdr tmp) #f)))) + (if testsdat + (let ((tests (map (lambda (test) + (let* ((test-id (car test)) + (test-dat (cdr test))) + (map (lambda (field) + (let ((tmp (assoc field test-dat))) + (if tmp (cdr tmp) ""))) + run-fields))) + testsdat))) + ;; (print "Target: " target "/" runname " tests:") + ;; (pp tests) + (cons (conc target "/" runname) + (cons (list (conc target "/" runname)) + (cons '() + (cons run-fields tests))))) + (begin + (debug:print 4 *default-log-port* "WARNING: run " target "/" runname " appears to have no data") + ;; (pp rundat) + '())))) + runsdat) + '()))) + newdat)) ;; we use newdat to get target + (sheets (filter (lambda (x) + (not (null? x))) + (cons runs (map car run-pages))))) + ;; (print "allrundat:") + ;; (pp allrundat) + ;; (print "runs:") + ;; (pp runs) + ;(print "sheets: ") + ;; (pp sheets) + (if (eq? dmode 'ods) + (let* ((tempdir (conc "/tmp/" (current-user-name) "/" (random 10000) "_" (current-process-id))) + (outputfile (or (args:get-arg "-o") "out.ods")) + (ouf (if (string-match (regexp "^[/~]+.*") outputfile) ;; full path? + outputfile + (begin + (debug:print 0 *default-log-port* "WARNING: path given, " outputfile " is relative, prefixing with current directory") + (conc (current-directory) "/" outputfile))))) + (create-directory tempdir #t) + (ods:list->ods tempdir ouf sheets)))) + ;; (system (conc "rm -rf " tempdir)) + (set! *didsomething* #t) + (set! *time-to-exit* #t) + ) ;; end if true branch (end of a let) + ) ;; end if + ) ;; end if -list-runs + + ;; list-waivers + (if (and (args:get-arg "-list-waivers") + (launch:setup)) + (let* ((runpatt (or (args:get-arg "-runname") "%")) + (testpatt (common:args-get-testpatt #f)) + (keys (rmt:get-keys)) + (runsdat (rmt:get-runs-by-patt + keys runpatt + (common:args-get-target) #f #f + '("id" "runname" "state" "status" "owner" "event_time" "comment") 0)) + (runs (db:get-rows runsdat)) + (header (db:get-header runsdat)) + (results (make-hash-table)) ;; [target] ( (testname/itempath . "comment") ... ) + (addtest (lambda (target testname itempath comment) + (hash-table-set! results target (cons (cons (conc testname "/" itempath) comment) + (hash-table-ref/default results target '()))))) + (last-target #f)) + (for-each + (lambda (run) + (let* ((run-id (db:get-value-by-header run header "id")) + (target (rmt:get-target run-id)) + (runname (db:get-value-by-header run header "runname")) + (tests (rmt:get-tests-for-run + run-id testpatt '("COMPLETED") '("WAIVED") #f #f #f 'testname 'asc ;; use qryvals if test-spec provided + #f #f #f))) + (if (not (equal? target last-target)) + (print "[" target "]")) + (set! last-target target) + (print "# " runname) + (for-each + (lambda (testdat) + (let* ((testfullname (conc (db:test-get-testname testdat) + (if (equal? "" (db:test-get-item-path testdat)) + "" + (conc "/" (db:test-get-item-path testdat))) + ))) + (print testfullname " " (db:test-get-comment testdat)))) + tests))) + runs) + (set! *didsomething* #t))) + + ;;====================================================================== + ;; full run + ;;====================================================================== + + (define (handle-run-requests target runname keys keyvals need-clean) + (if (or (args:get-arg "-kill-rerun") (args:get-arg "-rerun-clean")) ;; first set states/statuses correct + ;; For rerun-clean do we or do we not support the testpatt? + (let ((states (or (configf:lookup *configdat* "validvalues" "cleanrerun-states") + "KILLREQ,KILLED,UNKNOWN,INCOMPLETE,STUCK,NOT_STARTED")) + (statuses (or (configf:lookup *configdat* "validvalues" "cleanrerun-statuses") + "FAIL,INCOMPLETE,ABORT,CHECK,DEAD,PREQ_FAIL,PREQ_DISCARDED"))) + (hash-table-set! args:arg-hash "-preclean" #t) + (runs:operate-on 'set-state-status + target + (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) + ;; "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") + (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") + state: states + ;; status: statuses + new-state-status: "NOT_STARTED,n/a") + (runs:clean-cache target runname *toppath*) + (runs:operate-on 'set-state-status + target + (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) + ;; "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") + (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") + ;; state: states + status: statuses + new-state-status: "NOT_STARTED,n/a"))) + ;; RERUN ALL + (if (args:get-arg "-rerun-all") ;; first set states/statuses correct + (let* ((rconfig (full-runconfigs-read))) + (hash-table-set! args:arg-hash "-preclean" #t) + (runs:operate-on 'set-state-status + target + (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) + (common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt") + state: #f + ;; status: statuses + new-state-status: "NOT_STARTED,n/a") + (runs:clean-cache target runname *toppath*) + (runs:operate-on 'set-state-status + target + (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) + (common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt") + ;; state: states + status: #f + new-state-status: "NOT_STARTED,n/a"))) + (let* ((config-reruns (let ((x (configf:lookup *configdat* "setup" "reruns"))) + (if x (string->number x) #f))) + (rerun-cnt (if config-reruns + config-reruns + 1))) + + (runs:run-tests target + runname + #f ;; (common:args-get-testpatt #f) + ;; (or (args:get-arg "-testpatt") + ;; "%") + (current-user-name) + args:arg-hash + run-count: rerun-cnt))) + + ;; get lock in db for full run for this directory + ;; for all tests with deps + ;; walk tree of tests to find head tasks + ;; add head tasks to task queue + ;; add dependant tasks to task queue + ;; add remaining tasks to task queue + ;; for each task in task queue + ;; if have adequate resources + ;; launch task + ;; else + ;; put task in deferred queue + ;; if still ok to run tasks + ;; process deferred tasks per above steps + + ;; run all tests are are Not COMPLETED and PASS or CHECK + (if (or (args:get-arg "-runall") + (args:get-arg "-run") + (args:get-arg "-rerun-clean") + (args:get-arg "-rerun-all") + (args:get-arg "-runtests") + (args:get-arg "-kill-rerun")) + (let ((need-clean (or (args:get-arg "-rerun-clean") + (args:get-arg "-rerun-all"))) + (orig-cmdline (string-intersperse (argv) " "))) + (general-run-call + "-runall" + "run all tests" + (lambda (target runname keys keyvals) + (if (or (string-search "%" target) + (string-search "%" runname)) ;; we are being asked to re-run multiple runs + (let* ((run-specs (rmt:simple-get-runs runname #f #f target #f))) ;; list of simple-run records + (debug:print-info 0 *default-log-port* "Pattern supplied for target or runname with " + (length run-specs) " matches found. Running each in turn.") + (if (null? run-specs) + (debug:print 0 *default-log-port* "WARNING: No runs match target " target " and runname " runname)) + (for-each (lambda (spec) + (let* ((precmd (if (args:get-arg "-precmd")(conc (args:get-arg "-precmd") " ") "")) + (newcmdline (conc + precmd + (string-substitute + (conc "target " target) + (conc "target " (simple-run-target spec)) + (string-substitute + (conc "runname " runname) + (conc "runname " (simple-run-runname spec)) + orig-cmdline))))) + (debug:print 0 *default-log-port* "ORIG: " orig-cmdline) + (debug:print 0 *default-log-port* "NEW: " newcmdline) + (system newcmdline))) + run-specs)) + (handle-run-requests target runname keys keyvals need-clean)))) + (set! *didsomething* #t))) + + ;;====================================================================== + ;; run one test + ;;====================================================================== + + ;; 1. find the config file + ;; 2. change to the test directory + ;; 3. update the db with "test started" status, set running host + ;; 4. process launch the test + ;; - monitor the process, update stats in the db every 2^n minutes + ;; 5. as the test proceeds internally it calls megatest as each step is + ;; started and completed + ;; - step started, timestamp + ;; - step completed, exit status, timestamp + ;; 6. test phone home + ;; - if test run time > allowed run time then kill job + ;; - if cannot access db > allowed disconnect time then kill job + + ;; == duplicated == (if (or (args:get-arg "-run")(args:get-arg "-runtests")) + ;; == duplicated == (general-run-call + ;; == duplicated == "-runtests" + ;; == duplicated == "run a test" + ;; == duplicated == (lambda (target runname keys keyvals) + ;; == duplicated == ;; + ;; == duplicated == ;; May or may not implement it this way ... + ;; == duplicated == ;; + ;; == duplicated == ;; Insert this run into the tasks queue + ;; == duplicated == ;; (open-run-close tasks:add tasks:open-db + ;; == duplicated == ;; "runtests" + ;; == duplicated == ;; user + ;; == duplicated == ;; target + ;; == duplicated == ;; runname + ;; == duplicated == ;; (args:get-arg "-runtests") + ;; == duplicated == ;; #f)))) + ;; == duplicated == (runs:run-tests target + ;; == duplicated == runname + ;; == duplicated == (common:args-get-testpatt #f) ;; (args:get-arg "-runtests") + ;; == duplicated == user + ;; == duplicated == args:arg-hash)))) + + ;;====================================================================== + ;; Rollup into a run + ;;====================================================================== + +;; (if (args:get-arg "-rollup") +;; (general-run-call +;; "-rollup" +;; "rollup tests" +;; (lambda (target runname keys keyvals) +;; (runs:rollup-run keys +;; keyvals +;; (or (args:get-arg "-runname")(args:get-arg ":runname") ) +;; user)))) + + ;;====================================================================== + ;; Lock or unlock a run + ;;====================================================================== + + (if (or (args:get-arg "-lock")(args:get-arg "-unlock")) + (general-run-call + (if (args:get-arg "-lock") "-lock" "-unlock") + "lock/unlock tests" + (lambda (target runname keys keyvals) + (runs:handle-locking + target + keys + (or (args:get-arg "-runname")(args:get-arg ":runname") ) + (args:get-arg "-lock") + (args:get-arg "-unlock") + (current-user-name))))) + + ;;====================================================================== + ;; Get paths to tests + ;;====================================================================== + ;; Get test paths matching target, runname, and testpatt + (if (or (args:get-arg "-test-files")(args:get-arg "-test-paths")) + ;; if we are in a test use the MT_CMDINFO data + (if (getenv "MT_CMDINFO") + (let* ((startingdir (current-directory)) + (cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) + (transport (assoc/default 'transport cmdinfo)) + (testpath (assoc/default 'testpath cmdinfo)) + (test-name (assoc/default 'test-name cmdinfo)) + (runscript (assoc/default 'runscript cmdinfo)) + (db-host (assoc/default 'db-host cmdinfo)) + (run-id (assoc/default 'run-id cmdinfo)) + (itemdat (assoc/default 'itemdat cmdinfo)) + (state (args:get-arg ":state")) + (status (args:get-arg ":status")) + ;;(target (args:get-arg "-target")) + (target (common:args-get-target)) + (toppath (assoc/default 'toppath cmdinfo))) + (change-directory toppath) + (if (not target) + (begin + (debug:print-error 0 *default-log-port* "-target is required.") + (exit 1))) + (if (not (launch:setup)) + (begin + (debug:print 0 *default-log-port* "Failed to setup, giving up on -test-paths or -test-files, exiting") + (exit 1))) + (let* ((keys (rmt:get-keys)) + ;; db:test-get-paths must not be run remote + (paths (tests:test-get-paths-matching keys target (args:get-arg "-test-files")))) + (set! *didsomething* #t) + (for-each (lambda (path) + (if (common:file-exists? path) + (print path))) + paths))) + ;; else do a general-run-call + (general-run-call + "-test-files" + "Get paths to test" + (lambda (target runname keys keyvals) + (let* ((db #f) + ;; DO NOT run remote + (paths (tests:test-get-paths-matching keys target (args:get-arg "-test-files")))) + (for-each (lambda (path) + (print path)) + paths)))))) + + ;;====================================================================== + ;; Utils for test areas + ;;====================================================================== + + (if (args:get-arg "-regen-testfiles") + (if (getenv "MT_TEST_RUN_DIR") + (begin + (launch:setup) + (change-directory (getenv "MT_TEST_RUN_DIR")) + (let* ((testname (getenv "MT_TEST_NAME")) + (itempath (getenv "MT_ITEMPATH"))) + (launch:extract-scripts-logpro (getenv "MT_TEST_RUN_DIR") testname itempath #f)) + (set! *didsomething* #t)) + (debug:print 0 *default-log-port* "ERROR: Must run -regen-testfiles in a test environment (i.e. test xterm from dashboard)"))) + + ;;====================================================================== + ;; Archive tests + ;;====================================================================== + ;; Archive tests matching target, runname, and testpatt + (if (equal? (args:get-arg "-archive") "replicate-db") + (begin + ;; check if source + ;; check if megatest.db exist + (launch:setup) + (if (not (args:get-arg "-source")) + (begin + (debug:print-info 1 *default-log-port* "Missing required argument -source ") + (exit 1))) + (if (common:file-exists? (conc *toppath* "/megatest.db")) + (begin + (debug:print-info 1 *default-log-port* "File " (conc *toppath* "/megatest.db") " already exists. Please remove it before trying to replicate db") + (exit 1))) + (if (and (common:make-tmpdir-name *toppath* "") (> (length (directory (common:make-tmpdir-name *toppath* "") #f)) 0)) + (begin + (debug:print-info 1 *default-log-port* (common:make-tmpdir-name *toppath* "") " not empty. Please remove it before trying to replicate db") + (exit 1))) + ;; check if timestamp + (let* ((source (args:get-arg "-source")) + (src (if (not (equal? (substring source 0 1) "/")) + (conc (current-directory) "/" source) + source)) + (ts (if (args:get-arg "-time-stamp") (args:get-arg "-time-stamp") "latest"))) + (if (common:directory-exists? src) + (begin + (archive:restore-db src ts) + (set! *didsomething* #t)) + (begin + (debug:print-error 1 *default-log-port* "Path " source " not found") + (exit 1)))))) + ;; else do a general-run-call + (if (and (args:get-arg "-archive") (not (equal? (args:get-arg "-archive") "replicate-db"))) + (begin + ;; for the archive get we need to preserve the starting dir as part of the target path + (if (and (args:get-arg "-dest") + (not (equal? (substring (args:get-arg "-dest") 0 1) "/"))) + (let ((newpath (conc (current-directory) "/" (args:get-arg "-dest")))) + (debug:print-info 1 *default-log-port* "Preserving original path to destination, was " (args:get-arg "-dest") ", now " newpath) + (hash-table-set! args:arg-hash "-dest" newpath))) + (general-run-call + "-archive" + "Archive" + (lambda (target runname keys keyvals) + (operate-on 'archive target-in: target runname-in: runname ))))) + + ;;====================================================================== + ;; Extract a spreadsheet from the runs database + ;;====================================================================== + + (if (args:get-arg "-extract-ods") + (general-run-call + "-extract-ods" + "Make ods spreadsheet" + (lambda (target runname keys keyvals) + (let ((dbstruct (make-dbr:dbstruct areapath: *toppath* local: #t)) + (outputfile (args:get-arg "-extract-ods")) + (runspatt (or (args:get-arg "-runname")(args:get-arg ":runname"))) + (pathmod (args:get-arg "-pathmod"))) + ;; (keyvalalist (keys->alist keys "%"))) + (debug:print 2 *default-log-port* "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvals: " keyvals) + (db:extract-ods-file dbstruct outputfile keyvals (if runspatt runspatt "%") pathmod) + (db:close-all dbstruct) + (set! *didsomething* #t))))) + + ;;====================================================================== + ;; execute the test + ;; - gets called on remote host + ;; - receives info from the -execute param + ;; - passes info to steps via MT_CMDINFO env var (future is to use a dot file) + ;; - gathers host info and + ;;====================================================================== + + (if (args:get-arg "-execute") + (begin + (launch:execute (args:get-arg "-execute")) + (set! *didsomething* #t))) + + ;;====================================================================== + ;; recover from a test where the managing mtest was killed but the underlying + ;; process might still be salvageable + ;;====================================================================== + + (if (args:get-arg "-recover-test") + (let* ((params (string-split (args:get-arg "-recover-test") ","))) + (if (> (length params) 1) ;; run-id and test-id + (let ((run-id (string->number (car params))) + (test-id (string->number (cadr params)))) + (if (and run-id test-id) + (begin + (launch:recover-test run-id test-id) + (set! *didsomething* #t)) + (begin + (debug:print-error 0 *default-log-port* "bad run-id or test-id, must be integers") + (exit 1))))))) + + ;;====================================================================== + ;; Test commands (i.e. for use inside tests) + ;;====================================================================== + + (define (megatest:step step state status logfile msg) + (if (not (getenv "MT_CMDINFO")) + (begin + (debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!") + (exit 5)) + (let* ((cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) + (transport (assoc/default 'transport cmdinfo)) + (testpath (assoc/default 'testpath cmdinfo)) + (test-name (assoc/default 'test-name cmdinfo)) + (runscript (assoc/default 'runscript cmdinfo)) + (db-host (assoc/default 'db-host cmdinfo)) + (run-id (assoc/default 'run-id cmdinfo)) + (test-id (assoc/default 'test-id cmdinfo)) + (itemdat (assoc/default 'itemdat cmdinfo)) + (work-area (assoc/default 'work-area cmdinfo)) + (db #f)) + (change-directory testpath) + (if (not (launch:setup)) + (begin + (debug:print 0 *default-log-port* "Failed to setup, exiting") + (exit 1))) + (if (and state status) + (let ((comment (launch:load-logpro-dat run-id test-id step))) + ;; (rmt:test-set-log! run-id test-id (conc stepname ".html")))) + (rmt:teststep-set-status! run-id test-id step state status (or comment msg) logfile)) + (begin + (debug:print-error 0 *default-log-port* "You must specify :state and :status with every call to -step") + (exit 6)))))) + + (if (args:get-arg "-step") + (begin + (thread-sleep! 1.5) + (megatest:step + (args:get-arg "-step") + (or (args:get-arg "-state")(args:get-arg ":state")) + (or (args:get-arg "-status")(args:get-arg ":status")) + (args:get-arg "-setlog") + (args:get-arg "-m")) + ;; (if db (sqlite3:finalize! db)) + (set! *didsomething* #t) + (thread-sleep! 1.5))) + + (if (or (args:get-arg "-setlog") ;; since setting up is so costly lets piggyback on -test-status + ;; (not (args:get-arg "-step"))) ;; -setlog may have been processed already in the "-step" previous + ;; NEW POLICY - -setlog sets test overall log on every call. + (args:get-arg "-set-toplog") + (args:get-arg "-test-status") + (args:get-arg "-set-values") + (args:get-arg "-load-test-data") + (args:get-arg "-runstep") + (args:get-arg "-summarize-items")) + (if (not (getenv "MT_CMDINFO")) + (begin + (debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!") + (exit 5)) + (let* ((startingdir (current-directory)) + (cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) + (transport (assoc/default 'transport cmdinfo)) + (testpath (assoc/default 'testpath cmdinfo)) + (test-name (assoc/default 'test-name cmdinfo)) + (runscript (assoc/default 'runscript cmdinfo)) + (db-host (assoc/default 'db-host cmdinfo)) + (run-id (assoc/default 'run-id cmdinfo)) + (test-id (assoc/default 'test-id cmdinfo)) + (itemdat (assoc/default 'itemdat cmdinfo)) + (work-area (assoc/default 'work-area cmdinfo)) + (db #f) ;; (open-db)) + (state (args:get-arg ":state")) + (status (args:get-arg ":status")) + (stepname (args:get-arg "-step"))) + (if (not (launch:setup)) + (begin + (debug:print 0 *default-log-port* "Failed to setup, exiting") + (exit 1))) + + (if (args:get-arg "-runstep")(debug:print-info 1 *default-log-port* "Running -runstep, first change to directory " work-area)) + (change-directory work-area) + ;; can setup as client for server mode now + + (if (args:get-arg "-load-test-data") + ;; has sub commands that are rdb: + ;; DO NOT put this one into either rmt: or open-run-close + (tdb:load-test-data run-id test-id)) + (if (args:get-arg "-setlog") + (let ((logfname (args:get-arg "-setlog"))) + (rmt:test-set-log! run-id test-id logfname))) + (if (args:get-arg "-set-toplog") + ;; DO NOT run remote + (tests:test-set-toplog! run-id test-name (args:get-arg "-set-toplog"))) + (if (args:get-arg "-summarize-items") + ;; DO NOT run remote + (tests:summarize-items run-id test-id test-name #t)) ;; do force here + (if (args:get-arg "-runstep") + (if (null? remargs) + (begin + (debug:print-error 0 *default-log-port* "nothing specified to run!") + (if db (sqlite3:finalize! db)) + (exit 6)) + (let* ((stepname (args:get-arg "-runstep")) + (logprofile (args:get-arg "-logpro")) + (logfile (conc stepname ".log")) + (cmd (if (null? remargs) #f (car remargs))) + (params (if cmd (cdr remargs) '())) + (exitstat #f) + (shell (let ((sh (get-environment-variable "SHELL") )) + (if sh + (last (string-split sh "/")) + "bash"))) + (redir (case (string->symbol shell) + ((tcsh csh ksh) ">&") + ((zsh bash sh ash) "2>&1 >") + (else ">&"))) + (fullcmd (conc "(" (string-intersperse + (cons cmd params) " ") + ") " redir " " logfile))) + ;; mark the start of the test + (rmt:teststep-set-status! run-id test-id stepname "start" "n/a" (args:get-arg "-m") logfile) + ;; run the test step + (debug:print-info 2 *default-log-port* "Running \"" fullcmd "\" in directory \"" startingdir) + (change-directory startingdir) + (set! exitstat (system fullcmd)) + (set! *globalexitstatus* exitstat) + ;; (change-directory testpath) + ;; run logpro if applicable ;; (process-run "ls" (list "/foo" "2>&1" "blah.log")) + (if logprofile + (let* ((htmllogfile (conc stepname ".html")) + (oldexitstat exitstat) + (cmd (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " "))) + (debug:print-info 2 *default-log-port* "running \"" cmd "\"") + (change-directory startingdir) + (set! exitstat (system cmd)) + (set! *globalexitstatus* exitstat) ;; no necessary + (change-directory testpath) + (rmt:test-set-log! run-id test-id htmllogfile))) + (let ((msg (args:get-arg "-m"))) + (rmt:teststep-set-status! run-id test-id stepname "end" exitstat msg logfile)) + ))) + (if (or (args:get-arg "-test-status") + (args:get-arg "-set-values")) + (let ((newstatus (cond + ((number? status) (if (equal? status 0) "PASS" "FAIL")) + ((and (string? status) + (string->number status))(if (equal? (string->number status) 0) "PASS" "FAIL")) + (else status))) + ;; transfer relevant keys into a hash to be passed to test-set-status! + ;; could use an assoc list I guess. + (otherdata (let ((res (make-hash-table))) + (for-each (lambda (key) + (if (args:get-arg key) + (hash-table-set! res key (args:get-arg key)))) + (list ":value" ":tol" ":expected" ":first_err" ":first_warn" ":units" ":category" ":variable")) + res))) + (if (and (args:get-arg "-test-status") + (or (not state) + (not status))) + (begin + (debug:print-error 0 *default-log-port* "You must specify :state and :status with every call to -test-status\n" help) + (if (sqlite3:database? db)(sqlite3:finalize! db)) + (exit 6))) + (let* ((msg (args:get-arg "-m")) + (numoth (length (hash-table-keys otherdata)))) + ;; Convert to rpc inside the tests:test-set-status! call, not here + (tests:test-set-status! run-id test-id state newstatus msg otherdata work-area: work-area)))) + (if (sqlite3:database? db)(sqlite3:finalize! db)) + (set! *didsomething* #t)))) + + ;;====================================================================== + ;; Various helper commands can go below here + ;;====================================================================== + + (if (or (args:get-arg "-showkeys") + (args:get-arg "-show-keys")) + (let ((db #f) + (keys #f)) + (if (not (launch:setup)) + (begin + (debug:print 0 *default-log-port* "Failed to setup, exiting") + (exit 1))) + (set! keys (rmt:get-keys)) ;; db)) + (debug:print 1 *default-log-port* "Keys: " (string-intersperse keys ", ")) + (if (sqlite3:database? db)(sqlite3:finalize! db)) + (set! *didsomething* #t))) + + (if (args:get-arg "-gui") + (begin + (debug:print 0 *default-log-port* "Look at the dashboard for now") + ;; (megatest-gui) + (set! *didsomething* #t))) + + (if (args:get-arg "-create-megatest-area") + (begin + (genexample:mk-megatest.config) + (set! *didsomething* #t))) + + (if (args:get-arg "-create-test") + (let ((testname (args:get-arg "-create-test"))) + (genexample:mk-megatest-test testname) + (set! *didsomething* #t))) + + ;;====================================================================== + ;; Update the database schema, clean up the db + ;;====================================================================== + + (if (args:get-arg "-rebuild-db") + (begin + (if (not (launch:setup)) + (begin + (debug:print 0 *default-log-port* "Failed to setup, exiting") + (exit 1))) + ;; keep this one local + ;; (open-run-close patch-db #f) + (let ((dbstructs (db:setup))) + (common:cleanup-db dbstructs full: #t)) + (set! *didsomething* #t))) + + (if (args:get-arg "-cleanup-db") + (begin + (if (not (launch:setup)) + (begin + (debug:print 0 *default-log-port* "Failed to setup, exiting") + (exit 1))) + + ;; (if (not (server:choose-server *toppath* 'home?)) + ;; (begin + ;; (debug:print 0 *default-log-port* "Servers are not running on this host or no servers alive. Cannot run cleanup-db") + ;; (exit 1))) + + (let ((dbstructs (db:setup))) + (common:cleanup-db dbstructs)) + (set! *didsomething* #t))) + + #;(if (args:get-arg "-mark-incompletes") + (begin + (if (not (launch:setup)) + (begin + (debug:print 0 *default-log-port* "Failed to setup, exiting") + (exit 1))) + (open-run-close db:find-and-mark-incomplete #f) + (set! *didsomething* #t))) + + ;;====================================================================== + ;; Update the tests meta data from the testconfig files + ;;====================================================================== + + (if (args:get-arg "-update-meta") + (begin + (if (not (launch:setup)) + (begin + (debug:print 0 *default-log-port* "Failed to setup, exiting") + (exit 1))) + (runs:update-all-test_meta #f) + (set! *didsomething* #t))) + + ;;====================================================================== + ;; Start a repl + ;;====================================================================== + + ;; fakeout readline + (include "readline-fix.scm") + + (when (args:get-arg "-diff-rep") + (when (and + (not (args:get-arg "-diff-html")) + (not (args:get-arg "-diff-email"))) + (debug:print 0 *default-log-port* "Must specify -diff-html or -diff-email with -diff-rep") + (set! *didsomething* 1) + (exit 1)) + + (let* ((toppath (launch:setup))) + (do-diff-report + (args:get-arg "-src-target") + (args:get-arg "-src-runname") + (args:get-arg "-target") + (args:get-arg "-runname") + (args:get-arg "-diff-html") + (args:get-arg "-diff-email")) + (set! *didsomething* #t) + (exit 0))) + + (if (or (getenv "MT_RUNSCRIPT") + (args:get-arg "-repl") + (args:get-arg "-load")) + (let* ((toppath (launch:setup)) + (dbstructs (if (and toppath + ;; NOTE: server:choose-server is starting a server + ;; either add equivalent for tcp mode or ???? + #;(server:choose-server toppath 'home?)) + (db:setup) + #f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f))) + (if *toppath* + (cond + ((getenv "MT_RUNSCRIPT") + ;; How to run megatest scripts + ;; + ;; #!/bin/bash + ;; + ;; export MT_RUNSCRIPT=yes + ;; megatest << EOF + ;; (print "Hello world") + ;; (exit) + ;; EOF + + (repl)) + (else + (begin + (define toplevel-command (lambda (a b)(print a " "b))) + (set! *db* dbstructs) + (import extras) ;; might not be needed + ;; (import csi) + ;; (import readline) + (import apropos) + (import dbfile) + + ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ... + + (if *use-new-readline* + (begin + #;(install-history-file (get-environment-variable "HOME") ".megatest_history") ;; [homedir] [filename] [nlines]) + #;(current-input-port (make-readline-port "megatest> "))) + #;(begin + (gnu-history-install-file-manager + (string-append + (or (get-environment-variable "HOME") ".") "/.megatest_history")) + (current-input-port (make-gnu-readline-port "megatest> ")))) + (if (args:get-arg "-repl") + (repl) + (load (args:get-arg "-load"))) + ;; (db:close-all dbstruct) <= taken care of by on-exit call + ) + (exit))) + (set! *didsomething* #t)))) + + ;;====================================================================== + ;; Wait on a run to complete + ;;====================================================================== + + (if (and (args:get-arg "-run-wait") + (not (or (args:get-arg "-run") + (args:get-arg "-runtests")))) ;; run-wait is built into runtests now + (begin + (if (not (launch:setup)) + (begin + (debug:print 0 *default-log-port* "Failed to setup, exiting") + (exit 1))) + (operate-on 'run-wait) + (set! *didsomething* #t))) + + ;; ;; ;; redo me ;; Not converted to use dbstruct yet + ;; ;; ;; redo me ;; + ;; ;; ;; redo me (if (args:get-arg "-convert-to-norm") + ;; ;; ;; redo me (let* ((toppath (setup-for-run)) + ;; ;; ;; redo me (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t)))) + ;; ;; ;; redo me (for-each + ;; ;; ;; redo me (lambda (field) + ;; ;; ;; redo me (let ((dat '())) + ;; ;; ;; redo me (debug:print-info 0 *default-log-port* "Getting data for field " field) + ;; ;; ;; redo me (sqlite3:for-each-row + ;; ;; ;; redo me (lambda (id val) + ;; ;; ;; redo me (set! dat (cons (list id val) dat))) + ;; ;; ;; redo me (db:get-db db run-id) + ;; ;; ;; redo me (conc "SELECT id," field " FROM tests;")) + ;; ;; ;; redo me (debug:print-info 0 *default-log-port* "found " (length dat) " items for field " field) + ;; ;; ;; redo me (let ((qry (sqlite3:prepare db (conc "UPDATE tests SET " field "=? WHERE id=?;")))) + ;; ;; ;; redo me (for-each + ;; ;; ;; redo me (lambda (item) + ;; ;; ;; redo me (let ((newval ;; (sdb:qry 'getid + ;; ;; ;; redo me (cadr item))) ;; ) + ;; ;; ;; redo me (if (not (equal? newval (cadr item))) + ;; ;; ;; redo me (debug:print-info 0 *default-log-port* "Converting " (cadr item) " to " newval " for test #" (car item))) + ;; ;; ;; redo me (sqlite3:execute qry newval (car item)))) + ;; ;; ;; redo me dat) + ;; ;; ;; redo me (sqlite3:finalize! qry)))) + ;; ;; ;; redo me (db:close-all dbstruct) + ;; ;; ;; redo me (list "uname" "rundir" "final_logf" "comment")) + ;; ;; ;; redo me (set! *didsomething* #t))) + + (if (args:get-arg "-import-megatest.db") + (begin + (launch:setup) + (db:multi-db-sync + (db:setup) + 'killservers + 'dejunk + 'adj-testids + 'old2new + ) + (set! *didsomething* #t))) + + (if (args:get-arg "-import-sexpr") + (let*( + (toppath (launch:setup)) + (tmppath (common:make-tmpdir-name toppath ""))) + (if (file-exists? (conc toppath "/.mtdb")) + (if (args:get-arg "-remove-dbs") + (let* ((dbfiles (conc toppath "/.mtdb/* " tmppath "/*"))) + (debug:print 0 *default-log-port* "Removing db files: " dbfiles) + (system (conc "rm -rvf " dbfiles)) + ) + (begin + (debug:print 0 *default-log-port* "ERROR: Cannot import sexpr with an existing DB present.") + (debug:print 0 *default-log-port* "Add '-remove-dbs all' to remove the current Megatest DBs.") + (set! *didsomething* #t) + (exit) + ) + ) + (debug:print 0 *default-log-port* "Did not find " (conc toppath "/.mtdb")) + ) + (db:setup) + (rmt:import-sexpr (args:get-arg "-import-sexpr")) + (set! *didsomething* #t))) + + (if (args:get-arg "-sync-to-megatest.db") + (let* ((duh (launch:setup)) + (dbstruct (db:setup)) + (tmpdbpth (dbr:dbstruct-tmppath dbstruct)) + (lockfile (conc tmpdbpth ".lock")) + (locked (common:simple-file-lock lockfile)) + (res (if locked + (db:multi-db-sync + dbstruct + 'new2old) + #f))) + (if res + (begin + (common:simple-file-release-lock lockfile) + (debug:print 0 *default-log-port* "Synced " res " records to megatest.db")) + (debug:print 0 *default-log-port* "Skipping sync, there is a sync in progress.")) + (set! *didsomething* #t))) + + (if (args:get-arg "-sync-to") + (let ((toppath (launch:setup))) + (tasks:sync-to-postgres *configdat* (args:get-arg "-sync-to")) + (set! *didsomething* #t))) + + + ;; use with -from and -to + ;; + (if (args:get-arg "-db2db") + (let* ((duh (launch:setup)) + (src-db (args:get-arg "-from")) + (dest-db (args:get-arg "-to")) + ;; (sync-period (args:get-arg-number "-period")) + ;; (sync-timeout (args:get-arg-number "-timeout")) + (sync-period-in (args:get-arg "-period")) + (sync-timeout-in (args:get-arg "-timeout")) + (sync-period (if sync-period-in (string->number sync-period-in) #f)) + (sync-timeout (if sync-timeout-in (string->number sync-timeout-in) #f)) + (synclock-file (conc dest-db".sync-lock")) + (keys (db:get-keys #f)) + (thesync (lambda (last-update) + (debug:print-info 0 *default-log-port* "Attempting to sync data from "src-db" to "dest-db"...") + (debug:print-info 0 *default-log-port* "PID = " (current-process-id)) + (if (not (file-exists? dest-db)) + (begin + (debug:print 0 *default-log-port* "Using copy to create "dest-db" from "src-db) + (file-copy src-db dest-db) + 1) + (let ((res (dbmod:db-to-db-sync src-db dest-db last-update (dbfile:db-init-proc) keys))) + (if res + (debug:print-info 2 *default-log-port* "Synced " res " records from "src-db" to "dest-db) + (debug:print-info 0 *default-log-port* "No sync due to permissions or other issue.")) + res)))) + (start-time (current-seconds)) + (synclock-mod-time (if (file-exists? synclock-file) + (handle-exceptions + exn + #f + (file-modification-time synclock-file)) + #f)) + (age (if synclock-mod-time (- (current-seconds) synclock-mod-time) 1000)) + ) + (if (and src-db dest-db) + (if (file-exists? src-db) + (if (and (file-exists? synclock-file) (< age 20)) + (debug:print 0 *default-log-port* "Lock "synclock-file" exists, skipping sync...") + (begin + (if (file-exists? synclock-file) + (begin + (debug:print 0 *default-log-port* "Deleting old lock file " synclock-file) + (delete-file synclock-file) + ) + ) + (dbfile:with-simple-file-lock + synclock-file + (lambda () + (let loop ((last-changed (current-seconds)) + (last-update 0)) + (let* ((changes (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "Exception in sync: "(condition->list exn)) + (delete-file synclock-file) + (exit)) + (thesync last-update))) + (now-time (current-seconds))) + (if (and sync-period sync-timeout) ;; + (if (and (< (- now-time start-time) 600) ;; hard limit on how long we run for + (> sync-timeout (- now-time last-changed))) + (begin + (if sync-period (thread-sleep! sync-period)) + (loop (if (> changes 0) now-time last-changed) now-time)))))))) + (debug:print 0 *default-log-port* "Releasing lock file " synclock-file) + ) + ) + (debug:print 0 *default-log-port* "No sync due to unreadble or non-existant source file"src-db)) + (debug:print 0 *default-log-port* "Usage for -db2db; -to and -from must be specified")) + (set! *didsomething* #t))) + + (if (args:get-arg "-list-test-time") + (let* ((toppath (launch:setup))) + (task:get-test-times) + (set! *didsomething* #t))) + + (if (args:get-arg "-list-run-time") + (let* ((toppath (launch:setup))) + (task:get-run-times) + (set! *didsomething* #t))) + + (if (args:get-arg "-generate-html") + (let* ((toppath (launch:setup))) + (if (tests:create-html-tree #f) + (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/page0.html") + (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html")) + (set! *didsomething* #t))) + + (if (args:get-arg "-generate-html-structure") + (let* ((toppath (launch:setup))) + ;(if (tests:create-html-tree #f) + (if (tests:create-html-summary #f) + (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/targets.html") + (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html")) + (set! *didsomething* #t))) + + (if (args:get-arg "-syscheck") + (begin + (mutils:syscheck common:raw-get-remote-host-load + server:get-best-guess-address + read-config) + (set! *didsomething* #t))) + + (if (args:get-arg "-extract-skeleton") + (let* ((toppath (launch:setup))) + (genexample:extract-skeleton-area (args:get-arg "-extract-skeleton")) + (set! *didsomething* #t))) + + ;;====================================================================== + ;; Exit and clean up + ;;====================================================================== + + (if (not *didsomething*) + (debug:print 0 *default-log-port* help) + (set! *time-to-exit* #t) + ) + ;;(debug:print-info 13 *default-log-port* "thread-join! watchdog") + + ;; join the watchdog thread if it has been thread-start!ed (it may not have been started in the case of a server that never enters running state) + ;; (symbols returned by thread-state: created ready running blocked suspended sleeping terminated dead) + ;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage + ;;(if (thread? *watchdog*) + ;; (case (thread-state *watchdog*) + ;; ((ready running blocked sleeping terminated dead) + ;; (thread-join! *watchdog*)))) + + (set! *time-to-exit* #t) + + (if (not (eq? *globalexitstatus* 0)) + (if (or (args:get-arg "-run")(args:get-arg "-runtests")(args:get-arg "-runall")) + (begin + (debug:print 0 *default-log-port* "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*) + (exit 0)) + (case *globalexitstatus* + ((0)(exit 0)) + ((1)(exit 1)) + ((2)(exit 2)) + (else (exit 3))))) + ) ;; main +) Index: mtexec.scm ================================================================== --- mtexec.scm +++ mtexec.scm @@ -27,20 +27,19 @@ (prefix dbi dbi:) ) ;; (declare (uses common)) (declare (uses mtargs)) -(declare (uses configf)) (declare (uses commonmod)) (declare (uses configfmod)) (import commonmod configfmod (prefix mtargs args:)) ;; (use ducttape-lib) -(include "megatest-version.scm") +;; (include "megatest-version.scm") (include "megatest-fossil-hash.scm") ;; (require-library stml) (define help (conc " Index: mtmod.scm ================================================================== --- mtmod.scm +++ mtmod.scm @@ -32,11 +32,22 @@ ;; (declare (uses tcp-transportmod)) ;; we don't want mtmod depending on tcp (use srfi-69) (module mtmod - * + ( + keys:make-key/field-string + common:get-testsuite-name + items:get-items-from-config + mt:run-trigger + common:get-linktree + common:get-area-name + + items:check-valid-items + mt:discard-blocked-tests + + ) (import scheme) (cond-expand (chicken-4 Index: mtut.scm ================================================================== --- mtut.scm +++ mtut.scm @@ -14,20 +14,19 @@ ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; ; -(declare (uses common)) +;; (declare (uses common)) (declare (uses mtargs)) (declare (uses mtargs.import)) (declare (uses debugprint)) (declare (uses debugprint.import)) (declare (uses commonmod)) (declare (uses commonmod.import)) (declare (uses configfmod)) (declare (uses configfmod.import)) -(declare (uses configf)) (declare (uses rmtmod)) (declare (uses rmtmod.import)) (include "megatest-version.scm") Index: odsmod.scm ================================================================== --- odsmod.scm +++ odsmod.scm @@ -16,18 +16,21 @@ ;; along with Megatest. If not, see . ;; (use csv-xml regex) (declare (unit odsmod)) -(declare (uses common)) +;; (declare (uses common)) (declare (uses commonmod)) (declare (uses debugprint)) (declare (uses dbfile)) (declare (uses dbmod)) (module odsmod - * + ( + db:extract-ods-file + ods:list->ods + ) (import scheme chicken data-structures extras @@ -40,10 +43,11 @@ commonmod debugprint dbfile dbmod + ) (define ods:dirs '("Configurations2" "Configurations2/toolpanel" DELETED process.scm Index: process.scm ================================================================== --- process.scm +++ /dev/null @@ -1,32 +0,0 @@ -;;====================================================================== -;; Copyright 2006-2012, 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 . - -;;====================================================================== - -;;====================================================================== -;; Process convience utils -;;====================================================================== - -(use regex directory-utils) -(declare (unit process)) -(declare (uses debugprint)) -(declare (uses processmod)) - -(import debugprint - processmod) - Index: processmod.scm ================================================================== --- processmod.scm +++ processmod.scm @@ -23,11 +23,21 @@ (declare (uses commonmod)) (use srfi-69) (module processmod - * + ( + process:children + + process:cmd-run->list + process:alive? + run-n-wait + process:cmd-run-with-stderr-and-exitcode->list + + process:alive-on-host? + process:get-sub-pids + ) (import scheme) (cond-expand (chicken-4 Index: rmtmod.scm ================================================================== --- rmtmod.scm +++ rmtmod.scm @@ -28,11 +28,136 @@ (declare (uses tcp-transportmod)) (declare (uses apimod)) (declare (uses servermod)) (module rmtmod - * + ( + rmt:get-tests-for-run-state-status + rmt:tasks-get-last + rmt:read-test-data + rmt:get-targets + rmt:get-run-stats + rmt:get-key-vals + rmt:test-data-rollup + rmt:import-sexpr + rmt:read-test-data-varpatt + rmt:get-run-status + rmt:set-run-status + + rmtmod:send-receive + rmt:send-receive + rmt:no-sync-get-lock + rmt:no-sync-del! + rmt:no-sync-set + rmt:no-sync-get/default + + rmt:get-runs-by-patt + rmt:get-testinfo-state-status + rmt:get-test-id + rmt:set-state-status-and-roll-up-items + + rmt:get-prereqs-not-met + rmt:get-tests-for-run + + rmt:get-keys + rmt:test-get-records-for-index-file + tests:test-set-toplog! + rmt:test-get-logfile-info + rmt:general-call + rmt:test-get-paths-matching-keynames-target-new + rmt:get-test-info-by-id + rmt:get-steps-for-test + rmt:get-num-runs + rmt:get-runs-cnt-by-patt + rmt:get-runs + + rmt:get-latest-host-load + rmt:get-changed-record-test-ids + rmt:get-all-runids + rmt:get-changed-record-run-ids + rmt:get-run-record-ids + rmt:get-data-info-by-id + rmt:get-steps-info-by-id + rmt:get-target + + rmt:get-run-name-from-id + rmt:get-run-info + rmt:get-test-times + rmt:get-run-times + + rmt:tasks-find-task-queue-records + + common:api-changed? + rmt:on-homehost? + + rmt:get-var + rmt:csv->test-data + rmt:get-previous-test-run-record + + common:cleanup-db + common:get-last-run-version + + rmt:get-key-val-pairs + rmt:create-all-triggers + rmt:update-tesdata-on-repilcate-db + rmt:drop-all-triggers + rmt:test-get-archive-block-info + rmt:test-toplevel-num-items + rmt:archive-get-allocations + rmt:archive-register-disk + rmt:archive-register-block-name + + mt:get-runs-by-patt + rmt:simple-get-runs + rmt:get-tests-for-runs-mindata + rmt:test-get-top-process-pid + rmt:set-state-status-and-roll-up-run + rmt:get-run-state-status + rmt:get-not-completed-cnt + rmt:get-tests-tags + rmt:testmeta-update-field + rmt:testmeta-add-record + rmt:testmeta-get-record + rmt:lock/unlock-run + rmt:delete-old-deleted-test-records + rmt:delete-run + rmt:get-raw-run-stats + rmt:update-run-stats + rmt:delete-test-records + rmt:test-set-archive-block-id + mt:get-tests-for-run + mt:test-set-state-status-by-testname + mt:test-set-state-status-by-testname-unless-completed + rmt:register-test + mt:test-set-state-status-by-id-unless-completed + rmt:get-all-run-ids + + rmt:set-run-state-status + rmt:set-var + rmt:set-tests-state-status + rmt:tasks-add + rmt:tasks-set-state-given-param-key + rmt:register-run + rmt:get-count-tests-running-in-jobgroup + rmt:get-count-tests-running-for-run-id + + rmt:test-set-state-status-by-id + mt:test-set-state-status-by-id + + rmt:get-status-from-final-status-file + rmt:get-toplevels-and-incompletes + + rmt:test-set-log! + rmt:teststep-set-status! + + rmt:delete-steps-for-test! + rmt:test-set-state-status + rmt:get-test-state-status-by-id + rmt:test-set-top-process-pid + + ) + (import scheme chicken data-structures regex @@ -164,18 +289,10 @@ (rmtmod:send-receive 'get-test-state-status-by-id run-id (list run-id test-id))) (define (rmt:test-get-rundir-from-test-id run-id test-id) (rmtmod:send-receive 'test-get-rundir-from-test-id run-id (list run-id test-id))) -;; (define (rmt:open-test-db-by-test-id run-id test-id #!key (work-area #f)) -;; (assert (number? run-id) "FATAL: Run id required.") -;; (let* ((test-path (if (string? work-area) -;; work-area -;; (rmt:test-get-rundir-from-test-id run-id test-id)))) -;; (debug:print 3 *default-log-port* "TEST PATH: " test-path) -;; (open-test-db test-path))) - ;; WARNING: This currently bypasses the transaction wrapped writes system (define (rmt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment) (assert (number? run-id) "FATAL: Run id required.") (rmtmod:send-receive 'test-set-state-status-by-id run-id (list run-id test-id newstate newstatus newcomment))) @@ -705,14 +822,14 @@ (rmt:send-receive 'update-run-event_time #f (list run-id))) (define (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit fields last-runs-update #!key (sort-order "asc")) ;; fields of #f uses default (rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit fields last-runs-update sort-order))) -(define (rmt:find-and-mark-incomplete run-id ovr-deadtime) - (assert (number? run-id) "FATAL: Run id required.") - ;; (if (rmt:send-receive 'have-incompletes? run-id (list run-id ovr-deadtime)) - (rmt:send-receive 'mark-incomplete run-id (list run-id ovr-deadtime))) ;; ) +;; (define (rmt:find-and-mark-incomplete run-id ovr-deadtime) +;; (assert (number? run-id) "FATAL: Run id required.") +;; ;; (if (rmt:send-receive 'have-incompletes? run-id (list run-id ovr-deadtime)) +;; (rmt:send-receive 'mark-incomplete run-id (list run-id ovr-deadtime))) ;; ) (define (rmt:get-main-run-stats run-id) (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-main-run-stats #f (list run-id))) @@ -737,15 +854,15 @@ ;;====================================================================== ;; M U L T I R U N Q U E R I E S ;;====================================================================== ;; Need to move this to multi-run section and make associated changes -(define (rmt:find-and-mark-incomplete-all-runs #!key (ovr-deadtime #f)) - (let ((run-ids (rmt:get-all-run-ids))) - (for-each (lambda (run-id) - (rmt:find-and-mark-incomplete run-id ovr-deadtime)) - run-ids))) +;; (define (rmt:find-and-mark-incomplete-all-runs #!key (ovr-deadtime #f)) +;; (let ((run-ids (rmt:get-all-run-ids))) +;; (for-each (lambda (run-id) +;; (rmt:find-and-mark-incomplete run-id ovr-deadtime)) +;; run-ids))) ;; get the previous record for when this test was run where all keys match but runname ;; returns #f if no such test found, returns a single test record if found ;; ;; Run this at the client end since we have to connect to multiple run-id dbs @@ -950,11 +1067,10 @@ #f))) #f))) ;; not true strickly speaking, might be runremote was not yet initialized. (define (make-and-init-remote areapath) (case (rmt:transport-mode) - ((http)(make-remote)) ((tcp) (tt:make-remote areapath)) (else #f))) ;; how to make area-dat (define (rmt:set-ttdat areapath ttdat) Index: run_records.scm ================================================================== --- run_records.scm +++ run_records.scm @@ -16,33 +16,33 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; ;;====================================================================== -(define-inline (runs:runrec-make-record) (make-vector 13)) -(define-inline (runs:runrec-get-target vec)(vector-ref vec 0)) ;; a/b/c -(define-inline (runs:runrec-get-runname vec)(vector-ref vec 1)) ;; string -(define-inline (runs:runrec-testpatt vec)(vector-ref vec 2)) ;; a,b/c,d% -(define-inline (runs:runrec-keys vec)(vector-ref vec 3)) ;; (key1 key2 ...) -(define-inline (runs:runrec-keyvals vec)(vector-ref vec 4)) ;; ((key1 val1)(key2 val2) ...) -(define-inline (runs:runrec-environment vec)(vector-ref vec 5)) ;; environment, alist key val -(define-inline (runs:runrec-mconfig vec)(vector-ref vec 6)) ;; megatest.config -(define-inline (runs:runrec-runconfig vec)(vector-ref vec 7)) ;; runconfigs.config -(define-inline (runs:runrec-serverdat vec)(vector-ref vec 8)) ;; (host port) -(define-inline (runs:runrec-transport vec)(vector-ref vec 9)) ;; 'http -(define-inline (runs:runrec-db vec)(vector-ref vec 10)) ;; (if 'fs) -(define-inline (runs:runrec-top-path vec)(vector-ref vec 11)) ;; *toppath* -(define-inline (runs:runrec-run_id vec)(vector-ref vec 12)) ;; run-id - -(define-inline (test:get-id vec) (vector-ref vec 0)) -(define-inline (test:get-run_id vec) (vector-ref vec 1)) -(define-inline (test:get-test-name vec)(vector-ref vec 2)) -(define-inline (test:get-state vec) (vector-ref vec 3)) -(define-inline (test:get-status vec) (vector-ref vec 4)) -(define-inline (test:get-item-path vec)(vector-ref vec 5)) - -(define-inline (test:test-get-fullname test) +(define (runs:runrec-make-record) (make-vector 13)) +(define (runs:runrec-get-target vec)(vector-ref vec 0)) ;; a/b/c +(define (runs:runrec-get-runname vec)(vector-ref vec 1)) ;; string +(define (runs:runrec-testpatt vec)(vector-ref vec 2)) ;; a,b/c,d% +(define (runs:runrec-keys vec)(vector-ref vec 3)) ;; (key1 key2 ...) +(define (runs:runrec-keyvals vec)(vector-ref vec 4)) ;; ((key1 val1)(key2 val2) ...) +(define (runs:runrec-environment vec)(vector-ref vec 5)) ;; environment, alist key val +(define (runs:runrec-mconfig vec)(vector-ref vec 6)) ;; megatest.config +(define (runs:runrec-runconfig vec)(vector-ref vec 7)) ;; runconfigs.config +(define (runs:runrec-serverdat vec)(vector-ref vec 8)) ;; (host port) +(define (runs:runrec-transport vec)(vector-ref vec 9)) ;; 'http +(define (runs:runrec-db vec)(vector-ref vec 10)) ;; (if 'fs) +(define (runs:runrec-top-path vec)(vector-ref vec 11)) ;; *toppath* +(define (runs:runrec-run_id vec)(vector-ref vec 12)) ;; run-id + +(define (test:get-id vec) (vector-ref vec 0)) +(define (test:get-run_id vec) (vector-ref vec 1)) +(define (test:get-test-name vec)(vector-ref vec 2)) +(define (test:get-state vec) (vector-ref vec 3)) +(define (test:get-status vec) (vector-ref vec 4)) +(define (test:get-item-path vec)(vector-ref vec 5)) + +(define (test:test-get-fullname test) (conc (db:test-get-testname test) (if (equal? (db:test-get-item-path test) "") "" (conc "(" (db:test-get-item-path test) ")")))) Index: runconfig.scm ================================================================== --- runconfig.scm +++ runconfig.scm @@ -21,14 +21,14 @@ ;;====================================================================== (use format directory-utils) (declare (unit runconfig)) -(declare (uses common)) +;; (declare (uses common)) (declare (uses debugprint)) (declare (uses commonmod)) (import commonmod debugprint) -(include "common_records.scm") +;; (include "common_records.scm") DELETED runs.scm Index: runs.scm ================================================================== --- runs.scm +++ /dev/null @@ -1,68 +0,0 @@ -;; Copyright 2006-2016, 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 . - -;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') - -(declare (unit runs)) -(declare (uses debugprint)) -(declare (uses commonmod)) -(declare (uses processmod)) -(declare (uses configfmod)) -(declare (uses mtargs)) -(declare (uses rmtmod)) -(declare (uses dbfile)) -(declare (uses dbmod)) -(declare (uses megatestmod)) -(declare (uses mtmod)) -(declare (uses tasksmod)) -(declare (uses servermod)) - -(declare (uses common)) - -(declare (uses runconfig)) -(declare (uses server)) -(declare (uses mt)) -(declare (uses archive)) - -(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) - posix-extras directory-utils pathname-expand typed-records format sxml-serializer - sxml-modifications matchable) - - - -(include "common_records.scm") -;; (include "key_records.scm") -;; (include "db_records.scm") -(include "run_records.scm") -;; (include "test_records.scm") - -;; (include "debugger.scm") - -(import commonmod - processmod - configfmod - debugprint - rmtmod - dbfile - dbmod - megatestmod - (prefix mtargs args:) - mtmod - tasksmod - servermod - ) - Index: runsmod.scm ================================================================== --- runsmod.scm +++ runsmod.scm @@ -44,11 +44,31 @@ (declare (uses fsmod)) (use srfi-69) (module runsmod - * + ( + runs:get-mt-env-alist + setup-env-defaults + runs:clean-cache + rmt:find-and-mark-incomplete + launch:setup + launch:end-of-run-check + launch:test-copy + + set-item-env-vars + runs:set-megatest-env-vars + full-runconfigs-read + runs:operate-on + + runs:update-all-test_meta + runs:handle-locking + ;; runs:rollup-run ;; not ported + runs:run-tests + runs:remove-all-but-last-n-runs-per-target + general-run-call + ) (import scheme) (cond-expand (chicken-4 @@ -127,11 +147,11 @@ subrunmod archivemod fsmod ) -(include "common_records.scm") +;; (include "common_records.scm") ;; (include "key_records.scm") ;; (include "db_records.scm") (include "run_records.scm") ;; (include "test_records.scm") @@ -1188,13 +1208,15 @@ (if (and (not (rmt:on-homehost?)) maxload) ;; only gate if maxload is specified, NOTE: maxload is normalized, i.e. load=1 means all cpus fully utilized (common:wait-for-normalized-load maxload "Waiting for load to drop before starting more tests" #f)) ;; jobtools maxhomehostload is intended to prevent overloading on the homehost which can cause database corruption issues - (if maxhomehostload - (common:wait-for-homehost-load maxhomehostload - (conc "Waiting for homehost load to drop below normalized value of " maxhomehostload)))))) + ;; (if maxhomehostload + ;; (common:wait-for-homehost-load + ;; maxhomehostload + ;; (conc "Waiting for homehost load to drop below normalized value of " maxhomehostload))) + ))) (if (and (not (null? prereqs-not-met)) (runs:lownoise (conc "waiting on tests " prereqs-not-met hed) 60)) @@ -4538,7 +4560,95 @@ (debug:print-info 0 *default-log-port* "remove testdat") (runs:remove-test-directory test-dat 'archive-remove))))) (hash-table-ref test-groups test-base))))) (hash-table-keys disk-groups)) #t)) + +;;====================================================================== +;; Maintenance +;;====================================================================== + +(define (rmt:find-and-mark-incomplete run-id ovr-deadtime) + (let* ((cfg-deadtime (configf:lookup-number *configdat* "setup" "deadtime")) + (test-stats-update-period (configf:lookup-number *configdat* "setup" "test-stats-update-period"))) + (rmt:find-and-mark-incomplete-engine run-id ovr-deadtime cfg-deadtime test-stats-update-period) + ;;call end of eud of run detection for posthook + (launch:end-of-run-check run-id))) + +;; select end_time-now from +;; (select testname,item_path,event_time+run_duration as +;; end_time,strftime('%s','now') as now from tests where state in +;; ('RUNNING','REMOTEHOSTSTART','LAUNCHED')); +;; +;; NOT EASY TO MIGRATE TO db{file,mod} +;; +(define (rmt:find-and-mark-incomplete-engine run-id ovr-deadtime cfg-deadtime test-stats-update-period) + (let* ((incompleted '()) + (oldlaunched '()) + (toplevels '()) + ;; The default running-deadtime is 720 seconds = 12 minutes. + ;; "(running-deadtime-default (+ server-start-allowance (* 2 launch-monitor-period)))" = 200 + (2 * (200 + 30 + 30)) + (deadtime-trim (or ovr-deadtime cfg-deadtime)) + (server-start-allowance 200) + (server-overloaded-budget 200) + (launch-monitor-off-time (or test-stats-update-period 30)) + (launch-monitor-on-time-budget 30) + (launch-monitor-period (+ launch-monitor-off-time launch-monitor-on-time-budget server-overloaded-budget)) + (remotehoststart-deadtime-default (+ server-start-allowance server-overloaded-budget 30)) + (remotehoststart-deadtime (or deadtime-trim remotehoststart-deadtime-default)) + (running-deadtime-default (+ server-start-allowance (* 2 launch-monitor-period))) + (running-deadtime (or deadtime-trim running-deadtime-default))) ;; two minutes (30 seconds between updates, this leaves 3x grace period) + + (debug:print-info 4 *default-log-port* "running-deadtime = " running-deadtime) + (debug:print-info 4 *default-log-port* "deadtime-trim = " deadtime-trim) + + (let* ((dat (rmt:get-toplevels-and-incompletes run-id running-deadtime remotehoststart-deadtime))) + (set! oldlaunched (list-ref dat 1)) + (set! toplevels (list-ref dat 2)) + (set! incompleted (list-ref dat 0))) + + (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, " + (length toplevels) " old LAUNCHED toplevel tests and " + (length incompleted) " tests marked RUNNING but apparently dead.") + + ;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE. + ;; + ;; (db:delay-if-busy dbdat) + (let* ((min-incompleted-ids (map car incompleted)) ;; do 'em all + (all-ids (append min-incompleted-ids (map car oldlaunched)))) + (if (> (length all-ids) 0) + (begin + ;; (launch:is-test-alive "localhost" 435) + (debug:print 0 *default-log-port* "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") + " as DEAD") + (for-each + (lambda (test-id) + (let* ((tinfo (rmt:get-test-info-by-id run-id test-id)) + (run-dir (db:test-get-rundir tinfo)) + (host (db:test-get-host tinfo)) + (pid (db:test-get-process_id tinfo)) + (result (rmt:get-status-from-final-status-file run-dir))) + (if (and (list? result) (> (length result) 1) (equal? "PASS" (cadr result)) (equal? "COMPLETED" (car result))) + (begin + (debug:print 0 *default-log-port* "INFO: test " test-id " actually passed, so marking PASS not DEAD") + (rmt:set-state-status-and-roll-up-items + run-id test-id 'foo "COMPLETED" "PASS" + "Test stopped responding but it has PASSED; marking it PASS in the DB.")) + (let ((is-alive (and (not (eq? pid 0)) ;; 0 is default in re-used field "attemptnum" where pid stored. + (commonmod:is-test-alive host pid)))) + (if is-alive + (debug:print 0 *default-log-port* "INFO: test " test-id " on host " host + " has a process on pid " pid ", NOT setting to DEAD.") + (begin + (debug:print 0 *default-log-port* "INFO: test " test-id + " final state/status is not COMPLETED/PASS. It is " result) + (rmt:set-state-status-and-roll-up-items + run-id test-id 'foo "COMPLETED" "DEAD" + "Test stopped responding while in RUNNING or REMOTEHOSTSTART; presumed dead."))))))) + ;; call end of eud of run detection for posthook - from merge, is it needed? + ;; (launch:end-of-run-check run-id) + all-ids) + ))))) + + ) Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -16,29 +16,30 @@ ;; along with Megatest. If not, see . ;; (declare (unit server)) -(declare (uses common)) +;; (declare (uses common)) (declare (uses debugprint)) (declare (uses commonmod)) (declare (uses configfmod)) (declare (uses rmtmod)) -(declare (uses launch)) +(declare (uses launchmod)) (declare (uses mtargs)) (use (srfi 18) extras s11n) (use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest) (use directory-utils posix-extras matchable utils) (use spiffy uri-common intarweb http-client spiffy-request-vars) (import commonmod configfmod + launchmod debugprint (prefix mtargs args:)) -(include "common_records.scm") +;; (include "common_records.scm") ;; (include "db_records.scm") (define (db:kill-servers) (let* ((tl (launch:setup)) ;; need this to initialize *toppath* (servdir (conc *toppath* "/.servinfo")) Index: servermod.scm ================================================================== --- servermod.scm +++ servermod.scm @@ -23,11 +23,18 @@ (declare (uses mtmod)) (declare (uses debugprint)) (declare (uses mtargs)) (module servermod - * + ( + remote-hh-dat + server:mk-signature + common:wait-for-normalized-load + server:expiration-timeout + server:get-best-guess-address + + ) (import scheme chicken) (use (srfi 18) extras s11n) @@ -46,11 +53,11 @@ debugprint (prefix mtargs args:) mtmod ) -(include "common_records.scm") +;; (include "common_records.scm") ;; (include "db_records.scm") (define (server:make-server-url hostport) (if (not hostport) #f @@ -272,29 +279,29 @@ ;; or another host? ;; ;; returns #t => ok to start another server ;; #f => not ok to start another server ;; -(define (server:minimal-check areapath) - (server:clean-up-old areapath) - (let* ((srvdir (server:get-servinfo-dir areapath)) ;; (conc areapath"/.servinfo")) - (servrs (glob (conc srvdir"/*"))) - (thishostip (server:get-best-guess-address (get-host-name))) - (thisservrs (glob (conc srvdir"/"thishostip":*"))) - (homehostinf (server:choose-server areapath 'homehost)) - (havehome (car homehostinf)) - (wearehome (cdr homehostinf))) - (debug:print-info 0 *default-log-port* thishostip", have homehost: "havehome", we are homehost: "wearehome - ", numservers: "(length thisservrs)) - (cond - ((not havehome) #t) ;; no homehost yet, go for it - ((and havehome wearehome (< (length thisservrs) 20)) #t) ;; we are home and less than 20 servers, ok to start another - ((and havehome (not wearehome)) #f) ;; we are not the home host - ((and havehome wearehome (>= (length thisservrs) 20)) #f) ;; have enough running - (else - (debug:print 0 *default-log-port* "WARNING: Unrecognised scenario, servrs="servrs", thishostip="thishostip", thisservrs="thisservrs) - #t)))) +;; (define (server:minimal-check areapath) +;; (server:clean-up-old areapath) +;; (let* ((srvdir (server:get-servinfo-dir areapath)) ;; (conc areapath"/.servinfo")) +;; (servrs (glob (conc srvdir"/*"))) +;; (thishostip (server:get-best-guess-address (get-host-name))) +;; (thisservrs (glob (conc srvdir"/"thishostip":*"))) +;; (homehostinf (server:choose-server areapath 'homehost)) +;; (havehome (car homehostinf)) +;; (wearehome (cdr homehostinf))) +;; (debug:print-info 0 *default-log-port* thishostip", have homehost: "havehome", we are homehost: "wearehome +;; ", numservers: "(length thisservrs)) +;; (cond +;; ((not havehome) #t) ;; no homehost yet, go for it +;; ((and havehome wearehome (< (length thisservrs) 20)) #t) ;; we are home and less than 20 servers, ok to start another +;; ((and havehome (not wearehome)) #f) ;; we are not the home host +;; ((and havehome wearehome (>= (length thisservrs) 20)) #f) ;; have enough running +;; (else +;; (debug:print 0 *default-log-port* "WARNING: Unrecognised scenario, servrs="servrs", thishostip="thishostip", thisservrs="thisservrs) +;; #t)))) (define server-last-start 0) @@ -303,87 +310,87 @@ ;; ;; mode: ;; best - get best server (random of newest five) ;; home - get home host based on oldest server ;; info - print info -(define (server:choose-server areapath #!optional (mode 'best)) - ;; age is current-starttime - ;; find oldest alive - ;; 1. sort by age ascending and ping until good - ;; find alive rand from youngest - ;; 1. sort by age descending - ;; 2. take five - ;; 3. check alive, discard if not and repeat - ;; first we clean up old server files - (assert (eq? (rmt:transport-mode) 'http) "FATAL: server:run called with rmt:transport-mode="(rmt:transport-mode)) - (server:clean-up-old areapath) - (let* ((since-last (- (current-seconds) server-last-start)) - (server-start-delay 10)) - (if ( < (- (current-seconds) server-last-start) 10 ) - (begin - (debug:print 2 *default-log-port* "server:choose-server: seconds since last server start: " (- (current-seconds) server-last-start)) - (debug:print 2 *default-log-port* "server:choose-server: last server start less than " server-start-delay " seconds ago. Sleeping " server-start-delay " seconds") - (thread-sleep! server-start-delay) - ) - (debug:print 2 *default-log-port* "server:choose-server: seconds since last server start: " (- (current-seconds) server-last-start)) - ) - ) - (let* ((serversdat (server:get-servers-info areapath)) - (servkeys (hash-table-keys serversdat)) - (by-time-asc (if (not (null? servkeys)) ;; NOTE: Oldest is last - (sort servkeys ;; list of "host:port" - (lambda (a b) - (>= (list-ref (hash-table-ref serversdat a) 2) - (list-ref (hash-table-ref serversdat b) 2)))) - '()))) - (debug:print 2 *default-log-port* "server:choose-server: serversdat: " serversdat) - (debug:print 2 *default-log-port* "server:choose-server: servkeys: " servkeys) - (if (not (null? by-time-asc)) - (let* ((oldest (last by-time-asc)) - (oldest-dat (hash-table-ref serversdat oldest)) - (host (list-ref oldest-dat 0)) - (all-valid (filter (lambda (x) - (equal? host (list-ref (hash-table-ref serversdat x) 0))) - by-time-asc)) - (best-ten (lambda () - (if (> (length all-valid) 11) - (take (drop-right all-valid 1) 10) ;; remove the oldest from consideration so it can age out - (if (> (length all-valid) 8) - (drop-right all-valid 1) - all-valid)))) - (names->dats (lambda (names) - (map (lambda (x) - (hash-table-ref serversdat x)) - names))) - (am-home? (lambda () - (let* ((currhost (get-host-name)) - (bestadrs (server:get-best-guess-address currhost))) - (or (equal? host currhost) - (equal? host bestadrs)))))) - (case mode - ((info) - (debug:print 0 *default-log-port* "oldest: "oldest-dat", selected host: "host", all-valid: "all-valid) - (debug:print 0 *default-log-port* "youngest: "(hash-table-ref serversdat (car all-valid)))) - ((home) host) - ((homehost) (cons host (am-home?))) ;; shut up old code - ((home?) (am-home?)) - ((best-ten)(names->dats (best-ten))) - ((all-valid)(names->dats all-valid)) - ((best) (let* ((best-ten (best-ten)) - (len (length best-ten))) - (hash-table-ref serversdat (list-ref best-ten (random len))))) - ((count)(length all-valid)) - (else - (debug:print 0 *default-log-port* "ERROR: invalid command "mode) - #f))) - (begin - (server:run areapath) - (set! server-last-start (current-seconds)) - ;; (thread-sleep! 3) - (case mode - ((homehost) (cons #f #f)) - (else #f)))))) +;; (define (server:choose-server areapath #!optional (mode 'best)) +;; ;; age is current-starttime +;; ;; find oldest alive +;; ;; 1. sort by age ascending and ping until good +;; ;; find alive rand from youngest +;; ;; 1. sort by age descending +;; ;; 2. take five +;; ;; 3. check alive, discard if not and repeat +;; ;; first we clean up old server files +;; (assert (eq? (rmt:transport-mode) 'http) "FATAL: server:run called with rmt:transport-mode="(rmt:transport-mode)) +;; (server:clean-up-old areapath) +;; (let* ((since-last (- (current-seconds) server-last-start)) +;; (server-start-delay 10)) +;; (if ( < (- (current-seconds) server-last-start) 10 ) +;; (begin +;; (debug:print 2 *default-log-port* "server:choose-server: seconds since last server start: " (- (current-seconds) server-last-start)) +;; (debug:print 2 *default-log-port* "server:choose-server: last server start less than " server-start-delay " seconds ago. Sleeping " server-start-delay " seconds") +;; (thread-sleep! server-start-delay) +;; ) +;; (debug:print 2 *default-log-port* "server:choose-server: seconds since last server start: " (- (current-seconds) server-last-start)) +;; ) +;; ) +;; (let* ((serversdat (server:get-servers-info areapath)) +;; (servkeys (hash-table-keys serversdat)) +;; (by-time-asc (if (not (null? servkeys)) ;; NOTE: Oldest is last +;; (sort servkeys ;; list of "host:port" +;; (lambda (a b) +;; (>= (list-ref (hash-table-ref serversdat a) 2) +;; (list-ref (hash-table-ref serversdat b) 2)))) +;; '()))) +;; (debug:print 2 *default-log-port* "server:choose-server: serversdat: " serversdat) +;; (debug:print 2 *default-log-port* "server:choose-server: servkeys: " servkeys) +;; (if (not (null? by-time-asc)) +;; (let* ((oldest (last by-time-asc)) +;; (oldest-dat (hash-table-ref serversdat oldest)) +;; (host (list-ref oldest-dat 0)) +;; (all-valid (filter (lambda (x) +;; (equal? host (list-ref (hash-table-ref serversdat x) 0))) +;; by-time-asc)) +;; (best-ten (lambda () +;; (if (> (length all-valid) 11) +;; (take (drop-right all-valid 1) 10) ;; remove the oldest from consideration so it can age out +;; (if (> (length all-valid) 8) +;; (drop-right all-valid 1) +;; all-valid)))) +;; (names->dats (lambda (names) +;; (map (lambda (x) +;; (hash-table-ref serversdat x)) +;; names))) +;; (am-home? (lambda () +;; (let* ((currhost (get-host-name)) +;; (bestadrs (server:get-best-guess-address currhost))) +;; (or (equal? host currhost) +;; (equal? host bestadrs)))))) +;; (case mode +;; ((info) +;; (debug:print 0 *default-log-port* "oldest: "oldest-dat", selected host: "host", all-valid: "all-valid) +;; (debug:print 0 *default-log-port* "youngest: "(hash-table-ref serversdat (car all-valid)))) +;; ((home) host) +;; ((homehost) (cons host (am-home?))) ;; shut up old code +;; ((home?) (am-home?)) +;; ((best-ten)(names->dats (best-ten))) +;; ((all-valid)(names->dats all-valid)) +;; ((best) (let* ((best-ten (best-ten)) +;; (len (length best-ten))) +;; (hash-table-ref serversdat (list-ref best-ten (random len))))) +;; ((count)(length all-valid)) +;; (else +;; (debug:print 0 *default-log-port* "ERROR: invalid command "mode) +;; #f))) +;; (begin +;; (server:run areapath) +;; (set! server-last-start (current-seconds)) +;; ;; (thread-sleep! 3) +;; (case mode +;; ((homehost) (cons #f #f)) +;; (else #f)))))) (define (server:get-servinfo-dir areapath) (let* ((spath (conc areapath"/.servinfo"))) (if (not (file-exists? spath)) (create-directory spath #t)) @@ -451,11 +458,11 @@ ;; transport to be used ;; http - use http-transport ;; http-read-cached - use http-transport for writes but in-mem cached for reads (rmode 'http) - (hh-dat (let ((res (or (server:choose-server *toppath* 'homehost) + (hh-dat (let ((res (or ;; (server:choose-server *toppath* 'homehost) (cons #f #f)))) (assert (pair? res)(conc "FATAL: hh-dat should be a pair, got "res)) res)) (server-url #f) ;; (server:check-if-running *toppath*) #f)) (server-id #f) DELETED subrun.scm Index: subrun.scm ================================================================== --- subrun.scm +++ /dev/null @@ -1,39 +0,0 @@ - -;; Copyright 2006-2016, 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 . - -;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') - -(declare (unit subrun)) - -(declare (uses debugprint)) -(declare (uses commonmod)) -(declare (uses configfmod)) -(declare (uses tasksmod)) - -(declare (uses mt)) -(declare (uses common)) - -(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) - posix-extras directory-utils pathname-expand typed-records format - call-with-environment-variables) - -(import commonmod - configfmod - debugprint - tasksmod) - Index: subrunmod.scm ================================================================== --- subrunmod.scm +++ subrunmod.scm @@ -40,11 +40,22 @@ (declare (uses tasksmod)) (use srfi-69) (module subrunmod - * + ( + subrun:launch-dashboard + subrun:get-runarea + subrun:set-state-status + subrun:kill-subrun + subrun:get-log-path + subrun:remove-subrun + subrun:subrun-removed? + subrun:subrun-test-initialized? + subrun:launch-cmd + subrun:initialize-toprun-test + ) (import scheme) (cond-expand (chicken-4 Index: task_records.scm ================================================================== --- task_records.scm +++ task_records.scm @@ -15,30 +15,5 @@ ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;;====================================================================== -;; make-vector-record tasks task id action owner state target name test item params creation_time execution_time -(define (make-tasks:task)(make-vector 11)) -(define-inline (tasks:task-get-id vec) (vector-ref vec 0)) -(define-inline (tasks:task-get-action vec) (vector-ref vec 1)) -(define-inline (tasks:task-get-owner vec) (vector-ref vec 2)) -(define-inline (tasks:task-get-state vec) (vector-ref vec 3)) -(define-inline (tasks:task-get-target vec) (vector-ref vec 4)) -(define-inline (tasks:task-get-name vec) (vector-ref vec 5)) -(define-inline (tasks:task-get-testpatt vec) (vector-ref vec 6)) -(define-inline (tasks:task-get-keylock vec) (vector-ref vec 7)) -(define-inline (tasks:task-get-params vec) (vector-ref vec 8)) -(define-inline (tasks:task-get-creation_time vec) (vector-ref vec 9)) -(define-inline (tasks:task-get-execution_time vec) (vector-ref vec 10)) - -(define-inline (tasks:task-set-state! vec val)(vector-set! vec 3 val)) - - -;; make-vector-record tasks monitor id pid start_time last_update hostname username -(define (make-tasks:monitor)(make-vector 5)) -(define-inline (tasks:monitor-get-id vec) (vector-ref vec 0)) -(define-inline (tasks:monitor-get-pid vec) (vector-ref vec 1)) -(define-inline (tasks:monitor-get-start_time vec) (vector-ref vec 2)) -(define-inline (tasks:monitor-get-last_update vec) (vector-ref vec 3)) -(define-inline (tasks:monitor-get-hostname vec) (vector-ref vec 4)) -(define-inline (tasks:monitor-get-username vec) (vector-ref vec 5)) Index: tasksmod.scm ================================================================== --- tasksmod.scm +++ tasksmod.scm @@ -39,11 +39,29 @@ (declare (uses megatestmod)) (use srfi-69) (module tasksmod - * + ( + configf:write-alist + common:simple-unlock + common:simple-lock + tests:test-set-status! + common:get-launcher + tasks:kill-runner + tests:get-testconfig + tests:get-waitons + + tests:get-test-path-from-environment + common:exit-on-version-changed + task:get-run-times + task:get-test-times + tasks:sync-to-postgres + tests:get-full-data + tasks:task-get-testpatt + + ) (import scheme) (cond-expand (chicken-4 @@ -1220,27 +1238,27 @@ ;;====================================================================== ;; (begin ;; (debug:print 0 *default-log-port* "ERROR: cannot migrate version unless on homehost. Exiting.") ;; (exit 1)))) -(define (common:wait-for-homehost-load maxnormload msg) - (let loop ((start-time (current-seconds))) ;; we saw some instances of this being called before *toppath* was set. This might be an early setup race. This delay should help but it is impossible to test... - (if (not *toppath*) - (begin - (debug:print 0 *default-log-port* "ERROR: common:wait-for-homehost-load called before *toppath* set.") - (thread-sleep! 30) - (if (< (- (current-seconds) start-time) 300) - (loop start-time))))) - (case (rmt:transport-mode) - ((http) - (let* ((hh-dat (if (rmt:on-homehost?) ;; if we are on the homehost then pass in #f so the calls are local. - #f - (server:choose-server *toppath* 'homehost))) - (hh (if hh-dat (car hh-dat) #f))) - (common:wait-for-normalized-load maxnormload msg hh))) - (else - (common:wait-for-normalized-load maxnormload msg (get-host-name))))) +;; (define (common:wait-for-homehost-load maxnormload msg) +;; (let loop ((start-time (current-seconds))) ;; we saw some instances of this being called before *toppath* was set. This might be an early setup race. This delay should help but it is impossible to test... +;; (if (not *toppath*) +;; (begin +;; (debug:print 0 *default-log-port* "ERROR: common:wait-for-homehost-load called before *toppath* set.") +;; (thread-sleep! 30) +;; (if (< (- (current-seconds) start-time) 300) +;; (loop start-time))))) +;; (case (rmt:transport-mode) +;; ((http) +;; (let* ((hh-dat (if (rmt:on-homehost?) ;; if we are on the homehost then pass in #f so the calls are local. +;; #f +;; (server:choose-server *toppath* 'homehost))) +;; (hh (if hh-dat (car hh-dat) #f))) +;; (common:wait-for-normalized-load maxnormload msg hh))) +;; (else +;; (common:wait-for-normalized-load maxnormload msg (get-host-name))))) (define (configf:write-alist cdat fname) (if (not (common:faux-lock fname)) (debug:print 0 *default-log-port* "INFO: Could not get lock on " fname)) @@ -1867,7 +1885,32 @@ ) (hash-table-keys missing-waitons) ) )) +;; make-vector-record tasks task id action owner state target name test item params creation_time execution_time +(define (make-tasks:task)(make-vector 11)) +(define (tasks:task-get-id vec) (vector-ref vec 0)) +(define (tasks:task-get-action vec) (vector-ref vec 1)) +(define (tasks:task-get-owner vec) (vector-ref vec 2)) +(define (tasks:task-get-state vec) (vector-ref vec 3)) +(define (tasks:task-get-target vec) (vector-ref vec 4)) +(define (tasks:task-get-name vec) (vector-ref vec 5)) +(define (tasks:task-get-testpatt vec) (vector-ref vec 6)) +(define (tasks:task-get-keylock vec) (vector-ref vec 7)) +(define (tasks:task-get-params vec) (vector-ref vec 8)) +(define (tasks:task-get-creation_time vec) (vector-ref vec 9)) +(define (tasks:task-get-execution_time vec) (vector-ref vec 10)) + +(define (tasks:task-set-state! vec val)(vector-set! vec 3 val)) + + +;; make-vector-record tasks monitor id pid start_time last_update hostname username +(define (make-tasks:monitor)(make-vector 5)) +(define (tasks:monitor-get-id vec) (vector-ref vec 0)) +(define (tasks:monitor-get-pid vec) (vector-ref vec 1)) +(define (tasks:monitor-get-start_time vec) (vector-ref vec 2)) +(define (tasks:monitor-get-last_update vec) (vector-ref vec 3)) +(define (tasks:monitor-get-hostname vec) (vector-ref vec 4)) +(define (tasks:monitor-get-username vec) (vector-ref vec 5)) ) Index: tcmt.scm ================================================================== --- tcmt.scm +++ tcmt.scm @@ -24,11 +24,11 @@ ;; (declare (uses mtargs)) (declare (uses rmt)) (declare (uses rmtmod)) -(declare (uses common)) +;; (declare (uses common)) ;; (declare (uses megatest-version)) (declare (uses commonmod)) (use srfi-1 posix srfi-69 srfi-18 regex defstruct) @@ -37,11 +37,11 @@ (import commonmod rmtmod (prefix mtargs args:)) -(include "megatest-version.scm") +;; (include "megatest-version.scm") (include "megatest-fossil-hash.scm") ;; (include "db_records.scm") (define origargs (cdr (argv))) (define remargs (args:get-args Index: tcp-transportmod.scm ================================================================== --- tcp-transportmod.scm +++ tcp-transportmod.scm @@ -27,11 +27,29 @@ (declare (uses mtmod)) (use address-info tcp) (module tcp-transportmod - * + ( + make-tt + tt:get-server-info-sorted + tt:ping + tt:find-server + tt:start-server + tt:get-servinfo-dir + tt-server-timeout-param + tt:mk-signature + tt-state + tt:server-process-run + tt:make-remote + tt-ro-mode-checked-set! + tt-ro-mode-set! + tt-ro-mode + tt-ro-mode-checked + tt:handler + tt:get-conn + ) (import scheme) (cond-expand (chicken-4 Index: tdb.scm ================================================================== --- tdb.scm +++ tdb.scm @@ -1,6 +1,6 @@ -;;====================================================================== +>;;====================================================================== ;; Copyright 2006-2013, Matthew Welland. ;; ;; This file is part of Megatest. ;; ;; Megatest is free software: you can redistribute it and/or modify @@ -22,31 +22,40 @@ ;; Database access ;;====================================================================== (declare (unit tdb)) (declare (uses debugprint)) -(declare (uses common)) (declare (uses keys)) -(declare (uses mt)) (declare (uses commonmod)) (declare (uses mtargs)) (declare (uses rmtmod)) + +(module tdb + * + +(import scheme + chicken + data-structures + ) (require-extension (srfi 18) extras tcp) -(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64) + +(import srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 + message-digest base64) + (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) (import commonmod debugprint rmtmod (prefix mtargs args:)) -(include "common_records.scm") +;; (include "common_records.scm") ;; (include "db_records.scm") ;; (include "key_records.scm") -(include "run_records.scm") +;; (include "run_records.scm") ;;====================================================================== ;; ;; T E S T D A T A B A S E S ;; @@ -53,10 +62,19 @@ ;;====================================================================== ;;====================================================================== ;; T E S T S P E C I F I C D B ;;====================================================================== + +;; (define (rmt:open-test-db-by-test-id run-id test-id #!key (work-area #f)) +;; (assert (number? run-id) "FATAL: Run id required.") +;; (let* ((test-path (if (string? work-area) +;; work-area +;; (rmt:test-get-rundir-from-test-id run-id test-id)))) +;; (debug:print 3 *default-log-port* "TEST PATH: " test-path) +;; (open-test-db test-path))) + ;; =not-used= ;; Create the sqlite db for the individual test(s) ;; =not-used= ;; ;; =not-used= ;; Moved these tables into .db ;; =not-used= ;; THIS CODE TO BE REMOVED @@ -232,23 +250,23 @@ (loop (read-line))))) ;; roll up the current results. ;; FIXME: Add the status too (rmt:test-data-rollup run-id test-id #f)) -;; NOTE: Run this local with #f for db !!! -(define (tdb:load-logpro-data run-id test-id) - (let loop ((lin (read-line))) - (if (not (eof-object? lin)) - (begin - (debug:print 4 *default-log-port* lin) - ;;(when lin ;; this when blocked stack dump caused by .dat file from logpro being 0-byte. fixed by upgrading logpro - (rmt:csv->test-data run-id test-id lin) - ;;) - (loop (read-line))))) - ;; roll up the current results. - ;; FIXME: Add the status too - (rmt:test-data-rollup run-id test-id #f)) +;; ;; NOTE: Run this local with #f for db !!! +;; (define (tdb:load-logpro-data run-id test-id) +;; (let loop ((lin (read-line))) +;; (if (not (eof-object? lin)) +;; (begin +;; (debug:print 4 *default-log-port* lin) +;; ;;(when lin ;; this when blocked stack dump caused by .dat file from logpro being 0-byte. fixed by upgrading logpro +;; (rmt:csv->test-data run-id test-id lin) +;; ;;) +;; (loop (read-line))))) +;; ;; roll up the current results. +;; ;; FIXME: Add the status too +;; (rmt:test-data-rollup run-id test-id #f)) ;;====================================================================== ;; S T E P S ;;====================================================================== @@ -403,14 +421,16 @@ (conc (vector-ref b 2))) #f)) (string. - -;; make-vector-record tests testqueue testname testconfig waitons priority items -(define (make-tests:testqueue)(make-vector 7 #f)) -(define (tests:testqueue-get-testname vec) (vector-ref vec 0)) -(define (tests:testqueue-get-testconfig vec) (vector-ref vec 1)) -(define (tests:testqueue-get-waitons vec) (vector-ref vec 2)) -(define (tests:testqueue-get-priority vec) (vector-ref vec 3)) -;; items: #f=no items, list=list of items remaining, proc=need to call to get items -(define (tests:testqueue-get-items vec) (vector-ref vec 4)) -(define (tests:testqueue-get-itemdat vec) (vector-ref vec 5)) -(define (tests:testqueue-get-item_path vec) (vector-ref vec 6)) - -(define (tests:testqueue-set-testname! vec val)(vector-set! vec 0 val)) -(define (tests:testqueue-set-testconfig! vec val)(vector-set! vec 1 val)) -(define (tests:testqueue-set-waitons! vec val)(vector-set! vec 2 val)) -(define (tests:testqueue-set-priority! vec val)(vector-set! vec 3 val)) -(define (tests:testqueue-set-items! vec val)(vector-set! vec 4 val)) -(define (tests:testqueue-set-itemdat! vec val)(vector-set! vec 5 val)) -(define (tests:testqueue-set-item_path! vec val)(vector-set! vec 6 val)) - Index: testsmod.scm ================================================================== --- testsmod.scm +++ testsmod.scm @@ -39,11 +39,27 @@ (declare (uses fsmod)) (use srfi-69) (module testsmod - * + ( + tests:summarize-items + tests:filter-non-runnable + tests:sort-by-priority-and-waiton + tests:lazy-dot + + tests:summarize-test + tests:save-final-status + tests:update-central-meta-info + tests:set-full-meta-info + tests:get-compressed-steps + tests:create-html-summary + tests:create-html-summary + tests:create-html-tree + tests:summarize-items + tests:test-get-paths-matching + ) (import scheme) (cond-expand (chicken-4 @@ -125,11 +141,11 @@ mtmod servermod fsmod ) -(include "common_records.scm") +;; (include "common_records.scm") ;; (include "key_records.scm") ;; (include "db_records.scm") (include "run_records.scm") ;; (include "test_records.scm") (include "js-path.scm") Index: transport-mode.scm ================================================================== --- transport-mode.scm +++ transport-mode.scm @@ -8,15 +8,15 @@ ;; NOTE: NOT ALL COMBINATIONS WORK ;; ;;====================================================================== ;; uncomment this block to test without tcp -;; (dbfile:sync-method 'none) -;; (dbfile:cache-method 'none) -;; (rmt:transport-mode 'nfs) +(dbfile:sync-method 'none) +(dbfile:cache-method 'none) +(rmt:transport-mode 'nfs) ;; uncomment this block to test with tcp -(dbfile:sync-method 'attach) ;; attach) ;; original -(dbfile:cache-method 'tmp) -(rmt:transport-mode 'tcp) +;; (dbfile:sync-method 'attach) ;; attach) ;; original +;; (dbfile:cache-method 'tmp) +;; (rmt:transport-mode 'tcp) DELETED tree.scm Index: tree.scm ================================================================== --- tree.scm +++ /dev/null @@ -1,158 +0,0 @@ -;;====================================================================== -;; Copyright 2006-2013, 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 tree)) -(declare (uses mtargs)) -(declare (uses debugprint)) -(declare (uses launch)) -(declare (uses gutils)) -(declare (uses server)) -(declare (uses dcommon)) - -(use format) -(require-library iup) -(import (prefix iup iup:)) -(use canvas-draw) - -(use sqlite3 srfi-1 posix regex regex-case srfi-69) -(import (prefix sqlite3 sqlite3:)) - -(import (prefix mtargs args:) - debugprint) - -(include "megatest-version.scm") -(include "common_records.scm") -;; (include "db_records.scm") -;; (include "key_records.scm") - -;;====================================================================== -;; T R E E S T U F F -;;====================================================================== - -;; path is a list of nodes, each the child of the previous -;; this routine returns the id so another node can be added -;; either as a leaf or as a branch -;; -;; BUG: This needs a stop sensor for when a branch is exhausted -;; -(define (tree:find-node obj path) - ;; start at the base of the tree - (if (null? path) - #f ;; or 0 ???? - (let loop ((hed (car path)) - (tal (cdr path)) - (depth 0) - (nodenum 0)) - ;; nodes in iup tree are 100% sequential so iterate over nodenum - (if (iup:attribute obj (conc "DEPTH" nodenum)) ;; end when no more nodes - (let ((node-depth (string->number (iup:attribute obj (conc "DEPTH" nodenum)))) - (node-title (iup:attribute obj (conc "TITLE" nodenum)))) - (if (and (equal? depth node-depth) - (equal? hed node-title)) ;; yep, this is the one! - (if (null? tal) ;; end of the line - nodenum - (loop (car tal)(cdr tal)(+ depth 1)(+ 1 nodenum))) - ;; this is the case where we found part of the hierarchy but not - ;; all of it, i.e. the node-depth went from deep to less deep - (if (> depth node-depth) ;; (+ 1 node-depth)) - #f - (loop hed tal depth (+ nodenum 1))))) - #f)))) - -;; top is the top node name zeroeth node VALUE=0 -(define (tree:add-node obj top nodelst #!key (userdata #f)) - (let ((curr-top (iup:attribute obj "TITLE0"))) - (if (or (not (string? curr-top)) - (string-null? curr-top) - (string-match "^\\s*$" curr-top)) - (iup:attribute-set! obj "ADDBRANCH0" top)) - - - - (cond - ((not (equal? top (iup:attribute obj "TITLE0"))) - (debug:print 0 *default-log-port* "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0"))) - ((null? nodelst)) - (else - (let loop ((hed (car nodelst)) - (tal (cdr nodelst)) - (depth 1) - (pathl (list top))) - ;; Because the tree dialog changes node numbers when - ;; nodes are added or removed we must look up nodes - ;; each and every time. 0 is the top node so default - ;; to that. - (let* ((newpath (append pathl (list hed))) - (parentnode (tree:find-node obj pathl)) - (nodenum (tree:find-node obj newpath))) - ;; Add the branch under lastnode if not found - (if (not nodenum) - (begin - (iup:attribute-set! obj (conc "ADDBRANCH" parentnode) hed) - ;; ERROR? ADDING DATA TO PARENT, DONT WE WANT IT ON CREATED NODE? - (if userdata - (iup:attribute-set! obj (conc "USERDATA" parentnode) userdata)) - (if (null? tal) - #t - ;; reset to top - (loop (car nodelst)(cdr nodelst) 1 (list top)))) - (if (null? tal) ;; if null here then this path has already been added - #t - (loop (car tal)(cdr tal)(+ depth 1) newpath))))))))) - -(define (tree:node->path obj nodenum) - (let loop ((currnode 0) - (path '())) - (let* ((node-depth (string->number (iup:attribute obj (conc "DEPTH" currnode)))) - (node-title (iup:attribute obj (conc "TITLE" currnode))) - (trimpath (if (and (not (null? path)) - (> (length path) node-depth)) - (take path node-depth) - path)) - (newpath (append trimpath (list node-title)))) - (if (>= currnode nodenum) - newpath - (loop (+ currnode 1) - newpath))))) - -(define (tree:delete-node obj top node-path) ;; node-path is a list of strings - (let ((id (tree:find-node obj (cons top node-path)))) - (debug:print 0 *default-log-port* "Found node to remove " id " for path " top " " node-path) - (iup:attribute-set! obj (conc "DELNODE" id) "SELECTED"))) - -#| - - (let* ((tb (iup:treebox - #:value 0 - #:name "Runs" - #:expand "YES" - #:addexpanded "NO" - #:selection-cb - (lambda (obj id state) - ;; (print "obj: " obj ", id: " id ", state: " state) - (let* ((run-path (tree:node->path obj id)) - (run-id (tree-path->run-id (cdr run-path)))) - (if run-id - (begin - (dboard:data-curr-run-id-set! data run-id) - (dashboard:update-run-summary-tab))) - ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) - )))) -|# ADDED utils/extract-export-list.scm Index: utils/extract-export-list.scm ================================================================== --- /dev/null +++ utils/extract-export-list.scm @@ -0,0 +1,78 @@ +;; #!/bin/bash + +(module extract + * + +(import scheme + chicken) + +(use srfi-1 + srfi-69 + extras + posix + regex + matchable + data-structures + ) + +(define (get-norefs) + (let* ((indat (with-input-from-pipe + "grep 'Warning: refer' typescript" + read-lines))) + (filter string? + (map (lambda (instr) + (match (string-search "`(\\S+)'" instr) + ((full thematch) thematch) + (else #f))) + indat)))) + +(define (get-parent-files noref) + (let ((scmfiles (with-input-from-pipe + "ls *scm|grep -v import" + read-lines)) + (resultht (make-hash-table))) + (for-each + (lambda (scmfile) + (let ((lines (with-input-from-pipe + (conc "grep '"noref"' "scmfile"|egrep '^.define'") + read-lines))) + (if (not (null? lines)) + (hash-table-set! resultht scmfile #t)))) + scmfiles) + (hash-table-keys resultht))) + +(define (main) + (let ((data (make-hash-table)) + (fns (get-norefs))) + (for-each + (lambda (fn) + (let ((parents (get-parent-files fn))) + ;; (print fn": "parents) + (for-each + (lambda (parent) + (hash-table-set! data parent (cons fn (hash-table-ref/default data parent '())))) + parents))) + fns) + (for-each + (lambda (f) + (let ((fns (hash-table-ref data f))) + (print "\n"f) + (map print fns))) + (hash-table-keys data)))) + +(main) +) + +;; +;; LAST_PARENT=foobar +;; +;; for fn in $(grep 'Warning: refer' typescript |tr '`' ' '|tr "'" " "|awk '{print $7}');do +;; PARENT=$(grep $fn *mod.scm|grep define|cut -d: -f1) +;; if [[ $PARENT != $LAST_PARENT ]];then +;; echo +;; echo $PARENT +;; LAST_PARENT=$PARENT +;; fi +;; echo $fn +;; done +;; ADDED utils/extract-export-list.sh Index: utils/extract-export-list.sh ================================================================== --- /dev/null +++ utils/extract-export-list.sh @@ -0,0 +1,13 @@ +#!/bin/bash + +LAST_PARENT=foobar + +for fn in $(grep 'Warning: refer' typescript |tr '`' ' '|tr "'" " "|awk '{print $7}');do + PARENT=$(grep $fn *mod.scm|grep define|cut -d: -f1) + if [[ $PARENT != $LAST_PARENT ]];then + echo + echo $PARENT + LAST_PARENT=$PARENT + fi + echo $fn +done Index: vg.scm ================================================================== --- vg.scm +++ vg.scm @@ -16,651 +16,25 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') -(use typed-records srfi-1) - -(declare (unit vg)) -(use canvas-draw iup) -(import canvas-draw-iup) - -(include "vg_records.scm") - -;; ;; structs -;; ;; -;; (defstruct vg:lib comps) -;; (defstruct vg:comp objs name file) -;; ;; extents caches extents calculated on draw -;; ;; proc is called on draw and takes the obj itself as a parameter -;; ;; attrib is an alist of parameters -;; (defstruct vg:obj type pts fill-color text line-color call-back angle font attrib extents proc) -;; (defstruct vg:inst libname compname theta xoff yoff scalex scaley mirrx mirry call-back cache) -;; (defstruct vg:drawing libs insts scalex scaley xoff yoff cnv cache) ;; libs: hash of name->lib, insts: hash of instname->inst - -;; inits -;; -(define (vg:comp-new) - (make-vg:comp objs: '() name: #f file: #f)) - -(define (vg:lib-new) - (make-vg:lib comps: (make-hash-table))) - -(define (vg:drawing-new) - (make-vg:drawing scalex: 1 - scaley: 1 - xoff: 0 - yoff: 0 - libs: (make-hash-table) - insts: (make-hash-table) - cache: '())) - -;;====================================================================== -;; scaling and offsets -;;====================================================================== - -(define-inline (vg:scale-offset val s o) - (+ o (* val s))) - ;; (* (+ o val) s)) - -;; apply scale and offset to a list of x y values -;; -(define (vg:scale-offset-xy lstxy sx sy ox oy) - (if (> (length lstxy) 1) ;; have at least one xy pair - (let loop ((x (car lstxy)) - (y (cadr lstxy)) - (tal (cddr lstxy)) - (res '())) - (let ((newres (cons (vg:scale-offset y sy oy) - (cons (vg:scale-offset x sx ox) - res)))) - (if (> (length tal) 1) - (loop (car tal)(cadr tal)(cddr tal) newres) - (reverse newres)))) - '())) - -;; apply drawing offset and scaling to the points in lstxy -;; -(define (vg:drawing-apply-scale drawing lstxy) - (vg:scale-offset-xy - lstxy - (vg:drawing-scalex drawing) - (vg:drawing-scaley drawing) - (vg:drawing-xoff drawing) - (vg:drawing-yoff drawing))) - -;; apply instance offset and scaling to the points in lstxy -;; -(define (vg:inst-apply-scale inst lstxy) - (vg:scale-offset-xy - lstxy - (vg:inst-scalex inst) - (vg:inst-scaley inst) - (vg:inst-xoff inst) - (vg:inst-yoff inst))) - -;; apply both drawing and instance scaling to a list of xy points -;; -(define (vg:drawing-inst-apply-scale-offset drawing inst lstxy) - (vg:drawing-apply-scale - drawing - (vg:inst-apply-scale inst lstxy))) - -;;====================================================================== -;; objects -;;====================================================================== - -;; (vg:inst-apply-scale -;; inst -;; (vg:drawing-apply-scale drawing lstxy))) - -;; make a rectangle obj -;; -(define (vg:make-rect-obj x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)(text #f)(font #f)(extents #f)) - (make-vg:obj type: 'r pts: (list x1 y1 x2 y2) text: text font: font line-color: line-color fill-color: fill-color extents: extents)) - -;; make a rectangle obj -;; -(define (vg:make-line-obj x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)(text #f)(font #f)(extents #f)) - (make-vg:obj type: 'l pts: (list x1 y1 x2 y2) text: text font: font line-color: line-color extents: extents)) - -;; make a text obj -;; -(define (vg:make-text-obj x1 y1 text #!key (line-color #f)(fill-color #f) - (angle #f)(scale-with-zoom #f)(font #f) - (font-size #f)) - (make-vg:obj type: 't pts: (list x1 y1) text: text - line-color: line-color fill-color: fill-color - angle: angle font: font extents: #f - attributes: (vg:make-attrib 'font-size font-size))) - -;; proc takes startnum and endnum and yields scalef, per-grad and unitname -;; -(define (vg:make-xaxis-obj x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)(text #f)(font #f)(proc #f)) - (make-vg:obj type: 'x pts: (list x1 y1 x2 y2) text: text font: font line-color: line-color fill-color: fill-color extents: #f proc: proc)) - -;;====================================================================== -;; obj modifiers and queries -;;====================================================================== - -;; get extents, use knowledge of type ... -;; -(define (vg:obj-get-extents drawing obj) - (let ((type (vg:obj-type obj))) - (case type - ((l)(vg:rect-get-extents obj)) - ((r)(vg:rect-get-extents obj)) - ((t)(vg:draw-text drawing obj draw: #f)) - (else #f)))) - -(define (vg:rect-get-extents obj) - (vg:obj-pts obj)) ;; extents are just the points for a rectangle - -(define (vg:grow-rect borderx bordery x1 y1 x2 y2) - (list - (- x1 borderx) - (- y1 bordery) - (+ x2 borderx) - (+ y2 bordery))) - -(define (vg:make-attrib . attrib-list) - #f) - -;;====================================================================== -;; components -;;====================================================================== - -;; add obj to comp -;; -(define (vg:add-objs-to-comp comp . objs) - (vg:comp-objs-set! comp (append (vg:comp-objs comp) objs))) - -(define (vg:add-obj-to-comp comp obj) - (vg:comp-objs-set! comp (cons obj (vg:comp-objs comp)))) - -;; use the struct. leave this here to remind of this! -;; -;; (define (vg:comp-get-objs comp) -;; (vg:comp-objs comp)) - -;; add comp to lib -;; -(define (vg:add-comp-to-lib lib compname comp) - (hash-table-set! (vg:lib-comps lib) compname comp)) - -;; instanciate component in drawing -;; -(define (vg:instantiate drawing libname compname instname xoff yoff #!key (theta 0)(scalex 1)(scaley 1)(mirrx #f)(mirry #f)) - (let ((inst (make-vg:inst libname: libname compname: compname xoff: xoff yoff: yoff theta: theta scalex: scalex scaley: scaley mirrx: mirrx mirry: mirry)) ) - (hash-table-set! (vg:drawing-insts drawing) instname inst))) - -(define (vg:instance-move drawing instname newx newy) - (let ((inst (hash-table-ref (vg:drawing-insts drawing) instname))) - (vg:inst-xoff-set! inst newx) - (vg:inst-yoff-set! inst newy))) - -;; get component from drawing (look in apropriate lib) given libname and compname -(define (vg:get-component drawing libname compname) - (let* ((lib (hash-table-ref (vg:drawing-libs drawing) libname)) - (inst (hash-table-ref (vg:lib-comps lib) compname))) - inst)) - -(define (vg:get-extents-for-objs drawing objs) - (if (or (not objs) - (null? objs)) - #f - (let loop ((hed (car objs)) - (tal (cdr objs)) - (extents (vg:obj-get-extents drawing (car objs)))) - (let ((newextents - (vg:get-extents-for-two-rects - extents - (vg:obj-get-extents drawing hed)))) - (if (null? tal) - extents - (loop (car tal)(cdr tal) newextents)))))) - -;; (let ((extents #f)) -;; (for-each -;; (lambda (obj) -;; (set! extents -;; (vg:get-extents-for-two-rects -;; extents -;; (vg:obj-get-extents drawing obj)))) -;; objs) -;; extents)) - -;; given rectangles r1 and r2, return the box that bounds both -;; -(define (vg:get-extents-for-two-rects r1 r2) - (if (not r1) - r2 - (if (not r2) - r1 ;; #f ;; no extents from #f #f - (list (min (car r1)(car r2)) ;; llx - (min (cadr r1)(cadr r2)) ;; lly - (max (caddr r1)(caddr r2)) ;; ulx - (max (cadddr r1)(cadddr r2)))))) ;; uly - -(define (vg:components-get-extents drawing . comps) - (if (null? comps) - #f - (let loop ((hed (car comps)) - (tal (cdr comps)) - (extents #f)) - (let* ((objs (vg:comp-objs hed)) - (newextents (if extents - (vg:get-extents-for-two-rects - extents - (vg:get-extents-for-objs drawing objs)) - (vg:get-extents-for-objs drawing objs)))) - (if (null? tal) - newextents - (loop (car tal)(cdr tal) newextents)))))) - -;;====================================================================== -;; libraries -;;====================================================================== - -;; register lib with drawing - -;; -(define (vg:add-lib drawing libname lib) - (hash-table-set! (vg:drawing-libs drawing) libname lib)) - -(define (vg:get-lib drawing libname) - (hash-table-ref/default (vg:drawing-libs drawing) libname #f)) - -(define (vg:get/create-lib drawing libname) - (let ((lib (vg:get-lib drawing libname))) - (if lib - lib - (let ((newlib (vg:lib-new))) - (vg:add-lib drawing libname newlib) - newlib)))) - -;;====================================================================== -;; map objects given offset, scale and mirror, resulting obj is displayed -;;====================================================================== - -;; dispatch the drawing of obj off to the correct drawing routine -;; -(define (vg:map-obj drawing inst obj) - (case (vg:obj-type obj) - ((l)(vg:map-line drawing inst obj)) - ((r)(vg:map-rect drawing inst obj)) - ((t)(vg:map-text drawing inst obj)) - ((x)(vg:map-xaxis drawing inst obj)) - (else #f))) - -;; given a drawing and a inst map a rectangle to it screen coordinates -;; -(define (vg:map-rect drawing inst obj) - (let ((res (make-vg:obj type: 'r ;; is there a defstruct copy? - fill-color: (vg:obj-fill-color obj) - text: (vg:obj-text obj) - line-color: (vg:obj-line-color obj) - font: (vg:obj-font obj))) - (pts (vg:obj-pts obj))) - (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts)) - (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing) )) - res)) - -;; given a drawing and a inst map a line to it screen coordinates -;; -(define (vg:map-line drawing inst obj) - (let ((res (make-vg:obj type: 'l ;; is there a defstruct copy? - line-color: (vg:obj-line-color obj) - font: (vg:obj-font obj))) - (pts (vg:obj-pts obj))) - (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts)) - (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing) )) - res)) - -;; given a drawing and a inst map a text to it screen coordinates -;; -(define (vg:map-text drawing inst obj) - (let ((res (make-vg:obj type: 't - fill-color: (vg:obj-fill-color obj) - text: (vg:obj-text obj) - line-color: (vg:obj-line-color obj) - font: (vg:obj-font obj) - angle: (vg:obj-angle obj) - attrib: (vg:obj-attrib obj))) - (pts (vg:obj-pts obj))) - (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts)) - (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing))) - res)) - -;; given a drawing and a inst map a line to it screen coordinates -;; -(define (vg:map-xaxis drawing inst obj) - (let ((res (make-vg:obj type: 'x ;; is there a defstruct copy? - line-color: (vg:obj-line-color obj) - font: (vg:obj-font obj))) - (pts (vg:obj-pts obj))) - (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts)) - (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing) )) - res)) - -;;====================================================================== -;; instances -;;====================================================================== - -(define (vg:instances-get-extents drawing . instance-names) - (let ((xtnt-lst (vg:draw drawing #f))) - (if (null? xtnt-lst) - #f - (let loop ((extents (car xtnt-lst)) - (tal (cdr xtnt-lst)) - (llx #f) - (lly #f) - (ulx #f) - (uly #f)) - (let ((nllx (if llx (min llx (list-ref extents 0))(list-ref extents 0))) - (nlly (if lly (min lly (list-ref extents 1))(list-ref extents 1))) - (nulx (if ulx (max ulx (list-ref extents 2))(list-ref extents 2))) - (nuly (if uly (max uly (list-ref extents 3))(list-ref extents 3)))) - (if (null? tal) - (list llx lly ulx uly) - (loop (car tal)(cdr tal) nllx nlly nulx nuly))))))) - -(define (vg:lib-get-component lib instname) - (hash-table-ref/default (vg:lib-comps lib) instname #f)) - -;;====================================================================== -;; color -;;====================================================================== - -(define (vg:rgb->number r g b #!key (a 0)) - (bitwise-ior - (arithmetic-shift a 24) - (arithmetic-shift r 16) - (arithmetic-shift g 8) - b)) - -;; Obsolete function -;; -(define (vg:generate-color) - (vg:rgb->number (random 255) - (random 255) - (random 255))) - -;; Need to return a string of random iup-color for graph -;; -(define (vg:generate-color-rgb) - (conc (number->string (random 255)) " " - (number->string (random 255)) " " - (number->string (random 255)))) - -(define (vg:iup-color->number iup-color) - (apply vg:rgb->number (map string->number (string-split iup-color)))) - -;;====================================================================== -;; graphing -;;====================================================================== - -(define (vg:make-xaxis drawing component x1 y1 x2 y2 startnum endnum scaleproc) - (let ((obj (vg:make-xaxis-obj x1 y1 x2 y2))) - #f)) - -;;====================================================================== -;; Unravel and draw the objects -;;====================================================================== - -;; with get-extents = #t return the extents -;; with draw = #f don't actually draw the object -;; -(define (vg:draw-obj drawing obj #!key (draw #t)) - ;; (print "obj type: " (vg:obj-type obj)) - (case (vg:obj-type obj) - ((l)(vg:draw-line drawing obj draw: draw)) - ((r)(vg:draw-rect drawing obj draw: draw)) - ((t)(vg:draw-text drawing obj draw: draw)))) - -;; given a rect obj draw it on the canvas applying first the drawing -;; scale and offset -;; -(define (vg:draw-rect drawing obj #!key (draw #t)) - (let* ((cnv (vg:drawing-cnv drawing)) - (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj))) - (fill-color (vg:obj-fill-color obj)) - (line-color (vg:obj-line-color obj)) - (text (vg:obj-text obj)) - (font (vg:obj-font obj)) - (llx (car pts)) - (lly (cadr pts)) - (ulx (caddr pts)) - (uly (cadddr pts)) - (w (- ulx llx)) - (h (- uly lly)) - (text-xmax #f) - (text-ymax #f)) - (if draw - (let ((prev-background-color (canvas-background cnv)) - (prev-foreground-color (canvas-foreground cnv))) - (if fill-color - (begin - (canvas-foreground-set! cnv fill-color) - (canvas-box! cnv llx ulx lly uly))) ;; docs are all over the place on this one.;; w h) - (if line-color - (canvas-foreground-set! cnv line-color) - (if fill-color - (canvas-foreground-set! cnv prev-foreground-color))) - (canvas-rectangle! cnv llx ulx lly uly) - (canvas-foreground-set! cnv prev-foreground-color) - (if text - (let* ((prev-font (canvas-font cnv)) - (font-changed (and font (not (equal? font prev-font))))) - (if font-changed (canvas-font-set! cnv font)) - (canvas-text! cnv (+ 2 llx)(+ 2 lly) text) - (if (eq? draw 'get-extents) - (let-values (((xmax ymax)(canvas-text-size cnv text))) - (set! text-xmax xmax)(set! text-ymax ymax))) - (if font-changed (canvas-font-set! cnv prev-font)))))) - ;; (print "text-xmax: " text-xmax " text-ymax: " text-ymax) - (if (vg:obj-extents obj) - (vg:obj-extents obj) - (if (not text) - pts ;; no text - (if (and text-xmax text-ymax) ;; have text - (let ((xt (list llx lly - (max ulx (+ llx text-xmax)) - (max uly (+ lly text-ymax))))) - (vg:obj-extents-set! obj xt) - xt) - (if cnv - (if (eq? draw 'get-extents) - (let-values (((xmax ymax)(canvas-text-size cnv text))) - (let ((xt (list llx lly - (max ulx (+ llx xmax)) - (max uly (+ lly ymax))))) - (vg:obj-extents-set! obj xt) - xt)) - pts) - pts)))))) ;; return extents - -;; given a rect obj draw it on the canvas applying first the drawing -;; scale and offset -;; -(define (vg:draw-line drawing obj #!key (draw #t)) - (let* ((cnv (vg:drawing-cnv drawing)) - (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj))) - ;; (fill-color (vg:obj-fill-color obj)) - (line-color (vg:obj-line-color obj)) - (text (vg:obj-text obj)) - (font (vg:obj-font obj)) - (llx (car pts)) - (lly (cadr pts)) - (ulx (caddr pts)) - (uly (cadddr pts)) - (w (- ulx llx)) - (h (- uly lly)) - (text-xmax #f) - (text-ymax #f)) - (if draw - (let ((prev-background-color (canvas-background cnv)) - (prev-foreground-color (canvas-foreground cnv))) - ;; (if fill-color - ;; (begin - ;; (canvas-foreground-set! cnv fill-color) - ;; (canvas-box! cnv llx ulx lly uly))) ;; docs are all over the place on this one.;; w h) - (if line-color - (canvas-foreground-set! cnv line-color)) - ;; (if fill-color - ;; (canvas-foreground-set! cnv prev-foreground-color))) - (canvas-line! cnv llx lly ulx uly) - (canvas-foreground-set! cnv prev-foreground-color) - (if text - (let* ((prev-font (canvas-font cnv)) - (font-changed (and font (not (equal? font prev-font))))) - (if font-changed (canvas-font-set! cnv font)) - (canvas-text! cnv (+ 2 llx)(+ 2 lly) text) - (let-values (((xmax ymax)(canvas-text-size cnv text))) - (set! text-xmax xmax)(set! text-ymax ymax)) - (if font-changed (canvas-font-set! cnv prev-font)))))) - ;; (print "text-xmax: " text-xmax " text-ymax: " text-ymax) - (if (vg:obj-extents obj) - (vg:obj-extents obj) - (if (not text) - pts - (if (and text-xmax text-ymax) - (let ((xt (list llx lly - (max ulx (+ llx text-xmax)) - (max uly (+ lly text-ymax))))) - (vg:obj-extents-set! obj xt) - xt) - (if cnv - (let-values (((xmax ymax)(canvas-text-size cnv text))) - (let ((xt (list llx lly - (max ulx (+ llx xmax)) - (max uly (+ lly ymax))))) - (vg:obj-extents-set! obj xt) - xt)) - pts)))))) ;; return extents - -;; given a rect obj draw it on the canvas applying first the drawing -;; scale and offset -;; -(define (vg:draw-xaxis drawing obj #!key (draw #t)) - (let* ((cnv (vg:drawing-cnv drawing)) - (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj))) - ;; (fill-color (vg:obj-fill-color obj)) - (line-color (vg:obj-line-color obj)) - (text (vg:obj-text obj)) - (font (vg:obj-font obj)) - (llx (car pts)) - (lly (cadr pts)) - (ulx (caddr pts)) - (uly (cadddr pts)) - (w (- ulx llx)) - (h (- uly lly)) - (text-xmax #f) - (text-ymax #f)) - (if draw - (let ((prev-background-color (canvas-background cnv)) - (prev-foreground-color (canvas-foreground cnv))) - ;; (if fill-color - ;; (begin - ;; (canvas-foreground-set! cnv fill-color) - ;; (canvas-box! cnv llx ulx lly uly))) ;; docs are all over the place on this one.;; w h) - (if line-color - (canvas-foreground-set! cnv line-color) - #;(if fill-color - (canvas-foreground-set! cnv prev-foreground-color))) - (canvas-line! cnv llx ulx lly uly) - (canvas-foreground-set! cnv prev-foreground-color) - (if text - (let* ((prev-font (canvas-font cnv)) - (font-changed (and font (not (equal? font prev-font))))) - (if font-changed (canvas-font-set! cnv font)) - (canvas-text! cnv (+ 2 llx)(+ 2 lly) text) - (let-values (((xmax ymax)(canvas-text-size cnv text))) - (set! text-xmax xmax)(set! text-ymax ymax)) - (if font-changed (canvas-font-set! cnv prev-font)))))) - ;; (print "text-xmax: " text-xmax " text-ymax: " text-ymax) - (if (vg:obj-extents obj) - (vg:obj-extents obj) - (if (not text) - pts - (if (and text-xmax text-ymax) - (let ((xt (list llx lly - (max ulx (+ llx text-xmax)) - (max uly (+ lly text-ymax))))) - (vg:obj-extents-set! obj xt) - xt) - (if cnv - (let-values (((xmax ymax)(canvas-text-size cnv text))) - (let ((xt (list llx lly - (max ulx (+ llx xmax)) - (max uly (+ lly ymax))))) - (vg:obj-extents-set! obj xt) - xt)) - pts)))))) ;; return extents - -;; given a rect obj draw it on the canvas applying first the drawing -;; scale and offset -;; -(define (vg:draw-text drawing obj #!key (draw #t)) - (let* ((cnv (vg:drawing-cnv drawing)) - (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj))) - (text (vg:obj-text obj)) - (font (vg:obj-font obj)) - (fill-color (vg:obj-fill-color obj)) - (line-color (vg:obj-line-color obj)) - (llx (car pts)) - (lly (cadr pts))) - (if draw - (let* ((prev-background-color (canvas-background cnv)) - (prev-foreground-color (canvas-foreground cnv)) - (prev-font (canvas-font cnv)) - (font-changed (and font (not (equal? font prev-font))))) - (if line-color - (canvas-foreground-set! cnv line-color) - (if fill-color - (canvas-foreground-set! cnv prev-foreground-color))) - (if font-changed (canvas-font-set! cnv font)) - (canvas-text! cnv llx lly text) - ;; NOTE: we do not set the font back!! - (canvas-foreground-set! cnv prev-foreground-color))) - (if cnv - (if (eq? draw 'get-extents) - (let-values (((xmax ymax)(canvas-text-size cnv text))) - (append pts (list (+ llx xmax)(+ lly ymax)))) ;; will be wrong if text is rotated? - (append pts pts)) - (append pts pts)))) - -(define (vg:draw-inst drawing inst #!key (draw-mode #t)(prev-extents '())) - (let* ((libname (vg:inst-libname inst)) - (compname (vg:inst-compname inst)) - (comp (vg:get-component drawing libname compname)) - (objs (vg:comp-objs comp))) - ;; (print "comp: " comp) - (if (null? objs) - prev-extents - (let loop ((obj (car objs)) - (tal (cdr objs)) - (res prev-extents)) - (let* ((obj-xfrmd (vg:map-obj drawing inst obj)) - (newres (cons (vg:draw-obj drawing obj-xfrmd draw: draw-mode) res))) - (if (null? tal) - newres - (loop (car tal)(cdr tal) newres))))))) - -(define (vg:draw drawing draw-mode . instnames) - (let* ((insts (vg:drawing-insts drawing)) - (all-inst-names (hash-table-keys insts)) - (master-list (if (null? instnames) - all-inst-names - instnames))) - (if (null? master-list) - '() - (let loop ((instname (car master-list)) - (tal (cdr master-list)) - (res '())) - (let* ((inst (hash-table-ref/default insts instname #f)) - (newres (if inst - (vg:draw-inst drawing inst draw-mode: draw-mode prev-extents: res) - res))) - (if (null? tal) - newres - (loop (car tal)(cdr tal) newres))))))) +(declare (unit vg)) + +(module vg + ( + vg:drawing-new + ) + +(import scheme + chicken + + data-structures + extras + typed-records + srfi-1 + srfi-69 + canvas-draw iup + ) + + +) DELETED vg_records.scm Index: vg_records.scm ================================================================== --- vg_records.scm +++ /dev/null @@ -1,171 +0,0 @@ -;; Created by records.sh. DO NOT EDIT THIS FILE. Edit records.sh instead -;; Generated using make-vector-record -safe vg lib comps - -;; Copyright 2006-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 . -;; - -(use simple-exceptions) -(define vg:lib-exn (make-exception "wrong record type, expected vg:lib." 'assert)) -(define (pmake-vg:lib . params)(let ((v (if (null? params)(make-vector 2)(apply vector 'vg:lib params)))) v)) -(define (make-vg:lib #!key - (comps #f) - ) - (vector 'vg:lib comps)) - -(define-inline (vg:lib-comps vec)(if (eq? (vector-ref vec 0) 'vg:lib)(vector-ref vec 1)(raise (vg:lib-exn 'vg:lib-comps 'xpr)))) - -(define-inline (vg:lib-comps-set! vec val)(if (eq? (vector-ref vec 0) 'vg:lib)(vector-set! vec 1 val)(raise (vg:lib-exn 'comps)))) -;; Generated using make-vector-record -safe vg comp objs name file - -(use simple-exceptions) -(define vg:comp-exn (make-exception "wrong record type, expected vg:comp." 'assert)) -(define (pmake-vg:comp . params)(let ((v (if (null? params)(make-vector 4)(apply vector 'vg:comp params)))) v)) -(define (make-vg:comp #!key - (objs #f) - (name #f) - (file #f) - ) - (vector 'vg:comp objs name file)) - -(define-inline (vg:comp-objs vec)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-ref vec 1)(raise (vg:comp-exn 'vg:comp-objs 'xpr)))) -(define-inline (vg:comp-name vec)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-ref vec 2)(raise (vg:comp-exn 'vg:comp-name 'xpr)))) -(define-inline (vg:comp-file vec)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-ref vec 3)(raise (vg:comp-exn 'vg:comp-file 'xpr)))) - -(define-inline (vg:comp-objs-set! vec val)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-set! vec 1 val)(raise (vg:comp-exn 'objs)))) -(define-inline (vg:comp-name-set! vec val)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-set! vec 2 val)(raise (vg:comp-exn 'name)))) -(define-inline (vg:comp-file-set! vec val)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-set! vec 3 val)(raise (vg:comp-exn 'file)))) -;; Generated using make-vector-record -safe vg obj type pts fill-color text line-color call-back angle font attrib extents proc - -(use simple-exceptions) -(define vg:obj-exn (make-exception "wrong record type, expected vg:obj." 'assert)) -(define (pmake-vg:obj . params)(let ((v (if (null? params)(make-vector 12)(apply vector 'vg:obj params)))) v)) -(define (make-vg:obj #!key - (type #f) - (pts #f) - (fill-color #f) - (text #f) - (line-color #f) - (call-back #f) - (angle #f) - (font #f) - (attrib #f) - (extents #f) - (proc #f) - ) - (vector 'vg:obj type pts fill-color text line-color call-back angle font attrib extents proc)) - -(define-inline (vg:obj-type vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 1)(raise (vg:obj-exn 'vg:obj-type 'xpr)))) -(define-inline (vg:obj-pts vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 2)(raise (vg:obj-exn 'vg:obj-pts 'xpr)))) -(define-inline (vg:obj-fill-color vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 3)(raise (vg:obj-exn 'vg:obj-fill-color 'xpr)))) -(define-inline (vg:obj-text vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 4)(raise (vg:obj-exn 'vg:obj-text 'xpr)))) -(define-inline (vg:obj-line-color vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 5)(raise (vg:obj-exn 'vg:obj-line-color 'xpr)))) -(define-inline (vg:obj-call-back vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 6)(raise (vg:obj-exn 'vg:obj-call-back 'xpr)))) -(define-inline (vg:obj-angle vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 7)(raise (vg:obj-exn 'vg:obj-angle 'xpr)))) -(define-inline (vg:obj-font vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 8)(raise (vg:obj-exn 'vg:obj-font 'xpr)))) -(define-inline (vg:obj-attrib vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 9)(raise (vg:obj-exn 'vg:obj-attrib 'xpr)))) -(define-inline (vg:obj-extents vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 10)(raise (vg:obj-exn 'vg:obj-extents 'xpr)))) -(define-inline (vg:obj-proc vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 11)(raise (vg:obj-exn 'vg:obj-proc 'xpr)))) - -(define-inline (vg:obj-type-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 1 val)(raise (vg:obj-exn 'type)))) -(define-inline (vg:obj-pts-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 2 val)(raise (vg:obj-exn 'pts)))) -(define-inline (vg:obj-fill-color-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 3 val)(raise (vg:obj-exn 'fill-color)))) -(define-inline (vg:obj-text-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 4 val)(raise (vg:obj-exn 'text)))) -(define-inline (vg:obj-line-color-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 5 val)(raise (vg:obj-exn 'line-color)))) -(define-inline (vg:obj-call-back-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 6 val)(raise (vg:obj-exn 'call-back)))) -(define-inline (vg:obj-angle-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 7 val)(raise (vg:obj-exn 'angle)))) -(define-inline (vg:obj-font-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 8 val)(raise (vg:obj-exn 'font)))) -(define-inline (vg:obj-attrib-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 9 val)(raise (vg:obj-exn 'attrib)))) -(define-inline (vg:obj-extents-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 10 val)(raise (vg:obj-exn 'extents)))) -(define-inline (vg:obj-proc-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 11 val)(raise (vg:obj-exn 'proc)))) -;; Generated using make-vector-record -safe vg inst libname compname theta xoff yoff scalex scaley mirrx mirry call-back cache - -(use simple-exceptions) -(define vg:inst-exn (make-exception "wrong record type, expected vg:inst." 'assert)) -(define (pmake-vg:inst . params)(let ((v (if (null? params)(make-vector 12)(apply vector 'vg:inst params)))) v)) -(define (make-vg:inst #!key - (libname #f) - (compname #f) - (theta #f) - (xoff #f) - (yoff #f) - (scalex #f) - (scaley #f) - (mirrx #f) - (mirry #f) - (call-back #f) - (cache #f) - ) - (vector 'vg:inst libname compname theta xoff yoff scalex scaley mirrx mirry call-back cache)) - -(define-inline (vg:inst-libname vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 1)(raise (vg:inst-exn 'vg:inst-libname 'xpr)))) -(define-inline (vg:inst-compname vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 2)(raise (vg:inst-exn 'vg:inst-compname 'xpr)))) -(define-inline (vg:inst-theta vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 3)(raise (vg:inst-exn 'vg:inst-theta 'xpr)))) -(define-inline (vg:inst-xoff vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 4)(raise (vg:inst-exn 'vg:inst-xoff 'xpr)))) -(define-inline (vg:inst-yoff vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 5)(raise (vg:inst-exn 'vg:inst-yoff 'xpr)))) -(define-inline (vg:inst-scalex vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 6)(raise (vg:inst-exn 'vg:inst-scalex 'xpr)))) -(define-inline (vg:inst-scaley vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 7)(raise (vg:inst-exn 'vg:inst-scaley 'xpr)))) -(define-inline (vg:inst-mirrx vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 8)(raise (vg:inst-exn 'vg:inst-mirrx 'xpr)))) -(define-inline (vg:inst-mirry vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 9)(raise (vg:inst-exn 'vg:inst-mirry 'xpr)))) -(define-inline (vg:inst-call-back vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 10)(raise (vg:inst-exn 'vg:inst-call-back 'xpr)))) -(define-inline (vg:inst-cache vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 11)(raise (vg:inst-exn 'vg:inst-cache 'xpr)))) - -(define-inline (vg:inst-libname-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 1 val)(raise (vg:inst-exn 'libname)))) -(define-inline (vg:inst-compname-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 2 val)(raise (vg:inst-exn 'compname)))) -(define-inline (vg:inst-theta-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 3 val)(raise (vg:inst-exn 'theta)))) -(define-inline (vg:inst-xoff-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 4 val)(raise (vg:inst-exn 'xoff)))) -(define-inline (vg:inst-yoff-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 5 val)(raise (vg:inst-exn 'yoff)))) -(define-inline (vg:inst-scalex-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 6 val)(raise (vg:inst-exn 'scalex)))) -(define-inline (vg:inst-scaley-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 7 val)(raise (vg:inst-exn 'scaley)))) -(define-inline (vg:inst-mirrx-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 8 val)(raise (vg:inst-exn 'mirrx)))) -(define-inline (vg:inst-mirry-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 9 val)(raise (vg:inst-exn 'mirry)))) -(define-inline (vg:inst-call-back-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 10 val)(raise (vg:inst-exn 'call-back)))) -(define-inline (vg:inst-cache-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 11 val)(raise (vg:inst-exn 'cache)))) -;; Generated using make-vector-record -safe vg drawing libs insts scalex scaley xoff yoff cnv cache - -(use simple-exceptions) -(define vg:drawing-exn (make-exception "wrong record type, expected vg:drawing." 'assert)) -(define (pmake-vg:drawing . params)(let ((v (if (null? params)(make-vector 9)(apply vector 'vg:drawing params)))) v)) -(define (make-vg:drawing #!key - (libs #f) - (insts #f) - (scalex #f) - (scaley #f) - (xoff #f) - (yoff #f) - (cnv #f) - (cache #f) - ) - (vector 'vg:drawing libs insts scalex scaley xoff yoff cnv cache)) - -(define-inline (vg:drawing-libs vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 1)(raise (vg:drawing-exn 'vg:drawing-libs 'xpr)))) -(define-inline (vg:drawing-insts vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 2)(raise (vg:drawing-exn 'vg:drawing-insts 'xpr)))) -(define-inline (vg:drawing-scalex vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 3)(raise (vg:drawing-exn 'vg:drawing-scalex 'xpr)))) -(define-inline (vg:drawing-scaley vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 4)(raise (vg:drawing-exn 'vg:drawing-scaley 'xpr)))) -(define-inline (vg:drawing-xoff vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 5)(raise (vg:drawing-exn 'vg:drawing-xoff 'xpr)))) -(define-inline (vg:drawing-yoff vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 6)(raise (vg:drawing-exn 'vg:drawing-yoff 'xpr)))) -(define-inline (vg:drawing-cnv vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 7)(raise (vg:drawing-exn 'vg:drawing-cnv 'xpr)))) -(define-inline (vg:drawing-cache vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 8)(raise (vg:drawing-exn 'vg:drawing-cache 'xpr)))) - -(define-inline (vg:drawing-libs-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 1 val)(raise (vg:drawing-exn 'libs)))) -(define-inline (vg:drawing-insts-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 2 val)(raise (vg:drawing-exn 'insts)))) -(define-inline (vg:drawing-scalex-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 3 val)(raise (vg:drawing-exn 'scalex)))) -(define-inline (vg:drawing-scaley-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 4 val)(raise (vg:drawing-exn 'scaley)))) -(define-inline (vg:drawing-xoff-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 5 val)(raise (vg:drawing-exn 'xoff)))) -(define-inline (vg:drawing-yoff-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 6 val)(raise (vg:drawing-exn 'yoff)))) -(define-inline (vg:drawing-cnv-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 7 val)(raise (vg:drawing-exn 'cnv)))) -(define-inline (vg:drawing-cache-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 8 val)(raise (vg:drawing-exn 'cache)))) ADDED vgmod.scm Index: vgmod.scm ================================================================== --- /dev/null +++ vgmod.scm @@ -0,0 +1,885 @@ +;; +;; Copyright 2016 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 . + +;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') + +(declare (unit vgmod)) + +(module vgmod + ( + vg:drawing-new + vg:drawing-cnv-set! +vg:drawing-scalex +vg:drawing-scalex-set! +vg:drawing-libs-set! +vg:drawing-insts-set! +vg:drawing-cache-set! +vg:drawing-xoff-set! +vg:drawing-yoff-set! +vg:draw +vg:get/create-lib +vg:get-component +vg:rgb->number +vg:add-obj-to-comp +vg:make-rect-obj +vg:make-text-obj +vg:generate-color-rgb +vg:iup-color->number +vg:make-line-obj +vg:lib-get-component +vg:comp-new +vg:add-comp-to-lib +vg:instantiate +vg:get-extents-for-objs +vg:components-get-extents +vg:grow-rect + + ) + +(import scheme + chicken + + data-structures + extras + typed-records + srfi-1 + srfi-69 + canvas-draw iup + ) + + +;;====================================================================== +;; vg_records.scm +;;====================================================================== +;; Created by records.sh. DO NOT EDIT THIS FILE. Edit records.sh instead +;; Generated using make-vector-record -safe vg lib comps + +;; Copyright 2006-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 . +;; + +(use simple-exceptions) + +(define vg:lib-exn (make-exception "wrong record type, expected vg:lib." 'assert)) +(define (pmake-vg:lib . params)(let ((v (if (null? params)(make-vector 2)(apply vector 'vg:lib params)))) v)) +(define (make-vg:lib #!key + (comps #f) + ) + (vector 'vg:lib comps)) + +(define (vg:lib-comps vec)(if (eq? (vector-ref vec 0) 'vg:lib)(vector-ref vec 1)(raise (vg:lib-exn 'vg:lib-comps 'xpr)))) + +(define (vg:lib-comps-set! vec val)(if (eq? (vector-ref vec 0) 'vg:lib)(vector-set! vec 1 val)(raise (vg:lib-exn 'comps)))) +;; Generated using make-vector-record -safe vg comp objs name file + +(use simple-exceptions) +(define vg:comp-exn (make-exception "wrong record type, expected vg:comp." 'assert)) +(define (pmake-vg:comp . params)(let ((v (if (null? params)(make-vector 4)(apply vector 'vg:comp params)))) v)) +(define (make-vg:comp #!key + (objs #f) + (name #f) + (file #f) + ) + (vector 'vg:comp objs name file)) + +(define (vg:comp-objs vec)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-ref vec 1)(raise (vg:comp-exn 'vg:comp-objs 'xpr)))) +(define (vg:comp-name vec)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-ref vec 2)(raise (vg:comp-exn 'vg:comp-name 'xpr)))) +(define (vg:comp-file vec)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-ref vec 3)(raise (vg:comp-exn 'vg:comp-file 'xpr)))) + +(define (vg:comp-objs-set! vec val)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-set! vec 1 val)(raise (vg:comp-exn 'objs)))) +(define (vg:comp-name-set! vec val)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-set! vec 2 val)(raise (vg:comp-exn 'name)))) +(define (vg:comp-file-set! vec val)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-set! vec 3 val)(raise (vg:comp-exn 'file)))) +;; Generated using make-vector-record -safe vg obj type pts fill-color text line-color call-back angle font attrib extents proc + +(use simple-exceptions) +(define vg:obj-exn (make-exception "wrong record type, expected vg:obj." 'assert)) +(define (pmake-vg:obj . params)(let ((v (if (null? params)(make-vector 12)(apply vector 'vg:obj params)))) v)) +(define (make-vg:obj #!key + (type #f) + (pts #f) + (fill-color #f) + (text #f) + (line-color #f) + (call-back #f) + (angle #f) + (font #f) + (attrib #f) + (extents #f) + (proc #f) + ) + (vector 'vg:obj type pts fill-color text line-color call-back angle font attrib extents proc)) + +(define (vg:obj-type vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 1)(raise (vg:obj-exn 'vg:obj-type 'xpr)))) +(define (vg:obj-pts vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 2)(raise (vg:obj-exn 'vg:obj-pts 'xpr)))) +(define (vg:obj-fill-color vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 3)(raise (vg:obj-exn 'vg:obj-fill-color 'xpr)))) +(define (vg:obj-text vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 4)(raise (vg:obj-exn 'vg:obj-text 'xpr)))) +(define (vg:obj-line-color vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 5)(raise (vg:obj-exn 'vg:obj-line-color 'xpr)))) +(define (vg:obj-call-back vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 6)(raise (vg:obj-exn 'vg:obj-call-back 'xpr)))) +(define (vg:obj-angle vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 7)(raise (vg:obj-exn 'vg:obj-angle 'xpr)))) +(define (vg:obj-font vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 8)(raise (vg:obj-exn 'vg:obj-font 'xpr)))) +(define (vg:obj-attrib vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 9)(raise (vg:obj-exn 'vg:obj-attrib 'xpr)))) +(define (vg:obj-extents vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 10)(raise (vg:obj-exn 'vg:obj-extents 'xpr)))) +(define (vg:obj-proc vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 11)(raise (vg:obj-exn 'vg:obj-proc 'xpr)))) + +(define (vg:obj-type-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 1 val)(raise (vg:obj-exn 'type)))) +(define (vg:obj-pts-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 2 val)(raise (vg:obj-exn 'pts)))) +(define (vg:obj-fill-color-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 3 val)(raise (vg:obj-exn 'fill-color)))) +(define (vg:obj-text-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 4 val)(raise (vg:obj-exn 'text)))) +(define (vg:obj-line-color-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 5 val)(raise (vg:obj-exn 'line-color)))) +(define (vg:obj-call-back-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 6 val)(raise (vg:obj-exn 'call-back)))) +(define (vg:obj-angle-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 7 val)(raise (vg:obj-exn 'angle)))) +(define (vg:obj-font-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 8 val)(raise (vg:obj-exn 'font)))) +(define (vg:obj-attrib-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 9 val)(raise (vg:obj-exn 'attrib)))) +(define (vg:obj-extents-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 10 val)(raise (vg:obj-exn 'extents)))) +(define (vg:obj-proc-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 11 val)(raise (vg:obj-exn 'proc)))) +;; Generated using make-vector-record -safe vg inst libname compname theta xoff yoff scalex scaley mirrx mirry call-back cache + +(use simple-exceptions) +(define vg:inst-exn (make-exception "wrong record type, expected vg:inst." 'assert)) +(define (pmake-vg:inst . params)(let ((v (if (null? params)(make-vector 12)(apply vector 'vg:inst params)))) v)) +(define (make-vg:inst #!key + (libname #f) + (compname #f) + (theta #f) + (xoff #f) + (yoff #f) + (scalex #f) + (scaley #f) + (mirrx #f) + (mirry #f) + (call-back #f) + (cache #f) + ) + (vector 'vg:inst libname compname theta xoff yoff scalex scaley mirrx mirry call-back cache)) + +(define (vg:inst-libname vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 1)(raise (vg:inst-exn 'vg:inst-libname 'xpr)))) +(define (vg:inst-compname vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 2)(raise (vg:inst-exn 'vg:inst-compname 'xpr)))) +(define (vg:inst-theta vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 3)(raise (vg:inst-exn 'vg:inst-theta 'xpr)))) +(define (vg:inst-xoff vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 4)(raise (vg:inst-exn 'vg:inst-xoff 'xpr)))) +(define (vg:inst-yoff vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 5)(raise (vg:inst-exn 'vg:inst-yoff 'xpr)))) +(define (vg:inst-scalex vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 6)(raise (vg:inst-exn 'vg:inst-scalex 'xpr)))) +(define (vg:inst-scaley vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 7)(raise (vg:inst-exn 'vg:inst-scaley 'xpr)))) +(define (vg:inst-mirrx vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 8)(raise (vg:inst-exn 'vg:inst-mirrx 'xpr)))) +(define (vg:inst-mirry vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 9)(raise (vg:inst-exn 'vg:inst-mirry 'xpr)))) +(define (vg:inst-call-back vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 10)(raise (vg:inst-exn 'vg:inst-call-back 'xpr)))) +(define (vg:inst-cache vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 11)(raise (vg:inst-exn 'vg:inst-cache 'xpr)))) + +(define (vg:inst-libname-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 1 val)(raise (vg:inst-exn 'libname)))) +(define (vg:inst-compname-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 2 val)(raise (vg:inst-exn 'compname)))) +(define (vg:inst-theta-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 3 val)(raise (vg:inst-exn 'theta)))) +(define (vg:inst-xoff-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 4 val)(raise (vg:inst-exn 'xoff)))) +(define (vg:inst-yoff-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 5 val)(raise (vg:inst-exn 'yoff)))) +(define (vg:inst-scalex-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 6 val)(raise (vg:inst-exn 'scalex)))) +(define (vg:inst-scaley-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 7 val)(raise (vg:inst-exn 'scaley)))) +(define (vg:inst-mirrx-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 8 val)(raise (vg:inst-exn 'mirrx)))) +(define (vg:inst-mirry-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 9 val)(raise (vg:inst-exn 'mirry)))) +(define (vg:inst-call-back-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 10 val)(raise (vg:inst-exn 'call-back)))) +(define (vg:inst-cache-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 11 val)(raise (vg:inst-exn 'cache)))) +;; Generated using make-vector-record -safe vg drawing libs insts scalex scaley xoff yoff cnv cache + +(use simple-exceptions) +(define vg:drawing-exn (make-exception "wrong record type, expected vg:drawing." 'assert)) +(define (pmake-vg:drawing . params)(let ((v (if (null? params)(make-vector 9)(apply vector 'vg:drawing params)))) v)) +(define (make-vg:drawing #!key + (libs #f) + (insts #f) + (scalex #f) + (scaley #f) + (xoff #f) + (yoff #f) + (cnv #f) + (cache #f) + ) + (vector 'vg:drawing libs insts scalex scaley xoff yoff cnv cache)) + +(define (vg:drawing-libs vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 1)(raise (vg:drawing-exn 'vg:drawing-libs 'xpr)))) +(define (vg:drawing-insts vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 2)(raise (vg:drawing-exn 'vg:drawing-insts 'xpr)))) +(define (vg:drawing-scalex vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 3)(raise (vg:drawing-exn 'vg:drawing-scalex 'xpr)))) +(define (vg:drawing-scaley vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 4)(raise (vg:drawing-exn 'vg:drawing-scaley 'xpr)))) +(define (vg:drawing-xoff vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 5)(raise (vg:drawing-exn 'vg:drawing-xoff 'xpr)))) +(define (vg:drawing-yoff vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 6)(raise (vg:drawing-exn 'vg:drawing-yoff 'xpr)))) +(define (vg:drawing-cnv vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 7)(raise (vg:drawing-exn 'vg:drawing-cnv 'xpr)))) +(define (vg:drawing-cache vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 8)(raise (vg:drawing-exn 'vg:drawing-cache 'xpr)))) + +(define (vg:drawing-libs-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 1 val)(raise (vg:drawing-exn 'libs)))) +(define (vg:drawing-insts-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 2 val)(raise (vg:drawing-exn 'insts)))) +(define (vg:drawing-scalex-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 3 val)(raise (vg:drawing-exn 'scalex)))) +(define (vg:drawing-scaley-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 4 val)(raise (vg:drawing-exn 'scaley)))) +(define (vg:drawing-xoff-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 5 val)(raise (vg:drawing-exn 'xoff)))) +(define (vg:drawing-yoff-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 6 val)(raise (vg:drawing-exn 'yoff)))) +(define (vg:drawing-cnv-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 7 val)(raise (vg:drawing-exn 'cnv)))) +(define (vg:drawing-cache-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 8 val)(raise (vg:drawing-exn 'cache)))) + +;;====================================================================== +;; end vg_records +;;====================================================================== + + +;; ;; structs +;; ;; +;; (defstruct vg:lib comps) +;; (defstruct vg:comp objs name file) +;; ;; extents caches extents calculated on draw +;; ;; proc is called on draw and takes the obj itself as a parameter +;; ;; attrib is an alist of parameters +;; (defstruct vg:obj type pts fill-color text line-color call-back angle font attrib extents proc) +;; (defstruct vg:inst libname compname theta xoff yoff scalex scaley mirrx mirry call-back cache) +;; (defstruct vg:drawing libs insts scalex scaley xoff yoff cnv cache) ;; libs: hash of name->lib, insts: hash of instname->inst + +;; inits +;; +(define (vg:comp-new) + (make-vg:comp objs: '() name: #f file: #f)) + +(define (vg:lib-new) + (make-vg:lib comps: (make-hash-table))) + +(define (vg:drawing-new) + (make-vg:drawing scalex: 1 + scaley: 1 + xoff: 0 + yoff: 0 + libs: (make-hash-table) + insts: (make-hash-table) + cache: '())) + +;;====================================================================== +;; scaling and offsets +;;====================================================================== + +(define (vg:scale-offset val s o) + (+ o (* val s))) + ;; (* (+ o val) s)) + +;; apply scale and offset to a list of x y values +;; +(define (vg:scale-offset-xy lstxy sx sy ox oy) + (if (> (length lstxy) 1) ;; have at least one xy pair + (let loop ((x (car lstxy)) + (y (cadr lstxy)) + (tal (cddr lstxy)) + (res '())) + (let ((newres (cons (vg:scale-offset y sy oy) + (cons (vg:scale-offset x sx ox) + res)))) + (if (> (length tal) 1) + (loop (car tal)(cadr tal)(cddr tal) newres) + (reverse newres)))) + '())) + +;; apply drawing offset and scaling to the points in lstxy +;; +(define (vg:drawing-apply-scale drawing lstxy) + (vg:scale-offset-xy + lstxy + (vg:drawing-scalex drawing) + (vg:drawing-scaley drawing) + (vg:drawing-xoff drawing) + (vg:drawing-yoff drawing))) + +;; apply instance offset and scaling to the points in lstxy +;; +(define (vg:inst-apply-scale inst lstxy) + (vg:scale-offset-xy + lstxy + (vg:inst-scalex inst) + (vg:inst-scaley inst) + (vg:inst-xoff inst) + (vg:inst-yoff inst))) + +;; apply both drawing and instance scaling to a list of xy points +;; +(define (vg:drawing-inst-apply-scale-offset drawing inst lstxy) + (vg:drawing-apply-scale + drawing + (vg:inst-apply-scale inst lstxy))) + +;;====================================================================== +;; objects +;;====================================================================== + +;; (vg:inst-apply-scale +;; inst +;; (vg:drawing-apply-scale drawing lstxy))) + +;; make a rectangle obj +;; +(define (vg:make-rect-obj x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)(text #f)(font #f)(extents #f)) + (make-vg:obj type: 'r pts: (list x1 y1 x2 y2) text: text font: font line-color: line-color fill-color: fill-color extents: extents)) + +;; make a rectangle obj +;; +(define (vg:make-line-obj x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)(text #f)(font #f)(extents #f)) + (make-vg:obj type: 'l pts: (list x1 y1 x2 y2) text: text font: font line-color: line-color extents: extents)) + +;; make a text obj +;; +(define (vg:make-text-obj x1 y1 text #!key (line-color #f)(fill-color #f) + (angle #f)(scale-with-zoom #f)(font #f) + (font-size #f)) + (make-vg:obj type: 't pts: (list x1 y1) text: text + line-color: line-color fill-color: fill-color + angle: angle font: font extents: #f + attributes: (vg:make-attrib 'font-size font-size))) + +;; proc takes startnum and endnum and yields scalef, per-grad and unitname +;; +(define (vg:make-xaxis-obj x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)(text #f)(font #f)(proc #f)) + (make-vg:obj type: 'x pts: (list x1 y1 x2 y2) text: text font: font line-color: line-color fill-color: fill-color extents: #f proc: proc)) + +;;====================================================================== +;; obj modifiers and queries +;;====================================================================== + +;; get extents, use knowledge of type ... +;; +(define (vg:obj-get-extents drawing obj) + (let ((type (vg:obj-type obj))) + (case type + ((l)(vg:rect-get-extents obj)) + ((r)(vg:rect-get-extents obj)) + ((t)(vg:draw-text drawing obj draw: #f)) + (else #f)))) + +(define (vg:rect-get-extents obj) + (vg:obj-pts obj)) ;; extents are just the points for a rectangle + +(define (vg:grow-rect borderx bordery x1 y1 x2 y2) + (list + (- x1 borderx) + (- y1 bordery) + (+ x2 borderx) + (+ y2 bordery))) + +(define (vg:make-attrib . attrib-list) + #f) + +;;====================================================================== +;; components +;;====================================================================== + +;; add obj to comp +;; +(define (vg:add-objs-to-comp comp . objs) + (vg:comp-objs-set! comp (append (vg:comp-objs comp) objs))) + +(define (vg:add-obj-to-comp comp obj) + (vg:comp-objs-set! comp (cons obj (vg:comp-objs comp)))) + +;; use the struct. leave this here to remind of this! +;; +;; (define (vg:comp-get-objs comp) +;; (vg:comp-objs comp)) + +;; add comp to lib +;; +(define (vg:add-comp-to-lib lib compname comp) + (hash-table-set! (vg:lib-comps lib) compname comp)) + +;; instanciate component in drawing +;; +(define (vg:instantiate drawing libname compname instname xoff yoff #!key (theta 0)(scalex 1)(scaley 1)(mirrx #f)(mirry #f)) + (let ((inst (make-vg:inst libname: libname compname: compname xoff: xoff yoff: yoff theta: theta scalex: scalex scaley: scaley mirrx: mirrx mirry: mirry)) ) + (hash-table-set! (vg:drawing-insts drawing) instname inst))) + +(define (vg:instance-move drawing instname newx newy) + (let ((inst (hash-table-ref (vg:drawing-insts drawing) instname))) + (vg:inst-xoff-set! inst newx) + (vg:inst-yoff-set! inst newy))) + +;; get component from drawing (look in apropriate lib) given libname and compname +(define (vg:get-component drawing libname compname) + (let* ((lib (hash-table-ref (vg:drawing-libs drawing) libname)) + (inst (hash-table-ref (vg:lib-comps lib) compname))) + inst)) + +(define (vg:get-extents-for-objs drawing objs) + (if (or (not objs) + (null? objs)) + #f + (let loop ((hed (car objs)) + (tal (cdr objs)) + (extents (vg:obj-get-extents drawing (car objs)))) + (let ((newextents + (vg:get-extents-for-two-rects + extents + (vg:obj-get-extents drawing hed)))) + (if (null? tal) + extents + (loop (car tal)(cdr tal) newextents)))))) + +;; (let ((extents #f)) +;; (for-each +;; (lambda (obj) +;; (set! extents +;; (vg:get-extents-for-two-rects +;; extents +;; (vg:obj-get-extents drawing obj)))) +;; objs) +;; extents)) + +;; given rectangles r1 and r2, return the box that bounds both +;; +(define (vg:get-extents-for-two-rects r1 r2) + (if (not r1) + r2 + (if (not r2) + r1 ;; #f ;; no extents from #f #f + (list (min (car r1)(car r2)) ;; llx + (min (cadr r1)(cadr r2)) ;; lly + (max (caddr r1)(caddr r2)) ;; ulx + (max (cadddr r1)(cadddr r2)))))) ;; uly + +(define (vg:components-get-extents drawing . comps) + (if (null? comps) + #f + (let loop ((hed (car comps)) + (tal (cdr comps)) + (extents #f)) + (let* ((objs (vg:comp-objs hed)) + (newextents (if extents + (vg:get-extents-for-two-rects + extents + (vg:get-extents-for-objs drawing objs)) + (vg:get-extents-for-objs drawing objs)))) + (if (null? tal) + newextents + (loop (car tal)(cdr tal) newextents)))))) + +;;====================================================================== +;; libraries +;;====================================================================== + +;; register lib with drawing + +;; +(define (vg:add-lib drawing libname lib) + (hash-table-set! (vg:drawing-libs drawing) libname lib)) + +(define (vg:get-lib drawing libname) + (hash-table-ref/default (vg:drawing-libs drawing) libname #f)) + +(define (vg:get/create-lib drawing libname) + (let ((lib (vg:get-lib drawing libname))) + (if lib + lib + (let ((newlib (vg:lib-new))) + (vg:add-lib drawing libname newlib) + newlib)))) + +;;====================================================================== +;; map objects given offset, scale and mirror, resulting obj is displayed +;;====================================================================== + +;; dispatch the drawing of obj off to the correct drawing routine +;; +(define (vg:map-obj drawing inst obj) + (case (vg:obj-type obj) + ((l)(vg:map-line drawing inst obj)) + ((r)(vg:map-rect drawing inst obj)) + ((t)(vg:map-text drawing inst obj)) + ((x)(vg:map-xaxis drawing inst obj)) + (else #f))) + +;; given a drawing and a inst map a rectangle to it screen coordinates +;; +(define (vg:map-rect drawing inst obj) + (let ((res (make-vg:obj type: 'r ;; is there a defstruct copy? + fill-color: (vg:obj-fill-color obj) + text: (vg:obj-text obj) + line-color: (vg:obj-line-color obj) + font: (vg:obj-font obj))) + (pts (vg:obj-pts obj))) + (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts)) + (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing) )) + res)) + +;; given a drawing and a inst map a line to it screen coordinates +;; +(define (vg:map-line drawing inst obj) + (let ((res (make-vg:obj type: 'l ;; is there a defstruct copy? + line-color: (vg:obj-line-color obj) + font: (vg:obj-font obj))) + (pts (vg:obj-pts obj))) + (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts)) + (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing) )) + res)) + +;; given a drawing and a inst map a text to it screen coordinates +;; +(define (vg:map-text drawing inst obj) + (let ((res (make-vg:obj type: 't + fill-color: (vg:obj-fill-color obj) + text: (vg:obj-text obj) + line-color: (vg:obj-line-color obj) + font: (vg:obj-font obj) + angle: (vg:obj-angle obj) + attrib: (vg:obj-attrib obj))) + (pts (vg:obj-pts obj))) + (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts)) + (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing))) + res)) + +;; given a drawing and a inst map a line to it screen coordinates +;; +(define (vg:map-xaxis drawing inst obj) + (let ((res (make-vg:obj type: 'x ;; is there a defstruct copy? + line-color: (vg:obj-line-color obj) + font: (vg:obj-font obj))) + (pts (vg:obj-pts obj))) + (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts)) + (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing) )) + res)) + +;;====================================================================== +;; instances +;;====================================================================== + +(define (vg:instances-get-extents drawing . instance-names) + (let ((xtnt-lst (vg:draw drawing #f))) + (if (null? xtnt-lst) + #f + (let loop ((extents (car xtnt-lst)) + (tal (cdr xtnt-lst)) + (llx #f) + (lly #f) + (ulx #f) + (uly #f)) + (let ((nllx (if llx (min llx (list-ref extents 0))(list-ref extents 0))) + (nlly (if lly (min lly (list-ref extents 1))(list-ref extents 1))) + (nulx (if ulx (max ulx (list-ref extents 2))(list-ref extents 2))) + (nuly (if uly (max uly (list-ref extents 3))(list-ref extents 3)))) + (if (null? tal) + (list llx lly ulx uly) + (loop (car tal)(cdr tal) nllx nlly nulx nuly))))))) + +(define (vg:lib-get-component lib instname) + (hash-table-ref/default (vg:lib-comps lib) instname #f)) + +;;====================================================================== +;; color +;;====================================================================== + +(define (vg:rgb->number r g b #!key (a 0)) + (bitwise-ior + (arithmetic-shift a 24) + (arithmetic-shift r 16) + (arithmetic-shift g 8) + b)) + +;; Obsolete function +;; +(define (vg:generate-color) + (vg:rgb->number (random 255) + (random 255) + (random 255))) + +;; Need to return a string of random iup-color for graph +;; +(define (vg:generate-color-rgb) + (conc (number->string (random 255)) " " + (number->string (random 255)) " " + (number->string (random 255)))) + +(define (vg:iup-color->number iup-color) + (apply vg:rgb->number (map string->number (string-split iup-color)))) + +;;====================================================================== +;; graphing +;;====================================================================== + +(define (vg:make-xaxis drawing component x1 y1 x2 y2 startnum endnum scaleproc) + (let ((obj (vg:make-xaxis-obj x1 y1 x2 y2))) + #f)) + +;;====================================================================== +;; Unravel and draw the objects +;;====================================================================== + +;; with get-extents = #t return the extents +;; with draw = #f don't actually draw the object +;; +(define (vg:draw-obj drawing obj #!key (draw #t)) + ;; (print "obj type: " (vg:obj-type obj)) + (case (vg:obj-type obj) + ((l)(vg:draw-line drawing obj draw: draw)) + ((r)(vg:draw-rect drawing obj draw: draw)) + ((t)(vg:draw-text drawing obj draw: draw)))) + +;; given a rect obj draw it on the canvas applying first the drawing +;; scale and offset +;; +(define (vg:draw-rect drawing obj #!key (draw #t)) + (let* ((cnv (vg:drawing-cnv drawing)) + (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj))) + (fill-color (vg:obj-fill-color obj)) + (line-color (vg:obj-line-color obj)) + (text (vg:obj-text obj)) + (font (vg:obj-font obj)) + (llx (car pts)) + (lly (cadr pts)) + (ulx (caddr pts)) + (uly (cadddr pts)) + (w (- ulx llx)) + (h (- uly lly)) + (text-xmax #f) + (text-ymax #f)) + (if draw + (let ((prev-background-color (canvas-background cnv)) + (prev-foreground-color (canvas-foreground cnv))) + (if fill-color + (begin + (canvas-foreground-set! cnv fill-color) + (canvas-box! cnv llx ulx lly uly))) ;; docs are all over the place on this one.;; w h) + (if line-color + (canvas-foreground-set! cnv line-color) + (if fill-color + (canvas-foreground-set! cnv prev-foreground-color))) + (canvas-rectangle! cnv llx ulx lly uly) + (canvas-foreground-set! cnv prev-foreground-color) + (if text + (let* ((prev-font (canvas-font cnv)) + (font-changed (and font (not (equal? font prev-font))))) + (if font-changed (canvas-font-set! cnv font)) + (canvas-text! cnv (+ 2 llx)(+ 2 lly) text) + (if (eq? draw 'get-extents) + (let-values (((xmax ymax)(canvas-text-size cnv text))) + (set! text-xmax xmax)(set! text-ymax ymax))) + (if font-changed (canvas-font-set! cnv prev-font)))))) + ;; (print "text-xmax: " text-xmax " text-ymax: " text-ymax) + (if (vg:obj-extents obj) + (vg:obj-extents obj) + (if (not text) + pts ;; no text + (if (and text-xmax text-ymax) ;; have text + (let ((xt (list llx lly + (max ulx (+ llx text-xmax)) + (max uly (+ lly text-ymax))))) + (vg:obj-extents-set! obj xt) + xt) + (if cnv + (if (eq? draw 'get-extents) + (let-values (((xmax ymax)(canvas-text-size cnv text))) + (let ((xt (list llx lly + (max ulx (+ llx xmax)) + (max uly (+ lly ymax))))) + (vg:obj-extents-set! obj xt) + xt)) + pts) + pts)))))) ;; return extents + +;; given a rect obj draw it on the canvas applying first the drawing +;; scale and offset +;; +(define (vg:draw-line drawing obj #!key (draw #t)) + (let* ((cnv (vg:drawing-cnv drawing)) + (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj))) + ;; (fill-color (vg:obj-fill-color obj)) + (line-color (vg:obj-line-color obj)) + (text (vg:obj-text obj)) + (font (vg:obj-font obj)) + (llx (car pts)) + (lly (cadr pts)) + (ulx (caddr pts)) + (uly (cadddr pts)) + (w (- ulx llx)) + (h (- uly lly)) + (text-xmax #f) + (text-ymax #f)) + (if draw + (let ((prev-background-color (canvas-background cnv)) + (prev-foreground-color (canvas-foreground cnv))) + ;; (if fill-color + ;; (begin + ;; (canvas-foreground-set! cnv fill-color) + ;; (canvas-box! cnv llx ulx lly uly))) ;; docs are all over the place on this one.;; w h) + (if line-color + (canvas-foreground-set! cnv line-color)) + ;; (if fill-color + ;; (canvas-foreground-set! cnv prev-foreground-color))) + (canvas-line! cnv llx lly ulx uly) + (canvas-foreground-set! cnv prev-foreground-color) + (if text + (let* ((prev-font (canvas-font cnv)) + (font-changed (and font (not (equal? font prev-font))))) + (if font-changed (canvas-font-set! cnv font)) + (canvas-text! cnv (+ 2 llx)(+ 2 lly) text) + (let-values (((xmax ymax)(canvas-text-size cnv text))) + (set! text-xmax xmax)(set! text-ymax ymax)) + (if font-changed (canvas-font-set! cnv prev-font)))))) + ;; (print "text-xmax: " text-xmax " text-ymax: " text-ymax) + (if (vg:obj-extents obj) + (vg:obj-extents obj) + (if (not text) + pts + (if (and text-xmax text-ymax) + (let ((xt (list llx lly + (max ulx (+ llx text-xmax)) + (max uly (+ lly text-ymax))))) + (vg:obj-extents-set! obj xt) + xt) + (if cnv + (let-values (((xmax ymax)(canvas-text-size cnv text))) + (let ((xt (list llx lly + (max ulx (+ llx xmax)) + (max uly (+ lly ymax))))) + (vg:obj-extents-set! obj xt) + xt)) + pts)))))) ;; return extents + +;; given a rect obj draw it on the canvas applying first the drawing +;; scale and offset +;; +(define (vg:draw-xaxis drawing obj #!key (draw #t)) + (let* ((cnv (vg:drawing-cnv drawing)) + (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj))) + ;; (fill-color (vg:obj-fill-color obj)) + (line-color (vg:obj-line-color obj)) + (text (vg:obj-text obj)) + (font (vg:obj-font obj)) + (llx (car pts)) + (lly (cadr pts)) + (ulx (caddr pts)) + (uly (cadddr pts)) + (w (- ulx llx)) + (h (- uly lly)) + (text-xmax #f) + (text-ymax #f)) + (if draw + (let ((prev-background-color (canvas-background cnv)) + (prev-foreground-color (canvas-foreground cnv))) + ;; (if fill-color + ;; (begin + ;; (canvas-foreground-set! cnv fill-color) + ;; (canvas-box! cnv llx ulx lly uly))) ;; docs are all over the place on this one.;; w h) + (if line-color + (canvas-foreground-set! cnv line-color) + #;(if fill-color + (canvas-foreground-set! cnv prev-foreground-color))) + (canvas-line! cnv llx ulx lly uly) + (canvas-foreground-set! cnv prev-foreground-color) + (if text + (let* ((prev-font (canvas-font cnv)) + (font-changed (and font (not (equal? font prev-font))))) + (if font-changed (canvas-font-set! cnv font)) + (canvas-text! cnv (+ 2 llx)(+ 2 lly) text) + (let-values (((xmax ymax)(canvas-text-size cnv text))) + (set! text-xmax xmax)(set! text-ymax ymax)) + (if font-changed (canvas-font-set! cnv prev-font)))))) + ;; (print "text-xmax: " text-xmax " text-ymax: " text-ymax) + (if (vg:obj-extents obj) + (vg:obj-extents obj) + (if (not text) + pts + (if (and text-xmax text-ymax) + (let ((xt (list llx lly + (max ulx (+ llx text-xmax)) + (max uly (+ lly text-ymax))))) + (vg:obj-extents-set! obj xt) + xt) + (if cnv + (let-values (((xmax ymax)(canvas-text-size cnv text))) + (let ((xt (list llx lly + (max ulx (+ llx xmax)) + (max uly (+ lly ymax))))) + (vg:obj-extents-set! obj xt) + xt)) + pts)))))) ;; return extents + +;; given a rect obj draw it on the canvas applying first the drawing +;; scale and offset +;; +(define (vg:draw-text drawing obj #!key (draw #t)) + (let* ((cnv (vg:drawing-cnv drawing)) + (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj))) + (text (vg:obj-text obj)) + (font (vg:obj-font obj)) + (fill-color (vg:obj-fill-color obj)) + (line-color (vg:obj-line-color obj)) + (llx (car pts)) + (lly (cadr pts))) + (if draw + (let* ((prev-background-color (canvas-background cnv)) + (prev-foreground-color (canvas-foreground cnv)) + (prev-font (canvas-font cnv)) + (font-changed (and font (not (equal? font prev-font))))) + (if line-color + (canvas-foreground-set! cnv line-color) + (if fill-color + (canvas-foreground-set! cnv prev-foreground-color))) + (if font-changed (canvas-font-set! cnv font)) + (canvas-text! cnv llx lly text) + ;; NOTE: we do not set the font back!! + (canvas-foreground-set! cnv prev-foreground-color))) + (if cnv + (if (eq? draw 'get-extents) + (let-values (((xmax ymax)(canvas-text-size cnv text))) + (append pts (list (+ llx xmax)(+ lly ymax)))) ;; will be wrong if text is rotated? + (append pts pts)) + (append pts pts)))) + +(define (vg:draw-inst drawing inst #!key (draw-mode #t)(prev-extents '())) + (let* ((libname (vg:inst-libname inst)) + (compname (vg:inst-compname inst)) + (comp (vg:get-component drawing libname compname)) + (objs (vg:comp-objs comp))) + ;; (print "comp: " comp) + (if (null? objs) + prev-extents + (let loop ((obj (car objs)) + (tal (cdr objs)) + (res prev-extents)) + (let* ((obj-xfrmd (vg:map-obj drawing inst obj)) + (newres (cons (vg:draw-obj drawing obj-xfrmd draw: draw-mode) res))) + (if (null? tal) + newres + (loop (car tal)(cdr tal) newres))))))) + +(define (vg:draw drawing draw-mode . instnames) + (let* ((insts (vg:drawing-insts drawing)) + (all-inst-names (hash-table-keys insts)) + (master-list (if (null? instnames) + all-inst-names + instnames))) + (if (null? master-list) + '() + (let loop ((instname (car master-list)) + (tal (cdr master-list)) + (res '())) + (let* ((inst (hash-table-ref/default insts instname #f)) + (newres (if inst + (vg:draw-inst drawing inst draw-mode: draw-mode prev-extents: res) + res))) + (if (null? tal) + newres + (loop (car tal)(cdr tal) newres))))))) +)