Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -489,11 +489,13 @@ "runname") #f)) (tdb (tdb:open-test-db-by-test-id-local dbstruct run-id test-id)) ;; These next two are intentional bad values to ensure errors if they should not ;; get filled in properly. (logfile "/this/dir/better/not/exist") - (rundir logfile) + (rundir (if testdat + (db:test-get-rundir testdat) + logfile)) (testdat-path (conc rundir "/testdat.db")) ;; this gets recalculated until found (teststeps (if testdat (dashboard-tests:get-compressed-steps dbstruct run-id test-id) '())) (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ...")) (testname (if testdat (db:test-get-testname testdat) "n/a")) (testmeta (if testdat Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -1041,12 +1041,20 @@ (begin (dboard:data-set-curr-run-id! *data* run-id) (dashboard:update-run-summary-tab))) ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) )))) + (cell-lookup (make-hash-table)) (run-matrix (iup:matrix - #:expand "YES")) + #: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 " test-id "&"))) + (system cmd))))) (updater (lambda () (let* ((runs-dat (db:get-runs-by-patt db *keys* "%" #f #f #f)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (run-id (dboard:data-get-curr-run-id *data*)) (tests-dat (let ((tdat (db:get-tests-for-run db run-id @@ -1110,12 +1118,13 @@ userdata: (conc "run-id: " run-id)) (hash-table-set! (dboard:data-get-path-run-ids *data*) run-path run-id) ;; (set! colnum (+ colnum 1)) )))) run-ids) - (iup:attribute-set! run-matrix "CLEARVALUE" "CONTENTS") + (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS") + (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES") (iup:attribute-set! run-matrix "NUMCOL" max-col ) (iup:attribute-set! run-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)) ;; min of 20 ;; (iup:attribute-set! run-matrix "NUMCOL_VISIBLE" max-col) ;; (iup:attribute-set! run-matrix "NUMLIN_VISIBLE" (if (> max-row max-visible) max-visible max-row)) @@ -1128,22 +1137,10 @@ (begin (set! changed #t) (iup:attribute-set! run-matrix key name))))) row-indices) - ;; Col labels - (for-each (lambda (ind) - (let* ((name (car ind)) - (num (cadr ind)) - (key (conc "0:" num))) - (if (not (equal? (iup:attribute run-matrix key) name)) - (begin - (set! changed #t) - (iup:attribute-set! run-matrix key name) - (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num)))))) - col-indices) - ;; Cell contents (for-each (lambda (entry) (let* ((row-name (cadr entry)) (col-name (car entry)) (valuedat (caddr entry)) @@ -1154,17 +1151,32 @@ (status (list-ref valuedat 2)) (value (gutils:get-color-for-state-status state status)) (row-num (cadr (assoc row-name row-indices))) (col-num (cadr (assoc col-name col-indices))) (key (conc row-num ":" col-num))) + (hash-table-set! cell-lookup key test-id) (if (not (equal? (iup:attribute run-matrix key) (cadr value))) (begin (set! changed #t) (iup:attribute-set! run-matrix key (cadr value)) (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value)))))) tests-mindat) + + ;; Col labels - do after setting Cell contents so they are accounted for in the size calc. + + (for-each (lambda (ind) + (let* ((name (car ind)) + (num (cadr ind)) + (key (conc "0:" num))) + (if (not (equal? (iup:attribute run-matrix key) name)) + (begin + (set! changed #t) + (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) (dboard:data-set-runs-tree! *data* tb) (iup:split tb run-matrix))) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -1207,13 +1207,14 @@ (set! runflag #t)) (else (set! runflag #f))) (debug:print 4 "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat)) (if (not runflag) (if (not parent-test) - (debug:print 1 "NOTE: Not starting test " full-test-name " as it is state \"" (test:get-state testdat) - "\" and status \"" (test:get-status testdat) "\", use -rerun \"" (test:get-status testdat) - "\" or -force to override")) + (if (runs:lownoise (conc "not starting test" full-test-name) 60) + (debug:print 1 "NOTE: Not starting test " full-test-name " as it is state \"" (test:get-state testdat) + "\" and status \"" (test:get-status testdat) "\", use -rerun \"" (test:get-status testdat) + "\" or -force to override"))) ;; NOTE: No longer be checking prerequisites here! Will never get here unless prereqs are ;; already met. ;; This would be a great place to do the process-fork ;; (let ((skip-test #f) @@ -1270,11 +1271,15 @@ (take dparts (- (length dparts) count)) "/")))) (define (runs:recursive-delete-with-error-msg real-dir) (if (> (system (conc "rm -rf " real-dir)) 0) - (debug:print 0 "ERROR: There was a problem removing " real-dir " with rm -f"))) + (begin + ;; FAILED, possibly due to permissions, do chmod a+rwx then try one more time + (system (conc "chmod -R a+rwx " real-dir)) + (if (> (system (conc "rm -rf " real-dir)) 0) + (debug:print 0 "ERROR: There was a problem removing " real-dir " with rm -f"))))) (define (runs:safe-delete-test-dir real-dir) ;; first delete all sub-directories (directory-fold (lambda (f x) Index: tests/Makefile ================================================================== --- tests/Makefile +++ tests/Makefile @@ -21,19 +21,19 @@ TARGET = "ubuntu/nfs/none" all : test1 test2 test3 test4 test5 test6 test7 test8 test9 server : - cd ..;make;make install + cd ..;make -j;make install cd fullrun;$(MEGATEST) -server - -debug $(DEBUG) -run-id $(RUNID) stopserver : - cd ..;make && make install + cd ..;make -j && make install cd fullrun;$(MEGATEST) -stop-server 0 repl : - cd ..;make && make install + cd ..;make -j && make install cd fullrun;$(MEGATEST) -repl test0 : cleanprep cd simplerun ; $(MEGATEST) -server - -debug $(DEBUG) @@ -143,20 +143,20 @@ test11 : cd fullrun;time (for a in 1 2 3 4 5 6 7 8 9 10 1 2 3 4 5 6 7 8 9 10 1 2 3 4 5 6 7 8 9 10 1 2 3 4 5 6 7 8 9 10 ;do (megatest -test-paths -target %/%/% > /dev/null ) & done; wait; ) minsetup : - cd ..;make && make install + cd ..;make -j && make install mkdir -p mintest/runs mintest/links cd mintest;$(MEGATEST) -stop-server 0 cd mintest;$(MEGATEST) -server - -debug $(DEBUG) > server.log 2> server.log & sleep 3 cd mintest;$(DASHBOARD) -rows 18 & cleanprep : ../*.scm Makefile */*.config mkdir -p fullrun/tmp/mt_runs fullrun/tmp/mt_links - cd ..;make;make install + cd ..;make -j;make install rm -f */logging.db touch cleanprep fullprep : cleanprep cd fullrun;$(MEGATEST) -remove-runs :runname $(RUNNAME)% -target %/%/% -testpatt %/% Index: txtdb/txtdb.scm ================================================================== --- txtdb/txtdb.scm +++ txtdb/txtdb.scm @@ -15,10 +15,11 @@ (use srfi-69) (use regex-case) (use posix) (use json) (use csv) +(use srfi-18) (include "../megatest-fossil-hash.scm") ;; Read a non-compressed gnumeric file (define (refdb:read-gnumeric-xml fname) @@ -112,21 +113,23 @@ (let ((ref-colnums (map (lambda (c) (list (cdr c)(car c))) (hash-table->alist colnums)))) (with-output-to-file (conc targdir "/" sheet-name ".dat") (lambda () - (print "[" col0title "]") + (if (not (string-null? col0title))(print "[" col0title "]")) (for-each (lambda (colname) (print "[" colname "]") (for-each (lambda (row) (let ((key (car row)) (val (cadr row))) (if (string-search comment-rx key) (print val) (if (string-search blank-rx key) (print) - (print key " " val))))) + (if (string-search " " key) + (print "\"" key "\" " val) + (print key " " val)))))) (reverse (hash-table-ref cols colname))) ;; (print) ) (sort (hash-table-keys cols)(lambda (a b) (let ((colnum-a (assoc a ref-colnums)) @@ -216,10 +219,11 @@ (hash-table-fold ht (lambda (k v res)(if (equal? v val) k res)) #f)) (define (read-dat fname) (let ((section-rx (regexp "^\\[(.*)\\]\\s*$")) (comment-rx (regexp "^#.*")) ;; This means a cell name cannot start with # + (quoted-cell-rx (regexp "^\"([^\"]*)\" (.*)$")) (cell-rx (regexp "^(\\S+) (.*)$")) ;; One space only for the cellname content separator (blank-rx (regexp "^\\s*$")) (continue-rx (regexp ".*\\\\$")) (var-no-val-rx (regexp "^(\\S+)\\s*$")) (inp (open-input-file fname)) @@ -251,10 +255,13 @@ (if (not first-section) (set! first-section sname)) (loop (read-line inp) sname res))) + (quoted-cell-rx (x k v)(loop (read-line inp) + section + (cons (list k section v) res))) (cell-rx (x k v) (loop (read-line inp) section (cons (list k section v) res))) (var-no-val-rx (x k) (loop (read-line inp) section @@ -263,10 +270,11 @@ (print "ERROR: Unrecognised line in input file " fname ", ignoring it") (loop (read-line inp) section res)))))))) (define (get-value-type val expressions) (cond + ((not val) '(ValueType "60")) ((string->number val) '(ValueType "40")) ((equal? val "") '(ValueType "60")) ((equal? (substring val 0 1) "=") (let ((exid (hash-table-ref/default expressions val #f))) (if exid @@ -454,13 +462,29 @@ (exit))) (let* ((dbname (pathname-strip-directory path)) (tmpf (conc (create-temporary-file dbname) ".gnumeric"))) (if (file-exists? (conc path "/sheet-names.cfg")) (refdb-export path tmpf)) - (let ((pid (process-run "gnumeric" (list tmpf)))) - (process-wait pid) - (import-gnumeric-file tmpf path)))) + (let* ((pid (process-run "gnumeric" (list tmpf)))) + (let loop ((last-mod-time (current-seconds))) + (let-values (((pid-code exit-status exit-signal)(process-wait pid #t))) + (if (eq? pid-code 0) ;; still going + (if (file-exists? tmpf) + (let ((mod-time (file-modification-time tmpf))) + (if (> mod-time last-mod-time) + (begin + (print "saved data to " path) + (import-gnumeric-file tmpf path))) + (thread-sleep! 0.5) + (loop mod-time)) + (begin + (thread-sleep! 0.5) + (loop last-mod-time)))))) + ;; all done + (print "all done, writing new data to " path) + (import-gnumeric-file tmpf path) + (print "data written, exiting refdb edit.")))) ;;====================================================================== ;; This routine dispaches or executes most of the commands for refdb ;;====================================================================== ;; Index: utils/Makefile_latest.installall ================================================================== --- utils/Makefile_latest.installall +++ utils/Makefile_latest.installall @@ -103,12 +103,19 @@ setup-chicken4x.sh : $(EGGFLAGS) (echo "export PATH=$(PATH)" > setup-chicken4x.sh) (echo "export LD_LIBRARY_PATH=$(LD_LIBRARY_PATH)" >> setup-chicken4x.sh) mkdir -p $(PREFIX) -chicken-core/chicken.scm : - git clone http://code.call-cc.org/git/chicken-core.git +chicken-core/chicken.scm : chicken-4.9.0rc1.tar.gz + tar xfz chicken-4.9.0rc1.tar.gz + ln -sf chicken-4.9.0rc1 chicken-core + # git clone http://code.call-cc.org/git/chicken-core.git + + +chicken-4.9.0rc1.tar.gz : + wget http://code.call-cc.org/dev-snapshots/2014/04/17/chicken-4.9.0rc1.tar.gz + # git clone git://code.call-cc.org/chicken-core $(CHICKEN_INSTALL) : chicken-core/chicken.scm setup-chicken4x.sh cd chicken-core;make PLATFORM=linux PREFIX=$(PREFIX) cd chicken-core;make PLATFORM=linux PREFIX=$(PREFIX) install