Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -36,11 +36,11 @@ ARCHSTR=$(shell lsb_release -sr) # ARCHSTR=$(shell bash -c "echo \$$MACHTYPE") all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard -mtest: $(OFILES) megatest.o readline-fix.scm +mtest: $(OFILES) readline-fix.scm megatest.o csc $(CSCOPTS) $(OFILES) megatest.o -o mtest dboard : $(OFILES) $(GOFILES) dashboard.scm csc $(OFILES) dashboard.scm $(GOFILES) -o dboard Index: archive.scm ================================================================== --- archive.scm +++ archive.scm @@ -135,11 +135,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 @@ -220,11 +220,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)) Index: batchsim/Makefile ================================================================== --- batchsim/Makefile +++ batchsim/Makefile @@ -1,7 +1,8 @@ +RUN=default.scm all : batchsim - ./batchsim + ./batchsim $(RUN) batchsim : batchsim.scm csc batchsim.scm Index: batchsim/batchsim.scm ================================================================== --- batchsim/batchsim.scm +++ batchsim/batchsim.scm @@ -61,10 +61,74 @@ 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 ;;====================================================================== Index: batchsim/default.scm ================================================================== --- batchsim/default.scm +++ batchsim/default.scm @@ -7,10 +7,18 @@ (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" '()) 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) +;; Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -215,10 +215,11 @@ (tasks:hostinfo-get-port server-info))) ;; client:signal-handler (define (client:signal-handler signum) (signal-mask! signum) + (set! *time-to-exit* #t) (handle-exceptions exn (debug:print " ... exiting ...") (let ((th1 (make-thread (lambda () "") ;; do nothing for now (was flush out last call if applicable) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -275,39 +275,51 @@ ;;====================================================================== ;; E X I T H A N D L I N G ;;====================================================================== (define (std-exit-procedure area-dat) - (debug:print-info 2 "starting exit process, finalizing databases.") + (set! *time-to-exit* #t) (rmt:print-db-stats area-dat) (let* ((configdat (megatest:area-configdat area-dat)) (run-ids (hash-table-keys *db-local-sync*))) - (if (and (not (null? run-ids)) - (configf:lookup configdat "setup" "megatest-db")) - (db:multi-db-sync run-ids 'new2old))) - (if *dbstruct-db* (db:close-all *dbstruct-db* area-dat)) - (if *inmemdb* (db:close-all *inmemdb* area-dat)) - (if (and *megatest-db* - (sqlite3:database? *megatest-db*)) - (begin - (sqlite3:interrupt! *megatest-db*) - (sqlite3:finalize! *megatest-db* #t) - (set! *megatest-db* #f))) - (if *task-db* (let ((db (cdr *task-db*))) - (if (sqlite3:database? db) - (begin - (sqlite3:interrupt! db) - (sqlite3:finalize! db #t) - (vector-set! *task-db* 0 #f)))))) - + (if (debug:debug-mode 18) + (rmt:print-db-stats)) + (let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds + (if (and (not (null? run-ids)) + (configf:lookup configdat "setup" "megatest-db")) + (db:multi-db-sync run-ids 'new2old)) + (if *dbstruct-db* (db:close-all *dbstruct-db* area-dat)) + (if *inmemdb* (db:close-all *inmemdb* area-dat)) + (if (and *megatest-db* + (sqlite3:database? *megatest-db*)) + (begin + (sqlite3:interrupt! *megatest-db*) + (sqlite3:finalize! *megatest-db* #t) + (set! *megatest-db* #f))) + (if *task-db* (let ((db (cdr *task-db*))) + (if (sqlite3:database? db) + (begin + (sqlite3:interrupt! db) + (sqlite3:finalize! db #t) + (vector-set! *task-db* 0 #f)))))) "Cleanup db exit thread")) + (th2 (make-thread (lambda () + (debug:print 4 "Exiting with clean exit. Please be patient and wait a few seconds.") + (thread-sleep! 5) ;; give the clean up few seconds to do it's stuff + (debug:print 4 " Done.") + (exit)) + "exit timer"))) + (thread-start! th2) + (thread-start! th1) + (thread-join! th2)))) + (define (std-signal-handler signum) - (signal-mask! signum) + ;; (signal-mask! signum) (debug:print 0 "ERROR: Received signal " signum " exiting promptly") ;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway (exit)) -(set-signal-handler! signal/int std-signal-handler) +(set-signal-handler! signal/int std-signal-handler) ;; ^C (set-signal-handler! signal/term std-signal-handler) ;;====================================================================== ;; Misc utils ;;====================================================================== 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) @@ -125,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 \ @@ -137,37 +138,41 @@ (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) @@ -176,12 +181,15 @@ (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 @@ -190,18 +198,18 @@ "/" include-file))))) (if (file-exists? full-conf) (begin ;; (push-directory conf-dir) (debug:print 9 "Including: " full-conf) - (read-config full-conf res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections) + (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 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)) @@ -225,12 +233,12 @@ 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))) @@ -237,16 +245,16 @@ (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" @@ -256,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: db.scm ================================================================== --- db.scm +++ db.scm @@ -516,11 +516,12 @@ (for-each (lambda (dbdat) (debug:print 0 " dbpath: " (db:dbdat-get-path dbdat))) (cons todb slave-dbs)) (if *server-run* ;; we are inside a server, throw a sync-failed error (signal (make-composite-condition - (make-property-condition 'sync-failed 'message "db:sync-tables failed in a server context."))))) + (make-property-condition 'sync-failed 'message "db:sync-tables failed in a server context."))) + 0)) ;; return zero for num synced ;; (set! *time-to-exit* #t) ;; let watch dog know that it is time to die. ;; (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "shutting-down") ;; (portlogger:open-run-close portlogger:set-port port "released") ;; (exit 1))) @@ -576,11 +577,11 @@ ;; tack on remaining records in fromdat (if (not (null? fromdat)) (set! fromdats (cons fromdat fromdats))) - (debug:print-info 2 "found " totrecords " records to sync") + (debug:print-info 4 "found " totrecords " records to sync") ;; read the target table (sqlite3:for-each-row (lambda (a . b) (hash-table-set! todat a (apply vector a b))) @@ -2092,11 +2093,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 area-dat 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")) ) @@ -2270,11 +2271,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: docs/manual/megatest_manual.html ================================================================== --- docs/manual/megatest_manual.html +++ docs/manual/megatest_manual.html @@ -1038,10 +1038,22 @@

