Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -34,16 +34,13 @@ # BASH_MACHTYPE=$(shell bash -c "echo \$$MACHTYPE") # ARCHSTR=$(BASH_MACHTYPE)_$(shell lsb_release -sr) ARCHSTR=$(shell lsb_release -sr) # ARCHSTR=$(shell bash -c "echo \$$MACHTYPE") -all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard txtdb +all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard -refdb : txtdb/txtdb.scm - csc -I txtdb txtdb/txtdb.scm -o refdb - -mtest: $(OFILES) megatest.o +mtest: $(OFILES) megatest.o readline-fix.scm csc $(CSCOPTS) $(OFILES) megatest.o -o mtest dboard : $(OFILES) $(GOFILES) dashboard.scm csc $(OFILES) dashboard.scm $(GOFILES) -o dboard @@ -87,11 +84,23 @@ $(PREFIX)/bin/newdashboard : $(PREFIX)/bin/.$(ARCHSTR)/ndboard utils/mk_wrapper $(PREFIX) ndboard $(PREFIX)/bin/newdashboard chmod a+x $(PREFIX)/bin/newdashboard -$(HELPERS) : utils/mt_* +# $(HELPERS) : utils/% +# $(INSTALL) $< $@ +# chmod a+x $@ + +$(PREFIX)/bin/mt_laststep : utils/mt_laststep + $(INSTALL) $< $@ + chmod a+x $@ + +$(PREFIX)/bin/mt_runstep : utils/mt_runstep + $(INSTALL) $< $@ + chmod a+x $@ + +$(PREFIX)/bin/mt_ezstep : utils/mt_ezstep $(INSTALL) $< $@ chmod a+x $@ $(PREFIX)/bin/mt_xterm : utils/mt_xterm $(INSTALL) $< $@ @@ -107,13 +116,13 @@ $(PREFIX)/bin/loadrunner : utils/loadrunner $(INSTALL) $< $@ chmod a+x $@ -$(PREFIX)/bin/refdb : refdb - $(INSTALL) $< $@ - chmod a+x $@ +# $(PREFIX)/bin/refdb : refdb +# $(INSTALL) $< $@ +# chmod a+x $@ deploytarg/nbfake : utils/nbfake $(INSTALL) $< $@ chmod a+x $@ @@ -128,11 +137,11 @@ chmod a+x $(PREFIX)/bin/dashboard $(INSTALL) dboard $(PREFIX)/bin/.$(ARCHSTR)/dboard install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \ $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \ - $(PREFIX)/bin/nbfind $(PREFIX)/bin/loadrunner $(PREFIX)/bin/refdb $(PREFIX)/bin/mt_xterm \ + $(PREFIX)/bin/nbfind $(PREFIX)/bin/loadrunner $(PREFIX)/bin/mt_xterm \ $(PREFIX)/bin/newdashboard $(PREFIX)/bin/.$(ARCHSTR) : mkdir -p $(PREFIX)/bin/.$(ARCHSTR) @@ -183,5 +192,12 @@ mkdir -p /tmp/$(USER)/datashare/disk1 /tmp/$(USER)/basepath xterm : sd (export BASEPATH=/tmp/$(USER)/basepath ; export PATH="$(PWD)/datashare-testing:$(PATH)" ; xterm &) +# "(define (toplevel-command . a) #f)" +readline-fix.scm : + 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 Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -20,10 +20,11 @@ '(get-key-val-pairs get-keys test-toplevel-num-items get-test-info-by-id test-get-rundir-from-test-id + get-count-tests-running-for-testname get-count-tests-running get-count-tests-running-in-jobgroup get-previous-test-run-record get-matching-previous-test-run-records test-get-logfile-info @@ -44,10 +45,11 @@ get-all-run-ids get-prev-run-ids get-run-ids-matching-target get-runs-by-patt get-steps-data + get-steps-for-test login testmeta-get-record have-incompletes? synchash-get )) @@ -180,10 +182,11 @@ ;; TESTS ((test-toplevel-num-items) (apply db:test-toplevel-num-items dbstruct params)) ((get-test-info-by-id) (apply db:get-test-info-by-id dbstruct params)) ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id dbstruct params)) + ((get-count-tests-running-for-testname) (apply db:get-count-tests-running-for-testname dbstruct params)) ((get-count-tests-running) (apply db:get-count-tests-running dbstruct params)) ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params)) ;; ((delete-test-step-records) (apply db:delete-test-step-records dbstruct params)) ((get-previous-test-run-record) (apply db:get-previous-test-run-record dbstruct params)) ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params)) @@ -210,10 +213,11 @@ ((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct params)) ((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params)) ;; STEPS ((get-steps-data) (apply db:get-steps-data dbstruct params)) + ((get-steps-for-test) (apply db:get-steps-for-test dbstruct params)) ;; MISC ((have-incompletes?) (apply db:have-incompletes? dbstruct params)) ((login) (apply db:login dbstruct params)) ((general-call) (let ((stmtname (car params)) Index: archive.scm ================================================================== --- archive.scm +++ archive.scm @@ -133,11 +133,11 @@ (run-id (db:test-get-run_id test-dat)) (target (string-intersperse (map cadr (rmt:get-key-val-pairs run-id)) "/")) (toplevel/children (and (db:test-get-is-toplevel test-dat) (> (rmt:test-toplevel-num-items run-id test-name) 0))) - (test-partial-path (conc target "/" run-name "/" (runs:make-full-test-name test-name item-path))) + (test-partial-path (conc target "/" run-name "/" (db:test-make-full-name test-name item-path))) ;; note the trailing slash to get the dir inspite of it being a link (test-path (conc linktree "/" test-partial-path)) (test-physical-path (if (file-exists? test-path) (read-symbolic-link test-path #t) #f)) (partial-path-index (if test-physical-path (substring-index test-partial-path test-physical-path) #f)) (test-base (if (and partial-path-index @@ -217,11 +217,11 @@ (keyvals (rmt:get-key-val-pairs run-id)) (target (string-intersperse (map cadr keyvals) "/")) (toplevel/children (and (db:test-get-is-toplevel test-dat) (> (rmt:test-toplevel-num-items run-id test-name) 0))) - (test-partial-path (conc target "/" run-name "/" (runs:make-full-test-name test-name item-path))) + (test-partial-path (conc target "/" run-name "/" (db:test-make-full-name test-name item-path))) ;; note the trailing slash to get the dir inspite of it being a link (test-path (conc linktree "/" test-partial-path)) ;; if the old path was not deleted then prev-test-physical-path will end up pointing to a real directory (prev-test-physical-path (if (file-exists? test-path) (read-symbolic-link test-path #t) #f)) ADDED batchsim/Makefile Index: batchsim/Makefile ================================================================== --- /dev/null +++ batchsim/Makefile @@ -0,0 +1,8 @@ +RUN=default.scm + +all : batchsim + ./batchsim $(RUN) + +batchsim : batchsim.scm + csc batchsim.scm + ADDED batchsim/batchsim.scm Index: batchsim/batchsim.scm ================================================================== --- /dev/null +++ batchsim/batchsim.scm @@ -0,0 +1,417 @@ +(use ezxdisp srfi-18) + +(define *ezx* (ezx-init 650 650 "Batch simulator")) +(require-library ezxgui) +(define *green* (make-ezx-color 0 1 0)) +(define *black* (make-ezx-color 0 0 0)) +(define *grey* (make-ezx-color 0.1 0.1 0.1)) +(define *blue* (make-ezx-color 0 0 1)) +(define *cyan* (make-ezx-color 0 1 1)) +(define *green* (make-ezx-color 0 1 0)) +(define *purple* (make-ezx-color 1 0 1)) +(define *red* (make-ezx-color 1 0 0)) +(define *white* (make-ezx-color 1 1 1)) +(define *yellow* (make-ezx-color 1 1 0)) + +(define *user-colors-palette* + (list + *green* + *blue* + *cyan* + *purple* + *red* + *yellow* + *black*)) + +(define *dark-green* (get-color "dark-green")) +(define *brown* (get-color "brown")) + +(ezx-select-layer *ezx* 1) +(ezx-wipe-layer *ezx* 1) + +;; (ezx-str-2d *ezx* 30 30 "Hello" *white*) +;; (ezx-fillrect-2d *ezx* 100 100 120 120 *brown*) +(ezx-redraw *ezx*) + +(define *last-draw* (current-milliseconds)) +(define *draw-delta* 40) ;; milliseconds between drawing + +(define (wait-for-next-draw-time) + (let* ((cm (current-milliseconds)) + (delta (- *draw-delta* (- cm *last-draw*)))) + (if (> delta 0) + (thread-sleep! (/ delta 1000))) + (set! *last-draw* (current-milliseconds)))) + +(include "events.scm") + +;; System spec (to be moved into loaded file) +;; +;; x y w gap x-min x-max +(define *cpu-grid* (vector 500 50 15 2 500 600)) +(define (make-cpu:grid)(make-vector 6)) +(define *queues* (make-hash-table)) ;; name -> (list (list user duration num-cpus num-gigs) ... ) +(define *cpus* (make-hash-table)) ;; cpu-name => (vector user job-len num-cpu mem x-loc y-loc) +(define *obj-locations* (make-hash-table)) ;; name -> (x y layer) +(define *queue-spec* + (vector + 80 ;; start-x + 300 ;; start-y + 300 ;; delta-y how far to next queue + 15 ;; height + 400 ;; length + )) +(define *use-log* #f) +(define *job-log-scale* 10) + +;;====================================================================== +;; CPU +;;====================================================================== + +(define-record cpu name num-cores mem job x y) + +;;====================================================================== +;; CPU Pool +;;====================================================================== + +(define-record pool name x y w h gap boxw cpus delta nrows ncols cpunum) + +(define (new-pool name x y nrows ncols gap boxw) + (let* ((delta (+ gap boxw)) + ;; (nrows (quotient h (+ gap delta))) + ;; (ncols (quotient w (+ gap delta))) + (w (+ gap (* nrows delta))) + (h (+ gap (* ncols delta))) + (cpus (make-vector (* nrows ncols) #f)) + (npool (make-pool name x y w h gap boxw cpus delta nrows ncols 0))) + npool)) + +(define (pool:add-cpu pool name num-cores mem) + (let* ((cpu (make-cpu name num-cores mem #f #f #f))) + (vector-set! (pool-cpus pool)(pool-cpunum pool) cpu) + (pool-cpunum-set! pool (+ 1 (pool-cpunum pool))) + cpu)) + +(define (pool:draw ezx pool) + (let ((nrows (pool-nrows pool)) + (ncols (pool-ncols pool)) + (x (pool-x pool)) + (y (pool-y pool)) + (w (pool-w pool)) + (h (pool-h pool)) + (gap (pool-gap pool)) + (boxw (pool-boxw pool)) + (delta (pool-delta pool)) + (cpus (pool-cpus pool))) + (ezx-select-layer ezx 1) + ;(ezx-wipe-layer ezx 1) + ;; draw time at upper right + (ezx-str-2d ezx x y (pool-name pool) *black*) + (ezx-rect-2d ezx x y (+ x w)(+ y h) *black* 1) + (let loop ((row 0) + (col 0) + (cpunum 0)) + (let* ((cpu (vector-ref cpus cpunum)) + (xval (+ x gap (* row delta))) + (yval (+ y gap (* col delta)))) + (if cpu + (begin + (cpu-x-set! cpu xval) + (cpu-y-set! cpu yval)) + (vector-set! cpus cpunum (make-cpu (conc cpunum) 1 1 #f xval yval))) + ;; (print "box at " xval ", " yval) + (ezx-rect-2d ezx xval yval (+ xval boxw) (+ yval boxw) *grey* 1) + (if (< col (- ncols 1)) + (loop row (+ col 1)(+ cpunum 1)) + (if (< row (- nrows 1)) + (loop (+ row 1) 0 (+ cpunum 1)))))) + (ezx-redraw ezx))) + + +;;====================================================================== +;; Users +;;====================================================================== + +(define *user-colors* (make-hash-table)) + +(define (get-user-color user) + (let ((color (hash-table-ref/default *user-colors* user #f))) + (if color + color + (let* ((color-num (+ (length (hash-table-keys *user-colors*)) 1)) + (color (list-ref *user-colors-palette* color-num))) + (hash-table-set! *user-colors* user color) + color)))) + +;;====================================================================== +;; Job Queues +;;====================================================================== + +;; jobs + +(define (make-queue:job)(make-vector 4)) +(define-inline (queue:job-get-user vec) (vector-ref vec 0)) +(define-inline (queue:job-get-duration vec) (vector-ref vec 1)) +(define-inline (queue:job-get-num-cpu vec) (vector-ref vec 2)) +(define-inline (queue:job-get-num-gigs vec) (vector-ref vec 3)) +(define-inline (queue:job-set-user! vec val)(vector-set! vec 0 val)) +(define-inline (queue:job-set-duration! vec val)(vector-set! vec 1 val)) +(define-inline (queue:job-set-num-cpu! vec val)(vector-set! vec 2 val)) +(define-inline (queue:job-set-num-gigs! vec val)(vector-set! vec 3 val)) + +;; add a job to the queue +;; +(define (add-job queue-name user duration num-cpu num-gigs) + (let* ((queue-dat (hash-table-ref/default *queues* queue-name '())) + (new-queue (append + queue-dat + (list (vector user duration num-cpu num-gigs))))) + (hash-table-set! *queues* queue-name new-queue) + (draw-queue-jobs queue-name))) + +;; peek for jobs to do in queue +;; +(define (peek-job queue-name) + (let ((queue (hash-table-ref/default *queues* queue-name '()))) + (if (null? queue) + #f + (car queue)))) + +;; take job from queue +;; +(define (take-job queue-name) + (let ((queue (hash-table-ref/default *queues* queue-name '()))) + (if (null? queue) + #f + (begin + (hash-table-set! *queues* queue-name (cdr queue)) + (draw-queue-jobs queue-name) + (car queue))))) + +;;====================================================================== +;; CPUs +;;====================================================================== + +(define (make-cpu:dat)(make-vector 6 #f)) +(define-inline (cpu:dat-get-user vec) (vector-ref vec 0)) +(define-inline (cpu:dat-get-job-len vec) (vector-ref vec 1)) +(define-inline (cpu:dat-get-num-cpu vec) (vector-ref vec 2)) +(define-inline (cpu:dat-get-mem vec) (vector-ref vec 3)) +(define-inline (cpu:dat-get-x vec) (vector-ref vec 4)) +(define-inline (cpu:dat-get-y vec) (vector-ref vec 5)) +(define-inline (cpu:dat-set-user! vec val)(vector-set! vec 0 val)) +(define-inline (cpu:dat-set-job-len! vec val)(vector-set! vec 1 val)) +(define-inline (cpu:dat-set-num-cpu! vec val)(vector-set! vec 2 val)) +(define-inline (cpu:dat-set-mem! vec val)(vector-set! vec 3 val)) +(define-inline (cpu:dat-set-x! vec val)(vector-set! vec 4 val)) +(define-inline (cpu:dat-set-y! vec val)(vector-set! vec 5 val)) + +(define-inline (cpu:grid-get-x vec) (vector-ref vec 0)) +(define-inline (cpu:grid-get-y vec) (vector-ref vec 1)) +(define-inline (cpu:grid-get-w vec) (vector-ref vec 2)) +(define-inline (cpu:grid-get-gap vec) (vector-ref vec 3)) +(define-inline (cpu:grid-get-x-min vec) (vector-ref vec 4)) +(define-inline (cpu:grid-get-x-max vec) (vector-ref vec 5)) +(define-inline (cpu:grid-set-x! vec val)(vector-set! vec 0 val)) +(define-inline (cpu:grid-set-y! vec val)(vector-set! vec 1 val)) +(define-inline (cpu:grid-set-w! vec val)(vector-set! vec 2 val)) +(define-inline (cpu:grid-set-gap! vec val)(vector-set! vec 3 val)) +(define-inline (cpu:grid-set-x-min! vec val)(vector-set! vec 4 val)) +(define-inline (cpu:grid-set-x-max! vec val)(vector-set! vec 5 val)) + +(define (add-cpu name num-cores mem) + (let ((x (cpu:grid-get-x *cpu-grid*)) + (y (cpu:grid-get-y *cpu-grid*)) + (delta (+ (cpu:grid-get-w *cpu-grid*)(cpu:grid-get-gap *cpu-grid*))) + (x-max (cpu:grid-get-x-max *cpu-grid*))) + (hash-table-set! *cpus* name (vector #f #f num-cores mem x y)) + (if (> x x-max) + (begin + (cpu:grid-set-x! *cpu-grid* (cpu:grid-get-x-min *cpu-grid*)) + (cpu:grid-set-y! *cpu-grid* (+ y delta))) + (cpu:grid-set-x! *cpu-grid* (+ x delta))))) + +;; draw grey box for each cpu on layer 2 +;; jobs are drawn on layer 1 +;; +(define (draw-cpus) ;; call once after init'ing all cpus + (ezx-select-layer *ezx* 1) + (ezx-wipe-layer *ezx* 1) + ;; draw time at upper right + (ezx-str-2d *ezx* 20 20 (seconds->h:m:s *now*) *black*) + (for-each + (lambda (cpu) + (let ((x (cpu:dat-get-x cpu)) + (y (cpu:dat-get-y cpu)) + (w (cpu:grid-get-w *cpu-grid*))) + (ezx-rect-2d *ezx* x y (+ x w) (+ y w) *grey* 1))) + (hash-table-values *cpus*)) + (ezx-redraw *ezx*)) + +(define (draw-jobs) + ;; (draw-cpus) + (ezx-select-layer *ezx* 2) + (ezx-wipe-layer *ezx* 2) + (for-each + (lambda (cpu) + (let* ((x (cpu:dat-get-x cpu)) + (y (cpu:dat-get-y cpu)) + (w (cpu:grid-get-w *cpu-grid*)) + (u (cpu:dat-get-user cpu))) + (if u ;; job running if not #f + (let ((color (get-user-color u))) + (ezx-fillrect-2d *ezx* (+ x 2)(+ 2 y)(+ x 9) (+ y 9) color))))) + (hash-table-values *cpus*)) + (ezx-redraw *ezx*)) + +(define (end-job cpu-name user) + (let ((cpu (hash-table-ref/default *cpus* cpu-name #f))) + (if cpu + (let ((curr-user (cpu:dat-get-user cpu))) ;; if it is a user name then job is not done - error + (if (or (not curr-user) + (not (equal? curr-user user))) + (print "ERROR: cpu " cpu-name " not running job for " user "!") + (begin + (cpu:dat-set-user! cpu #f) + (cpu:dat-set-job-len! cpu #f) + (draw-jobs)))) ;; hash-table-set! *cpus* cpu-name (make-cpu:dat)))) + (print "ERROR: no cpu " cpu-name " found. Ensure it is registered before addressing it.")))) + +(define (run-job cpu-name job) + (let* ((user (queue:job-get-user job)) + (job-len (queue:job-get-duration job)) + (cpu (hash-table-ref/default *cpus* cpu-name #f))) + (if cpu + (let ((curr-user (cpu:dat-get-user cpu))) ;; if it is a user name then job is not done - error + (if curr-user + (begin + (print "ERROR: cpu already busy! Adding more jobs not supported yet. " cpu-name) + #f) + (begin + (cpu:dat-set-user! cpu user) + (cpu:dat-set-job-len! cpu job-len) + (draw-jobs) + (hash-table-set! *cpus* cpu-name cpu) + (event (+ *now* job-len) (lambda ()(end-job cpu-name user))) + #t))) + #f))) + +(define (get-cpu) + (let ((all-cpus (hash-table-keys *cpus*))) + (if (null? all-cpus) + #f + (let loop ((hed (car all-cpus)) + (tal (cdr all-cpus))) + (if (cpu:dat-get-user (hash-table-ref/default *cpus* hed '(#f #f))) ;; if user is #f then cpu is available + (if (null? tal) + #f + (loop (car tal)(cdr tal))) + hed))))) + +;;====================================================================== +;; Animation +;;====================================================================== + +;; make-vector-record queue spec x y delta-y height length +(define (make-queue:spec)(make-vector 5)) +(define-inline (queue:spec-get-x vec) (vector-ref vec 0)) +(define-inline (queue:spec-get-y vec) (vector-ref vec 1)) +(define-inline (queue:spec-get-delta-y vec) (vector-ref vec 2)) +(define-inline (queue:spec-get-height vec) (vector-ref vec 3)) +(define-inline (queue:spec-get-length vec) (vector-ref vec 4)) +(define-inline (queue:spec-set-x! vec val)(vector-set! vec 0 val)) +(define-inline (queue:spec-set-y! vec val)(vector-set! vec 1 val)) +(define-inline (queue:spec-set-delta-y! vec val)(vector-set! vec 2 val)) +(define-inline (queue:spec-set-height! vec val)(vector-set! vec 3 val)) +(define-inline (queue:spec-set-length! vec val)(vector-set! vec 4 val)) + +;; queues are drawn on layer 3 but boxes (jobs) are drawn on the numbered layer +;; +(define (draw-queues) + (let* ((text-offset 3) + (queue-names (sort (hash-table-keys *queues*) string>=?)) + (start-x (vector-ref *queue-spec* 0)) + (text-x (+ start-x text-offset)) + (delta-y (vector-ref *queue-spec* 1)) + (delta-x (vector-ref *queue-spec* 2)) + (height (vector-ref *queue-spec* 3)) + (length (vector-ref *queue-spec* 4)) + (end-x (+ start-x length))) + (ezx-select-layer *ezx* 3) + (ezx-wipe-layer *ezx* 3) + (let loop ((y (vector-ref *queue-spec* 1)) + (qname (car queue-names)) + (tail (cdr queue-names)) + (layer 4)) + (print "Drawing queue at x=" start-x ", y=" y) + (ezx-fillrect-2d *ezx* start-x y end-x (+ y height) *brown*) + (ezx-str-2d *ezx* text-x (- (+ y height) text-offset) qname *white*) + (hash-table-set! *obj-locations* qname (list start-x y layer)) + (if (not (null? tail)) + (loop (+ y height delta-y) + (car tail) + (cdr tail) + (+ layer 1)))) + (ezx-redraw *ezx*))) + +;; compress queue data to (vector user count) list +;; +(define (draw-queue-compress-queue-data queue-dat) + (let loop ((hed (car queue-dat)) + (tal (cdr queue-dat)) + (curr #f) ;; (vector name count) + (res '())) + (let ((user (queue:job-get-user hed))) + (cond + ((not curr) ;; first time through only? + (if (null? tal) + (append res (list (vector user 1))) + (loop (car tal)(cdr tal)(vector user 1) res))) + ((equal? (vector-ref curr 0) user) + (vector-set! curr 1 (+ (vector-ref curr 1) 1)) + (if (null? tal) + (append res (list curr)) + (loop (car tal)(cdr tal) curr res))) + (else ;; names are different, add curr to queue and create new curr + (let ((newcurr (vector user 1))) + (if (null? tal) + (append res (list newcurr)) + (loop (car tal)(cdr tal) newcurr (append res (list curr)))))))))) + +;; draw jobs for a given queue +;; +(define (draw-queue-jobs queue-name) + (let* ((queue-dat (hash-table-ref/default *queues* queue-name #f)) ;; list of jobs in the queue + (obj-spec (hash-table-ref/default *obj-locations* queue-name #f))) ;; x, y etc. of the drawn queue + (if obj-spec + (let ((origin-x (list-ref obj-spec 0)) + (origin-y (list-ref obj-spec 1)) + (bar-width 10) + (queue-len (queue:spec-get-length *queue-spec*)) + (layer (list-ref obj-spec 2))) + (ezx-select-layer *ezx* layer) + (ezx-wipe-layer *ezx* layer) + (if (not (null? queue-dat)) + (let ((res (draw-queue-compress-queue-data queue-dat))) + (if (not (null? res)) + (let loop ((hed (car res)) + (tal (cdr res)) + (x2 (+ origin-x queue-len))) + (let* ((user (vector-ref hed 0)) + (h (let ((numjobs (vector-ref hed 1))) + (if *use-log* + (inexact->exact (round (log (+ 1 (* *job-log-scale* numjobs))))) + numjobs))) + (x1 (- x2 bar-width)) + (y2 (- origin-y h))) + ;; (print "x1 " x1 ", origin-y " origin-y ", x2 " x2 ", y2 " y2) + (ezx-fillrect-2d *ezx* x1 y2 x2 origin-y (get-user-color user)) + (if (not (null? tal)) + (loop (car tal)(cdr tal) x1))))) + (ezx-redraw *ezx*))))))) + +(let* ((args (argv)) + (fname (if (> (length args) 1) + (cadr args) + "default.scm"))) + (load (if (file-exists? fname) fname "default.scm"))) ADDED batchsim/default.scm Index: batchsim/default.scm ================================================================== --- /dev/null +++ batchsim/default.scm @@ -0,0 +1,133 @@ +;; run sim for four hours +;; +(define *end-time* (* 60 50)) + +;; create the cpus +;; +(let loop ((count 200)) + (add-cpu (conc "cpu_" count) 1 1) + (if (>= count 0)(loop (- count 1)))) + +(draw-cpus) + +(define *pool1* (new-pool "generic" 100 100 100 100 2 10)) +(let loop ((count 10)) + (pool:add-cpu *pool1* (conc count) 1 1) + (if (> count 0) + (loop (- count 1)))) + +(pool:draw *ezx* *pool1*) + +;; init the queues +;; +(hash-table-set! *queues* "normal" '()) +(hash-table-set! *queues* "quick" '()) +(draw-queues) + +;; user k adds 200 jobs at time zero +;; +(event *start-time* + (lambda () + (let loop ((count 300)) ;; add 500 jobs + (add-job "normal" "k" 600 1 1) + (if (>= count 0)(loop (- count 1)))))) + +;; one minute in user m runs ten jobs +;; +(event (+ 600 *start-time*) + (lambda () + (let loop ((count 300)) ;; add 100 jobs + (add-job "normal" "m" 600 1 1) + (if (> count 0)(loop (- count 1)))))) + +;; every minute user j runs ten jobs +;; +(define *user-j-jobs* 300) +(event (+ 600 *start-time*) + (lambda () + (let f () + (schedule 60) + (if (> *user-j-jobs* 0) + (begin + (let loop ((count 5)) ;; add 100 jobs + (add-job "quick" "j" 600 1 1) + (if (> count 0)(loop (- count 1)))) + (set! *user-j-jobs* (- *user-j-jobs* 5)))) + (if (and (not *done*) + (> *user-j-jobs* 0)) + (f))))) ;; Megatest user running 200 jobs + +;; every minute user j runs ten jobs +;; +(define *user-j-jobs* 300) +(event (+ 630 *start-time*) + (lambda () + (let f () + (schedule 60) + (if (> *user-j-jobs* 0) + (begin + (let loop ((count 5)) ;; add 100 jobs + (add-job "quick" "n" 600 1 1) + (if (> count 0)(loop (- count 1)))) + (set! *user-j-jobs* (- *user-j-jobs* 5)))) + (if (and (not *done*) + (> *user-j-jobs* 0)) + (f))))) ;; Megatest user running 200 jobs + +;; ;; +;; (event *start-time* +;; (lambda () +;; (let f ((count 200)) +;; (schedule 10) +;; (add-job "normal" "t" 60 1 1) +;; (if (and (not *done*) +;; (>= count 0)) +;; (f (- count 1)))))) + +;; every 3 seconds check for available machines and launch a job +;; +(event *start-time* + (lambda () + (let f () + (schedule 3) + (let ((queue-names (random-sort (hash-table-keys *queues*)))) + (let loop ((cpu (get-cpu)) + (count (+ (length queue-names) 4)) + (qname (car queue-names)) + (remq (cdr queue-names))) + (if (and cpu + (> count 0)) + (begin + (if (peek-job qname) ;; any jobs to do in normal queue + (let ((job (take-job qname))) + (run-job cpu job))) + (loop (get-cpu) + (- count 1) + (if (null? remq) + (car queue-names) + (car remq)) + (if (null? remq) + (cdr queue-names) + (cdr remq))))))) + (if (not *done*)(f))))) + +;; screen updates +;; +(event *start-time* (lambda () + (let f () + (schedule 60) ;; update the screen every 60 seconds of sim time + (draw-cpus) ;; (print "Now: " *now* " queue: " (hash-table->alist *queues*)) + (wait-for-next-draw-time) + (if (not *done*) (f))))) + + +;; end the simulation +;; +(event *end-time* + (lambda () + (set! *event-list* '()) + (set! *done* #t))) + +(start) +;; (exit 0) + ADDED batchsim/events.scm Index: batchsim/events.scm ================================================================== --- /dev/null +++ batchsim/events.scm @@ -0,0 +1,79 @@ + +;;====================================================================== +;; Event Processing and Simulator +;;====================================================================== + +;; The global event list +(define *event-list* '()) +(define *start-time* 0) +(define *end-time* (* 60 60 4)) ;; four hours +(define *now* *start-time*) +(define *done* #f) + +(define (random-sort l) + (sort l + (lambda (x y) + (equal? 0 (random 2))))) + +;; Each item in the event list is a list of a scheduled time and the thunk +;; (time thunk). Sort the list so that the next event is the earliest. +;; +(define event-sort + (lambda (@a @b) + (< (car @a)(car @b)))) + +(define event + (lambda ($time $thunk) ;; add a sort based on scheduled time here -- improve later + ;; to use an insert algorythm. + (set! *event-list* (sort (cons (list $time $thunk) *event-list*) event-sort)))) + +(define start + (lambda () + (let ((next (car *event-list*))) + (set! *event-list* (cdr *event-list*)) + (set! *now* (car next)) + (if (not *done*) ;; note that the second item in the list is the thunk + ((car (cdr next))))))) + +(define pause + (lambda () + (call/cc + (lambda (k) + (event (lambda () (k #f))) + (start))))) + +(define schedule + (lambda ($time) + (call/cc + (lambda (k) + (event (+ *now* $time) (lambda () (k #f))) + (start))))) + +;; (event (lambda () (let f () (pause) (display "h") (f)))) + +(define years->seconds + (lambda ($yrs) + (* $yrs 365 24 3600))) + +(define weeks->seconds + (lambda ($wks) + (* $wks 7 24 3600))) + +(define days->seconds + (lambda ($days) + (* $days 24 3600))) + +(define months->seconds + (lambda ($months) + (* $months (/ 365 12) 24 3600))) + +(define seconds->date + (lambda ($seconds) + (posix-strftime "%D" (posix-localtime (inexact->exact $seconds))))) + +(define (seconds->h:m:s seconds) + (let* ((hours (quotient seconds 3600)) + (rem1 (- seconds (* hours 3600))) + (minutes (quotient rem1 60)) + (rem-sec (- rem1 (* minutes 60)))) + (conc hours "h " minutes "m " rem-sec "s"))) ADDED batchsim/testing.scm Index: batchsim/testing.scm ================================================================== --- /dev/null +++ batchsim/testing.scm @@ -0,0 +1,135 @@ +;; run sim for four hours +;; +(define *end-time* (* 60 50)) + +;; create the cpus +;; +(let loop ((count 200)) + (add-cpu (conc "cpu_" count) 1 1) + (if (>= count 0)(loop (- count 1)))) + +;; (draw-cpus) + +(define *pool1* (new-pool "generic" 20 20 12 80 2 4)) +(let loop ((count 10)) + (pool:add-cpu *pool1* (conc count) 1 1) + (if (> count 0) + (loop (- count 1)))) + +(pool:draw *ezx* *pool1*) + +;; ;; init the queues +;; ;; +;; (hash-table-set! *queues* "normal" '()) +;; (hash-table-set! *queues* "quick" '()) +;; (draw-queues) +;; +;; ;; user k adds 200 jobs at time zero +;; ;; +;; (event *start-time* +;; (lambda () +;; (let loop ((count 300)) ;; add 500 jobs +;; (add-job "normal" "k" 600 1 1) +;; (if (>= count 0)(loop (- count 1)))))) +;; +;; ;; one minute in user m runs ten jobs +;; ;; +;; (event (+ 600 *start-time*) +;; (lambda () +;; (let loop ((count 300)) ;; add 100 jobs +;; (add-job "normal" "m" 600 1 1) +;; (if (> count 0)(loop (- count 1)))))) +;; +;; ;; every minute user j runs ten jobs +;; ;; +;; (define *user-j-jobs* 300) +;; (event (+ 600 *start-time*) +;; (lambda () +;; (let f () +;; (schedule 60) +;; (if (> *user-j-jobs* 0) +;; (begin +;; (let loop ((count 5)) ;; add 100 jobs +;; (add-job "quick" "j" 600 1 1) +;; (if (> count 0)(loop (- count 1)))) +;; (set! *user-j-jobs* (- *user-j-jobs* 5)))) +;; (if (and (not *done*) +;; (> *user-j-jobs* 0)) +;; (f))))) ;; Megatest user running 200 jobs +;; +;; ;; every minute user j runs ten jobs +;; ;; +;; (define *user-j-jobs* 300) +;; (event (+ 630 *start-time*) +;; (lambda () +;; (let f () +;; (schedule 60) +;; (if (> *user-j-jobs* 0) +;; (begin +;; (let loop ((count 5)) ;; add 100 jobs +;; (add-job "quick" "n" 600 1 1) +;; (if (> count 0)(loop (- count 1)))) +;; (set! *user-j-jobs* (- *user-j-jobs* 5)))) +;; (if (and (not *done*) +;; (> *user-j-jobs* 0)) +;; (f))))) ;; Megatest user running 200 jobs +;; +;; ;; ;; +;; ;; (event *start-time* +;; ;; (lambda () +;; ;; (let f ((count 200)) +;; ;; (schedule 10) +;; ;; (add-job "normal" "t" 60 1 1) +;; ;; (if (and (not *done*) +;; ;; (>= count 0)) +;; ;; (f (- count 1)))))) +;; +;; ;; every 3 seconds check for available machines and launch a job +;; ;; +;; (event *start-time* +;; (lambda () +;; (let f () +;; (schedule 3) +;; (let ((queue-names (random-sort (hash-table-keys *queues*)))) +;; (let loop ((cpu (get-cpu)) +;; (count (+ (length queue-names) 4)) +;; (qname (car queue-names)) +;; (remq (cdr queue-names))) +;; (if (and cpu +;; (> count 0)) +;; (begin +;; (if (peek-job qname) ;; any jobs to do in normal queue +;; (let ((job (take-job qname))) +;; (run-job cpu job))) +;; (loop (get-cpu) +;; (- count 1) +;; (if (null? remq) +;; (car queue-names) +;; (car remq)) +;; (if (null? remq) +;; (cdr queue-names) +;; (cdr remq))))))) +;; (if (not *done*)(f))))) +;; +;; ;; screen updates +;; ;; +(event *start-time* (lambda () + (let f () + (schedule 60) ;; update the screen every 60 seconds of sim time + ;; (draw-cpus) ;; (print "Now: " *now* " queue: " (hash-table->alist *queues*)) + (pool:draw *ezx* *pool1*) + + (wait-for-next-draw-time) + (if (not *done*) (f))))) +;; +;; +;; ;; end the simulation +;; ;; +(event *end-time* + (lambda () + (set! *event-list* '()) + (set! *done* #t))) +;; +(start) +;; ;; (exit 0) +;; ADDED bin/sleeprunner Index: bin/sleeprunner ================================================================== --- /dev/null +++ bin/sleeprunner @@ -0,0 +1,7 @@ +#!/bin/bash + +if [[ $SLEEPRUNNER == "" ]];then +SLEEPRUNNER=1 +fi + +echo "nbfake $@ &> /dev/null" | at now + $SLEEPRUNNER minutes &> /dev/null Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -164,10 +164,33 @@ (debug:print 0 "ERROR: received bad encoded string \"" instr "\", message: " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain (current-error-port)) #f) (read (open-input-string (base64:base64-decode instr)))) (read (open-input-string (z3:decode-buffer (base64:base64-decode instr)))))) + +;; dot-locking egg seems not to work, using this for now +;; if lock is older than expire-time then remove it and try again +;; to get the lock +;; +(define (common:simple-file-lock fname #!key (expire-time 300)) + (if (file-exists? fname) + (if (> (- (current-seconds)(file-modification-time fname)) expire-time) + (begin + (delete-file* fname) + (common:simple-file-lock fname expire-time: expire-time)) + #f) + (let ((key-string (conc (get-host-name) "-" (current-process-id)))) + (with-output-to-file fname + (lambda () + (print key-string))) + (thread-sleep! 0.25) + (with-input-from-file fname + (lambda () + (equal? key-string (read-line))))))) + +(define (common:simple-file-release-lock fname) + (delete-file* fname)) ;;====================================================================== ;; S T A T E S A N D S T A T U S E S ;;====================================================================== Index: common_records.scm ================================================================== --- common_records.scm +++ common_records.scm @@ -52,15 +52,24 @@ (print "ERROR: Invalid debug value \"" vstr "\"") #f) #t)) (define (debug:debug-mode n) - (or (and (number? *verbosity*) - (<= n *verbosity*)) - (and (list? *verbosity*) - (member n *verbosity*)))) - + (cond + ((and (number? *verbosity*) ;; number number + (number? n)) + (<= n *verbosity*)) + ((and (list? *verbosity*) ;; list number + (number? n)) + (member n *verbosity*)) + ((and (list? *verbosity*) ;; list list + (list? n)) + (not (null? (lset-intersection! eq? *verbosity* n)))) + ((and (number? *verbosity*) + (list? n)) + (member *verbosity* n)))) + (define (debug:setup) (let ((debugstr (or (args:get-arg "-debug") (getenv "MT_DEBUG_MODE")))) (set! *verbosity* (debug:calc-verbosity debugstr)) (debug:check-verbosity *verbosity* debugstr) @@ -85,11 +94,11 @@ (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: (~2d) ~a" n (apply conc params)))) + (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) )))))) Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -57,10 +57,11 @@ (define configf:key-sys-pr (regexp "^(\\S+)\\s+\\[system\\s+(\\S+.*)\\]\\s*$")) (define configf:key-val-pr (regexp "^(\\S+)(\\s+(.*)|())$")) (define configf:key-no-val (regexp "^(\\S+)(\\s*)$")) (define configf:comment-rx (regexp "^\\s*#.*")) (define configf:cont-ln-rx (regexp "^(\\s+)(\\S+.*)$")) +(define configf:settings (regexp "^\\[configf:settings\\s+(\\S+)\\s+(\\S+)]\\s*$")) ;; read a line and process any #{ ... } constructs (define configf:var-expand-regex (regexp "^(.*)#\\{(scheme|system|shell|getenv|get|runconfigs-get|rget)\\s+([^\\}\\{]*)\\}(.*)")) (define (configf:process-line l ht allow-system) @@ -85,16 +86,20 @@ (conc "(lambda (ht)(config-lookup ht \"" sect "\" \"" var "\"))"))) ((runconfigs-get) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))")) ((rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))")) (else "(lambda (ht)(print \"ERROR\") \"ERROR\")")))) ;; (print "fullcmd=" fullcmd) - (if (or allow-system - (not (member cmdtype '("system" "shell")))) - (with-input-from-string fullcmd - (lambda () - (set! result ((eval (read)) ht)))) - (set! result (conc "#{(" cmdtype ") " cmd "}"))) (loop (conc prestr result poststr))) + (handle-exceptions + exn + (debug:print 0 "ERROR: failed to process config input \"" l "\"") + (if (or allow-system + (not (member cmdtype '("system" "shell")))) + (with-input-from-string fullcmd + (lambda () + (set! result ((eval (read)) ht)))) + (set! result (conc "#{(" cmdtype ") " cmd "}")))) + (loop (conc prestr result poststr))) res)) res))) ;; Run a shell command and return the output as a string (define (shell cmd) @@ -121,11 +126,11 @@ (configf:lookup config "default" var)) (configf:lookup config "default" var)))) ;; this was inline but I'm pretty sure that is a hold over from when it was *very* simple ... ;; -(define (configf:read-line p ht allow-processing) +(define (configf:read-line p ht allow-processing settings) (let loop ((inl (read-line p))) (let ((cont-line (and (string? inl) (not (string-null? inl)) (equal? "\\" (string-take-right inl 1))))) (if cont-line ;; last character is \ @@ -133,49 +138,58 @@ (if (not (eof-object? nextl)) (loop (string-append (if cont-line (string-take inl (- (string-length inl) 1)) inl) nextl)))) - (case allow-processing ;; if (and allow-processing - ;; (not (eq? allow-processing 'return-string))) - ((#t #f) - (configf:process-line inl ht allow-processing)) - ((return-string) - inl) - (else - (configf:process-line inl ht allow-processing))))))) - + (let ((res (case allow-processing ;; if (and allow-processing + ;; (not (eq? allow-processing 'return-string))) + ((#t #f) + (configf:process-line inl ht allow-processing)) + ((return-string) + inl) + (else + (configf:process-line inl ht allow-processing))))) + (if (and (string? res) + (not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "no") "no"))) + (string-substitute "\\s+$" "" res) + res)))))) + ;; read a config file, returns hash table of alists ;; read a config file, returns hash table of alists ;; adds to ht if given (must be #f otherwise) ;; envion-patt is a regex spec that identifies sections that will be eval'd ;; in the environment on the fly ;; sections: #f => get all, else list of sections to gather -(define (read-config path ht allow-system #!key (environ-patt #f)(curr-section #f)(sections #f)) +(define (read-config path ht allow-system #!key (environ-patt #f)(curr-section #f)(sections #f)(settings (make-hash-table))) (debug:print-info 5 "read-config " path " allow-system " allow-system " environ-patt " environ-patt " curr-section: " curr-section " sections: " sections " pwd: " (current-directory)) + (debug:print 9 "START: " path) (if (not (file-exists? path)) (begin (debug:print-info 1 "read-config - file not found " path " current path: " (current-directory)) ;; WARNING: This is a risky change but really, we should not return an empty hash table if no file read? #f) ;; (if (not ht)(make-hash-table) ht)) (let ((inp (open-input-file path)) (res (if (not ht)(make-hash-table) ht))) - (let loop ((inl (configf:read-line inp res allow-system)) ;; (read-line inp)) + (let loop ((inl (configf:read-line inp res allow-system settings)) ;; (read-line inp)) (curr-section-name (if curr-section curr-section "default")) (var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere (lead #f)) (debug:print-info 8 "curr-section-name: " curr-section-name " var-flag: " var-flag "\n inl: \"" inl "\"") (if (eof-object? inl) (begin (close-input-port inp) (hash-table-delete! res "") ;; we are using "" as a dumping ground and must remove it before returning the ht + (debug:print 9 "END: " path) res) (regex-case inl - (configf:comment-rx _ (loop (configf:read-line inp res allow-system) curr-section-name #f #f)) - (configf:blank-l-rx _ (loop (configf:read-line inp res allow-system) curr-section-name #f #f)) + (configf:comment-rx _ (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f)) + (configf:blank-l-rx _ (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f)) + (configf:settings ( x setting val ) (begin + (hash-table-set! settings setting val) + (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f))) (configf:include-rx ( x include-file ) (let* ((curr-conf-dir (pathname-directory path)) (full-conf (if (absolute-pathname? include-file) include-file (nice-path (conc (if curr-conf-dir @@ -183,18 +197,19 @@ ".") "/" include-file))))) (if (file-exists? full-conf) (begin ;; (push-directory conf-dir) - (read-config full-conf res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections) + (debug:print 9 "Including: " full-conf) + (read-config full-conf res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings) ;; (pop-directory) - (loop (configf:read-line inp res allow-system) curr-section-name #f #f)) + (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f)) (begin - (debug:print 2 "INFO: include file " include-file " not found (called from " path ")") + (debug:print '(2 9) "INFO: include file " include-file " not found (called from " path ")") (debug:print 2 " " full-conf) - (loop (configf:read-line inp res allow-system) curr-section-name #f #f))))) - (configf:section-rx ( x section-name ) (loop (configf:read-line inp res allow-system) + (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f))))) + (configf:section-rx ( x section-name ) (loop (configf:read-line inp res allow-system settings) ;; if we have the sections list then force all settings into "" and delete it later? (if (or (not sections) (member section-name sections)) section-name "") ;; stick everything into "" #f #f)) @@ -218,26 +233,28 @@ key (case allow-system ((return-procs) val-proc) ((return-string) cmd) (else (val-proc))))) - (loop (configf:read-line inp res allow-system) curr-section-name #f #f)) - (loop (configf:read-line inp res allow-system) curr-section-name #f #f))) + (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f)) + (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f))) (configf:key-val-pr ( x key unk1 val unk2 ) (let* ((alist (hash-table-ref/default res curr-section-name '())) (envar (and environ-patt (string-search (regexp environ-patt) curr-section-name))) (realval (if envar (config:eval-string-in-environment val) val))) (debug:print-info 6 "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name) (if envar (safe-setenv key realval)) + (debug:print 10 " setting: [" curr-section-name "] " key " = " val) (hash-table-set! res curr-section-name (config:assoc-safe-add alist key realval)) - (loop (configf:read-line inp res allow-system) curr-section-name key #f))) + (loop (configf:read-line inp res allow-system settings) curr-section-name key #f))) (configf:key-no-val ( x key val) (let* ((alist (hash-table-ref/default res curr-section-name '()))) + (debug:print 10 " setting: [" curr-section-name "] " key " = #t") (hash-table-set! res curr-section-name (config:assoc-safe-add alist key #t)) - (loop (configf:read-line inp res allow-system) curr-section-name key #f))) + (loop (configf:read-line inp res allow-system settings) curr-section-name key #f))) ;; if a continued line (configf:cont-ln-rx ( x whsp val ) (let ((alist (hash-table-ref/default res curr-section-name '()))) (if var-flag ;; if set to a string then we have a continued var (let ((newval (conc (config-lookup res curr-section-name var-flag) "\n" @@ -247,15 +264,15 @@ "") val))) ;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag) (hash-table-set! res curr-section-name (config:assoc-safe-add alist var-flag newval)) - (loop (configf:read-line inp res allow-system) curr-section-name var-flag (if lead lead whsp))) - (loop (configf:read-line inp res allow-system) curr-section-name #f #f)))) + (loop (configf:read-line inp res allow-system settings) curr-section-name var-flag (if lead lead whsp))) + (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f)))) (else (debug:print 0 "ERROR: problem parsing " path ",\n \"" inl "\"") (set! var-flag #f) - (loop (configf:read-line inp res allow-system) curr-section-name #f #f)))))))) + (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f)))))))) ;; pathenvvar will set the named var to the path of the config (define (find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f)) (let* ((curr-dir (current-directory)) (configinfo (find-config fname toppath: given-toppath)) Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -401,11 +401,12 @@ ;;====================================================================== ;; ;;====================================================================== (define (examine-test run-id test-id) ;; run-id run-key origtest) (let* ((db-path (db:dbfile-path run-id)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db")) - (dbstruct (make-dbr:dbstruct path: (configf:lookup *configdat* "setup" "linktree") local: #t)) + (dbstruct (make-dbr:dbstruct path: (db:dbfile-path #f) ;; (configf:lookup *configdat* "setup" "linktree") + local: #t)) (testdat (db:get-test-info-by-id dbstruct run-id test-id)) (db-mod-time 0) ;; (file-modification-time db-path)) (last-update 0) ;; (current-seconds)) (request-update #t)) (if (not testdat) @@ -424,11 +425,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 (dcommon:get-compressed-steps dbstruct run-id test-id) '())) + (teststeps (if testdat (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 (let ((tm (db:testmeta-get-record dbstruct testname))) (if tm tm (make-db:testmeta))) @@ -481,11 +482,11 @@ (db:get-test-info-by-id dbstruct 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 (dcommon:get-compressed-steps dbstruct run-id test-id)) + (set! teststeps (tests:get-compressed-steps dbstruct 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 ")) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -85,11 +85,11 @@ (if (not (launch:setup-for-run)) (begin (print "Failed to find megatest.config, exiting") (exit 1))) -(define *dbdir* (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) +(define *dbdir* (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) (define *dbstruct-local* (make-dbr:dbstruct path: *dbdir* local: #t)) (define *db-file-path* (db:dbfile-path 0)) ;; HACK ALERT: this is a hack, please fix. Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -61,18 +61,15 @@ ;; (define (db:get-db dbstruct run-id) (if (sqlite3:database? dbstruct) ;; pass sqlite3 databases on through dbstruct (begin - (mutex-lock! *rundb-mutex*) (let ((dbdat (if (or (not run-id) (eq? run-id 0)) (db:open-main dbstruct) (db:open-rundb dbstruct run-id) ))) - ;; db prunning would go here - (mutex-unlock! *rundb-mutex*) dbdat)))) (define (db:dbdat-get-db dbdat) (if (pair? dbdat) (car dbdat) @@ -137,24 +134,28 @@ ;; ;; ;; (define (db:get-path dbstruct id) ;; (let ((fdb (db:get-filedb dbstruct))) ;; (filedb:get-path db id))) -;; NB// #f => zeroth db with name=main.db +;; NB// #f => return dbdir only +;; (was planned to be; zeroth db with name=main.db) ;; (define (db:dbfile-path run-id) - (let* (;; (toppath (dbr:dbstruct-get-path dbstruct)) - (link-tree-path (configf:lookup *configdat* "setup" "linktree")) - (fname (if (eq? run-id 0) "main.db" (conc run-id ".db"))) - (dbdir (conc link-tree-path "/.db/"))) + (let* ((dbdir (or (configf:lookup *configdat* "setup" "dbdir") + (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))) + (fname (if run-id + (if (eq? run-id 0) "main.db" (conc run-id ".db")) + #f))) (handle-exceptions exn (begin (debug:print 0 "ERROR: Couldn't create path to " dbdir) (exit 1)) (if (not (directory? dbdir))(create-directory dbdir #t))) - (conc dbdir fname))) + (if fname + (conc dbdir "/" fname) + dbdir))) (define (db:set-sync db) (let ((syncprag (configf:lookup *configdat* "setup" "sychronous"))) (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 1) ";")))) @@ -191,86 +192,95 @@ (dbr:dbstruct-get-localdb dbstruct run-id) (dbr:dbstruct-get-inmem dbstruct)))) ;; (dbr:dbstruct-get-runrec dbstruct run-id 'inmem))) (if (or rdb do-not-open) rdb - (let* ((dbpath (db:dbfile-path run-id)) ;; (conc toppath "/db/" run-id ".db")) - (dbexists (file-exists? dbpath)) - (inmem (if local #f (db:open-inmem-db))) - (refdb (if local #f (db:open-inmem-db))) - (db (db:lock-create-open dbpath ;; this is the database physically on disk - (lambda (db) - (handle-exceptions - exn - (begin - (release-dot-lock dbpath) - (if (> attemptnum 2) - (debug:print 0 "ERROR: tried twice, cannot create/initialize db for run-id " run-id ", at path " dbpath) - (db:open-rundb dbstruct run-id attemptnum (+ attemptnum 1)))) - (db:initialize-run-id-db db) - (sqlite3:execute - db - "INSERT OR IGNORE INTO tests (id,run_id,testname,event_time,item_path,state,status) VALUES (?,?,'bogustest',strftime('%s','now'),'nowherepath','DELETED','n/a');" - (* run-id 30000) ;; allow for up to 30k tests per run - run-id) - ;; do a dummy query to test that the table exists and the db is truly readable - (sqlite3:execute db "SELECT * FROM tests WHERE id=?;" (* run-id 30000)) - )))) ;; add strings db to rundb, not in use yet - ;; )) ;; (sqlite3:open-database dbpath)) - (olddb (if *megatest-db* - *megatest-db* - (let ((db (db:open-megatest-db))) - (set! *megatest-db* db) - db))) - (write-access (file-write-access? dbpath)) - ;; (handler (make-busy-timeout 136000)) - ) - (if (and dbexists (not write-access)) - (set! *db-write-access* #f)) ;; only unset so other db's also can use this control - (dbr:dbstruct-set-rundb! dbstruct (cons db dbpath)) - (dbr:dbstruct-set-inuse! dbstruct #t) - (dbr:dbstruct-set-olddb! dbstruct olddb) - ;; (dbr:dbstruct-set-run-id! dbstruct run-id) - (if local - (begin - (dbr:dbstruct-set-localdb! dbstruct run-id db) ;; (dbr:dbstruct-set-inmem! dbstruct db) ;; direct access ... - db) - (begin - (dbr:dbstruct-set-inmem! dbstruct inmem) - ;; dec 14, 2014 - keep deleted records available. hunch is that they are needed for id placeholders - ;; (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';") ;; they just slow us down in this context - (db:sync-tables db:sync-tests-only db inmem) - (db:delay-if-busy refdb) ;; dbpath: (db:dbdat-get-path refdb)) ;; What does delaying here achieve? - (dbr:dbstruct-set-refdb! dbstruct refdb) - (db:sync-tables db:sync-tests-only inmem refdb) ;; use inmem as the reference, don't read again from db - ;; sync once more to deal with delays? - ;; (db:sync-tables db:sync-tests-only db inmem) - ;; (db:sync-tables db:sync-tests-only inmem refdb) - inmem)))))) + (begin + (mutex-lock! *rundb-mutex*) + (let* ((dbpath (db:dbfile-path run-id)) ;; (conc toppath "/db/" run-id ".db")) + (dbexists (file-exists? dbpath)) + (inmem (if local #f (db:open-inmem-db))) + (refdb (if local #f (db:open-inmem-db))) + (db (db:lock-create-open dbpath ;; this is the database physically on disk + (lambda (db) + (handle-exceptions + exn + (begin + (release-dot-lock dbpath) + (if (> attemptnum 2) + (debug:print 0 "ERROR: tried twice, cannot create/initialize db for run-id " run-id ", at path " dbpath) + (db:open-rundb dbstruct run-id attemptnum (+ attemptnum 1)))) + (db:initialize-run-id-db db) + (sqlite3:execute + db + "INSERT OR IGNORE INTO tests (id,run_id,testname,event_time,item_path,state,status) VALUES (?,?,'bogustest',strftime('%s','now'),'nowherepath','DELETED','n/a');" + (* run-id 30000) ;; allow for up to 30k tests per run + run-id) + ;; do a dummy query to test that the table exists and the db is truly readable + (sqlite3:execute db "SELECT * FROM tests WHERE id=?;" (* run-id 30000)) + )))) ;; add strings db to rundb, not in use yet + ;; )) ;; (sqlite3:open-database dbpath)) + (olddb (if *megatest-db* + *megatest-db* + (let ((db (db:open-megatest-db))) + (set! *megatest-db* db) + db))) + (write-access (file-write-access? dbpath)) + ;; (handler (make-busy-timeout 136000)) + ) + (if (and dbexists (not write-access)) + (set! *db-write-access* #f)) ;; only unset so other db's also can use this control + (dbr:dbstruct-set-rundb! dbstruct (cons db dbpath)) + (dbr:dbstruct-set-inuse! dbstruct #t) + (dbr:dbstruct-set-olddb! dbstruct olddb) + ;; (dbr:dbstruct-set-run-id! dbstruct run-id) + (mutex-unlock! *rundb-mutex*) + (if local + (begin + (dbr:dbstruct-set-localdb! dbstruct run-id db) ;; (dbr:dbstruct-set-inmem! dbstruct db) ;; direct access ... + db) + (begin + (dbr:dbstruct-set-inmem! dbstruct inmem) + ;; dec 14, 2014 - keep deleted records available. hunch is that they are needed for id placeholders + ;; (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';") ;; they just slow us down in this context + (db:sync-tables db:sync-tests-only db inmem) + (db:delay-if-busy refdb) ;; dbpath: (db:dbdat-get-path refdb)) ;; What does delaying here achieve? + (dbr:dbstruct-set-refdb! dbstruct refdb) + (db:sync-tables db:sync-tests-only inmem refdb) ;; use inmem as the reference, don't read again from db + ;; sync once more to deal with delays? + ;; (db:sync-tables db:sync-tests-only db inmem) + ;; (db:sync-tables db:sync-tests-only inmem refdb) + inmem))))))) ;; This routine creates the db. It is only called if the db is not already ls opened ;; (define (db:open-main dbstruct) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) (let ((mdb (dbr:dbstruct-get-main dbstruct))) (if mdb mdb - (let* ((dbpath (db:dbfile-path 0)) - (dbexists (file-exists? dbpath)) - (db (db:lock-create-open dbpath db:initialize-main-db)) - (olddb (db:open-megatest-db)) - (write-access (file-write-access? dbpath)) - (dbdat (cons db dbpath))) - (if (and dbexists (not write-access)) - (set! *db-write-access* #f)) - (dbr:dbstruct-set-main! dbstruct dbdat) - (dbr:dbstruct-set-olddb! dbstruct olddb) ;; olddb is already a (cons db path) - dbdat)))) + (begin + (mutex-lock! *rundb-mutex*) + (let* ((dbpath (db:dbfile-path 0)) + (dbexists (file-exists? dbpath)) + (db (db:lock-create-open dbpath db:initialize-main-db)) + (olddb (db:open-megatest-db)) + (write-access (file-write-access? dbpath)) + (dbdat (cons db dbpath))) + (if (and dbexists (not write-access)) + (set! *db-write-access* #f)) + (dbr:dbstruct-set-main! dbstruct dbdat) + (dbr:dbstruct-set-olddb! dbstruct olddb) ;; olddb is already a (cons db path) + (mutex-unlock! *rundb-mutex*) + (if (and (not dbexists) + *db-write-access*) ;; did not have a prior db and do have write access + (db:multi-db-sync #f 'old2new)) ;; migrate data from megatest.db automatically + dbdat))))) ;; Make the dbstruct, setup up auxillary db's and call for main db at least once ;; (define (db:setup run-id #!key (local #f)) - (let* ((dbdir (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) + (let* ((dbdir (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) (dbstruct (make-dbr:dbstruct path: dbdir local: local))) dbstruct)) ;; Open the classic megatest.db file in toppath ;; @@ -2072,11 +2082,11 @@ "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=?;" test-id))) res)) ;; get a useful subset of the tests data (used in dashboard -;; use db:mintests-get-{id ,run_id,testname ...} +;; use db:mintest-get-{id ,run_id,testname ...} ;; (define (db:get-tests-for-runs-mindata dbstruct run-ids testpatt states statuses not-in) (debug:print 0 "ERROR: BROKN!") ;; (db:get-tests-for-runs dbstruct run-ids testpatt states statuses not-in: not-in qryvals: "id,run_id,testname,state,status,event_time,item_path")) ) @@ -2211,10 +2221,23 @@ (lambda (db) (sqlite3:first-result db "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=? AND NOT (uname = 'n/a' AND item_path = '');" run-id)))) +;; For a given testname how many items are running? Used to determine +;; probability for regenerating html +;; +(define (db:get-count-tests-running-for-testname dbstruct run-id testname) + (db:with-db + dbstruct + run-id + #f + (lambda (db) + (sqlite3:first-result + db + "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=? AND NOT (uname = 'n/a' AND item_path = '') AND testname=?;" run-id testname)))) + (define (db:get-count-tests-running-in-jobgroup dbstruct run-id jobgroup) (let* ((dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) (if (not jobgroup) 0 ;; @@ -2237,11 +2260,11 @@ (sqlite3:first-result db (conc "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND testname in ('" (string-intersperse testnames "','") "') AND NOT (uname = 'n/a' AND item_path='');")) ;; should this include the (uname = 'n/a' ...) ??? - 0))))))) + ))))))) ;; DEBUG FIXME - need to merge this v.155 query correctly ;; AND testname in (SELECT testname FROM test_meta WHERE jobgroup=?) ;; AND NOT (uname = 'n/a' AND item_path = '');" ;; done with run when: Index: db_records.scm ================================================================== --- db_records.scm +++ db_records.scm @@ -89,10 +89,14 @@ ;; (define-inline (db:test-get-pass_count vec) (vector-ref vec 15)) ;; (define-inline (db:test-get-fail_count vec) (vector-ref vec 16)) (define-inline (db:test-get-fullname vec) (conc (db:test-get-testname vec) "/" (db:test-get-item-path vec))) +;; replace runs:make-full-test-name with this routine +(define (db:test-make-full-name testname itempath) + (if (equal? itempath "") testname (conc testname "/" itempath))) + (define-inline (db:test-get-first_err vec) (printable (vector-ref vec 15))) (define-inline (db:test-get-first_warn vec) (printable (vector-ref vec 16))) (define-inline (db:test-set-cpuload! vec val)(vector-set! vec 7 val)) (define-inline (db:test-set-diskfree! vec val)(vector-set! vec 8 val)) @@ -198,10 +202,12 @@ (define-inline (tdb:steps-table-get-stepname vec) (vector-ref vec 0)) (define-inline (tdb:steps-table-get-start vec) (vector-ref vec 1)) (define-inline (tdb:steps-table-get-end vec) (vector-ref vec 2)) (define-inline (tdb:steps-table-get-status vec) (vector-ref vec 3)) (define-inline (tdb:steps-table-get-runtime vec) (vector-ref vec 4)) +(define-inline (tdb:steps-table-get-log-file vec) (vector-ref vec 5)) + (define-inline (tdb:step-stable-set-stepname! vec val)(vector-set! vec 0 val)) (define-inline (tdb:step-stable-set-start! vec val)(vector-set! vec 1 val)) (define-inline (tdb:step-stable-set-end! vec val)(vector-set! vec 2 val)) (define-inline (tdb:step-stable-set-status! vec val)(vector-set! vec 3 val)) (define-inline (tdb:step-stable-set-runtime! vec val)(vector-set! vec 4 val)) Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -98,10 +98,19 @@ ;; Look up test-ids by (key1 key2 ... testname [itempath]) (dboard:data-set-path-test-ids! *data* (make-hash-table)) ;; Look up run-ids by ?? (dboard:data-set-path-run-ids! *data* (make-hash-table)) + +;;====================================================================== +;; D O T F I L E +;;====================================================================== + +(define (dcommon:write-dotfile fname dat) + (with-output-to-file fname + (lambda () + (pp dat)))) ;;====================================================================== ;; TARGET AND PATTERN MANIPULATIONS ;;====================================================================== @@ -543,25 +552,32 @@ ;; The main menu (define (dcommon:main-menu) (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top) (iup:menu-item "Files" (iup:menu ;; Note that you can use either #:action or action: for options - (iup:menu-item "Open" action: (lambda (obj) - (iup:show (iup:file-dialog)) - (print "File->open " obj))) - (iup:menu-item "Save" #:action (lambda (obj)(print "File->save " obj))) - (iup:menu-item "Exit" #:action (lambda (obj)(exit))))) + (iup:menu-item "Open" action: (lambda (obj) + (let* ((area-name (iup:textbox #:expand "HORIZONTAL")) + (fd (iup:file-dialog #:dialogtype "DIR")) + (top (iup:show fd #:modal? "YES"))) + (iup:attribute-set! source-tb "VALUE" + (iup:attribute fd "VALUE")) + (iup:destroy! fd)))) + ;; (lambda (obj) + ;; (iup:show (iup:file-dialog)) + ;; (print "File->open " obj))) + (iup:menu-item "Save" #:action (lambda (obj)(print "File->save " obj))) + (iup:menu-item "Exit" #:action (lambda (obj)(exit))))) (iup:menu-item "Tools" (iup:menu - (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah"))) - ;; (iup:menu-item "Show dialog" #:action (lambda (obj) - ;; (show message-window - ;; #:modal? #t - ;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current - ;; ;; #:x 'mouse - ;; ;; #:y 'mouse - ;; ) - )))) + (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah"))) + ;; (iup:menu-item "Show dialog" #:action (lambda (obj) + ;; (show message-window + ;; #:modal? #t + ;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current + ;; ;; #:x 'mouse + ;; ;; #:y 'mouse + ;; ) + )))) ;;====================================================================== ;; CANVAS STUFF FOR TESTS ;;====================================================================== @@ -648,99 +664,10 @@ ;;====================================================================== ;; S T E P S ;;====================================================================== -;; CHECK - WAS THIS ADDED OR REMOVED? MANUAL MERGE WITH API STUFF!!! -;; -;; get a pretty table to summarize steps -;; -(define (dcommon:process-steps-table steps);; db test-id #!key (work-area #f)) -;; (let ((steps (db:get-steps-for-test db test-id work-area: work-area))) - ;; organise the steps for better readability - (let ((res (make-hash-table))) - (for-each - (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) "" "" "" "" "")))) - (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) - "\ntime: " (tdb:step-get-event_time step)) - (case (string->symbol (tdb:step-get-state step)) - ((start)(vector-set! record 1 (tdb:step-get-event_time step)) - (vector-set! record 3 (if (equal? (vector-ref record 3) "") - (tdb:step-get-status step))) - (if (> (string-length (tdb:step-get-logfile step)) - 0) - (vector-set! record 5 (tdb:step-get-logfile step)))) - ((end) - (vector-set! record 2 (any->number (tdb:step-get-event_time step))) - (vector-set! record 3 (tdb:step-get-status step)) - (vector-set! record 4 (let ((startt (any->number (vector-ref record 1))) - (endt (any->number (vector-ref record 2)))) - (debug:print 4 "record[1]=" (vector-ref record 1) - ", startt=" startt ", endt=" endt - ", 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)))) - (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)))) - (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) - "\nstatus: " (tdb:step-get-status step) - "\ntime: " (tdb:step-get-event_time step)))) - ;; (else (vector-set! record 1 (tdb:step-get-event_time step))) - (sort steps (lambda (a b) - (cond - ((< (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t) - ((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)) - -(define (dcommon:get-compressed-steps dbstruct run-id test-id) - (let* ((steps-data (db:get-steps-for-test dbstruct run-id test-id)) - (comprsteps (dcommon: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) - (let ((s (vector-ref x 1))) - (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 - (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)) - (if (< time-a time-b) - #t - (if (eq? time-a time-b) - (string

