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)) @@ -251,13 +259,13 @@ ((csv->test-data) (apply db:csv->test-data dbstruct params)) ;; MISC ;; ((sync-inmem->db) (let ((run-id (car params))) ;; (db:sync-touched dbstruct run-id force-sync: #t))) - ;; ((mark-incomplete) (apply db:find-and-mark-incomplete dbstruct params)) - ;; ((create-all-triggers) (db:create-all-triggers dbstruct)) - ;; ((drop-all-triggers) (db:drop-all-triggers dbstruct)) + ((mark-incomplete) (apply db:find-and-mark-incomplete dbstruct params)) + ((create-all-triggers) (db:create-all-triggers dbstruct)) + ((drop-all-triggers) (db:drop-all-triggers dbstruct)) ;; TESTMETA ((testmeta-add-record) (apply db:testmeta-add-record dbstruct params)) ((testmeta-update-field) (apply db:testmeta-update-field dbstruct params)) ((get-tests-tags) (db:get-tests-tags dbstruct)) @@ -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 testpatt-key target) #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 testpatt-key target))) (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)) @@ -3177,11 +3923,11 @@ (define (common:load-views-config) (let* ((view-cfgdat (make-hash-table)) (home-cfgfile (conc (get-environment-variable "HOME") "/.mtviews.config")) (mthome-cfgfile (conc *toppath* "/.mtviews.config"))) (if (common:file-exists? mthome-cfgfile) - (configf:read-config mthome-cfgfile view-cfgdat)) + (configf:read-config mthome-cfgfile view-cfgdat #t)) ;; we load the home dir file AFTER the MTRAH file so the user can clobber settings when running the dashboard in read-only areas (if (common:file-exists? home-cfgfile) (configf:read-config home-cfgfile view-cfgdat #t)) view-cfgdat)) @@ -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,23 +22,59 @@ (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:get-sections + 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 + getenv + mytarget + nice-path + process:cmd-run->list + runconfig:read + runconfigs-get + safe-setenv + setenv + configf:eval-string-in-environment + ) (import scheme + big-chicken ;; more of a reminder than anything ... chicken.base chicken.condition chicken.file chicken.io 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,15 +102,20 @@ typed-records z3 ) -(define *configdat* #f) - (define getenv get-environment-variable) (define setenv set-environment-variable!) (define unsetenv unset-environment-variable!) + +;;====================================================================== +;; parameters +;;====================================================================== + +;; while targets are Megatest specific they are a useful concept +(define mytarget (make-parameter #f)) ;;====================================================================== ;; move debug stuff to separate module then put these back where they belong ;;====================================================================== ;;====================================================================== @@ -84,17 +125,20 @@ (define (configf:lookup cfgdat section var) (if (hash-table? cfgdat) (let ((sectdat (hash-table-ref/default cfgdat section '()))) (if (null? sectdat) #f - (let ((match (assoc var sectdat))) - (if match ;; (and match (list? match)(> (length match) 1)) - (cadr match) + (let ((res (assoc var sectdat))) + (if res ;; (and match (list? match)(> (length match) 1)) + (cadr res) #f)) )) #f)) +(define (configf:get-sections cfgdat) + (filter string? (hash-table-keys cfgdat))) + (define (configf:assoc-safe-add alist key val #!key (metadata #f)) (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist))) (append newalist (list (if metadata (list key val metadata) (list key val)))))) @@ -281,11 +325,11 @@ (string-substitute (regexp "^/(.*)/$") "\\1" section-name))) (rx (regexp rxstr))) ;; (print "\nsection-name: " section-name " rxstr: " rxstr) (for-each (lambda (section) - (if section + (if (string? section) (let ((same-section (string=? section-name section)) (rx-match (string-match rx section))) ;; (print "section: " section " vars: " vars " same-section: " same-section " rx-match: " rx-match) (if (and (not same-section) rx-match) (for-each @@ -312,13 +356,15 @@ ;; in the environment on the fly ;; sections: #f => get all, else list of sections to gather ;; post-section-procs alist of section-pattern => proc, where: (proc section-name next-section-name ht curr-path) ;; apply-wildcards: #t/#f - apply vars from targets with % wildcards to all matching sections ;; -(define (configf:read-config path ht allow-system #!key (environ-patt #f) (curr-section #f) - (sections #f) (settings (make-hash-table)) (keep-filenames #f) - (post-section-procs '()) (apply-wildcards #t) (env-to-use #f)) +(define (configf:read-config path ht allow-system + #!key (environ-patt #f) (curr-section #f) + (sections #f) (settings (make-hash-table)) + (keep-filenames #f) (post-section-procs '()) + (apply-wildcards #t) (env-to-use #f)) (debug:print 9 *default-log-port* "START: " path) ;; (if *configdat* ;; (common:save-pkt `((action . read-config) ;; (f . ,(cond ((string? path) path) ;; ((port? path) "port") @@ -333,11 +379,16 @@ #f) ;; (if (not ht)(make-hash-table) ht)) (let (;; (env-to-use (if env-to-use env-to-use (module-environment 'configfmod))) (inp (if (string? path) (open-input-file path) path)) ;; we can be handed a port - (res (if (not ht)(make-hash-table) ht)) + (res (let ((ht-in (if (not ht) + (make-hash-table) + ht))) + (if (not (configf:lookup ht-in "" "toppath")) + (configf:set-section-var ht-in "" "toppath" path)) + ht-in)) (metapath (if (or (debug:debug-mode 9) keep-filenames) path #f)) (process-wildcards (lambda (res curr-section-name) (if (and apply-wildcards @@ -674,13 +725,13 @@ (for-each (lambda (x) (x)) restore-thunks) ;; restore env to original state rv))) ;; return a nice clean pathname made absolute (define (common:nice-path dir) - (let ((match (string-match "^(~[^\\/]*)(\\/.*|)$" dir))) - (if match ;; using ~ for home? - (common:nice-path (conc (common:read-link-f (cadr match)) "/" (caddr match))) + (let ((res (string-match "^(~[^\\/]*)(\\/.*|)$" dir))) + (if res ;; using ~ for home? + (common:nice-path (conc (common:read-link-f (cadr res)) "/" (caddr res))) (normalize-pathname (if (absolute-pathname? dir) dir (conc (current-directory) "/" dir)))))) ;; make "nice-path" available in config files and the repl @@ -711,14 +762,14 @@ (led #f) (res '())) ;; ALL WHITESPACE LEADING LINES ARE TACKED ON!! ;; 1. remove led whitespace ;; 2. tack on to hed with "\n" - (let ((match (string-match configf:cont-ln-rx hed))) - (if match ;; blast! have to deal with a multiline - (let* ((lead (cadr match)) - (lval (caddr match)) + (let ((res (string-match configf:cont-ln-rx hed))) + (if res ;; blast! have to deal with a multiline + (let* ((lead (cadr res)) + (lval (caddr res)) (newl (conc cur "\n" lval))) (if (not led)(set! led lead)) (if (null? tal) (set! fdat (append fdat (list newl))) (loop (car tal)(cdr tal) newl led res))) ;; NB// not tacking newl onto res @@ -933,18 +984,20 @@ (define (configf:config->ini data) (map (lambda (section) (let ((section-name (car section)) (section-dat (cdr section))) - (print "\n[" section-name "]") - (map (lambda (dat-pair) - (let* ((var (car dat-pair)) - (val (cadr dat-pair)) - (fname (if (> (length dat-pair) 2)(caddr dat-pair) #f))) - (if fname (print "# " var "=>" fname)) - (print var " " val))) - section-dat))) ;; (print "section-dat: " section-dat)) + (if (string? section-name) + (begin + (print "\n[" section-name "]") + (map (lambda (dat-pair) + (let* ((var (car dat-pair)) + (val (cadr dat-pair)) + (fname (if (> (length dat-pair) 2)(caddr dat-pair) #f))) + (if fname (print "# " var "=>" fname)) + (print var " " val))) + section-dat))))) ;; (print "section-dat: " section-dat)) (hash-table->alist data))) (define (runconfig:read fname target environ-patt) (let ((ht (make-hash-table))) (if target (hash-table-set! ht target '())) @@ -953,14 +1006,81 @@ ;;====================================================================== ;; Config file handling ;;====================================================================== ;; convert to param? -(define configf:std-imports "") ;;(import configfmod commonmod)") - +(define configf:std-imports "(import big-chicken configfmod commonmod rmtmod (prefix mtargs args:))") +(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 "(lambda (ht)" + configf:std-imports + cmd ")")) + (case cmdsym + ((system) `(noeval-needed ,(conc (configf:system ht cmd)))) + ;; ((shell sh) `(noeval-needed ,(conc (string-translate (shell quotedcmd) "\n" " ")))) + ((shell sh) `(noeval-needed ,(conc (string-translate (shell cmd) "\n" " ")))) + ((realpath rp)`(noeval-needed ,(conc (common:nice-path quotedcmd)))) + ((getenv gv) `(noeval-needed ,(conc (get-environment-variable cmd)))) + ((mtrah) `(noeval-needed ,(configf:lookup ht "" "toppath"))) + ((get g) + (match + (string-split cmd) + ((sect var) `(noeval-needed ,(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)) + (else ;; (#f errres) + (debug:print 0 *default-log-port* "WARNING: failed to process config input \""l"\", fullcmd="fullcmd"."))) + ;; 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 +1089,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 +1138,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 var #!optional (target #f)) + (let ((targ (or target (mytarget)))) ;; (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)) @@ -1061,11 +1193,11 @@ (res (begin (with-output-to-file fname ;; first write out the file (lambda () (pp dat))) - + ;; I don't like this. It makes write-alist opaque and complicated. -mrw- (if (file-exists? fname) ;; now verify it is readable (if (configf:read-alist fname) #t ;; data is good. (begin (handle-exceptions 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)) @@ -1143,11 +1067,11 @@ ;; (dboard:tabdat-all-test-names-set! tabdat (collapse-rows tabdat - (sort (hash-table-keys all-test-names) string>?))) ;; FIXME: Sorting needs to happen here + (sort (filter string? (hash-table-keys all-test-names)) string>?))) ;; FIXME: Sorting needs to happen here ;; Trim the names list to fit the matrix of buttons ;; (dboard:tabdat-all-test-names-set! tabdat @@ -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") )) @@ -3010,11 +2864,11 @@ ((external) ;; was tabs (let ((tab-content (dboard:add-external-tab commondat view-name views-cfgdat #f tab-num))) (set! additional-tabnames (cons (cons tab-num view-name) additional-tabnames)) (set! tab-num (+ tab-num 1)) (set! result (append result (list tab-content))))))))) - (sort (hash-table-keys views-cfgdat) + (sort (configf:get-sections views-cfgdat) ;; (hash-table-keys views-cfgdat) (lambda (a b) (let ((order-a (or (any->number (configf:lookup views-cfgdat a "order")) 999)) (order-b (or (any->number (configf:lookup views-cfgdat b "order")) 999))) (> order-a order-b))))) result)) @@ -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 @@ -3877,15 +3727,28 @@ (dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab ) "update buttons once")) (th2 (make-thread iup:main-loop "Main loop"))) (thread-start! th2) (thread-join! th2))))) + +(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 (conc (get-environment-variable "HOME") "/.dashboardrc"))) - (if (common:file-exists? debugcontrolf) +(let ((debugcontrolf (get-debugcontrolf))) + (if debugcontrolf (load debugcontrolf))) -(if (args:get-arg "-repl") - (repl) - (main)) +(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 @@ -56,10 +297,11 @@ system-information (prefix base64 base64:) csv-xml directory-utils + format matchable regex s11n srfi-1 srfi-13 @@ -102,17 +344,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 +397,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 +419,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 +455,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 +469,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 +494,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 +519,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 +682,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 +722,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 +914,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 +1013,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 +1030,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 )) @@ -1177,24 +1434,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)))) - +; "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id= (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 +1880,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 +1963,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 +2085,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 +2235,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 +2255,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 +2277,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 +2346,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 +2502,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 +2758,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 +3315,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 +3377,33 @@ 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: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))))) + (define (db:test-set-state-status dbstruct run-id test-id newstate newstatus newcomment) (db:with-db dbstruct - ;; run-id - #f + run-id #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)) + (db:db-test-set-state-status db run-id test-id newstate newstatus newcomment)))) ;; NEW BEHAVIOR: Count tests running in all runs! ;; (define (db:get-count-tests-running dbstruct run-id) ;; fastmode) (let* ((qry ;; (if fastmode @@ -3492,24 +3786,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 +3856,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,126 +4163,132 @@ (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: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))) + (state-statuses (db:roll-up-rules state-status-counts state status)) + (newstate (car state-statuses)) + (newstatus (cadr state-statuses))) (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 + (db: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))) - (bad-not-started (length (filter (lambda (x) - (and (equal? (dbr:counts-state x) "NOT_STARTED") - (not (member (dbr:counts-status x) *common:not-started-ok-statuses*)))) - state-status-counts))) - (all-curr-states (common:special-sort ;; worst -> best (sort of) - (delete-duplicates - (if (and state (not (member state *common:dont-roll-up-states*))) - (cons state (map dbr:counts-state state-status-counts)) - (map dbr:counts-state state-status-counts))) - *common:std-states* >)) - (all-curr-statuses (common:special-sort ;; worst -> best - (delete-duplicates - (if (and state status (not (member state *common:dont-roll-up-states*))) - (cons status (map dbr:counts-status state-status-counts)) - (map dbr:counts-status state-status-counts))) - *common:std-statuses* >)) - (non-completes (filter (lambda (x) - (not (member x (cons "COMPLETED" *common:dont-roll-up-states*)))) - all-curr-states)) - (preq-fails (filter (lambda (x) - (equal? x "PREQ_FAIL")) - all-curr-statuses)) - (num-non-completes (length non-completes)) - (newstate (cond - ((> running 0) "RUNNING") ;; anything running, call the situation running - ((> (length preq-fails) 0) "NOT_STARTED") - ((> bad-not-started 0) "COMPLETED") ;; we have an ugly situation, it is completed in the sense we cannot do more. - ((> num-non-completes 0) (car non-completes)) ;; (remove (lambda (x)(equal? "COMPLETED" x)) all-curr-states))) ;; only rollup DELETED if all DELETED - (else (car all-curr-states)))) - (newstatus (cond - ((> (length preq-fails) 0) "PREQ_FAIL") - ((or (> bad-not-started 0) - (and (equal? newstate "NOT_STARTED") - (> num-non-completes 0))) - "STARTED") - (else (car all-curr-statuses))))) - (debug:print-info 2 *default-log-port* - "\n--> probe db:set-state-status-and-roll-up-items: " - "\n--> state-status-counts: "(map dbr:counts->alist state-status-counts) - "\n--> running: "running - "\n--> bad-not-started: "bad-not-started - "\n--> non-non-completes: "num-non-completes - "\n--> non-completes: "non-completes - "\n--> all-curr-states: "all-curr-states - "\n--> all-curr-statuses: "all-curr-statuses - "\n--> newstate "newstate - "\n--> newstatus "newstatus - "\n\n") - - ;; NB// Pass the db so it is part of the transaction - (list newstate newstatus))) + (if (null? state-status-counts) + '(#f #f) + (let* ((running (length (filter (lambda (x) + (member (dbr:counts-state x) *common:running-states*)) + state-status-counts))) + (bad-not-started (length (filter (lambda (x) + (and (equal? (dbr:counts-state x) "NOT_STARTED") + (not (member (dbr:counts-status x) *common:not-started-ok-statuses*)))) + state-status-counts))) + (all-curr-states (common:special-sort ;; worst -> best (sort of) + (delete-duplicates + (if (and state (not (member state *common:dont-roll-up-states*))) + (cons state (map dbr:counts-state state-status-counts)) + (map dbr:counts-state state-status-counts))) + *common:std-states* >)) + (all-curr-statuses (common:special-sort ;; worst -> best + (delete-duplicates + (if (and state status (not (member state *common:dont-roll-up-states*))) + (cons status (map dbr:counts-status state-status-counts)) + (map dbr:counts-status state-status-counts))) + *common:std-statuses* >)) + (non-completes (filter (lambda (x) + (not (member x (cons "COMPLETED" *common:dont-roll-up-states*)))) + all-curr-states)) + (preq-fails (filter (lambda (x) + (equal? x "PREQ_FAIL")) + all-curr-statuses)) + (num-non-completes (length non-completes)) + (newstate (cond + ((> running 0) "RUNNING") ;; anything running, call the situation running + ((> (length preq-fails) 0) "NOT_STARTED") + ((> bad-not-started 0) "COMPLETED") ;; we have an ugly situation, it is completed in the sense we cannot do more. + ((> num-non-completes 0) (car non-completes)) ;; (remove (lambda (x)(equal? "COMPLETED" x)) all-curr-states))) ;; only rollup DELETED if all DELETED + (else (car all-curr-states)))) + (newstatus (cond + ((> (length preq-fails) 0) "PREQ_FAIL") + ((or (> bad-not-started 0) + (and (equal? newstate "NOT_STARTED") + (> num-non-completes 0))) + "STARTED") + (else (car all-curr-statuses))))) + (debug:print-info 2 *default-log-port* + "\n--> probe db:set-state-status-and-roll-up-items: " + "\n--> state-status-counts: "(map dbr:counts->alist state-status-counts) + "\n--> running: "running + "\n--> bad-not-started: "bad-not-started + "\n--> non-non-completes: "num-non-completes + "\n--> non-completes: "non-completes + "\n--> all-curr-states: "all-curr-states + "\n--> all-curr-statuses: "all-curr-statuses + "\n--> newstate "newstate + "\n--> newstatus "newstatus + "\n\n") + + ;; NB// Pass the db so it is part of the transaction + (list newstate newstatus)))) (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 db (lambda () - (let* ((state-status-counts (db:get-all-state-status-counts-for-run dbstruct run-id)) - (state-stauses (db:roll-up-rules state-status-counts #f #f )) - (newstate (car state-stauses)) - (newstatus (cadr state-stauses))) - (if (or (not (eq? newstate curr-state)) (not (eq? newstatus curr-status))) - (db:set-run-state-status dbstruct run-id newstate newstatus ))))))) - (mutex-unlock! *db-transaction-mutex*) + (let* ((state-status-counts (db:get-all-state-status-counts-for-run dbstruct run-id)) + (state-statuses (db:roll-up-rules state-status-counts #f #f )) + (newstate (car state-statuses)) + (newstatus (cadr state-statuses))) + (if (or (not (eq? newstate curr-state)) (not (eq? newstatus curr-status))) + (db:set-run-state-status dbstruct run-id newstate newstatus ))))))) + ;; (mutex-unlock! *db-transaction-mutex*) tr-res)))) (define (db:get-all-state-status-counts-for-run dbstruct run-id) (let* ((test-count-recs (db:with-db - dbstruct #f #f - (lambda (db) - (sqlite3:map-row - (lambda (state status count) - (make-dbr:counts state: state status: status count: count)) - db - "SELECT state,status,count(id) FROM tests WHERE run_id=? GROUP BY state,status;" - run-id ))))) + dbstruct #f #f + (lambda (db) + (sqlite3:map-row + (lambda (state status count) + (make-dbr:counts state: state status: status count: count)) + db + "SELECT state,status,count(id) FROM tests WHERE run_id=? GROUP BY state,status;" + run-id ))))) test-count-recs)) ;; BBnote: db:get-all-state-status-counts-for-test returns dbr:counts object aggregating state and status of items of a given test, *not including rollup state/status* ;; @@ -4233,18 +4533,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 +5456,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 +5471,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 +5548,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 +5837,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 +5869,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") + (rmt:set-var run-id (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 * @@ -64,10 +64,11 @@ (import scheme chicken.base chicken.bitwise chicken.condition + ;; chicken.csi chicken.eval chicken.file chicken.file.posix chicken.format chicken.io @@ -92,10 +93,11 @@ (prefix sxml-modifications sxml-) address-info csv-abnf directory-utils fmt + format http-client intarweb json linenoise matchable @@ -128,11 +130,10 @@ ;; local modules autoload adjutant csv-xml - ducttape-lib hostinfo mtver mutils cookie csv-xml @@ -169,13 +170,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 +183,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 +216,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 +245,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 +264,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 +750,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,11 +889,12 @@ (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")) - + + ;; (debug:print 0 *default-log-port* "on-exit disabled. Please re-enable") (on-exit std-exit-procedure) ;;====================================================================== ;; Misc general calls ;;====================================================================== @@ -923,11 +901,11 @@ ;; 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 +1241,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 +2037,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 +2204,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 +2430,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 +2441,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 @@ -2479,13 +2457,13 @@ (repl)) (else (begin ;; (set! *db* dbstruct) ;; (import extras) ;; might not be needed - ;; (import csi) + ;; (import chicken.csi) ;; (import readline) - (import apropos + #;(import apropos archivemod commonmod configfmod dbmod debugprint @@ -2497,13 +2475,11 @@ servermod tasksmod testsmod) (set-history-length! 300) - (load-history-from-file ".megatest_history") - (current-input-port (make-linenoise-port)) ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ... ;; (if *use-new-readline* ;; (begin 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,8 @@ +nng-test : nng-test.scm + csc nng-test.scm + +test : nng-test + ./nng-test do-test + +clean : + rm -f .runners/* NBFAKE* ADDED nng-trial/nng-test.scm Index: nng-trial/nng-test.scm ================================================================== --- /dev/null +++ nng-trial/nng-test.scm @@ -0,0 +1,157 @@ +(module nng-test * + +(import scheme + (chicken io) + (chicken base) + (chicken time) + (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: + do-test : run the basic req/rep test + run tcp://host:port : start test server - start several in same dir +") + +(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)) + +;; 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 (main) + (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* ((endtimes (+ (current-seconds) 20)) ;; run for 20 seconds + (socket (make-listening-reply-socket myaddr)) + (rfile (conc ".runners/"(get-host-name)"-"(current-process-id))) + (th1 (make-thread (lambda () + (run-listener-responder socket myaddr) + ) + "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 (> (current-seconds) endtimes) + (begin + (delete-file* rfile) + (sleep 1) + (exit)) + (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.025) + (loop (cdr entries)))))))) + ((cmd)(print "ERROR: command "cmd", not recognised.\n\n"help)) + (else + (print help)))) + +) ;; end module + +(import nng-test) +(main) + + Index: rmtmod.scm ================================================================== --- rmtmod.scm +++ rmtmod.scm @@ -40,11 +40,11 @@ chicken.base chicken.condition chicken.file chicken.file.posix - chicken.format + ;; chicken.format chicken.io chicken.pathname chicken.port chicken.pretty-print chicken.process @@ -57,15 +57,17 @@ chicken.time chicken.time.posix (prefix sqlite3 sqlite3:) directory-utils + format ;; http-client ;; intarweb matchable md5 message-digest + nng ;; nanomsg (prefix base64 base64:) (prefix sqlite3 sqlite3:) regex s11n ;; spiffy @@ -75,11 +77,11 @@ srfi-13 srfi-18 srfi-69 stack system-information - tcp6 + ;; tcp6 typed-records uri-common z3 apimod @@ -119,10 +121,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 +246,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 +266,62 @@ (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) + ;; (api:process-request dbdat 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 +332,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 +359,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 +704,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 +764,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 +842,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 +1423,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 +1470,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 +1530,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 +1597,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 +1614,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 +1867,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 +2043,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 +2133,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 +2162,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 +2205,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 +2247,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 +2268,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 @@ -65,10 +65,11 @@ chicken.process.signal (prefix base64 base64:) csv-xml directory-utils + format matchable regex s11n srfi-1 srfi-13 @@ -298,11 +299,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 +346,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 +499,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 +523,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) @@ -647,16 +648,17 @@ (runs:find-and-mark-incomplete-and-check-end-of-run run-id #f)))) ;; ovr-deadtime))) ;; could be root of https://hsdes.intel.com/appstore/article/#/220546828/main -- Title: Megatest jobs show DEAD even though they are still running (1.64/27) run-ids))) "runs: mark-incompletes"))) ;; (thread-start! th1) (thread-start! th2) - ;; (thread-join! th1) + (thread-join! th2) ;; turn off marking incompletes in parallel. see if it is related to the db locks we are seeing. + ;; just do the main stuff in the main thread (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry) (set! keep-going #f) - (thread-join! th2) + ;; (thread-join! th2) ;; if run-count > 0 call, set -preclean and -rerun STUCK/DEAD (if (> run-count 0) ;; handle reruns (begin (if (not (hash-table-ref/default flags "-preclean" #f)) (hash-table-set! flags "-preclean" #t)) @@ -813,12 +815,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) @@ -1301,11 +1303,13 @@ (equal? state (db:test-get-state prevdat)) (equal? status (db:test-get-status prevdat))))) (let ((fmt (runs:gendat-inc-results-fmt runs-data)) (dtime (seconds->year-work-week/day-time event-time))) (if (runs:lownoise "inc-print" 600) - (format #t fmt "State" "Status" "Start Time" "Duration" "Test path")) + (begin + (print "fmt=" fmt) + (format #t fmt "State" "Status" "Start Time" "Duration" "Test path"))) ;; (debug:print 0 *default-log-port* "fmt: " fmt " state: " state " status: " status " test-name: " test-name " item-path: " item-path " dtime: " dtime) ;; (debug:print 0 #f "event-time: " event-time " duration: " duration) (format #t fmt state status @@ -1705,11 +1709,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 +1831,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? ;; @@ -2137,15 +2141,15 @@ (bup-mutex (make-mutex)) (keep-records (args:get-arg "-keep-records")) ;; used in conjunction with -remove-runs to keep the records, TODO: consolidate this with "mode". (test-records '())) ;; for tasks that we wish to operate on all tests in one fell swoop (let* ((write-access-actions '(remove-runs set-state-status archive run-wait kill-runs)) - (dbfile (conc *toppath* "/megatest.db")) + (dbfile (conc *toppath* "/.db/main.db")) (readonly-mode (not (file-writable? dbfile)))) (when (and readonly-mode (member action write-access-actions)) - (debug:print-error 0 *default-log-port* "megatest.db is readonly. Cannot proceed with action ["action"] in which write-access isrequired .") + (debug:print-error 0 *default-log-port* ".db/main.db is readonly. Cannot proceed with action ["action"] in which write-access isrequired .") (exit 1))) (debug:print-info 4 *default-log-port* "runs:operate-on => Header: " header " action: " action " new-state-status: " new-state-status) (if (> 2 (length state-status)) (begin @@ -2740,17 +2744,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 @@ -38,11 +38,11 @@ (prefix sqlite3 sqlite3:) chicken.base chicken.condition chicken.file chicken.file.posix - chicken.format + ;; chicken.format chicken.io chicken.pathname chicken.port chicken.pretty-print chicken.process @@ -54,10 +54,11 @@ chicken.time.posix (prefix base64 base64:) ;; csv-xml directory-utils + format matchable regex s11n srfi-1 srfi-13 @@ -90,11 +91,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)) @@ -1171,24 +1204,24 @@ (define (tests:easy-dot test-records outtype) (let-values (((fd temp-path) (file-mkstemp (conc "/tmp/" (current-user-name) ".XXXXXX")))) (let ((all-testnames (hash-table-keys test-records)) (temp-port (open-output-file* fd))) - ;; (format temp-port "This file is ~A.~%" temp-path) - (format temp-port "digraph tests {\n") - (format temp-port " size=4,8\n") - ;; (format temp-port " splines=none\n") + ;; (chicken.format#format temp-port "This file is ~A.~%" temp-path) + (chicken.format#format temp-port "digraph tests {\n") + (chicken.format#format temp-port " size=4,8\n") + ;; (chicken.format#format temp-port " splines=none\n") (for-each (lambda (testname) (let* ((testrec (hash-table-ref test-records testname)) (waitons (or (tests:testqueue-get-waitons testrec) '()))) (for-each (lambda (waiton) - (format temp-port (conc " " waiton " -> " testname " [splines=ortho]\n"))) + (chicken.format#format temp-port (conc " " waiton " -> " testname " [splines=ortho]\n"))) waitons))) all-testnames) - (format temp-port "}\n") + (chicken.format#format temp-port "}\n") (close-output-port temp-port) (with-input-from-pipe (conc "env -i PATH=$PATH dot -T" outtype " < " temp-path) (lambda () (let ((res (read-lines))) 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)))) ;;======================================================================