Index: .fossil-settings/ignore-glob ================================================================== --- .fossil-settings/ignore-glob +++ .fossil-settings/ignore-glob @@ -1,5 +1,6 @@ +altdb.scm utils/build/* *~ *.o bin/* megatest.db Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -61,10 +61,11 @@ db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm tests.o tasks.o dashboard-tasks.o : task_records.scm runs.o : test_records.scm megatest.o : megatest-fossil-hash.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm rpc-transport.scm +common_records.scm : altdb.scm # Temporary while transitioning to new routine # runs.o : run-tests-queue-classic.scm run-tests-queue-new.scm megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm @@ -164,11 +165,11 @@ $(MTQA_FOSSIL) : fossil clone https://www.kiatoa.com/fossils/megatest_qa $(MTQA_FOSSIL) clean : - rm -f $(OFILES) $(GOFILES) megatest dboard dboard.o megatest.o dashboard.o + rm -f $(OFILES) $(GOFILES) megatest dboard dboard.o megatest.o dashboard.o megatest-fossil-hash.* altdb.scm # Deploy section (not complete yet) # $(DEPLOYHELPERS) : utils/mt_* $(INSTALL) $< $@ @@ -233,8 +234,18 @@ if egrep 'version.*3.0' $(shell dirname $(shell dirname $(shell which csi)))/lib/chicken/7/readline.setup-info;then \ echo "(use-legacy-bindings)" > readline-fix.scm; \ else \ echo "" > readline-fix.scm;\ fi + +altdb.scm : + echo ";; optional alternate db setup" > altdb.scm + echo "(define *available-db* (make-hash-table))" >> altdb.scm + if csi -ne '(use mysql-client)';then \ + echo "(use mysql-client)(hash-table-set! *available-db* 'mysql #t)" >> altdb.scm; \ + fi + if csi -ne '(use postgresql)';then \ + echo "(use postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\ + fi portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o daemon.o dashboard-tests.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 megatest-version.o mt.o nmsg-transport.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o csc portlogger-example.scm api.o archive.o client.o common.o configf.o daemon.o dashboard-tests.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 megatest-version.o mt.o nmsg-transport.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -47,10 +47,11 @@ get-prev-run-ids get-run-ids-matching-target get-runs-by-patt get-steps-data get-steps-for-test + read-test-data login testmeta-get-record have-incompletes? synchash-get )) @@ -226,10 +227,13 @@ ;; STEPS ((get-steps-data) (apply db:get-steps-data dbstruct params)) ((get-steps-for-test) (apply db:get-steps-for-test dbstruct params)) + ;; TEST DATA + ((read-test-data) (apply db:read-test-data dbstruct params)) + ;; MISC ((have-incompletes?) (apply db:have-incompletes? dbstruct params)) ((login) (apply db:login dbstruct params)) ((general-call) (let ((stmtname (car params)) (run-id (cadr params)) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -129,10 +129,69 @@ ;; Generic string database (define sdb:qry #f) ;; (make-sdb:qry)) ;; 'init #f) ;; Generic path database (define *fdb* #f) + +;;====================================================================== +;; V E R S I O N +;;====================================================================== + +(define (common:get-full-version) + (conc megatest-version "-" megatest-fossil-hash)) + +(define (common:version-signature) + (conc megatest-version "-" (substring megatest-fossil-hash 0 4))) + +;; from metadat lookup MEGATEST_VERSION +;; +(define (common:get-last-run-version) + (rmt:get-var "MEGATEST_VERSION")) + +(define (common:set-last-run-version) + (rmt:set-var "MEGATEST_VERSION" (common:version-signature))) + +(define (common:version-changed?) + (not (equal? (common:get-last-run-version) + (common:version-signature)))) + +(define (common:exit-on-version-changed) + (if (common:version-changed?) + (begin + (debug:print 0 + "ERROR: Version mismatch!\n" + " expected: " (common:version-signature) "\n" + " got: " (common:get-last-run-version) "\n" + " to switch versions you can run: \"megatest -cleanup-db\"") + (exit 1)))) + +;;====================================================================== +;; S P A R S E A R R A Y S +;;====================================================================== + +(define (make-sparse-array) + (let ((a (make-sparse-vector))) + (sparse-vector-set! a 0 (make-sparse-vector)) + a)) + +(define (sparse-array? a) + (and (sparse-vector? a) + (sparse-vector? (sparse-vector-ref a 0)))) + +(define (sparse-array-ref a x y) + (let ((row (sparse-vector-ref a x))) + (if row + (sparse-vector-ref row y) + #f))) + +(define (sparse-array-set! a x y val) + (let ((row (sparse-vector-ref a x))) + (if row + (sparse-vector-set! row y val) + (let ((new-row (make-sparse-vector))) + (sparse-vector-set! a x new-row) + (sparse-vector-set! new-row y val))))) ;;====================================================================== ;; L O C K E R S A N D B L O C K E R S ;;====================================================================== @@ -334,11 +393,11 @@ ;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway (exit)) (set-signal-handler! signal/int std-signal-handler) ;; ^C (set-signal-handler! signal/term std-signal-handler) -(set-signal-handler! signal/stop std-signal-handler) ;; ^Z +;; (set-signal-handler! signal/stop std-signal-handler) ;; ^Z NO, do NOT handle ^Z! ;;====================================================================== ;; M I S C U T I L S ;;====================================================================== @@ -362,13 +421,10 @@ ((d) (* 24 60 60)) (else 0)))))))))) parts) time-secs)) -(define (common:version-signature) - (conc megatest-version "-" (substring megatest-fossil-hash 0 4))) - ;; one-of args defined (define (args-defined? . param) (let ((res #f)) (for-each (lambda (arg) @@ -525,11 +581,11 @@ (cdr tal)) (max hed max-val)))) ;;====================================================================== -;; Munge data into nice forms +;; M U N G E D A T A I N T O N I C E F O R M S ;;====================================================================== ;; Generate an index for a sparse list of key values ;; ( (rowname1 colname1 val1)(rowname2 colname2 val2) ) ;; @@ -568,11 +624,11 @@ (if (> curr-rownum rownum) curr-rownum rownum) (if (> curr-colnum colnum) curr-colnum colnum) )))))) ;;====================================================================== -;; System stuff +;; S Y S T E M S T U F F ;;====================================================================== ;; return a nice clean pathname made absolute (define (nice-path dir) (normalize-pathname (if (absolute-pathname? dir) @@ -673,11 +729,11 @@ ;; with free-space-script /path/to/some/script.sh ;; (define (get-df path) (if (configf:lookup *configdat* "setup" "free-space-script") (with-input-from-pipe - (configf:lookup *configdat* "setup" "free-space-script") + (conc (configf:lookup *configdat* "setup" "free-space-script") " " path) (lambda () (let ((res (read-line))) (if (string? res) (string->number res))))) (get-unix-df path))) @@ -838,11 +894,11 @@ (lambda (var val) (setenv var val))) vars)) ;;====================================================================== -;; time and date nice to have stuff +;; T I M E A N D D A T E ;;====================================================================== (define (seconds->hr-min-sec secs) (let* ((hrs (quotient secs 3600)) (min (quotient (- secs (* hrs 3600)) 60)) @@ -881,11 +937,11 @@ ((7 8 9) 3) ((10 11 12) 4) (else #f))) ;;====================================================================== -;; Colors +;; C O L O R S ;;====================================================================== (define (common:name->iup-color name) (case (string->symbol (string-downcase name)) ((red) "223 33 49") Index: common_records.scm ================================================================== --- common_records.scm +++ common_records.scm @@ -8,10 +8,12 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== ;; (use trace) + +(include "altdb.scm") ;; Some of these routines use: ;; ;; http://www.cs.toronto.edu/~gfb/scheme/simple-macros.html ;; @@ -94,17 +96,17 @@ (define (debug:print-info n . params) (if (debug:debug-mode n) (with-output-to-port (current-error-port) (lambda () - (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params)))) - (if *logging* - (db:log-event res) - ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res) - (apply print "INFO: (" n ") " params) ;; res) - )))))) + (if *logging* + (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params)))) + (db:log-event res)) + ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res) + (apply print "INFO: (" n ") " params) ;; res) + ))))) ;; 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: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -441,11 +441,11 @@ (logfile "/this/dir/better/not/exist") (rundir (if testdat (db:test-get-rundir testdat) logfile)) ;; (testdat-path (conc rundir "/testdat.db")) ;; this gets recalculated until found - (teststeps (if testdat (tests:get-compressed-steps #f run-id test-id) '())) + (teststeps (if testdat (tests:get-compressed-steps run-id test-id) '())) (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ...")) (testname (if testdat (db:test-get-testname testdat) "n/a")) ;; (tests:get-testconfig testdat testname 'return-procs)) (testmeta (if testdat (let ((tm (rmt:testmeta-get-record testname))) @@ -517,11 +517,11 @@ (rmt:get-test-info-by-id run-id test-id ))))) ;; (debug:print-info 0 "need-update= " need-update " curr-mod-time = " curr-mod-time) (cond ((and need-update newtestdat) (set! testdat newtestdat) - (set! teststeps (tests:get-compressed-steps #f run-id test-id)) + (set! teststeps (tests:get-compressed-steps run-id test-id)) (set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat))) (set! rundir ;; (filedb:get-path *fdb* (db:test-get-rundir testdat)) ;; ) (set! testfullname (db:test-get-fullname testdat)) ;; (debug:print 0 "INFO: teststeps=" (intersperse teststeps "\n ")) @@ -611,10 +611,11 @@ command-text-box "VALUE" (conc "megatest -target " keystring " -runname " runname " -run -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) + " -clean-cache" )))) (remove-test (lambda (x) (iup:attribute-set! command-text-box "VALUE" (conc "megatest -remove-runs -target " keystring " -runname " runname @@ -629,10 +630,11 @@ item-path)) ";megatest -target " keystring " -runname " runname " -run -preclean -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) + " -clean-cache" ))) (common:without-vars (conc (dtests:get-pre-command) cmd (dtests:get-post-command)) @@ -691,13 +693,13 @@ ;; Replace here with matrix (let ((steps-matrix (iup:matrix #:font "Courier New, -8" #:expand "YES" #:scrollbar "YES" - #:numcol 6 - #:numlin 30 - #:numcol-visible 6 + #:numcol 7 + #:numlin 100 + #:numcol-visible 7 #:numlin-visible 5 #:click-cb (lambda (obj lin col status) ;; (if (equal? col 6) (let* ((mtrx-rc (conc lin ":" 6)) (fname (iup:attribute obj mtrx-rc))) ;; col)))) @@ -718,10 +720,11 @@ (iup:attribute-set! steps-matrix "WIDTH3" "50") (iup:attribute-set! steps-matrix "0:4" "Status") (iup:attribute-set! steps-matrix "WIDTH4" "50") (iup:attribute-set! steps-matrix "0:5" "Duration") (iup:attribute-set! steps-matrix "0:6" "Log File") + (iup:attribute-set! steps-matrix "0:7" "Comment") (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT") ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1") (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES") (let ((proc (lambda (testdat) @@ -740,11 +743,11 @@ #:font "Courier New, -10" #:size "100x100"))) (hash-table-set! widgets "Test Data" (lambda (testdat) ;; (let* ((currval (iup:attribute test-data "VALUE")) ;; "TITLE")) - (fmtstr "~10a~10a~10a~10a~7a~7a~6a~6a~a") ;; category,variable,value,expected,tol,units,type,comment + (fmtstr "~10a~10a~10a~10a~7a~7a~6a~7a~a") ;; category,variable,value,expected,tol,units,type,comment (newval (string-intersperse (append (list (format #f fmtstr "Category" "Variable" "Value" "Expected" "Tol" "Status" "Units" "Type" "Comment") (format #f fmtstr "========" "========" "=====" "========" "===" "======" "=====" "====" "=======")) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -41,11 +41,11 @@ (include "db_records.scm") (include "run_records.scm") (include "megatest-fossil-hash.scm") (define help (conc -"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest + "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " license GPL, Copyright (C) Matt Welland 2012-2016 Usage: dashboard [options] -h : this help @@ -72,11 +72,11 @@ "-guimonitor" "-main" "-v" "-q" "-use-local" - ) + ) args:arg-hash 0)) (if (args:get-arg "-h") (begin @@ -97,10 +97,11 @@ curr-tab-num dbdir dbfpath dbkeys dblocal + filters-changed header hide-empty-runs hide-not-hide ;; toggle for hide/not hide hide-not-hide-button hide-not-hide-tabs @@ -119,11 +120,11 @@ tot-runs update-mutex updaters updating useserver - ) + ) (define *alldat* (make-d:alldat header: #f allruns: '() allruns-by-id: (make-hash-table) @@ -144,37 +145,13 @@ hide-not-hide: #t hide-not-hide-button: #f hide-not-hide-tabs: #f curr-tab-num: 0 updaters: (make-hash-table) + filters-changed: #f )) -;; simple two dimentional sparse array -;; -(define (make-sparse-array) - (let ((a (make-sparse-vector))) - (sparse-vector-set! a 0 (make-sparse-vector)) - a)) - -(define (sparse-array? a) - (and (sparse-vector? a) - (sparse-vector? (sparse-vector-ref a 0)))) - -(define (sparse-array-ref a x y) - (let ((row (sparse-vector-ref a x))) - (if row - (sparse-vector-ref row y) - #f))) - -(define (sparse-array-set! a x y val) - (let ((row (sparse-vector-ref a x))) - (if row - (sparse-vector-set! row y val) - (let ((new-row (make-sparse-vector))) - (sparse-vector-set! a x new-row) - (sparse-vector-set! new-row y val))))) - ;; data for runs, tests etc ;; (defstruct d:rundat ;; new system runs-index ;; target/runname => colnum @@ -328,11 +305,11 @@ (let* ((c1 (map string->number (string-split color1))) (c2 (map string->number (string-split color2))) (delta (map (lambda (a b)(abs (- a b))) c1 c2))) (null? (filter (lambda (x)(> x 3)) delta)))) -(define (compare-tests test1 test2) +(define (dboard:compare-tests test1 test2) (let* ((test-name1 (db:test-get-testname test1)) (item-path1 (db:test-get-item-path test1)) (eventtime1 (db:test-get-event_time test1)) (test-name2 (db:test-get-testname test2)) (item-path2 (db:test-get-item-path test2)) @@ -347,104 +324,119 @@ (string>? item-path1 item-path2) test1-older) (if same-time (string>? test-name1 test-name2) test1-older)))) - -;; create a virtual table of all the tests -;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) -(define (update-rundat runnamepatt numruns testnamepatt keypatts) - (let* ((referenced-run-ids '()) - (allruns (if (d:alldat-useserver *alldat*) - (rmt:get-runs runnamepatt numruns (d:alldat-start-run-offset *alldat*) keypatts) - (db:get-runs (d:alldat-dblocal *alldat*) runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) - (d:alldat-start-run-offset *alldat*) keypatts))) - (header (db:get-header allruns)) - (runs (db:get-rows allruns)) - (result '()) - (maxtests 0) - (states (hash-table-keys (d:alldat-state-ignore-hash *alldat*))) - (statuses (hash-table-keys (d:alldat-status-ignore-hash *alldat*))) + +;; This is roughly the same as dboard:get-tests-dat, should merge them if possible +;; +(define (dboard:get-tests-for-run-duplicate data run-id run testnamepatt key-vals) + (let* ((states (hash-table-keys (d:alldat-state-ignore-hash data))) + (statuses (hash-table-keys (d:alldat-status-ignore-hash data))) (sort-info (get-curr-sort)) (sort-by (vector-ref sort-info 1)) (sort-order (vector-ref sort-info 2)) (bubble-type (if (member sort-order '(testname)) 'testname - 'itempath))) + 'itempath)) + (prev-dat (let ((rec (hash-table-ref/default (d:alldat-allruns-by-id data) run-id #f))) + (if rec rec (vector run '() key-vals -100)))) ;; -100 is before time began + (prev-tests (vector-ref prev-dat 1)) + (last-update (vector-ref prev-dat 3)) + (tmptests (if (d:alldat-useserver data) + (rmt:get-tests-for-run run-id testnamepatt states statuses + #f #f + (d:alldat-hide-not-hide data) + sort-by + sort-order + 'shortlist + (if (d:alldat-filters-changed data) + 0 + last-update)) + (db:get-tests-for-run (d:alldat-dblocal data) run-id testnamepatt states statuses + #f #f + (d:alldat-hide-not-hide data) + sort-by + sort-order + 'shortlist + (if (d:alldat-filters-changed data) + 0 + last-update)))) + (tests (let ((newdat (filter + (lambda (x) + (not (equal? (db:test-get-state x) "DELETED"))) ;; remove deleted tests but do it after merging + (delete-duplicates (if (d:alldat-filters-changed data) + tmptests + (append tmptests prev-tests)) + (lambda (a b) + (eq? (db:test-get-id a)(db:test-get-id b))))))) + (if (eq? *tests-sort-reverse* 3) ;; +event_time + (sort newdat dboard:compare-tests) + newdat)))) + (vector-set! prev-dat 3 (- (current-seconds) 2)) ;; go back two seconds in time to ensure all changes are captured. + ;; (debug:print 0 "(dboard:get-tests-for-run-duplicate: filters-changed=" (d:alldat-filters-changed data) " last-update=" last-update " got " (length tmptests) " test records for run " run-id) + tests)) + +;; create a virtual table of all the tests +;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) +(define (update-rundat data runnamepatt numruns testnamepatt keypatts) + (let* ((referenced-run-ids '()) + (allruns (if (d:alldat-useserver data) + (rmt:get-runs runnamepatt numruns (d:alldat-start-run-offset data) keypatts) + (db:get-runs (d:alldat-dblocal data) runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) + (d:alldat-start-run-offset data) keypatts))) + (header (db:get-header allruns)) + (runs (db:get-rows allruns)) + (result '()) + (maxtests 0) +) ;; ;; trim runs to only those that are changing often here ;; (for-each (lambda (run) (let* ((run-id (db:get-value-by-header run header "id")) - (key-vals (if (d:alldat-useserver *alldat*) + (key-vals (if (d:alldat-useserver data) (rmt:get-key-vals run-id) - (db:get-key-vals (d:alldat-dblocal *alldat*) run-id))) - (prev-dat (let ((rec (hash-table-ref/default (d:alldat-allruns-by-id *alldat*) run-id #f))) - (if rec rec (vector run '() key-vals -100)))) ;; -100 is before time began - (prev-tests (vector-ref prev-dat 1)) - (last-update (vector-ref prev-dat 3)) - (tmptests (if (d:alldat-useserver *alldat*) - (rmt:get-tests-for-run run-id testnamepatt states statuses - #f #f - (d:alldat-hide-not-hide *alldat*) - sort-by - sort-order - 'shortlist - last-update) - (db:get-tests-for-run (d:alldat-dblocal *alldat*) run-id testnamepatt states statuses - #f #f - (d:alldat-hide-not-hide *alldat*) - sort-by - sort-order - 'shortlist - last-update))) - (tests (let ((newdat (filter - (lambda (x) - (not (equal? (db:test-get-state x) "DELETED"))) ;; remove deleted tests but do it after merging - (delete-duplicates (append tmptests prev-tests) - (lambda (a b) - (eq? (db:test-get-id a)(db:test-get-id b))))))) - (if (eq? *tests-sort-reverse* 3) ;; +event_time - (sort newdat compare-tests) - newdat)))) - ;; NOTE: bubble-up also sets the global (d:alldat-item-test-names *alldat*) + (db:get-key-vals (d:alldat-dblocal data) run-id))) + (tests (dboard:get-tests-for-run-duplicate data run-id run testnamepatt key-vals))) + ;; NOTE: bubble-up also sets the global (d:alldat-item-test-names data) ;; (tests (bubble-up tmptests priority: bubble-type)) ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively. ;; (debug:print 0 "Getting data for run " run-id " with key-vals=" key-vals) ;; Not sure this is needed? (set! referenced-run-ids (cons run-id referenced-run-ids)) (if (> (length tests) maxtests) (set! maxtests (length tests))) - (if (or (not (d:alldat-hide-empty-runs *alldat*)) ;; this reduces the data burden when set + (if (or (not (d:alldat-hide-empty-runs data)) ;; this reduces the data burden when set (not (null? tests))) (let ((dstruct (vector run tests key-vals (- (current-seconds) 10)))) - (hash-table-set! (d:alldat-allruns-by-id *alldat*) run-id dstruct) + (hash-table-set! (d:alldat-allruns-by-id data) run-id dstruct) (set! result (cons dstruct result)))))) runs) - (d:alldat-header-set! *alldat* header) - (d:alldat-allruns-set! *alldat* result) - (debug:print-info 6 "(d:alldat-allruns *alldat*) has " (length (d:alldat-allruns *alldat*)) " runs") + (d:alldat-header-set! data header) + (d:alldat-allruns-set! data result) + (debug:print-info 6 "(d:alldat-allruns data) has " (length (d:alldat-allruns data)) " runs") maxtests)) (define *collapsed* (make-hash-table)) -; (define *row-lookup* (make-hash-table)) ;; testname => (rownum lableobj) + ; (define *row-lookup* (make-hash-table)) ;; testname => (rownum lableobj) (define (toggle-hide lnum) ; fulltestname) (let* ((btn (vector-ref (dboard:uidat-get-lftcol uidat) lnum)) (fulltestname (iup:attribute btn "TITLE")) (parts (string-split fulltestname "(")) (basetestname (if (null? parts) "" (car parts)))) - ;(print "Toggling " basetestname " currently " (hash-table-ref/default *collapsed* basetestname #f)) + ;(print "Toggling " basetestname " currently " (hash-table-ref/default *collapsed* basetestname #f)) (if (hash-table-ref/default *collapsed* basetestname #f) (begin - ;(iup:attribute-set! btn "FGCOLOR" "0 0 0") + ;(iup:attribute-set! btn "FGCOLOR" "0 0 0") (hash-table-delete! *collapsed* basetestname)) (begin - ;(iup:attribute-set! btn "FGCOLOR" "0 192 192") + ;(iup:attribute-set! btn "FGCOLOR" "0 192 192") (hash-table-set! *collapsed* basetestname #t))))) - + (define blank-line-rx (regexp "^\\s*$")) (define (run-item-name->vectors lst) (map (lambda (x) (let ((splst (string-split x "(")) @@ -479,11 +471,11 @@ (map (lambda (x) (if (equal? (vector-ref x 1) "") (vector-ref x 0) (conc (vector-ref x 0) "(" (vector-ref x 1) ")"))) vlst2))) - + (define (update-labels uidat) (let* ((rown 0) (keycol (dboard:uidat-get-keycol uidat)) (lftcol (dboard:uidat-get-lftcol uidat)) (numcols (vector-length lftcol)) @@ -564,11 +556,11 @@ (res '())) (let ((newres (append res (hash-table-ref tests hed)))) (if (null? tal) newres (loop (car tal)(cdr tal) newres)))))))) - + (define (update-buttons uidat numruns numtests) (let* ((runs (if (> (length (d:alldat-allruns *alldat*)) numruns) (take-right (d:alldat-allruns *alldat*) numruns) (pad-list (d:alldat-allruns *alldat*) numruns))) (lftcol (dboard:uidat-get-lftcol uidat)) @@ -679,14 +671,16 @@ (if (or search-changed state-changed status-changed) "190 180 190" "190 190 190" - )))) + )) + (d:alldat-filters-changed-set! *alldat* #t))) (define (update-search x val) (hash-table-set! (d:alldat-searchpatts *alldat*) x val) + (d:alldat-filters-changed-set! *alldat* #t) (set-bg-on-filter)) (define (mark-for-update) (d:alldat-last-db-update-set! *alldat* 0)) @@ -818,25 +812,27 @@ (if targ-list (string-intersperse targ-list "/") "no-target-selected"))) (run-name (dboard:data-get-run-name *data*)) (states-str (if (or (not states) (null? states)) "" - (conc " :state " (string-intersperse states ",")))) + (conc " -state " (string-intersperse states ",")))) (statuses-str (if (or (not statuses) (null? statuses)) "" - (conc " :status " (string-intersperse statuses ",")))) + (conc " -status " (string-intersperse statuses ",")))) (full-cmd "megatest")) (case (string->symbol cmd) - ((runtests) + ((run) (set! full-cmd (conc full-cmd - " -runtests " + " -run" + " -testpatt " test-patt " -target " target " -runname " run-name + " -clean-cache" ))) ((remove-runs) (set! full-cmd (conc full-cmd " -remove-runs -runname " run-name @@ -855,22 +851,22 @@ (define (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames test-records) (canvas-clear! cnv) (canvas-font-set! cnv "Helvetica, -10") (let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv)) ((originx originy) (canvas-origin cnv))) - ;; (print "originx: " originx " originy: " originy) - ;; (canvas-origin-set! cnv 0 (- (/ sizey 2))) - (if (hash-table-ref/default tests-draw-state 'first-time #t) - (begin - (hash-table-set! tests-draw-state 'first-time #f) - (hash-table-set! tests-draw-state 'scalef 1) - (hash-table-set! tests-draw-state 'tests-info (make-hash-table)) - (hash-table-set! tests-draw-state 'selected-tests (make-hash-table)) - ;; set these - (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)) - (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)) - )) + ;; (print "originx: " originx " originy: " originy) + ;; (canvas-origin-set! cnv 0 (- (/ sizey 2))) + (if (hash-table-ref/default tests-draw-state 'first-time #t) + (begin + (hash-table-set! tests-draw-state 'first-time #f) + (hash-table-set! tests-draw-state 'scalef 1) + (hash-table-set! tests-draw-state 'tests-info (make-hash-table)) + (hash-table-set! tests-draw-state 'selected-tests (make-hash-table)) + ;; set these + (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)) + (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)) + )) ;;====================================================================== ;; R U N C O N T R O L S ;;====================================================================== ;; @@ -880,21 +876,25 @@ (let* ((targets (make-hash-table)) (test-records (make-hash-table)) (all-tests-registry (tests:get-all)) ;; (tests:get-valid-tests *toppath* '())) (test-names (hash-table-keys all-tests-registry)) (sorted-testnames #f) - (action "-runtests") + (action "-run") (cmdln "") (runlogs (make-hash-table)) (key-listboxes #f) (updater-for-runs #f) (update-keyvals (lambda () (let ((targ (map (lambda (x) (iup:attribute x "VALUE")) - (car (dashboard:update-target-selector key-listboxes))))) + (car (dashboard:update-target-selector key-listboxes)))) + (curr-runname (dboard:data-get-run-name *data*))) (dboard:data-set-target! *data* targ) (if updater-for-runs (updater-for-runs)) + (if (or (not (equal? curr-runname (dboard:data-get-run-name *data*))) + (equal? (dboard:data-get-run-name *data*) "")) + (dboard:data-set-run-name! *data* curr-runname)) (dashboard:update-run-command)))) (tests-draw-state (make-hash-table)) ;; use for keeping state of the test canvas (test-patterns-textbox #f)) (hash-table-set! tests-draw-state 'first-time #t) ;; (hash-table-set! tests-draw-state 'scalef 1) @@ -939,11 +939,11 @@ ;; Command to run (iup:frame #:title "Set the action to take" (iup:hbox ;; (iup:label "Command to run" #:expand "HORIZONTAL" #:size "70x" #:alignment "LEFT:ACENTER") - (let* ((cmds-list '("runtests" "remove-runs" "set-state-status" "lock-runs" "unlock-runs")) + (let* ((cmds-list '("run" "remove-runs" "set-state-status" "lock-runs" "unlock-runs")) (lb (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES" #:action (lambda (obj val index lbstate) ;; (print obj " " val " " index " " lbstate) (dboard:data-set-command! *data* val) @@ -959,17 +959,19 @@ (tb (iup:textbox #:expand "HORIZONTAL" #:action (lambda (obj val txt) ;; (print "obj: " obj " val: " val " unk: " unk) (dboard:data-set-run-name! *data* txt) ;; (iup:attribute obj "VALUE")) (dashboard:update-run-command)) - #:value default-run-name)) + #:value (or default-run-name (dboard:data-get-run-name *data*)))) (lb (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES" #:action (lambda (obj val index lbstate) - (iup:attribute-set! tb "VALUE" val) - (dboard:data-set-run-name! *data* val) - (dashboard:update-run-command)))) + (if (not (equal? val "")) + (begin + (iup:attribute-set! tb "VALUE" val) + (dboard:data-set-run-name! *data* val) + (dashboard:update-run-command)))))) (refresh-runs-list (lambda () (let* ((target (dboard:data-get-target-string *data*)) (runs-for-targ (if (d:alldat-useserver *alldat*) (rmt:get-runs-by-patt (d:alldat-keys *alldat*) "%" target #f #f #f) (db:get-runs-by-patt (d:alldat-dblocal *alldat*) (d:alldat-keys *alldat*) "%" target #f #f #f))) @@ -977,11 +979,11 @@ (runs-dat (vector-ref runs-for-targ 1)) (run-names (cons default-run-name (map (lambda (x) (db:get-value-by-header x runs-header "runname")) runs-dat)))) - (iup:attribute-set! lb "REMOVEITEM" "ALL") + ;; (iup:attribute-set! lb "REMOVEITEM" "ALL") (iuplistbox-fill-list lb run-names selected-item: default-run-name))))) (set! updater-for-runs refresh-runs-list) (refresh-runs-list) (dboard:data-set-run-name! *data* default-run-name) (iup:hbox @@ -1031,11 +1033,11 @@ (dashboard:text-list-toggle-box (map cadr *common:std-statuses*) ;; '("PASS" "FAIL" "n/a" "CHECK" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD") (lambda (all) (dboard:data-set-statuses! *data* all) (dashboard:update-run-command)))))))) - + (iup:frame #:title "Tests and Tasks" (let* ((updater #f) (last-xadj 0) (last-yadj 0) @@ -1067,14 +1069,14 @@ #:scrollbar "YES" #:posx "0.5" #:posy "0.5" #:button-cb (lambda (obj btn pressed x y status) ;; (print "obj: " obj ", pressed " pressed ", status " status) - ; (print "canvas-origin: " (canvas-origin the-cnv)) + ; (print "canvas-origin: " (canvas-origin the-cnv)) ;; (let-values (((xx yy)(canvas-origin the-cnv))) - ;; (canvas-transform-set! the-cnv #f) - ;; (print "canvas-origin: " xx " " yy " click at " x " " y)) + ;; (canvas-transform-set! the-cnv #f) + ;; (print "canvas-origin: " xx " " yy " click at " x " " y)) (let* ((tests-info (hash-table-ref tests-draw-state 'tests-info)) (selected-tests (hash-table-ref tests-draw-state 'selected-tests)) (scalef (hash-table-ref tests-draw-state 'scalef)) (sizey (hash-table-ref tests-draw-state 'sizey)) (xoffset (dcommon:get-xoffset tests-draw-state #f #f)) @@ -1107,11 +1109,11 @@ (dboard:data-set-test-patts! *data* (dboard:lines->test-patt newpatt)) (dashboard:update-run-command) (if updater (updater last-xadj last-yadj))))))) (hash-table-keys tests-info))))))) canvas-obj))) - + (iup:frame #:title "Logs" ;; To be replaced with tabs (let ((logs-tb (iup:textbox #:expand "YES" #:multiline "YES"))) (dboard:data-set-logs-textbox! *data* logs-tb) @@ -1146,12 +1148,13 @@ ;;====================================================================== ;; S U M M A R Y ;;====================================================================== ;; ;; General info about the run(s) and megatest area -(define (dashboard:summary db) - (let ((rawconfig (read-config (conc *toppath* "/megatest.config") #f #f))) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string))) +(define (dashboard:summary data) + (let* ((db (d:alldat-dblocal data)) + (rawconfig (read-config (conc *toppath* "/megatest.config") #f #f))) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string))) (iup:vbox (iup:split #:value 500 (iup:frame #:title "General Info" @@ -1189,84 +1192,93 @@ (if (not (null? path)) (hash-table-ref/default (d:data-path-run-ids data) path #f) #f)) (define dashboard:update-run-summary-tab #f) +(define dashboard:update-new-view-tab #f) + +(define (dboard:get-tests-dat data run-id last-update) + (let ((tdat (if run-id + (if (d:alldat-useserver data) + (rmt:get-tests-for-run run-id + (hash-table-ref/default (d:alldat-searchpatts data) "test-name" "%/%") + (hash-table-keys (d:alldat-state-ignore-hash data)) ;; '() + (hash-table-keys (d:alldat-status-ignore-hash data)) ;; '() + #f #f + (d:alldat-hide-not-hide data) + #f #f + "id,testname,item_path,state,status" + (if (d:alldat-filters-changed data) + 0 + last-update)) ;; get 'em all + (db:get-tests-for-run db run-id + (hash-table-ref/default (d:alldat-searchpatts data) "test-name" "%/%") + (hash-table-keys (d:alldat-state-ignore-hash data)) ;; '() + (hash-table-keys (d:alldat-status-ignore-hash data)) ;; '() + #f #f + (d:alldat-hide-not-hide data) + #f #f + "id,testname,item_path,state,status" + (if (d:alldat-filters-changed data) + 0 + last-update))) + '()))) ;; get 'em all + (debug:print 0 "dboard:get-tests-dat: got " (length tdat) " test records for run " run-id) + (sort tdat (lambda (a b) + (let* ((aval (vector-ref a 2)) + (bval (vector-ref b 2)) + (anum (string->number aval)) + (bnum (string->number bval))) + (if (and anum bnum) + (< anum bnum) + (string<= aval bval))))))) ;; This is the Run Summary tab ;; -(define (dashboard:one-run db data) +(define (dashboard:one-run db data ddata) (let* ((tb (iup:treebox #:value 0 #:name "Runs" #:expand "YES" #:addexpanded "NO" #:selection-cb (lambda (obj id state) ;; (print "obj: " obj ", id: " id ", state: " state) (let* ((run-path (tree:node->path obj id)) - (run-id (tree-path->run-id data (cdr run-path)))) + (run-id (tree-path->run-id ddata (cdr run-path)))) (if (number? run-id) (begin - (d:data-curr-run-id-set! data run-id) + (d:data-curr-run-id-set! ddata run-id) (dashboard:update-run-summary-tab)) (debug:print 0 "ERROR: tree-path->run-id returned non-number " run-id))) - ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) - ))) + ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) + ))) (cell-lookup (make-hash-table)) (run-matrix (iup:matrix #:expand "YES" #:click-cb (lambda (obj lin col status) (let* ((toolpath (car (argv))) (key (conc lin ":" col)) (test-id (hash-table-ref/default cell-lookup key -1)) - (cmd (conc toolpath " -test " (d:data-curr-run-id data) "," test-id "&"))) + (cmd (conc toolpath " -test " (d:data-curr-run-id ddata) "," test-id "&"))) (system cmd))))) (updater (lambda () - (let* ((runs-dat (if (d:alldat-useserver *alldat*) - (rmt:get-runs-by-patt (d:alldat-keys *alldat*) "%" #f #f #f #f) - (db:get-runs-by-patt db (d:alldat-keys *alldat*) "%" #f #f #f #f))) + (let* ((runs-dat (if (d:alldat-useserver data) + (rmt:get-runs-by-patt (d:alldat-keys data) "%" #f #f #f #f) + (db:get-runs-by-patt db (d:alldat-keys data) "%" #f #f #f #f))) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records - (run-id (d:data-curr-run-id data)) + (run-id (d:data-curr-run-id ddata)) (last-update 0) ;; fix me - (tests-dat (let ((tdat (if run-id - (if (d:alldat-useserver *alldat*) - (rmt:get-tests-for-run run-id - (hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%") - (hash-table-keys (d:alldat-state-ignore-hash *alldat*)) ;; '() - (hash-table-keys (d:alldat-status-ignore-hash *alldat*)) ;; '() - #f #f - (d:alldat-hide-not-hide *alldat*) - #f #f - "id,testname,item_path,state,status" - last-update) ;; get 'em all - (db:get-tests-for-run db run-id - (hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%") - (hash-table-keys (d:alldat-state-ignore-hash *alldat*)) ;; '() - (hash-table-keys (d:alldat-status-ignore-hash *alldat*)) ;; '() - #f #f - (d:alldat-hide-not-hide *alldat*) - #f #f - "id,testname,item_path,state,status" - last-update)) - '()))) ;; get 'em all - (sort tdat (lambda (a b) - (let* ((aval (vector-ref a 2)) - (bval (vector-ref b 2)) - (anum (string->number aval)) - (bnum (string->number bval))) - (if (and anum bnum) - (< anum bnum) - (string<= aval bval))))))) + (tests-dat (dboard:get-tests-dat data run-id last-update)) (tests-mindat (dcommon:minimize-test-data tests-dat)) (indices (common:sparse-list-generate-index tests-mindat)) ;; proc: set-cell)) (row-indices (cadr indices)) (col-indices (car indices)) (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices)))) - (max-visible (max (- (d:alldat-num-tests *alldat*) 15) 3)) ;; (d:alldat-num-tests *alldat*) is proportional to the size of the window + (max-visible (max (- (d:alldat-num-tests data) 15) 3)) ;; (d:alldat-num-tests data) is proportional to the size of the window (numrows 1) (numcols 1) (changed #f) (runs-hash (let ((ht (make-hash-table))) (for-each (lambda (run) @@ -1279,31 +1291,32 @@ (record-b (hash-table-ref runs-hash b)) (time-a (db:get-value-by-header record-a runs-header "event_time")) (time-b (db:get-value-by-header record-b runs-header "event_time"))) (< time-a time-b)))))) + (d:alldat-filters-changed-set! data #f) ;; (iup:attribute-set! tb "VALUE" "0") ;; (iup:attribute-set! tb "NAME" "Runs") ;; Update the runs tree (for-each (lambda (run-id) (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) (key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key)) - (d:alldat-keys *alldat*))) + (d:alldat-keys data))) (run-name (db:get-value-by-header run-record runs-header "runname")) (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) (run-path (append key-vals (list run-name))) (existing (tree:find-node tb run-path))) - (if (not (hash-table-ref/default (d:data-path-run-ids data) run-path #f)) + (if (not (hash-table-ref/default (d:data-path-run-ids ddata) run-path #f)) (begin - (hash-table-set! (d:data-run-keys data) run-id run-path) + (hash-table-set! (d:data-run-keys ddata) run-id run-path) ;; (iup:attribute-set! (dboard:data-get-runs-matrix *data*) ;; (conc rownum ":" colnum) col-name) ;; (hash-table-set! runid-to-col run-id (list colnum run-record)) ;; Here we update the tests treebox and tree keys (tree:add-node tb "Runs" run-path ;; (append key-vals (list run-name)) userdata: (conc "run-id: " run-id)) - (hash-table-set! (d:data-path-run-ids data) run-path run-id) + (hash-table-set! (d:data-path-run-ids ddata) run-path run-id) ;; (set! colnum (+ colnum 1)) )))) run-ids) (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS") @@ -1359,88 +1372,60 @@ (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num)))))) col-indices) (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL")))))) (set! dashboard:update-run-summary-tab updater) - (d:data-runs-tree-set! data tb) + (d:data-runs-tree-set! ddata tb) (iup:split tb run-matrix))) ;; This is the New View tab ;; -(define (dashboard:new-view db data) +(define (dashboard:new-view db data ddata) (let* ((tb (iup:treebox #:value 0 #:name "Runs" #:expand "YES" #:addexpanded "NO" #:selection-cb (lambda (obj id state) ;; (print "obj: " obj ", id: " id ", state: " state) (let* ((run-path (tree:node->path obj id)) - (run-id (tree-path->run-id data (cdr run-path)))) + (run-id (tree-path->run-id ddata (cdr run-path)))) (if (number? run-id) (begin - (d:data-curr-run-id-set! data run-id) - (dashboard:update-run-summary-tab)) + (d:data-curr-run-id-set! ddata run-id) + (dashboard:update-new-view-tab)) (debug:print 0 "ERROR: tree-path->run-id returned non-number " run-id))) - ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) - ))) + ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) + ))) (cell-lookup (make-hash-table)) (run-matrix (iup:matrix #:expand "YES" #:click-cb (lambda (obj lin col status) (let* ((toolpath (car (argv))) (key (conc lin ":" col)) (test-id (hash-table-ref/default cell-lookup key -1)) - (cmd (conc toolpath " -test " (d:data-curr-run-id data) "," test-id "&"))) + (cmd (conc toolpath " -test " (d:data-curr-run-id ddata) "," test-id "&"))) (system cmd))))) (updater (lambda () - (let* ((runs-dat (if (d:alldat-useserver *alldat*) - (rmt:get-runs-by-patt (d:alldat-keys *alldat*) "%" #f #f #f #f) - (db:get-runs-by-patt db (d:alldat-keys *alldat*) "%" #f #f #f #f))) + (let* ((runs-dat (if (d:alldat-useserver data) + (rmt:get-runs-by-patt (d:alldat-keys data) "%" #f #f #f #f) + (db:get-runs-by-patt db (d:alldat-keys data) "%" #f #f #f #f))) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records - (run-id (d:data-curr-run-id data)) + (run-id (d:data-curr-run-id ddata)) (last-update 0) ;; fix me - (tests-dat (let ((tdat (if run-id - (if (d:alldat-useserver *alldat*) - (rmt:get-tests-for-run run-id - (hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%") - (hash-table-keys (d:alldat-state-ignore-hash *alldat*)) ;; '() - (hash-table-keys (d:alldat-status-ignore-hash *alldat*)) ;; '() - #f #f - (d:alldat-hide-not-hide *alldat*) - #f #f - "id,testname,item_path,state,status" - last-update) ;; get 'em all - (db:get-tests-for-run db run-id - (hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%") - (hash-table-keys (d:alldat-state-ignore-hash *alldat*)) ;; '() - (hash-table-keys (d:alldat-status-ignore-hash *alldat*)) ;; '() - #f #f - (d:alldat-hide-not-hide *alldat*) - #f #f - "id,testname,item_path,state,status" - last-update)) - '()))) ;; get 'em all - (sort tdat (lambda (a b) - (let* ((aval (vector-ref a 2)) - (bval (vector-ref b 2)) - (anum (string->number aval)) - (bnum (string->number bval))) - (if (and anum bnum) - (< anum bnum) - (string<= aval bval))))))) + (tests-dat (dboard:get-tests-dat data run-id last-update)) (tests-mindat (dcommon:minimize-test-data tests-dat)) (indices (common:sparse-list-generate-index tests-mindat)) ;; proc: set-cell)) (row-indices (cadr indices)) (col-indices (car indices)) (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices)))) - (max-visible (max (- (d:alldat-num-tests *alldat*) 15) 3)) ;; (d:alldat-num-tests *alldat*) is proportional to the size of the window + (max-visible (max (- (d:alldat-num-tests data) 15) 3)) ;; (d:alldat-num-tests data) is proportional to the size of the window (numrows 1) (numcols 1) (changed #f) (runs-hash (let ((ht (make-hash-table))) (for-each (lambda (run) @@ -1459,25 +1444,25 @@ ;; (iup:attribute-set! tb "NAME" "Runs") ;; Update the runs tree (for-each (lambda (run-id) (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) (key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key)) - (d:alldat-keys *alldat*))) + (d:alldat-keys data))) (run-name (db:get-value-by-header run-record runs-header "runname")) (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) (run-path (append key-vals (list run-name))) (existing (tree:find-node tb run-path))) - (if (not (hash-table-ref/default (d:data-path-run-ids data) run-path #f)) + (if (not (hash-table-ref/default (d:data-path-run-ids ddata) run-path #f)) (begin - (hash-table-set! (d:data-run-keys data) run-id run-path) + (hash-table-set! (d:data-run-keys ddata) run-id run-path) ;; (iup:attribute-set! (dboard:data-get-runs-matrix *data*) ;; (conc rownum ":" colnum) col-name) ;; (hash-table-set! runid-to-col run-id (list colnum run-record)) ;; Here we update the tests treebox and tree keys (tree:add-node tb "Runs" run-path ;; (append key-vals (list run-name)) userdata: (conc "run-id: " run-id)) - (hash-table-set! (d:data-path-run-ids data) run-path run-id) + (hash-table-set! (d:data-path-run-ids ddata) run-path run-id) ;; (set! colnum (+ colnum 1)) )))) run-ids) (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS") @@ -1532,34 +1517,21 @@ (iup:attribute-set! run-matrix key name) (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num)))))) col-indices) (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL")))))) - (set! dashboard:update-run-summary-tab updater) - (d:data-runs-tree-set! data tb) + (set! dashboard:update-new-view-tab updater) + (d:data-runs-tree-set! ddata tb) (iup:split tb run-matrix))) ;;====================================================================== ;; R U N S ;;====================================================================== -(define (make-dashboard-buttons db nruns ntests keynames runs-sum-dat new-view-dat) - (let* ((nkeys (length keynames)) - (runsvec (make-vector nruns)) - (header (make-vector nruns)) - (lftcol (make-vector ntests)) - (keycol (make-vector ntests)) - (controls '()) - (lftlst '()) - (hdrlst '()) - (bdylst '()) - (result '()) - (i 0)) - ;; controls (along bottom) - (set! controls +(define (dboard:make-controls data) (iup:hbox (iup:vbox (iup:frame #:title "filter test and items" (iup:hbox @@ -1588,32 +1560,32 @@ ;; (iup:button "Sort -t" #:action (lambda (obj) ;; (next-sort-option) ;; (iup:attribute-set! obj "TITLE" (vector-ref (vector-ref *tests-sort-options* *tests-sort-reverse*) 0)) ;; (mark-for-update))) (iup:button "HideEmpty" #:action (lambda (obj) - (d:alldat-hide-empty-runs-set! *alldat* (not (d:alldat-hide-empty-runs *alldat*))) - (iup:attribute-set! obj "TITLE" (if (d:alldat-hide-empty-runs *alldat*) "+HideE" "-HideE")) + (d:alldat-hide-empty-runs-set! data (not (d:alldat-hide-empty-runs data))) + (iup:attribute-set! obj "TITLE" (if (d:alldat-hide-empty-runs data) "+HideE" "-HideE")) (mark-for-update))) (let ((hideit (iup:button "HideTests" #:action (lambda (obj) - (d:alldat-hide-not-hide-set! *alldat* (not (d:alldat-hide-not-hide *alldat*))) - (iup:attribute-set! obj "TITLE" (if (d:alldat-hide-not-hide *alldat*) "HideTests" "NotHide")) + (d:alldat-hide-not-hide-set! data (not (d:alldat-hide-not-hide data))) + (iup:attribute-set! obj "TITLE" (if (d:alldat-hide-not-hide data) "HideTests" "NotHide")) (mark-for-update))))) - (d:alldat-hide-not-hide-button-set! *alldat* hideit) ;; never used, can eliminate ... + (d:alldat-hide-not-hide-button-set! data hideit) ;; never used, can eliminate ... hideit)) (iup:hbox (iup:button "Quit" #:action (lambda (obj) - ;; (if (d:alldat-dblocal *alldat*) (db:close-all (d:alldat-dblocal *alldat*))) + ;; (if (d:alldat-dblocal data) (db:close-all (d:alldat-dblocal data))) (exit))) (iup:button "Refresh" #:action (lambda (obj) (mark-for-update))) (iup:button "Collapse" #:action (lambda (obj) (let ((myname (iup:attribute obj "TITLE"))) (if (equal? myname "Collapse") (begin (for-each (lambda (tname) (hash-table-set! *collapsed* tname #t)) - (d:alldat-item-test-names *alldat*)) + (d:alldat-item-test-names data)) (iup:attribute-set! obj "TITLE" "Expand")) (begin (for-each (lambda (tname) (hash-table-delete! *collapsed* tname)) (hash-table-keys *collapsed*)) @@ -1626,40 +1598,55 @@ iup:hbox (map (lambda (status) (iup:toggle status #:action (lambda (obj val) (mark-for-update) (if (eq? val 1) - (hash-table-set! (d:alldat-status-ignore-hash *alldat*) status #t) - (hash-table-delete! (d:alldat-status-ignore-hash *alldat*) status)) + (hash-table-set! (d:alldat-status-ignore-hash data) status #t) + (hash-table-delete! (d:alldat-status-ignore-hash data) status)) (set-bg-on-filter)))) (map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP"))) (apply iup:hbox (map (lambda (state) (iup:toggle state #:action (lambda (obj val) (mark-for-update) (if (eq? val 1) - (hash-table-set! (d:alldat-state-ignore-hash *alldat*) state #t) - (hash-table-delete! (d:alldat-state-ignore-hash *alldat*) state)) + (hash-table-set! (d:alldat-state-ignore-hash data) state #t) + (hash-table-delete! (d:alldat-state-ignore-hash data) state)) (set-bg-on-filter)))) (map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED"))) (iup:valuator #:valuechanged_cb (lambda (obj) (let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10)))) (oldmax (string->number (iup:attribute obj "MAX"))) - (maxruns (d:alldat-tot-runs *alldat*))) - (d:alldat-start-run-offset-set! *alldat* val) + (maxruns (d:alldat-tot-runs data))) + (d:alldat-start-run-offset-set! data val) (mark-for-update) - (debug:print 6 "(d:alldat-start-run-offset *alldat*) " (d:alldat-start-run-offset *alldat*) " maxruns: " maxruns ", val: " val " oldmax: " oldmax) + (debug:print 6 "(d:alldat-start-run-offset data) " (d:alldat-start-run-offset data) " maxruns: " maxruns ", val: " val " oldmax: " oldmax) (iup:attribute-set! obj "MAX" (* maxruns 10)))) #:expand "HORIZONTAL" - #:max (* 10 (length (d:alldat-allruns *alldat*))) + #:max (* 10 (length (d:alldat-allruns data))) #:min 0 #:step 0.01))) - ;(iup:button "inc rows" #:action (lambda (obj)(d:alldat-num-tests-set! *alldat* (+ (d:alldat-num-tests *alldat*) 1)))) - ;(iup:button "dec rows" #:action (lambda (obj)(d:alldat-num-tests-set! *alldat* (if (> (d:alldat-num-tests *alldat*) 0)(- (d:alldat-num-tests *alldat*) 1) 0)))) - ) - ) + ;(iup:button "inc rows" #:action (lambda (obj)(d:alldat-num-tests-set! data (+ (d:alldat-num-tests data) 1)))) + ;(iup:button "dec rows" #:action (lambda (obj)(d:alldat-num-tests-set! data (if (> (d:alldat-num-tests data) 0)(- (d:alldat-num-tests data) 1) 0)))) + )) + +(define (make-dashboard-buttons data nruns ntests keynames runs-sum-dat new-view-dat) + (let* ((db (d:alldat-dblocal data)) + (nkeys (length keynames)) + (runsvec (make-vector nruns)) + (header (make-vector nruns)) + (lftcol (make-vector ntests)) + (keycol (make-vector ntests)) + (controls '()) + (lftlst '()) + (hdrlst '()) + (bdylst '()) + (result '()) + (i 0)) + ;; controls (along bottom) + (set! controls (dboard:make-controls data)) ;; create the left most column for the run key names and the test names (set! lftlst (list (iup:hbox (iup:label) ;; (iup:valuator) (apply iup:vbox @@ -1681,11 +1668,11 @@ (set! lftlst (append lftlst (list (iup:hbox #:expand "HORIZONTAL" (iup:valuator #:valuechanged_cb (lambda (obj) (let ((val (string->number (iup:attribute obj "VALUE"))) (oldmax (string->number (iup:attribute obj "MAX"))) (newmax (* 10 (length *alltestnamelst*)))) - (d:alldat-please-update-set! *alldat* #t) + (d:alldat-please-update-set! data #t) (d:alldat-start-test-offset-set! *alldat* (inexact->exact (round (/ val 10)))) (debug:print 6 "(d:alldat-start-test-offset *alldat*) " (d:alldat-start-test-offset *alldat*) " val: " val " newmax: " newmax " oldmax: " oldmax) (if (< val 10) (iup:attribute-set! obj "MAX" newmax)) )) @@ -1762,20 +1749,21 @@ (list (iup:vbox ;; the header (apply iup:hbox (reverse hdrlst)) (apply iup:hbox (reverse bdylst)))))) - controls)) - (data (d:data-init (make-d:data))) + ;; controls + )) + ;; (data (d:data-init (make-d:data))) (tabs (iup:tabs #:tabchangepos-cb (lambda (obj curr prev) (d:alldat-please-update-set! *alldat* #t) (d:alldat-curr-tab-num-set! *alldat* curr)) - (dashboard:summary db) + (dashboard:summary *alldat*) runs-view - (dashboard:one-run db runs-sum-dat) - (dashboard:new-view db new-view-dat) + (dashboard:one-run db data runs-sum-dat) + (dashboard:new-view db data new-view-dat) (dashboard:run-controls) ))) ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c))) (iup:attribute-set! tabs "TABTITLE0" "Summary") (iup:attribute-set! tabs "TABTITLE1" "Runs") @@ -1782,21 +1770,23 @@ (iup:attribute-set! tabs "TABTITLE2" "Run Summary") (iup:attribute-set! tabs "TABTITLE3" "New View") (iup:attribute-set! tabs "TABTITLE4" "Run Control") (iup:attribute-set! tabs "BGCOLOR" "190 190 190") (d:alldat-hide-not-hide-tabs-set! *alldat* tabs) - tabs))) + (iup:vbox + tabs + controls)))) (vector keycol lftcol header runsvec))) (if (or (args:get-arg "-rows") (get-environment-variable "DASHBOARDROWS" )) (begin (d:alldat-num-tests-set! *alldat* (string->number (or (args:get-arg "-rows") (get-environment-variable "DASHBOARDROWS")))) - (update-rundat "%" (d:alldat-numruns *alldat*) "%/%" '())) - (d:alldat-num-tests-set! *alldat* (min (max (update-rundat "%" (d:alldat-numruns *alldat*) "%/%" '()) 8) 20))) + (update-rundat *alldat* "%" (d:alldat-numruns *alldat*) "%/%" '())) + (d:alldat-num-tests-set! *alldat* (min (max (update-rundat *alldat* "%" (d:alldat-numruns *alldat*) "%/%" '()) 8) 20))) (define *tim* (iup:timer)) (define *ord* #f) (iup:attribute-set! *tim* "TIME" 300) (iup:attribute-set! *tim* "RUN" "YES") @@ -1851,11 +1841,11 @@ (begin (case (d:alldat-curr-tab-num *alldat*) ((0) (if dashboard:update-summary-tab (dashboard:update-summary-tab))) ((1) ;; The runs table is active - (update-rundat (hash-table-ref/default (d:alldat-searchpatts *alldat*) "runname" "%") (d:alldat-numruns *alldat*) + (update-rundat *alldat* (hash-table-ref/default (d:alldat-searchpatts *alldat*) "runname" "%") (d:alldat-numruns *alldat*) (hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%") ;; (hash-table-ref/default (d:alldat-searchpatts *alldat*) "item-name" "%") (let ((res '())) (for-each (lambda (key) (if (not (equal? key "runname")) @@ -1865,11 +1855,11 @@ res)) (update-buttons uidat (d:alldat-numruns *alldat*) (d:alldat-num-tests *alldat*))) ((2) (dashboard:update-run-summary-tab)) ((3) - (dashboard:update-run-summary-tab)) + (dashboard:update-new-view-tab)) (else (let ((updater (hash-table-ref/default (d:alldat-updaters *alldat*) (d:alldat-curr-tab-num *alldat*) #f))) (if updater (updater))))) (d:alldat-please-update-set! *alldat* #f) @@ -1884,20 +1874,22 @@ (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) (if (file-exists? debugcontrolf) (load debugcontrolf))) (define (main) - (let ((runs-sum-dat (d:data-init (make-d:data))) ;; data for run-summary tab - (new-view-dat (d:data-init (make-d:data)))) + (common:exit-on-version-changed) + (let* ((runs-sum-dat (d:data-init (make-d:data))) ;; data for run-summary tab + (new-view-dat (d:data-init (make-d:data))) + (data *alldat*)) (cond ((args:get-arg "-run") (let ((runid (string->number (args:get-arg "-run")))) (if runid (begin (lambda (x) (on-exit std-exit-procedure) - (examine-run (d:alldat-dblocal *alldat*) runid))) + (examine-run (d:alldat-dblocal data) runid))) (begin (print "ERROR: runid is not a number " (args:get-arg "-run")) (exit 1))))) ((args:get-arg "-test") ;; run-id,test-id (let* ((dat (let ((d (map string->number (string-split (args:get-arg "-test") ",")))) @@ -1912,39 +1904,39 @@ (examine-test run-id test-id) (begin (debug:print 3 "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test")) (exit 1))))) ((args:get-arg "-guimonitor") - (gui-monitor (d:alldat-dblocal *alldat*))) + (gui-monitor (d:alldat-dblocal data))) (else - (set! uidat (make-dashboard-buttons (d:alldat-dblocal *alldat*) - (d:alldat-numruns *alldat*) - (d:alldat-num-tests *alldat*) - (d:alldat-dbkeys *alldat*) - runs-sum-dat new-view-dat)) + (set! uidat (make-dashboard-buttons data ;; (d:alldat-dblocal data) + (d:alldat-numruns data) + (d:alldat-num-tests data) + (d:alldat-dbkeys data) + runs-sum-dat new-view-dat)) (iup:callback-set! *tim* "ACTION_CB" (lambda (x) (let ((update-is-running #f)) - (mutex-lock! (d:alldat-update-mutex *alldat*)) - (set! update-is-running (d:alldat-updating *alldat*)) + (mutex-lock! (d:alldat-update-mutex data)) + (set! update-is-running (d:alldat-updating data)) (if (not update-is-running) - (d:alldat-updating-set! *alldat* #t)) - (mutex-unlock! (d:alldat-update-mutex *alldat*)) + (d:alldat-updating-set! data #t)) + (mutex-unlock! (d:alldat-update-mutex data)) (if (not update-is-running) (begin (dashboard:run-update x) - (mutex-lock! (d:alldat-update-mutex *alldat*)) - (d:alldat-updating-set! *alldat* #f) - (mutex-unlock! (d:alldat-update-mutex *alldat*))))) + (mutex-lock! (d:alldat-update-mutex data)) + (d:alldat-updating-set! data #f) + (mutex-unlock! (d:alldat-update-mutex data))))) 1)))) (let ((th1 (make-thread (lambda () (thread-sleep! 1) - (d:alldat-please-update-set! *alldat* #t) + (d:alldat-please-update-set! data #t) (dashboard:run-update 1)) "update buttons once")) (th2 (make-thread iup:main-loop "Main loop"))) (thread-start! th1) (thread-start! th2) (thread-join! th2)))) (main) Index: datashare-testing/.sretrieve.config ================================================================== --- datashare-testing/.sretrieve.config +++ datashare-testing/.sretrieve.config @@ -1,8 +1,8 @@ [settings] base-dir /tmp/delme_data allowed-users matt allowed-chars [0-9a-zA-Z\-\.]+ - +allowed-sub-paths [0-9a-zA-Z\-\.]+ [database] location #{scheme (create-directory "/tmp/#{getenv USER}" #t)} Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -386,39 +386,11 @@ (let ((locdbs (dbr:dbstruct-get-locdbs dbstruct))) (if (hash-table? locdbs) (for-each (lambda (run-id) (db:close-run-db dbstruct run-id)) - (hash-table-keys locdbs)))) - - ;; (let* ((local (dbr:dbstruct-get-local dbstruct)) - ;; (rundb (db:dbdat-get-db (dbr:dbstruct-get-rundb dbstruct)))) - ;; (if local - ;; (for-each - ;; (lambda (dbdat) - ;; (let ((db (db:dbdat-get-db dbdat))) - ;; (if (sqlite3:database? db) - ;; (begin - ;; (sqlite3:interrupt! db) - ;; (sqlite3:finalize! db #t))))) - ;; ;; TODO: Come back to this and rework to delete from hashtable when finalized - ;; (hash-table-values (dbr:dbstruct-get-locdbs dbstruct)))) - ;; (thread-sleep! 3) - ;; (if (and rundb - ;; (sqlite3:database? rundb)) - ;; (handle-exceptions - ;; exn - ;; (begin - ;; (debug:print 0 "WARNING: database files may not have been closed correctly. Consider running -cleanup-db") - ;; (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) - ;; (debug:print 0 " db: " rundb) - ;; (print-call-chain (current-error-port)) - ;; #f) - ;; (sqlite3:interrupt! rundb) - ;; (sqlite3:finalize! rundb #t)))) - ;; ;; (mutex-unlock! *db-sync-mutex*) - ) + (hash-table-keys locdbs))))) (define (db:open-inmem-db) (let* ((db (sqlite3:open-database ":memory:")) (handler (make-busy-timeout 3600))) (sqlite3:set-busy-handler! db handler) @@ -844,30 +816,37 @@ (begin ;; NB// must sync first to ensure deleted tests get marked as such in megatest.db (db:sync-tables db:sync-tests-only (db:get-db fromdb run-id) mtdb) (db:clean-up-rundb (db:get-db fromdb run-id)) ;; - ;; Feb 18, 2016: add field last_update to tests + ;; Feb 18, 2016: add field last_update to tests, test_steps and test_data ;; ;; remove this some time after September 2016 (added in version v1.6031 ;; - (handle-exceptions - exn - (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn)) - (debug:print 0 "Column last_update already added to tests table") - (db:general-sqlite-error-dump exn "alter table tests ..." #f "none")) - (sqlite3:execute - frundb - "ALTER TABLE tests ADD COLUMN last_update INTEGER DEFAULT 0")) - (sqlite3:execute - frundb - "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests + (for-each + (lambda (table-name) + (handle-exceptions + exn + (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 "Column last_update already added to " table-name " table") + (db:general-sqlite-error-dump exn "alter table " table-name " ..." #f "none")) + (sqlite3:execute + frundb + (conc "ALTER TABLE " table-name " ADD COLUMN last_update INTEGER DEFAULT 0"))) + (sqlite3:execute + frundb + (conc "DROP TRIGGER IF EXISTS update_" table-name "_trigger;")) + (sqlite3:execute + frundb + (conc "CREATE TRIGGER IF NOT EXISTS update_" table-name "_trigger AFTER UPDATE ON " table-name " FOR EACH ROW BEGIN - UPDATE tests SET last_update=(strftime('%s','now')); - END;") - )))) + UPDATE " table-name " SET last_update=(strftime('%s','now')) + WHERE id=old.id; + END;")) + ) + '("tests" "test_steps" "test_data")))))) all-run-ids) ;; removed deleted runs (let ((dbdir (tasks:get-task-db-path))) (for-each (lambda (run-id) (let ((fullname (conc dbdir "/" run-id ".db"))) @@ -1036,11 +1015,11 @@ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, CONSTRAINT metadat_constraint UNIQUE (var));") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);") ;; Must do this *after* running patch db !! No more. ;; cannot use db:set-var since it will deadlock, hardwire the code here - (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" megatest-version) + (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" (common:version-signature)) (debug:print-info 11 "db:initialize END"))))) ;;====================================================================== ;; R U N S P E C I F I C D B ;;====================================================================== @@ -1087,20 +1066,19 @@ state TEXT DEFAULT 'NOT_STARTED', status TEXT DEFAULT 'n/a', event_time TIMESTAMP, comment TEXT DEFAULT '', logfile TEXT DEFAULT '', + last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));") - ;; (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data - ;; (id INTEGER PRIMARY KEY, - ;; reviewed TIMESTAMP DEFAULT (strftime('%s','now')), - ;; iterated TEXT DEFAULT '', - ;; avg_runtime REAL DEFAULT -1, - ;; avg_disk REAL DEFAULT -1, - ;; tags TEXT DEFAULT '', - ;; jobgroup TEXT DEFAULT 'default', - ;; CONSTRAINT test_meta_constraint UNIQUE (testname));") + (sqlite3:execute db "CREATE INDEX IF NOT EXISTS teststeps_index ON tests (run_id, testname, item_path);") + (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps + FOR EACH ROW + BEGIN + UPDATE test_steps SET last_update=(strftime('%s','now')) + WHERE id=old.id; + END;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, test_id INTEGER, category TEXT DEFAULT '', variable TEXT, value REAL, @@ -1108,13 +1086,19 @@ tol REAL, units TEXT, comment TEXT DEFAULT '', status TEXT DEFAULT 'n/a', type TEXT DEFAULT '', + last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));") - ;; Why use FULL here? This data is not that critical - ;; (sqlite3:execute db "PRAGMA synchronous = FULL;") + (sqlite3:execute db "CREATE INDEX IF NOT EXISTS test_data_index ON test_data (test_id);") + (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data + FOR EACH ROW + BEGIN + UPDATE test_data SET last_update=(strftime('%s','now')) + WHERE id=old.id; + END;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_rundat ( id INTEGER PRIMARY KEY, test_id INTEGER, update_time TIMESTAMP, cpuload INTEGER DEFAULT -1, @@ -1583,35 +1567,36 @@ ;;====================================================================== ;; returns number if string->number is successful, string otherwise ;; also updates *global-delta* ;; -;; Operates on megatestdb -;; (define (db:get-var dbstruct var) (let* ((res #f) (dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) - ;; (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (val) (set! res val)) db "SELECT val FROM metadat WHERE var=?;" var) ;; convert to number if can (if (string? res) (let ((valnum (string->number res))) (if valnum (set! res valnum)))) - ;; scale by 10, average with current value. + res)) + +;; This was part of db:get-var. It was used to estimate the load on +;; the database files. +;; +;; scale by 10, average with current value. ;; (set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms) ;; (if throttle throttle 0.01))) ;; 2)) ;; (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit ;; (begin ;; (debug:print-info 4 "launch throttle factor=" *global-delta*) ;; (set! *last-global-delta-printed* *global-delta*))) - res)) (define (db:set-var dbstruct var val) (let* ((dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val))) @@ -1808,55 +1793,10 @@ (begin (debug:print 2 "WARNING: Failed to process " dbfile " for run-id") 0)))) changed)))) -;; db:get-runs-by-patt -;; get runs by list of criteria -;; register a test run with the db -;; -;; Use: (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) -;; to extract info from the structure returned -;; -;; NOTE: THIS IS COMPLETELY UNFINISHED. IT GOES WITH rmt:get-get-paths-matching-keynames -;; -;; (define (db:get-run-ids-matching dbstruct keynames target res) -;; ;; (define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit) ;; test-name) -;; (let* ((tmp (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time"))) -;; (keystr (car tmp)) -;; (header (cadr tmp)) -;; (res '()) -;; (key-patt "") -;; (runwildtype (if (substring-index "%" runnamepatt) "like" "glob")) -;; (qry-str #f) -;; (keyvals (if targpatt (keys:target->keyval keys targpatt) '()))) -;; (for-each (lambda (keyval) -;; (let* ((key (car keyval)) -;; (patt (cadr keyval)) -;; (fulkey (conc ":" key)) -;; (wildtype (if (substring-index "%" patt) "like" "glob"))) -;; (if patt -;; (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'")) -;; (begin -;; (debug:print 0 "ERROR: searching for runs with no pattern set for " fulkey) -;; (exit 6))))) -;; keyvals) -;; (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt " ORDER BY event_time " -;; (if limit (conc " LIMIT " limit) "") -;; (if offset (conc " OFFSET " offset) "") -;; ";")) -;; (debug:print-info 4 "runs:get-runs-by-patt qry=" qry-str " " runnamepatt) -;; (db:with-db dbstruct #f #f ;; reads db, does not write to it. -;; (lambda (db) -;; (sqlite3:for-each-row -;; (lambda (a . r) -;; (set! res (cons (list->vector (cons a r)) res))) -;; (db:get-db dbstruct #f) -;; qry-str -;; runnamepatt))) -;; (vector header res))) - ;; Get all targets from the db ;; (define (db:get-targets dbstruct) (let* ((res '()) (keys (db:get-keys dbstruct)) @@ -2763,14 +2703,14 @@ run-id #f (lambda (db) (let* ((res '())) (sqlite3:for-each-row - (lambda (id test-id stepname state status event-time logfile) - (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res))) + (lambda (id test-id stepname state status event-time logfile comment) + (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment) res))) db - "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; + "SELECT id,test_id,stepname,state,status,event_time,logfile,comment FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; test-id) (reverse res))))) (define (db:get-steps-data dbstruct run-id test-id) (db:with-db @@ -2813,21 +2753,100 @@ ;; Now rollup the counts to the central megatest.db (db:general-call dbdat 'pass-fail-counts (list pass-count fail-count test-id)) ;; if the test is not FAIL then set status based on the fail and pass counts. (db:general-call dbdat 'test_data-pf-rollup (list test-id test-id test-id test-id)))) -;; NOT USED!? +;; each section is a rule except "final" which is the final result +;; +;; [rule-5] +;; operator in +;; section LogFileBody +;; desc Output voltage +;; status OK +;; expected 1.9 +;; measured 1.8 +;; type +/- +;; tolerance 0.1 +;; pass 1 +;; fail 0 +;; +;; [final] +;; exit-code 6 +;; exit-status SKIP +;; message If flagged we are asking for this to exit with code 6 ;; +;; recorded in steps table: +;; category: stepname +;; variable: rule-N +;; value: measured +;; expected: expected +;; tol: tolerance +;; units: - +;; comment: desc or message +;; status: status +;; type: type +;; +(define (db:logpro-dat->csv dat stepname) + (let ((res '())) + (for-each + (lambda (entry-name) + (if (equal? entry-name "final") + (set! res (append + res + (list + (list stepname + entry-name + (configf:lookup dat entry-name "exit-code") ;; 0 ;; Value + 0 ;; 1 ;; Expected + 0 ;; 2 ;; Tolerance + "n/a" ;; 3 ;; Units + (configf:lookup dat entry-name "message") ;; 4 ;; Comment + (configf:lookup dat entry-name "exit-status") ;; 5 ;; Status + "logpro" ;; 6 ;; Type + )))) + (let* ((value (or (configf:lookup dat entry-name "measured") "n/a")) + (expected (or (configf:lookup dat entry-name "expected") "n/a")) + (tolerance (or (configf:lookup dat entry-name "tolerance") "n/a")) + (comment (or (configf:lookup dat entry-name "comment") + (configf:lookup dat entry-name "desc") "n/a")) + (status (or (configf:lookup dat entry-name "status") "n/a")) + (type (or (configf:lookup dat entry-name "expected") "n/a"))) + (set! res (append + res + (list (list stepname + entry-name + value ;; 0 + expected ;; 1 + tolerance ;; 2 + "n/a" ;; 3 Units + comment ;; 4 + status ;; 5 + type ;; 6 + ))))))) + (hash-table-keys dat)) + res)) + +;; $MT_MEGATEST -load-test-data << EOF +;; foo,bar, 1.2, 1.9, > +;; foo,rab, 1.0e9, 10e9, 1e9 +;; foo,bla, 1.2, 1.9, < +;; foo,bal, 1.2, 1.2, < , ,Check for overload +;; foo,alb, 1.2, 1.2, <= , Amps,This is the high power circuit test +;; foo,abl, 1.2, 1.3, 0.1 +;; foo,bra, 1.2, pass, silly stuff +;; faz,bar, 10, 8mA, , ,"this is a comment" +;; EOF + (define (db:csv->test-data dbstruct run-id test-id csvdata) (debug:print 4 "test-id " test-id ", csvdata: " csvdata) (let* ((dbdat (db:get-db dbstruct run-id)) (db (db:dbdat-get-db dbdat)) (csvlist (csv->list (make-csv-reader (open-input-string csvdata) '((strip-leading-whitespace? #t) (strip-trailing-whitespace? #t)))))) ;; (csv->list csvdata))) - (for-each + (for-each (lambda (csvrow) (let* ((padded-row (take (append csvrow (list #f #f #f #f #f #f #f #f #f)) 9)) (category (list-ref padded-row 0)) (variable (list-ref padded-row 1)) (value (any->number-if-possible (list-ref padded-row 2))) @@ -3670,27 +3689,6 @@ ;; brutal clean up (system "rm -rf tempdir"))) ;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%") -;; This is a list of all procs that write to the db -;; -;; (define *db:all-write-procs* -;; (list -;; db:set-var -;; db:del-var -;; db:register-run -;; db:set-comment-for-run -;; db:delete-run -;; db:update-run-event_time -;; db:lock/unlock-run -;; db:delete-test-step-records -;; db:delete-test-records -;; db:delete-tests-for-run -;; db:delete-old-deleted-test-records -;; db:set-tests-state-status -;; db:test-set-state-status-by-id -;; db:test-set-state-status-by-run-id-testname -;; db:testmeta-add-record -;; db:csv->test-data -;; )) Index: db_records.scm ================================================================== --- db_records.scm +++ db_records.scm @@ -186,17 +186,19 @@ (define-inline (tdb:step-get-stepname vec) (vector-ref vec 2)) (define-inline (tdb:step-get-state vec) (vector-ref vec 3)) (define-inline (tdb:step-get-status vec) (vector-ref vec 4)) (define-inline (tdb:step-get-event_time vec) (vector-ref vec 5)) (define-inline (tdb:step-get-logfile vec) (vector-ref vec 6)) +(define-inline (tdb:step-get-comment vec) (vector-ref vec 7)) (define-inline (tdb:step-set-id! vec val)(vector-set! vec 0 val)) (define-inline (tdb:step-set-test_id! vec val)(vector-set! vec 1 val)) (define-inline (tdb:step-set-stepname! vec val)(vector-set! vec 2 val)) (define-inline (tdb:step-set-state! vec val)(vector-set! vec 3 val)) (define-inline (tdb:step-set-status! vec val)(vector-set! vec 4 val)) (define-inline (tdb:step-set-event_time! vec val)(vector-set! vec 5 val)) (define-inline (tdb:step-set-logfile! vec val)(vector-set! vec 6 val)) +(define-inline (tdb:step-set-comment! vec vak)(vector-set! vec 7 val)) ;; The steps table (define (make-db:steps-table)(make-vector 5)) (define-inline (tdb:steps-table-get-stepname vec) (vector-ref vec 0)) Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -363,11 +363,11 @@ #:alignment1 "ALEFT" #:expand "YES" ;; "HORIZONTAL" #:numcol 1 #:numlin (length key-vals) #:numcol-visible 1 - #:numlin-visible (length key-vals) + #:numlin-visible (min 10 (length key-vals)) #:scrollbar "YES"))) (iup:attribute-set! section-matrix "0:0" varcolname) (iup:attribute-set! section-matrix "0:1" valcolname) (iup:attribute-set! section-matrix "WIDTH1" "200") ;; fill in keys @@ -880,11 +880,12 @@ ;;====================================================================== ;; S T E P S ;;====================================================================== (define (dcommon:populate-steps teststeps steps-matrix) - (let ((max-row 0)) + (let ((max-row 0) + (max-col 7)) (if (null? teststeps) (iup:attribute-set! steps-matrix "CLEARVALUE" "CONTENTS") (let loop ((hed (car teststeps)) (tal (cdr teststeps)) (rownum 1) @@ -891,11 +892,11 @@ (colnum 1)) (if (> rownum max-row)(set! max-row rownum)) (let ((val (vector-ref hed (- colnum 1))) (mtrx-rc (conc rownum ":" colnum))) (iup:attribute-set! steps-matrix mtrx-rc (if val (conc val) "")) - (if (< colnum 6) + (if (< colnum max-col) (loop hed tal rownum (+ colnum 1)) (if (not (null? tal)) (loop (car tal)(cdr tal)(+ rownum 1) 1)))))) (if (> max-row 0) (begin @@ -902,19 +903,19 @@ ;; we are going to speculatively clear rows until we find a row that is already cleared (let loop ((rownum (+ max-row 1)) (colnum 0) (deleted #f)) ;; (debug:print-info 0 "cleaning " rownum ":" colnum) - (let* ((next-row (if (eq? colnum 6) (+ rownum 1) rownum)) - (next-col (if (eq? colnum 6) 1 (+ colnum 1))) + (let* ((next-row (if (eq? colnum max-col) (+ rownum 1) rownum)) + (next-col (if (eq? colnum max-col) 1 (+ colnum 1))) (mtrx-rc (conc rownum ":" colnum)) (curr-val (iup:attribute steps-matrix mtrx-rc))) ;; (debug:print-info 0 "cleaning " rownum ":" colnum " currval= " curr-val) (if (and (string? curr-val) (not (equal? curr-val ""))) (begin (iup:attribute-set! steps-matrix mtrx-rc "") (loop next-row next-col #t)) - (if (eq? colnum 6) ;; not done, didn't get a full blank row + (if (eq? colnum max-col) ;; not done, didn't get a full blank row (if deleted (loop next-row next-col #f)) ;; exit on this not met (loop next-row next-col deleted))))) (iup:attribute-set! steps-matrix "REDRAW" "ALL"))))) ADDED docs/waiton-analysis.gnumeric Index: docs/waiton-analysis.gnumeric ================================================================== --- /dev/null +++ docs/waiton-analysis.gnumeric cannot compute difference between binary files ADDED inteldate.scm Index: inteldate.scm ================================================================== --- /dev/null +++ inteldate.scm @@ -0,0 +1,180 @@ +(use srfi-19) +(use test) +(use format) +(use regex) +(declare (unit inteldate)) +;; utility procedures to convert among +;; different ways to express date (inteldate, seconds since epoch, isodate) +;; +;; samples: +;; isodate -> "2016-01-01" +;; inteldate -> "16ww01.5" +;; seconds -> 1451631600 + +;; procedures provided: +;; ==================== +;; seconds->isodate +;; seconds->inteldate +;; +;; isodate->seconds +;; isodate->inteldate +;; +;; inteldate->seconds +;; inteldate->isodate + +;; srfi-19 used extensively; this doc is better tha the eggref: +;; http://srfi.schemers.org/srfi-19/srfi-19.html + +;; Author: brandon.j.barclay@intel.com 16ww18.6 + +(define (date->seconds date) + (inexact->exact + (string->number + (date->string date "~s")))) + +(define (seconds->isodate seconds) + (let* ((date (seconds->date seconds)) + (result (date->string date "~Y-~m-~d"))) + result)) + +(define (isodate->seconds isodate) + "Takes a string input of the form 'YY-MM-DD' or 'YYYY-MM-DD' and returns epoch time; for YY, assume after Y2K" + (let* ((numlist (map string->number (string-split isodate "-"))) + (raw-year (car numlist)) + (year (if (< raw-year 100) (+ raw-year 2000) raw-year)) + (month (list-ref numlist 1)) + (day (list-ref numlist 2)) + (date (make-date 0 0 0 0 day month year)) + (seconds (date->seconds date))) + + seconds)) + +;; adapted from perl Intel::WorkWeek perl module +;; intel year consists of numbered weeks starting from week 1 +;; week 1 is the week containing jan 1 of the year +;; days of week are numbered starting from 0 on sunday +;; intel year does not match calendar year in workweek 1 +;; before jan1. +(define (seconds->inteldate-values seconds) + (define (date-difference->seconds d1 d2) + (- (date->seconds d1) (date->seconds d2))) + + (let* ((thisdate (seconds->date seconds)) + (thisdow (string->number (date->string thisdate "~w"))) + + (year (date-year thisdate)) + ;; intel workweek 1 begins on sunday of week containing jan1 + (jan1 (make-date 0 0 0 0 1 1 year)) + (jan1dow (date-week-day jan1)) + (ww01 (date-subtract-duration jan1 (seconds->time (* 60 60 24 jan1dow)))) + + (ww01_delta_seconds (date-difference->seconds thisdate ww01)) + (wwnum_initial (inexact->exact (add1 (floor (/ ww01_delta_seconds 24 3600 7) )))) + + ;; we could be in ww1 of next year + (this-saturday (seconds->date + (+ seconds + (* 60 60 24 (- 6 thisdow))))) + (this-week-ends-next-year? + (> (date-year this-saturday) year)) + (intelyear + (if this-week-ends-next-year? + (add1 year) + year)) + (intelweek + (if this-week-ends-next-year? + 1 + wwnum_initial))) + (values intelyear intelweek thisdow))) + +(define (seconds->inteldate seconds) + (define (string-leftpad in width pad-char) + (let* ((unpadded-str (->string in)) + (padlen_temp (- width (string-length unpadded-str))) + (padlen (if (< padlen_temp 0) 0 padlen_temp)) + (padding + (fold conc "" + (map (lambda (x) (->string pad-char)) (iota padlen))))) + (conc padding unpadded-str))) + (define (zeropad num width) + (string-leftpad num width #:0)) + + (let-values (((intelyear intelweek day-of-week-num) + (seconds->inteldate-values seconds))) + (let ((intelyear-str + (zeropad + (->string + (if (> intelyear 1999) + (- intelyear 2000) intelyear)) + 2)) + (intelweek-str + (zeropad (->string intelweek) 2)) + (dow-str (->string day-of-week-num))) + (conc intelyear-str "ww" intelweek-str "." dow-str)))) + +(define (isodate->inteldate isodate) + (seconds->inteldate + (isodate->seconds isodate))) + +(define (inteldate->seconds inteldate) + (let ((match (string-match "^(\\d+)ww(\\d+).(\\d)$" inteldate))) + (if + (not match) + #f + (let* ( + (intelyear-raw (string->number (list-ref match 1))) + (intelyear (if (< intelyear-raw 100) + (+ intelyear-raw 2000) + intelyear-raw)) + (intelww (string->number (list-ref match 2))) + (dayofweek (string->number (list-ref match 3))) + + (day-of-seconds (* 60 60 24 )) + (week-of-seconds (* day-of-seconds 7)) + + + ;; get seconds at ww1.0 + (new-years-date (make-date 0 0 0 0 1 1 intelyear)) + (new-years-seconds + (date->seconds new-years-date)) + (new-years-dayofweek (date-week-day new-years-date)) + (ww1.0_seconds (- new-years-seconds + (* day-of-seconds + new-years-dayofweek))) + (workweek-adjustment (* week-of-seconds (sub1 intelww))) + (weekday-adjustment (* dayofweek day-of-seconds)) + + (result (+ ww1.0_seconds workweek-adjustment weekday-adjustment))) + result)))) + +(define (inteldate->isodate inteldate) + (seconds->isodate (inteldate->seconds inteldate))) + +(define (inteldate-tests) + (test-group + "date conversion tests" + (let ((test-table + '(("16ww01.5" . "2016-01-01") + ("16ww18.5" . "2016-04-29") + ("1999ww33.5" . "1999-08-13") + ("16ww18.4" . "2016-04-28") + ("16ww18.3" . "2016-04-27") + ("13ww01.0" . "2012-12-30") + ("13ww52.6" . "2013-12-28") + ("16ww53.3" . "2016-12-28")))) + (for-each + (lambda (test-pair) + (let ((inteldate (car test-pair)) + (isodate (cdr test-pair))) + (test + (conc "(isodate->inteldate "isodate ") => "inteldate) + inteldate + (isodate->inteldate isodate)) + + (test + (conc "(inteldate->isodate "inteldate ") => "isodate) + isodate + (inteldate->isodate inteldate)))) + test-table)))) + +;(inteldate-tests) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -11,11 +11,11 @@ ;;====================================================================== ;; launch a task - this runs on the originating host, tests themselves ;; ;;====================================================================== -(use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3 call-with-environment-variables) +(use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3 call-with-environment-variables csv) (use defstruct) (import (prefix base64 base64:)) (import (prefix sqlite3 sqlite3:)) @@ -55,10 +55,29 @@ (common:read-encoded-string enccmd) '()))) ;; 0 1 2 3 (defstruct launch:einf (pid #t)(exit-status #t)(exit-code #t)(rollup-status 0)) + +;; return (conc status ": " comment) from the final section so that +;; the comment can be set in the step record in launch.scm +;; +(define (launch:load-logpro-dat run-id test-id stepname) + (let ((cname (conc stepname ".dat"))) + (if (file-exists? cname) + (let* ((dat (read-config cname #f #f)) + (csvr (db:logpro-dat->csv dat stepname)) + (csvt (let-values (( (fmt-cell fmt-record fmt-csv) (make-format ","))) + (fmt-csv (map list->csv-record csvr)))) + (status (configf:lookup dat "final" "exit-status")) + (msg (configf:lookup dat "final" "message"))) + (rmt:csv->test-data run-id test-id csvt) + (cond + ((equal? status "PASS") "PASS") ;; skip the message part if status is pass + (status (conc (configf:lookup dat "final" "exit-status") ": " (if msg msg "no message"))) + (else #f))) + #f))) (define (launch:runstep ezstep run-id test-id exit-info m tal testconfig) (let* ((stepname (car ezstep)) ;; do stuff to run the step (stepinfo (cadr ezstep)) (stepparts (string-match (regexp "^(\\{([^\\}]*)\\}\\s*|)(.*)$") stepinfo)) @@ -65,10 +84,11 @@ (stepparms (list-ref stepparts 2)) ;; for future use, {VAR=1,2,3}, run step for each (stepcmd (list-ref stepparts 3)) (script "") ; "#!/bin/bash\n") ;; yep, we depend on bin/bash FIXME!!!\ (logpro-file (conc stepname ".logpro")) (html-file (conc stepname ".html")) + (dat-file (conc stepname ".dat")) (tconfig-logpro (configf:lookup testconfig "logpro" stepname)) (logpro-used (file-exists? logpro-file))) (if (and tconfig-logpro (not logpro-used)) ;; no logpro file found but have a defn in the testconfig @@ -131,14 +151,19 @@ (thread-sleep! 2) (processloop (+ i 1))))) (debug:print-info 0 "logpro for step " stepname " exited with code " (launch:einf-exit-code exit-info))))) ;; (vector-ref exit-info 2))))) (let ((exinfo (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2)) - (logfna (if logpro-used (conc stepname ".html") ""))) - (rmt:teststep-set-status! run-id test-id stepname "end" exinfo #f logfna)) - (if logpro-used - (rmt:test-set-log! run-id test-id (conc stepname ".html"))) + (logfna (if logpro-used (conc stepname ".html") "")) + (comment #f)) + (if logpro-used + (let ((datfile (conc stepname ".dat"))) + ;; load the .dat file into the test_data table if it exists + (if (file-exists? datfile) + (set! comment (launch:load-logpro-dat run-id test-id stepname))) + (rmt:test-set-log! run-id test-id (conc stepname ".html")))) + (rmt:teststep-set-status! run-id test-id stepname "end" exinfo comment logfna)) ;; set the test final status (let* ((process-exit-status (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2)) (this-step-status (cond ((and (eq? process-exit-status 2) logpro-used) 'warn) ;; logpro 2 = warnings ((and (eq? process-exit-status 3) logpro-used) 'check) ;; logpro 3 = check @@ -202,13 +227,169 @@ (launch:einf-rollup-status-set! exit-info 1) ;; (vector-set! exit-info 3 1) ;; force fail, this used to be next-state but that doesn't make sense. should always be "COMPLETED" (tests:test-set-status! run-id test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f) ))) logpro-used)) +(define (launch:manage-steps run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m) + ;; (let-values + ;; (((pid exit-status exit-code) + ;; (run-n-wait fullrunscript))) + ;; (tests:test-set-status! test-id "RUNNING" "n/a" #f #f) + ;; Since we should have a clean slate at this time there is no need to do + ;; any of the other stuff that tests:test-set-status! does. Let's just + ;; force RUNNING/n/a + + ;; (thread-sleep! 0.3) + (tests:test-force-state-status! run-id test-id "RUNNING" "n/a") + (rmt:roll-up-pass-fail-counts run-id test-name item-path #f "RUNNING") + ;; (thread-sleep! 0.3) ;; NFS slowness has caused grief here + + ;; if there is a runscript do it first + (if fullrunscript + (let ((pid (process-run fullrunscript))) + (rmt:test-set-top-process-pid run-id test-id pid) + (let loop ((i 0)) + (let-values + (((pid-val exit-status exit-code) (process-wait pid #t))) + (mutex-lock! m) + (launch:einf-pid-set! exit-info pid) ;; (vector-set! exit-info 0 pid) + (launch:einf-exit-status-set! exit-info exit-status) ;; (vector-set! exit-info 1 exit-status) + (launch:einf-exit-code-set! exit-info exit-code) ;; (vector-set! exit-info 2 exit-code) + (launch:einf-rollup-status-set! exit-info exit-code) ;; (vector-set! exit-info 3 exit-code) ;; rollup status + (mutex-unlock! m) + (if (eq? pid-val 0) + (begin + (thread-sleep! 2) + (loop (+ i 1))) + ))))) + ;; then, if runscript ran ok (or did not get called) + ;; do all the ezsteps (if any) + (if ezsteps + (let* ((testconfig ;; (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here? + ;; NOTE: it is tempting to turn off force-create of testconfig but dynamic + ;; ezstep names need a full re-eval here. + (tests:get-testconfig test-name tconfigreg #t force-create: #t)) ;; 'return-procs))) + (ezstepslst (if (hash-table? testconfig) + (hash-table-ref/default testconfig "ezsteps" '()) + #f))) + (if testconfig + (hash-table-set! *testconfigs* test-name testconfig) ;; cached for lazy reads later ... + (begin + (launch:setup) + (debug:print 0 "WARNING: no testconfig found for " test-name " in search path:\n " + (string-intersperse (tests:get-tests-search-path *configdat*) "\n ")))) + ;; after all that, still no testconfig? Time to abort + (if (not testconfig) + (begin + (debug:print 0 "ERROR: Failed to resolve megatest.config, runconfigs.config and testconfig issues. Giving up now") + (exit 1))) + (if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps")) + ;; if ezsteps was defined then we are sure to have at least one step but check anyway + (if (not (> (length ezstepslst) 0)) + (debug:print 0 "ERROR: ezsteps defined but ezstepslst is zero length") + (let loop ((ezstep (car ezstepslst)) + (tal (cdr ezstepslst)) + (prevstep #f)) + ;; check exit-info (vector-ref exit-info 1) + (if (launch:einf-exit-status exit-info) ;; (vector-ref exit-info 1) + (let ((logpro-used (launch:runstep ezstep run-id test-id exit-info m tal testconfig)) + (stepname (car ezstep))) + ;; if logpro-used read in the stepname.dat file + (if (and logpro-used (file-exists? (conc stepname ".dat"))) + (launch:load-logpro-dat run-id test-id stepname)) + (if (steprun-good? logpro-used (launch:einf-exit-code exit-info)) + (if (not (null? tal)) + (loop (car tal) (cdr tal) stepname)) + (debug:print 4 "WARNING: step " (car ezstep) " failed. Stopping"))) + (debug:print 4 "WARNING: a prior step failed, stopping at " ezstep))))))) + +(define (launch:monitor-job run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m work-area runtlim misc-flags) + (let* ((start-seconds (current-seconds)) + (calc-minutes (lambda () + (inexact->exact + (round + (- + (current-seconds) + start-seconds))))) + (kill-tries 0)) + ;; (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area) + ;; (tests:set-full-meta-info test-id run-id (calc-minutes) work-area) + (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area 10) + (let loop ((minutes (calc-minutes)) + (cpu-load (get-cpu-load)) + (disk-free (get-df (current-directory)))) + (let ((new-cpu-load (let* ((load (get-cpu-load)) + (delta (abs (- load cpu-load)))) + (if (> delta 0.6) ;; don't bother updating with small changes + load + #f))) + (new-disk-free (let* ((df (get-df (current-directory))) + (delta (abs (- df disk-free)))) + (if (> delta 200) ;; ignore changes under 200 Meg + df + #f)))) + (set! kill-job? (or (test-get-kill-request run-id test-id) ;; run-id test-name itemdat)) + (and runtlim (let* ((run-seconds (- (current-seconds) start-seconds)) + (time-exceeded (> run-seconds runtlim))) + (if time-exceeded + (begin + (debug:print-info 0 "KILLING TEST DUE TO TIME LIMIT EXCEEDED! Runtime=" run-seconds " seconds, limit=" runtlim) + #t) + #f))))) + (tests:update-central-meta-info run-id test-id new-cpu-load new-disk-free (calc-minutes) #f #f) + (if kill-job? + (begin + (mutex-lock! m) + ;; NOTE: The pid can change as different steps are run. Do we need handshaking between this + ;; section and the runit section? Or add a loop that tries three times with a 1/4 second + ;; between tries? + (let* ((pid1 (launch:einf-pid exit-info)) ;; (vector-ref exit-info 0)) + (pid2 (rmt:test-get-top-process-pid run-id test-id)) + (pids (delete-duplicates (filter number? (list pid1 pid2))))) + (if (not (null? pids)) + (begin + (for-each + (lambda (pid) + (handle-exceptions + exn + (begin + (debug:print-info 0 "Unable to kill process with pid " pid ", possibly already killed.") + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))) + (debug:print 0 "WARNING: Request received to kill job " pid) ;; " (attempt # " kill-tries ")") + (debug:print-info 0 "Signal mask=" (signal-mask)) + ;; (if (process:alive? pid) + ;; (begin + (map (lambda (pid-num) + (process-signal pid-num signal/term)) + (process:get-sub-pids pid)) + (thread-sleep! 5) + ;; (if (process:process-alive? pid) + (map (lambda (pid-num) + (handle-exceptions + exn + #f + (process-signal pid-num signal/kill))) + (process:get-sub-pids pid)))) + ;; (debug:print-info 0 "not killing process " pid " as it is not alive")))) + pids) + (tests:test-set-status! run-id test-id "KILLED" "KILLED" (args:get-arg "-m") #f)) + (begin + (debug:print 0 "ERROR: Nothing to kill, pid1=" pid1 ", pid2=" pid2) + (tests:test-set-status! run-id test-id "KILLED" "FAILED TO KILL" (args:get-arg "-m") #f) + ))) + (mutex-unlock! m) + ;; no point in sticking around. Exit now. + (exit))) + (if (hash-table-ref/default misc-flags 'keep-going #f) + (begin + (thread-sleep! 3) ;; (+ 3 (random 6))) ;; add some jitter to the call home time to spread out the db accesses + (if (hash-table-ref/default misc-flags 'keep-going #f) ;; keep originals for cpu-load and disk-free unless they change more than the allowed delta + (loop (calc-minutes) (or new-cpu-load cpu-load) (or new-disk-free disk-free))))))) + (tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f))) ;; NOTE: Checking twice for keep-going is intentional + (define (launch:execute encoded-cmd) - - (let* ((cmdinfo (common:read-encoded-string encoded-cmd)) + (let* ((cmdinfo (common:read-encoded-string encoded-cmd)) (tconfigreg (tests:get-all))) (setenv "MT_CMDINFO" encoded-cmd) (if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed) ;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1)) (let* ((testpath (assoc/default 'testpath cmdinfo)) ;; testpath is the test spec area @@ -241,12 +422,11 @@ (let ((fulln (conc testpath "/" runscript))) (if (and (file-exists? fulln) (file-execute-access? fulln)) fulln runscript))))) ;; assume it is on the path - ;; (rollup-status 0) - ) + ) ;; (rollup-status 0) ;; NFS might not have propagated the directory meta data to the run host - give it time if needed (let loop ((count 0)) (if (or (file-exists? top-path) (> count 10)) @@ -274,14 +454,12 @@ (thread-start! th2) (thread-start! th1) (thread-join! th2))))) (set-signal-handler! signal/int sighand) (set-signal-handler! signal/term sighand) - (set-signal-handler! signal/stop sighand)) + ) ;; (set-signal-handler! signal/stop sighand) - ;; (set-signal-handler! signal/int (lambda () - ;; Do not run the test if it is REMOVING, RUNNING, KILLREQ or REMOTEHOSTSTART, ;; Mark the test as REMOTEHOSTSTART *IMMEDIATELY* ;; (let* ((test-info (rmt:get-test-info-by-id run-id test-id)) (test-host (db:test-get-host test-info)) @@ -390,11 +568,11 @@ ;; open-run-close not needed for test-set-meta-info ;; (tests:set-full-meta-info #f test-id run-id 0 work-area) ;; (tests:set-full-meta-info test-id run-id 0 work-area) (tests:set-full-meta-info #f test-id run-id 0 work-area 10) - (thread-sleep! 0.3) ;; NFS slowness has caused grief here + ;; (thread-sleep! 0.3) ;; NFS slowness has caused grief here (if (args:get-arg "-xterm") (set! fullrunscript "xterm") (if (and fullrunscript (file-exists? fullrunscript) @@ -403,176 +581,31 @@ ;; We are about to actually kick off the test ;; so this is a good place to remove the records for ;; any previous runs ;; (db:test-remove-steps db run-id testname itemdat) - + ;; (let* ((m (make-mutex)) (kill-job? #f) (exit-info (make-launch:einf pid: #t exit-status: #t exit-code: #t rollup-status: 0)) ;; pid exit-status exit-code (i.e. process was successfully run) rollup-status (job-thread #f) - (keep-going #t) + ;; (keep-going #t) + (misc-flags (let ((ht (make-hash-table))) + (hash-table-set! ht 'keep-going #t) + ht)) (runit (lambda () - ;; (let-values - ;; (((pid exit-status exit-code) - ;; (run-n-wait fullrunscript))) - ;; (tests:test-set-status! test-id "RUNNING" "n/a" #f #f) - ;; Since we should have a clean slate at this time there is no need to do - ;; any of the other stuff that tests:test-set-status! does. Let's just - ;; force RUNNING/n/a - - - ;; (thread-sleep! 0.3) - (tests:test-force-state-status! run-id test-id "RUNNING" "n/a") - (rmt:roll-up-pass-fail-counts run-id test-name item-path #f "RUNNING") - ;; (thread-sleep! 0.3) ;; NFS slowness has caused grief here - - ;; if there is a runscript do it first - (if fullrunscript - (let ((pid (process-run fullrunscript))) - (rmt:test-set-top-process-pid run-id test-id pid) - (let loop ((i 0)) - (let-values - (((pid-val exit-status exit-code) (process-wait pid #t))) - (mutex-lock! m) - (launch:einf-pid-set! exit-info pid) ;; (vector-set! exit-info 0 pid) - (launch:einf-exit-status-set! exit-info exit-status) ;; (vector-set! exit-info 1 exit-status) - (launch:einf-exit-code-set! exit-info exit-code) ;; (vector-set! exit-info 2 exit-code) - (launch:einf-rollup-status-set! exit-info exit-code) ;; (vector-set! exit-info 3 exit-code) ;; rollup status - (mutex-unlock! m) - (if (eq? pid-val 0) - (begin - (thread-sleep! 2) - (loop (+ i 1))) - ))))) - ;; then, if runscript ran ok (or did not get called) - ;; do all the ezsteps (if any) - (if ezsteps - (let* ((testconfig ;; (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here? - ;; NOTE: it is tempting to turn off force-create of testconfig but dynamic - ;; ezstep names need a full re-eval here. - (tests:get-testconfig test-name tconfigreg #t force-create: #t)) ;; 'return-procs))) - (ezstepslst (if (hash-table? testconfig) - (hash-table-ref/default testconfig "ezsteps" '()) - #f))) - (if testconfig - (hash-table-set! *testconfigs* test-name testconfig) ;; cached for lazy reads later ... - (begin - (launch:setup) - (debug:print 0 "WARNING: no testconfig found for " test-name " in search path:\n " - (string-intersperse (tests:get-tests-search-path *configdat*) "\n ")))) - ;; after all that, still no testconfig? Time to abort - (if (not testconfig) - (begin - (debug:print 0 "ERROR: Failed to resolve megatest.config, runconfigs.config and testconfig issues. Giving up now") - (exit 1))) - (if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps")) - ;; if ezsteps was defined then we are sure to have at least one step but check anyway - (if (not (> (length ezstepslst) 0)) - (debug:print 0 "ERROR: ezsteps defined but ezstepslst is zero length") - (let loop ((ezstep (car ezstepslst)) - (tal (cdr ezstepslst)) - (prevstep #f)) - ;; check exit-info (vector-ref exit-info 1) - (if (launch:einf-exit-status exit-info) ;; (vector-ref exit-info 1) - (let ((logpro-used (launch:runstep ezstep run-id test-id exit-info m tal testconfig))) - (if (steprun-good? logpro-used (launch:einf-exit-code exit-info)) - (if (not (null? tal)) - (loop (car tal) (cdr tal) stepname)) - (debug:print 4 "WARNING: step " (car ezstep) " failed. Stopping"))) - (debug:print 4 "WARNING: a prior step failed, stopping at " ezstep)))))))) + (launch:manage-steps run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m))) (monitorjob (lambda () - (let* ((start-seconds (current-seconds)) - (calc-minutes (lambda () - (inexact->exact - (round - (- - (current-seconds) - start-seconds))))) - (kill-tries 0)) - ;; (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area) - ;; (tests:set-full-meta-info test-id run-id (calc-minutes) work-area) - (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area 10) - (let loop ((minutes (calc-minutes)) - (cpu-load (get-cpu-load)) - (disk-free (get-df (current-directory)))) - (let ((new-cpu-load (let* ((load (get-cpu-load)) - (delta (abs (- load cpu-load)))) - (if (> delta 0.6) ;; don't bother updating with small changes - load - #f))) - (new-disk-free (let* ((df (get-df (current-directory))) - (delta (abs (- df disk-free)))) - (if (> delta 200) ;; ignore changes under 200 Meg - df - #f)))) - (set! kill-job? (or (test-get-kill-request run-id test-id) ;; run-id test-name itemdat)) - (and runtlim (let* ((run-seconds (- (current-seconds) start-seconds)) - (time-exceeded (> run-seconds runtlim))) - (if time-exceeded - (begin - (debug:print-info 0 "KILLING TEST DUE TO TIME LIMIT EXCEEDED! Runtime=" run-seconds " seconds, limit=" runtlim) - #t) - #f))))) - (tests:update-central-meta-info run-id test-id new-cpu-load new-disk-free (calc-minutes) #f #f) - (if kill-job? - (begin - (mutex-lock! m) - ;; NOTE: The pid can change as different steps are run. Do we need handshaking between this - ;; section and the runit section? Or add a loop that tries three times with a 1/4 second - ;; between tries? - (let* ((pid1 (launch:einf-pid exit-info)) ;; (vector-ref exit-info 0)) - (pid2 (rmt:test-get-top-process-pid run-id test-id)) - (pids (delete-duplicates (filter number? (list pid1 pid2))))) - (if (not (null? pids)) - (begin - (for-each - (lambda (pid) - (handle-exceptions - exn - (begin - (debug:print-info 0 "Unable to kill process with pid " pid ", possibly already killed.") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))) - (debug:print 0 "WARNING: Request received to kill job " pid) ;; " (attempt # " kill-tries ")") - (debug:print-info 0 "Signal mask=" (signal-mask)) - ;; (if (process:alive? pid) - ;; (begin - (map (lambda (pid-num) - (process-signal pid-num signal/term)) - (process:get-sub-pids pid)) - (thread-sleep! 5) - ;; (if (process:process-alive? pid) - (map (lambda (pid-num) - (handle-exceptions - exn - #f - (process-signal pid-num signal/kill))) - (process:get-sub-pids pid)))) - ;; (debug:print-info 0 "not killing process " pid " as it is not alive")))) - pids) - (tests:test-set-status! run-id test-id "KILLED" "KILLED" (args:get-arg "-m") #f)) - (begin - (debug:print 0 "ERROR: Nothing to kill, pid1=" pid1 ", pid2=" pid2) - (tests:test-set-status! run-id test-id "KILLED" "FAILED TO KILL" (args:get-arg "-m") #f) - ))) - (mutex-unlock! m) - ;; no point in sticking around. Exit now. - (exit))) - (if keep-going - (begin - (thread-sleep! 3) ;; (+ 3 (random 6))) ;; add some jitter to the call home time to spread out the db accesses - (if keep-going ;; keep originals for cpu-load and disk-free unless they change more than the allowed delta - (loop (calc-minutes) (or new-cpu-load cpu-load) (or new-disk-free disk-free))))))) - (tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f)))) ;; NOTE: Checking twice for keep-going is intentional + (launch:monitor-job run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m work-area runtlim misc-flags))) (th1 (make-thread monitorjob "monitor job")) (th2 (make-thread runit "run job"))) (set! job-thread th2) (thread-start! th1) (thread-start! th2) (thread-join! th2) (debug:print-info 0 "Megatest exectute of test " test-name ", item path " item-path " complete. Notifying the db ...") - (set! keep-going #f) + (hash-table-set! misc-flags 'keep-going #f) (thread-join! th1) (thread-sleep! 1) ;; givbe thread th1 a chance to be done TODO: Verify this is needed. At 0.1 I was getting fail to stop, increased to total of 1.1 sec. (mutex-lock! m) (let* ((item-path (item-list->path itemdat)) ;; only state and status needed - use lazy routine @@ -630,13 +663,13 @@ (args:get-arg ":runname") (getenv "MT_RUNNAME"))) (fulldir (conc linktree "/" target "/" runname))) - (debug:print-info 0 "Have -runtests with target=" target ", runname=" runname ", fulldir=" fulldir ", testpatt=" (or (args:get-arg "-testpatt") "%")) (if (and linktree (file-exists? linktree)) ;; can't proceed without linktree (begin + (debug:print-info 0 "Have -run with target=" target ", runname=" runname ", fulldir=" fulldir ", testpatt=" (or (args:get-arg "-testpatt") "%")) (if (not (file-exists? fulldir)) (create-directory fulldir #t)) ;; need to protect with exception handler (if (and target runname (file-exists? fulldir)) @@ -643,84 +676,16 @@ (let ((tmpfile (conc fulldir "/.megatest.cfg." (current-seconds))) (targfile (conc fulldir "/.megatest.cfg-" megatest-version "-" megatest-fossil-hash)) (rconfig (conc fulldir "/.runconfig." megatest-version "-" megatest-fossil-hash))) (if (file-exists? rconfig) ;; only cache megatest.config AFTER runconfigs has been cached (begin - (debug:print-info 0 "Caching megatest.config in " fulldir "/.megatest.cfg") + (debug:print-info 0 "Caching megatest.config in " tmpfile) (configf:write-alist *configdat* tmpfile) (system (conc "ln -sf " tmpfile " " targfile)))) - ))))))) - -;; set up the very basics needed for doing anything here. -;; -(define (launch:setup-old #!key (force #f)) - ;; would set values for KEYS in the environment here for better support of env-override but - ;; have chicken/egg scenario. need to read megatest.config then read it again. Going to - ;; pass on that idea for now - ;; special case - (if (or force (not (hash-table? *configdat*))) ;; no need to re-open on every call - (begin - (set! *configinfo* (or (if (get-environment-variable "MT_CMDINFO") ;; we are inside a test - do not reprocess configs - (let ((alistconfig (conc (get-environment-variable "MT_LINKTREE") "/" - (get-environment-variable "MT_TARGET") "/" - (get-environment-variable "MT_RUNNAME") "/" - ".megatest.cfg-" megatest-version "-" megatest-fossil-hash))) - (if (file-exists? alistconfig) - (list (configf:read-alist alistconfig) - (get-environment-variable "MT_RUN_AREA_HOME")) - #f)) - #f) ;; no config cached - give up - (let ((runname (or (args:get-arg "-runname")(args:get-arg ":runname")))) - (if runname (setenv "MT_RUNNAME" runname)) - (find-and-read-config - (if (args:get-arg "-config")(args:get-arg "-config") "megatest.config") - environ-patt: "env-override" - given-toppath: (get-environment-variable "MT_RUN_AREA_HOME") - pathenvvar: "MT_RUN_AREA_HOME")))) - (set! *configdat* (if (car *configinfo*)(car *configinfo*) #f)) - (set! *toppath* (if (car *configinfo*)(cadr *configinfo*) #f)) - (let* ((tmptransport (configf:lookup *configdat* "server" "transport")) - (transport (if tmptransport (string->symbol tmptransport) 'http))) - (if (member transport '(http rpc nmsg)) - (set! *transport-type* transport) - (begin - (debug:print 0 "ERROR: Unrecognised transport " transport) - (exit)))) - (let ((linktree (configf:lookup *configdat* "setup" "linktree"))) ;; link tree is critical - (if linktree - (if (not (file-exists? linktree)) - (begin - (handle-exceptions - exn - (begin - (debug:print 0 "ERROR: Something went wrong when trying to create linktree dir at " linktree) - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) - (exit 1)) - (create-directory linktree #t)))) - (begin - (debug:print 0 "ERROR: linktree not defined in [setup] section of megatest.config") - (exit 1))) - (if linktree - (let ((dbdir (conc linktree "/.db"))) - (handle-exceptions - exn - (begin - (debug:print 0 "ERROR: failed to create the " dbdir " area for your database files") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))) - (if (not (directory-exists? dbdir))(create-directory dbdir))) - (setenv "MT_LINKTREE" linktree)) - (begin - (debug:print 0 "ERROR: linktree is required in your megatest.config [setup] section") - (exit 1))) - (if (and *toppath* - (directory-exists? *toppath*)) - (setenv "MT_RUN_AREA_HOME" *toppath*) - (begin - (debug:print 0 "ERROR: failed to find the top path to your Megatest area.") - (exit 1))) - ))) - *toppath*) + ))) + (debug:print-info 1 "No linktree yet, no caching configs."))))) + ;; gather available information, if legit read configs in this order: ;; ;; if have cache; ;; read it a return it @@ -768,12 +733,17 @@ given-toppath: toppath pathenvvar: "MT_RUN_AREA_HOME")) (first-rundat (let ((toppath (if toppath toppath (car first-pass)))) - (read-config (conc toppath "/runconfigs.config") *runconfigdat* #t - sections: sections)))) + (read-config ;; (conc toppath "/runconfigs.config") + (conc (if (string? toppath) + toppath + (get-environment-variable "MT_RUN_AREA_HOME")) + "/runconfigs.config") + *runconfigdat* #t + sections: sections)))) (set! *runconfigdat* first-rundat) (if first-pass ;; (begin (set! *configdat* (car first-pass)) (set! *configinfo* first-pass) Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -1,7 +1,7 @@ ;; Always use two or four digit decimal -;; 1.01, 1.02...1.10,1.11,1,1101 ... 1.99,2.00.. +;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00.. (declare (unit megatest-version)) -(define megatest-version 1.6031) +(define megatest-version 1.6102) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -82,10 +82,11 @@ -unlock : unlock run specified by target and runname -set-run-status status : sets status for run to status, requires -target and -runname -get-run-status : gets status for run specified by target and runname -run-wait : wait on run specified by target and runname -preclean : remove the existing test directory before running the test + -clean-cache : remove the cached megatest.config and runconfig.config files Selectors (e.g. use for -runtests, -remove-runs, -set-state-status, -list-runs etc.) -target key1/key2/... : run for key1, key2, etc. -reqtarg key1/key2/... : run for key1, key2, etc. but key1/key2 must be in runconfig -testpatt patt1/patt2,patt3/... : % is wildcard @@ -270,10 +271,11 @@ "-summarize-items" "-gui" "-daemonize" "-preclean" "-rerun-clean" + "-clean-cache" ;; misc "-repl" "-lock" "-unlock" @@ -385,10 +387,11 @@ (if (common:low-noise-print 30) (debug:print-info 0 "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*))))) "Watchdog thread"))) (thread-start! *watchdog*) + (if (args:get-arg "-log") (let ((oup (open-output-file (args:get-arg "-log")))) (debug:print-info 0 "Sending log output to " (args:get-arg "-log")) (current-error-port oup) @@ -408,11 +411,11 @@ (debug:print 0 "ERROR: non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.") (exit 1)))) (if (args:get-arg "-version") (begin - (print megatest-version) + (print (common:version-signature)) ;; (print megatest-version) (exit))) (define *didsomething* #f) ;; Overall exit handling setup immediately @@ -454,18 +457,48 @@ (let ((newval (conc (args:get-arg "-testpatt") "/" (args:get-arg "-itempatt")))) (debug:print 0 "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval) (hash-table-set! args:arg-hash "-testpatt" newval) (hash-table-delete! args:arg-hash "-itempatt"))) - +(if (args:get-arg "-runtests") + (debug:print 0 "WARNING: \"-runtests\" is deprecated. Use \"-run\" with \"-testpatt\" instead")) (on-exit std-exit-procedure) ;;====================================================================== ;; Misc general calls ;;====================================================================== +;; handle a clean-cache request as early as possible +;; +(if (args:get-arg "-clean-cache") + (begin + (set! *didsomething* #t) ;; suppress the help output. + (if (getenv "MT_TARGET") ;; no point in trying if no target + (if (args:get-arg "-runname") + (let* ((toppath (launch:setup)) + (linktree (if toppath (configf:lookup *configdat* "setup" "linktree"))) + (runtop (conc linktree "/" (getenv "MT_TARGET") "/" (args:get-arg "-runname"))) + (files (if (file-exists? runtop) + (append (glob (conc runtop "/.megatest*")) + (glob (conc runtop "/.runconfig*"))) + '()))) + (if (null? files) + (debug:print-info 0 "No cached megatest or runconfigs files found. None removed.") + (begin + (debug:print-info 0 "Removing cached files:\n " (string-intersperse files "\n ")) + (for-each + (lambda (f) + (handle-exceptions + exn + (debug:print 0 "WARNING: Failed to remove file " f) + (delete-file f))) + files)))) + (debug:print 0 "ERROR: -clean-cache requires -runname.")) + (debug:print 0 "ERROR: -clean-cache requires -target or -reqtarg")))) + + (if (args:get-arg "-env2file") (begin (save-environment-as-files (args:get-arg "-env2file")) (set! *didsomething* #t))) @@ -479,33 +512,10 @@ " => ")) (common:get-disks *configdat*)) "\n")) (set! *didsomething* #t))) -(define (make-sparse-array) - (let ((a (make-sparse-vector))) - (sparse-vector-set! a 0 (make-sparse-vector)) - a)) - -(define (sparse-array? a) - (and (sparse-vector? a) - (sparse-vector? (sparse-vector-ref a 0)))) - -(define (sparse-array-ref a x y) - (let ((row (sparse-vector-ref a x))) - (if row - (sparse-vector-ref row y) - #f))) - -(define (sparse-array-set! a x y val) - (let ((row (sparse-vector-ref a x))) - (if row - (sparse-vector-set! row y val) - (let ((new-row (make-sparse-vector))) - (sparse-vector-set! a x new-row) - (sparse-vector-set! new-row y val))))) - ;; csv processing record (define (make-refdb:csv) (vector (make-sparse-array) (make-hash-table) @@ -660,18 +670,10 @@ (if (args:get-arg "-ping") (let* ((run-id (string->number (args:get-arg "-run-id"))) (host:port (args:get-arg "-ping"))) (server:ping run-id host:port))) -;; (set! *did-something* #t) -;; (begin -;; (print ((rpc:procedure 'testing (car host-port)(cadr host-port)))) -;; (case (server:get-transport) -;; ((http)(http:ping run-id host-port)) -;; ((rpc) (rpc:procedure 'server:login (car host-port)(cadr host-port));; *toppath*)) ;; (rpc-transport:ping run-id (car host-port)(cadr host-port))) -;; (else (debug:print 0 "ERROR: No transport set")(exit))))) - ;;====================================================================== ;; Capture, save and manipulate environments ;;====================================================================== ;; NOTE: Keep these above the section where the server or client code is setup @@ -708,12 +710,10 @@ (env:print added removed changed))) (env:print added removed changed)) (env:close-database db) (set! *didsomething* #t)) (debug:print 0 "ERROR: Parameter to -envdelta should be new=star-end"))))) - - ;;====================================================================== ;; Start the server - can be done in conjunction with -runall or -runtests (one day...) ;; we start the server if not running else start the client thread ;;====================================================================== @@ -947,19 +947,22 @@ (if (not (car *configinfo*)) (begin (debug:print 0 "ERROR: Attempted " action "on test(s) but run area config file not found") (exit 1)) ;; put test parameters into convenient variables - (runs:operate-on action - target - (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) - (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") - state: (common:args-get-state) - status: (common:args-get-status) - new-state-status: (args:get-arg "-set-state-status"))) + (begin + ;; check for correct version, exit with message if not correct + (common:exit-on-version-changed) + (runs:operate-on action + target + (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) + (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") + state: (common:args-get-state) + status: (common:args-get-status) + new-state-status: (args:get-arg "-set-state-status")))) (set! *didsomething* #t))))) - + (if (args:get-arg "-remove-runs") (general-run-call "-remove-runs" "remove runs" (lambda (target runname keys keyvals) @@ -1626,11 +1629,13 @@ (if (not (launch:setup)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (if (and state status) - (rmt:teststep-set-status! run-id test-id step state status msg logfile) + (let ((comment (launch:load-logpro-dat run-id test-id step))) + ;; (rmt:test-set-log! run-id test-id (conc stepname ".html")))) + (rmt:teststep-set-status! run-id test-id step state status (or comment msg) logfile)) (begin (debug:print 0 "ERROR: You must specify :state and :status with every call to -step") (exit 6)))))) (if (args:get-arg "-step") @@ -1668,11 +1673,12 @@ (test-id (assoc/default 'test-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) (work-area (assoc/default 'work-area cmdinfo)) (db #f) ;; (open-db)) (state (args:get-arg ":state")) - (status (args:get-arg ":status"))) + (status (args:get-arg ":status")) + (stepname (args:get-arg "-step"))) (if (not (launch:setup)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) @@ -1830,17 +1836,19 @@ 'dejunk ;; 'adj-testids ;; 'old2new 'new2old ) + (if (common:version-changed?) + (common:set-last-run-version)) (set! *didsomething* #t))) (if (args:get-arg "-mark-incompletes") (begin (if (not (launch:setup)) (begin - (debug:print 0 "Failed to setup, exiting") b + (debug:print 0 "Failed to setup, exiting") (exit 1))) (open-run-close db:find-and-mark-incomplete #f) (set! *didsomething* #t))) ;;====================================================================== Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -659,14 +659,15 @@ ;;====================================================================== ;; T E S T D A T A ;;====================================================================== (define (rmt:read-test-data run-id test-id categorypatt #!key (work-area #f)) - (let ((tdb (rmt:open-test-db-by-test-id run-id test-id work-area: work-area))) - (if tdb - (tdb:read-test-data tdb test-id categorypatt) - '()))) + (rmt:send-receive 'read-test-data run-id (list run-id test-id categorypatt))) +;; (let ((tdb (rmt:open-test-db-by-test-id run-id test-id work-area: work-area))) +;; (if tdb +;; (tdb:read-test-data tdb test-id categorypatt) +;; '()))) (define (rmt:testmeta-add-record testname) (rmt:send-receive 'testmeta-add-record #f (list testname))) (define (rmt:testmeta-get-record testname) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -195,11 +195,11 @@ (set! run-count config-reruns)) (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) (let ((sighand (lambda (signum) - y ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting + ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting (set! *time-to-exit* #t) (print "Received signal " signum ", cleaning up before exit. Please wait...") (let ((th1 (make-thread (lambda () (let ((tdbdat (tasks:open-db))) (rmt:tasks-set-state-given-param-key task-key "killed")) @@ -373,20 +373,21 @@ (let ((reglen (configf:lookup *configdat* "setup" "runqueue"))) (if (> (length (hash-table-keys test-records)) 0) (let* ((keep-going #t) (run-queue-retries 5) (th1 (make-thread (lambda () - (handle-exceptions - exn - (begin - (print-call-chain (current-error-port)) - (debug:print 0 "ERROR: failure in runs:run-tests-queue thread, error: " ((condition-property-accessor 'exn 'message) exn)) - (if (> run-queue-retries 0) - (begin - (set! run-queue-retries (- run-queue-retries 1)) - (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry)))) - (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry))) + (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry)) + ;; (handle-exceptions + ;; exn + ;; (begin + ;; (print-call-chain (current-error-port)) + ;; (debug:print 0 "ERROR: failure in runs:run-tests-queue thread, error: " ((condition-property-accessor 'exn 'message) exn)) + ;; (if (> run-queue-retries 0) + ;; (begin + ;; (set! run-queue-retries (- run-queue-retries 1)) + ;; (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry)))) + ;; (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry))) "runs:run-tests-queue")) (th2 (make-thread (lambda () ;; (rmt:find-and-mark-incomplete-all-runs))))) CAN'T INTERRUPT IT ... (let ((run-ids (rmt:get-all-run-ids))) (for-each (lambda (run-id) @@ -459,11 +460,18 @@ (define runs:nothing-left-in-queue-count 0) (define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmaps) (let* ((loop-list (list hed tal reg reruns)) - (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps)) + (prereqs-not-met (let ((res (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps))) + (if (list? res) + res + (begin + (debug:print 0 + "ERROR: rmt:get-prereqs-not-met returned non-list!\n" + " res=" res " run-id=" run-id " waitons=" waitons " hed=" hed " item-path=" item-path " testmode=" testmode " itemmaps=" itemmaps) + '())))) ;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap)) (fails (runs:calc-fails prereqs-not-met)) (prereq-fails (runs:calc-prereq-fail prereqs-not-met)) (non-completed (runs:calc-not-completed prereqs-not-met)) (runnables (runs:calc-runnable prereqs-not-met))) @@ -652,11 +660,15 @@ (num-running-in-jobgroup (list-ref run-limits-info 2)) (max-concurrent-jobs (list-ref run-limits-info 3)) (job-group-limit (list-ref run-limits-info 4)) (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps)) ;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap)) - (fails (runs:calc-fails prereqs-not-met)) + (fails (if (list? prereqs-not-met) + (runs:calc-fails prereqs-not-met) + (begin + (debug:print 0 "ERROR: prereqs-not-met is not a list! " prereqs-not-met) + '()))) (non-completed (filter (lambda (x) ;; remove hed from not completed list, duh, of course it is not completed! (not (equal? x hed))) (runs:calc-not-completed prereqs-not-met))) (loop-list (list hed tal reg reruns)) ;; configure the load runner Index: sretrieve.scm ================================================================== --- sretrieve.scm +++ sretrieve.scm @@ -54,11 +54,11 @@ (define sretrieve:help (conc "Usage: " *exe-name* " [action [params ...]] ls : list contents of target area get : retrieve data for release -m \"message\" : why retrieved? - + cp : copy file to current directory log : get listing of recent downloads Part of the Megatest tool suite. Learn more at http://www.kiatoa.com/fossils/megatest @@ -108,10 +108,11 @@ ;; (set-busy-handler! db (busy-timeout 10000)) ; 10 second timeout ;; ...)) ;; Create the sqlite db (define (sretrieve:db-do configdat proc) + (let ((path (configf:lookup configdat "database" "location"))) (if (not path) (begin (debug:print 0 "[database]\nlocation /some/path\n\n Is missing from the config file!") (exit 1))) @@ -125,20 +126,21 @@ exn (begin (debug:print 2 "ERROR: problem accessing db " dbpath ((condition-property-accessor 'exn 'message) exn)) (exit 1)) + ;;(debug:print 0 "calling proc " proc "db path " dbpath ) (call-with-database dbpath (lambda (db) - ;; (debug:print 0 "calling proc " proc " on db " db) + ;;(debug:print 0 "calling proc " proc " on db " db) (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout (if (not dbexists)(sretrieve:initialize-db db)) (proc db))))) (debug:print 0 "ERROR: invalid path for storing database: " path)))) -;; copy in file to dest, validation is done BEFORE calling this +;; copy in directory to dest, validation is done BEFORE calling this ;; (define (sretrieve:get configdat retriever version comment) (let* ((base-dir (configf:lookup configdat "settings" "base-dir")) (datadir (conc base-dir "/" version))) (if (or (not base-dir) @@ -156,16 +158,97 @@ configdat (lambda (db) (sretrieve:register-action db "get" retriever datadir comment))) (sretrieve:do-as-calling-user (lambda () - (change-directory datadir) - (let ((files (filter (lambda (x) + (if (directory? datadir) + (begin + (change-directory datadir) + (let ((files (filter (lambda (x) (not (member x '("." "..")))) (glob "*" ".*")))) - (print "files: " files) - (process-execute "/bin/tar" (append (list "chfv" "-") files))))))) + (print "files: " files) + (process-execute "/bin/tar" (append (append (list "chfv" "-") files) (list "--ignore-failed-read"))))) + (begin + (let* ((parent-dir (pathname-directory datadir) ) + (filename (conc(pathname-file datadir) "." (pathname-extension datadir)))) + (change-directory parent-dir) + (process-execute "/bin/tar" (list "chfv" "-" filename)) + ))) +)) +)) + + +;; copy in file to dest, validation is done BEFORE calling this +;; +(define (sretrieve:cp configdat retriever file comment) + (let* ((base-dir (configf:lookup configdat "settings" "base-dir")) + (allowed-sub-paths (configf:lookup configdat "settings" "allowed-sub-paths")) + (datadir (conc base-dir "/" file)) + (filename (conc(pathname-file datadir) "." (pathname-extension datadir)))) + (if (or (not base-dir) + (not (file-exists? base-dir))) + (begin + (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found") + (exit 1))) + (print datadir) + (if (not (file-exists? datadir)) + (begin + (debug:print 0 "ERROR: File (" file "), not found at " base-dir "." ) + (exit 1))) + (if (directory? datadir) + (begin + (debug:print 0 "ERROR: (" file ") is a dirctory!! cp cmd works only on files ." ) + (exit 1))) + (if(not (string-match (regexp allowed-sub-paths) file)) + (begin + (debug:print 0 "ERROR: Access denied to file (" file ")!! " ) + (exit 1))) + + (sretrieve:db-do + configdat + (lambda (db) + (sretrieve:register-action db "cp" retriever datadir comment))) + (sretrieve:do-as-calling-user + ;; (debug:print 0 "ph: "(pathname-directory datadir) "!! " ) + (change-directory (pathname-directory datadir)) + ;;(debug:print 0 "ph: /bin/tar" (list "chfv" "-" filename) ) + (process-execute "/bin/tar" (list "chfv" "-" filename))) + )) + +;; ls in file to dest, validation is done BEFORE calling this +;; +(define (sretrieve:ls configdat retriever file comment) + (let* ((base-dir (configf:lookup configdat "settings" "base-dir")) + (allowed-sub-paths (configf:lookup configdat "settings" "allowed-sub-paths")) + (datadir (conc base-dir "/" file)) + (filename (conc(pathname-file datadir) "." (pathname-extension datadir)))) + (if (or (not base-dir) + (not (file-exists? base-dir))) + (begin + (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found") + (exit 1))) + (print datadir) + (if (not (file-exists? datadir)) + (begin + (debug:print 0 "ERROR: File (" file "), not found at " base-dir "." ) + (exit 1))) + (if(not (string-match (regexp allowed-sub-paths) file)) + (begin + (debug:print 0 "ERROR: Access denied to file (" file ")!! " ) + (exit 1))) + + (sretrieve:do-as-calling-user + (lambda () + ;;(change-directory datadir) + ;; (debug:print 0 "/usr/bin/find" (list datadir "-ls" "|" "grep" "-E" "'"allowed-file-patt"'")) + ;; (status (with-input-from-pipe "find " datadir " -ls | grep -E '" allowed-file-patt "'" (lambda () (read-line)))) + ;; (debug:print 0 status) + (process-execute "/bin/ls" (list "-ls" "-lrt" datadir )) + )))) + + ;;(filter (lambda (x) ;; (not (member x '("." "..")))) ;; (glob "*" ".*")))))))) @@ -376,10 +459,11 @@ res))) (define (sretrieve:process-action configdat action . args) (let* ((base-dir (configf:lookup configdat "settings" "base-dir")) (user (current-user-name)) + (allowed-sub-paths (configf:lookup configdat "settings" "allowed-sub-paths")) (allowed-users (string-split (or (configf:lookup configdat "settings" "allowed-users") ""))) (default-area (configf:lookup configdat "settings" "default-area"))) ;; otherwise known as the package @@ -409,10 +493,33 @@ (exe-dir (configf:lookup configdat "exe-info" "exe-dir"))) ;; (relconfig (sretrieve:load-packages configdat exe-dir package-type))) (debug:print 0 "retrieving " version " of " package-type " as tar data on stdout") (sretrieve:get configdat user version msg))) + ((cp) + (if (< (length args) 1) + (begin + (debug:print 0 "ERROR: Missing arguments; " (string-intersperse args ", ")) + (exit 1))) + (let* ((remargs (args:get-args args '("-m" "-i" "-package") '() args:arg-hash 0)) + (file (car args)) + (msg (or (args:get-arg "-m") "")) ) + + (debug:print 0 "copinging " file " to current directory " ) + (sretrieve:cp configdat user file msg))) + ((ls) + (if (< (length args) 1) + (begin + (debug:print 0 "ERROR: Missing arguments; " (string-intersperse args ", ")) + (exit 1))) + (let* ((remargs (args:get-args args '("-m" "-i" "-package") '() args:arg-hash 0)) + (dir (car args)) + (msg (or (args:get-arg "-m") "")) ) + + (debug:print 0 "Listing files in " ) + (sretrieve:ls configdat user dir msg))) + (else (debug:print 0 "Unrecognised command " action))))) ;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION! ;; (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.sretrieverc"))) ;; (if (file-exists? debugcontrolf) @@ -442,11 +549,11 @@ (if base-dir (begin (print "Files in " base-dir) (sretrieve:do-as-calling-user (lambda () - (process-execute "/bin/ls" (list base-dir))))) + (process-execute "/bin/ls" (list "-lrt" base-dir))))) (print "ERROR: No base dir specified!")))) ((log) (sretrieve:db-do configdat (lambda (db) (print "Logs : ") (query (for-each-row Index: tdb.scm ================================================================== --- tdb.scm +++ tdb.scm @@ -208,10 +208,22 @@ ;; NOTE: Run this local with #f for db !!! (define (tdb:load-test-data run-id test-id) (let loop ((lin (read-line))) (if (not (eof-object? lin)) (begin + (debug:print 4 lin) + (rmt:csv->test-data run-id test-id lin) + (loop (read-line))))) + ;; roll up the current results. + ;; FIXME: Add the status too + (rmt:test-data-rollup run-id test-id #f)) + +;; NOTE: Run this local with #f for db !!! +(define (tdb:load-logpro-data run-id test-id) + (let loop ((lin (read-line))) + (if (not (eof-object? lin)) + (begin (debug:print 4 lin) (rmt:csv->test-data run-id test-id lin) (loop (read-line))))) ;; roll up the current results. ;; FIXME: Add the status too Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -583,12 +583,12 @@ (lambda (step) (debug:print 6 "step=" step) (let ((record (hash-table-ref/default res (tdb:step-get-stepname step) - ;; stepname start end status Duration Logfile - (vector (tdb:step-get-stepname step) "" "" "" "" "")))) + ;; stepname start end status Duration Logfile Comment + (vector (tdb:step-get-stepname step) "" "" "" "" "" "")))) (debug:print 6 "record(before) = " record "\nid: " (tdb:step-get-id step) "\nstepname: " (tdb:step-get-stepname step) "\nstate: " (tdb:step-get-state step) "\nstatus: " (tdb:step-get-status step) @@ -610,15 +610,19 @@ ", get-status: " (tdb:step-get-status step)) (if (and (number? startt)(number? endt)) (seconds->hr-min-sec (- endt startt)) "-1"))) (if (> (string-length (tdb:step-get-logfile step)) 0) - (vector-set! record 5 (tdb:step-get-logfile step)))) + (vector-set! record 5 (tdb:step-get-logfile step))) + (if (> (string-length (tdb:step-get-comment step)) + 0) + (vector-set! record 6 (tdb:step-get-comment step)))) (else (vector-set! record 2 (tdb:step-get-state step)) (vector-set! record 3 (tdb:step-get-status step)) - (vector-set! record 4 (tdb:step-get-event_time step)))) + (vector-set! record 4 (tdb:step-get-event_time step)) + (vector-set! record 6 (tdb:step-get-comment step)))) (hash-table-set! res (tdb:step-get-stepname step) record) (debug:print 6 "record(after) = " record "\nid: " (tdb:step-get-id step) "\nstepname: " (tdb:step-get-stepname step) "\nstate: " (tdb:step-get-state step) @@ -631,17 +635,14 @@ ((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b)) (< (tdb:step-get-id a) (tdb:step-get-id b))) (else #f))))) res)) - -;; temporarily passing in dbstruct to support direct access (i.e. bypassing servers) +;; ;; -(define (tests:get-compressed-steps dbstruct run-id test-id) - (let* ((steps-data (if dbstruct - (db:get-steps-for-test dbstruct run-id test-id) - (rmt:get-steps-for-test run-id test-id))) +(define (tests:get-compressed-steps run-id test-id) + (let* ((steps-data (rmt:get-steps-for-test run-id test-id)) (comprsteps (tests:process-steps-table steps-data))) ;; (open-run-close db:get-steps-table #f test-id work-area: work-area))) (map (lambda (x) ;; take advantage of the \n on time->string (vector (vector-ref x 0) @@ -649,11 +650,12 @@ (if (number? s)(seconds->time-string s) s)) (let ((s (vector-ref x 2))) (if (number? s)(seconds->time-string s) s)) (vector-ref x 3) ;; status (vector-ref x 4) - (vector-ref x 5))) ;; time delta + (vector-ref x 5) ;; time delta + (vector-ref x 6))) (sort (hash-table-values comprsteps) (lambda (a b) (let ((time-a (vector-ref a 1)) (time-b (vector-ref b 1))) (if (and (number? time-a)(number? time-b)) @@ -675,11 +677,11 @@ (full-name (db:test-make-full-name test-name item-path)) (oup (open-output-file (conc (db:test-get-rundir test-dat) "/test-summary.html"))) (status (db:test-get-status test-dat)) (color (common:get-color-from-status status)) (logf (db:test-get-final_logf test-dat)) - (steps-dat (tests:get-compressed-steps #f run-id test-id))) + (steps-dat (tests:get-compressed-steps run-id test-id))) ;; (dcommon:get-compressed-steps #f 1 30045) ;; (#("wasting_time" "23:36:13" "23:36:21" "0" "8.0s" "wasting_time.log")) (s:output-new oup @@ -753,22 +755,23 @@ ;; (map (lambda (testp) ;; (last (string-split testp "/"))) ;; tests))))) (define (tests:get-test-path-from-environment) - (and (getenv "MT_LINKTREE") - (getenv "MT_TARGET") - (getenv "MT_RUNNAME") - (getenv "MT_TEST_NAME") - (getenv "MT_ITEMPATH") - (conc (getenv "MT_LINKTREE") "/" - (getenv "MT_TARGET") "/" - (getenv "MT_RUNNAME") "/" - (getenv "MT_TEST_NAME") "/" - (if (or (getenv "MT_ITEMPATH") - (not (string=? "" (getenv "MT_ITEMPATH")))) - (conc "/" (getenv "MT_ITEMPATH")))))) + (if (and (getenv "MT_LINKTREE") + (getenv "MT_TARGET") + (getenv "MT_RUNNAME") + (getenv "MT_TEST_NAME") + (getenv "MT_ITEMPATH")) + (conc (getenv "MT_LINKTREE") "/" + (getenv "MT_TARGET") "/" + (getenv "MT_RUNNAME") "/" + (getenv "MT_TEST_NAME") "/" + (if (or (getenv "MT_ITEMPATH") + (not (string=? "" (getenv "MT_ITEMPATH")))) + (conc "/" (getenv "MT_ITEMPATH")))) + #f)) ;; if .testconfig exists in test directory read and return it ;; else if have cached copy in *testconfigs* return it IFF there is a section "have fulldata" ;; else read the testconfig file ;; if have path to test directory save the config as .testconfig and return it @@ -803,11 +806,11 @@ (read-config test-configf #f system-allowed environ-patt: (if system-allowed "pre-launch-env-vars" #f)) #f))) - (if cache-file (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data + (if (and tcfg cache-file) (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data (if tcfg (hash-table-set! *testconfigs* test-name tcfg)) (if (and testexists cache-file (file-write-access? cache-path)) (let ((tpath (conc cache-path "/.testconfig"))) Index: tests/rununittest.sh ================================================================== --- tests/rununittest.sh +++ tests/rununittest.sh @@ -13,8 +13,9 @@ dbdir=$(cd simplerun;megatest -show-config -section setup -var linktree)/.db rm -f simplerun/megatest.db simplerun/monitor.db simplerun/db/monitor.db $dbdir/*.db rm -rf simplelinks/ simpleruns/ simplerun/db/ $dbdir mkdir -p simplelinks simpleruns (cd simplerun;cp ../../*_records.scm .;perl -pi.bak -e 's/define-inline/define/' *_records.scm) +(cd simplerun;cp ../../altdb.scm .) # Run the test $1 is the unit test to run cd simplerun;echo '(load "../tests.scm")' | ../../bin/megatest -repl -debug $2 $1 ADDED utils/Makefile.git.installall Index: utils/Makefile.git.installall ================================================================== --- /dev/null +++ utils/Makefile.git.installall @@ -0,0 +1,334 @@ + +# Copyright 2013-2015 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. + +help : + @echo You may need to do the following setup first: + @echo + @echo sudo apt-get install libreadline-dev + @echo sudo apt-get install libwebkitgtk-dev libfreetype6-dev libx11-dev libxpm-dev libxmu-dev \ + libxft-dev libgtk2.0-dev libgl1-mesa-dev libglu1-mesa-dev libpangox-1.0-dev bison \ + libwebkitgtk-3.0-dev + @echo -- nb// adding monodevelop gets more packages of which some might be needed... + @echo sudo apt-get install libmotif3 + @echo + @echo Set up your PATH, setting it in the Makefile does not work as expected + @echo export PATH=$(PREFIX)/bin:\$$PATH + @echo + @echo For IUP set IUPBRANCH, currently $(IUPBRANCH) + @echo set IUPCONFIG, currently $(IUPCONFIG) - look in https://www.kiatoa.com/fossils/iuplib for .inc files + @echo You are using PREFIX=$(PREFIX) + @echo You are using PRODCHICKEN=$(PRODCHICKEN) + @echo You are using PROXY="$(PROXY)" + @echo If needed set PROXY to host.dom:port + @echo http_proxy=$(http_proxy) + @echo + @echo To make all do: make all + @echo make minimal: make nogui + @echo + @echo Note: If compiling on amd64 do CSC_OPTIONS=\'-C "-fPIC"\' make all IUPCONFIG= + +FPIC=-C "-fPIC" + +# Put the installation here +ifeq ($(PREFIX),) +PREFIX=$(PWD)/target +endif +ifeq ($(PRODCHICKEN),) +PRODCHICKEN=$(PREFIX)/prod-chicken/ +endif +# Set this on the command line of your make call if needed: make PROXY=host.com:1234 +PROXY= + +# http://code.call-cc.org/dev-snapshots/2015/06/07/chicken-4.10.0rc1.tar.gz +# http://code.call-cc.org/releases/4.10.0/chicken-4.10.0.tar.gz +# Select version of chicken, sqlite3 etc +CHICKEN_VERSION=4.10.1 +SQLITE3_VERSION=3090200 +# http://www.sqlite.org/2014/sqlite-autoconf-3080500.tar.gz +# http://www.sqlite.org/2015/sqlite-autoconf-3081101.tar.gz +# Override IUPBRANCH to use other than trunk +IUPBRANCH=trunk +IUPCONFIG=ubuntu-15.04.inc +# iup-3.15 + +# Eggs to install (straightforward ones) +EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \ + dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \ + json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \ + spiffy-directory-listing ssax sxml-serializer sxml-modifications sql-de-lite \ + srfi-19 refdb ini-file sparse-vectors z3 call-with-environment-variables hahn linenoise \ + crypt parley + +# +# Derived variables +# + +ifeq ($(PROXY),) +PROX:= +else +http_proxy:=http://$(PROXY) +PROX:=-proxy $(PROXY) +endif + +BUILDHOME=$(PWD) +PATH:=$(PREFIX)/bin:$(PATH) +LIBPATH=$(PREFIX)/lib$(ADDITIONAL_LIBPATH) +LD_LIBRARY_PATH=$(LIBPATH) +CHICKEN_INSTALL=$(PREFIX)/bin/chicken-install +CHICKEN_EGG_DIR=$(PREFIX)/lib/chicken/7 + +VPATH=$(CHICKEN_EGG_DIR):$(PWD)/eggflags + +vpath %.so $(CHICKEN_EGG_DIR) +vpath %.flag eggflags + +EGGSOFILES=$(addprefix $(CHICKEN_EGG_DIR)/,$(addsuffix .so,$(EGGS))) +EGGFLAGS=$(addprefix eggflags/,$(addsuffix .flag,$(EGGS))) + +# Stuff needed for IUP +ISARCHX86_64=$(shell uname -a | grep x86_64) +ifeq ($(ISARCHX86_64),) +ARCHSIZE= +else +ARCHSIZE=64_ +endif + +CSCLIBS=$(shell echo $(LD_LIBRARY_PATH) | sed 's/:/ -L/g') +CSC_OPTIONS="-I$(PREFIX)/include -L$(CSCLIBS) -C \"-fPIC\"" +# CSC_OPTIONS=-I $(PREFIX)/include -L $(CSCLIBS) + +nogui : base mutils + +#all : nogui libiup $(PREFIX)/lib/sqlite3.so +all : nogui libiup + +base : chkn eggs + +# stuff needed for Kiatoa and Megatest from matts miscellaneous stash +# NOTE TO SELF: eggifying these would be great... +mutils : base logprobin $(PREFIX)/bin/hs \ + $(PREFIX)/lib/chicken/7/mutils.so \ + $(PREFIX)/lib/chicken/7/dbi.so \ + $(PREFIX)/lib/chicken/7/stml.so \ + $(PREFIX)/lib/chicken/7/margs.so + +chkn : $(CHICKEN_INSTALL) + +eggs : $(EGGSOFILES) + +# libiup : $(PREFIX)/lib/libavcall.a +libiup : $(CHICKEN_EGG_DIR)/iup.so $(CHICKEN_EGG_DIR)/canvas-draw.so + +logprobin : $(PREFIX)/bin/logpro + +$(PREFIX)/bin/logpro : $(CHICKEN_EGG_DIR)/regex-literals.so + $(CHICKEN_INSTALL) logpro + +# Silly rule to make installing eggs more makeish, I don't understand why I need the basename +$(CHICKEN_EGG_DIR)/%.so : eggflags/%.flag + $(CHICKEN_INSTALL) $(PROX) -keep-installed $(shell basename $*) + +$(EGGFLAGS) : # $(CHICKEN_INSTALL) + mkdir -p eggflags + touch $(EGGFLAGS) + +# some setup stuff +# +$(PREFIX)/setup-chicken4x.sh : $(EGGFLAGS) + mkdir -p $(PREFIX) + (echo 'export PATH=$(PREFIX)/bin:$$PATH' > $(PREFIX)/setup-chicken4x.sh) + (echo "export LD_LIBRARY_PATH=$(LD_LIBRARY_PATH)" >> $(PREFIX)/setup-chicken4x.sh) + +$(PREFIX)/setup-chicken4x.csh : $(EGGFLAGS) + mkdir -p $(PREFIX) + (echo "setenv PATH $(PREFIX):'$$'PATH" > $(PREFIX)/setup-chicken4x.csh) + (echo "setenv LD_LIBRARY_PATH $(LD_LIBRARY_PATH)" >> $(PREFIX)/setup-chicken4x.csh) + +chicken-core/chicken.scm : chicken-$(CHICKEN_VERSION).tar.gz + #tar xf chicken-$(CHICKEN_VERSION).tar.gz + #ln -sf chicken-$(CHICKEN_VERSION) chicken-core + echo "Hello from chicken" + +chicken-4.9.0rc1.tar.gz : + wget http://code.call-cc.org/dev-snapshots/2014/04/17/chicken-4.9.0rc1.tar.gz + +chicken-4.9.0.1.tar.gz : + wget http://code.call-cc.org/releases/4.9.0/chicken-4.9.0.1.tar.gz + +chicken-4.10.0rc1.tar.gz : + wget http://code.call-cc.org/dev-snapshots/2015/06/07/chicken-4.10.0rc1.tar.gz + +chicken-4.10.0.tar.gz : + wget http://code.call-cc.org/releases/4.10.0/chicken-4.10.0.tar.gz + +chicken-4.10.1.tar.gz : + fossil clone https://www.kiatoa.com/fossils/chicken-core chicken-scheme.fossil + mkdir -p chicken-core + cd chicken-core; pwd + cd chicken-core; fossil open ../chicken-scheme.fossil + cd chicken-core; fossil up 337f5be +# wget http://code.call-cc.org/dev-snapshots/2015/08/29/chicken-4.10.1.tar.gz + +# git clone git://code.call-cc.org/chicken-core +# git clone http://code.call-cc.org/git/chicken-core.git + +$(PRODCHICKEN)/bin/chicken : + wget http://code.call-cc.org/dev-snapshots/2015/08/29/chicken-4.10.1.tar.gz + tar -xzvf chicken-4.10.1.tar.gz + cd chicken-4.10.1/; make PLATFORM=linux PREFIX=$(PRODCHICKEN) + cd chicken-4.10.1/; make PLATFORM=linux PREFIX=$(PRODCHICKEN) install + rm -rfv chicken-4.10.1/ + +$(CHICKEN_INSTALL) : chicken-core/chicken.scm $(PREFIX)/setup-chicken4x.sh $(PREFIX)/setup-chicken4x.csh $(PRODCHICKEN)/bin/chicken + cd chicken-core; LD_LIBRARY_PATH=$(PRODCHICKEN) make PLATFORM=linux CHICKEN=$(PRODCHICKEN)/bin/chicken PREFIX=$(PREFIX) + cd chicken-core; LD_LIBRARY_PATH=$(PRODCHICKEN) make PLATFORM=linux CHICKEN=$(PRODCHICKEN)/bin/chicken PREFIX=$(PREFIX) install + +#====================================================================== +# S Q L I T E 3 +#====================================================================== +# https://www.sqlite.org/2015/sqlite-autoconf-3090200.tar.gz +sqlite-autoconf-$(SQLITE3_VERSION).tar.gz : + wget http://www.sqlite.org/2015/sqlite-autoconf-$(SQLITE3_VERSION).tar.gz + +sqlite-autoconf-$(SQLITE3_VERSION)/config.log : sqlite-autoconf-$(SQLITE3_VERSION).tar.gz + tar xf sqlite-autoconf-$(SQLITE3_VERSION).tar.gz + +$(PREFIX)/bin/sqlite3 : sqlite-autoconf-$(SQLITE3_VERSION)/config.log + cd sqlite-autoconf-$(SQLITE3_VERSION);./configure --prefix=$(PREFIX);make;make install + +$(CHICKEN_EGG_DIR)/sqlite3.so : $(PREFIX)/bin/sqlite3 + CSC_OPTIONS="-I$(PREFIX)/include -L$(PREFIX)/lib" $(CHICKEN_INSTALL) $(PROX) sqlite3 + +#====================================================================== +# N A N O M S G +#====================================================================== + +# https://github.com/nanomsg/nanomsg/releases/download/0.6-beta/nanomsg-0.6-beta.tar.gz +# https://github.com/nanomsg/nanomsg/releases/download/0.8-beta/nanomsg-0.8-beta.tar.gz + +nanomsg-0.6-beta.tar.gz : + wget http://download.nanomsg.org/nanomsg-0.6-beta.tar.gz + +nanomsg-0.6-beta/COPYING : nanomsg-0.6-beta.tar.gz + tar xf nanomsg-0.6-beta.tar.gz + +$(PREFIX)/bin/nanocat : nanomsg-0.6-beta/COPYING + cd nanomsg-0.6-beta;./configure --prefix=$(PREFIX);make;make install + +$(PREFIX)/lib/nanomsg.so : $(PREFIX)/bin/nanocat + CSC_OPTIONS="-I$(PREFIX)/include -L$(PREFIX)/lib" $(CHICKEN_INSTALL) $(PROX) nanomsg + +# LD_LIBRARY_PATH=/mfs/pkgs/chicken/4.10.0-amd64/lib CSC_OPTIONS="-I/mfs/pkgs/chicken/4.10.0-amd64/include -L/mfs/pkgs/chicken/4.10.0-amd64/lib -C \"-fPIC\"" /mfs/pkgs/chicken/4.10.0-amd64/bin/chicken-install -D no-library-checks nanomsg + +#====================================================================== +# M A T T S U T I L S +#====================================================================== + +# opensrc + +opensrc.fossil : + fossil clone http://www.kiatoa.com/fossils/opensrc opensrc.fossil + +opensrc/histstore/histstore.scm : opensrc.fossil + mkdir -p opensrc + cd opensrc;if [ -e .fslckout ];then fossil update; else fossil open ../opensrc.fossil; fi + +$(PREFIX)/lib/chicken/7/mutils.so : opensrc/histstore/histstore.scm + cd opensrc/mutils;chicken-install + +$(PREFIX)/lib/chicken/7/dbi.so : opensrc/dbi/dbi.scm + cd opensrc/dbi; sed -i -e 's/.*postgres.*/;;commented out/g' dbi.scm; chicken-install + +$(PREFIX)/lib/chicken/7/margs.so : opensrc/margs/margs.scm + cd opensrc/margs;chicken-install + +opensrc/histstore/hs : opensrc/histstore/histstore.scm chkn eggs $(CHICKEN_EGG_DIR)/sqlite3.so + cd opensrc/histstore;$(PREFIX)/bin/csc histstore.scm -o hs + +$(PREFIX)/bin/hs : opensrc/histstore/hs + cp -f opensrc/histstore/hs $(PREFIX)/bin/hs + +# stml +stml.fossil : + fossil clone http://www.kiatoa.com/fossils/stml stml.fossil + +# open touches the .fossil :( +stml/requirements.scm.template : stml.fossil + mkdir -p stml + cd stml;if [ -e .fslckout ];then fossil update; else fossil open ../stml.fossil;fi + +stml/requirements.scm : stml/requirements.scm.template + cp stml/install.cfg.template stml/install.cfg + cp stml/requirements.scm.template stml/requirements.scm + +$(PREFIX)/lib/chicken/7/stml.so : stml/requirements.scm + cd stml; sed -i -e "s#.*TARGDIR.*#TARGDIR=$(PREFIX)/bin#g" install.cfg + cd stml;CSC_OPTIONS='-C "-fPIC"' make + +#====================================================================== +# F F C A L L (Used by IUP) +#====================================================================== + +ffcall.fossil : + fossil clone http://www.kiatoa.com/fossils/ffcall ffcall.fossil + +ffcall/README : ffcall.fossil + mkdir -p ffcall + cd ffcall && if [ -e README ];then fossil update; else fossil open ../ffcall.fossil; fi + +# NOTE: This worked fine *without* the enable-shared +# +$(PREFIX)/lib/libavcall.a : ffcall/README + cd ffcall;./configure --prefix=$(PREFIX) --enable-shared && make CC="gcc -fPIC" && make install + +#====================================================================== +# I U P +#====================================================================== + +iuplib.fossil : + #fossil clone http://www.kiatoa.com/fossils/iuplib iuplib.fossil + touch iuplib.fossil +iup/installall.sh : iuplib.fossil $(PREFIX)/lib/libiup.so + mkdir -p iup + pwd + wget -c --no-check-certificate http://sourceforge.net/projects/canvasdraw/files/5.9/Linux%20Libraries/cd-5.9_Linux26g4_64_lib.tar.gz/download + wget -c --no-check-certificate http://sourceforge.net/projects/iup/files/3.17/Linux%20Libraries/iup-3.17_Linux26g4_64_lib.tar.gz/download + wget -c --no-check-certificate http://sourceforge.net/projects/imtoolkit/files/3.10/Linux%20Libraries/im-3.10_Linux26g4_64_lib.tar.gz/download + #wget -c http://sourceforge.net/projects/luabinaries/files/5.3.2/Linux%20Libraries/lua-5.3.2_Linux26g4_64_lib.tar.gz/download + tar -xzvf cd-5.9_Linux26g4_64_lib.tar.gz -C iup/ + tar -xzvf im-3.10_Linux26g4_64_lib.tar.gz -C iup/ + tar -xzvf iup-3.17_Linux26g4_64_lib.tar.gz -C iup/ + mkdir -p $(PREFIX)/include/ $(PREFIX)/lib/ + cp iup/include/* $(PREFIX)/include/ + cp iup/*.so $(PREFIX)/lib/ + cp iup/*.a $(PREFIX)/lib/ + +# cd iup && if [ -e makeall.sh ];then fossil update $(IUPBRANCH); else fossil open ../iuplib.fossil;fossil update $(IUPBRANCH); fi + +#iup/alldone : iup/makeall.sh $(PREFIX)/include/iup.h $(PREFIX)/lib/libiup.so +# cd iup && ./makeall.sh $(IUPCONFIG) + +$(PREFIX)/lib/libiup.so $(PREFIX)/include/iup.h : iup/installall.sh +# cd iup && ./makeall.sh $(IUPCONFIG) + +# $(PREFIX)/lib/libiup.so : iup/iup/alldone +# touch -c $(PREFIX)/lib/libiup.so + +$(CHICKEN_EGG_DIR)/iup.so : $(PREFIX)/lib/libiup.so $(PREFIX)/lib/libavcall.a + LD_LIBRARY_PATH=$(LD_LIBRARY_PATH) CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks -feature disable-iup-web iup + +# -feature disable-iup-web + +$(CHICKEN_EGG_DIR)/canvas-draw.so : $(PREFIX)/lib/libiup.so $(PREFIX)/lib/libavcall.a + CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks canvas-draw + + +clean : + rm -rf chicken-4.8.0 eggflags ffcall sqlite-autoconf-$(SQLITE3_VERSION) Index: utils/Makefile.installall ================================================================== --- utils/Makefile.installall +++ utils/Makefile.installall @@ -44,11 +44,12 @@ PROXY= # http://code.call-cc.org/dev-snapshots/2015/06/07/chicken-4.10.0rc1.tar.gz # http://code.call-cc.org/releases/4.10.0/chicken-4.10.0.tar.gz # Select version of chicken, sqlite3 etc -CHICKEN_VERSION=4.10.0 +# CHICKEN_VERSION=4.10.0 +CHICKEN_VERSION=4.11.0rc2 SQLITE3_VERSION=3090200 # http://www.sqlite.org/2014/sqlite-autoconf-3080500.tar.gz # http://www.sqlite.org/2015/sqlite-autoconf-3081101.tar.gz # Override IUPBRANCH to use other than trunk IUPBRANCH=trunk @@ -59,11 +60,11 @@ EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \ dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \ json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \ spiffy-directory-listing ssax sxml-serializer sxml-modifications sql-de-lite \ srfi-19 refdb ini-file sparse-vectors z3 call-with-environment-variables hahn linenoise \ - crypt + crypt parley # # Derived variables # @@ -77,11 +78,11 @@ BUILDHOME=$(PWD) PATH:=$(PREFIX)/bin:$(PATH) LIBPATH=$(PREFIX)/lib$(ADDITIONAL_LIBPATH) LD_LIBRARY_PATH=$(LIBPATH) CHICKEN_INSTALL=$(PREFIX)/bin/chicken-install -CHICKEN_EGG_DIR=$(PREFIX)/lib/chicken/7 +CHICKEN_EGG_DIR=$(PREFIX)/lib/chicken/8 VPATH=$(CHICKEN_EGG_DIR):$(PWD)/eggflags vpath %.so $(CHICKEN_EGG_DIR) vpath %.flag eggflags @@ -101,21 +102,22 @@ CSC_OPTIONS="-I$(PREFIX)/include -L$(CSCLIBS) -C \"-fPIC\"" # CSC_OPTIONS=-I $(PREFIX)/include -L $(CSCLIBS) nogui : base mutils -all : nogui libiup $(PREFIX)/lib/sqlite3.so +#all : nogui libiup $(PREFIX)/lib/sqlite3.so +all : nogui libiup base : chkn eggs # stuff needed for Kiatoa and Megatest from matts miscellaneous stash # NOTE TO SELF: eggifying these would be great... mutils : base logprobin $(PREFIX)/bin/hs \ - $(PREFIX)/lib/chicken/7/mutils.so \ - $(PREFIX)/lib/chicken/7/dbi.so \ - $(PREFIX)/lib/chicken/7/stml.so \ - $(PREFIX)/lib/chicken/7/margs.so + $(PREFIX)/lib/chicken/8/mutils.so \ + $(PREFIX)/lib/chicken/8/dbi.so \ + $(PREFIX)/lib/chicken/8/stml.so \ + $(PREFIX)/lib/chicken/8/margs.so chkn : $(CHICKEN_INSTALL) eggs : $(EGGSOFILES) @@ -145,14 +147,15 @@ $(PREFIX)/setup-chicken4x.csh : $(EGGFLAGS) mkdir -p $(PREFIX) (echo "setenv PATH $(PREFIX):'$$'PATH" > $(PREFIX)/setup-chicken4x.csh) (echo "setenv LD_LIBRARY_PATH $(LD_LIBRARY_PATH)" >> $(PREFIX)/setup-chicken4x.csh) +# NOTE: the touch chicken-core/chicken.scm compensates for the time stamp from the tar file chicken-core/chicken.scm : chicken-$(CHICKEN_VERSION).tar.gz tar xf chicken-$(CHICKEN_VERSION).tar.gz ln -sf chicken-$(CHICKEN_VERSION) chicken-core - + if [[ -e chicken-core/chicken.scm ]];then touch chicken-core/chicken.scm;fi chicken-4.9.0rc1.tar.gz : wget http://code.call-cc.org/dev-snapshots/2014/04/17/chicken-4.9.0rc1.tar.gz chicken-4.9.0.1.tar.gz : @@ -162,10 +165,13 @@ wget http://code.call-cc.org/dev-snapshots/2015/06/07/chicken-4.10.0rc1.tar.gz chicken-4.10.0.tar.gz : wget http://code.call-cc.org/releases/4.10.0/chicken-4.10.0.tar.gz +chicken-4.11.0rc2.tar.gz : + wget http://code.call-cc.org/dev-snapshots/2016/04/28/chicken-4.11.0rc2.tar.gz + # git clone git://code.call-cc.org/chicken-core # git clone http://code.call-cc.org/git/chicken-core.git $(CHICKEN_INSTALL) : chicken-core/chicken.scm $(PREFIX)/setup-chicken4x.sh $(PREFIX)/setup-chicken4x.csh cd chicken-core;make PLATFORM=linux PREFIX=$(PREFIX) @@ -219,17 +225,17 @@ opensrc/histstore/histstore.scm : opensrc.fossil mkdir -p opensrc cd opensrc;if [ -e .fslckout ];then fossil update; else fossil open ../opensrc.fossil; fi -$(PREFIX)/lib/chicken/7/mutils.so : opensrc/histstore/histstore.scm +$(PREFIX)/lib/chicken/8/mutils.so : opensrc/histstore/histstore.scm cd opensrc/mutils;chicken-install -$(PREFIX)/lib/chicken/7/dbi.so : opensrc/dbi/dbi.scm +$(PREFIX)/lib/chicken/8/dbi.so : opensrc/dbi/dbi.scm cd opensrc/dbi;chicken-install -$(PREFIX)/lib/chicken/7/margs.so : opensrc/margs/margs.scm +$(PREFIX)/lib/chicken/8/margs.so : opensrc/margs/margs.scm cd opensrc/margs;chicken-install opensrc/histstore/hs : opensrc/histstore/histstore.scm chkn eggs $(CHICKEN_EGG_DIR)/sqlite3.so cd opensrc/histstore;$(PREFIX)/bin/csc histstore.scm -o hs @@ -247,11 +253,11 @@ stml/requirements.scm : stml/requirements.scm.template cp stml/install.cfg.template stml/install.cfg cp stml/requirements.scm.template stml/requirements.scm -$(PREFIX)/lib/chicken/7/stml.so : stml/requirements.scm +$(PREFIX)/lib/chicken/8/stml.so : stml/requirements.scm cd stml;make #====================================================================== # F F C A L L (Used by IUP) #====================================================================== @@ -271,31 +277,44 @@ #====================================================================== # I U P #====================================================================== iuplib.fossil : - fossil clone http://www.kiatoa.com/fossils/iuplib iuplib.fossil - -iup/installall.sh : iuplib.fossil + #fossil clone http://www.kiatoa.com/fossils/iuplib iuplib.fossil + touch iuplib.fossil +iup/installall.sh : iuplib.fossil $(PREFIX)/lib/libiup.so mkdir -p iup - cd iup && if [ -e makeall.sh ];then fossil update $(IUPBRANCH); else fossil open ../iuplib.fossil;fossil update $(IUPBRANCH); fi + pwd + #wget -c http://sourceforge.net/projects/canvasdraw/files/5.9/Linux%20Libraries/cd-5.9_Linux26g4_64_lib.tar.gz/download + #wget -c http://sourceforge.net/projects/iup/files/3.17/Linux%20Libraries/iup-3.17_Linux26g4_64_lib.tar.gz/download + #wget -c http://sourceforge.net/projects/imtoolkit/files/3.10/Linux%20Libraries/im-3.10_Linux26g4_64_lib.tar.gz/download + #wget -c http://sourceforge.net/projects/luabinaries/files/5.3.2/Linux%20Libraries/lua-5.3.2_Linux26g4_64_lib.tar.gz/download + tar -xzvf cd-5.9_Linux26g4_64_lib.tar.gz -C iup/ + tar -xzvf im-3.10_Linux26g4_64_lib.tar.gz -C iup/ + tar -xzvf iup-3.17_Linux26g4_64_lib.tar.gz -C iup/ + mkdir -p $(PREFIX)/include/ $(PREFIX)/lib/ + cp iup/include/* $(PREFIX)/include/ + cp iup/*.so $(PREFIX)/lib/ + cp iup/*.a $(PREFIX)/lib/ + +# cd iup && if [ -e makeall.sh ];then fossil update $(IUPBRANCH); else fossil open ../iuplib.fossil;fossil update $(IUPBRANCH); fi iup/alldone : iup/makeall.sh $(PREFIX)/include/iup.h $(PREFIX)/lib/libiup.so - cd iup && ./makeall.sh $(IUPCONFIG) +# cd iup && ./makeall.sh $(IUPCONFIG) $(PREFIX)/lib/libiup.so $(PREFIX)/include/iup.h : iup/installall.sh iup/alldone - cd iup && ./makeall.sh $(IUPCONFIG) +# cd iup && ./makeall.sh $(IUPCONFIG) # $(PREFIX)/lib/libiup.so : iup/iup/alldone # touch -c $(PREFIX)/lib/libiup.so $(CHICKEN_EGG_DIR)/iup.so : $(PREFIX)/lib/libiup.so $(PREFIX)/lib/libavcall.a - LD_LIBRARY_PATH=$(LD_LIBRARY_PATH) CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks iup + LD_LIBRARY_PATH=$(LD_LIBRARY_PATH) CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks -feature disable-iup-web iup # -feature disable-iup-web $(CHICKEN_EGG_DIR)/canvas-draw.so : $(PREFIX)/lib/libiup.so $(PREFIX)/lib/libavcall.a CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks canvas-draw clean : rm -rf chicken-4.8.0 eggflags ffcall sqlite-autoconf-$(SQLITE3_VERSION) ADDED utils/Makefile.latest.installall Index: utils/Makefile.latest.installall ================================================================== --- /dev/null +++ utils/Makefile.latest.installall @@ -0,0 +1,320 @@ + +# Copyright 2013-2015 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. + +help : + @echo You may need to do the following setup first: + @echo + @echo sudo apt-get install libreadline-dev + @echo sudo apt-get install libwebkitgtk-dev libfreetype6-dev libx11-dev libxpm-dev libxmu-dev \ + libxft-dev libgtk2.0-dev libgl1-mesa-dev libglu1-mesa-dev libpangox-1.0-dev bison \ + libwebkitgtk-3.0-dev + @echo -- nb// adding monodevelop gets more packages of which some might be needed... + @echo sudo apt-get install libmotif3 + @echo + @echo Set up your PATH, setting it in the Makefile does not work as expected + @echo export PATH=$(PREFIX)/bin:\$$PATH + @echo + @echo For IUP set IUPBRANCH, currently $(IUPBRANCH) + @echo set IUPCONFIG, currently $(IUPCONFIG) - look in https://www.kiatoa.com/fossils/iuplib for .inc files + @echo You are using PREFIX=$(PREFIX) + @echo You are using PROXY="$(PROXY)" + @echo If needed set PROXY to host.dom:port + @echo http_proxy=$(http_proxy) + @echo + @echo To make all do: make all + @echo make minimal: make nogui + @echo + @echo Note: If compiling on amd64 do CSC_OPTIONS=\'-C "-fPIC"\' make all IUPCONFIG= + +FPIC=-C "-fPIC" + +# Put the installation here +ifeq ($(PREFIX),) +PREFIX=$(PWD)/target +endif + +# Set this on the command line of your make call if needed: make PROXY=host.com:1234 +PROXY= + +# http://code.call-cc.org/dev-snapshots/2015/06/07/chicken-4.10.0rc1.tar.gz +# http://code.call-cc.org/releases/4.10.0/chicken-4.10.0.tar.gz +# Select version of chicken, sqlite3 etc +CHICKEN_VERSION=4.10.1 +SQLITE3_VERSION=3090200 +# http://www.sqlite.org/2014/sqlite-autoconf-3080500.tar.gz +# http://www.sqlite.org/2015/sqlite-autoconf-3081101.tar.gz +# Override IUPBRANCH to use other than trunk +IUPBRANCH=trunk +IUPCONFIG=ubuntu-15.04.inc +# iup-3.15 + +# Eggs to install (straightforward ones) +EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \ + dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \ + json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \ + spiffy-directory-listing ssax sxml-serializer sxml-modifications sql-de-lite \ + srfi-19 refdb ini-file sparse-vectors z3 call-with-environment-variables hahn linenoise \ + crypt parley zlib shell udp loops foof-loop lazy-seq ansi-escape-sequences rfc3339 slice \ + slice-utf8 scsh-process functional-lists srfi-101 uuid-lib filepath srfi-78 srfi-42 sexp-diff \ + low-level-macros symbol-utils expand-full chicken-doc irc silex lalr lalr-driver sha1 refdb + +# +# Derived variables +# + +ifeq ($(PROXY),) +PROX:= +else +http_proxy:=http://$(PROXY) +PROX:=-proxy $(PROXY) +endif + +BUILDHOME=$(PWD) +PATH:=$(PREFIX)/bin:$(PATH) +LIBPATH=$(PREFIX)/lib$(ADDITIONAL_LIBPATH) +LD_LIBRARY_PATH=$(LIBPATH) +CHICKEN_INSTALL=$(PREFIX)/bin/chicken-install +CHICKEN_EGG_DIR=$(PREFIX)/lib/chicken/7 + +VPATH=$(CHICKEN_EGG_DIR):$(PWD)/eggflags + +vpath %.so $(CHICKEN_EGG_DIR) +vpath %.flag eggflags + +EGGSOFILES=$(addprefix $(CHICKEN_EGG_DIR)/,$(addsuffix .so,$(EGGS))) +EGGFLAGS=$(addprefix eggflags/,$(addsuffix .flag,$(EGGS))) + +# Stuff needed for IUP +ISARCHX86_64=$(shell uname -a | grep x86_64) +ifeq ($(ISARCHX86_64),) +ARCHSIZE= +else +ARCHSIZE=64_ +endif + +CSCLIBS=$(shell echo $(LD_LIBRARY_PATH) | sed 's/:/ -L/g') +CSC_OPTIONS="-I$(PREFIX)/include -L$(CSCLIBS) -C \"-fPIC\"" +# CSC_OPTIONS=-I $(PREFIX)/include -L $(CSCLIBS) + +nogui : base mutils + +#all : nogui libiup $(PREFIX)/lib/sqlite3.so +all : nogui libiup + +base : chkn eggs + +# stuff needed for Kiatoa and Megatest from matts miscellaneous stash +# NOTE TO SELF: eggifying these would be great... +mutils : base logprobin $(PREFIX)/bin/hs \ + $(PREFIX)/lib/chicken/7/mutils.so \ + $(PREFIX)/lib/chicken/7/dbi.so \ + $(PREFIX)/lib/chicken/7/stml.so \ + $(PREFIX)/lib/chicken/7/margs.so + +chkn : $(CHICKEN_INSTALL) + +eggs : $(EGGSOFILES) + +# libiup : $(PREFIX)/lib/libavcall.a +libiup : $(CHICKEN_EGG_DIR)/iup.so $(CHICKEN_EGG_DIR)/canvas-draw.so + +logprobin : $(PREFIX)/bin/logpro + +$(PREFIX)/bin/logpro : $(CHICKEN_EGG_DIR)/regex-literals.so + $(CHICKEN_INSTALL) logpro + +# Silly rule to make installing eggs more makeish, I don't understand why I need the basename +$(CHICKEN_EGG_DIR)/%.so : eggflags/%.flag + $(CHICKEN_INSTALL) $(PROX) -keep-installed $(shell basename $*) + +$(EGGFLAGS) : # $(CHICKEN_INSTALL) + mkdir -p eggflags + touch $(EGGFLAGS) + +# some setup stuff +# +$(PREFIX)/setup-chicken4x.sh : $(EGGFLAGS) + mkdir -p $(PREFIX) + (echo 'export PATH=$(PREFIX)/bin:$$PATH' > $(PREFIX)/setup-chicken4x.sh) + (echo "export LD_LIBRARY_PATH=$(LD_LIBRARY_PATH)" >> $(PREFIX)/setup-chicken4x.sh) + +$(PREFIX)/setup-chicken4x.csh : $(EGGFLAGS) + mkdir -p $(PREFIX) + (echo "setenv PATH $(PREFIX):'$$'PATH" > $(PREFIX)/setup-chicken4x.csh) + (echo "setenv LD_LIBRARY_PATH $(LD_LIBRARY_PATH)" >> $(PREFIX)/setup-chicken4x.csh) + +chicken-core/chicken.scm : chicken-$(CHICKEN_VERSION).tar.gz + tar xf chicken-$(CHICKEN_VERSION).tar.gz + ln -sf chicken-$(CHICKEN_VERSION) chicken-core + + +chicken-4.9.0rc1.tar.gz : + wget http://code.call-cc.org/dev-snapshots/2014/04/17/chicken-4.9.0rc1.tar.gz + +chicken-4.9.0.1.tar.gz : + wget http://code.call-cc.org/releases/4.9.0/chicken-4.9.0.1.tar.gz + +chicken-4.10.0rc1.tar.gz : + wget http://code.call-cc.org/dev-snapshots/2015/06/07/chicken-4.10.0rc1.tar.gz + +chicken-4.10.0.tar.gz : + wget http://code.call-cc.org/releases/4.10.0/chicken-4.10.0.tar.gz + +chicken-4.10.1.tar.gz : + wget http://code.call-cc.org/dev-snapshots/2015/08/29/chicken-4.10.1.tar.gz + +# git clone git://code.call-cc.org/chicken-core +# git clone http://code.call-cc.org/git/chicken-core.git + +$(CHICKEN_INSTALL) : chicken-core/chicken.scm $(PREFIX)/setup-chicken4x.sh $(PREFIX)/setup-chicken4x.csh + cd chicken-core;make PLATFORM=linux PREFIX=$(PREFIX) + cd chicken-core;make PLATFORM=linux PREFIX=$(PREFIX) install + +#====================================================================== +# S Q L I T E 3 +#====================================================================== +# https://www.sqlite.org/2015/sqlite-autoconf-3090200.tar.gz +sqlite-autoconf-$(SQLITE3_VERSION).tar.gz : + wget http://www.sqlite.org/2015/sqlite-autoconf-$(SQLITE3_VERSION).tar.gz + +sqlite-autoconf-$(SQLITE3_VERSION)/config.log : sqlite-autoconf-$(SQLITE3_VERSION).tar.gz + tar xf sqlite-autoconf-$(SQLITE3_VERSION).tar.gz + +$(PREFIX)/bin/sqlite3 : sqlite-autoconf-$(SQLITE3_VERSION)/config.log + cd sqlite-autoconf-$(SQLITE3_VERSION);./configure --prefix=$(PREFIX);make;make install + +$(CHICKEN_EGG_DIR)/sqlite3.so : $(PREFIX)/bin/sqlite3 + CSC_OPTIONS="-I$(PREFIX)/include -L$(PREFIX)/lib" $(CHICKEN_INSTALL) $(PROX) sqlite3 + +#====================================================================== +# N A N O M S G +#====================================================================== + +# https://github.com/nanomsg/nanomsg/releases/download/0.6-beta/nanomsg-0.6-beta.tar.gz +# https://github.com/nanomsg/nanomsg/releases/download/0.8-beta/nanomsg-0.8-beta.tar.gz + +nanomsg-0.6-beta.tar.gz : + wget http://download.nanomsg.org/nanomsg-0.6-beta.tar.gz + +nanomsg-0.6-beta/COPYING : nanomsg-0.6-beta.tar.gz + tar xf nanomsg-0.6-beta.tar.gz + +$(PREFIX)/bin/nanocat : nanomsg-0.6-beta/COPYING + cd nanomsg-0.6-beta;./configure --prefix=$(PREFIX);make;make install + +$(PREFIX)/lib/nanomsg.so : $(PREFIX)/bin/nanocat + CSC_OPTIONS="-I$(PREFIX)/include -L$(PREFIX)/lib" $(CHICKEN_INSTALL) $(PROX) nanomsg + +# LD_LIBRARY_PATH=/mfs/pkgs/chicken/4.10.0-amd64/lib CSC_OPTIONS="-I/mfs/pkgs/chicken/4.10.0-amd64/include -L/mfs/pkgs/chicken/4.10.0-amd64/lib -C \"-fPIC\"" /mfs/pkgs/chicken/4.10.0-amd64/bin/chicken-install -D no-library-checks nanomsg + +#====================================================================== +# M A T T S U T I L S +#====================================================================== + +# opensrc + +opensrc.fossil : + fossil clone http://www.kiatoa.com/fossils/opensrc opensrc.fossil + +opensrc/histstore/histstore.scm : opensrc.fossil + mkdir -p opensrc + cd opensrc;if [ -e .fslckout ];then fossil update; else fossil open ../opensrc.fossil; fi + +$(PREFIX)/lib/chicken/7/mutils.so : opensrc/histstore/histstore.scm + cd opensrc/mutils;chicken-install + +$(PREFIX)/lib/chicken/7/dbi.so : opensrc/dbi/dbi.scm + cd opensrc/dbi;chicken-install + +$(PREFIX)/lib/chicken/7/margs.so : opensrc/margs/margs.scm + cd opensrc/margs;chicken-install + +opensrc/histstore/hs : opensrc/histstore/histstore.scm chkn eggs $(CHICKEN_EGG_DIR)/sqlite3.so + cd opensrc/histstore;$(PREFIX)/bin/csc histstore.scm -o hs + +$(PREFIX)/bin/hs : opensrc/histstore/hs + cp -f opensrc/histstore/hs $(PREFIX)/bin/hs + +# stml +stml.fossil : + fossil clone http://www.kiatoa.com/fossils/stml stml.fossil + +# open touches the .fossil :( +stml/requirements.scm.template : stml.fossil + mkdir -p stml + cd stml;if [ -e .fslckout ];then fossil update; else fossil open ../stml.fossil;fi + +stml/requirements.scm : stml/requirements.scm.template + cp stml/install.cfg.template stml/install.cfg + cp stml/requirements.scm.template stml/requirements.scm + +$(PREFIX)/lib/chicken/7/stml.so : stml/requirements.scm + cd stml;make + +#====================================================================== +# F F C A L L (Used by IUP) +#====================================================================== + +ffcall.fossil : + fossil clone http://www.kiatoa.com/fossils/ffcall ffcall.fossil + +ffcall/README : ffcall.fossil + mkdir -p ffcall + cd ffcall && if [ -e README ];then fossil update; else fossil open ../ffcall.fossil; fi + +# NOTE: This worked fine *without* the enable-shared +# +$(PREFIX)/lib/libavcall.a : ffcall/README + cd ffcall;./configure --prefix=$(PREFIX) --enable-shared && make CC="gcc -fPIC" && make install + +#====================================================================== +# I U P +#====================================================================== + +iuplib.fossil : + #fossil clone http://www.kiatoa.com/fossils/iuplib iuplib.fossil + touch iuplib.fossil +iup/installall.sh : iuplib.fossil $(PREFIX)/lib/libiup.so + mkdir -p iup + pwd + #wget -c http://sourceforge.net/projects/canvasdraw/files/5.9/Linux%20Libraries/cd-5.9_Linux26g4_64_lib.tar.gz/download + #wget -c http://sourceforge.net/projects/iup/files/3.17/Linux%20Libraries/iup-3.17_Linux26g4_64_lib.tar.gz/download + #wget -c http://sourceforge.net/projects/imtoolkit/files/3.10/Linux%20Libraries/im-3.10_Linux26g4_64_lib.tar.gz/download + #wget -c http://sourceforge.net/projects/luabinaries/files/5.3.2/Linux%20Libraries/lua-5.3.2_Linux26g4_64_lib.tar.gz/download + tar -xzvf cd-5.9_Linux26g4_64_lib.tar.gz -C iup/ + tar -xzvf im-3.10_Linux26g4_64_lib.tar.gz -C iup/ + tar -xzvf iup-3.17_Linux26g4_64_lib.tar.gz -C iup/ + mkdir -p $(PREFIX)/include/ $(PREFIX)/lib/ + cp iup/include/* $(PREFIX)/include/ + cp iup/*.so $(PREFIX)/lib/ + cp iup/*.a $(PREFIX)/lib/ + +# cd iup && if [ -e makeall.sh ];then fossil update $(IUPBRANCH); else fossil open ../iuplib.fossil;fossil update $(IUPBRANCH); fi + +#iup/alldone : iup/makeall.sh $(PREFIX)/include/iup.h $(PREFIX)/lib/libiup.so +# cd iup && ./makeall.sh $(IUPCONFIG) + +$(PREFIX)/lib/libiup.so $(PREFIX)/include/iup.h : iup/installall.sh +# cd iup && ./makeall.sh $(IUPCONFIG) + +# $(PREFIX)/lib/libiup.so : iup/iup/alldone +# touch -c $(PREFIX)/lib/libiup.so + +$(CHICKEN_EGG_DIR)/iup.so : $(PREFIX)/lib/libiup.so $(PREFIX)/lib/libavcall.a + LD_LIBRARY_PATH=$(LD_LIBRARY_PATH) CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks -feature disable-iup-web iup + +# -feature disable-iup-web + +$(CHICKEN_EGG_DIR)/canvas-draw.so : $(PREFIX)/lib/libiup.so $(PREFIX)/lib/libavcall.a + CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks canvas-draw + + +clean : + rm -rf chicken-4.8.0 eggflags ffcall sqlite-autoconf-$(SQLITE3_VERSION)