Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -22,18 +22,18 @@
CSCOPTS=
INSTALL=install
SRCFILES = common.scm items.scm launch.scm ods.scm runconfig.scm \
server.scm configf.scm db.scm keys.scm margs.scm \
process.scm runs.scm tasks.scm tests.scm genexample.scm \
- http-transport.scm filedb.scm tdb.scm client.scm mt.scm \
- ezsteps.scm lock-queue.scm sdb.scm rmt.scm api.scm \
+ http-transport.scm tdb.scm client.scm mt.scm \
+ ezsteps.scm sdb.scm rmt.scm api.scm \
subrun.scm portlogger.scm archive.scm env.scm \
diff-report.scm cgisetup/models/pgdb.scm
# module source files
MSRCFILES =
-# ftail.scm rmtmod.scm commonmod.scm removed
+# 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 \
@@ -108,11 +108,10 @@
env.o \
http-transport.o \
items.o \
keys.o \
launch.o \
- lock-queue.o \
margs.o \
mt.o \
ods.o \
portlogger.o \
process.o \
@@ -156,23 +155,21 @@
# 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 \
-monitor.o dashboard.o archive.o megatest.o : db_records.scm megatest-fossil-hash.scm
+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
-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 runs-for-ref.o runs.o tests.o : key_records.scm
tests.o tasks.o dashboard-tasks.o : task_records.scm
-runs.o : test_records.scm
-
megatest.o : megatest-fossil-hash.scm megatest-version.scm
-rmt.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm megatest-version.scm
+rmt.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm megatest-version.scm
common_records.scm : altdb.scm
# mofiles/stml2.o : mofiles/cookie.o
# configf.o : mofiles/commonmod.o
@@ -215,14 +212,10 @@
chmod a+x $(PREFIX)/bin/megatest
$(PREFIX)/bin/.$(ARCHSTR)/ndboard : ndboard
$(INSTALL) ndboard $(PREFIX)/bin/.$(ARCHSTR)/ndboard
-$(PREFIX)/bin/newdashboard : $(PREFIX)/bin/.$(ARCHSTR)/ndboard utils/mk_wrapper
- utils/mk_wrapper $(PREFIX) ndboard $(PREFIX)/bin/newdashboard
- chmod a+x $(PREFIX)/bin/newdashboard
-
# mtutil
$(PREFIX)/bin/.$(ARCHSTR)/mtut : mtut
$(INSTALL) mtut $(PREFIX)/bin/.$(ARCHSTR)/mtut
@@ -323,13 +316,10 @@
$(PREFIX)/bin/nbfind $(PREFIX)/bin/mtrunner $(PREFIX)/bin/viewscreen $(PREFIX)/bin/mt_xterm \
$(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun \
$(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun $(PREFIX)/bin/mtutil \
$(PREFIX)/bin/tcmt $(PREFIX)/share/db/mt-pg.sql \
$(PREFIX)/share/js/jquery-3.1.0.slim.min.js
-# $(PREFIX)/bin/.$(ARCHSTR)/ndboard
-
-# $(PREFIX)/bin/newdashboard
$(PREFIX)/bin/.$(ARCHSTR) :
mkdir -p $(PREFIX)/bin/.$(ARCHSTR)
mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib
@@ -347,15 +337,15 @@
rm -f $(OFILES) $(GOFILES) $(MOFILES) $(TCMTOBJS) \
$(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil mtut \
tcmt readline-fix.scm serialize-env dboard *.o \
megatest-fossil-hash.* altdb.scm mofiles/*.o \
mofiles/*.o vg.o cookie.o dashboard-main.o \
- ducttape-lib.o ftail.o mutils.o pkts.o rmtmod.o stml2.o \
+ ducttape-lib.o mutils.o pkts.o rmtmod.o stml2.o \
tcmt.o *.import.scm *.import.o
rm -f $(OFILES) $(GOFILES) $(MOFILES) $(TCMTOBJS) \
$(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil mtut \
- tcmt ftail.import.scm readline-fix.scm serialize-env \
+ tcmt readline-fix.scm serialize-env \
dboard dboard.o megatest.o dashboard.o \
megatest-fossil-hash.* altdb.scm mofiles/*.o vg.o
rm -rf share
#======================================================================
@@ -432,12 +422,12 @@
fi
if csi -ne '(use postgresql)';then \
echo "(use postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\
fi
-portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.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 sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
- csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.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 sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
+portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o genexample.o gutils.o http-transport.o items.o keys.o launch.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
+ csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o genexample.o gutils.o http-transport.o items.o keys.o launch.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
# create a pdf dot graphviz diagram from notations in rmt.scm
rmt.pdf : rmt.scm
grep ';;DOT' rmt.scm | sed -e 's/.*;;DOT //' > rmt.dot;dot -Tpdf rmt.dot -o rmt.pdf
Index: api.scm
==================================================================
--- api.scm
+++ api.scm
@@ -388,15 +388,7 @@
(if (not success)
(debug:print 0 *default-log-port* "ERROR: success flag is #f for " cmd " with params " params))
(if (> *api-process-request-count* *max-api-process-requests*)
(set! *max-api-process-requests* *api-process-request-count*))
(set! *api-process-request-count* (- *api-process-request-count* 1))
- ;; This can be here but needs controls to ensure it doesn't run more than every 4 seconds
- ;; (rmt:dat->json-str
- ;; (if (or (string? res)
- ;; (list? res)
- ;; (number? res)
- ;; (boolean? res))
- ;; res
- ;; (list "ERROR, not string, list, number or boolean" 1 cmd params res)))))
(db:obj->string res transport: 'http)))
ADDED attic/fdb_records.scm
Index: attic/fdb_records.scm
==================================================================
--- /dev/null
+++ attic/fdb_records.scm
@@ -0,0 +1,36 @@
+;; 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 .
+
+;; Single record for managing a filedb
+;; make-vector-record "Filedb record" filedb fdb db dbpath pathcache idcache partcache
+;; Filedb record
+(define (make-filedb:fdb)(make-vector 5))
+(define-inline (filedb:fdb-get-db vec) (vector-ref vec 0))
+(define-inline (filedb:fdb-get-dbpath vec) (vector-ref vec 1))
+(define-inline (filedb:fdb-get-pathcache vec) (vector-ref vec 2))
+(define-inline (filedb:fdb-get-idcache vec) (vector-ref vec 3))
+(define-inline (filedb:fdb-get-partcache vec) (vector-ref vec 4))
+(define-inline (filedb:fdb-set-db! vec val)(vector-set! vec 0 val))
+(define-inline (filedb:fdb-set-dbpath! vec val)(vector-set! vec 1 val))
+(define-inline (filedb:fdb-set-pathcache! vec val)(vector-set! vec 2 val))
+(define-inline (filedb:fdb-set-idcache! vec val)(vector-set! vec 3 val))
+(define-inline (filedb:fdb-set-partcache! vec val)(vector-set! vec 4 val))
+
+;; children records, should have use something other than "child"
+(define-inline (filedb:child-get-id vec) (vector-ref vec 0))
+(define-inline (filedb:child-get-path vec) (vector-ref vec 1))
+(define-inline (filedb:child-get-parent_id vec)(vector-ref vec 2))
ADDED attic/filedb.scm
Index: attic/filedb.scm
==================================================================
--- /dev/null
+++ attic/filedb.scm
@@ -0,0 +1,255 @@
+;; Copyright 2006-2011, 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 .
+;;
+
+;; (require-extension synch sqlite3 posix srfi-13 srfi-1 utils regex)
+(use sqlite3 srfi-1 posix regex srfi-69 srfi-13 posix-extras)
+(import (prefix sqlite3 sqlite3:))
+
+(declare (unit filedb))
+
+(include "fdb_records.scm")
+;; (include "settings.scm")
+
+(define (filedb:open-db dbpath)
+ (let* ((fdb (make-filedb:fdb))
+ (dbexists (common:file-exists? dbpath))
+ (db (sqlite3:open-database dbpath)))
+ (filedb:fdb-set-db! fdb db)
+ (filedb:fdb-set-dbpath! fdb dbpath)
+ (filedb:fdb-set-pathcache! fdb (make-hash-table))
+ (filedb:fdb-set-idcache! fdb (make-hash-table))
+ (filedb:fdb-set-partcache! fdb (make-hash-table))
+ (sqlite3:set-busy-handler! db (make-busy-timeout 136000))
+ (if (not dbexists)
+ (begin
+ (sqlite3:execute db "PRAGMA synchronous = OFF;")
+ (sqlite3:execute db "CREATE TABLE names (id INTEGER PRIMARY KEY,name TEST);") ;; for future use - change path in paths table to path_id
+ (sqlite3:execute db "CREATE INDEX name_index ON names (name);")
+ ;; NB// We store a useful subset of file attributes but do not attempt to store all
+ (sqlite3:execute db "CREATE TABLE paths (id INTEGER PRIMARY KEY,
+ path TEXT,
+ parent_id INTEGER,
+ mode INTEGER DEFAULT -1,
+ uid INTEGER DEFAULT -1,
+ gid INTEGER DEFAULT -1,
+ size INTEGER DEFAULT -1,
+ mtime INTEGER DEFAULT -1);")
+ (sqlite3:execute db "CREATE INDEX path_index ON paths (path,parent_id);")
+ (sqlite3:execute db "CREATE TABLE bases (id INTEGER PRIMARY KEY,base TEXT, updated TIMESTAMP);")))
+ ;; close the sqlite3 db and open it as needed
+ (filedb:finalize-db! fdb)
+ (filedb:fdb-set-db! fdb #f)
+ fdb))
+
+(define (filedb:reopen-db fdb)
+ (let ((db (sqlite3:open-database (filedb:fdb-get-dbpath fdb))))
+ (filedb:fdb-set-db! fdb db)
+ (sqlite3:set-busy-handler! db (make-busy-timeout 136000))))
+
+(define (filedb:finalize-db! fdb)
+ (sqlite3:finalize! (filedb:fdb-get-db fdb)))
+
+(define (filedb:get-current-time-string)
+ (string-chomp (time->string (seconds->local-time (current-seconds)))))
+
+(define (filedb:get-base-id db path)
+ (let ((stmt (sqlite3:prepare db "SELECT id FROM bases WHERE base=?;"))
+ (id-num #f))
+ (sqlite3:for-each-row
+ (lambda (num) (set! id-num num)) stmt path)
+ (sqlite3:finalize! stmt)
+ id-num))
+
+(define (filedb:get-path-id db path parent)
+ (let ((stmt (sqlite3:prepare db "SELECT id FROM paths WHERE path=? AND parent_id=?;"))
+ (id-num #f))
+ (sqlite3:for-each-row
+ (lambda (num) (set! id-num num)) stmt path parent)
+ (sqlite3:finalize! stmt)
+ id-num))
+
+(define (filedb:add-base db path)
+ (let ((existing (filedb:get-base-id db path)))
+ (if existing #f
+ (begin
+ (sqlite3:execute db "INSERT INTO bases (base,updated) VALUES (?,?);" path (filedb:get-current-time-string))))))
+
+;; index value field notes
+;; 0 inode number st_ino
+;; 1 mode st_mode bitfield combining file permissions and file type
+;; 2 number of hard links st_nlink
+;; 3 UID of owner st_uid as with file-owner
+;; 4 GID of owner st_gid
+;; 5 size st_size as with file-size
+;; 6 access time st_atime as with file-access-time
+;; 7 change time st_ctime as with file-change-time
+;; 8 modification time st_mtime as with file-modification-time
+;; 9 parent device ID st_dev ID of device on which this file resides
+;; 10 device ID st_rdev device ID for special files (i.e. the raw major/minor number)
+;; 11 block size st_blksize
+;; 12 number of blocks allocated st_blocks
+
+(define (filedb:add-path-stat db path parent statinfo)
+ (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id,mode,uid,gid,size,mtime) VALUES (?,?,?,?,?,?,?);")))
+ (sqlite3:execute stmt
+ path
+ parent
+ (vector-ref statinfo 1) ;; mode
+ (vector-ref statinfo 3) ;; uid
+ (vector-ref statinfo 4) ;; gid
+ (vector-ref statinfo 5) ;; size
+ (vector-ref statinfo 8) ;; mtime
+ )
+ (sqlite3:finalize! stmt))) ;; (filedb:get-current-time-string))))
+
+(define (filedb:add-path db path parent)
+ (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id) VALUES (?,?);")))
+ (sqlite3:execute stmt path parent)
+ (sqlite3:finalize! stmt)))
+
+(define (filedb:register-path fdb path #!key (save-stat #f))
+ (let* ((db (filedb:fdb-get-db fdb))
+ (pathcache (filedb:fdb-get-pathcache fdb))
+ (stat (if save-stat (file-stat path #t)))
+ (id (hash-table-ref/default pathcache path #f)))
+ (if (not db)(filedb:reopen-db fdb))
+ (if id id
+ (let ((plist (string-split path "/")))
+ (let loop ((head (car plist))
+ (tail (cdr plist))
+ (parent 0))
+ (let ((id (filedb:get-path-id db head parent))
+ (done (null? tail)))
+ (if id ;; we'll have a id if the path is already registered
+ (if done
+ (begin
+ (hash-table-set! pathcache path id)
+ id) ;; return the last path id for a result
+ (loop (car tail)(cdr tail) id))
+ (begin ;; add the path and then repeat the loop with the same data
+ (if save-stat
+ (filedb:add-path-stat db head parent stat)
+ (filedb:add-path db head parent))
+ (loop head tail parent)))))))))
+
+(define (filedb:update-recursively fdb path #!key (save-stat #f))
+ (let ((p (open-input-pipe (string-append "find -L " path)))) ;; (resolve-pathname path)))) ;; (string-append "find " path))))
+ (print "processed 0 files...")
+ (let loop ((l (read-line p))
+ (lc 0)) ;; line count
+ (if (eof-object? l)
+ (begin
+ (print " " lc " files")
+ (close-input-port p))
+ (begin
+ (filedb:register-path fdb l save-stat: save-stat) ;; (get-real-path l)) ;; don't like losing the original path info
+ (if (= (modulo lc 100) 0)
+ (print " " lc " files"))
+ (loop (read-line p)(+ lc 1)))))))
+
+(define (filedb:update fdb path #!key (save-stat #f))
+ ;; first get the realpath and add it to the bases table
+ (let ((real-path path) ;; (filedb:get-real-path path))
+ (db (filedb:fdb-get-db fdb)))
+ (filedb:add-base db real-path)
+ (filedb:update-recursively fdb path save-stat: save-stat)))
+
+;; not used and broken
+;;
+(define (filedb:get-real-path path)
+ (let* ((p (open-input-pipe (string-append real-path " " (regexp-escape path))))
+ (pth (read-line p)))
+ (if (eof-object? pth) path
+ (begin
+ (close-input-port p)
+ pth))))
+
+(define (filedb:drop-base fdb path)
+ (print "Sorry, I don't do anything yet"))
+
+(define (filedb:find-all fdb pattern action)
+ (let* ((db (filedb:fdb-get-db fdb))
+ (stmt (sqlite3:prepare db "SELECT id FROM paths WHERE path like ?;"))
+ (result '()))
+ (sqlite3:for-each-row
+ (lambda (num)
+ (action num)
+ (set! result (cons num result))) stmt pattern)
+ (sqlite3:finalize! stmt)
+ result))
+
+(define (filedb:get-path-record fdb id)
+ (let* ((db (filedb:fdb-get-db fdb))
+ (partcache (filedb:fdb-get-partcache fdb))
+ (dat (hash-table-ref/default partcache id #f)))
+ (if dat dat
+ (let ((stmt (sqlite3:prepare db "SELECT path,parent_id FROM paths WHERE id=?;"))
+ (result #f))
+ (sqlite3:for-each-row
+ (lambda (path parent_id)(set! result (list path parent_id))) stmt id)
+ (hash-table-set! partcache id result)
+ (sqlite3:finalize! stmt)
+ result))))
+
+(define (filedb:get-children fdb parent-id)
+ (let* ((db (filedb:fdb-get-db fdb))
+ (res '()))
+ (sqlite3:for-each-row
+ (lambda (id path parent-id)
+ (set! res (cons (vector id path parent-id) res)))
+ db "SELECT id,path,parent_id FROM paths WHERE parent_id=?;"
+ parent-id)
+ res))
+
+;; retrieve all that have children and those without
+;; children that match patt
+(define (filedb:get-children-patt fdb parent-id search-patt)
+ (let* ((db (filedb:fdb-get-db fdb))
+ (res '()))
+ ;; first get the children that have no children
+ (sqlite3:for-each-row
+ (lambda (id path parent-id)
+ (set! res (cons (vector id path parent-id) res)))
+ db "SELECT id,path,parent_id FROM paths WHERE parent_id=? AND
+ (id IN (SELECT parent_id FROM paths) OR path LIKE ?);"
+ parent-id search-patt)
+ res))
+
+(define (filedb:get-path fdb id)
+ (let* ((db (filedb:fdb-get-db fdb))
+ (idcache (filedb:fdb-get-idcache fdb))
+ (path (hash-table-ref/default idcache id #f)))
+ (if (not db)(filedb:reopen-db fdb))
+ (if path path
+ (let loop ((curr-id id)
+ (path ""))
+ (let ((path-record (filedb:get-path-record fdb curr-id)))
+ (if (not path-record) #f ;; this id has no path
+ (let* ((parent-id (list-ref path-record 1))
+ (pname (list-ref path-record 0))
+ (newpath (string-append "/" pname path)))
+ (if (= parent-id 0) ;; fields 0=path, 1=parent. root parent=0
+ (begin
+ (hash-table-set! idcache id newpath)
+ newpath)
+ (loop parent-id newpath)))))))))
+
+(define (filedb:search db pattern)
+ (let ((action (lambda (id)(print (filedb:get-path db id)))))
+ (filedb:find-all db pattern action)))
+
ADDED attic/fs-transport.scm
Index: attic/fs-transport.scm
==================================================================
--- /dev/null
+++ attic/fs-transport.scm
@@ -0,0 +1,52 @@
+
+;; 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 .
+
+(require-extension (srfi 18) extras tcp s11n)
+
+(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)
+(import (prefix sqlite3 sqlite3:))
+
+(use spiffy uri-common intarweb http-client spiffy-request-vars)
+
+(tcp-buffer-size 2048)
+
+(declare (unit fs-transport))
+
+(declare (uses common))
+(declare (uses db))
+(declare (uses tests))
+(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
+
+(include "common_records.scm")
+(include "db_records.scm")
+
+
+;;======================================================================
+;; F S T R A N S P O R T S E R V E R
+;;======================================================================
+
+;; There is no "server" per se but a convience routine to make it non
+;; necessary to be reopening the db over and over again.
+;;
+
+(define (fs:process-queue-item packet)
+ (if (not *dbstruct-db*) ;; we will require that (setup-for-run) has already been called
+ (set! *dbstruct-db* (db:setup-db)))
+ (debug:print-info 11 *default-log-port* "fs:process-queue-item called with packet=" packet)
+ (db:process-queue-item *dbstruct-db* packet))
+
ADDED attic/ftail.scm
Index: attic/ftail.scm
==================================================================
--- /dev/null
+++ attic/ftail.scm
@@ -0,0 +1,108 @@
+;;======================================================================
+;; Copyright 2017, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+
+;;======================================================================
+
+(declare (unit ftail))
+
+(module ftail
+ (
+ open-tail-db
+ tail-write
+ tail-get-fid
+ file-tail
+ )
+
+(import scheme chicken data-structures extras)
+(use (prefix sqlite3 sqlite3:) posix typed-records)
+
+(define (open-tail-db )
+ (let* ((basedir (create-directory (conc "/tmp/" (current-user-name))))
+ (dbpath (conc basedir "/megatest_logs.db"))
+ (dbexists (file-exists? dbpath))
+ (db (sqlite3:open-database dbpath))
+ (handler (sqlite3:make-busy-timeout 136000)))
+ (sqlite3:set-busy-handler! db handler)
+ (sqlite3:execute db "PRAGMA synchronous = 0;")
+ (if (not dbexists)
+ (begin
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_files (id INTEGER PRIMARY KEY,filename TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_data (id INTEGER PRIMARY KEY,fid INTEGER,line TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));")
+ ))
+ db))
+
+(define (tail-write db fid lines)
+ (sqlite3:with-transaction
+ db
+ (lambda ()
+ (for-each
+ (lambda (line)
+ (sqlite3:execute db "INSERT INTO log_data (fid,line) VALUES (?,?);" fid line))
+ lines))))
+
+(define (tail-get-fid db fname)
+ (let ((fid (handle-exceptions
+ exn
+ #f
+ (sqlite3:first-result db "SELECT id FROM log_files WHERE filename=?;" fname))))
+ (if fid
+ fid
+ (begin
+ (sqlite3:execute db "INSERT INTO log_files (filename) VALUES (?);" fname)
+ (tail-get-fid db fname)))))
+
+(define (file-tail fname #!key (db-in #f))
+ (let* ((inp (open-input-file fname))
+ (db (or db-in (open-tail-db)))
+ (fid (tail-get-fid db fname)))
+ (let loop ((inl (read-line inp))
+ (lines '())
+ (lastwr (current-seconds)))
+ (if (eof-object? inl)
+ (let ((timed-out (> (- (current-seconds) lastwr) 60)))
+ (if timed-out (tail-write db fid (reverse lines)))
+ (sleep 1)
+ (if timed-out
+ (loop (read-line inp) '() (current-seconds))
+ (loop (read-line inp) lines lastwr)))
+ (let* ((savelines (> (length lines) 19)))
+ ;; (print inl)
+ (if savelines (tail-write db fid (reverse lines)))
+ (loop (read-line inp)
+ (if savelines
+ '()
+ (cons inl lines))
+ (if savelines
+ (current-seconds)
+ lastwr)))))))
+
+;; offset -20 means get last 20 lines
+;;
+(define (tail-get-lines db fid offset count)
+ (if (> offset 0)
+ (sqlite3:map-row (lambda (id line)
+ (vector id line))
+ db
+ "SELECT id,line FROM log_data WHERE fid=? OFFSET ? LIMIT ?;" fid offset count)
+ (reverse ;; get N from the end
+ (sqlite3:map-row (lambda (id line)
+ (vector id line))
+ db
+ "SELECT id,line FROM log_data WHERE fid=? ORDER BY id DESC LIMIT ?;" fid (abs offset)))))
+
+)
ADDED attic/lock-queue.scm
Index: attic/lock-queue.scm
==================================================================
--- /dev/null
+++ attic/lock-queue.scm
@@ -0,0 +1,253 @@
+;; 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 (prefix sqlite3 sqlite3:) srfi-18)
+
+(declare (unit lock-queue))
+(declare (uses common))
+(declare (uses tasks))
+
+;;======================================================================
+;; attempt to prevent overlapping updates of rollup files by queueing
+;; update requests in an sqlite db
+;;======================================================================
+
+;;======================================================================
+;; db record,
+;;======================================================================
+
+(define (make-lock-queue:db-dat)(make-vector 3))
+(define-inline (lock-queue:db-dat-get-db vec) (vector-ref vec 0))
+(define-inline (lock-queue:db-dat-get-path vec) (vector-ref vec 1))
+(define-inline (lock-queue:db-dat-set-db! vec val)(vector-set! vec 0 val))
+(define-inline (lock-queue:db-dat-set-path! vec val)(vector-set! vec 1 val))
+
+(define (lock-queue:delete-lock-db dbdat)
+ (let ((fname (lock-queue:db-dat-get-path dbdat)))
+ (system (conc "rm -f " fname "*"))))
+
+(define (lock-queue:open-db fname #!key (count 10))
+ (let* ((actualfname (conc fname ".lockdb"))
+ (dbexists (common:file-exists? actualfname))
+ (db (sqlite3:open-database actualfname))
+ (handler (make-busy-timeout 136000)))
+ (if dbexists
+ (vector db actualfname)
+ (begin
+ (handle-exceptions
+ exn
+ (begin
+ (thread-sleep! 10)
+ (if (> count 0)
+ (lock-queue:open-db fname count: (- count 1))
+ (vector db actualfname)))
+ (sqlite3:with-transaction
+ db
+ (lambda ()
+ (sqlite3:execute
+ db
+ "CREATE TABLE IF NOT EXISTS queue (
+ id INTEGER PRIMARY KEY,
+ test_id INTEGER,
+ start_time INTEGER,
+ state TEXT,
+ CONSTRAINT queue_constraint UNIQUE (test_id));")
+ (sqlite3:execute
+ db
+ "CREATE TABLE IF NOT EXISTS runlocks (
+ id INTEGER PRIMARY KEY,
+ test_id INTEGER,
+ run_lock TEXT,
+ CONSTRAINT runlock_constraint UNIQUE (run_lock));"))))))
+ (sqlite3:set-busy-handler! db handler)
+ (vector db actualfname)))
+
+(define (lock-queue:set-state dbdat test-id newstate #!key (remtries 10))
+ (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200)
+ (handle-exceptions
+ exn
+ (if (> remtries 0)
+ (begin
+ (debug:print 0 *default-log-port* "WARNING: exception on lock-queue:set-state. Trying again in 30 seconds.")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (thread-sleep! 30)
+ (lock-queue:set-state dbdat test-id newstate remtries: (- remtries 1)))
+ (begin
+ (debug:print-error 0 *default-log-port* " Failed to set lock state for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.")
+ #f))
+ (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "UPDATE queue SET state=? WHERE test_id=?;"
+ newstate
+ test-id)))
+
+(define (lock-queue:any-younger? dbdat mystart test-id #!key (remtries 10))
+ ;; no need to wait on journal on read only queries
+ ;; (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200)
+ (handle-exceptions
+ exn
+ (if (> remtries 0)
+ (begin
+ (debug:print 0 *default-log-port* "WARNING: exception on lock-queue:any-younger. Removing lockdb and trying again in 5 seconds.")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (thread-sleep! 5)
+ (lock-queue:delete-lock-db dbdat)
+ (lock-queue:any-younger? dbdat mystart test-id remtries: (- remtries 1)))
+ (begin
+ (debug:print-error 0 *default-log-port* " Failed to find younger locks for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.")
+ #f))
+ (let ((res #f))
+ (sqlite3:for-each-row
+ (lambda (tid)
+ ;; Actually this should not be needed as mystart cannot be simultaneously less than and test-id same as
+ (if (not (equal? tid test-id))
+ (set! res tid)))
+ (lock-queue:db-dat-get-db dbdat)
+ "SELECT test_id FROM queue WHERE start_time > ?;" mystart)
+ res)))
+
+(define (lock-queue:get-lock dbdat test-id #!key (count 10)(waiting-msg #f))
+ (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 remove: #t waiting-msg: "lock-queue:get-lock, waiting on journal")
+ (let* ((res #f)
+ (db (lock-queue:db-dat-get-db dbdat))
+ (lckqry (sqlite3:prepare db "SELECT test_id,run_lock FROM runlocks WHERE run_lock='locked';"))
+ (mklckqry (sqlite3:prepare db "INSERT INTO runlocks (test_id,run_lock) VALUES (?,'locked');")))
+ (let ((result
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port* "WARNING: failed to get queue lock. Removing lock db and returning fail") ;; Will try again in a few seconds")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (thread-sleep! 10)
+ ;; (if (> count 0)
+ ;; #f ;; (lock-queue:get-lock dbdat test-id count: (- count 1)) - give up on retries
+ ;; (begin ;; never recovered, remote the lock file and return #f, no lock obtained
+ (lock-queue:delete-lock-db dbdat)
+ #f)
+ (sqlite3:with-transaction
+ db
+ (lambda ()
+ (sqlite3:for-each-row (lambda (tid lockstate)
+ (set! res (list tid lockstate)))
+ lckqry)
+ (if res
+ (if (equal? (car res) test-id)
+ #t ;; already have the lock
+ #f)
+ (begin
+ (sqlite3:execute mklckqry test-id)
+ ;; if no error handled then return #t for got the lock
+ #t)))))))
+ (sqlite3:finalize! lckqry)
+ (sqlite3:finalize! mklckqry)
+ result)))
+
+(define (lock-queue:release-lock fname test-id #!key (count 10))
+ (let* ((dbdat (lock-queue:open-db fname)))
+ (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 "lock-queue:release-lock; waiting on journal")
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port* "WARNING: Failed to release queue lock. Will try again in few seconds")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (thread-sleep! (/ count 10))
+ (if (> count 0)
+ (begin
+ (sqlite3:finalize! (lock-queue:db-dat-get-db dbdat))
+ (lock-queue:release-lock fname test-id count: (- count 1)))
+ (let ((journal (conc fname "-journal")))
+ ;; If we've tried ten times and failed there is a serious problem
+ ;; try to remove the lock db and allow it to be recreated
+ (handle-exceptions
+ exn
+ #f
+ (if (common:file-exists? journal)(delete-file journal))
+ (if (common:file-exists? fname) (delete-file fname))
+ #f))))
+ (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "DELETE FROM runlocks WHERE test_id=?;" test-id)
+ (sqlite3:finalize! (lock-queue:db-dat-get-db dbdat)))))
+
+(define (lock-queue:steal-lock dbdat test-id #!key (count 10))
+ (debug:print-info 0 *default-log-port* "Attempting to steal lock at " (lock-queue:db-dat-get-path dbdat))
+ (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 "lock-queue:steal-lock; waiting on journal")
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port* "WARNING: Failed to steal queue lock. Will try again in few seconds")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (thread-sleep! 10)
+ (if (> count 0)
+ (lock-queue:steal-lock dbdat test-id count: (- count 1))
+ #f))
+ (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "DELETE FROM runlocks WHERE run_lock='locked';"))
+ (lock-queue:get-lock dbdat test-it))
+
+;; returns #f if ok to skip the task
+;; returns #t if ok to proceed with task
+;; otherwise waits
+;;
+(define (lock-queue:wait-turn fname test-id #!key (count 10)(waiting-msg #f))
+ (let* ((dbdat (lock-queue:open-db fname))
+ (mystart (current-seconds))
+ (db (lock-queue:db-dat-get-db dbdat)))
+ ;; (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 waiting-msg: "lock-queue:wait-turn; waiting on journal file")
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port* "WARNING: Failed to find out if it is ok to skip the wait queue. Will try again in few seconds")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (print-call-chain (current-error-port))
+ (thread-sleep! 10)
+ (if (> count 0)
+ (begin
+ (sqlite3:finalize! db)
+ (lock-queue:wait-turn fname test-id count: (- count 1)))
+ (begin
+ (debug:print 0 *default-log-port* "Giving up calls to lock-queue:wait-turn for test-id " test-id " at path " fname ", printing call chain")
+ (print-call-chain (current-error-port))
+ #f)))
+ ;; wait 10 seconds and then check to see if someone is already updating the html
+ (thread-sleep! 10)
+ (if (not (lock-queue:any-younger? dbdat mystart test-id)) ;; no processing in flight, must try to start processing
+ (begin
+ (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 waiting-msg: "lock-queue:wait-turn; waiting on journal file")
+ (sqlite3:execute
+ db
+ "INSERT OR REPLACE INTO queue (test_id,start_time,state) VALUES (?,?,'waiting');"
+ test-id mystart)
+ ;; (thread-sleep! 1) ;; give other tests a chance to register
+ (let ((result
+ (let loop ((younger-waiting (lock-queue:any-younger? dbdat mystart test-id)))
+ (if younger-waiting
+ (begin
+ ;; no need for us to wait. mark in the lock queue db as skipping
+ ;; no point in marking anything in the queue - simply never register this
+ ;; test as it is *covered* by a previously started update to the html file
+ ;; (lock-queue:set-state dbdat test-id "skipping")
+ #f) ;; let the calling process know that nothing needs to be done
+ (if (lock-queue:get-lock dbdat test-id)
+ #t
+ (if (> (- (current-seconds) mystart) 36000) ;; waited too long, steal the lock
+ (lock-queue:steal-lock dbdat test-id)
+ (begin
+ (thread-sleep! 1)
+ (loop (lock-queue:any-younger? dbdat mystart test-id)))))))))
+ (sqlite3:finalize! db)
+ result))))))
+
+
+;; (use trace)
+;; (trace lock-queue:get-lock lock-queue:release-lock lock-queue:wait-turn lock-queue:any-younger? lock-queue:set-state)
ADDED attic/mlaunch.scm
Index: attic/mlaunch.scm
==================================================================
--- /dev/null
+++ attic/mlaunch.scm
@@ -0,0 +1,33 @@
+;; Copyright 2006-2014, 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')
+
+;;======================================================================
+;; MLAUNCH
+;;
+;; take jobs from the given queue and keep launching them keeping
+;; the cpu load at the targeted level
+;;
+;;======================================================================
+
+(use sqlite3 srfi-1 posix regex regex-case srfi-69 format)
+
+(declare (unit mlaunch))
+(declare (uses db))
+(declare (uses common))
+
ADDED attic/monitor.scm
Index: attic/monitor.scm
==================================================================
--- /dev/null
+++ attic/monitor.scm
@@ -0,0 +1,33 @@
+;; 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 .
+
+;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
+
+(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking)
+(import (prefix sqlite3 sqlite3:))
+
+(declare (unit runs))
+(declare (uses db))
+(declare (uses common))
+(declare (uses items))
+(declare (uses runconfig))
+
+(include "common_records.scm")
+(include "key_records.scm")
+(include "db_records.scm")
+(include "run_records.scm")
+
ADDED attic/newdashboard.scm
Index: attic/newdashboard.scm
==================================================================
--- /dev/null
+++ attic/newdashboard.scm
@@ -0,0 +1,742 @@
+;;======================================================================
+;; 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 .
+
+;;======================================================================
+
+(use format)
+
+(use (prefix iup iup:))
+
+(use canvas-draw)
+(import canvas-draw-iup)
+
+(use sql-de-lite srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors ;; defstruct
+ (prefix dbi dbi:))
+
+(declare (uses common))
+(declare (uses megatest-version))
+(declare (uses margs))
+
+;; (declare (uses launch))
+;; (declare (uses gutils))
+;; (declare (uses db))
+;; (declare (uses server))
+;; (declare (uses synchash))
+(declare (uses dcommon))
+;; (declare (uses tree))
+;;
+;; (include "common_records.scm")
+;; (include "db_records.scm")
+;; (include "key_records.scm")
+
+(define help (conc
+"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
+ version " megatest-version "
+ license GPL, Copyright (C) Matt Welland 2011
+
+Usage: dashboard [options]
+ -h : this help
+ -server host:port : connect to host:port instead of db access
+ -test testid : control test identified by testid
+ -guimonitor : control panel for runs
+
+Misc
+ -rows N : set number of rows
+"))
+
+;; process args
+(define remargs (args:get-args
+ (argv)
+ (list "-rows"
+ "-run"
+ "-test"
+ "-debug"
+ "-host"
+ )
+ (list "-h"
+ "-guimonitor"
+ "-main"
+ "-v"
+ "-q"
+ )
+ args:arg-hash
+ 0))
+
+(if (args:get-arg "-h")
+ (begin
+ (print help)
+ (exit)))
+
+;; ease debugging by loading ~/.dashboardrc
+(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
+ (if (common:file-exists? debugcontrolf)
+ (load debugcontrolf)))
+
+(debug:setup)
+
+(define *tim* (iup:timer))
+(define *ord* #f)
+
+(iup:attribute-set! *tim* "TIME" 300)
+(iup:attribute-set! *tim* "RUN" "YES")
+
+(define (message-window msg)
+ (iup:show
+ (iup:dialog
+ (iup:vbox
+ (iup:label msg #:margin "40x40")))))
+
+(define (iuplistbox-fill-list lb items . default)
+ (let ((i 1)
+ (selected-item (if (null? default) #f (car default))))
+ (iup:attribute-set! lb "VALUE" (if selected-item selected-item ""))
+ (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" item))) ;; (number->string i))))
+ (set! i (+ i 1)))
+ items)
+ i))
+
+(define (pad-list l n)(append l (make-list (- n (length l)))))
+
+
+(define (mkstr . x)
+ (string-intersperse (map conc x) ","))
+
+(define (update-search x val)
+ (hash-table-set! *searchpatts* x val))
+
+
+;; 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") "10"))) : 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") "60")) : 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
+ )
+
+
+
+;; mtest is actually the megatest.config file
+;;
+(define (mtest toppath window-id)
+ (let* ((curr-row-num 0)
+ ;; (rawconfig (read-config (conc toppath "/megatest.config") #f 'return-string))
+ (keys-matrix (iup:matrix)) ;; (dcommon:keys-matrix rawconfig))
+ (setup-matrix (iup:matrix)) ;; (dcommon:section-matrix rawconfig "setup" "Varname" "Value"))
+ (jobtools-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 1
+ #:numlin 5
+ #:numcol-visible 1
+ #:numlin-visible 3))
+ (validvals-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 1
+ #:numlin 2
+ #:numcol-visible 1
+ #:numlin-visible 2))
+ (envovrd-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 1
+ #:numlin 20
+ #:numcol-visible 1
+ #:numlin-visible 8))
+ (disks-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 1
+ #:numlin 20
+ #:numcol-visible 1
+ #:numlin-visible 8))
+ )
+ (iup:attribute-set! disks-matrix "0:0" "Disk Name")
+ (iup:attribute-set! disks-matrix "0:1" "Disk Path")
+ (iup:attribute-set! disks-matrix "WIDTH1" "120")
+ (iup:attribute-set! disks-matrix "WIDTH0" "100")
+ (iup:attribute-set! disks-matrix "ALIGNMENT1" "ALEFT")
+ (iup:attribute-set! disks-matrix "FIXTOTEXT" "C1")
+ (iup:attribute-set! disks-matrix "RESIZEMATRIX" "YES")
+
+ ;; fill in existing info
+ (for-each
+ (lambda (mat fname)
+ (set! curr-row-num 1)
+ (for-each
+ (lambda (var)
+ (iup:attribute-set! mat (conc curr-row-num ":0") var)
+ ;; (iup:attribute-set! mat (conc curr-row-num ":1") (config-lookup rawconfig fname var))
+ (set! curr-row-num (+ curr-row-num 1)))
+ '()));; (configf:section-vars rawconfig fname)))
+ (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix disks-matrix)
+ (list "setup" "jobtools" "validvalues" "env-override" "disks"))
+
+ (for-each
+ (lambda (mat)
+ (iup:attribute-set! mat "0:1" "Value")
+ (iup:attribute-set! mat "0:0" "Var")
+ (iup:attribute-set! mat "ALIGNMENT1" "ALEFT")
+ (iup:attribute-set! mat "FIXTOTEXT" "C1")
+ (iup:attribute-set! mat "RESIZEMATRIX" "YES")
+ (iup:attribute-set! mat "WIDTH1" "120")
+ (iup:attribute-set! mat "WIDTH0" "100")
+ )
+ (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix))
+
+ (iup:attribute-set! validvals-matrix "WIDTH1" "290")
+ (iup:attribute-set! envovrd-matrix "WIDTH1" "290")
+
+ (iup:vbox
+ (iup:hbox
+
+ (iup:vbox
+ (let ((tabs (iup:tabs
+ ;; The required tab
+ (iup:hbox
+ ;; The keys
+ (iup:frame
+ #:title "Keys (required)"
+ (iup:vbox
+ (iup:label (conc "Set the fields for organising your runs\n"
+ "here. Note: can only be changed before\n"
+ "running the first run when megatest.db\n"
+ "is created."))
+ keys-matrix))
+ (iup:vbox
+ ;; The setup section
+ (iup:frame
+ #:title "Setup"
+ (iup:vbox
+ (iup:label (conc "max_concurrent_jobs : limits total concurrent jobs (optional)\n"
+ "linktree : directory where linktree will be created."))
+ setup-matrix))
+ ;; The jobtools
+ (iup:frame
+ #:title "Jobtools"
+ (iup:vbox
+ (iup:label (conc "launcher : tool or script to run jobs (try nbfake)\n"
+ "useshell : use system to run your launcher\n"
+ "workhosts : spread jobs out on these hosts"))
+ jobtools-matrix))
+ ;; The disks
+ (iup:frame
+ #:title "Disks"
+ (iup:vbox
+ (iup:label (conc "Enter names and existing paths of locations to run tests"))
+ disks-matrix))))
+ ;; The optional tab
+ (iup:vbox
+ ;; The Environment Overrides
+ (iup:frame
+ #:title "Env override"
+ envovrd-matrix)
+ ;; The valid values
+ (iup:frame
+ #:title "Validvalues"
+ validvals-matrix)
+ ))))
+ (iup:attribute-set! tabs "TABTITLE0" "Required settings")
+ (iup:attribute-set! tabs "TABTITLE1" "Optional settings")
+ tabs))
+ ))))
+
+;; The runconfigs.config file
+;;
+(define (rconfig window-id)
+ (iup:vbox
+ (iup:frame #:title "Default")))
+
+;;======================================================================
+;; T E S T S
+;;======================================================================
+
+(define (tree-path->test-id path)
+ (if (not (null? path))
+ (hash-table-ref/default (dboard:data-path-test-ids *data*) path #f)
+ #f))
+
+(define (test-panel window-id)
+ (let* ((curr-row-num 0)
+ (viewlog (lambda (x)
+ (if (common:file-exists? logfile)
+ ;(system (conc "firefox " logfile "&"))
+ (iup:send-url logfile)
+ (message-window (conc "File " logfile " not found")))))
+ (xterm (lambda (x)
+ (if (directory-exists? rundir)
+ (let ((shell (if (get-environment-variable "SHELL")
+ (conc "-e " (get-environment-variable "SHELL"))
+ "")))
+ (system (conc "cd " rundir
+ ";xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&")))
+ (message-window (conc "Directory " rundir " not found")))))
+ (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -12"))
+ (command-launch-button (iup:button "Execute!"
+ ;; #:expand "HORIZONTAL"
+ #:size "50x"
+ #:action (lambda (x)
+ (let ((cmd (iup:attribute command-text-box "VALUE")))
+ (system (conc cmd " &"))))))
+ (run-test (lambda (x)
+ (iup:attribute-set!
+ command-text-box "VALUE"
+ (conc "xterm -geometry 180x20 -e \"megatest -target " keystring " :runname " runname
+ " -runtests " (conc testname "/" (if (equal? item-path "")
+ "%"
+ item-path))
+ ";echo Press any key to continue;bash -c 'read -n 1 -s'\""))))
+ (remove-test (lambda (x)
+ (iup:attribute-set!
+ command-text-box "VALUE"
+ (conc "xterm -geometry 180x20 -e \"megatest -remove-runs -target " keystring " :runname " runname
+ " -testpatt " (conc testname "/" (if (equal? item-path "")
+ "%"
+ item-path))
+ " -v;echo Press any key to continue;bash -c 'read -n 1 -s'\""))))
+ (run-info-matrix (iup:matrix
+ #:expand "YES"
+ ;; #:scrollbar "YES"
+ #:numcol 1
+ #:numlin 4
+ #:numcol-visible 1
+ #:numlin-visible 4
+ #:click-cb (lambda (obj lin col status)
+ (print "obj: " obj " lin: " lin " col: " col " status: " status))))
+ (test-info-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 1
+ #:numlin 7
+ #:numcol-visible 1
+ #:numlin-visible 7))
+ (test-run-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 1
+ #:numlin 5
+ #:numcol-visible 1
+ #:numlin-visible 5))
+ (meta-dat-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 1
+ #:numlin 5
+ #:numcol-visible 1
+ #:numlin-visible 5))
+ (steps-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 6
+ #:numlin 50
+ #:numcol-visible 6
+ #:numlin-visible 8))
+ (data-matrix (iup:matrix
+ #:expand "YES"
+ #:numcol 8
+ #:numlin 50
+ #:numcol-visible 8
+ #:numlin-visible 8))
+ (updater (lambda (testdat)
+ (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix))))
+
+ ;; Set the updater in updaters
+ ;; (hash-table-set! (dboard:data-updaters *data*) window-id updater)
+ ;;
+ (for-each
+ (lambda (mat)
+ ;; (iup:attribute-set! mat "0:1" "Value")
+ ;; (iup:attribute-set! mat "0:0" "Var")
+ (iup:attribute-set! mat "HEIGHT0" 0)
+ (iup:attribute-set! mat "ALIGNMENT1" "ALEFT")
+ ;; (iup:attribute-set! mat "FIXTOTEXT" "C1")
+ (iup:attribute-set! mat "RESIZEMATRIX" "YES"))
+ ;; (iup:attribute-set! mat "WIDTH1" "120")
+ ;; (iup:attribute-set! mat "WIDTH0" "100"))
+ (list run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix))
+
+ ;; Steps matrix
+ (iup:attribute-set! steps-matrix "0:1" "Step Name")
+ (iup:attribute-set! steps-matrix "0:2" "Start")
+ (iup:attribute-set! steps-matrix "WIDTH2" "40")
+ (iup:attribute-set! steps-matrix "0:3" "End")
+ (iup:attribute-set! steps-matrix "WIDTH3" "40")
+ (iup:attribute-set! steps-matrix "0:4" "Status")
+ (iup:attribute-set! steps-matrix "WIDTH4" "40")
+ (iup:attribute-set! steps-matrix "0:5" "Duration")
+ (iup:attribute-set! steps-matrix "WIDTH5" "40")
+ (iup:attribute-set! steps-matrix "0:6" "Log File")
+ (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT")
+ ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1")
+ (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES")
+ ;; (iup:attribute-set! steps-matrix "WIDTH1" "120")
+ ;; (iup:attribute-set! steps-matrix "WIDTH0" "100")
+
+ ;; Data matrix
+ ;;
+ (let ((rownum 1))
+ (for-each
+ (lambda (x)
+ (iup:attribute-set! data-matrix (conc "0:" rownum) x)
+ (iup:attribute-set! data-matrix (conc "WIDTH" rownum) "50")
+ (set! rownum (+ rownum 1)))
+ (list "Category" "Variable" "Value" "Expected" "Tolerance" "Status" "Units" "Type" "Comment")))
+ (iup:attribute-set! data-matrix "REDRAW" "ALL")
+
+ (for-each
+ (lambda (data)
+ (let ((mat (car data))
+ (keys (cadr data))
+ (rownum 1))
+ (for-each
+ (lambda (key)
+ (iup:attribute-set! mat (conc rownum ":0") key)
+ (set! rownum (+ rownum 1)))
+ keys)
+ (iup:attribute-set! mat "REDRAW" "ALL")))
+ (list
+ (list run-info-matrix '("Run Id" "Target" "Runname" "Run Start Time" ))
+ (list test-info-matrix '("Test Id" "Testname" "Itempath" "State" "Status" "Test Start Time" "Comment"))
+ (list test-run-matrix '("Hostname" "Host info" "Disk Free" "CPU Load" "Run Duration"))
+ (list meta-dat-matrix '("Author" "Owner" "Last Reviewed" "Tags" "Description"))))
+
+ (iup:split
+ #:orientation "HORIZONTAL"
+ (iup:vbox
+ (iup:hbox
+ (iup:vbox
+ run-info-matrix
+ test-info-matrix)
+ ;; test-info-matrix)
+ (iup:vbox
+ test-run-matrix
+ meta-dat-matrix))
+ (iup:vbox
+ (iup:vbox
+ (iup:hbox
+ (iup:button "View Log" #:action viewlog #:size "60x" ) ;; #:size "30x"
+ (iup:button "Start Xterm" #:action xterm #:size "60x" )) ;; #:size "30x"
+ (iup:hbox
+ (iup:button "Run Test" #:action run-test #:size "60x" ) ;; #:size "30x"
+ (iup:button "Clean Test" #:action remove-test #:size "60x" ))) ;; #:size "30x"
+ (iup:hbox
+ ;; hiup:split ;; hbox
+ ;; #:orientation "HORIZONTAL"
+ ;; #:value 300
+ command-text-box
+ command-launch-button)))
+ (iup:vbox
+ (let ((tabs (iup:tabs
+ steps-matrix
+ data-matrix)))
+ (iup:attribute-set! tabs "TABTITLE0" "Test Steps")
+ (iup:attribute-set! tabs "TABTITLE1" "Test Data")
+ tabs)))))
+
+;; Test browser
+(define (tests window-id)
+ (iup:split
+ (let* ((tb (iup:treebox
+ #:selection-cb
+ (lambda (obj id state)
+ ;; (print "obj: " obj ", id: " id ", state: " state)
+ (let* ((run-path (tree:node->path obj id))
+ (test-id (tree-path->test-id (cdr run-path))))
+ ;; (if test-id
+ ;; (hash-table-set! (dboard:data-curr-test-ids *data*)
+ ;; window-id test-id))
+ (print "path: " (tree:node->path obj id) " test-id: " test-id))))))
+ (iup:attribute-set! tb "VALUE" "0")
+ (iup:attribute-set! tb "NAME" "Runs")
+ ;;(iup:attribute-set! tb "ADDEXPANDED" "NO")
+ ;; (dboard:data-tests-tree-set! *data* tb)
+ tb)
+ (test-panel window-id)))
+
+;; The function to update the fields in the test view panel
+(define (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix)
+ ;; get test-id
+ ;; then get test record
+ (if testdat
+ (let* ((test-id 0) ;; (hash-table-ref/default (dboard:data-curr-test-ids *data*) window-id #f))
+ (test-data (hash-table-ref/default testdat test-id #f))
+ (run-id (db:test-get-run_id test-data))
+ (targ/runname (hash-table-ref/default (dboard:data-run-keys *data*)
+ run-id
+ '()))
+ (target (if (null? targ/runname) "" (string-intersperse (reverse (cdr (reverse targ/runname))) "/")))
+ (runname (if (null? targ/runname) "" (car (cdr targ/runname))))
+ (steps-dat (tests:get-compressed-steps *dbstruct-local* run-id test-id)))
+
+ (if test-data
+ (begin
+ ;;
+ (for-each
+ (lambda (data)
+ (let ((mat (car data))
+ (vals (cadr data))
+ (rownum 1))
+ (for-each
+ (lambda (key)
+ (let ((cell (conc rownum ":1")))
+ (if (not (equal? (iup:attribute mat cell)(conc key)))
+ (begin
+ ;; (print "setting cell " cell " in matrix " mat " to value " key)
+ (iup:attribute-set! mat cell (conc key))
+ (iup:attribute-set! mat "REDRAW" cell)))
+ (set! rownum (+ rownum 1))))
+ vals)))
+ (list
+ (list run-info-matrix
+ (if test-id
+ (list (db:test-get-run_id test-data)
+ target
+ runname
+ "n/a")
+ (make-list 4 "")))
+ (list test-info-matrix
+ (if test-id
+ (list test-id
+ (db:test-get-testname test-data)
+ (db:test-get-item-path test-data)
+ (db:test-get-state test-data)
+ (db:test-get-status test-data)
+ (seconds->string (db:test-get-event_time test-data))
+ (db:test-get-comment test-data))
+ (make-list 7 "")))
+ (list test-run-matrix
+ (if test-id
+ (list (db:test-get-host test-data)
+ (db:test-get-uname test-data)
+ (db:test-get-diskfree test-data)
+ (db:test-get-cpuload test-data)
+ (seconds->hr-min-sec (db:test-get-run_duration test-data)))
+ (make-list 5 "")))
+ ))
+ (dcommon:populate-steps steps-dat steps-matrix))))))
+ ;;(list meta-dat-matrix
+ ;; (if test-id
+ ;; (list (
+
+
+;; db:test-get-id
+;; db:test-get-run_id
+;; db:test-get-testname
+;; db:test-get-state
+;; db:test-get-status
+;; db:test-get-event_time
+;; db:test-get-host
+;; db:test-get-cpuload
+;; db:test-get-diskfree
+;; db:test-get-uname
+;; db:test-get-rundir
+;; db:test-get-item-path
+;; db:test-get-run_duration
+;; db:test-get-final_logf
+;; db:test-get-comment
+;; db:test-get-fullname
+
+
+;;======================================================================
+;; R U N C O N T R O L
+;;======================================================================
+
+;; Overall runs browser
+;;
+(define (runs window-id)
+ (let* ((runs-matrix (iup:matrix
+ #:expand "YES"
+ ;; #:fittosize "YES"
+ #:scrollbar "YES"
+ #:numcol 100
+ #:numlin 100
+ #:numcol-visible 7
+ #:numlin-visible 7
+ #:click-cb (lambda (obj lin col status)
+ (print "obj: " obj " lin: " lin " col: " col " status: " status)))))
+
+ (iup:attribute-set! runs-matrix "RESIZEMATRIX" "YES")
+ (iup:attribute-set! runs-matrix "WIDTH0" "100")
+
+ ;; (dboard:data-runs-matrix-set! *data* runs-matrix)
+ (iup:hbox
+ (iup:frame
+ #:title "Runs browser"
+ (iup:vbox
+ runs-matrix)))))
+
+;; Browse and control a single run
+;;
+(define (runcontrol window-id)
+ (iup:hbox))
+
+;;======================================================================
+;; D A S H B O A R D
+;;======================================================================
+
+;; Main Panel
+(define (main-panel window-id)
+ (iup:dialog
+ #:title "Megatest Control Panel"
+ #:menu (dcommon:main-menu)
+ #:shrink "YES"
+ (let ((tabtop (iup:tabs
+ (runs window-id)
+ (tests window-id)
+ (runcontrol window-id)
+ (mtest *toppath* window-id)
+ (rconfig window-id)
+ )))
+ (iup:attribute-set! tabtop "TABTITLE0" "Runs")
+ (iup:attribute-set! tabtop "TABTITLE1" "Tests")
+ (iup:attribute-set! tabtop "TABTITLE2" "Run Control")
+ (iup:attribute-set! tabtop "TABTITLE3" "megatest.config")
+ (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config")
+ tabtop)))
+
+(define *current-window-id* 0)
+
+(define (newdashboard dbstruct)
+ (let* ((data (make-hash-table))
+ (keys '()) ;; (db:get-keys dbstruct))
+ (runname "%")
+ (testpatt "%")
+ (keypatts '()) ;; (map (lambda (k)(list k "%")) keys))
+ (states '())
+ (statuses '())
+ (nextmintime (current-milliseconds))
+ (my-window-id *current-window-id*))
+ (set! *current-window-id* (+ 1 *current-window-id*))
+ ;; (dboard:data-runs-set! *data* data) ;; make this data available to the rest of the application
+ (iup:show (main-panel my-window-id))
+ ;; Yes, running iup:show will pop up a new panel
+ ;; (iup:show (main-panel my-window-id))
+ (iup:callback-set! *tim*
+ "ACTION_CB"
+ (lambda (x)
+ ;; Want to dedicate no more than 50% of the time to this so skip if
+ ;; 2x delta time has not passed since last query
+ (if (< nextmintime (current-milliseconds))
+ (let* ((starttime (current-milliseconds))
+ ;; (changes (dcommon:run-update keys data runname keypatts testpatt states statuses 'full my-window-id))
+ (endtime (current-milliseconds)))
+ (set! nextmintime (+ endtime (* 2 (- endtime starttime))))
+ ;; (debug:print 11 *default-log-port* "CHANGE(S): " (car changes) "..."))
+ )
+ (debug:print-info 11 *default-log-port* "Server overloaded"))))))
+
+;; (dboard:data-updaters-set! *data* (make-hash-table))
+(newdashboard #f) ;; *dbstruct-local*)
+(iup:main-loop)
ADDED attic/records-vs-vectors-vs-coops.scm
Index: attic/records-vs-vectors-vs-coops.scm
==================================================================
--- /dev/null
+++ attic/records-vs-vectors-vs-coops.scm
@@ -0,0 +1,110 @@
+;; 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 .
+
+;; (include "vg.scm")
+
+;; (declare (uses vg))
+
+(use foof-loop defstruct coops)
+
+(defstruct obj type fill-color angle)
+
+(define (make-vg:obj)(make-vector 3))
+(define-inline (vg:obj-get-type vec) (vector-ref vec 0))
+(define-inline (vg:obj-get-fill-color vec) (vector-ref vec 1))
+(define-inline (vg:obj-get-angle vec) (vector-ref vec 2))
+(define-inline (vg:obj-set-type! vec val)(vector-set! vec 0 val))
+(define-inline (vg:obj-set-fill-color! vec val)(vector-set! vec 1 val))
+(define-inline (vg:obj-set-angle! vec val)(vector-set! vec 2 val))
+
+(use simple-exceptions)
+(define vgs:obj-exn (make-exception "wrong record type, expected vgs:obj." 'assert))
+(define (make-vgs:obj)(let ((v (make-vector 4)))(vector-set! v 0 'vgs:obj) v))
+(define-inline (vgs:obj-type vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref vec 1)(raise (vgs:obj-exn 'vgs:obj-type 'xpr))))
+(define-inline (vgs:obj-fill-color vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref vec 2)(raise (vgs:obj-exn 'vgs:obj-fill-color 'xpr))))
+(define-inline (vgs:obj-angle vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref vec 3)(raise (vgs:obj-exn 'vgs:obj-angle 'xpr))))
+(define-inline (vgs:obj-type-set! vec val)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-set! vec 1 val)(raise (vgs:obj-exn 'type))))
+(define-inline (vgs:obj-fill-color-set! vec val)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-set! vec 2 val)(raise (vgs:obj-exn 'fill-color))))
+(define-inline (vgs:obj-angle-set! vec val)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-set! vec 3 val)(raise (vgs:obj-exn 'angle))))
+
+(define-class ()
+ ((type)
+ (fill-color)
+ (angle)))
+
+
+;; first use raw vectors
+(print "Using vectors")
+(time
+ (loop ((for r (up-from 0 (to 255))))
+ (loop ((for g (up-from 0 (to 255))))
+ (loop ((for b (up-from 0 (to 255))))
+ (let ((obj (make-vg:obj)))
+ (vg:obj-set-type! obj 'abc)
+ (vg:obj-set-fill-color! obj "green")
+ (vg:obj-set-angle! obj 135)
+ (let ((a (vg:obj-get-type obj))
+ (b (vg:obj-get-fill-color obj))
+ (c (vg:obj-get-angle obj)))
+ obj))))))
+
+;; first use raw vectors with safe mode
+(print "Using vectors (safe mode)")
+(time
+ (loop ((for r (up-from 0 (to 255))))
+ (loop ((for g (up-from 0 (to 255))))
+ (loop ((for b (up-from 0 (to 255))))
+ (let ((obj (make-vgs:obj)))
+ ;; (badobj (make-vector 20)))
+ (vgs:obj-type-set! obj 'abc)
+ (vgs:obj-fill-color-set! obj "green")
+ (vgs:obj-angle-set! obj 135)
+ (let ((a (vgs:obj-type obj))
+ (b (vgs:obj-fill-color obj))
+ (c (vgs:obj-angle obj)))
+ obj))))))
+
+;; first use defstruct
+(print "Using defstruct")
+(time
+ (loop ((for r (up-from 0 (to 255))))
+ (loop ((for g (up-from 0 (to 255))))
+ (loop ((for b (up-from 0 (to 255))))
+ (let ((obj (make-obj)))
+ (obj-type-set! obj 'abc)
+ (obj-fill-color-set! obj "green")
+ (obj-angle-set! obj 135)
+ (let ((a (obj-type obj))
+ (b (obj-fill-color obj))
+ (c (obj-angle obj)))
+ obj))))))
+
+
+;; first use defstruct
+(print "Using coops")
+(time
+ (loop ((for r (up-from 0 (to 255))))
+ (loop ((for g (up-from 0 (to 255))))
+ (loop ((for b (up-from 0 (to 255))))
+ (let ((obj (make )))
+ (set! (slot-value obj 'type) 'abc)
+ (set! (slot-value obj 'fill-color) "green")
+ (set! (slot-value obj 'angle) 135)
+ (let ((a (slot-value obj 'type))
+ (b (slot-value obj 'fill-color))
+ (c (slot-value obj 'angle)))
+ obj))))))
ADDED attic/rmtdb.scm
Index: attic/rmtdb.scm
==================================================================
--- /dev/null
+++ attic/rmtdb.scm
@@ -0,0 +1,20 @@
+;;======================================================================
+;; 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 .
+
+;;======================================================================
+
ADDED attic/test_records.scm
Index: attic/test_records.scm
==================================================================
--- /dev/null
+++ attic/test_records.scm
@@ -0,0 +1,36 @@
+;; 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 .
+
+;; make-vector-record tests testqueue testname testconfig waitons priority items
+(define (make-tests:testqueue)(make-vector 7 #f))
+(define-inline (tests:testqueue-get-testname vec) (vector-ref vec 0))
+(define-inline (tests:testqueue-get-testconfig vec) (vector-ref vec 1))
+(define-inline (tests:testqueue-get-waitons vec) (vector-ref vec 2))
+(define-inline (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-inline (tests:testqueue-get-items vec) (vector-ref vec 4))
+(define-inline (tests:testqueue-get-itemdat vec) (vector-ref vec 5))
+(define-inline (tests:testqueue-get-item_path vec) (vector-ref vec 6))
+
+(define-inline (tests:testqueue-set-testname! vec val)(vector-set! vec 0 val))
+(define-inline (tests:testqueue-set-testconfig! vec val)(vector-set! vec 1 val))
+(define-inline (tests:testqueue-set-waitons! vec val)(vector-set! vec 2 val))
+(define-inline (tests:testqueue-set-priority! vec val)(vector-set! vec 3 val))
+(define-inline (tests:testqueue-set-items! vec val)(vector-set! vec 4 val))
+(define-inline (tests:testqueue-set-itemdat! vec val)(vector-set! vec 5 val))
+(define-inline (tests:testqueue-set-item_path! vec val)(vector-set! vec 6 val))
+
Index: client.scm
==================================================================
--- client.scm
+++ client.scm
@@ -38,30 +38,13 @@
(if *my-client-signature* *my-client-signature*
(let ((sig (conc (get-host-name) " " (current-process-id))))
(set! *my-client-signature* sig)
*my-client-signature*)))
-;; Not currently used! But, I think it *should* be used!!!
-#;(define (client:logout serverdat)
- (let ((ok (and (socket? serverdat)
- (cdb:logout serverdat *toppath* (client:get-signature)))))
- ok))
-
-#;(define (client:connect iface port)
- (http-transport:client-connect iface port)
- #;(case (server:get-transport)
- ((rpc) (rpc:client-connect iface port))
- ((http) (http:client-connect iface port))
- ((zmq) (zmq:client-connect iface port))
- (else (rpc:client-connect iface port))))
(define (client:setup areapath #!key (remaining-tries 100) (failed-connects 0))
- (client:setup-http areapath remaining-tries: remaining-tries failed-connects: failed-connects)
- #;(case (server:get-transport)
- ((rpc) (rpc-transport:client-setup remaining-tries: remaining-tries failed-connects: failed-connects)) ;;(client:setup-rpc run-id))
- ((http)(client:setup-http areapath remaining-tries: remaining-tries failed-connects: failed-connects))
- (else (rpc-transport:client-setup remaining-tries: remaining-tries failed-connects: failed-connects)))) ;; (client:setup-rpc run-id))))
+ (client:setup-http areapath remaining-tries: remaining-tries failed-connects: failed-connects))
;; Do all the connection work, look up the transport type and set up the
;; connection if required.
;;
;; There are two scenarios.
@@ -94,24 +77,21 @@
(debug:print-info 4 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries)
(if (and (not area-dat)
(not *runremote*))
(set! *runremote* (make-remote)))
(if (and host port)
- (let* ((start-res (case *transport-type*
- ((http)(http-transport:client-connect host port))))
- (ping-res (case *transport-type*
- ((http)(rmt:login-no-auto-client-setup start-res)))))
+ (let* ((start-res (http-transport:client-connect host port))
+ (ping-res (rmt:login-no-auto-client-setup start-res)))
(if (and start-res
ping-res)
(let ((runremote (or area-dat *runremote*))) ;; it might have been generated only a few statements ago
(remote-conndat-set! runremote start-res) ;; (hash-table-set! runremote run-id start-res)
(debug:print-info 2 *default-log-port* "connected to " (http-transport:server-dat-make-url start-res))
start-res)
(begin ;; login failed but have a server record, clean out the record and try again
(debug:print-info 0 *default-log-port* "client:setup, login unsuccessful, will attempt to start server ... start-res=" start-res ", server-dat=" server-dat) ;; had runid. Fixes part of Randy;s ticket 1405717332
- (case *transport-type*
- ((http)(http-transport:close-connections)))
+ (http-transport:close-connections)
(remote-conndat-set! runremote #f) ;; (hash-table-delete! runremote run-id)
(thread-sleep! 1)
(client:setup-http areapath remaining-tries: (- remaining-tries 1))
)))
(begin ;; no server registered
Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -1,6 +1,6 @@
-;;======================================================================
+;get-u;======================================================================
;; Copyright 2006-2012, Matthew Welland.
;;
;; This file is part of Megatest.
;;
;; Megatest is free software: you can redistribute it and/or modify
@@ -2232,95 +2232,10 @@
(debug:print 0 *default-log-port* "Load on " effective-host " is acceptable at effective normalized load of "
effective-normalized-load " continuing."))
(debug:print 0 *default-log-port* "Load on " effective-host ", "
first" could not be retrieved. Giving up and continuing."))))))
-;; DO NOT CALL THIS DIRECTLY. It is called from common:wait-for-normalized-load
-;;
-;; (define (common:wait-for-cpuload maxload-in numcpus-in waitdelay #!key (count 1000) (msg #f)(remote-host #f)(force-maxload #f)(num-tries 5))
-;; (let* ((loadavg (common:get-cpu-load remote-host))
-;; (numcpus (if (<= 1 numcpus-in) ;; not possible to have zero. If we get 1, it's possible that we got the previous default, and we should check again
-;; (common:get-num-cpus remote-host)
-;; numcpus-in))
-;; (maxload (if force-maxload
-;; maxload-in
-;; (if (number? maxload-in)
-;; (max maxload-in 0.5)
-;; 0.5))) ;; so maxload must be greater than 0.5 for now BUG - FIXME?
-;; (first (car loadavg))
-;; (next (cadr loadavg))
-;; (adjmaxload (* maxload (max 1 numcpus))) ;; possible bug where
-;; ;; numcpus (or could be
-;; ;; maxload) is zero,
-;; ;; crude fallback is to
-;; ;; at least use 1
-;; (loadjmp (- first (if (> next (* numcpus 0.7)) ;; could do something with average of first and next?
-;; 0
-;; next))) ;; we will force a conservative calculation any time next is large.
-;; (first-next-avg (/ (+ first next) 2))
-;; ;; add some randomness to the time to break any alignment
-;; ;; where netbatch dumps many jobs to machines simultaneously
-;; (adjwait (min (+ 300 (random 10)) (abs (* (+ (random 10)
-;; (/ (- 1000 count) 10)
-;; waitdelay)
-;; (- first adjmaxload) ))))
-;; (load-jump-limit (configf:lookup-number *configdat* "setup" "load-jump-limit"))
-;; ;; effective load accounts for load jumps, this should elminate all the first-next-avg, adjwait, load-jump-limit
-;; ;; etc.
-;; (effective-load (common:get-intercept first next))
-;; (effective-host (or remote-host "localhost"))
-;; (normalized-effective-load (/ effective-load numcpus))
-;; (will-wait (> normalized-effective-load maxload)))
-;;
-;; ;; let's let the user know once in a long while that load checking
-;; ;; is happening but not constantly report it
-;; #;(if (common:low-noise-print 30 (conc "cpuload" (or remote-host "localhost"))) ;; (> (random 100) 75) ;; about 25% of the time
-;; (debug:print-info 1 *default-log-port* "Checking cpuload on " (or remote-host "localhost") ", maxload: " maxload
-;; ", load: " first ", adjmaxload: " adjmaxload ", loadjmp: " loadjmp))
-;;
-;; (debug:print-info 1 *default-log-port*
-;; "On host: " effective-host
-;; ", effective load: " effective-load
-;; ", numcpus: " numcpus
-;; ", normalized effective load: " normalized-effective-load
-;; )
-;;
-;; (cond
-;; ;; bad data, try again to get the data
-;; ((and (< first 0) ;; this indicates the loadavg data is bad - machine may not be reachable
-;; (> num-tries 0))
-;; (debug:print 0 *default-log-port* "WARNING: received bad data from get-cpu-load " first ", we'll sleep 10s and try " num-tries " more times.")
-;; (thread-sleep! 10)
-;; (common:wait-for-cpuload maxload-in numcpus-in waitdelay
-;; count: count remote-host: remote-host force-maxload: force-maxload num-tries: (- num-tries 1)))
-;; ;; need to wait for load to drop
-;; ((and will-wait ;; (> first adjmaxload)
-;; (> count 0))
-;; (debug:print-info 0 *default-log-port*
-;; "Delaying " 15 ;; adjwait
-;; " seconds due to normalized effective load " normalized-effective-load ;; first
-;; " exceeding max of " adjmaxload
-;; " on server " (or remote-host (get-host-name))
-;; " (normalized load-limit: " maxload ") " (if msg msg ""))
-;; (thread-sleep! 15) ;; adjwait)
-;; (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host))
-;; ((and (> loadjmp (cond
-;; (load-jump-limit load-jump-limit)
-;; ((> numcpus 8)(/ numcpus 2))
-;; ((> numcpus 4)(/ numcpus 1.2))
-;; (else 0.5)))
-;; (> count 0))
-;; (debug:print-info 0 *default-log-port* "waiting " adjwait " seconds due to possible load jump " loadjmp ". "
-;; (if msg msg ""))
-;; (thread-sleep! adjwait)
-;; (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host))
-;; (else
-;; (if (> num-tries 0)
-;; (if (common:low-noise-print 30 (conc (round first) "-load-acceptable-" (or remote-host "localhost")))
-;; (debug:print 0 *default-log-port* "Load on " (or remote-host "localhost") " is acceptable at " first " continuing."))
-;; (debug:print 0 *default-log-port* "Load on " (or remote-host "localhost") ", "first" could not be retrieved. Giving up and continuing."))))))
-;;
(define (get-uname . params)
(let* ((uname-res (process:cmd-run->list (conc "uname " (if (null? params) "-a" (car params)))))
(uname #f))
(if (null? (car uname-res))
"unknown"
@@ -2328,24 +2243,10 @@
;; for reasons I don't understand multiple calls to real-path in parallel threads
;; must be protected by mutexes
;;
(define (common:real-path inpath)
- ;; (process:cmd-run-with-stderr->list "readlink" "-f" inpath)) ;; cmd . params)
- ;; (let-values
- ;; (((inp oup pid) (process "readlink" (list "-f" inpath))))
- ;; (with-input-from-port inp
- ;; (let loop ((inl (read-line))
- ;; (res #f))
- ;; (print "inl=" inl)
- ;; (if (eof-object? inl)
- ;; (begin
- ;; (close-input-port inp)
- ;; (close-output-port oup)
- ;; ;; (process-wait pid)
- ;; res)
- ;; (loop (read-line) inl))))))
(with-input-from-pipe (conc "readlink -f " inpath) read-line))
;;======================================================================
;; D I S K S P A C E
;;======================================================================
@@ -3088,81 +2989,10 @@
((equal? status "KILLREQ") "purple")
((equal? status "RUNNING") "blue")
((equal? status "ABORT") "brown")
(else "black")))
-;; ;;======================================================================
-;; ;; N A N O M S G C L I E N T
-;; ;;======================================================================
-;;
-;;
-;;
-;; (define (common:send-dboard-main-changed)
-;; (let* ((dashboard-ips (mddb:get-dashboards)))
-;; (for-each
-;; (lambda (ipadr)
-;; (let* ((soc (common:open-nm-req (conc "tcp://" ipadr)))
-;; (msg (conc "main " *toppath*))
-;; (res (common:nm-send-receive-timeout soc msg)))
-;; (if (not res) ;; couldn't reach that dashboard - remove it from db
-;; (print "ERROR: couldn't reach dashboard " ipadr))
-;; res))
-;; dashboard-ips)))
-;;
-;;
-;; ;;======================================================================
-;; ;; D A S H B O A R D D B
-;; ;;======================================================================
-;;
-;; (define (mddb:open-db)
-;; (let* ((db (open-database (conc (get-environment-variable "HOME") "/.dashboard.db"))))
-;; (set-busy-handler! db (busy-timeout 10000))
-;; (for-each
-;; (lambda (qry)
-;; (exec (sql db qry)))
-;; (list
-;; "CREATE TABLE IF NOT EXISTS vars (id INTEGER PRIMARY KEY,key TEXT, val TEXT, CONSTRAINT varsconstraint UNIQUE (key));"
-;; "CREATE TABLE IF NOT EXISTS dashboards (
-;; id INTEGER PRIMARY KEY,
-;; pid INTEGER,
-;; username TEXT,
-;; hostname TEXT,
-;; ipaddr TEXT,
-;; portnum INTEGER,
-;; start_time TIMESTAMP DEFAULT (strftime('%s','now')),
-;; CONSTRAINT hostport UNIQUE (hostname,portnum)
-;; );"
-;; ))
-;; db))
-;;
-;; ;; register a dashboard
-;; ;;
-;; (define (mddb:register-dashboard port)
-;; (let* ((pid (current-process-id))
-;; (hostname (get-host-name))
-;; (ipaddr (server:get-best-guess-address hostname))
-;; (username (current-user-name)) ;; (car userinfo)))
-;; (db (mddb:open-db)))
-;; (print "Register monitor, pid: " pid ", hostname: " hostname ", port: " port ", username: " username)
-;; (exec (sql db "INSERT OR REPLACE INTO dashboards (pid,username,hostname,ipaddr,portnum) VALUES (?,?,?,?,?);")
-;; pid username hostname ipaddr port)
-;; (close-database db)))
-;;
-;; ;; unregister a monitor
-;; ;;
-;; (define (mddb:unregister-dashboard host port)
-;; (let* ((db (mddb:open-db)))
-;; (print "Register unregister monitor, host:port=" host ":" port)
-;; (exec (sql db "DELETE FROM dashboards WHERE hostname=? AND portnum=?;") host port)
-;; (close-database db)))
-;;
-;; ;; get registered dashboards
-;; ;;
-;; (define (mddb:get-dashboards)
-;; (let ((db (mddb:open-db)))
-;; (query fetch-column
-;; (sql db "SELECT ipaddr || ':' || portnum FROM dashboards;"))))
;;======================================================================
;; T E S T L A U N C H I N G P E R I T E M W I T H H O S T T Y P E S
;;======================================================================
;;
Index: common_records.scm
==================================================================
--- common_records.scm
+++ common_records.scm
@@ -146,13 +146,14 @@
(if *logging*
(db:log-event (apply conc params))
(apply print params)
)))))
+;; Useful stuff. Do not remove - commented and removed to trim mem usage for now (might make no difference).
;; Brandon's debug printer shortcut (indulge me :)
-(define *BB-process-starttime* (current-milliseconds))
-(define (BB> . in-args)
+#;(define *BB-process-starttime* (current-milliseconds))
+#;(define (BB> . in-args)
(let* ((stack (get-call-chain))
(location "??"))
(for-each
(lambda (frame)
(let* ((this-loc (vector-ref frame 0))
@@ -168,20 +169,20 @@
(list 0 *default-log-port*
(conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off " ") )
in-args)))
(apply debug:print dp-args))))
-(define *BBpp_custom_expanders_list* (make-hash-table))
+#;(define *BBpp_custom_expanders_list* (make-hash-table))
;; register hash tables with BBpp.
-(hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE:
+#;(hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE:
(cons hash-table? hash-table->alist))
;; test name converter
-(define (BBpp_custom_converter arg)
+#;(define (BBpp_custom_converter arg)
(let ((res #f))
(for-each
(lambda (custom-type-name)
(let* ((custom-type-info (hash-table-ref *BBpp_custom_expanders_list* custom-type-name))
(custom-type-test (car custom-type-info))
@@ -189,11 +190,11 @@
(when (and (not res) (custom-type-test arg))
(set! res (custom-type-converter arg)))))
(hash-table-keys *BBpp_custom_expanders_list*))
(if res (BBpp_ res) arg)))
-(define (BBpp_ arg)
+#;(define (BBpp_ arg)
(cond
;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg)))
;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg)))
((hash-table? arg)
(let ((al (hash-table->alist arg)))
@@ -202,11 +203,11 @@
;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
(else (BBpp_custom_converter arg))))
;; Brandon's pretty printer. It expands hashes and custom types in addition to regular pp
-(define (BBpp arg)
+#;(define (BBpp arg)
(pp (BBpp_ arg)))
;(use define-macro)
(define-syntax inspect
(syntax-rules ()
Index: configf.scm
==================================================================
--- configf.scm
+++ configf.scm
@@ -126,17 +126,15 @@
(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 ()
@@ -265,17 +263,10 @@
;;
(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?
Index: dashboard-context-menu.scm
==================================================================
--- dashboard-context-menu.scm
+++ dashboard-context-menu.scm
@@ -308,11 +308,10 @@
(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)
@@ -321,11 +320,10 @@
(begin
(handle-exceptions
exn
(print "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)))
Index: dashboard-tests.scm
==================================================================
--- dashboard-tests.scm
+++ dashboard-tests.scm
@@ -754,13 +754,13 @@
#: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))))
+ (stepname (iup:attribute obj (conc lin ":" 1)))
+ (comment (iup:attribute obj (conc lin ":" 7))))
(case col
-
((7) (print "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))
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -48,11 +48,10 @@
;; (declare (uses dashboard-main))
(declare (uses mt))
(include "common_records.scm")
(include "db_records.scm")
-(include "run_records.scm")
(include "task_records.scm")
(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
(include "vg_records.scm")
@@ -1827,37 +1826,10 @@
(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)
@@ -2305,11 +2277,10 @@
;; 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))
@@ -2471,17 +2442,10 @@
(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"))
@@ -2495,23 +2459,19 @@
(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)
@@ -3034,11 +2994,10 @@
(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)
@@ -3257,26 +3216,13 @@
;; (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)
- )))))
+ testpatt
+ targpatt)))))
;; run times canvas updater
;;
(define (dashboard:run-times-tab-canvas-updater commondat tabdat tab-num)
(let ((cnv (dboard:tabdat-cnv tabdat))
@@ -3291,16 +3237,10 @@
(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")
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -1173,55 +1173,10 @@
(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))
-;; keeping it around for debugging purposes only
-#;(define (open-run-close-no-exception-handling proc idb . params)
- (debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params)
- (print "I don't work anymore. open-run-close-no-exception-handling needs fixing or removing...")
- (exit)
- (if (or *db-write-access*
- (not #t)) ;; was: (member proc * db:all-write-procs *)))
- (let* ((db (cond
- ((pair? idb) (db:dbdat-get-db idb))
- ((sqlite3:database? idb) idb)
- ((not idb) (debug:print-error 0 *default-log-port* "cannot open-run-close with #f anymore"))
- ((procedure? idb) (idb))
- (else (debug:print-error 0 *default-log-port* "cannot open-run-close with #f anymore"))))
- (res #f))
- (set! res (apply proc db params))
- (if (not idb)(sqlite3:finalize! dbstruct))
- (debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling END" )
- res)
- #f))
-
-#;(define (open-run-close-exception-handling proc idb . params)
- (handle-exceptions
- exn
- (let ((sleep-time (random 30))
- (err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
- (case err-status
- ((busy)
- (thread-sleep! sleep-time))
- (else
- (debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable.")
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (debug:print 5 *default-log-port* "exn=" (condition->list exn))
- (debug:print 0 *default-log-port* " status: " ((condition-property-accessor 'sqlite3 'status) exn))
- (print-call-chain (current-error-port))
- (thread-sleep! sleep-time)
- (debug:print-info 0 *default-log-port* "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up")))
- (apply open-run-close-exception-handling proc idb params))
- (apply open-run-close-no-exception-handling proc idb params)))
-
-;; (define open-run-close
-#;(define open-run-close open-run-close-exception-handling)
- ;; open-run-close-no-exception-handling
-;; open-run-close-exception-handling)
-;;)
-
(define db:trigger-list
(list (list "update_runs_trigger" "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs
FOR EACH ROW
BEGIN
UPDATE runs SET last_update=(strftime('%s','now'))
@@ -1661,17 +1616,10 @@
db
"SELECT id,archive_disk_id,disk_path,last_du,last_du_time,creation_time FROM archive_blocks WHERE id=?;"
archive-block-id)
res))))
-;; (define (db:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey)
-;; (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db
-;; (db (db:dbdat-get-db dbdat))
-;; (res '())
-;; (blocks '())) ;; a block is an archive chunck that can be added too if there is space
-;; (sqlite3:for-each-row #f)
-
;;======================================================================
;; L O G G I N G D B
;;======================================================================
(define (open-logging-db)
@@ -3954,25 +3902,10 @@
(print-call-chain (current-error-port))
msg))) ;; crude reply for when things go awry
((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize))))
(else msg))) ;; rpc
-;; ; This is to be the big daddy call NOPE: Replaced by db:set-state-status-and-roll-up-items
-;; ;
-;; define (db:test-set-state-status dbstruct run-id test-id state status msg)
-;; (let ((dbdat (db:get-db dbstruct run-id)))
-;; (if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
-;; (db:general-call dbdat 'set-test-start-time (list test-id)))
-;; ;; (if msg
-;; ;; (db:general-call dbdat 'state-status-msg (list state status msg test-id))
-;; ;; (db:general-call dbdat 'state-status (list state status test-id)))
-;; (db:set-state-status-and-roll-up-items dbstruct run-id test-id #f state status msg)
-;; ;; process the test_data table
-;; (if (and test-id state status (equal? status "AUTO"))
-;; (db:test-data-rollup dbstruct run-id test-id status))
-;; (mt:process-triggers dbstruct run-id test-id state status)))
-
;; state is the priority rollup of all states
;; status is the priority rollup of all completed statesfu
;;
;; if test-name is an integer work off that instead of test-name test-path
;;
@@ -4042,76 +3975,74 @@
(if (and state status (not (member state *common:dont-roll-up-states*)))
(cons status (map dbr:counts-status state-status-counts))
(map dbr:counts-status state-status-counts)))
*common:std-statuses* >))
(non-completes (filter (lambda (x)
- (not (member x (cons "COMPLETED" *common:dont-roll-up-states*))))
- all-curr-states))
- (preq-fails (filter (lambda (x)
- (equal? x "PREQ_FAIL"))
- all-curr-statuses))
+ (not (member x (cons "COMPLETED" *common:dont-roll-up-states*))))
+ all-curr-states))
+ (preq-fails (filter (lambda (x)
+ (equal? x "PREQ_FAIL"))
+ all-curr-statuses))
(num-non-completes (length non-completes))
- (newstate (cond
- ((> running 0) "RUNNING") ;; anything running, call the situation running
- ((> (length preq-fails) 0) "NOT_STARTED")
- ((> bad-not-started 0) "COMPLETED") ;; we have an ugly situation, it is completed in the sense we cannot do more.
- ((> num-non-completes 0) (car non-completes)) ;; (remove (lambda (x)(equal? "COMPLETED" x)) all-curr-states))) ;; only rollup DELETED if all DELETED
- (else (car all-curr-states))))
+ (newstate (cond
+ ((> running 0) "RUNNING") ;; anything running, call the situation running
+ ((> (length preq-fails) 0) "NOT_STARTED")
+ ((> bad-not-started 0) "COMPLETED") ;; we have an ugly situation, it is completed in the sense we cannot do more.
+ ((> num-non-completes 0) (car non-completes)) ;; (remove (lambda (x)(equal? "COMPLETED" x)) all-curr-states))) ;; only rollup DELETED if all DELETED
+ (else (car all-curr-states))))
(newstatus (cond
- ((> (length preq-fails) 0) "PREQ_FAIL")
- ((or (> bad-not-started 0)
- (and (equal? newstate "NOT_STARTED")
- (> num-non-completes 0)))
- "STARTED")
- (else (car all-curr-statuses)))))
- (debug:print-info 2 *default-log-port*
- "\n--> probe db:set-state-status-and-roll-up-items: "
- "\n--> state-status-counts: "(map dbr:counts->alist state-status-counts)
- "\n--> running: "running
- "\n--> bad-not-started: "bad-not-started
- "\n--> non-non-completes: "num-non-completes
- "\n--> non-completes: "non-completes
- "\n--> all-curr-states: "all-curr-states
- "\n--> all-curr-statuses: "all-curr-statuses
- "\n--> newstate "newstate
- "\n--> newstatus "newstatus
- "\n\n")
-
- ;; NB// Pass the db so it is part of the transaction
- (list newstate newstatus)))
+ ((> (length preq-fails) 0) "PREQ_FAIL")
+ ((or (> bad-not-started 0)
+ (and (equal? newstate "NOT_STARTED")
+ (> num-non-completes 0)))
+ "STARTED")
+ (else (car all-curr-statuses)))))
+ (debug:print-info 2 *default-log-port*
+ "\n--> probe db:set-state-status-and-roll-up-items: "
+ "\n--> state-status-counts: "(map dbr:counts->alist state-status-counts)
+ "\n--> running: "running
+ "\n--> bad-not-started: "bad-not-started
+ "\n--> non-non-completes: "num-non-completes
+ "\n--> non-completes: "non-completes
+ "\n--> all-curr-states: "all-curr-states
+ "\n--> all-curr-statuses: "all-curr-statuses
+ "\n--> newstate "newstate
+ "\n--> newstatus "newstatus
+ "\n\n")
+
+ ;; NB// Pass the db so it is part of the transaction
+ (list newstate newstatus)))
(define (db:set-state-status-and-roll-up-run dbstruct run-id curr-state curr-status)
- (mutex-lock! *db-transaction-mutex*)
- (db:with-db
- dbstruct #f #f
- (lambda (db)
- (let ((tr-res
- (sqlite3:with-transaction
- db
- (lambda ()
- (let* ((state-status-counts (db:get-all-state-status-counts-for-run dbstruct run-id))
- (state-stauses (db:roll-up-rules state-status-counts #f #f ))
- (newstate (car state-stauses))
- (newstatus (cadr state-stauses)))
- (if (or (not (eq? newstate curr-state)) (not (eq? newstatus curr-status)))
- (db:set-run-state-status dbstruct run-id newstate newstatus )))))))
- (mutex-unlock! *db-transaction-mutex*)
- tr-res))))
-
+ (mutex-lock! *db-transaction-mutex*)
+ (db:with-db
+ dbstruct #f #f
+ (lambda (db)
+ (let ((tr-res
+ (sqlite3:with-transaction
+ db
+ (lambda ()
+ (let* ((state-status-counts (db:get-all-state-status-counts-for-run dbstruct run-id))
+ (state-stauses (db:roll-up-rules state-status-counts #f #f ))
+ (newstate (car state-stauses))
+ (newstatus (cadr state-stauses)))
+ (if (or (not (eq? newstate curr-state)) (not (eq? newstatus curr-status)))
+ (db:set-run-state-status dbstruct run-id newstate newstatus )))))))
+ (mutex-unlock! *db-transaction-mutex*)
+ tr-res))))
(define (db:get-all-state-status-counts-for-run dbstruct run-id)
- (let* ((test-count-recs (db:with-db
- dbstruct #f #f
- (lambda (db)
- (sqlite3:map-row
- (lambda (state status count)
- (make-dbr:counts state: state status: status count: count))
- db
- "SELECT state,status,count(id) FROM tests WHERE run_id=? GROUP BY state,status;"
- run-id )))))
- test-count-recs))
-
+ (let* ((test-count-recs (db:with-db
+ dbstruct #f #f
+ (lambda (db)
+ (sqlite3:map-row
+ (lambda (state status count)
+ (make-dbr:counts state: state status: status count: count))
+ db
+ "SELECT state,status,count(id) FROM tests WHERE run_id=? GROUP BY state,status;"
+ run-id )))))
+ test-count-recs))
;; BBnote: db:get-all-state-status-counts-for-test returns dbr:counts object aggregating state and status of items of a given test, *not including rollup state/status*
;;
;; NOTE: This is called within a transaction
;;
@@ -4149,24 +4080,10 @@
(unrelated-rec-list
(filter nonmatch-countrec-lambda other-items-count-recs)))
(cons updated-count-rec unrelated-rec-list)))
-;; (define (db:get-all-item-states db run-id test-name)
-;; (sqlite3:map-row
-;; (lambda (a) a)
-;; db
-;; "SELECT DISTINCT state FROM tests WHERE item_path != '' AND state != 'DELETED' AND run_id=? AND testname=?"
-;; run-id test-name))
-;;
-;; (define (db:get-all-item-statuses db run-id test-name)
-;; (sqlite3:map-row
-;; (lambda (a) a)
-;; db
-;; "SELECT DISTINCT status FROM tests WHERE item_path != '' AND state != 'DELETED' AND state='COMPLETED' AND run_id=? AND testname=?"
-;; run-id test-name))
-
(define (db:test-get-logfile-info dbstruct run-id test-name)
(db:with-db
dbstruct
run-id
#f
Index: db_records.scm
==================================================================
--- db_records.scm
+++ db_records.scm
@@ -106,13 +106,20 @@
(define-inline (db:test-get-archived vec) (vector-ref vec 17))
(define-inline (db:test-get-last_update vec) (vector-ref vec 18))
;; (define-inline (db:test-get-pass_count vec) (vector-ref vec 15))
;; (define-inline (db:test-get-fail_count vec) (vector-ref vec 16))
+
(define-inline (db:test-get-fullname vec)
(conc (db:test-get-testname vec) "/" (db:test-get-item-path vec)))
+(define-inline (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) ")"))))
+
;; 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-inline (db:test-get-first_err vec) (printable (vector-ref vec 15)))
@@ -240,20 +247,5 @@
(define-inline (tdb:step-stable-set-stepname! vec val)(vector-set! vec 0 val))
(define-inline (tdb:step-stable-set-start! vec val)(vector-set! vec 1 val))
(define-inline (tdb:step-stable-set-end! vec val)(vector-set! vec 2 val))
(define-inline (tdb:step-stable-set-status! vec val)(vector-set! vec 3 val))
(define-inline (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-inline (cdb:packet-get-client-sig vec) (vector-ref vec 0))
-(define-inline (cdb:packet-get-qtype vec) (vector-ref vec 1))
-(define-inline (cdb:packet-get-immediate vec) (vector-ref vec 2))
-(define-inline (cdb:packet-get-query-sig vec) (vector-ref vec 3))
-(define-inline (cdb:packet-get-params vec) (vector-ref vec 4))
-(define-inline (cdb:packet-get-qtime vec) (vector-ref vec 5))
-(define-inline (cdb:packet-set-client-sig! vec val)(vector-set! vec 0 val))
-(define-inline (cdb:packet-set-qtype! vec val)(vector-set! vec 1 val))
-(define-inline (cdb:packet-set-immediate! vec val)(vector-set! vec 2 val))
-(define-inline (cdb:packet-set-query-sig! vec val)(vector-set! vec 3 val))
-(define-inline (cdb:packet-set-params! vec val)(vector-set! vec 4 val))
-(define-inline (cdb:packet-set-qtime! vec val)(vector-set! vec 5 val))
Index: dcommon.scm
==================================================================
--- dcommon.scm
+++ dcommon.scm
@@ -151,215 +151,10 @@
(iup:attribute-set! mtrx cell-name new-val) ;; was col-name
#t) ;; need a re-draw
prev-changed)))
-;; TO-DO
-;; 1. Make "data" hash-table hierarchial store of all displayed data
-;; 2. Update synchash to understand "get-runs", "get-tests" etc.
-;; 3. Add extraction of filters to synchash calls
-;;
-;; NOTE: Used in newdashboard
-;;
-;; Mode is 'full or 'incremental for full refresh or incremental refresh
-;; (define (dcommon:run-update keys data runname keypatts testpatt states statuses mode window-id)
-;; (let* (;; count and offset => #f so not used
-;; ;; the synchash calls modify the "data" hash
-;; (changed #f)
-;; (get-runs-sig (conc (client:get-signature) " get-runs"))
-;; (get-tests-sig (conc (client:get-signature) " get-tests"))
-;; (get-details-sig (conc (client:get-signature) " get-test-details"))
-;;
-;; ;; test-ids to get and display are indexed on window-id in curr-test-ids hash
-;; (test-ids (hash-table-values (dboard:tabdat-curr-test-ids data)))
-;; ;; run-id is #f in next line to send the query to server 0
-;; (run-changes (synchash:client-get 'db:get-runs get-runs-sig (length keypatts) data #f runname #f #f keypatts))
-;; (tests-detail-changes (if (not (null? test-ids))
-;; (synchash:client-get 'db:get-test-info-by-ids get-details-sig 0 data #f test-ids)
-;; '()))
-;;
-;; ;; Now can calculate the run-ids
-;; (run-hash (hash-table-ref/default data get-runs-sig #f))
-;; (run-ids (if run-hash (filter number? (hash-table-keys run-hash)) '()))
-;;
-;; (all-test-changes (let ((res (make-hash-table)))
-;; (for-each (lambda (run-id)
-;; (if (> run-id 0)
-;; (hash-table-set! res run-id (synchash:client-get 'db:get-tests-for-run-mindata get-tests-sig 0 data run-id 1 testpatt states statuses #f))))
-;; run-ids)
-;; res))
-;; (runs-hash (hash-table-ref/default data get-runs-sig #f))
-;; (header (hash-table-ref/default runs-hash "header" #f))
-;; (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 header "event_time"))
-;; (time-b (db:get-value-by-header record-b header "event_time")))
-;; (> time-a time-b)))
-;; ))
-;; (runid-to-col (hash-table-ref *cachedata* "runid-to-col"))
-;; (testname-to-row (hash-table-ref *cachedata* "testname-to-row"))
-;; (colnum 1)
-;; (rownum 0)
-;; (cellname (conc rownum ":" colnum))) ;; rownum = 0 is the header
-;; ;; (debug:print 0 *default-log-port* "test-ids " test-ids ", tests-detail-changes " tests-detail-changes)
-;;
-;; ;; tests related stuff
-;; ;; (all-testnames (delete-duplicates (map db:test-get-testname test-changes))))
-;;
-;; ;; Given a run-id and testname/item_path calculate a cell R:C
-;;
-;; ;; NOTE: Also build the test tree browser and look up table
-;; ;;
-;; ;; Each run is unique on its keys and runname or run-id, store in hash on colnum
-;; (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 header key))
-;; keys))
-;; (run-name (db:get-value-by-header run-record header "runname"))
-;; (col-name (conc (string-intersperse key-vals "\n") "\n" run-name))
-;; (run-path (append key-vals (list run-name))))
-;; (hash-table-set! (dboard:tabdat-run-keys data) run-id run-path)
-;; ;; modify cell - but only if changed
-;; (set! changed (dcommon:modifiy-if-different (dboard:tabdat-runs-matrix data) cellname col-name changed))
-;; (hash-table-set! runid-to-col run-id (list colnum run-record))
-;; ;; Here we update the tests treebox and tree keys
-;; (tree:add-node (dboard:tabdat-tests-tree data) "Runs" (append key-vals (list run-name))
-;; userdata: (conc "run-id: " run-id))
-;; (set! colnum (+ colnum 1))))
-;; run-ids)
-;;
-;; ;; Scan all tests to be displayed and organise all the test names, respecting what is in the hash table
-;; ;; Do this analysis in the order of the run-ids, the most recent run wins
-;; (for-each (lambda (run-id)
-;; (let* ((run-path (hash-table-ref (dboard:tabdat-run-keys data) run-id))
-;; (test-changes (hash-table-ref all-test-changes run-id))
-;; (new-test-dat (car test-changes))
-;; (removed-tests (cadr test-changes))
-;; (tests (sort (map cadr (filter (lambda (testrec)
-;; (eq? run-id (db:mintest-get-run_id (cadr testrec))))
-;; new-test-dat))
-;; (lambda (a b)
-;; (let ((time-a (db:mintest-get-event_time a))
-;; (time-b (db:mintest-get-event_time b)))
-;; (> time-a time-b)))))
-;; ;; test-changes is a list of (( id record ) ... )
-;; ;; Get list of test names sorted by time, remove tests
-;; (test-names (delete-duplicates (map (lambda (t)
-;; (let ((i (db:mintest-get-item_path t))
-;; (n (db:mintest-get-testname t)))
-;; (if (string=? i "")
-;; (conc " " i)
-;; n)))
-;; tests)))
-;; (colnum (car (hash-table-ref runid-to-col run-id))))
-;; ;; for each test name get the slot if it exists and fill in the cell
-;; ;; or take the next slot and fill in the cell, deal with items in the
-;; ;; run view panel? The run view panel can have a tree selector for
-;; ;; browsing the tests/items
-;;
-;; ;; SWITCH THIS TO USING CHANGED TESTS ONLY
-;; (for-each (lambda (test)
-;; (let* ((test-id (db:mintest-get-id test))
-;; (state (db:mintest-get-state test))
-;; (status (db:mintest-get-status test))
-;; (testname (db:mintest-get-testname test))
-;; (itempath (db:mintest-get-item_path test))
-;; (fullname (conc testname "/" itempath))
-;; (dispname (if (string=? itempath "") testname (conc " " itempath)))
-;; (rownum (hash-table-ref/default testname-to-row fullname #f))
-;; (test-path (append run-path (if (equal? itempath "")
-;; (list testname)
-;; (list testname itempath))))
-;; (tb (dboard:tabdat-tests-tree data)))
-;; (print "INFONOTE: run-path: " run-path)
-;; (tree:add-node (dboard:tabdat-tests-tree data) "Runs"
-;; test-path
-;; userdata: (conc "test-id: " test-id))
-;; (let ((node-num (tree:find-node tb (cons "Runs" test-path)))
-;; (color (car (gutils:get-color-for-state-status state status))))
-;; (debug:print 0 *default-log-port* "node-num: " node-num ", color: " color)
-;;
-;; (set! changed (dcommon:modifiy-if-different
-;; tb
-;; (conc "COLOR" node-num)
-;; color changed))
-;;
-;; ;; (iup:attribute-set! tb (conc "COLOR" node-num) color)
-;; )
-;; (hash-table-set! (dboard:tabdat-path-test-ids data) test-path test-id)
-;; (if (not rownum)
-;; (let ((rownums (hash-table-values testname-to-row)))
-;; (set! rownum (if (null? rownums)
-;; 1
-;; (+ 1 (common:max rownums))))
-;; (hash-table-set! testname-to-row fullname rownum)
-;; ;; create the label
-;; (set! changed (dcommon:modifiy-if-different
-;; (dboard:tabdat-runs-matrix data)
-;; (conc rownum ":" 0)
-;; dispname
-;; changed))
-;; ;; (iup:attribute-set! (dboard:tabdat-runs-matrix data)
-;; ;; (conc rownum ":" 0) dispname)
-;; ))
-;; ;; set the cell text and color
-;; ;; (debug:print 2 *default-log-port* "rownum:colnum=" rownum ":" colnum ", state=" status)
-;; (set! changed (dcommon:modifiy-if-different
-;; (dboard:tabdat-runs-matrix data)
-;; (conc rownum ":" colnum)
-;; (if (member state '("ARCHIVED" "COMPLETED"))
-;; status
-;; state)
-;; changed))
-;; ;; (iup:attribute-set! (dboard:tabdat-runs-matrix data)
-;; ;; (conc rownum ":" colnum)
-;; ;; (if (member state '("ARCHIVED" "COMPLETED"))
-;; ;; status
-;; ;; state))
-;; (set! changed (dcommon:modifiy-if-different
-;; (dboard:tabdat-runs-matrix data)
-;; (conc "BGCOLOR" rownum ":" colnum)
-;; (car (gutils:get-color-for-state-status state status))
-;; changed))
-;; ;; (iup:attribute-set! (dboard:tabdat-runs-matrix data)
-;; ;; (conc "BGCOLOR" rownum ":" colnum)
-;; ;; (car (gutils:get-color-for-state-status state status)))
-;; ))
-;; tests)))
-;; run-ids)
-;;
-;; (let ((updater (hash-table-ref/default (dboard:commondat-updaters commondat) window-id #f)))
-;; (if updater (updater (hash-table-ref/default data get-details-sig #f))))
-;;
-;; (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)
- (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))))))
- (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: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))
@@ -1215,36 +1010,10 @@
#:size "x30" ;; was 10x30
#:multiline "YES")))
(set! test-patterns-textbox tb)
(dboard:tabdat-test-patterns-textbox-set! tabdat tb)
tb))
-;; (iup:frame
-;; #:title "Target"
-;; ;; Target selectors
-;; (apply iup:hbox
-;; (let* ((dat (dashboard:update-target-selector tabdat action-proc: update-keyvals))
-;; (key-lb (car dat))
-;; (combos (cadr dat)))
-;; combos)))
- ;; (iup:hbox
- ;; ;; Text box for STATES
- ;; (iup:frame
- ;; #:title "States"
- ;; (dashboard:text-list-toggle-box
- ;; ;; Move these definitions to common and find the other useages and replace!
- ;; (map cadr *common:std-states*) ;; '("COMPLETED" "RUNNING" "STUCK" "INCOMPLETE" "LAUNCHED" "REMOTEHOSTSTART" "KILLED")
- ;; (lambda (all)
- ;; (dboard:tabdat-states-set! tabdat all)
- ;; (dashboard:update-run-command tabdat))))
- ;; ;; Text box for STATES
- ;; (iup:frame
- ;; #:title "Statuses"
- ;; (dashboard:text-list-toggle-box
- ;; (map cadr *common:std-statuses*) ;; '("PASS" "FAIL" "n/a" "CHECK" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD")
- ;; (lambda (all)
- ;; (dboard:tabdat-statuses-set! tabdat all)
- ;; (dashboard:update-run-command tabdat)))))
))
(define (dcommon:command-tests-tasks-canvas tabdat test-records sorted-testnames tests-draw-state)
(iup:frame
#:title "Tests and Tasks"
Index: ezsteps.scm
==================================================================
--- ezsteps.scm
+++ ezsteps.scm
@@ -25,30 +25,23 @@
(declare (unit ezsteps))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
-;; (declare (uses sdb))
-;; (declare (uses filedb))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
-
-;;(rmt:get-test-info-by-id run-id test-id) -> testdat
-
+;; (rmt:get-test-info-by-id run-id test-id) -> testdat
+;;
;; TODO: deprecate me in favor of ezsteps.scm
;;
(define (launch:runstep ezstep run-id test-id exit-info m tal testconfig all-steps-dat)
(let* ((stepname (car ezstep)) ;; do stuff to run the step
(stepinfo (cadr ezstep))
- ;; (let ((info (cadr ezstep)))
- ;; (if (proc? info) "" info)))
- ;; (stepproc (let ((info (cadr ezstep)))
- ;; (if (proc? info) info #f)))
(stepparts (string-match (regexp "^(\\{([^\\}\\{]*)\\}\\s*|)(.*)$") stepinfo))
(stepparams (if (and (list? stepparts)
(> (length stepparts) 1))
(list-ref stepparts 2)
#f)) ;; for future use, {VAR=1,2,3}, run step for each
DELETED fdb_records.scm
Index: fdb_records.scm
==================================================================
--- fdb_records.scm
+++ /dev/null
@@ -1,36 +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 .
-
-;; Single record for managing a filedb
-;; make-vector-record "Filedb record" filedb fdb db dbpath pathcache idcache partcache
-;; Filedb record
-(define (make-filedb:fdb)(make-vector 5))
-(define-inline (filedb:fdb-get-db vec) (vector-ref vec 0))
-(define-inline (filedb:fdb-get-dbpath vec) (vector-ref vec 1))
-(define-inline (filedb:fdb-get-pathcache vec) (vector-ref vec 2))
-(define-inline (filedb:fdb-get-idcache vec) (vector-ref vec 3))
-(define-inline (filedb:fdb-get-partcache vec) (vector-ref vec 4))
-(define-inline (filedb:fdb-set-db! vec val)(vector-set! vec 0 val))
-(define-inline (filedb:fdb-set-dbpath! vec val)(vector-set! vec 1 val))
-(define-inline (filedb:fdb-set-pathcache! vec val)(vector-set! vec 2 val))
-(define-inline (filedb:fdb-set-idcache! vec val)(vector-set! vec 3 val))
-(define-inline (filedb:fdb-set-partcache! vec val)(vector-set! vec 4 val))
-
-;; children records, should have use something other than "child"
-(define-inline (filedb:child-get-id vec) (vector-ref vec 0))
-(define-inline (filedb:child-get-path vec) (vector-ref vec 1))
-(define-inline (filedb:child-get-parent_id vec)(vector-ref vec 2))
DELETED filedb.scm
Index: filedb.scm
==================================================================
--- filedb.scm
+++ /dev/null
@@ -1,255 +0,0 @@
-;; Copyright 2006-2011, 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 .
-;;
-
-;; (require-extension synch sqlite3 posix srfi-13 srfi-1 utils regex)
-(use sqlite3 srfi-1 posix regex srfi-69 srfi-13 posix-extras)
-(import (prefix sqlite3 sqlite3:))
-
-(declare (unit filedb))
-
-(include "fdb_records.scm")
-;; (include "settings.scm")
-
-(define (filedb:open-db dbpath)
- (let* ((fdb (make-filedb:fdb))
- (dbexists (common:file-exists? dbpath))
- (db (sqlite3:open-database dbpath)))
- (filedb:fdb-set-db! fdb db)
- (filedb:fdb-set-dbpath! fdb dbpath)
- (filedb:fdb-set-pathcache! fdb (make-hash-table))
- (filedb:fdb-set-idcache! fdb (make-hash-table))
- (filedb:fdb-set-partcache! fdb (make-hash-table))
- (sqlite3:set-busy-handler! db (make-busy-timeout 136000))
- (if (not dbexists)
- (begin
- (sqlite3:execute db "PRAGMA synchronous = OFF;")
- (sqlite3:execute db "CREATE TABLE names (id INTEGER PRIMARY KEY,name TEST);") ;; for future use - change path in paths table to path_id
- (sqlite3:execute db "CREATE INDEX name_index ON names (name);")
- ;; NB// We store a useful subset of file attributes but do not attempt to store all
- (sqlite3:execute db "CREATE TABLE paths (id INTEGER PRIMARY KEY,
- path TEXT,
- parent_id INTEGER,
- mode INTEGER DEFAULT -1,
- uid INTEGER DEFAULT -1,
- gid INTEGER DEFAULT -1,
- size INTEGER DEFAULT -1,
- mtime INTEGER DEFAULT -1);")
- (sqlite3:execute db "CREATE INDEX path_index ON paths (path,parent_id);")
- (sqlite3:execute db "CREATE TABLE bases (id INTEGER PRIMARY KEY,base TEXT, updated TIMESTAMP);")))
- ;; close the sqlite3 db and open it as needed
- (filedb:finalize-db! fdb)
- (filedb:fdb-set-db! fdb #f)
- fdb))
-
-(define (filedb:reopen-db fdb)
- (let ((db (sqlite3:open-database (filedb:fdb-get-dbpath fdb))))
- (filedb:fdb-set-db! fdb db)
- (sqlite3:set-busy-handler! db (make-busy-timeout 136000))))
-
-(define (filedb:finalize-db! fdb)
- (sqlite3:finalize! (filedb:fdb-get-db fdb)))
-
-(define (filedb:get-current-time-string)
- (string-chomp (time->string (seconds->local-time (current-seconds)))))
-
-(define (filedb:get-base-id db path)
- (let ((stmt (sqlite3:prepare db "SELECT id FROM bases WHERE base=?;"))
- (id-num #f))
- (sqlite3:for-each-row
- (lambda (num) (set! id-num num)) stmt path)
- (sqlite3:finalize! stmt)
- id-num))
-
-(define (filedb:get-path-id db path parent)
- (let ((stmt (sqlite3:prepare db "SELECT id FROM paths WHERE path=? AND parent_id=?;"))
- (id-num #f))
- (sqlite3:for-each-row
- (lambda (num) (set! id-num num)) stmt path parent)
- (sqlite3:finalize! stmt)
- id-num))
-
-(define (filedb:add-base db path)
- (let ((existing (filedb:get-base-id db path)))
- (if existing #f
- (begin
- (sqlite3:execute db "INSERT INTO bases (base,updated) VALUES (?,?);" path (filedb:get-current-time-string))))))
-
-;; index value field notes
-;; 0 inode number st_ino
-;; 1 mode st_mode bitfield combining file permissions and file type
-;; 2 number of hard links st_nlink
-;; 3 UID of owner st_uid as with file-owner
-;; 4 GID of owner st_gid
-;; 5 size st_size as with file-size
-;; 6 access time st_atime as with file-access-time
-;; 7 change time st_ctime as with file-change-time
-;; 8 modification time st_mtime as with file-modification-time
-;; 9 parent device ID st_dev ID of device on which this file resides
-;; 10 device ID st_rdev device ID for special files (i.e. the raw major/minor number)
-;; 11 block size st_blksize
-;; 12 number of blocks allocated st_blocks
-
-(define (filedb:add-path-stat db path parent statinfo)
- (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id,mode,uid,gid,size,mtime) VALUES (?,?,?,?,?,?,?);")))
- (sqlite3:execute stmt
- path
- parent
- (vector-ref statinfo 1) ;; mode
- (vector-ref statinfo 3) ;; uid
- (vector-ref statinfo 4) ;; gid
- (vector-ref statinfo 5) ;; size
- (vector-ref statinfo 8) ;; mtime
- )
- (sqlite3:finalize! stmt))) ;; (filedb:get-current-time-string))))
-
-(define (filedb:add-path db path parent)
- (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id) VALUES (?,?);")))
- (sqlite3:execute stmt path parent)
- (sqlite3:finalize! stmt)))
-
-(define (filedb:register-path fdb path #!key (save-stat #f))
- (let* ((db (filedb:fdb-get-db fdb))
- (pathcache (filedb:fdb-get-pathcache fdb))
- (stat (if save-stat (file-stat path #t)))
- (id (hash-table-ref/default pathcache path #f)))
- (if (not db)(filedb:reopen-db fdb))
- (if id id
- (let ((plist (string-split path "/")))
- (let loop ((head (car plist))
- (tail (cdr plist))
- (parent 0))
- (let ((id (filedb:get-path-id db head parent))
- (done (null? tail)))
- (if id ;; we'll have a id if the path is already registered
- (if done
- (begin
- (hash-table-set! pathcache path id)
- id) ;; return the last path id for a result
- (loop (car tail)(cdr tail) id))
- (begin ;; add the path and then repeat the loop with the same data
- (if save-stat
- (filedb:add-path-stat db head parent stat)
- (filedb:add-path db head parent))
- (loop head tail parent)))))))))
-
-(define (filedb:update-recursively fdb path #!key (save-stat #f))
- (let ((p (open-input-pipe (string-append "find -L " path)))) ;; (resolve-pathname path)))) ;; (string-append "find " path))))
- (print "processed 0 files...")
- (let loop ((l (read-line p))
- (lc 0)) ;; line count
- (if (eof-object? l)
- (begin
- (print " " lc " files")
- (close-input-port p))
- (begin
- (filedb:register-path fdb l save-stat: save-stat) ;; (get-real-path l)) ;; don't like losing the original path info
- (if (= (modulo lc 100) 0)
- (print " " lc " files"))
- (loop (read-line p)(+ lc 1)))))))
-
-(define (filedb:update fdb path #!key (save-stat #f))
- ;; first get the realpath and add it to the bases table
- (let ((real-path path) ;; (filedb:get-real-path path))
- (db (filedb:fdb-get-db fdb)))
- (filedb:add-base db real-path)
- (filedb:update-recursively fdb path save-stat: save-stat)))
-
-;; not used and broken
-;;
-(define (filedb:get-real-path path)
- (let* ((p (open-input-pipe (string-append real-path " " (regexp-escape path))))
- (pth (read-line p)))
- (if (eof-object? pth) path
- (begin
- (close-input-port p)
- pth))))
-
-(define (filedb:drop-base fdb path)
- (print "Sorry, I don't do anything yet"))
-
-(define (filedb:find-all fdb pattern action)
- (let* ((db (filedb:fdb-get-db fdb))
- (stmt (sqlite3:prepare db "SELECT id FROM paths WHERE path like ?;"))
- (result '()))
- (sqlite3:for-each-row
- (lambda (num)
- (action num)
- (set! result (cons num result))) stmt pattern)
- (sqlite3:finalize! stmt)
- result))
-
-(define (filedb:get-path-record fdb id)
- (let* ((db (filedb:fdb-get-db fdb))
- (partcache (filedb:fdb-get-partcache fdb))
- (dat (hash-table-ref/default partcache id #f)))
- (if dat dat
- (let ((stmt (sqlite3:prepare db "SELECT path,parent_id FROM paths WHERE id=?;"))
- (result #f))
- (sqlite3:for-each-row
- (lambda (path parent_id)(set! result (list path parent_id))) stmt id)
- (hash-table-set! partcache id result)
- (sqlite3:finalize! stmt)
- result))))
-
-(define (filedb:get-children fdb parent-id)
- (let* ((db (filedb:fdb-get-db fdb))
- (res '()))
- (sqlite3:for-each-row
- (lambda (id path parent-id)
- (set! res (cons (vector id path parent-id) res)))
- db "SELECT id,path,parent_id FROM paths WHERE parent_id=?;"
- parent-id)
- res))
-
-;; retrieve all that have children and those without
-;; children that match patt
-(define (filedb:get-children-patt fdb parent-id search-patt)
- (let* ((db (filedb:fdb-get-db fdb))
- (res '()))
- ;; first get the children that have no children
- (sqlite3:for-each-row
- (lambda (id path parent-id)
- (set! res (cons (vector id path parent-id) res)))
- db "SELECT id,path,parent_id FROM paths WHERE parent_id=? AND
- (id IN (SELECT parent_id FROM paths) OR path LIKE ?);"
- parent-id search-patt)
- res))
-
-(define (filedb:get-path fdb id)
- (let* ((db (filedb:fdb-get-db fdb))
- (idcache (filedb:fdb-get-idcache fdb))
- (path (hash-table-ref/default idcache id #f)))
- (if (not db)(filedb:reopen-db fdb))
- (if path path
- (let loop ((curr-id id)
- (path ""))
- (let ((path-record (filedb:get-path-record fdb curr-id)))
- (if (not path-record) #f ;; this id has no path
- (let* ((parent-id (list-ref path-record 1))
- (pname (list-ref path-record 0))
- (newpath (string-append "/" pname path)))
- (if (= parent-id 0) ;; fields 0=path, 1=parent. root parent=0
- (begin
- (hash-table-set! idcache id newpath)
- newpath)
- (loop parent-id newpath)))))))))
-
-(define (filedb:search db pattern)
- (let ((action (lambda (id)(print (filedb:get-path db id)))))
- (filedb:find-all db pattern action)))
-
DELETED fs-transport.scm
Index: fs-transport.scm
==================================================================
--- fs-transport.scm
+++ /dev/null
@@ -1,52 +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 .
-
-(require-extension (srfi 18) extras tcp s11n)
-
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)
-(import (prefix sqlite3 sqlite3:))
-
-(use spiffy uri-common intarweb http-client spiffy-request-vars)
-
-(tcp-buffer-size 2048)
-
-(declare (unit fs-transport))
-
-(declare (uses common))
-(declare (uses db))
-(declare (uses tests))
-(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
-
-(include "common_records.scm")
-(include "db_records.scm")
-
-
-;;======================================================================
-;; F S T R A N S P O R T S E R V E R
-;;======================================================================
-
-;; There is no "server" per se but a convience routine to make it non
-;; necessary to be reopening the db over and over again.
-;;
-
-(define (fs:process-queue-item packet)
- (if (not *dbstruct-db*) ;; we will require that (setup-for-run) has already been called
- (set! *dbstruct-db* (db:setup-db)))
- (debug:print-info 11 *default-log-port* "fs:process-queue-item called with packet=" packet)
- (db:process-queue-item *dbstruct-db* packet))
-
DELETED ftail.scm
Index: ftail.scm
==================================================================
--- ftail.scm
+++ /dev/null
@@ -1,108 +0,0 @@
-;;======================================================================
-;; Copyright 2017, Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see .
-
-;;======================================================================
-
-(declare (unit ftail))
-
-(module ftail
- (
- open-tail-db
- tail-write
- tail-get-fid
- file-tail
- )
-
-(import scheme chicken data-structures extras)
-(use (prefix sqlite3 sqlite3:) posix typed-records)
-
-(define (open-tail-db )
- (let* ((basedir (create-directory (conc "/tmp/" (current-user-name))))
- (dbpath (conc basedir "/megatest_logs.db"))
- (dbexists (file-exists? dbpath))
- (db (sqlite3:open-database dbpath))
- (handler (sqlite3:make-busy-timeout 136000)))
- (sqlite3:set-busy-handler! db handler)
- (sqlite3:execute db "PRAGMA synchronous = 0;")
- (if (not dbexists)
- (begin
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_files (id INTEGER PRIMARY KEY,filename TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_data (id INTEGER PRIMARY KEY,fid INTEGER,line TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));")
- ))
- db))
-
-(define (tail-write db fid lines)
- (sqlite3:with-transaction
- db
- (lambda ()
- (for-each
- (lambda (line)
- (sqlite3:execute db "INSERT INTO log_data (fid,line) VALUES (?,?);" fid line))
- lines))))
-
-(define (tail-get-fid db fname)
- (let ((fid (handle-exceptions
- exn
- #f
- (sqlite3:first-result db "SELECT id FROM log_files WHERE filename=?;" fname))))
- (if fid
- fid
- (begin
- (sqlite3:execute db "INSERT INTO log_files (filename) VALUES (?);" fname)
- (tail-get-fid db fname)))))
-
-(define (file-tail fname #!key (db-in #f))
- (let* ((inp (open-input-file fname))
- (db (or db-in (open-tail-db)))
- (fid (tail-get-fid db fname)))
- (let loop ((inl (read-line inp))
- (lines '())
- (lastwr (current-seconds)))
- (if (eof-object? inl)
- (let ((timed-out (> (- (current-seconds) lastwr) 60)))
- (if timed-out (tail-write db fid (reverse lines)))
- (sleep 1)
- (if timed-out
- (loop (read-line inp) '() (current-seconds))
- (loop (read-line inp) lines lastwr)))
- (let* ((savelines (> (length lines) 19)))
- ;; (print inl)
- (if savelines (tail-write db fid (reverse lines)))
- (loop (read-line inp)
- (if savelines
- '()
- (cons inl lines))
- (if savelines
- (current-seconds)
- lastwr)))))))
-
-;; offset -20 means get last 20 lines
-;;
-(define (tail-get-lines db fid offset count)
- (if (> offset 0)
- (sqlite3:map-row (lambda (id line)
- (vector id line))
- db
- "SELECT id,line FROM log_data WHERE fid=? OFFSET ? LIMIT ?;" fid offset count)
- (reverse ;; get N from the end
- (sqlite3:map-row (lambda (id line)
- (vector id line))
- db
- "SELECT id,line FROM log_data WHERE fid=? ORDER BY id DESC LIMIT ?;" fid (abs offset)))))
-
-)
Index: index-tree.scm
==================================================================
--- index-tree.scm
+++ index-tree.scm
@@ -34,11 +34,10 @@
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
-(include "test_records.scm")
;; Populate the links tree with index.html files
;;
;; - start from most recent tests and work towards oldest -OR-
;; start from deepest hierarchy and work way up
DELETED lock-queue.scm
Index: lock-queue.scm
==================================================================
--- lock-queue.scm
+++ /dev/null
@@ -1,253 +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 (prefix sqlite3 sqlite3:) srfi-18)
-
-(declare (unit lock-queue))
-(declare (uses common))
-(declare (uses tasks))
-
-;;======================================================================
-;; attempt to prevent overlapping updates of rollup files by queueing
-;; update requests in an sqlite db
-;;======================================================================
-
-;;======================================================================
-;; db record,
-;;======================================================================
-
-(define (make-lock-queue:db-dat)(make-vector 3))
-(define-inline (lock-queue:db-dat-get-db vec) (vector-ref vec 0))
-(define-inline (lock-queue:db-dat-get-path vec) (vector-ref vec 1))
-(define-inline (lock-queue:db-dat-set-db! vec val)(vector-set! vec 0 val))
-(define-inline (lock-queue:db-dat-set-path! vec val)(vector-set! vec 1 val))
-
-(define (lock-queue:delete-lock-db dbdat)
- (let ((fname (lock-queue:db-dat-get-path dbdat)))
- (system (conc "rm -f " fname "*"))))
-
-(define (lock-queue:open-db fname #!key (count 10))
- (let* ((actualfname (conc fname ".lockdb"))
- (dbexists (common:file-exists? actualfname))
- (db (sqlite3:open-database actualfname))
- (handler (make-busy-timeout 136000)))
- (if dbexists
- (vector db actualfname)
- (begin
- (handle-exceptions
- exn
- (begin
- (thread-sleep! 10)
- (if (> count 0)
- (lock-queue:open-db fname count: (- count 1))
- (vector db actualfname)))
- (sqlite3:with-transaction
- db
- (lambda ()
- (sqlite3:execute
- db
- "CREATE TABLE IF NOT EXISTS queue (
- id INTEGER PRIMARY KEY,
- test_id INTEGER,
- start_time INTEGER,
- state TEXT,
- CONSTRAINT queue_constraint UNIQUE (test_id));")
- (sqlite3:execute
- db
- "CREATE TABLE IF NOT EXISTS runlocks (
- id INTEGER PRIMARY KEY,
- test_id INTEGER,
- run_lock TEXT,
- CONSTRAINT runlock_constraint UNIQUE (run_lock));"))))))
- (sqlite3:set-busy-handler! db handler)
- (vector db actualfname)))
-
-(define (lock-queue:set-state dbdat test-id newstate #!key (remtries 10))
- (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200)
- (handle-exceptions
- exn
- (if (> remtries 0)
- (begin
- (debug:print 0 *default-log-port* "WARNING: exception on lock-queue:set-state. Trying again in 30 seconds.")
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (thread-sleep! 30)
- (lock-queue:set-state dbdat test-id newstate remtries: (- remtries 1)))
- (begin
- (debug:print-error 0 *default-log-port* " Failed to set lock state for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.")
- #f))
- (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "UPDATE queue SET state=? WHERE test_id=?;"
- newstate
- test-id)))
-
-(define (lock-queue:any-younger? dbdat mystart test-id #!key (remtries 10))
- ;; no need to wait on journal on read only queries
- ;; (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200)
- (handle-exceptions
- exn
- (if (> remtries 0)
- (begin
- (debug:print 0 *default-log-port* "WARNING: exception on lock-queue:any-younger. Removing lockdb and trying again in 5 seconds.")
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (thread-sleep! 5)
- (lock-queue:delete-lock-db dbdat)
- (lock-queue:any-younger? dbdat mystart test-id remtries: (- remtries 1)))
- (begin
- (debug:print-error 0 *default-log-port* " Failed to find younger locks for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.")
- #f))
- (let ((res #f))
- (sqlite3:for-each-row
- (lambda (tid)
- ;; Actually this should not be needed as mystart cannot be simultaneously less than and test-id same as
- (if (not (equal? tid test-id))
- (set! res tid)))
- (lock-queue:db-dat-get-db dbdat)
- "SELECT test_id FROM queue WHERE start_time > ?;" mystart)
- res)))
-
-(define (lock-queue:get-lock dbdat test-id #!key (count 10)(waiting-msg #f))
- (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 remove: #t waiting-msg: "lock-queue:get-lock, waiting on journal")
- (let* ((res #f)
- (db (lock-queue:db-dat-get-db dbdat))
- (lckqry (sqlite3:prepare db "SELECT test_id,run_lock FROM runlocks WHERE run_lock='locked';"))
- (mklckqry (sqlite3:prepare db "INSERT INTO runlocks (test_id,run_lock) VALUES (?,'locked');")))
- (let ((result
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port* "WARNING: failed to get queue lock. Removing lock db and returning fail") ;; Will try again in a few seconds")
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (thread-sleep! 10)
- ;; (if (> count 0)
- ;; #f ;; (lock-queue:get-lock dbdat test-id count: (- count 1)) - give up on retries
- ;; (begin ;; never recovered, remote the lock file and return #f, no lock obtained
- (lock-queue:delete-lock-db dbdat)
- #f)
- (sqlite3:with-transaction
- db
- (lambda ()
- (sqlite3:for-each-row (lambda (tid lockstate)
- (set! res (list tid lockstate)))
- lckqry)
- (if res
- (if (equal? (car res) test-id)
- #t ;; already have the lock
- #f)
- (begin
- (sqlite3:execute mklckqry test-id)
- ;; if no error handled then return #t for got the lock
- #t)))))))
- (sqlite3:finalize! lckqry)
- (sqlite3:finalize! mklckqry)
- result)))
-
-(define (lock-queue:release-lock fname test-id #!key (count 10))
- (let* ((dbdat (lock-queue:open-db fname)))
- (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 "lock-queue:release-lock; waiting on journal")
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port* "WARNING: Failed to release queue lock. Will try again in few seconds")
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (thread-sleep! (/ count 10))
- (if (> count 0)
- (begin
- (sqlite3:finalize! (lock-queue:db-dat-get-db dbdat))
- (lock-queue:release-lock fname test-id count: (- count 1)))
- (let ((journal (conc fname "-journal")))
- ;; If we've tried ten times and failed there is a serious problem
- ;; try to remove the lock db and allow it to be recreated
- (handle-exceptions
- exn
- #f
- (if (common:file-exists? journal)(delete-file journal))
- (if (common:file-exists? fname) (delete-file fname))
- #f))))
- (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "DELETE FROM runlocks WHERE test_id=?;" test-id)
- (sqlite3:finalize! (lock-queue:db-dat-get-db dbdat)))))
-
-(define (lock-queue:steal-lock dbdat test-id #!key (count 10))
- (debug:print-info 0 *default-log-port* "Attempting to steal lock at " (lock-queue:db-dat-get-path dbdat))
- (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 "lock-queue:steal-lock; waiting on journal")
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port* "WARNING: Failed to steal queue lock. Will try again in few seconds")
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (thread-sleep! 10)
- (if (> count 0)
- (lock-queue:steal-lock dbdat test-id count: (- count 1))
- #f))
- (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "DELETE FROM runlocks WHERE run_lock='locked';"))
- (lock-queue:get-lock dbdat test-it))
-
-;; returns #f if ok to skip the task
-;; returns #t if ok to proceed with task
-;; otherwise waits
-;;
-(define (lock-queue:wait-turn fname test-id #!key (count 10)(waiting-msg #f))
- (let* ((dbdat (lock-queue:open-db fname))
- (mystart (current-seconds))
- (db (lock-queue:db-dat-get-db dbdat)))
- ;; (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 waiting-msg: "lock-queue:wait-turn; waiting on journal file")
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port* "WARNING: Failed to find out if it is ok to skip the wait queue. Will try again in few seconds")
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (print-call-chain (current-error-port))
- (thread-sleep! 10)
- (if (> count 0)
- (begin
- (sqlite3:finalize! db)
- (lock-queue:wait-turn fname test-id count: (- count 1)))
- (begin
- (debug:print 0 *default-log-port* "Giving up calls to lock-queue:wait-turn for test-id " test-id " at path " fname ", printing call chain")
- (print-call-chain (current-error-port))
- #f)))
- ;; wait 10 seconds and then check to see if someone is already updating the html
- (thread-sleep! 10)
- (if (not (lock-queue:any-younger? dbdat mystart test-id)) ;; no processing in flight, must try to start processing
- (begin
- (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 waiting-msg: "lock-queue:wait-turn; waiting on journal file")
- (sqlite3:execute
- db
- "INSERT OR REPLACE INTO queue (test_id,start_time,state) VALUES (?,?,'waiting');"
- test-id mystart)
- ;; (thread-sleep! 1) ;; give other tests a chance to register
- (let ((result
- (let loop ((younger-waiting (lock-queue:any-younger? dbdat mystart test-id)))
- (if younger-waiting
- (begin
- ;; no need for us to wait. mark in the lock queue db as skipping
- ;; no point in marking anything in the queue - simply never register this
- ;; test as it is *covered* by a previously started update to the html file
- ;; (lock-queue:set-state dbdat test-id "skipping")
- #f) ;; let the calling process know that nothing needs to be done
- (if (lock-queue:get-lock dbdat test-id)
- #t
- (if (> (- (current-seconds) mystart) 36000) ;; waited too long, steal the lock
- (lock-queue:steal-lock dbdat test-id)
- (begin
- (thread-sleep! 1)
- (loop (lock-queue:any-younger? dbdat mystart test-id)))))))))
- (sqlite3:finalize! db)
- result))))))
-
-
-;; (use trace)
-;; (trace lock-queue:get-lock lock-queue:release-lock lock-queue:wait-turn lock-queue:any-younger? lock-queue:set-state)
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -1,6 +1,6 @@
-;; Copyright 2006-2017, Matthew Welland.
+>;; 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
@@ -47,11 +47,10 @@
(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:)
readline apropos json http-client directory-utils typed-records
http-client srfi-18 extras format)
@@ -1082,12 +1081,11 @@
;;======================================================================
;; 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
+ (let* ((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))
@@ -1240,14 +1238,10 @@
(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") "%"))
DELETED mlaunch.scm
Index: mlaunch.scm
==================================================================
--- mlaunch.scm
+++ /dev/null
@@ -1,33 +0,0 @@
-;; Copyright 2006-2014, 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')
-
-;;======================================================================
-;; MLAUNCH
-;;
-;; take jobs from the given queue and keep launching them keeping
-;; the cpu load at the targeted level
-;;
-;;======================================================================
-
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 format)
-
-(declare (unit mlaunch))
-(declare (uses db))
-(declare (uses common))
-
DELETED monitor.scm
Index: monitor.scm
==================================================================
--- monitor.scm
+++ /dev/null
@@ -1,33 +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 .
-
-;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
-
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking)
-(import (prefix sqlite3 sqlite3:))
-
-(declare (unit runs))
-(declare (uses db))
-(declare (uses common))
-(declare (uses items))
-(declare (uses runconfig))
-
-(include "common_records.scm")
-(include "key_records.scm")
-(include "db_records.scm")
-(include "run_records.scm")
-
Index: mt.scm
==================================================================
--- mt.scm
+++ mt.scm
@@ -33,11 +33,10 @@
(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.
;;======================================================================
DELETED newdashboard.scm
Index: newdashboard.scm
==================================================================
--- newdashboard.scm
+++ /dev/null
@@ -1,742 +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 .
-
-;;======================================================================
-
-(use format)
-
-(use (prefix iup iup:))
-
-(use canvas-draw)
-(import canvas-draw-iup)
-
-(use sql-de-lite srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors ;; defstruct
- (prefix dbi dbi:))
-
-(declare (uses common))
-(declare (uses megatest-version))
-(declare (uses margs))
-
-;; (declare (uses launch))
-;; (declare (uses gutils))
-;; (declare (uses db))
-;; (declare (uses server))
-;; (declare (uses synchash))
-(declare (uses dcommon))
-;; (declare (uses tree))
-;;
-;; (include "common_records.scm")
-;; (include "db_records.scm")
-;; (include "key_records.scm")
-
-(define help (conc
-"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
- version " megatest-version "
- license GPL, Copyright (C) Matt Welland 2011
-
-Usage: dashboard [options]
- -h : this help
- -server host:port : connect to host:port instead of db access
- -test testid : control test identified by testid
- -guimonitor : control panel for runs
-
-Misc
- -rows N : set number of rows
-"))
-
-;; process args
-(define remargs (args:get-args
- (argv)
- (list "-rows"
- "-run"
- "-test"
- "-debug"
- "-host"
- )
- (list "-h"
- "-guimonitor"
- "-main"
- "-v"
- "-q"
- )
- args:arg-hash
- 0))
-
-(if (args:get-arg "-h")
- (begin
- (print help)
- (exit)))
-
-;; ease debugging by loading ~/.dashboardrc
-(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
- (if (common:file-exists? debugcontrolf)
- (load debugcontrolf)))
-
-(debug:setup)
-
-(define *tim* (iup:timer))
-(define *ord* #f)
-
-(iup:attribute-set! *tim* "TIME" 300)
-(iup:attribute-set! *tim* "RUN" "YES")
-
-(define (message-window msg)
- (iup:show
- (iup:dialog
- (iup:vbox
- (iup:label msg #:margin "40x40")))))
-
-(define (iuplistbox-fill-list lb items . default)
- (let ((i 1)
- (selected-item (if (null? default) #f (car default))))
- (iup:attribute-set! lb "VALUE" (if selected-item selected-item ""))
- (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" item))) ;; (number->string i))))
- (set! i (+ i 1)))
- items)
- i))
-
-(define (pad-list l n)(append l (make-list (- n (length l)))))
-
-
-(define (mkstr . x)
- (string-intersperse (map conc x) ","))
-
-(define (update-search x val)
- (hash-table-set! *searchpatts* x val))
-
-
-;; 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") "10"))) : 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") "60")) : 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
- )
-
-
-
-;; mtest is actually the megatest.config file
-;;
-(define (mtest toppath window-id)
- (let* ((curr-row-num 0)
- ;; (rawconfig (read-config (conc toppath "/megatest.config") #f 'return-string))
- (keys-matrix (iup:matrix)) ;; (dcommon:keys-matrix rawconfig))
- (setup-matrix (iup:matrix)) ;; (dcommon:section-matrix rawconfig "setup" "Varname" "Value"))
- (jobtools-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 5
- #:numcol-visible 1
- #:numlin-visible 3))
- (validvals-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 2
- #:numcol-visible 1
- #:numlin-visible 2))
- (envovrd-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 20
- #:numcol-visible 1
- #:numlin-visible 8))
- (disks-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 20
- #:numcol-visible 1
- #:numlin-visible 8))
- )
- (iup:attribute-set! disks-matrix "0:0" "Disk Name")
- (iup:attribute-set! disks-matrix "0:1" "Disk Path")
- (iup:attribute-set! disks-matrix "WIDTH1" "120")
- (iup:attribute-set! disks-matrix "WIDTH0" "100")
- (iup:attribute-set! disks-matrix "ALIGNMENT1" "ALEFT")
- (iup:attribute-set! disks-matrix "FIXTOTEXT" "C1")
- (iup:attribute-set! disks-matrix "RESIZEMATRIX" "YES")
-
- ;; fill in existing info
- (for-each
- (lambda (mat fname)
- (set! curr-row-num 1)
- (for-each
- (lambda (var)
- (iup:attribute-set! mat (conc curr-row-num ":0") var)
- ;; (iup:attribute-set! mat (conc curr-row-num ":1") (config-lookup rawconfig fname var))
- (set! curr-row-num (+ curr-row-num 1)))
- '()));; (configf:section-vars rawconfig fname)))
- (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix disks-matrix)
- (list "setup" "jobtools" "validvalues" "env-override" "disks"))
-
- (for-each
- (lambda (mat)
- (iup:attribute-set! mat "0:1" "Value")
- (iup:attribute-set! mat "0:0" "Var")
- (iup:attribute-set! mat "ALIGNMENT1" "ALEFT")
- (iup:attribute-set! mat "FIXTOTEXT" "C1")
- (iup:attribute-set! mat "RESIZEMATRIX" "YES")
- (iup:attribute-set! mat "WIDTH1" "120")
- (iup:attribute-set! mat "WIDTH0" "100")
- )
- (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix))
-
- (iup:attribute-set! validvals-matrix "WIDTH1" "290")
- (iup:attribute-set! envovrd-matrix "WIDTH1" "290")
-
- (iup:vbox
- (iup:hbox
-
- (iup:vbox
- (let ((tabs (iup:tabs
- ;; The required tab
- (iup:hbox
- ;; The keys
- (iup:frame
- #:title "Keys (required)"
- (iup:vbox
- (iup:label (conc "Set the fields for organising your runs\n"
- "here. Note: can only be changed before\n"
- "running the first run when megatest.db\n"
- "is created."))
- keys-matrix))
- (iup:vbox
- ;; The setup section
- (iup:frame
- #:title "Setup"
- (iup:vbox
- (iup:label (conc "max_concurrent_jobs : limits total concurrent jobs (optional)\n"
- "linktree : directory where linktree will be created."))
- setup-matrix))
- ;; The jobtools
- (iup:frame
- #:title "Jobtools"
- (iup:vbox
- (iup:label (conc "launcher : tool or script to run jobs (try nbfake)\n"
- "useshell : use system to run your launcher\n"
- "workhosts : spread jobs out on these hosts"))
- jobtools-matrix))
- ;; The disks
- (iup:frame
- #:title "Disks"
- (iup:vbox
- (iup:label (conc "Enter names and existing paths of locations to run tests"))
- disks-matrix))))
- ;; The optional tab
- (iup:vbox
- ;; The Environment Overrides
- (iup:frame
- #:title "Env override"
- envovrd-matrix)
- ;; The valid values
- (iup:frame
- #:title "Validvalues"
- validvals-matrix)
- ))))
- (iup:attribute-set! tabs "TABTITLE0" "Required settings")
- (iup:attribute-set! tabs "TABTITLE1" "Optional settings")
- tabs))
- ))))
-
-;; The runconfigs.config file
-;;
-(define (rconfig window-id)
- (iup:vbox
- (iup:frame #:title "Default")))
-
-;;======================================================================
-;; T E S T S
-;;======================================================================
-
-(define (tree-path->test-id path)
- (if (not (null? path))
- (hash-table-ref/default (dboard:data-path-test-ids *data*) path #f)
- #f))
-
-(define (test-panel window-id)
- (let* ((curr-row-num 0)
- (viewlog (lambda (x)
- (if (common:file-exists? logfile)
- ;(system (conc "firefox " logfile "&"))
- (iup:send-url logfile)
- (message-window (conc "File " logfile " not found")))))
- (xterm (lambda (x)
- (if (directory-exists? rundir)
- (let ((shell (if (get-environment-variable "SHELL")
- (conc "-e " (get-environment-variable "SHELL"))
- "")))
- (system (conc "cd " rundir
- ";xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&")))
- (message-window (conc "Directory " rundir " not found")))))
- (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -12"))
- (command-launch-button (iup:button "Execute!"
- ;; #:expand "HORIZONTAL"
- #:size "50x"
- #:action (lambda (x)
- (let ((cmd (iup:attribute command-text-box "VALUE")))
- (system (conc cmd " &"))))))
- (run-test (lambda (x)
- (iup:attribute-set!
- command-text-box "VALUE"
- (conc "xterm -geometry 180x20 -e \"megatest -target " keystring " :runname " runname
- " -runtests " (conc testname "/" (if (equal? item-path "")
- "%"
- item-path))
- ";echo Press any key to continue;bash -c 'read -n 1 -s'\""))))
- (remove-test (lambda (x)
- (iup:attribute-set!
- command-text-box "VALUE"
- (conc "xterm -geometry 180x20 -e \"megatest -remove-runs -target " keystring " :runname " runname
- " -testpatt " (conc testname "/" (if (equal? item-path "")
- "%"
- item-path))
- " -v;echo Press any key to continue;bash -c 'read -n 1 -s'\""))))
- (run-info-matrix (iup:matrix
- #:expand "YES"
- ;; #:scrollbar "YES"
- #:numcol 1
- #:numlin 4
- #:numcol-visible 1
- #:numlin-visible 4
- #:click-cb (lambda (obj lin col status)
- (print "obj: " obj " lin: " lin " col: " col " status: " status))))
- (test-info-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 7
- #:numcol-visible 1
- #:numlin-visible 7))
- (test-run-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 5
- #:numcol-visible 1
- #:numlin-visible 5))
- (meta-dat-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 5
- #:numcol-visible 1
- #:numlin-visible 5))
- (steps-matrix (iup:matrix
- #:expand "YES"
- #:numcol 6
- #:numlin 50
- #:numcol-visible 6
- #:numlin-visible 8))
- (data-matrix (iup:matrix
- #:expand "YES"
- #:numcol 8
- #:numlin 50
- #:numcol-visible 8
- #:numlin-visible 8))
- (updater (lambda (testdat)
- (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix))))
-
- ;; Set the updater in updaters
- ;; (hash-table-set! (dboard:data-updaters *data*) window-id updater)
- ;;
- (for-each
- (lambda (mat)
- ;; (iup:attribute-set! mat "0:1" "Value")
- ;; (iup:attribute-set! mat "0:0" "Var")
- (iup:attribute-set! mat "HEIGHT0" 0)
- (iup:attribute-set! mat "ALIGNMENT1" "ALEFT")
- ;; (iup:attribute-set! mat "FIXTOTEXT" "C1")
- (iup:attribute-set! mat "RESIZEMATRIX" "YES"))
- ;; (iup:attribute-set! mat "WIDTH1" "120")
- ;; (iup:attribute-set! mat "WIDTH0" "100"))
- (list run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix))
-
- ;; Steps matrix
- (iup:attribute-set! steps-matrix "0:1" "Step Name")
- (iup:attribute-set! steps-matrix "0:2" "Start")
- (iup:attribute-set! steps-matrix "WIDTH2" "40")
- (iup:attribute-set! steps-matrix "0:3" "End")
- (iup:attribute-set! steps-matrix "WIDTH3" "40")
- (iup:attribute-set! steps-matrix "0:4" "Status")
- (iup:attribute-set! steps-matrix "WIDTH4" "40")
- (iup:attribute-set! steps-matrix "0:5" "Duration")
- (iup:attribute-set! steps-matrix "WIDTH5" "40")
- (iup:attribute-set! steps-matrix "0:6" "Log File")
- (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT")
- ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1")
- (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES")
- ;; (iup:attribute-set! steps-matrix "WIDTH1" "120")
- ;; (iup:attribute-set! steps-matrix "WIDTH0" "100")
-
- ;; Data matrix
- ;;
- (let ((rownum 1))
- (for-each
- (lambda (x)
- (iup:attribute-set! data-matrix (conc "0:" rownum) x)
- (iup:attribute-set! data-matrix (conc "WIDTH" rownum) "50")
- (set! rownum (+ rownum 1)))
- (list "Category" "Variable" "Value" "Expected" "Tolerance" "Status" "Units" "Type" "Comment")))
- (iup:attribute-set! data-matrix "REDRAW" "ALL")
-
- (for-each
- (lambda (data)
- (let ((mat (car data))
- (keys (cadr data))
- (rownum 1))
- (for-each
- (lambda (key)
- (iup:attribute-set! mat (conc rownum ":0") key)
- (set! rownum (+ rownum 1)))
- keys)
- (iup:attribute-set! mat "REDRAW" "ALL")))
- (list
- (list run-info-matrix '("Run Id" "Target" "Runname" "Run Start Time" ))
- (list test-info-matrix '("Test Id" "Testname" "Itempath" "State" "Status" "Test Start Time" "Comment"))
- (list test-run-matrix '("Hostname" "Host info" "Disk Free" "CPU Load" "Run Duration"))
- (list meta-dat-matrix '("Author" "Owner" "Last Reviewed" "Tags" "Description"))))
-
- (iup:split
- #:orientation "HORIZONTAL"
- (iup:vbox
- (iup:hbox
- (iup:vbox
- run-info-matrix
- test-info-matrix)
- ;; test-info-matrix)
- (iup:vbox
- test-run-matrix
- meta-dat-matrix))
- (iup:vbox
- (iup:vbox
- (iup:hbox
- (iup:button "View Log" #:action viewlog #:size "60x" ) ;; #:size "30x"
- (iup:button "Start Xterm" #:action xterm #:size "60x" )) ;; #:size "30x"
- (iup:hbox
- (iup:button "Run Test" #:action run-test #:size "60x" ) ;; #:size "30x"
- (iup:button "Clean Test" #:action remove-test #:size "60x" ))) ;; #:size "30x"
- (iup:hbox
- ;; hiup:split ;; hbox
- ;; #:orientation "HORIZONTAL"
- ;; #:value 300
- command-text-box
- command-launch-button)))
- (iup:vbox
- (let ((tabs (iup:tabs
- steps-matrix
- data-matrix)))
- (iup:attribute-set! tabs "TABTITLE0" "Test Steps")
- (iup:attribute-set! tabs "TABTITLE1" "Test Data")
- tabs)))))
-
-;; Test browser
-(define (tests window-id)
- (iup:split
- (let* ((tb (iup:treebox
- #:selection-cb
- (lambda (obj id state)
- ;; (print "obj: " obj ", id: " id ", state: " state)
- (let* ((run-path (tree:node->path obj id))
- (test-id (tree-path->test-id (cdr run-path))))
- ;; (if test-id
- ;; (hash-table-set! (dboard:data-curr-test-ids *data*)
- ;; window-id test-id))
- (print "path: " (tree:node->path obj id) " test-id: " test-id))))))
- (iup:attribute-set! tb "VALUE" "0")
- (iup:attribute-set! tb "NAME" "Runs")
- ;;(iup:attribute-set! tb "ADDEXPANDED" "NO")
- ;; (dboard:data-tests-tree-set! *data* tb)
- tb)
- (test-panel window-id)))
-
-;; The function to update the fields in the test view panel
-(define (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix)
- ;; get test-id
- ;; then get test record
- (if testdat
- (let* ((test-id 0) ;; (hash-table-ref/default (dboard:data-curr-test-ids *data*) window-id #f))
- (test-data (hash-table-ref/default testdat test-id #f))
- (run-id (db:test-get-run_id test-data))
- (targ/runname (hash-table-ref/default (dboard:data-run-keys *data*)
- run-id
- '()))
- (target (if (null? targ/runname) "" (string-intersperse (reverse (cdr (reverse targ/runname))) "/")))
- (runname (if (null? targ/runname) "" (car (cdr targ/runname))))
- (steps-dat (tests:get-compressed-steps *dbstruct-local* run-id test-id)))
-
- (if test-data
- (begin
- ;;
- (for-each
- (lambda (data)
- (let ((mat (car data))
- (vals (cadr data))
- (rownum 1))
- (for-each
- (lambda (key)
- (let ((cell (conc rownum ":1")))
- (if (not (equal? (iup:attribute mat cell)(conc key)))
- (begin
- ;; (print "setting cell " cell " in matrix " mat " to value " key)
- (iup:attribute-set! mat cell (conc key))
- (iup:attribute-set! mat "REDRAW" cell)))
- (set! rownum (+ rownum 1))))
- vals)))
- (list
- (list run-info-matrix
- (if test-id
- (list (db:test-get-run_id test-data)
- target
- runname
- "n/a")
- (make-list 4 "")))
- (list test-info-matrix
- (if test-id
- (list test-id
- (db:test-get-testname test-data)
- (db:test-get-item-path test-data)
- (db:test-get-state test-data)
- (db:test-get-status test-data)
- (seconds->string (db:test-get-event_time test-data))
- (db:test-get-comment test-data))
- (make-list 7 "")))
- (list test-run-matrix
- (if test-id
- (list (db:test-get-host test-data)
- (db:test-get-uname test-data)
- (db:test-get-diskfree test-data)
- (db:test-get-cpuload test-data)
- (seconds->hr-min-sec (db:test-get-run_duration test-data)))
- (make-list 5 "")))
- ))
- (dcommon:populate-steps steps-dat steps-matrix))))))
- ;;(list meta-dat-matrix
- ;; (if test-id
- ;; (list (
-
-
-;; db:test-get-id
-;; db:test-get-run_id
-;; db:test-get-testname
-;; db:test-get-state
-;; db:test-get-status
-;; db:test-get-event_time
-;; db:test-get-host
-;; db:test-get-cpuload
-;; db:test-get-diskfree
-;; db:test-get-uname
-;; db:test-get-rundir
-;; db:test-get-item-path
-;; db:test-get-run_duration
-;; db:test-get-final_logf
-;; db:test-get-comment
-;; db:test-get-fullname
-
-
-;;======================================================================
-;; R U N C O N T R O L
-;;======================================================================
-
-;; Overall runs browser
-;;
-(define (runs window-id)
- (let* ((runs-matrix (iup:matrix
- #:expand "YES"
- ;; #:fittosize "YES"
- #:scrollbar "YES"
- #:numcol 100
- #:numlin 100
- #:numcol-visible 7
- #:numlin-visible 7
- #:click-cb (lambda (obj lin col status)
- (print "obj: " obj " lin: " lin " col: " col " status: " status)))))
-
- (iup:attribute-set! runs-matrix "RESIZEMATRIX" "YES")
- (iup:attribute-set! runs-matrix "WIDTH0" "100")
-
- ;; (dboard:data-runs-matrix-set! *data* runs-matrix)
- (iup:hbox
- (iup:frame
- #:title "Runs browser"
- (iup:vbox
- runs-matrix)))))
-
-;; Browse and control a single run
-;;
-(define (runcontrol window-id)
- (iup:hbox))
-
-;;======================================================================
-;; D A S H B O A R D
-;;======================================================================
-
-;; Main Panel
-(define (main-panel window-id)
- (iup:dialog
- #:title "Megatest Control Panel"
- #:menu (dcommon:main-menu)
- #:shrink "YES"
- (let ((tabtop (iup:tabs
- (runs window-id)
- (tests window-id)
- (runcontrol window-id)
- (mtest *toppath* window-id)
- (rconfig window-id)
- )))
- (iup:attribute-set! tabtop "TABTITLE0" "Runs")
- (iup:attribute-set! tabtop "TABTITLE1" "Tests")
- (iup:attribute-set! tabtop "TABTITLE2" "Run Control")
- (iup:attribute-set! tabtop "TABTITLE3" "megatest.config")
- (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config")
- tabtop)))
-
-(define *current-window-id* 0)
-
-(define (newdashboard dbstruct)
- (let* ((data (make-hash-table))
- (keys '()) ;; (db:get-keys dbstruct))
- (runname "%")
- (testpatt "%")
- (keypatts '()) ;; (map (lambda (k)(list k "%")) keys))
- (states '())
- (statuses '())
- (nextmintime (current-milliseconds))
- (my-window-id *current-window-id*))
- (set! *current-window-id* (+ 1 *current-window-id*))
- ;; (dboard:data-runs-set! *data* data) ;; make this data available to the rest of the application
- (iup:show (main-panel my-window-id))
- ;; Yes, running iup:show will pop up a new panel
- ;; (iup:show (main-panel my-window-id))
- (iup:callback-set! *tim*
- "ACTION_CB"
- (lambda (x)
- ;; Want to dedicate no more than 50% of the time to this so skip if
- ;; 2x delta time has not passed since last query
- (if (< nextmintime (current-milliseconds))
- (let* ((starttime (current-milliseconds))
- ;; (changes (dcommon:run-update keys data runname keypatts testpatt states statuses 'full my-window-id))
- (endtime (current-milliseconds)))
- (set! nextmintime (+ endtime (* 2 (- endtime starttime))))
- ;; (debug:print 11 *default-log-port* "CHANGE(S): " (car changes) "..."))
- )
- (debug:print-info 11 *default-log-port* "Server overloaded"))))))
-
-;; (dboard:data-updaters-set! *data* (make-hash-table))
-(newdashboard #f) ;; *dbstruct-local*)
-(iup:main-loop)
Index: process.scm
==================================================================
--- process.scm
+++ process.scm
@@ -30,17 +30,10 @@
(if (not (eof-object? (peek-char port)))
(loop (conc res (read-char port)))
res)))
(define (process:cmd-run-with-stderr->list cmd . params)
- ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params)
-;; (handle-exceptions
-;; exn
-;; (begin
-;; (print "ERROR: Failed to run command: " cmd " " (string-intersperse params " "))
-;; (print " " ((condition-property-accessor 'exn 'message) exn))
-;; #f)
(let-values (((fh fho pid fhe) (if (null? params)
(process* cmd)
(process* cmd params))))
(let loop ((curr (read-line fh))
(result '()))
@@ -55,17 +48,10 @@
(close-input-port fhe)
(close-output-port fho)
result))))) ;; )
(define (process:cmd-run-with-stderr-and-exitcode->list cmd . params)
- ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params)
-;; (handle-exceptions
-;; exn
-;; (begin
-;; (print "ERROR: Failed to run command: " cmd " " (string-intersperse params " "))
-;; (print " " ((condition-property-accessor 'exn 'message) exn))
-;; #f)
(let-values (((fh fho pid fhe) (if (null? params)
(process* cmd)
(process* cmd params))))
(let loop ((curr (read-line fh))
(result '()))
@@ -81,11 +67,10 @@
(close-input-port fhe)
(close-output-port fho)
(list result (if normalexit? exitstatus -1))))))))
(define (process:cmd-run-proc-each-line cmd proc . params)
- ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params)
(handle-exceptions
exn
(begin
(print "ERROR: Failed to run command: " cmd " " (string-intersperse params " "))
(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
DELETED records-vs-vectors-vs-coops.scm
Index: records-vs-vectors-vs-coops.scm
==================================================================
--- records-vs-vectors-vs-coops.scm
+++ /dev/null
@@ -1,110 +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 .
-
-;; (include "vg.scm")
-
-;; (declare (uses vg))
-
-(use foof-loop defstruct coops)
-
-(defstruct obj type fill-color angle)
-
-(define (make-vg:obj)(make-vector 3))
-(define-inline (vg:obj-get-type vec) (vector-ref vec 0))
-(define-inline (vg:obj-get-fill-color vec) (vector-ref vec 1))
-(define-inline (vg:obj-get-angle vec) (vector-ref vec 2))
-(define-inline (vg:obj-set-type! vec val)(vector-set! vec 0 val))
-(define-inline (vg:obj-set-fill-color! vec val)(vector-set! vec 1 val))
-(define-inline (vg:obj-set-angle! vec val)(vector-set! vec 2 val))
-
-(use simple-exceptions)
-(define vgs:obj-exn (make-exception "wrong record type, expected vgs:obj." 'assert))
-(define (make-vgs:obj)(let ((v (make-vector 4)))(vector-set! v 0 'vgs:obj) v))
-(define-inline (vgs:obj-type vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref vec 1)(raise (vgs:obj-exn 'vgs:obj-type 'xpr))))
-(define-inline (vgs:obj-fill-color vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref vec 2)(raise (vgs:obj-exn 'vgs:obj-fill-color 'xpr))))
-(define-inline (vgs:obj-angle vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref vec 3)(raise (vgs:obj-exn 'vgs:obj-angle 'xpr))))
-(define-inline (vgs:obj-type-set! vec val)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-set! vec 1 val)(raise (vgs:obj-exn 'type))))
-(define-inline (vgs:obj-fill-color-set! vec val)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-set! vec 2 val)(raise (vgs:obj-exn 'fill-color))))
-(define-inline (vgs:obj-angle-set! vec val)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-set! vec 3 val)(raise (vgs:obj-exn 'angle))))
-
-(define-class ()
- ((type)
- (fill-color)
- (angle)))
-
-
-;; first use raw vectors
-(print "Using vectors")
-(time
- (loop ((for r (up-from 0 (to 255))))
- (loop ((for g (up-from 0 (to 255))))
- (loop ((for b (up-from 0 (to 255))))
- (let ((obj (make-vg:obj)))
- (vg:obj-set-type! obj 'abc)
- (vg:obj-set-fill-color! obj "green")
- (vg:obj-set-angle! obj 135)
- (let ((a (vg:obj-get-type obj))
- (b (vg:obj-get-fill-color obj))
- (c (vg:obj-get-angle obj)))
- obj))))))
-
-;; first use raw vectors with safe mode
-(print "Using vectors (safe mode)")
-(time
- (loop ((for r (up-from 0 (to 255))))
- (loop ((for g (up-from 0 (to 255))))
- (loop ((for b (up-from 0 (to 255))))
- (let ((obj (make-vgs:obj)))
- ;; (badobj (make-vector 20)))
- (vgs:obj-type-set! obj 'abc)
- (vgs:obj-fill-color-set! obj "green")
- (vgs:obj-angle-set! obj 135)
- (let ((a (vgs:obj-type obj))
- (b (vgs:obj-fill-color obj))
- (c (vgs:obj-angle obj)))
- obj))))))
-
-;; first use defstruct
-(print "Using defstruct")
-(time
- (loop ((for r (up-from 0 (to 255))))
- (loop ((for g (up-from 0 (to 255))))
- (loop ((for b (up-from 0 (to 255))))
- (let ((obj (make-obj)))
- (obj-type-set! obj 'abc)
- (obj-fill-color-set! obj "green")
- (obj-angle-set! obj 135)
- (let ((a (obj-type obj))
- (b (obj-fill-color obj))
- (c (obj-angle obj)))
- obj))))))
-
-
-;; first use defstruct
-(print "Using coops")
-(time
- (loop ((for r (up-from 0 (to 255))))
- (loop ((for g (up-from 0 (to 255))))
- (loop ((for b (up-from 0 (to 255))))
- (let ((obj (make )))
- (set! (slot-value obj 'type) 'abc)
- (set! (slot-value obj 'fill-color) "green")
- (set! (slot-value obj 'angle) 135)
- (let ((a (slot-value obj 'type))
- (b (slot-value obj 'fill-color))
- (c (slot-value obj 'angle)))
- obj))))))
DELETED rmtdb.scm
Index: rmtdb.scm
==================================================================
--- rmtdb.scm
+++ /dev/null
@@ -1,20 +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 .
-
-;;======================================================================
-
Index: run_records.scm
==================================================================
--- run_records.scm
+++ run_records.scm
@@ -38,11 +38,5 @@
(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)
- (conc (db:test-get-testname test)
- (if (equal? (db:test-get-item-path test) "")
- ""
- (conc "(" (db:test-get-item-path test) ")"))))
-
Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -34,11 +34,10 @@
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
-(include "test_records.scm")
;; (include "debugger.scm")
;; use this struct to facilitate refactoring
;;
Index: server.scm
==================================================================
--- server.scm
+++ server.scm
@@ -42,22 +42,10 @@
#f
(conc "http://" (car hostport) ":" (cadr hostport))))
(define *server-loop-heart-beat* (current-seconds))
-;;======================================================================
-;; P K T S S T U F F
-;;======================================================================
-
-;; ???
-
-;;======================================================================
-;; P K T S S T U F F
-;;======================================================================
-
-;; ???
-
;;======================================================================
;; S E R V E R
;;======================================================================
;; Call this to start the actual server
@@ -77,11 +65,11 @@
;;======================================================================
;; S E R V E R U T I L I T I E S
;;======================================================================
;; Get the transport
-(define (server:get-transport)
+#;(define (server:get-transport)
(if *transport-type*
*transport-type*
(let ((ttype (string->symbol
(or (args:get-arg "-transport")
(configf:lookup *configdat* "server" "transport")
@@ -95,25 +83,10 @@
(with-output-to-string
(lambda ()
(write (list (current-directory)
(argv)))))))
-;; When using zmq this would send the message back (two step process)
-;; with spiffy or rpc this simply returns the return data to be returned
-;;
-(define (server:reply return-addr query-sig success/fail result)
- (debug:print-info 11 *default-log-port* "server:reply return-addr=" return-addr ", result=" result)
- ;; (send-message pubsock target send-more: #t)
- ;; (send-message pubsock
- (case (server:get-transport)
- ((rpc) (db:obj->string (vector success/fail query-sig result)))
- ((http) (db:obj->string (vector success/fail query-sig result)))
- ((fs) result)
- (else
- (debug:print-error 0 *default-log-port* "unrecognised transport type: " *transport-type*)
- result)))
-
;; Given a run id start a server process ### NOTE ### > file 2>&1
;; if the run-id is zero and the target-host is set
;; try running on that host
;; incidental: rotate logs in logs/ dir.
;;
@@ -391,12 +364,10 @@
(server:kind-run areapath))
(thread-sleep! 5)
(loop (server:check-if-running areapath)
(+ try-num 1)))))))
-(define server:try-running server:run) ;; there is no more per-run servers ;; REMOVE ME. BUG.
-
(define (server:get-num-servers #!key (numservers 2))
(let ((ns (string->number
(or (configf:lookup *configdat* "server" "numservers") "notanumber"))))
(or ns numservers)))
@@ -444,25 +415,17 @@
;; in the same process as the server.
;;
(define (server:ping host-port-in #!key (do-exit #f))
(let ((host:port (if (not host-port-in) ;; use read-dotserver to find
#f ;; (server:check-if-running *toppath*)
- ;; (if (number? host-port-in) ;; we were handed a server-id
- ;; (let ((srec (tasks:get-server-by-id (db:delay-if-busy (tasks:open-db)) host-port-in)))
- ;; ;; (print "srec: " srec " host-port-in: " host-port-in)
- ;; (if srec
- ;; (conc (vector-ref srec 3) ":" (vector-ref srec 4))
- ;; (conc "no such server-id " host-port-in)))
- host-port-in))) ;; )
+ host-port-in)))
(let* ((host-port (if host:port
(let ((slst (string-split host:port ":")))
(if (eq? (length slst) 2)
(list (car slst)(string->number (cadr slst)))
#f))
#f)))
-;; (toppath (launch:setup)))
- ;; (print "host-port=" host-port)
(if (not host-port)
(begin
(if host-port-in
(debug:print 0 *default-log-port* "ERROR: bad host:port"))
(if do-exit (exit 1))
@@ -526,26 +489,10 @@
(string-intersperse
(map number->string
(u8vector->list
(if res res (hostname->ip hostname)))) ".")))
-;; (define server:sync-lock-token "SERVER_SYNC_LOCK")
-;; (define (server:release-sync-lock)
-;; (db:no-sync-del! *no-sync-db* server:sync-lock-token))
-;; (define (server:have-sync-lock?)
-;; (let* ((have-lock-pair (db:no-sync-get-lock *no-sync-db* server:sync-lock-token))
-;; (have-lock? (car have-lock-pair))
-;; (lock-time (cdr have-lock-pair))
-;; (lock-age (- (current-seconds) lock-time)))
-;; (cond
-;; (have-lock? #t)
-;; ((>lock-age
-;; (* 3 (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: 180)))
-;; (server:release-sync-lock)
-;; (server:have-sync-lock?))
-;; (else #f))))
-
;; moving this here as it needs access to db and cannot be in common.
;;
(define (server:get-bruteforce-syncer dbstruct #!key (fork-to-background #f) (persist-until-sync #f))
(let* ((sqlite-exe (or (get-environment-variable "MT_SQLITE3_EXE"))) ;; defined in cfg.sh
@@ -567,11 +514,11 @@
(calculate-off-time (lambda (work-duration duty-cycle)
(* (/ (- 1 duty-cycle) duty-cycle) last-sync-seconds)))
(off-time min-intersync-delay) ;; adjusted in closure below.
(do-a-sync
(lambda ()
- (BB> "Start do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync)
+ ;; (BB> "Start do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync)
(let* ((finalres
(let retry-loop ((num-tries 0))
(if (common:simple-file-lock lockfile)
(begin
(cond
@@ -616,13 +563,10 @@
(debug:print 0 *default-log-port* "ERROR: ["(common:human-time)"] Sync failed. See log at "sync-log".fail")
(if (file-exists? (conc mtdbfile ".backup"))
(system (conc "/bin/cp "mtdbfile ".backup " mtdbfile)))
#f))))
(common:simple-file-release-lock lockfile)
- (BB> "released lockfile: " lockfile)
- (when (common:file-exists? lockfile)
- (BB> "DID NOT ACTUALLY RELEASE LOCKFILE"))
res2) ;; end let
);; end begin
;; else
(cond
(persist-until-sync
@@ -634,11 +578,10 @@
(debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" other SYNC in progress; not syncing.")
'parallel-sync-in-progress))
) ;; end if got lockfile
)
))
- (BB> "End do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync" and result="finalres)
finalres)
) ;; end lambda
))
do-a-sync))
@@ -736,32 +679,10 @@
(mutex-lock! *heartbeat-mutex*)
(set! *db-last-access* (current-seconds))
(mutex-unlock! *heartbeat-mutex*)
(debug:print-info 0 *default-log-port* "sync called, " res " records transferred."))
(debug:print-info 2 *default-log-port* "sync called but zero records transferred")))))
-;; ;; TODO: factor this next routine out into a function
-;; (with-input-from-pipe ;; this should not block other threads but need to verify this
-;; (conc "megatest -sync-to-megatest.db -m testsuite:" (common:get-area-name) ":" *toppath*)
-;; (lambda ()
-;; (let loop ((inl (read-line))
-;; (res #f))
-;; (if (eof-object? inl)
-;; (begin
-;; (set! sync-duration (- (current-milliseconds) sync-start))
-;; (cond
-;; ((not res)
-;; (debug:print 0 *default-log-port* "ERROR: sync from /tmp db to megatest.db appears to have failed. Recommended that you stop your runs and run \"megatest -cleanup-db\""))
-;; ((> res 0)
-;; (mutex-lock! *heartbeat-mutex*)
-;; (set! *db-last-access* (current-seconds))
-;; (mutex-unlock! *heartbeat-mutex*))))
-;; (let ((num-synced (let ((matches (string-match "^Synced (\\d+).*$" inl)))
-;; (if matches
-;; (string->number (cadr matches))
-;; #f))))
-;; (loop (read-line)
-;; (or num-synced res))))))))))
(if will-sync
(begin
(mutex-lock! *db-multi-sync-mutex*)
(set! *db-sync-in-progress* #f)
(set! *db-last-sync* start-time)
@@ -778,12 +699,10 @@
;; keep going unless time to exit
;;
(if (not *time-to-exit*)
(let delay-loop ((count 0))
- ;;(debug:print-info 13 *default-log-port* "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*)
-
(if (and (not *time-to-exit*)
(< count 6)) ;; was 11, changing to 4.
(begin
(thread-sleep! 1)
(delay-loop (+ count 1))))
Index: subrun.scm
==================================================================
--- subrun.scm
+++ subrun.scm
@@ -20,26 +20,14 @@
(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)
(declare (unit subrun))
-;;(declare (uses runs))
(declare (uses db))
(declare (uses common))
-;;(declare (uses items))
-;;(declare (uses runconfig))
-;;(declare (uses tests))
-;;(declare (uses server))
(declare (uses mt))
-;;(declare (uses archive))
-;; (declare (uses filedb))
-
-;(include "common_records.scm")
-;;(include "key_records.scm")
(include "db_records.scm") ;; provides db:test-get-id
-;;(include "run_records.scm")
-;;(include "test_records.scm")
(define (subrun:subrun-test-initialized? test-run-dir)
(if (and (common:file-exists? (conc test-run-dir "/subrun-area") )
(common:file-exists? (conc test-run-dir "/testconfig.subrun") ))
#t
DELETED test_records.scm
Index: test_records.scm
==================================================================
--- test_records.scm
+++ /dev/null
@@ -1,36 +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 .
-
-;; make-vector-record tests testqueue testname testconfig waitons priority items
-(define (make-tests:testqueue)(make-vector 7 #f))
-(define-inline (tests:testqueue-get-testname vec) (vector-ref vec 0))
-(define-inline (tests:testqueue-get-testconfig vec) (vector-ref vec 1))
-(define-inline (tests:testqueue-get-waitons vec) (vector-ref vec 2))
-(define-inline (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-inline (tests:testqueue-get-items vec) (vector-ref vec 4))
-(define-inline (tests:testqueue-get-itemdat vec) (vector-ref vec 5))
-(define-inline (tests:testqueue-get-item_path vec) (vector-ref vec 6))
-
-(define-inline (tests:testqueue-set-testname! vec val)(vector-set! vec 0 val))
-(define-inline (tests:testqueue-set-testconfig! vec val)(vector-set! vec 1 val))
-(define-inline (tests:testqueue-set-waitons! vec val)(vector-set! vec 2 val))
-(define-inline (tests:testqueue-set-priority! vec val)(vector-set! vec 3 val))
-(define-inline (tests:testqueue-set-items! vec val)(vector-set! vec 4 val))
-(define-inline (tests:testqueue-set-itemdat! vec val)(vector-set! vec 5 val))
-(define-inline (tests:testqueue-set-item_path! vec val)(vector-set! vec 6 val))
-
Index: tests.scm
==================================================================
--- tests.scm
+++ tests.scm
@@ -21,11 +21,11 @@
;;======================================================================
;; Tests
;;======================================================================
(declare (unit tests))
-(declare (uses lock-queue))
+;; (declare (uses lock-queue))
(declare (uses db))
(declare (uses tdb))
(declare (uses common))
;; (declare (uses dcommon)) ;; needed for the steps processing
(declare (uses items))
@@ -40,11 +40,10 @@
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
-(include "test_records.scm")
(include "js-path.scm")
(define (init-java-script-lib)
(set! *java-script-lib* (conc (common:get-install-area) "/share/js/jquery-3.1.0.slim.min.js"))
)