Reference

+
+

Config File Settings

+
+
+

Trim trailing spaces

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

The testconfig File

Setup section

@@ -1378,10 +1390,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: 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)))) "."))) @@ -430,11 +431,11 @@ (debug:print 0 "ERROR: error from sync code other than 'sync-failed. Attempting to gracefully shutdown the server") (tasks:server-delete-record (db:delay-if-busy tdbdat area-dat) server-id " http-transport:keep-running crashed") (exit))) (set! sync-time (- (current-milliseconds) start-time)) (set! rem-time (quotient (- 4000 sync-time) 1000)) - (debug:print 2 "SYNC: time= " sync-time ", rem-time=" rem-time) + (debug:print 4 "SYNC: time= " sync-time ", rem-time=" rem-time) (if (and (<= rem-time 4) (> rem-time 0)) (thread-sleep! rem-time) (thread-sleep! 4))) ;; fallback for if the math is changed ... Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -81,13 +81,23 @@ (debug:print 4 "script: " script) (rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f area-dat) ;; now launch the actual process (call-with-environment-variables (list (cons "PATH" (conc (get-environment-variable "PATH") ":."))) +<<<<<<< BEGIN MERGE CONFLICT: local copy shown first <<<<<<<<<<<<<<< + (lambda () ;; (process-run "/bin/bash" "-c" "exec ls -l /tmp/foobar > /tmp/delme-more.log 2>&1") + (let* ((cmd (conc stepcmd " > " stepname ".log 2>&1")) ;; >outfile 2>&1 + (pid (process-run "/bin/bash" (list "-c" cmd)))) +======= COMMON ANCESTOR content follows ============================ (lambda () (let* ((cmd (conc stepcmd " > " stepname ".log")) (pid (process-run cmd))) +======= MERGED IN content follows ================================== + (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)))) +>>>>>>> END MERGE CONFLICT >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> (rmt:test-set-top-process-pid run-id test-id pid area-dat) (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) @@ -200,15 +210,18 @@ ) (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 area-dat))) - (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)))) @@ -894,11 +907,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 @@ -932,18 +953,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: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -1,7 +1,13 @@ ;; 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)) +<<<<<<< BEGIN MERGE CONFLICT: local copy shown first <<<<<<<<<<<<<<< +(define megatest-version 1.6014) +======= COMMON ANCESTOR content follows ============================ (define megatest-version 1.6009) +======= MERGED IN content follows ================================== +(define megatest-version 1.6013) +>>>>>>> END MERGE CONFLICT >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -324,50 +324,57 @@ (thread-sleep! 0.05) ;; delay for startup ;; the query to get megatest-db setting might not work, forcing it to be default on. Use "no" to turn off (let ((legacy-sync (configf:lookup (megatest:area-configdat *area-dat*) "setup" "megatest-db")) (debug-mode (debug:debug-mode 1)) (last-time (current-seconds))) - (let loop () - ;; sync for filesystem local db writes - ;; - (let ((start-time (current-seconds)) - (servers-started (make-hash-table))) - (for-each - (lambda (run-id) - (mutex-lock! *db-multi-sync-mutex*) + (if (or (args:get-arg "-runtests") + (args:get-arg "-server") + (args:get-arg "-set-run-status") + (args:get-arg "-remove-runs") + (args:get-arg "-get-run-status") + ) + (let loop () + ;; sync for filesystem local db writes + ;; + (let ((start-time (current-seconds)) + (servers-started (make-hash-table))) + (for-each + (lambda (run-id) + (mutex-lock! *db-multi-sync-mutex*) (if (and (not (equal? legacy-sync "no")) - (hash-table-ref/default *db-local-sync* run-id #f)) - ;; (if (> (- start-time last-write) 5) ;; every five seconds - (begin ;; let ((sync-time (- (current-seconds) start-time))) + (hash-table-ref/default *db-local-sync* run-id #f)) + ;; (if (> (- start-time last-write) 5) ;; every five seconds + (begin ;; let ((sync-time (- (current-seconds) start-time))) (db:multi-db-sync (list run-id) *area-dat* 'new2old) - (if (common:low-noise-print 30 "sync new to old") - (let ((sync-time (- (current-seconds) start-time))) - (debug:print-info 0 "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds"))) - ;; (if (> sync-time 10) ;; took more than ten seconds, start a server for this run - ;; (begin - ;; (debug:print-info 0 "Sync is taking a long time, start up a server to assist for run " run-id) - ;; (server:kind-run run-id))))) - (hash-table-delete! *db-local-sync* run-id))) - (mutex-unlock! *db-multi-sync-mutex*)) - (hash-table-keys *db-local-sync*)) - (if (and debug-mode - (> (- start-time last-time) 60)) - (begin - (set! last-time start-time) - (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)) - (if (and (not *time-to-exit*) - (< count 11)) ;; aprox 5-6 seconds - (begin - (thread-sleep! 1) - (delay-loop (+ count 1)))) - (loop)))))) - "Watchdog thread")) + (if (common:low-noise-print 30 "sync new to old") + (let ((sync-time (- (current-seconds) start-time))) + (debug:print-info 0 "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds"))) + ;; (if (> sync-time 10) ;; took more than ten seconds, start a server for this run + ;; (begin + ;; (debug:print-info 0 "Sync is taking a long time, start up a server to assist for run " run-id) + ;; (server:kind-run run-id))))) + (hash-table-delete! *db-local-sync* run-id))) + (mutex-unlock! *db-multi-sync-mutex*)) + (hash-table-keys *db-local-sync*)) + (if (and debug-mode + (> (- start-time last-time) 60)) + (begin + (set! last-time start-time) + (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)) + (if (and (not *time-to-exit*) + (< count 11)) ;; aprox 5-6 seconds + (begin + (thread-sleep! 1) + (delay-loop (+ count 1)))) + (loop))) + (debug:print-info 0 "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*)))) + "Watchdog thread"))) (thread-start! *watchdog*) (if (args:get-arg "-log") (let ((oup (open-output-file (args:get-arg "-log")))) Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -185,11 +185,11 @@ (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 (rmt:get-test-id run-id test-name item-path))) - (mt:test-set-state-status-by-id test-id new-state new-status new-comment))) + (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 area-dat) (let ((tconf (hash-table-ref/default *testconfigs* test-name #f)) (configdat (megatest:area-configdat area-dat))) (if tconf Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -254,11 +254,11 @@ (rmt:open-qry-close-locally cmd run-id area-dat 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)) @@ -425,11 +425,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)) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -226,18 +226,29 @@ (task-key (conc (hash-table->alist flags) " " (get-host-name) " " (current-process-id))) (tdbdat (tasks:open-db area-dat))) (if (tasks:need-server run-id area-dat)(tasks:start-and-wait-for-server tdbdat run-id 10)) - (set-signal-handler! signal/int - (lambda (signum) - (signal-mask! signum) - (print "Received signal " signum ", cleaning up before exit. Please wait...") - (let ((tdbdat (tasks:open-db area-dat))) - (rmt:tasks-set-state-given-param-key task-key "killed")) - (print "Killed by signal " signum ". Exiting") - (exit))) + (let ((sighand (lambda (signum) + ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting + (set! *time-to-exit* #t) + (print "Received signal " signum ", cleaning up before exit. Please wait...") + ;; (let ((tdbdat (tasks:open-db area-dat))) + (let ((th1 (make-thread (lambda () + (let ((tdbdat (tasks:open-db))) + (rmt:tasks-set-state-given-param-key task-key "killed")) + (print "Killed by signal " signum ". Exiting") + (exit)))) + (th2 (make-thread (lambda () + (thread-sleep! 3) + (debug:print 0 "Done") + (exit 4))))) + (thread-start! th2) + (thread-start! th1) + (thread-join! th2))))) + (set-signal-handler! signal/int sighand) + (set-signal-handler! signal/term sighand)) ;; register this run in monitor.db (rmt:tasks-add "run-tests" user target runname test-patts task-key area-dat) ;; params) (rmt:tasks-set-state-given-param-key task-key "running" area-dat) (runs:set-megatest-env-vars run-id area-dat inkeys: keys inrunname: runname) ;; these may be needed by the launching process @@ -247,19 +258,25 @@ ;; Now generate all the tests lists (set! all-tests-registry (tests:get-all area-dat)) (set! all-test-names (hash-table-keys all-tests-registry)) (set! test-names (tests:filter-test-names all-test-names test-patts)) - (set! required-tests (lset-intersection equal? (string-split test-patts ",") test-names)) + + ;; I think seeding required-tests with all test-names makes sense but lack analysis to back that up. + ;; + ;; (set! required-tests (lset-intersection equal? (string-split test-patts ",") all-test-names)) + (set! required-tests (lset-intersection equal? test-names all-test-names)) ;; look up all tests matching the comma separated list of globs in ;; test-patts (using % as wildcard) ;; (set! test-names (delete-duplicates (tests:get-valid-tests toppath test-patts))) - (debug:print-info 0 "tests search path: " (tests:get-tests-search-path configdat area-dat)) - (debug:print-info 0 "all tests: " (string-intersperse (sort all-test-names string<) " ")) - (debug:print-info 0 "test names: " (string-intersperse (sort test-names string<) " ")) + (debug:print-info 0 "tests search path: " (string-intersperse (tests:get-tests-search-path configdat area-dat " "))) + ;; (debug:print-info 0 "tests search path: " (string-intersperse (tests:get-tests-search-path *configdat*) " ")) + (debug:print-info 0 "all tests: " (string-intersperse (sort all-test-names string<) " ")) + (debug:print-info 0 "test names: " (string-intersperse (sort test-names string<) " ")) + (debug:print-info 0 "required tests: " (string-intersperse (sort required-tests string<) " ")) ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if ;; -keepgoing is specified (if (eq? *passnum* 0) (begin @@ -548,11 +565,11 @@ (give-up #f)) ;; We can get here when a prereq has not been run due to *it* having a prereq that failed. ;; We need to use this to dequeue this item as CANNOTRUN ;; - (if (member testmode '(toplevel)) + (if (member 'toplevel testmode) ;; '(toplevel)) ;; NOTE: this probably should be (member 'toplevel testmode) (for-each (lambda (prereq) (if (eq? (hash-table-ref/default test-registry prereq 'justfine) 'CANNOTRUN) (set! give-up #t))) prereqstrs)) @@ -656,11 +673,13 @@ (max-concurrent-jobs (list-ref run-limits-info 3)) (job-group-limit (list-ref run-limits-info 4)) (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons item-path testmode area-dat itemmap: itemmap)) ;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap)) (fails (runs:calc-fails prereqs-not-met)) - (non-completed (runs:calc-not-completed prereqs-not-met)) + (non-completed (filter (lambda (x) ;; remove hed from not completed list, duh, of course it is not completed! + (not (equal? x hed))) + (runs:calc-not-completed prereqs-not-met))) (loop-list (list hed tal reg reruns)) ;; configure the load runner (numcpus (common:get-num-cpus)) (maxload (string->number (or (configf:lookup configdat "jobtools" "maxload") "3"))) (waitdelay (string->number (or (configf:lookup configdat "jobtools" "waitdelay") "60")))) @@ -668,11 +687,15 @@ (string-intersperse (map (lambda (t) (if (vector? t) (conc (db:test-get-state t) "/" (db:test-get-status t)) (conc " WARNING: t is not a vector=" t ))) - prereqs-not-met) ", ") ") fails: " fails) + prereqs-not-met) + ", ") ") fails: " fails + "\nregistered? " (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f)) + + (if (and (not (null? prereqs-not-met)) (runs:lownoise (conc "waiting on tests " prereqs-not-met hed) 60)) (debug:print-info 2 "waiting on tests; " (string-intersperse (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) ", "))) @@ -752,11 +775,11 @@ ;; This is the final stage, everything is in place so launch the test ;; ((and have-resources (or (null? prereqs-not-met) - (and (eq? testmode 'toplevel) + (and (member 'toplevel testmode) ;; 'toplevel) (null? non-completed)))) ;; (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)) @@ -785,11 +808,12 @@ (if (and (not (null? prereqs-not-met)) (runs:lownoise (conc "waiting on tests " prereqs-not-met hed) 60)) (debug:print-info 1 "waiting on tests; " (string-intersperse (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) ", "))) - (if (null? fails) + (if (or (null? fails) + (member 'toplevel testmode)) (begin ;; couldn't run, take a breather (if (runs:lownoise "Waiting for more work to do..." 60) (debug:print-info 0 "Waiting for more work to do...")) (thread-sleep! 1) @@ -857,11 +881,12 @@ (if (runs:lownoise (conc "FAILED prerequitests and we tried" hed) 60) (debug:print 0 "WARNING: test " hed " has FAILED prerequitests and we've tried at least 10 times to run it. Giving up now.")) ;; (debug:print 0 " prereqs: " prereqs-not-met) (hash-table-set! test-registry hed 'removed) (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "TEN_STRIKES" #f) - (mt:roll-up-pass-fail-counts run-id test-name item-path "FAIL") ;; treat as FAIL + ;; I'm unclear on if this roll up is needed - it may be the root cause of the "all set to FAIL" bug. + (rmt:roll-up-pass-fail-counts run-id test-name item-path "FAIL") ;; treat as FAIL (list (if (null? tal)(car newtal)(car tal)) tal reg reruns))))) ;; can't drop this - maybe running? Just keep trying @@ -975,11 +1000,11 @@ (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. @@ -1347,11 +1372,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)) @@ -1579,15 +1617,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)))))) 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 @@ -213,14 +213,19 @@ # 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"))} -# +[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/tests/all_toplevel/testconfig ================================================================== --- tests/fullrun/tests/all_toplevel/testconfig +++ tests/fullrun/tests/all_toplevel/testconfig @@ -1,13 +1,13 @@ [ezsteps] calcresults megatest -list-runs $MT_RUNNAME -target $MT_TARGET [requirements] -waiton all_toplevel exit_0 exit_1 ez_exit2_fail ez_fail ez_pass ezlog_fail \ +waiton exit_0 exit_1 ez_exit2_fail ez_fail ez_pass ezlog_fail \ ezlog_fail_then_pass ezlog_pass ezlog_warn lineitem_fail lineitem_pass logpro_required_fail \ - manual_example neverrun priority_1 priority_10 priority_10_waiton_1 priority_2 \ + manual_example neverrun priority_1 priority_10 priority_10_waiton_1 \ priority_3 priority_4 priority_5 priority_6 priority_7 priority_8 \ priority_9 runfirst singletest singletest2 sqlitespeed test_mt_vars \ - ez_fail_quick test1 test2 special blocktestxz + ez_fail_quick test1 test2 # This is a "toplevel" test, it does not require waitons to be non-FAIL to run mode toplevel 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: utils/Makefile.installall ================================================================== --- utils/Makefile.installall +++ utils/Makefile.installall @@ -47,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 z3 + srfi-19 refdb ini-file sparse-vectors z3 call-with-environment-variables # # Derived variables # @@ -87,11 +87,15 @@ CSCLIBS=$(shell echo $(LD_LIBRARY_PATH) | sed 's/:/ -L/g') CSC_OPTIONS="-I$(PREFIX)/include -L$(CSCLIBS) -C \"-fPIC\"" # CSC_OPTIONS=-I$(PREFIX)/include -L$(CSCLIBS) -all : chkn eggs libiup logprobin $(PREFIX)/lib/sqlite3.so $(PREFIX)/bin/hs $(PREFIX)/lib/chicken/7/mutils.so +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) @@ -111,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 @@ -130,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 @@ -177,14 +186,20 @@ 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 @@ -192,16 +207,21 @@ # stml stml.fossil : fossil clone http://www.kiatoa.com/fossils/stml stml.fossil -stml/stml.scm : stml.fossil +# open touches the .fossil :( +stml/requirements.scm.template : stml.fossil mkdir -p stml - cd stml;fossil open ../stml.fossil + 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/stml.so - cd stml;chicken-install +$(PREFIX)/lib/chicken/7/stml.so : stml/requirements.scm + cd stml;make #====================================================================== # I U P #====================================================================== @@ -231,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)