Reference

+
+

Config File Settings

+
+
+

Trim trailing spaces

+
+
+
[configf:settings trim-trailing-spaces yes]
+
+
+
+

The testconfig File

Setup section

@@ -1352,10 +1364,11 @@
Index: docs/manual/reference.txt ================================================================== --- docs/manual/reference.txt +++ docs/manual/reference.txt @@ -1,8 +1,18 @@ Reference ========= + +Config File Settings +-------------------- + +Trim trailing spaces +~~~~~~~~~~~~~~~~~~~~ + +------------------ +[configf:settings trim-trailing-spaces yes] +------------------ The testconfig File ------------------- Setup section Index: docs/manual/server.png ================================================================== --- docs/manual/server.png +++ docs/manual/server.png cannot compute difference between binary files Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -53,10 +53,11 @@ (let ((res #f)) (for-each (lambda (adr) (if (not (eq? (u8vector-ref adr 0) 127)) (set! res adr))) + ;; NOTE: This can fail when there is no mention of the host in /etc/hosts. FIXME (vector->list (hostinfo-addresses (hostname->hostinfo hostname)))) (string-intersperse (map number->string (u8vector->list (if res res (hostname->ip hostname)))) "."))) @@ -272,15 +273,16 @@ (set! success #f) (debug:print 0 "WARNING: failure in with-input-from-request to " fullurl ".") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (hash-table-delete! *runremote* run-id) ;; Killing associated server to allow clean retry.") - (tasks:kill-server-run-id run-id) ;; better to kill the server in the logic that called this routine? + ;; (tasks:kill-server-run-id run-id) ;; better to kill the server in the logic that called this routine? (mutex-unlock! *http-mutex*) - (signal (make-composite-condition - (make-property-condition 'commfail 'message "failed to connect to server"))) - "communications failed") + ;;; (signal (make-composite-condition + ;;; (make-property-condition 'commfail 'message "failed to connect to server"))) + ;;; "communications failed" + (db:obj->string #f)) (with-input-from-request ;; was dat fullurl (list (cons 'key "thekey") (cons 'cmd cmd) (cons 'params sparams)) Index: items.scm ================================================================== --- items.scm +++ items.scm @@ -16,29 +16,10 @@ (declare (unit items)) (declare (uses common)) (include "common_records.scm") -;; Puts out all combinations -(define (process-itemlist hierdepth curritemkey itemlist) - (let ((res '())) - (if (not hierdepth) - (set! hierdepth (length itemlist))) - (let loop ((hed (car itemlist)) - (tal (cdr itemlist))) - (if (null? tal) - (for-each (lambda (item) - (if (> (length curritemkey) (- hierdepth 2)) - (set! res (append res (list (append curritemkey (list (list (car hed) item)))))))) - (cadr hed)) - (begin - (for-each (lambda (item) - (set! res (append res (process-itemlist hierdepth (append curritemkey (list (list (car hed) item))) tal)))) - (cadr hed)) - (loop (car tal)(cdr tal))))) - res)) - ;; Puts out all combinations (define (process-itemlist hierdepth curritemkey itemlist) (let ((res '())) (if (not hierdepth) (set! hierdepth (length itemlist))) ADDED iupexamples/graph.scm Index: iupexamples/graph.scm ================================================================== --- /dev/null +++ iupexamples/graph.scm @@ -0,0 +1,62 @@ +(use iup) +(import iup-pplot) + + + +(define (tl) + (let* ((lastx 0) + (lastsample 2) + (plt (pplot + #:title "MyTitle" + #:marginbottom "65" + #:marginleft "65" + #:axs_xlabel "Score" + #:axs_ylabel "Count" + #:legendshow "YES" + ;; #:axs_xmin "0" + ;; #:axs_ymin "0" + #:axs_yautomin "YES" + #:axs_xautomin "YES" + #:axs_xautotick "YES" + #:axs_yautotick "YES" + #:ds_showvalues "YES" + #:size "200x200" + )) + (plt1 (call-with-pplot + plt + (lambda (x) + (pplot-add! plt 10 100) + (pplot-add! plt 20 120) + (pplot-add! plt 30 200)) + #:x-string #f + )) + (plt2 (call-with-pplot + plt + (lambda (x) + (pplot-add! plt 10 180) + (pplot-add! plt 20 125) + (pplot-add! plt 30 100)) + #:x-string #f + )) + (dlg (dialog + (vbox + plt + (hbox + ;; (button "Redraw" size: "50x" action: (lambda (obj) + ;; (redraw plt))) + (button "Quit" size: "50x" action: (lambda (obj) + (exit))) + (button "AddPoint" size: "50x" action: (lambda (obj) + (set! lastx (+ lastx 10)) + (set! lastsample (+ lastsample 1)) + ;; (attribute-set! plt 'current 0) + (print "lastx: " lastx " lastsample: " lastsample) + (pplot-add! plt lastx (random 300) lastsample 1) + (attribute-set! plt "REDRAW" "1")))))))) + (set! lastx 30) + (attribute-set! plt 'ds_mode "LINE") + ;; (attribute-set! plt 'ds_legend "Yada") + (show dlg) + (main-loop))) + +(tl) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -11,11 +11,12 @@ ;;====================================================================== ;; launch a task - this runs on the originating host, tests themselves ;; ;;====================================================================== -(use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3) +(use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3 call-with-environment-variables) + (import (prefix base64 base64:)) (import (prefix sqlite3 sqlite3:)) (declare (unit launch)) (declare (uses common)) @@ -51,10 +52,115 @@ (let ((enccmd (if encoded-cmd encoded-cmd (getenv "MT_CMDINFO")))) (if enccmd (common:read-encoded-string enccmd) '()))) + +(define (launch:runstep ezstep run-id test-id exit-info m tal) + (let* ((stepname (car ezstep)) ;; do stuff to run the step + (stepinfo (cadr ezstep)) + (stepparts (string-match (regexp "^(\\{([^\\}]*)\\}\\s*|)(.*)$") stepinfo)) + (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")) + (logpro-used (file-exists? logpro-file))) + ;; NB// can safely assume we are in test-area directory + (debug:print 4 "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts + " stepparms: " stepparms " stepcmd: " stepcmd) + + ;; ;; first source the previous environment + ;; (let ((prev-env (conc ".ezsteps/" prevstep (if (string-search (regexp "csh") + ;; (get-environment-variable "SHELL")) ".csh" ".sh")))) + ;; (if (and prevstep (file-exists? prev-env)) + ;; (set! script (conc script "source " prev-env)))) + + ;; call the command using mt_ezstep + ;; (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "x") " " stepcmd)) + + (debug:print 4 "script: " script) + (rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f) + ;; now launch the actual process + (call-with-environment-variables + (list (cons "PATH" (conc (get-environment-variable "PATH") ":."))) + (lambda () ;; (process-run "/bin/bash" "-c" "exec ls -l /tmp/foobar > /tmp/delme-more.log 2>&1") + (let* ((cmd (conc "exec " stepcmd " > " stepname ".log 2>&1")) ;; >outfile 2>&1 + (pid (process-run "/bin/bash" (list "-c" cmd)))) + (rmt:test-set-top-process-pid run-id test-id pid) + (let processloop ((i 0)) + (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) + (mutex-lock! m) + (vector-set! exit-info 0 pid) + (vector-set! exit-info 1 exit-status) + (vector-set! exit-info 2 exit-code) + (mutex-unlock! m) + (if (eq? pid-val 0) + (begin + (thread-sleep! 2) + (processloop (+ i 1)))) + ))))) + (debug:print-info 0 "step " stepname " completed with exit code " (vector-ref exit-info 2)) + ;; now run logpro if needed + (if logpro-used + (let ((pid (process-run (conc "logpro " logpro-file " " (conc stepname ".html") " < " stepname ".log")))) + (let processloop ((i 0)) + (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) + (mutex-lock! m) + (vector-set! exit-info 0 pid) + (vector-set! exit-info 1 exit-status) + (vector-set! exit-info 2 exit-code) + (mutex-unlock! m) + (if (eq? pid-val 0) + (begin + (thread-sleep! 2) + (processloop (+ i 1))))) + (debug:print-info 0 "logpro for step " stepname " exited with code " (vector-ref exit-info 2))))) + + (let ((exinfo (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"))) + ;; set the test final status + (let* ((this-step-status (cond + ((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn) + ((eq? (vector-ref exit-info 2) 0) 'pass) + (else 'fail))) + (overall-status (cond + ((eq? (vector-ref exit-info 3) 2) 'warn) ;; rollup-status + ((eq? (vector-ref exit-info 3) 0) 'pass) + (else 'fail))) + (next-status (cond + ((eq? overall-status 'pass) this-step-status) + ((eq? overall-status 'warn) + (if (eq? this-step-status 'fail) 'fail 'warn)) + (else 'fail))) + (next-state ;; "RUNNING") ;; WHY WAS THIS CHANGED TO NOT USE (null? tal) ?? + (cond + ((null? tal) ;; more to run? + "COMPLETED") + (else "RUNNING"))) + ) + (debug:print 4 "Exit value received: " (vector-ref exit-info 2) " logpro-used: " logpro-used + " this-step-status: " this-step-status " overall-status: " overall-status + " next-status: " next-status " rollup-status: " (vector-ref exit-info 3)) + (case next-status + ((warn) + (vector-set! exit-info 3 2) ;; rollup-status + ;; NB// test-set-status! does rdb calls under the hood + (tests:test-set-status! run-id test-id next-state "WARN" + (if (eq? this-step-status 'warn) "Logpro warning found" #f) + #f)) + ((pass) + (tests:test-set-status! run-id test-id next-state "PASS" #f #f)) + (else ;; 'fail + (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:execute encoded-cmd) (let* ((cmdinfo (common:read-encoded-string encoded-cmd))) (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)) @@ -88,20 +194,24 @@ (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) + ) (change-directory top-path) ;; (set-signal-handler! signal/int (lambda () - ;; Do not run the test if it is REMOVING, RUNNING, KILLREQ or REMOTEHOSTSTART, + ;; WAS: Do not run the test if it is REMOVING, RUNNING, KILLREQ or REMOTEHOSTSTART, + ;; NOW: Do not run test test unless state is LAUNCHED ;; Mark the test as REMOTEHOSTSTART *IMMEDIATELY* ;; + ;; This is flawed. It should be a single transaction that tests for NOT_STARTED and updates to REMOTEHOSTSTART + ;; (let ((test-info (rmt:get-testinfo-state-status run-id test-id))) - (if (not (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ"))) + (if (equal? (db:test-get-state test-info) "LAUNCHED") ;; '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ"))) (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a") (begin (debug:print 0 "ERROR: test state is " (db:test-get-state test-info) ", cannot proceed") (exit)))) @@ -197,11 +307,11 @@ ;; any previous runs ;; (db:test-remove-steps db run-id testname itemdat) (let* ((m (make-mutex)) (kill-job? #f) - (exit-info (vector #t #t #t)) + (exit-info (vector #t #t #t 0)) (job-thread #f) (keep-going #t) (runit (lambda () ;; (let-values ;; (((pid exit-status exit-code) @@ -210,14 +320,14 @@ ;; 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) + ;; (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 "RUNNING") - (thread-sleep! 0.3) ;; NFS slowness has caused grief here + ;; (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) @@ -226,11 +336,11 @@ (((pid-val exit-status exit-code) (process-wait pid #t))) (mutex-lock! m) (vector-set! exit-info 0 pid) (vector-set! exit-info 1 exit-status) (vector-set! exit-info 2 exit-code) - (set! rollup-status 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))) @@ -248,90 +358,11 @@ (let loop ((ezstep (car ezstepslst)) (tal (cdr ezstepslst)) (prevstep #f)) ;; check exit-info (vector-ref exit-info 1) (if (vector-ref exit-info 1) - (let* ((stepname (car ezstep)) ;; do stuff to run the step - (stepinfo (cadr ezstep)) - (stepparts (string-match (regexp "^(\\{([^\\}]*)\\}\\s*|)(.*)$") stepinfo)) - (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-used #f)) - ;; NB// can safely assume we are in test-area directory - (debug:print 4 "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts - " stepparms: " stepparms " stepcmd: " stepcmd) - - (if (file-exists? (conc stepname ".logpro"))(set! logpro-used #t)) - - ;; ;; first source the previous environment - ;; (let ((prev-env (conc ".ezsteps/" prevstep (if (string-search (regexp "csh") - ;; (get-environment-variable "SHELL")) ".csh" ".sh")))) - ;; (if (and prevstep (file-exists? prev-env)) - ;; (set! script (conc script "source " prev-env)))) - - ;; call the command using mt_ezstep - (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd)) - - (debug:print 4 "script: " script) - (rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f) - ;; now launch - (let ((pid (process-run script))) - (rmt:test-set-top-process-pid run-id test-id pid) - (let processloop ((i 0)) - (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) - (mutex-lock! m) - (vector-set! exit-info 0 pid) - (vector-set! exit-info 1 exit-status) - (vector-set! exit-info 2 exit-code) - (mutex-unlock! m) - (if (eq? pid-val 0) - (begin - (thread-sleep! 2) - (processloop (+ i 1)))) - )) - (let ((exinfo (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"))) - ;; set the test final status - (let* ((this-step-status (cond - ((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn) - ((eq? (vector-ref exit-info 2) 0) 'pass) - (else 'fail))) - (overall-status (cond - ((eq? rollup-status 2) 'warn) - ((eq? rollup-status 0) 'pass) - (else 'fail))) - (next-status (cond - ((eq? overall-status 'pass) this-step-status) - ((eq? overall-status 'warn) - (if (eq? this-step-status 'fail) 'fail 'warn)) - (else 'fail))) - (next-state ;; "RUNNING") ;; WHY WAS THIS CHANGED TO NOT USE (null? tal) ?? - (cond - ((null? tal) ;; more to run? - "COMPLETED") - (else "RUNNING"))) - ) - (debug:print 4 "Exit value received: " (vector-ref exit-info 2) " logpro-used: " logpro-used - " this-step-status: " this-step-status " overall-status: " overall-status - " next-status: " next-status " rollup-status: " rollup-status) - (case next-status - ((warn) - (set! rollup-status 2) - ;; NB// test-set-status! does rdb calls under the hood - (tests:test-set-status! run-id test-id next-state "WARN" - (if (eq? this-step-status 'warn) "Logpro warning found" #f) - #f)) - ((pass) - (tests:test-set-status! run-id test-id next-state "PASS" #f #f)) - (else ;; 'fail - (set! rollup-status 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) - )))) + (let ((logpro-used (launch:runstep ezstep run-id test-id exit-info m tal))) (if (and (steprun-good? logpro-used (vector-ref exit-info 2)) (not (null? tal))) (loop (car tal) (cdr tal) stepname))) (debug:print 4 "WARNING: a prior step failed, stopping at " ezstep)))))))) (monitorjob (lambda () @@ -374,16 +405,25 @@ 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 ")") - (if (process:alive? pid) - (begin - (process-signal pid signal/int) - (thread-sleep! 5) - (if (process:process-alive? pid) - (process-signal pid signal/kill)))))) + (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) @@ -417,30 +457,32 @@ ;; "COMPLETED" ;; (db:test-get-state testinfo))) ;; else preseve the state as set within the test ) (new-status (cond ((not (vector-ref exit-info 1)) "FAIL") ;; job failed to run - ((eq? rollup-status 0) + ((eq? (vector-ref exit-info 3) 0) ;; if the current status is AUTO then defer to the calculated value (i.e. leave this AUTO) (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO" "PASS")) - ((eq? rollup-status 1) "FAIL") - ((eq? rollup-status 2) + ((eq? (vector-ref exit-info 3) 1) "FAIL") + ((eq? (vector-ref exit-info 3) 2) ;; if the current status is AUTO the defer to the calculated value but qualify (i.e. make this AUTO-WARN) (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO-WARN" "WARN")) (else "FAIL")))) ;; (db:test-get-status testinfo))) - (debug:print-info 1 "Test exited in state=" (db:test-get-state testinfo) ", setting state/status based on exit code of " (vector-ref exit-info 1) " and rollup-status of " rollup-status) + (debug:print-info 1 "Test exited in state=" (db:test-get-state testinfo) ", setting state/status based on exit code of " (vector-ref exit-info 1) " and rollup-status of " (vector-ref exit-info 3)) (tests:test-set-status! run-id test-id new-state new-status (args:get-arg "-m") #f) ;; need to update the top test record if PASS or FAIL and this is a subtest ;; NO NEED TO CALL roll-up-pass-fail-counts HERE, THIS IS DONE IN roll-up-pass-fail-counts called by tests:test-set-status! )) ;; for automated creation of the rollup html file this is a good place... - (if (not (equal? item-path "")) - (tests:summarize-items run-id test-id test-name #f))) ;; don't force - just update if no + ;; (if (and (not (equal? item-path "")) + ;; (< (random (rmt:get-count-tests-running-for-testname run-id test-name)) 5)) + (tests:summarize-items run-id test-id test-name #f) + (tests:summarize-test run-id test-id)) ;; don't force - just update if no (mutex-unlock! m) (debug:print 2 "Output from running " fullrunscript ", pid " (vector-ref exit-info 0) " in work area " work-area ":\n====\n exit code " (vector-ref exit-info 2) "\n" "====\n") (if (not (vector-ref exit-info 1)) (exit 4))))))) @@ -461,15 +503,17 @@ (if (file-exists? alistconfig) (list (configf:read-alist alistconfig) (get-environment-variable "MT_RUN_AREA_HOME")) #f)) #f) ;; no config cached - give up - (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"))) + (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)) @@ -784,11 +828,10 @@ (toptest-work-area #f) ;; for iterated tests the top test contains data relevant for all (diskpath #f) (cmdparms #f) (fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x)))) (mt-bindir-path #f) - ;; (test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path)) (testinfo (rmt:get-test-info-by-id run-id test-id)) (mt_target (string-intersperse (map cadr keyvals) "/")) (debug-param (append (if (args:get-arg "-debug") (list "-debug" (args:get-arg "-debug")) '()) (if (args:get-arg "-logging")(list "-logging") '())))) (setenv "MT_ITEMPATH" item-path) @@ -842,11 +885,19 @@ (list 'runname runname) (list 'mt-bindir-path mt-bindir-path)))))))) ;; clean out step records from previous run if they exist ;; (rmt:delete-test-step-records run-id test-id) - (change-directory work-area) ;; so that log files from the launch process don't clutter the test dir + + ;; Moving launch logs to MT_RUN_AREA_HOME/logs + ;; + (let ((launchdir (configf:lookup *configdat* "setup" "launchdir"))) ;; (change-directory work-area) ;; so that log files from the launch process don't clutter the test dir + (if (not launchdir) ;; default + (change-directory (conc *toppath* "/logs")) ;; can assume this exists + (case (string->symbol launchdir) + ((legacy)(change-directory work-area)) + (else (change-directory launchdir))))) (cond ((and launcher hosts) ;; must be using ssh hostname (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms) debug-param))) ;; (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms)))) (launcher @@ -880,18 +931,18 @@ process-run) (if useshell (let ((cmdstr (string-intersperse fullcmd " "))) (if launchwait cmdstr - (conc cmdstr " >> mt_launch.log 2>&1"))) + (conc cmdstr " >> " work-area "/mt_launch.log 2>&1"))) (car fullcmd)) (if useshell '() (cdr fullcmd))))) (if (not launchwait) ;; give the OS a little time to allow the process to start (thread-sleep! 0.01)) - (with-output-to-file "mt_launch.log" + (with-output-to-file (conc work-area "/mt_launch.log") (lambda () (if (list? launch-results) (apply print launch-results) (print "NOTE: launched \"" fullcmd "\"\n but did not wait for it to proceed. Add the following to megatest.config \n[setup]\nlaunchwait yes\n if you have problems with this")) #:append)) Index: lock-queue.scm ================================================================== --- lock-queue.scm +++ lock-queue.scm @@ -26,10 +26,14 @@ (define (make-lock-queue:db-dat)(make-vector 3)) (define-inline (lock-queue:db-dat-get-db vec) (vector-ref vec 0)) (define-inline (lock-queue:db-dat-get-path vec) (vector-ref vec 1)) (define-inline (lock-queue:db-dat-set-db! vec val)(vector-set! vec 0 val)) (define-inline (lock-queue:db-dat-set-path! vec val)(vector-set! vec 1 val)) + +(define (lock-queue:delete-lock-db dbdat) + (let ((fname (lock-queue:db-dat-get-path dbdat))) + (system (conc "rm -f " fname "*")))) (define (lock-queue:open-db fname #!key (count 10)) (let* ((actualfname (conc fname ".lockdb")) (dbexists (file-exists? actualfname)) (db (sqlite3:open-database actualfname)) @@ -81,18 +85,20 @@ (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "UPDATE queue SET state=? WHERE test_id=?;" newstate test-id))) (define (lock-queue:any-younger? dbdat mystart test-id #!key (remtries 10)) - (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200) + ;; no need to wait on journal on read only queries + ;; (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200) (handle-exceptions exn (if (> remtries 0) (begin - (debug:print 0 "WARNING: exception on lock-queue:any-younger. Trying again in 30 seconds.") + (debug:print 0 "WARNING: exception on lock-queue:any-younger. Removing lockdb and trying again in 5 seconds.") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) - (thread-sleep! 30) + (thread-sleep! 5) + (lock-queue:delete-lock-db dbdat) (lock-queue:any-younger? dbdat mystart test-id remtries: (- remtries 1))) (begin (debug:print 0 "ERROR: Failed to find younger locks for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.") #f)) (let ((res #f)) @@ -113,15 +119,17 @@ (mklckqry (sqlite3:prepare db "INSERT INTO runlocks (test_id,run_lock) VALUES (?,'locked');"))) (let ((result (handle-exceptions exn (begin - (debug:print 0 "WARNING: failed to get queue lock. Will try again in a few seconds") + (debug:print 0 "WARNING: failed to get queue lock. Removing lock db and returning fail") ;; Will try again in a few seconds") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (thread-sleep! 10) - (if (> count 0) - (lock-queue:get-lock dbdat test-id count: (- count 1))) + ;; (if (> count 0) + ;; #f ;; (lock-queue:get-lock dbdat test-id count: (- count 1)) - give up on retries + ;; (begin ;; never recovered, remote the lock file and return #f, no lock obtained + (lock-queue:delete-lock-db dbdat) #f) (sqlite3:with-transaction db (lambda () (sqlite3:for-each-row (lambda (tid lockstate) @@ -139,10 +147,11 @@ (sqlite3:finalize! mklckqry) result))) (define (lock-queue:release-lock fname test-id #!key (count 10)) (let* ((dbdat (lock-queue:open-db fname))) + (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 "lock-queue:release-lock; waiting on journal") (handle-exceptions exn (begin (debug:print 0 "WARNING: Failed to release queue lock. Will try again in few seconds") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) @@ -167,11 +176,11 @@ (debug:print-info 0 "Attempting to steal lock at " (lock-queue:db-dat-get-path dbdat)) (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 "lock-queue:steal-lock; waiting on journal") (handle-exceptions exn (begin - (debug:print 0 "WARNING: Failed to steal queue lock. Will try again in few seconds") + (tadebug:print 0 "WARNING: Failed to steal queue lock. Will try again in few seconds") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (thread-sleep! 10) (if (> count 0) (lock-queue:steal-lock dbdat test-id count: (- count 1)) #f)) @@ -184,10 +193,11 @@ ;; (define (lock-queue:wait-turn fname test-id #!key (count 10)(waiting-msg #f)) (let* ((dbdat (lock-queue:open-db fname)) (mystart (current-seconds)) (db (lock-queue:db-dat-get-db dbdat))) + ;; (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 waiting-msg: "lock-queue:wait-turn; waiting on journal file") (handle-exceptions exn (begin (debug:print 0 "WARNING: Failed to find out if it is ok to skip the wait queue. Will try again in few seconds") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) @@ -199,31 +209,37 @@ (lock-queue:wait-turn fname test-id count: (- count 1))) (begin (debug:print 0 "Giving up calls to lock-queue:wait-turn for test-id " test-id " at path " fname ", printing call chain") (print-call-chain (current-error-port)) #f))) - (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 waiting-msg: "lock-queue:wait-turn; waiting on journal file") - (sqlite3:execute - db - "INSERT OR REPLACE INTO queue (test_id,start_time,state) VALUES (?,?,'waiting');" - test-id mystart) - (thread-sleep! 1) ;; give other tests a chance to register - (let ((result - (let loop ((younger-waiting (lock-queue:any-younger? dbdat mystart test-id))) - (if younger-waiting - (begin - ;; no need for us to wait. mark in the lock queue db as skipping - (lock-queue:set-state dbdat test-id "skipping") - #f) ;; let the calling process know that nothing needs to be done - (if (lock-queue:get-lock dbdat test-id) - #t - (if (> (- (current-seconds) mystart) 36000) ;; waited too long, steal the lock - (lock-queue:steal-lock dbdat test-id) - (begin - (thread-sleep! 1) - (loop (lock-queue:any-younger? dbdat mystart test-id))))))))) - (sqlite3:finalize! db) - result)))) + ;; wait 10 seconds and then check to see if someone is already updating the html + (thread-sleep! 10) + (if (not (lock-queue:any-younger? dbdat mystart test-id)) ;; no processing in flight, must try to start processing + (begin + (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 waiting-msg: "lock-queue:wait-turn; waiting on journal file") + (sqlite3:execute + db + "INSERT OR REPLACE INTO queue (test_id,start_time,state) VALUES (?,?,'waiting');" + test-id mystart) + ;; (thread-sleep! 1) ;; give other tests a chance to register + (let ((result + (let loop ((younger-waiting (lock-queue:any-younger? dbdat mystart test-id))) + (if younger-waiting + (begin + ;; no need for us to wait. mark in the lock queue db as skipping + ;; no point in marking anything in the queue - simply never register this + ;; test as it is *covered* by a previously started update to the html file + ;; (lock-queue:set-state dbdat test-id "skipping") + #f) ;; let the calling process know that nothing needs to be done + (if (lock-queue:get-lock dbdat test-id) + #t + (if (> (- (current-seconds) mystart) 36000) ;; waited too long, steal the lock + (lock-queue:steal-lock dbdat test-id) + (begin + (thread-sleep! 1) + (loop (lock-queue:any-younger? dbdat mystart test-id))))))))) + (sqlite3:finalize! db) + result)))))) ;; (use trace) ;; (trace lock-queue:get-lock lock-queue:release-lock lock-queue:wait-turn lock-queue:any-younger? lock-queue:set-state) 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.. (declare (unit megatest-version)) -(define megatest-version 1.6007) +(define megatest-version 1.6012) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -8,20 +8,24 @@ ;; PURPOSE. ;; (include "common.scm") ;; (include "megatest-version.scm") -(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 format readline apropos json http-client directory-utils rpc ;; (srfi 18) extras) - http-client srfi-18) ;; zmq extras) +;; fake out readline usage of toplevel-command +(define (toplevel-command . a) #f) + +(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 readline apropos json http-client directory-utils rpc ;; (srfi 18) extras) + http-client srfi-18 extras format) ;; zmq extras) ;; Added for csv stuff - will be removed ;; (use sparse-vectors) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) (import (prefix rpc rpc:)) +(require-library mutils) ;; (use zmq) (declare (uses common)) (declare (uses megatest-version)) @@ -330,11 +334,11 @@ (hash-table-keys *db-local-sync*)) (if (and debug-mode (> (- start-time last-time) 60)) (begin (set! last-time start-time) - (debug:print-info 1 "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*)))))) + (debug:print-info 4 "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*)))))) ;; keep going unless time to exit ;; (if (not *time-to-exit*) (let delay-loop ((count 0)) @@ -887,15 +891,17 @@ "%")) (keys (db:get-keys dbstruct)) ;; (runsdat (db:get-runs dbstruct runpatt #f #f '())) (runsdat (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target) #f #f)) - ;; (cdb:remote-run db:get-runs #f runpatt #f #f '())) (runs (db:get-rows runsdat)) (header (db:get-header runsdat)) (db-targets (args:get-arg "-list-db-targets")) - (seen (make-hash-table))) + (seen (make-hash-table)) + (dmode (let ((d (args:get-arg "-dumpmode"))) + (if d (string->symbol d) #f))) + (data (make-hash-table))) ;; Each run (for-each (lambda (run) (let ((targetstr (string-intersperse (map (lambda (x) (db:get-value-by-header run header x)) @@ -903,56 +909,78 @@ (if db-targets (if (not (hash-table-ref/default seen targetstr #f)) (begin (hash-table-set! seen targetstr #t) ;; (print "[" targetstr "]")))) - (print targetstr)))) - (if (not db-targets) - (let* ((run-id (db:get-value-by-header run header "id")) + (if (not dmode)(print targetstr)))) + (let* ((run-id (db:get-value-by-header run header "id")) + (runname (db:get-value-by-header run header "runname")) (tests (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc #f))) - (print "Run: " targetstr "/" (db:get-value-by-header run header "runname") - " status: " (db:get-value-by-header run header "state") - " run-id: " run-id ", number tests: " (length tests)) + (case dmode + ((json) + (mutils:hierhash-set! data (db:get-value-by-header run header "status") targetstr runname "meta" "status" ) + (mutils:hierhash-set! data (db:get-value-by-header run header "state") targetstr runname "meta" "state" ) + (mutils:hierhash-set! data (conc (db:get-value-by-header run header "id")) targetstr runname "meta" "id" ) + (mutils:hierhash-set! data (db:get-value-by-header run header "event_time") targetstr runname "meta" "event_time" )) + (else + (print "Run: " targetstr "/" runname + " status: " (db:get-value-by-header run header "state") + " run-id: " run-id ", number tests: " (length tests)))) (for-each (lambda (test) - (format #t - " Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n" - (conc (db:test-get-testname test) - (if (equal? (db:test-get-item-path test) "") - "" - (conc "(" (db:test-get-item-path test) ")"))) - (db:test-get-state test) - (db:test-get-status test) - (db:test-get-run_duration test) - (db:test-get-event_time test) - (db:test-get-host test)) - (if (not (or (equal? (db:test-get-status test) "PASS") - (equal? (db:test-get-status test) "WARN") - (equal? (db:test-get-state test) "NOT_STARTED"))) - (begin - (print " cpuload: " (db:test-get-cpuload test) - "\n diskfree: " (db:test-get-diskfree test) - "\n uname: " ;; (sdb:qry 'getstr - (db:test-get-uname test) ;; ) - "\n rundir: " ;; (sdb:qry 'getstr ;; (filedb:get-path *fdb* - (db:test-get-rundir test) ;; ) - ) - ;; Each test - ;; DO NOT remote run - (let ((steps (db:get-steps-for-test dbstruct run-id (db:test-get-id test)))) - (for-each - (lambda (step) - (format #t - " Step: ~20a State: ~10a Status: ~10a Time ~22a\n" - (tdb:step-get-stepname step) - (tdb:step-get-state step) - (tdb:step-get-status step) - (tdb:step-get-event_time step))) - steps))))) + (handle-exceptions + exn + (debug:print 0 "ERROR: Bad data in test record? " test) + (let ((test-id (db:test-get-id test)) + (fullname (conc (db:test-get-testname test) + (if (equal? (db:test-get-item-path test) "") + "" + (conc "(" (db:test-get-item-path test) ")")))) + (tstate (db:test-get-state test)) + (tstatus (db:test-get-status test)) + (event-time (db:test-get-event_time test))) + (case dmode + ((json) + (mutils:hierhash-set! data fullname targetstr runname "data" (conc test-id) "tname" ) + (mutils:hierhash-set! data tstate targetstr runname "data" (conc test-id) "state" ) + (mutils:hierhash-set! data tstatus targetstr runname "data" (conc test-id) "status" ) + (mutils:hierhash-set! data event-time targetstr runname "data" (conc test-is) "event_time")) + (else + (format #t + " Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n" + fullname + tstate + tstatus + (db:test-get-run_duration test) + event-time + (db:test-get-host test)) + (if (not (or (equal? (db:test-get-status test) "PASS") + (equal? (db:test-get-status test) "WARN") + (equal? (db:test-get-state test) "NOT_STARTED"))) + (begin + (print " cpuload: " (db:test-get-cpuload test) + "\n diskfree: " (db:test-get-diskfree test) + "\n uname: " (db:test-get-uname test) + "\n rundir: " (db:test-get-rundir test) + "\n rundir: " ;; (sdb:qry 'getstr ;; (filedb:get-path *fdb* + (db:test-get-rundir test) ;; ) + ) + ;; Each test + ;; DO NOT remote run + (let ((steps (db:get-steps-for-test dbstruct run-id (db:test-get-id test)))) + (for-each + (lambda (step) + (format #t + " Step: ~20a State: ~10a Status: ~10a Time ~22a\n" + (tdb:step-get-stepname step) + (tdb:step-get-state step) + (tdb:step-get-status step) + (tdb:step-get-event_time step))) + steps))))))))) tests))))) - runs) - ;; (db:close-all dbstruct) + runs) + (if (eq? dmode 'json)(json-write data)) (set! *didsomething* #t)))) ;;====================================================================== ;; full run ;;====================================================================== @@ -1224,11 +1252,11 @@ ;; can setup as client for server mode now ;; (client:setup) (if (args:get-arg "-load-test-data") ;; has sub commands that are rdb: - ;; DO NOT put this one into either cdb:remote-run or open-run-close + ;; DO NOT put this one into either rmt: or open-run-close (tdb:load-test-data run-id test-id)) (if (args:get-arg "-setlog") (let ((logfname (args:get-arg "-setlog"))) (rmt:test-set-log! run-id test-id logfname))) (if (args:get-arg "-set-toplog") @@ -1321,11 +1349,11 @@ (keys #f)) (if (not (launch:setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) - (set! keys (cdb:remote-run db:get-keys db)) + (set! keys (rmt:get-keys)) ;; db)) (debug:print 1 "Keys: " (string-intersperse keys ", ")) (if (sqlite3:database? db)(sqlite3:finalize! db)) (set! *didsomething* #t))) (if (args:get-arg "-gui") @@ -1402,22 +1430,27 @@ (set! *didsomething* #t))) ;;====================================================================== ;; Start a repl ;;====================================================================== + +;; fakeout readline (if (or (args:get-arg "-repl") (args:get-arg "-load")) (let* ((toppath (launch:setup-for-run)) (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))) (if dbstruct (begin (set! *db* dbstruct) (set! *client-non-blocking-mode* #t) + (import extras) ;; might not be needed + ;; (import csi) (import readline) (import apropos) ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ... + (include "readline-fix.scm") (gnu-history-install-file-manager (string-append (or (get-environment-variable "HOME") ".") "/.megatest_history")) (current-input-port (make-gnu-readline-port "megatest> ")) (if (args:get-arg "-repl") Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -184,12 +184,12 @@ (if newcomment (rmt:general-call 'set-test-comment run-id newcomment test-id)))) (mt:process-triggers run-id test-id newstate newstatus) #t))) (define (mt:test-set-state-status-by-testname run-id test-name item-path new-state new-status new-comment) - (let ((test-id (cdb:remote-run db:get-test-id-cached #f run-id test-name item-path))) - (mt:test-set-state-status-by-id test-id new-state new-status new-comment))) + (let ((test-id (rmt:get-test-id run-id test-name item-path))) + (mt:test-set-state-status-by-id run-id test-id new-state new-status new-comment))) (define (mt:lazy-read-test-config test-name) (let ((tconf (hash-table-ref/default *testconfigs* test-name #f))) (if tconf tconf Index: newdashboard.scm ================================================================== --- newdashboard.scm +++ newdashboard.scm @@ -83,11 +83,11 @@ ;; ease debugging by loading ~/.dashboardrc (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) (if (file-exists? debugcontrolf) (load debugcontrolf))) -(define *dbdir* (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) +(define *dbdir* (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) (define *dbstruct-local* (make-dbr:dbstruct path: *dbdir* local: #t)) (define *db-file-path* (db:dbfile-path 0)) ;; HACK ALERT: this is a hack, please fix. @@ -470,11 +470,11 @@ (targ/runname (hash-table-ref/default (dboard:data-get-run-keys *data*) run-id '())) (target (if (null? targ/runname) "" (string-intersperse (reverse (cdr (reverse targ/runname))) "/"))) (runname (if (null? targ/runname) "" (car (cdr targ/runname)))) - (steps-dat (dcommon:get-compressed-steps *dbstruct-local* run-id test-id))) + (steps-dat (tests:get-compressed-steps *dbstruct-local* run-id test-id))) (if test-data (begin ;; (for-each Index: process.scm ================================================================== --- process.scm +++ process.scm @@ -11,10 +11,11 @@ ;;====================================================================== ;; Process convience utils ;;====================================================================== +(use regex) (declare (unit process)) (declare (uses common)) (define (conservative-read port) (let loop ((res "")) @@ -147,5 +148,17 @@ (file-exists? (conc "/proc/" pid)) (let-values (((rpid exit-type exit-signal)(process-wait pid #t))) (and (number? rpid) (equal? rpid pid))))) +(define (process:get-sub-pids pid) + (with-input-from-pipe + (conc "pstree -A -p " pid) ;; | tr 'a-z\\-+`()\\.' ' ' " pid) + (lambda () + (let loop ((inl (read-line)) + (res '())) + (if (eof-object? inl) + (reverse res) + (let ((nums (map string->number + (string-split-fields "\\d+" inl)))) + (loop (read-line) + (append res nums)))))))) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -148,17 +148,21 @@ ;; ;; Note: The tasks db was checked for a server in starting mode in the rmt:get-connection-info call ;; (if (and (< attemptnum 15) (member cmd api:write-queries)) - (begin + (let ((faststart (configf:lookup *configdat* "server" "faststart"))) (hash-table-delete! *runremote* run-id) ;; (mutex-unlock! *send-receive-mutex*) - (tasks:start-and-wait-for-server (db:delay-if-busy (tasks:open-db)) run-id 10) - ;; (client:setup run-id) ;; client setup happens in rmt:get-connection-info - (thread-sleep! (random 5)) ;; give some time to settle and minimize collison? - (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1))) + (if (and faststart (equal? faststart "no")) + (begin + (tasks:start-and-wait-for-server (db:delay-if-busy (tasks:open-db)) run-id 10) + (thread-sleep! (random 5)) ;; give some time to settle and minimize collison? + (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1))) + (begin + (server:kind-run run-id) + (rmt:open-qry-close-locally cmd run-id params)))) (begin ;; (debug:print 0 "ERROR: Communication failed!") ;; (mutex-unlock! *send-receive-mutex*) ;; (exit) (rmt:open-qry-close-locally cmd run-id params) @@ -222,11 +226,11 @@ res)) (define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5)) (let* ((dbstruct-local (if *dbstruct-db* *dbstruct-db* - (let* ((dbdir (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) + (let* ((dbdir (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) (db (make-dbr:dbstruct path: dbdir local: #t))) (set! *dbstruct-db* db) db))) (db-file-path (db:dbfile-path 0)) ;; (read-only (not (file-read-access? db-file-path))) @@ -243,11 +247,11 @@ (rmt:open-qry-close-locally cmd run-id params remretries: (- remretries 1))) (begin (debug:print 0 "ERROR: too many retries in rmt:open-qry-close-locally, giving up") #f)) (begin - (rmt:update-db-stats run-id cmd params duration) + ;; (rmt:update-db-stats run-id cmd params duration) ;; mark this run as dirty if this was a write (if (not (member cmd api:read-only-queries)) (let ((start-time (current-seconds))) (mutex-lock! *db-multi-sync-mutex*) ;; (if (not (hash-table-ref/default *db-local-sync* run-id #f)) @@ -412,11 +416,11 @@ (mutex-unlock! multi-run-mutex)) (debug:print 0 "ERROR: get-tests-for-run-mindata failed for run-id " hed ", testpatt " testpatt ", states " states ", status " status ", not-in " not-in)))) (conc "multi-run-thread for run-id " hed))) (newthreads (cons newthread threads))) (thread-start! newthread) - (thread-sleep! 0.5) ;; give that thread some time to start + (thread-sleep! 0.05) ;; give that thread some time to start (if (null? tal) newthreads (loop (car tal)(cdr tal) newthreads)))))) result)) @@ -492,10 +496,13 @@ ;; Statistical queries (define (rmt:get-count-tests-running run-id) (rmt:send-receive 'get-count-tests-running run-id (list run-id))) +(define (rmt:get-count-tests-running-for-testname run-id testname) + (rmt:send-receive 'get-count-tests-running-for-testname run-id (list run-id testname))) + (define (rmt:get-count-tests-running-in-jobgroup run-id jobgroup) (rmt:send-receive 'get-count-tests-running-in-jobgroup run-id (list run-id jobgroup))) (define (rmt:roll-up-pass-fail-counts run-id test-name item-path status) (rmt:send-receive 'roll-up-pass-fail-counts run-id (list run-id test-name item-path status))) @@ -604,12 +611,12 @@ ;; 2. Open the testdat.db file and do the query ;; If not given the work area ;; 1. Do a remote call to get the test path ;; 2. Continue as above ;; -(define (rmt:get-steps-for-test run-id test-id) - (rmt:send-receive 'get-steps-data run-id (list test-id))) +;;(define (rmt:get-steps-for-test run-id test-id) +;; (rmt:send-receive 'get-steps-data run-id (list test-id))) (define (rmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile) (let* ((state (items:check-valid-items "state" state-in)) (status (items:check-valid-items "status" status-in))) (if (or (not state)(not status)) @@ -616,11 +623,11 @@ (debug:print 3 "WARNING: Invalid " (if status "status" "state") " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) (rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile)))) (define (rmt:get-steps-for-test run-id test-id) - (rmt:send-receive 'get-steps-for-test run-id (list test-id))) + (rmt:send-receive 'get-steps-for-test run-id (list run-id test-id))) ;;====================================================================== ;; T E S T D A T A ;;====================================================================== Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -162,11 +162,14 @@ #t) #f))) (define (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs) (thread-sleep! (cond - ((> *runs:can-run-more-tests-count* 20) 2);; obviously haven't had any work to do for a while + ((> *runs:can-run-more-tests-count* 20) + (if (runs:lownoise "waiting on tasks" 60) + (debug:print-info 2 "waiting for tasks to complete, sleeping briefly ...")) + 2);; obviously haven't had any work to do for a while (else 0))) (let* ((num-running (rmt:get-count-tests-running run-id)) (num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup run-id jobgroup)) (job-group-limit (let ((jobg-count (config-lookup *configdat* "jobgroups" jobgroup))) (if (string? jobg-count) @@ -481,13 +484,13 @@ (cond ;; all prereqs met, fire off the test ;; or, if it is a 'toplevel test and all prereqs not met are COMPLETED then launch ((and (not (member 'toplevel testmode)) - (member (hash-table-ref/default test-registry (runs:make-full-test-name hed item-path) 'n/a) + (member (hash-table-ref/default test-registry (db:test-make-full-name hed item-path) 'n/a) '(DONOTRUN removed CANNOTRUN))) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE)) ;; try to catch repeat processing of COMPLETED tests here - (debug:print-info 1 "Test " hed " set to \"" (hash-table-ref test-registry (runs:make-full-test-name hed item-path)) "\". Removing it from the queue") + (debug:print-info 1 "Test " hed " set to \"" (hash-table-ref test-registry (db:test-make-full-name hed item-path)) "\". Removing it from the queue") (if (or (not (null? tal)) (not (null? reg))) (list (runs:queue-next-hed tal reg reglen regfull) (runs:queue-next-tal tal reg reglen regfull) (runs:queue-next-reg tal reg reglen regfull) @@ -686,26 +689,27 @@ reruns) #f)) ;; Register tests ;; - ((not (hash-table-ref/default test-registry (runs:make-full-test-name test-name item-path) #f)) + ((not (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f)) (debug:print-info 4 "Pre-registering test " test-name "/" item-path " to create placeholder" ) ;; always do firm registration now in v1.60 and greater ;; (eq? *transport-type* 'fs) ;; no point in parallel registration if use fs (let register-loop ((numtries 15)) (rmt:general-call 'register-test run-id run-id test-name item-path) - (thread-sleep! 0.5) (if (rmt:get-test-id run-id test-name item-path) - (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'done) + (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'done) (if (> numtries 0) - (register-loop (- numtries 1)) - (debug:print 0 "ERROR: failed to register test " (runs:make-full-test-name test-name item-path))))) - (if (not (eq? (hash-table-ref/default test-registry (runs:make-full-test-name test-name "") #f) 'done)) + (begin + (thread-sleep! 0.5) + (register-loop (- numtries 1))) + (debug:print 0 "ERROR: failed to register test " (db:test-make-full-name test-name item-path))))) + (if (not (eq? (hash-table-ref/default test-registry (db:test-make-full-name test-name "") #f) 'done)) (begin (rmt:general-call 'register-test run-id run-id test-name "") (if (rmt:get-test-id run-id test-name "") - (hash-table-set! test-registry (runs:make-full-test-name test-name "") 'done)))) + (hash-table-set! test-registry (db:test-make-full-name test-name "") 'done)))) (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) (if (and (null? tal)(null? reg)) (list hed tal (append reg (list hed)) reruns) (list (runs:queue-next-hed tal reg reglen regfull) (runs:queue-next-tal tal reg reglen regfull) @@ -716,19 +720,19 @@ (append reg (list hed))) reruns))) ;; At this point hed test registration must be completed. ;; - ((eq? (hash-table-ref/default test-registry (runs:make-full-test-name test-name item-path) #f) + ((eq? (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f) 'start) (debug:print-info 0 "Waiting on test registration(s): " (string-intersperse (filter (lambda (x) (eq? (hash-table-ref/default test-registry x #f) 'start)) (hash-table-keys test-registry)) ", ")) - (thread-sleep! 0.1) + (thread-sleep! 0.051) (list hed tal reg reruns)) ;; If no resources are available just kill time and loop again ;; ((not have-resources) ;; simply try again after waiting a second @@ -744,20 +748,20 @@ ;; ((and have-resources (or (null? prereqs-not-met) (and (eq? testmode 'toplevel) (null? non-completed)))) - ;; (hash-table-delete! *max-tries-hash* (runs:make-full-test-name test-name item-path)) + ;; (hash-table-delete! *max-tries-hash* (db:test-make-full-name test-name item-path)) ;; we are going to reset all the counters for test retries by setting a new hash table ;; this means they will increment only when nothing can be run (set! *max-tries-hash* (make-hash-table)) ;; well, first lets see if cpu load throttling is enabled. If so wait around until the ;; average cpu load is under the threshold before continuing (if (configf:lookup *configdat* "jobtools" "maxload") ;; only gate if maxload is specified (common:wait-for-cpuload maxload numcpus waitdelay)) (run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry) - (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'running) + (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'running) (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) ;; (thread-sleep! *global-delta*) (if (or (not (null? tal))(not (null? reg))) (list (runs:queue-next-hed tal reg reglen regfull) (runs:queue-next-tal tal reg reglen regfull) @@ -794,11 +798,11 @@ (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL" "Failed to run due to failed prerequisites"))) (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) ;; (thread-sleep! *global-delta*) ;; This next is for the items (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "BLOCKED" #f) - (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'removed) + (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'removed) (list (runs:queue-next-hed tal reg reglen regfull) (runs:queue-next-tal tal reg reglen regfull) (runs:queue-next-reg tal reg reglen regfull) reruns ;; WAS: (cons hed reruns) ;; but that makes no sense? )) @@ -891,11 +895,11 @@ ;; NB// Should expand items here and then insert into the run queue. (debug:print 5 "test-records: " test-records ", flags: " (hash-table->alist flags)) ;; Do mark-and-find clean up of db before starting runing of quue ;; - ;; (cdb:remote-run db:find-and-mark-incomplete #f) + ;; (rmt:find-and-mark-incomplete) (let ((run-info (rmt:get-run-info run-id)) (tests-info (mt:get-tests-for-run run-id #f '() '())) ;; qryvals: "id,testname,item_path")) (sorted-test-names (tests:sort-by-priority-and-waiton test-records)) (test-registry (make-hash-table)) @@ -917,11 +921,11 @@ (let ((id (db:test-get-id trec)) (tn (db:test-get-testname trec)) (ip (db:test-get-item-path trec)) (st (db:test-get-state trec))) (if (not (equal? st "DELETED")) - (hash-table-set! test-registry (runs:make-full-test-name tn ip) (string->symbol st))))) + (hash-table-set! test-registry (db:test-make-full-name tn ip) (string->symbol st))))) tests-info) (set! max-retries (if (and max-retries (string->number max-retries))(string->number max-retries) 100)) (let loop ((hed (car sorted-test-names)) (tal (cdr sorted-test-names)) @@ -950,11 +954,11 @@ (waitons (tests:testqueue-get-waitons test-record)) (priority (tests:testqueue-get-priority test-record)) (itemdat (tests:testqueue-get-itemdat test-record)) ;; itemdat can be a string, list or #f (items (tests:testqueue-get-items test-record)) (item-path (item-list->path itemdat)) - (tfullname (runs:make-full-test-name test-name item-path)) + (tfullname (db:test-make-full-name test-name item-path)) (newtal (append tal (list hed))) (regfull (>= (length reg) reglen)) (num-running (rmt:get-count-tests-running-for-run-id run-id))) ;; every couple minutes verify the server is there for this run @@ -963,20 +967,20 @@ (tasks:start-and-wait-for-server tdbdat run-id 10)) ;; NOTE: delay and wait is done under the hood (if (> num-running 0) (set! last-time-some-running (current-seconds))) - (if (> (current-seconds)(+ last-time-some-running 240)) + (if (> (current-seconds)(+ last-time-some-running (or (configf:lookup *configdat* "setup" "give-up-waiting") 36000))) (hash-table-set! *max-tries-hash* tfullname (+ (hash-table-ref/default *max-tries-hash* tfullname 0) 1))) ;; (debug:print 0 "max-tries-hash: " (hash-table->alist *max-tries-hash*)) ;; Ensure all top level tests get registered. This way they show up as "NOT_STARTED" on the dashboard ;; and it is clear they *should* have run but did not. - (if (not (hash-table-ref/default test-registry (runs:make-full-test-name test-name "") #f)) + (if (not (hash-table-ref/default test-registry (db:test-make-full-name test-name "") #f)) (begin (rmt:general-call 'register-test run-id run-id test-name "") - (hash-table-set! test-registry (runs:make-full-test-name test-name "") 'done))) + (hash-table-set! test-registry (db:test-make-full-name test-name "") 'done))) ;; Fast skip of tests that are already "COMPLETED" - NO! Cannot do that as the items may not have been expanded yet :( ;; (if (member (hash-table-ref/default test-registry tfullname #f) '(DONOTRUN removed)) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE)) @@ -1065,11 +1069,11 @@ (let* ((new-test-record (let ((newrec (make-tests:testqueue))) (vector-copy! test-record newrec) newrec)) (my-item-path (item-list->path my-itemdat))) (if (tests:match test-patts hed my-item-path required: required-tests) ;; (patt-list-match my-item-path item-patts) ;; yes, we want to process this item, NOTE: Should not need this check here! - (let ((newtestname (runs:make-full-test-name hed my-item-path))) ;; test names are unique on testname/item-path + (let ((newtestname (db:test-make-full-name hed my-item-path))) ;; test names are unique on testname/item-path (tests:testqueue-set-items! new-test-record #f) (tests:testqueue-set-itemdat! new-test-record my-itemdat) (tests:testqueue-set-item_path! new-test-record my-item-path) (hash-table-set! test-records newtestname new-test-record) (set! tal (append tal (list newtestname))))))) ;; since these are itemized create new test names testname/itempath @@ -1191,13 +1195,10 @@ (if (not (vector? t)) (conc t) (conc (db:test-get-testname t) ":" (db:test-get-state t) "/" (db:test-get-status t)))) lst)) -(define (runs:make-full-test-name testname itempath) - (if (equal? itempath "") testname (conc testname "/" itempath))) - ;; parent-test is there as a placeholder for when parent-tests can be run as a setup step (define (run:test run-id run-info keyvals runname test-record flags parent-test test-registry all-tests-registry) ;; All these vars might be referenced by the testconfig file reader (let* ((test-name (tests:testqueue-get-testname test-record)) (test-waitons (tests:testqueue-get-waitons test-record)) @@ -1213,11 +1214,11 @@ (full-test-name #f)) ;; setting itemdat to a list if it is #f (if (not itemdat)(set! itemdat '())) (set! item-path (item-list->path itemdat)) - (set! full-test-name (runs:make-full-test-name test-name item-path)) + (set! full-test-name (db:test-make-full-name test-name item-path)) (debug:print-info 4 "\nTESTNAME: " full-test-name "\n test-config: " (hash-table->alist test-conf) "\n itemdat: " itemdat ) @@ -1337,11 +1338,24 @@ (if (not (null? running-tests)) ;; have to skip (set! skip-test "Skipping due to previous tests running")))) ((and skip-check (configf:lookup test-conf "skip" "fileexists")) (if (file-exists? (configf:lookup test-conf "skip" "fileexists")) - (set! skip-test (conc "Skipping due to existance of file " (configf:lookup test-conf "skip" "fileexists")))))) + (set! skip-test (conc "Skipping due to existance of file " (configf:lookup test-conf "skip" "fileexists"))))) + + ((and skip-check + (configf:lookup test-conf "skip" "rundelay")) + ;; run-ids = #f means *all* runs + (let* ((numseconds (common:hms-string->seconds (configf:lookup test-conf "skip" "rundelay"))) + (running-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f)) + (completed-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("COMPLETED") '("PASS" "FAIL" "ABORT") #f)) + (last-run-times (map db:mintest-get-event_time completed-tests)) + (time-since-last (- (current-seconds) (if (null? last-run-times) 0 (apply max last-run-times))))) + (if (or (not (null? running-tests)) ;; have to skip if test is running + (> numseconds time-since-last)) + (set! skip-test (conc "Skipping due to previous test run less than " (configf:lookup test-conf "skip" "rundelay") " ago")))))) + (if skip-test (begin (mt:test-set-state-status-by-id run-id test-id "COMPLETED" "SKIP" skip-test) (debug:print-info 1 "SKIPPING Test " full-test-name " due to " skip-test)) (if (not (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat flags)) @@ -1349,11 +1363,11 @@ (print "ERROR: Failed to launch the test. Exiting as soon as possible") (set! *globalexitstatus* 1) ;; (process-signal (current-process-id) signal/kill)))))))) ((KILLED) (debug:print 1 "NOTE: " full-test-name " is already running or was explictly killed, use -force to launch it.") - (hash-table-set! test-registry (runs:make-full-test-name test-name test-path) 'DONOTRUN)) ;; KILLED)) + (hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN)) ;; KILLED)) ((LAUNCHED REMOTEHOSTSTART RUNNING) (debug:print 2 "NOTE: " test-name " is already running")) ;; (if (> (- (current-seconds)(+ (db:test-get-event_time testdat) ;; (db:test-get-run_duration testdat))) ;; (or incomplete-timeout @@ -1365,13 +1379,13 @@ ;; (debug:print 2 "NOTE: " test-name " is already running"))) (else (debug:print 0 "ERROR: Failed to launch test " full-test-name ". Unrecognised state " (test:get-state testdat)) (case (string->symbol (test:get-state testdat)) ((COMPLETED INCOMPLETE) - (hash-table-set! test-registry (runs:make-full-test-name test-name test-path) 'DONOTRUN)) + (hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN)) (else - (hash-table-set! test-registry (runs:make-full-test-name test-name test-path) 'DONOTRUN)))))))) + (hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN)))))))) ;;====================================================================== ;; END OF NEW STUFF ;;====================================================================== @@ -1476,11 +1490,13 @@ (debug:print 1 "Archiving/restoring (" (args:get-arg "-archive") ") data for run: " runkey " " (db:get-value-by-header run header "runname")) (set! worker-thread (make-thread (lambda () (case (string->symbol (args:get-arg "-archive")) ((save save-remove keep-html)(archive:run-bup (args:get-arg "-archive") run-id run-name tests)) ((restore)(archive:bup-restore (args:get-arg "-archive") run-id run-name tests)) - (else (debug:print 0 "ERROR: unrecognised sub command to -archive. Run \"megatest\" to see help")))) + (else + (debug:print 0 "ERROR: unrecognised sub command to -archive. Run \"megatest\" to see help") + (exit)))) "archive-bup-thread")) (thread-start! worker-thread)) (else (debug:print-info 0 "action not recognised " action))) @@ -1567,15 +1583,16 @@ (let ((new-tests (proc-get-tests run-id))) (if (null? new-tests) (debug:print-info 1 "Run completed according to zero tests matching provided criteria.") (loop (car new-tests)(cdr new-tests))))) ((archive) - (if (not toplevel-with-children) - (case (string->symbol (args:get-arg "-archive")) - ((save save-remove keep-html) - (debug:print-info 0 "Estimating disk space usage for " test-fulln) - (debug:print-info 0 " " (common:get-disk-space-used (conc run-dir "/")))))) + (if (and run-dir (not toplevel-with-children)) + (let ((ddir (conc run-dir "/"))) + (case (string->symbol (args:get-arg "-archive")) + ((save save-remove keep-html) + (if (file-exists? ddir) + (debug:print-info 0 "Estimating disk space usage for " test-fulln ": " (common:get-disk-space-used ddir))))))) (if (not (null? tal)) (loop (car tal)(cdr tal)))) ))) ) (if worker-thread (thread-join! worker-thread)))))) @@ -1588,11 +1605,11 @@ (take dparts (- (length dparts) 1)) "/")))) (debug:print 1 "Removing run: " runkey " " (db:get-value-by-header run header "runname") " and related record") (rmt:delete-run run-id) (rmt:delete-old-deleted-test-records) - ;; (cdb:remote-run db:set-var db "DELETED_TESTS" (current-seconds)) + ;; (rmt:set-var "DELETED_TESTS" (current-seconds)) ;; need to figure out the path to the run dir and remove it if empty ;; (if (null? (glob (conc runpath "/*"))) ;; (begin ;; (debug:print 1 "Removing run dir " runpath) ;; (system (conc "rmdir -p " runpath)))) @@ -1671,12 +1688,10 @@ (if (launch:setup-for-run) (launch:cache-config) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) - ;; (if (args:get-arg "-server") - ;; (cdb:remote-run server:start db (args:get-arg "-server"))) (set! keys (keys:config-get-fields *configdat*)) ;; have enough to process -target or -reqtarg here (if (args:get-arg "-reqtarg") (let* ((runconfigf (conc *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL (runconfig (read-config runconfigf #f #t environ-patt: #f))) @@ -1791,11 +1806,11 @@ new-run-id (cddr (vector->list testdat))) (set! new-testdat (car (mt:get-tests-for-run new-run-id (conc testname "/" item-path) '() '()))) (hash-table-set! curr-tests-hash full-name new-testdat) ;; this could be confusing, which record should go into the lookup table? ;; Now duplicate the test steps (debug:print 4 "Copying records in test_steps from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat)) - (cdb:remote-run + (cdb:remote-run ;; to be replaced, note: this routine is not used currently (lambda () (sqlite3:execute db (conc "INSERT OR REPLACE INTO test_steps (test_id,stepname,state,status,event_time,comment) " "SELECT " (db:test-get-id new-testdat) ",stepname,state,status,event_time,comment FROM test_steps WHERE test_id=?;") Index: synchash.scm ================================================================== --- synchash.scm +++ synchash.scm @@ -56,14 +56,10 @@ orig-keys) (list changed deleted) ;; (list indat '()) ;; just for debugging )) -;; (cdb:remote-run db:get-keys #f) -;; (cdb:remote-run db:get-num-runs #f "%") -;; (cdb:remote-run db:get-runs #f runnamepatt numruns *start-run-offset* keypatts) -;; ;; keynum => the field to use as the unique key (usually 0 but can be other field) ;; (define (synchash:client-get proc synckey keynum synchash run-id . params) (let* ((data (rmt:synchash-get run-id proc synckey keynum params)) (newdat (car data)) Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -53,15 +53,20 @@ (if remove (system (conc "rm -rf " fullpath))) #f))) #t)))))) (define (tasks:get-task-db-path) - (let* ((linktree (configf:lookup *configdat* "setup" "linktree")) - (dbpath (conc linktree "/.db"))) - dbpath)) - - + (let ((dbdir (or (configf:lookup *configdat* "setup" "monitordir") + (configf:lookup *configdat* "setup" "dbdir") + (conc (configf:lookup *configdat* "setup" "linktree") "/.db")))) + (handle-exceptions + exn + (begin + (debug:print 0 "ERROR: Couldn't create path to " dbdir) + (exit 1)) + (if (not (directory? dbdir))(create-directory dbdir #t))) + dbdir)) ;; If file exists AND ;; file readable ;; ==> open it ;; If file exists AND @@ -516,11 +521,11 @@ ;; (define (tasks:start-monitor db mdb) (if (> (tasks:get-num-alive-monitors mdb) 2) ;; have two running, no need for more (debug:print-info 1 "Not starting monitor, already have more than two running") (let* ((megatestdb (conc *toppath* "/megatest.db")) - (monitordbf (conc (configf:lookup *configdat* "setup" "linktree") "/.db/monitor.db")) + (monitordbf (conc (db:dbfile-path #f) "/monitor.db")) (last-db-update 0)) ;; (file-modification-time megatestdb))) (task:register-monitor mdb) (let loop ((count 0) (next-touch 0)) ;; next-touch is the time where we need to update last_update ;; if the db has been modified we'd best look at the task queue Index: tdb.scm ================================================================== --- tdb.scm +++ tdb.scm @@ -45,26 +45,34 @@ (define (open-test-db work-area) (debug:print-info 11 "open-test-db " work-area) (if (and work-area (directory? work-area) (file-read-access? work-area)) - (let* ((dbpath (conc work-area "/testdat.db")) - (tdb-writeable (file-write-access? dbpath)) - (dbexists (file-exists? dbpath)) + (let* ((dbpath (conc work-area "/testdat.db")) + (dbexists (file-exists? dbpath)) + (work-area-writeable (file-write-access? work-area)) + (db (handle-exceptions ;; open the db if area writeable or db pre-existing. open in-mem otherwise. if exception, open in-mem + exn + (begin + (print-call-chain (current-error-port)) + (debug:print 2 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test" + ((condition-property-accessor 'exn 'message) exn)) + (set! dbexists #f) ;; must force re-creation of tables, more tom-foolery + (sqlite3:open-database ":memory:")) ;; open an in-memory db to allow readonly access + (if (or work-area-writeable + dbexists) + (sqlite3:open-database dbpath) + (sqlite3:open-database ":memory:")))) + (tdb-writeable (and (file-write-access? work-area) + (file-write-access? dbpath))) (handler (make-busy-timeout (if (args:get-arg "-override-timeout") (string->number (args:get-arg "-override-timeout")) 136000)))) - (handle-exceptions - exn - (begin - (print-call-chain (current-error-port)) - (debug:print 2 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test" - ((condition-property-accessor 'exn 'message) exn)) - (set! db (sqlite3:open-database ":memory:")) ;; open an in-memory db to allow readonly access - (set! dbexists #f)) ;; must force re-creation of tables, more tom-foolery - (set! db (sqlite3:open-database dbpath))) - (if *db-write-access* (sqlite3:set-busy-handler! db handler)) + + (if (and tdb-writeable + *db-write-access*) + (sqlite3:set-busy-handler! db handler)) (if (not dbexists) (begin (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = FULL;") (debug:print-info 11 "Initialized test database " dbpath) (tdb:testdb-initialize db))) @@ -81,15 +89,16 @@ #f) ;; Is there a cheaper single line operation that will check for existance of a table ;; and raise an exception ? (sqlite3:execute db "SELECT id FROM test_data LIMIT 1;")) db) + ;; no work-area or not readable - create a placeholder to fake rest of world out (let ((baddb (sqlite3:open-database ":memory:"))) - (debug:print-info 11 "open-test-db END (unsucessful)" work-area) - ;; provide an in-mem db (this is dangerous!) - (tdb:testdb-initialize baddb) - baddb))) + (debug:print-info 11 "open-test-db END (unsucessful)" work-area) + ;; provide an in-mem db (this is dangerous!) + (tdb:testdb-initialize baddb) + baddb))) ;; find and open the testdat.db file for an existing test (define (tdb:open-test-db-by-test-id test-id #!key (work-area #f)) (let* ((test-path (if work-area work-area Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -13,16 +13,18 @@ ;; Tests ;;====================================================================== (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils) (import (prefix sqlite3 sqlite3:)) +(require-library stml) (declare (unit tests)) (declare (uses lock-queue)) (declare (uses db)) (declare (uses tdb)) (declare (uses common)) +;; (declare (uses dcommon)) ;; needed for the steps processing (declare (uses items)) (declare (uses runconfig)) ;; (declare (uses sdb)) (include "common_records.scm") @@ -314,85 +316,241 @@ (debug:print 0 "ERROR: summarize-items for run-id=" run-id ", test-name=" test-name ", no such path: " path)) (debug:print 4 "summarize-items with logf " logf ", outputfilename " outputfilename " and force " force) (if (or (equal? logf "logs/final.log") (equal? logf outputfilename) force) - (begin - (if (not (lock-queue:wait-turn outputfilename test-id)) - (print "Not updating " outputfilename " as another test item has signed up for the job") - (begin - (print "Obtained lock for " outputfilename) - (let ((oup (open-output-file outputfilename)) - (counts (make-hash-table)) - (statecounts (make-hash-table)) - (outtxt "") - (tot 0) - (testdat (rmt:test-get-records-for-index-file run-id test-name))) - (with-output-to-port - oup - (lambda () - (set! outtxt (conc outtxt "Summary: " test-name - "

Summary for " test-name "

")) - (for-each - (lambda (testrecord) - (let ((id (vector-ref testrecord 0)) - (itempath (vector-ref testrecord 1)) - (state (vector-ref testrecord 2)) - (status (vector-ref testrecord 3)) - (run_duration (vector-ref testrecord 4)) - (logf (vector-ref testrecord 5)) - (comment (vector-ref testrecord 6))) - (hash-table-set! counts status (+ 1 (hash-table-ref/default counts status 0))) - (hash-table-set! statecounts state (+ 1 (hash-table-ref/default statecounts state 0))) - (set! outtxt (conc outtxt "" - " " itempath "" - "" state "" - "" status "" - "" (if (equal? comment "") - " " - comment) "" - "")))) - (if (list? testdat) - testdat - (begin - (print "ERROR: failed to get records with rmt:test-get-records-for-index-file run-id=" run-id "test-name=" test-name) - '()))) - - (print "
") - ;; Print out stats for status - (set! tot 0) - (print "") - (for-each (lambda (state) - (set! tot (+ tot (hash-table-ref statecounts state))) - (print "")) - (hash-table-keys statecounts)) - (print "

State stats

" state "" (hash-table-ref statecounts state) "
Total" tot "
") - (print "		") - ;; Print out stats for state - (set! tot 0) - (print "") - (for-each (lambda (status) - (set! tot (+ tot (hash-table-ref counts status))) - (print "")) - (hash-table-keys counts)) - (print "

Status stats

" status - "" (hash-table-ref counts status) "
Total" tot "
") - (print "
") - - (print "" - "" - outtxt "
ItemStateStatusComment
") - ;; (release-dot-lock outputfilename) - )) - (close-output-port oup) - (lock-queue:release-lock outputfilename test-id) + (let ((my-start-time (current-seconds)) + (lockf (conc outputfilename ".lock"))) + (let loop ((have-lock (common:simple-file-lock lockf))) + (if have-lock + (begin + (print "Obtained lock for " outputfilename) + (tests:generate-html-summary-for-iterated-test run-id test-id test-name outputfilename) + (common:simple-file-release-lock lockf) (change-directory orig-dir) ;; NB// tests:test-set-toplog! is remote internal... - (tests:test-set-toplog! run-id test-name outputfilename) - ))))))) + (tests:test-set-toplog! run-id test-name outputfilename)) + ;; didn't get the lock, check to see if current update started later than this + ;; update, if so we can exit without doing any work + (if (> my-start-time (file-modification-time lockf)) + ;; we started since current re-gen in flight, delay a little and try again + (begin + (debug:print-info 1 "Waiting to update " outputfilename ", another test currently updating it") + (thread-sleep! (+ 5 (random 5))) ;; delay between 5 and 10 seconds + (loop (common:simple-file-lock lockf)))))))))) + +(define (tests:generate-html-summary-for-iterated-test run-id test-id test-name outputfilename) + (let ((counts (make-hash-table)) + (statecounts (make-hash-table)) + (outtxt "") + (tot 0) + (testdat (rmt:test-get-records-for-index-file run-id test-name))) + (with-output-to-file outputfilename + (lambda () + (set! outtxt (conc outtxt "Summary: " test-name + "

Summary for " test-name "

")) + (for-each + (lambda (testrecord) + (let ((id (vector-ref testrecord 0)) + (itempath (vector-ref testrecord 1)) + (state (vector-ref testrecord 2)) + (status (vector-ref testrecord 3)) + (run_duration (vector-ref testrecord 4)) + (logf (vector-ref testrecord 5)) + (comment (vector-ref testrecord 6))) + (hash-table-set! counts status (+ 1 (hash-table-ref/default counts status 0))) + (hash-table-set! statecounts state (+ 1 (hash-table-ref/default statecounts state 0))) + (set! outtxt (conc outtxt "" + ;; " " itempath "" + " " itempath "" + "" state "" + "" status "" + "" (if (equal? comment "") + " " + comment) "" + "")))) + (if (list? testdat) + testdat + (begin + (print "ERROR: failed to get records with rmt:test-get-records-for-index-file run-id=" run-id "test-name=" test-name) + '()))) + + (print "
") + ;; Print out stats for status + (set! tot 0) + (print "") + (for-each (lambda (state) + (set! tot (+ tot (hash-table-ref statecounts state))) + (print "")) + (hash-table-keys statecounts)) + (print "

State stats

" state "" (hash-table-ref statecounts state) "
Total" tot "
") + (print "		") + ;; Print out stats for state + (set! tot 0) + (print "") + (for-each (lambda (status) + (set! tot (+ tot (hash-table-ref counts status))) + (print "")) + (hash-table-keys counts)) + (print "

Status stats

" status + "" (hash-table-ref counts status) "
Total" tot "
") + (print "
") + + (print "" + "" + outtxt "
ItemStateStatusComment
") + ;; (release-dot-lock outputfilename) + )))) + +;; CHECK - WAS THIS ADDED OR REMOVED? MANUAL MERGE WITH API STUFF!!! +;; +;; get a pretty table to summarize steps +;; +;; (define (dcommon:process-steps-table steps);; db test-id #!key (work-area #f)) +(define (tests:process-steps-table steps);; db test-id #!key (work-area #f)) +;; (let ((steps (db:get-steps-for-test db test-id work-area: work-area))) + ;; organise the steps for better readability + (let ((res (make-hash-table))) + (for-each + (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) "" "" "" "" "")))) + (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) + "\ntime: " (tdb:step-get-event_time step)) + (case (string->symbol (tdb:step-get-state step)) + ((start)(vector-set! record 1 (tdb:step-get-event_time step)) + (vector-set! record 3 (if (equal? (vector-ref record 3) "") + (tdb:step-get-status step))) + (if (> (string-length (tdb:step-get-logfile step)) + 0) + (vector-set! record 5 (tdb:step-get-logfile step)))) + ((end) + (vector-set! record 2 (any->number (tdb:step-get-event_time step))) + (vector-set! record 3 (tdb:step-get-status step)) + (vector-set! record 4 (let ((startt (any->number (vector-ref record 1))) + (endt (any->number (vector-ref record 2)))) + (debug:print 4 "record[1]=" (vector-ref record 1) + ", startt=" startt ", endt=" endt + ", 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)))) + (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)))) + (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) + "\nstatus: " (tdb:step-get-status step) + "\ntime: " (tdb:step-get-event_time step)))) + ;; (else (vector-set! record 1 (tdb:step-get-event_time step))) + (sort steps (lambda (a b) + (cond + ((< (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t) + ((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))) + (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) + (let ((s (vector-ref x 1))) + (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 + (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)) + (if (< time-a time-b) + #t + (if (eq? time-a time-b) + (stringwork-week/day-time + (db:test-get-event_time test-dat))) + (s:td "Duration") (s:td (seconds->hr-min-sec (db:test-get-run_duration test-dat))))) + (s:h3 "Log files") + (s:table + 'cellspacing "0" 'border "1" + (s:tr (s:td "Final log")(s:td (s:a 'href logf logf)))) + (s:table + 'cellspacing "0" 'border "1" + (s:tr (s:td "Step Name")(s:td "Start")(s:td "End")(s:td "Status")(s:td "Duration")(s:td "Log File")) + (map (lambda (step-dat) + (s:tr (s:td (tdb:steps-table-get-stepname step-dat)) + (s:td (tdb:steps-table-get-start step-dat)) + (s:td (tdb:steps-table-get-end step-dat)) + (s:td (tdb:steps-table-get-status step-dat)) + (s:td (tdb:steps-table-get-runtime step-dat)) + (s:td (let ((step-log (tdb:steps-table-get-log-file step-dat))) + (s:a 'href step-log step-log))))) + steps-dat)) + ))) + (close-output-port oup))) + + ;; MUST BE CALLED local! ;; (define (tests:test-get-paths-matching keynames target fnamepatt #!key (res '())) ;; BUG: Move the values derived from args to parameters and push to megatest.scm (let* ((testpatt (if (args:get-arg "-testpatt")(args:get-arg "-testpatt") "%")) Index: tests/Makefile ================================================================== --- tests/Makefile +++ tests/Makefile @@ -72,14 +72,14 @@ # NOTE: Only one instance can be a server test5 : cleanprep rm -f fullrun/a*.log fullrun/logs/* @echo "WARNING: No longer running fullprep, test converage may be lessened" cd fullrun;sleep 0;$(MEGATEST) -preclean -runtests % -target $(TARGET) :runname $(RUNNAME)_aa -debug $(DEBUG) $(LOGGING) > aa.log 2> aa.log & - cd fullrun;sleep 0;$(MEGATEST) -preclean -runtests % -target $(TARGET) :runname $(RUNNAME)_ab -debug $(DEBUG) $(LOGGING) > ab.log 2> ab.log & - cd fullrun;sleep 5;$(MEGATEST) -preclean -runtests % -target $(TARGET) :runname $(RUNNAME)_ac -debug $(DEBUG) $(LOGGING) > ac.log 2> ac.log & - cd fullrun;sleep 8;$(MEGATEST) -preclean -runtests % -target $(TARGET) :runname $(RUNNAME)_ad -debug $(DEBUG) $(LOGGING) > ad.log 2> ad.log & -# cd fullrun;sleep 0;$(MEGATEST) -preclean -runtests % -target $(TARGET) :runname $(RUNNAME)_ae -debug $(DEBUG) $(LOGGING) > ae.log 2> ae.log & + cd fullrun;sleep 0;$(MEGATEST) -preclean -runtests % -target ubuntu/nfs/sleep1 :runname $(RUNNAME)_ae -debug $(DEBUG) $(LOGGING) > ae.log 2> ae.log & + cd fullrun;sleep 0;$(MEGATEST) -preclean -runtests % -target ubuntu/nfs/sleep10 :runname $(RUNNAME)_ab -debug $(DEBUG) $(LOGGING) > ab.log 2> ab.log & + cd fullrun;sleep 5;$(MEGATEST) -preclean -runtests % -target ubuntu/nfs/sleep60 :runname $(RUNNAME)_ac -debug $(DEBUG) $(LOGGING) > ac.log 2> ac.log & + cd fullrun;sleep 8;$(MEGATEST) -preclean -runtests % -target ubuntu/nfs/sleep240 :runname $(RUNNAME)_ad -debug $(DEBUG) $(LOGGING) > ad.log 2> ad.log & # cd fullrun;sleep 0;$(MEGATEST) -preclean -runtests % -target $(TARGET) :runname $(RUNNAME)_af -debug $(DEBUG) $(LOGGING) > af.log 2> af.log & # MUST ADD THIS BACK IN ASAP!!!! # cd fullrun;sleep 10;$(MEGATEST) -run-wait -target $(TARGET) :runname % -testpatt % :state RUNNING,LAUNCHED,NOT_STARTED,REMOTEHOSTSTART;echo ALL DONE Index: tests/fdktestqa/fdk.config ================================================================== --- tests/fdktestqa/fdk.config +++ tests/fdktestqa/fdk.config @@ -29,5 +29,8 @@ [jobtools] # launcher nbq -P ch_vp -C SLES11_EM64T_4G -Q /ciaf/fdk # launcher nbfake # maxload 4 + +launcher bsub -q priority -o $MT_TEST_RUN_DIR/openlava.log + Index: tests/fdktestqa/testqa/megatest.config ================================================================== --- tests/fdktestqa/testqa/megatest.config +++ tests/fdktestqa/testqa/megatest.config @@ -1,9 +1,11 @@ [setup] testcopycmd cp --remove-destination -rlv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log # launchwait no -[jobtools] -launcher nbfake +# All these are overridden in ../fdk.config +# [jobtools] +# launcher nbfake +# launcher bsub -q priority -o $MT_TEST_RUN_DIR/openlava.log [include ../fdk.config] ADDED tests/fixpath.csh Index: tests/fixpath.csh ================================================================== --- /dev/null +++ tests/fixpath.csh @@ -0,0 +1,1 @@ +setenv PATH `readlink -f ../bin`:$PATH ADDED tests/fixpath.sh Index: tests/fixpath.sh ================================================================== --- /dev/null +++ tests/fixpath.sh @@ -0,0 +1,1 @@ +export PATH=$(readlink -f ../bin):$PATH Index: tests/fullrun/megatest.config ================================================================== --- tests/fullrun/megatest.config +++ tests/fullrun/megatest.config @@ -21,20 +21,27 @@ [tests-paths] 1 #{get misc parent}/simplerun/tests [setup] + +# turn off faststart, put monitor.db in MT_RUN_AREA_HOME/db +# and set the dbdir to /var/tmp/$USER/mt_db to enable keeping +# the raw db in /var/tmp/$USER +# +faststart no +monitordir #{getenv MT_RUN_AREA_HOME}/db +dbdir /var/tmp/#{getenv USER}/mt_db + # Set launchwait to no to use the more agressive code that does not wait for the launch to complete before proceeding # this may save a few milliseconds on launching tests # launchwait no waivercommentpatt ^WW\d+ [a-z].* incomplete-timeout 1 -# yes, anything else is no +# wait for runs to completely complete. yes, anything else is no run-wait yes - - # If set to "default" the old code is used. Otherwise defaults to 200 or uses # numeric value given. # runqueue 20 @@ -75,11 +82,11 @@ logviewer (%MTCMD%) 2> /dev/null > /dev/null # override the html viewer launch command # # htmlviewercmd firefox -new-window -htmlviewercmd konqueror +htmlviewercmd arora # -runtests automatically deletes the records for tests with the listed states on starting up a run allowing them to re-run # (nb// this is in addition to NOT_STARTED which is automatically re-run) # allow-auto-rerun INCOMPLETE ZERO_ITEMS @@ -116,11 +123,14 @@ WRAPPEDVAR This var should have the work blah thrice: \ blah \ blah -MAX_ALLOWED_LOAD 200 +MYRUNNAME1 /this/is/#{getenv MT_RUNNAME}/my/runname +MYRUNNAME2 /this/is/[system echo $MT_RUNNAME]/my/runname + + # XTERM [system xterm] # RUNDEAD [system exit 56] [server] @@ -138,12 +148,12 @@ # This server will keep running this number of hours after last access. # Three minutes is 0.05 hours # timeout 0.025 timeout 0.061 -# Server is required - slower but more resistant to Sqlite issues. -required yes +# faststart; unless no, start server but proceed with writes until server started +faststart yes # Start server when average query takes longer than this # server-query-threshold 55500 server-query-threshold 100 timeout 0.01 @@ -201,5 +211,21 @@ # Archives will be organised under these paths like this: # / # Within the archive the data is structured like this: # /// disk0 /tmp/#{getenv USER}/adisk1 + +# Uncomment these to emulate a job queue with a long time (look in bin/sleeprunner for the time) +[jobtools] +launcher #{scheme (case (string->symbol (conc (getenv "datapath"))) \ + ((none) "nbfake") \ + ((openlava) "bsub") \ + (else "sleeprunner"))} + +# launcher bsub -q priority -o $MT_TEST_RUN_DIR/openlava.log + +[configf:settings trim-trailing-spaces yes] + +[test] +# VAL1 has trailing spaces +VAL1 Foo +VAL2 ==>#{get test VAL1}Bar<== no spaces between Foo and Bar to pass Index: tests/fullrun/runconfigs.config ================================================================== --- tests/fullrun/runconfigs.config +++ tests/fullrun/runconfigs.config @@ -26,5 +26,18 @@ SOMEVAR4 #{rget SOMEVAR2} SOMEVAR5 #{runconfigs-get SOMEVAR2} [this/a/test] BLAHFOO 123 + +[ubuntu/nfs/sleep1] +SLEEPRUNNER 1 + +[ubuntu/nfs/sleep10] +SLEEPRUNNER 10 + +[ubuntu/nfs/sleep60] +SLEEPRUNNER 60 + +[ubuntu/nfs/sleep240] +SLEEPRUNNER 240 + ADDED tests/fullrun/tests/dynamic_waiton/testconfig Index: tests/fullrun/tests/dynamic_waiton/testconfig ================================================================== --- /dev/null +++ tests/fullrun/tests/dynamic_waiton/testconfig @@ -0,0 +1,21 @@ +[ezsteps] +listfiles ls + +[requirements] +waiton #{scheme (string-intersperse \ + (tests:filter-test-names \ + (hash-table-keys (tests:get-all)) \ + (or (args:get-arg "-runtests") \ + (args:get-arg "-testpatt") "")) " ")} + +[items] + +[test_meta] +author matt +owner bob +description This test runs a single ezstep which is expected to pass \ +but there is an items definition with no items. This should evoke an \ +error. + +tags first,single +reviewed 09/10/2011, by Matt Index: tests/fullrun/tests/ez_pass/testconfig ================================================================== --- tests/fullrun/tests/ez_pass/testconfig +++ tests/fullrun/tests/ez_pass/testconfig @@ -1,10 +1,12 @@ [setup] [ezsteps] -lookittmp ls /tmp -lookithome ls /home +lookittmp sleep 1;ls /tmp +lookithome sleep 1;ls /home +isrunname1 sleep 1;echo $MYRUNNAME1 | grep -v '#f' +isrunname2 sleep 1;echo $MYRUNNAME2 | grep -v '#f' [test_meta] author matt owner bob description This test runs a single ezstep which is expected to pass, no logpro file. Index: tests/fullrun/tests/priority_7/testconfig ================================================================== --- tests/fullrun/tests/priority_7/testconfig +++ tests/fullrun/tests/priority_7/testconfig @@ -2,10 +2,14 @@ runscript main.sh [requirements] priority 7 +[skip] +# Run only if this much time since last run of this test +rundelay 10m 5s + [test_meta] author matt owner bob description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS Index: tests/fullrun/tests/runfirst/main.sh ================================================================== --- tests/fullrun/tests/runfirst/main.sh +++ tests/fullrun/tests/runfirst/main.sh @@ -1,6 +1,8 @@ #!/bin/bash + +# (export DISPLAY=:0;xterm) # megatest -step wasting_time :state start :status n/a -m "This is a test step comment" # sleep 20 # megatest -step wasting_time :state end :status $? ADDED tests/fullrun/tests/test_mt_vars/altvarnotset.logpro Index: tests/fullrun/tests/test_mt_vars/altvarnotset.logpro ================================================================== --- /dev/null +++ tests/fullrun/tests/test_mt_vars/altvarnotset.logpro @@ -0,0 +1,1 @@ +(expect:error in "LogFileBody" = 0 "a file that should never exist" #/what a dumb filename this is/) ADDED tests/fullrun/tests/test_mt_vars/bogousnotset.logpro Index: tests/fullrun/tests/test_mt_vars/bogousnotset.logpro ================================================================== --- /dev/null +++ tests/fullrun/tests/test_mt_vars/bogousnotset.logpro @@ -0,0 +1,1 @@ +(expect:error in "LogFileBody" = 0 "a file that should never exist" #/what a dumb filename this is/) ADDED tests/fullrun/tests/test_mt_vars/currentisblah.logpro Index: tests/fullrun/tests/test_mt_vars/currentisblah.logpro ================================================================== --- /dev/null +++ tests/fullrun/tests/test_mt_vars/currentisblah.logpro @@ -0,0 +1,1 @@ +(expect:error in "LogFileBody" = 0 "a file that should never exist" #/what a dumb filename this is/) ADDED tests/fullrun/tests/test_mt_vars/empty_var.logpro Index: tests/fullrun/tests/test_mt_vars/empty_var.logpro ================================================================== --- /dev/null +++ tests/fullrun/tests/test_mt_vars/empty_var.logpro @@ -0,0 +1,1 @@ +(expect:error in "LogFileBody" = 0 "a file that should never exist" #/what a dumb filename this is/) ADDED tests/fullrun/tests/test_mt_vars/lookithome.logpro Index: tests/fullrun/tests/test_mt_vars/lookithome.logpro ================================================================== --- /dev/null +++ tests/fullrun/tests/test_mt_vars/lookithome.logpro @@ -0,0 +1,1 @@ +(expect:error in "LogFileBody" = 0 "a file that should never exist" #/what a dumb filename this is/) ADDED tests/fullrun/tests/test_mt_vars/lookittmp.logpro Index: tests/fullrun/tests/test_mt_vars/lookittmp.logpro ================================================================== --- /dev/null +++ tests/fullrun/tests/test_mt_vars/lookittmp.logpro @@ -0,0 +1,1 @@ +(expect:error in "LogFileBody" = 0 "a file that should never exist" #/what a dumb filename this is/) ADDED tests/fullrun/tests/test_mt_vars/test-path.logpro Index: tests/fullrun/tests/test_mt_vars/test-path.logpro ================================================================== --- /dev/null +++ tests/fullrun/tests/test_mt_vars/test-path.logpro @@ -0,0 +1,1 @@ +(expect:error in "LogFileBody" = 0 "a file that should never exist" #/what a dumb filename this is/) ADDED tests/fullrun/tests/test_mt_vars/vackyvar.logpro Index: tests/fullrun/tests/test_mt_vars/vackyvar.logpro ================================================================== --- /dev/null +++ tests/fullrun/tests/test_mt_vars/vackyvar.logpro @@ -0,0 +1,1 @@ +(expect:error in "LogFileBody" = 0 "a file that should never exist" #/what a dumb filename this is/) ADDED tests/fullrun/tests/test_mt_vars/varwithdollar.logpro Index: tests/fullrun/tests/test_mt_vars/varwithdollar.logpro ================================================================== --- /dev/null +++ tests/fullrun/tests/test_mt_vars/varwithdollar.logpro @@ -0,0 +1,1 @@ +(expect:error in "LogFileBody" = 0 "a file that should never exist" #/what a dumb filename this is/) Index: tests/simplerun/tests/test1/step2.sh ================================================================== --- tests/simplerun/tests/test1/step2.sh +++ tests/simplerun/tests/test1/step2.sh @@ -1,6 +1,5 @@ #!/usr/bin/env bash # Run your step here echo Got here eh! - Index: tests/unittests/basicserver.scm ================================================================== --- tests/unittests/basicserver.scm +++ tests/unittests/basicserver.scm @@ -92,11 +92,11 @@ ;; (test #f 1 (rmt:register-run keyvals runname "new" "n/a" user)) ;; (test #f #f (rmt:get-runs-by-patt keys runname)) (test #f #t (rmt:general-call 'register-test run-id run-id "test-one" "")) (define test-one-id #f) -(test #f 1 (let ((test-id (rmt:get-test-id run-id "test-one" ""))) +(test #f 30001 (let ((test-id (rmt:get-test-id run-id "test-one" ""))) (set! test-one-id test-id) test-id)) (define test-one-rec #f) (test #f "test-one" (let ((test-rec (rmt:get-test-info-by-id run-id test-one-id))) (set! test-one-rec test-rec) @@ -139,11 +139,11 @@ ((start) (print "Trying to start server") (server:kind-run run-id) (loop 'server-started)) ((server-started) - (case (vector-ref first-dat) + (case (if first-dat (vector-ref first-dat 0) 'blah) ((running) (print "Server appears to be running. Now ask it to shutdown") (rmt:kill-server run-id) (loop 'server-shutdown)) ((shutting-down) DELETED txtdb/txtdb.scm Index: txtdb/txtdb.scm ================================================================== --- txtdb/txtdb.scm +++ /dev/null @@ -1,635 +0,0 @@ - -;; Copyright 2006-2013, 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. - -(use ssax) -(use sxml-serializer) -(use sxml-modifications) -(use regex) -(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) - (with-input-from-file fname - (lambda () - (ssax:xml->sxml (current-input-port) '())))) - -(define (find-section dat section #!key (depth 0)) - (let loop ((hed (car dat)) - (tal (cdr dat))) - (if (list? hed) - (let ((res (find-section hed section depth: (+ depth 1)))) - (if res - res - (if (null? tal) - #f - (loop (car tal)(cdr tal))))) - (if (eq? hed section) - tal - (if (null? tal) - #f - (loop (car tal)(cdr tal))))))) - -(define (remove-section dat section) - (if (null? dat) - '() - (let loop ((hed (car dat)) - (tal (cdr dat)) - (res '())) - (let ((newres (if (and (list? hed) - (not (null? hed)) - (equal? (car hed) section)) - res - (cons hed res)))) - (if (null? tal) - (reverse newres) - (loop (car tal)(cdr tal) newres)))))) - -(define (list-sections dat) - (filter (lambda (x)(and x)) - (map (lambda (section) - (if (and (list? section) - (not (null? section))) - (car section) - #f)) - dat))) - -(define (string->safe-filename str) - (string-substitute (regexp " ") "_" str #t)) - -(define (sheet->refdb dat targdir) - (let* ((comment-rx (regexp "^#CMNT\\d+\\s*")) - (blank-rx (regexp "^#BLNK\\d+\\s*")) - (sheet-name (car (find-section dat 'http://www.gnumeric.org/v10.dtd:Name))) - ;; (safe-name (string->safe-filename sheet-name)) - (cells (find-section dat 'http://www.gnumeric.org/v10.dtd:Cells)) - (remaining (remove-section (remove-section dat 'http://www.gnumeric.org/v10.dtd:Name) - 'http://www.gnumeric.org/v10.dtd:Cells)) - (rownums (make-hash-table)) ;; num -> name - (colnums (make-hash-table)) ;; num -> name - (cols (make-hash-table)) ;; name -> ( (name val) ... ) - (col0title "")) - (for-each (lambda (cell) - (let ((rownum (string->number (car (find-section cell 'Row)))) - (colnum (string->number (car (find-section cell 'Col)))) - (valtype (let ((res (find-section cell 'ValueType))) - (if res (car res) #f))) - (value (let ((res (cdr (filter (lambda (x)(not (list? x))) cell)))) - (if (null? res) "" (car res))))) - ;; If colnum is 0 Then this is a row name, if rownum is 0 then this is a col name - (cond - ((and (not (eq? 0 rownum)) - (eq? 0 colnum)) ;; a blank in column zero is handled with the special name "row-N" - (hash-table-set! rownums rownum (if (equal? value "") - (conc "row-" rownum) - value))) - ((and (not (eq? 0 colnum)) - (eq? 0 rownum)) - (hash-table-set! colnums colnum (if (equal? value "") - (conc "col-" colnum) - value))) - ((and (eq? 0 rownum) - (eq? 0 colnum)) - (set! col0title value)) - (else - (let ((colname (hash-table-ref/default colnums colnum (conc "col-" colnum))) - (rowname (hash-table-ref/default rownums rownum (conc "row-" rownum)))) - (hash-table-set! cols colname (cons (list rowname value) - (hash-table-ref/default cols colname '())))))))) - cells) - (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 () - (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) - (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)) - (colnum-b (assoc b ref-colnums))) - (if (and colnum-a colnum-b) - (< (cadr colnum-a)(cadr colnum-b)) - (if (and (string? a) - (string? b)) - (string< a b)))))))))) - (with-output-to-file (conc targdir "/sxml/" sheet-name ".sxml") - (lambda () - (pp remaining))) - sheet-name)) - -(define (sxml->file dat fname) - (with-output-to-file fname - (lambda () - ;; (print (sxml-serializer#serialize-sxml dat)) - (pp dat)))) - -(define (file->sxml fname) - (let ((res (read-file fname read))) - (if (null? res) - (begin - (print "ERROR: file " fname " is malformed for read") - #f) - (car res)))) - -(define (replace-sheet-name-index indat sheets) - (let* ((rem-dat (remove-section indat 'http://www.gnumeric.org/v10.dtd:SheetNameIndex)) - (one-sht (find-section rem-dat 'http://www.gnumeric.org/v10.dtd:SheetName)) ;; for the future if I ever decide to do this "right" - (mk-entry (lambda (sheet-name) - (append '(http://www.gnumeric.org/v10.dtd:SheetName - (@ (http://www.gnumeric.org/v10.dtd:Rows "65536") - (http://www.gnumeric.org/v10.dtd:Cols "256"))) - (list sheet-name)))) - (new-indx-values (map mk-entry sheets))) - (append rem-dat (list (cons 'http://www.gnumeric.org/v10.dtd:SheetNameIndex - new-indx-values))))) - - -;; Write an sxml gnumeric workbook to a refdb directory structure. -;; -(define (extract-refdb dat targdir) - (create-directory (conc targdir "/sxml") #t) - (let* ((wrkbk (find-section dat 'http://www.gnumeric.org/v10.dtd:Workbook)) - (wrk-rem (remove-section dat 'http://www.gnumeric.org/v10.dtd:Workbook)) - (sheets (find-section wrkbk 'http://www.gnumeric.org/v10.dtd:Sheets)) - (sht-rem (remove-section wrkbk 'http://www.gnumeric.org/v10.dtd:Sheets)) - (sheet-names (map (lambda (sheet) - (sheet->refdb sheet targdir)) - sheets))) - (sxml->file wrk-rem (conc targdir "/sxml/_workbook.sxml")) - (sxml->file sht-rem (conc targdir "/sxml/_sheets.sxml")) - (with-output-to-file (conc targdir "/sheet-names.cfg") - (lambda () - (map print sheet-names))))) - -(define (read-gnumeric-file fname) - (if (not (string-match (regexp ".*.gnumeric$") fname)) - (begin - (print "ERROR: Attempt to import gnumeric file with extention other than .gnumeric") - (exit)) - (let ((tmpf (create-temporary-file (pathname-strip-directory fname)))) - (system (conc " gunzip > " tmpf " < " fname)) - (let ((res (refdb:read-gnumeric-xml tmpf))) - (delete-file tmpf) - res)))) - -(define (import-gnumeric-file fname targdir) - (extract-refdb (read-gnumeric-file fname) targdir)) - -;; Write a gnumeric compressed xml spreadsheet from a refdb directory structure. -;; -(define (refdb-export dbdir fname) - (let* ((sxml-dat (refdb->sxml dbdir)) - (tmpf (create-temporary-file (pathname-strip-directory fname))) - (tmpgzf (conc tmpf ".gz"))) - (with-output-to-file tmpf - (lambda () - (print (sxml-serializer#serialize-sxml sxml-dat ns-prefixes: (list (cons 'gnm "http://www.gnumeric.org/v10.dtd")))))) - (system (conc "gzip " tmpf)) - (file-copy tmpgzf fname #t) - (delete-file tmpgzf))) - -(define (hash-table-reverse-lookup ht val) - (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)) - (cmnt-indx (make-hash-table)) - (blnk-indx (make-hash-table)) - (first-section #f)) ;; used for zeroth title - (let loop ((inl (read-line inp)) - (section ".............") - (res '())) - (if (eof-object? inl) - (begin - (close-input-port inp) - (cons (list first-section first-section first-section) - (reverse res))) - (regex-case - inl - (continue-rx _ (loop (conc inl (read-line inp)) section res)) - (comment-rx _ (let ((curr-indx (+ 1 (hash-table-ref/default cmnt-indx section 0)))) - (hash-table-set! cmnt-indx section curr-indx) - (loop (read-line inp) - section - (cons (list (conc "#CMNT" curr-indx) section inl) res)))) - (blank-rx _ (let ((curr-indx (+ 1 (hash-table-ref/default blnk-indx section 0)))) - (hash-table-set! blnk-indx section curr-indx) - (loop (read-line inp) - section - (cons (list (conc "#BLNK" curr-indx) section " ") res)))) - (section-rx (x sname) (begin - (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 - (cons (list k section "") res))) - (else (begin - (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 - (list 'ExprID exid) - (let* ((values (hash-table-keys expressions)) ;; note, values are the id numbers - (new-max (+ 1 (if (null? values) 0 (apply max values))))) - (hash-table-set! expressions val new-max) - (list 'ExprID new-max))))) - (else '(ValueType "60")))) - -(define (dat->cells dat) - (let* ((indx (common:sparse-list-generate-index (cdr dat))) - (row-indx (car indx)) - (col-indx (cadr indx)) - (rowdat (map (lambda (row)(list (car row) " " (car row))) row-indx)) - (coldat (map (lambda (col)(list " " (car col) (car col))) col-indx)) - (exprs (make-hash-table))) - (list (cons 'http://www.gnumeric.org/v10.dtd:Cells - (map (lambda (item) - (let* ((row-name (car item)) - (col-name (cadr item)) - (row-num (let ((i (assoc row-name row-indx))) - (if i (cadr i) 0))) ;; 0 for the title row/col - (col-num (let ((i (assoc col-name col-indx))) - (if i (cadr i) 0))) - (value (caddr item)) - (val-type (get-value-type value exprs))) - (list 'http://www.gnumeric.org/v10.dtd:Cell - (list '@ val-type (list 'Row (conc row-num)) (list 'Col (conc col-num))) - value))) - (append rowdat coldat dat)))))) - -(define (refdb->sxml dbdir) - (let* ((sht-names (read-file (conc dbdir "/sheet-names.cfg") read-line)) - (wrk-rem (file->sxml (conc dbdir "/sxml/_workbook.sxml"))) - (sht-rem (file->sxml (conc dbdir "/sxml/_sheets.sxml"))) - (sheets (fold (lambda (sheetname res) - (let* ((sheetdat (read-dat (conc dbdir "/" sheetname ".dat"))) - (cells (dat->cells sheetdat)) - (sht-meta (file->sxml (conc dbdir "/sxml/" sheetname ".sxml")))) - (cons (cons (car sht-meta) - (append (cons (list 'http://www.gnumeric.org/v10.dtd:Name sheetname) - (cdr sht-meta)) - cells)) - res))) - '() - (reverse sht-names)))) - (append wrk-rem (list (append - (cons 'http://www.gnumeric.org/v10.dtd:Workbook - sht-rem) - (list (cons 'http://www.gnumeric.org/v10.dtd:Sheets sheets))))))) - -;; (define ( - -;; -;; optional apply proc to rownum colnum value -;; -;; NB// If a change is made to this routine please look also at applying -;; it to the code in Megatest (http://www.kiatoa.com/fossils/megatest) -;; in the file common.scm -;; -(define (common:sparse-list-generate-index data #!key (proc #f)) - (if (null? data) - (list '() '()) - (let loop ((hed (car data)) - (tal (cdr data)) - (rownames '()) - (colnames '()) - (rownum 0) - (colnum 0)) - (let* ((rowkey (car hed)) - (colkey (cadr hed)) - (value (caddr hed)) - (existing-rowdat (assoc rowkey rownames)) - (existing-coldat (assoc colkey colnames)) - (curr-rownum (if existing-rowdat rownum (+ rownum 1))) - (curr-colnum (if existing-coldat colnum (+ colnum 1))) - (new-rownames (if existing-rowdat rownames (cons (list rowkey curr-rownum) rownames))) - (new-colnames (if existing-coldat colnames (cons (list colkey curr-colnum) colnames)))) - ;; (debug:print-info 0 "Processing record: " hed ) - (if proc (proc curr-rownum curr-colnum rowkey colkey value)) - (if (null? tal) - (list new-rownames new-colnames) - (loop (car tal) - (cdr tal) - new-rownames - new-colnames - (if (> curr-rownum rownum) curr-rownum rownum) - (if (> curr-colnum colnum) curr-colnum colnum) - )))))) -(define help - (conc "Usage: refdb action params ... - -Note: refdbdir is a path to the directory containg sheet-names.cfg - - import filename.gnumeric refdbdir : Import a gnumeric file into a txt db directory - export refdbdir filename.gnumeric : Export a refdb to a gnumeric file - edit refdbdir : Edit a refdbdir using gnumeric. - ls refdbdir : List the keys for specified level - lookup refdbdir sheetname row col : Look up a value in the text db - getrownames refdb sheetname : Get a list of row titles - getcolnames refdb sheetname : Get a list of column titles - -To export to other formats; first export to gnumeric then use ssconvert. - -e.g. - -refdb export mydata mydata.gnumeric -ssconvert -T Gnumeric_html:html40 mydata.gnumeric mydata.html - -Part of the Megatest tool suite. Learn more at http://www.kiatoa.com/fossils/megatest - -Version: " megatest-fossil-hash)) - -(define (list-sheets path) - ;; (cond - ;; ((and path (not sheet)(not row)(not col)) - (if (file-exists? path) - (read-file (conc path "/sheet-names.cfg") read-line) - '())) -;; ((and path sheet (not row)(not col)) - -(define (lookup path sheet row col) - (let ((fname (conc path "/" sheet ".dat"))) - (if (file-exists? fname) - (let ((dat (read-dat fname))) - (if (null? dat) - #f - (let loop ((hed (car dat)) - (tal (cdr dat))) - (if (and (equal? row (car hed)) - (equal? col (cadr hed))) - (caddr hed) - (if (null? tal) - #f - (loop (car tal)(cdr tal))))))) - #f))) - -;; call with proc = car to get row names -;; call with proc = cadr to get col names -(define (get-rowcol-names path sheet proc) - (let ((fname (conc path "/" sheet ".dat")) - (cmnt-rx (regexp "^#CMNT\\d+\\s*")) - (blnk-rx (regexp "^#BLNK\\d+\\s*"))) - (if (file-exists? fname) - (let ((dat (read-dat fname))) - (if (null? dat) - '() - (let loop ((hed (car dat)) - (tal (cdr dat)) - (res '())) - (let* ((row-name (proc hed)) - (newres (if (and (not (member row-name res)) - (not (string-search cmnt-rx row-name)) - (not (string-search blnk-rx row-name))) - (cons row-name res) - res))) - (if (null? tal) - (reverse newres) - (loop (car tal)(cdr tal) newres)))))) - '()))) - -;; (define (get-col-names path sheet) -;; (let ((fname (conc path "/" sheet ".dat"))) -;; (if (file-exists? fname) -;; (let ((dat (read-dat fname))) -;; (if (null? dat) -;; #f -;; (map cadr dat)))))) - -(define (edit-refdb path) - ;; TEMPORARY, REMOVE IN 2014 - (if (not (file-exists? path)) ;; Create new - (begin - (print "\nINFO: Creating new txtdb at " path "\n") - (create-new-db path))) - (if (not (file-exists? (conc path "/sxml/_sheets.sxml"))) - (begin - (print "ERROR: You appear to have the old file structure for txtdb. Please do the following and try again.") - (print) - (print "mv " path "/sxml/sheets.sxml " path "/sxml/_sheets.sxml") - (print "mv " path "/sxml/workbook.sxml " path "/sxml/_workbook.sxml") - (print) - (print "Don't forget to remove the old files from your revision control system and add the new.") - (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)))) - (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 -;;====================================================================== -;; -(define (process-action action-str . param) - (let ((num-params (length param)) - (action (string->symbol action-str))) - (cond - ((eq? num-params 1) - (case action - ((edit) - (edit-refdb (car param))) - ((ls) - (map print (list-sheets (car param)))))) - ((eq? num-params 2) - (let ((param1 (car param)) - (param2 (cadr param))) - (case action - ((getrownames) (print (string-intersperse (get-rowcol-names param1 param2 car) " "))) - ((getcolnames) (print (string-intersperse (get-rowcol-names param1 param2 cadr) " "))) - ((import) (import-gnumeric-file param1 param2)) ;; fname targname - ((export) (refdb-export param1 param2)) - (else (print "Unrecognised command " action)(print help))))) - ((eq? num-params 4) - (case action - ((lookup) ;; path section row col - (let ((res (lookup (car param)(cadr param)(caddr param)(cadddr param)))) - (if res - (print res) - (begin - (print "") - (exit 1)))))))))) - -(define (main) - (let* ((args (argv)) - (prog (car args)) - (rema (cdr args))) - (cond - ((null? rema)(print help)) - ((eq? (length rema) 1) - (case (string->symbol (car rema)) - ((mtedit) ;; Edit a Megatest area - (megatest->refdb)))) - ((>= (length rema) 2) - (apply process-action (car rema)(cdr rema))) - (else (print help))))) - -;;====================================================================== -;; C R E A T E N E W D B S -;;====================================================================== - -(include "metadat.scm") - -;; Creates a new db at path with one sheet -(define (create-new-db path) - (extract-refdb minimal-sxml path)) - -;;====================================================================== -;; M E G A T E S T S U P P O R T -;;====================================================================== - -;; Construct a temporary refdb area from the files in a Megatest area -;; -;; .refdb -;; megatest.dat (from megatest.config) -;; runconfigs.dat (from runconfigs.config) -;; tests_test1.dat (from tests/test1/testconfig) -;; etc. -;; - -(define (make-sheet-meta-if-needed fname) - (if (not (file-exists? fname)) - (sxml->file sheet-meta fname))) - -(define (megatest->refdb) - (if (not (file-exists? "megatest.config")) ;; must be at top of Megatest area - (begin - (print "ERROR: Must be at top of Megatest area to edit") - (exit))) - (create-directory ".refdb/sxml" #t) - (if (not (file-exists? ".refdb/sxml/_workbook.sxml")) - (sxml->file workbook-meta ".refdb/sxml/_workbook.sxml")) - (file-copy "megatest.config" ".refdb/megatest.dat" #t) - (make-sheet-meta-if-needed ".refdb/sxml/megatest.sxml") - (file-copy "runconfigs.config" ".refdb/runconfigs.dat" #t) - (make-sheet-meta-if-needed ".refdb/sxml/runconfigs.sxml") - (let ((testnames '())) - (for-each (lambda (tdir) - (let* ((testname (pathname-strip-directory tdir)) - (tconfig (conc tdir "/testconfig")) - (metafile (conc ".refdb/sxml/" testname ".sxml"))) - (if (file-exists? tconfig) - (begin - (set! testnames (append testnames (list testname))) - (file-copy tconfig (conc ".refdb/" testname ".dat") #t) - (make-sheet-meta-if-needed metafile))))) - (glob "tests/*")) - (let ((sheet-names (append (list "megatest" "runconfigs") testnames))) - (if (not (file-exists? ".refdb/sxml/_sheets.sxml")) - (sxml->file (replace-sheet-name-index sheets-meta sheet-names) ".refdb/sxml/_sheets.sxml")) - (with-output-to-file ".refdb/sheet-names.cfg" - (lambda () - (map print sheet-names)))))) - -(let ((dotfile (conc (get-environment-variable "HOME") "/.txtdbrc"))) - (if (file-exists? dotfile) - (load dotfile))) - -(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.refdbrc"))) - (if (file-exists? debugcontrolf) - (load debugcontrolf))) - -(main) - -#| - (define x (refdb:read-gnumeric-xml "testdata-stripped.xml")) - - - -;; Write out sxml -(with-output-to-file "testdata.sxml" (lambda()(pp x))) - - -;; (serialize-sxml a output: "new.xml") -(with-output-to-file "testdata-stripped.xml" (lambda ()(print (sxml-serializer#serialize-sxml y)))) - -;; Read in sxml file -(with-input-from-file "testdata.sxml" (lambda ()(set! y (read)))) - -(find-section x 'http://www.gnumeric.org/v10.dtd:Workbook) - -(define sheets (find-section x 'http://www.gnumeric.org/v10.dtd:Sheets)) - -(define sheet1 (car sheets)) -(define cells-sheet1 (find-section sheet1 'http://www.gnumeric.org/v10.dtd:Cells)) -(map (lambda (c)(find-section c 'Row)) cells-sheet1) - -(for-each (lambda (cell) - (let* ((len (length cell)) - (row (car (find-section cell 'Row))) - (col (car (find-section cell 'Col))) - (val (let ((res (cdr (filter (lambda (x)(not (list? x))) cell)))) - (if (null? res) "" (car res))))) - (print "Row=" row " col=" col " val=" val))) - cells-sheet1) - - -(map (lambda (c)(filter (lambda (x)(not (list? x))) c)) cells-sheet1) -|# Index: utils/Makefile.installall ================================================================== --- utils/Makefile.installall +++ utils/Makefile.installall @@ -21,10 +21,14 @@ @echo If needed set PROXY to host.dom:port @echo http_proxy=$(http_proxy) @echo PROX=$(PROX) @echo @echo To make all do: make all + @echo + @echo Note: might need to do CSC_OPTIONS='-C "-fPIC"' make + +# FPIC=-C "-fPIC" # Put the installation here ifeq ($(PREFIX),) PREFIX=$(PWD)/target endif @@ -43,11 +47,11 @@ # 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 + srfi-19 refdb ini-file sparse-vectors z3 call-with-environment-variables # # Derived variables # @@ -80,20 +84,25 @@ else ARCHSIZE=64_ endif CSCLIBS=$(shell echo $(LD_LIBRARY_PATH) | sed 's/:/ -L/g') -CSC_OPTIONS="-I$(PREFIX)/include -L$(CSCLIBS)" +CSC_OPTIONS="-I$(PREFIX)/include -L$(CSCLIBS) -C \"-fPIC\"" # CSC_OPTIONS=-I$(PREFIX)/include -L$(CSCLIBS) -all : chkn eggs libiup logprobin $(PREFIX)/lib/sqlite3.so $(PREFIX)/bin/hs +all : chkn eggs libiup logprobin $(PREFIX)/lib/sqlite3.so $(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 $(CHICKEN_EGG_DIR)/iup.so $(CHICKEN_EGG_DIR)/canvas-draw.so +# 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 @@ -106,14 +115,19 @@ mkdir -p eggflags touch $(EGGFLAGS) # some setup stuff # -setup-chicken4x.sh : $(EGGFLAGS) - (echo "export PATH=$(PATH)" > setup-chicken4x.sh) - (echo "export LD_LIBRARY_PATH=$(LD_LIBRARY_PATH)" >> setup-chicken4x.sh) +$(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 xfz chicken-$(CHICKEN_VERSION).tar.gz ln -sf chicken-$(CHICKEN_VERSION) chicken-core @@ -125,11 +139,11 @@ wget http://code.call-cc.org/releases/4.9.0/chicken-4.9.0.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 setup-chicken4x.sh +$(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 @@ -164,24 +178,51 @@ CSC_OPTIONS="-I$(PREFIX)/include -L$(PREFIX)/lib" $(CHICKEN_INSTALL) $(PROX) 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;fossil open ../opensrc.fossil + 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 $(PREFIX)/lib/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 + #====================================================================== # I U P #====================================================================== ffcall.fossil : @@ -210,14 +251,14 @@ cd iup && ./installall.sh # $(PREFIX)/lib/libiup.so : iup/iup/alldone # touch -c $(PREFIX)/lib/libiup.so -$(CHICKEN_EGG_DIR)/iup.so : $(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 -$(CHICKEN_EGG_DIR)/canvas-draw.so : $(PREFIX)/lib/libiup.so +$(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/installall.sh ================================================================== --- utils/installall.sh +++ utils/installall.sh @@ -140,13 +140,19 @@ fi # $CHICKEN_INSTALL $PROX sqlite3 # IUP versions -CDVER=5.7 -IUPVER=3.8 -IMVER=3.8 +if [[ x$USEOLDIUP == "x" ]];then + CDVER=5.7 + IUPVER=3.8 + IMVER=3.8 +else + CDVER=5.7 + IUPVER=3.8 + IMVER=3.8 +fi if [[ `uname -a | grep x86_64` == "" ]]; then export ARCHSIZE='' else export ARCHSIZE=64_ @@ -161,12 +167,12 @@ mkdir -p $PREFIX/iuplib for a in `echo $files` ; do if ! [[ -e tgz/$a ]] ; then wget http://www.kiatoa.com/matt/iup/$a + mv $a tgz/$a fi - mv $a tgz/$a echo Untarring tgz/$a into $BUILDHOME/lib (cd $PREFIX/lib;tar xfvz $BUILDHOME/tgz/$a;mv include/* ../include) # (cd $DEPLOYTARG;tar xfvz $BUILDHOME/$a) done @@ -196,15 +202,15 @@ # NB// Removed bunch of zmq compiling tricks. Look at older versions of this file if you need to recreate... cd $BUILDHOME -git clone https://bitbucket.org/DerGuteMoritz/zmq/commits/branch/3.2 zmq-3.2 -cd zmq-3.2 -chicken-install - -cd $BUILDHOME +# git clone https://bitbucket.org/DerGuteMoritz/zmq/commits/branch/3.2 zmq-3.2 +# cd zmq-3.2 +# chicken-install +# +# cd $BUILDHOME ## WEBKIT=WebKit-r131972 ## if ! [[ -e ${WEBKIT}.tar.bz2 ]] ; then ## # http://builds.nightly.webkit.org/files/trunk/src/WebKit-r131972.tar.bz2 ## wget http://builds.nightly.webkit.org/files/trunk/src/${WEBKIT}.tar.bz2 Index: utils/mk_wrapper ================================================================== --- utils/mk_wrapper +++ utils/mk_wrapper @@ -18,9 +18,14 @@ echo else echo "INFO: LD_LIBRARY_PATH not set" >&2 fi +# echo "#!/bin/bash" > $target +# if [ "$LD_LIBRARY_PATH" != "" ];then +# echo "source $prefix/bin/.\$(lsb_release -sr)/cfg.sh" >> $target +# fi +# echo "exec $prefix/bin/.\$(lsb_release -sr)/$cmd \"\$@\"" >> $target echo "#!/bin/bash" > $target -echo "source $prefix/bin/.\$(lsb_release -sr)/cfg.sh" >> $target -echo "exec $prefix/bin/.\$(lsb_release -sr)/$cmd \"\$@\"" >> $target - +echo "lsbr=\$(lsb_release -sr)" >> $target +echo "if [[ -e \$lsbr ]];then source \$lsbr;fi" >> $target +echo "exec $prefix/bin/.\$lsbr/$cmd \"\$@\"" >> $target Index: utils/mt_ezstep ================================================================== --- utils/mt_ezstep +++ utils/mt_ezstep @@ -1,11 +1,11 @@ #!/bin/bash usage="mt_ezstep stepname prevstepname command [args ...]" -if [ "$MT_CMDINFO" == "" ];then - if [ -e megatest.sh ];then +if [[ "$MT_CMDINFO" == "" ]];then + if [[ -e megatest.sh ]];then source megatest.sh else echo "ERROR: $0 should be run within a megatest test environment" echo "Usage: $usage" exit @@ -16,11 +16,11 @@ # DO NOT USE IN YOUR SCRIPTS! # # Call like this: # mt_ezstep stepname prevstepname command .... # -if [ "x$1" == "x" ];then +if [[ "x$1" == "x" ]];then echo "Usage: $usage" exit fi # Since the user may not have . on the path and since we are likely to want to @@ -34,19 +34,20 @@ allstatus=99 runstatus=99 logpropstatus=99 -prev_env=.ezsteps/${prevstepname}.sh -if [ -e $prev_env ];then - source $prev_env -fi +# prev_env=".ezsteps/${prevstepname}.sh" +# echo "prev_env=$prev_env" +# if [[ -e "${prev_env}" ]];then +# source $prev_env +# fi # source the environment from the previous step if it exists # if a logpro file exists then use it otherwise just run the command, nb// was using 2>&1 -if [ -e ${stepname}.logpro ];then +if [[ -e ${stepname}.logpro ]];then # could do: $command 2>&1| tee ${stepname}.log | logpro ${stepname}.logpro ${stepname}.html &> /dev/null logprostatus=$? # $command 2>&1| logpro ${stepname}.logpro ${stepname}.html &> ${stepname}.log # allstatus=(${PIPESTATUS[0]} ${PIPESTATUS[1]}) @@ -60,19 +61,19 @@ fi # If the test exits with non-zero, we will record FAIL even if logpro # says it is a PASS -if [ $runstatus -ne 0 ]; then +if [[ $runstatus -ne 0 ]]; then exitstatus=$runstatus -elif [ $logprostatus -eq 0 ]; then +elif [[ $logprostatus -eq 0 ]]; then exitstatus=$logprostatus -elif [ $logprostatus -eq 2 ]; then +elif [[ $logprostatus -eq 2 ]]; then exitstatus=2 -elif [ $logprostatus -eq 1 ]; then +elif [[ $logprostatus -eq 1 ]]; then exitstatus=1 else exitstatus=0 fi # $MT_MEGATEST -env2file .ezsteps/${stepname} exit $exitstatus Index: utils/mt_laststep ================================================================== --- utils/mt_laststep +++ utils/mt_laststep @@ -20,12 +20,13 @@ # mt_runstep copy_files cp $frompath $topath # # Use a copy_files.logpro file like this: # (expect:error in "LogFileBody" = 0 "Any err/error/warn/warning" #/(err|warn)/) # -stepname=$1;shift +stepname=$1;shifttepname" +echo "stepname=$s # Theoretically could call megatest directly like the following line but # we'll do each individual step so folks can see what is going on. # # $MT_MEGATEST -runstep $stepname -logpro ${stepname}.logpro "$*" || exit $?