Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -36,27 +36,37 @@
itemsmod.scm keysmod.scm mtmod.scm rmtmod.scm \
tasksmod.scm pgdb.scm launchmod.scm runsmod.scm \
portloggermod.scm archivemod.scm ezstepsmod.scm \
subrunmod.scm bigmod.scm testsmod.scm
-GUISRCF = dashboard-context-menu.scm dashboard-tests.scm \
- dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm \
- vg.scm
+# GUISRCF =
+
+GUIMODFILES = tree.scm dashboard-tests.scm vgmod.scm \
+ dashboard-context-menu.scm dcommon.scm
+
+# dashboard-guimonitor.scm
+
+mofiles/dashboard-context-menu.o : mofiles/dcommon.o
+mofiles/dashboard-tests.o : mofiles/dcommon.o
+# mofiles/dcommon.o mofiles/tree.o : mofiles/gutils.o
OFILES = $(SRCFILES:%.scm=%.o)
-GOFILES = $(GUISRCF:%.scm=%.o)
+# GOFILES = $(GUISRCF:%.scm=%.o)
MOFILES = $(addprefix mofiles/,$(MSRCFILES:%.scm=%.o))
+GMOFILES = $(addprefix mofiles/,$(GUIMODFILES:%.scm=%.o))
+
# compiled import files
MOIMPFILES = $(MSRCFILES:%.scm=%.import.o)
+GMOIMPFILES = $(GUIMODFILES:%.scm=%.import.o)
%.import.o : %.import.scm
csc $(CSCOPTS) -unit $*.import -c $*.import.scm -o $*.import.o
mofiles/%.o : %.scm
@mkdir -p mofiles
- csc $(CSCOPTS) -J -c $< -o mofiles/$*.o
+ csc $(CSCOPTS) -M -J -c $< -o mofiles/$*.o
# module dependencies
mofiles/apimod.o : mofiles/commonmod.o
mofiles/apimod.o : mofiles/servermod.o
mofiles/apimod.o : mofiles/tasksmod.o
@@ -63,15 +73,15 @@
mofiles/archivemod.o : mofiles/launchmod.o
mofiles/archivemod.o : mofiles/servermod.o
mofiles/bigmod.o : mofiles/configfmod.o
mofiles/bigmod.o : mofiles/dbmod.o
mofiles/bigmod.o : mofiles/rmtmod.o
-# mofiles/clientmod.o : mofiles/servermod.o
+# mofiles/clientmod.o : mofiles/servermod.oibpq-dev
+mofiles/commonmod.o : megatest-fossil-hash.scm
mofiles/commonmod.o : mofiles/configfmod.o
mofiles/commonmod.o : mofiles/debugprint.o
mofiles/commonmod.o : mofiles/hostinfo.o
-mofiles/commonmod.o : mofiles/itemsmod.o
mofiles/commonmod.o : mofiles/keysmod.o
mofiles/commonmod.o : mofiles/mtargs.o
mofiles/commonmod.o : mofiles/mtver.o
mofiles/commonmod.o : mofiles/processmod.o
mofiles/configfmod.o : mofiles/keysmod.o
@@ -80,10 +90,11 @@
mofiles/dbmod.o : mofiles/csv-xml.o
mofiles/dbmod.o : mofiles/keysmod.o
mofiles/dbmod.o : mofiles/mtmod.o
mofiles/ezstepsmod.o : mofiles/rmtmod.o
mofiles/ezstepsmod.o : mofiles/subrunmod.o
+mofiles/itemsmod.o : mofiles/commonmod.o
mofiles/keysmod.o : mofiles/debugprint.o
mofiles/launchmod.o : mofiles/bigmod.o
mofiles/launchmod.o : mofiles/ezstepsmod.o
mofiles/launchmod.o : mofiles/rmtmod.o mofiles/servermod.o
mofiles/mtmod.o : mofiles/debugprint.o
@@ -117,18 +128,22 @@
ARCHSTR=$(shell if [[ -e /usr/bin/sw_vers ]]; then /usr/bin/sw_vers -productVersion; else lsb_release -sr; fi)
# ARCHSTR=$(shell bash -c "echo \$$MACHTYPE")
PNGFILES = $(shell cd docs/manual;ls *png)
-mtest: readline-fix.scm megatest.scm $(MOFILES) $(MOIMPFILES)
- csc $(CSCOPTS) $(OFILES) $(MOFILES) $(MOIMPFILES) megatest.scm -o mtest
+mtest: megatest.scm $(MOFILES) megatest-fossil-hash.scm
+ csc $(CSCOPTS) $(MOFILES) megatest.scm -o mtest
+
+# $(MOIMPFILES) removed
showmtesthash:
@echo $(MTESTHASH)
-dboard : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES) $(MOIMPFILES) megatest-fossil-hash.scm
- csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MOFILES) $(MOIMPFILES) -o dboard
+dboard : dashboard.scm $(MOFILES) $(GMOFILES) megatest-fossil-hash.scm
+ csc -k $(CSCOPTS) $(MOFILES) $(GMOFILES) dashboard.scm -o dboard
+
+# $(GMOIMPFILES) $(MOIMPFILES)
mtut: $(OFILES) $(MOFILES) megatest-fossil-hash.scm mtut.scm
csc $(CSCOPTS) $(OFILES) $(MOFILES) mtut.scm -o mtut
# include makefile.inc
@@ -331,11 +346,13 @@
$(HELPERS) $(PREFIX)/bin/nbfake \
$(PREFIX)/bin/serialize-env \
$(PREFIX)/bin/nbfind $(PREFIX)/bin/mtrunner $(PREFIX)/bin/mt_xterm \
$(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun \
$(PREFIX)/share/db/mt-pg.sql \
- $(PREFIX)/share/js/jquery-3.1.0.slim.min.js
+ $(PREFIX)/share/js/jquery-3.1.0.slim.min.js \
+ $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard \
+ $(PREFIX)/bin/serialize-env
$(PREFIX)/bin/.$(ARCHSTR) :
mkdir -p $(PREFIX)/bin/.$(ARCHSTR)
mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib
@@ -409,12 +426,12 @@
fi
if csi -ne '(import postgresql)';then \
echo "(import postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\
fi
-portlogger-example : portlogger-example.scm api.o archive.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o 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 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 common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o genexample.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
+ csc $(CSCOPTS) portlogger-example.scm api.o archive.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.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
buildmanual:
cd docs/manual && make
targets:
Index: apimod.scm
==================================================================
--- apimod.scm
+++ apimod.scm
@@ -24,11 +24,17 @@
(declare (uses debugprint))
(declare (uses tasksmod))
(declare (uses servermod))
(module apimod
- *
+ (
+api:run-server-process
+api:start-server
+api:dispatch-cmd
+api:execute-requests
+api:process-request
+)
(import scheme
chicken.base
chicken.process-context.posix
chicken.string
@@ -81,11 +87,10 @@
get-run-state
get-run-stats
get-run-times
get-targets
get-target
- ;; register-run
get-tests-tags
get-test-times
get-tests-for-run
get-tests-for-run-state-status
get-test-id
@@ -200,10 +205,12 @@
;; SERVERS
;; ((start-server) (apply server:kind-run params))
((kill-server) (set! *server-run* #f))
((get-server) (api:start-server dbstruct params))
((register-server) (apply db:register-server dbstruct params) );; dbstruct host port servkey pid ipaddr dbpath)
+ ((deregister-server) (apply db:deregister-server dbstruct params) );; dbstruct host port servkey pid ipaddr dbpath)
+ ((get-count-servers) (apply db:get-count-servers dbstruct params))
;; TESTS
;;((test-set-state-status-by-id) (apply mt:test-set-state-status-by-id dbstruct params))
;;BB - commented out above because it was calling below, eventually, incorrectly (dbstruct passed to mt:test-set-state-status-by-id, which previosly did more, but now only passes thru to db:set-state-status-and-roll-up-items.
@@ -229,10 +236,11 @@
((top-test-set-per-pf-counts) (apply db:top-test-set-per-pf-counts dbstruct params))
((test-set-archive-block-id) (apply db:test-set-archive-block-id dbstruct params))
;; RUNS
((register-run) (apply db:register-run dbstruct params))
+ ((insert-run) (apply db:insert-run dbstruct params))
((set-tests-state-status) (apply db:set-tests-state-status dbstruct params))
((delete-run) (apply db:delete-run dbstruct params))
((lock/unlock-run) (apply db:lock/unlock-run dbstruct params))
((update-run-event_time) (apply db:update-run-event_time dbstruct params))
((update-run-stats) (apply db:update-run-stats dbstruct params))
@@ -356,11 +364,11 @@
((have-incompletes?) (apply db:have-incompletes? dbstruct params))
((login) (apply db:login dbstruct params))
((general-call) (let ((stmtname (car params))
(run-id (cadr params))
(realparams (cddr params)))
- (db:general-call dbstruct stmtname realparams)))
+ (db:general-call dbstruct stmtname run-id realparams)))
((sdb-qry) (apply sdb:qry params))
((ping) (current-process-id))
((get-changed-record-ids) (apply db:get-changed-record-ids dbstruct params))
((get-run-record-ids) (apply db:get-run-record-ids dbstruct params))
;; TESTMETA
@@ -409,21 +417,22 @@
(define (api:process-request dbstruct indat) ;; the $ is the request vars proc
(let* ((cmd-in (alist-ref 'cmd indat)) ;; ($ 'cmd))
(cmd (if (string? cmd-in)(string->symbol cmd-in) cmd-in))
(params (alist-ref 'params indat))
(key (alist-ref 'key indat)) ;; TODO - add this back
+ (doprint (apply common:low-noise-print 10 params))
)
- (debug:print 0 *default-log-port* "cmd:" cmd " with params " params ", key " key)
+ (if doprint (debug:print 0 *default-log-port* "cmd: " cmd " with params: " params ", key: " key))
(case cmd-in
((ping) #t)
;; ((quit) (exit))
(else
(if (equal? key *my-signature*) ;; TODO - get real key involved
(begin
(set! *api-process-request-count* (+ *api-process-request-count* 1))
(let* ((res (api:execute-requests dbstruct cmd params)))
- (debug:print 0 *default-log-port* "res:" res)
+ (if doprint (debug:print 0 *default-log-port* "res:" res))
#;(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))
Index: archivemod.scm
==================================================================
--- archivemod.scm
+++ archivemod.scm
@@ -33,11 +33,26 @@
(declare (uses launchmod))
(declare (uses processmod))
(declare (uses servermod))
(module archivemod
- *
+ (
+archive:get-archive-disks
+archive:get-archive
+archive:allocate-new-archive-block
+archive:run-bup
+archive:megatest-db
+archive:restore-db
+archive:ls->list
+time-string->seconds
+seconds->std-time-str
+archive:get-timestamp-dir
+archive:bup-restore
+common:get-youngest-test
+archive:bup-get-data
+)
+
(import scheme
(prefix sqlite3 sqlite3:)
chicken.base
chicken.condition
@@ -223,11 +238,11 @@
(if s (string->symbol s) 'bup)))
(archiver-cmd (case archiver
((tar) "tar cfj ARCHIVE_NAME.tar.bz2 ")
((7z) " 7z u -t7z -m0=lzma -mx=9 -mfb=64 -md=32m -ms=on ARCHIVE_NAME.7z ")
(else #f)))
- (src-archive-linktree (rmt:get-var "src-archive-linktree"))
+ (src-archive-linktree (rmt:get-var run-id "src-archive-linktree"))
(print-prefix "Running: ") ;; change to #f to turn off printing
(preclean-spec (configf:get-section *configdat* "archive-preclean")))
(if (or (not src-archive-linktree) (not (equal? src-archive-linktree linktree)))
(rmt:set-var "src-archive-linktree" linktree))
@@ -481,11 +496,11 @@
'old2new
)
(debug:print-info 1 *default-log-port* "dropping triggers to update linktree")
(rmt:drop-all-triggers)
(let* ((linktree (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")))
- (src-archive-linktree (rmt:get-var "src-archive-linktree")))
+ (src-archive-linktree (rmt:get-var #f "src-archive-linktree")))
(if (not (equal? src-archive-linktree linktree))
(rmt:update-tesdata-on-repilcate-db src-archive-linktree linktree))
(debug:print-info 1 *default-log-port* "creating triggers after updating linktree")
(rmt:create-all-triggers)
))
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/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/vg.scm
Index: attic/vg.scm
==================================================================
--- /dev/null
+++ attic/vg.scm
@@ -0,0 +1,674 @@
+;;
+;; Copyright 2016 Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+
+;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
+
+(use typed-records srfi-1)
+
+(declare (unit vg))
+(use canvas-draw iup)
+(import canvas-draw-iup)
+
+(include "vg_records.scm")
+
+;;======================================================================
+;; IDEA
+;;
+;; make it possible to instantiate a vg drawing inside a vg drawing
+;;
+;;======================================================================
+
+;; ;; structs
+;; ;;
+;; (defstruct vg:lib comps)
+;; (defstruct vg:comp objs name file)
+;; ;; extents caches extents calculated on draw
+;; ;; proc is called on draw and takes the obj itself as a parameter
+;; ;; attrib is an alist of parameters
+;; (defstruct vg:obj type pts fill-color text line-color call-back angle font attrib extents proc)
+;; (defstruct vg:inst libname compname theta xoff yoff scalex scaley mirrx mirry call-back cache)
+;; (defstruct vg:drawing libs insts scalex scaley xoff yoff cnv cache)
+;; ;; libs: hash of name->lib, insts: hash of instname->inst
+
+;; inits
+;;
+(define (vg:comp-new)
+ (make-vg:comp objs: '() name: #f file: #f))
+
+(define (vg:lib-new)
+ (make-vg:lib comps: (make-hash-table)))
+
+(define (vg:drawing-new)
+ (make-vg:drawing scalex: 1
+ scaley: 1
+ xoff: 0
+ yoff: 0
+ libs: (make-hash-table)
+ insts: (make-hash-table)
+ cache: '()))
+
+;;======================================================================
+;; scaling and offsets
+;;======================================================================
+
+(define-inline (vg:scale-offset val s o)
+ (+ o (* val s)))
+ ;; (* (+ o val) s))
+
+;; apply scale and offset to a list of x y values
+;;
+(define (vg:scale-offset-xy lstxy sx sy ox oy)
+ (if (> (length lstxy) 1) ;; have at least one xy pair
+ (let loop ((x (car lstxy))
+ (y (cadr lstxy))
+ (tal (cddr lstxy))
+ (res '()))
+ (let ((newres (cons (vg:scale-offset y sy oy)
+ (cons (vg:scale-offset x sx ox)
+ res))))
+ (if (> (length tal) 1)
+ (loop (car tal)(cadr tal)(cddr tal) newres)
+ (reverse newres))))
+ '()))
+
+;; apply drawing offset and scaling to the points in lstxy
+;;
+(define (vg:drawing-apply-scale drawing lstxy)
+ (vg:scale-offset-xy
+ lstxy
+ (vg:drawing-scalex drawing)
+ (vg:drawing-scaley drawing)
+ (vg:drawing-xoff drawing)
+ (vg:drawing-yoff drawing)))
+
+;; apply instance offset and scaling to the points in lstxy
+;;
+(define (vg:inst-apply-scale inst lstxy)
+ (vg:scale-offset-xy
+ lstxy
+ (vg:inst-scalex inst)
+ (vg:inst-scaley inst)
+ (vg:inst-xoff inst)
+ (vg:inst-yoff inst)))
+
+;; apply both drawing and instance scaling to a list of xy points
+;;
+(define (vg:drawing-inst-apply-scale-offset drawing inst lstxy)
+ (vg:drawing-apply-scale
+ drawing
+ (vg:inst-apply-scale inst lstxy)))
+
+;;======================================================================
+;; objects
+;;======================================================================
+
+;; (vg:inst-apply-scale
+;; inst
+;; (vg:drawing-apply-scale drawing lstxy)))
+
+;; make a rectangle obj
+;;
+(define (vg:make-rect-obj x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)(text #f)(font #f)(extents #f))
+ (make-vg:obj type: 'r pts: (list x1 y1 x2 y2) text: text font: font line-color: line-color fill-color: fill-color extents: extents))
+
+;; make a rectangle obj
+;;
+(define (vg:make-line-obj x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)(text #f)(font #f)(extents #f))
+ (make-vg:obj type: 'l pts: (list x1 y1 x2 y2) text: text font: font line-color: line-color extents: extents))
+
+;; make a text obj
+;;
+(define (vg:make-text-obj x1 y1 text #!key (line-color #f)(fill-color #f)
+ (angle #f)(scale-with-zoom #f)(font #f)
+ (font-size #f))
+ (make-vg:obj type: 't pts: (list x1 y1) text: text
+ line-color: line-color fill-color: fill-color
+ angle: angle font: font extents: #f
+ attributes: (vg:make-attrib 'font-size font-size)))
+
+;; proc takes startnum and endnum and yields scalef, per-grad and unitname
+;;
+(define (vg:make-xaxis-obj x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)(text #f)(font #f)(proc #f))
+ (make-vg:obj type: 'x pts: (list x1 y1 x2 y2) text: text font: font line-color: line-color fill-color: fill-color extents: #f proc: proc))
+
+;;======================================================================
+;; obj modifiers and queries
+;;======================================================================
+
+;; get extents, use knowledge of type ...
+;;
+(define (vg:obj-get-extents drawing obj)
+ (let ((type (vg:obj-type obj)))
+ (case type
+ ((l)(vg:rect-get-extents obj))
+ ((r)(vg:rect-get-extents obj))
+ ((t)(vg:draw-text drawing obj draw: #f))
+ (else #f))))
+
+(define (vg:rect-get-extents obj)
+ (vg:obj-pts obj)) ;; extents are just the points for a rectangle
+
+(define (vg:grow-rect borderx bordery x1 y1 x2 y2)
+ (list
+ (- x1 borderx)
+ (- y1 bordery)
+ (+ x2 borderx)
+ (+ y2 bordery)))
+
+(define (vg:make-attrib . attrib-list)
+ #f)
+
+;;======================================================================
+;; components
+;;======================================================================
+
+;; add obj to comp
+;;
+(define (vg:add-objs-to-comp comp . objs)
+ (vg:comp-objs-set! comp (append (vg:comp-objs comp) objs)))
+
+(define (vg:add-obj-to-comp comp obj)
+ (vg:comp-objs-set! comp (cons obj (vg:comp-objs comp))))
+
+;; use the struct. leave this here to remind of this!
+;;
+;; (define (vg:comp-get-objs comp)
+;; (vg:comp-objs comp))
+
+;; add comp to lib
+;;
+(define (vg:add-comp-to-lib lib compname comp)
+ (hash-table-set! (vg:lib-comps lib) compname comp))
+
+;; instanciate component in drawing
+;;
+(define (vg:instantiate drawing libname compname instname xoff yoff #!key (theta 0)(scalex 1)(scaley 1)(mirrx #f)(mirry #f))
+ (let ((inst (make-vg:inst libname: libname compname: compname xoff: xoff yoff: yoff theta: theta scalex: scalex scaley: scaley mirrx: mirrx mirry: mirry)) )
+ (hash-table-set! (vg:drawing-insts drawing) instname inst)))
+
+(define (vg:instance-move drawing instname newx newy)
+ (let ((inst (hash-table-ref (vg:drawing-insts drawing) instname)))
+ (vg:inst-xoff-set! inst newx)
+ (vg:inst-yoff-set! inst newy)))
+
+;; get component from drawing (look in apropriate lib) given libname and compname
+(define (vg:get-component drawing libname compname)
+ (let* ((lib (hash-table-ref (vg:drawing-libs drawing) libname))
+ (inst (hash-table-ref (vg:lib-comps lib) compname)))
+ inst))
+
+(define (vg:get-extents-for-objs drawing objs)
+ (if (or (not objs)
+ (null? objs))
+ #f
+ (let loop ((hed (car objs))
+ (tal (cdr objs))
+ (extents (vg:obj-get-extents drawing (car objs))))
+ (let ((newextents
+ (vg:get-extents-for-two-rects
+ extents
+ (vg:obj-get-extents drawing hed))))
+ (if (null? tal)
+ extents
+ (loop (car tal)(cdr tal) newextents))))))
+
+;; (let ((extents #f))
+;; (for-each
+;; (lambda (obj)
+;; (set! extents
+;; (vg:get-extents-for-two-rects
+;; extents
+;; (vg:obj-get-extents drawing obj))))
+;; objs)
+;; extents))
+
+;; given rectangles r1 and r2, return the box that bounds both
+;;
+(define (vg:get-extents-for-two-rects r1 r2)
+ (if (not r1)
+ r2
+ (if (not r2)
+ r1 ;; #f ;; no extents from #f #f
+ (list (min (car r1)(car r2)) ;; llx
+ (min (cadr r1)(cadr r2)) ;; lly
+ (max (caddr r1)(caddr r2)) ;; ulx
+ (max (cadddr r1)(cadddr r2)))))) ;; uly
+
+(define (vg:components-get-extents drawing . comps)
+ (if (null? comps)
+ #f
+ (let loop ((hed (car comps))
+ (tal (cdr comps))
+ (extents #f))
+ (let* ((objs (vg:comp-objs hed))
+ (newextents (if extents
+ (vg:get-extents-for-two-rects
+ extents
+ (vg:get-extents-for-objs drawing objs))
+ (vg:get-extents-for-objs drawing objs))))
+ (if (null? tal)
+ newextents
+ (loop (car tal)(cdr tal) newextents))))))
+
+;;======================================================================
+;; libraries
+;;======================================================================
+
+;; register lib with drawing
+
+;;
+(define (vg:add-lib drawing libname lib)
+ (hash-table-set! (vg:drawing-libs drawing) libname lib))
+
+(define (vg:get-lib drawing libname)
+ (hash-table-ref/default (vg:drawing-libs drawing) libname #f))
+
+(define (vg:get/create-lib drawing libname)
+ (let ((lib (vg:get-lib drawing libname)))
+ (if lib
+ lib
+ (let ((newlib (vg:lib-new)))
+ (vg:add-lib drawing libname newlib)
+ newlib))))
+
+;;======================================================================
+;; map objects given offset, scale and mirror, resulting obj is displayed
+;;======================================================================
+
+;; dispatch the drawing of obj off to the correct drawing routine
+;;
+(define (vg:map-obj drawing inst obj)
+ (case (vg:obj-type obj)
+ ((l)(vg:map-line drawing inst obj))
+ ((r)(vg:map-rect drawing inst obj))
+ ((t)(vg:map-text drawing inst obj))
+ ((x)(vg:map-xaxis drawing inst obj))
+ (else #f)))
+
+;; given a drawing and a inst map a rectangle to it screen coordinates
+;;
+(define (vg:map-rect drawing inst obj)
+ (let ((res (make-vg:obj type: 'r ;; is there a defstruct copy?
+ fill-color: (vg:obj-fill-color obj)
+ text: (vg:obj-text obj)
+ line-color: (vg:obj-line-color obj)
+ font: (vg:obj-font obj)))
+ (pts (vg:obj-pts obj)))
+ (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts))
+ (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing) ))
+ res))
+
+;; given a drawing and a inst map a line to it screen coordinates
+;;
+(define (vg:map-line drawing inst obj)
+ (let ((res (make-vg:obj type: 'l ;; is there a defstruct copy?
+ line-color: (vg:obj-line-color obj)
+ font: (vg:obj-font obj)))
+ (pts (vg:obj-pts obj)))
+ (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts))
+ (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing) ))
+ res))
+
+;; given a drawing and a inst map a text to it screen coordinates
+;;
+(define (vg:map-text drawing inst obj)
+ (let ((res (make-vg:obj type: 't
+ fill-color: (vg:obj-fill-color obj)
+ text: (vg:obj-text obj)
+ line-color: (vg:obj-line-color obj)
+ font: (vg:obj-font obj)
+ angle: (vg:obj-angle obj)
+ attrib: (vg:obj-attrib obj)))
+ (pts (vg:obj-pts obj)))
+ (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts))
+ (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing)))
+ res))
+
+;; given a drawing and a inst map a line to it screen coordinates
+;;
+(define (vg:map-xaxis drawing inst obj)
+ (let ((res (make-vg:obj type: 'x ;; is there a defstruct copy?
+ line-color: (vg:obj-line-color obj)
+ font: (vg:obj-font obj)))
+ (pts (vg:obj-pts obj)))
+ (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts))
+ (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing) ))
+ res))
+
+;;======================================================================
+;; instances
+;;======================================================================
+
+(define (vg:instances-get-extents drawing . instance-names)
+ (let ((xtnt-lst (vg:draw drawing #f)))
+ (if (null? xtnt-lst)
+ #f
+ (let loop ((extents (car xtnt-lst))
+ (tal (cdr xtnt-lst))
+ (llx #f)
+ (lly #f)
+ (ulx #f)
+ (uly #f))
+ (let ((nllx (if llx (min llx (list-ref extents 0))(list-ref extents 0)))
+ (nlly (if lly (min lly (list-ref extents 1))(list-ref extents 1)))
+ (nulx (if ulx (max ulx (list-ref extents 2))(list-ref extents 2)))
+ (nuly (if uly (max uly (list-ref extents 3))(list-ref extents 3))))
+ (if (null? tal)
+ (list llx lly ulx uly)
+ (loop (car tal)(cdr tal) nllx nlly nulx nuly)))))))
+
+(define (vg:lib-get-component lib instname)
+ (hash-table-ref/default (vg:lib-comps lib) instname #f))
+
+;;======================================================================
+;; color
+;;======================================================================
+
+(define (vg:rgb->number r g b #!key (a 0))
+ (bitwise-ior
+ (arithmetic-shift a 24)
+ (arithmetic-shift r 16)
+ (arithmetic-shift g 8)
+ b))
+
+;; Obsolete function
+;;
+(define (vg:generate-color)
+ (vg:rgb->number (pseudo-random-integer 255)
+ (pseudo-random-integer 255)
+ (pseudo-random-integer 255)))
+
+;; Need to return a string of random iup-color for graph
+;;
+(define (vg:generate-color-rgb)
+ (conc (number->string (pseudo-random-integer 255)) " "
+ (number->string (pseudo-random-integer 255)) " "
+ (number->string (pseudo-random-integer 255))))
+
+(define (vg:iup-color->number iup-color)
+ (apply vg:rgb->number (map string->number (string-split iup-color))))
+
+;;======================================================================
+;; graphing
+;;======================================================================
+
+(define (vg:make-xaxis drawing component x1 y1 x2 y2 startnum endnum scaleproc)
+ (let ((obj (vg:make-xaxis-obj x1 y1 x2 y2)))
+ #f))
+
+;;======================================================================
+;; Unravel and draw the objects
+;;======================================================================
+
+;; with get-extents = #t return the extents
+;; with draw = #f don't actually draw the object
+;;
+(define (vg:draw-obj drawing obj #!key (draw #t))
+ ;; (print "obj type: " (vg:obj-type obj))
+ (case (vg:obj-type obj)
+ ((l)(vg:draw-line drawing obj draw: draw))
+ ((r)(vg:draw-rect drawing obj draw: draw))
+ ((t)(vg:draw-text drawing obj draw: draw))))
+
+;; given a rect obj draw it on the canvas applying first the drawing
+;; scale and offset
+;;
+(define (vg:draw-rect drawing obj #!key (draw #t))
+ (let* ((cnv (vg:drawing-cnv drawing))
+ (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj)))
+ (fill-color (vg:obj-fill-color obj))
+ (line-color (vg:obj-line-color obj))
+ (text (vg:obj-text obj))
+ (font (vg:obj-font obj))
+ (llx (car pts))
+ (lly (cadr pts))
+ (ulx (caddr pts))
+ (uly (cadddr pts))
+ (w (- ulx llx))
+ (h (- uly lly))
+ (text-xmax #f)
+ (text-ymax #f))
+ (if draw
+ (let ((prev-background-color (canvas-background cnv))
+ (prev-foreground-color (canvas-foreground cnv)))
+ (if fill-color
+ (begin
+ (canvas-foreground-set! cnv fill-color)
+ (canvas-box! cnv llx ulx lly uly))) ;; docs are all over the place on this one.;; w h)
+ (if line-color
+ (canvas-foreground-set! cnv line-color)
+ (if fill-color
+ (canvas-foreground-set! cnv prev-foreground-color)))
+ (canvas-rectangle! cnv llx ulx lly uly)
+ (canvas-foreground-set! cnv prev-foreground-color)
+ (if text
+ (let* ((prev-font (canvas-font cnv))
+ (font-changed (and font (not (equal? font prev-font)))))
+ (if font-changed (canvas-font-set! cnv font))
+ (canvas-text! cnv (+ 2 llx)(+ 2 lly) text)
+ (if (eq? draw 'get-extents)
+ (let-values (((xmax ymax)(canvas-text-size cnv text)))
+ (set! text-xmax xmax)(set! text-ymax ymax)))
+ (if font-changed (canvas-font-set! cnv prev-font))))))
+ ;; (print "text-xmax: " text-xmax " text-ymax: " text-ymax)
+ (if (vg:obj-extents obj)
+ (vg:obj-extents obj)
+ (if (not text)
+ pts ;; no text
+ (if (and text-xmax text-ymax) ;; have text
+ (let ((xt (list llx lly
+ (max ulx (+ llx text-xmax))
+ (max uly (+ lly text-ymax)))))
+ (vg:obj-extents-set! obj xt)
+ xt)
+ (if cnv
+ (if (eq? draw 'get-extents)
+ (let-values (((xmax ymax)(canvas-text-size cnv text)))
+ (let ((xt (list llx lly
+ (max ulx (+ llx xmax))
+ (max uly (+ lly ymax)))))
+ (vg:obj-extents-set! obj xt)
+ xt))
+ pts)
+ pts)))))) ;; return extents
+
+;; given a rect obj draw it on the canvas applying first the drawing
+;; scale and offset
+;;
+(define (vg:draw-line drawing obj #!key (draw #t))
+ (let* ((cnv (vg:drawing-cnv drawing))
+ (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj)))
+ ;; (fill-color (vg:obj-fill-color obj))
+ (line-color (vg:obj-line-color obj))
+ (text (vg:obj-text obj))
+ (font (vg:obj-font obj))
+ (llx (car pts))
+ (lly (cadr pts))
+ (ulx (caddr pts))
+ (uly (cadddr pts))
+ (w (- ulx llx))
+ (h (- uly lly))
+ (text-xmax #f)
+ (text-ymax #f))
+ (if draw
+ (let ((prev-background-color (canvas-background cnv))
+ (prev-foreground-color (canvas-foreground cnv)))
+ ;; (if fill-color
+ ;; (begin
+ ;; (canvas-foreground-set! cnv fill-color)
+ ;; (canvas-box! cnv llx ulx lly uly))) ;; docs are all over the place on this one.;; w h)
+ (if line-color
+ (canvas-foreground-set! cnv line-color))
+ ;; (if fill-color
+ ;; (canvas-foreground-set! cnv prev-foreground-color)))
+ (canvas-line! cnv llx lly ulx uly)
+ (canvas-foreground-set! cnv prev-foreground-color)
+ (if text
+ (let* ((prev-font (canvas-font cnv))
+ (font-changed (and font (not (equal? font prev-font)))))
+ (if font-changed (canvas-font-set! cnv font))
+ (canvas-text! cnv (+ 2 llx)(+ 2 lly) text)
+ (let-values (((xmax ymax)(canvas-text-size cnv text)))
+ (set! text-xmax xmax)(set! text-ymax ymax))
+ (if font-changed (canvas-font-set! cnv prev-font))))))
+ ;; (print "text-xmax: " text-xmax " text-ymax: " text-ymax)
+ (if (vg:obj-extents obj)
+ (vg:obj-extents obj)
+ (if (not text)
+ pts
+ (if (and text-xmax text-ymax)
+ (let ((xt (list llx lly
+ (max ulx (+ llx text-xmax))
+ (max uly (+ lly text-ymax)))))
+ (vg:obj-extents-set! obj xt)
+ xt)
+ (if cnv
+ (let-values (((xmax ymax)(canvas-text-size cnv text)))
+ (let ((xt (list llx lly
+ (max ulx (+ llx xmax))
+ (max uly (+ lly ymax)))))
+ (vg:obj-extents-set! obj xt)
+ xt))
+ pts)))))) ;; return extents
+
+;; given a rect obj draw it on the canvas applying first the drawing
+;; scale and offset
+;;
+(define (vg:draw-xaxis drawing obj #!key (draw #t))
+ (let* ((cnv (vg:drawing-cnv drawing))
+ (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj)))
+ ;; (fill-color (vg:obj-fill-color obj))
+ (line-color (vg:obj-line-color obj))
+ (text (vg:obj-text obj))
+ (font (vg:obj-font obj))
+ (llx (car pts))
+ (lly (cadr pts))
+ (ulx (caddr pts))
+ (uly (cadddr pts))
+ (w (- ulx llx))
+ (h (- uly lly))
+ (text-xmax #f)
+ (text-ymax #f))
+ (if draw
+ (let ((prev-background-color (canvas-background cnv))
+ (prev-foreground-color (canvas-foreground cnv)))
+ ;; (if fill-color
+ ;; (begin
+ ;; (canvas-foreground-set! cnv fill-color)
+ ;; (canvas-box! cnv llx ulx lly uly))) ;; docs are all over the place on this one.;; w h)
+ (if line-color
+ (canvas-foreground-set! cnv line-color)
+ #;(if fill-color
+ (canvas-foreground-set! cnv prev-foreground-color)))
+ (canvas-line! cnv llx ulx lly uly)
+ (canvas-foreground-set! cnv prev-foreground-color)
+ (if text
+ (let* ((prev-font (canvas-font cnv))
+ (font-changed (and font (not (equal? font prev-font)))))
+ (if font-changed (canvas-font-set! cnv font))
+ (canvas-text! cnv (+ 2 llx)(+ 2 lly) text)
+ (let-values (((xmax ymax)(canvas-text-size cnv text)))
+ (set! text-xmax xmax)(set! text-ymax ymax))
+ (if font-changed (canvas-font-set! cnv prev-font))))))
+ ;; (print "text-xmax: " text-xmax " text-ymax: " text-ymax)
+ (if (vg:obj-extents obj)
+ (vg:obj-extents obj)
+ (if (not text)
+ pts
+ (if (and text-xmax text-ymax)
+ (let ((xt (list llx lly
+ (max ulx (+ llx text-xmax))
+ (max uly (+ lly text-ymax)))))
+ (vg:obj-extents-set! obj xt)
+ xt)
+ (if cnv
+ (let-values (((xmax ymax)(canvas-text-size cnv text)))
+ (let ((xt (list llx lly
+ (max ulx (+ llx xmax))
+ (max uly (+ lly ymax)))))
+ (vg:obj-extents-set! obj xt)
+ xt))
+ pts)))))) ;; return extents
+
+;; given a rect obj draw it on the canvas applying first the drawing
+;; scale and offset
+;;
+(define (vg:draw-text drawing obj #!key (draw #t))
+ (let* ((cnv (vg:drawing-cnv drawing))
+ (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj)))
+ (text (vg:obj-text obj))
+ (font (vg:obj-font obj))
+ (fill-color (vg:obj-fill-color obj))
+ (line-color (vg:obj-line-color obj))
+ (llx (car pts))
+ (lly (cadr pts)))
+ (if draw
+ (let* ((prev-background-color (canvas-background cnv))
+ (prev-foreground-color (canvas-foreground cnv))
+ (prev-font (canvas-font cnv))
+ (font-changed (and font (not (equal? font prev-font)))))
+ (if line-color
+ (canvas-foreground-set! cnv line-color)
+ (if fill-color
+ (canvas-foreground-set! cnv prev-foreground-color)))
+ (if font-changed (canvas-font-set! cnv font))
+ (canvas-text! cnv llx lly text)
+ ;; NOTE: we do not set the font back!!
+ (canvas-foreground-set! cnv prev-foreground-color)))
+ (if cnv
+ (if (eq? draw 'get-extents)
+ (let-values (((xmax ymax)(canvas-text-size cnv text)))
+ (append pts (list (+ llx xmax)(+ lly ymax)))) ;; will be wrong if text is rotated?
+ (append pts pts))
+ (append pts pts))))
+
+(define (vg:draw-inst drawing inst #!key (draw-mode #t)(prev-extents '()))
+ (let* ((libname (vg:inst-libname inst))
+ (compname (vg:inst-compname inst))
+ (comp (vg:get-component drawing libname compname))
+ (objs (vg:comp-objs comp)))
+ ;; (print "comp: " comp)
+ (if (null? objs)
+ prev-extents
+ (let loop ((obj (car objs))
+ (tal (cdr objs))
+ (res prev-extents))
+ (let* ((obj-xfrmd (vg:map-obj drawing inst obj))
+ (newres (cons (vg:draw-obj drawing obj-xfrmd draw: draw-mode) res)))
+ (if (null? tal)
+ newres
+ (loop (car tal)(cdr tal) newres)))))))
+
+(define (vg:draw drawing draw-mode . instnames)
+ (let* ((insts (vg:drawing-insts drawing))
+ (all-inst-names (hash-table-keys insts))
+ (master-list (if (null? instnames)
+ all-inst-names
+ instnames)))
+ (if (null? master-list)
+ '()
+ (let loop ((instname (car master-list))
+ (tal (cdr master-list))
+ (res '()))
+ (let* ((inst (hash-table-ref/default insts instname #f))
+ (newres (if inst
+ (vg:draw-inst drawing inst draw-mode: draw-mode prev-extents: res)
+ res)))
+ (if (null? tal)
+ newres
+ (loop (car tal)(cdr tal) newres)))))))
ADDED build-assist/ck5
Index: build-assist/ck5
==================================================================
--- /dev/null
+++ build-assist/ck5
@@ -0,0 +1,9 @@
+#!/bin/bash
+export PATH=/home/matt/data/buildall/ck5.2/bin:$PATH
+if [[ -z /home/matt/data/buildall/ck5.2/lib:/home/matt/data/buildall/ck5.2/lib64 ]];then
+ export LD_LIBRARY_PATH=/home/matt/data/buildall/ck5.2/lib:/home/matt/data/buildall/ck5.2/lib64:$LD_LIBRARY_PATH
+else
+ export LD_LIBRARY_PATH=/home/matt/data/buildall/ck5.2/lib:/home/matt/data/buildall/ck5.2/lib64
+fi
+export CHICKEN_DOC_PAGER=cat
+exec "$@"
ADDED build-assist/ck5-eggs.list
Index: build-assist/ck5-eggs.list
==================================================================
--- /dev/null
+++ build-assist/ck5-eggs.list
@@ -0,0 +1,44 @@
+address-info
+ansi-escape-sequences
+apropos
+base64
+crypt
+csv-abnf
+directory-utils
+filepath
+fmt
+format
+http-client
+itemsmod
+json
+linenoise
+md5
+message-digest
+nanomsg
+postgresql
+queues
+regex
+regex-case
+rfc3339
+s11n
+sha1
+simple-exceptions
+slice
+sparse-vectors
+spiffy
+spiffy-directory-listing
+spiffy-request-vars
+sql-de-lite
+sqlite3
+sql-null
+srfi-1
+srfi-13
+srfi-19
+sxml-modifications
+sxml-serializer
+sxml-transforms
+system-information
+test
+typed-records
+uri-common
+z3
ADDED build-assist/debian-packages-needed
Index: build-assist/debian-packages-needed
==================================================================
--- /dev/null
+++ build-assist/debian-packages-needed
@@ -0,0 +1,5 @@
+build-essential
+libnanomsg-dev
+libpq-dev
+libsqlite3-dev
+sqlite3
ADDED build-assist/iup-compile.sh
Index: build-assist/iup-compile.sh
==================================================================
--- /dev/null
+++ build-assist/iup-compile.sh
@@ -0,0 +1,21 @@
+if [[ -z $PREFIX ]];then
+ echo "PREFIX required"
+ exit
+fi
+
+echo "Put iup, im and cd .a and .so files in PREFIX/lib"
+echo " 1. get opensrc fossil from https://www.kiatoa.com/fossils/opensrc"
+echo " 2. list the unversioned files and export the cd, im and iup lib for your kernel (try uname -a for the kernel number) 4.15 ==> 415_64"
+echo " 3. untar iup, im and cp tars into a clean working dir and then copy:"
+echo " cp *.a *.so $PREFIX/lib"
+echo " cp include/*.h $PREFIX/include"
+echo " 4. run the chicken-install like this:"
+
+echo "If you use a wrapper (e.g. ck5) to create the chicken environment:"
+echo "CSC_OPTIONS=\"-I$PREFIX/include -I$PREFIX/include/im -I$PREFIX/include/cd -I$PREFIX/include/iup -L$PREFIX/lib -C -std=gnu99\" ck5 chicken-install iup -feature disable-iup-matrixex"
+echo "else:"
+echo "CSC_OPTIONS=\"-I$PREFIX/include -I$PREFIX/include/im -I$PREFIX/include/cd -I$PREFIX/include/iup -L$PREFIX/lib -C -std=gnu99\" chicken-install iup"
+echo "Then repeat for canvas-draw"
+
+# (export PREFIX=/home/matt/data/buildall/ck5.2;CSC_OPTIONS="-I/home/matt/data/buildall/ck5.2/include -I/home/matt/data/buildall/ck5.2/include/im -I/home/matt/data/buildall/ck5.2/include/cd -I/home/matt/data/buildall/ck5.2/include/iup -L/home/matt/data/buildall/ck5.2/lib -C -std=gnu99" ck5 chicken-install iup -feature disable-iup-matrixex)
+
ADDED build-assist/other-stuff
Index: build-assist/other-stuff
==================================================================
--- /dev/null
+++ build-assist/other-stuff
@@ -0,0 +1,2 @@
+cd megatest/dbi;chicken-install
+
DELETED common.scm
Index: common.scm
==================================================================
--- common.scm
+++ /dev/null
@@ -1,46 +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 .
-
-;;======================================================================
-
-;; (use srfi-1 data-structures posix regex-case (prefix base64 base64:)
-;; format dot-locking csv-xml z3 udp ;; sql-de-lite
-;; hostinfo md5 message-digest typed-records directory-utils stack
-;; matchable regex posix (srfi 18) extras ;; tcp
-;; (prefix nanomsg nmsg:)
-;; (prefix sqlite3 sqlite3:)
-;; pkts (prefix dbi dbi:)
-;; )
-;;
-;; (declare (unit common))
-;; ;; (declare (uses commonmod))
-;; ;; (import commonmod)
-;;
-;; (include "common_records.scm")
-
-
-;; (require-library margs)
-;; (include "margs.scm")
-
-;; (define old-exit exit)
-;;
-;; (define (exit . code)
-;; (if (null? code)
-;; (old-exit)
-;; (old-exit code)))
-
Index: common_records.scm
==================================================================
--- common_records.scm
+++ common_records.scm
@@ -18,11 +18,11 @@
;;
;;======================================================================
;; (use trace)
-(include "altdb.scm")
+;; (include "altdb.scm")
;; Some of these routines use:
;;
;; http://www.cs.toronto.edu/~gfb/scheme/simple-macros.html
;;
Index: commonmod.scm
==================================================================
--- commonmod.scm
+++ commonmod.scm
@@ -28,14 +28,490 @@
(declare (uses configfmod))
(declare (uses hostinfo))
(declare (uses keysmod))
;; odd but it works?
-(declare (uses itemsmod))
+;; (declare (uses itemsmod))
(module commonmod
- *
+ (
+make-db:test
+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-process_id
+db:test-get-archived
+db:test-get-last_update
+db:test-get-fullname
+db:test-make-full-name
+db:test-get-first_err
+db:test-get-first_warn
+db:test-set-cpuload!
+db:test-set-diskfree!
+db:test-set-testname!
+db:test-set-state!
+db:test-set-status!
+db:test-set-run_duration!
+db:test-set-final_logf!
+db:test-get-is-toplevel
+make-db:mintest
+db:mintest-get-id
+db:mintest-get-run_id
+db:mintest-get-testname
+db:mintest-get-state
+db:mintest-get-status
+db:mintest-get-event_time
+db:mintest-get-item_path
+make-db:testmeta
+db:testmeta-get-id
+db:testmeta-get-testname
+db:testmeta-get-author
+db:testmeta-get-owner
+db:testmeta-get-description
+db:testmeta-get-reviewed
+db:testmeta-get-iterated
+db:testmeta-get-avg_runtime
+db:testmeta-get-avg_disk
+db:testmeta-get-tags
+db:testmeta-set-id!
+db:testmeta-set-testname!
+db:testmeta-set-author!
+db:testmeta-set-owner!
+db:testmeta-set-description!
+db:testmeta-set-reviewed!
+db:testmeta-set-iterated!
+db:testmeta-set-avg_runtime!
+db:testmeta-set-avg_disk!
+make-db:test-data
+db:test-data-get-id
+db:test-data-get-test_id
+db:test-data-get-category
+db:test-data-get-variable
+db:test-data-get-value
+db:test-data-get-expected
+db:test-data-get-tol
+db:test-data-get-units
+db:test-data-get-comment
+db:test-data-get-status
+db:test-data-get-type
+db:test-data-get-last_update
+db:test-data-set-id!
+db:test-data-set-test_id!
+db:test-data-set-category!
+db:test-data-set-variable!
+db:test-data-set-value!
+db:test-data-set-expected!
+db:test-data-set-tol!
+db:test-data-set-units!
+db:test-data-set-comment!
+db:test-data-set-status!
+db:test-data-set-type!
+make-db:step
+tdb:step-get-id
+tdb:step-get-test_id
+tdb:step-get-stepname
+tdb:step-get-state
+tdb:step-get-status
+tdb:step-get-event_time
+tdb:step-get-logfile
+tdb:step-get-comment
+tdb:step-get-last_update
+tdb:step-set-id!
+tdb:step-set-test_id!
+tdb:step-set-stepname!
+tdb:step-set-state!
+tdb:step-set-status!
+tdb:step-set-event_time!
+tdb:step-set-logfile!
+tdb:step-set-comment!
+make-db:steps-table
+tdb:steps-table-get-stepname
+tdb:steps-table-get-start
+tdb:steps-table-get-end
+tdb:steps-table-get-status
+tdb:steps-table-get-runtime
+tdb:steps-table-get-log-file
+tdb:step-stable-set-stepname!
+tdb:step-stable-set-start!
+tdb:step-stable-set-end!
+tdb:step-stable-set-status!
+tdb:step-stable-set-runtime!
+make-cdb:packet
+cdb:packet-get-client-sig
+cdb:packet-get-qtype
+cdb:packet-get-immediate
+cdb:packet-get-query-sig
+cdb:packet-get-params
+cdb:packet-get-qtime
+cdb:packet-set-client-sig!
+cdb:packet-set-qtype!
+cdb:packet-set-immediate!
+cdb:packet-set-query-sig!
+cdb:packet-set-params!
+cdb:packet-set-qtime!
+runs:runrec-make-record
+runs:runrec-get-target
+runs:runrec-get-runname
+runs:runrec-testpatt
+runs:runrec-keys
+runs:runrec-keyvals
+runs:runrec-environment
+runs:runrec-mconfig
+runs:runrec-runconfig
+runs:runrec-serverdat
+runs:runrec-transport
+runs:runrec-db
+runs:runrec-top-path
+runs:runrec-run_id
+test:get-id
+test:get-run_id
+test:get-test-name
+test:get-state
+test:get-status
+test:get-item-path
+test:test-get-fullname
+make-and-init-bigdata
+call-with-environment-variables
+common:simple-file-lock
+common:simple-file-lock-and-wait
+common:simple-file-release-lock
+common:fail-safe
+get-file-descriptor-count
+common:get-this-exe-fullpath
+common:get-sync-lock-filepath
+common:find-local-megatest
+common:logpro-exit-code->status-sym
+common:worse-status-sym
+common:steps-can-proceed-given-status-sym
+status-sym->string
+common:logpro-exit-code->test-status
+common:clear-caches
+common:get-full-version
+common:version-signature
+common:snapshot-file
+common:rotate-logs
+make-sparse-array
+sparse-array?
+sparse-array-ref
+sparse-array-set!
+common:db-block-further-queries
+common:db-access-allowed?
+common:to-alist
+common:alist-ref/default
+common:low-noise-print
+common:get-megatest-exe
+common:read-encoded-string
+common:special-sort
+get-with-default
+assoc/default
+common:get-area-name
+common:get-toppath
+common:get-db-tmp-area
+common:get-signature
+common:get-area-path-signature
+common:calc-area-key
+common:get-area-key
+common:human-time
+std-signal-handler
+special-signal-handler
+any->number
+any->number-if-possible
+patt-list-match
+common:get-disks
+common:which
+common:get-install-area
+common:get-create-writeable-dir
+common:get-youngest
+common:bash-glob
+common:list-or-null
+common:get-runconfig-targets
+common:args-get-state
+common:args-get-status
+common:args-get-testpatt
+common:false-on-exception
+common:file-exists?
+common:directory-exists?
+common:directory-writable?
+common:get-linktree
+common:args-get-runname
+common:args-get-target
+common:get-full-test-name
+common:use-cache?
+common:force-server?
+common:list-is-sublist
+common:max
+common:min-max
+common:sum
+common:list->htree
+common:htree->html
+common:htree->atree
+common:sparse-list-generate-index
+common:lazy-convert
+common:val->alist
+common:lazy-modification-time
+common:lazy-sqlite-db-modification-time
+common:get-intercept
+common:get-delay
+common:print-delay-table
+get-cpu-load
+common:get-cached-info
+common:write-cached-info
+common:raw-get-remote-host-load
+common:get-cpu-load
+common:get-normalized-cpu-load
+common:get-normalized-cpu-load-raw
+common:unix-ping
+launch:is-test-alive
+common:get-num-cpus
+common:wait-for-normalized-load
+common:wait-for-cpuload
+tasks:kill-server
+server:get-logs-list
+server:get-list
+server:get-num-alive
+server:get-best
+server:get-first-best
+server:get-rand-best
+server:record->id
+server:get-num-servers
+server:logf-get-start-info
+get-uname
+realpath
+common:real-path
+common:get-disk-space-used
+get-df
+get-free-inodes
+get-unix-df
+get-unix-inodes
+common:check-space-in-dir
+common:check-db-dir-space
+common:check-db-dir-and-exit-if-insufficient
+common:get-disk-with-most-free-space
+common:spec-string->list-of-specs
+common:file-find-rule
+common:dir-clean-up
+bb-check-path
+save-environment-as-files
+common:get-param-mapping
+alist->env-vars
+get-the-original-environment
+common:with-orig-env
+common:without-vars
+common:run-a-command
+common:hms-string->seconds
+seconds->hr-min-sec
+seconds->time-string
+seconds->work-week/day-time
+seconds->work-week/day
+seconds->year-work-week/day
+seconds->year-work-week/day-time
+seconds->year-week/day-time
+seconds->quarter
+common:date-time->seconds
+common:find-start-mark-and-mark-delta
+common:expand-cron-slash
+common:cron-expand
+common:cron-event
+common:extended-cron
+common:name->iup-color
+common:iup-color->rgb-hex
+common:in-running-test?
+common:get-color-from-status
+common:load-views-config
+hh:make-hh
+hh:get
+hh:set!
+common:get-pkts-dirs
+common:save-pkt
+common:minimal-save-pkt
+common:get-pkt-alists
+common:get-pkt-times
+common:send-thunk-to-background-thread
+common:join-backgrounded-threads
+dtests:get-pre-command
+dtests:get-post-command
+db:patt->like
+tests:cache-regexp
+tests:glob-like-match
+tests:match
+tests:match->sqlqry
+tests:get-itemmaps
+tests:lookup-itemmap
+tests:get-tests-search-path
+server:get-best-guess-address
+tests:readlines
+server:expiration-timeout
+runs:get-mt-env-alist
+keys:make-key/field-string
+sexpr->string
+string->sexpr
+*bdat*
+*user-hash-data*
+*db-keys*
+*pkts-info*
+*configinfo*
+*runconfigdat*
+*configdat*
+*configstatus*
+*toppath*
+*already-seen-runconfig-info*
+*test-meta-updated*
+*globalexitstatus*
+*passnum*
+*common:denoise*
+*time-zero*
+*default-area-tag*
+*dbstruct-db*
+*db-stats*
+*db-stats-mutex*
+*db-last-access*
+*db-write-access*
+*db-last-sync*
+*db-sync-in-progress*
+*db-multi-sync-mutex*
+*task-db*
+*db-access-allowed*
+*db-access-mutex*
+*db-transaction-mutex*
+*db-cache-path*
+*db-with-db-mutex*
+*db-api-call-time*
+*no-sync-db*
+*my-signature*
+*transport-type*
+*logged-in-clients*
+*server-info*
+*server-run*
+*run-id*
+*server-kind-run*
+*home-host*
+*heartbeat-mutex*
+*api-process-request-count*
+*max-api-process-requests*
+*server-overloaded*
+*writes-total-delay*
+*unclean-shutdown*
+*rmt-mutex*
+*keys*
+*keyvals*
+*toptest-paths*
+*test-paths*
+*test-ids*
+*test-info*
+*run-info-cache*
+*launch-setup-mutex*
+*homehost-mutex*
+*triggers-mutex*
+*numcpus-cache*
+*host-loads*
+*env-vars-by-run-id*
+*testconfigs*
+*runconfigs*
+*pre-reqs-met-cache*
+*verbosity-cache*
+*fdb*
+*last-launch*
+*common:std-states*
+*common:dont-roll-up-states*
+*common:std-statuses*
+*common:ended-states*
+*common:badly-ended-states*
+*common:well-ended-states*
+*common:running-states*
+*common:cant-run-states*
+*common:not-started-ok-statuses*
+*verbosity*
+*logging*
+*common:thread-punchlist*
+*last-num-running-tests*
+*seen-cant-run-tests*
+*runs:denoise*
+*max-tries-hash*
+*send-receive-mutex*
+*db:process-queue-mutex*
+*http-functions*
+*http-mutex*
+*http-requests-in-progress*
+*http-connections-next-cleanup*
+*number-of-writes*
+*number-non-write-queries*
+*global-db-store*
+*common:logpro-exit-code->status-sym-alist*
+*glob-like-match-cache*
+
+;; bad name - clean this up
+keys:config-get-fields
+sdb:qry
+
+;; record accessors and settors
+
+bdat-home
+bdat-user
+bdat-watchdog
+bdat-time-to-exit
+bdat-task-db
+bdat-target
+bdat-this-exe-fullpath
+bdat-this-exe-dir
+bdat-this-exe-name
+bdat-orig-env
+bdat-runs-data
+
+bdat-task-db-set!
+bdat-time-to-exit-set!
+bdat-watchdog-set!
+bdat-task-db-set!
+bdat-target-set!
+
+make-launch:einf
+launch:einf-pid
+launch:einf-exit-status
+launch:einf-exit-code
+launch:einf-rollup-status
+launch:einf-pid-set!
+launch:einf-exit-status-set!
+launch:einf-exit-code-set!
+launch:einf-rollup-status-set!
+
+make-host
+host-reachable
+host-last-update
+host-last-used
+host-last-cpuload
+host-reachable-set!
+host-last-update-set!
+host-last-used-set!
+host-last-cpuload-set!
+
+runs:gendat-inc-results
+runs:gendat-inc-results-last-update
+runs:gendat-inc-results-fmt
+runs:gendat-run-info
+runs:gendat-runname
+runs:gendat-target
+runs:gendat-inc-results-set!
+runs:gendat-inc-results-last-update-set!
+runs:gendat-inc-results-fmt-set!
+runs:gendat-run-info-set!
+runs:gendat-runname-set!
+runs:gendat-target-set!
+
+megatest-fossil-hash
+)
+
(import scheme
chicken.base
chicken.condition
chicken.file
@@ -78,11 +554,11 @@
pkts
processmod
(prefix mtargs args:)
configfmod
keysmod
- itemsmod
+ ;; itemsmod
hostinfo
)
;;======================================================================
;; CONTENTS
@@ -92,11 +568,292 @@
;; testsuite and area utilites
;;
;;======================================================================
(include "megatest-fossil-hash.scm")
-(include "db_records.scm")
+
+;;======================================================================
+;; Make available the old db_records.scm stuff
+;;======================================================================
+;;
+
+;; (include "db_records.scm")
+
+;;======================================================================
+;; dbstruct
+;;======================================================================
+
+;;
+;; -path-|-megatest.db
+;; |-db-|-main.db
+;; |-monitor.db
+;; |-sdb.db
+;; |-fdb.db
+;; |-1.db
+;; |-.db
+;;
+;;
+;; Accessors for a dbstruct
+;;
+
+;; (define-inline (dbr:dbstruct-main vec) (vector-ref vec 0)) ;; ( db path )
+;; (define-inline (dbr:dbstruct-strdb vec) (vector-ref vec 1)) ;; ( db path )
+;; (define-inline (dbr:dbstruct-path vec) (vector-ref vec 2))
+;; (define-inline (dbr:dbstruct-local vec) (vector-ref vec 3))
+;; (define-inline (dbr:dbstruct-rundb vec) (vector-ref vec 4)) ;; ( db path )
+;; (define-inline (dbr:dbstruct-inmem vec) (vector-ref vec 5)) ;; ( db #f )
+;; (define-inline (dbr:dbstruct-mtime vec) (vector-ref vec 6))
+;; (define-inline (dbr:dbstruct-rtime vec) (vector-ref vec 7))
+;; (define-inline (dbr:dbstruct-stime vec) (vector-ref vec 8))
+;; (define-inline (dbr:dbstruct-inuse vec) (vector-ref vec 9))
+;; (define-inline (dbr:dbstruct-refdb vec) (vector-ref vec 10)) ;; ( db path )
+;; (define-inline (dbr:dbstruct-locdbs vec) (vector-ref vec 11))
+;; (define-inline (dbr:dbstruct-olddb vec) (vector-ref vec 12)) ;; ( db path )
+;; ;; (define-inline (dbr:dbstruct-main-path vec) (vector-ref vec 13))
+;; ;; (define-inline (dbr:dbstruct-rundb-path vec) (vector-ref vec 14))
+;; ;; (define-inline (dbr:dbstruct-run-id vec) (vector-ref vec 13))
+;;
+;; (define-inline (dbr:dbstruct-main-set! vec val)(vector-set! vec 0 val))
+;; (define-inline (dbr:dbstruct-strdb-set! vec val)(vector-set! vec 1 val))
+;; (define-inline (dbr:dbstruct-path-set! vec val)(vector-set! vec 2 val))
+;; (define-inline (dbr:dbstruct-local-set! vec val)(vector-set! vec 3 val))
+;; (define-inline (dbr:dbstruct-rundb-set! vec val)(vector-set! vec 4 val))
+;; (define-inline (dbr:dbstruct-inmem-set! vec val)(vector-set! vec 5 val))
+;; (define-inline (dbr:dbstruct-mtime-set! vec val)(vector-set! vec 6 val))
+;; (define-inline (dbr:dbstruct-rtime-set! vec val)(vector-set! vec 7 val))
+;; (define-inline (dbr:dbstruct-stime-set! vec val)(vector-set! vec 8 val))
+;; (define-inline (dbr:dbstruct-inuse-set! vec val)(vector-set! vec 9 val))
+;; (define-inline (dbr:dbstruct-refdb-set! vec val)(vector-set! vec 10 val))
+;; (define-inline (dbr:dbstruct-locdbs-set! vec val)(vector-set! vec 11 val))
+;; (define-inline (dbr:dbstruct-olddb-set! vec val)(vector-set! vec 12 val))
+;; (define-inline (dbr:dbstruct-main-path-set! vec val)(vector-set! vec 13 val))
+;; (define-inline (dbr:dbstruct-rundb-path-set! vec val)(vector-set! vec 14 val))
+;;
+; (define-inline (dbr:dbstruct-run-id-set! vec val)(vector-set! vec 13 val))
+
+;; constructor for dbstruct
+;;
+;; (define (make-dbr:dbstruct #!key (path #f)(local #f))
+;; (let ((v (make-vector 15 #f)))
+;; (dbr:dbstruct-path-set! v path)
+;; (dbr:dbstruct-local-set! v local)
+;; (dbr:dbstruct-locdbs-set! v (make-hash-table))
+;; v))
+
+
+(define (make-db:test)(make-vector 20))
+(define (db:test-get-id vec) (vector-ref vec 0))
+(define (db:test-get-run_id vec) (vector-ref vec 1))
+(define (db:test-get-testname vec) (vector-ref vec 2))
+(define (db:test-get-state vec) (vector-ref vec 3))
+(define (db:test-get-status vec) (vector-ref vec 4))
+(define (db:test-get-event_time vec) (vector-ref vec 5))
+(define (db:test-get-host vec) (vector-ref vec 6))
+(define (db:test-get-cpuload vec) (vector-ref vec 7))
+(define (db:test-get-diskfree vec) (vector-ref vec 8))
+(define (db:test-get-uname vec) (vector-ref vec 9))
+;; (define (db:test-get-rundir vec) (sdb:qry 'getstr (vector-ref vec 10)))
+(define (db:test-get-rundir vec) (vector-ref vec 10))
+(define (db:test-get-item-path vec) (vector-ref vec 11))
+(define (db:test-get-run_duration vec) (vector-ref vec 12))
+(define (db:test-get-final_logf vec) (vector-ref vec 13))
+(define (db:test-get-comment vec) (vector-ref vec 14))
+(define (db:test-get-process_id vec) (vector-ref vec 16))
+(define (db:test-get-archived vec) (vector-ref vec 17))
+(define (db:test-get-last_update vec) (vector-ref vec 18))
+
+;; (define (db:test-get-pass_count vec) (vector-ref vec 15))
+;; (define (db:test-get-fail_count vec) (vector-ref vec 16))
+(define (db:test-get-fullname vec)
+ (conc (db:test-get-testname vec) "/" (db:test-get-item-path vec)))
+
+;; replace runs:make-full-test-name with this routine
+(define (db:test-make-full-name testname itempath)
+ (if (equal? itempath "") testname (conc testname "/" itempath)))
+
+(define (db:test-get-first_err vec) (conc #;printable (vector-ref vec 15)))
+(define (db:test-get-first_warn vec) (conc #;printable (vector-ref vec 16))) ;; RADT => reference 16 is repeated
+
+(define (db:test-set-cpuload! vec val)(vector-set! vec 7 val))
+(define (db:test-set-diskfree! vec val)(vector-set! vec 8 val))
+(define (db:test-set-testname! vec val)(vector-set! vec 2 val))
+(define (db:test-set-state! vec val)(vector-set! vec 3 val))
+(define (db:test-set-status! vec val)(vector-set! vec 4 val))
+(define (db:test-set-run_duration! vec val)(vector-set! vec 12 val))
+(define (db:test-set-final_logf! vec val)(vector-set! vec 13 val))
+
+;; Test record utility functions
+
+;; Is a test a toplevel?
+;;
+(define (db:test-get-is-toplevel vec)
+ (and (equal? (db:test-get-item-path vec) "") ;; test is not an item
+ (equal? (db:test-get-uname vec) "n/a"))) ;; test has never been run
+
+;; make-vector-record "" db mintest id run_id testname state status event_time item_path
+;; RADT => purpose of mintest??
+;;
+(define (make-db:mintest)(make-vector 7))
+(define (db:mintest-get-id vec) (vector-ref vec 0))
+(define (db:mintest-get-run_id vec) (vector-ref vec 1))
+(define (db:mintest-get-testname vec) (vector-ref vec 2))
+(define (db:mintest-get-state vec) (vector-ref vec 3))
+(define (db:mintest-get-status vec) (vector-ref vec 4))
+(define (db:mintest-get-event_time vec) (vector-ref vec 5))
+(define (db:mintest-get-item_path vec) (vector-ref vec 6))
+
+;; make-vector-record db testmeta id testname author owner description reviewed iterated avg_runtime avg_disk
+(define (make-db:testmeta)(make-vector 10 ""))
+(define (db:testmeta-get-id vec) (vector-ref vec 0))
+(define (db:testmeta-get-testname vec) (vector-ref vec 1))
+(define (db:testmeta-get-author vec) (vector-ref vec 2))
+(define (db:testmeta-get-owner vec) (vector-ref vec 3))
+(define (db:testmeta-get-description vec) (vector-ref vec 4))
+(define (db:testmeta-get-reviewed vec) (vector-ref vec 5))
+(define (db:testmeta-get-iterated vec) (vector-ref vec 6))
+(define (db:testmeta-get-avg_runtime vec) (vector-ref vec 7))
+(define (db:testmeta-get-avg_disk vec) (vector-ref vec 8))
+(define (db:testmeta-get-tags vec) (vector-ref vec 9))
+(define (db:testmeta-set-id! vec val)(vector-set! vec 0 val))
+(define (db:testmeta-set-testname! vec val)(vector-set! vec 1 val))
+(define (db:testmeta-set-author! vec val)(vector-set! vec 2 val))
+(define (db:testmeta-set-owner! vec val)(vector-set! vec 3 val))
+(define (db:testmeta-set-description! vec val)(vector-set! vec 4 val))
+(define (db:testmeta-set-reviewed! vec val)(vector-set! vec 5 val))
+(define (db:testmeta-set-iterated! vec val)(vector-set! vec 6 val))
+(define (db:testmeta-set-avg_runtime! vec val)(vector-set! vec 7 val))
+(define (db:testmeta-set-avg_disk! vec val)(vector-set! vec 8 val))
+
+;;======================================================================
+;; S I M P L E R U N
+;;======================================================================
+
+;; (defstruct id "runname" "state" "status" "owner" "event_time"
+
+;;======================================================================
+;; T E S T D A T A
+;;======================================================================
+(define (make-db:test-data)(make-vector 10))
+(define (db:test-data-get-id vec) (vector-ref vec 0))
+(define (db:test-data-get-test_id vec) (vector-ref vec 1))
+(define (db:test-data-get-category vec) (vector-ref vec 2))
+(define (db:test-data-get-variable vec) (vector-ref vec 3))
+(define (db:test-data-get-value vec) (vector-ref vec 4))
+(define (db:test-data-get-expected vec) (vector-ref vec 5))
+(define (db:test-data-get-tol vec) (vector-ref vec 6))
+(define (db:test-data-get-units vec) (vector-ref vec 7))
+(define (db:test-data-get-comment vec) (vector-ref vec 8))
+(define (db:test-data-get-status vec) (vector-ref vec 9))
+(define (db:test-data-get-type vec) (vector-ref vec 10))
+(define (db:test-data-get-last_update vec) (vector-ref vec 11))
+
+(define (db:test-data-set-id! vec val)(vector-set! vec 0 val))
+(define (db:test-data-set-test_id! vec val)(vector-set! vec 1 val))
+(define (db:test-data-set-category! vec val)(vector-set! vec 2 val))
+(define (db:test-data-set-variable! vec val)(vector-set! vec 3 val))
+(define (db:test-data-set-value! vec val)(vector-set! vec 4 val))
+(define (db:test-data-set-expected! vec val)(vector-set! vec 5 val))
+(define (db:test-data-set-tol! vec val)(vector-set! vec 6 val))
+(define (db:test-data-set-units! vec val)(vector-set! vec 7 val))
+(define (db:test-data-set-comment! vec val)(vector-set! vec 8 val))
+(define (db:test-data-set-status! vec val)(vector-set! vec 9 val))
+(define (db:test-data-set-type! vec val)(vector-set! vec 10 val))
+
+;;======================================================================
+;; S T E P S
+;;======================================================================
+;; Run steps
+;; make-vector-record "Run steps" db step id test_id stepname step_complete step_pass event_time
+(define (make-db:step)(make-vector 9))
+(define (tdb:step-get-id vec) (vector-ref vec 0))
+(define (tdb:step-get-test_id vec) (vector-ref vec 1))
+(define (tdb:step-get-stepname vec) (vector-ref vec 2))
+(define (tdb:step-get-state vec) (vector-ref vec 3))
+(define (tdb:step-get-status vec) (vector-ref vec 4))
+(define (tdb:step-get-event_time vec) (vector-ref vec 5))
+(define (tdb:step-get-logfile vec) (vector-ref vec 6))
+(define (tdb:step-get-comment vec) (vector-ref vec 7))
+(define (tdb:step-get-last_update vec) (vector-ref vec 8))
+(define (tdb:step-set-id! vec val)(vector-set! vec 0 val))
+(define (tdb:step-set-test_id! vec val)(vector-set! vec 1 val))
+(define (tdb:step-set-stepname! vec val)(vector-set! vec 2 val))
+(define (tdb:step-set-state! vec val)(vector-set! vec 3 val))
+(define (tdb:step-set-status! vec val)(vector-set! vec 4 val))
+(define (tdb:step-set-event_time! vec val)(vector-set! vec 5 val))
+(define (tdb:step-set-logfile! vec val)(vector-set! vec 6 val))
+(define (tdb:step-set-comment! vec val)(vector-set! vec 7 val))
+
+
+;; The steps table
+(define (make-db:steps-table)(make-vector 5))
+(define (tdb:steps-table-get-stepname vec) (vector-ref vec 0))
+(define (tdb:steps-table-get-start vec) (vector-ref vec 1))
+(define (tdb:steps-table-get-end vec) (vector-ref vec 2))
+(define (tdb:steps-table-get-status vec) (vector-ref vec 3))
+(define (tdb:steps-table-get-runtime vec) (vector-ref vec 4))
+(define (tdb:steps-table-get-log-file vec) (vector-ref vec 5))
+
+(define (tdb:step-stable-set-stepname! vec val)(vector-set! vec 0 val))
+(define (tdb:step-stable-set-start! vec val)(vector-set! vec 1 val))
+(define (tdb:step-stable-set-end! vec val)(vector-set! vec 2 val))
+(define (tdb:step-stable-set-status! vec val)(vector-set! vec 3 val))
+(define (tdb:step-stable-set-runtime! vec val)(vector-set! vec 4 val))
+
+;; The data structure for handing off requests via wire
+(define (make-cdb:packet)(make-vector 6))
+(define (cdb:packet-get-client-sig vec) (vector-ref vec 0))
+(define (cdb:packet-get-qtype vec) (vector-ref vec 1))
+(define (cdb:packet-get-immediate vec) (vector-ref vec 2))
+(define (cdb:packet-get-query-sig vec) (vector-ref vec 3))
+(define (cdb:packet-get-params vec) (vector-ref vec 4))
+(define (cdb:packet-get-qtime vec) (vector-ref vec 5))
+(define (cdb:packet-set-client-sig! vec val)(vector-set! vec 0 val))
+(define (cdb:packet-set-qtype! vec val)(vector-set! vec 1 val))
+(define (cdb:packet-set-immediate! vec val)(vector-set! vec 2 val))
+(define (cdb:packet-set-query-sig! vec val)(vector-set! vec 3 val))
+(define (cdb:packet-set-params! vec val)(vector-set! vec 4 val))
+(define (cdb:packet-set-qtime! vec val)(vector-set! vec 5 val))
+
+;;======================================================================
+;; end of old db_records.scm
+;;
+
+;;======================================================================
+;; old run_records stuff
+;;
+
+(define (runs:runrec-make-record) (make-vector 13))
+(define (runs:runrec-get-target vec)(vector-ref vec 0)) ;; a/b/c
+(define (runs:runrec-get-runname vec)(vector-ref vec 1)) ;; string
+(define (runs:runrec-testpatt vec)(vector-ref vec 2)) ;; a,b/c,d%
+(define (runs:runrec-keys vec)(vector-ref vec 3)) ;; (key1 key2 ...)
+(define (runs:runrec-keyvals vec)(vector-ref vec 4)) ;; ((key1 val1)(key2 val2) ...)
+(define (runs:runrec-environment vec)(vector-ref vec 5)) ;; environment, alist key val
+(define (runs:runrec-mconfig vec)(vector-ref vec 6)) ;; megatest.config
+(define (runs:runrec-runconfig vec)(vector-ref vec 7)) ;; runconfigs.config
+(define (runs:runrec-serverdat vec)(vector-ref vec 8)) ;; (host port)
+(define (runs:runrec-transport vec)(vector-ref vec 9)) ;; 'http
+(define (runs:runrec-db vec)(vector-ref vec 10)) ;; (if 'fs)
+(define (runs:runrec-top-path vec)(vector-ref vec 11)) ;; *toppath*
+(define (runs:runrec-run_id vec)(vector-ref vec 12)) ;; run-id
+
+(define (test:get-id vec) (vector-ref vec 0))
+(define (test:get-run_id vec) (vector-ref vec 1))
+(define (test:get-test-name vec)(vector-ref vec 2))
+(define (test:get-state vec) (vector-ref vec 3))
+(define (test:get-status vec) (vector-ref vec 4))
+(define (test:get-item-path vec)(vector-ref vec 5))
+
+(define (test:test-get-fullname test)
+ (conc (db:test-get-testname test)
+ (if (equal? (db:test-get-item-path test) "")
+ ""
+ (conc "(" (db:test-get-item-path test) ")"))))
+
+;;======================================================================
+;; end of run_records
+;;
;; these come from processmod
;;
;; (define setenv set-environment-variable!)
;; (define unsetenv unset-environment-variable!)
@@ -108,12 +865,12 @@
(define *bdat* #f) ;; the one and only (someday) global?
(defstruct bdat
- (home (getenv "HOME"))
- (user (getenv "USER"))
+ (home (get-environment-variable "HOME"))
+ (user (get-environment-variable "USER"))
(watchdog #f)
(time-to-exit #f)
(task-db #f)
(target #f)
(this-exe-fullpath #f)
@@ -153,12 +910,12 @@
(set-signal-handler! signal/term std-signal-handler)
;; (set-signal-handler! signal/stop std-signal-handler) ;; ^Z NO, do NOT handle ^Z!
bdat))
-;; (define home (getenv "HOME"))
-;; (define user (getenv "USER"))
+;; (define home (get-environment-variable "HOME"))
+;; (define user (get-environment-variable "USER"))
(define keys:config-get-fields common:get-fields)
;; Globals
;;
;;(define *server-loop-heart-beat* (current-seconds))
@@ -171,11 +928,11 @@
(define *db-keys* #f)
(define *pkts-info* (make-hash-table)) ;; store stuff like the last parent here
(define *configinfo* #f) ;; raw results from setup, includes toppath and table from megatest.config
(define *runconfigdat* #f) ;; run configs data
-;; (define *configdat* #f) ;; megatest.config data ==> moved to configfmod
+(define *configdat* #f) ;; megatest.config data ==> moved to configfmod
(define *configstatus* #f) ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done
(define *toppath* #f)
(define *already-seen-runconfig-info* #f)
(define *test-meta-updated* (make-hash-table))
@@ -228,17 +985,15 @@
(define *heartbeat-mutex* (make-mutex))
(define *api-process-request-count* 0)
(define *max-api-process-requests* 0)
(define *server-overloaded* #f)
(define *writes-total-delay* 0)
+(define *unclean-shutdown* #t) ;; flag to clear on clean shutdown
;; client
(define *rmt-mutex* (make-mutex)) ;; remote access calls mutex
-;; RPC transport
-(define *rpc:listener* #f)
-
;; KEY info
;; (define *target* (make-hash-table)) ;; cache the target here; target is keyval1/keyval2/.../keyvalN
(define *keys* (make-hash-table)) ;; cache the keys here
(define *keyvals* (make-hash-table))
(define *toptest-paths* (make-hash-table)) ;; cache toptest path settings here
@@ -408,20 +1163,20 @@
(dynamic-wind
(lambda () (void))
(lambda ()
;; (use posix)
(for-each (lambda (var-value)
- (setenv (car var-value) (cdr var-value)))
+ (set-environment-variable! (car var-value) (cdr var-value)))
variables)
(thunk))
(lambda ()
(for-each (lambda (var-value)
(let ((var (car var-value))
(value (cdr var-value)))
(if value
- (setenv var value)
- (unsetenv var))))
+ (set-environment-variable! var value)
+ (unset-environment-variable! var))))
pre-existing-variables)))))
;; dot-locking egg seems not to work, using this for now
;; if lock is older than expire-time then remove it and try again
;; to get the lock
@@ -902,11 +1657,11 @@
(hash-table-set! *common:denoise* key currtime)
#t)
#f)))
(define (common:get-megatest-exe)
- (or (getenv "MT_MEGATEST") "megatest"))
+ (or (get-environment-variable "MT_MEGATEST") "megatest"))
(define (common:read-encoded-string instr)
(handle-exceptions
exn
(handle-exceptions
@@ -991,11 +1746,11 @@
(if res (cadr res)(if (null? default) #f (car default)))))
(define (common:get-area-name)
(or (configf:lookup *configdat* "setup" "area-name") ;; megatest is a flexible tool, testsuite is too limiting a description.
(configf:lookup *configdat* "setup" "testsuite" )
- (getenv "MT_TESTSUITE_NAME")
+ (get-environment-variable "MT_TESTSUITE_NAME")
(pathname-file (or (if (string? *toppath* )
(pathname-file *toppath*)
#f)
(common:get-toppath #f)))
"please-set-setup-area-name")) ;; (pathname-file (current-directory)))))
@@ -1005,16 +1760,16 @@
(define (common:get-toppath areapath)
(or *toppath*
(if areapath
(begin
(set! *toppath* areapath)
- (setenv "MT_RUN_AREA_HOME" areapath)
+ (set-environment-variable! "MT_RUN_AREA_HOME" areapath)
areapath)
#f)
- (if (getenv "MT_RUN_AREA_HOME")
+ (if (get-environment-variable "MT_RUN_AREA_HOME")
(begin
- (set! *toppath* (getenv "MT_RUN_AREA_HOME"))
+ (set! *toppath* (get-environment-variable "MT_RUN_AREA_HOME"))
*toppath*)
#f)
;; last resort, look for megatest.config
(let loop ((thepath (realpath ".")))
(if (file-exists? (conc thepath "/megatest.config"))
@@ -1255,36 +2010,27 @@
(filter (lambda (x)
(patt-list-match x target-patt))
targs)
targs)))
-;;======================================================================
-;; Lookup a value in runconfigs based on -reqtarg or -target
-;;
-(define (runconfigs-get config var)
- (let ((targ (common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET"))))
- (if targ
- (or (configf:lookup config targ var)
- (configf:lookup config "default" var))
- (configf:lookup config "default" var))))
-
(define (common:args-get-state)
(or (args:get-arg "-state")(args:get-arg ":state")))
(define (common:args-get-status)
(or (args:get-arg "-status")(args:get-arg ":status")))
(define (common:args-get-testpatt rconf)
- (let* (;; (tagexpr (args:get-arg "-tagexpr"))
+ (let* ((target (common:args-get-target))
+ ;; (tagexpr (args:get-arg "-tagexpr"))
;; (tags-testpatt (if tagexpr (string-join (runs:get-tests-matching-tags tagexpr) ",") #f))
(testpatt-key (or (args:get-arg "-modepatt") (args:get-arg "--modepatt") "TESTPATT"))
(args-testpatt (or (args:get-arg "-testpatt") (args:get-arg "-runtests") "%"))
- (rtestpatt (if rconf (runconfigs-get rconf testpatt-key) #f)))
+ (rtestpatt (if rconf (runconfigs-get rconf target testpatt-key) #f)))
(cond
((or (args:get-arg "--modepatt") (args:get-arg "-modepatt")) ;; modepatt is a forced setting, when set it MUST refer to an existing PATT in the runconfig
(if rconf
- (let* ((patts-from-mode-patt (runconfigs-get rconf testpatt-key)))
+ (let* ((patts-from-mode-patt (runconfigs-get rconf target testpatt-key)))
(debug:print-info 0 *default-log-port* "modepatt defined is: "testpatt-key" runconfigs values for " testpatt-key " " patts-from-mode-patt)
patts-from-mode-patt)
(begin
(debug:print-info 0 *default-log-port* " modepatt defined is: "testpatt-key" runconfigs values for " testpatt-key) ;; " " patts-from-mode-patt)
#f))) ;; We do NOT fall back to "%"
@@ -1334,35 +2080,35 @@
(file-writable? path-string))
path-string
#f)))
(define (common:get-linktree)
- (or (getenv "MT_LINKTREE")
+ (or (get-environment-variable "MT_LINKTREE")
(if *configdat*
(configf:lookup *configdat* "setup" "linktree")
#f)
- (if (or *toppath* (getenv "MT_RUN_AREA_HOME"))
- (conc (or *toppath* (getenv "MT_RUN_AREA_HOME")) "/lt")
+ (if (or *toppath* (get-environment-variable "MT_RUN_AREA_HOME"))
+ (conc (or *toppath* (get-environment-variable "MT_RUN_AREA_HOME")) "/lt")
#f)
(let* ((tp (common:get-toppath #f))
(lt (conc tp "/lt")))
(if (not tp)(debug:print 0 *default-log-port* "WARNING: cannot calculate best path for linktree, using " lt))
lt)))
(define (common:args-get-runname)
(let ((res (or (args:get-arg "-runname")
(args:get-arg ":runname")
- (getenv "MT_RUNNAME"))))
- ;; (if res (set-environment-variable "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ...
+ (get-environment-variable "MT_RUNNAME"))))
+ ;; (if res (set-environment-variable! "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ...
res))
(define (common:args-get-target #!key (split #f)(exit-if-bad #f))
(let* ((keys (if (hash-table? *configdat*) (common:get-fields *configdat*) '()))
(numkeys (length keys))
(target (or (args:get-arg "-reqtarg")
(args:get-arg "-target")
- (getenv "MT_TARGET")))
+ (get-environment-variable "MT_TARGET")))
(tlist (if target (string-split target "/" #t) '()))
(valid (if target
(or (null? keys) ;; probably don't know our keys yet
(and (not (null? tlist))
(eq? numkeys (length tlist))
@@ -1381,15 +2127,15 @@
;;======================================================================
;; looking only (at least for now) at the MT_ variables craft the full testname
;;
(define (common:get-full-test-name)
- (if (getenv "MT_TEST_NAME")
- (if (and (getenv "MT_ITEMPATH")
- (not (equal? (getenv "MT_ITEMPATH") "")))
- (getenv "MT_TEST_NAME")
- (conc (getenv "MT_TEST_NAME") "/" (getenv "MT_ITEMPATH")))
+ (if (get-environment-variable "MT_TEST_NAME")
+ (if (and (get-environment-variable "MT_ITEMPATH")
+ (not (equal? (get-environment-variable "MT_ITEMPATH") "")))
+ (get-environment-variable "MT_TEST_NAME")
+ (conc (get-environment-variable "MT_TEST_NAME") "/" (get-environment-variable "MT_ITEMPATH")))
#f))
;;======================================================================
;; do we honor the caches of the config files?
;;
@@ -1399,14 +2145,14 @@
(if (equal? (configf:lookup *configdat* "setup" "use-cache") "no")
(set! res #f)
(if (equal? (configf:lookup *configdat* "setup" "use-cache") "yes")
(set! res #t))))
(if (args:get-arg "-no-cache")(set! res #f)) ;; overrides setting in "setup"
- (if (getenv "MT_USE_CACHE")
- (if (equal? (getenv "MT_USE_CACHE") "yes")
+ (if (get-environment-variable "MT_USE_CACHE")
+ (if (equal? (get-environment-variable "MT_USE_CACHE") "yes")
(set! res #t)
- (if (equal? (getenv "MT_USE_CACHE") "no")
+ (if (equal? (get-environment-variable "MT_USE_CACHE") "no")
(set! res #f)))) ;; overrides -no-cache switch
res))
;;======================================================================
;; force use of server?
@@ -2061,27 +2807,27 @@
;; no elegance here ...
;;
(define (tasks:kill-server hostname pid #!key (kill-switch ""))
(debug:print-info 0 *default-log-port* "Attempting to kill server process " pid " on host " hostname)
- (setenv "TARGETHOST" hostname)
+ (set-environment-variable! "TARGETHOST" hostname)
(let* ((logdir (if (directory-exists? "logs")
"logs/"
""))
(logfile (if logdir (conc "logs/server-"pid"-"hostname".log") #f))
(gzfile (if logfile (conc logfile ".gz"))))
- (setenv "TARGETHOST_LOGF" (conc logdir "server-kills.log"))
+ (set-environment-variable! "TARGETHOST_LOGF" (conc logdir "server-kills.log"))
(system (conc "nbfake kill "kill-switch" "pid))
(when logfile
(thread-sleep! 0.5)
(if (file-exists? gzfile) (delete-file gzfile))
(system (conc "gzip " logfile))
- (unsetenv "TARGETHOST_LOGF")
- (unsetenv "TARGETHOST"))))
+ (unset-environment-variable! "TARGETHOST_LOGF")
+ (unset-environment-variable! "TARGETHOST"))))
(define (server:get-logs-list area-path)
(let* (;; (server-logs-cmd (conc "grep -iL exiting " area-path "/logs/server-*-*.log"))
;; (server-logs (string-split (string-chomp (with-input-from-pipe server-logs-cmd read-string))))
(server-logs (glob (conc area-path"/logs/server-*-*.log")))
@@ -2713,11 +3459,11 @@
(val (cadr p))
(prv (get-environment-variable var)))
(set! res (cons (list var prv) res))
(if val
(safe-setenv var (->string val))
- (unsetenv var))))
+ (unset-environment-variable! var))))
lst)
res)
'()))
;;======================================================================
@@ -2737,17 +3483,17 @@
x))
envvars))))
(define (common:with-orig-env proc)
(let ((current-env (get-environment-variables)))
- (for-each (lambda (x) (unsetenv (car x))) current-env)
- (for-each (lambda (x) (setenv (car x) (cdr x))) (bdat-orig-env *bdat*))
+ (for-each (lambda (x) (unset-environment-variable! (car x))) current-env)
+ (for-each (lambda (x) (set-environment-variable! (car x) (cdr x))) (bdat-orig-env *bdat*))
(let ((rv (cond
((string? proc)(system proc))
(proc (proc)))))
- (for-each (lambda (x) (unsetenv (car x))) (bdat-orig-env *bdat*))
- (for-each (lambda (x) (setenv (car x) (cdr x))) current-env)
+ (for-each (lambda (x) (unset-environment-variable! (car x))) (bdat-orig-env *bdat*))
+ (for-each (lambda (x) (set-environment-variable! (car x) (cdr x))) current-env)
rv)))
(define (common:without-vars proc . var-patts)
(let ((vars (make-hash-table)))
(for-each
@@ -2756,20 +3502,20 @@
(lambda (var-patt)
(if (string-match var-patt (car vardat))
(let ((var (car vardat))
(val (cdr vardat)))
(hash-table-set! vars var val)
- (unsetenv var))))
+ (unset-environment-variable! var))))
var-patts))
(get-environment-variables))
(cond
((string? proc)(system proc))
(proc (proc)))
(hash-table-for-each
vars
(lambda (var val)
- (setenv var val)))
+ (set-environment-variable! var val)))
vars))
(define (common:run-a-command cmd #!key (with-vars #f) (with-orig-env #f))
(let* ((pre-cmd (dtests:get-pre-command))
(post-cmd (dtests:get-post-command))
@@ -3576,38 +4322,10 @@
((null? res) #f)
((string? (cdr res)) (cdr res)) ;; it is a pair
((string? (cadr res))(cadr res)) ;; it is a list
(else cadr res))))))
-;; return items given config
-;;
-(define (tests:get-items tconfig)
- (let ((items (hash-table-ref/default tconfig "items" #f)) ;; items 4
- (itemstable (hash-table-ref/default tconfig "itemstable" #f)))
- ;; if either items or items table is a proc return it so test running
- ;; process can know to call items:get-items-from-config
- ;; if either is a list and none is a proc go ahead and call get-items
- ;; otherwise return #f - this is not an iterated test
- (cond
- ((procedure? items)
- (debug:print-info 4 *default-log-port* "items is a procedure, will calc later")
- items) ;; calc later
- ((procedure? itemstable)
- (debug:print-info 4 *default-log-port* "itemstable is a procedure, will calc later")
- itemstable) ;; calc later
- ((filter (lambda (x)
- (let ((val (car x)))
- (if (procedure? val) val #f)))
- (append (if (list? items) items '())
- (if (list? itemstable) itemstable '())))
- 'have-procedure)
- ((or (list? items)(list? itemstable)) ;; calc now
- (debug:print-info 4 *default-log-port* "items and itemstable are lists, calc now\n"
- " items: " items " itemstable: " itemstable)
- (items:get-items-from-config tconfig))
- (else #f)))) ;; not iterated
-
(define (tests:get-tests-search-path cfgdat)
(let ((paths (let ((section (if cfgdat
(configf:get-section cfgdat "tests-paths")
#f)))
(if section
@@ -3649,11 +4367,11 @@
(define (server:expiration-timeout)
(let ((tmo (configf:lookup *configdat* "server" "timeout")))
(if (and (string? tmo)
(common:hms-string->seconds tmo)) ;; BUG: hms-string->seconds is broken, if given "10" returns 0. Also, it doesn't belong in this logic unless the string->number is changed below
(* 3600 (string->number tmo))
- 600))) ;; default is ten minutes
+ 60))) ;; default is one minute
(define (runs:get-mt-env-alist run-id runname target testname itempath)
;;(bb-check-path msg: "runs:set-megatest-env-vars entry")
`(("MT_TEST_NAME" . ,testname)
Index: configfmod.scm
==================================================================
--- configfmod.scm
+++ configfmod.scm
@@ -22,11 +22,42 @@
(declare (uses mtargs))
(declare (uses debugprint))
(declare (uses keysmod))
(module configfmod
- *
+ (
+ common:get-fields
+ common:nice-path
+ common:read-link-f
+ common:with-env-vars
+ configf:config->ini
+ configf:alist->config
+ configf:assoc-safe-add
+ configf:config->alist
+ configf:find-and-read-config
+ configf:get-section
+ configf:lookup
+ configf:lookup-number
+ configf:map-all-hier-alist
+ configf:read-alist
+ configf:read-config
+ configf:read-refdb
+ configf:section-var-set!
+ configf:section-vars
+ configf:set-section-var
+ configf:var-is?
+ configf:write-alist
+ configf:write-config
+ find-config
+ nice-path
+ process:cmd-run->list
+ runconfig:read
+ runconfigs-get
+ safe-setenv
+ setenv
+ configf:eval-string-in-environment
+ )
(import scheme
chicken.base
chicken.condition
@@ -35,10 +66,11 @@
chicken.pathname
chicken.port
chicken.pretty-print
chicken.process
chicken.process-context
+ chicken.process-context.posix
chicken.sort
chicken.string
chicken.time
chicken.eval
@@ -66,12 +98,10 @@
typed-records
z3
)
-(define *configdat* #f)
-
(define getenv get-environment-variable)
(define setenv set-environment-variable!)
(define unsetenv unset-environment-variable!)
;;======================================================================
@@ -953,14 +983,81 @@
;;======================================================================
;; Config file handling
;;======================================================================
;; convert to param?
-(define configf:std-imports "") ;;(import configfmod commonmod)")
-
+(define configf:std-imports "(import configfmod commonmod)")
+(define (configf:process-one matchdat l ht allow-system env-to-use linenum)
+ (let* ((prestr (list-ref matchdat 1))
+ (cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv
+ (cmd (list-ref matchdat 3))
+ (quotedcmd (conc "\""cmd"\""))
+ (poststr (list-ref matchdat 4))
+ (result #f)
+ (start-time (current-seconds))
+ (cmdsym (string->symbol cmdtype))
+ (fullcmd
+ (if (member cmdsym '(scheme scm))
+ `(eval-needed
+ ,(conc configf:std-imports
+ "(import chicken.process-context.posix chicken.process-context)"
+ "(define setenv set-environment-variable)"
+ (conc "(lambda (ht)" cmd ")")))
+ (case cmdsym
+ ((system) `(noeval-needed ,(conc (configf:system ht quotedcmd))))
+ ((shell sh) `(noeval-needed ,(conc (string-translate (shell quotedcmd) "\n" " "))))
+ ((realpath rp)`(noeval-needed ,(conc (common:nice-path quotedcmd))))
+ ((getenv gv) `(noeval-needed ,(conc (get-environment-variable cmd))))
+ ;; ((mtrah) (conc (or *toppath* (get-environment-variable \"MT_RUN_AREA_HOME\"))))
+ ((get g)
+ (match
+ (string-split cmd)
+ ((sect var)(configf:lookup ht sect var))
+ (else
+ (debug:print-error 0 *default-log-port* "#{get ...} used with only one parameter, \"" cmd "\", two needed.")
+ '(bad-param ,(conc "#{get ...} used with only one parameter, \"" cmd "\", two needed.")))))
+ ((runconfigs-get rget) `(noeval-needed ,(runconfigs-get ht quotedcmd))) ;; (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
+ (else `(#f ,(conc "cmd: " cmd " not recognised")))))))
+ (match
+ fullcmd
+ (('eval-needed newres)
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\", fullcmd="fullcmd", 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 newres
+ (lambda ()
+ (set! result (if env-to-use
+ ((eval (read) env-to-use) ht)
+ ((eval (read)) ht)
+ ))))
+ (set! result (conc "#{(" cmdtype ") " cmd "}")))))
+ (('noeval-needed newres)(set! result newres))
+ ((#f errres)
+ (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\".")))
+ ;; we process as a result
+ (let ((delta (- (current-seconds) start-time)))
+ (debug:print-info (if (> delta 2) 0 9) *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result))
+ (conc prestr result poststr)))
+
(define (configf:process-line l ht allow-system env-to-use #!key (linenum #f))
(let loop ((res l))
+ (if (string? res)
+ (let ((matchdat (string-search configf:var-expand-regex res)))
+ (if matchdat
+ (let ((result (configf:process-one matchdat l ht allow-system env-to-use linenum)))
+ (loop result))
+ res))
+ res)))
+
+(define (configf:process-line-old l ht allow-system env-to-use #!key (linenum #f))
+ (let loop ((res l))
(if (string? res)
(let ((matchdat (string-search configf:var-expand-regex res)))
(if matchdat
(let* ((prestr (list-ref matchdat 1))
(cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv
@@ -969,10 +1066,12 @@
(result #f)
(start-time (current-seconds))
(cmdsym (string->symbol cmdtype))
(fullcmd
(conc configf:std-imports
+ "(import chicken.process-context.posix)"
+ "(define setenv set-environment-variable)"
(case cmdsym
((scheme scm) (conc "(lambda (ht)" cmd ")"))
((system) (conc "(lambda (ht)(configf:system ht \"" cmd "\"))"))
((shell sh) (conc "(lambda (ht)(string-translate (shell \"" cmd "\") \"\n\" \" \"))"))
((realpath rp)(conc "(lambda (ht)(common:nice-path \"" cmd "\"))"))
@@ -1016,11 +1115,21 @@
(debug:print-info 9 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result)))))
(loop (conc prestr result poststr)))
res))
res)))
-
+;;======================================================================
+;; Lookup a value in runconfigs based on -reqtarg or -target
+;;
+(define (runconfigs-get config target var)
+ (let ((targ target #;(common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET"))))
+ (if targ
+ (or (configf:lookup config targ var)
+ (configf:lookup config "default" var))
+ (configf:lookup config "default" var))))
+
+
;; pathenvvar will set the named var to the path of the config
(define (configf:find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f)(env-to-use #f))
(let* ((curr-dir (current-directory))
(configinfo (find-config fname toppath: given-toppath))
(toppath (car configinfo))
Index: dashboard-context-menu.scm
==================================================================
--- dashboard-context-menu.scm
+++ dashboard-context-menu.scm
@@ -21,32 +21,73 @@
;;======================================================================
;; implementation of context menu that pops up on
;; right click on test cell in Runs & Runs Summary Tabs
;;======================================================================
-(use format fmt)
-(require-library iup)
-(import (prefix iup iup:))
-
-(use canvas-draw)
-
-(use srfi-1 posix regex regex-case srfi-69)
-(use (prefix sqlite3 sqlite3:))
-
(declare (unit dashboard-context-menu))
-(declare (uses common))
-(declare (uses db))
-(declare (uses gutils))
-(declare (uses rmt))
-(declare (uses ezsteps))
+(declare (uses commonmod))
+(declare (uses configfmod))
+(declare (uses dbmod))
+;; (declare (uses gutils))
+(declare (uses rmtmod))
+(declare (uses ezstepsmod))
;; (declare (uses sdb))
;; (declare (uses filedb))
-(declare (uses subrun))
+(declare (uses subrunmod))
+(declare (uses debugprint))
+(declare (uses testsmod))
+(declare (uses dcommon))
+
+(module dashboard-context-menu
+ (
+dboard:launch-testpanel
+dashboard:run-menu-items
+dashboard:test-menu-items
+dashboard:step-logs-menu-item
+dashboard:toplevel-menu-items
+dashboard:custom-menu-items
+dashboard:context-menu
+)
+
+
+(import format fmt)
+(import (prefix iup iup:))
+
+(import canvas-draw)
+
+(import scheme
+ srfi-1
+ chicken.base
+ chicken.condition
+ chicken.port
+ chicken.file.posix
+ chicken.pathname
+ chicken.process
+ chicken.process-context
+ chicken.string
+ chicken.time
+
+ srfi-1
+ regex regex-case srfi-69
+ (prefix sqlite3 sqlite3:))
+
+(import commonmod
+ dbmod
+ rmtmod
+ ezstepsmod
+ subrunmod
+ debugprint
+ configfmod
+ testsmod
+ dcommon
+ ;; gutils
+ )
+
-(include "common_records.scm")
-(include "db_records.scm")
-(include "run_records.scm")
+;; (include "common_records.scm")
+;; (include "db_records.scm")
+;; (include "run_records.scm")
(define (dboard:launch-testpanel run-id test-id)
(let* ((dboardexe (common:find-local-megatest "dashboard"))
(cmd (conc dboardexe
" -test " run-id "," test-id
@@ -259,14 +300,15 @@
;; item7 custom show run-area-home (%run-area-home%):echo "%run-area-home%"
;; item8 custom show megatest root (%mt-root%):echo "%mt-root%"
;; item9 custom ls : ls -lrt
;; item10 custom see $MT_RUN_AREA_HOME (not yet implemented) : echo $MT_RUN_AREA_HOME
-(define (dashboard:custom-menu-items run-id test-id target run-name test-name testpatt item-test-path test-info)
+(define (dashboard:custom-menu-items bdat run-id test-id target run-name test-name testpatt item-test-path test-info)
(let* ((vars (configf:section-vars *configdat* "custom-context-menu-items"))
(item-path (db:test-get-item-path test-info))
- (mt-root (pathname-directory (pathname-directory *common:this-exe-dir* ))))
+ ;; (bdat-this-exe-dir-set! bdat (pathname-directory fullp))
+ (mt-root (pathname-directory (pathname-directory (bdat-this-exe-dir bdat)))))
(filter-map
(lambda (var)
(let* ((val (configf:lookup *configdat* "custom-context-menu-items" var))
(m (string-match "^\\s*([^:]+?)\\s*:\\s*(.*?)\\s*$" val)))
(if m
@@ -327,17 +369,17 @@
(eval (with-input-from-string (cadr scheme-match) read)))))
(common:run-a-command command-line with-vars: #t))))))))
#f)))
vars)))
-(define (dashboard:context-menu run-id test-id target runname test-name testpatt item-test-path test-info)
+(define (dashboard:context-menu bdat run-id test-id target runname test-name testpatt item-test-path test-info)
(let* ((run-menu-items
(dashboard:run-menu-items run-id test-id target runname test-name testpatt item-test-path test-info))
(test-menu-items
(dashboard:test-menu-items run-id test-id target runname test-name testpatt item-test-path test-info))
(custom-menu-items
- (dashboard:custom-menu-items run-id test-id target runname test-name testpatt item-test-path test-info))
+ (dashboard:custom-menu-items bdat run-id test-id target runname test-name testpatt item-test-path test-info))
(toplevel-menu-items
(dashboard:toplevel-menu-items run-id test-id target runname test-name testpatt item-test-path test-info))
)
(apply iup:menu
`(,@toplevel-menu-items
@@ -346,5 +388,7 @@
(apply iup:menu run-menu-items))
,(iup:menu-item
"Test"
(apply iup:menu test-menu-items))
,@custom-menu-items))))
+
+)
Index: dashboard-guimonitor.scm
==================================================================
--- dashboard-guimonitor.scm
+++ dashboard-guimonitor.scm
@@ -20,29 +20,38 @@
;;======================================================================
;; Test info panel
;;======================================================================
-(use format)
-(require-library iup)
+(import format)
(import (prefix iup iup:))
-
-(use canvas-draw)
+(import canvas-draw)
-(use sqlite3 srfi-1 posix regex regex-case srfi-69)
-(import (prefix sqlite3 sqlite3:))
+(import
+ srfi-1
+ chicken.file.posix regex regex-case srfi-69
+ (prefix sqlite3 sqlite3:))
(declare (unit dashboard-guimonitor))
-(declare (uses common))
-(declare (uses keys))
-(declare (uses db))
-(declare (uses tasks))
-
-(include "common_records.scm")
-(include "db_records.scm")
-(include "run_records.scm")
-(include "task_records.scm")
+(declare (uses commonmod))
+(declare (uses keysmod))
+(declare (uses dbmod))
+(declare (uses tasksmod))
+(declare (uses debugprint))
+
+;; (include "common_records.scm")
+;; (include "db_records.scm")
+;; (include "run_records.scm")
+;; (include "task_records.scm")
+
+(import
+ commonmod
+ keysmod
+ dbmod
+ tasksmod
+ debugprint
+ )
(define (control-panel db tdb keys)
(let* ((var-params (make-hash-table)) ;; register all the widgets here for querying on run, rollup, remove?
(key-params (make-hash-table))
(monitordat '()) ;; list of monitor records
Index: dashboard-tests.scm
==================================================================
--- dashboard-tests.scm
+++ dashboard-tests.scm
@@ -20,36 +20,93 @@
;;======================================================================
;; Test info panel
;;======================================================================
-(use format fmt)
-(require-library iup)
-(import (prefix iup iup:))
-
-(use canvas-draw)
-
-(use srfi-1 posix regex regex-case srfi-69)
-(use (prefix sqlite3 sqlite3:))
-
(declare (unit dashboard-tests))
-(declare (uses common))
-(declare (uses db))
-(declare (uses gutils))
-(declare (uses rmt))
-(declare (uses ezsteps))
+(declare (uses commonmod))
+(declare (uses dbmod))
+;; (declare (uses gutils))
+(declare (uses rmtmod))
+(declare (uses ezstepsmod))
;; (declare (uses sdb))
;; (declare (uses filedb))
-(declare (uses subrun))
+(declare (uses subrunmod))
+(declare (uses debugprint))
+(declare (uses configfmod))
+(declare (uses testsmod))
+(declare (uses mtmod))
+(declare (uses dcommon))
+(declare (uses launchmod))
+
+(module dashboard-tests
+ (
+message-window
+test-info-panel
+test-meta-panel-get-description
+test-meta-panel
+run-info-panel
+host-info-panel
+submegatest-panel
+update-state-status-buttons
+set-fields-panel
+dashboard-tests:run-a-step
+dashboard-tests:waiver
+dashboard-tests:examine-test
+colors-similar?
+dashboard:draw-tests
+dboard:tabdat-test-patts-use
+dashboard:update-run-command
+iuplistbox-fill-list
+*tim*
+*dashboard-comment-share-slot*
+*state-status*
+*dashboard-test-db*
+*dashboard-comment-share-slot*
+)
+
+
+(import scheme
+ chicken.file.posix
+ chicken.base
+ chicken.string
+ chicken.condition
+ chicken.file
+ chicken.process-context
+ chicken.time
+
+ format
+ fmt
+ (prefix iup iup:)
+ canvas-draw
+ srfi-1
+ srfi-18
+ regex regex-case srfi-69
+ (prefix sqlite3 sqlite3:))
+
+;; (include "common_records.scm")
+;; (include "db_records.scm")
+;; (include "run_records.scm")
-(include "common_records.scm")
-(include "db_records.scm")
-(include "run_records.scm")
+(import commonmod
+ dcommon
+ dbmod
+ rmtmod
+ ezstepsmod
+ subrunmod
+ debugprint
+;; gutils
+ configfmod
+ testsmod
+ mtmod
+ launchmod
+ )
;;======================================================================
;; C O M M O N
;;======================================================================
+(define *tim* (iup:timer))
(define *dashboard-comment-share-slot* #f)
(define (message-window msg)
(iup:show
@@ -458,12 +515,12 @@
;;======================================================================
;;
;;======================================================================
(define (dashboard-tests:examine-test run-id test-id) ;; run-id run-key origtest)
- (let* ((db-path (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db"))
- (dbstruct #f) ;; NOT ACTUALLY USED (db:setup)) ;; (make-dbr:dbstruct path: (db:dbfile-path #f) ;; (configf:lookup *configdat* "setup" "linktree")
+ (let* ((db-path (common:get-db-tmp-area)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db"))
+ (dbstruct #f) ;; NOT ACTUALLY USED (db:setup)) ;; (make-dbr:dbstruct path: (common:get-db-tmp-area #f) ;; (configf:lookup *configdat* "setup" "linktree")
;; local: #t))
(testdat (rmt:get-test-info-by-id run-id test-id)) ;; (db:get-test-info-by-id dbstruct run-id test-id))
(db-mod-time 0) ;; (file-modification-time db-path))
(last-update 0) ;; (current-seconds))
(request-update #t))
@@ -866,13 +923,13 @@
))
(define (dboard:tabdat-test-patts-use vec)
(let ((val (dboard:tabdat-test-patts vec)))(if val val ""))) ;;RADT => What is the if for?
-;; additional setters for dboard:data
-(define (dboard:tabdat-test-patts-set!-use vec val)
- (dboard:tabdat-test-patts-set! vec (if (equal? val "") #f val)))
+;; ;; additional setters for dboard:data
+;; (define (dboard:tabdat-test-patts-set!-use vec val)
+;; (dboard:tabdat-test-patts-set! vec (if (equal? val "") #f val)))
;; Extract the various bits of data from tabdat and create the command line equivalent that will be displayed
;;
(define (dashboard:update-run-command tabdat)
(let* ((cmd-tb (dboard:tabdat-command-tb tabdat))
@@ -932,16 +989,6 @@
(set! i (+ i 1)))
items)
;; (iup:attribute-set! lb "VALUE" (if selected-item selected-item ""))
i))
-;; if tab-num passed in then use it, otherwise look in commondat at curr-tab-num
-;; adds the updater passed in the updaters list at that hashkey
-;;
-(define (dboard:commondat-add-updater commondat updater #!key (tab-num #f))
- (let* ((tnum (or tab-num
- (dboard:commondat-curr-tab-num commondat)))
- (curr-updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '())))
- (hash-table-set! (dboard:commondat-updaters commondat)
- tnum
- (cons updater curr-updaters))))
-
+)
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -16,47 +16,124 @@
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
;;======================================================================
-(use format)
-
-(require-library iup)
-(import (prefix iup iup:))
-
-(use canvas-draw)
-(import canvas-draw-iup)
-(use ducttape-lib)
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors) ;; defstruct
-(import (prefix sqlite3 sqlite3:))
-
-(declare (uses common))
-(declare (uses margs))
-(declare (uses keys))
-(declare (uses items))
-(declare (uses db))
-(declare (uses configf))
-(declare (uses process))
-(declare (uses launch))
-(declare (uses runs))
+(declare (uses ducttape-lib))
+
+(declare (uses debugprint))
+(declare (uses bigmod))
+;; (declare (uses gutils))
+;; (declare (uses bigmod.import))
+(declare (uses commonmod))
+(declare (uses configfmod))
+(declare (uses dashboard-context-menu))
(declare (uses dashboard-tests))
-(declare (uses dashboard-guimonitor))
+(declare (uses dbmod))
+(declare (uses dcommon))
+;; (declare (uses debugprint.import))
+(declare (uses itemsmod))
+(declare (uses launchmod))
+(declare (uses mtargs))
+(declare (uses mtmod))
+(declare (uses mtver))
+(declare (uses processmod))
+(declare (uses runsmod))
+(declare (uses rmtmod))
+(declare (uses subrunmod))
(declare (uses tree))
-(declare (uses dcommon))
-(declare (uses dashboard-context-menu))
-(declare (uses vg))
-(declare (uses subrun))
+(declare (uses vgmod))
+(declare (uses testsmod))
+(declare (uses tasksmod))
+
+;; needed for configf scripts, scheme etc.
+;; (declare (uses apimod.import))
+;; (declare (uses debugprint.import))
+;; (declare (uses mtargs.import))
+;; (declare (uses commonmod.import))
+;; (declare (uses configfmod.import))
+;; (declare (uses bigmod.import))
+;; (declare (uses dbmod.import))
+;; (declare (uses rmtmod.import))
+;; ;; (declare (uses servermod.import))
+;; (declare (uses launchmod.import))
+;; (declare (uses dashboard-guimonitor))
;; (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")
+(module dashboard
+ *
+
+(import scheme
+ chicken.base
+ chicken.bitwise
+ chicken.condition
+ chicken.eval
+ chicken.file
+ chicken.file.posix
+ chicken.format
+ chicken.io
+ chicken.irregex
+ chicken.pathname
+ chicken.port
+ chicken.pretty-print
+ chicken.process
+ chicken.process-context
+ chicken.process-context.posix
+ chicken.process.signal
+ chicken.random
+ chicken.repl
+ chicken.sort
+ chicken.string
+ chicken.tcp
+ chicken.time
+ chicken.time.posix
+
+ (prefix iup iup:)
+ canvas-draw
+ canvas-draw-iup
+ (prefix sqlite3 sqlite3:)
+ srfi-1
+ regex regex-case srfi-69
+ typed-records
+ sparse-vectors
+ format
+ srfi-4
+ srfi-14
+ )
+
+;; (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")
+;; (include "vg_records.scm")
+
+(import (prefix mtargs args:)
+ ;; gutils
+ bigmod
+ commonmod
+ configfmod
+ dashboard-context-menu
+ dashboard-tests
+ dbmod
+ dcommon
+ debugprint
+ itemsmod
+ launchmod
+ mtmod
+ mtver
+ processmod
+ rmtmod
+ runsmod
+ subrunmod
+ tasksmod
+ testsmod
+ tree
+ vgmod
+ ducttape-lib
+ )
(define help (conc
"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
version " megatest-version "
license GPL, Copyright (C) Matt Welland 2012-2017
@@ -102,10 +179,11 @@
"-:p" ;; ignore the built in chicken profiling switch
)
args:arg-hash
0))
+(make-and-init-bigdata)
;; check for MT_* environment variables and exit if found
(if (not (args:get-arg "-test"))
(begin
(display "Checking for MT_ vars: ")
(for-each (lambda (var)
@@ -149,11 +227,11 @@
(if (or (args:get-arg "-rh5.11")
(configf:lookup *configdat* "dashboard" "no-detachbox")
(not (file-exists? "/etc/os-release")))
(set! iup:detachbox iup:vbox))
-(if (not (common:on-homehost?))
+#;(if (not (common:on-homehost?))
(begin
(debug:print 0 *default-log-port* "WARNING: Current policy requires running dashboard on homehost: " (common:get-homehost))))
;; RA => Might require revert for filters
;; create a watch dog to move changes from lt/.db/*.db to megatest.db
@@ -272,135 +350,13 @@
(lambda (updater)
;; (debug:print 3 *default-log-port* "Running " updater)
(updater))
updaters))))
-;; if tab-num passed in then use it, otherwise look in commondat at curr-tab-num
-;; adds the updater passed in the updaters list at that hashkey
-;;
-(define (dboard:commondat-add-updater commondat updater #!key (tab-num #f))
- (let* ((tnum (or tab-num
- (dboard:commondat-curr-tab-num commondat)))
- (curr-updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '())))
- (hash-table-set! (dboard:commondat-updaters commondat)
- tnum
- (cons updater curr-updaters))))
-
-;; data for each specific tab goes here
-;;
-(defstruct dboard:tabdat
- ;; runs
- ((allruns '()) : list) ;; list of dboard:rundat records
- ((allruns-by-id (make-hash-table)) : hash-table) ;; hash of run-id -> dboard:rundat records
- ((done-runs '()) : list) ;; list of runs already drawn
- ((not-done-runs '()) : list) ;; list of runs not yet drawn
- (header #f) ;; header for decoding the run records
- (keys #f) ;; keys for this run (i.e. target components)
- ((numruns (string->number (or (args:get-arg "-cols")
- (configf:lookup *configdat* "dashboard" "cols")
- "8"))) : number) ;;
- ((tot-runs 0) : number)
- ((last-data-update 0) : number) ;; last time the data in allruns was updated
- ((last-runs-update 0) : number) ;; last time we pulled the runs info to update the tree
- (runs-mutex (make-mutex)) ;; use to prevent parallel access to draw objects
- ((run-update-times (make-hash-table)) : hash-table) ;; update times indexed by run-id
- ((last-test-dat (make-hash-table)) : hash-table) ;; cache last tests dat by run-id
- ((run-db-paths (make-hash-table)) : hash-table) ;; cache the paths to the run db files
-
- ;; Runs view
- ((buttondat (make-hash-table)) : hash-table) ;;
- ((item-test-names '()) : list) ;; list of itemized tests
- ((run-keys (make-hash-table)) : hash-table)
- (runs-matrix #f) ;; used in newdashboard
- ((start-run-offset 0) : number) ;; left-right slider value
- ((start-test-offset 0) : number) ;; up-down slider value
- ((runs-btn-height (or (configf:lookup *configdat* "dashboard" "btn-height") "x16")) : string) ;; was 12
- ((runs-btn-fontsz (or (configf:lookup *configdat* "dashboard" "btn-fontsz") "10")) : string) ;; was 8
- ((runs-cell-width (or (configf:lookup *configdat* "dashboard" "cell-width") "50")) : string) ;; was 50
- ((all-test-names '()) : list)
-
- ;; Canvas and drawing data
- (cnv #f)
- (cnv-obj #f)
- (drawing #f)
- ((run-start-row 0) : number)
- ((max-row 0) : number)
- ((running-layout #f) : boolean)
- (originx #f)
- (originy #f)
- ((layout-update-ok #t) : boolean)
- ((compact-layout #t) : boolean)
-
- ;; Run times layout
- ;; (graph-button-box #f) ;; RA => Think it is not referenced anywhere
- (graph-matrix #f)
- ((graph-matrix-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru graph name info
- ((graph-cell-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru matrix cell info
- ((graph-matrix-row 1) : number)
- ((graph-matrix-col 1) : number)
-
- ;; Controls used to launch runs etc.
- ((command "") : string) ;; for run control this is the command being built up
- (command-tb #f) ;; widget for the type of command; run, remove-runs etc.
- (test-patterns-textbox #f) ;; text box widget for editing a list of test patterns
- (key-listboxes #f)
- (key-lbs #f)
- run-name ;; from run name setting widget
- states ;; states for -state s1,s2 ...
- statuses ;; statuses for -status s1,s2 ...
-
- ;; Selector variables
- curr-run-id ;; current row to display in Run summary view
- prev-run-id ;; previous runid selected before current runid was selected (used in xor-two-runs runs summary mode
- curr-test-ids ;; used only in dcommon:run-update which is used in newdashboard
- ((filters-changed #t) : boolean) ;; to indicate that the user changed filters for this tab
- ((last-filter-str "") : string) ;; conc the target runname and testpatt for a signature of changed filters
- ((hide-empty-runs #f) : boolean)
- ((hide-not-hide #t) : boolean) ;; toggle for hide/not hide empty runs
- (hide-not-hide-button #f)
- ((searchpatts (make-hash-table)) : hash-table) ;;
- ((state-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATE => #t/#f for display control
- ((status-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATUS => #t/#f
- (target #f)
- (test-patts #f)
-
- ;; db info to file the .db files for the area
- (access-mode (db:get-access-mode)) ;; use cached db or not
- (dbdir #f)
- (dbfpath #f)
- (dbkeys #f)
- ((last-db-update (make-hash-table)) : hash-table) ;; last db file timestamp
- (monitor-db-path #f) ;; where to find monitor.db
- ro ;; is the database read-only?
-
- ;; tests data
- ((num-tests 10) : number) ;; total number of tests to show (used in the old runs display)
-
- ;; runs tree
- ((path-run-ids (make-hash-table)) : hash-table) ;; path (target / runname) => id
- (runs-tree #f)
- ((runs-tree-ht (make-hash-table)) : hash-table) ;; track which targets added to tree (merge functionality with path-run-ids?)
-
- ;; tab data
- ((view-changed #t) : boolean)
- ((xadj 0) : number) ;; x slider number (if using canvas)
- ((yadj 0) : number) ;; y slider number (if using canvas)
- ;; runs-summary tab state
- ((runs-summary-modes '((one-run . "Show One Run") (xor-two-runs . "XOR Two Runs") (xor-two-runs-hide-clean . "XOR; Hide Clean")) ) : list)
- ((runs-summary-mode-buttons '()) : list)
- ((runs-summary-mode 'one-run) : symbol)
- ((runs-summary-mode-change-callbacks '()) : list)
- (runs-summary-source-runname-label #f)
- (runs-summary-dest-runname-label #f)
- ;; runs summary view
-
- tests-tree ;; used in newdashboard
- )
-
;; register tabdat with BBpp
;; this is used by BBpp (Brandon's pretty printer) to convert dboard:tabdat into a composition of lists that pp will handle
-(hash-table-set! *BBpp_custom_expanders_list* TABDAT:
+#;(hash-table-set! *BBpp_custom_expanders_list* TABDAT:
(cons dboard:tabdat?
(lambda (tabdat-item)
(filter
(lambda (alist-entry)
(member (car alist-entry)
@@ -411,30 +367,23 @@
(define (dboard:tabdat-target-string vec)
(let ((targ (dboard:tabdat-target vec)))
(if (list? targ)(string-intersperse targ "/") "no-target-specified")))
-(define (dboard:tabdat-test-patts-use vec)
- (let ((val (dboard:tabdat-test-patts vec)))(if val val ""))) ;;RADT => What is the if for?
-
-;; additional setters for dboard:data
-(define (dboard:tabdat-test-patts-set!-use vec val)
- (dboard:tabdat-test-patts-set! vec (if (equal? val "") #f val)))
-
(define (dboard:tabdat-make-data)
(let ((dat (make-dboard:tabdat)))
(dboard:setup-tabdat dat)
(dboard:setup-num-rows dat)
dat))
(define (dboard:setup-tabdat tabdat)
- (dboard:tabdat-dbdir-set! tabdat (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
- (dboard:tabdat-dbfpath-set! tabdat (db:dbfile-path))
+ (dboard:tabdat-dbdir-set! tabdat (common:get-db-tmp-area)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
+ (dboard:tabdat-dbfpath-set! tabdat (common:get-db-tmp-area))
(dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db"))
;; HACK ALERT: this is a hack, please fix.
- (dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat))))
+ (dboard:tabdat-ro-set! tabdat (not (file-readable? (dboard:tabdat-dbfpath tabdat))))
(dboard:tabdat-keys-set! tabdat (rmt:get-keys))
(dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname")))
(dboard:tabdat-tot-runs-set! tabdat (rmt:get-num-runs "%"))
)
@@ -497,11 +446,12 @@
(keys (rmt:get-keys)) ;; to be removed when targets handling is refactored
(runs (make-sparse-vector)) ;; id => runrec
(runsbynum (make-vector 100 #f)) ;; vector num => runrec
(targ-runid (make-hash-table)) ;; area/target/runname => run-id ;; not sure this will be needed
(tests (make-hash-table)) ;; test[/itempath] => list of test rec
-
+ (path-run-ids (make-hash-table)) ;; path => run-id (this is a guess based on code reference)
+
;; run sql filters
(targ-sql-filt "%")
(runname-sql-filt "%")
(run-state-sql-filt "%")
(run-status-sql-filt "%")
@@ -546,11 +496,11 @@
duration
)
;; register dboard:rundat with BBpp
;; this is used by BBpp (Brandon's pretty printer) to convert dboard:rundat into a composition of lists that pp will handle
-(hash-table-set! *BBpp_custom_expanders_list* RUNDAT:
+#;(hash-table-set! *BBpp_custom_expanders_list* RUNDAT:
(cons dboard:rundat?
(lambda (tabdat-item)
(filter
(lambda (alist-entry)
(member (car alist-entry)
@@ -573,11 +523,11 @@
status ;; test status
)
;; default is to NOT set the cell if the column and row names are not pre-existing
;;
-(define (dboard:runsdat-set-test-cell dat target runname testname itempath test-id state status #!key (force-set #f))
+#;(define (dboard:runsdat-set-test-cell dat target runname testname itempath test-id state status #!key (force-set #f))
(let* ((col-num (dcommon:runsdat-get-col-num dat target runname force-set))
(row-num (dcommon:runsdat-get-row-num dat testname itempath force-set)))
(if (and row-num col-num)
(let ((tdat (dboard:testdat
id: test-id
@@ -588,12 +538,10 @@
#f)))
(define *dashboard-mode* (string->symbol (or (configf:lookup *configdat* "dashboard" "mode") "dashboard")))
-(define *exit-started* #f)
-
;; sorting global data (would apply to many testsuites so leave it global for now)
;;
(define *tests-sort-options* (vector (vector "Sort +a" 'testname "ASC")
(vector "Sort -a" 'testname "DESC")
(vector "Sort +t" 'event_time "ASC")
@@ -636,36 +584,12 @@
(define-inline (dboard:uidat-get-header vec)(vector-ref vec 2))
(define-inline (dboard:uidat-get-runsvec vec)(vector-ref vec 3))
(if (get-environment-variable "MT_RUN_AREA_HOME")(change-directory (get-environment-variable "MT_RUN_AREA_HOME")))
-(define (message-window msg)
- (iup:show
- (iup:dialog
- (iup:vbox
- (iup:label msg #:margin "40x40")))))
-
-(define (iuplistbox-fill-list lb items #!key (selected-item #f))
- (let ((i 1))
- (for-each (lambda (item)
- (iup:attribute-set! lb (number->string i) item)
- (if selected-item
- (if (equal? selected-item item)
- (iup:attribute-set! lb "VALUE" i))) ;; (number->string i))))
- (set! i (+ i 1)))
- items)
- ;; (iup:attribute-set! lb "VALUE" (if selected-item selected-item ""))
- i))
-
(define (pad-list l n)(append l (make-list (- n (length l)))))
-(define (colors-similar? color1 color2)
- (let* ((c1 (map string->number (string-split color1)))
- (c2 (map string->number (string-split color2)))
- (delta (map (lambda (a b)(abs (- a b))) c1 c2)))
- (null? (filter (lambda (x)(> x 3)) delta))))
-
(define (dboard:compare-tests test1 test2)
(let* ((test-name1 (db:test-get-testname test1))
(item-path1 (db:test-get-item-path test1))
(eventtime1 (db:test-get-event_time test1))
(test-name2 (db:test-get-testname test2))
@@ -1310,11 +1234,11 @@
(let ((newval (car values)))
(iup:attribute-set! lb "VALUE" newval)
newval))))))
(define (dashboard:update-target-selector tabdat #!key (action-proc #f))
- (let* ((runconf-targs (common:get-runconfig-targets))
+ (let* ((runconf-targs (common:get-runconfig-targets *configdat*))
(key-lbs (dboard:tabdat-key-listboxes tabdat))
(db-target-dat (rmt:get-targets))
(header (vector-ref db-target-dat 0))
(db-targets (vector-ref db-target-dat 1))
(munge-target (lambda (x) ;; create a target vector from a string. Pad with na if needed.
@@ -1390,80 +1314,10 @@
(let ((all (hash-table-keys alltgls)))
(proc all)))
"text-list-toggle-box"))))
items))))
-;; Extract the various bits of data from tabdat and create the command line equivalent that will be displayed
-;;
-(define (dashboard:update-run-command tabdat)
- (let* ((cmd-tb (dboard:tabdat-command-tb tabdat))
- (cmd (dboard:tabdat-command tabdat))
- (test-patt (let ((tp (dboard:tabdat-test-patts tabdat)))
- (if (or (not tp)
- (equal? tp ""))
- "%"
- tp)))
- (states (dboard:tabdat-states tabdat))
- (statuses (dboard:tabdat-statuses tabdat))
- (target (let ((targ-list (dboard:tabdat-target tabdat)))
- (if targ-list (string-intersperse targ-list "/") "no-target-selected")))
- (run-name (dboard:tabdat-run-name tabdat))
- (states-str (if (or (not states)
- (null? states))
- ""
- (conc " -state " (string-intersperse states ","))))
- (statuses-str (if (or (not statuses)
- (null? statuses))
- ""
- (conc " -status " (string-intersperse statuses ","))))
- (full-cmd "megatest"))
- (case (string->symbol cmd)
- ((run)
- (set! full-cmd (conc full-cmd
- " -run"
- " -testpatt "
- test-patt
- " -target "
- target
- " -runname "
- run-name
- " -clean-cache"
- )))
- ((remove-runs)
- (set! full-cmd (conc full-cmd
- " -remove-runs -runname "
- run-name
- " -target "
- target
- " -testpatt "
- test-patt
- states-str
- statuses-str
- )))
- (else (set! full-cmd " no valid command ")))
- (iup:attribute-set! cmd-tb "VALUE" full-cmd)))
-
-;; Display the tests as rows of boxes on the test/task pane
-;;
-(define (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames test-records)
- (canvas-clear! cnv)
- (canvas-font-set! cnv "Helvetica, -10")
- (let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv))
- ((originx originy) (canvas-origin cnv)))
- ;; (print "originx: " originx " originy: " originy)
- ;; (canvas-origin-set! cnv 0 (- (/ sizey 2)))
- (if (hash-table-ref/default tests-draw-state 'first-time #t)
- (begin
- (hash-table-set! tests-draw-state 'first-time #f)
- (hash-table-set! tests-draw-state 'scalef 1)
- (hash-table-set! tests-draw-state 'tests-info (make-hash-table))
- (hash-table-set! tests-draw-state 'selected-tests (make-hash-table))
- ;; set these
- (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records))
- (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records))
- ))
-
;;======================================================================
;; R U N C O N T R O L S
;;======================================================================
;;
;; A gui for launching tests
@@ -1484,11 +1338,11 @@
;; used by run-controls
;;
(define (dashboard:update-tree-selector tabdat #!key (action-proc #f))
(let* ((tb (dboard:tabdat-runs-tree tabdat))
- (runconf-targs (common:get-runconfig-targets))
+ (runconf-targs (common:get-runconfig-targets *configdat*))
(db-target-dat (rmt:get-targets))
(runs-tree-ht (dboard:tabdat-runs-tree-ht tabdat))
(header (vector-ref db-target-dat 0))
(db-targets (vector-ref db-target-dat 1))
(munge-target (lambda (x) ;; create a target vector from a string. Pad with na if needed.
@@ -1877,11 +1731,11 @@
(hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) path #f)
#f))
(define (new-tree-path->run-id rdat path)
(if (not (null? path))
- (hash-table-ref/default (dboard:rdat-path-run-ids tabdat) path #f)
+ (hash-table-ref/default (dboard:rdat-path-run-ids rdat) path #f)
#f))
;; (define (dboard:get-tests-dat tabdat run-id last-update)
;; (let* ((access-mode (dboard:tabdat-access-mode tabdat))
;; (tdat (if run-id (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run
@@ -2132,11 +1986,11 @@
;; S U M M A R Y
;;======================================================================
;;
;; General info about the run(s) and megatest area
(define (dashboard:summary commondat tabdat #!key (tab-num #f))
- (let* ((rawconfig (read-config (conc *toppath* "/megatest.config") #f #f)) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string)))
+ (let* ((rawconfig (configf:read-config (conc *toppath* "/megatest.config") #f #f)) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string)))
(changed #f))
(iup:vbox
(iup:split
#:value 300
(iup:frame
@@ -2174,11 +2028,11 @@
(source (configf:lookup views-cfgdat view-name "source"))
(viewgen (configf:lookup views-cfgdat view-name "viewgen"))
(updater (configf:lookup views-cfgdat view-name "updater"))
(result-child #f))
(if (and (common:file-exists? source)
- (file-read-access? source))
+ (file-readable? source))
(handle-exceptions
exn
(begin
(print-call-chain)
(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
@@ -2389,18 +2243,18 @@
(dboard:launch-testpanel run-id test-id))
((member #\2 status-chars) ;; 2 is middle mouse button
(debug:print-info 13 *default-log-port* "mmb- test-name="test-name" testpatt="testpatt)
- (iup:show (dashboard:context-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu
+ (iup:show (dashboard:context-menu *bdat* run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu
#:x 'mouse
#:y 'mouse
#:modal? "NO")
)
(else
(debug:print-info 13 *default-log-port* "unhandled status in run-summary-click-cb. Doing right click action. (status is corrupted on Brandon's ubuntu host - bad/buggy iup install??" )
- (iup:show (dashboard:context-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu
+ (iup:show (dashboard:context-menu *bdat* run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu
#:x 'mouse
#:y 'mouse
#:modal? "NO")
)
)
@@ -2947,11 +2801,11 @@
"%")))
(item-path (db:test-get-item-path (rmt:get-test-info-by-id run-id test-id)))
(item-test-path (conc test-name "/" (if (equal? item-path "")
"%"
item-path))))
- (iup:show (dashboard:context-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu
+ (iup:show (dashboard:context-menu *bdat* run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu
#:x 'mouse
#:y 'mouse
#:modal? "NO")
;; (print "got here")
))
@@ -3075,11 +2929,10 @@
(dboard:tabdat-num-tests-set! tabdat (string->number
(or (args:get-arg "-rows")
(get-environment-variable "DASHBOARDROWS")
"15"))))
-(define *tim* (iup:timer))
(define *ord* #f)
(iup:attribute-set! *tim* "TIME" (or (configf:lookup *configdat* "dashboard" "poll-interval") "1000"))
(iup:attribute-set! *tim* "RUN" "YES")
(define *last-recalc-ended-time* 0)
@@ -3088,13 +2941,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)
(define (dashboard:get-youngest-run-db-mod-time dbdir)
(handle-exceptions
@@ -3360,13 +3210,13 @@
(if (equal? (car parts) "sqlite3")
(cadr parts)
(begin
(debug:print 0 *default-log-port* "ERROR: I only know sqlite3 databases for now: " dbstr)
#f)))))
- (if (and dbpth (file-read-access? dbpth))
+ (if (and dbpth (file-readable? dbpth))
(let ((db (sqlite3:open-database dbpth))) ;; (open-database dbpth)))
- (sqlite3:set-busy-handler! db (make-busy-timeout 10000))
+ (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 10000))
db)
#f)))
;; sqlite3:path tablename timefieldname varfieldname field1 field2 ...
;;
@@ -3813,14 +3663,14 @@
;;======================================================================
;; The heavy lifting starts here
;;======================================================================
-(define (main)
+(define (dashboard-main)
(let ((mtdb-path (conc *toppath* "/megatest.db"))) ;;
- (if (and (common:file-exists? mtdb-path)
- (file-write-access? mtdb-path))
+ #;(if (and (common:file-exists? mtdb-path)
+ (file-writable? mtdb-path))
(if (not (args:get-arg "-skip-version-check"))
(common:exit-on-version-changed)))
(let* ((commondat (dboard:commondat-make)))
;; Move this stuff to db.scm? I'm not sure that is the right thing to do...
(cond
@@ -3878,14 +3728,26 @@
) "update buttons once"))
(th2 (make-thread iup:main-loop "Main loop")))
(thread-start! th2)
(thread-join! th2)))))
-;; ease debugging by loading ~/.dashboardrc
-(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
- (if (common:file-exists? debugcontrolf)
- (load debugcontrolf)))
-
-(if (args:get-arg "-repl")
- (repl)
- (main))
+(define (get-debugcontrolf)
+ (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
+ (if (common:file-exists? debugcontrolf)
+ debugcontrolf
+ #f)))
+
+(define (main)
+ (if (args:get-arg "-repl")
+ (repl)
+ (dashboard-main)))
+
+)
+
+(import dashboard)
+
+;; ease debugging by loading ~/.dashboardrc
+(let ((debugcontrolf (get-debugcontrolf)))
+ (load debugcontrolf))
+
+(main)
Index: db_records.scm
==================================================================
--- db_records.scm
+++ db_records.scm
@@ -13,239 +13,5 @@
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
-;;======================================================================
-;; dbstruct
-;;======================================================================
-
-;;
-;; -path-|-megatest.db
-;; |-db-|-main.db
-;; |-monitor.db
-;; |-sdb.db
-;; |-fdb.db
-;; |-1.db
-;; |-.db
-;;
-;;
-;; Accessors for a dbstruct
-;;
-
-;; (define-inline (dbr:dbstruct-main vec) (vector-ref vec 0)) ;; ( db path )
-;; (define-inline (dbr:dbstruct-strdb vec) (vector-ref vec 1)) ;; ( db path )
-;; (define-inline (dbr:dbstruct-path vec) (vector-ref vec 2))
-;; (define-inline (dbr:dbstruct-local vec) (vector-ref vec 3))
-;; (define-inline (dbr:dbstruct-rundb vec) (vector-ref vec 4)) ;; ( db path )
-;; (define-inline (dbr:dbstruct-inmem vec) (vector-ref vec 5)) ;; ( db #f )
-;; (define-inline (dbr:dbstruct-mtime vec) (vector-ref vec 6))
-;; (define-inline (dbr:dbstruct-rtime vec) (vector-ref vec 7))
-;; (define-inline (dbr:dbstruct-stime vec) (vector-ref vec 8))
-;; (define-inline (dbr:dbstruct-inuse vec) (vector-ref vec 9))
-;; (define-inline (dbr:dbstruct-refdb vec) (vector-ref vec 10)) ;; ( db path )
-;; (define-inline (dbr:dbstruct-locdbs vec) (vector-ref vec 11))
-;; (define-inline (dbr:dbstruct-olddb vec) (vector-ref vec 12)) ;; ( db path )
-;; ;; (define-inline (dbr:dbstruct-main-path vec) (vector-ref vec 13))
-;; ;; (define-inline (dbr:dbstruct-rundb-path vec) (vector-ref vec 14))
-;; ;; (define-inline (dbr:dbstruct-run-id vec) (vector-ref vec 13))
-;;
-;; (define-inline (dbr:dbstruct-main-set! vec val)(vector-set! vec 0 val))
-;; (define-inline (dbr:dbstruct-strdb-set! vec val)(vector-set! vec 1 val))
-;; (define-inline (dbr:dbstruct-path-set! vec val)(vector-set! vec 2 val))
-;; (define-inline (dbr:dbstruct-local-set! vec val)(vector-set! vec 3 val))
-;; (define-inline (dbr:dbstruct-rundb-set! vec val)(vector-set! vec 4 val))
-;; (define-inline (dbr:dbstruct-inmem-set! vec val)(vector-set! vec 5 val))
-;; (define-inline (dbr:dbstruct-mtime-set! vec val)(vector-set! vec 6 val))
-;; (define-inline (dbr:dbstruct-rtime-set! vec val)(vector-set! vec 7 val))
-;; (define-inline (dbr:dbstruct-stime-set! vec val)(vector-set! vec 8 val))
-;; (define-inline (dbr:dbstruct-inuse-set! vec val)(vector-set! vec 9 val))
-;; (define-inline (dbr:dbstruct-refdb-set! vec val)(vector-set! vec 10 val))
-;; (define-inline (dbr:dbstruct-locdbs-set! vec val)(vector-set! vec 11 val))
-;; (define-inline (dbr:dbstruct-olddb-set! vec val)(vector-set! vec 12 val))
-;; (define-inline (dbr:dbstruct-main-path-set! vec val)(vector-set! vec 13 val))
-;; (define-inline (dbr:dbstruct-rundb-path-set! vec val)(vector-set! vec 14 val))
-;;
-; (define-inline (dbr:dbstruct-run-id-set! vec val)(vector-set! vec 13 val))
-
-;; constructor for dbstruct
-;;
-;; (define (make-dbr:dbstruct #!key (path #f)(local #f))
-;; (let ((v (make-vector 15 #f)))
-;; (dbr:dbstruct-path-set! v path)
-;; (dbr:dbstruct-local-set! v local)
-;; (dbr:dbstruct-locdbs-set! v (make-hash-table))
-;; v))
-
-
-(define (make-db:test)(make-vector 20))
-(define (db:test-get-id vec) (vector-ref vec 0))
-(define (db:test-get-run_id vec) (vector-ref vec 1))
-(define (db:test-get-testname vec) (vector-ref vec 2))
-(define (db:test-get-state vec) (vector-ref vec 3))
-(define (db:test-get-status vec) (vector-ref vec 4))
-(define (db:test-get-event_time vec) (vector-ref vec 5))
-(define (db:test-get-host vec) (vector-ref vec 6))
-(define (db:test-get-cpuload vec) (vector-ref vec 7))
-(define (db:test-get-diskfree vec) (vector-ref vec 8))
-(define (db:test-get-uname vec) (vector-ref vec 9))
-;; (define (db:test-get-rundir vec) (sdb:qry 'getstr (vector-ref vec 10)))
-(define (db:test-get-rundir vec) (vector-ref vec 10))
-(define (db:test-get-item-path vec) (vector-ref vec 11))
-(define (db:test-get-run_duration vec) (vector-ref vec 12))
-(define (db:test-get-final_logf vec) (vector-ref vec 13))
-(define (db:test-get-comment vec) (vector-ref vec 14))
-(define (db:test-get-process_id vec) (vector-ref vec 16))
-(define (db:test-get-archived vec) (vector-ref vec 17))
-(define (db:test-get-last_update vec) (vector-ref vec 18))
-
-;; (define (db:test-get-pass_count vec) (vector-ref vec 15))
-;; (define (db:test-get-fail_count vec) (vector-ref vec 16))
-(define (db:test-get-fullname vec)
- (conc (db:test-get-testname vec) "/" (db:test-get-item-path vec)))
-
-;; replace runs:make-full-test-name with this routine
-(define (db:test-make-full-name testname itempath)
- (if (equal? itempath "") testname (conc testname "/" itempath)))
-
-(define (db:test-get-first_err vec) (conc #;printable (vector-ref vec 15)))
-(define (db:test-get-first_warn vec) (conc #;printable (vector-ref vec 16))) ;; RADT => reference 16 is repeated
-
-(define (db:test-set-cpuload! vec val)(vector-set! vec 7 val))
-(define (db:test-set-diskfree! vec val)(vector-set! vec 8 val))
-(define (db:test-set-testname! vec val)(vector-set! vec 2 val))
-(define (db:test-set-state! vec val)(vector-set! vec 3 val))
-(define (db:test-set-status! vec val)(vector-set! vec 4 val))
-(define (db:test-set-run_duration! vec val)(vector-set! vec 12 val))
-(define (db:test-set-final_logf! vec val)(vector-set! vec 13 val))
-
-;; Test record utility functions
-
-;; Is a test a toplevel?
-;;
-(define (db:test-get-is-toplevel vec)
- (and (equal? (db:test-get-item-path vec) "") ;; test is not an item
- (equal? (db:test-get-uname vec) "n/a"))) ;; test has never been run
-
-;; make-vector-record "" db mintest id run_id testname state status event_time item_path
-;; RADT => purpose of mintest??
-;;
-(define (make-db:mintest)(make-vector 7))
-(define (db:mintest-get-id vec) (vector-ref vec 0))
-(define (db:mintest-get-run_id vec) (vector-ref vec 1))
-(define (db:mintest-get-testname vec) (vector-ref vec 2))
-(define (db:mintest-get-state vec) (vector-ref vec 3))
-(define (db:mintest-get-status vec) (vector-ref vec 4))
-(define (db:mintest-get-event_time vec) (vector-ref vec 5))
-(define (db:mintest-get-item_path vec) (vector-ref vec 6))
-
-;; make-vector-record db testmeta id testname author owner description reviewed iterated avg_runtime avg_disk
-(define (make-db:testmeta)(make-vector 10 ""))
-(define (db:testmeta-get-id vec) (vector-ref vec 0))
-(define (db:testmeta-get-testname vec) (vector-ref vec 1))
-(define (db:testmeta-get-author vec) (vector-ref vec 2))
-(define (db:testmeta-get-owner vec) (vector-ref vec 3))
-(define (db:testmeta-get-description vec) (vector-ref vec 4))
-(define (db:testmeta-get-reviewed vec) (vector-ref vec 5))
-(define (db:testmeta-get-iterated vec) (vector-ref vec 6))
-(define (db:testmeta-get-avg_runtime vec) (vector-ref vec 7))
-(define (db:testmeta-get-avg_disk vec) (vector-ref vec 8))
-(define (db:testmeta-get-tags vec) (vector-ref vec 9))
-(define (db:testmeta-set-id! vec val)(vector-set! vec 0 val))
-(define (db:testmeta-set-testname! vec val)(vector-set! vec 1 val))
-(define (db:testmeta-set-author! vec val)(vector-set! vec 2 val))
-(define (db:testmeta-set-owner! vec val)(vector-set! vec 3 val))
-(define (db:testmeta-set-description! vec val)(vector-set! vec 4 val))
-(define (db:testmeta-set-reviewed! vec val)(vector-set! vec 5 val))
-(define (db:testmeta-set-iterated! vec val)(vector-set! vec 6 val))
-(define (db:testmeta-set-avg_runtime! vec val)(vector-set! vec 7 val))
-(define (db:testmeta-set-avg_disk! vec val)(vector-set! vec 8 val))
-
-;;======================================================================
-;; S I M P L E R U N
-;;======================================================================
-
-;; (defstruct id "runname" "state" "status" "owner" "event_time"
-
-;;======================================================================
-;; T E S T D A T A
-;;======================================================================
-(define (make-db:test-data)(make-vector 10))
-(define (db:test-data-get-id vec) (vector-ref vec 0))
-(define (db:test-data-get-test_id vec) (vector-ref vec 1))
-(define (db:test-data-get-category vec) (vector-ref vec 2))
-(define (db:test-data-get-variable vec) (vector-ref vec 3))
-(define (db:test-data-get-value vec) (vector-ref vec 4))
-(define (db:test-data-get-expected vec) (vector-ref vec 5))
-(define (db:test-data-get-tol vec) (vector-ref vec 6))
-(define (db:test-data-get-units vec) (vector-ref vec 7))
-(define (db:test-data-get-comment vec) (vector-ref vec 8))
-(define (db:test-data-get-status vec) (vector-ref vec 9))
-(define (db:test-data-get-type vec) (vector-ref vec 10))
-(define (db:test-data-get-last_update vec) (vector-ref vec 11))
-
-(define (db:test-data-set-id! vec val)(vector-set! vec 0 val))
-(define (db:test-data-set-test_id! vec val)(vector-set! vec 1 val))
-(define (db:test-data-set-category! vec val)(vector-set! vec 2 val))
-(define (db:test-data-set-variable! vec val)(vector-set! vec 3 val))
-(define (db:test-data-set-value! vec val)(vector-set! vec 4 val))
-(define (db:test-data-set-expected! vec val)(vector-set! vec 5 val))
-(define (db:test-data-set-tol! vec val)(vector-set! vec 6 val))
-(define (db:test-data-set-units! vec val)(vector-set! vec 7 val))
-(define (db:test-data-set-comment! vec val)(vector-set! vec 8 val))
-(define (db:test-data-set-status! vec val)(vector-set! vec 9 val))
-(define (db:test-data-set-type! vec val)(vector-set! vec 10 val))
-
-;;======================================================================
-;; S T E P S
-;;======================================================================
-;; Run steps
-;; make-vector-record "Run steps" db step id test_id stepname step_complete step_pass event_time
-(define (make-db:step)(make-vector 9))
-(define (tdb:step-get-id vec) (vector-ref vec 0))
-(define (tdb:step-get-test_id vec) (vector-ref vec 1))
-(define (tdb:step-get-stepname vec) (vector-ref vec 2))
-(define (tdb:step-get-state vec) (vector-ref vec 3))
-(define (tdb:step-get-status vec) (vector-ref vec 4))
-(define (tdb:step-get-event_time vec) (vector-ref vec 5))
-(define (tdb:step-get-logfile vec) (vector-ref vec 6))
-(define (tdb:step-get-comment vec) (vector-ref vec 7))
-(define (tdb:step-get-last_update vec) (vector-ref vec 8))
-(define (tdb:step-set-id! vec val)(vector-set! vec 0 val))
-(define (tdb:step-set-test_id! vec val)(vector-set! vec 1 val))
-(define (tdb:step-set-stepname! vec val)(vector-set! vec 2 val))
-(define (tdb:step-set-state! vec val)(vector-set! vec 3 val))
-(define (tdb:step-set-status! vec val)(vector-set! vec 4 val))
-(define (tdb:step-set-event_time! vec val)(vector-set! vec 5 val))
-(define (tdb:step-set-logfile! vec val)(vector-set! vec 6 val))
-(define (tdb:step-set-comment! vec val)(vector-set! vec 7 val))
-
-
-;; The steps table
-(define (make-db:steps-table)(make-vector 5))
-(define (tdb:steps-table-get-stepname vec) (vector-ref vec 0))
-(define (tdb:steps-table-get-start vec) (vector-ref vec 1))
-(define (tdb:steps-table-get-end vec) (vector-ref vec 2))
-(define (tdb:steps-table-get-status vec) (vector-ref vec 3))
-(define (tdb:steps-table-get-runtime vec) (vector-ref vec 4))
-(define (tdb:steps-table-get-log-file vec) (vector-ref vec 5))
-
-(define (tdb:step-stable-set-stepname! vec val)(vector-set! vec 0 val))
-(define (tdb:step-stable-set-start! vec val)(vector-set! vec 1 val))
-(define (tdb:step-stable-set-end! vec val)(vector-set! vec 2 val))
-(define (tdb:step-stable-set-status! vec val)(vector-set! vec 3 val))
-(define (tdb:step-stable-set-runtime! vec val)(vector-set! vec 4 val))
-
-;; The data structure for handing off requests via wire
-(define (make-cdb:packet)(make-vector 6))
-(define (cdb:packet-get-client-sig vec) (vector-ref vec 0))
-(define (cdb:packet-get-qtype vec) (vector-ref vec 1))
-(define (cdb:packet-get-immediate vec) (vector-ref vec 2))
-(define (cdb:packet-get-query-sig vec) (vector-ref vec 3))
-(define (cdb:packet-get-params vec) (vector-ref vec 4))
-(define (cdb:packet-get-qtime vec) (vector-ref vec 5))
-(define (cdb:packet-set-client-sig! vec val)(vector-set! vec 0 val))
-(define (cdb:packet-set-qtype! vec val)(vector-set! vec 1 val))
-(define (cdb:packet-set-immediate! vec val)(vector-set! vec 2 val))
-(define (cdb:packet-set-query-sig! vec val)(vector-set! vec 3 val))
-(define (cdb:packet-set-params! vec val)(vector-set! vec 4 val))
-(define (cdb:packet-set-qtime! vec val)(vector-set! vec 5 val))
Index: dbmod.scm
==================================================================
--- dbmod.scm
+++ dbmod.scm
@@ -30,12 +30,253 @@
(declare (uses mtmod))
(declare (uses pkts))
(declare (uses dbi))
(module dbmod
- *
-
+ (
+dbr:dbstruct-get-dbdat
+dbr:dbstruct-dbdat-put!
+db:run-id->first-num
+db:run-id->path
+db:dbname->path
+db:run-id->dbname
+db:get-dbdat
+db:get-inmem
+db:get-ddb
+db:open-dbdat
+db:open-run-db
+db:open-inmem-db
+db:setup
+db:get-main-lock
+db:with-lock-db
+db:get-iam-server-lock
+db:get-locker
+db:take-lock
+db:release-lock
+db:general-sqlite-error-dump
+db:first-result-default
+db:generic-error-printout
+db:with-db
+db:set-sync
+db:get-last-update-time
+db:sync-inmem->disk
+db:sync-main-list
+db:sync-all-tables-list
+db:move-and-recreate-db
+db:repair-db
+db:sync-one-table
+db:sync-tables
+db:patch-schema-rundb
+db:patch-schema-maindb
+db:adj-target
+db:get-access-mode
+db:dispatch-query
+db:create-all-triggers
+db:create-triggers
+db:drop-all-triggers
+db:is-trigger-dropped
+db:drop-triggers
+db:initialize-db
+db:archive-get-allocations
+db:archive-register-disk
+db:archive-register-block-name
+db:test-set-archive-block-id
+db:test-get-archive-block-info
+open-logging-db
+db:log-local-event
+db:log-event
+db:have-incompletes?
+db:get-status-from-final-status-file
+db:find-and-mark-incomplete
+db:top-test-set-per-pf-counts
+db:clean-up
+db:clean-up-rundb
+db:get-var
+db:inc-var
+db:dec-var
+db:set-var
+db:add-var
+db:del-var
+db:open-no-sync-db
+db:no-sync-db
+db:no-sync-set
+db:no-sync-del!
+db:no-sync-get/default
+db:no-sync-get-lock
+db:get-keys
+db:get-index-by-header
+db:get-value-by-header
+db:get-header
+db:get-rows
+db:get-run-times
+db:get-run-name-from-id
+db:get-run-key-val
+runs:get-std-run-fields
+db:register-run
+db:insert-run
+db:get-runs
+db:simple-get-runs
+db:get-changed-run-ids
+db:get-targets
+db:get-num-runs
+db:get-runs-cnt-by-patt
+db:get-raw-run-stats
+db:update-run-stats
+db:get-main-run-stats
+db:print-current-query-stats
+db:get-all-run-ids
+db:get-run-stats
+db:get-runs-by-patt
+db:get-run-info
+db:set-comment-for-run
+db:delete-run
+db:update-run-event_time
+db:lock/unlock-run
+db:set-run-status
+db:set-run-state-status
+db:get-run-status
+db:get-run-state
+db:get-key-val-pairs
+db:get-key-vals
+db:get-target
+db:get-prev-run-ids
+db:get-tests-for-run
+db:test-short-record->norm
+db:get-tests-for-run-state-status
+db:get-testinfo-state-status
+db:get-tests-for-run-mindata
+db:get-tests-for-runs
+db:delete-test-records
+db:delete-old-deleted-test-records
+db:set-tests-state-status
+db:test-set-state-status
+db:get-count-tests-running
+db:get-count-tests-actually-running
+db:get-count-tests-running-for-run-id
+db:get-count-tests-running-for-testname
+db:get-not-completed-cnt
+db:get-count-tests-running-in-jobgroup
+db:estimated-tests-remaining
+db:get-test-id
+db:test-set-top-process-pid
+db:test-get-top-process-pid
+db:field->number
+db:update-tesdata-on-repilcate-db
+db:get-all-tests-info-by-run-id
+db:replace-test-records
+db:get-test-info-by-id
+db:get-test-info-by-ids
+db:get-test-info
+db:test-get-rundir-from-test-id
+db:get-test-times
+db:teststep-set-status!
+db:delete-steps-for-test!
+db:get-steps-for-test
+db:get-steps-data
+db:get-data-info-by-id
+db:test-data-rollup
+db:logpro-dat->csv
+db:csv->test-data
+db:read-test-data
+db:read-test-data-varpatt
+db:get-run-ids-matching-target
+db:test-get-paths-matching-keynames-target-new
+db:test-toplevel-num-items
+db:obj->string
+db:string->obj
+db:set-state-status-and-roll-up-items
+db:roll-up-rules
+db:set-state-status-and-roll-up-run
+db:get-all-state-status-counts-for-run
+db:get-all-state-status-counts-for-test
+db:test-get-logfile-info
+db:lookup-query
+db:login
+db:general-call
+db:get-state-status-summary
+db:get-latest-host-load
+db:set-top-level-from-items
+db:get-matching-previous-test-run-records
+db:test-get-records-for-index-file
+db:get-tests-tags
+db:testmeta-get-record
+db:testmeta-add-record
+db:testmeta-update-field
+db:testmeta-get-all
+db:compare-itempaths
+db:convert-test-itempath
+db:multi-pattern-apply
+db:get-prereqs-not-met
+db:get-run-record-ids
+db:get-changed-record-ids
+tdb:read-test-data
+tdb:get-prev-tol-for-test
+tdb:step-get-time-as-string
+tdb:get-steps-table
+tdb:get-steps-table-list
+tdb:get-compressed-steps
+mt:run-trigger
+mt:process-triggers
+mt:lazy-read-test-config
+mt:get-run-stats
+server:reply
+common:with-queue-db
+common:load-pkts-to-db
+db:hoh-set!
+db:hoh-get
+db:get-cache-stmth
+db:register-server
+db:deregister-server
+db:get-server-info
+db:get-count-servers
+db:get-steps-info-by-id
+
+make-dbr:dbdat
+dbr:dbdat-db
+dbr:dbdat-inmem
+dbr:dbdat-last-sync
+dbr:dbdat-last-write
+dbr:dbdat-run-id
+dbr:dbdat-fname
+dbr:dbdat-db-set!
+dbr:dbdat-inmem-set!
+dbr:dbdat-last-sync-set!
+dbr:dbdat-last-write-set!
+dbr:dbdat-run-id-set!
+dbr:dbdat-fname-set!
+
+make-dbr:dbstruct
+dbr:dbstruct-mtdb
+dbr:dbstruct-dbdats
+dbr:dbstruct-read-only
+dbr:dbstruct-stmt-cache
+dbr:dbstruct-mtdb-set!
+dbr:dbstruct-dbdats-set!
+dbr:dbstruct-read-only-set!
+dbr:dbstruct-stmt-cache-set!
+
+make-simple-run
+simple-run-target
+simple-run-id
+simple-run-runname
+simple-run-state
+simple-run-status
+simple-run-owner
+simple-run-event_time
+simple-run-target-set!
+simple-run-id-set!
+simple-run-runname-set!
+simple-run-state-set!
+simple-run-status-set!
+simple-run-owner-set!
+simple-run-event_time-set!
+
+;; fix naming on these ones
+db:test-record-fields
+db:test-record-qry-selector
+)
+
(import scheme
(prefix sqlite3 sqlite3:)
chicken.base
chicken.condition
chicken.eval
@@ -102,17 +343,17 @@
(last-sync 0)
(last-write (current-seconds))
(run-id #f)
(fname #f))
-;; Returns the dbdat for a particular run-id from dbstruct
+;; Returns the dbdat for a particular dbfile inside the area
;;
-(define (dbr:dbstruct-get-dbdat v run-id)
- (hash-table-ref/default (dbr:dbstruct-dbdats v) run-id #f))
+(define (dbr:dbstruct-get-dbdat dbstruct dbfile)
+ (hash-table-ref/default (dbr:dbstruct-dbdats dbstruct) dbfile #f))
-(define (dbr:dbstruct-dbdat-put! v run-id db)
- (hash-table-set! (dbr:dbstruct-dbdats v) run-id db))
+(define (dbr:dbstruct-dbdat-put! dbstruct dbfile db)
+ (hash-table-set! (dbr:dbstruct-dbdats dbstruct) dbfile db))
(define (db:run-id->first-num run-id)
(let* ((s (number->string run-id))
(l (string-length s)))
(substring s (- l 1) l)))
@@ -155,15 +396,14 @@
;; if db already open - return inmem
;; if db not open, open inmem, rundb and sync then return inmem
;; inuse gets set automatically for rundb's
;;
(define (db:get-dbdat dbstruct apath dbfile)
- (let ((dbdat (dbr:dbstruct-get-dbdat dbstruct dbfile))) ;; run-id)))
+ (let ((dbdat (dbr:dbstruct-get-dbdat dbstruct dbfile)))
(if dbdat
dbdat
- (let* (;; (dbfile (db:run-id->path apath run-id))
- (newdbdat (db:open-dbdat apath dbfile db:initialize-db)))
+ (let* ((newdbdat (db:open-dbdat apath dbfile db:initialize-db)))
(dbr:dbstruct-dbdat-put! dbstruct dbfile newdbdat)
newdbdat))))
;; get the inmem db for actual db operations
;;
@@ -178,21 +418,33 @@
;; open or create the disk db file
;; create and fill the inmemory db
;; assemble into dbr:dbdat struct and return
;;
(define (db:open-dbdat apath dbfile dbinit-proc)
- (let* (;; (dbfile (db:run-id->path apath run-id))
- (db (db:open-run-db dbfile dbinit-proc))
- (inmem (db:open-inmem-db dbinit-proc))
+ (let* ((db (db:open-run-db dbfile dbinit-proc))
+ ;; (inmem (db:open-inmem-db dbinit-proc))
(dbdat (make-dbr:dbdat
- db: db
- inmem: inmem
+ db: #f ;; db
+ inmem: db ;; inmem
;; run-id: run-id ;; no can do, there are many run-id values that point to single db
fname: dbfile)))
;; now sync the disk file data into the inmemory db
- (db:sync-tables (db:sync-all-tables-list) #f db inmem)
+ ;; (db:sync-tables (db:sync-all-tables-list) '("last_update" . 0) db inmem)
+ ;; (sqlite3:finalize! db) ;; open and close every sync
dbdat))
+;; (define (db:open-dbdat apath dbfile dbinit-proc)
+;; (let* ((db (db:open-run-db dbfile dbinit-proc))
+;; (inmem (db:open-inmem-db dbinit-proc))
+;; (dbdat (make-dbr:dbdat
+;; db: #f ;; db
+;; inmem: inmem
+;; ;; run-id: run-id ;; no can do, there are many run-id values that point to single db
+;; fname: dbfile)))
+;; ;; now sync the disk file data into the inmemory db
+;; (db:sync-tables (db:sync-all-tables-list) '("last_update" . 0) db inmem)
+;; (sqlite3:finalize! db) ;; open and close every sync
+;; dbdat))
;; open the disk database file
;; NOTE: May need to add locking to file create process here
;; returns an sqlite3 database handle
;;
@@ -202,11 +454,11 @@
(create-directory parent-dir #t))
(let* ((exists (file-exists? dbfile))
(db (sqlite3:open-database dbfile))
(handler (sqlite3:make-busy-timeout 3600)))
(sqlite3:set-busy-handler! db handler)
- (db:set-sync db)
+ ;; (db:set-sync db) ;; we don't mind that this is slow?
(if (not exists)
(dbinit-proc db))
db)))
;; open and initialize the inmem db
@@ -216,10 +468,25 @@
(let* ((db (sqlite3:open-database ":memory:"))
(handler (sqlite3:make-busy-timeout 3600)))
(sqlite3:set-busy-handler! db handler)
(dbinit-proc db) ;; NOTE: inmem must always be initialized (db:initialize-db db)
db))
+
+;; ;; for debugging we have a local mode. these routines support that mode
+;; (define *dbcache* (make-hash-table))
+;;
+;; (define (db:cache-get-dbstruct rid apath)
+;; (let* ((dbname (db:run-id->dbname rid))
+;; (dbfile (db:dbname->path apath dbname)))
+;; (or (hash-table-ref/default *dbcache* dbfile #f)
+;; (let* ((dbstruct (db:setup dbfile))) ;; (db:open-dbdat apath dbfile db:initialize-db)))
+;; (hash-table-set! *dbcache* dbfile dbstruct)
+;; dbstruct))))
+;;
+;; (define (db:finalize-all-cache-dbstruct)
+;; #f)
+;;
;; get and initalize dbstruct for a given run-id
;;
;; - uses db:initialize-db to create the schema
;;
@@ -226,14 +493,13 @@
;; Make the dbstruct, call for main db at least once
;; sync disk db to inmem
;;
;; called in http-transport and replicated in rmt.scm for *local* access.
;;
-(define (db:setup run-id)
+(define (db:setup db-file) ;; run-id)
(assert *toppath* "FATAL: db:setup called before toppath is available.")
- (let* ((dbstruct (or *dbstruct-db* (make-dbr:dbstruct)))
- (db-file (db:run-id->path *toppath* run-id)))
+ (let* ((dbstruct (or *dbstruct-db* (make-dbr:dbstruct))))
(db:get-dbdat dbstruct *toppath* db-file)
(if (not *dbstruct-db*)(set! *dbstruct-db* dbstruct))
dbstruct))
;;======================================================================
@@ -252,11 +518,11 @@
(db:get-iam-server-lock dbh dbfile))))
(define (db:with-lock-db dbfile proc)
(let* ((dbh (db:open-run-db dbfile db:initialize-db))
(res (proc dbh dbfile)))
- (sqlite3:finalize! dbh)
+ ;; (sqlite3:finalize! dbh)
res))
;; called before db is open?
;;
(define (db:get-iam-server-lock dbh dbfname)
@@ -415,29 +681,33 @@
;; NOTE: touched logic is disabled/not done
;; sync run to disk if touched
;;
(define (db:sync-inmem->disk dbstruct apath dbfile #!key (force-sync #f))
- (let* ((dbdat (db:get-dbdat dbstruct apath dbfile))
- (db (dbr:dbdat-db dbdat))
- (inmem (dbr:dbdat-inmem dbdat))
- (start-t (current-seconds))
- (last-update (dbr:dbdat-last-write dbdat))
- (last-sync (dbr:dbdat-last-sync dbdat)))
- (debug:print-info 4 *default-log-port* "Syncing for dbfile: " dbfile)
- (mutex-lock! *db-multi-sync-mutex*)
- (let* ((update_info (cons (if force-sync 0 last-update) "last_update"))
- (need-sync (or force-sync (>= last-update last-sync))))
- (if need-sync
- (db:sync-tables (db:sync-all-tables-list) update_info inmem db)
- (debug:print 0 *default-log-port* "Skipping sync as nothing touched.")))
- (dbr:dbdat-last-sync-set! dbdat start-t)
- (mutex-unlock! *db-multi-sync-mutex*)))
+ #f) ;; disabled
+;; (let* ((dbdat (db:get-dbdat dbstruct apath dbfile))
+;; (dbfullname (conc apath "/" dbfile))
+;; (db (db:open-run-db dbfullname db:initialize-db)) ;; (dbr:dbdat-db dbdat))
+;; (inmem (dbr:dbdat-inmem dbdat))
+;; (start-t (current-seconds))
+;; (last-update (dbr:dbdat-last-write dbdat))
+;; (last-sync (dbr:dbdat-last-sync dbdat)))
+;; (debug:print-info 0 *default-log-port* "Syncing for dbfile: "dbfile", last-update: "last-update", last-sync: "last-sync)
+;; (mutex-lock! *db-multi-sync-mutex*)
+;; (let* ((update_info (cons "last_update" (if force-sync 0 last-update))) ;; "last_update"))
+;; (need-sync (or force-sync (>= last-update last-sync))))
+;; (if need-sync
+;; (begin
+;; (db:sync-tables (db:sync-all-tables-list) update_info inmem db)
+;; (dbr:dbdat-last-sync-set! dbdat start-t))
+;; (debug:print 0 *default-log-port* "Skipping sync as nothing touched.")))
+;; (sqlite3:finalize! db)
+;; (mutex-unlock! *db-multi-sync-mutex*)))
;; TODO: Add final sync to this
;;
-(define (db:safely-close-sqlite3-db db stmt-cache #!key (try-num 3))
+#;(define (db:safely-close-sqlite3-db db stmt-cache #!key (try-num 3))
(if (<= try-num 0)
#f
(handle-exceptions
exn
(begin
@@ -451,11 +721,11 @@
(sqlite3:finalize! db)
#t)
#f))))
;; close all opened run-id dbs
-(define (db:close-all dbstruct)
+#;(define (db:close-all dbstruct)
(assert (dbr:dbstruct? dbstruct) "FATAL: db:close-all called with dbstruct not set up.")
(handle-exceptions
exn
(begin
(debug:print 0 *default-log-port* "WARNING: Finalizing failed, " ((condition-property-accessor 'exn 'message) exn) ", note - exn=" exn)
@@ -643,38 +913,23 @@
(sqlite3:execute db "vacuum;")))
(sqlite3:finalize! db)
#t))))))
+;; last-update is *always* a pair ( fieldname|#f . last-update-seconds|#f)
(define (db:sync-one-table fromdb todb tabledat last-update numrecs)
+ (assert (pair? last-update) "FATAL: last-update must always be a pair.")
(let* ((tablename (car tabledat))
(fields (cdr tabledat))
(has-last-update (member "last_update" fields))
- (use-last-update (cond
- ((and has-last-update
- (member "last_update" fields))
- #t) ;; if given a number, just use it for all fields
- ((number? last-update) #f) ;; if not matched first entry then ignore last-update for this table
- ((and (pair? last-update)
- (member (car last-update) ;; last-update field name
- (map car fields)))
- #t)
- (last-update
- (debug:print 0 *default-log-port* "ERROR: parameter last-update for db:sync-tables must be a pair or a number, received: " last-update);; found in fields
- #f)
- (else
- #f)))
- (last-update-value (if use-last-update ;; no need to check for has-last-update - it is already accounted for
- (if (number? last-update)
- last-update
- (cdr last-update))
- #f))
- (last-update-field (if use-last-update
- (if (number? last-update)
+ (last-update-field (or (car last-update)
+ (if has-last-update
"last_update"
- (car last-update))
- #f))
+ #f)))
+ (has-field (member last-update-field fields))
+ (last-update-value (cdr last-update))
+ (use-last-update (and has-field last-update-field last-update-value))
(num-fields (length fields))
(field->num (make-hash-table))
(num->field (apply vector (map car fields))) ;; BBHERE
(full-sel (conc "SELECT " (string-intersperse (map car fields) ",")
" FROM " tablename (if use-last-update ;; apply last-update criteria
@@ -757,10 +1012,11 @@
(if (and same
(< i (- num-fields 1)))
(loop (+ i 1))))
(if (not same)
(begin
+ (debug:print 0 *default-log-port* "applying data "fromrow"to table "tablename", numrecs="numrecs)
(apply sqlite3:execute stmth (vector->list fromrow))
(hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0)))))))
fromdat-lst))))
fromdats)
(sqlite3:finalize! stmth)
@@ -773,11 +1029,11 @@
;; if last-update specified ("field-name" . time-in-seconds)
;; then sync only records where field-name >= time-in-seconds
;; IFF field-name exists
;;
(define (db:sync-tables tbls last-update fromdb todb)
-
+ (assert (pair? last-update) "FATAL: last-update must always be a pair")
;; NOTE: I'm moving all the checking OUT of this routine. Check for read/write access, existance, etc
;; BEFORE calling this sync
(let ((stmts (make-hash-table)) ;; table-field => stmt
(all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 ))
@@ -798,11 +1054,11 @@
(lambda (dat)
(let ((tblname (car dat))
(count (cdr dat)))
(set! tot-count (+ tot-count count))
(if (> count 0)
- (if should-print (debug:print 0 *default-log-port* (format #f " ~10a ~5a" tblname count))))))
+ (if should-print (debug:print 0 *default-log-port* " "tblname" "count))))) ;; (format #f " ~10a ~5a" tblname count))))))
(sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b))))))
tot-count))
(define (db:patch-schema-rundb frundb)
;;
@@ -1177,24 +1433,24 @@
BEGIN
UPDATE test_data SET last_update=(strftime('%s','now'))
WHERE id=old.id;
END;" )))
-(define (db:create-all-triggers dbstruct)
+(define (db:create-all-triggers dbstruct run-id)
(db:with-db
- dbstruct #f #f
+ dbstruct run-id #f
(lambda (db)
(db:create-triggers db))))
(define (db:create-triggers db)
(for-each (lambda (key)
(sqlite3:execute db (cadr key)))
db:trigger-list))
-(define (db:drop-all-triggers dbstruct)
+(define (db:drop-all-triggers dbstruct run-id)
(db:with-db
- dbstruct #f #f
+ dbstruct run-id #f
(lambda (db)
(db:drop-triggers db))))
(define (db:is-trigger-dropped db tbl-name)
(let* ((trigger-name (if (equal? tbl-name "test_steps")
@@ -1623,11 +1879,11 @@
(deadtime (if (and deadtime-str
(string->number deadtime-str))
(string->number deadtime-str)
72000))) ;; twenty hours
(db:with-db
- dbstruct #f #f
+ dbstruct run-id #f
(lambda (db)
(if (number? ovr-deadtime)(set! deadtime ovr-deadtime))
;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes
;;
@@ -1706,11 +1962,11 @@
)
(debug:print-info 4 *default-log-port* "running-deadtime = " running-deadtime)
(debug:print-info 4 *default-log-port* "deadtime-trim = " deadtime-trim)
(db:with-db
- dbstruct #f #f
+ dbstruct run-id #f
(lambda (db)
(let* ((stmth1 (db:get-cache-stmth
dbstruct db
"SELECT id,rundir,uname,testname,item_path,event_time,run_duration FROM tests
WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?)
@@ -1828,11 +2084,11 @@
)))))))
;; BUG: Probably broken - does not explicitly use run-id in the query
;;
(define (db:top-test-set-per-pf-counts dbstruct run-id test-name)
- (db:general-call dbstruct 'top-test-set-per-pf-counts (list test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name)))
+ (db:general-call dbstruct 'top-test-set-per-pf-counts run-id (list test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name)))
;; Clean out old junk and vacuum the database
;;
;; Ultimately do something like this:
;;
@@ -1978,18 +2234,18 @@
;; dead-runs))
;;======================================================================
;; M E T A G E T A N D S E T V A R S
;;======================================================================
-
+
;; returns number if string->number is successful, string otherwise
;; also updates *global-delta*
;;
-(define (db:get-var dbstruct var)
+(define (db:get-var dbstruct run-id var)
(let* ((res #f))
(db:with-db
- dbstruct #f #f
+ dbstruct run-id #f
(lambda (db)
(sqlite3:for-each-row
(lambda (val)
(set! res val))
db
@@ -1998,17 +2254,17 @@
(if (string? res)
(let ((valnum (string->number res)))
(if valnum (set! res valnum))))
res))))
-(define (db:inc-var dbstruct var)
- (db:with-db dbstruct #f #t
+(define (db:inc-var dbstruct run-id var)
+ (db:with-db dbstruct run-id #t
(lambda (db)
(sqlite3:execute db "UPDATE metadat SET val=val+1 WHERE var=?;" var))))
-(define (db:dec-var dbstruct var)
- (db:with-db dbstruct #f #t
+(define (db:dec-var dbstruct run-id var)
+ (db:with-db dbstruct run-id #t
(lambda (db)
(sqlite3:execute db "UPDATE metadat SET val=val-1 WHERE var=?;" var))))
;; This was part of db:get-var. It was used to estimate the load on
;; the database files.
@@ -2020,22 +2276,22 @@
;; (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit
;; (begin
;; (debug:print-info 4 *default-log-port* "launch throttle factor=" *global-delta*)
;; (set! *last-global-delta-printed* *global-delta*)))
-(define (db:set-var dbstruct var val)
- (db:with-db dbstruct #f #t
+(define (db:set-var dbstruct run-id var val)
+ (db:with-db dbstruct run-id #t
(lambda (db)
(sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val))))
-(define (db:add-var dbstruct var val)
- (db:with-db dbstruct #f #t
+(define (db:add-var dbstruct run-id var val)
+ (db:with-db dbstruct run-id #t
(lambda (db)
(sqlite3:execute db "UPDATE metadat SET val=val+? WHERE var=?;" val var))))
-(define (db:del-var dbstruct var)
- (db:with-db dbstruct #f #t
+(define (db:del-var dbstruct run-id var)
+ (db:with-db dbstruct run-id #t
(lambda (db)
(sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var))))
;;======================================================================
;; no-sync.db - small bits of data to be shared between servers
@@ -2089,11 +2345,11 @@
(if newres
newres
res))
res)))
-(define (db:no-sync-close-db db stmt-cache)
+#;(define (db:no-sync-close-db db stmt-cache)
(db:safely-close-sqlite3-db db stmt-cache))
;; transaction protected lock aquisition
;; either:
;; fails returns (#f . lock-creation-time)
@@ -2245,10 +2501,45 @@
(db:with-db
dbstruct #f #f
(lambda (db)
(let ((res #f))
(apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time,contour" comma keystr ") VALUES (?,?,?,?,strftime('%s','now'),?" comma valslots ");")
+ allvals)
+ (apply sqlite3:for-each-row
+ (lambda (id)
+ (set! res id))
+ db
+ (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");")))
+ qry)
+ qryvals)
+ (sqlite3:execute db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res)
+ res)))
+ (begin
+ (debug:print-error 0 *default-log-port* "Called without all necessary keys")
+ #f))))
+
+;; register a run with the db
+;;
+(define (db:insert-run dbstruct run-id keyvals runname state status user contour-in)
+ (let* ((keys (map car keyvals))
+ (keystr (keys->keystr keys))
+ (contour (or contour-in "")) ;; empty string to force no hierarcy and be backwards compatible.
+ (comma (if (> (length keys) 0) "," ""))
+ (andstr (if (> (length keys) 0) " AND " ""))
+ (valslots (keys->valslots keys)) ;; ?,?,? ...
+ (allvals (append (list runname state status user contour) (map cadr keyvals)))
+ (qryvals (append (list runname) (map cadr keyvals)))
+ (key=?str (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND ")))
+ (debug:print 3 *default-log-port* "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str)
+ (debug:print 2 *default-log-port* "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run")
+ (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and"
+ (db:with-db
+ dbstruct run-id #f
+ (lambda (db)
+ (let ((res #f))
+ (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (id,runname,state,status,owner,event_time,contour" comma keystr ") VALUES (?,?,?,?,?,strftime('%s','now'),?" comma valslots ");")
+ run-id
allvals)
(apply sqlite3:for-each-row
(lambda (id)
(set! res id))
db
@@ -2466,11 +2757,11 @@
;;
(define (db:update-run-stats dbstruct run-id stats)
;; (mutex-lock! *db-transaction-mutex*)
(db:with-db
dbstruct
- #f
+ run-id
#f
(lambda (db)
;; remove previous data
@@ -3023,14 +3314,14 @@
;; Convert calling routines to get list of run-ids and loop, do not use the get-tests-for-runs
;;
(define (db:delete-test-records dbstruct run-id test-id)
- (db:general-call dbstruct 'delete-test-step-records (list test-id))
- (db:general-call dbstruct 'delete-test-data-records (list test-id))
+ (db:general-call dbstruct 'delete-test-step-records run-id (list test-id))
+ (db:general-call dbstruct 'delete-test-data-records run-id (list test-id))
(db:with-db
- dbstruct #f #f
+ dbstruct run-id #f
(lambda (db)
(sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id))))
;;
(define (db:delete-old-deleted-test-records dbstruct)
@@ -3085,31 +3376,25 @@
test-ids))
;; ;; speed up for common cases with a little logic
;; ;; NB// Ultimately this will be deprecated in deference to mt:test-set-state-status-by-id
;;
+;; NOTE: processing triggers was called here - moved upstream
+;;
;; NOTE: run-id is not used
;; ;;
-(define (db:test-set-state-status dbstruct run-id test-id newstate newstatus newcomment)
- (db:with-db
- dbstruct
- ;; run-id
- #f
- #t
- (lambda (db)
- (cond
- ((and newstate newstatus newcomment)
- (sqlite3:execute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus newcomment ;; (sdb:qry 'getid newcomment)
- test-id))
- ((and newstate newstatus)
- (sqlite3:execute db "UPDATE tests SET state=?,status=? WHERE id=?;" newstate newstatus test-id))
- (else
- (if newstate (sqlite3:execute db "UPDATE tests SET state=? WHERE id=?;" newstate test-id))
- (if newstatus (sqlite3:execute db "UPDATE tests SET status=? WHERE id=?;" newstatus test-id))
- (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment ;; (sdb:qry 'getid newcomment)
- test-id))))))
- (mt:process-triggers dbstruct run-id test-id newstate newstatus))
+(define (db:test-set-state-status db run-id test-id newstate newstatus newcomment)
+ (cond
+ ((and newstate newstatus newcomment)
+ (sqlite3:execute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus newcomment ;; (sdb:qry 'getid newcomment)
+ test-id))
+ ((and newstate newstatus)
+ (sqlite3:execute db "UPDATE tests SET state=?,status=? WHERE id=?;" newstate newstatus test-id))
+ (else
+ (if newstate (sqlite3:execute db "UPDATE tests SET state=? WHERE id=?;" newstate test-id))
+ (if newstatus (sqlite3:execute db "UPDATE tests SET status=? WHERE id=?;" newstatus test-id))
+ (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment test-id)))))
;; NEW BEHAVIOR: Count tests running in all runs!
;;
(define (db:get-count-tests-running dbstruct run-id) ;; fastmode)
(let* ((qry ;; (if fastmode
@@ -3492,24 +3777,24 @@
db
"SELECT id,test_id,stepname,state,status,event_time,logfile,comment FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC;
test-id)
(reverse res)))))
- (define (db:get-steps-info-by-id dbstruct test-step-id)
- (db:with-db
- dbstruct
- #f
- #f
- (lambda (db)
- (let* ((res (vector #f #f #f #f #f #f #f #f #f)))
- (sqlite3:for-each-row
- (lambda (id test-id stepname state status event-time logfile comment last-update)
- (set! res (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment last-update)))
- db
- "SELECT id,test_id,stepname,state,status,event_time,logfile,comment,last_update FROM test_steps WHERE id=? ORDER BY id ASC;" ;; event_time DESC,id ASC;
- test-step-id)
- res))))
+(define (db:get-steps-info-by-id dbstruct test-step-id)
+ (db:with-db
+ dbstruct
+ #f
+ #f
+ (lambda (db)
+ (let* ((res (vector #f #f #f #f #f #f #f #f #f)))
+ (sqlite3:for-each-row
+ (lambda (id test-id stepname state status event-time logfile comment last-update)
+ (set! res (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment last-update)))
+ db
+ "SELECT id,test_id,stepname,state,status,event_time,logfile,comment,last_update FROM test_steps WHERE id=? ORDER BY id ASC;" ;; event_time DESC,id ASC;
+ test-step-id)
+ res))))
(define (db:get-steps-data dbstruct run-id test-id)
(db:with-db
dbstruct
run-id
@@ -3562,13 +3847,13 @@
db
"SELECT (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail') AS fail_count,
(SELECT count(id) FROM test_data WHERE test_id=? AND status like 'pass') AS pass_count;"
test-id test-id)
;; Now rollup the counts to the central megatest.db
- (db:general-call dbstruct 'pass-fail-counts (list pass-count fail-count test-id))
+ (db:general-call dbstruct 'pass-fail-counts run-id (list pass-count fail-count test-id))
;; if the test is not FAIL then set status based on the fail and pass counts.
- (db:general-call dbstruct 'test_data-pf-rollup (list test-id test-id test-id test-id))))))
+ (db:general-call dbstruct 'test_data-pf-rollup run-id (list test-id test-id test-id test-id))))))
;; each section is a rule except "final" which is the final result
;;
;; [rule-5]
;; operator in
@@ -3869,40 +4154,44 @@
(tl-testdat (db:get-test-info dbstruct run-id test-name ""))
(tl-test-id (if tl-testdat
(db:test-get-id tl-testdat)
#f)))
(if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
- (db:general-call dbstruct 'set-test-start-time (list test-id)))
- (mutex-lock! *db-transaction-mutex*)
+ (db:general-call dbstruct 'set-test-start-time run-id (list test-id)))
+ ;; (mutex-lock! *db-transaction-mutex*)
(db:with-db
- dbstruct #f #f
+ dbstruct run-id #f
(lambda (db)
(let ((tr-res
(sqlite3:with-transaction
db
(lambda ()
;; NB// Pass the db so it is part fo the transaction
- (db:test-set-state-status db run-id test-id state status comment) ;; this call sets the item state/status
+ ;; this call sets the item state/status
+ (db:test-set-state-status db run-id test-id state status comment)
(if (not (equal? item-path "")) ;; only roll up IF incoming test is an item
(let* ((state-status-counts (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path state status)) ;; item-path is used to exclude current state/status of THIS test
(state-stauses (db:roll-up-rules state-status-counts state status))
(newstate (car state-stauses))
(newstatus (cadr state-stauses)))
(debug:print 4 *default-log-port* "BB> tl-test-id="tl-test-id" ; "test-name":"item-path" newstate="newstate" newstatus="newstatus" len(sscs)="(length state-status-counts) " state-status-counts: "
(apply conc
(map (lambda (x)
(conc
- (with-output-to-string (lambda () (pp (dbr:counts->alist x)))) " | "))
- state-status-counts))); end debug:print
-
+ (with-output-to-string (lambda () (pp (dbr:counts->alist x)))) " | "))
+ state-status-counts))); end debug:print
+
(if tl-test-id
(db:test-set-state-status db run-id tl-test-id newstate newstatus #f)) ;; we are still in the transaction - must access the db and not the dbstruct
))))))
- (mutex-unlock! *db-transaction-mutex*)
+ ;; (mutex-unlock! *db-transaction-mutex*)
(if (and test-id state status (equal? status "AUTO"))
(db:test-data-rollup dbstruct run-id test-id status))
- tr-res)))))
+ tr-res)))
+ ;; this was moved out of test-set-state-status
+ (mt:process-triggers dbstruct run-id test-id state status)))
+
(define (db:roll-up-rules state-status-counts state status)
(let* ((running (length (filter (lambda (x)
(member (dbr:counts-state x) *common:running-states*))
state-status-counts)))
@@ -3957,11 +4246,11 @@
;; 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*)
+ ;; (mutex-lock! *db-transaction-mutex*)
(db:with-db
dbstruct #f #f
(lambda (db)
(let ((tr-res
(sqlite3:with-transaction
@@ -3971,11 +4260,11 @@
(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*)
+ ;; (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
@@ -4233,18 +4522,18 @@
(else
(hash-table-set! *logged-in-clients* client-signature (current-seconds))
'(#t "successful login"))))
-(define (db:general-call dbstruct stmtname params)
+(define (db:general-call dbstruct stmtname run-id params)
(let ((query (let ((q (alist-ref (if (string? stmtname)
(string->symbol stmtname)
stmtname)
db:queries)))
(if q (car q) #f))))
(db:with-db
- dbstruct #f #f
+ dbstruct run-id #f
(lambda (db)
(apply sqlite3:execute db query params)
#t))))
;; get a summary of state and status counts to calculate a rollup
@@ -5156,11 +5445,11 @@
actual-state " "
actual-status " "
event-time
))
(prev-nbfake-log (get-environment-variable "NBFAKE_LOG")))
- (setenv "NBFAKE_LOG" (conc (cond
+ (set-environment-variable! "NBFAKE_LOG" (conc (cond
((and (directory-exists? test-rundir)
(file-writable? test-rundir))
test-rundir)
((and (directory-exists? *toppath*)
(file-writable? *toppath*))
@@ -5171,12 +5460,12 @@
;; (call-with-environment-variables
;; `(("NBFAKE_LOG" . ,(conc test-rundir "/" logname)))
;; (lambda ()
(process-run fullcmd)
(if prev-nbfake-log
- (setenv "NBFAKE_LOG" prev-nbfake-log)
- (unsetenv "NBFAKE_LOG"))
+ (set-environment-variable! "NBFAKE_LOG" prev-nbfake-log)
+ (unset-environment-variable! "NBFAKE_LOG"))
)) ;; ))
(define (mt:process-triggers dbstruct run-id test-id newstate newstatus)
(if test-id
(let* ((test-dat (db:get-test-info-by-id dbstruct run-id test-id)))
@@ -5248,16 +5537,16 @@
(if (and (common:file-exists? tconfig-file)
(file-readable? tconfig-file))
(let ((link-tree-path (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree"))
(old-link-tree (get-environment-variable "MT_LINKTREE"))
(bigmodenv (module-environment 'bigmod)))
- (if link-tree-path (setenv "MT_LINKTREE" link-tree-path))
+ (if link-tree-path (set-environment-variable! "MT_LINKTREE" link-tree-path))
(let ((newtcfg (configf:read-config tconfig-file #f #f env-to-use: bigmodenv))) ;; NOTE: Does NOT run [system ...]
(hash-table-set! *testconfigs* test-name newtcfg)
(if old-link-tree
- (setenv "MT_LINKTREE" old-link-tree)
- (unsetenv "MT_LINKTREE"))
+ (set-environment-variable! "MT_LINKTREE" old-link-tree)
+ (unset-environment-variable! "MT_LINKTREE"))
newtcfg))
(if (null? tal)
(begin
(debug:print-error 0 *default-log-port* "No readable testconfig found for " test-name)
#f)
@@ -5537,10 +5826,30 @@
(begin
(sqlite3:execute db "INSERT INTO servers (host,port,servkey,pid,ipaddr,apath,dbname) VALUES (?,?,?,?,?,?,?);"
host port servkey pid ipaddr apath dbname)
(db:get-server-info dbstruct apath dbname)))))))))
+;; run this one in a transaction where first check if host:port is taken
+(define (db:deregister-server dbstruct host port servkey pid ipaddr apath dbname)
+ (db:with-db
+ dbstruct
+ #f #f
+ (lambda (db)
+ (sqlite3:with-transaction
+ db
+ (lambda ()
+ (let* ((sinfo (db:get-server-info dbstruct apath dbname)))
+ (if (not sinfo)
+ (begin
+ (debug:print-info 0 *default-log-port* "Server already removed for "apath", "dbname) ;; at "sinfo ", while trying to register server " host":"port)
+ #f) ;; server already deregistered
+ (begin
+ (sqlite3:execute db "DELETE FROM servers WHERE apath=? AND dbname=?;" ;; (host,port,servkey,pid,ipaddr,apath,dbname) VALUES (?,?,?,?,?,?,?);"
+ ;; host port servkey pid ipaddr
+ apath dbname)
+ #;(db:get-server-info dbstruct apath dbname)))))))))
+
(define (db:get-server-info dbstruct apath dbname)
(db:with-db
dbstruct
#f #f
(lambda (db)
@@ -5549,7 +5858,20 @@
(list host port servkey pid ipaddr apath dbpath))
#f
db
"SELECT host,port,servkey,pid,ipaddr,apath,dbname FROM servers WHERE apath=? AND dbname=?;"
apath dbname))))
+
+(define (db:get-count-servers dbstruct apath)
+ (db:with-db
+ dbstruct
+ #f #f
+ (lambda (db)
+ (sqlite3:fold-row
+ (lambda (res count)
+ (max res count))
+ 0
+ db
+ "SELECT count(*) FROM servers WHERE apath=?;"
+ apath))))
)
Index: dcommon.scm
==================================================================
--- dcommon.scm
+++ dcommon.scm
@@ -16,32 +16,77 @@
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
;;======================================================================
-(use format)
-(require-library iup)
-(import (prefix iup iup:))
-(use canvas-draw)
-(import canvas-draw-iup)
-(use regex typed-records matchable)
-
(declare (unit dcommon))
+;; (declare (uses gutils))
+(declare (uses dbmod))
+(declare (uses mtver))
+(declare (uses debugprint))
+(declare (uses commonmod))
+(declare (uses configfmod))
+(declare (uses rmtmod))
+(declare (uses mtargs))
+(declare (uses testsmod))
-(declare (uses gutils))
-(declare (uses db))
-;; (declare (uses synchash))
+(module dcommon
+ *
-(include "megatest-version.scm")
+ (import scheme
+ chicken.base
+ chicken.condition
+ chicken.string
+ chicken.pretty-print
+ chicken.sort
+ chicken.time
+
+ chicken.file
+ chicken.file.posix
+ chicken.port
+ chicken.process
+ chicken.process-context
+ chicken.process-context.posix)
+
+ (import srfi-18
+ format
+ iup
+ (prefix iup iup:)
+ canvas-draw
+ canvas-draw-iup
+
+ regex
+ typed-records
+ matchable
+ srfi-69
+ sparse-vectors
+ srfi-1
+ )
+
+(import mtver
+ dbmod
+ commonmod
+ debugprint
+ configfmod
+ rmtmod
+ ;; gutils
+ (prefix mtargs args:)
+ testsmod)
+
+;; (include "megatest-version.scm")
(include "common_records.scm")
-(include "db_records.scm")
-(include "key_records.scm")
-(include "run_records.scm")
+;; (include "db_records.scm")
+;; (include "key_records.scm")
+;; (include "run_records.scm")
;; yes, this is non-ideal
(define dashboard:update-summary-tab #f)
(define dashboard:update-servers-table #f)
+
+(define *last-monitor-update-time* 0)
+(define *exit-started* #f)
+
;;======================================================================
;; C O M M O N D A T A S T R U C T U R E
;;======================================================================
;;
@@ -108,10 +153,127 @@
((last-db-time 0) : number) ;; last timestamp on megatest.db
((data-changed #f) : boolean)
((run-data-offset 0) : number) ;; get only 100 items per call, set back to zero when received less than 100 items
(db-path #f))
+;; data for each specific tab goes here
+;;
+(defstruct dboard:tabdat
+ ;; runs
+ ((allruns '()) : list) ;; list of dboard:rundat records
+ ((allruns-by-id (make-hash-table)) : hash-table) ;; hash of run-id -> dboard:rundat records
+ ((done-runs '()) : list) ;; list of runs already drawn
+ ((not-done-runs '()) : list) ;; list of runs not yet drawn
+ (header #f) ;; header for decoding the run records
+ (keys #f) ;; keys for this run (i.e. target components)
+ ((numruns (string->number (or (args:get-arg "-cols")
+ (configf:lookup *configdat* "dashboard" "cols")
+ "8"))) : number) ;;
+ ((tot-runs 0) : number)
+ ((last-data-update 0) : number) ;; last time the data in allruns was updated
+ ((last-runs-update 0) : number) ;; last time we pulled the runs info to update the tree
+ (runs-mutex (make-mutex)) ;; use to prevent parallel access to draw objects
+ ((run-update-times (make-hash-table)) : hash-table) ;; update times indexed by run-id
+ ((last-test-dat (make-hash-table)) : hash-table) ;; cache last tests dat by run-id
+ ((run-db-paths (make-hash-table)) : hash-table) ;; cache the paths to the run db files
+
+ ;; Runs view
+ ((buttondat (make-hash-table)) : hash-table) ;;
+ ((item-test-names '()) : list) ;; list of itemized tests
+ ((run-keys (make-hash-table)) : hash-table)
+ (runs-matrix #f) ;; used in newdashboard
+ ((start-run-offset 0) : number) ;; left-right slider value
+ ((start-test-offset 0) : number) ;; up-down slider value
+ ((runs-btn-height (or (configf:lookup *configdat* "dashboard" "btn-height") "x16")) : string) ;; was 12
+ ((runs-btn-fontsz (or (configf:lookup *configdat* "dashboard" "btn-fontsz") "10")) : string) ;; was 8
+ ((runs-cell-width (or (configf:lookup *configdat* "dashboard" "cell-width") "50")) : string) ;; was 50
+ ((all-test-names '()) : list)
+
+ ;; Canvas and drawing data
+ (cnv #f)
+ (cnv-obj #f)
+ (drawing #f)
+ ((run-start-row 0) : number)
+ ((max-row 0) : number)
+ ((running-layout #f) : boolean)
+ (originx #f)
+ (originy #f)
+ ((layout-update-ok #t) : boolean)
+ ((compact-layout #t) : boolean)
+
+ ;; Run times layout
+ ;; (graph-button-box #f) ;; RA => Think it is not referenced anywhere
+ (graph-matrix #f)
+ ((graph-matrix-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru graph name info
+ ((graph-cell-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru matrix cell info
+ ((graph-matrix-row 1) : number)
+ ((graph-matrix-col 1) : number)
+
+ ;; Controls used to launch runs etc.
+ ((command "") : string) ;; for run control this is the command being built up
+ (command-tb #f) ;; widget for the type of command; run, remove-runs etc.
+ (test-patterns-textbox #f) ;; text box widget for editing a list of test patterns
+ (key-listboxes #f)
+ (key-lbs #f)
+ run-name ;; from run name setting widget
+ states ;; states for -state s1,s2 ...
+ statuses ;; statuses for -status s1,s2 ...
+
+ ;; Selector variables
+ curr-run-id ;; current row to display in Run summary view
+ prev-run-id ;; previous runid selected before current runid was selected (used in xor-two-runs runs summary mode
+ curr-test-ids ;; used only in dcommon:run-update which is used in newdashboard
+ ((filters-changed #t) : boolean) ;; to indicate that the user changed filters for this tab
+ ((last-filter-str "") : string) ;; conc the target runname and testpatt for a signature of changed filters
+ ((hide-empty-runs #f) : boolean)
+ ((hide-not-hide #t) : boolean) ;; toggle for hide/not hide empty runs
+ (hide-not-hide-button #f)
+ ((searchpatts (make-hash-table)) : hash-table) ;;
+ ((state-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATE => #t/#f for display control
+ ((status-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATUS => #t/#f
+ (target #f)
+ (test-patts #f)
+
+ ;; db info to file the .db files for the area
+ (access-mode (db:get-access-mode)) ;; use cached db or not
+ (dbdir #f)
+ (dbfpath #f)
+ (dbkeys #f)
+ ((last-db-update (make-hash-table)) : hash-table) ;; last db file timestamp
+ (monitor-db-path #f) ;; where to find monitor.db
+ ro ;; is the database read-only?
+
+ ;; tests data
+ ((num-tests 10) : number) ;; total number of tests to show (used in the old runs display)
+
+ ;; runs tree
+ ((path-run-ids (make-hash-table)) : hash-table) ;; path (target / runname) => id
+ (runs-tree #f)
+ ((runs-tree-ht (make-hash-table)) : hash-table) ;; track which targets added to tree (merge functionality with path-run-ids?)
+
+ ;; tab data
+ ((view-changed #t) : boolean)
+ ((xadj 0) : number) ;; x slider number (if using canvas)
+ ((yadj 0) : number) ;; y slider number (if using canvas)
+ ;; runs-summary tab state
+ ((runs-summary-modes '((one-run . "Show One Run") (xor-two-runs . "XOR Two Runs") (xor-two-runs-hide-clean . "XOR; Hide Clean")) ) : list)
+ ((runs-summary-mode-buttons '()) : list)
+ ((runs-summary-mode 'one-run) : symbol)
+ ((runs-summary-mode-change-callbacks '()) : list)
+ (runs-summary-source-runname-label #f)
+ (runs-summary-dest-runname-label #f)
+ ;; runs summary view
+
+ tests-tree ;; used in newdashboard
+ )
+
+;; additional setters for dboard:data
+(define (dboard:tabdat-test-patts-set!-use vec val)
+ (dboard:tabdat-test-patts-set! vec (if (equal? val "") #f val)))
+
+(define (dboard:tabdat-test-patts-use vec)
+ (let ((val (dboard:tabdat-test-patts vec)))(if val val ""))) ;;RADT => What is the if for?
;;======================================================================
;; D O T F I L E
;;======================================================================
@@ -150,10 +312,30 @@
(begin
(iup:attribute-set! mtrx cell-name new-val) ;; was col-name
#t) ;; need a re-draw
prev-changed)))
+
+;; Display the tests as rows of boxes on the test/task pane
+;;
+(define (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames test-records)
+ (canvas-clear! cnv)
+ (canvas-font-set! cnv "Helvetica, -10")
+ (let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv))
+ ((originx originy) (canvas-origin cnv)))
+ ;; (print "originx: " originx " originy: " originy)
+ ;; (canvas-origin-set! cnv 0 (- (/ sizey 2)))
+ (if (hash-table-ref/default tests-draw-state 'first-time #t)
+ (begin
+ (hash-table-set! tests-draw-state 'first-time #f)
+ (hash-table-set! tests-draw-state 'scalef 1)
+ (hash-table-set! tests-draw-state 'tests-info (make-hash-table))
+ (hash-table-set! tests-draw-state 'selected-tests (make-hash-table))
+ ;; set these
+ (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records))
+ (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records))
+ ))
;; 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
@@ -675,10 +857,32 @@
(set! changed #t)
(iup:attribute-set! stats-matrix key value)))))
run-stats)
(if changed (iup:attribute-set! stats-matrix "REDRAW" "ALL")))))
+;; if tab-num passed in then use it, otherwise look in commondat at curr-tab-num
+;; adds the updater passed in the updaters list at that hashkey
+;;
+(define (dboard:commondat-add-updater commondat updater #!key (tab-num #f))
+ (let* ((tnum (or tab-num
+ (dboard:commondat-curr-tab-num commondat)))
+ (curr-updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '())))
+ (hash-table-set! (dboard:commondat-updaters commondat)
+ tnum
+ (cons updater curr-updaters))))
+
+;; ;; if tab-num passed in then use it, otherwise look in commondat at curr-tab-num
+;; ;; adds the updater passed in the updaters list at that hashkey
+;; ;;
+;; (define (dboard:commondat-add-updater commondat updater #!key (tab-num #f))
+;; (let* ((tnum (or tab-num
+;; (dboard:commondat-curr-tab-num commondat)))
+;; (curr-updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '())))
+;; (hash-table-set! (dboard:commondat-updaters commondat)
+;; tnum
+;; (cons updater curr-updaters))))
+;;
(define (dcommon:run-stats commondat tabdat #!key (tab-num #f))
(let* ((stats-matrix (iup:matrix expand: "YES"))
(stats-updater (lambda ()
(dcommon:stats-updater commondat tabdat stats-matrix))))
@@ -1131,10 +1335,60 @@
#:action (lambda (obj)
;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
(common:run-a-command (iup:attribute (dboard:tabdat-command-tb data) "VALUE")))))))
;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
;; (system cmd)))))))
+
+;; Extract the various bits of data from tabdat and create the command line equivalent that will be displayed
+;;
+(define (dashboard:update-run-command tabdat)
+ (let* ((cmd-tb (dboard:tabdat-command-tb tabdat))
+ (cmd (dboard:tabdat-command tabdat))
+ (test-patt (let ((tp (dboard:tabdat-test-patts tabdat)))
+ (if (or (not tp)
+ (equal? tp ""))
+ "%"
+ tp)))
+ (states (dboard:tabdat-states tabdat))
+ (statuses (dboard:tabdat-statuses tabdat))
+ (target (let ((targ-list (dboard:tabdat-target tabdat)))
+ (if targ-list (string-intersperse targ-list "/") "no-target-selected")))
+ (run-name (dboard:tabdat-run-name tabdat))
+ (states-str (if (or (not states)
+ (null? states))
+ ""
+ (conc " -state " (string-intersperse states ","))))
+ (statuses-str (if (or (not statuses)
+ (null? statuses))
+ ""
+ (conc " -status " (string-intersperse statuses ","))))
+ (full-cmd "megatest"))
+ (case (string->symbol cmd)
+ ((run)
+ (set! full-cmd (conc full-cmd
+ " -run"
+ " -testpatt "
+ test-patt
+ " -target "
+ target
+ " -runname "
+ run-name
+ " -clean-cache"
+ )))
+ ((remove-runs)
+ (set! full-cmd (conc full-cmd
+ " -remove-runs -runname "
+ run-name
+ " -target "
+ target
+ " -testpatt "
+ test-patt
+ states-str
+ statuses-str
+ )))
+ (else (set! full-cmd " no valid command ")))
+ (iup:attribute-set! cmd-tb "VALUE" full-cmd)))
(define (dcommon:command-action-selector commondat tabdat #!key (tab-num #f))
(iup:frame
#:title "Set the action to take"
(iup:hbox
@@ -1403,11 +1657,11 @@
(iup:send-url lfilename))))
(define (dashboard:monitor-changed? commondat tabdat)
(let* ((run-update-time (current-seconds))
(monitor-db-path (dboard:tabdat-monitor-db-path tabdat))
- (monitor-modtime (if (and monitor-db-path (common:file-exists? monitor-db-path))
+ (monitor-modtime (if (and monitor-db-path (file-exists? monitor-db-path))
(file-modification-time monitor-db-path)
-1)))
(if (and (eq? (dboard:commondat-curr-tab-num commondat) 0)
(or (> monitor-modtime *last-monitor-update-time*)
(> (- run-update-time *last-monitor-update-time*) 5))) ;; update every 1/2 minute just in case
@@ -1458,5 +1712,95 @@
(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)))))
+;;======================================================================
+;; stuff from gutils
+;;
+
+(define (iuplistbox-fill-list lb items #!key (selected-item #f))
+ (let ((i 1))
+ (for-each (lambda (item)
+ (iup:attribute-set! lb (number->string i) item)
+ (if selected-item
+ (if (equal? selected-item item)
+ (iup:attribute-set! lb "VALUE" i))) ;; (number->string i))))
+ (set! i (+ i 1)))
+ items)
+ ;; (iup:attribute-set! lb "VALUE" (if selected-item selected-item ""))
+ i))
+
+(define (message-window msg)
+ (iup:show
+ (iup:dialog
+ (iup:vbox
+ (iup:label msg #:margin "40x40")))))
+
+;; NOTE: These functions will move to iuputils
+
+(define (gutils:colors-similar? color1 color2)
+ (let* ((c1 (map string->number (string-split color1)))
+ (c2 (map string->number (string-split color2)))
+ (delta (map (lambda (a b)(abs (- a b))) c1 c2)))
+ (null? (filter (lambda (x)(> x 3)) delta))))
+
+(define gutils:colors
+ '((PASS . "70 249 73")
+ (FAIL . "253 33 49")
+ (SKIP . "230 230 0")))
+
+(define (gutils:get-color-spec effective-state)
+ (or (alist-ref effective-state gutils:colors)
+ (alist-ref 'FAIL gutils:colors)))
+
+;; BBnote - state status dashboard button color / text defined here
+(define (gutils:get-color-for-state-status state status);; #!key (get-label #f))
+ ;; ((if get-label cadr car)
+ (case (string->symbol state)
+ ((COMPLETED) ;; ARCHIVED)
+ (case (string->symbol status)
+ ((PASS) (list "70 249 73" status))
+ ((PREQ_FAIL PREQ_DISCARDED) (list "255 127 127" status))
+ ((WARN WAIVED) (list "255 172 13" status))
+ ((SKIP) (list (gutils:get-color-spec 'SKIP) status))
+ ((ABORT) (list "198 36 166" status))
+ (else (list "253 33 49" status))))
+ ((ARCHIVED)
+ (case (string->symbol status)
+ ((PASS) (list "70 170 73" status))
+ ((WARN WAIVED) (list "200 130 13" status))
+ ((SKIP) (list (gutils:get-color-spec 'SKIP) status))
+ (else (list "180 33 49" status))))
+ ;; (if (equal? status "PASS")
+ ;; '("70 249 73" "PASS")
+ ;; (if (or (equal? status "WARN")
+ ;; (equal? status "WAIVED"))
+ ;; (list "255 172 13" status)
+ ;; (list "223 33 49" status)))) ;; greenish orangeish redish
+ ((LAUNCHED) (list "101 123 142" state))
+ ((CHECK) (list "255 100 50" state))
+ ((REMOTEHOSTSTART) (list "50 130 195" state))
+ ((RUNNING STARTED) (list "9 131 232" state))
+ ((KILLREQ) (list "39 82 206" state))
+ ((KILLED) (list "234 101 17" state))
+ ((NOT_STARTED) (case (string->symbol status)
+ ((CHECK STARTED)(list (gutils:get-color-spec 'SKIP) state))
+ (else (list "240 240 240" state))))
+ ;; for xor mode below
+ ;;
+ ((CLEAN)
+ (case (string->symbol status)
+ ((CLEAN-FAIL CLEAN-CHECK CLEAN-ABORT) (list "200 130 13" status)) ;; orange requested for these
+ (else (list "60 235 63" status))))
+ ((DIRTY-BETTER) (list "160 255 153" status))
+ ((DIRTY-WORSE) (list "165 42 42" status))
+ ((BOTH-BAD) (list "180 33 49" status))
+
+ (else (list
+ ;; "192 192 192"
+ "222 222 221"
+ state))))
+
+;; end of stuff from gutils
+
+)
Index: debugprint.scm
==================================================================
--- debugprint.scm
+++ debugprint.scm
@@ -7,11 +7,12 @@
;;(import scheme chicken data-structures extras files ports)
(import scheme
chicken.base
chicken.string
chicken.port
- mtargs
+ chicken.process-context
+ (prefix mtargs args:)
srfi-1
)
;;======================================================================
;; debug stuff
@@ -18,10 +19,34 @@
;;======================================================================
(define verbosity (make-parameter '()))
(define *default-log-port* (current-error-port))
+(define (debug:setup)
+ (let ((debugstr (or (args:get-arg "-debug")
+ (args:get-arg "-debug-noprop")
+ (get-environment-variable "MT_DEBUG_MODE"))))
+ (verbosity (debug:calc-verbosity debugstr 'q))
+ (debug:check-verbosity (verbosity) debugstr)
+ ;; if we were handed a bad verbosity rule then we will override it with 1 and continue
+ (if (verbosity)(verbosity 1))
+ (if (and (not (args:get-arg "-debug-noprop"))
+ (or (args:get-arg "-debug")
+ (not (get-environment-variable "MT_DEBUG_MODE"))))
+ (set-environment-variable! "MT_DEBUG_MODE" (if (list? (verbosity))
+ (string-intersperse (map conc (verbosity)) ",")
+ (conc (verbosity)))))))
+
+;; check verbosity, #t is ok
+(define (debug:check-verbosity verbosity vstr)
+ (if (not (or (number? verbosity)
+ (list? verbosity)))
+ (begin
+ (print "ERROR: Invalid debug value \"" vstr "\"")
+ #f)
+ #t))
+
;;======================================================================
;; (define (debug:print . params) #f)
;; (define (debug:print-info . params) #f)
;;
;; (define (set-functions dbgp dbgpinfo)
Index: docs/manual/server.dot
==================================================================
--- docs/manual/server.dot
+++ docs/manual/server.dot
@@ -17,61 +17,65 @@
digraph G {
subgraph cluster_1 {
node [style=filled,shape=box];
- check_available_queue -> remove_entries_over_10s_old;
- remove_entries_over_10s_old -> set_available [label="num_avail < 3"];
- remove_entries_over_10s_old -> exit [label="num_avail > 2"];
-
- set_available -> delay_2s;
- delay_2s -> check_place_in_queue;
-
- check_place_in_queue -> "http:transport-launch" [label="at head"];
- check_place_in_queue -> exit [label="not at head"];
-
- "client:login" -> "server:shutdown" [label="login failed"];
- "server:shutdown" -> exit;
-
- subgraph cluster_2 {
- "http:transport-launch" -> "http:transport-run";
- "http:transport-launch" -> "http:transport-keep-running";
-
- "http:transport-keep-running" -> "tests running?";
- "tests running?" -> "client:login" [label=yes];
- "tests running?" -> "server:shutdown" [label=no];
- "client:login" -> delay_5s [label="login ok"];
- delay_5s -> "http:transport-keep-running";
- }
-
- // start_server -> "server_running?";
- // "server_running?" -> set_available [label="no"];
- // "server_running?" -> delay_2s [label="yes"];
- // delay_2s -> "still_running?";
- // "still_running?" -> ping_server [label=yes];
- // "still_running?" -> set_available [label=no];
- // ping_server -> exit [label=alive];
- // ping_server -> remove_server_record [label=dead];
- // remove_server_record -> set_available;
- // set_available -> avail_delay [label="delay 3s"];
- // avail_delay -> "first_in_queue?";
- //
- // "first_in_queue?" -> set_running [label=yes];
- // set_running -> get_next_port -> handle_requests;
- // "first_in_queue?" -> "dead_entry_in_queue?" [label=no];
- // "dead_entry_in_queue?" -> "server_running?" [label=no];
- // "dead_entry_in_queue?" -> "remove_dead_entries" [label=yes];
- // remove_dead_entries -> "server_running?";
- //
- // handle_requests -> start_shutdown [label="no traffic\nno running tests"];
- // handle_requests -> shutdown_request;
- // start_shutdown -> shutdown_delay;
- // shutdown_request -> shutdown_delay;
- // shutdown_delay -> exit;
-
- label = "server:launch";
- color=brown;
+ rmt:send-receive -> "init-*remote* if needed" -> rmt:general-open-connection ->
+ rmt:send-receive-real;
+
+
+// check_available_queue -> remove_entries_over_10s_old;
+// remove_entries_over_10s_old -> set_available [label="num_avail < 3"];
+// remove_entries_over_10s_old -> exit [label="num_avail > 2"];
+//
+// set_available -> delay_2s;
+// delay_2s -> check_place_in_queue;
+//
+// check_place_in_queue -> "http:transport-launch" [label="at head"];
+// check_place_in_queue -> exit [label="not at head"];
+//
+// "client:login" -> "server:shutdown" [label="login failed"];
+// "server:shutdown" -> exit;
+//
+// subgraph cluster_2 {
+// "http:transport-launch" -> "http:transport-run";
+// "http:transport-launch" -> "http:transport-keep-running";
+//
+// "http:transport-keep-running" -> "tests running?";
+// "tests running?" -> "client:login" [label=yes];
+// "tests running?" -> "server:shutdown" [label=no];
+// "client:login" -> delay_5s [label="login ok"];
+// delay_5s -> "http:transport-keep-running";
+// }
+//
+// // start_server -> "server_running?";
+// // "server_running?" -> set_available [label="no"];
+// // "server_running?" -> delay_2s [label="yes"];
+// // delay_2s -> "still_running?";
+// // "still_running?" -> ping_server [label=yes];
+// // "still_running?" -> set_available [label=no];
+// // ping_server -> exit [label=alive];
+// // ping_server -> remove_server_record [label=dead];
+// // remove_server_record -> set_available;
+// // set_available -> avail_delay [label="delay 3s"];
+// // avail_delay -> "first_in_queue?";
+// //
+// // "first_in_queue?" -> set_running [label=yes];
+// // set_running -> get_next_port -> handle_requests;
+// // "first_in_queue?" -> "dead_entry_in_queue?" [label=no];
+// // "dead_entry_in_queue?" -> "server_running?" [label=no];
+// // "dead_entry_in_queue?" -> "remove_dead_entries" [label=yes];
+// // remove_dead_entries -> "server_running?";
+// //
+// // handle_requests -> start_shutdown [label="no traffic\nno running tests"];
+// // handle_requests -> shutdown_request;
+// // start_shutdown -> shutdown_delay;
+// // shutdown_request -> shutdown_delay;
+// // shutdown_delay -> exit;
+//
+// label = "server:launch";
+// color=brown;
}
// client_start_server -> start_server;
// handle_requests -> read_write;
// read_write -> handle_requests;
Index: env.scm
==================================================================
--- env.scm
+++ env.scm
@@ -141,11 +141,11 @@
;; (print "COMMON: " (string-intersperse common-parts "\n "))
(string-intersperse final separator)))
(define (env:process-path-envvar varname separator patha pathb)
(let ((newpath (env:merge-path-envvar separator patha pathb)))
- (setenv varname newpath)))
+ (set-environment-variable! varname newpath)))
(define (env:have-context db context)
(> (query fetch-value (sql db "SELECT count(id) FROM envvars WHERE context=?") context)
0))
Index: ezstepsmod.scm
==================================================================
--- ezstepsmod.scm
+++ ezstepsmod.scm
@@ -132,11 +132,11 @@
(logpro-file (conc stepname ".logpro"))
(html-file (conc stepname ".html"))
(dat-file (conc stepname ".dat"))
(tconfig-logpro (configf:lookup testconfig "logpro" stepname))
(logpro-used (common:file-exists? logpro-file)))
- (setenv "MT_STEP_NAME" stepname)
+ (set-environment-variable! "MT_STEP_NAME" stepname)
(hash-table-set! all-steps-dat stepname `((params . ,paramparts)))
(debug:print 0 *default-log-port* "stepparts: " stepparts ", stepparams: " stepparams
", paramparts: " paramparts ", subrun: " subrun ", stepcmd: " stepcmd)
(if (and tconfig-logpro
@@ -203,11 +203,11 @@
(processloop (+ i 1))))
)))))
(debug:print-info 0 *default-log-port* "step " stepname " completed with exit code " (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2))
;; now run logpro if needed
(if logpro-used
- (let* ((logpro-exe (or (getenv "LOGPRO_EXE") "logpro"))
+ (let* ((logpro-exe (or (get-environment-variable "LOGPRO_EXE") "logpro"))
(pid (process-run (conc "/bin/sh -c '"logpro-exe" "logpro-file " " (conc stepname ".html") " < " stepname ".log > /dev/null'"))))
(let processloop ((i 0))
(let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
(mutex-lock! m)
;; (make-launch:einf pid: pid exit-status: exit-status exit-code: exit-code)
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)))
-
Index: gutils.scm
==================================================================
--- gutils.scm
+++ gutils.scm
@@ -16,17 +16,58 @@
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
;;======================================================================
-(require-library iup)
-(import (prefix iup iup:))
-(use canvas-draw)
-
-(use srfi-1 regex regex-case srfi-69)
(declare (unit gutils))
+(module gutils
+ (iuplistbox-fill-list
+ message-window
+ gutils:colors-similar?
+ gutils:colors
+ gutils:get-color-for-state-status
+ )
+
+(import (prefix iup iup:)
+ canvas-draw)
+
+(import scheme
+ chicken.base
+ chicken.condition
+ chicken.string
+ chicken.pretty-print
+ chicken.sort
+ chicken.time
+
+ chicken.file
+ chicken.file.posix
+ chicken.process
+ chicken.process-context
+ chicken.process-context.posix)
+
+
+(import srfi-1 regex regex-case srfi-69)
+
+(define (iuplistbox-fill-list lb items #!key (selected-item #f))
+ (let ((i 1))
+ (for-each (lambda (item)
+ (iup:attribute-set! lb (number->string i) item)
+ (if selected-item
+ (if (equal? selected-item item)
+ (iup:attribute-set! lb "VALUE" i))) ;; (number->string i))))
+ (set! i (+ i 1)))
+ items)
+ ;; (iup:attribute-set! lb "VALUE" (if selected-item selected-item ""))
+ i))
+
+(define (message-window msg)
+ (iup:show
+ (iup:dialog
+ (iup:vbox
+ (iup:label msg #:margin "40x40")))))
+
;; NOTE: These functions will move to iuputils
(define (gutils:colors-similar? color1 color2)
(let* ((c1 (map string->number (string-split color1)))
(c2 (map string->number (string-split color2)))
@@ -88,5 +129,6 @@
(else (list
;; "192 192 192"
"222 222 221"
state))))
+)
Index: index-tree.scm
==================================================================
--- index-tree.scm
+++ index-tree.scm
@@ -20,25 +20,26 @@
;;======================================================================
;; Tests
;;======================================================================
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils)
-(import (prefix sqlite3 sqlite3:))
-
-(declare (unit tests))
-(declare (uses lock-queue))
-(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")
-(include "test_records.scm")
+(import
+ srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils
+ (prefix sqlite3 sqlite3:))
+
+(declare (unit testsmod))
+(declare (uses lock-queue))
+(declare (uses dbmod))
+(declare (uses commonmod))
+(declare (uses itemsmod))
+(declare (uses runconfigmod))
+
+;; (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
Index: itemsmod.scm
==================================================================
--- itemsmod.scm
+++ itemsmod.scm
@@ -20,10 +20,11 @@
(declare (unit itemsmod))
(declare (uses mtargs))
(declare (uses debugprint))
(declare (uses configfmod))
+(declare (uses commonmod))
(module itemsmod
*
(import scheme
@@ -164,14 +165,14 @@
(set! res (append res (list item)))
(loop (+ indx 1)
'()
#f)))
res)))
- ;; Nope, not now, return null as of 6/6/2011
-
-(define (items:check-valid-items class item)
- (let ((valid-values (let ((s (configf:lookup *configdat* "validvalues" class)))
+;; Nope, not now, return null as of 6/6/2011
+
+(define (items:check-valid-items valid-values class item)
+ (let ((valid-values (let ((s valid-values)) ;; (configf:lookup *configdat* "validvalues" class)))
(if s (string-split s) #f))))
(if valid-values
(if (member item valid-values)
item #f)
item)))
Index: launchmod.scm
==================================================================
--- launchmod.scm
+++ launchmod.scm
@@ -125,11 +125,11 @@
(debug:print 0 *default-log-port* "keep-going=" keep-going)
(and keep-going (equal? (car keep-going) "yes")))))
;; if handed a string, process it, else look for MT_CMDINFO
(define (launch:get-cmdinfo-assoc-list #!key (encoded-cmd #f))
- (let ((enccmd (if encoded-cmd encoded-cmd (getenv "MT_CMDINFO"))))
+ (let ((enccmd (if encoded-cmd encoded-cmd (get-environment-variable "MT_CMDINFO"))))
(if enccmd
(common:read-encoded-string enccmd)
'())))
(define (launch:manage-steps run-id test-id item-path fullrunscript ezsteps subrun test-name tconfigreg exit-info m)
@@ -218,11 +218,11 @@
;; check exit-info (vector-ref exit-info 1)
(if (launch:einf-exit-status exit-info) ;; (vector-ref exit-info 1)
(let* ((logpro-used (launch:runstep ezstep run-id test-id exit-info m tal testconfig all-steps-dat))
(stepname (car ezstep))
(stepparms (hash-table-ref all-steps-dat stepname)))
- (setenv "MT_STEP_NAME" stepname)
+ (set-environment-variable! "MT_STEP_NAME" stepname)
(pp (hash-table->alist all-steps-dat))
;; if logpro-used read in the stepname.dat file
(if (and logpro-used (common:file-exists? (conc stepname ".dat")))
(launch:load-logpro-dat run-id test-id stepname))
(if (steprun-good? logpro-used (launch:einf-exit-code exit-info) stepparms)
@@ -286,11 +286,11 @@
(set! kill-job? #f)))
(debug:print 4 *default-log-port* "cpu: " new-cpu-load " disk: " new-disk-free " last-sync: " last-sync " do-sync: " do-sync)
(launch:handle-zombie-tests run-id)
(when do-sync
- ;;(with-output-to-file (conc (getenv "MT_TEST_RUN_DIR") "/last-loadinfo.log" #:append)
+ ;;(with-output-to-file (conc (get-environment-variable "MT_TEST_RUN_DIR") "/last-loadinfo.log" #:append)
;; (lambda () (pp (list (current-seconds) new-cpu-load new-disk-free (calc-minutes)))))
;; (common:telemetry-log "zombie" (conc "launch:monitor-job - dosync started at "(current-seconds)))
(tests:update-central-meta-info run-id test-id new-cpu-load new-disk-free (calc-minutes) #f #f)
;; (common:telemetry-log "zombie" (conc "launch:monitor-job - dosync finished at "(current-seconds)))
)
@@ -355,11 +355,11 @@
(define (launch:execute encoded-cmd)
(let* ((cmdinfo (common:read-encoded-string encoded-cmd))
(tconfigreg #f))
- (setenv "MT_CMDINFO" encoded-cmd)
+ (set-environment-variable! "MT_CMDINFO" encoded-cmd)
;;(bb-check-path msg: "launch:execute incoming")
(if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed)
;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1))
(let* ((testpath (assoc/default 'testpath cmdinfo)) ;; testpath is the test spec area
(top-path (assoc/default 'toppath cmdinfo))
@@ -434,31 +434,31 @@
(launch:test-copy testpath work-area))))
;; one more time, change to the work-area directory
(change-directory work-area)))
) ;; let*
- (if contour (setenv "MT_CONTOUR" contour))
+ (if contour (set-environment-variable! "MT_CONTOUR" contour))
;; immediated set some key variables from CMDINFO data, yes, these will be set again below ...
;;
- (setenv "MT_TESTSUITENAME" areaname)
- (setenv "MT_RUN_AREA_HOME" top-path)
+ (set-environment-variable! "MT_TESTSUITENAME" areaname)
+ (set-environment-variable! "MT_RUN_AREA_HOME" top-path)
(set! *toppath* top-path)
(change-directory *toppath*) ;; temporarily switch to the run area home
- (setenv "MT_TEST_RUN_DIR" work-area)
+ (set-environment-variable! "MT_TEST_RUN_DIR" work-area)
(launch:setup) ;; should be properly in the run area home now
- (if contour (setenv "MT_CONTOUR" contour))
+ (if contour (set-environment-variable! "MT_CONTOUR" contour))
;; immediated set some key variables from CMDINFO data, yes, these will be set again below ...
;;
- (setenv "MT_TESTSUITENAME" areaname)
- (setenv "MT_RUN_AREA_HOME" top-path)
+ (set-environment-variable! "MT_TESTSUITENAME" areaname)
+ (set-environment-variable! "MT_RUN_AREA_HOME" top-path)
(set! *toppath* top-path)
(change-directory *toppath*) ;; temporarily switch to the run area home
- (setenv "MT_TEST_RUN_DIR" work-area)
+ (set-environment-variable! "MT_TEST_RUN_DIR" work-area)
(launch:setup) ;; should be properly in the run area home now
(set! tconfigreg (tests:get-all)) ;; mapping of testname => test source path
(let ((sighand (lambda (signum)
@@ -592,19 +592,19 @@
(let ((varval (string-split varpair "=")))
(if (eq? (length varval) 2)
(let ((var (car varval))
(val (cadr varval)))
(debug:print 1 *default-log-port* "Adding pre-var/val " var " = " val " to the environment")
- (setenv var val)))))
+ (set-environment-variable! var val)))))
varpairs)))
;;(bb-check-path msg: "launch:execute post block 2")
(for-each
(lambda (varval)
(let ((var (car varval))
(val (cadr varval)))
(if val
- (setenv var val)
+ (set-environment-variable! var val)
(begin
(debug:print-error 0 *default-log-port* "required variable " var " does not have a valid value. Exiting")
(exit)))))
(list
(list "MT_TEST_RUN_DIR" work-area)
@@ -616,11 +616,11 @@
(list "MT_TARGET" target)
(list "MT_LINKTREE" (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree"))
(list "MT_TESTSUITENAME" (common:get-area-name))))
;;(bb-check-path msg: "launch:execute post block 3")
- (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path)))
+ (if mt-bindir-path (set-environment-variable! "PATH" (conc (get-environment-variable "PATH") ":" mt-bindir-path)))
;;(bb-check-path msg: "launch:execute post block 4")
;; (change-directory top-path)
;; Can setup as client for server mode now
;; (client:setup)
@@ -635,11 +635,11 @@
(let ((blacklist (configf:lookup *configdat* "setup" "blacklistvars")))
(if blacklist
(let ((vars (string-split blacklist)))
(save-environment-as-files "megatest" ignorevars: vars)
(for-each (lambda (var)
- (unsetenv var))
+ (unset-environment-variable! var))
vars))
(save-environment-as-files "megatest")))
;;(bb-check-path msg: "launch:execute post block 44")
;; open-run-close not needed for test-set-meta-info
;; (tests:set-full-meta-info #f test-id run-id 0 work-area)
@@ -768,11 +768,11 @@
(args:get-arg "-execute")))
(let* ((linktree (common:get-linktree)) ;; (get-environment-variable "MT_LINKTREE"))
(target (common:args-get-target exit-if-bad: #t))
(runname (or (args:get-arg "-runname")
(args:get-arg ":runname")
- (getenv "MT_RUNNAME")))
+ (get-environment-variable "MT_RUNNAME")))
(fulldir (conc linktree "/"
target "/"
runname)))
(if (and linktree (common:file-exists? linktree)) ;; can't proceed without linktree
(begin
@@ -921,16 +921,16 @@
(set! toppath *toppath*)
(if (not *toppath*)
(begin
(debug:print-error 0 *default-log-port* "you are not in a megatest area!")
(exit 1)))
- (setenv "MT_RUN_AREA_HOME" *toppath*)
+ (set-environment-variable! "MT_RUN_AREA_HOME" *toppath*)
;; the seed read is done, now read runconfigs, cache it then read megatest.config one more time and cache it
(let* ((keys (common:list-or-null (rmt:get-keys)
message: "Failed to retrieve keys in launch.scm. Please report this to the developers."))
(key-vals (keys:target->keyval keys target))
- (linktree (common:get-linktree)) ;; (or (getenv "MT_LINKTREE")(if *configdat* (configf:lookup *configdat* "setup" "linktree") #f)))
+ (linktree (common:get-linktree)) ;; (or (get-environment-variable "MT_LINKTREE")(if *configdat* (configf:lookup *configdat* "setup" "linktree") #f)))
; (if *configdat*
; (configf:lookup *configdat* "setup" "linktree")
; (conc *toppath* "/lt"))))
(second-pass (configf:find-and-read-config
mtconfig
@@ -938,11 +938,11 @@
given-toppath: toppath
pathenvvar: "MT_RUN_AREA_HOME"
env-to-use: (module-environment 'bigmod)))
(runconfigdat (begin ;; this read of the runconfigs will see any adjustments made by re-reading megatest.config
(for-each (lambda (kt)
- (setenv (car kt) (cadr kt)))
+ (set-environment-variable! (car kt) (cadr kt)))
key-vals)
(configf:read-config (conc toppath "/runconfigs.config") *runconfigdat* #t ;; consider using runconfig:read some day ...
sections: sections)))
(cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig))
(mtcachef (car cachefiles))
@@ -1018,12 +1018,12 @@
(debug:print-error 0 *default-log-port* "linktree not defined in [setup] section of megatest.config")
)))
(if (and *toppath*
(directory-exists? *toppath*))
(begin
- (setenv "MT_RUN_AREA_HOME" *toppath*)
- (setenv "MT_TESTSUITENAME" (common:get-area-name)))
+ (set-environment-variable! "MT_RUN_AREA_HOME" *toppath*)
+ (set-environment-variable! "MT_TESTSUITENAME" (common:get-area-name)))
(begin
(debug:print-error 0 *default-log-port* "failed to find the top path to your Megatest area.")
(set! *toppath* #f) ;; force it to be false so we return #f
#f))
@@ -1299,21 +1299,21 @@
(define (launch:handle-zombie-tests run-id)
(let* ((key (conc "zombiescan-runid-"run-id))
(now (current-seconds))
(threshold (- (current-seconds) (* 2 (or (configf:lookup-number *configdat* "setup" "deadtime") 120))))
- (val (rmt:get-var key))
+ (val (rmt:get-var run-id key))
(do-scan?
(cond
((not val)
#t)
((< val threshold)
#t)
(else #f))))
(when do-scan?
(debug:print 1 *default-log-port* "INFO: search and mark zombie tests")
- (rmt:set-var key (current-seconds))
+ (rmt:set-var run-id key (current-seconds))
(runs:find-and-mark-incomplete-and-check-end-of-run run-id #f))))
@@ -1888,29 +1888,29 @@
;; 0 RUNNING ==> this is actually the first condition, should not get here
(define (runs:end-of-run-check run-id )
(let* ((not-completed-cnt (rmt:get-not-completed-cnt run-id))
(running-cnt (rmt:get-count-tests-running-for-run-id run-id))
- (all-test-launched (rmt:get-var (conc "lunch-complete-" run-id)))
+ (all-test-launched (rmt:get-var run-id (conc "lunch-complete-" run-id)))
(current-state (rmt:get-run-state run-id))
(current-status (rmt:get-run-status run-id)))
;;get-vars run-id to query metadata table to check if all completed. if all-test-launched = yes then only not-completed-cnt = 0 means everyting is completed if no entry found in the table do nothing
(debug:print 0 *default-log-port* "Running test cnt :" running-cnt)
(rmt:set-state-status-and-roll-up-run run-id current-state current-status)
(runs:update-junit-test-reporter-xml run-id)
(cond
((and all-test-launched (eq? not-completed-cnt 0) (equal? all-test-launched "yes" ))
- (if (and (equal? (rmt:get-var (conc "end-of-run-" run-id)) "no") (common:simple-lock (conc "endOfRun" run-id)))
+ (if (and (equal? (rmt:get-var run-id (conc "end-of-run-" run-id)) "no") (common:simple-lock (conc "endOfRun" run-id)))
(begin
- (debug:print 4 *default-log-port* "look for post hook. currseconds: " (current-seconds) " EOR " (rmt:get-var (conc "end-of-run-" run-id)))
+ (debug:print 4 *default-log-port* "look for post hook. currseconds: " (current-seconds) " EOR " (rmt:get-var run-id (conc "end-of-run-" run-id)))
(debug:print 0 *default-log-port* "End of Run Detected.")
(rmt:set-var (conc "end-of-run-" run-id) "yes")
;(thread-sleep! 10)
(runs:run-post-hook run-id)
- (debug:print 4 *default-log-port* "currseconds: " (current-seconds)" eor: " (rmt:get-var (conc "end-of-run-" run-id)))
+ (debug:print 4 *default-log-port* "currseconds: " (current-seconds)" eor: " (rmt:get-var run-id (conc "end-of-run-" run-id)))
(common:simple-unlock (conc "endOfRun" run-id)))
- (debug:print 0 *default-log-port* "End of Run Detected but not running post hook. This should happen when eor is set to yes. This will happen only when 2 tests exit at smae time. eor= " (rmt:get-var (conc "end-of-run-" run-id)))))
+ (debug:print 0 *default-log-port* "End of Run Detected but not running post hook. This should happen when eor is set to yes. This will happen only when 2 tests exit at smae time. eor= " (rmt:get-var run-id (conc "end-of-run-" run-id)))))
((> running-cnt 3)
(debug:print 0 *default-log-port* "There are " running-cnt " tests running." ))
((> running-cnt 0)
(debug:print 0 *default-log-port* "running cnt > 0 but <= 3 kill-running-tests-if-dead" )
(let ((kill-cnt (launch:kill-tests-if-dead run-id)))
@@ -1968,11 +1968,11 @@
#f ;; get full data (not 'shortlist)
0 ;; (runs:gendat-inc-results-last-update *runs:general-data*) ;; last update time
'dashboard)
'()))
(log-dir (conc *toppath* "/logs"))
- (log-file (conc "post-hook-" (string-translate (getenv "MT_TARGET") "/" "-") "-" (getenv "MT_RUNNAME") ".log"))
+ (log-file (conc "post-hook-" (string-translate (get-environment-variable "MT_TARGET") "/" "-") "-" (get-environment-variable "MT_RUNNAME") ".log"))
(full-log-fname (conc log-dir "/" log-file)))
(if run-post-hook
;; (if (null? existing-tests)
;; (debug:print 0 *default-log-port* "Skipping post-hook call \"" run-post-hook "\" as there are existing tests for this run.")))))
(let* ((use-log-dir (if (not (directory-exists? log-dir))
@@ -1998,11 +1998,11 @@
(define (runs:rerun-hook test-id new-test-path testdat rerunlst)
(let* ((rerun-hook (configf:lookup *configdat* "runs" "rerun-hook"))
(log-dir (conc *toppath* "/reruns/logs"))
- (target (getenv "MT_TARGET"))
+ (target (get-environment-variable "MT_TARGET"))
(runname (common:args-get-runname))
(rundir (db:test-get-rundir testdat))
(tarfiledir (conc *toppath* "/reruns"))
(status (db:test-get-status testdat))
(comment (conc "\"" (db:test-get-comment testdat) "\"" ))
@@ -2053,14 +2053,14 @@
(let* ((junit-test-reporter (configf:lookup *configdat* "runs" "junit-test-reporter-xml"))
(junit-test-report-dir (configf:lookup *configdat* "runs" "junit-test-report-dir"))
(xml-dir (if (and junit-test-reporter (equal? junit-test-reporter "yes" ))
(if junit-test-report-dir
junit-test-report-dir
- (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME")))
+ (conc (get-environment-variable "MT_LINKTREE") "/" (get-environment-variable "MT_TARGET") "/" (get-environment-variable "MT_RUNNAME")))
#f))
(xml-ts-name (if xml-dir
- (conc (getenv "MT_TESTSUITENAME")"."(string-translate (getenv "MT_TARGET") "/" ".") "." (getenv "MT_RUNNAME"))
+ (conc (get-environment-variable "MT_TESTSUITENAME")"."(string-translate (get-environment-variable "MT_TARGET") "/" ".") "." (get-environment-variable "MT_RUNNAME"))
#f))
(keyname (if xml-ts-name (common:get-signature xml-ts-name) #f))
(xml-path (if xml-dir
(conc xml-dir "/" keyname ".xml")
#f))
@@ -2141,11 +2141,11 @@
(testsuite)))
(define (set-item-env-vars itemdat)
(for-each (lambda (item)
(debug:print 2 *default-log-port* "setenv " (car item) " " (cadr item))
- (setenv (car item) (cadr item)))
+ (set-environment-variable! (car item) (cadr item)))
itemdat))
;; set up needed environment variables given a run-id and optionally a target, itempath etc.
;;
(define (runs:set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)(intarget #f)(testname #f)(itempath #f))
@@ -2155,16 +2155,16 @@
(get-environment-variable "MT_TARGET")))
(keys (if inkeys inkeys (common:get-fields *configdat*) #;(rmt:get-keys)))
(keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target)))
(vals (hash-table-ref/default *env-vars-by-run-id* run-id #f))
(link-tree (common:get-linktree))) ;; (configf:lookup *configdat* "setup" "linktree")))
- (if testname (setenv "MT_TEST_NAME" testname))
- (if itempath (setenv "MT_ITEMPATH" itempath))
+ (if testname (set-environment-variable! "MT_TEST_NAME" testname))
+ (if itempath (set-environment-variable! "MT_ITEMPATH" itempath))
;; get the info from the db and put it in the cache
(if link-tree
- (setenv "MT_LINKTREE" link-tree)
+ (set-environment-variable! "MT_LINKTREE" link-tree)
(debug:print-error 0 *default-log-port* "linktree not set, should be set in megatest.config in [setup] section."))
(if (not vals)
(let ((ht (make-hash-table)))
(hash-table-set! *env-vars-by-run-id* run-id ht)
(set! vals ht)
@@ -2180,11 +2180,11 @@
(debug:print 2 *default-log-port* "setenv " key " " val)
(safe-setenv key val)))
;;(bb-check-path msg: "runs:set-megatest-env-vars block 1")
;;(BB> "*env-vars-by-run-id*/runid("run-id" vals="(hash-table->alist vals))
- (if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target))
+ (if (not (get-environment-variable "MT_TARGET"))(set-environment-variable! "MT_TARGET" target))
;; we had a case where there was an exception generated by the hash-table-ref
;; due to *configdat* being #f Adding a handle and exit
(let fatal-loop ((count 0))
(handle-exceptions
exn
@@ -2217,22 +2217,22 @@
(alist->env-vars (hash-table-ref/default *configdat* "env-override" '())))) ;;;; environment is tainted HERE in this let block.
;;(bb-check-path msg: "runs:set-megatest-env-vars block 2")
;; Lets use this as an opportunity to put MT_RUNNAME in the environment
(let ((runname (if inrunname inrunname (rmt:get-run-name-from-id run-id))))
(if runname
- (setenv "MT_RUNNAME" runname)
+ (set-environment-variable! "MT_RUNNAME" runname)
(debug:print-error 0 *default-log-port* "no value for runname for id " run-id)))
- (setenv "MT_RUN_AREA_HOME" *toppath*)
+ (set-environment-variable! "MT_RUN_AREA_HOME" *toppath*)
;; if a testname and itempath are available set the remaining appropriate variables
- (if testname (setenv "MT_TEST_NAME" testname))
- (if itempath (setenv "MT_ITEMPATH" itempath))
+ (if testname (set-environment-variable! "MT_TEST_NAME" testname))
+ (if itempath (set-environment-variable! "MT_ITEMPATH" itempath))
;;(bb-check-path msg: "runs:set-megatest-env-vars block 3")
(if (and testname link-tree)
- (setenv "MT_TEST_RUN_DIR" (conc (getenv "MT_LINKTREE") "/"
- (getenv "MT_TARGET") "/"
- (getenv "MT_RUNNAME") "/"
- (getenv "MT_TEST_NAME")
+ (set-environment-variable! "MT_TEST_RUN_DIR" (conc (get-environment-variable "MT_LINKTREE") "/"
+ (get-environment-variable "MT_TARGET") "/"
+ (get-environment-variable "MT_RUNNAME") "/"
+ (get-environment-variable "MT_TEST_NAME")
(if (and itempath
(not (equal? itempath "")))
(conc "/" itempath)
""))))))
@@ -2244,12 +2244,12 @@
;; (if (eq? *configstatus* 'fulldata)
;; *runconfigdat*
;; (begin
;; (launch:setup)
;; *runconfigdat*)))
- (let* ((rundir (if (and (getenv "MT_LINKTREE")(getenv "MT_TARGET")(getenv "MT_RUNNAME"))
- (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME"))
+ (let* ((rundir (if (and (get-environment-variable "MT_LINKTREE")(get-environment-variable "MT_TARGET")(get-environment-variable "MT_RUNNAME"))
+ (conc (get-environment-variable "MT_LINKTREE") "/" (get-environment-variable "MT_TARGET") "/" (get-environment-variable "MT_RUNNAME"))
#f))
(cfgf (if rundir (conc rundir "/.runconfig." megatest-version "-" megatest-fossil-hash) #f)))
(if (and cfgf
(file-exists? cfgf)
(file-writable? cfgf)
@@ -2258,14 +2258,14 @@
(let* ((keys (common:get-fields *configdat*)) ;; (rmt:get-keys))
(target (common:args-get-target))
(key-vals (if target (keys:target->keyval keys target) #f))
(sections (if target (list "default" target) #f))
(data (begin
- (setenv "MT_RUN_AREA_HOME" *toppath*)
+ (set-environment-variable! "MT_RUN_AREA_HOME" *toppath*)
(if key-vals
(for-each (lambda (kt)
- (setenv (car kt) (cadr kt)))
+ (set-environment-variable! (car kt) (cadr kt)))
key-vals))
;; (configf:read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections))))
(runconfig:read (conc *toppath* "/runconfigs.config") target #f))))
(if (and rundir ;; have all needed variabless
(directory-exists? rundir)
@@ -2289,13 +2289,16 @@
(dbfile (args:get-arg "-db"))
(apath *toppath*))
(let loop ()
(thread-sleep! 5) ;; add control / setting for this
(if am-server
- (if (not *dbstruct-db*)
+ (if (not *dbstruct-db*) ;; skip syncing until db is setup
(loop)
- (db:sync-inmem->disk *dbstruct-db* *toppath* dbfile))))))
+ (begin
+ ;; (debug:print-info 0 *default-log-port* "syncing "apath" "dbfile" at "(current-seconds))
+ ;; (db:sync-inmem->disk *dbstruct-db* apath dbfile)
+ (loop)))))))
;;
;; (let ((dbstruct
;; (debug:print-info 13 *default-log-port* "after db:setup with dbstruct=" dbstruct)
;; (cond
Index: megatest.config
==================================================================
--- megatest.config
+++ megatest.config
@@ -14,14 +14,16 @@
#
# You should have received a copy of the GNU General Public License
# along with Megatest. If not, see .
## commented out due to a bug in v1.6501 in mtutil
-## [fields]
-## a text
-## b text
-## c text
+[fields]
+a text
+b text
+c text
+
+[default]
usercode .mtutil.scm
areafilter area-to-run
targtrans generic-target-translator
runtrans generic-runname-translator
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -44,20 +44,20 @@
(declare (uses runsmod))
(declare (uses servermod))
(declare (uses testsmod))
;; needed for configf scripts, scheme etc.
-(declare (uses apimod.import))
-(declare (uses debugprint.import))
-(declare (uses mtargs.import))
-(declare (uses commonmod.import))
-(declare (uses configfmod.import))
-(declare (uses bigmod.import))
-(declare (uses dbmod.import))
-(declare (uses rmtmod.import))
-(declare (uses servermod.import))
-(declare (uses launchmod.import))
+;; (declare (uses apimod.import))
+;; (declare (uses debugprint.import))
+;; (declare (uses mtargs.import))
+;; (declare (uses commonmod.import))
+;; (declare (uses configfmod.import))
+;; (declare (uses bigmod.import))
+;; (declare (uses dbmod.import))
+;; (declare (uses rmtmod.import))
+;; (declare (uses servermod.import))
+;; (declare (uses launchmod.import))
;; (include "call-with-environment-variables/call-with-environment-variables.scm")
(module megatest-main
*
@@ -128,11 +128,10 @@
;; local modules
autoload
adjutant
csv-xml
- ducttape-lib
hostinfo
mtver
mutils
cookie
csv-xml
@@ -169,13 +168,13 @@
;; (include "key_records.scm")
;; (include "db_records.scm")
(include "run_records.scm")
;; (include "test_records.scm")
-(include "common.scm")
+;; (include "common.scm")
(include "db.scm")
-(include "server.scm")
+;; (include "server.scm")
(include "tests.scm")
(include "genexample.scm")
(include "tdb.scm")
(include "env.scm")
(include "diff-report.scm")
@@ -182,20 +181,20 @@
(include "ods.scm")
(define *usage-log-file* #f) ;; put path to file for logging usage in this var in the ~/.megatestrc file
(define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file
- ;;======================================================================
- ;; Test commands (i.e. for use inside tests)
- ;;======================================================================
-
- (define (megatest:step step state status logfile msg)
- (if (not (getenv "MT_CMDINFO"))
- (begin
+;;======================================================================
+;; Test commands (i.e. for use inside tests)
+;;======================================================================
+
+(define (megatest:step step state status logfile msg)
+ (if (not (get-environment-variable "MT_CMDINFO"))
+ (begin
(debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!")
(exit 5))
- (let* ((cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO")))
+ (let* ((cmdinfo (common:read-encoded-string (get-environment-variable "MT_CMDINFO")))
(transport (assoc/default 'transport cmdinfo))
(testpath (assoc/default 'testpath cmdinfo))
(test-name (assoc/default 'test-name cmdinfo))
(runscript (assoc/default 'runscript cmdinfo))
(db-host (assoc/default 'db-host cmdinfo))
@@ -215,18 +214,18 @@
(rmt:teststep-set-status! run-id test-id step state status (or comment msg) logfile))
(begin
(debug:print-error 0 *default-log-port* "You must specify :state and :status with every call to -step")
(exit 6))))))
- ;;======================================================================
- ;; full run
- ;;======================================================================
-
- (define (handle-run-requests target runname keys keyvals need-clean)
- (if (or (args:get-arg "-kill-rerun") (args:get-arg "-rerun-clean")) ;; first set states/statuses correct
- ;; For rerun-clean do we or do we not support the testpatt?
- (let ((states (or (configf:lookup *configdat* "validvalues" "cleanrerun-states")
+;;======================================================================
+;; full run
+;;======================================================================
+
+(define (handle-run-requests target runname keys keyvals need-clean)
+ (if (or (args:get-arg "-kill-rerun") (args:get-arg "-rerun-clean")) ;; first set states/statuses correct
+ ;; For rerun-clean do we or do we not support the testpatt?
+ (let ((states (or (configf:lookup *configdat* "validvalues" "cleanrerun-states")
"KILLREQ,KILLED,UNKNOWN,INCOMPLETE,STUCK,NOT_STARTED"))
(statuses (or (configf:lookup *configdat* "validvalues" "cleanrerun-statuses")
"FAIL,INCOMPLETE,ABORT,CHECK,DEAD,PREQ_FAIL,PREQ_DISCARDED")))
(hash-table-set! args:arg-hash "-preclean" #t)
(runs:operate-on 'set-state-status
@@ -244,13 +243,13 @@
;; "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
(common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
;; state: states
status: statuses
new-state-status: "NOT_STARTED,n/a")))
- ;; RERUN ALL
- (if (args:get-arg "-rerun-all") ;; first set states/statuses correct
- (let* ((rconfig (full-runconfigs-read)))
+ ;; RERUN ALL
+ (if (args:get-arg "-rerun-all") ;; first set states/statuses correct
+ (let* ((rconfig (full-runconfigs-read)))
(hash-table-set! args:arg-hash "-preclean" #t)
(runs:operate-on 'set-state-status
target
(common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
(common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt")
@@ -263,97 +262,73 @@
(common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
(common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt")
;; state: states
status: #f
new-state-status: "NOT_STARTED,n/a")))
- (let* ((config-reruns (let ((x (configf:lookup *configdat* "setup" "reruns")))
+ (let* ((config-reruns (let ((x (configf:lookup *configdat* "setup" "reruns")))
(if x (string->number x) #f)))
(rerun-cnt (if config-reruns
config-reruns
1)))
-
- (runs:run-tests target
+
+ (runs:run-tests target
runname
#f ;; (common:args-get-testpatt #f)
;; (or (args:get-arg "-testpatt")
;; "%")
(bdat-user *bdat*)
args:arg-hash
run-count: rerun-cnt)))
- ;; csv processing record
- (define (make-refdb:csv)
- (vector
- (make-sparse-array)
- (make-hash-table)
- (make-hash-table)
- 0
- 0))
- (define-inline (refdb:csv-get-svec vec) (vector-ref vec 0))
- (define-inline (refdb:csv-get-rows vec) (vector-ref vec 1))
- (define-inline (refdb:csv-get-cols vec) (vector-ref vec 2))
- (define-inline (refdb:csv-get-maxrow vec) (vector-ref vec 3))
- (define-inline (refdb:csv-get-maxcol vec) (vector-ref vec 4))
- (define-inline (refdb:csv-set-svec! vec val)(vector-set! vec 0 val))
- (define-inline (refdb:csv-set-rows! vec val)(vector-set! vec 1 val))
- (define-inline (refdb:csv-set-cols! vec val)(vector-set! vec 2 val))
- (define-inline (refdb:csv-set-maxrow! vec val)(vector-set! vec 3 val))
- (define-inline (refdb:csv-set-maxcol! vec val)(vector-set! vec 4 val))
-
- (define (get-dat results sheetname)
- (or (hash-table-ref/default results sheetname #f)
- (let ((tmp-vec (make-refdb:csv)))
+;; csv processing record
+(define (make-refdb:csv)
+ (vector
+ (make-sparse-array)
+ (make-hash-table)
+ (make-hash-table)
+ 0
+ 0))
+(define-inline (refdb:csv-get-svec vec) (vector-ref vec 0))
+(define-inline (refdb:csv-get-rows vec) (vector-ref vec 1))
+(define-inline (refdb:csv-get-cols vec) (vector-ref vec 2))
+(define-inline (refdb:csv-get-maxrow vec) (vector-ref vec 3))
+(define-inline (refdb:csv-get-maxcol vec) (vector-ref vec 4))
+(define-inline (refdb:csv-set-svec! vec val)(vector-set! vec 0 val))
+(define-inline (refdb:csv-set-rows! vec val)(vector-set! vec 1 val))
+(define-inline (refdb:csv-set-cols! vec val)(vector-set! vec 2 val))
+(define-inline (refdb:csv-set-maxrow! vec val)(vector-set! vec 3 val))
+(define-inline (refdb:csv-set-maxcol! vec val)(vector-set! vec 4 val))
+
+(define (get-dat results sheetname)
+ (or (hash-table-ref/default results sheetname #f)
+ (let ((tmp-vec (make-refdb:csv)))
(hash-table-set! results sheetname tmp-vec)
tmp-vec)))
-
- ;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions
- (define (open-logfile logpath-in)
- (condition-case
- (let* ((log-dir (or (pathname-directory logpath-in) "."))
+
+;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions
+(define (open-logfile logpath-in)
+ (condition-case
+ (let* ((log-dir (or (pathname-directory logpath-in) "."))
(fname (pathname-strip-directory logpath-in))
(logpath (if (> (string-length fname) 250)
(let ((newlogf (conc log-dir "/" (common:get-signature fname) ".log")))
(debug:print 0 *default-log-port* "WARNING: log file " logpath-in " path too long, converted to " newlogf)
newlogf)
logpath-in)))
- (if (not (directory-exists? log-dir))
- (system (conc "mkdir -p " log-dir)))
- (open-output-file logpath))
- (exn ()
- (debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath-in)
- (define *didsomething* #t)
- (exit 1))))
-
-(define (debug:setup)
- (let ((debugstr (or (args:get-arg "-debug")
- (args:get-arg "-debug-noprop")
- (getenv "MT_DEBUG_MODE"))))
- (set! *verbosity* (debug:calc-verbosity debugstr 'q))
- (debug:check-verbosity *verbosity* debugstr)
- ;; if we were handed a bad verbosity rule then we will override it with 1 and continue
- (if (not *verbosity*)(set! *verbosity* 1))
- (if (and (not (args:get-arg "-debug-noprop"))
- (or (args:get-arg "-debug")
- (not (getenv "MT_DEBUG_MODE"))))
- (setenv "MT_DEBUG_MODE" (if (list? *verbosity*)
- (string-intersperse (map conc *verbosity*) ",")
- (conc *verbosity*))))))
-
-;; check verbosity, #t is ok
-(define (debug:check-verbosity verbosity vstr)
- (if (not (or (number? verbosity)
- (list? verbosity)))
- (begin
- (print "ERROR: Invalid debug value \"" vstr "\"")
- #f)
- #t))
+ (if (not (directory-exists? log-dir))
+ (system (conc "mkdir -p " log-dir)))
+ (open-output-file logpath))
+ (exn ()
+ (debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath-in)
+ (define *didsomething* #t)
+ (exit 1))))
;; Disabled help items
;; -rollup : (currently disabled) fill run (set by :runname) with latest test(s)
;; from prior runs with same keys
;; -daemonize : fork into background and disconnect from stdin/out
-
+
(define help (conc "
Megatest, documentation at http://www.kiatoa.com/fossils/megatest
version " megatest-version "
license GPL, Copyright Matt Welland 2006-2017
@@ -773,24 +748,24 @@
;; before doing anything else change to the start-dir if provided
;;
(if (args:get-arg "-start-dir")
(if (common:file-exists? (args:get-arg "-start-dir"))
(let ((fullpath (common:real-path (args:get-arg "-start-dir"))))
- (setenv "PWD" fullpath)
+ (set-environment-variable! "PWD" fullpath)
(change-directory fullpath))
(begin
(debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.")
(exit 1))))
;; immediately set MT_TARGET if -reqtarg or -target are available
;;
(let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target"))))
- (if targ (setenv "MT_TARGET" targ)))
+ (if targ (set-environment-variable! "MT_TARGET" targ)))
;; The watchdog is to keep an eye on things like db sync etc.
;;
-(init-watchdog)
+;; (init-watchdog)
;; (define (debug:debug-mode n)
;; (cond
;; ((and (number? *verbosity*) ;; number number
;; (number? n))
@@ -912,22 +887,23 @@
(hash-table-set! args:arg-hash "-testpatt" newval)
(hash-table-delete! args:arg-hash "-itempatt")))
(if (args:get-arg "-runtests")
(debug:print 0 *default-log-port* "WARNING: \"-runtests\" is deprecated. Use \"-run\" with \"-testpatt\" instead"))
-
- (on-exit std-exit-procedure)
+
+ (debug:print 0 *default-log-port* "on-exit disabled. Please re-enable")
+ ;; (on-exit std-exit-procedure)
;;======================================================================
;; Misc general calls
;;======================================================================
;; TODO: Restore this functionality
#; (if (and (args:get-arg "-cache-db")
(args:get-arg "-source-db"))
- (let* ((temp-dir (or (args:get-arg "-target-db") (create-directory (conc "/tmp/" (getenv "USER") "/" (string-translate (current-directory) "/" "_")))))
+ (let* ((temp-dir (or (args:get-arg "-target-db") (create-directory (conc "/tmp/" (get-environment-variable "USER") "/" (string-translate (current-directory) "/" "_")))))
(target-db (conc temp-dir "/cached.db"))
(source-db (args:get-arg "-source-db")))
(db:cache-for-read-only source-db target-db)
(set! *didsomething* #t)))
@@ -1263,12 +1239,12 @@
(set! *didsomething* #t)
(pop-directory)
(bdat-time-to-exit-set! *bdat* #t)))
(if (args:get-arg "-show-cmdinfo")
- (if (or (args:get-arg ":value")(getenv "MT_CMDINFO"))
- (let ((data (common:read-encoded-string (or (args:get-arg ":value")(getenv "MT_CMDINFO")))))
+ (if (or (args:get-arg ":value")(get-environment-variable "MT_CMDINFO"))
+ (let ((data (common:read-encoded-string (or (args:get-arg ":value")(get-environment-variable "MT_CMDINFO")))))
(if (equal? (args:get-arg "-dumpmode") "json")
(json-write data)
(pp data))
(set! *didsomething* #t))
(debug:print-info 0 *default-log-port* "environment variable MT_CMDINFO is not set")))
@@ -2059,13 +2035,13 @@
;; Get paths to tests
;;======================================================================
;; Get test paths matching target, runname, and testpatt
(if (or (args:get-arg "-test-files")(args:get-arg "-test-paths"))
;; if we are in a test use the MT_CMDINFO data
- (if (getenv "MT_CMDINFO")
+ (if (get-environment-variable "MT_CMDINFO")
(let* ((startingdir (current-directory))
- (cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO")))
+ (cmdinfo (common:read-encoded-string (get-environment-variable "MT_CMDINFO")))
(transport (assoc/default 'transport cmdinfo))
(testpath (assoc/default 'testpath cmdinfo))
(test-name (assoc/default 'test-name cmdinfo))
(runscript (assoc/default 'runscript cmdinfo))
(db-host (assoc/default 'db-host cmdinfo))
@@ -2226,16 +2202,16 @@
(args:get-arg "-test-status")
(args:get-arg "-set-values")
(args:get-arg "-load-test-data")
(args:get-arg "-runstep")
(args:get-arg "-summarize-items"))
- (if (not (getenv "MT_CMDINFO"))
+ (if (not (get-environment-variable "MT_CMDINFO"))
(begin
(debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!")
(exit 5))
(let* ((startingdir (current-directory))
- (cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO")))
+ (cmdinfo (common:read-encoded-string (get-environment-variable "MT_CMDINFO")))
(transport (assoc/default 'transport cmdinfo))
(testpath (assoc/default 'testpath cmdinfo))
(test-name (assoc/default 'test-name cmdinfo))
(runscript (assoc/default 'runscript cmdinfo))
(db-host (assoc/default 'db-host cmdinfo))
@@ -2452,11 +2428,11 @@
(args:get-arg "-diff-html")
(args:get-arg "-diff-email"))
(set! *didsomething* #t)
(exit 0)))
- (if (or (getenv "MT_RUNSCRIPT")
+ (if (or (get-environment-variable "MT_RUNSCRIPT")
(args:get-arg "-repl")
(args:get-arg "-load"))
(let* ((toppath (launch:setup)))
;; (dbstruct (if (and toppath
@@ -2463,11 +2439,11 @@
;; #;(common:on-homehost?))
;; (db:setup #f) ;; sets up main.db
;; #f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f)))
(if *toppath*
(cond
- ((getenv "MT_RUNSCRIPT")
+ ((get-environment-variable "MT_RUNSCRIPT")
;; How to run megatest scripts
;;
;; #!/bin/bash
;;
;; export MT_RUNSCRIPT=yes
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")
-
ADDED nng-trial/Makefile
Index: nng-trial/Makefile
==================================================================
--- /dev/null
+++ nng-trial/Makefile
@@ -0,0 +1,5 @@
+nng-test : nng-test.scm
+ csc nng-test.scm
+
+test : nng-test
+ ./nng-test do-test
ADDED nng-trial/nng-test.scm
Index: nng-trial/nng-test.scm
==================================================================
--- /dev/null
+++ nng-trial/nng-test.scm
@@ -0,0 +1,153 @@
+(import (chicken io)
+ (chicken file)
+ (chicken file posix)
+ (chicken string)
+ (chicken process-context)
+ (chicken process-context posix)
+ miscmacros
+ nng
+ srfi-18
+ srfi-69
+ test
+ matchable
+ typed-records
+ system-information
+ directory-utils
+ )
+
+(define help "Usage: nng-test COMMAND
+ where COMMAND is one of:
+ dotest : run the basic req/rep test
+")
+
+(define address-tcp-1 "tcp://localhost:5555")
+(define address-tcp-2 "tcp://localhost:6666")
+
+(define address-inproc-1 "inproc://local1")
+(define address-inproc-2 "inproc://local2")
+
+;;;
+;;; Req-Rep
+;;;
+(define (make-listening-reply-socket address)
+ (let ((socket (make-rep-socket)))
+ (socket-set! socket 'nng/recvtimeo 2000)
+ (nng-listen socket address)
+ socket))
+
+(define (make-dialed-request-socket address)
+ (let ((socket (make-req-socket)))
+ (socket-set! socket 'nng/recvtimeo 2000)
+ (nng-dial socket address)
+ socket))
+
+(define (req-rep-test address)
+ (let ((rep (make-listening-reply-socket address))
+ (req (make-dialed-request-socket address)))
+ (nng-send req "message 1")
+ (nng-recv rep)
+ (nng-send rep "message")
+ (begin0
+ (nng-recv req)
+ (nng-close! rep))))
+
+(define (do-test)
+ (test-group "nng"
+ (test "tcp req-rep"
+ "message"
+ (req-rep-test address-tcp-1))
+ (test "inproc req-rep"
+ "message"
+ (req-rep-test address-inproc-1)))
+ (test-exit))
+
+;; talking to self here...
+;;
+(define (send-n-messages n srvdat)
+ (let* ((name (srv-name srvdat)))
+ (let loop ((i 0))
+ (if (< i n)
+ (begin
+ (nng-send (srv-req srvdat) (conc name "-" i))
+ (print "received: "(nng-recv (srv-rep srvdat)))
+ (loop (+ i 1)))))))
+
+;; this should be run in a thread
+(define (run-listener-responder socket myaddr)
+ (let loop ((status 'running))
+ (let* ((msg (nng-recv socket))
+ (response (process-message msg)))
+ (if (not (eq? response 'done))
+ (begin
+ (nng-send socket response)
+ (loop status))))))
+
+(define *channels* (make-hash-table))
+
+(define (call channels msg addr)
+ (let* ((csocket (hash-table-ref/default channels addr #f))
+ (socket (or csocket (make-dialed-request-socket addr))))
+ (nng-send socket msg)
+ (print "Sent: "msg", received: "(nng-recv socket))
+ (if (not (hash-table-exists? channels addr))
+ (hash-table-set! channels addr socket))))
+
+;; start => hello 0
+;; hello 0 => hello 1
+;; hello 1 => hello 2
+;; ...
+;; hello 11 => 'done
+;;
+(define (process-message mesg)
+ (let ((parts (string-split mesg)))
+ (match
+ parts
+ ((msg c)
+ (let ((count (string->number c)))
+ (if (> count 10)
+ 'done
+ (conc msg " " (if count count 0)))))
+ ((msg)
+ (conc msg " 0"))
+ (else
+ "hello 0"))))
+
+(define (close-srv srvdat)
+ (nng-close! (srv-rep srvdat)))
+
+(match
+ (command-line-arguments)
+ (("do-test")(do-test))
+ ((run myaddr)
+ ;; start listener
+ ;; put myaddr into file by host-pid in .runners
+ ;; for 1 minute
+ ;; get all in .runners
+ ;; call each with a message
+ ;;
+ (let* ((socket (make-listening-reply-socket myaddr))
+ (rfile (conc ".runners/"(get-host-name)"-"(current-process-id)))
+ (th1 (make-thread (lambda ()
+ (run-listener-responder socket myaddr)
+ (delete-file* rfile)
+ (exit))
+ "responder")))
+ (if (not (and (file-exists? ".runners")
+ (directory? ".runners")))
+ (create-directory ".runners" #t))
+ (with-output-to-file rfile
+ (lambda ()
+ (print myaddr)))
+ (thread-start! th1)
+ (let loop ((entries '()))
+ (if (null? entries)
+ (loop (glob ".runners/*"))
+ (let* ((entry (car entries))
+ (destaddr (with-input-from-file entry read-line)))
+ (call *channels* (conc "hello-from-"destaddr) destaddr)
+ (thread-sleep! 0.25)
+ (loop (cdr entries)))))))
+ ((cmd)(print "ERROR: command "cmd", not recognised.\n\n"help))
+ (else
+ (print help)))
+
Index: rmtmod.scm
==================================================================
--- rmtmod.scm
+++ rmtmod.scm
@@ -62,10 +62,11 @@
;; http-client
;; intarweb
matchable
md5
message-digest
+ nng ;; nanomsg
(prefix base64 base64:)
(prefix sqlite3 sqlite3:)
regex
s11n
;; spiffy
@@ -75,11 +76,11 @@
srfi-13
srfi-18
srfi-69
stack
system-information
- tcp6
+ ;; tcp6
typed-records
uri-common
z3
apimod
@@ -119,10 +120,11 @@
;;
(defstruct servdat
(host #f)
(port #f)
(uuid #f)
+ (rep #f)
(dbfile #f)
(api-url #f)
(api-uri #f)
(api-req #f)
(status 'starting)
@@ -243,15 +245,16 @@
(start-main-srv))))
;; NB// remote is a rmt:remote struct
;;
(define (rmt:general-open-connection remote apath dbname #!key (num-tries 5))
- (let ((mdbname (db:run-id->dbname #f)))
+ (let* ((mdbname (db:run-id->dbname #f))
+ (mconn (rmt:get-conn remote apath mdbname)))
(cond
- ((not (rmt:get-conn remote apath mdbname)) ;; no channel open to main?
+ ((or (not mconn) ;; no channel open to main?
+ (< (rmt:conn-expires mconn)(+ (current-seconds) 2))) ;; restablish connection if less than 2 seconds on the lease
(rmt:open-main-connection remote apath)
- (thread-sleep! 2)
(rmt:general-open-connection remote apath mdbname))
((not (rmt:get-conn remote apath dbname)) ;; no channel open to dbname?
(let* ((res (rmt:send-receive-real remote apath mdbname 'get-server `(,apath ,dbname))))
(case res
((server-started)
@@ -262,27 +265,60 @@
(begin
(debug:print-error 0 *default-log-port* "Failed to start servers needed or open channel to "apath", "dbname)
(exit 1))))
(else
(if (list? res) ;; server has been registered and the info was returned. pass it on.
- res
+ (begin ;; ("192.168.0.9" 53817
+ ;; "5e34239f48e8973b3813221e54701a01" "24310"
+ ;; "192.168.0.9"
+ ;; "/home/matt/data/megatest/tests/simplerun"
+ ;; ".db/1.db")
+ (match
+ res
+ ((host port servkey pid ipaddr apath dbname)
+ (debug:print-info 0 *default-log-port* "got "res)
+ (hash-table-set! (rmt:remote-conns remote)
+ dbname
+ (make-rmt:conn
+ apath: apath
+ dbname: dbname
+ hostport: (conc host":"port)
+ ipaddr: ipaddr
+ port: port
+ srvkey: servkey
+ lastmsg: (current-seconds)
+ expires: (+ (current-seconds) 60))))
+ (else
+ (debug:print-info 0 *default-log-port* "return data from starting server did not match host port servkey pid ipaddr apath dbname " res)))
+ res)
(begin
(debug:print-info 0 *default-log-port* "Unexpected result: " res)
- res)))))))))
+ res))))))
+
+
+ )))
;;======================================================================
+;; FOR DEBUGGING SET TO #t
+(define *localmode* #t)
+(define *dbstruct* (make-dbr:dbstruct))
;; Defaults to current area
;;
(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f))
(if (not *rmt:remote*)(set! *rmt:remote* (make-rmt:remote)))
- (let* ((apath *toppath*)
- (conns *rmt:remote*)
- (dbname (db:run-id->dbname rid)))
- (rmt:general-open-connection conns apath dbname)
- (rmt:send-receive-real conns apath dbname cmd params)))
+ (let* ((apath *toppath*)
+ (conns *rmt:remote*)
+ (dbname (db:run-id->dbname rid)))
+ (if *localmode*
+ (let* ((dbdat (dbr:dbstruct-get-dbdat *dbstruct* dbname))
+ (indat `((cmd . ,cmd)(params . ,params))))
+ (api:process-request *dbstruct* indat))
+ (begin
+ (rmt:general-open-connection conns apath dbname)
+ (rmt:send-receive-real conns apath dbname cmd params)))))
#;(define (rmt:send-receive-setup conn)
(if (not (rmt:conn-inport conn))
(let-values (((i o) (tcp-connect (rmt:conn-ipaddr conn)
(rmt:conn-port conn))))
@@ -293,31 +329,19 @@
;; sometime in the future
;;
(define (rmt:send-receive-real remote apath dbname cmd params)
(let* ((conn (rmt:get-conn remote apath dbname)))
(assert conn "FATAL: rmt:send-receive-real called without the needed channels opened")
- (pp (rmt:conn->alist conn))
- ;; (rmt:send-receive-setup conn)
- (let-values (((i o) (tcp-connect (rmt:conn-ipaddr conn)
- (rmt:conn-port conn))))
- (let* ((key #f)
- (payload `((cmd . ,cmd)
- (key . ,(rmt:conn-srvkey conn))
- (params . ,params)))
- (res (begin
- (write payload o) ;; (rmt:conn-outport conn))
- (with-input-from-port
- i ;; (rmt:conn-inport conn)
- read))))
- (close-input-port i)
- (close-output-port o)
- res))))
-;; (if (string? res)
-;; (string->sexpr res)
-;; res))))
-
-
+ (let* ((key #f)
+ (host (rmt:conn-ipaddr conn))
+ (port (rmt:conn-port conn))
+ (payload `((cmd . ,cmd)
+ (key . ,(rmt:conn-srvkey conn))
+ (params . ,params)))
+ (res (open-send-receive-nn (conc host":"port)
+ (sexpr->string payload))))
+ (string->sexpr res))))
;; db is at apath/.db/dbname, rid is an intermediary solution and will be removed
;; sometime in the future.
;;
;; Purpose - call the main.db server and request a server be started
@@ -332,11 +356,11 @@
;; read-string)))
;; (string->sexpr res))))
(define (rmt:print-db-stats)
(let ((fmtstr "~40a~7-d~9-d~20,2-f")) ;; "~20,2-f"
- (debug:print 18 *default-log-port* "DB Stats\n========")
+ (debug:print 18 *default-log-port* "DB Stats, "(seconds->year-week/day-time (current-seconds))"\n=====================")
(debug:print 18 *default-log-port* (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg"))
(for-each (lambda (cmd)
(let ((cmd-dat (hash-table-ref *db-stats* cmd)))
(debug:print 18 *default-log-port* (format #f fmtstr cmd (vector-ref cmd-dat 0) (vector-ref cmd-dat 1) (/ (vector-ref cmd-dat 1)(vector-ref cmd-dat 0))))))
(sort (hash-table-keys *db-stats*)
@@ -677,12 +701,11 @@
;; first register in main.db (thus the #f)
(let* ((run-id (rmt:send-receive 'register-run #f (list keyvals runname state status user contour))))
;; now register in the run db itself
;; NEED A RECORD INSERT INCLUDING SETTING id
- (rmt:send-receive 'register-run run-id (list keyvals runname state status user contour))
-
+ (rmt:send-receive 'insert-run run-id (list run-id keyvals runname state status user contour))
run-id))
(define (rmt:get-run-name-from-id run-id)
(rmt:send-receive 'get-run-name-from-id run-id (list run-id)))
@@ -738,27 +761,27 @@
) ;; )
(define (rmt:get-main-run-stats run-id)
(rmt:send-receive 'get-main-run-stats #f (list run-id)))
-(define (rmt:get-var varname)
- (rmt:send-receive 'get-var #f (list varname)))
-
-(define (rmt:del-var varname)
- (rmt:send-receive 'del-var #f (list varname)))
-
-(define (rmt:set-var varname value)
- (rmt:send-receive 'set-var #f (list varname value)))
-
-(define (rmt:inc-var varname)
- (rmt:send-receive 'inc-var #f (list varname)))
-
-(define (rmt:dec-var varname)
- (rmt:send-receive 'dec-var #f (list varname)))
-
-(define (rmt:add-var varname value)
- (rmt:send-receive 'add-var #f (list varname value)))
+(define (rmt:get-var run-id varname)
+ (rmt:send-receive 'get-var run-id (list run-id varname)))
+
+(define (rmt:del-var run-id varname)
+ (rmt:send-receive 'del-var run-id (list run-id varname)))
+
+(define (rmt:set-var run-id varname value)
+ (rmt:send-receive 'set-var run-id (list run-id varname value)))
+
+(define (rmt:inc-var run-id varname)
+ (rmt:send-receive 'inc-var #f (list run-id varname)))
+
+(define (rmt:dec-var run-id varname)
+ (rmt:send-receive 'dec-var run-id (list run-id varname)))
+
+(define (rmt:add-var run-id varname value)
+ (rmt:send-receive 'add-var run-id (list run-id varname value)))
;;======================================================================
;; M U L T I R U N Q U E R I E S
;;======================================================================
@@ -816,12 +839,13 @@
;;
;;(define (rmt:get-steps-for-test run-id test-id)
;; (rmt:send-receive 'get-steps-data run-id (list test-id)))
(define (rmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile)
- (let* ((state (items:check-valid-items "state" state-in))
- (status (items:check-valid-items "status" status-in)))
+ (let* ((valid-values (configf:lookup *configdat* "validvalues" "state"))
+ (state (items:check-valid-items valid-values "state" state-in))
+ (status (items:check-valid-items valid-values "status" status-in)))
(if (or (not state)(not status))
(debug:print 3 *default-log-port* "WARNING: Invalid " (if status "status" "state")
" value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config"))
(rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile))))
@@ -1396,18 +1420,18 @@
;;======================================================================
;; from metadat lookup MEGATEST_VERSION
;;
(define (common:get-last-run-version) ;; RADT => How does this work in send-receive function??; assume it is the value saved in some DB
- (rmt:get-var "MEGATEST_VERSION"))
+ (rmt:get-var #f "MEGATEST_VERSION"))
(define (common:get-last-run-version-number)
(string->number
(substring (common:get-last-run-version) 0 6)))
(define (common:set-last-run-version)
- (rmt:set-var "MEGATEST_VERSION" (common:version-signature)))
+ (rmt:set-var #f "MEGATEST_VERSION" (common:version-signature)))
;;======================================================================
;; faux-lock is deprecated. Please use simple-lock below
;;
(define (common:faux-lock keyname #!key (wait-time 8)(allow-lock-steal #t))
@@ -1443,10 +1467,57 @@
(common:version-signature))))
(define (common:api-changed?)
(not (equal? (substring (->string megatest-version) 0 4)
(substring (conc (common:get-last-run-version)) 0 4))))
+
+(define (rmt:server-shutdown)
+ (let ((dbfile (servdat-dbfile *server-info*)))
+ (debug:print-info 0 *default-log-port* "dbfile is "dbfile)
+ (if dbfile
+ (let* ((am-server (args:get-arg "-server"))
+ (dbfile (args:get-arg "-db"))
+ (apath *toppath*)
+ (dbdat (db:get-dbdat *dbstruct-db* apath dbfile))
+ (db (dbr:dbdat-db dbdat))
+ (inmem (dbr:dbdat-db dbdat))
+ )
+ ;; do a final sync here
+ (debug:print-info 0 *default-log-port* "Doing final sync for "apath" "dbfile" at "(current-seconds))
+ (db:sync-inmem->disk *dbstruct-db* apath dbfile force-sync: #t)
+ ;; let's finalize here
+ (debug:print-info 0 *default-log-port* "Finalizing db and inmem")
+ (sqlite3:finalize! db)
+ (sqlite3:finalize! inmem)
+ (debug:print-info 0 *default-log-port* "Finalizing db and inmem complete")
+ (if am-server
+ (if (string-match ".*/main.db$" dbfile)
+ (let ((pkt-file (conc (get-pkts-dir *toppath*)
+ "/" (servdat-uuid *server-info*)
+ ".pkt")))
+ (debug:print-info 0 *default-log-port* "removing pkt "pkt-file)
+ (delete-file* pkt-file)
+ (debug:print-info 0 *default-log-port* "Releasing lock for "dbfile)
+ (db:with-lock-db (servdat-dbfile *server-info*)
+ (lambda (dbh dbfile)
+ (db:release-lock dbh dbfile))))
+ (let* ((sdat *server-info*) ;; we have a run-id server
+ (host (servdat-host sdat))
+ (port (servdat-port sdat))
+ (uuid (servdat-uuid sdat)))
+ (if (not (string-match ".db/main.db" (args:get-arg "-db")))
+ (let* ((res (rmt:deregister-server *rmt:remote* ;; TODO/BUG: why is this requiring *rmt:remote*?
+ *toppath*
+ (servdat-host *server-info*) ;; iface
+ (servdat-port *server-info*)
+ (servdat-uuid *server-info*)
+ (current-process-id)
+ )))
+ (debug:print-info 0 *default-log-port* "deregistered-server, res="res)))
+
+ (debug:print-info 0 *default-log-port* "deregistering server "host":"port" with uuid "uuid)
+ )))))))
(define (std-exit-procedure)
;;(common:telemetry-log-close)
(on-exit (lambda () 0))
;;(debug:print-info 13 *default-log-port* "std-exit-procedure called; *time-to-exit*="*time-to-exit*)
@@ -1456,56 +1527,40 @@
(bdat-time-to-exit-set! *bdat* #t)
#t))))
(debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.")
(if (and no-hurry (debug:debug-mode 18))
(rmt:print-db-stats))
- (let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds
- (if *server-info*
- (let ((pkt-file (conc (get-pkts-dir *toppath*)
- "/" (servdat-uuid *server-info*)
- ".pkt"))
- (dbfile (servdat-dbfile *server-info*)))
- (if dbfile
- (begin
-
- ;; do a final sync here
-
- (if (string-match ".*/main.db$" dbfile)
- (begin
- (debug:print-info 0 *default-log-port* "removing pkt "pkt-file)
- (delete-file* pkt-file)
- (debug:print-info 0 *default-log-port* "Releasing lock for "dbfile)
- (db:with-lock-db (servdat-dbfile *server-info*)
- (lambda (dbh dbfile)
- (db:release-lock dbh dbfile))))
- (let* ((sdat *server-info*)) ;; we have a run-id server
- (rmt:send-receive-real *rmt:remote* *toppath*
- (db:run-id->dbname #f)
- 'deregister-server
- `(,(servdat-uuid sdat)
- ,(current-process-id)
- ,(servdat-host sdat) ;; iface
- ,(servdat-port sdat)))))))))
- (if *dbstruct-db* (db:close-all *dbstruct-db*)) ;; one second allocated
- (if (bdat-task-db *bdat*) ;; TODO: Check that this is correct for task db
- (let ((db (cdr (bdat-task-db *bdat*))))
- (if (sqlite3:database? db)
- (begin
- (sqlite3:interrupt! db)
- (sqlite3:finalize! db #t)
- (bdat-task-db-set! *bdat* #f)))))
- #;(http-client#close-idle-connections!)
- (if (not (eq? *default-log-port* (current-error-port)))
- (close-output-port *default-log-port*))
- (set! *default-log-port* (current-error-port))) "Cleanup db exit thread"))
+ (let ((th1 (make-thread
+ (lambda () ;; thread for cleaning up, give it five seconds
+ (let* ((start-time (current-seconds)))
+ (if (and *server-info*
+ *unclean-shutdown*)
+ (begin
+ (debug:print-info 0 *default-log-port* "Unclean server exit, calling server-shtudown")
+ (rmt:server-shutdown)))
+ (debug:print-info 0 *default-log-port* "Shutdown activities completed in "(- (current-seconds) start-time)" seconds"))
+ ;; (if *dbstruct-db* (db:close-all *dbstruct-db*)) ;; one second allocated
+ #;(if (bdat-task-db *bdat*) ;; TODO: Check that this is correct for task db
+ (let ((db (cdr (bdat-task-db *bdat*))))
+ (if (sqlite3:database? db)
+ (begin
+ (debug:print-info 0 *default-log-port* "Closing down task db "db)
+ (sqlite3:interrupt! db)
+ (sqlite3:finalize! db #t)
+ (bdat-task-db-set! *bdat* #f)))))
+ #;(http-client#close-idle-connections!)
+ (if (not (eq? *default-log-port* (current-error-port)))
+ (close-output-port *default-log-port*))
+ (set! *default-log-port* (current-error-port))) "Cleanup db exit thread"))
(th2 (make-thread (lambda ()
- (debug:print 4 *default-log-port* "Attempting clean exit. Please be patient and wait a few seconds...")
+ (debug:print 4 *default-log-port* "Attempting clean exit. Mode="(if no-hurry "no-hurry" "normal")
+ " Please be patient and wait a few seconds...")
(if no-hurry
(begin
(thread-sleep! 5)) ;; give the clean up few seconds to do it's stuff
(begin
- (thread-sleep! 2)))
+ (thread-sleep! 2)))
(debug:print 4 *default-log-port* " ... done")
)
"clean exit")))
(thread-start! th1)
(thread-start! th2)
@@ -1539,38 +1594,13 @@
;;======================================================================
;; S E R V E R
;; ======================================================================
-;; NOTE: http-transport:launch is the entry point
-;; -> http-transport:run
-;; -> http-transport:try-start-server -> http-transport:try-start-server (until success)
-
(define (http-get-function fnkey)
(hash-table-ref/default *http-functions* fnkey (lambda () "nothing here yet")))
-#;(define (rmt:launch-server hostn port)
- (if *server-info*
- (begin
- (servdat-host-set! *server-info* hostn)
- (servdat-port-set! *server-info* port)
- (servdat-status-set! *server-info* 'trying-port)
- (servdat-trynum-set! *server-info* (+ (servdat-trynum *server-info*) 1)))
- (set! *server-info* (make-servdat host: ipaddrstr port: portnum)))
- (let* ((l (tcp-listen port))
- (dbstruct #f))
- (let-values (((i o) (tcp-accept l)))
- ;; (write-line "Hello!" o)
- (let loop ((indat (read i)))
- (let* ((res (api:process-request dbstruct indat)))
- (case res
- ((quit)
- (close-input-port i)
- (close-output-port o))
- (else
- (write res o))))))))
-
(define (rmt:run hostn)
;; ;; Configurations for server
;; (tcp-buffer-size 2048)
;; (max-connections 2048)
(debug:print 2 *default-log-port* "Attempting to start the server ...")
@@ -1581,73 +1611,111 @@
(server:get-best-guess-address hostname)
#f)))
(if ipstr ipstr hostn))) ;; hostname)))
(port (portlogger:open-run-close portlogger:find-port))
(link-tree-path (common:get-linktree))
- (tmp-area (common:get-db-tmp-area))
+ ;; (tmp-area (common:get-db-tmp-area))
#;(start-file (conc tmp-area "/.server-start")))
(debug:print-info 0 *default-log-port* "portlogger recommended port: " port)
(if *server-info*
(begin
(servdat-host-set! *server-info* ipaddrstr)
(servdat-port-set! *server-info* port)
(servdat-status-set! *server-info* 'trying-port)
(servdat-trynum-set! *server-info* (+ (servdat-trynum *server-info*) 1)))
(set! *server-info* (make-servdat host: ipaddrstr port: port)))
- (let* ((l (rmt:try-start-server ipaddrstr port)))
- (let oloop ()
- (let-values (((i o) (tcp-accept l)))
- ;; (write-line "Hello!" o)
- (let loop ((indat (read i)))
- (if (eof-object? indat)
- (begin
- (close-input-port i)
- (close-output-port o)
- (oloop))
- (let* ((res (api:process-request *dbstruct-db* indat)))
- (set! *db-last-access* (current-seconds))
- (write res o)
- (loop (read i))))))))
+ (let* ((rep (rmt:try-start-server ipaddrstr port)))
+ (let loop ((instr (nng-recv rep)))
+ (let* ((data (string->sexpr instr))
+ (res (case data
+ ((quit) 'quit)
+ (else (api:process-request *dbstruct-db* data))))
+ (resdat (sexpr->string res)))
+ (if (not (eq? res 'quit))
+ (begin
+ (set! *db-last-access* (current-seconds))
+ (nng-send rep resdat)
+ (loop (nng-recv rep)))))))
+ (debug:print-info 0 *default-log-port* "After server, should never see this")
+ ;; server exit stuff here
(let* ((portnum (servdat-port *server-info*)))
(portlogger:open-run-close portlogger:set-port portnum "released")
- (debug:print 1 *default-log-port* "INFO: server has been stopped"))))
+ (rmt:server-shutdown)
+ ;; (bdat-time-to-exit-set! *bdat* #t) ;; tell on-exit to be fast as we've already cleaned up
+ (portlogger:open-run-close portlogger:set-port port "released") ;; done in rmt:run
+ ;; (debug:print-info 0 *default-log-port* "Max cached queries was " *max-cache-size*)
+ ;; (debug:print-info 0 *default-log-port* "Number of cached writes " *number-of-writes*)
+ ;; (debug:print-info 0 *default-log-port* "Average cached write time "
+ ;; (if (eq? *number-of-writes* 0)
+ ;; "n/a (no writes)"
+ ;; (/ *writes-total-delay*
+ ;; *number-of-writes*))
+ ;; " ms")
+ ;; (debug:print-info 0 *default-log-port* "Number non-cached queries " *number-non-write-queries*)
+ ;; (debug:print-info 0 *default-log-port* "Average non-cached time "
+ ;; (if (eq? *number-non-write-queries* 0)
+ ;; "n/a (no queries)"
+ ;; (/ *total-non-write-delay*
+ ;; *number-non-write-queries*))
+ ;; " ms")
+
+ (db:print-current-query-stats)
+ (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting")
+ )))
(define (rmt:try-start-server ipaddrstr portnum)
- (if *server-info*
+ (if *server-info* ;; update the server info as we might be trying next port
(begin
(servdat-host-set! *server-info* ipaddrstr)
(servdat-port-set! *server-info* portnum)
(servdat-status-set! *server-info* 'trying-port)
- (servdat-trynum-set! *server-info* (+ (servdat-trynum *server-info*) 1)))
+ (servdat-trynum-set! *server-info*
+ (+ (servdat-trynum *server-info*) 1)))
(set! *server-info* (make-servdat host: ipaddrstr port: portnum)))
(debug:print-info 0 *default-log-port* "rmt:try-start-server time="
(seconds->time-string (current-seconds))
" ipaddrsstr=" ipaddrstr
" portnum=" portnum)
- (handle-exceptions
- exn
- (begin
- (print-error-message exn)
- (if (< portnum 64000)
- (begin
- (debug:print 0 *default-log-port* "WARNING: attempt to start server failed. Trying again ...")
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (debug:print 5 *default-log-port* "exn=" (condition->list exn))
- (portlogger:open-run-close portlogger:set-failed portnum)
- (debug:print 0 *default-log-port* "WARNING: failed to start on portnum: " portnum ", trying next port")
- ;; (thread-sleep! 0.1)
- (rmt:try-start-server ipaddrstr
- (portlogger:open-run-close portlogger:find-port)))
- (begin
- (print "ERROR: Tried and tried but could not start the server"))))
- ;; any error in following steps will result in a retry
- (if *server-info*
- (servdat-status-set! *server-info* 'starting)
- (set! *server-info* (make-servdat host: ipaddrstr port: portnum)))
-
- (debug:print 0 *default-log-port* "INFO: Trying to start server on " ipaddrstr ":" portnum)
- (tcp-listen portnum)))
+ (if (is-port-in-use portnum)
+ (begin
+ (portlogger:open-run-close portlogger:set-failed portnum)
+ (debug:print 0 *default-log-port* "WARNING: failed to start on portnum: " portnum ", trying next port")
+ ;; (thread-sleep! 0.1)
+ (rmt:try-start-server ipaddrstr
+ (portlogger:open-run-close
+ portlogger:find-port)))
+ (begin
+ (if (not *server-info*)
+ (set! *server-info* (make-servdat
+ host: ipaddrstr
+ port: portnum)))
+ (servdat-status-set! *server-info* 'starting)
+ (servdat-port-set! *server-info* portnum)
+ (if (not (servdat-rep *server-info*))
+ (let ((rep (make-rep-socket)))
+ (servdat-rep-set! *server-info* rep)
+ (socket-set! rep 'nng/recvtimeo 2000)))
+ (let* ((rep (servdat-rep *server-info*)))
+ (debug:print 0 *default-log-port* "INFO: Trying to start server on " ipaddrstr ":" portnum)
+ (handle-exceptions
+ exn
+ (begin
+ (print-error-message exn)
+ (if (< portnum 64000)
+ (begin
+ (debug:print 0 *default-log-port* "WARNING: attempt to start server failed. Trying again ...")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 5 *default-log-port* "exn=" (condition->list exn))
+ (portlogger:open-run-close portlogger:set-failed portnum)
+ (debug:print 0 *default-log-port* "WARNING: failed to start on portnum: " portnum ", trying next port")
+ ;; (thread-sleep! 0.1)
+ (rmt:try-start-server ipaddrstr
+ (portlogger:open-run-close portlogger:find-port)))
+ (begin
+ (print "ERROR: Tried and tried but could not start the server, stopping at port "portnum))))
+ (nng-listen rep (conc "tcp://*:" portnum))
+ rep)))))
;;======================================================================
;; S E R V E R U T I L I T I E S
;;======================================================================
@@ -1796,31 +1864,33 @@
(define (server-address srv-pkt)
(conc (alist-ref 'host srv-pkt) ":"
(alist-ref 'port srv-pkt)))
(define (server-ready? host port key) ;; server-address is host:port
- (let-values (((i o)(handle-exceptions
- exn
- (values #f #f)
- (tcp-connect host port))))
- (if (and i o)
- (begin
- (write `((cmd . ping)
- (key . ,key)
- (params . ())) o)
- (let ((res (with-input-from-port i
- read)))
- (close-output-port o)
- (close-input-port i)
- res))
+;; (let-values (((i o)(handle-exceptions
+;; exn
+;; (values #f #f)
+;; (tcp-connect host port))))
+;; (if (and i o)
+ (let* ((data (sexpr->string `((cmd . ping)
+ (key . ,key)
+ (params . ()))))
+ (res (open-send-receive-nn (conc host ":" port) data)))
+ (string->sexpr res)))
+
+;; (let ((res (with-input-from-port i
+;; read)))
+;; (close-output-port o)
+;; (close-input-port i)
+;; res))
;; (if (string? res)
;; (string->sexpr res)
;; res)))
- (begin ;; connection failed
- (debug:print-info 0 *default-log-port* "Server at "host":"port" is not responding.")
- #f))))
-
+;; (begin ;; connection failed
+;; (debug:print-info 0 *default-log-port* "Server at "host":"port" is not responding.")
+;; #f))))
+
;; (define (loop-test host port data) ;; server-address is host:port
;; ;; ping the server and ask it
;; ;; if it ready
;; ;; (let* ((sdat (servdat-init #f host port #f)))
;; ;; (http-transport:send-receive sdat "abc" 'ping '())))
@@ -1970,18 +2040,38 @@
(equal? sdat last-sdat)
sdat))))))))
(define (rmt:register-server remote apath iface port server-key dbname)
(rmt:open-main-connection remote apath) ;; we need a channel to main.db
- (rmt:send-receive-real remote apath ;; params: host port servkey pid ipaddr dbpath
- (db:run-id->dbname #f) 'register-server `(,iface
- ,port
- ,server-key
- ,(current-process-id)
- ,iface
- ,apath
- ,dbname)))
+ (rmt:send-receive-real remote apath ;; params: host port servkey pid ipaddr dbpath
+ (db:run-id->dbname #f)
+ 'register-server `(,iface
+ ,port
+ ,server-key
+ ,(current-process-id)
+ ,iface
+ ,apath
+ ,dbname)))
+
+(define (rmt:get-count-servers remote apath)
+ (rmt:open-main-connection remote apath) ;; we need a channel to main.db
+ (rmt:send-receive-real remote apath ;; params: host port servkey pid ipaddr dbpath
+ (db:run-id->dbname #f)
+ 'get-count-servers `(,apath
+ )))
+
+(define (rmt:deregister-server remote apath iface port server-key dbname)
+ (rmt:open-main-connection remote apath) ;; we need a channel to main.db
+ (rmt:send-receive-real remote apath ;; params: host port servkey pid ipaddr dbpath
+ (db:run-id->dbname #f)
+ 'deregister-server `(,iface
+ ,port
+ ,server-key
+ ,(current-process-id)
+ ,iface
+ ,apath
+ ,dbname)))
(define (http-transport:wait-for-stable-interface #!optional (num-tries-allowed 100))
;; wait until *server-info* stops changing
(let* ((stime (current-seconds)))
(let loop ((last-host #f)
@@ -2040,15 +2130,16 @@
(http-transport:wait-for-server pkts-dir dbname server-key)
(http-transport:wait-for-stable-interface))
;; this is our forever loop
(let* ((iface (servdat-host *server-info*))
(port (servdat-port *server-info*)))
- (let loop ((count 0)
+ (let loop ((count 0)
(bad-sync-count 0)
(start-time (current-milliseconds)))
- (if (not is-main)
+ (if (and (not is-main)
+ (common:low-noise-print 60 "servdat-status"))
(debug:print-info 0 *default-log-port* "servdat-status is " (servdat-status *server-info*)))
;; set up the database handle
(mutex-lock! *heartbeat-mutex*)
(if (not *dbstruct-db*) ;; no db opened yet, open the db and register with main if appropriate
@@ -2068,20 +2159,28 @@
(exit)))))
(debug:print 0 *default-log-port*
"SERVER: running, db "dbname" opened, megatest version: "
(common:get-full-version))
;; start the watchdog
- (if watchdog
+
+ ;; is this really needed?
+
+ #;(if watchdog
(if (not (member (thread-state watchdog)
'(ready running blocked
sleeping dead)))
(begin
(debug:print-info 0 *default-log-port* "Starting watchdog thread (in state "(thread-state watchdog)")")
(thread-start! watchdog))
(debug:print-info 0 *default-log-port* "Not starting watchdog thread (in state "(thread-state watchdog)")"))
(debug:print 0 *default-log-port* "ERROR: *watchdog* not setup, cannot start it."))
- #;(loop (+ count 1) bad-sync-count start-time)))
+ #;(loop (+ count 1) bad-sync-count start-time)
+ ))
+
+ (debug:print-info 0 *default-log-port* "syncing "*toppath*" "dbname" at "(current-seconds))
+ (db:sync-inmem->disk *dbstruct-db* *toppath* dbname force-sync: #t)
+
(mutex-unlock! *heartbeat-mutex*)
;; when things go wrong we don't want to be doing the various
;; queries too often so we strive to run this stuff only every
;; four seconds or so.
@@ -2103,64 +2202,37 @@
(db:print-current-query-stats)))
(let* ((hrs-since-start (/ (- (current-seconds) server-start-time) 3600)))
(cond
((and *server-run*
(> (+ last-access server-timeout)
- (current-seconds)))
+ (current-seconds))
+ (if is-main
+ (> (rmt:get-count-servers *rmt:remote* *toppath*) 1)
+ #t))
(if (common:low-noise-print 120 "server continuing")
(debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access)))
(loop 0 bad-sync-count (current-milliseconds)))
(else
+ (set! *unclean-shutdown* #f)
(debug:print-info 0 *default-log-port* "Server timed out. seconds since last db access: " (- (current-seconds) last-access))
- (http-transport:server-shutdown port))))))))
-
-(define (http-transport:server-shutdown port)
- (begin
- ;;(BB> "http-transport:server-shutdown called")
- (debug:print-info 0 *default-log-port* "Starting to shutdown the server. pid="(current-process-id))
- ;;
- ;; start_shutdown
- ;;
-
- ;; deregister the server
-
-
- (bdat-time-to-exit-set! *bdat* #t) ;; tell on-exit to be fast as we've already cleaned up
- (portlogger:open-run-close portlogger:set-port port "released")
- (thread-sleep! 1)
-
- ;; (debug:print-info 0 *default-log-port* "Max cached queries was " *max-cache-size*)
- ;; (debug:print-info 0 *default-log-port* "Number of cached writes " *number-of-writes*)
- ;; (debug:print-info 0 *default-log-port* "Average cached write time "
- ;; (if (eq? *number-of-writes* 0)
- ;; "n/a (no writes)"
- ;; (/ *writes-total-delay*
- ;; *number-of-writes*))
- ;; " ms")
- ;; (debug:print-info 0 *default-log-port* "Number non-cached queries " *number-non-write-queries*)
- ;; (debug:print-info 0 *default-log-port* "Average non-cached time "
- ;; (if (eq? *number-non-write-queries* 0)
- ;; "n/a (no queries)"
- ;; (/ *total-non-write-delay*
- ;; *number-non-write-queries*))
- ;; " ms")
-
- (db:print-current-query-stats)
- (common:save-pkt `((action . exit)
- (T . server)
- (pid . ,(current-process-id)))
- *configdat* #t)
- (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting")
- (exit)))
+ (debug:print-info 0 *default-log-port* "Starting to shutdown the server. pid="(current-process-id))
+ (rmt:server-shutdown)
+ (portlogger:open-run-close portlogger:set-port port "released")
+ (exit)
+ #;(debug:print-info 0 *default-log-port* "Sending 'quit to server, received: "
+ (open-send-receive-nn (conc iface":"port) ;; do this here and not in server-shutdown
+ (sexpr->string 'quit)))
+ )))))))
;; Call this to start the actual server
;;
;; all routes though here end in exit ...
;;
;; This is the point at which servers are started
;;
(define (rmt:server-launch dbname)
+ (debug:print-info 0 *default-log-port* "Entered rmt:server-launch")
(let* ((th2 (make-thread (lambda ()
(debug:print-info 0 *default-log-port* "Server run thread started")
(rmt:run (if (args:get-arg "-server")
(args:get-arg "-server")
"-")
@@ -2172,12 +2244,13 @@
(thread-start! th2)
(thread-sleep! 0.252) ;; give the server time to settle before starting the keep-running monitor.
(thread-start! th3)
(set! *didsomething* #t)
(thread-join! th2)
- (exit))
-
+ (thread-join! th3)
+ ;; (exit))
+ )
#f
)
;; Generate a unique signature for this process, used at both client and
;; server side
@@ -2192,10 +2265,112 @@
(define (rmt:get-signature)
(if *my-signature* *my-signature*
(let ((sig (rmt:mk-signature)))
(set! *my-signature* sig)
*my-signature*)))
+
+;;======================================================================
+;; Nanomsg transport
+;;======================================================================
+
+(define (is-port-in-use port-num)
+ (let* ((ret #f))
+ (let-values (((inp oup pid)
+ (process "netstat" (list "-tulpn" ))))
+ (let loop ((inl (read-line inp)))
+ (if (not (eof-object? inl))
+ (begin
+ (if (string-search (regexp (conc ":" port-num)) inl)
+ (begin
+ ;(print "Output: " inl)
+ (set! ret #t))
+ (loop (read-line inp)))))))
+ ret))
+
+;;start a server, returns the connection
+;;
+(define (start-nn-server portnum )
+ (let ((rep (make-rep-socket))) ;; (nn-socket 'rep)))
+ (socket-set! rep 'nng/recvtimeo 2000)
+ (handle-exceptions
+ exn
+ (let ((emsg ((condition-property-accessor 'exn 'message) exn)))
+ (print "ERROR: Failed to start server \"" emsg "\"")
+ (exit 1))
+
+ (nng-dial #;nn-bind rep (conc "tcp://*:" portnum)))
+ rep))
+
+;; open connection to server, send message, close connection
+;;
+(define (open-send-close-nn host-port msg #!key (timeout 3) ) ;; default timeout is 3 seconds
+ (let ((req (make-req-socket 'req))
+ (uri (conc "tcp://" host-port))
+ (res #f)
+ ;; (contacts (alist-ref 'contact attrib))
+ ;; (mode (alist-ref 'mode attrib))
+ )
+ (socket-set! req 'nng/recvtimeo 2000)
+ (handle-exceptions
+ exn
+ (let ((emsg ((condition-property-accessor 'exn 'message) exn)))
+ ;; Send notification
+ (debug:print 0 *default-log-port* "ERROR: Failed to connect / send to " uri " message was \"" emsg "\"" )
+ #f)
+ (nng-dial req uri)
+ ;; (print "Connected to the server " )
+ (nng-send req msg)
+ ;; (print "Request Sent")
+ (let* ((th1 (make-thread (lambda ()
+ (let ((resp (nng-recv req)))
+ (nng-close! req)
+ (set! res (if (equal? resp "ok")
+ #t
+ #f))))
+ "recv thread"))
+ (th2 (make-thread (lambda ()
+ (thread-sleep! timeout)
+ (thread-terminate! th1))
+ "timer thread")))
+ (thread-start! th1)
+ (thread-start! th2)
+ (thread-join! th1)
+ res))))
+
+(define (open-send-receive-nn host-port msg #!key (timeout 3) ) ;; default timeout is 3 seconds
+ (let ((req (make-req-socket))
+ (uri (conc "tcp://" host-port))
+ (res #f)
+ ;; (contacts (alist-ref 'contact attrib))
+ ;; (mode (alist-ref 'mode attrib))
+ )
+ (handle-exceptions
+ exn
+ (let ((emsg ((condition-property-accessor 'exn 'message) exn)))
+ ;; Send notification
+ (debug:print 0 *default-log-port* "ERROR: Failed to connect / send to " uri " message was \"" emsg "\", exn=" exn)
+ #f)
+ (nng-dial req uri)
+ ;; (print "Connected to the server " )
+ (nng-send req msg)
+ ;; (print "Request Sent")
+ ;; receive code here
+ ;;(print (nn-recv req))
+ (let* ((th1 (make-thread (lambda ()
+ (let ((resp (nng-recv req)))
+ (nng-close! req)
+ (print resp)
+ (set! res resp)))
+ "recv thread"))
+ (th2 (make-thread (lambda ()
+ (thread-sleep! timeout)
+ (thread-terminate! th1))
+ "timer thread")))
+ (thread-start! th1)
+ (thread-start! th2)
+ (thread-join! th1)
+ res))))
;;======================================================================
;; S E R V E R U T I L I T I E S
;;======================================================================
Index: run_records.scm
==================================================================
--- run_records.scm
+++ run_records.scm
@@ -15,34 +15,5 @@
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
;;======================================================================
-
-(define-inline (runs:runrec-make-record) (make-vector 13))
-(define-inline (runs:runrec-get-target vec)(vector-ref vec 0)) ;; a/b/c
-(define-inline (runs:runrec-get-runname vec)(vector-ref vec 1)) ;; string
-(define-inline (runs:runrec-testpatt vec)(vector-ref vec 2)) ;; a,b/c,d%
-(define-inline (runs:runrec-keys vec)(vector-ref vec 3)) ;; (key1 key2 ...)
-(define-inline (runs:runrec-keyvals vec)(vector-ref vec 4)) ;; ((key1 val1)(key2 val2) ...)
-(define-inline (runs:runrec-environment vec)(vector-ref vec 5)) ;; environment, alist key val
-(define-inline (runs:runrec-mconfig vec)(vector-ref vec 6)) ;; megatest.config
-(define-inline (runs:runrec-runconfig vec)(vector-ref vec 7)) ;; runconfigs.config
-(define-inline (runs:runrec-serverdat vec)(vector-ref vec 8)) ;; (host port)
-(define-inline (runs:runrec-transport vec)(vector-ref vec 9)) ;; 'http
-(define-inline (runs:runrec-db vec)(vector-ref vec 10)) ;; (if 'fs)
-(define-inline (runs:runrec-top-path vec)(vector-ref vec 11)) ;; *toppath*
-(define-inline (runs:runrec-run_id vec)(vector-ref vec 12)) ;; run-id
-
-(define-inline (test:get-id vec) (vector-ref vec 0))
-(define-inline (test:get-run_id vec) (vector-ref vec 1))
-(define-inline (test:get-test-name vec)(vector-ref vec 2))
-(define-inline (test:get-state vec) (vector-ref vec 3))
-(define-inline (test:get-status vec) (vector-ref vec 4))
-(define-inline (test:get-item-path vec)(vector-ref vec 5))
-
-(define-inline (test:test-get-fullname test)
- (conc (db:test-get-testname test)
- (if (equal? (db:test-get-item-path test) "")
- ""
- (conc "(" (db:test-get-item-path test) ")"))))
-
Index: runsmod.scm
==================================================================
--- runsmod.scm
+++ runsmod.scm
@@ -298,11 +298,11 @@
#f ;; get full data (not 'shortlist)
0 ;; (runs:gendat-inc-results-last-update *runs:general-data*) ;; last update time
'dashboard)
'()))
(log-dir (conc *toppath* "/logs"))
- (log-file (conc "pre-hook-" (string-translate (getenv "MT_TARGET") "/" "-") "-" (getenv "MT_RUNNAME") ".log"))
+ (log-file (conc "pre-hook-" (string-translate (get-environment-variable "MT_TARGET") "/" "-") "-" (get-environment-variable "MT_RUNNAME") ".log"))
(full-log-fname (conc log-dir "/" log-file)))
(if run-pre-hook
(if (null? existing-tests)
(let* ((use-log-dir (if (not (directory-exists? log-dir))
(handle-exceptions
@@ -345,11 +345,11 @@
(let* ((keys (keys:config-get-fields *configdat*))
(keyvals (keys:target->keyval keys target))
(run-id (rmt:register-run keyvals runname "new" "n/a" user (args:get-arg "-contour"))) ;; test-name)))
;; (deferred '()) ;; delay running these since they have a waiton clause
(runconfigf (conc *toppath* "/runconfigs.config"))
- (dbfile (conc *toppath* "/megatest.db"))
+ (dbfile (conc *toppath* "/.db/main.db"))
(readonly-mode (not (file-writable? dbfile)))
(test-records (make-hash-table))
;; need to process runconfigs before generating these lists
(all-tests-registry #f) ;; (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names
(all-test-names #f) ;; (hash-table-keys all-tests-registry))
@@ -498,19 +498,19 @@
;; run the run prehook if there are no tests yet run for this run:
;;
(runs:run-pre-hook run-id)
;; mark all test launched flag as false in the meta table
- (rmt:set-var (conc "lunch-complete-" run-id) "no")
+ (rmt:set-var run-id (conc "lunch-complete-" run-id) "no")
(debug:print-info 1 *default-log-port* "Setting end-of-run to no")
(let* ((config-reruns (let ((x (configf:lookup *configdat* "setup" "reruns")))
(if x (string->number x) #f)))
(config-rerun-cnt (if config-reruns
config-reruns
1)))
(if (eq? config-rerun-cnt run-count)
- (rmt:set-var (conc "end-of-run-" run-id) "no")))
+ (rmt:set-var run-id (conc "end-of-run-" run-id) "no")))
(rmt:set-run-state-status run-id "new" "n/a")
;; now add non-directly referenced dependencies (i.e. waiton)
;;======================================================================
;; refactoring this block into tests:get-full-data
@@ -522,11 +522,11 @@
(if (not (null? test-names)) ;; BEGIN test-names loop
(let loop ((hed (car test-names)) ;; NOTE: This is the main loop that iterates over the test-names
(tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc
(debug:print-info 4 *default-log-port* "\n\ntestpatt elaboration loop => hed="hed " tal="tal" test-patts="test-patts" test-names="test-names)
(change-directory *toppath*) ;; PLEASE OPTIMIZE ME!!! I think this should be a no-op but there are several places where change-directories could be happening.
- (setenv "MT_TEST_NAME" hed) ;;
+ (set-environment-variable! "MT_TEST_NAME" hed) ;;
(let*-values (((waitons waitors config) (tests:get-waitons hed all-tests-registry))
;; NOTE: Have the config - can extract [waitons] section
((hed-mode)
@@ -813,12 +813,12 @@
(and (member 'toplevel testmode)
(null? non-completed)))
(debug:print-info 4 *default-log-port* "cond branch - " "ei-2")
(debug:print-info 4 *default-log-port* "runs:expand-items: (or (null? prereqs-not-met) (and (member 'toplevel testmode)(null? non-completed)))")
(let ((test-name (tests:testqueue-get-testname test-record)))
- (setenv "MT_TEST_NAME" test-name) ;;
- (setenv "MT_RUNNAME" runname)
+ (set-environment-variable! "MT_TEST_NAME" test-name) ;;
+ (set-environment-variable! "MT_RUNNAME" runname)
(runs:set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process
(let ((items-list (items:get-items-from-config tconfig)))
(if (list? items-list)
(begin
(if (null? items-list)
@@ -1705,11 +1705,11 @@
(else
(debug:print-info 4 *default-log-port* "cond branch - " "rtq-9")
(debug:print-info 4 *default-log-port* "Exiting loop with...\n hed=" hed "\n tal=" tal "\n reruns=" reruns))
))) ;; end loop on sorted test names
;; this is the point where everything is launched and now you can mark the run in metadata table as all launched
- (rmt:set-var (conc "lunch-complete-" run-id) "yes")
+ (rmt:set-var run-id (conc "lunch-complete-" run-id) "yes")
;; now *if* -run-wait we wait for all tests to be done
;; Now wait for any RUNNING tests to complete (if in run-wait mode)
;; (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat)))
(thread-sleep! 10) ;; I think there is a race condition here. Let states/statuses settle
@@ -1827,13 +1827,13 @@
"\nTESTNAME: " full-test-name
"\n test-config: " (hash-table->alist test-conf)
"\n itemdat: " itemdat
)
(debug:print 2 *default-log-port* "Attempting to launch test " full-test-name)
- ;; (setenv "MT_TEST_NAME" test-name) ;;
- ;; (setenv "MT_ITEMPATH" item-path)
- ;; (setenv "MT_RUNNAME" runname)
+ ;; (set-environment-variable! "MT_TEST_NAME" test-name) ;;
+ ;; (set-environment-variable! "MT_ITEMPATH" item-path)
+ ;; (set-environment-variable! "MT_RUNNAME" runname)
(change-directory *toppath*)
;; Here is where the test_meta table is best updated
;; Yes, another use of a global for caching. Need a better way?
;;
@@ -2740,17 +2740,17 @@
(process-signal pid signal/int)
(thread-sleep! 5)
(if (process:alive? pid)
(process-signal pid signal/kill)))))
;; (call-with-environment-variables
- (let ((old-targethost (getenv "TARGETHOST")))
- (setenv "TARGETHOST" hostname)
- (setenv "TARGETHOST_LOGF" "server-kills.log")
+ (let ((old-targethost (get-environment-variable "TARGETHOST")))
+ (set-environment-variable! "TARGETHOST" hostname)
+ (set-environment-variable! "TARGETHOST_LOGF" "server-kills.log")
(system (conc "nbfake kill " pid))
- (if old-targethost (setenv "TARGETHOST" old-targethost))
- (unsetenv "TARGETHOST")
- (unsetenv "TARGETHOST_LOGF"))))
+ (if old-targethost (set-environment-variable! "TARGETHOST" old-targethost))
+ (unset-environment-variable! "TARGETHOST")
+ (unset-environment-variable! "TARGETHOST_LOGF"))))
(debug:print-error 0 *default-log-port* "no record or improper record for " target "/" run-name " in tasks_queue in main.db"))))
records)))
(define (task:get-run-times)
(let* (
ADDED scripts/gen-module-list.sh
Index: scripts/gen-module-list.sh
==================================================================
--- /dev/null
+++ scripts/gen-module-list.sh
@@ -0,0 +1,8 @@
+#!/bin/bash
+
+TARGFILE=$1
+
+echo ' ('
+egrep '^\(define \(' $TARGFILE | tr '()' ' '|awk '{print $2}'
+egrep '^\(define \*' $TARGFILE | awk '{print $2}'
+echo ')'
DELETED server.scm
Index: server.scm
==================================================================
--- server.scm
+++ /dev/null
@@ -1,51 +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 .
-;;
-
-;; (require-extension (srfi 18) extras tcp s11n)
-;;
-;; (use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest
-;; directory-utils posix-extras matchable)
-;;
-;; (use spiffy uri-common intarweb http-client spiffy-request-vars)
-;;
-;; (declare (unit server))
-;;
-;; (declare (uses common))
-;; (declare (uses db))
-;; (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
-;; ;; (declare (uses synchash))
-;; (declare (uses http-transport))
-;; ;;(declare (uses rpc-transport))
-;; (declare (uses launch))
-;; ;; (declare (uses daemon))
-;;
-;; (include "common_records.scm")
-;; (include "db_records.scm")
-
-;;======================================================================
-;; P K T S S T U F F
-;;======================================================================
-
-;; ???
-
-;;======================================================================
-;; P K T S S T U F F
-;;======================================================================
-
-;; ???
-
Index: task_records.scm
==================================================================
--- task_records.scm
+++ task_records.scm
@@ -15,30 +15,5 @@
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;======================================================================
-;; make-vector-record tasks task id action owner state target name test item params creation_time execution_time
-(define (make-tasks:task)(make-vector 11))
-(define-inline (tasks:task-get-id vec) (vector-ref vec 0))
-(define-inline (tasks:task-get-action vec) (vector-ref vec 1))
-(define-inline (tasks:task-get-owner vec) (vector-ref vec 2))
-(define-inline (tasks:task-get-state vec) (vector-ref vec 3))
-(define-inline (tasks:task-get-target vec) (vector-ref vec 4))
-(define-inline (tasks:task-get-name vec) (vector-ref vec 5))
-(define-inline (tasks:task-get-testpatt vec) (vector-ref vec 6))
-(define-inline (tasks:task-get-keylock vec) (vector-ref vec 7))
-(define-inline (tasks:task-get-params vec) (vector-ref vec 8))
-(define-inline (tasks:task-get-creation_time vec) (vector-ref vec 9))
-(define-inline (tasks:task-get-execution_time vec) (vector-ref vec 10))
-
-(define-inline (tasks:task-set-state! vec val)(vector-set! vec 3 val))
-
-
-;; make-vector-record tasks monitor id pid start_time last_update hostname username
-(define (make-tasks:monitor)(make-vector 5))
-(define-inline (tasks:monitor-get-id vec) (vector-ref vec 0))
-(define-inline (tasks:monitor-get-pid vec) (vector-ref vec 1))
-(define-inline (tasks:monitor-get-start_time vec) (vector-ref vec 2))
-(define-inline (tasks:monitor-get-last_update vec) (vector-ref vec 3))
-(define-inline (tasks:monitor-get-hostname vec) (vector-ref vec 4))
-(define-inline (tasks:monitor-get-username vec) (vector-ref vec 5))
Index: tasksmod.scm
==================================================================
--- tasksmod.scm
+++ tasksmod.scm
@@ -90,11 +90,35 @@
;; (declare (uses common))
;; (declare (uses pgdb))
;; (import pgdb) ;; pgdb is a module
-(include "task_records.scm")
+;; make-vector-record tasks task id action owner state target name test item params creation_time execution_time
+(define (make-tasks:task)(make-vector 11))
+(define (tasks:task-get-id vec) (vector-ref vec 0))
+(define (tasks:task-get-action vec) (vector-ref vec 1))
+(define (tasks:task-get-owner vec) (vector-ref vec 2))
+(define (tasks:task-get-state vec) (vector-ref vec 3))
+(define (tasks:task-get-target vec) (vector-ref vec 4))
+(define (tasks:task-get-name vec) (vector-ref vec 5))
+(define (tasks:task-get-testpatt vec) (vector-ref vec 6))
+(define (tasks:task-get-keylock vec) (vector-ref vec 7))
+(define (tasks:task-get-params vec) (vector-ref vec 8))
+(define (tasks:task-get-creation_time vec) (vector-ref vec 9))
+(define (tasks:task-get-execution_time vec) (vector-ref vec 10))
+
+(define (tasks:task-set-state! vec val)(vector-set! vec 3 val))
+
+
+;; make-vector-record tasks monitor id pid start_time last_update hostname username
+(define (make-tasks:monitor)(make-vector 5))
+(define (tasks:monitor-get-id vec) (vector-ref vec 0))
+(define (tasks:monitor-get-pid vec) (vector-ref vec 1))
+(define (tasks:monitor-get-start_time vec) (vector-ref vec 2))
+(define (tasks:monitor-get-last_update vec) (vector-ref vec 3))
+(define (tasks:monitor-get-hostname vec) (vector-ref vec 4))
+(define (tasks:monitor-get-username vec) (vector-ref vec 5))
;; (include "db_records.scm")
;;======================================================================
;; Tasks db
;;======================================================================
ADDED testbuild/Makefile
Index: testbuild/Makefile
==================================================================
--- /dev/null
+++ testbuild/Makefile
@@ -0,0 +1,17 @@
+CSCOPTS=
+SRCFILES=m1.scm m2.scm m3.scm
+
+%.import.o : %.import.scm
+ csc $(CSCOPTS) -unit $*.import -c $*.import.scm -o $*.import.o
+
+%.o %.import.scm : %.scm
+ csc $(CSCOPTS) -J -c $< -o $*.o
+
+cl : cl.scm m1.o m2.o m1.import.o
+ csc $(CSCOPTS) m1.o m1.import.o m2.o cl.scm -o cl
+
+gui : gui.scm m1.o m2.o m3.o m1.import.o
+ csc $(CSCOPTS) m1.o m2.o m3.o m1.import.o gui.scm -o gui
+
+clean :
+ rm -f *.o *.import.scm cl gui
ADDED testbuild/README
Index: testbuild/README
==================================================================
--- /dev/null
+++ testbuild/README
@@ -0,0 +1,5 @@
+This is a minimal set of files to illustrate how Megatest is built.
+
+NOTE: Missing is an example of how the .import.o files are compiled in to
+ enable code in evals to access the procedures in modules.
+
ADDED testbuild/cl.scm
Index: testbuild/cl.scm
==================================================================
--- /dev/null
+++ testbuild/cl.scm
@@ -0,0 +1,24 @@
+;; a command line only executable
+
+(declare (uses m1))
+(declare (uses m2))
+
+(module cl-guts
+ *
+
+(import scheme
+ chicken.base
+ m1
+ m2)
+
+(define (main)
+ (a)
+ (b)
+ (print "I'm main from cl.scm")
+ (print "Got "(try-an-eval)" from try an eval"))
+
+)
+
+(import cl-guts)
+
+(main)
ADDED testbuild/gui.scm
Index: testbuild/gui.scm
==================================================================
--- /dev/null
+++ testbuild/gui.scm
@@ -0,0 +1,27 @@
+;; a command line only executable
+
+(declare (uses m1))
+(declare (uses m2))
+(declare (uses m3))
+
+(module gui-guts
+ *
+
+(import scheme
+ chicken.base
+ m1
+ m2
+ m3
+ )
+
+(define (main)
+ (a)
+ (c)
+ (print "I'm main from cl.scm, let's start a gui ...")
+ (print "Got "(try-an-eval)" from try an eval"))
+
+)
+
+(import gui-guts)
+
+(main)
ADDED testbuild/m1.scm
Index: testbuild/m1.scm
==================================================================
--- /dev/null
+++ testbuild/m1.scm
@@ -0,0 +1,23 @@
+;; a module used by both command line (cl.scm) and gui (gui.scm)
+
+(declare (unit m1))
+
+(module m1
+ *
+
+(import scheme
+ chicken.base
+ chicken.port
+ )
+
+(define (a)
+ (print "I'm from module m1"))
+
+(define (do-an-eval thestring ht)
+ (with-input-from-string
+ thestring
+ (lambda ()
+ ((eval (read)) ht))))
+
+)
+
ADDED testbuild/m2.scm
Index: testbuild/m2.scm
==================================================================
--- /dev/null
+++ testbuild/m2.scm
@@ -0,0 +1,28 @@
+;; a module used only by the command line executable
+;;
+(declare (unit m2))
+(declare (uses m1))
+(declare (uses m1.import))
+
+(module m2
+ *
+
+(import scheme
+ chicken.base
+
+ m1
+
+ srfi-69
+ )
+
+(define (b)
+ (print "I'm from module m2"))
+
+(define (try-an-eval)
+ (let* ((ht (make-hash-table)))
+ (do-an-eval "(lambda (ht)(import srfi-69 m1)
+ (a)
+ (hash-table-set! ht \"a\" 123))" ht)
+ (hash-table->alist ht)))
+
+)
ADDED testbuild/m3.scm
Index: testbuild/m3.scm
==================================================================
--- /dev/null
+++ testbuild/m3.scm
@@ -0,0 +1,23 @@
+;; a module used only by gui.scm
+;;
+(declare (unit m3))
+
+(module m3
+ *
+
+(import scheme
+ chicken.base
+ iup)
+
+(define (c)
+ (print "I'm from module m3")
+ (show
+ (dialog
+ (vbox
+ (label "Hello, I'm a gui")
+ (button "Push me to exit"
+ action: (lambda (obj)(exit)))
+ )))
+ (main-loop))
+
+)
Index: tests/unittests/basicserver.scm
==================================================================
--- tests/unittests/basicserver.scm
+++ tests/unittests/basicserver.scm
@@ -63,11 +63,11 @@
;; (rmt:conn-port *main*) tdat)))
;; (list 'a
;; '(a "b" 123 1.23 )))
(test #f #t (rmt:send-receive 'ping #f 'hello))
-(define *db* (db:setup #f))
+(define *db* (db:setup ".db/main.db"))
;; these let me cut and paste from source easily
(define apath *toppath*)
(define dbname ".db/2.db")
(define remote *rmt:remote*)
Index: tests/unittests/server.scm
==================================================================
--- tests/unittests/server.scm
+++ tests/unittests/server.scm
@@ -32,490 +32,51 @@
;; rmt:send-receive-real
;; rmt:send-receive
;; sexpr->string
;; server-ready?
;; rmt:register-server
+ ;; rmt:deregister-server
;; rmt:open-main-connection
;; rmt:general-open-connection
- ;; rmt:get-conny
+ ;; rmt:get-conn
;; common:watchdog
;; rmt:find-main-server
;; get-all-server-pkts
;; get-viable-servers
;; get-best-candidate
;; api:run-server-process
+ ;; api:process-request
;; rmt:run
;; rmt:try-start-server
)
-(define *db* (db:setup #f))
+(define *db* (db:setup ".db/main.db"))
;; these let me cut and paste from source easily
(define apath *toppath*)
(define dbname ".db/2.db")
(define remote *rmt:remote*)
(define keyvals '(("SYSTEM" "a")("RELEASE" "b")))
(test #f #t (rmt:open-main-connection remote apath))
+(test #f #t (rmt:conn? (rmt:get-conn *rmt:remote* *toppath* ".db/main.db")))
(test #f #t (rmt:conn? (rmt:get-conn *rmt:remote* *toppath* ".db/main.db")))
(test #f 'server-started (rmt:send-receive-real *rmt:remote* *toppath* ".db/main.db" 'get-server `(,apath ,dbname)))
(thread-sleep! 2)
(test #f #t (list? (rmt:general-open-connection *rmt:remote* *toppath* ".db/2.db")))
(test #f '("SYSTEM" "RELEASE") (rmt:get-keys))
(test #f 1 (rmt:send-receive 'register-run #f (list keyvals "run1" "new" "n/a" "justme" #f)))
(print "Got here.")
-(test #t 1 (rmt:send-receive 'register-run 1 (list keyvals "run2" "new" "n/a" "justme" #f)))
-
-(test #f 1 (rmt:register-run keyvals "run2" "new" "n/a" "justme" #f))
-
-;; (delete-file* "logs/1.log")
-;; (define run-id 1)
-
-;; (test "setup for run" #t (begin (launch:setup)
-;; (string? (getenv "MT_RUN_AREA_HOME"))))
-;;
-;; (test #f #t (and (server:kind-run *toppath*) #t))
-;;
-;;
-;; (define user (current-user-name))
-;; (define runname "mytestrun")
-;; (define keys (rmt:get-keys))
-;; (define runinfo #f)
-;; (define keyvals '(("SYSTEM" "abc")("RELEASE" "def")))
-;; (define header (list "SYSTEM" "RELEASE" "id" "runname" "state" "status" "owner" "event_time"))
-;;
-;; ;; Setup
-;; ;;
-;; ;; (test #f #f (not (client:setup run-id)))
-;; ;; (test #f #f (not (hash-table-ref/default *runremote* run-id #f)))
-;;
-;; ;; Login
-;; ;;
-;; (test #f'(#t "successful login")
-;; (rmt:login run-id))
-;;
-;; ;; Keys
-;; ;;
-;; (test #f '("SYSTEM" "RELEASE") (rmt:get-keys))
-;;
-;; ;; No data in db
-;; ;;
-;; (test #f '() (rmt:get-all-run-ids))
-;; (test #f #f (rmt:get-run-name-from-id run-id))
-;; (test #f
-;; (vector
-;; header
-;; (vector #f #f #f #f))
-;; (rmt:get-run-info run-id))
-;;
-;; ;; Insert data into db
-;; ;;
-;; (test #f 1 (rmt:register-run keyvals runname "new" "n/a" user))
-;; ;; (test #f #f (rmt:get-runs-by-patt keys runname))
-;; (test #f #t (rmt:general-call 'register-test run-id run-id "test-one" ""))
-;; (define test-one-id #f)
-;; (test #f 1 (let ((test-id (rmt:get-test-id run-id "test-one" "")))
-;; (set! test-one-id test-id)
-;; test-id))
-;; (define test-one-rec #f)
-;; (test #f "test-one" (let ((test-rec (rmt:get-test-info-by-id run-id test-one-id)))
-;; (set! test-one-rec test-rec)
-;; (vector-ref test-rec 2)))
-;;
-;; ;; With data in db
-;; ;;
-;; (print "Using runame=" runname)
-;; (test #f '(1) (rmt:get-all-run-ids))
-;; (test #f runname (rmt:get-run-name-from-id run-id))
-;; (test #f
-;; runname
-;; (let ((run-info (rmt:get-run-info run-id)))
-;; (db:get-value-by-header (db:get-rows run-info)
-;; (db:get-header run-info)
-;; "runname")))
-;;
-;; ;; test killing server
-;; ;;
-;; (for-each
-;; (lambda (run-id)
-;; (test #f #t (and (tasks:kill-server-run-id run-id) #t))
-;; (test #f #f (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id)))
-;; (list 0 1))
-;;
-;; ;; Tests to assess reading/writing while servers are starting/stopping
-;; ;; NO LONGER APPLICABLE
-;;
-;; ;; Server tests go here
-;; (define (server-tests-dont-run-right-now)
-;; (for-each
-;; (lambda (run-id)
-;; (test #f #f (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id))
-;; (server:kind-run run-id)
-;; (test "did server start within 20 seconds?"
-;; #t
-;; (let loop ((remtries 20)
-;; (running (tasks:server-running-or-starting? (db:delay-if-busy
-;; (tasks:open-db))
-;; run-id)))
-;; (if running
-;; (> running 0)
-;; (if (> remtries 0)
-;; (begin
-;; (thread-sleep! 1)
-;; (loop (- remtries 1)
-;; (tasks:server-running-or-starting? (db:delay-if-busy
-;; (tasks:open-db))
-;; run-id)))))))
-;;
-;; (test "did server become available" #t
-;; (let loop ((remtries 10)
-;; (res (tasks:get-server (db:delay-if-busy (tasks:open-db)) run-id)))
-;; (if res
-;; (vector? res)
-;; (begin
-;; (if (> remtries 0)
-;; (begin
-;; (thread-sleep! 1.1)
-;; (loop (- remtries 1)(tasks:get-server (db:delay-if-busy (tasks:open-db)) run-id)))
-;; res)))))
-;; )
-;; (list 0 1)))
-;;
-;; (define start-time (current-seconds))
-;; (define (reading-writing-while-server-starting-stopping-dont-run-now)
-;; (let loop ((test-state 'start))
-;; (let* ((server-dats (tasks:get-server-records (db:delay-if-busy (tasks:open-db)) run-id))
-;; (first-dat (if (not (null? server-dats))
-;; (car server-dats)
-;; #f)))
-;; (map (lambda (dat)
-;; (apply print (intersperse (vector->list dat) ", ")))
-;; server-dats)
-;; (test #f test-one-rec (rmt:get-test-info-by-id run-id test-one-id))
-;; (thread-sleep! 1)
-;; (case test-state
-;; ((start)
-;; (print "Trying to start server")
-;; (server:kind-run run-id)
-;; (loop 'server-started))
-;; ((server-started)
-;; (case (if first-dat (vector-ref first-dat 0) 'blah)
-;; ((running)
-;; (print "Server appears to be running. Now ask it to shutdown")
-;; (rmt:kill-server run-id)
-;; (loop 'server-shutdown))
-;; ((shutting-down)
-;; (loop test-state))
-;; (else (print "Don't know what to do if get here"))))
-;; ((server-shutdown)
-;; (loop test-state)))))
-;; )
-
-;;======================================================================
-;; END OF TESTS
-;;======================================================================
-
-
-;; (test #f #f (client:setup run-id))
-
-;; (set! *transport-type* 'http)
-;;
-;; (test "setup for run" #t (begin (launch:setup-for-run)
-;; (string? (getenv "MT_RUN_AREA_HOME"))))
-;;
-;; (test "server-register, get-best-server" #t (let ((res #f))
-;; (open-run-close tasks:server-register tasks:open-db 1 "bob" 1234 100 'live 'http)
-;; (set! res (open-run-close tasks:get-best-server tasks:open-db))
-;; (number? (vector-ref res 3))))
-;;
-;; (test "de-register server" #f (let ((res #f))
-;; (open-run-close tasks:server-deregister tasks:open-db "bob" port: 1234)
-;; (vector? (open-run-close tasks:get-best-server tasks:open-db))))
-;;
-;; (define server-pid #f)
-;;
-;; ;; Not sure how the following should work, replacing it with system of megatest -server
-;; ;; (test "launch server" #t (let ((pid (process-fork (lambda ()
-;; ;; ;; (daemon:ize)
-;; ;; (server:launch 'http)))))
-;; ;; (set! server-pid pid)
-;; ;; (number? pid)))
-;; (system "../../bin/megatest -server - -debugbcom 22 > server.log 2> server.log &")
-;;
-;; (let loop ((n 10))
-;; (thread-sleep! 1) ;; need to wait for server to start.
-;; (let ((res (open-run-close tasks:get-best-server tasks:open-db)))
-;; (print "tasks:get-best-server returned " res)
-;; (if (and (not res)
-;; (> n 0))
-;; (loop (- n 1)))))
-;;
-;; (test "get-best-server" #t (begin
-;; (client:launch)
-;; (let ((dat (open-run-close tasks:get-best-server tasks:open-db)))
-;; (vector? dat))))
-;;
-;; (define *keys* (keys:config-get-fields *configdat*))
-;; (define *keyvals* (keys:target->keyval *keys* "a/b/c"))
-;;
-;; (test #f #t (string? (car *runremote*)))
-;; (test #f '(#t "successful login") (rmt:login)) ;; *runremote* *toppath* *my-client-signature*)))
-;;
-;; (test #f #f (rmt:get-test-info-by-id 99)) ;; get non-existant test
-;;
-;; ;; RUNS
-;; (test #f 1 (rmt:register-run *keyvals* "firstrun" "new" "n/a" (current-user-name)))
-;; (test "get run info" "firstrun" (let ((rinfo (rmt:get-run-info 1)))
-;; (vector-ref (vector-ref rinfo 1) 3)))
-;; (test "get runname from id" "firstrun" (rmt:get-run-name-from-id 1))
-;;
-;; ;; TESTS
-;; (test "get tests (no data)" '() (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f))
-;; (test "register test" #t (rmt:general-call 'register-test 1 "test1" ""))
-;; (test "get tests (some data)" 1 (length (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f)))
-;; (test "get test id" 1 (rmt:get-test-id 1 "test1" ""))
-;; (test "sync back" #t (> (rmt:sync-inmem->db) 0))
-;; (test "get test id from main" 1 (db:get-test-id *db* 1 "test1" ""))
-;; (test "get keys" #t (list? (rmt:get-keys)))
-;; (test "set comment" #t (begin (rmt:general-call 'set-test-comment "this is a comment" 1) #t))
-;; (test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 1)))
-;; (db:test-get-comment trec)))
-;;
-;; ;; MORE RUNS
-;; (test "get runs" #t (let* ((runs (rmt:get-runs "%" #f #f '()))
-;; (header (vector-ref runs 0))
-;; (data (vector-ref runs 1)))
-;; (and (list? header)
-;; (list? data)
-;; (vector? (car data)))))
-;;
-;; (test "get local testinfo" "test1" (vector-ref (db:get-testinfo-state-status *db* 1) 2))
-;; (test "get testinfo" "test1" (vector-ref (rmt:get-testinfo-state-status 1) 2))
-;;
-;; ;;======================================================================
-;; ;; D B
-;; ;;======================================================================
-;;
-;; (test "pass fail counts" #t (rmt:general-call 'pass-fail-counts 10 9 1))
-;; (test "get pass fail counts" 19 (let ((dat (rmt:get-test-info-by-id 1)))
-;; (+ (db:test-get-pass_count dat)
-;; (db:test-get-fail_count dat))))
-;;
-;; (define testregistry (make-hash-table))
-;; (for-each
-;; (lambda (tname)
-;; (for-each
-;; (lambda (itempath)
-;; (let ((tkey (conc tname "/" itempath))
-;; (rpass (random 10))
-;; (rfail (random 10)))
-;; (hash-table-set! testregistry tkey (list tname itempath))
-;; (rmt:general-call 'register-test 1 tname itempath)
-;; (let* ((tid (rmt:get-test-id 1 tname itempath))
-;; (tdat (rmt:get-test-info-by-id tid)))
-;; (rmt:general-call 'pass-fail-counts rpass rfail (db:test-get-id tdat))
-;; (let* ((resdat (rmt:get-test-info-by-id tid)))
-;; (test "set/get pass fail counts" (list rpass rfail)
-;; (list (db:test-get-pass_count resdat)
-;; (db:test-get-fail_count resdat)))))))
-;; (list "" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j")))
-;; (list "test1" "test2" "test3" "test4" "test5"))
-;;
-;;
-;; (test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f)))
-;;
+
+(test #f 1 (rmt:send-receive 'register-run 1 (list keyvals "run1" "new" "n/a" "justme" #f)))
+
+(test #f 2 (rmt:register-run keyvals "run2" "new" "n/a" "justme" #f))
+;; (test #f 2 (rmt:deregister-server *rmt:remote* *toppath* iface port server-key dbname
+
+(test #f 2 (rmt:get-count-servers *rmt:remote* *toppath*))
+
+(test #f "run2" (rmt:get-run-name-from-id 2))
;; (exit)
-
-;; all old stuff below
-
-
-
-
-(delete-file* "logs/1.log")
-(define run-id 1)
-
-(test "setup for run" #t (begin (launch:setup-for-run)
- (string? (getenv "MT_RUN_AREA_HOME"))))
-
-;; Insert data into db
-;;
-(define user (current-user-name))
-(define runname "mytestrun")
-(define keys (rmt:get-keys))
-(define runinfo #f)
-(define keyvals '(("SYSTEM" "abc")("RELEASE" "def")))
-(define header (list "SYSTEM" "RELEASE" "id" "runname" "state" "status" "owner" "event_time"))
-
-(test #f 1 (rmt:register-run keyvals runname "new" "n/a" user))
-;; (test #f #f (rmt:get-runs-by-patt keys runname))
-(test #f #t (rmt:general-call 'register-test run-id run-id "test-one" ""))
-(define test-one-id #f)
-(test #f 30001 (let ((test-id (rmt:get-test-id run-id "test-one" "")))
- (set! test-one-id test-id)
- test-id))
-(define test-one-rec #f)
-(test #f "test-one" (let ((test-rec (rmt:get-test-info-by-id run-id test-one-id)))
- (set! test-one-rec test-rec)
- (vector-ref test-rec 2)))
-
-(use trace)
-(import trace)
-;; (trace
-;; rmt:send-receive
-;; rmt:open-qry-close-locally
-;; )
-
-;; Tests to assess reading/writing while servers are starting/stopping
-(define start-time (current-seconds))
-(let loop ((test-state 'start))
- (let* ((server-dats (tasks:get-server-records (db:delay-if-busy (tasks:open-db)) run-id))
- (first-dat (if (not (null? server-dats))
- (car server-dats)
- #f))
- (server-state (or (and first-dat (string->symbol (vector-ref first-dat 8))) 'no-dat)))
- (if first-dat
- (map (lambda (dat)
- (apply print (intersperse (vector->list dat) ", ")))
- server-dats)
- (print "No server"))
- (test #f test-one-rec (rmt:get-test-info-by-id run-id test-one-id))
- (thread-sleep! 1)
- (case test-state
- ((start)
- (print "Trying to start server")
- (server:kind-run run-id)
- (loop 'server-started))
- ((server-started)
- (case server-state
- ((running)
- (print "Server appears to be running. Now ask it to shutdown")
- (rmt:kill-server run-id)
- ;; (trace rmt:open-qry-close-locally rmt:send-receive)
- (loop 'shutdown-started))
- ((available)
- (loop test-state))
- ((shutting-down)
- (loop test-state))
- ((no-dat)
- (loop test-state))
- (else (print "Don't know what to do if get here"))))
- ((shutdown-started)
- (case server-state
- ((no-dat)
- (print "Server appears to have shutdown, ending this test"))
- (else
- (loop test-state)))))))
-
-(exit)
-
-;; (set! *transport-type* 'http)
-;;
-;; (test "setup for run" #t (begin (setup-for-run)
-;; (string? (getenv "MT_RUN_AREA_HOME"))))
-;;
-;; (test "server-register, get-best-server" #t (let ((res #f))
-;; (open-run-close tasks:server-register tasks:open-db 1 "bob" 1234 100 'live 'http)
-;; (set! res (open-run-close tasks:get-best-server tasks:open-db))
-;; (number? (vector-ref res 3))))
-;;
-;; (test "de-register server" #f (let ((res #f))
-;; (open-run-close tasks:server-deregister tasks:open-db "bob" port: 1234)
-;; (vector? (open-run-close tasks:get-best-server tasks:open-db))))
-;;
-;; (define server-pid #f)
-;;
-;; ;; Not sure how the following should work, replacing it with system of megatest -server
-;; ;; (test "launch server" #t (let ((pid (process-fork (lambda ()
-;; ;; ;; (daemon:ize)
-;; ;; (server:launch 'http)))))
-;; ;; (set! server-pid pid)
-;; ;; (number? pid)))
-;; (system "../../bin/megatest -server - -debug 22 > server.log 2> server.log &")
-;;
-;; (let loop ((n 10))
-;; (thread-sleep! 1) ;; need to wait for server to start.
-;; (let ((res (open-run-close tasks:get-best-server tasks:open-db)))
-;; (print "tasks:get-best-server returned " res)
-;; (if (and (not res)
-;; (> n 0))
-;; (loop (- n 1)))))
-;;
-;; (test "get-best-server" #t (begin
-;; (client:launch)
-;; (let ((dat (open-run-close tasks:get-best-server tasks:open-db)))
-;; (vector? dat))))
-;;
-;; (define *keys* (keys:config-get-fields *configdat*))
-;; (define *keyvals* (keys:target->keyval *keys* "a/b/c"))
-;;
-;; (test #f #t (string? (car *runremote*)))
-;; (test #f '(#t "successful login") (rmt:login)) ;; *runremote* *toppath* *my-client-signature*)))
-;;
-;; (test #f #f (rmt:get-test-info-by-id 1 99)) ;; get non-existant test
-;;
-;; ;; RUNS
-;; (test #f 1 (rmt:register-run *keyvals* "firstrun" "new" "n/a" (current-user-name)))
-;; (test "get run info" "firstrun" (let ((rinfo (rmt:get-run-info 1)))
-;; (vector-ref (vector-ref rinfo 1) 3)))
-;; (test "get runname from id" "firstrun" (rmt:get-run-name-from-id 1))
-;;
-;; ;; TESTS
-;; (test "get tests (no data)" '() (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f))
-;; (test "register test" #t (rmt:general-call 'register-test 1 1 "test1" ""))
-;; (test "get tests (some data)" 1 (length (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f)))
-;; (test "get test id" 1 (rmt:get-test-id 1 "test1" ""))
-;;
-;; (test "sync back" #t (> (rmt:sync-inmem->db) 0))
-;; (test "get test id from main" 1 (db:get-test-id *db* 1 "test1" ""))
-;;
-;; (test "get keys" #t (list? (rmt:get-keys)))
-;; (test "set comment" #t (begin (rmt:general-call 'set-test-comment 1 "this is a comment" 1) #t))
-;; (test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 1 1)))
-;; (db:test-get-comment trec)))
-;;
-;; ;; MORE RUNS
-;; (test "get runs" #t (let* ((runs (rmt:get-runs "%" #f #f '()))
-;; (header (vector-ref runs 0))
-;; (data (vector-ref runs 1)))
-;; (and (list? header)
-;; (list? data)
-;; (vector? (car data)))))
-;;
-;; (test "get local testinfo" "test1" (vector-ref (db:get-testinfo-state-status *db* 1 1) 2))
-;; (test "get testinfo" "test1" (vector-ref (rmt:get-testinfo-state-status 1 1) 2))
-;;
-;; ;;======================================================================
-;; ;; D B
-;; ;;======================================================================
-;;
-;; (test "pass fail counts" #t (rmt:general-call 'pass-fail-counts 10 9 1))
-;; (test "get pass fail counts" 19 (let ((dat (rmt:get-test-info-by-id 1)))
-;; (+ (db:test-get-pass_count dat)
-;; (db:test-get-fail_count dat))))
-;;
-;; (define testregistry (make-hash-table))
-;; (for-each
-;; (lambda (tname)
-;; (for-each
-;; (lambda (itempath)
-;; (let ((tkey (conc tname "/" itempath))
-;; (rpass (random 10))
-;; (rfail (random 10)))
-;; (hash-table-set! testregistry tkey (list tname itempath))
-;; (rmt:general-call 'register-test 1 tname itempath)
-;; (let* ((tid (rmt:get-test-id 1 tname itempath))
-;; (tdat (rmt:get-test-info-by-id tid)))
-;; (rmt:general-call 'pass-fail-counts rpass rfail (db:test-get-id tdat))
-;; (let* ((resdat (rmt:get-test-info-by-id tid)))
-;; (test "set/get pass fail counts" (list rpass rfail)
-;; (list (db:test-get-pass_count resdat)
-;; (db:test-get-fail_count resdat)))))))
-;; (list "" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j")))
-;; (list "test1" "test2" "test3" "test4" "test5"))
-;;
-;;
-;; (test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f)))
-;;
Index: testsmod.scm
==================================================================
--- testsmod.scm
+++ testsmod.scm
@@ -113,10 +113,43 @@
(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"))
)
+
+;; pulled from commonmod
+;;
+
+;; return items given config
+;;
+(define (tests:get-items tconfig)
+ (let ((items (hash-table-ref/default tconfig "items" #f)) ;; items 4
+ (itemstable (hash-table-ref/default tconfig "itemstable" #f)))
+ ;; if either items or items table is a proc return it so test running
+ ;; process can know to call items:get-items-from-config
+ ;; if either is a list and none is a proc go ahead and call get-items
+ ;; otherwise return #f - this is not an iterated test
+ (cond
+ ((procedure? items)
+ (debug:print-info 4 *default-log-port* "items is a procedure, will calc later")
+ items) ;; calc later
+ ((procedure? itemstable)
+ (debug:print-info 4 *default-log-port* "itemstable is a procedure, will calc later")
+ itemstable) ;; calc later
+ ((filter (lambda (x)
+ (let ((val (car x)))
+ (if (procedure? val) val #f)))
+ (append (if (list? items) items '())
+ (if (list? itemstable) itemstable '())))
+ 'have-procedure)
+ ((or (list? items)(list? itemstable)) ;; calc now
+ (debug:print-info 4 *default-log-port* "items and itemstable are lists, calc now\n"
+ " items: " items " itemstable: " itemstable)
+ (items:get-items-from-config tconfig))
+ (else #f)))) ;; not iterated
+
+
;; Call this one to do all the work and get a standardized list of tests
;; gets paths from configs and finds valid tests
;; returns hash of testname --> fullpath
;;
@@ -411,11 +444,11 @@
;; This was run remote, don't think that makes sense. Perhaps not, but that is the easiest path for the moment.
(rmt:csv->test-data run-id test-id
dat)
;; This was added in check-in a5adfa3f9a. Message was: "...added delay in set-values to allow for delayed write on server start"
;; I'm inserting an arbitrary rmt: call to force/ensure that the server is available to (hopefully) prevent a communication issue.
- (rmt:get-var "MEGATEST_VERSION") ;; this does NOTHING but ensure the server is reachable. This is almost certainly NOT needed :)
+ ;; (rmt:get-var "MEGATEST_VERSION") ;; this does NOTHING but ensure the server is reachable. This is almost certainly NOT needed :)
;; BB - commentiong out arbitrary 10 second wait (thread-sleep! 10) ;; add 10 second delay before quit incase rmt needs time to start a server.
)))
;; need to update the top test record if PASS or FAIL and this is a subtest
;;;;;; (if (not (equal? item-path ""))
@@ -996,22 +1029,22 @@
;; (map (lambda (testp)
;; (last (string-split testp "/")))
;; tests)))))
(define (tests:get-test-path-from-environment)
- (if (and (getenv "MT_LINKTREE")
- (getenv "MT_TARGET")
- (getenv "MT_RUNNAME")
- (getenv "MT_TEST_NAME")
- (getenv "MT_ITEMPATH"))
- (conc (getenv "MT_LINKTREE") "/"
- (getenv "MT_TARGET") "/"
- (getenv "MT_RUNNAME") "/"
- (getenv "MT_TEST_NAME")
- (if (and (getenv "MT_ITEMPATH")
- (not (string=? "" (getenv "MT_ITEMPATH"))))
- (conc "/" (getenv "MT_ITEMPATH"))
+ (if (and (get-environment-variable "MT_LINKTREE")
+ (get-environment-variable "MT_TARGET")
+ (get-environment-variable "MT_RUNNAME")
+ (get-environment-variable "MT_TEST_NAME")
+ (get-environment-variable "MT_ITEMPATH"))
+ (conc (get-environment-variable "MT_LINKTREE") "/"
+ (get-environment-variable "MT_TARGET") "/"
+ (get-environment-variable "MT_RUNNAME") "/"
+ (get-environment-variable "MT_TEST_NAME")
+ (if (and (get-environment-variable "MT_ITEMPATH")
+ (not (string=? "" (get-environment-variable "MT_ITEMPATH"))))
+ (conc "/" (get-environment-variable "MT_ITEMPATH"))
""))
#f))
;; if .testconfig exists in test directory read and return it
;; else if have cached copy in *testconfigs* return it IFF there is a section "have fulldata"
@@ -1046,13 +1079,13 @@
dat
;; no cached data available
(let* ((treg (or test-registry
(tests:get-all)))
(test-path (or (hash-table-ref/default treg test-name #f)
- (let* ((local-tcdir (conc (getenv "MT_LINKTREE") "/"
- (getenv "MT_TARGET") "/"
- (getenv "MT_RUNNAME") "/"
+ (let* ((local-tcdir (conc (get-environment-variable "MT_LINKTREE") "/"
+ (get-environment-variable "MT_TARGET") "/"
+ (get-environment-variable "MT_RUNNAME") "/"
test-name "/" item-path))
(local-tcfg (conc local-tcdir "/testconfig")))
(if (common:file-exists? local-tcfg)
local-tcdir
#f))
Index: tree.scm
==================================================================
--- tree.scm
+++ tree.scm
@@ -16,32 +16,50 @@
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
;;======================================================================
-(use format)
-(require-library iup)
-(import (prefix iup iup:))
-(use canvas-draw)
-
-(use sqlite3 srfi-1 posix regex regex-case srfi-69)
-(import (prefix sqlite3 sqlite3:))
-
(declare (unit tree))
-(declare (uses margs))
-(declare (uses launch))
-;; (declare (uses megatest-version))
-(declare (uses gutils))
-(declare (uses db))
-(declare (uses server))
-;; (declare (uses synchash))
-(declare (uses dcommon))
-
-(include "megatest-version.scm")
-(include "common_records.scm")
-(include "db_records.scm")
-(include "key_records.scm")
+;; (declare (uses mtargs))
+;; (declare (uses mtver))
+;; (declare (uses launchmod))
+;; ;; (declare (uses megatest-version))
+;; ;; (declare (uses gutils))
+;; (declare (uses dbmod))
+;; (declare (uses servermod))
+;; ;; (declare (uses synchash))
+;; (declare (uses dcommon))
+
+(module tree
+ *
+
+(import scheme
+ chicken.base
+ chicken.string
+ chicken.file.posix
+ )
+
+(import format
+ srfi-13
+ (prefix iup iup:)
+ canvas-draw
+ sqlite3
+ srfi-1
+ regex regex-case srfi-69
+ (prefix sqlite3 sqlite3:))
+
+;; (import mtver
+;; launchmod
+;; dbmod
+;; servermod
+;; gutils
+;; )
+
+;; (include "megatest-version.scm")
+;; (include "common_records.scm")
+;; (include "db_records.scm")
+;; (include "key_records.scm")
;;======================================================================
;; T R E E S T U F F
;;======================================================================
@@ -153,5 +171,7 @@
(dboard:data-curr-run-id-set! data run-id)
(dashboard:update-run-summary-tab)))
;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
))))
|#
+
+)
DELETED vg.scm
Index: vg.scm
==================================================================
--- vg.scm
+++ /dev/null
@@ -1,674 +0,0 @@
-;;
-;; Copyright 2016 Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see .
-
-;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
-
-(use typed-records srfi-1)
-
-(declare (unit vg))
-(use canvas-draw iup)
-(import canvas-draw-iup)
-
-(include "vg_records.scm")
-
-;;======================================================================
-;; IDEA
-;;
-;; make it possible to instantiate a vg drawing inside a vg drawing
-;;
-;;======================================================================
-
-;; ;; structs
-;; ;;
-;; (defstruct vg:lib comps)
-;; (defstruct vg:comp objs name file)
-;; ;; extents caches extents calculated on draw
-;; ;; proc is called on draw and takes the obj itself as a parameter
-;; ;; attrib is an alist of parameters
-;; (defstruct vg:obj type pts fill-color text line-color call-back angle font attrib extents proc)
-;; (defstruct vg:inst libname compname theta xoff yoff scalex scaley mirrx mirry call-back cache)
-;; (defstruct vg:drawing libs insts scalex scaley xoff yoff cnv cache)
-;; ;; libs: hash of name->lib, insts: hash of instname->inst
-
-;; inits
-;;
-(define (vg:comp-new)
- (make-vg:comp objs: '() name: #f file: #f))
-
-(define (vg:lib-new)
- (make-vg:lib comps: (make-hash-table)))
-
-(define (vg:drawing-new)
- (make-vg:drawing scalex: 1
- scaley: 1
- xoff: 0
- yoff: 0
- libs: (make-hash-table)
- insts: (make-hash-table)
- cache: '()))
-
-;;======================================================================
-;; scaling and offsets
-;;======================================================================
-
-(define-inline (vg:scale-offset val s o)
- (+ o (* val s)))
- ;; (* (+ o val) s))
-
-;; apply scale and offset to a list of x y values
-;;
-(define (vg:scale-offset-xy lstxy sx sy ox oy)
- (if (> (length lstxy) 1) ;; have at least one xy pair
- (let loop ((x (car lstxy))
- (y (cadr lstxy))
- (tal (cddr lstxy))
- (res '()))
- (let ((newres (cons (vg:scale-offset y sy oy)
- (cons (vg:scale-offset x sx ox)
- res))))
- (if (> (length tal) 1)
- (loop (car tal)(cadr tal)(cddr tal) newres)
- (reverse newres))))
- '()))
-
-;; apply drawing offset and scaling to the points in lstxy
-;;
-(define (vg:drawing-apply-scale drawing lstxy)
- (vg:scale-offset-xy
- lstxy
- (vg:drawing-scalex drawing)
- (vg:drawing-scaley drawing)
- (vg:drawing-xoff drawing)
- (vg:drawing-yoff drawing)))
-
-;; apply instance offset and scaling to the points in lstxy
-;;
-(define (vg:inst-apply-scale inst lstxy)
- (vg:scale-offset-xy
- lstxy
- (vg:inst-scalex inst)
- (vg:inst-scaley inst)
- (vg:inst-xoff inst)
- (vg:inst-yoff inst)))
-
-;; apply both drawing and instance scaling to a list of xy points
-;;
-(define (vg:drawing-inst-apply-scale-offset drawing inst lstxy)
- (vg:drawing-apply-scale
- drawing
- (vg:inst-apply-scale inst lstxy)))
-
-;;======================================================================
-;; objects
-;;======================================================================
-
-;; (vg:inst-apply-scale
-;; inst
-;; (vg:drawing-apply-scale drawing lstxy)))
-
-;; make a rectangle obj
-;;
-(define (vg:make-rect-obj x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)(text #f)(font #f)(extents #f))
- (make-vg:obj type: 'r pts: (list x1 y1 x2 y2) text: text font: font line-color: line-color fill-color: fill-color extents: extents))
-
-;; make a rectangle obj
-;;
-(define (vg:make-line-obj x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)(text #f)(font #f)(extents #f))
- (make-vg:obj type: 'l pts: (list x1 y1 x2 y2) text: text font: font line-color: line-color extents: extents))
-
-;; make a text obj
-;;
-(define (vg:make-text-obj x1 y1 text #!key (line-color #f)(fill-color #f)
- (angle #f)(scale-with-zoom #f)(font #f)
- (font-size #f))
- (make-vg:obj type: 't pts: (list x1 y1) text: text
- line-color: line-color fill-color: fill-color
- angle: angle font: font extents: #f
- attributes: (vg:make-attrib 'font-size font-size)))
-
-;; proc takes startnum and endnum and yields scalef, per-grad and unitname
-;;
-(define (vg:make-xaxis-obj x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)(text #f)(font #f)(proc #f))
- (make-vg:obj type: 'x pts: (list x1 y1 x2 y2) text: text font: font line-color: line-color fill-color: fill-color extents: #f proc: proc))
-
-;;======================================================================
-;; obj modifiers and queries
-;;======================================================================
-
-;; get extents, use knowledge of type ...
-;;
-(define (vg:obj-get-extents drawing obj)
- (let ((type (vg:obj-type obj)))
- (case type
- ((l)(vg:rect-get-extents obj))
- ((r)(vg:rect-get-extents obj))
- ((t)(vg:draw-text drawing obj draw: #f))
- (else #f))))
-
-(define (vg:rect-get-extents obj)
- (vg:obj-pts obj)) ;; extents are just the points for a rectangle
-
-(define (vg:grow-rect borderx bordery x1 y1 x2 y2)
- (list
- (- x1 borderx)
- (- y1 bordery)
- (+ x2 borderx)
- (+ y2 bordery)))
-
-(define (vg:make-attrib . attrib-list)
- #f)
-
-;;======================================================================
-;; components
-;;======================================================================
-
-;; add obj to comp
-;;
-(define (vg:add-objs-to-comp comp . objs)
- (vg:comp-objs-set! comp (append (vg:comp-objs comp) objs)))
-
-(define (vg:add-obj-to-comp comp obj)
- (vg:comp-objs-set! comp (cons obj (vg:comp-objs comp))))
-
-;; use the struct. leave this here to remind of this!
-;;
-;; (define (vg:comp-get-objs comp)
-;; (vg:comp-objs comp))
-
-;; add comp to lib
-;;
-(define (vg:add-comp-to-lib lib compname comp)
- (hash-table-set! (vg:lib-comps lib) compname comp))
-
-;; instanciate component in drawing
-;;
-(define (vg:instantiate drawing libname compname instname xoff yoff #!key (theta 0)(scalex 1)(scaley 1)(mirrx #f)(mirry #f))
- (let ((inst (make-vg:inst libname: libname compname: compname xoff: xoff yoff: yoff theta: theta scalex: scalex scaley: scaley mirrx: mirrx mirry: mirry)) )
- (hash-table-set! (vg:drawing-insts drawing) instname inst)))
-
-(define (vg:instance-move drawing instname newx newy)
- (let ((inst (hash-table-ref (vg:drawing-insts drawing) instname)))
- (vg:inst-xoff-set! inst newx)
- (vg:inst-yoff-set! inst newy)))
-
-;; get component from drawing (look in apropriate lib) given libname and compname
-(define (vg:get-component drawing libname compname)
- (let* ((lib (hash-table-ref (vg:drawing-libs drawing) libname))
- (inst (hash-table-ref (vg:lib-comps lib) compname)))
- inst))
-
-(define (vg:get-extents-for-objs drawing objs)
- (if (or (not objs)
- (null? objs))
- #f
- (let loop ((hed (car objs))
- (tal (cdr objs))
- (extents (vg:obj-get-extents drawing (car objs))))
- (let ((newextents
- (vg:get-extents-for-two-rects
- extents
- (vg:obj-get-extents drawing hed))))
- (if (null? tal)
- extents
- (loop (car tal)(cdr tal) newextents))))))
-
-;; (let ((extents #f))
-;; (for-each
-;; (lambda (obj)
-;; (set! extents
-;; (vg:get-extents-for-two-rects
-;; extents
-;; (vg:obj-get-extents drawing obj))))
-;; objs)
-;; extents))
-
-;; given rectangles r1 and r2, return the box that bounds both
-;;
-(define (vg:get-extents-for-two-rects r1 r2)
- (if (not r1)
- r2
- (if (not r2)
- r1 ;; #f ;; no extents from #f #f
- (list (min (car r1)(car r2)) ;; llx
- (min (cadr r1)(cadr r2)) ;; lly
- (max (caddr r1)(caddr r2)) ;; ulx
- (max (cadddr r1)(cadddr r2)))))) ;; uly
-
-(define (vg:components-get-extents drawing . comps)
- (if (null? comps)
- #f
- (let loop ((hed (car comps))
- (tal (cdr comps))
- (extents #f))
- (let* ((objs (vg:comp-objs hed))
- (newextents (if extents
- (vg:get-extents-for-two-rects
- extents
- (vg:get-extents-for-objs drawing objs))
- (vg:get-extents-for-objs drawing objs))))
- (if (null? tal)
- newextents
- (loop (car tal)(cdr tal) newextents))))))
-
-;;======================================================================
-;; libraries
-;;======================================================================
-
-;; register lib with drawing
-
-;;
-(define (vg:add-lib drawing libname lib)
- (hash-table-set! (vg:drawing-libs drawing) libname lib))
-
-(define (vg:get-lib drawing libname)
- (hash-table-ref/default (vg:drawing-libs drawing) libname #f))
-
-(define (vg:get/create-lib drawing libname)
- (let ((lib (vg:get-lib drawing libname)))
- (if lib
- lib
- (let ((newlib (vg:lib-new)))
- (vg:add-lib drawing libname newlib)
- newlib))))
-
-;;======================================================================
-;; map objects given offset, scale and mirror, resulting obj is displayed
-;;======================================================================
-
-;; dispatch the drawing of obj off to the correct drawing routine
-;;
-(define (vg:map-obj drawing inst obj)
- (case (vg:obj-type obj)
- ((l)(vg:map-line drawing inst obj))
- ((r)(vg:map-rect drawing inst obj))
- ((t)(vg:map-text drawing inst obj))
- ((x)(vg:map-xaxis drawing inst obj))
- (else #f)))
-
-;; given a drawing and a inst map a rectangle to it screen coordinates
-;;
-(define (vg:map-rect drawing inst obj)
- (let ((res (make-vg:obj type: 'r ;; is there a defstruct copy?
- fill-color: (vg:obj-fill-color obj)
- text: (vg:obj-text obj)
- line-color: (vg:obj-line-color obj)
- font: (vg:obj-font obj)))
- (pts (vg:obj-pts obj)))
- (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts))
- (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing) ))
- res))
-
-;; given a drawing and a inst map a line to it screen coordinates
-;;
-(define (vg:map-line drawing inst obj)
- (let ((res (make-vg:obj type: 'l ;; is there a defstruct copy?
- line-color: (vg:obj-line-color obj)
- font: (vg:obj-font obj)))
- (pts (vg:obj-pts obj)))
- (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts))
- (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing) ))
- res))
-
-;; given a drawing and a inst map a text to it screen coordinates
-;;
-(define (vg:map-text drawing inst obj)
- (let ((res (make-vg:obj type: 't
- fill-color: (vg:obj-fill-color obj)
- text: (vg:obj-text obj)
- line-color: (vg:obj-line-color obj)
- font: (vg:obj-font obj)
- angle: (vg:obj-angle obj)
- attrib: (vg:obj-attrib obj)))
- (pts (vg:obj-pts obj)))
- (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts))
- (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing)))
- res))
-
-;; given a drawing and a inst map a line to it screen coordinates
-;;
-(define (vg:map-xaxis drawing inst obj)
- (let ((res (make-vg:obj type: 'x ;; is there a defstruct copy?
- line-color: (vg:obj-line-color obj)
- font: (vg:obj-font obj)))
- (pts (vg:obj-pts obj)))
- (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts))
- (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing) ))
- res))
-
-;;======================================================================
-;; instances
-;;======================================================================
-
-(define (vg:instances-get-extents drawing . instance-names)
- (let ((xtnt-lst (vg:draw drawing #f)))
- (if (null? xtnt-lst)
- #f
- (let loop ((extents (car xtnt-lst))
- (tal (cdr xtnt-lst))
- (llx #f)
- (lly #f)
- (ulx #f)
- (uly #f))
- (let ((nllx (if llx (min llx (list-ref extents 0))(list-ref extents 0)))
- (nlly (if lly (min lly (list-ref extents 1))(list-ref extents 1)))
- (nulx (if ulx (max ulx (list-ref extents 2))(list-ref extents 2)))
- (nuly (if uly (max uly (list-ref extents 3))(list-ref extents 3))))
- (if (null? tal)
- (list llx lly ulx uly)
- (loop (car tal)(cdr tal) nllx nlly nulx nuly)))))))
-
-(define (vg:lib-get-component lib instname)
- (hash-table-ref/default (vg:lib-comps lib) instname #f))
-
-;;======================================================================
-;; color
-;;======================================================================
-
-(define (vg:rgb->number r g b #!key (a 0))
- (bitwise-ior
- (arithmetic-shift a 24)
- (arithmetic-shift r 16)
- (arithmetic-shift g 8)
- b))
-
-;; Obsolete function
-;;
-(define (vg:generate-color)
- (vg:rgb->number (pseudo-random-integer 255)
- (pseudo-random-integer 255)
- (pseudo-random-integer 255)))
-
-;; Need to return a string of random iup-color for graph
-;;
-(define (vg:generate-color-rgb)
- (conc (number->string (pseudo-random-integer 255)) " "
- (number->string (pseudo-random-integer 255)) " "
- (number->string (pseudo-random-integer 255))))
-
-(define (vg:iup-color->number iup-color)
- (apply vg:rgb->number (map string->number (string-split iup-color))))
-
-;;======================================================================
-;; graphing
-;;======================================================================
-
-(define (vg:make-xaxis drawing component x1 y1 x2 y2 startnum endnum scaleproc)
- (let ((obj (vg:make-xaxis-obj x1 y1 x2 y2)))
- #f))
-
-;;======================================================================
-;; Unravel and draw the objects
-;;======================================================================
-
-;; with get-extents = #t return the extents
-;; with draw = #f don't actually draw the object
-;;
-(define (vg:draw-obj drawing obj #!key (draw #t))
- ;; (print "obj type: " (vg:obj-type obj))
- (case (vg:obj-type obj)
- ((l)(vg:draw-line drawing obj draw: draw))
- ((r)(vg:draw-rect drawing obj draw: draw))
- ((t)(vg:draw-text drawing obj draw: draw))))
-
-;; given a rect obj draw it on the canvas applying first the drawing
-;; scale and offset
-;;
-(define (vg:draw-rect drawing obj #!key (draw #t))
- (let* ((cnv (vg:drawing-cnv drawing))
- (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj)))
- (fill-color (vg:obj-fill-color obj))
- (line-color (vg:obj-line-color obj))
- (text (vg:obj-text obj))
- (font (vg:obj-font obj))
- (llx (car pts))
- (lly (cadr pts))
- (ulx (caddr pts))
- (uly (cadddr pts))
- (w (- ulx llx))
- (h (- uly lly))
- (text-xmax #f)
- (text-ymax #f))
- (if draw
- (let ((prev-background-color (canvas-background cnv))
- (prev-foreground-color (canvas-foreground cnv)))
- (if fill-color
- (begin
- (canvas-foreground-set! cnv fill-color)
- (canvas-box! cnv llx ulx lly uly))) ;; docs are all over the place on this one.;; w h)
- (if line-color
- (canvas-foreground-set! cnv line-color)
- (if fill-color
- (canvas-foreground-set! cnv prev-foreground-color)))
- (canvas-rectangle! cnv llx ulx lly uly)
- (canvas-foreground-set! cnv prev-foreground-color)
- (if text
- (let* ((prev-font (canvas-font cnv))
- (font-changed (and font (not (equal? font prev-font)))))
- (if font-changed (canvas-font-set! cnv font))
- (canvas-text! cnv (+ 2 llx)(+ 2 lly) text)
- (if (eq? draw 'get-extents)
- (let-values (((xmax ymax)(canvas-text-size cnv text)))
- (set! text-xmax xmax)(set! text-ymax ymax)))
- (if font-changed (canvas-font-set! cnv prev-font))))))
- ;; (print "text-xmax: " text-xmax " text-ymax: " text-ymax)
- (if (vg:obj-extents obj)
- (vg:obj-extents obj)
- (if (not text)
- pts ;; no text
- (if (and text-xmax text-ymax) ;; have text
- (let ((xt (list llx lly
- (max ulx (+ llx text-xmax))
- (max uly (+ lly text-ymax)))))
- (vg:obj-extents-set! obj xt)
- xt)
- (if cnv
- (if (eq? draw 'get-extents)
- (let-values (((xmax ymax)(canvas-text-size cnv text)))
- (let ((xt (list llx lly
- (max ulx (+ llx xmax))
- (max uly (+ lly ymax)))))
- (vg:obj-extents-set! obj xt)
- xt))
- pts)
- pts)))))) ;; return extents
-
-;; given a rect obj draw it on the canvas applying first the drawing
-;; scale and offset
-;;
-(define (vg:draw-line drawing obj #!key (draw #t))
- (let* ((cnv (vg:drawing-cnv drawing))
- (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj)))
- ;; (fill-color (vg:obj-fill-color obj))
- (line-color (vg:obj-line-color obj))
- (text (vg:obj-text obj))
- (font (vg:obj-font obj))
- (llx (car pts))
- (lly (cadr pts))
- (ulx (caddr pts))
- (uly (cadddr pts))
- (w (- ulx llx))
- (h (- uly lly))
- (text-xmax #f)
- (text-ymax #f))
- (if draw
- (let ((prev-background-color (canvas-background cnv))
- (prev-foreground-color (canvas-foreground cnv)))
- ;; (if fill-color
- ;; (begin
- ;; (canvas-foreground-set! cnv fill-color)
- ;; (canvas-box! cnv llx ulx lly uly))) ;; docs are all over the place on this one.;; w h)
- (if line-color
- (canvas-foreground-set! cnv line-color))
- ;; (if fill-color
- ;; (canvas-foreground-set! cnv prev-foreground-color)))
- (canvas-line! cnv llx lly ulx uly)
- (canvas-foreground-set! cnv prev-foreground-color)
- (if text
- (let* ((prev-font (canvas-font cnv))
- (font-changed (and font (not (equal? font prev-font)))))
- (if font-changed (canvas-font-set! cnv font))
- (canvas-text! cnv (+ 2 llx)(+ 2 lly) text)
- (let-values (((xmax ymax)(canvas-text-size cnv text)))
- (set! text-xmax xmax)(set! text-ymax ymax))
- (if font-changed (canvas-font-set! cnv prev-font))))))
- ;; (print "text-xmax: " text-xmax " text-ymax: " text-ymax)
- (if (vg:obj-extents obj)
- (vg:obj-extents obj)
- (if (not text)
- pts
- (if (and text-xmax text-ymax)
- (let ((xt (list llx lly
- (max ulx (+ llx text-xmax))
- (max uly (+ lly text-ymax)))))
- (vg:obj-extents-set! obj xt)
- xt)
- (if cnv
- (let-values (((xmax ymax)(canvas-text-size cnv text)))
- (let ((xt (list llx lly
- (max ulx (+ llx xmax))
- (max uly (+ lly ymax)))))
- (vg:obj-extents-set! obj xt)
- xt))
- pts)))))) ;; return extents
-
-;; given a rect obj draw it on the canvas applying first the drawing
-;; scale and offset
-;;
-(define (vg:draw-xaxis drawing obj #!key (draw #t))
- (let* ((cnv (vg:drawing-cnv drawing))
- (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj)))
- ;; (fill-color (vg:obj-fill-color obj))
- (line-color (vg:obj-line-color obj))
- (text (vg:obj-text obj))
- (font (vg:obj-font obj))
- (llx (car pts))
- (lly (cadr pts))
- (ulx (caddr pts))
- (uly (cadddr pts))
- (w (- ulx llx))
- (h (- uly lly))
- (text-xmax #f)
- (text-ymax #f))
- (if draw
- (let ((prev-background-color (canvas-background cnv))
- (prev-foreground-color (canvas-foreground cnv)))
- ;; (if fill-color
- ;; (begin
- ;; (canvas-foreground-set! cnv fill-color)
- ;; (canvas-box! cnv llx ulx lly uly))) ;; docs are all over the place on this one.;; w h)
- (if line-color
- (canvas-foreground-set! cnv line-color)
- #;(if fill-color
- (canvas-foreground-set! cnv prev-foreground-color)))
- (canvas-line! cnv llx ulx lly uly)
- (canvas-foreground-set! cnv prev-foreground-color)
- (if text
- (let* ((prev-font (canvas-font cnv))
- (font-changed (and font (not (equal? font prev-font)))))
- (if font-changed (canvas-font-set! cnv font))
- (canvas-text! cnv (+ 2 llx)(+ 2 lly) text)
- (let-values (((xmax ymax)(canvas-text-size cnv text)))
- (set! text-xmax xmax)(set! text-ymax ymax))
- (if font-changed (canvas-font-set! cnv prev-font))))))
- ;; (print "text-xmax: " text-xmax " text-ymax: " text-ymax)
- (if (vg:obj-extents obj)
- (vg:obj-extents obj)
- (if (not text)
- pts
- (if (and text-xmax text-ymax)
- (let ((xt (list llx lly
- (max ulx (+ llx text-xmax))
- (max uly (+ lly text-ymax)))))
- (vg:obj-extents-set! obj xt)
- xt)
- (if cnv
- (let-values (((xmax ymax)(canvas-text-size cnv text)))
- (let ((xt (list llx lly
- (max ulx (+ llx xmax))
- (max uly (+ lly ymax)))))
- (vg:obj-extents-set! obj xt)
- xt))
- pts)))))) ;; return extents
-
-;; given a rect obj draw it on the canvas applying first the drawing
-;; scale and offset
-;;
-(define (vg:draw-text drawing obj #!key (draw #t))
- (let* ((cnv (vg:drawing-cnv drawing))
- (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj)))
- (text (vg:obj-text obj))
- (font (vg:obj-font obj))
- (fill-color (vg:obj-fill-color obj))
- (line-color (vg:obj-line-color obj))
- (llx (car pts))
- (lly (cadr pts)))
- (if draw
- (let* ((prev-background-color (canvas-background cnv))
- (prev-foreground-color (canvas-foreground cnv))
- (prev-font (canvas-font cnv))
- (font-changed (and font (not (equal? font prev-font)))))
- (if line-color
- (canvas-foreground-set! cnv line-color)
- (if fill-color
- (canvas-foreground-set! cnv prev-foreground-color)))
- (if font-changed (canvas-font-set! cnv font))
- (canvas-text! cnv llx lly text)
- ;; NOTE: we do not set the font back!!
- (canvas-foreground-set! cnv prev-foreground-color)))
- (if cnv
- (if (eq? draw 'get-extents)
- (let-values (((xmax ymax)(canvas-text-size cnv text)))
- (append pts (list (+ llx xmax)(+ lly ymax)))) ;; will be wrong if text is rotated?
- (append pts pts))
- (append pts pts))))
-
-(define (vg:draw-inst drawing inst #!key (draw-mode #t)(prev-extents '()))
- (let* ((libname (vg:inst-libname inst))
- (compname (vg:inst-compname inst))
- (comp (vg:get-component drawing libname compname))
- (objs (vg:comp-objs comp)))
- ;; (print "comp: " comp)
- (if (null? objs)
- prev-extents
- (let loop ((obj (car objs))
- (tal (cdr objs))
- (res prev-extents))
- (let* ((obj-xfrmd (vg:map-obj drawing inst obj))
- (newres (cons (vg:draw-obj drawing obj-xfrmd draw: draw-mode) res)))
- (if (null? tal)
- newres
- (loop (car tal)(cdr tal) newres)))))))
-
-(define (vg:draw drawing draw-mode . instnames)
- (let* ((insts (vg:drawing-insts drawing))
- (all-inst-names (hash-table-keys insts))
- (master-list (if (null? instnames)
- all-inst-names
- instnames)))
- (if (null? master-list)
- '()
- (let loop ((instname (car master-list))
- (tal (cdr master-list))
- (res '()))
- (let* ((inst (hash-table-ref/default insts instname #f))
- (newres (if inst
- (vg:draw-inst drawing inst draw-mode: draw-mode prev-extents: res)
- res)))
- (if (null? tal)
- newres
- (loop (car tal)(cdr tal) newres)))))))
Index: vg_records.scm
==================================================================
--- vg_records.scm
+++ vg_records.scm
@@ -17,155 +17,8 @@
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
-(use simple-exceptions)
-(define vg:lib-exn (make-exception "wrong record type, expected vg:lib." 'assert))
-(define (pmake-vg:lib . params)(let ((v (if (null? params)(make-vector 2)(apply vector 'vg:lib params)))) v))
-(define (make-vg:lib #!key
- (comps #f)
- )
- (vector 'vg:lib comps))
-
-(define-inline (vg:lib-comps vec)(if (eq? (vector-ref vec 0) 'vg:lib)(vector-ref vec 1)(raise (vg:lib-exn 'vg:lib-comps 'xpr))))
-
-(define-inline (vg:lib-comps-set! vec val)(if (eq? (vector-ref vec 0) 'vg:lib)(vector-set! vec 1 val)(raise (vg:lib-exn 'comps))))
-;; Generated using make-vector-record -safe vg comp objs name file
-
-(use simple-exceptions)
-(define vg:comp-exn (make-exception "wrong record type, expected vg:comp." 'assert))
-(define (pmake-vg:comp . params)(let ((v (if (null? params)(make-vector 4)(apply vector 'vg:comp params)))) v))
-(define (make-vg:comp #!key
- (objs #f)
- (name #f)
- (file #f)
- )
- (vector 'vg:comp objs name file))
-
-(define-inline (vg:comp-objs vec)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-ref vec 1)(raise (vg:comp-exn 'vg:comp-objs 'xpr))))
-(define-inline (vg:comp-name vec)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-ref vec 2)(raise (vg:comp-exn 'vg:comp-name 'xpr))))
-(define-inline (vg:comp-file vec)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-ref vec 3)(raise (vg:comp-exn 'vg:comp-file 'xpr))))
-
-(define-inline (vg:comp-objs-set! vec val)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-set! vec 1 val)(raise (vg:comp-exn 'objs))))
-(define-inline (vg:comp-name-set! vec val)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-set! vec 2 val)(raise (vg:comp-exn 'name))))
-(define-inline (vg:comp-file-set! vec val)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-set! vec 3 val)(raise (vg:comp-exn 'file))))
-;; Generated using make-vector-record -safe vg obj type pts fill-color text line-color call-back angle font attrib extents proc
-
-(use simple-exceptions)
-(define vg:obj-exn (make-exception "wrong record type, expected vg:obj." 'assert))
-(define (pmake-vg:obj . params)(let ((v (if (null? params)(make-vector 12)(apply vector 'vg:obj params)))) v))
-(define (make-vg:obj #!key
- (type #f)
- (pts #f)
- (fill-color #f)
- (text #f)
- (line-color #f)
- (call-back #f)
- (angle #f)
- (font #f)
- (attrib #f)
- (extents #f)
- (proc #f)
- )
- (vector 'vg:obj type pts fill-color text line-color call-back angle font attrib extents proc))
-
-(define-inline (vg:obj-type vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 1)(raise (vg:obj-exn 'vg:obj-type 'xpr))))
-(define-inline (vg:obj-pts vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 2)(raise (vg:obj-exn 'vg:obj-pts 'xpr))))
-(define-inline (vg:obj-fill-color vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 3)(raise (vg:obj-exn 'vg:obj-fill-color 'xpr))))
-(define-inline (vg:obj-text vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 4)(raise (vg:obj-exn 'vg:obj-text 'xpr))))
-(define-inline (vg:obj-line-color vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 5)(raise (vg:obj-exn 'vg:obj-line-color 'xpr))))
-(define-inline (vg:obj-call-back vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 6)(raise (vg:obj-exn 'vg:obj-call-back 'xpr))))
-(define-inline (vg:obj-angle vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 7)(raise (vg:obj-exn 'vg:obj-angle 'xpr))))
-(define-inline (vg:obj-font vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 8)(raise (vg:obj-exn 'vg:obj-font 'xpr))))
-(define-inline (vg:obj-attrib vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 9)(raise (vg:obj-exn 'vg:obj-attrib 'xpr))))
-(define-inline (vg:obj-extents vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 10)(raise (vg:obj-exn 'vg:obj-extents 'xpr))))
-(define-inline (vg:obj-proc vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 11)(raise (vg:obj-exn 'vg:obj-proc 'xpr))))
-
-(define-inline (vg:obj-type-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 1 val)(raise (vg:obj-exn 'type))))
-(define-inline (vg:obj-pts-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 2 val)(raise (vg:obj-exn 'pts))))
-(define-inline (vg:obj-fill-color-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 3 val)(raise (vg:obj-exn 'fill-color))))
-(define-inline (vg:obj-text-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 4 val)(raise (vg:obj-exn 'text))))
-(define-inline (vg:obj-line-color-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 5 val)(raise (vg:obj-exn 'line-color))))
-(define-inline (vg:obj-call-back-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 6 val)(raise (vg:obj-exn 'call-back))))
-(define-inline (vg:obj-angle-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 7 val)(raise (vg:obj-exn 'angle))))
-(define-inline (vg:obj-font-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 8 val)(raise (vg:obj-exn 'font))))
-(define-inline (vg:obj-attrib-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 9 val)(raise (vg:obj-exn 'attrib))))
-(define-inline (vg:obj-extents-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 10 val)(raise (vg:obj-exn 'extents))))
-(define-inline (vg:obj-proc-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 11 val)(raise (vg:obj-exn 'proc))))
-;; Generated using make-vector-record -safe vg inst libname compname theta xoff yoff scalex scaley mirrx mirry call-back cache
-
-(use simple-exceptions)
-(define vg:inst-exn (make-exception "wrong record type, expected vg:inst." 'assert))
-(define (pmake-vg:inst . params)(let ((v (if (null? params)(make-vector 12)(apply vector 'vg:inst params)))) v))
-(define (make-vg:inst #!key
- (libname #f)
- (compname #f)
- (theta #f)
- (xoff #f)
- (yoff #f)
- (scalex #f)
- (scaley #f)
- (mirrx #f)
- (mirry #f)
- (call-back #f)
- (cache #f)
- )
- (vector 'vg:inst libname compname theta xoff yoff scalex scaley mirrx mirry call-back cache))
-
-(define-inline (vg:inst-libname vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 1)(raise (vg:inst-exn 'vg:inst-libname 'xpr))))
-(define-inline (vg:inst-compname vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 2)(raise (vg:inst-exn 'vg:inst-compname 'xpr))))
-(define-inline (vg:inst-theta vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 3)(raise (vg:inst-exn 'vg:inst-theta 'xpr))))
-(define-inline (vg:inst-xoff vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 4)(raise (vg:inst-exn 'vg:inst-xoff 'xpr))))
-(define-inline (vg:inst-yoff vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 5)(raise (vg:inst-exn 'vg:inst-yoff 'xpr))))
-(define-inline (vg:inst-scalex vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 6)(raise (vg:inst-exn 'vg:inst-scalex 'xpr))))
-(define-inline (vg:inst-scaley vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 7)(raise (vg:inst-exn 'vg:inst-scaley 'xpr))))
-(define-inline (vg:inst-mirrx vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 8)(raise (vg:inst-exn 'vg:inst-mirrx 'xpr))))
-(define-inline (vg:inst-mirry vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 9)(raise (vg:inst-exn 'vg:inst-mirry 'xpr))))
-(define-inline (vg:inst-call-back vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 10)(raise (vg:inst-exn 'vg:inst-call-back 'xpr))))
-(define-inline (vg:inst-cache vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 11)(raise (vg:inst-exn 'vg:inst-cache 'xpr))))
-
-(define-inline (vg:inst-libname-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 1 val)(raise (vg:inst-exn 'libname))))
-(define-inline (vg:inst-compname-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 2 val)(raise (vg:inst-exn 'compname))))
-(define-inline (vg:inst-theta-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 3 val)(raise (vg:inst-exn 'theta))))
-(define-inline (vg:inst-xoff-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 4 val)(raise (vg:inst-exn 'xoff))))
-(define-inline (vg:inst-yoff-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 5 val)(raise (vg:inst-exn 'yoff))))
-(define-inline (vg:inst-scalex-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 6 val)(raise (vg:inst-exn 'scalex))))
-(define-inline (vg:inst-scaley-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 7 val)(raise (vg:inst-exn 'scaley))))
-(define-inline (vg:inst-mirrx-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 8 val)(raise (vg:inst-exn 'mirrx))))
-(define-inline (vg:inst-mirry-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 9 val)(raise (vg:inst-exn 'mirry))))
-(define-inline (vg:inst-call-back-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 10 val)(raise (vg:inst-exn 'call-back))))
-(define-inline (vg:inst-cache-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 11 val)(raise (vg:inst-exn 'cache))))
-;; Generated using make-vector-record -safe vg drawing libs insts scalex scaley xoff yoff cnv cache
-
-(use simple-exceptions)
-(define vg:drawing-exn (make-exception "wrong record type, expected vg:drawing." 'assert))
-(define (pmake-vg:drawing . params)(let ((v (if (null? params)(make-vector 9)(apply vector 'vg:drawing params)))) v))
-(define (make-vg:drawing #!key
- (libs #f)
- (insts #f)
- (scalex #f)
- (scaley #f)
- (xoff #f)
- (yoff #f)
- (cnv #f)
- (cache #f)
- )
- (vector 'vg:drawing libs insts scalex scaley xoff yoff cnv cache))
-
-(define-inline (vg:drawing-libs vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 1)(raise (vg:drawing-exn 'vg:drawing-libs 'xpr))))
-(define-inline (vg:drawing-insts vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 2)(raise (vg:drawing-exn 'vg:drawing-insts 'xpr))))
-(define-inline (vg:drawing-scalex vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 3)(raise (vg:drawing-exn 'vg:drawing-scalex 'xpr))))
-(define-inline (vg:drawing-scaley vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 4)(raise (vg:drawing-exn 'vg:drawing-scaley 'xpr))))
-(define-inline (vg:drawing-xoff vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 5)(raise (vg:drawing-exn 'vg:drawing-xoff 'xpr))))
-(define-inline (vg:drawing-yoff vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 6)(raise (vg:drawing-exn 'vg:drawing-yoff 'xpr))))
-(define-inline (vg:drawing-cnv vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 7)(raise (vg:drawing-exn 'vg:drawing-cnv 'xpr))))
-(define-inline (vg:drawing-cache vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 8)(raise (vg:drawing-exn 'vg:drawing-cache 'xpr))))
-
-(define-inline (vg:drawing-libs-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 1 val)(raise (vg:drawing-exn 'libs))))
-(define-inline (vg:drawing-insts-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 2 val)(raise (vg:drawing-exn 'insts))))
-(define-inline (vg:drawing-scalex-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 3 val)(raise (vg:drawing-exn 'scalex))))
-(define-inline (vg:drawing-scaley-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 4 val)(raise (vg:drawing-exn 'scaley))))
-(define-inline (vg:drawing-xoff-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 5 val)(raise (vg:drawing-exn 'xoff))))
-(define-inline (vg:drawing-yoff-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 6 val)(raise (vg:drawing-exn 'yoff))))
-(define-inline (vg:drawing-cnv-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 7 val)(raise (vg:drawing-exn 'cnv))))
-(define-inline (vg:drawing-cache-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 8 val)(raise (vg:drawing-exn 'cache))))
+;; (import simple-exceptions)
+
+;; moved to vgmod.scm
Index: vgmod.scm
==================================================================
--- vgmod.scm
+++ vgmod.scm
@@ -21,16 +21,173 @@
(declare (unit vgmod))
(module vgmod
*
-(import scheme chicken data-structures extras ports)
-(use canvas-draw iup)
-(use typed-records srfi-1 srfi-69)
-(import canvas-draw-iup)
+ (import scheme
+ chicken.base
+ chicken.bitwise
+ chicken.string
+ chicken.random
+ )
+
+ (import canvas-draw
+ iup
+ typed-records
+ srfi-1
+ srfi-69
+ simple-exceptions)
+
+(define vg:lib-exn (make-exception "wrong record type, expected vg:lib." 'assert))
+(define (pmake-vg:lib . params)(let ((v (if (null? params)(make-vector 2)(apply vector 'vg:lib params)))) v))
+(define (make-vg:lib #!key
+ (comps #f)
+ )
+ (vector 'vg:lib comps))
+
+(define (vg:lib-comps vec)(if (eq? (vector-ref vec 0) 'vg:lib)(vector-ref vec 1)(raise (vg:lib-exn 'vg:lib-comps 'xpr))))
+
+(define (vg:lib-comps-set! vec val)(if (eq? (vector-ref vec 0) 'vg:lib)(vector-set! vec 1 val)(raise (vg:lib-exn 'comps))))
+;; Generated using make-vector-record -safe vg comp objs name file
+
+(import simple-exceptions)
+(define vg:comp-exn (make-exception "wrong record type, expected vg:comp." 'assert))
+(define (pmake-vg:comp . params)(let ((v (if (null? params)(make-vector 4)(apply vector 'vg:comp params)))) v))
+(define (make-vg:comp #!key
+ (objs #f)
+ (name #f)
+ (file #f)
+ )
+ (vector 'vg:comp objs name file))
+
+(define (vg:comp-objs vec)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-ref vec 1)(raise (vg:comp-exn 'vg:comp-objs 'xpr))))
+(define (vg:comp-name vec)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-ref vec 2)(raise (vg:comp-exn 'vg:comp-name 'xpr))))
+(define (vg:comp-file vec)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-ref vec 3)(raise (vg:comp-exn 'vg:comp-file 'xpr))))
+
+(define (vg:comp-objs-set! vec val)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-set! vec 1 val)(raise (vg:comp-exn 'objs))))
+(define (vg:comp-name-set! vec val)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-set! vec 2 val)(raise (vg:comp-exn 'name))))
+(define (vg:comp-file-set! vec val)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-set! vec 3 val)(raise (vg:comp-exn 'file))))
+;; Generated using make-vector-record -safe vg obj type pts fill-color text line-color call-back angle font attrib extents proc
+
+(import simple-exceptions)
+(define vg:obj-exn (make-exception "wrong record type, expected vg:obj." 'assert))
+(define (pmake-vg:obj . params)(let ((v (if (null? params)(make-vector 12)(apply vector 'vg:obj params)))) v))
+(define (make-vg:obj #!key
+ (type #f)
+ (pts #f)
+ (fill-color #f)
+ (text #f)
+ (line-color #f)
+ (call-back #f)
+ (angle #f)
+ (font #f)
+ (attrib #f)
+ (extents #f)
+ (proc #f)
+ )
+ (vector 'vg:obj type pts fill-color text line-color call-back angle font attrib extents proc))
+
+(define (vg:obj-type vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 1)(raise (vg:obj-exn 'vg:obj-type 'xpr))))
+(define (vg:obj-pts vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 2)(raise (vg:obj-exn 'vg:obj-pts 'xpr))))
+(define (vg:obj-fill-color vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 3)(raise (vg:obj-exn 'vg:obj-fill-color 'xpr))))
+(define (vg:obj-text vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 4)(raise (vg:obj-exn 'vg:obj-text 'xpr))))
+(define (vg:obj-line-color vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 5)(raise (vg:obj-exn 'vg:obj-line-color 'xpr))))
+(define (vg:obj-call-back vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 6)(raise (vg:obj-exn 'vg:obj-call-back 'xpr))))
+(define (vg:obj-angle vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 7)(raise (vg:obj-exn 'vg:obj-angle 'xpr))))
+(define (vg:obj-font vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 8)(raise (vg:obj-exn 'vg:obj-font 'xpr))))
+(define (vg:obj-attrib vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 9)(raise (vg:obj-exn 'vg:obj-attrib 'xpr))))
+(define (vg:obj-extents vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 10)(raise (vg:obj-exn 'vg:obj-extents 'xpr))))
+(define (vg:obj-proc vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 11)(raise (vg:obj-exn 'vg:obj-proc 'xpr))))
+
+(define (vg:obj-type-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 1 val)(raise (vg:obj-exn 'type))))
+(define (vg:obj-pts-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 2 val)(raise (vg:obj-exn 'pts))))
+(define (vg:obj-fill-color-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 3 val)(raise (vg:obj-exn 'fill-color))))
+(define (vg:obj-text-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 4 val)(raise (vg:obj-exn 'text))))
+(define (vg:obj-line-color-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 5 val)(raise (vg:obj-exn 'line-color))))
+(define (vg:obj-call-back-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 6 val)(raise (vg:obj-exn 'call-back))))
+(define (vg:obj-angle-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 7 val)(raise (vg:obj-exn 'angle))))
+(define (vg:obj-font-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 8 val)(raise (vg:obj-exn 'font))))
+(define (vg:obj-attrib-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 9 val)(raise (vg:obj-exn 'attrib))))
+(define (vg:obj-extents-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 10 val)(raise (vg:obj-exn 'extents))))
+(define (vg:obj-proc-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 11 val)(raise (vg:obj-exn 'proc))))
+;; Generated using make-vector-record -safe vg inst libname compname theta xoff yoff scalex scaley mirrx mirry call-back cache
+
+(import simple-exceptions)
+(define vg:inst-exn (make-exception "wrong record type, expected vg:inst." 'assert))
+(define (pmake-vg:inst . params)(let ((v (if (null? params)(make-vector 12)(apply vector 'vg:inst params)))) v))
+(define (make-vg:inst #!key
+ (libname #f)
+ (compname #f)
+ (theta #f)
+ (xoff #f)
+ (yoff #f)
+ (scalex #f)
+ (scaley #f)
+ (mirrx #f)
+ (mirry #f)
+ (call-back #f)
+ (cache #f)
+ )
+ (vector 'vg:inst libname compname theta xoff yoff scalex scaley mirrx mirry call-back cache))
+
+(define (vg:inst-libname vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 1)(raise (vg:inst-exn 'vg:inst-libname 'xpr))))
+(define (vg:inst-compname vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 2)(raise (vg:inst-exn 'vg:inst-compname 'xpr))))
+(define (vg:inst-theta vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 3)(raise (vg:inst-exn 'vg:inst-theta 'xpr))))
+(define (vg:inst-xoff vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 4)(raise (vg:inst-exn 'vg:inst-xoff 'xpr))))
+(define (vg:inst-yoff vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 5)(raise (vg:inst-exn 'vg:inst-yoff 'xpr))))
+(define (vg:inst-scalex vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 6)(raise (vg:inst-exn 'vg:inst-scalex 'xpr))))
+(define (vg:inst-scaley vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 7)(raise (vg:inst-exn 'vg:inst-scaley 'xpr))))
+(define (vg:inst-mirrx vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 8)(raise (vg:inst-exn 'vg:inst-mirrx 'xpr))))
+(define (vg:inst-mirry vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 9)(raise (vg:inst-exn 'vg:inst-mirry 'xpr))))
+(define (vg:inst-call-back vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 10)(raise (vg:inst-exn 'vg:inst-call-back 'xpr))))
+(define (vg:inst-cache vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 11)(raise (vg:inst-exn 'vg:inst-cache 'xpr))))
+
+(define (vg:inst-libname-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 1 val)(raise (vg:inst-exn 'libname))))
+(define (vg:inst-compname-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 2 val)(raise (vg:inst-exn 'compname))))
+(define (vg:inst-theta-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 3 val)(raise (vg:inst-exn 'theta))))
+(define (vg:inst-xoff-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 4 val)(raise (vg:inst-exn 'xoff))))
+(define (vg:inst-yoff-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 5 val)(raise (vg:inst-exn 'yoff))))
+(define (vg:inst-scalex-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 6 val)(raise (vg:inst-exn 'scalex))))
+(define (vg:inst-scaley-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 7 val)(raise (vg:inst-exn 'scaley))))
+(define (vg:inst-mirrx-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 8 val)(raise (vg:inst-exn 'mirrx))))
+(define (vg:inst-mirry-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 9 val)(raise (vg:inst-exn 'mirry))))
+(define (vg:inst-call-back-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 10 val)(raise (vg:inst-exn 'call-back))))
+(define (vg:inst-cache-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 11 val)(raise (vg:inst-exn 'cache))))
+;; Generated using make-vector-record -safe vg drawing libs insts scalex scaley xoff yoff cnv cache
+
+(import simple-exceptions)
+(define vg:drawing-exn (make-exception "wrong record type, expected vg:drawing." 'assert))
+(define (pmake-vg:drawing . params)(let ((v (if (null? params)(make-vector 9)(apply vector 'vg:drawing params)))) v))
+(define (make-vg:drawing #!key
+ (libs #f)
+ (insts #f)
+ (scalex #f)
+ (scaley #f)
+ (xoff #f)
+ (yoff #f)
+ (cnv #f)
+ (cache #f)
+ )
+ (vector 'vg:drawing libs insts scalex scaley xoff yoff cnv cache))
+
+(define (vg:drawing-libs vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 1)(raise (vg:drawing-exn 'vg:drawing-libs 'xpr))))
+(define (vg:drawing-insts vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 2)(raise (vg:drawing-exn 'vg:drawing-insts 'xpr))))
+(define (vg:drawing-scalex vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 3)(raise (vg:drawing-exn 'vg:drawing-scalex 'xpr))))
+(define (vg:drawing-scaley vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 4)(raise (vg:drawing-exn 'vg:drawing-scaley 'xpr))))
+(define (vg:drawing-xoff vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 5)(raise (vg:drawing-exn 'vg:drawing-xoff 'xpr))))
+(define (vg:drawing-yoff vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 6)(raise (vg:drawing-exn 'vg:drawing-yoff 'xpr))))
+(define (vg:drawing-cnv vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 7)(raise (vg:drawing-exn 'vg:drawing-cnv 'xpr))))
+(define (vg:drawing-cache vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 8)(raise (vg:drawing-exn 'vg:drawing-cache 'xpr))))
-(include "vg_records.scm")
+(define (vg:drawing-libs-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 1 val)(raise (vg:drawing-exn 'libs))))
+(define (vg:drawing-insts-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 2 val)(raise (vg:drawing-exn 'insts))))
+(define (vg:drawing-scalex-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 3 val)(raise (vg:drawing-exn 'scalex))))
+(define (vg:drawing-scaley-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 4 val)(raise (vg:drawing-exn 'scaley))))
+(define (vg:drawing-xoff-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 5 val)(raise (vg:drawing-exn 'xoff))))
+(define (vg:drawing-yoff-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 6 val)(raise (vg:drawing-exn 'yoff))))
+(define (vg:drawing-cnv-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 7 val)(raise (vg:drawing-exn 'cnv))))
+(define (vg:drawing-cache-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 8 val)(raise (vg:drawing-exn 'cache))))
;; ;; structs
;; ;;
;; (defstruct vg:lib comps)
;; (defstruct vg:comp objs name file)
@@ -383,20 +540,20 @@
b))
;; Obsolete function
;;
(define (vg:generate-color)
- (vg:rgb->number (random 255)
- (random 255)
- (random 255)))
+ (vg:rgb->number (pseudo-random-integer 255)
+ (pseudo-random-integer 255)
+ (pseudo-random-integer 255)))
-;; Need to return a string of random iup-color for graph
+;; Need to return a string of pseudo-random-integer iup-color for graph
;;
(define (vg:generate-color-rgb)
- (conc (number->string (random 255)) " "
- (number->string (random 255)) " "
- (number->string (random 255))))
+ (conc (number->string (pseudo-random-integer 255)) " "
+ (number->string (pseudo-random-integer 255)) " "
+ (number->string (pseudo-random-integer 255))))
(define (vg:iup-color->number iup-color)
(apply vg:rgb->number (map string->number (string-split iup-color))))
;;======================================================================