Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -1,16 +1,36 @@ PREFIX=. -FILES=$(shell ls *.scm) +SRCFILES = common.scm items.scm launch.scm \ + ods.scm runconfig.scm server.scm configf.scm \ + db.scm keys.scm margs.scm megatest-version.scm \ + process.scm runs.scm + +GUISRCF = dashboard.scm dboard.scm dashboard-tests.scm + +OFILES = $(SRCFILES:%.scm=%.o) +GOFILES = $(GUISRCF:%.scm=%.o) + HELPERS=$(addprefix $(PREFIX)/bin/,mt_laststep mt_runstep) -megatest: $(FILES) - csc megatest.scm +all : megatest dashboard + +megatest: $(OFILES) megatest.o + csc $(OFILES) megatest.o -o megatest + +dashboard: $(OFILES) $(GOFILES) + csc $(OFILES) $(GOFILES) -o dashboard + +db.o launch.o runs.o : db_records.scm + +keys.o db.o runs.o launch.o : key_records.scm + +$(OFILES) $(GOFILES) : common_records.scm -dashboard: $(FILES) - csc dashboard.scm +%.o : %.scm + csc -c $< $(PREFIX)/bin/megatest : megatest @echo Installing to PREFIX=$(PREFIX), use ^C to cancel and change sleep 2 cp megatest $(PREFIX)/bin/megatest Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -15,12 +15,16 @@ (require-extension (srfi 18) extras tcp rpc) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) +(declare (unit common)) + +(include "common_records.scm") + ;; (require-library margs) -(include "margs.scm") +;; (include "margs.scm") (define getenv get-environment-variable) (define home (getenv "HOME")) (define user (getenv "USER")) @@ -34,31 +38,22 @@ (define *globalexitstatus* 0) ;; attempt to work around possible thread issues (define *passnum* 0) ;; when running track calls to run-tests or similar (define *verbosity* 1) (define *rpc:listener* #f) ;; if set up for server communication this will hold the tcp port -(define-inline (get-with-default val default) +(define (get-with-default val default) (let ((val (args:get-arg val))) (if val val default))) -(define-inline (assoc/default key lst . default) +(define (assoc/default key lst . default) (let ((res (assoc key lst))) (if res (cadr res)(if (null? default) #f (car default))))) ;;====================================================================== ;; Misc utils ;;====================================================================== -(define-inline (debug:print n . params) - (if (<= n *verbosity*) - (apply print params))) - -;; if a value is printable (i.e. string or number) return the value -;; else return an empty string -(define-inline (printable val) - (if (or (number? val)(string? val)) val "")) - ;; convert stuff to a number if possible (define (any->number val) (cond ((number? val) val) ((string? val) (string->number val)) ADDED common_records.scm Index: common_records.scm ================================================================== --- /dev/null +++ common_records.scm @@ -0,0 +1,9 @@ +(define-inline (debug:print n . params) + (if (<= n *verbosity*) + (apply print params))) + +;; if a value is printable (i.e. string or number) return the value +;; else return an empty string +(define-inline (printable val) + (if (or (number? val)(string? val)) val "")) + Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -11,10 +11,17 @@ ;;====================================================================== ;; Config file handling ;;====================================================================== +(use regex regex-case) +(declare (unit configf)) +(declare (uses common)) +(declare (uses process)) + +(include "common_records.scm") + ;; return list (path fullpath configname) (define (find-config configname) (let* ((cwd (string-split (current-directory) "/"))) (let loop ((dir cwd)) (let* ((path (conc "/" (string-intersperse dir "/"))) Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -10,10 +10,18 @@ ;;====================================================================== ;;====================================================================== ;; Test info panel ;;====================================================================== + +(declare (unit dashboard-tests)) +(declare (uses common)) +(declare (uses db)) +(declare (uses dboard)) + +(include "common_records.scm") + (define (test-info-panel testdat store-label widgets) (iup:frame #:title "Test Info" ; #:expand "YES" (iup:hbox ; #:expand "YES" (apply iup:vbox ; #:expand "YES" Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -14,25 +14,26 @@ (import (prefix iup iup:)) (use canvas-draw) (use sqlite3 srfi-1 posix regex regex-case srfi-69) - (import (prefix sqlite3 sqlite3:)) -(include "common.scm") -(include "margs.scm") -(include "keys.scm") -(include "items.scm") -(include "db.scm") -(include "configf.scm") -(include "process.scm") -(include "launch.scm") -(include "runs.scm") -(include "gui.scm") -(include "dashboard-tests.scm") -(include "megatest-version.scm") +(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 dboard)) +(declare (uses dashboard-tests)) +(declare (uses megatest-version)) + +(include "common_records.scm") (define help (conc "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " license GPL, Copyright (C) Matt Welland 2011 Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -10,10 +10,21 @@ ;;====================================================================== ;;====================================================================== ;; Database access ;;====================================================================== + +(use sqlite3 srfi-1 posix regex regex-case srfi-69) +(import (prefix sqlite3 sqlite3:)) + +(declare (unit db)) +(declare (uses common)) +(declare (uses keys)) + +(include "common_records.scm") +(include "db_records.scm") +(include "key_records.scm") (define (open-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) (let* ((dbpath (conc *toppath* "/megatest.db")) ;; fname) (configdat (car *configinfo*)) (dbexists (file-exists? dbpath)) @@ -235,13 +246,10 @@ (set! *db-keys* res) res))) (define db:get-keys db-get-keys) -(define-inline (db:get-header vec)(vector-ref vec 0)) -(define-inline (db:get-rows vec)(vector-ref vec 1)) - (define (db:get-value-by-header row header field) (if (null? header) #f (let loop ((hed (car header)) (tal (cdr header)) (n 0)) @@ -312,13 +320,10 @@ db "SELECT COUNT(id) FROM runs WHERE runname LIKE ?;" runpatt) numruns)) -;; use this one for db-get-run-info -(define-inline (db:get-row vec)(vector-ref vec 1)) - ;; use (get-value-by-header (db:get-header runinfo)(db:get-row runinfo)) (define (db:get-run-info db run-id) (let* ((res #f) (keys (db-get-keys db)) (remfields (list "id" "runname" "state" "status" "owner" "event_time")) @@ -342,39 +347,10 @@ ;;====================================================================== ;; T E S T S ;;====================================================================== -(define (make-db:test)(make-vector 6)) -(define-inline (db:test-get-id vec) (vector-ref vec 0)) -(define-inline (db:test-get-run_id vec) (vector-ref vec 1)) -(define-inline (db:test-get-testname vec) (vector-ref vec 2)) -(define-inline (db:test-get-state vec) (vector-ref vec 3)) -(define-inline (db:test-get-status vec) (vector-ref vec 4)) -(define-inline (db:test-get-event_time vec) (vector-ref vec 5)) -(define-inline (db:test-get-host vec) (vector-ref vec 6)) -(define-inline (db:test-get-cpuload vec) (vector-ref vec 7)) -(define-inline (db:test-get-diskfree vec) (vector-ref vec 8)) -(define-inline (db:test-get-uname vec) (vector-ref vec 9)) -(define-inline (db:test-get-rundir vec) (vector-ref vec 10)) -(define-inline (db:test-get-item-path vec) (vector-ref vec 11)) -(define-inline (db:test-get-run_duration vec) (vector-ref vec 12)) -(define-inline (db:test-get-final_logf vec) (vector-ref vec 13)) -(define-inline (db:test-get-comment vec) (vector-ref vec 14)) -(define-inline (db:test-get-fullname vec) - (conc (db:test-get-testname vec) "/" (db:test-get-item-path vec))) -;; (define-inline (db:test-get-value vec) (printable (vector-ref vec 15))) -;; (define-inline (db:test-get-expected_value vec)(printable (vector-ref vec 16))) -;; (define-inline (db:test-get-tol vec) (printable (vector-ref vec 17))) -;; (define-inline (db:test-get-units vec) (printable (vector-ref vec 15))) ;; 18))) -(define-inline (db:test-get-first_err vec) (printable (vector-ref vec 15))) ;; 19))) -(define-inline (db:test-get-first_warn vec) (printable (vector-ref vec 16))) ;; 20))) - -(define-inline (db:test-set-testname! vec val)(vector-set! vec 2 val)) -(define-inline (db:test-set-state! vec val)(vector-set! vec 3 val)) -(define-inline (db:test-set-status! vec val)(vector-set! vec 4 val)) - (define (db-get-tests-for-run db run-id testpatt itempatt) (let ((res '())) (sqlite3:for-each-row (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment first-err first-warn) (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment first-err first-warn) res))) @@ -474,32 +450,10 @@ ;;====================================================================== ;; Tests meta data ;;====================================================================== -;; make-vector-record db testmeta id testname author owner description reviewed iterated avg_runtime avg_disk -(define (make-db:testmeta)(make-vector 10 "")) -(define-inline (db:testmeta-get-id vec) (vector-ref vec 0)) -(define-inline (db:testmeta-get-testname vec) (vector-ref vec 1)) -(define-inline (db:testmeta-get-author vec) (vector-ref vec 2)) -(define-inline (db:testmeta-get-owner vec) (vector-ref vec 3)) -(define-inline (db:testmeta-get-description vec) (vector-ref vec 4)) -(define-inline (db:testmeta-get-reviewed vec) (vector-ref vec 5)) -(define-inline (db:testmeta-get-iterated vec) (vector-ref vec 6)) -(define-inline (db:testmeta-get-avg_runtime vec) (vector-ref vec 7)) -(define-inline (db:testmeta-get-avg_disk vec) (vector-ref vec 8)) -(define-inline (db:testmeta-get-tags vec) (vector-ref vec 9)) -(define-inline (db:testmeta-set-id! vec val)(vector-set! vec 0 val)) -(define-inline (db:testmeta-set-testname! vec val)(vector-set! vec 1 val)) -(define-inline (db:testmeta-set-author! vec val)(vector-set! vec 2 val)) -(define-inline (db:testmeta-set-owner! vec val)(vector-set! vec 3 val)) -(define-inline (db:testmeta-set-description! vec val)(vector-set! vec 4 val)) -(define-inline (db:testmeta-set-reviewed! vec val)(vector-set! vec 5 val)) -(define-inline (db:testmeta-set-iterated! vec val)(vector-set! vec 6 val)) -(define-inline (db:testmeta-set-avg_runtime! vec val)(vector-set! vec 7 val)) -(define-inline (db:testmeta-set-avg_disk! vec val)(vector-set! vec 8 val)) - ;; read the record given a testname (define (db:testmeta-get-record db testname) (let ((res #f)) (sqlite3:for-each-row (lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags) @@ -517,21 +471,10 @@ (sqlite3:execute db (conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname)) ;;====================================================================== ;; T E S T D A T A ;;====================================================================== -(define (make-db:test-data)(make-vector 10)) -(define-inline (db:test-data-get-id vec) (vector-ref vec 0)) -(define-inline (db:test-data-get-test_id vec) (vector-ref vec 1)) -(define-inline (db:test-data-get-category vec) (vector-ref vec 2)) -(define-inline (db:test-data-get-variable vec) (vector-ref vec 3)) -(define-inline (db:test-data-get-value vec) (vector-ref vec 4)) -(define-inline (db:test-data-get-expected vec) (vector-ref vec 5)) -(define-inline (db:test-data-get-tol vec) (vector-ref vec 6)) -(define-inline (db:test-data-get-units vec) (vector-ref vec 7)) -(define-inline (db:test-data-get-comment vec) (vector-ref vec 8)) -(define-inline (db:test-data-get-status vec) (vector-ref vec 9)) (define (db:csv->test-data db test-id csvdata) (debug:print 4 "test-id " test-id ", csvdata: " csvdata) (let ((csvlist (csv->list (make-csv-reader (open-input-string csvdata) @@ -644,25 +587,10 @@ (values #f #f #f)) ;;====================================================================== ;; 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 6)) -(define-inline (db:step-get-id vec) (vector-ref vec 0)) -(define-inline (db:step-get-test_id vec) (vector-ref vec 1)) -(define-inline (db:step-get-stepname vec) (vector-ref vec 2)) -(define-inline (db:step-get-state vec) (vector-ref vec 3)) -(define-inline (db:step-get-status vec) (vector-ref vec 4)) -(define-inline (db:step-get-event_time vec) (vector-ref vec 5)) -(define-inline (db:step-set-id! vec val)(vector-set! vec 0 val)) -(define-inline (db:step-set-test_id! vec val)(vector-set! vec 1 val)) -(define-inline (db:step-set-stepname! vec val)(vector-set! vec 2 val)) -(define-inline (db:step-set-state! vec val)(vector-set! vec 3 val)) -(define-inline (db:step-set-status! vec val)(vector-set! vec 4 val)) -(define-inline (db:step-set-event_time! vec val)(vector-set! vec 5 val)) (define (db:step-get-time-as-string vec) (seconds->time-string (db:step-get-event_time vec))) ;; db-get-test-steps-for-run @@ -673,24 +601,10 @@ (set! res (cons (vector id test-id stepname state status event-time) res))) db "SELECT id,test_id,stepname,state,status,event_time FROM test_steps WHERE test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; test-id) (reverse res))) - -;; -(define (make-db:steps-table)(make-vector 5)) -(define-inline (db:steps-table-get-stepname vec) (vector-ref vec 0)) -(define-inline (db:steps-table-get-start vec) (vector-ref vec 1)) -(define-inline (db:steps-table-get-end vec) (vector-ref vec 2)) -(define-inline (db:steps-table-get-status vec) (vector-ref vec 3)) -(define-inline (db:steps-table-get-runtime vec) (vector-ref vec 4)) -(define-inline (db:step-stable-set-stepname! vec val)(vector-set! vec 0 val)) -(define-inline (db:step-stable-set-start! vec val)(vector-set! vec 1 val)) -(define-inline (db:step-stable-set-end! vec val)(vector-set! vec 2 val)) -(define-inline (db:step-stable-set-status! vec val)(vector-set! vec 3 val)) -(define-inline (db:step-stable-set-runtime! vec val)(vector-set! vec 4 val)) - ;; get a pretty table to summarize steps ;; (define (db:get-steps-table db test-id) (let ((steps (db:get-steps-for-test db test-id))) ADDED db_records.scm Index: db_records.scm ================================================================== --- /dev/null +++ db_records.scm @@ -0,0 +1,105 @@ +(define (make-db:test)(make-vector 6)) +(define-inline (db:test-get-id vec) (vector-ref vec 0)) +(define-inline (db:test-get-run_id vec) (vector-ref vec 1)) +(define-inline (db:test-get-testname vec) (vector-ref vec 2)) +(define-inline (db:test-get-state vec) (vector-ref vec 3)) +(define-inline (db:test-get-status vec) (vector-ref vec 4)) +(define-inline (db:test-get-event_time vec) (vector-ref vec 5)) +(define-inline (db:test-get-host vec) (vector-ref vec 6)) +(define-inline (db:test-get-cpuload vec) (vector-ref vec 7)) +(define-inline (db:test-get-diskfree vec) (vector-ref vec 8)) +(define-inline (db:test-get-uname vec) (vector-ref vec 9)) +(define-inline (db:test-get-rundir vec) (vector-ref vec 10)) +(define-inline (db:test-get-item-path vec) (vector-ref vec 11)) +(define-inline (db:test-get-run_duration vec) (vector-ref vec 12)) +(define-inline (db:test-get-final_logf vec) (vector-ref vec 13)) +(define-inline (db:test-get-comment vec) (vector-ref vec 14)) +(define-inline (db:test-get-fullname vec) + (conc (db:test-get-testname vec) "/" (db:test-get-item-path vec))) +;; (define-inline (db:test-get-value vec) (printable (vector-ref vec 15))) +;; (define-inline (db:test-get-expected_value vec)(printable (vector-ref vec 16))) +;; (define-inline (db:test-get-tol vec) (printable (vector-ref vec 17))) +;; (define-inline (db:test-get-units vec) (printable (vector-ref vec 15))) ;; 18))) +(define-inline (db:test-get-first_err vec) (printable (vector-ref vec 15))) ;; 19))) +(define-inline (db:test-get-first_warn vec) (printable (vector-ref vec 16))) ;; 20))) + +(define-inline (db:test-set-testname! vec val)(vector-set! vec 2 val)) +(define-inline (db:test-set-state! vec val)(vector-set! vec 3 val)) +(define-inline (db:test-set-status! vec val)(vector-set! vec 4 val)) + +;; get rows and header from +(define-inline (db:get-header vec)(vector-ref vec 0)) +(define-inline (db:get-rows vec)(vector-ref vec 1)) + +;; make-vector-record db testmeta id testname author owner description reviewed iterated avg_runtime avg_disk +(define (make-db:testmeta)(make-vector 10 "")) +(define-inline (db:testmeta-get-id vec) (vector-ref vec 0)) +(define-inline (db:testmeta-get-testname vec) (vector-ref vec 1)) +(define-inline (db:testmeta-get-author vec) (vector-ref vec 2)) +(define-inline (db:testmeta-get-owner vec) (vector-ref vec 3)) +(define-inline (db:testmeta-get-description vec) (vector-ref vec 4)) +(define-inline (db:testmeta-get-reviewed vec) (vector-ref vec 5)) +(define-inline (db:testmeta-get-iterated vec) (vector-ref vec 6)) +(define-inline (db:testmeta-get-avg_runtime vec) (vector-ref vec 7)) +(define-inline (db:testmeta-get-avg_disk vec) (vector-ref vec 8)) +(define-inline (db:testmeta-get-tags vec) (vector-ref vec 9)) +(define-inline (db:testmeta-set-id! vec val)(vector-set! vec 0 val)) +(define-inline (db:testmeta-set-testname! vec val)(vector-set! vec 1 val)) +(define-inline (db:testmeta-set-author! vec val)(vector-set! vec 2 val)) +(define-inline (db:testmeta-set-owner! vec val)(vector-set! vec 3 val)) +(define-inline (db:testmeta-set-description! vec val)(vector-set! vec 4 val)) +(define-inline (db:testmeta-set-reviewed! vec val)(vector-set! vec 5 val)) +(define-inline (db:testmeta-set-iterated! vec val)(vector-set! vec 6 val)) +(define-inline (db:testmeta-set-avg_runtime! vec val)(vector-set! vec 7 val)) +(define-inline (db:testmeta-set-avg_disk! vec val)(vector-set! vec 8 val)) + +;;====================================================================== +;; T E S T D A T A +;;====================================================================== +(define (make-db:test-data)(make-vector 10)) +(define-inline (db:test-data-get-id vec) (vector-ref vec 0)) +(define-inline (db:test-data-get-test_id vec) (vector-ref vec 1)) +(define-inline (db:test-data-get-category vec) (vector-ref vec 2)) +(define-inline (db:test-data-get-variable vec) (vector-ref vec 3)) +(define-inline (db:test-data-get-value vec) (vector-ref vec 4)) +(define-inline (db:test-data-get-expected vec) (vector-ref vec 5)) +(define-inline (db:test-data-get-tol vec) (vector-ref vec 6)) +(define-inline (db:test-data-get-units vec) (vector-ref vec 7)) +(define-inline (db:test-data-get-comment vec) (vector-ref vec 8)) +(define-inline (db:test-data-get-status vec) (vector-ref vec 9)) + +;;====================================================================== +;; 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 6)) +(define-inline (db:step-get-id vec) (vector-ref vec 0)) +(define-inline (db:step-get-test_id vec) (vector-ref vec 1)) +(define-inline (db:step-get-stepname vec) (vector-ref vec 2)) +(define-inline (db:step-get-state vec) (vector-ref vec 3)) +(define-inline (db:step-get-status vec) (vector-ref vec 4)) +(define-inline (db:step-get-event_time vec) (vector-ref vec 5)) +(define-inline (db:step-set-id! vec val)(vector-set! vec 0 val)) +(define-inline (db:step-set-test_id! vec val)(vector-set! vec 1 val)) +(define-inline (db:step-set-stepname! vec val)(vector-set! vec 2 val)) +(define-inline (db:step-set-state! vec val)(vector-set! vec 3 val)) +(define-inline (db:step-set-status! vec val)(vector-set! vec 4 val)) +(define-inline (db:step-set-event_time! vec val)(vector-set! vec 5 val)) + +;; The steps table +(define (make-db:steps-table)(make-vector 5)) +(define-inline (db:steps-table-get-stepname vec) (vector-ref vec 0)) +(define-inline (db:steps-table-get-start vec) (vector-ref vec 1)) +(define-inline (db:steps-table-get-end vec) (vector-ref vec 2)) +(define-inline (db:steps-table-get-status vec) (vector-ref vec 3)) +(define-inline (db:steps-table-get-runtime vec) (vector-ref vec 4)) +(define-inline (db:step-stable-set-stepname! vec val)(vector-set! vec 0 val)) +(define-inline (db:step-stable-set-start! vec val)(vector-set! vec 1 val)) +(define-inline (db:step-stable-set-end! vec val)(vector-set! vec 2 val)) +(define-inline (db:step-stable-set-status! vec val)(vector-set! vec 3 val)) +(define-inline (db:step-stable-set-runtime! vec val)(vector-set! vec 4 val)) + +;; use this one for db-get-run-info +(define-inline (db:get-row vec)(vector-ref vec 1)) + Index: dboard.scm ================================================================== --- dboard.scm +++ dboard.scm @@ -11,26 +11,28 @@ (use format) (require-library iup) (import (prefix iup iup:)) +(declare (unit dboard)) +(declare (uses common)) +(declare (uses db)) +(declare (uses margs)) +(declare (uses keys)) +(declare (uses configf)) +(declare (uses process)) +(declare (uses launch)) +(declare (uses runs)) + +(include "common_records.scm") + ;; (use canvas-draw) (use sqlite3 srfi-1 posix regex regex-case srfi-69) (import (prefix sqlite3 sqlite3:)) -(include "margs.scm") -(include "keys.scm") -(include "items.scm") -(include "db.scm") -(include "configf.scm") -(include "process.scm") -(include "launch.scm") -(include "runs.scm") -(include "gui.scm") - (define help " Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version 0.2 license GPL, Copyright Matt Welland 2011 DELETED gui.scm Index: gui.scm ================================================================== --- gui.scm +++ /dev/null @@ -1,58 +0,0 @@ - -;; Copyright 2006-2011, Matthew Welland. -;; -;; This program is made available under the GNU GPL version 2.0 or -;; greater. See the accompanying file COPYING for details. -;; -;; This program is distributed WITHOUT ANY WARRANTY; without even the -;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR -;; PURPOSE. - -;; (define (celsius->fahrenheit item) -;; (let ((number (string->number item))) -;; (if (number? number) -;; (+ (* number 9/5) 32) -;; 0.0))) - -;; (define (megatest-gui-1) -;; (use pstk) -;; (handle-exceptions -;; exn -;; (tk-end) ; make sure tk is closed in event of any error -;; -;; (tk-start) -;; (tk/wm 'title tk "Celsius to Fahrenheit") -;; (let* ((celsius (tk 'create-widget 'entry)) -;; (label (tk 'create-widget 'label)) -;; (button (tk 'create-widget 'button -;; 'text: 'Calculate -;; 'command: (lambda () -;; (label 'configure -;; 'text: (number->string (celsius->fahrenheit (celsius 'get)))))))) -;; ; layout widgets in a grid -;; (tk/grid celsius 'column: 2 'row: 1 'sticky: 'we 'padx: 5 'pady: 5) -;; (tk/grid label 'column: 2 'row: 2 'sticky: 'we 'padx: 5 'pady: 5) -;; (tk/grid button 'column: 2 'row: 3 'sticky: 'we 'padx: 5 'pady: 5) -;; (tk/grid (tk 'create-widget 'label 'text: "celsius") -;; 'column: 3 'row: 1 'sticky: 'w 'padx: 5 'pady: 5) -;; (tk/grid (tk 'create-widget 'label 'text: "is") -;; 'column: 1 'row: 2 'sticky: 'e 'padx: 5 'pady: 5) -;; (tk/grid (tk 'create-widget 'label 'text: "fahrenheit") -;; 'column: 3 'row: 2 'sticky: 'w 'padx: 5 'pady: 5) ; begin program -;; ; rest of gui setup -;; (tk-event-loop)) -;; )) - -(define (init-dialog) - ;; (let ((controls-frame (iup:frame - ;; (iup:hbox - #t) - -;; For now the gui work will be done in dashboard.scm - -;;(define (megatest-gui) -;; (require-library iup) -;; (import (prefix iup iup:)) -;; (use canvas-draw canvas-draw-iup) -;; (use srfi-4)) - Index: items.scm ================================================================== --- items.scm +++ items.scm @@ -11,10 +11,15 @@ ;; (define itemdat '((ripeness "green ripe overripe") ;; (temperature "cool medium hot") ;; (season "summer winter fall spring"))) +(declare (unit items)) +(declare (uses common)) + +(include "common_records.scm") + ;; Mostly worked = puts out all combinations? (define (process-itemlist-try1 curritemkey itemlist) (let loop ((hed (car itemlist)) (tal (cdr itemlist))) (if (null? tal) @@ -113,12 +118,9 @@ #f))) res))) ;; Nope, not now, return null as of 6/6/2011 -(define-inline (item-list->path itemdat) - (string-intersperse (map cadr itemdat) "/")) - ;; (pp (item-assoc->item-list itemdat)) ADDED key_records.scm Index: key_records.scm ================================================================== --- /dev/null +++ key_records.scm @@ -0,0 +1,12 @@ +(define-inline (key:get-fieldname key)(vector-ref key 0)) +(define-inline (key:get-fieldtype key)(vector-ref key 1)) + +(define-inline (keys->valslots keys) ;; => ?,?,? .... + (string-intersperse (map (lambda (x) "?") keys) ",")) + +(define-inline (keys->key/field keys . additional) + (string-join (map (lambda (k)(conc (key:get-fieldname k) " " (key:get-fieldtype k)))(append keys additional)) ",")) + +(define-inline (item-list->path itemdat) + (string-intersperse (map cadr itemdat) "/")) + Index: keys.scm ================================================================== --- keys.scm +++ keys.scm @@ -10,13 +10,18 @@ ;;====================================================================== ;; Run keys, these are used to hierarchially organise tests and run areas ;;====================================================================== +(use sqlite3 srfi-1 posix regex regex-case srfi-69) +(import (prefix sqlite3 sqlite3:)) + +(declare (unit keys)) +(declare (uses common)) -(define-inline (key:get-fieldname key)(vector-ref key 0)) -(define-inline (key:get-fieldtype key)(vector-ref key 1)) +(include "key_records.scm") +(include "common_records.scm") (define (get-keys db) (let ((keys '())) ;; keys are vectors (sqlite3:for-each-row (lambda (fieldname fieldtype) (set! keys (cons (vector fieldname fieldtype) keys))) @@ -58,16 +63,10 @@ (reverse res))) (define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ... (string-intersperse (map key:get-fieldname keys) ",")) -(define-inline (keys->valslots keys) ;; => ?,?,? .... - (string-intersperse (map (lambda (x) "?") keys) ",")) - -(define-inline (keys->key/field keys . additional) - (string-join (map (lambda (k)(conc (key:get-fieldname k) " " (key:get-fieldtype k)))(append keys additional)) ",")) - (define (args:usage . a) #f) ;; keys->vallist is called several times (quite unnecessarily), use this hash to suppress multiple ;; reporting of missing keys on the command line. (define keys:warning-suppress-hash (make-hash-table)) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -10,10 +10,22 @@ ;;====================================================================== ;; launch a task - this runs on the originating host, tests themselves ;; ;;====================================================================== + +(use regex regex-case base64) +(import (prefix base64 base64:)) + +(declare (unit launch)) +(declare (uses common)) +(declare (uses configf)) +(declare (uses db)) + +(include "common_records.scm") +(include "key_records.scm") +(include "db_records.scm") (define (setup-for-run) (set! *configinfo* (find-and-read-config (if (args:get-arg "-config")(args:get-arg "-config") "megatest.config"))) (set! *configdat* (if (car *configinfo*)(car *configinfo*) #f)) (set! *toppath* (if (car *configinfo*)(cadr *configinfo*) #f)) Index: margs.scm ================================================================== --- margs.scm +++ margs.scm @@ -5,10 +5,13 @@ ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. +(declare (unit margs)) +(declare (uses common)) + (define args:arg-hash (make-hash-table)) (define (args:get-arg arg . default) (if (null? default) (hash-table-ref/default args:arg-hash arg #f) Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -1,3 +1,6 @@ ;; Always use two digit decimal ;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00.. + +(declare (unit megatest-version)) + (define megatest-version 1.26) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -5,12 +5,20 @@ ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. -(include "common.scm") -(include "megatest-version.scm") +;; (include "common.scm") +;; (include "megatest-version.scm") + +(declare (uses common)) +(declare (uses megatest-version)) +(declare (uses margs)) +(declare (uses runs)) +(declare (uses launch)) + +(include "common_records.scm") (define help (conc " Megatest, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " license GPL, Copyright Matt Welland 2006-2011 @@ -152,20 +160,10 @@ (if (args:get-arg "-h") (begin (print help) (exit))) -(include "keys.scm") -(include "items.scm") -(include "db.scm") -(include "configf.scm") -(include "process.scm") -(include "launch.scm") -(include "runs.scm") -(include "runconfig.scm") -(include "ods.scm") - (define *didsomething* #f) ;;====================================================================== ;; Misc setup stuff ;;====================================================================== Index: ods.scm ================================================================== --- ods.scm +++ ods.scm @@ -6,10 +6,12 @@ ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE (use csv-xml) +(declare (unit ods)) +(declare (uses common)) (define ods:dirs '("Configurations2" "Configurations2/toolpanel" "Configurations2/menubar" Index: process.scm ================================================================== --- process.scm +++ process.scm @@ -10,10 +10,13 @@ ;;====================================================================== ;;====================================================================== ;; Process convience utils ;;====================================================================== + +(declare (unit process)) +(declare (uses common)) (define (cmd-run-proc-each-line cmd proc . params) ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params) (handle-exceptions exn Index: runconfig.scm ================================================================== --- runconfig.scm +++ runconfig.scm @@ -1,9 +1,17 @@ ;;====================================================================== ;; read a config file, loading only the section pertinent ;; to this run field1val/field2val/field3val ... ;;====================================================================== + +(use format) + +(declare (unit runconfig)) +(declare (uses common)) + +(include "common_records.scm") + (define (setup-env-defaults db fname run-id . already-seen) (let* ((keys (get-keys db)) (keyvals (get-key-vals db run-id)) (thekey (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/")) (confdat (read-config fname #f #f)) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -7,10 +7,23 @@ ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') + +(use sqlite3 srfi-1 posix regex regex-case srfi-69) +(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") ;; register a test run with the db (define (register-run db keys) ;; test-name) (let* ((keystr (keys->keystr keys)) (comma (if (> (length keys) 0) "," "")) Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -5,10 +5,12 @@ ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. + +(declare (unit server)) ;; procstr is the name of the procedure to be called as a string (define (server:autoremote procstr params) (handle-exceptions exn