Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -105,10 +105,14 @@ chmod a+x $@ $(PREFIX)/bin/nbfind : utils/nbfind $(INSTALL) $< $@ chmod a+x $@ + +$(PREFIX)/bin/nbload : utils/nbload + $(INSTALL) $< $@ + chmod a+x $@ $(PREFIX)/bin/refdb : refdb $(INSTALL) $< $@ chmod a+x $@ @@ -126,11 +130,11 @@ $(INSTALL) dboard $(PREFIX)/bin/dboard utils/mk_wrapper $(PREFIX) dboard > $(PREFIX)/bin/dashboard chmod a+x $(PREFIX)/bin/dashboard install : bin $(PREFIX)/bin/mtest $(PREFIX)/bin/megatest $(PREFIX)/bin/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \ - $(PREFIX)/bin/nbfind $(PREFIX)/bin/newdboard $(PREFIX)/bin/refdb $(PREFIX)/bin/mt_xterm $(PREFIX)/bin/revtagfsl + $(PREFIX)/bin/nbfind $(PREFIX)/bin/nbload $(PREFIX)/bin/newdboard $(PREFIX)/bin/refdb $(PREFIX)/bin/mt_xterm $(PREFIX)/bin/revtagfsl deploytarg/apropos.so : Makefile for i in apropos base64 canvas-draw csv-xml directory-utils dot-locking extras fmt format hostinfo http-client intarweb json md5 message-digest posix posix-extras readline regex regex-case s11n spiffy spiffy-request-vars sqlite3 srfi-1 srfi-18 srfi-69 tcp test uri-common check-errors synch matchable sql-null tcp-server rpc blob-utils string-utils variable-item defstruct uri-generic sendfile opensll openssl lookup-table list-utils stack; do \ chicken-install -prefix deploytarg -deploy $$i;done Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -347,11 +347,11 @@ "unknown" (caar uname-res)))) (define (save-environment-as-files fname #!key (ignorevars (list "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR"))) (let ((envvars (get-environment-variables)) - (whitesp (regexp "[^a-zA-Z0-9_\\-:;,.\\/%$]"))) + (whitesp (regexp "[^a-zA-Z0-9_\\-:,.\\/%$]"))) (with-output-to-file (conc fname ".csh") (lambda () (for-each (lambda (key) (if (not (member key ignorevars)) (let* ((val (cdr key)) Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -76,12 +76,18 @@ lbl) (store-label "testcomment" (iup:label "TestComment " #:expand "HORIZONTAL") (lambda (testdat) - ;; (sdb:qry 'getstr - (db:test-get-comment testdat))) ;; ) + (let ((newcomment (db:test-get-comment testdat))) + (if *dashboard-comment-share-slot* + (if (not (equal? (iup:attribute *dashboard-comment-share-slot* "VALUE") + newcomment)) + (iup:attribute-set! *dashboard-comment-slot* + "VALUE" + newcomment))) + newcomment))) (store-label "testid" (iup:label "TestId " #:expand "HORIZONTAL") (lambda (testdat) (db:test-get-id testdat))) @@ -216,28 +222,34 @@ (color (car (gutils:get-color-for-state-status state status)))) ((vector-ref *state-status* 0) state color) ((vector-ref *state-status* 1) status color))) (define *dashboard-test-db* #t) +(define *dashboard-comment-share-slot* #f) ;;====================================================================== ;; Set fields ;;====================================================================== (define (set-fields-panel dbstruct run-id test-id testdat #!key (db #f)) (let ((newcomment #f) (newstatus #f) - (newstate #f)) + (newstate #f) + (wtxtbox #f)) (iup:frame #:title "Set fields" (iup:vbox (iup:hbox (iup:label "Comment:") - (iup:textbox #:action (lambda (val a b) + (let ((txtbox (iup:textbox #:action (lambda (val a b) (rmt:test-set-state-status-by-id run-id test-id #f #f b) - ;; IDEA: Just set a variable with the proc to call? - (set! newcomment b)) - #:value (db:test-get-comment testdat) - #:expand "HORIZONTAL")) + ;; IDEA: Just set a variable with the proc to call? + (open-run-close db:test-set-state-status-by-id db test-id #f #f b) + (set! newcomment b)) + #:value (db:test-get-comment testdat) + #:expand "HORIZONTAL"))) + (set! wtxtbox txtbox) + txtbox)) + (apply iup:hbox (iup:label "STATE:" #:size "30x") (let* ((btns (map (lambda (state) (let ((btn (iup:button state #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" @@ -262,12 +274,20 @@ (let ((btn (iup:button status #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" #:action (lambda (x) (let ((t (iup:attribute x "TITLE"))) (if (equal? t "WAIVED") - (iup:show (dashboard-tests:waiver testdat (lambda (c) - (set! newcomment c)))) + (iup:show (dashboard-tests:waiver testdat + (if wtxtbox (iup:attribute wtxtbox "VALUE") #f) + (lambda (c) + (set! newcomment c) + (if wtxtbox + (begin + (iup:attribute-set! wtxtbox "VALUE" c) + (if (not *dashboard-comment-share-slot*) + (set! *dashboard-comment-share-slot* wtxtbox))) + )))) (begin (open-run-close db:test-set-state-status-by-id db test-id #f status #f) (db:test-set-status! testdat status)))))))) btn)) (map cadr *common:std-statuses*)))) ;; (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP")))) @@ -314,21 +334,21 @@ ;; #:expand "HORIZONTAL" ;; #:action (lambda (obj) ;; (print "Refresh test data " stepname)) ))) -(define (dashboard-tests:waiver testdat cmtcmd) +(define (dashboard-tests:waiver testdat ovrdval cmtcmd) (let* ((wpatt (configf:lookup *configdat* "setup" "waivercommentpatt")) (wregx (if (string? wpatt)(regexp wpatt) #f)) (wmesg (iup:label (if wpatt (conc "Comment must match pattern " wpatt) ""))) (comnt (iup:textbox #:action (lambda (val a b) (if wpatt (if (string-match wregx b) (iup:attribute-set! wmesg "TITLE" (conc "Comment matches " wpatt)) (iup:attribute-set! wmesg "TITLE" (conc "Comment does not match " wpatt)) ))) - #:value (db:test-get-comment testdat) + #:value (if ovrdval ovrdval (db:test-get-comment testdat)) #:expand "HORIZONTAL")) (dlog #f)) (set! dlog (iup:dialog ;; #:close_cb (lambda (a)(exit)) ; #:expand "YES" #:title "SET WAIVER" (iup:vbox ; #:expand "YES" Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -1335,11 +1335,11 @@ (let ((res 0)) (sqlite3:for-each-row (lambda (count) (set! res count)) (db:get-db dbstruct run-id) - "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART');") + "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id NOT IN (SELECT id FROM runs WHERE state='deleted');") res)) ;; NEW BEHAVIOR: Look only at single run with run-id ;; ;; (define (db:get-running-stats dbstruct run-id) @@ -1358,11 +1358,11 @@ (let ((res 0)) (sqlite3:for-each-row (lambda (count) (set! res count)) (db:get-db dbstruct run-id) - "SELECT count(id) FROM tests WHERE state = 'RUNNING' OR state = 'LAUNCHED' OR state = 'REMOTEHOSTSTART' + "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND testname in (SELECT testname FROM test_meta WHERE jobgroup=?);" jobgroup) res))) ;; done with run when: @@ -1901,14 +1901,14 @@ ;; read the record given a testname (define (db:testmeta-get-record dbstruct testname) (let ((res #f)) (sqlite3:for-each-row - (lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags) - (set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags))) + (lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup) + (set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup))) (db:get-db dbstruct #f) - "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags FROM test_meta WHERE testname=?;" + "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta WHERE testname=?;" testname) res)) ;; create a new record for a given testname (define (db:testmeta-add-record dbstruct testname) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -1003,11 +1003,11 @@ (change-directory startingdir) (set! exitstat (system cmd)) (set! *globalexitstatus* exitstat) ;; no necessary (change-directory testpath) ;; (cdb:test-set-log! *runremote* test-id (sdb:qry 'getid htmllogfile)))) - (rmt:test-set-log! test-id htmllogfile))) + (rmt:test-set-log! run-id test-id htmllogfile))) (let ((msg (args:get-arg "-m"))) (rmt:teststep-set-status! run-id test-id stepname "end" exitstat msg logfile)) ))) (if (or (args:get-arg "-test-status") (args:get-arg "-set-values")) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -165,11 +165,14 @@ (thread-sleep! (cond ((> *runs:can-run-more-tests-count* 20) 2);; obviously haven't had any work to do for a while (else 0))) (let* ((num-running (rmt:get-count-tests-running run-id)) (num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup run-id jobgroup)) - (job-group-limit (config-lookup *configdat* "jobgroups" jobgroup))) + (job-group-limit (let ((jobg-count (config-lookup *configdat* "jobgroups" jobgroup))) + (if (string? jobg-count) + (string->number jobg-count) + jobg-count)))) (if (> (+ num-running num-running-in-jobgroup) 0) (set! *runs:can-run-more-tests-count* (+ *runs:can-run-more-tests-count* 1))) (if (not (eq? *last-num-running-tests* num-running)) (begin (debug:print 2 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running) @@ -186,12 +189,13 @@ #t) ;; if job-group-limit is set and number of jobs in the group is greater ;; than the limit then cannot run more jobs of this kind ((and job-group-limit (>= num-running-in-jobgroup job-group-limit)) - (debug:print 1 "WARNING: number of jobs " num-running-in-jobgroup - " in " jobgroup " exceeded, will not run " (tests:testqueue-get-testname test-record)) + (if (runs:lownoise (conc "maxjobgroup " jobgroup) 60) + (debug:print 1 "WARNING: number of jobs " num-running-in-jobgroup + " in jobgroup \"" jobgroup "\" exceeds limit of " job-group-limit)) #t) (else #f)))) (list (not can-not-run-more) num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit))))) ;; test-names: Comma separated patterns same as test-patts but used in selection @@ -790,11 +794,11 @@ ;; (print "Top of loop, hed=" hed ", tal=" tal " ,reruns=" reruns) (let* ((test-record (hash-table-ref test-records hed)) (test-name (tests:testqueue-get-testname test-record)) (tconfig (tests:testqueue-get-testconfig test-record)) - (jobgroup (config-lookup tconfig "requirements" "jobgroup")) + (jobgroup (config-lookup tconfig "test_meta" "jobgroup")) (testmode (let ((m (config-lookup tconfig "requirements" "mode"))) (if m (string->symbol m) 'normal))) (waitons (tests:testqueue-get-waitons test-record)) (priority (tests:testqueue-get-priority test-record)) (itemdat (tests:testqueue-get-itemdat test-record)) ;; itemdat can be a string, list or #f @@ -1457,11 +1461,11 @@ ;; Update the test_meta table for this test (define (runs:update-test_meta test-name test-conf) (let ((currrecord (rmt:testmeta-get-record test-name))) (if (not currrecord) (begin - (set! currrecord (make-vector 10 #f)) + (set! currrecord (make-vector 11 #f)) (rmt:testmeta-add-record test-name))) (for-each (lambda (key) (let* ((idx (cadr key)) (fld (car key)) @@ -1469,11 +1473,11 @@ ;; (debug:print 5 "idx: " idx " fld: " fld " val: " val) (if (and val (not (equal? (vector-ref currrecord idx) val))) (begin (print "Updating " test-name " " fld " to " val) (rmt:testmeta-update-field test-name fld val))))) - '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9))))) + '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)("jobgroup" 10))))) ;; Update test_meta for all tests (define (runs:update-all-test_meta db) (let ((test-names (tests:get-all))) ;; (tests:get-valid-tests))) (for-each Index: tests/fullrun/megatest.config ================================================================== --- tests/fullrun/megatest.config +++ tests/fullrun/megatest.config @@ -121,5 +121,9 @@ [disks] disk0 /foobarbazz [include config/mt_include_2.config] [include #{getenv USER}_testing.config] + +[jobgroups] +sqlite3 3 +blockz 5 Index: tests/fullrun/tests/blocktestxz/testconfig ================================================================== --- tests/fullrun/tests/blocktestxz/testconfig +++ tests/fullrun/tests/blocktestxz/testconfig @@ -16,5 +16,7 @@ that a test will never be run and thus remove it from\ the queue of tests to be run. tags first,single reviewed 1/1/1965 + +jobgroup blockz Index: tests/fullrun/tests/priority_1/testconfig ================================================================== --- tests/fullrun/tests/priority_1/testconfig +++ tests/fullrun/tests/priority_1/testconfig @@ -3,10 +3,11 @@ [requirements] priority 1 [test_meta] +jobgroup sqlite3 author matt owner bob description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS tags first,single Index: tests/fullrun/tests/priority_2/testconfig ================================================================== --- tests/fullrun/tests/priority_2/testconfig +++ tests/fullrun/tests/priority_2/testconfig @@ -5,10 +5,11 @@ priority 2 # runtimelim 1d 1h 1m 10s runtimelim 20s [test_meta] +jobgroup sqlite3 author matt owner bob description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS tags first,single Index: tests/fullrun/tests/priority_3/testconfig ================================================================== --- tests/fullrun/tests/priority_3/testconfig +++ tests/fullrun/tests/priority_3/testconfig @@ -4,10 +4,11 @@ [requirements] priority 3 [test_meta] +jobgroup sqlite3 author matt owner bob description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS tags first,single Index: tests/fullrun/tests/priority_4/testconfig ================================================================== --- tests/fullrun/tests/priority_4/testconfig +++ tests/fullrun/tests/priority_4/testconfig @@ -3,10 +3,11 @@ [requirements] priority 4 [test_meta] +jobgroup sqlite3 author matt owner bob description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS tags first,single Index: tests/fullrun/tests/sqlitespeed/testconfig ================================================================== --- tests/fullrun/tests/sqlitespeed/testconfig +++ tests/fullrun/tests/sqlitespeed/testconfig @@ -7,5 +7,7 @@ [items] MANYITEMS [system (env > envfile.txt;echo aa ab ac ad ae af ag ah ai)] # BORKED +[test_meta] +jobgroup sqlite3 Index: utils/installall.sh ================================================================== --- utils/installall.sh +++ utils/installall.sh @@ -302,10 +302,16 @@ # disabled zmq # # CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -deploy -prefix $DEPLOYTARG zmq # disabled zmq # fi # disabled zmq # fi # if zmq is in /usr/lib # disabled zmq # cd $BUILDHOME + +git clone https://bitbucket.org/DerGuteMoritz/zmq/commits/branch/3.2 zmq-3.2 +cd zmq-3.2 +chicken-install + +cd $BUILDHOME ## WEBKIT=WebKit-r131972 ## if ! [[ -e ${WEBKIT}.tar.bz2 ]] ; then ## # http://builds.nightly.webkit.org/files/trunk/src/WebKit-r131972.tar.bz2 ## wget http://builds.nightly.webkit.org/files/trunk/src/${WEBKIT}.tar.bz2 Index: utils/mtgetfile ================================================================== --- utils/mtgetfile +++ utils/mtgetfile @@ -18,11 +18,11 @@ ((not key-vals) "missing -target") ((not target) "missing -target") ((not scriptn) "missing file name to find") (else #f)))) (if errmsg - (begin + (begin (print "THEPATH: Missing required switch: " errmsg) (print "THEPATH: Usage: mtgetfile -target target scriptname [searchpath]") (exit))) (print "THEPATH: key-vals=" key-vals " path=" path " scriptn=" scriptn)) EOF Index: utils/nbload ================================================================== --- utils/nbload +++ utils/nbload @@ -2,23 +2,28 @@ # load=`uptime|awk '{print $10}'|cut -d, -f1` load=`uptime|perl -pe 's/.*: (\d+.\d+),.*/$1/'` if which cpucheck > /dev/null;then numcpu=`cpucheck|tail -1|awk '{print $6}'` -else +elif which lscpu > /dev/null;then numcpu=`lscpu|grep "CPU.s.:"|awk '{print $2}'` +else + numcpu=2 fi +# NB// max_load is in units of percent. +# lperc=`echo "100 * $load / $numcpu"|bc` if [[ "x$MAX_ALLOWED_LOAD" == "x" ]]; then - max_load=50 + max_load=100 else max_load=$MAX_ALLOWED_LOAD -fi -if [[ $lperc -lt $max_load ]];then - echo "$@" | at now + 0 minutes -elif [[ "x$NBLAUNCHER" == "x" ]];then - echo "nbfind $@" | at now + 2 minutes -else - $NBLAUNCHER "$@" fi +if [[ $lperc -lt $max_load ]];then + echo "Load acceptable: lperc=$lperc %, max_load=$max_load %, load=$load, numcpu=$numcpu, MAX_ALLOWED_LOAD=$MAX_ALLOWED_LOAD %" + echo "Starting command: \"$@\"" + nbfake "$@" +else + # echo "Load too high: lperc=$lperc, max_load=$max_load, waiting two minutes before trying to run command: \"$@\"" + echo "nbload $@" | at now + 2 minutes 2> /dev/null +fi