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 @@
</div></div>
</div>
</div>
</div>
<h1 id="_reference">Reference</h1>
+<div class="sect1">
+<h2 id="_config_file_settings">Config File Settings</h2>
+<div class="sectionbody">
+<div class="sect2">
+<h3 id="_trim_trailing_spaces">Trim trailing spaces</h3>
+<div class="listingblock">
+<div class="content">
+<pre><code>[configf:settings trim-trailing-spaces yes]</code></pre>
+</div></div>
+</div>
+</div>
+</div>
<div class="sect1">
<h2 id="_the_testconfig_file">The testconfig File</h2>
<div class="sectionbody">
<div class="sect2">
<h3 id="_setup_section">Setup section</h3>
@@ -1378,10 +1390,11 @@
</div>
<div id="footnotes"><hr /></div>
<div id="footer">
<div id="footer-text">
Version 1.0<br />
-Last updated 2015-04-06 08:49:48 MST
+Last updated
+ 2015-03-30 19:19:55 MST
</div>
</div>
</body>
</html>
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:
# <target>/<runname>/<test>/
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)