Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -34,14 +34,13 @@ debugprint.scm mtver.scm csv-xml.scm servermod.scm \ hostinfo.scm adjutant.scm processmod.scm testsmod.scm \ 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 vgmod.scm + subrunmod.scm bigmod.scm testsmod.scm - -GUISRCF = dashboard-tests.scm \ +GUISRCF = dashboard-tests.scm vgmod.scm \ dashboard-guimonitor.scm tree.scm GUIMODFILES = dashboard-context-menu.scm dcommon.scm gutils.scm mofiles/dashboard-context-menu.o : mofiles/dcommon.o @@ -48,12 +47,12 @@ mofiles/dcommon.o : mofiles/gutils.o OFILES = $(SRCFILES:%.scm=%.o) GOFILES = $(GUISRCF:%.scm=%.o) -MOFILES = $(addprefix mofiles/,$(MSRCFILES:%.scm=%.o)) \ -$(addprefix mofiles/,$(GUIMODFILES:%.scm=%.o)) +MOFILES = $(addprefix mofiles/,$(MSRCFILES:%.scm=%.o)) +GMOFILES = $(addprefix mofiles/,$(GUIMODFILES:%.scm=%.o)) # compiled import files MOIMPFILES = $(MSRCFILES:%.scm=%.import.o) %.import.o : %.import.scm @@ -125,18 +124,18 @@ 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) $(MOIMPFILES) + csc $(CSCOPTS) $(MOFILES) $(MOIMPFILES) megatest.scm -o mtest 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 : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES) $(MOIMPFILES) $(GMOFILES) megatest-fossil-hash.scm + csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MOFILES) $(MOIMPFILES) $(GMOFILES) -o dboard mtut: $(OFILES) $(MOFILES) megatest-fossil-hash.scm mtut.scm csc $(CSCOPTS) $(OFILES) $(MOFILES) mtut.scm -o mtut # include makefile.inc @@ -419,11 +418,11 @@ 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 +portlogger-example : portlogger-example.scm api.o archive.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o genexample.o gutils.o 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 buildmanual: cd docs/manual && make 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") + 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 @@ -92,11 +92,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!) Index: dashboard-context-menu.scm ================================================================== --- dashboard-context-menu.scm +++ dashboard-context-menu.scm @@ -71,12 +71,12 @@ testsmod dcommon ) ;; (include "common_records.scm") -(include "db_records.scm") -(include "run_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 Index: dashboard-guimonitor.scm ================================================================== --- dashboard-guimonitor.scm +++ dashboard-guimonitor.scm @@ -37,13 +37,13 @@ (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") +;; (include "db_records.scm") +;; (include "run_records.scm") +;; (include "task_records.scm") (import commonmod keysmod dbmod Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -20,20 +20,10 @@ ;;====================================================================== ;; Test info panel ;;====================================================================== -(import format fmt) -(import (prefix iup iup:)) - -(import canvas-draw) - -(import srfi-1 - chicken.file.posix - regex regex-case srfi-69 - (prefix sqlite3 sqlite3:)) - (declare (unit dashboard-tests)) (declare (uses commonmod)) (declare (uses dbmod)) (declare (uses gutils)) (declare (uses rmtmod)) @@ -40,27 +30,59 @@ (declare (uses ezstepsmod)) ;; (declare (uses sdb)) ;; (declare (uses filedb)) (declare (uses subrunmod)) (declare (uses debugprint)) +(declare (uses configfmod)) +(declare (uses testsmod)) +(declare (uses mtmod)) +(declare (uses dcommon)) +(declare (uses launchmod)) + +(module dashboard-tests + * + +(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") - -(import - commonmod - dbmod - rmtmod - ezstepsmod - subrunmod - debugprint - ) +;; (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 @@ -469,12 +491,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)) @@ -877,13 +899,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)) @@ -943,16 +965,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 @@ -21,28 +21,10 @@ (import format) (declare (uses ducttape-lib)) (declare (uses bigmod)) (declare (uses debugprint)) - -(import (prefix iup iup:)) -(import canvas-draw) - -;; (import canvas-draw-iup) - -(import ducttape-lib - bigmod) - -(import (prefix sqlite3 sqlite3:) - srfi-1 - chicken.file.posix - chicken.string - chicken.process-context - regex regex-case srfi-69 - typed-records - sparse-vectors) - (declare (uses commonmod)) (declare (uses configfmod)) (declare (uses dashboard-context-menu)) (declare (uses dashboard-guimonitor)) (declare (uses dashboard-tests)) @@ -59,35 +41,53 @@ (declare (uses tree)) (declare (uses vgmod)) (declare (uses bigmod.import)) (declare (uses debugprint.import)) ;; (declare (uses dashboard-main)) + +(import (prefix iup iup:)) +(import canvas-draw) + +;; (import canvas-draw-iup) + +(import ducttape-lib + bigmod) + +(import (prefix sqlite3 sqlite3:) + srfi-1 + chicken.file.posix + chicken.string + chicken.process-context + regex regex-case srfi-69 + typed-records + sparse-vectors) + ;; (include "common_records.scm") -(include "db_records.scm") -(include "run_records.scm") -(include "task_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") - -(import - commonmod - configfmod - dbmod - debugprint - itemsmod - launchmod - (prefix mtargs args:) - mtmod - mtver - processmod - runsmod - subrunmod - vgmod - dcommon - dashboard-context-menu) +;; (include "vg_records.scm") + +(import commonmod + configfmod + dbmod + debugprint + itemsmod + launchmod + (prefix mtargs args:) + mtmod + mtver + processmod + runsmod + subrunmod + vgmod + dcommon + dashboard-context-menu + dashboard-tests) (define help (conc "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " license GPL, Copyright (C) Matt Welland 2012-2017 @@ -304,21 +304,10 @@ (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)))) - ;; register tabdat with BBpp ;; this is used by BBpp (Brandon's pretty printer) to convert dboard:tabdat into a composition of lists that pp will handle (hash-table-set! *BBpp_custom_expanders_list* TABDAT: (cons dboard:tabdat? (lambda (tabdat-item) @@ -332,26 +321,19 @@ (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)))) @@ -509,12 +491,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") @@ -557,28 +537,10 @@ (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))) @@ -1311,60 +1273,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))) - ;;====================================================================== ;; R U N C O N T R O L S ;;====================================================================== ;; ;; A gui for launching tests @@ -2976,11 +2888,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) 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: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -17,10 +17,19 @@ ;; along with Megatest. If not, see . ;; ;;====================================================================== (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)) (module dcommon * (import scheme @@ -31,57 +40,53 @@ chicken.sort chicken.time chicken.file chicken.file.posix + chicken.port chicken.process chicken.process-context - chicken.process-context.posix - - srfi-18 + 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 ) -(declare (uses gutils)) -(declare (uses dbmod)) -(declare (uses mtver)) -(declare (uses debugprint)) -(declare (uses commonmod)) -(declare (uses configfmod)) -(declare (uses rmtmod)) +(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") - -(import - mtver - dbmod - commonmod - debugprint - configfmod - rmtmod - gutils - ) +(include "common_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 ;;====================================================================== ;; @@ -259,10 +264,16 @@ ;; 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 ;;====================================================================== @@ -846,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)))) @@ -1302,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 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 @@ -40,10 +40,28 @@ 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))) Index: index-tree.scm ================================================================== --- index-tree.scm +++ index-tree.scm @@ -32,14 +32,14 @@ (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") +;; (include "key_records.scm") +;; (include "db_records.scm") +;; (include "run_records.scm") +;; (include "test_records.scm") ;; Populate the links tree with index.html files ;; ;; - start from most recent tests and work towards oldest -OR- ;; start from deepest hierarchy and work way up DELETED monitor.scm Index: monitor.scm ================================================================== --- monitor.scm +++ /dev/null @@ -1,33 +0,0 @@ -;; Copyright 2006-2012, Matthew Welland. -;; -;; This file is part of Megatest. -;; -;; Megatest is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. -;; -;; Megatest is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with Megatest. If not, see . - -;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') - -(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking) -(import (prefix sqlite3 sqlite3:)) - -(declare (unit runs)) -(declare (uses db)) -(declare (uses common)) -(declare (uses items)) -(declare (uses runconfig)) - -;; (include "common_records.scm") -(include "key_records.scm") -(include "db_records.scm") -(include "run_records.scm") - Index: 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) ")")))) -