Index: .fossil-settings/ignore-glob ================================================================== --- .fossil-settings/ignore-glob +++ .fossil-settings/ignore-glob @@ -1,13 +1,31 @@ utils/build/* *~ *.o bin/* -tests/megatest.db -tests/monitor.db +megatest.db +monitor.db megatest dboard tests/fullrun/tmp/* tests/simpleruns tests/simplelinks mkdeploy/runs mkdeploy/links +example/linktree +example/runs +*.backup +mkdeploy/linktree +mkdeploy/site.config +mtest +newdboard +*.log +fslsync/fslsynclinks/* +fslsync/fslsyncruns/* +sites.dat +fullrun/config/*.config +fullrun/envfile.txt +*.bak +simplerun/*.scm +simplerun/simpleruns +tests/mintest/runs/* +tests/mintest/linktree/* Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -1,15 +1,16 @@ - +# make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)' PREFIX=$(PWD) CSCOPTS= INSTALL=install SRCFILES = common.scm items.scm launch.scm \ ods.scm runconfig.scm server.scm configf.scm \ db.scm keys.scm margs.scm megatest-version.scm \ process.scm runs.scm tasks.scm tests.scm genexample.scm \ fs-transport.scm http-transport.scm \ - client.scm gutils.scm synchash.scm daemon.scm + client.scm gutils.scm synchash.scm daemon.scm mt.scm dcommon.scm \ + tree.scm GUISRCF = dashboard-tests.scm dashboard-guimonitor.scm OFILES = $(SRCFILES:%.scm=%.o) GOFILES = $(GUISRCF:%.scm=%.o) @@ -56,11 +57,11 @@ tests.o tasks.o dashboard-tasks.o : task_records.scm runs.o : test_records.scm megatest.o : megatest-fossil-hash.scm # Temporary while transitioning to new routine -runs.o : run-tests-queue-classic.scm run-tests-queue-new.scm +# runs.o : run-tests-queue-classic.scm run-tests-queue-new.scm megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm echo "(define megatest-fossil-hash \"$(MTESTHASH)\")" > megatest-fossil-hash.new if ! diff -q megatest-fossil-hash.new megatest-fossil-hash.scm ; then echo copying .new to .scm;cp -f megatest-fossil-hash.new megatest-fossil-hash.scm;fi Index: NOTES ================================================================== --- NOTES +++ NOTES @@ -4,10 +4,19 @@ run area. rsync is used to pull the test area to the home host if and only if the originating area can not be seen via file system. NO LONGER TRUE. Rsync is used but file system must be visible. 4. All db access is done via the home host. NOT IMPLEMENTED YET. +REMOTE ACCESS DB LOADS + +INFO: (0) Max cached queries was 10 +INFO: (0) Number of cached writes 27043 +INFO: (0) Average cached write time 15.0634544983915 ms +INFO: (0) Number non-cached queries 71928 +INFO: (0) Average non-cached time 5.15547491936381 ms +INFO: (0) Server shutdown complete. Exiting + fdktestqa on Apr 29, 2013: 1812 tests INFO: (0) Max cached queries was 10 INFO: (0) Number of cached writes 41335 Index: TODO ================================================================== --- TODO +++ TODO @@ -1,15 +1,4 @@ -1. Run all tests -2. create run areas, copy in conf and scripts DONE -3. Add a host chooser for ssh to launch-tests -4. Run creation timestamp not happening DONE -5 . Check for test already in progress, give meaningful message DONE -6. Debug xterm creation for test generation DONE -7. Capture run info, host, load, freemem at test launch DONE -8. Rename to testalot? Nah! I like Megatest -10. Run, test and step comment field -11. At end of test scan all tests for this run, if all done - update run status to COMPLETED NOT gonna happen. It is up to the test to mark as PASS/FAIL -12. state and status lists need to be regexes -13. Test on Chicken 4. DONE -14. Try making static executable -15. Log processor script DONE + +1. Confirm that branch transaction-for-sequential-writes content was added to trunk/development +2. Add a host chooser for ssh to launch-tests +3. Try making static executable Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -17,11 +17,11 @@ (use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest) ;; (use zmq) (import (prefix sqlite3 sqlite3:)) -(use spiffy uri-common intarweb http-client spiffy-request-vars) +(use spiffy uri-common intarweb http-client spiffy-request-vars uri-common intarweb) (declare (unit client)) (declare (uses common)) (declare (uses db)) @@ -75,11 +75,20 @@ ;; ;; DEBUG STUFF ;; (if (eq? *transport-type* 'fs)(begin (print "ERROR!!!!!!! refusing to run with transport " *transport-type*)(exit 99))) (debug:print-info 11 "Using transport type of " *transport-type* (if hostinfo (conc " to connect to " hostinfo) "")) (case *transport-type* - ((fs)(if (not *megatest-db*)(set! *megatest-db* (open-db)))) + ((fs) ;; (if (not *megatest-db*)(set! *megatest-db* (open-db)))) + ;; we are not doing fs any longer. let's cheat and start up a server + ;; if we are falling back on fs (not 100% supported) do an about face and start a server + (if (not (equal? (args:get-arg "-transport") "fs")) + (begin + (set! *transport-type* #f) + (system (conc "megatest -list-servers | grep " megatest-version " | grep alive || megatest -server - -daemonize && sleep 3")) + (thread-sleep! 1) + (if (> numtries 0) + (client:setup numtries: (- numtries 1)))))) ((http) (http-transport:client-connect (tasks:hostinfo-get-interface hostinfo) (tasks:hostinfo-get-port hostinfo))) ((zmq) (zmq-transport:client-connect (tasks:hostinfo-get-interface hostinfo) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -53,10 +53,13 @@ (define *server-id* #f) (define *server-info* #f) (define *time-to-exit* #f) (define *received-response* #f) (define *default-numtries* 10) +(define *server-run* #t) +(define *db-write-access* #t) + (define *target* (make-hash-table)) ;; cache the target here; target is keyval1/keyval2/.../keyvalN (define *keys* (make-hash-table)) ;; cache the keys here (define *keyvals* (make-hash-table)) (define *toptest-paths* (make-hash-table)) ;; cache toptest path settings here @@ -96,10 +99,35 @@ ;;====================================================================== ;; Misc utils ;;====================================================================== +;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5 +(define (common:hms-string->seconds tstr) + (let ((parts (string-split tstr)) + (time-secs 0) + ;; s=seconds, m=minutes, h=hours, d=days + (trx (regexp "(\\d+)([smhd])"))) + (for-each (lambda (part) + (let ((match (string-match trx part))) + (if match + (let ((val (string->number (cadr match))) + (unt (caddr match))) + (if val + (set! time-secs (+ time-secs (* val + (case (string->symbol unt) + ((s) 1) + ((m) 60) + ((h) (* 60 60)) + ((d) (* 24 60 60)) + (else 0)))))))))) + parts) + time-secs)) + +(define (common:version-signature) + (conc megatest-version "-" (substring megatest-fossil-hash 0 4))) + ;; one-of args defined (define (args-defined? . param) (let ((res #f)) (for-each (lambda (arg) @@ -142,10 +170,91 @@ ;; '(print (string-intersperse (map cadr (hash-table-ref/default (read-config "megatest.config" \#f \#t) "disks" '"'"'("none" ""))) "\n"))' (define (common:get-disks) (hash-table-ref/default (read-config "megatest.config" #f #t) "disks" '("none" ""))) + +;;====================================================================== +;; M I S C L I S T S +;;====================================================================== + +;; items in lista are matched value and position in listb +;; return the remaining items in listb or #f +;; +(define (common:list-is-sublist lista listb) + (if (null? lista) + listb ;; all items in listb are "remaining" + (if (> (length lista)(length listb)) + #f + (let loop ((heda (car lista)) + (tala (cdr lista)) + (hedb (car listb)) + (talb (cdr listb))) + (if (equal? heda hedb) + (if (null? tala) ;; we are done + talb + (loop (car tala) + (cdr tala) + (car talb) + (cdr talb))) + #f))))) + +;; Needed for long lists to be sorted where (apply max ... ) dies +;; +(define (common:max inlst) + (let loop ((max-val (car inlst)) + (hed (car inlst)) + (tal (cdr inlst))) + (if (not (null? tal)) + (loop (max hed max-val) + (car tal) + (cdr tal)) + (max hed max-val)))) + + +;;====================================================================== +;; Munge data into nice forms +;;====================================================================== + +;; Generate an index for a sparse list of key values +;; ( (rowname1 colname1 val1)(rowname2 colname2 val2) ) +;; +;; => +;; +;; ( (rowname1 0)(rowname2 1)) ;; rownames -> num +;; (colname1 0)(colname2 1)) ) ;; colnames -> num +;; +;; optional apply proc to rownum colnum value +(define (common:sparse-list-generate-index data #!key (proc #f)) + (if (null? data) + (list '() '()) + (let loop ((hed (car data)) + (tal (cdr data)) + (rownames '()) + (colnames '()) + (rownum 0) + (colnum 0)) + (let* ((rowkey (car hed)) + (colkey (cadr hed)) + (value (caddr hed)) + (existing-rowdat (assoc rowkey rownames)) + (existing-coldat (assoc colkey colnames)) + (curr-rownum (if existing-rowdat rownum (+ rownum 1))) + (curr-colnum (if existing-coldat colnum (+ colnum 1))) + (new-rownames (if existing-rowdat rownames (cons (list rowkey curr-rownum) rownames))) + (new-colnames (if existing-coldat colnames (cons (list colkey curr-colnum) colnames)))) + ;; (debug:print-info 0 "Processing record: " hed ) + (if proc (proc curr-rownum curr-colnum rowkey colkey value)) + (if (null? tal) + (list new-rownames new-colnames) + (loop (car tal) + (cdr tal) + new-rownames + new-colnames + (if (> curr-rownum rownum) curr-rownum rownum) + (if (> curr-colnum colnum) curr-colnum colnum) + )))))) ;;====================================================================== ;; System stuff ;;====================================================================== @@ -238,10 +347,14 @@ (define (seconds->time-string sec) (time->string (seconds->local-time sec) "%H:%M:%S")) +(define (seconds->work-week/day sec) + (time->string + (seconds->local-time sec) "%V.%u")) + ;;====================================================================== ;; Colors ;;====================================================================== (define (common:name->iup-color name) @@ -249,26 +362,26 @@ ((red) "223 33 49") ((grey) "192 192 192") ((orange) "255 172 13") ((purple) "This is unfinished ..."))) -(define (common:get-color-for-state-status state status) - (case (string->symbol state) - ((COMPLETED) - (case (string->symbol status) - ((PASS) "70 249 73") - ((WARN WAIVED) "255 172 13") - ((SKIP) "230 230 0") - (else "223 33 49"))) - ((LAUNCHED) "101 123 142") - ((CHECK) "255 100 50") - ((REMOTEHOSTSTART) "50 130 195") - ((RUNNING) "9 131 232") - ((KILLREQ) "39 82 206") - ((KILLED) "234 101 17") - ((NOT_STARTED) "240 240 240") - (else "192 192 192"))) +;; (define (common:get-color-for-state-status state status) +;; (case (string->symbol state) +;; ((COMPLETED) +;; (case (string->symbol status) +;; ((PASS) "70 249 73") +;; ((WARN WAIVED) "255 172 13") +;; ((SKIP) "230 230 0") +;; (else "223 33 49"))) +;; ((LAUNCHED) "101 123 142") +;; ((CHECK) "255 100 50") +;; ((REMOTEHOSTSTART) "50 130 195") +;; ((RUNNING) "9 131 232") +;; ((KILLREQ) "39 82 206") +;; ((KILLED) "234 101 17") +;; ((NOT_STARTED) "240 240 240") +;; (else "192 192 192"))) (define (common:get-color-from-status status) (cond ((equal? status "PASS") "green") ((equal? status "FAIL") "red") Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -59,11 +59,11 @@ (define configf:comment-rx (regexp "^\\s*#.*")) (define configf:cont-ln-rx (regexp "^(\\s+)(\\S+.*)$")) ;; read a line and process any #{ ... } constructs -(define configf:var-expand-regex (regexp "^(.*)#\\{(scheme|system|shell|getenv|get|runconfigs-get)\\s+([^\\}\\{]*)\\}(.*)")) +(define configf:var-expand-regex (regexp "^(.*)#\\{(scheme|system|shell|getenv|get|runconfigs-get|rget)\\s+([^\\}\\{]*)\\}(.*)")) (define (configf:process-line l ht) (let loop ((res l)) (if (string? res) (let ((matchdat (string-search configf:var-expand-regex res))) (if matchdat @@ -81,10 +81,11 @@ (let* ((parts (string-split cmd)) (sect (car parts)) (var (cadr parts))) (conc "(lambda (ht)(config-lookup ht \"" sect "\" \"" var "\"))"))) ((runconfigs-get) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))")) + ((rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))")) (else "(lambda (ht)(print \"ERROR\") \"ERROR\")")))) ;; (print "fullcmd=" fullcmd) (with-input-from-string fullcmd (lambda () (set! result ((eval (read)) ht)))) @@ -110,18 +111,26 @@ ;; Lookup a value in runconfigs based on -reqtarg or -target (define (runconfigs-get config var) (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target")))) (if targ - (config-lookup config targ var) - #f))) + (or (configf:lookup config targ var) + (configf:lookup config "default" var)) + (configf:lookup config "default" var)))) (define-inline (configf:read-line p ht allow-processing) - (if (and allow-processing - (not (eq? allow-processing 'return-string))) - (configf:process-line (read-line p) ht) - (read-line p))) + (let loop ((inl (read-line p))) + (if (and (string? inl) + (not (string-null? inl)) + (equal? "\\" (string-take-right inl 1))) ;; last character is \ + (let ((nextl (read-line p))) + (if (not (eof-object? nextl)) + (loop (string-append inl nextl)))) + (if (and allow-processing + (not (eq? allow-processing 'return-string))) + (configf:process-line inl ht) + inl)))) ;; 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) @@ -260,11 +269,11 @@ (let ((sectdat (hash-table-ref/default cfgdat section '()))) (if (null? sectdat) '() (map car sectdat)))) -(define (configf:get-section cfdat section) +(define (configf:get-section cfgdat section) (hash-table-ref/default cfgdat section '())) (define (setup) (let* ((configf (find-config)) (config (if configf (read-config configf #f #t) #f))) Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -23,10 +23,11 @@ (import (prefix sqlite3 sqlite3:)) (declare (unit dashboard-tests)) (declare (uses common)) (declare (uses db)) +(declare (uses gutils)) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") @@ -62,12 +63,12 @@ (lambda (testdat) (let ((newstatus (db:test-get-status testdat)) (oldstatus (iup:attribute lbl "TITLE"))) (if (not (equal? oldstatus newstatus)) (begin - (iup:attribute-set! lbl "FGCOLOR" (common:get-color-for-state-status (db:test-get-state testdat) - (db:test-get-status testdat))) + (iup:attribute-set! lbl "FGCOLOR" (car (gutils:get-color-for-state-status (db:test-get-state testdat) + (db:test-get-status testdat)))) (iup:attribute-set! lbl "TITLE" (db:test-get-status testdat))))))) lbl) (store-label "testcomment" (iup:label "TestComment " #:expand "HORIZONTAL") @@ -188,11 +189,11 @@ ;; state status teststeps (define *state-status* (vector #f #f #f)) (define (update-state-status-buttons testdat) (let* ((state (db:test-get-state testdat)) (status (db:test-get-status testdat)) - (color (common:get-color-for-state-status state status))) + (color (car (gutils:get-color-for-state-status state status)))) ((vector-ref *state-status* 0) state color) ((vector-ref *state-status* 1) status color))) ;;====================================================================== ;; Set fields @@ -270,10 +271,12 @@ (keydat (if testdat (open-run-close db:get-key-val-pairs #f run-id) #f)) (rundat (if testdat (open-run-close db:get-run-info #f run-id) #f)) (runname (if testdat (db:get-value-by-header (db:get-row rundat) (db:get-header rundat) "runname") #f)) + ;; These next two are intentional bad values to ensure errors if they should not + ;; get filled in properly. (logfile "/this/dir/better/not/exist") (rundir logfile) (teststeps (if testdat (db:get-compressed-steps test-id work-area: rundir) '())) (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ...")) (testname (if testdat (db:test-get-testname testdat) "n/a")) @@ -292,10 +295,17 @@ (viewlog (lambda (x) (if (file-exists? logfile) ;(system (conc "firefox " logfile "&")) (iup:send-url logfile) (message-window (conc "File " logfile " not found"))))) + (view-a-log (lambda (lfile) + (let ((lfilename (conc rundir "/" lfile))) + ;; (print "lfilename: " lfilename) + (if (file-exists? lfilename) + ;(system (conc "firefox " logfile "&")) + (iup:send-url lfilename) + (message-window (conc "File " lfilename " not found")))))) (xterm (lambda (x) (if (directory-exists? rundir) (let ((shell (if (get-environment-variable "SHELL") (conc "-e " (get-environment-variable "SHELL")) ""))) @@ -353,26 +363,33 @@ (store-button store-label) (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -10")) (command-launch-button (iup:button "Execute!" #:action (lambda (x) (let ((cmd (iup:attribute command-text-box "VALUE"))) (system (conc cmd " &")))))) + (kill-jobs (lambda (x) + (iup:attribute-set! + command-text-box "VALUE" + (conc "xterm -geometry 180x20 -e \"megatest -target " keystring " :runname " runname + " -set-state-status KILLREQ,n/a -testpatt %/% " + ;; (conc testname "/" (if (equal? item-path "") "%" item-path)) + " :state RUNNING ;echo Press any key to continue;bash -c 'read -n 1 -s'\"")))) (run-test (lambda (x) (iup:attribute-set! command-text-box "VALUE" (conc "xterm -geometry 180x20 -e \"megatest -target " keystring " :runname " runname " -runtests " (conc testname "/" (if (equal? item-path "") "%" item-path)) - ";echo Press any key to continue;bash -c 'read -n 1 -s'\"")))) + " ;echo Press any key to continue;bash -c 'read -n 1 -s'\"")))) (remove-test (lambda (x) (iup:attribute-set! command-text-box "VALUE" (conc "xterm -geometry 180x20 -e \"megatest -remove-runs -target " keystring " :runname " runname " -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) - " -v;echo Press any key to continue;bash -c 'read -n 1 -s'\""))))) + " -v ;echo Press any key to continue;bash -c 'read -n 1 -s'\""))))) (cond ((not testdat)(begin (print "ERROR: bad test info for " test-id)(exit 1))) ((not rundat)(begin (print "ERROR: found test info but there is a problem with the run info for " run-id)(exit 1))) (else ;; (test-set-status! db run-id test-name state status itemdat) @@ -388,15 +405,16 @@ (host-info-panel testdat store-label) ;; The controls (iup:frame #:title "Actions" (iup:vbox (iup:hbox - (iup:button "View Log" #:action viewlog #:size "80x") - (iup:button "Start Xterm" #:action xterm #:size "80x") - (iup:button "Run Test" #:action run-test #:size "80x") - (iup:button "Clean Test" #:action remove-test #:size "80x") - (iup:button "Close" #:action (lambda (x)(exit)) #:size "80x")) + (iup:button "View Log" #:action viewlog #:size "80x") + (iup:button "Start Xterm" #:action xterm #:size "80x") + (iup:button "Run Test" #:action run-test #:size "80x") + (iup:button "Clean Test" #:action remove-test #:size "80x") + (iup:button "Kill All Jobs" #:action kill-jobs #:size "80x") + (iup:button "Close" #:action (lambda (x)(exit)) #:size "80x")) (apply iup:hbox (list command-text-box command-launch-button)))) (set-fields-panel test-id testdat) (let ((tabs @@ -409,15 +427,16 @@ #:numcol 6 #:numlin 30 #:numcol-visible 6 #:numlin-visible 5 #:click-cb (lambda (obj lin col status) - (if (equal? col 6) - (let ((fname (iup:attribute obj (conc lin ":" col)))) - (viewlog fname) - (print "obj: " obj " lin: " lin " col: " col " status: " status))))) - )) + ;; (if (equal? col 6) + (let* ((mtrx-rc (conc lin ":" 6)) + (fname (iup:attribute obj mtrx-rc))) ;; col)))) + (view-a-log fname))) + ;; (print "obj: " obj " mtrx-rc: " mtrx-rc " fname: " fname " lin: " lin " col: " col " status: " status))) + ))) ;; (let loop ((count 0)) ;; (iup:attribute-set! steps-matrix "FITTOTEXT" (conc "L" count)) ;; (if (< count 30) ;; (loop (+ count 1)))) (iup:attribute-set! steps-matrix "0:1" "Step Name") @@ -436,16 +455,18 @@ (if (not (null? teststeps)) (let loop ((hed (car teststeps)) (tal (cdr teststeps)) (rownum 1) (colnum 1)) - (let ((val (vector-ref hed (- colnum 1)))) - (iup:attribute-set! steps-matrix (conc rownum ":" colnum)(if val (conc val) "")) + (let ((val (vector-ref hed (- colnum 1))) + (mtrx-rc (conc rownum ":" colnum))) + (iup:attribute-set! steps-matrix mtrx-rc (if val (conc val) "")) (if (< colnum 6) (loop hed tal rownum (+ colnum 1)) (if (not (null? tal)) - (loop (car tal)(cdr tal)(+ rownum 1) 1))))))))) + (loop (car tal)(cdr tal)(+ rownum 1) 1)))) + (iup:attribute-set! steps-matrix "REDRAW" "ALL")))))) (hash-table-set! widgets "StepsMatrix" proc) (proc testdat)) steps-matrix) ;; populate the Test Data panel (iup:frame @@ -479,11 +500,13 @@ (db:test-data-get-comment x))) (open-run-close db:read-test-data #f test-id "%"))) "\n"))) (if (not (equal? currval newval)) (iup:attribute-set! test-data "VALUE" newval ))))) ;; "TITLE" newval))))) - test-data))))) + test-data)) + ;;(dashboard:run-controls) + ))) (iup:attribute-set! tabs "TABTITLE0" "Steps") (iup:attribute-set! tabs "TABTITLE1" "Test Data") tabs)))) (iup:show self) (iup:callback-set! *tim* "ACTION_CB" Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -12,13 +12,15 @@ (use format) (require-library iup) (import (prefix iup iup:)) (use canvas-draw) +(import canvas-draw-iup) (use sqlite3 srfi-1 posix regex regex-case srfi-69) (import (prefix sqlite3 sqlite3:)) +(use trace) (declare (uses common)) (declare (uses margs)) (declare (uses keys)) (declare (uses items)) @@ -27,21 +29,25 @@ (declare (uses process)) (declare (uses launch)) (declare (uses runs)) (declare (uses dashboard-tests)) (declare (uses dashboard-guimonitor)) +(declare (uses tree)) +(declare (uses dcommon)) + ;; (declare (uses dashboard-main)) (declare (uses megatest-version)) +(declare (uses mt)) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") (define help (conc "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " - license GPL, Copyright (C) Matt Welland 2011 + license GPL, Copyright (C) Matt Welland 2013 Usage: dashboard [options] -h : this help -server host:port : connect to host:port instead of db access -test testid : control test identified by testid @@ -98,12 +104,13 @@ (define dlg #f) (define max-test-num 0) ;; (define *keys* (open-run-close db:get-keys #f)) (define *keys* (cdb:remote-run db:get-keys #f)) ;; (define *keys* (db:get-keys *db*)) -(define *dbkeys* (map (lambda (x)(vector-ref x 0)) - (append *keys* (list (vector "runname" "blah"))))) + +(define *dbkeys* (append *keys* (list "runname"))) + (define *header* #f) (define *allruns* '()) (define *allruns-by-id* (make-hash-table)) ;; (define *runchangerate* (make-hash-table)) @@ -112,27 +119,30 @@ (define *searchpatts* (make-hash-table)) (define *num-runs* 8) (define *tot-run-count* (cdb:remote-run db:get-num-runs #f "%")) ;; (define *tot-run-count* (db:get-num-runs *db* "%")) (define *last-update* (current-seconds)) +(define *last-db-update-time* 0) +(define *please-update-buttons* #t) +(define *delayed-update* 0) + (define *num-tests* 15) (define *start-run-offset* 0) (define *start-test-offset* 0) (define *examine-test-dat* (make-hash-table)) (define *exit-started* #f) (define *status-ignore-hash* (make-hash-table)) (define *state-ignore-hash* (make-hash-table)) -(define *last-db-update-time* 0) -(define *please-update-buttons* #t) -(define *delayed-update* 0) - (define *db-file-path* (conc *toppath* "/megatest.db")) (define *tests-sort-reverse* #f) (define *hide-empty-runs* #f) +(define *current-tab-number* 0) +(define *updaters* (make-hash-table)) + (debug:setup) (define uidat #f) (define-inline (dboard:uidat-get-keycol vec)(vector-ref vec 0)) @@ -145,21 +155,20 @@ (iup:show (iup:dialog (iup:vbox (iup:label msg #:margin "40x40"))))) -(define (iuplistbox-fill-list lb items . default) - (let ((i 1) - (selected-item (if (null? default) #f (car default)))) - (iup:attribute-set! lb "VALUE" (if selected-item selected-item "")) +(define (iuplistbox-fill-list lb items #!key (selected-item #f)) + (let ((i 1)) (for-each (lambda (item) (iup:attribute-set! lb (number->string i) item) (if selected-item (if (equal? selected-item item) - (iup:attribute-set! lb "VALUE" item))) ;; (number->string i)))) + (iup:attribute-set! lb "VALUE" i))) ;; (number->string i)))) (set! i (+ i 1))) items) + ;; (iup:attribute-set! lb "VALUE" (if selected-item selected-item "")) i)) (define (pad-list l n)(append l (make-list (- n (length l))))) (define (colors-similar? color1 color2) @@ -168,76 +177,46 @@ (delta (map (lambda (a b)(abs (- a b))) c1 c2))) (null? (filter (lambda (x)(> x 3)) delta)))) ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) (define (update-rundat runnamepatt numruns testnamepatt keypatts) - (let ((modtime (file-modification-time *db-file-path*)) - (referenced-run-ids '())) - (if (or (and (> modtime *last-db-update-time*) - (> (current-seconds)(+ *last-db-update-time* 5))) - (> *delayed-update* 0)) - ;; - ;; Run this stuff only when the megatest.db file has changed - ;; - (let ((full-run (> (random 100) 75))) ;; 25% of the time do a full refresh - (debug:print-info 4 "update-rundat runnamepatt: " runnamepatt " numruns: " numruns " testnamepatt: " testnamepatt " keypatts: " keypatts) - (set! *please-update-buttons* #t) - (set! *last-db-update-time* modtime) - (set! *delayed-update* (- *delayed-update* 1)) - (let* ((allruns (cdb:remote-run db:get-runs #f runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) - *start-run-offset* keypatts)) - (header (db:get-header allruns)) - (runs (db:get-rows allruns)) - (result '()) - (maxtests 0) - (states (hash-table-keys *state-ignore-hash*)) - (statuses (hash-table-keys *status-ignore-hash*))) - ;; (thread-sleep! 0.1) ;; give some time to other threads - (debug:print 6 "update-rundat, got " (length runs) " runs") - (if (> (+ *last-update* 300) (current-seconds)) ;; every five minutes - (begin - (set! *last-update* (current-seconds)) - (set! *tot-run-count* (length runs)))) - ;; - ;; trim runs to only those that are changing often here - - ;; - (for-each (lambda (run) - (let* ((run-id (db:get-value-by-header run header "id")) - (tests (let ((tsts (cdb:remote-run db:get-tests-for-run #f run-id testnamepatt states statuses))) - (if *tests-sort-reverse* (reverse tsts) tsts))) - (key-vals (cdb:remote-run db:get-key-vals #f run-id))) - ;; Not sure this is needed? - (set! referenced-run-ids (cons run-id referenced-run-ids)) - (if (> (length tests) maxtests) - (set! maxtests (length tests))) - (if (or (not *hide-empty-runs*) ;; this reduces the data burden when set - (not (null? tests))) - (let ((dstruct (vector run tests key-vals))) - ;; - ;; compare the tests with the tests in *allruns-by-id* same run-id - ;; if different then increment value in *runchangerate* - ;; - (hash-table-set! *allruns-by-id* run-id dstruct) - (set! result (cons dstruct result)))))) - runs) - - ;; - ;; if full-run use referenced-run-ids to delete data in *all-runs-by-id* and *runchangerate* - ;; - - (set! *header* header) - (set! *allruns* result) - (debug:print 6 "*allruns* has " (length *allruns*) " runs") - ;; (set! *tot-run-count* (+ 1 (length *allruns*))) - maxtests)) - ;; - ;; Run this if the megatest.db file did not get touched - ;; - (begin - - *num-tests*)))) ;; FIXME, naughty coding eh? + (let* ((referenced-run-ids '()) + (allruns (cdb:remote-run db:get-runs #f runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) + *start-run-offset* keypatts)) + (header (db:get-header allruns)) + (runs (db:get-rows allruns)) + (result '()) + (maxtests 0) + (states (hash-table-keys *state-ignore-hash*)) + (statuses (hash-table-keys *status-ignore-hash*))) + ;; + ;; trim runs to only those that are changing often here + ;; + (for-each (lambda (run) + (let* ((run-id (db:get-value-by-header run header "id")) + (tests (let ((tsts (mt:get-tests-for-run run-id testnamepatt states statuses))) + (if *tests-sort-reverse* (reverse tsts) tsts))) + (key-vals (cdb:remote-run db:get-key-vals #f run-id))) + ;; Not sure this is needed? + (set! referenced-run-ids (cons run-id referenced-run-ids)) + (if (> (length tests) maxtests) + (set! maxtests (length tests))) + (if (or (not *hide-empty-runs*) ;; this reduces the data burden when set + (not (null? tests))) + (let ((dstruct (vector run tests key-vals))) + ;; + ;; compare the tests with the tests in *allruns-by-id* same run-id + ;; if different then increment value in *runchangerate* + ;; + (hash-table-set! *allruns-by-id* run-id dstruct) + (set! result (cons dstruct result)))))) + runs) + + (set! *header* header) + (set! *allruns* result) + (debug:print-info 6 "*allruns* has " (length *allruns*) " runs") + maxtests)) (define *collapsed* (make-hash-table)) ; (define *row-lookup* (make-hash-table)) ;; testname => (rownum lableobj) (define (toggle-hide lnum) ; fulltestname) @@ -319,103 +298,101 @@ (iup:attribute-set! lbl "FGCOLOR" (if (hash-table-ref/default *collapsed* newval #f) "0 112 112" "0 0 0")) (if (< i maxn) (loop (+ i 1))))))) (define (update-buttons uidat numruns numtests) - (if *please-update-buttons* - (let* ((runs (if (> (length *allruns*) numruns) - (take-right *allruns* numruns) - (pad-list *allruns* numruns))) - (lftcol (dboard:uidat-get-lftcol uidat)) - (tableheader (dboard:uidat-get-header uidat)) - (table (dboard:uidat-get-runsvec uidat)) - (coln 0)) - (set! *please-update-buttons* #f) - (set! *alltestnamelst* '()) - ;; create a concise list of test names - (for-each - (lambda (rundat) - (if (vector? rundat) - (let* ((testdat (vector-ref rundat 1)) - (testnames (map test:test-get-fullname testdat))) - (if (not (and *hide-empty-runs* - (null? testnames))) - (for-each (lambda (testname) - (if (not (member testname *alltestnamelst*)) - (begin - (set! *alltestnamelst* (append *alltestnamelst* (list testname)))))) - testnames))))) - runs) - - (set! *alltestnamelst* (collapse-rows *alltestnamelst*)) ;;; argh. please clean up this sillyness - (set! *alltestnamelst* (let ((xl (if (> (length *alltestnamelst*) *start-test-offset*) - (drop *alltestnamelst* *start-test-offset*) - '()))) - (append xl (make-list (- *num-tests* (length xl)) "")))) - (update-labels uidat) - (for-each - (lambda (rundat) - (if (not rundat) ;; handle padded runs - ;; ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration - (set! rundat (vector (make-vector 20 #f) '() (map (lambda (x) "") *keys*))));; 3))) - (let* ((run (vector-ref rundat 0)) - (testsdat (vector-ref rundat 1)) - (key-val-dat (vector-ref rundat 2)) - (run-id (db:get-value-by-header run *header* "id")) - (key-vals (append key-val-dat - (list (let ((x (db:get-value-by-header run *header* "runname"))) - (if x x ""))))) - (run-key (string-intersperse key-vals "\n"))) - - ;; fill in the run header key values - (let ((rown 0) - (headercol (vector-ref tableheader coln))) - (for-each (lambda (kval) - (let* ((labl (vector-ref headercol rown))) - (if (not (equal? kval (iup:attribute labl "TITLE"))) - (iup:attribute-set! (vector-ref headercol rown) "TITLE" kval)) - (set! rown (+ rown 1)))) - key-vals)) - - ;; For this run now fill in the buttons for each test - (let ((rown 0) - (columndat (vector-ref table coln))) - (for-each - (lambda (testname) - (let ((buttondat (hash-table-ref/default *buttondat* (mkstr coln rown) #f))) - (if buttondat - (let* ((test (let ((matching (filter - (lambda (x)(equal? (test:test-get-fullname x) testname)) - testsdat))) - (if (null? matching) - (vector -1 -1 "" "" "" 0 "" "" 0 "" "" "" 0 "" "") - (car matching)))) - (testname (db:test-get-testname test)) - (itempath (db:test-get-item-path test)) - (testfullname (test:test-get-fullname test)) - (teststatus (db:test-get-status test)) - (teststate (db:test-get-state test)) - (teststart (db:test-get-event_time test)) - (runtime (db:test-get-run_duration test)) - (buttontxt (if (equal? teststate "COMPLETED") teststatus teststate)) - (button (vector-ref columndat rown)) - (color (common:get-color-for-state-status teststate teststatus)) - (curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR")) - (curr-title (vector-ref buttondat 2))) ;; (iup:attribute button "TITLE"))) - (if (not (equal? curr-color color)) - (iup:attribute-set! button "BGCOLOR" color)) - (if (not (equal? curr-title buttontxt)) - (iup:attribute-set! button "TITLE" buttontxt)) - (vector-set! buttondat 0 run-id) - (vector-set! buttondat 1 color) - (vector-set! buttondat 2 buttontxt) - (vector-set! buttondat 3 test) - (vector-set! buttondat 4 run-key))) - (set! rown (+ rown 1)))) - *alltestnamelst*)) - (set! coln (+ coln 1)))) - runs)))) + (let* ((runs (if (> (length *allruns*) numruns) + (take-right *allruns* numruns) + (pad-list *allruns* numruns))) + (lftcol (dboard:uidat-get-lftcol uidat)) + (tableheader (dboard:uidat-get-header uidat)) + (table (dboard:uidat-get-runsvec uidat)) + (coln 0)) + (set! *alltestnamelst* '()) + ;; create a concise list of test names + (for-each + (lambda (rundat) + (if (vector? rundat) + (let* ((testdat (vector-ref rundat 1)) + (testnames (map test:test-get-fullname testdat))) + (if (not (and *hide-empty-runs* + (null? testnames))) + (for-each (lambda (testname) + (if (not (member testname *alltestnamelst*)) + (begin + (set! *alltestnamelst* (append *alltestnamelst* (list testname)))))) + testnames))))) + runs) + + (set! *alltestnamelst* (collapse-rows *alltestnamelst*)) ;;; argh. please clean up this sillyness + (set! *alltestnamelst* (let ((xl (if (> (length *alltestnamelst*) *start-test-offset*) + (drop *alltestnamelst* *start-test-offset*) + '()))) + (append xl (make-list (- *num-tests* (length xl)) "")))) + (update-labels uidat) + (for-each + (lambda (rundat) + (if (not rundat) ;; handle padded runs + ;; ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration + (set! rundat (vector (make-vector 20 #f) '() (map (lambda (x) "") *keys*))));; 3))) + (let* ((run (vector-ref rundat 0)) + (testsdat (vector-ref rundat 1)) + (key-val-dat (vector-ref rundat 2)) + (run-id (db:get-value-by-header run *header* "id")) + (key-vals (append key-val-dat + (list (let ((x (db:get-value-by-header run *header* "runname"))) + (if x x ""))))) + (run-key (string-intersperse key-vals "\n"))) + + ;; fill in the run header key values + (let ((rown 0) + (headercol (vector-ref tableheader coln))) + (for-each (lambda (kval) + (let* ((labl (vector-ref headercol rown))) + (if (not (equal? kval (iup:attribute labl "TITLE"))) + (iup:attribute-set! (vector-ref headercol rown) "TITLE" kval)) + (set! rown (+ rown 1)))) + key-vals)) + + ;; For this run now fill in the buttons for each test + (let ((rown 0) + (columndat (vector-ref table coln))) + (for-each + (lambda (testname) + (let ((buttondat (hash-table-ref/default *buttondat* (mkstr coln rown) #f))) + (if buttondat + (let* ((test (let ((matching (filter + (lambda (x)(equal? (test:test-get-fullname x) testname)) + testsdat))) + (if (null? matching) + (vector -1 -1 "" "" "" 0 "" "" 0 "" "" "" 0 "" "") + (car matching)))) + (testname (db:test-get-testname test)) + (itempath (db:test-get-item-path test)) + (testfullname (test:test-get-fullname test)) + (teststatus (db:test-get-status test)) + (teststate (db:test-get-state test)) + (teststart (db:test-get-event_time test)) + (runtime (db:test-get-run_duration test)) + (buttontxt (if (equal? teststate "COMPLETED") teststatus teststate)) + (button (vector-ref columndat rown)) + (color (car (gutils:get-color-for-state-status teststate teststatus))) + (curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR")) + (curr-title (vector-ref buttondat 2))) ;; (iup:attribute button "TITLE"))) + (if (not (equal? curr-color color)) + (iup:attribute-set! button "BGCOLOR" color)) + (if (not (equal? curr-title buttontxt)) + (iup:attribute-set! button "TITLE" buttontxt)) + (vector-set! buttondat 0 run-id) + (vector-set! buttondat 1 color) + (vector-set! buttondat 2 buttontxt) + (vector-set! buttondat 3 test) + (vector-set! buttondat 4 run-key))) + (set! rown (+ rown 1)))) + *alltestnamelst*)) + (set! coln (+ coln 1)))) + runs))) (define (mkstr . x) (string-intersperse (map conc x) ",")) (define (update-search x val) @@ -422,12 +399,663 @@ ;; (print "Setting search for " x " to " val) (hash-table-set! *searchpatts* x val)) (define (mark-for-update) (set! *last-db-update-time* 0) - (set! *delayed-update* 1) - ) + (set! *delayed-update* 1)) + +;;====================================================================== +;; R U N C O N T R O L +;;====================================================================== + +;; target populating logic +;; +;; lb = +;; field = target field name for this dropdown +;; referent-vals = selected value in the left dropdown +;; targets = list of targets to use to build the dropdown +;; +;; each node is chained: key1 -> key2 -> key3 +;; +;; must select values from only apropriate targets +;; a b c +;; a d e +;; a b f +;; a/b => c f +;; +(define (dashboard:populate-target-dropdown lb referent-vals targets) ;; runconf-targs) + ;; is the current value in the new list? choose new default if not + (let* ((remvalues (map (lambda (row) + (common:list-is-sublist referent-vals (vector->list row))) + targets)) + (values (delete-duplicates (map car (filter list? remvalues)))) + (sel-valnum (iup:attribute lb "VALUE")) + (sel-val (iup:attribute lb sel-valnum)) + (val-num 1)) + ;; first check if the current value is in the new list, otherwise replace with + ;; first value from values + (iup:attribute-set! lb "REMOVEITEM" "ALL") + (for-each (lambda (val) + ;; (iup:attribute-set! lb "APPENDITEM" val) + (iup:attribute-set! lb (conc val-num) val) + (if (equal? sel-val val) + (iup:attribute-set! lb "VALUE" val-num)) + (set! val-num (+ val-num 1))) + values) + (let ((val (iup:attribute lb "VALUE"))) + (if val + val + (if (not (null? values)) + (let ((newval (car values))) + (iup:attribute-set! lb "VALUE" newval) + newval)))))) + +(define (dashboard:update-target-selector key-lbs #!key (action-proc #f)) + (let* ((runconf-targs (common:get-runconfig-targets)) + (db-target-dat (open-run-close db:get-targets #f)) + (header (vector-ref db-target-dat 0)) + (db-targets (vector-ref db-target-dat 1)) + (all-targets (append db-targets + (map (lambda (x) + (list->vector + (take (append (string-split x "/") + (make-list (length header) "na")) + (length header)))) + runconf-targs))) + (key-listboxes (if key-lbs key-lbs (make-list (length header) #f)))) + (let loop ((key (car header)) + (remkeys (cdr header)) + (refvals '()) + (indx 0) + (lbs '())) + (let* ((lb (let ((lb (list-ref key-listboxes indx))) + (if lb + lb + (iup:listbox + ;; #:size "x10" + #:fontsize "10" + #:expand "YES" ;; "VERTICAL" + ;; #:dropdown "YES" + #:editbox "YES" + #:action (lambda (obj a b c) + (action-proc)) + #:caret_cb (lambda (obj a b c)(action-proc)) + )))) + ;; loop though all the targets and build the list for this dropdown + (selected-value (dashboard:populate-target-dropdown lb refvals all-targets))) + (if (null? remkeys) + ;; return a list of the listbox items and an iup:hbox with the labels and listboxes + (let ((listboxes (append lbs (list lb)))) + (list listboxes + (map (lambda (htxt lb) + (iup:vbox + (iup:label htxt) + lb)) + header + listboxes))) + (loop (car remkeys) + (cdr remkeys) + (append refvals (list selected-value)) + (+ indx 1) + (append lbs (list lb)))))))) + +;; Make a vertical list of toggles using items, when toggled call proc with the conc'd string +;; interspersed with commas +;; +(define (dashboard:text-list-toggle-box items proc) + (let ((alltgls (make-hash-table))) + (apply iup:vbox + (map (lambda (item) + (iup:toggle + item + #:expand "YES" + #:action (lambda (obj tstate) + (if (eq? tstate 0) + (hash-table-delete! alltgls item) + (hash-table-set! alltgls item #t)) + (let ((all (hash-table-keys alltgls))) + (proc all))))) + items)))) + +;; Extract the various bits of data from *data* and create the command line equivalent that will be displayed +;; +(define (dashboard:update-run-command) + (let* ((cmd-tb (dboard:data-get-command-tb *data*)) + (cmd (dboard:data-get-command *data*)) + (test-patt (let ((tp (dboard:data-get-test-patts *data*))) + (if (equal? tp "") "%" tp))) + (states (dboard:data-get-states *data*)) + (statuses (dboard:data-get-statuses *data*)) + (target (let ((targ-list (dboard:data-get-target *data*))) + (if targ-list (string-intersperse targ-list "/") "no-target-selected"))) + (run-name (dboard:data-get-run-name *data*)) + (states-str (if (or (not states) + (null? states)) + "" + (conc " :state " (string-intersperse states ",")))) + (statuses-str (if (or (not statuses) + (null? statuses)) + "" + (conc " :status " (string-intersperse statuses ",")))) + (full-cmd "megatest")) + (case (string->symbol cmd) + ((runtests) + (set! full-cmd (conc full-cmd + " -runtests " + test-patt + " -target " + target + " :runname " + run-name + ))) + ((remove-runs) + (set! full-cmd (conc full-cmd + " -remove-runs :runname " + run-name + " -target " + target + " -testpatt " + test-patt + states-str + statuses-str + ))) + (else (set! full-cmd " no valid command "))) + (iup:attribute-set! cmd-tb "VALUE" full-cmd))) + +;; Display the tests as rows of boxes on the test/task pane +;; +(define (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames) + (canvas-clear! cnv) + (canvas-font-set! cnv "Helvetica, -10") + (let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv)) + ((originx originy) (canvas-origin cnv))) + ;; (print "originx: " originx " originy: " originy) + ;; (canvas-origin-set! cnv 0 (- (/ sizey 2))) + (if (hash-table-ref/default tests-draw-state 'first-time #t) + (begin + (hash-table-set! tests-draw-state 'first-time #f) + (hash-table-set! tests-draw-state 'scalef 8) + (hash-table-set! tests-draw-state 'tests-info (make-hash-table)) + (hash-table-set! tests-draw-state 'selected-tests (make-hash-table)) + ;; set these + (hash-table-set! tests-draw-state 'test-browse-xoffset 20) ;; (- 0 (* (/ sizex 2) (* 8 xadj)))) + (hash-table-set! tests-draw-state 'test-browse-yoffset 20))) ;; (- 0 (* (/ sizey 2) (* 8 (- 1 yadj))))))) + (let* ((scalef (hash-table-ref/default tests-draw-state 'scalef 8)) + (test-browse-xoffset (hash-table-ref tests-draw-state 'test-browse-xoffset)) + (test-browse-yoffset (hash-table-ref tests-draw-state 'test-browse-yoffset)) + (xtorig (+ test-browse-xoffset (* (/ sizex 2) scalef (- 0.5 xadj)))) ;; (- xadj 1)))) + (ytorig (+ test-browse-yoffset (* (/ sizey 2) scalef (- yadj 0.5)))) + (boxw 90) + (boxh 25) + (gapx 20) + (gapy 30) + (tests-hash (hash-table-ref tests-draw-state 'tests-info)) + (selected-tests (hash-table-ref tests-draw-state 'selected-tests ))) + ;; (print "sizex: " sizex " sizey: " sizey " font: " (canvas-font cnv) " originx: " originx " originy: " originy " xtorig: " xtorig " ytorig: " ytorig " xadj: " xadj " yadj: " yadj) + (let loop ((hed (car (reverse sorted-testnames))) + (tal (cdr (reverse sorted-testnames))) + (llx xtorig) + (lly ytorig) + (urx (+ xtorig boxw)) + (ury (+ ytorig boxh))) + ; (print "hed " hed " llx " llx " lly " lly " urx " urx " ury " ury) + (canvas-text! cnv (+ llx 5)(+ lly 5) hed) ;; (conc testname " (" xtorig "," ytorig ")")) + (canvas-rectangle! cnv llx urx lly ury) + (if (hash-table-ref/default selected-tests hed #f) + (canvas-box! cnv llx (+ llx 5) lly (+ lly 5))) + (hash-table-set! tests-hash hed (list llx urx (- sizey ury)(- sizey lly))) ;; NB// Swap ury and lly + (if (not (null? tal)) + ;; leave a column of space to the right to list items + (let ((have-room + (if #t ;; put "auto" here where some form of auto rearanging can be done + (> (* 3 (+ boxw gapx)) (- urx xtorig)) + (< urx (- sizex boxw gapx boxw))))) ;; is there room for another column? + (loop (car tal) + (cdr tal) + (if have-room (+ llx boxw gapx) xtorig) ;; have room, + (if have-room lly (+ lly boxh gapy)) + (if have-room (+ urx boxw gapx) (+ xtorig boxw)) + (if have-room ury (+ ury boxh gapy))))))))) + +;;====================================================================== +;; R U N C O N T R O L S +;;====================================================================== +;; +;; A gui for launching tests +;; +(define (dashboard:run-controls) + (let* ((targets (make-hash-table)) + (test-records (make-hash-table)) + (test-names (tests:get-valid-tests *toppath* '())) + (sorted-testnames #f) + (action "-runtests") + (cmdln "") + (runlogs (make-hash-table)) + (key-listboxes #f) + (updater-for-runs #f) + (update-keyvals (lambda () + (let ((targ (map (lambda (x) + (iup:attribute x "VALUE")) + (car (dashboard:update-target-selector key-listboxes))))) + (dboard:data-set-target! *data* targ) + (if updater-for-runs (updater-for-runs)) + (dashboard:update-run-command)))) + (tests-draw-state (make-hash-table)) ;; use for keeping state of the test canvas + (test-patterns-textbox #f)) + (hash-table-set! tests-draw-state 'first-time #t) + (hash-table-set! tests-draw-state 'scalef 8) + (tests:get-full-data test-names test-records '()) + (set! sorted-testnames (tests:sort-by-priority-and-waiton test-records)) + + ;; refer to *keys*, *dbkeys* for keys + (iup:vbox + ;; The command line display/exectution control + (iup:frame + #:title "Command to be exectuted" + (iup:hbox + (iup:label "Run on" #:size "40x") + (iup:radio + (iup:hbox + (iup:toggle "Local" #:size "40x") + (iup:toggle "Server" #:size "40x"))) + (let ((tb (iup:textbox + #:value "megatest " + #:expand "HORIZONTAL" + #:readonly "YES" + #:font "Courier New, -12" + ))) + (dboard:data-set-command-tb! *data* tb) + tb) + (iup:button "Execute" #:size "50x" + #:action (lambda (obj) + (let ((cmd (conc "xterm -geometry 180x20 -e \"" + (iup:attribute (dboard:data-get-command-tb *data*) "VALUE") + ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) + (system cmd)))))) + + (iup:split + #:orientation "HORIZONTAL" + + (iup:split + #:value 300 + + ;; Target, testpatt, state and status input boxes + ;; + (iup:vbox + ;; Command to run + (iup:frame + #:title "Set the action to take" + (iup:hbox + ;; (iup:label "Command to run" #:expand "HORIZONTAL" #:size "70x" #:alignment "LEFT:ACENTER") + (let* ((cmds-list '("runtests" "remove-runs" "set-state-status" "lock-runs" "unlock-runs")) + (lb (iup:listbox #:expand "HORIZONTAL" + #:dropdown "YES" + #:action (lambda (obj val index lbstate) + ;; (print obj " " val " " index " " lbstate) + (dboard:data-set-command! *data* val) + (dashboard:update-run-command)))) + (default-cmd (car cmds-list))) + (iuplistbox-fill-list lb cmds-list selected-item: default-cmd) + (dboard:data-set-command! *data* default-cmd) + lb))) + + (iup:frame + #:title "Runname" + (let* ((default-run-name (conc "ww" (seconds->work-week/day (current-seconds)))) + (tb (iup:textbox #:expand "HORIZONTAL" + #:action (lambda (obj val txt) + ;; (print "obj: " obj " val: " val " unk: " unk) + (dboard:data-set-run-name! *data* txt) ;; (iup:attribute obj "VALUE")) + (dashboard:update-run-command)) + #:value default-run-name)) + (lb (iup:listbox #:expand "HORIZONTAL" + #:dropdown "YES" + #:action (lambda (obj val index lbstate) + (iup:attribute-set! tb "VALUE" val) + (dboard:data-set-run-name! *data* val) + (dashboard:update-run-command)))) + (refresh-runs-list (lambda () + (let* ((target (dboard:data-get-target-string *data*)) + (runs-for-targ (mt:get-runs-by-patt *keys* "%" target)) + (runs-header (vector-ref runs-for-targ 0)) + (runs-dat (vector-ref runs-for-targ 1)) + (run-names (cons default-run-name + (map (lambda (x) + (db:get-value-by-header x runs-header "runname")) + runs-dat)))) + (iup:attribute-set! lb "REMOVEITEM" "ALL") + (iuplistbox-fill-list lb run-names selected-item: default-run-name))))) + (set! updater-for-runs refresh-runs-list) + (refresh-runs-list) + (dboard:data-set-run-name! *data* default-run-name) + (iup:hbox + tb + lb))) + + (iup:frame + #:title "SELECTORS" + (iup:vbox + ;; Text box for test patterns + (iup:frame + #:title "Test patterns (one per line)" + (let ((tb (iup:textbox #:action (lambda (val a b) + (dboard:data-set-test-patts! + *data* + (dboard:lines->test-patt b)) + (dashboard:update-run-command)) + #:value (dboard:test-patt->lines + (dboard:data-get-test-patts *data*)) + #:expand "YES" + #:multiline "YES"))) + (set! test-patterns-textbox tb) + tb)) + (iup:frame + #:title "Target" + ;; Target selectors + (apply iup:hbox + (let* ((dat (dashboard:update-target-selector key-listboxes action-proc: update-keyvals)) + (key-lb (car dat)) + (combos (cadr dat))) + (set! key-listboxes key-lb) + combos))) + (iup:hbox + ;; Text box for STATES + (iup:frame + #:title "States" + (dashboard:text-list-toggle-box + ;; Move these definitions to common and find the other useages and replace! + '("COMPLETED" "RUNNING" "STUCK" "INCOMPLETE" "LAUNCHED" "REMOTEHOSTSTART" "KILLED") + (lambda (all) + (dboard:data-set-states! *data* all) + (dashboard:update-run-command)))) + ;; Text box for STATES + (iup:frame + #:title "Statuses" + (dashboard:text-list-toggle-box + '("PASS" "FAIL" "n/a" "CHECK" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD") + (lambda (all) + (dboard:data-set-statuses! *data* all) + (dashboard:update-run-command)))))))) + + (iup:frame + #:title "Tests and Tasks" + (let* ((updater #f) + (last-xadj 0) + (last-yadj 0) + (canvas-obj + (iup:canvas #:action (make-canvas-action + (lambda (cnv xadj yadj) + (if (not updater) + (set! updater (lambda (xadj yadj) + ;; (print "cnv: " cnv " x: " x " y: " y) + (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames)))) + (updater xadj yadj) + (set! last-xadj xadj) + (set! last-yadj yadj))) + ;; Following doesn't work + ;; #:wheel-cb (make-canvas-action + ;; (lambda (cnv xadj yadj) + ;; ;; (print "cnv: " cnv " x: " x " y: " y) + ;; (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames))) + #:size "150x150" + #:expand "YES" + #:scrollbar "YES" + #:posx "0.5" + #:posy "0.5" + #:button-cb (lambda (obj btn pressed x y status) + ;; (print "obj: " obj) + (let ((tests-info (hash-table-ref tests-draw-state 'tests-info)) + (selected-tests (hash-table-ref tests-draw-state 'selected-tests))) + ;; (print "x\ty\tllx\tlly\turx\tury") + (for-each (lambda (test-name) + (let* ((rec-coords (hash-table-ref tests-info test-name)) + (llx (list-ref rec-coords 0)) + (urx (list-ref rec-coords 1)) + (lly (list-ref rec-coords 2)) + (ury (list-ref rec-coords 3))) + ;; (print x "\t" y "\t" llx "\t" lly "\t" urx "\t" ury "\t" test-name " " + (if (and (eq? pressed 1) + (> x llx) + (> y lly) + (< x urx) + (< y ury)) + (let ((patterns (string-split (iup:attribute test-patterns-textbox "VALUE")))) + (let* ((selected (not (member test-name patterns))) + (newpatt-list (if selected + (cons test-name patterns) + (delete test-name patterns))) + (newpatt (string-intersperse newpatt-list "\n"))) + ;; (if cnv-obj + ;; (dashboard:draw-tests cnv-obj 0 0 tests-draw-state sorted-testnames)) + (iup:attribute-set! obj "REDRAW" "ALL") + (hash-table-set! selected-tests test-name selected) + (iup:attribute-set! test-patterns-textbox "VALUE" newpatt) + (dboard:data-set-test-patts! *data* (dboard:lines->test-patt newpatt)) + (dashboard:update-run-command) + (if updater (updater last-xadj last-yadj))))))) + (hash-table-keys tests-info))))))) + canvas-obj))) + ;; (print "obj: " obj " btn: " btn " pressed: " pressed " x: " x " y: " y " status: " status)) + + (iup:frame + #:title "Logs" ;; To be replaced with tabs + (let ((logs-tb (iup:textbox #:expand "YES" + #:multiline "YES"))) + (dboard:data-set-logs-textbox! *data* logs-tb) + logs-tb)))))) + + +;; (trace dashboard:populate-target-dropdown +;; common:list-is-sublist) +;; +;; ;; key1 key2 key3 ... +;; ;; target entry (wild cards allowed) +;; +;; ;; The action +;; (iup:hbox +;; ;; label Action | action selector +;; )) +;; ;; Test/items selector +;; (iup:hbox +;; ;; tests +;; ;; items +;; )) +;; ;; The command line +;; (iup:hbox +;; ;; commandline entry +;; ;; GO button +;; ) +;; ;; The command log monitor +;; (iup:tabs +;; ;; log monitor +;; ))) + +;;====================================================================== +;; S U M M A R Y +;;====================================================================== +;; +;; General info about the run(s) and megatest area +(define (dashboard:summary) + (let ((rawconfig (read-config (conc *toppath* "/megatest.config") #f 'return-string))) + (iup:vbox + (iup:split + ;; #:value 500 + (iup:frame + #:title "General Info" + (iup:hbox + (dcommon:keys-matrix rawconfig) + (dcommon:general-info) + )) + (iup:frame + #:title "Server" + (dcommon:servers-table))) + (iup:frame + #:title "Megatest config settings" + (iup:hbox + (dcommon:section-matrix rawconfig "setup" "Varname" "Value") + (iup:vbox + (dcommon:section-matrix rawconfig "server" "Varname" "Value") + ;; (iup:frame + ;; #:title "Disks Areas" + (dcommon:section-matrix rawconfig "disks" "Disk area" "Path")))) + (iup:frame + #:title "Run statistics" + (dcommon:run-stats))))) + +;;====================================================================== +;; R U N +;;====================================================================== +;; +;; display and manage a single run at a time + +(define (tree-path->run-id path) + (if (not (null? path)) + (hash-table-ref/default (dboard:data-get-path-run-ids *data*) path #f) + #f)) + +(define dashboard:update-run-summary-tab #f) + +;; (define (tests window-id) +(define (dashboard:one-run) + (let* ((tb (iup:treebox + #:value 0 + #:name "Runs" + #:expand "YES" + #:addexpanded "NO" + #:selection-cb + (lambda (obj id state) + ;; (print "obj: " obj ", id: " id ", state: " state) + (let* ((run-path (tree:node->path obj id)) + (run-id (tree-path->run-id (cdr run-path)))) + (if run-id + (begin + (dboard:data-set-curr-run-id! *data* run-id) + (dashboard:update-run-summary-tab))) + ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) + )))) + (run-matrix (iup:matrix + #:expand "YES")) + (updater (lambda () + (let* ((runs-dat (mt:get-runs-by-patt *keys* "%" #f)) + (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records + (run-id (dboard:data-get-curr-run-id *data*)) + (tests-dat (let ((tdat (mt:get-tests-for-run run-id "%" '() '() + qryvals: "id,testname,item_path,state,status"))) ;; get 'em all + (sort tdat (lambda (a b) + (let* ((aval (vector-ref a 2)) + (bval (vector-ref b 2)) + (anum (string->number aval)) + (bnum (string->number bval))) + (if (and anum bnum) + (< anum bnum) + (string<= aval bval))))))) + (tests-mindat (dcommon:minimize-test-data tests-dat)) + (indices (common:sparse-list-generate-index tests-mindat)) ;; proc: set-cell)) + (row-indices (cadr indices)) + (col-indices (car indices)) + (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) + (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices)))) + (max-visible (max (- *num-tests* 15) 3)) ;; *num-tests* is proportional to the size of the window + (numrows 1) + (numcols 1) + (changed #f) + (runs-hash (let ((ht (make-hash-table))) + (for-each (lambda (run) + (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) + (vector-ref runs-dat 1)) + ht)) + (run-ids (sort (filter number? (hash-table-keys runs-hash)) + (lambda (a b) + (let* ((record-a (hash-table-ref runs-hash a)) + (record-b (hash-table-ref runs-hash b)) + (time-a (db:get-value-by-header record-a runs-header "event_time")) + (time-b (db:get-value-by-header record-b runs-header "event_time"))) + (< time-a time-b)))))) + + ;; (iup:attribute-set! tb "VALUE" "0") + ;; (iup:attribute-set! tb "NAME" "Runs") + ;; Update the runs tree + (for-each (lambda (run-id) + (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) + (key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key)) + *keys*)) + (run-name (db:get-value-by-header run-record runs-header "runname")) + (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) + (run-path (append key-vals (list run-name)))) + (hash-table-set! (dboard:data-get-run-keys *data*) run-id run-path) + ;; (iup:attribute-set! (dboard:data-get-runs-matrix *data*) + ;; (conc rownum ":" colnum) col-name) + ;; (hash-table-set! runid-to-col run-id (list colnum run-record)) + ;; Here we update the tests treebox and tree keys + (tree:add-node tb "Runs" (append key-vals (list run-name)) + userdata: (conc "run-id: " run-id)) + (let ((path ;;(string-intersperse "/" + (append key-vals (list run-name)))) + (hash-table-set! (dboard:data-get-path-run-ids *data*) path run-id)) + ;; (set! colnum (+ colnum 1)) + )) + run-ids) + (iup:attribute-set! run-matrix "CLEARVALUE" "CONTENTS") + (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS") + (iup:attribute-set! run-matrix "NUMCOL" max-col ) + (iup:attribute-set! run-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)) ;; min of 20 + ;; (iup:attribute-set! run-matrix "NUMCOL_VISIBLE" max-col) + ;; (iup:attribute-set! run-matrix "NUMLIN_VISIBLE" (if (> max-row max-visible) max-visible max-row)) + + ;; Row labels + (for-each (lambda (ind) + (let* ((name (car ind)) + (num (cadr ind)) + (key (conc num ":0"))) + (if (not (equal? (iup:attribute run-matrix key) name)) + (begin + (set! changed #t) + (iup:attribute-set! run-matrix key name))))) + row-indices) + + ;; Col labels + (for-each (lambda (ind) + (let* ((name (car ind)) + (num (cadr ind)) + (key (conc "0:" num))) + (if (not (equal? (iup:attribute run-matrix key) name)) + (begin + (set! changed #t) + (iup:attribute-set! run-matrix key name) + (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num)))))) + col-indices) + + ;; Cell contents + (for-each (lambda (entry) + (let* ((row-name (cadr entry)) + (col-name (car entry)) + (valuedat (caddr entry)) + (test-id (list-ref valuedat 0)) + (test-name row-name) ;; (list-ref valuedat 1)) + (item-path col-name) ;; (list-ref valuedat 2)) + (state (list-ref valuedat 1)) + (status (list-ref valuedat 2)) + (value (gutils:get-color-for-state-status state status)) + (row-num (cadr (assoc row-name row-indices))) + (col-num (cadr (assoc col-name col-indices))) + (key (conc row-num ":" col-num))) + (if (not (equal? (iup:attribute run-matrix key) (cadr value))) + (begin + (set! changed #t) + (iup:attribute-set! run-matrix key (cadr value)) + (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value)))))) + tests-mindat) + (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL")))))) + (set! dashboard:update-run-summary-tab updater) + (dboard:data-set-runs-tree! *data* tb) + (iup:split + tb + run-matrix))) + +;;====================================================================== +;; R U N S +;;====================================================================== (define (make-dashboard-buttons nruns ntests keynames) (let* ((nkeys (length keynames)) (runsvec (make-vector nruns)) (header (make-vector nruns)) @@ -484,11 +1112,11 @@ (iup:toggle status #:action (lambda (obj val) (mark-for-update) (if (eq? val 1) (hash-table-set! *status-ignore-hash* status #t) (hash-table-delete! *status-ignore-hash* status))))) - '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP"))) + '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP"))) (apply iup:hbox (map (lambda (state) (iup:toggle state #:action (lambda (obj val) (mark-for-update) @@ -504,54 +1132,54 @@ (mark-for-update) (debug:print 6 "*start-run-offset* " *start-run-offset* " maxruns: " maxruns ", val: " val " oldmax: " oldmax) (iup:attribute-set! obj "MAX" (* maxruns 10)))) #:expand "YES" #:max (* 10 (length *allruns*))))) - ;(iup:button "inc rows" #:action (lambda (obj)(set! *num-tests* (+ *num-tests* 1)))) - ;(iup:button "dec rows" #:action (lambda (obj)(set! *num-tests* (if (> *num-tests* 0)(- *num-tests* 1) 0)))) + ;(iup:button "inc rows" #:action (lambda (obj)(set! *num-tests* (+ *num-tests* 1)))) + ;(iup:button "dec rows" #:action (lambda (obj)(set! *num-tests* (if (> *num-tests* 0)(- *num-tests* 1) 0)))) ) ) ;; create the left most column for the run key names and the test names (set! lftlst (list (iup:hbox (iup:label) ;; (iup:valuator) (apply iup:vbox (map (lambda (x) (let ((res (iup:hbox #:expand "HORIZONTAL" - (iup:label x #:size "x15" #:fontsize "10" #:expand "HORIZONTAL") - (iup:textbox #:size "x15" #:fontsize "10" #:value "%" #:expand "HORIZONTAL" - #:action (lambda (obj unk val) - (mark-for-update) - (update-search x val)))))) + (iup:label x #:size "x15" #:fontsize "10" #:expand "HORIZONTAL") + (iup:textbox #:size "x15" #:fontsize "10" #:value "%" #:expand "HORIZONTAL" + #:action (lambda (obj unk val) + (mark-for-update) + (update-search x val)))))) (set! i (+ i 1)) res)) keynames))))) (let loop ((testnum 0) (res '())) (cond ((>= testnum ntests) ;; now lftlst will be an hbox with the test keys and the test name labels (set! lftlst (append lftlst (list (iup:hbox #:expand "HORIZONTAL" - (iup:valuator #:valuechanged_cb (lambda (obj) - (let ((val (string->number (iup:attribute obj "VALUE"))) - (oldmax (string->number (iup:attribute obj "MAX"))) - (newmax (* 10 (length *alltestnamelst*)))) - (set! *please-update-buttons* #t) - (set! *start-test-offset* (inexact->exact (round (/ val 10)))) - (debug:print 6 "*start-test-offset* " *start-test-offset* " val: " val " newmax: " newmax " oldmax: " oldmax) - (if (< val 10) - (iup:attribute-set! obj "MAX" newmax)) - )) - #:expand "VERTICAL" - #:orientation "VERTICAL") - (apply iup:vbox (reverse res))))))) + (iup:valuator #:valuechanged_cb (lambda (obj) + (let ((val (string->number (iup:attribute obj "VALUE"))) + (oldmax (string->number (iup:attribute obj "MAX"))) + (newmax (* 10 (length *alltestnamelst*)))) + (set! *please-update-buttons* #t) + (set! *start-test-offset* (inexact->exact (round (/ val 10)))) + (debug:print 6 "*start-test-offset* " *start-test-offset* " val: " val " newmax: " newmax " oldmax: " oldmax) + (if (< val 10) + (iup:attribute-set! obj "MAX" newmax)) + )) + #:expand "VERTICAL" + #:orientation "VERTICAL") + (apply iup:vbox (reverse res))))))) (else (let ((labl (iup:button "" #:flat "YES" #:alignment "ALEFT" - ; #:image img1 - ; #:impress img2 + ; #:image img1 + ; #:impress img2 #:size "x15" #:expand "HORIZONTAL" #:fontsize "10" #:action (lambda (obj) (mark-for-update) @@ -593,67 +1221,121 @@ #:action (lambda (x) (let* ((toolpath (car (argv))) (buttndat (hash-table-ref *buttondat* button-key)) (test-id (db:test-get-id (vector-ref buttndat 3))) (cmd (conc toolpath " -test " test-id "&"))) - ;(print "Launching " cmd) + ;(print "Launching " cmd) (system cmd)))))) (hash-table-set! *buttondat* button-key (vector 0 "100 100 100" button-key #f #f)) (vector-set! testvec testnum butn) (loop runnum (+ testnum 1) testvec (cons butn res)))))) ;; now assemble the hdrlst and bdylst and kick off the dialog (iup:show (iup:dialog - #:title "Megatest dashboard" - (iup:vbox - (apply iup:hbox - (cons (apply iup:vbox lftlst) - (list - (iup:vbox - ;; the header - (apply iup:hbox (reverse hdrlst)) - (apply iup:hbox (reverse bdylst)))))) - controls))) + #:title (conc "Megatest dashboard " (current-user-name) ":" *toppath*) + #:menu (dcommon:main-menu) + (let* ((runs-view (iup:vbox + (apply iup:hbox + (cons (apply iup:vbox lftlst) + (list + (iup:vbox + ;; the header + (apply iup:hbox (reverse hdrlst)) + (apply iup:hbox (reverse bdylst)))))) + controls)) + (tabs (iup:tabs + #:tabchangepos-cb (lambda (obj curr prev) + (set! *please-update-buttons* #t) + (set! *current-tab-number* curr)) + (dashboard:summary) + runs-view + (dashboard:one-run) + (dashboard:run-controls) + ))) + ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c))) + (iup:attribute-set! tabs "TABTITLE0" "Summary") + (iup:attribute-set! tabs "TABTITLE1" "Runs") + (iup:attribute-set! tabs "TABTITLE2" "Run Summary") + (iup:attribute-set! tabs "TABTITLE3" "Run Control") + tabs))) (vector keycol lftcol header runsvec))) (if (or (args:get-arg "-rows") (get-environment-variable "DASHBOARDROWS" )) (begin - (set! *num-tests* (string->number (or (args:get-arg "-rows") - (get-environment-variable "DASHBOARDROWS")))) - (update-rundat "%" *num-runs* "%/%" '())) + (set! *num-tests* (string->number (or (args:get-arg "-rows") + (get-environment-variable "DASHBOARDROWS")))) + (update-rundat "%" *num-runs* "%/%" '())) (set! *num-tests* (min (max (update-rundat "%" *num-runs* "%/%" '()) 8) 20))) (define *tim* (iup:timer)) (define *ord* #f) (iup:attribute-set! *tim* "TIME" 300) (iup:attribute-set! *tim* "RUN" "YES") -;; Move this stuff to db.scm FIXME +;; Move this stuff to db.scm? I'm not sure that is the right thing to do... ;; (define *last-db-update-time* (file-modification-time (conc *toppath* "/megatest.db"))) -(define (db:been-changed) + +(define (dashboard:been-changed) (> (file-modification-time (conc *toppath* "/megatest.db")) *last-db-update-time*)) -(define (db:set-db-update-time) + +(define (dashboard:set-db-update-time) (set! *last-db-update-time* (file-modification-time (conc *toppath* "/megatest.db")))) -(define (run-update x) - (update-buttons uidat *num-runs* *num-tests*) - ;; (if (db:been-changed) - (begin - (update-rundat (hash-table-ref/default *searchpatts* "runname" "%") *num-runs* - (hash-table-ref/default *searchpatts* "test-name" "%/%") - ;; (hash-table-ref/default *searchpatts* "item-name" "%") - (let ((res '())) - (for-each (lambda (key) - (if (not (equal? key "runname")) - (let ((val (hash-table-ref/default *searchpatts* key #f))) - (if val (set! res (cons (list key val) res)))))) - *dbkeys*) - res)) - ; (db:set-db-update-time) - )) +(define (dashboard:recalc modtime please-update-buttons last-db-update-time) + (or please-update-buttons + (and (> modtime last-db-update-time) + (> (current-seconds)(+ last-db-update-time 1))))) + +(define *monitor-db-path* (conc *toppath* "/monitor.db")) +(define *last-monitor-update-time* 0) + +(define (dashboard:run-update x) + (let* ((modtime (file-modification-time *db-file-path*)) + (monitor-modtime (file-modification-time *monitor-db-path*)) + (run-update-time (current-seconds)) + (recalc (dashboard:recalc modtime *please-update-buttons* *last-db-update-time*))) + (if (and (eq? *current-tab-number* 0) + (> monitor-modtime *last-monitor-update-time*)) + (begin + (set! *last-monitor-update-time* monitor-modtime) + (if dashboard:update-servers-table (dashboard:update-servers-table)))) + (if recalc + (begin + (case *current-tab-number* + ((0) + (if dashboard:update-summary-tab (dashboard:update-summary-tab))) + ((1) ;; The runs table is active + (update-rundat (hash-table-ref/default *searchpatts* "runname" "%") *num-runs* + (hash-table-ref/default *searchpatts* "test-name" "%/%") + ;; (hash-table-ref/default *searchpatts* "item-name" "%") + (let ((res '())) + (for-each (lambda (key) + (if (not (equal? key "runname")) + (let ((val (hash-table-ref/default *searchpatts* key #f))) + (if val (set! res (cons (list key val) res)))))) + *dbkeys*) + res)) + (update-buttons uidat *num-runs* *num-tests*)) + ((2) + (dashboard:update-run-summary-tab)) + (else + (let ((updater (hash-table-ref/default *updaters* *current-tab-number* #f))) + (if updater (updater))))) + (set! *please-update-buttons* #f) + (set! *last-db-update-time* modtime) + (set! *last-update* run-update-time))))) + +;;====================================================================== +;; The heavy lifting starts here +;;====================================================================== + +;; ease debugging by loading ~/.megatestrc +(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc"))) + (if (file-exists? debugcontrolf) + (load debugcontrolf))) (cond ((args:get-arg "-run") (let ((runid (string->number (args:get-arg "-run")))) (if runid @@ -664,11 +1346,11 @@ (cdb:remote-run examine-run *db* runid))) (begin (print "ERROR: runid is not a number " (args:get-arg "-run")) (exit 1))))) ((args:get-arg "-test") - (let ((testid (string->number (args:get-arg "-test")))) + (let ((testid (string->number (args:get-arg "-test")))) (if testid (examine-test testid) (begin (print "ERROR: testid is not a number " (args:get-arg "-test")) (exit 1))))) @@ -677,9 +1359,9 @@ (else (set! uidat (make-dashboard-buttons *num-runs* *num-tests* *dbkeys*)) (iup:callback-set! *tim* "ACTION_CB" (lambda (x) - (run-update x))))) - ;(print x))))) + (dashboard:run-update x) + 1)))) (iup:main-loop) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -1,7 +1,7 @@ ;;====================================================================== -;; Copyright 2006-2012, Matthew Welland. +;; Copyright 2006-2013, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the @@ -27,10 +27,11 @@ (declare (uses common)) (declare (uses keys)) (declare (uses ods)) (declare (uses fs-transport)) (declare (uses client)) +(declare (uses mt)) (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") (include "run_records.scm") @@ -68,14 +69,18 @@ (begin (debug:print 0 "ERROR: Attempted to open db when not in megatest area. Exiting.") (exit)))) (let* ((dbpath (conc *toppath* "/megatest.db")) ;; fname) (dbexists (file-exists? dbpath)) + (write-access (file-write-access? dbpath)) (db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath)) (handler (make-busy-timeout (if (args:get-arg "-override-timeout") (string->number (args:get-arg "-override-timeout")) 136000)))) ;; 136000))) ;; 136000 = 2.2 minutes + (if (and dbexists + (not write-access)) + (set! *db-write-access* write-access)) ;; only unset so other db's also can use this control (debug:print-info 11 "open-db, dbpath=" dbpath " argv=" (argv)) (sqlite3:set-busy-handler! db handler) (if (not dbexists) (db:initialize db)) (db:set-sync db) @@ -133,16 +138,16 @@ res)) (define (db:initialize db) (debug:print-info 11 "db:initialize START") (let* ((configdat (car *configinfo*)) ;; tut tut, global warning... - (keys (config-get-fields configdat)) + (keys (keys:config-get-fields configdat)) (havekeys (> (length keys) 0)) (keystr (keys->keystr keys)) (fieldstr (keys->key/field keys))) (for-each (lambda (key) - (let ((keyn (vector-ref key 0))) + (let ((keyn key)) (if (member (string-downcase keyn) (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count")) (begin (print "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table") @@ -151,11 +156,11 @@ keys) ;; (sqlite3:execute db "PRAGMA synchronous = OFF;") (db:set-sync db) (sqlite3:execute db "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));") (for-each (lambda (key) - (sqlite3:execute db "INSERT INTO keys (fieldname,fieldtype) VALUES (?,?);" (key:get-fieldname key)(key:get-fieldtype key))) + (sqlite3:execute db "INSERT INTO keys (fieldname,fieldtype) VALUES (?,?);" key "TEXT")) keys) (sqlite3:execute db (conc "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, " fieldstr (if havekeys "," "") "runname TEXT," @@ -492,26 +497,29 @@ (define (db:del-var db var) (debug:print-info 11 "db:del-var START " var) (sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var) (debug:print-info 11 "db:del-var END " var)) -;; use a global for some primitive caching, it is just silly to re-read the db -;; over and over again for the keys since they never change +;; use a global for some primitive caching, it is just silly to +;; re-read the db over and over again for the keys since they never +;; change + +;; why get the keys from the db? why not get from the *configdat* +;; using keys:config-get-fields? (define (db:get-keys db) (if *db-keys* *db-keys* (let ((res '())) - (debug:print-info 11 "db:get-keys START (cache miss)") (sqlite3:for-each-row - (lambda (key keytype) - (set! res (cons (vector key keytype) res))) + (lambda (key) + (set! res (cons key res))) db - "SELECT fieldname,fieldtype FROM keys ORDER BY id DESC;") + "SELECT fieldname FROM keys ORDER BY id DESC;") (set! *db-keys* res) - (debug:print-info 11 "db:get-keys END (cache miss)") res))) +;; (define (db:get-value-by-header row header field) (debug:print-info 4 "db:get-value-by-header row: " row " header: " header " field: " field) (if (null? header) #f (let loop ((hed (car header)) (tal (cdr header)) @@ -521,15 +529,34 @@ (if (null? tal) #f (loop (car tal)(cdr tal)(+ n 1))))))) ;;====================================================================== ;; R U N S ;;====================================================================== + +(define (db:get-run-name-from-id db run-id) + (let ((res #f)) + (sqlite3:for-each-row + (lambda (runname) + (set! res runname)) + db + "SELECT runname FROM runs WHERE id=?;" + run-id) + res)) + +(define (db:get-run-key-val db run-id key) + (let ((res #f)) + (sqlite3:for-each-row + (lambda (val) + (set! res val)) + db + (conc "SELECT " key " FROM runs WHERE id=?;") + run-id) + res)) ;; keys list to key1,key2,key3 ... (define (runs:get-std-run-fields keys remfields) - (let* ((header (append (map key:get-fieldname keys) - remfields)) + (let* ((header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ",")))) (list keystr header))) ;; make a query (fieldname like 'patt1' OR fieldname @@ -545,22 +572,22 @@ patts)) comparator))) ;; register a test run with the db -(define (db:register-run db keys keyvallst runname state status user) - (debug:print 3 "runs:register-run, keys: " keys " keyvallst: " keyvallst " runname: " runname " state: " state " status: " status " user: " user) - (let* ((keystr (keys->keystr keys)) +(define (db:register-run db keyvals runname state status user) + (debug:print 3 "runs:register-run runname: " runname " state: " state " status: " status " user: " user) + (let* ((keys (map car keyvals)) + (keystr (keys->keystr keys)) (comma (if (> (length keys) 0) "," "")) (andstr (if (> (length keys) 0) " AND " "")) (valslots (keys->valslots keys)) ;; ?,?,? ... - (keyvals (map cadr keyvallst)) - (allvals (append (list runname state status user) keyvals)) - (qryvals (append (list runname) keyvals)) - (key=?str (string-intersperse (map (lambda (k)(conc (key:get-fieldname k) "=?")) keys) " AND "))) - (debug:print 3 "keys: " keys " allvals: " allvals " keyvals: " keyvals) - (debug:print 2 "NOTE: using target " (string-intersperse keyvals "/") " for this run") + (allvals (append (list runname state status user) (map cadr keyvals))) + (qryvals (append (list runname) (map cadr keyvals))) + (key=?str (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND "))) + (debug:print 3 "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str) + (debug:print 2 "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run") (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and" (let ((res #f)) (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");") allvals) (apply sqlite3:for-each-row @@ -569,11 +596,11 @@ db (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");"))) ;(debug:print 4 "qry: " qry) qry) qryvals) - (sqlite3:execute db "UPDATE runs SET state=?,status=? WHERE id=?;" state status res) + (sqlite3:execute db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=?;" state status res) res) (begin (debug:print 0 "ERROR: Called without all necessary keys") #f)))) @@ -586,12 +613,11 @@ (define (db:get-runs db runpatt count offset keypatts) (let* ((res '()) (keys (db:get-keys db)) (runpattstr (db:patt->like "runname" runpatt)) (remfields (list "id" "runname" "state" "status" "owner" "event_time")) - (header (append (map key:get-fieldname keys) - remfields)) + (header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ","))) (qrystr (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? " ;; Generate: " AND x LIKE 'keypatt' ..." (if (null? keypatts) "" @@ -601,11 +627,11 @@ (let ((key (car keypatt)) (patt (cadr keypatt))) (db:patt->like key patt))) keypatts) " AND "))) - " ORDER BY event_time DESC " + " AND state != 'deleted' ORDER BY event_time DESC " (if (number? count) (conc " LIMIT " count) "") (if (number? offset) (conc " OFFSET " offset) @@ -618,39 +644,117 @@ qrystr ) (debug:print-info 11 "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) (vector header res))) +;; Get all targets from the db +;; +(define (db:get-targets db) + (let* ((res '()) + (keys (db:get-keys db)) + (header keys) ;; (map key:get-fieldname keys)) + (keystr (keys->keystr keys)) + (qrystr (conc "SELECT " keystr " FROM runs;")) + (seen (make-hash-table))) + (sqlite3:for-each-row + (lambda (a . x) + (let ((targ (cons a x))) + (if (not (hash-table-ref/default seen targ #f)) + (begin + (hash-table-set! seen targ #t) + (set! res (cons (apply vector targ) res)))))) + db + qrystr) + (debug:print-info 11 "db:get-targets END qrystr: " qrystr ) + (vector header res))) + ;; just get count of runs (define (db:get-num-runs db runpatt) (let ((numruns 0)) (debug:print-info 11 "db:get-num-runs START " runpatt) (sqlite3:for-each-row (lambda (count) (set! numruns count)) db - "SELECT COUNT(id) FROM runs WHERE runname LIKE ?;" runpatt) + "SELECT COUNT(id) FROM runs WHERE runname LIKE ? AND state != 'deleted';" runpatt) (debug:print-info 11 "db:get-num-runs END " runpatt) numruns)) + +;; get some basic run stats +;; +;; ( (runname (( state count ) ... )) +;; ( ... +(define (db:get-run-stats db) + (let ((totals (make-hash-table)) + (res '())) + (sqlite3:for-each-row + (lambda (runname state count) + (let* ((stateparts (string-split state "|")) + (newstate (conc (car stateparts) "\n" (cadr stateparts)))) + (hash-table-set! totals newstate (+ (hash-table-ref/default totals newstate 0) count)) + (set! res (cons (list runname newstate count) res)))) + db + "SELECT runname,t.state||'|'||t.status AS s,count(t.id) FROM runs AS r INNER JOIN tests AS t ON r.id=t.run_id GROUP BY s,runname ORDER BY r.event_time,s DESC;" ) + ;; (set! res (reverse res)) + (for-each (lambda (state) + (set! res (cons (list "Totals" state (hash-table-ref totals state)) res))) + (sort (hash-table-keys totals) string>=)) + res)) + +;; db:get-runs-by-patt +;; get runs by list of criteria +;; register a test run with the db +;; +;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-row runinfo)) +;; to extract info from the structure returned +;; +(define (db:get-runs-by-patt db keys runnamepatt targpatt) ;; test-name) + (let* ((tmp (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time"))) + (keystr (car tmp)) + (header (cadr tmp)) + (res '()) + (key-patt "") + (runwildtype (if (substring-index "%" runnamepatt) "like" "glob")) + (qry-str #f) + (keyvals (if targpatt (keys:target->keyval keys targpatt) '()))) + (for-each (lambda (keyval) + (let* ((key (car keyval)) + (patt (cadr keyval)) + (fulkey (conc ":" key)) + (wildtype (if (substring-index "%" patt) "like" "glob"))) + (if patt + (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'")) + (begin + (debug:print 0 "ERROR: searching for runs with no pattern set for " fulkey) + (exit 6))))) + keyvals) + (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt " ORDER BY event_time;")) + (debug:print-info 4 "runs:get-runs-by-patt qry=" qry-str " " runnamepatt) + (sqlite3:for-each-row + (lambda (a . r) + (set! res (cons (list->vector (cons a r)) res))) + db + qry-str + runnamepatt) + (vector header res))) ;; use (get-value-by-header (db:get-header runinfo)(db:get-row runinfo)) (define (db:get-run-info db run-id) ;;(if (hash-table-ref/default *run-info-cache* run-id #f) ;; (hash-table-ref *run-info-cache* run-id) (let* ((res #f) (keys (db:get-keys db)) (remfields (list "id" "runname" "state" "status" "owner" "event_time")) - (header (append (map key:get-fieldname keys) - remfields)) + (header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ",")))) (debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) (sqlite3:for-each-row (lambda (a . x) (set! res (apply vector a x))) db - (conc "SELECT " keystr " FROM runs WHERE id=?;") + (conc "SELECT " keystr " FROM runs WHERE id=? AND state != 'deleted';") run-id) (debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) (let ((finalres (vector header res))) ;; (hash-table-set! *run-info-cache* run-id finalres) finalres))) @@ -661,11 +765,14 @@ (debug:print-info 11 "db:set-comment-for-run END run-id: " run-id " comment: " comment)) ;; does not (obviously!) removed dependent data. But why not!!? (define (db:delete-run db run-id) (common:clear-caches) ;; don't trust caches after doing any deletion - (sqlite3:execute db "DELETE FROM runs WHERE id=?;" run-id)) + (sqlite3:execute db "UPDATE runs SET state='deleted' WHERE id=?;" run-id)) +;; (sqlite3:execute db "DELETE FROM runs WHERE id=?;" run-id)) + + (define (db:update-run-event_time db run-id) (debug:print-info 11 "db:update-run-event_time START run-id: " run-id) (sqlite3:execute db "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id) (debug:print-info 11 "db:update-run-event_time END run-id: " run-id)) @@ -685,54 +792,54 @@ ;;====================================================================== ;; get key val pairs for a given run-id ;; ( (FIELDNAME1 keyval1) (FIELDNAME2 keyval2) ... ) (define (db:get-key-val-pairs db run-id) - (let* ((keys (get-keys db)) + (let* ((keys (db:get-keys db)) (res '())) (debug:print-info 11 "db:get-key-val-pairs START keys: " keys " run-id: " run-id) (for-each (lambda (key) - (let ((qry (conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;"))) + (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) ;; (debug:print 0 "qry: " qry) (sqlite3:for-each-row (lambda (key-val) - (set! res (cons (list (key:get-fieldname key) key-val) res))) + (set! res (cons (list key key-val) res))) db qry run-id))) keys) (debug:print-info 11 "db:get-key-val-pairs END keys: " keys " run-id: " run-id) (reverse res))) ;; get key vals for a given run-id (define (db:get-key-vals db run-id) - (let ((mykeyvals (hash-table-ref/default *keyvals* run-id #f))) + (let ((mykeyvals (hash-table-ref/default *keyvals* run-id #f))) (if mykeyvals mykeyvals - (let* ((keys (get-keys db)) - (res '())) - (debug:print-info 11 "db:get-key-vals START keys: " keys " run-id: " run-id) - (for-each - (lambda (key) - (let ((qry (conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;"))) - ;; (debug:print 0 "qry: " qry) - (sqlite3:for-each-row - (lambda (key-val) - (set! res (cons key-val res))) - db qry run-id))) - keys) - (debug:print-info 11 "db:get-key-vals END keys: " keys " run-id: " run-id) + (let* ((keys (db:get-keys db)) + (res '())) + (debug:print-info 11 "db:get-key-vals START keys: " keys " run-id: " run-id) + (for-each + (lambda (key) + (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) + ;; (debug:print 0 "qry: " qry) + (sqlite3:for-each-row + (lambda (key-val) + (set! res (cons key-val res))) + db qry run-id))) + keys) + (debug:print-info 11 "db:get-key-vals END keys: " keys " run-id: " run-id) (let ((final-res (reverse res))) (hash-table-set! *keyvals* run-id final-res) final-res))))) ;; The target is keyval1/keyval2..., cached in *target* as it is used often (define (db:get-target db run-id) (let ((mytarg (hash-table-ref/default *target* run-id #f))) (if mytarg mytarg - (let* ((keyvals (db:get-key-vals db run-id)) - (thekey (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/"))) + (let* ((keyvals (db:get-key-vals db run-id)) + (thekey (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/"))) (hash-table-set! *target* run-id thekey) thekey)))) ;;====================================================================== ;; T E S T S @@ -740,42 +847,57 @@ ;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN ;; i.e. these lists define what to NOT show. ;; states and statuses are required to be lists, empty is ok ;; not-in #t = above behaviour, #f = must match -(define (db:get-tests-for-run db run-id testpatt states statuses - #!key (not-in #t) - (sort-by #f) ;; 'rundir 'event_time - (qryvals "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment") +(define (db:get-tests-for-run db run-id testpatt states statuses offset limit not-in sort-by + #!key + (qryvals #f) ) (debug:print-info 11 "db:get-tests-for-run START run-id=" run-id ", testpatt=" testpatt ", states=" states ", statuses=" statuses ", not-in=" not-in ", sort-by=" sort-by) - (let* ((res '()) + (let* ((qryvals (if qryvals qryvals "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")) + (res '()) ;; if states or statuses are null then assume match all when not-in is false (states-qry (if (null? states) #f (conc " state " - (if not-in "NOT" "") - " IN ('" + (if not-in + " NOT IN ('" + " IN ('") (string-intersperse states "','") "')"))) (statuses-qry (if (null? statuses) #f (conc " status " - (if not-in "NOT" "") - " IN ('" + (if not-in + " NOT IN ('" + " IN ('") (string-intersperse statuses "','") "')"))) + (states-statuses-qry + (cond + ((and states-qry statuses-qry) + (conc " AND ( " states-qry " AND " statuses-qry " ) ")) + (states-qry + (conc " AND " states-qry)) + (statuses-qry + (conc " AND " statuses-qry)) + (else ""))) (tests-match-qry (tests:match->sqlqry testpatt)) (qry (conc "SELECT " qryvals - " FROM tests WHERE run_id=? " - (if states-qry (conc " AND " states-qry) "") - (if statuses-qry (conc " AND " statuses-qry) "") + " FROM tests WHERE run_id=? AND state != 'DELETED' " + states-statuses-qry (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") (case sort-by - ((rundir) " ORDER BY length(rundir) DESC;") - ((event_time) " ORDER BY event_time ASC;") - (else ";")) + ((rundir) " ORDER BY length(rundir) DESC ") + ((event_time) " ORDER BY event_time ASC ") + (else (if (string? sort-by) + (conc " ORDER BY " sort-by) + ""))) + (if limit (conc " LIMIT " limit) "") + (if offset (conc " OFFSET " offset) "") + ";" ))) (debug:print-info 8 "db:get-tests-for-run qry=" qry) (sqlite3:for-each-row (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) @@ -786,20 +908,20 @@ (debug:print-info 11 "db:get-tests-for-run START run-id=" run-id ", testpatt=" testpatt ", states=" states ", statuses=" statuses ", not-in=" not-in ", sort-by=" sort-by) res)) ;; get a useful subset of the tests data (used in dashboard ;; use db:mintests-get-{id ,run_id,testname ...} -(define (db:get-tests-for-runs-mindata db run-ids testpatt states status) - (db:get-tests-for-runs db run-ids testpatt states status qryvals: "id,run_id,testname,state,status,event_time,item_path")) +(define (db:get-tests-for-runs-mindata db run-ids testpatt states status not-in) + (db:get-tests-for-runs db run-ids testpatt states status not-in: not-in qryvals: "id,run_id,testname,state,status,event_time,item_path")) ;; NB // This is get tests for "runs" (note the plural!!) ;; ;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN ;; i.e. these lists define what to NOT show. ;; states and statuses are required to be lists, empty is ok ;; not-in #t = above behaviour, #f = must match -;; run-ids is a list of run-ids or a single number +;; run-ids is a list of run-ids or a single number or #f for all runs (define (db:get-tests-for-runs db run-ids testpatt states statuses #!key (not-in #t) (sort-by #f) (qryvals "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")) ;; 'rundir 'event_time (debug:print-info 11 "db:get-tests-for-run START run-ids=" run-ids ", testpatt=" testpatt ", states=" states ", statuses=" statuses ", not-in=" not-in ", sort-by=" sort-by) @@ -819,15 +941,15 @@ " IN ('" (string-intersperse statuses "','") "')"))) (tests-match-qry (tests:match->sqlqry testpatt)) (qry (conc "SELECT " qryvals - " FROM tests WHERE " + " FROM tests WHERE state != 'DELETED' " (if run-ids (if (list? run-ids) - (conc " run_id in (" (string-intersperse (map conc run-ids) ",") ") ") - (conc "run_id=" run-ids " ")) + (conc "AND run_id IN (" (string-intersperse (map conc run-ids) ",") ") ") + (conc "AND run_id=" run-ids " ")) " ") ;; #f => run-ids don't filter on run-ids (if states-qry (conc " AND " states-qry) "") (if statuses-qry (conc " AND " statuses-qry) "") (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") (case sort-by @@ -875,16 +997,18 @@ (define (db:delete-tests-for-run db run-id) (common:clear-caches) (sqlite3:execute db "DELETE FROM tests WHERE run_id=?;" run-id)) (define (db:delete-old-deleted-test-records db) + (common:clear-caches) (let ((targtime (- (current-seconds)(* 30 24 60 60)))) ;; one month in the past (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED' AND event_timeobj rawdat)) - (vector-ref tmp 2)))) + (if rawdat + (begin + (set! tmp (db:string->obj rawdat)) + (vector-ref tmp 2)) + (begin + (debug:print 0 "ERROR: Communication with the server failed. Exiting if possible") + (exit 1)))))) ((zmq) (handle-exceptions exn (begin (debug:print-info 0 "cdb:client-call timeout or error. Trying again in 5 seconds") @@ -1305,12 +1465,12 @@ (cdb:client-call serverdat 'register-test #t *default-numtries* run-id test-name item-path)) (define (cdb:flush-queue serverdat) (cdb:client-call serverdat 'flush #f *default-numtries*)) -(define (cdb:kill-server serverdat) - (cdb:client-call serverdat 'killserver #t *default-numtries*)) +(define (cdb:kill-server serverdat pid) + (cdb:client-call serverdat 'killserver #t *default-numtries* pid)) (define (cdb:roll-up-pass-fail-counts serverdat run-id test-name item-path status) (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:roll-up-pass-fail-counts #f run-id test-name item-path status)) (define (cdb:get-test-info serverdat run-id test-name item-path) @@ -1361,10 +1521,12 @@ '(delete-tests-in-state "DELETE FROM tests WHERE state=? AND run_id=?;") '(tests:test-set-toplog "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';") '(update-cpuload-diskfree "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;") '(update-run-duration "UPDATE tests SET run_duration=? WHERE id=?;") '(update-uname-host "UPDATE tests SET uname=?,host=? WHERE id=?;") + '(update-test-state "UPDATE tests SET state=? WHERE state=? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));") + '(update-test-status "UPDATE tests SET status=? WHERE status like ? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));") )) ;; do not run these as part of the transaction (define db:special-queries '(rollup-tests-pass-fail db:roll-up-pass-fail-counts @@ -1540,18 +1702,24 @@ (server:reply return-address qry-sig #f (list #f (conc "Login failed due to mismatch paths: " calling-path ", " *toppath*))))))) ((flush sync) (server:reply return-address qry-sig #t 1)) ;; (length data))) ((set-verbosity) (set! *verbosity* (car params)) - (server:reply return-address qry-sig #t '(#t *verbosity*))) + (server:reply return-address qry-sig #t (list #t *verbosity*))) ((killserver) - (debug:print 0 "WARNING: Server going down in 15 seconds by user request!") - (open-run-close tasks:server-deregister tasks:open-db - (car *runremote*) - pullport: (cadr *runremote*)) - (thread-start! (make-thread (lambda ()(thread-sleep! 15)(exit)))) - (server:reply return-address qry-sig #t '(#t "exit process started"))) + (let ((hostname (car *runremote*)) + (port (cadr *runremote*)) + (pid (car params))) + (debug:print 0 "WARNING: Server on " hostname ":" port " going down by user request!") + (debug:print-info 1 "current pid=" (current-process-id)) + (open-run-close tasks:server-deregister tasks:open-db + hostname + port: port) + (set! *server-run* #f) + (thread-sleep! 3) + (process-signal pid signal/kill) + (server:reply return-address qry-sig #t '(#t "exit process started")))) (else ;; not a command, i.e. is a query (debug:print 0 "ERROR: Unrecognised query/command " stmt-key) (server:reply return-address qry-sig #f 'failed))))) (else (debug:print-info 11 "Executing " stmt-key " for " params) @@ -1963,11 +2131,11 @@ (result '())) (for-each (lambda (waitontest-name) ;; by getting the tests with matching name we are looking only at the matching test ;; and related sub items - (let ((tests (cdb:remote-run db:get-tests-for-run #f run-id waitontest-name '() '())) + (let ((tests (mt:get-tests-for-run run-id waitontest-name '() '())) (ever-seen #f) (parent-waiton-met #f) (item-waiton-met #f)) (for-each (lambda (test) @@ -1974,24 +2142,37 @@ ;; (if (equal? waitontest-name (db:test-get-testname test)) ;; by defintion this had better be true ... (let* ((state (db:test-get-state test)) (status (db:test-get-status test)) (item-path (db:test-get-item-path test)) (is-completed (equal? state "COMPLETED")) + (is-killed (equal? state "KILLED")) (is-ok (member status '("PASS" "WARN" "CHECK" "WAIVED" "SKIP"))) (same-itempath (equal? ref-item-path item-path))) (set! ever-seen #t) (cond ;; case 1, non-item (parent test) is ((and (equal? item-path "") ;; this is the parent test is-completed - (or is-ok (eq? mode 'toplevel))) + (or is-ok (member mode '(toplevel itemmatch)))) + (set! parent-waiton-met #t)) + ;; Special case for toplevel and KILLED + ((and (equal? item-path "") ;; this is the parent test + is-killed + (eq? mode 'toplevel)) (set! parent-waiton-met #t)) - ((and same-itempath - is-completed - (or is-ok (eq? mode 'toplevel))) + ((or (and (not same-itempath) + (eq? mode 'itemmatch)) ;; in itemmatch mode we look only at the same itempath + (and same-itempath + is-completed + (or is-ok + (eq? mode 'toplevel) ;; toplevel does not block on FAIL + (and is-ok (eq? mode 'itemmatch)) ;; itemmatch blocks on not ok + ))) (set! item-waiton-met #t))))) tests) + ;; both requirements, parent and item-waiton must be met to NOT add item to + ;; prereq's not met list (if (not (or parent-waiton-met item-waiton-met)) (set! result (append (if (null? tests) (list waitontest-name) tests) result))) ;; if the test is not found then clearly the waiton is not met... ;; (if (not ever-seen)(set! result (cons waitontest-name result))))) (if (not ever-seen) ADDED dcommon.scm Index: dcommon.scm ================================================================== --- /dev/null +++ dcommon.scm @@ -0,0 +1,544 @@ +;;====================================================================== +;; Copyright 2006-2013, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. +;;====================================================================== + +(use format) +(require-library iup) +(import (prefix iup iup:)) +(use canvas-draw) +(use regex) + +(declare (unit dcommon)) + +(declare (uses megatest-version)) +(declare (uses gutils)) +(declare (uses db)) +(declare (uses synchash)) + +(include "common_records.scm") +(include "db_records.scm") +(include "key_records.scm") + +;; yes, this is non-ideal +(define dashboard:update-summary-tab #f) +(define dashboard:update-servers-table #f) + +;;====================================================================== +;; C O M M O N D A T A S T R U C T U R E +;;====================================================================== +;; +;; A single data structure for all the data used in a dashboard. +;; Share this structure between newdashboard and dashboard with the +;; intent of converging on a single app. +;; +(define *data* (make-vector 25 #f)) +(define (dboard:data-get-runs vec) (vector-ref vec 0)) +(define (dboard:data-get-tests vec) (vector-ref vec 1)) +(define (dboard:data-get-runs-matrix vec) (vector-ref vec 2)) +(define (dboard:data-get-tests-tree vec) (vector-ref vec 3)) +(define (dboard:data-get-run-keys vec) (vector-ref vec 4)) +(define (dboard:data-get-curr-test-ids vec) (vector-ref vec 5)) +;; (define (dboard:data-get-test-details vec) (vector-ref vec 6)) +(define (dboard:data-get-path-test-ids vec) (vector-ref vec 7)) +(define (dboard:data-get-updaters vec) (vector-ref vec 8)) +(define (dboard:data-get-path-run-ids vec) (vector-ref vec 9)) +(define (dboard:data-get-curr-run-id vec) (vector-ref vec 10)) +(define (dboard:data-get-runs-tree vec) (vector-ref vec 11)) +;; For test-patts convert #f to "" +(define (dboard:data-get-test-patts vec) + (let ((val (vector-ref vec 12)))(if val val ""))) +(define (dboard:data-get-states vec) (vector-ref vec 13)) +(define (dboard:data-get-statuses vec) (vector-ref vec 14)) +(define (dboard:data-get-logs-textbox vec val)(vector-ref vec 15)) +(define (dboard:data-get-command vec) (vector-ref vec 16)) +(define (dboard:data-get-command-tb vec) (vector-ref vec 17)) +(define (dboard:data-get-target vec) (vector-ref vec 18)) +(define (dboard:data-get-target-string vec) + (let ((targ (dboard:data-get-target vec))) + (if (list? targ)(string-intersperse targ "/") "no-target-specified"))) +(define (dboard:data-get-run-name vec) (vector-ref vec 19)) +(define (dboard:data-get-runs-listbox vec) (vector-ref vec 20)) + +(define (dboard:data-set-runs! vec val)(vector-set! vec 0 val)) +(define (dboard:data-set-tests! vec val)(vector-set! vec 1 val)) +(define (dboard:data-set-runs-matrix! vec val)(vector-set! vec 2 val)) +(define (dboard:data-set-tests-tree! vec val)(vector-set! vec 3 val)) +(define (dboard:data-set-run-keys! vec val)(vector-set! vec 4 val)) +(define (dboard:data-set-curr-test-ids! vec val)(vector-set! vec 5 val)) +;; (define (dboard:data-set-test-details! vec val)(vector-set! vec 6 val)) +(define (dboard:data-set-path-test-ids! vec val)(vector-set! vec 7 val)) +(define (dboard:data-set-updaters! vec val)(vector-set! vec 8 val)) +(define (dboard:data-set-path-run-ids! vec val)(vector-set! vec 9 val)) +(define (dboard:data-set-curr-run-id! vec val)(vector-set! vec 10 val)) +(define (dboard:data-set-runs-tree! vec val)(vector-set! vec 11 val)) +;; For test-patts convert "" to #f +(define (dboard:data-set-test-patts! vec val) + (vector-set! vec 12 (if (equal? val "") #f val))) +(define (dboard:data-set-states! vec val)(vector-set! vec 13 val)) +(define (dboard:data-set-statuses! vec val)(vector-set! vec 14 val)) +(define (dboard:data-set-logs-textbox! vec val)(vector-set! vec 15 val)) +(define (dboard:data-set-command! vec val)(vector-set! vec 16 val)) +(define (dboard:data-set-command-tb! vec val)(vector-set! vec 17 val)) +(define (dboard:data-set-target! vec val)(vector-set! vec 18 val)) +(define (dboard:data-set-run-name! vec val)(vector-set! vec 19 val)) +(define (dboard:data-set-runs-listbox! vec val)(vector-set! vec 20 val)) + +(dboard:data-set-run-keys! *data* (make-hash-table)) + +;; List of test ids being viewed in various panels +(dboard:data-set-curr-test-ids! *data* (make-hash-table)) + +;; Look up test-ids by (key1 key2 ... testname [itempath]) +(dboard:data-set-path-test-ids! *data* (make-hash-table)) + +;; Look up run-ids by ?? +(dboard:data-set-path-run-ids! *data* (make-hash-table)) + +;;====================================================================== +;; TARGET AND PATTERN MANIPULATIONS +;;====================================================================== + +;; Convert to and from list of lines (for a text box) +;; "," => "\n" +(define (dboard:test-patt->lines test-patt) + (string-substitute (regexp ",") "\n" test-patt)) + +(define (dboard:lines->test-patt lines) + (string-substitute (regexp "\n") "," lines #t)) + + +;;====================================================================== +;; P R O C E S S R U N S +;;====================================================================== + +;; MOVE THIS INTO *data* +(define *cachedata* (make-hash-table)) +(hash-table-set! *cachedata* "runid-to-col" (make-hash-table)) +(hash-table-set! *cachedata* "testname-to-row" (make-hash-table)) + +;; TO-DO +;; 1. Make "data" hash-table hierarchial store of all displayed data +;; 2. Update synchash to understand "get-runs", "get-tests" etc. +;; 3. Add extraction of filters to synchash calls +;; +;; Mode is 'full or 'incremental for full refresh or incremental refresh +(define (run-update keys data runname keypatts testpatt states statuses mode window-id) + (let* (;; count and offset => #f so not used + ;; the synchash calls modify the "data" hash + (get-runs-sig (conc (client:get-signature) " get-runs")) + (get-tests-sig (conc (client:get-signature) " get-tests")) + (get-details-sig (conc (client:get-signature) " get-test-details")) + + ;; test-ids to get and display are indexed on window-id in curr-test-ids hash + (test-ids (hash-table-values (dboard:data-get-curr-test-ids *data*))) + + (run-changes (synchash:client-get 'db:get-runs get-runs-sig (length keypatts) data runname #f #f keypatts)) + (tests-detail-changes (if (not (null? test-ids)) + (synchash:client-get 'db:get-test-info-by-ids get-details-sig 0 data test-ids) + '())) + + ;; Now can calculate the run-ids + (run-hash (hash-table-ref/default data get-runs-sig #f)) + (run-ids (if run-hash (filter number? (hash-table-keys run-hash)) '())) + + (test-changes (synchash:client-get 'db:get-tests-for-runs-mindata get-tests-sig 0 data run-ids testpatt states statuses #f)) + (runs-hash (hash-table-ref/default data get-runs-sig #f)) + (header (hash-table-ref/default runs-hash "header" #f)) + (run-ids (sort (filter number? (hash-table-keys runs-hash)) + (lambda (a b) + (let* ((record-a (hash-table-ref runs-hash a)) + (record-b (hash-table-ref runs-hash b)) + (time-a (db:get-value-by-header record-a header "event_time")) + (time-b (db:get-value-by-header record-b header "event_time"))) + (> time-a time-b))) + )) + (runid-to-col (hash-table-ref *cachedata* "runid-to-col")) + (testname-to-row (hash-table-ref *cachedata* "testname-to-row")) + (colnum 1) + (rownum 0)) ;; rownum = 0 is the header +;; (debug:print 0 "test-ids " test-ids ", tests-detail-changes " tests-detail-changes) + + ;; tests related stuff + ;; (all-testnames (delete-duplicates (map db:test-get-testname test-changes)))) + + ;; Given a run-id and testname/item_path calculate a cell R:C + + ;; NOTE: Also build the test tree browser and look up table + ;; + ;; Each run is unique on its keys and runname or run-id, store in hash on colnum + (for-each (lambda (run-id) + (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) + (key-vals (map (lambda (key)(db:get-value-by-header run-record header key)) + keys)) + (run-name (db:get-value-by-header run-record header "runname")) + (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) + (run-path (append key-vals (list run-name)))) + (hash-table-set! (dboard:data-get-run-keys *data*) run-id run-path) + (iup:attribute-set! (dboard:data-get-runs-matrix *data*) + (conc rownum ":" colnum) col-name) + (hash-table-set! runid-to-col run-id (list colnum run-record)) + ;; Here we update the tests treebox and tree keys + (tree:add-node (dboard:data-get-tests-tree *data*) "Runs" (append key-vals (list run-name)) + userdata: (conc "run-id: " run-id)) + (set! colnum (+ colnum 1)))) + run-ids) + + ;; Scan all tests to be displayed and organise all the test names, respecting what is in the hash table + ;; Do this analysis in the order of the run-ids, the most recent run wins + (for-each (lambda (run-id) + (let* ((run-path (hash-table-ref (dboard:data-get-run-keys *data*) run-id)) + (new-test-dat (car test-changes)) + (removed-tests (cadr test-changes)) + (tests (sort (map cadr (filter (lambda (testrec) + (eq? run-id (db:mintest-get-run_id (cadr testrec)))) + new-test-dat)) + (lambda (a b) + (let ((time-a (db:mintest-get-event_time a)) + (time-b (db:mintest-get-event_time b))) + (> time-a time-b))))) + ;; test-changes is a list of (( id record ) ... ) + ;; Get list of test names sorted by time, remove tests + (test-names (delete-duplicates (map (lambda (t) + (let ((i (db:mintest-get-item_path t)) + (n (db:mintest-get-testname t))) + (if (string=? i "") + (conc " " i) + n))) + tests))) + (colnum (car (hash-table-ref runid-to-col run-id)))) + ;; for each test name get the slot if it exists and fill in the cell + ;; or take the next slot and fill in the cell, deal with items in the + ;; run view panel? The run view panel can have a tree selector for + ;; browsing the tests/items + + ;; SWITCH THIS TO USING CHANGED TESTS ONLY + (for-each (lambda (test) + (let* ((test-id (db:mintest-get-id test)) + (state (db:mintest-get-state test)) + (status (db:mintest-get-status test)) + (testname (db:mintest-get-testname test)) + (itempath (db:mintest-get-item_path test)) + (fullname (conc testname "/" itempath)) + (dispname (if (string=? itempath "") testname (conc " " itempath))) + (rownum (hash-table-ref/default testname-to-row fullname #f)) + (test-path (append run-path (if (equal? itempath "") + (list testname) + (list testname itempath))))) + (tree:add-node (dboard:data-get-tests-tree *data*) "Runs" + test-path + userdata: (conc "test-id: " test-id)) + (hash-table-set! (dboard:data-get-path-test-ids *data*) test-path test-id) + (if (not rownum) + (let ((rownums (hash-table-values testname-to-row))) + (set! rownum (if (null? rownums) + 1 + (+ 1 (apply max rownums)))) + (hash-table-set! testname-to-row fullname rownum) + ;; create the label + (iup:attribute-set! (dboard:data-get-runs-matrix *data*) + (conc rownum ":" 0) dispname) + )) + ;; set the cell text and color + ;; (debug:print 2 "rownum:colnum=" rownum ":" colnum ", state=" status) + (iup:attribute-set! (dboard:data-get-runs-matrix *data*) + (conc rownum ":" colnum) + (if (string=? state "COMPLETED") + status + state)) + (iup:attribute-set! (dboard:data-get-runs-matrix *data*) + (conc "BGCOLOR" rownum ":" colnum) + (car (gutils:get-color-for-state-status state status))) + )) + tests))) + run-ids) + + (let ((updater (hash-table-ref/default (dboard:data-get-updaters *data*) window-id #f))) + (if updater (updater (hash-table-ref/default data get-details-sig #f)))) + + (iup:attribute-set! (dboard:data-get-runs-matrix *data*) "REDRAW" "ALL") + ;; (debug:print 2 "run-changes: " run-changes) + ;; (debug:print 2 "test-changes: " test-changes) + (list run-changes test-changes))) + +;;====================================================================== +;; TESTS DATA +;;====================================================================== + +;; Produce a list of lists ready for common:sparse-list-generate-index +;; +(define (dcommon:minimize-test-data tests-dat) + (if (null? tests-dat) + '() + (let loop ((hed (car tests-dat)) + (tal (cdr tests-dat)) + (res '())) + (let* ((test-id (vector-ref hed 0)) ;; look at the tests-dat spec for locations + (test-name (vector-ref hed 1)) + (item-path (vector-ref hed 2)) + (state (vector-ref hed 3)) + (status (vector-ref hed 4)) + (newitem (list test-name item-path (list test-id state status)))) + (if (null? tal) + (reverse (cons newitem res)) + (loop (car tal)(cdr tal)(cons newitem res))))))) + + +;;====================================================================== +;; D A T A T A B L E S +;;====================================================================== + +;; Table of keys +(define (dcommon:keys-matrix rawconfig) + (let* ((curr-row-num 1) + (key-vals (configf:section-vars rawconfig "fields")) + (keys-matrix (iup:matrix + #:alignment1 "ALEFT" + #:expand "YES" ;; "HORIZONTAL" ;; "VERTICAL" + ;; #:scrollbar "YES" + #:numcol 1 + #:numlin (length key-vals) + #:numcol-visible 1 + #:numlin-visible (length key-vals) + #:click-cb (lambda (obj lin col status) + (print "obj: " obj " lin: " lin " col: " col " status: " status))))) + ;; (iup:attribute-set! keys-matrix "0:0" "Run Keys") + (iup:attribute-set! keys-matrix "WIDTH0" 0) + (iup:attribute-set! keys-matrix "0:1" "Key Name") + ;; (iup:attribute-set! keys-matrix "WIDTH1" "100") + ;; fill in keys + (for-each + (lambda (var) + ;; (iup:attribute-set! keys-matrix "ADDLIN" (conc curr-row-num)) + (iup:attribute-set! keys-matrix (conc curr-row-num ":0") curr-row-num) + (iup:attribute-set! keys-matrix (conc curr-row-num ":1") var) + (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup *configdat* "fields" var))) + key-vals) + (iup:attribute-set! keys-matrix "WIDTHDEF" "40") + keys-matrix)) + +;; Section to table +(define (dcommon:section-matrix rawconfig sectionname varcolname valcolname #!key (title #f)) + (let* ((curr-row-num 1) + (key-vals (configf:section-vars rawconfig sectionname)) + (section-matrix (iup:matrix + #:alignment1 "ALEFT" + #:expand "YES" ;; "HORIZONTAL" + #:numcol 1 + #:numlin (length key-vals) + #:numcol-visible 1 + #:numlin-visible (length key-vals) + #:scrollbar "YES"))) + (iup:attribute-set! section-matrix "0:0" varcolname) + (iup:attribute-set! section-matrix "0:1" valcolname) + (iup:attribute-set! section-matrix "WIDTH1" "200") + ;; fill in keys + (for-each + (lambda (var) + ;; (iup:attribute-set! keys-matrix "ADDLIN" (conc curr-row-num)) + (iup:attribute-set! section-matrix (conc curr-row-num ":0") var) + (iup:attribute-set! section-matrix (conc curr-row-num ":1") (configf:lookup rawconfig sectionname var)) + (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup *configdat* "fields" var))) + key-vals) + (iup:vbox + (iup:label (if title title (conc "Settings from [" sectionname "]")) + #:size "5x" + #:expand "HORIZONTAL" + ) + section-matrix))) + +;; General data +;; +(define (dcommon:general-info) + (let ((general-matrix (iup:matrix + #:alignment1 "ALEFT" + #:expand "YES" ;; "HORIZONTAL" + #:numcol 1 + #:numlin 3 + #:numcol-visible 1 + #:numlin-visible 3))) + (iup:attribute-set! general-matrix "WIDTH1" "200") + (iup:attribute-set! general-matrix "0:1" "About this Megatest area") + ;; User (this is not always obvious - it is common to run as a different user + (iup:attribute-set! general-matrix "1:0" "User") + (iup:attribute-set! general-matrix "1:1" (current-user-name)) + ;; Megatest area + (iup:attribute-set! general-matrix "2:0" "Area") + (iup:attribute-set! general-matrix "2:1" *toppath*) + ;; Megatest version + (iup:attribute-set! general-matrix "3:0" "Version") + (iup:attribute-set! general-matrix "3:1" megatest-version) + + general-matrix)) + +(define (dcommon:run-stats) + (let* ((stats-matrix (iup:matrix expand: "YES")) + (changed #f) + (updater (lambda () + (let* ((run-stats (mt:get-run-stats)) + (indices (common:sparse-list-generate-index run-stats)) ;; proc: set-cell)) + (row-indices (car indices)) + (col-indices (cadr indices)) + (max-row (if (null? row-indices) 1 (apply max (map cadr row-indices)))) + (max-col (if (null? col-indices) 1 (apply max (map cadr col-indices)))) + (max-visible (max (- *num-tests* 15) 3)) + (numrows 1) + (numcols 1)) + (iup:attribute-set! stats-matrix "CLEARVALUE" "CONTENTS") + (iup:attribute-set! stats-matrix "NUMCOL" max-col ) + (iup:attribute-set! stats-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)) ;; min of 20 + (iup:attribute-set! stats-matrix "NUMCOL_VISIBLE" max-col) + (iup:attribute-set! stats-matrix "NUMLIN_VISIBLE" (if (> max-row max-visible) max-visible max-row)) + + ;; Row labels + (for-each (lambda (ind) + (let* ((name (car ind)) + (num (cadr ind)) + (key (conc num ":0"))) + (if (not (equal? (iup:attribute stats-matrix key) name)) + (begin + (set! changed #t) + (iup:attribute-set! stats-matrix key name))))) + row-indices) + + ;; Col labels + (for-each (lambda (ind) + (let* ((name (car ind)) + (num (cadr ind)) + (key (conc "0:" num))) + (if (not (equal? (iup:attribute stats-matrix key) name)) + (begin + (set! changed #t) + (iup:attribute-set! stats-matrix key name))))) + col-indices) + + ;; Cell contents + (for-each (lambda (entry) + (let* ((row-name (car entry)) + (col-name (cadr entry)) + (value (caddr entry)) + (row-num (cadr (assoc row-name row-indices))) + (col-num (cadr (assoc col-name col-indices))) + (key (conc row-num ":" col-num))) + (if (not (equal? (iup:attribute stats-matrix key) value)) + (begin + (set! changed #t) + (iup:attribute-set! stats-matrix key value))))) + run-stats) + (if changed (iup:attribute-set! stats-matrix "REDRAW" "ALL")))))) + (updater) + (set! dashboard:update-summary-tab updater) + (iup:attribute-set! stats-matrix "WIDTHDEF" "40") + (iup:vbox + (iup:label "Run statistics" #:expand "HORIZONTAL") + stats-matrix))) + +(define (dcommon:servers-table) + (let* ((colnum 0) + (rownum 0) + (servers-matrix (iup:matrix #:expand "YES" + #:numcol 7 + #:numcol-visible 7 + #:numlin-visible 3 + )) + (colnames (list "Id" "MTver" "Pid" "Host" "Interface:OutPort" "InPort" "State" "Transport")) + (updater (lambda () + (let ((servers (open-run-close tasks:get-all-servers tasks:open-db))) + (iup:attribute-set! servers-matrix "NUMLIN" (length servers)) + ;; (set! colnum 0) + ;; (for-each (lambda (colname) + ;; ;; (print "colnum: " colnum " colname: " colname) + ;; (iup:attribute-set! servers-matrix (conc "0:" colnum) colname) + ;; (set! colnum (+ 1 colnum))) + ;; colnames) + (set! rownum 1) + (for-each + (lambda (server) + (set! colnum 0) + (let* ((vals (list (vector-ref server 0) ;; Id + (vector-ref server 9) ;; MT-Ver + (vector-ref server 1) ;; Pid + (vector-ref server 2) ;; Hostname + (conc (vector-ref server 3) ":" (vector-ref server 4)) ;; IP:Port + (vector-ref server 5) ;; Pubport + ;; (vector-ref server 10) ;; Last beat + ;; (vector-ref server 6) ;; Start time + ;; (vector-ref server 7) ;; Priority + ;; (vector-ref server 8) ;; State + (if (< (vector-ref server 10) 20) ;; Status (Please redo this properly!) + "alive" + "dead") + (vector-ref server 11) ;; Transport + ))) + (for-each (lambda (val) + ;; (print "rownum: " rownum " colnum: " colnum " val: " val) + (iup:attribute-set! servers-matrix (conc rownum ":" colnum) val) + (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum)) + (set! colnum (+ 1 colnum))) + vals) + (set! rownum (+ rownum 1))) + (iup:attribute-set! servers-matrix "REDRAW" "ALL")) + servers))))) + (set! colnum 0) + (for-each (lambda (colname) + (iup:attribute-set! servers-matrix (conc "0:" colnum) colname) + (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum)) + (set! colnum (+ colnum 1))) + colnames) + (set! dashboard:update-servers-table updater) + ;; (iup:attribute-set! servers-matrix "WIDTHDEF" "40") + (iup:hbox + (iup:vbox + (iup:button "Start" + ;; #:size "50x" + #:expand "YES" + #:action (lambda (obj) + (let ((cmd (conc ;; "xterm -geometry 180x20 -e \"" + "megatest -server - &"))) + ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) + (system cmd)))) + (iup:button "Stop" + #:expand "YES" + ;; #:size "50x" + #:action (lambda (obj) + (let ((cmd (conc ;; "xterm -geometry 180x20 -e \"" + "megatest -stop-server 0 &"))) + ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) + (system cmd)))) + (iup:button "Restart" + #:expand "YES" + ;; #:size "50x" + #:action (lambda (obj) + (let ((cmd (conc ;; "xterm -geometry 180x20 -e \"" + "megatest -stop-server 0;megatest -server - &"))) + ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) + (system cmd))))) + servers-matrix + ))) + +;; The main menu +(define (dcommon:main-menu) + (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top) + (iup:menu-item "Files" (iup:menu ;; Note that you can use either #:action or action: for options + (iup:menu-item "Open" action: (lambda (obj) + (iup:show (iup:file-dialog)) + (print "File->open " obj))) + (iup:menu-item "Save" #:action (lambda (obj)(print "File->save " obj))) + (iup:menu-item "Exit" #:action (lambda (obj)(exit))))) + (iup:menu-item "Tools" (iup:menu + (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah"))) + ;; (iup:menu-item "Show dialog" #:action (lambda (obj) + ;; (show message-window + ;; #:modal? #t + ;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current + ;; ;; #:x 'mouse + ;; ;; #:y 'mouse + ;; ) + )))) + ADDED docs/dashboard-summary-tab.png Index: docs/dashboard-summary-tab.png ================================================================== --- /dev/null +++ docs/dashboard-summary-tab.png cannot compute difference between binary files Index: docs/manual/megatest_manual.txt ================================================================== --- docs/manual/megatest_manual.txt +++ docs/manual/megatest_manual.txt @@ -3,27 +3,10 @@ Matt Welland v1.0, April 2012 :doctype: book -[dedication] -Dedication -========== - -Dedicated to my wife Joanna who has kindly supported my working on various projects over the years. - -Thanks ------- - -Thank you the many people I've worked over the years who have -shared their knowledge and insights with me. - -Thanks also to the creators of the various open source projects that -Megatest is built on. These include Linux, xemacs, chicken scheme, -fossil and asciidoc. Without these projects something like Megatest -would be difficult or impossible to do. - [preface] Preface ======= This book is organised as three sub-books; getting started, writing tests and reference. Index: gutils.scm ================================================================== --- gutils.scm +++ gutils.scm @@ -20,23 +20,29 @@ (let* ((c1 (map string->number (string-split color1))) (c2 (map string->number (string-split color2))) (delta (map (lambda (a b)(abs (- a b))) c1 c2))) (null? (filter (lambda (x)(> x 3)) delta)))) -(define (gutils:get-color-for-state-status state status) - (case (string->symbol state) - ((COMPLETED) - (if (equal? status "PASS") - "70 249 73" - (if (or (equal? status "WARN") - (equal? status "WAIVED")) - "255 172 13" - "223 33 49"))) ;; greenish orangeish redish - ((LAUNCHED) "101 123 142") - ((CHECK) "255 100 50") - ((REMOTEHOSTSTART) "50 130 195") - ((RUNNING) "9 131 232") - ((KILLREQ) "39 82 206") - ((KILLED) "234 101 17") - ((NOT_STARTED) "240 240 240") - (else "192 192 192"))) +(define (gutils:get-color-for-state-status state status);; #!key (get-label #f)) + ;; ((if get-label cadr car) + (case (string->symbol state) + ((COMPLETED) + (case (string->symbol status) + ((PASS) (list "70 249 73" status)) + ((WARN WAIVED) (list "255 172 13" status)) + ((SKIP) (list "230 230 0" status)) + (else (list "223 33 49" status)))) + ;; (if (equal? status "PASS") + ;; '("70 249 73" "PASS") + ;; (if (or (equal? status "WARN") + ;; (equal? status "WAIVED")) + ;; (list "255 172 13" status) + ;; (list "223 33 49" status)))) ;; greenish orangeish redish + ((LAUNCHED) (list "101 123 142" state)) + ((CHECK) (list "255 100 50" state)) + ((REMOTEHOSTSTART) (list "50 130 195" state)) + ((RUNNING) (list "9 131 232" state)) + ((KILLREQ) (list "39 82 206" state)) + ((KILLED) (list "234 101 17" state)) + ((NOT_STARTED) (list "240 240 240" state)) + (else (list "192 192 192" state)))) Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -11,13 +11,15 @@ (require-extension (srfi 18) extras tcp s11n) (use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest) (import (prefix sqlite3 sqlite3:)) -(use spiffy uri-common intarweb http-client spiffy-request-vars) +(use spiffy uri-common intarweb http-client spiffy-request-vars uri-common intarweb spiffy-directory-listing) +;; Configurations for server (tcp-buffer-size 2048) +(max-connections 2048) (declare (unit http-transport)) (declare (uses common)) (declare (uses db)) @@ -32,11 +34,11 @@ (define (http-transport:make-server-url hostport) (if (not hostport) #f (conc "http://" (car hostport) ":" (cadr hostport)))) -(define *server-loop-heart-beat* (current-seconds)) +(define *server-loop-heart-beat* (current-seconds)) (define *heartbeat-mutex* (make-mutex)) ;;====================================================================== ;; S E R V E R ;;====================================================================== @@ -85,24 +87,21 @@ (link-tree-path (config-lookup *configdat* "setup" "linktree"))) (set! *cache-on* #t) (root-path (if link-tree-path link-tree-path (current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP! - + (handle-directory spiffy-directory-listing) + ;; http-transport:handle-directory) ;; simple-directory-handler) ;; Setup the web server and a /ctrl interface ;; (vhost-map `(((* any) . ,(lambda (continue) ;; open the db on the first call (if (not db)(set! db (open-db))) (let* (($ (request-vars source: 'both)) (dat ($ 'dat)) (res #f)) (cond - ((equal? (uri-path (request-uri (current-request))) - '(/ "hey")) - (send-response body: "hey there!\n" - headers: '((content-type text/plain)))) ;; This is the /ctrl path where data is handed to the server and ;; responses ((equal? (uri-path (request-uri (current-request))) '(/ "ctrl")) (let* ((packet (db:string->obj dat)) @@ -120,10 +119,24 @@ (debug:print-info 11 "Return value from db:process-queue-item is " res) (send-response body: (conc "ctrl data\n" res "") headers: '((content-type text/plain))))) + ((equal? (uri-path (request-uri (current-request))) + '(/ "")) + (send-response body: (http-transport:main-page))) + ((equal? (uri-path (request-uri (current-request))) + '(/ "runs")) + (send-response body: (http-transport:main-page))) + ((equal? (uri-path (request-uri (current-request))) + '(/ any)) + (send-response body: "hey there!\n" + headers: '((content-type text/plain)))) + ((equal? (uri-path (request-uri (current-request))) + '(/ "hey")) + (send-response body: "hey there!\n" + headers: '((content-type text/plain)))) (else (continue)))))))) (http-transport:try-start-server ipaddrstr start-port))) ;; This is recursively run by http-transport:run until sucessful ;; @@ -144,76 +157,106 @@ (set! *runremote* (list ipaddrstr portnum)) ;; (open-run-close tasks:remove-server-records tasks:open-db) (open-run-close tasks:server-register tasks:open-db (current-process-id) - ipaddrstr portnum 0 'live 'http) - (print "INFO: Trying to start server on " ipaddrstr ":" portnum) + ipaddrstr portnum 0 'startup 'http) + (debug:print 1 "INFO: Trying to start server on " ipaddrstr ":" portnum) ;; This starts the spiffy server ;; NEED WAY TO SET IP TO #f TO BIND ALL (start-server bind-address: ipaddrstr port: portnum) (open-run-close tasks:server-delete tasks:open-db ipaddrstr portnum) - (print "INFO: server has been stopped"))) + (debug:print 1 "INFO: server has been stopped"))) ;;====================================================================== ;; S E R V E R U T I L I T I E S ;;====================================================================== ;;====================================================================== ;; C L I E N T S ;;====================================================================== +(define *http-mutex* (make-mutex)) + +;; (system "megatest -list-servers | grep alive || megatest -server - -daemonize && sleep 4") + ;; ;; ;; 1 Hello, world! Goodbye Dolly ;; Send msg to serverdat and receive result -(define (http-transport:client-send-receive serverdat msg) - (let* ((url (http-transport:make-server-url serverdat)) - (fullurl (conc url "/ctrl")) ;; (conc url "/?dat=" msg))) - (numretries 0)) +(define (http-transport:client-send-receive serverdat msg #!key (numretries 30)) + (let* (;; (url (http-transport:make-server-url serverdat)) + (fullurl (caddr serverdat)) ;; (conc url "/ctrl")) ;; (conc url "/?dat=" msg))) + (res #f)) (handle-exceptions exn - (if (< numretries 200) - (http-transport:client-send-receive serverdat msg)) + (begin + (print "ERROR IN http-transport:client-send-receive " ((condition-property-accessor 'exn 'message) exn)) + (thread-sleep! 2) + (if (> numretries 0) + (http-transport:client-send-receive serverdat msg numretries: (- numretries 1)))) (begin (debug:print-info 11 "fullurl=" fullurl "\n") ;; set up the http-client here - (max-retry-attempts 100) + (max-retry-attempts 5) + ;; consider all requests indempotent (retry-request? (lambda (request) - (thread-sleep! (/ (if (> numretries 100) 100 numretries) 10)) - (set! numretries (+ numretries 1)) - #t)) + #t)) ;; (thread-sleep! (/ (if (> numretries 100) 100 numretries) 10)) + ;; (set! numretries (- numretries 1)) + ;; #t)) ;; send the data and get the response ;; extract the needed info from the http data and ;; process and return it. - (let* ((res (with-input-from-request fullurl - ;; #f - ;; msg - (list (cons 'dat msg)) - read-string))) + (let* ((send-recieve (lambda () + (mutex-lock! *http-mutex*) + (set! res (with-input-from-request + fullurl + (list (cons 'dat msg)) + read-string)) + (close-all-connections!) + (mutex-unlock! *http-mutex*))) + (time-out (lambda () + (thread-sleep! 45) + (if (not res) + (begin + (debug:print 0 "WARNING: communication with the server timed out.") + (mutex-unlock! *http-mutex*) + (http-transport:client-send-receive serverdat msg numretries: (- numretries 1)) + (if (< numretries 3) ;; on last try just exit + (begin + (debug:print 0 "ERROR: communication with the server timed out. Giving up.") + (exit 1))))))) + (th1 (make-thread send-recieve "with-input-from-request")) + (th2 (make-thread time-out "time out"))) + (thread-start! th1) + (thread-start! th2) + (thread-join! th1) + (thread-terminate! th2) (debug:print-info 11 "got res=" res) (let ((match (string-search (regexp "(.*)<.body>") res))) (debug:print-info 11 "match=" match) (let ((final (cadr match))) (debug:print-info 11 "final=" final) final))))))) (define (http-transport:client-connect iface port) (let* ((login-res #f) - (serverdat (list iface port))) + (uri-dat (make-request method: 'POST uri: (uri-reference (conc "http://" iface ":" port "/ctrl")))) + (serverdat (list iface port uri-dat))) (set! login-res (client:login serverdat)) (if (and (not (null? login-res)) (car login-res)) (begin (debug:print-info 2 "Logged in and connected to " iface ":" port) (set! *runremote* serverdat) serverdat) (begin - (debug:print-info 0 "Failed to login or connect to " iface ":" port) - (set! *runremote* #f) - (set! *transport-type* 'fs) - #f)))) + (debug:print-info 0 "ERROR: Failed to login or connect to " iface ":" port) + (exit 1))))) +;; (set! *runremote* #f) +;; (set! *transport-type* 'fs) +;; #f)))) ;; run http-transport:keep-running in a parallel thread to monitor that the db is being ;; used and to shutdown after sometime if it is not. ;; @@ -224,11 +267,12 @@ (let* ((server-info (let loop () (let ((sdat #f)) (mutex-lock! *heartbeat-mutex*) (set! sdat *runremote*) (mutex-unlock! *heartbeat-mutex*) - (if sdat sdat + (if sdat + sdat (begin (sleep 4) (loop)))))) (iface (car server-info)) (port (cadr server-info)) @@ -271,14 +315,15 @@ ;; (if ;; (or (> numrunning 0) ;; stay alive for two days after last access (mutex-lock! *heartbeat-mutex*) (set! last-access *last-db-access*) (mutex-unlock! *heartbeat-mutex*) ;; (debug:print 11 "last-access=" last-access ", server-timeout=" server-timeout) - (if (> (+ last-access server-timeout) - (current-seconds)) + (if (and *server-run* + (> (+ last-access server-timeout) + (current-seconds))) (begin - (debug:print-info 2 "Server continuing, seconds since last db access: " (- (current-seconds) last-access)) + (debug:print-info 0 "Server continuing, seconds since last db access: " (- (current-seconds) last-access)) (loop 0)) (begin (debug:print-info 0 "Starting to shutdown the server.") ;; need to delete only *my* server entry (future use) (set! *time-to-exit* #t) @@ -366,5 +411,64 @@ (exit 4)) "exit on ^C timer"))) (thread-start! th2) (thread-start! th1) (thread-join! th2)))) + +;;====================================================================== +;; web pages +;;====================================================================== + +(define (http-transport:main-page) + (let ((linkpath (root-path))) + (conc "

" (pathname-strip-directory *toppath*) "

" + "" + "Run area: " *toppath* + "

Server Stats

" + (http-transport:stats-table) + "
" + (http-transport:runs linkpath) + "
" + (http-transport:run-stats) + "" + ))) + +(define (http-transport:stats-table) + (mutex-lock! *heartbeat-mutex*) + (let ((res + (conc "" + "" + "" + "" + "" + "" + "" + "
Max cached queries " *max-cache-size* "
Number of cached writes " *number-of-writes* "
Average cached write time " (if (eq? *number-of-writes* 0) + "n/a (no writes)" + (/ *writes-total-delay* + *number-of-writes*)) + " ms
Number non-cached queries " *number-non-write-queries* "
Average non-cached time " (if (eq? *number-non-write-queries* 0) + "n/a (no queries)" + (/ *total-non-write-delay* + *number-non-write-queries*)) + " ms
Last access" (seconds->time-string *last-db-access*) "
"))) + (mutex-unlock! *heartbeat-mutex*) + res)) + +(define (http-transport:runs linkpath) + (conc "

Runs

" + (string-intersperse + (let ((files (map pathname-strip-directory (glob (conc linkpath "/*"))))) + (map (lambda (p) + (conc "" p "
")) + files)) + " "))) + +(define (http-transport:run-stats) + (let ((stats (open-run-close db:get-running-stats #f))) + (conc "" + (string-intersperse + (map (lambda (stat) + (conc "")) + stats) + " ") + "
" (car stat) "" (cadr stat) "
"))) Index: key_records.scm ================================================================== --- key_records.scm +++ key_records.scm @@ -7,19 +7,15 @@ ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== -(define-inline (key:get-fieldname key)(vector-ref key 0)) -(define-inline (key:get-fieldtype key)(vector-ref key 1)) - (define-inline (keys->valslots keys) ;; => ?,?,? .... (string-intersperse (map (lambda (x) "?") keys) ",")) (define-inline (keys->key/field keys . additional) - (string-join (map (lambda (k)(conc (key:get-fieldname k) " " - (key:get-fieldtype k))) + (string-join (map (lambda (k)(conc k " TEXT")) (append keys additional)) ",")) (define-inline (item-list->path itemdat) (if (list? itemdat) (string-intersperse (map cadr itemdat) "/") Index: keys.scm ================================================================== --- keys.scm +++ keys.scm @@ -19,103 +19,52 @@ (declare (uses common)) (include "key_records.scm") (include "common_records.scm") -(define (get-keys db) - (let ((keys '())) ;; keys are vectors - (sqlite3:for-each-row (lambda (fieldname fieldtype) - (set! keys (cons (vector fieldname fieldtype) keys))) - db - "SELECT fieldname,fieldtype FROM keys ORDER BY id ASC;") - (reverse keys))) ;; could just sort desc? - (define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ... - (string-intersperse (map key:get-fieldname keys) ",")) + (string-intersperse keys ",")) (define (args:usage . a) #f) -;; keys->vallist is called several times (quite unnecessarily), use this hash to suppress multiple -;; reporting of missing keys on the command line. -(define keys:warning-suppress-hash (make-hash-table)) - ;;====================================================================== ;; key <=> target routines ;;====================================================================== -;; this now invalidates using "/" in item names +;; This invalidates using "/" in item names. Every key will be +;; available via args:get-arg as :keyfield. Since this only needs to +;; be called once let's use it to set the environment vars +;; +;; The setting of :keyfield in args should be turned off ASAP +;; (define (keys:target-set-args keys target ht) (let ((vals (string-split target "/"))) (if (eq? (length vals)(length keys)) (for-each (lambda (key val) - (hash-table-set! ht (conc ":" (vector-ref key 0)) val)) + (setenv key val) + (hash-table-set! ht (conc ":" key) val)) keys vals) (debug:print 0 "ERROR: wrong number of values in " target ", should match " keys)) vals)) -;; given the keys (a list of vectors ) and a target return a keyval list +;; given the keys (a list of vectors or a list of keys) and a target return a keyval list ;; keyval list ( (key1 val1) (key2 val2) ...) (define (keys:target->keyval keys target) (let* ((targlist (string-split target "/")) (numkeys (length keys)) (numtarg (length targlist)) (targtweaked (if (> numkeys numtarg) (append targlist (make-list (- numkeys numtarg) "")) targlist))) (map (lambda (key targ) - (list (vector-ref key 0) targ)) - keys targtweaked))) - - -;;====================================================================== -;; key <=> args routines -;;====================================================================== - -;; Using the keys pulled from the database (initially set from the megatest.config file) -;; look for the equivalent value on the command line and add it to a list, or #f if not found. -;; default => (val1 val2 val3 ...) -;; withkey => (:key1 val1 :key2 val2 :key3 val3 ...) -(define (keys->vallist keys . withkey) ;; ORDERING IS VERY IMPORTANT, KEEP PROPER ORDER HERE! - (let* ((keynames (map key:get-fieldname keys)) - (argkeys (map (lambda (k)(conc ":" k)) keynames)) - (withkey (not (null? withkey))) - (newremargs (args:get-args - (cons "blah" remargs) ;; the cons blah works around a bug in args [args assumes ("calling-prog-name" .... ) ] - argkeys - '() - args:arg-hash - 0))) - ;;(debug:print 0 "remargs: " remargs " newremargs: " newremargs) - (apply append (map (lambda (x) - (let ((val (args:get-arg x))) - ;; (debug:print 0 "x: " x " val: " val) - (if (not val) - (begin - (if (not (hash-table-ref/default keys:warning-suppress-hash x #f)) - (begin - (debug:print 0 "WARNING: missing key " x ". Specified in database but not on command line, using \"unk\"") - (hash-table-set! keys:warning-suppress-hash x #t))) - (set! val "default"))) - (if withkey (list x val) (list val)))) - argkeys)))) - -;; Given a list of keys (list of vectors) return an alist ((key argval) ...) -(define (keys->alist keys defaultval) - (let* ((keynames (map key:get-fieldname keys)) - (newremargs (args:get-args (cons "blah" remargs) (map (lambda (k)(conc ":" k)) keynames) '() args:arg-hash 0))) ;; the cons blah works around a bug in args - (map (lambda (key) - (let ((val (args:get-arg (conc ":" key)))) - (list key (if val val defaultval)))) - keynames))) - -(define (keystring->keys keystring) - (map (lambda (x) - (let ((xlst (string-split x ":"))) - (list->vector (if (> (length xlst) 1) xlst (append (car xlst)(list "TEXT")))))) - (delete-duplicates (string-split keystring ",")))) - -(define (config-get-fields confdat) - (let ((fields (hash-table-ref/default confdat "fields" '()))) - (map (lambda (x)(vector (car x)(cadr x))) - fields))) + (list key targ)) + keys targtweaked))) + +;;====================================================================== +;; config file related routines +;;====================================================================== + +(define (keys:config-get-fields confdat) + (let ((fields (hash-table-ref/default confdat "fields" '()))) + (map car fields))) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -71,10 +71,11 @@ (itemdat (assoc/default 'itemdat cmdinfo)) (env-ovrd (assoc/default 'env-ovrd cmdinfo)) (set-vars (assoc/default 'set-vars cmdinfo)) ;; pre-overrides from -setvar (runname (assoc/default 'runname cmdinfo)) (megatest (assoc/default 'megatest cmdinfo)) + (runtlim (assoc/default 'runtlim cmdinfo)) (mt-bindir-path (assoc/default 'mt-bindir-path cmdinfo)) (keys #f) (keyvals #f) (fullrunscript (if (not runscript) #f @@ -91,11 +92,11 @@ ;; Setup the *runremote* global var (if *runremote* (debug:print 2 "ERROR: I'm not expecting *runremote* to be set at this time")) ;; (set! *runremote* runremote) (set! *transport-type* (string->symbol transport)) (set! keys (cdb:remote-run db:get-keys #f)) - (set! keyvals (if run-id (cdb:remote-run db:get-key-vals #f run-id) #f)) + (set! keyvals (keys:target->keyval keys target)) ;; apply pre-overrides before other variables. The pre-override vars must not ;; clobbers things from the official sources such as megatest.config and runconfigs.config (if (string? set-vars) (let ((varpairs (string-split set-vars ","))) (debug:print 4 "varpairs: " varpairs) @@ -126,11 +127,11 @@ (change-directory *toppath*) (set-megatest-env-vars run-id) ;; these may be needed by the launching process (change-directory work-area) - (set-run-config-vars run-id keys keyvals target) ;; (db:get-target db run-id)) + (set-run-config-vars run-id keyvals target) ;; (db:get-target db run-id)) ;; environment overrides are done *before* the remaining critical envars. (alist->env-vars env-ovrd) (set-megatest-env-vars run-id) (set-item-env-vars itemdat) (save-environment-as-files "megatest") @@ -274,33 +275,41 @@ (current-seconds) start-seconds))))) (kill-tries 0)) (let loop ((minutes (calc-minutes))) (begin - (set! kill-job? (test-get-kill-request test-id)) ;; run-id test-name itemdat)) + (set! kill-job? (or (test-get-kill-request test-id) ;; run-id test-name itemdat)) + (and runtlim (let* ((run-seconds (- (current-seconds) start-seconds)) + (time-exceeded (> run-seconds runtlim))) + (if time-exceeded + (begin + (debug:print-info 0 "KILLING TEST DUE TO TIME LIMIT EXCEEDED! Runtime=" run-seconds " seconds, limit=" runtlim) + #t) + #f))))) ;; open-run-close not needed for test-set-meta-info (tests:set-meta-info #f test-id run-id test-name itemdat minutes work-area) (if kill-job? (begin (mutex-lock! m) (let* ((pid (vector-ref exit-info 0))) (if (number? pid) - (begin - (debug:print 0 "WARNING: Request received to kill job (attempt # " kill-tries ")") - (let ((processes (cmd-run->list (conc "pgrep -l -P " pid)))) - (for-each - (lambda (p) - (let* ((parts (string-split p)) - (p-id (if (> (length parts) 0) - (string->number (car parts)) - #f))) - (if p-id - (begin - (debug:print 0 "Killing " (cadr parts) "; kill -9 " p-id) - (system (conc "kill -9 " p-id)))))) - (car processes)) - (system (conc "kill -9 -" pid)))) + (process-signal pid signal/kill) + ;; (begin + ;; (debug:print 0 "WARNING: Request received to kill job (attempt # " kill-tries ")") + ;; (let ((processes (cmd-run->list (conc "pgrep -l -P " pid)))) + ;; (for-each + ;; (lambda (p) + ;; (let* ((parts (string-split p)) + ;; (p-id (if (> (length parts) 0) + ;; (string->number (car parts)) + ;; #f))) + ;; (if p-id + ;; (begin + ;; (debug:print 0 "Killing " (cadr parts) "; kill -9 " p-id) + ;; (system (conc "kill -9 " p-id)))))) + ;; (car processes)) + ;; (system (conc "kill -9 -" pid)))) (begin (debug:print 0 "WARNING: Request received to kill job but problem with process, attempting to kill manager process") (tests:test-set-status! test-id "KILLED" "FAIL" (args:get-arg "-m") #f) (sqlite3:finalize! tdb) @@ -406,17 +415,17 @@ ;; ;; All log file links should be stored relative to the top of link path ;; ;; - [ - ] ;; -(define (create-work-area run-id run-info key-vals test-id test-src-path disk-path testname itemdat) +(define (create-work-area run-id run-info keyvals test-id test-src-path disk-path testname itemdat) (let* ((item-path (item-list->path itemdat)) (runname (db:get-value-by-header (db:get-row run-info) (db:get-header run-info) "runname")) ;; convert back to db: from rdb: - this is always run at server end - (target (string-intersperse key-vals "/")) + (target (string-intersperse (map cadr keyvals) "/")) (not-iterated (equal? "" item-path)) ;; all tests are found at /test-base or /test-base (testtop-base (conc target "/" runname "/" testname)) @@ -554,28 +563,29 @@ ;; 3. create link from run dir to megatest runs area ;; 4. remotely run the test on allocated host ;; - could be ssh to host from hosts table (update regularly with load) ;; - could be netbatch ;; (launch-test db (cadr status) test-conf)) -(define (launch-test test-id run-id run-info key-vals runname test-conf keyvallst test-name test-path itemdat params) +(define (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat params) (change-directory *toppath*) (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute" (list ;; (list "MT_TEST_RUN_DIR" work-area) (list "MT_RUN_AREA_HOME" *toppath*) (list "MT_TEST_NAME" test-name) ;; (list "MT_ITEM_INFO" (conc itemdat)) (list "MT_RUNNAME" runname) ;; (list "MT_TARGET" mt_target) )) - (let* ((useshell (config-lookup *configdat* "jobtools" "useshell")) - (launcher (config-lookup *configdat* "jobtools" "launcher")) - (runscript (config-lookup test-conf "setup" "runscript")) - (ezsteps (> (length (hash-table-ref/default test-conf "ezsteps" '())) 0)) ;; don't send all the steps, could be big - (diskspace (config-lookup test-conf "requirements" "diskspace")) - (memory (config-lookup test-conf "requirements" "memory")) - (hosts (config-lookup *configdat* "jobtools" "workhosts")) + (let* ((useshell (config-lookup *configdat* "jobtools" "useshell")) + (launcher (config-lookup *configdat* "jobtools" "launcher")) + (runscript (config-lookup test-conf "setup" "runscript")) + (ezsteps (> (length (hash-table-ref/default test-conf "ezsteps" '())) 0)) ;; don't send all the steps, could be big + (diskspace (config-lookup test-conf "requirements" "diskspace")) + (memory (config-lookup test-conf "requirements" "memory")) + (hosts (config-lookup *configdat* "jobtools" "workhosts")) (remote-megatest (config-lookup *configdat* "setup" "executable")) + (run-time-limit (configf:lookup test-conf "requirements" "runtimelim")) ;; FIXME SOMEDAY: not good how this is so obtuse, this hack is to ;; allow running from dashboard. Extract the path ;; from the called megatest and convert dashboard ;; or dboard to megatest (local-megatest (let* ((lm (car (argv))) @@ -595,11 +605,11 @@ (fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x)))) (mt-bindir-path #f) (item-path (item-list->path itemdat)) ;; (test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path)) (testinfo (cdb:get-test-info-by-id *runremote* test-id)) - (mt_target (string-intersperse (map cadr keyvallst) "/")) + (mt_target (string-intersperse (map cadr keyvals) "/")) (debug-param (append (if (args:get-arg "-debug") (list "-debug" (args:get-arg "-debug")) '()) (if (args:get-arg "-logging")(list "-logging") '())))) (if hosts (set! hosts (string-split hosts))) ;; set the megatest to be called on the remote host (if (not remote-megatest)(set! remote-megatest local-megatest)) ;; "megatest")) @@ -606,11 +616,11 @@ (set! mt-bindir-path (pathname-directory remote-megatest)) (if launcher (set! launcher (string-split launcher))) ;; set up the run work area for this test (set! diskpath (get-best-disk *configdat*)) (if diskpath - (let ((dat (create-work-area run-id run-info key-vals test-id test-path diskpath test-name itemdat))) + (let ((dat (create-work-area run-id run-info keyvals test-id test-path diskpath test-name itemdat))) (set! work-area (car dat)) (set! toptest-work-area (cadr dat)) (debug:print-info 2 "Using work area " work-area)) (begin (set! work-area (conc test-path "/tmp_run")) @@ -631,14 +641,15 @@ (list 'test-id test-id ) (list 'itemdat itemdat ) (list 'megatest remote-megatest) (list 'ezsteps ezsteps) (list 'target mt_target) + (list 'runtlim (if run-time-limit (common:hms-string->seconds run-time-limit) #f)) (list 'env-ovrd (hash-table-ref/default *configdat* "env-override" '())) (list 'set-vars (if params (hash-table-ref/default params "-setvars" #f))) (list 'runname runname) - (list 'mt-bindir-path mt-bindir-path))))))) ;; (string-intersperse keyvallst " ")))) + (list 'mt-bindir-path mt-bindir-path))))))) ;; clean out step records from previous run if they exist ;; (debug:print-info 4 "FIXMEEEEE!!!! This can be removed some day, perhaps move all test records to the test db?") ;; (open-run-close db:delete-test-step-records db test-id) (change-directory work-area) ;; so that log files from the launch process don't clutter the test dir (tests:test-set-status! test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED")) @@ -667,24 +678,29 @@ (list "MT_ITEM_INFO" (conc itemdat)) (list "MT_RUNNAME" runname) (list "MT_TARGET" mt_target) ) itemdat))) - (launch-results (apply (if (equal? (configf:lookup *configdat* "setup" "launchwait") "yes") + ;; Launchwait defaults to true, must override it to turn off wait + (launchwait (if (equal? (configf:lookup *configdat* "setup" "launchwait") "no") #f #t)) + (launch-results (apply (if launchwait cmd-run-with-stderr->list process-run) (if useshell (string-intersperse fullcmd " ") (car fullcmd)) (if useshell '() (cdr fullcmd))))) - (if (list? launch-results) - (with-output-to-file "mt_launch.log" - (lambda () - (apply print launch-results)) - #:append)) + (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" + (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)) (debug:print 2 "Launching completed, updating db") (debug:print 2 "Launch results: " launch-results) (if (not launch-results) (begin (print "ERROR: Failed to run " (string-intersperse fullcmd " ") ", exiting now") Index: margs.scm ================================================================== --- margs.scm +++ margs.scm @@ -17,12 +17,12 @@ (hash-table-ref/default args:arg-hash arg #f) (hash-table-ref/default args:arg-hash arg (car default)))) (define (args:get-arg-from ht arg . default) (if (null? default) - (hash-table-ref/default ht arg #f)) - (hash-table-ref/default ht arg (car default))) + (hash-table-ref/default ht arg #f) + (hash-table-ref/default ht arg (car default)))) (define (args:usage . args) (if (> (length args) 0) (apply print "ERROR: " args)) (if (string? help) @@ -34,11 +34,12 @@ (define (args:get-args args params switches arg-hash num-needed) (let* ((numargs (length args)) (adj-num-needed (if num-needed (+ num-needed 2) #f))) (if (< numargs (if adj-num-needed adj-num-needed 2)) (if (>= num-needed 1) - (args:usage "No arguments provided")) + (args:usage "No arguments provided") + '()) (let loop ((arg (cadr args)) (tail (cddr args)) (remargs '())) (cond ((member arg params) ;; args with params Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -1,7 +1,7 @@ ;; Always use two digit decimal ;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00.. (declare (unit megatest-version)) -(define megatest-version 1.5419) +(define megatest-version 1.5506) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -8,11 +8,11 @@ ;; PURPOSE. ;; (include "common.scm") ;; (include "megatest-version.scm") -(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 format readline apropos json) ;; (srfi 18) extras) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 format readline apropos json http-client) ;; (srfi 18) extras) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) ;; (use zmq) @@ -24,47 +24,24 @@ (declare (uses server)) (declare (uses client)) (declare (uses tests)) (declare (uses genexample)) (declare (uses daemon)) +(declare (uses db)) (define *db* #f) ;; this is only for the repl, do not use in general!!!! (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") +(include "run_records.scm") (include "megatest-fossil-hash.scm") -;; (use trace dot-locking) -;; (trace -;; db:teststep-set-status! -;; db:open-test-db-by-test-id -;; db:test-get-rundir-from-test-id -;; cdb:tests-register-test -;; cdb:tests-update-uname-host -;; cdb:tests-update-run-duration -;; ;; cdb:client-call -;; ;; cdb:remote-run -;; ) -;; cdb:test-set-status-state -;; change-directory -;; db:process-queue-item -;; db:test-get-logfile-info -;; db:teststep-set-status! -;; nice-path -;; obtain-dot-lock -;; open-run-close -;; read-config -;; runs:can-run-more-tests -;; sqlite3:execute -;; sqlite3:for-each-row -;; tests:check-waiver-eligibility -;; tests:summarize-items -;; tests:test-set-status! -;; thread-sleep! -;;) - +(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc"))) + (if (file-exists? debugcontrolf) + (load debugcontrolf))) + (define help (conc " Megatest, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " license GPL, Copyright Matt Welland 2006-2012 @@ -83,10 +60,11 @@ -rerun FAIL,WARN... : force re-run for tests with specificed status(s) -rollup : (currently disabled) fill run (set by :runname) with latest test(s) from prior runs with same keys -lock : lock run specified by target and runname -unlock : unlock run specified by target and runname + -run-wait : wait on run specified by target and runname Selectors (e.g. use for -runtests, -remove-runs, -set-state-status, -list-runs etc.) -target key1/key2/... : run for key1, key2, etc. -reqtarg key1/key2/... : run for key1, key2, etc. but key1/key2 must be in runconfig -testpatt patt1/patt2,patt3/... : % is wildcard @@ -115,12 +93,12 @@ from standard in. Each line is comma delimited with four fields category,variable,value,comment Queries -list-runs patt : list runs matching pattern \"patt\", % is the wildcard - -showkeys : show the keys used in this megatest setup - -test-files targpatt : get the most recent test path/file matching targpatt e.g. %/%... + -show-keys : show the keys used in this megatest setup + -test-files targpatt : get the most recent test path/file matching targpatt e.g. %/%... returns list sorted by age ascending, see examples below -test-paths : get the test paths matching target, runname, item and test patterns. -list-disks : list the disks available for storing runs -list-targets : list the targets in runconfigs.config @@ -139,11 +117,12 @@ -server -|hostname : start the server (reduces contention on megatest.db), use - to automatically figure out hostname -transport http|fs : use http or direct access for transport (default is http) -daemonize : fork into background and disconnect from stdin/out -list-servers : list the servers - -stop-server id : stop server specified by id (see output of -list-servers) + -stop-server id : stop server specified by id (see output of -list-servers), use + 0 to kill all -repl : start a repl (useful for extending megatest) -load file.scm : load and run file.scm Spreadsheet generation -extract-ods fname.ods : extract an open document spreadsheet from the database @@ -221,10 +200,11 @@ (list "-h" "-version" "-force" "-xterm" "-showkeys" + "-show-keys" "-test-status" "-set-values" "-load-test-data" "-summarize-items" "-gui" @@ -233,11 +213,13 @@ "-archive" "-repl" "-lock" "-unlock" "-list-servers" - ;; mist queries + "-run-wait" ;; wait on a run to complete (i.e. no RUNNING) + + ;; misc queries "-list-disks" "-list-targets" "-list-db-targets" "-show-runconfig" "-show-config" @@ -269,10 +251,15 @@ (print megatest-version) (exit))) (define *didsomething* #f) +(if (and (or (args:get-arg "-list-targets") + (args:get-arg "-list-db-targets")) + (not (args:get-arg "-transport"))) + (hash-table-set! args:arg-hash "-transport" "fs")) + ;;====================================================================== ;; Misc setup stuff ;;====================================================================== (debug:setup) @@ -328,43 +315,52 @@ (let loop ((servers (open-run-close tasks:get-best-server tasks:open-db)) (trycount 0)) (if (or (not servers) (null? servers)) (begin - (if (eq? trycount 0) ;; just do the server start once + (if (even? trycount) ;; just do the server start every other time through this loop (every 8 seconds) (begin (debug:print 0 "INFO: Starting server as none running ...") ;; (server:launch (string->symbol (args:get-arg "-transport" "http")))) + ;; no need to use fork, no need to do the list-servers trick. Just start the damn server, it will exit on it's own + ;; if there is an existing server + (system "megatest -server - -daemonize") + (thread-sleep! 3) ;; (process-run (car (argv)) (list "-server" "-" "-daemonize" "-transport" (args:get-arg "-transport" "http"))) - (process-fork (lambda () - (daemon:ize) - (server:launch (string->symbol (args:get-arg "-transport" "http"))))) - (thread-sleep! 3)) - (debug:print-info 0 "Waiting for server to start")) - (loop (open-run-close tasks:get-best-server tasks:open-db) - (+ trycount 1))) + ;; (system (conc "megatest -list-servers | egrep '" megatest-version ".*alive' || megatest -server - -daemonize && sleep 3")) + ;; (process-fork (lambda () + ;; (daemon:ize) + ;; (server:launch (string->symbol (args:get-arg "-transport" "http"))))) + ) + (begin + (debug:print-info 0 "Waiting for server to start") + (thread-sleep! 4))) + (if (< trycount 10) + (loop (open-run-close tasks:get-best-server tasks:open-db) + (+ trycount 1)) + (debug:print 0 "WARNING: Couldn't start or find a server."))) (debug:print 0 "INFO: Server(s) running " servers) ))))) (if (or (args:get-arg "-list-servers") (args:get-arg "-stop-server")) (let ((tl (setup-for-run))) (if tl (let* ((servers (open-run-close tasks:get-all-servers tasks:open-db)) - (fmtstr "~5a~8a~8a~20a~20a~10a~10a~10a~10a~10a\n") + (fmtstr "~5a~12a~8a~20a~24a~10a~10a~10a~10a\n") (servers-to-kill '()) (killinfo (args:get-arg "-stop-server")) (khost-port (if killinfo (if (substring-index ":" killinfo)(string-split ":") #f) #f)) (sid (if killinfo (if (substring-index ":" killinfo) #f (string->number killinfo)) #f))) - (format #t fmtstr "Id" "MTver" "Pid" "Host" "Interface" "OutPort" "InPort" "LastBeat" "State" "Transport") - (format #t fmtstr "==" "=====" "===" "====" "=========" "=======" "======" "========" "=====" "=========") + (format #t fmtstr "Id" "MTver" "Pid" "Host" "Interface:OutPort" "InPort" "LastBeat" "State" "Transport") + (format #t fmtstr "==" "=====" "===" "====" "=================" "======" "========" "=====" "=========") (for-each (lambda (server) (let* ((id (vector-ref server 0)) (pid (vector-ref server 1)) (hostname (vector-ref server 2)) - (interface (vector-ref server 3)) + (interface (vector-ref server 3)) (pullport (vector-ref server 4)) (pubport (vector-ref server 5)) (start-time (vector-ref server 6)) (priority (vector-ref server 7)) (state (vector-ref server 8)) @@ -379,13 +375,14 @@ (if (equal? state "dead") (if (> last-update (* 25 60 60)) ;; keep records around for slighly over a day. (open-run-close tasks:server-deregister tasks:open-db hostname pullport: pullport pid: pid action: 'delete)) (if (> last-update 20) ;; Mark as dead if not updated in last 20 seconds (open-run-close tasks:server-deregister tasks:open-db hostname pullport: pullport pid: pid))) - (format #t fmtstr id mt-ver pid hostname interface pullport pubport last-update + (format #t fmtstr id mt-ver pid hostname (conc interface ":" pullport) pubport last-update (if status "alive" "dead") transport) - (if (equal? id sid) + (if (or (equal? id sid) + (equal? sid 0)) ;; kill all/any (begin (debug:print-info 0 "Attempting to stop server with pid " pid) (tasks:kill-server status hostname pullport pid transport))))) servers) (debug:print-info 1 "Done with listservers") @@ -409,20 +406,32 @@ (for-each (lambda (x) ;; (print "[" x "]")) (print x)) targets) (set! *didsomething* #t))) + +(define (full-runconfigs-read) + (let* ((keys (cdb:remote-run db:get-keys #f)) + (target (if (args:get-arg "-reqtarg") + (args:get-arg "-reqtarg") + (if (args:get-arg "-target") + (args:get-arg "-target") + #f))) + (key-vals (if target (keys:target->keyval keys target) #f)) + (sections (if target (list "default" target) #f)) + (data (begin + (setenv "MT_RUN_AREA_HOME" *toppath*) + (if key-vals + (for-each (lambda (kt) + (setenv (car kt) (cadr kt))) + key-vals)) + (read-config "runconfigs.config" #f #t sections: sections)))) + data)) + (if (args:get-arg "-show-runconfig") - (let* ((target (if (args:get-arg "-reqtarg") - (args:get-arg "-reqtarg") - (if (args:get-arg "-target") - (args:get-arg "-target") - #f))) - (sections (if target (list "default" target) #f)) - (data (read-config "runconfigs.config" #f #t sections: sections))) - + (let ((data (full-runconfigs-read))) ;; keep this one local (cond ((not (args:get-arg "-dumpmode")) (pp (hash-table->alist data))) ((string=? (args:get-arg "-dumpmode") "json") @@ -455,43 +464,50 @@ ;;====================================================================== ;; since several actions can be specified on the command line the removal ;; is done first (define (operate-on action) - (cond - ((not (args:get-arg ":runname")) - (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify the run name pattern with :runname patt") - (exit 2)) - ((not (args:get-arg "-testpatt")) - (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify the test pattern with -testpatt") - (exit 3)) - (else - (if (not (car *configinfo*)) - (begin - (debug:print 0 "ERROR: Attempted " action "on test(s) but run area config file not found") - (exit 1)) - ;; put test parameters into convenient variables - (runs:operate-on action - (args:get-arg ":runname") - (args:get-arg "-testpatt") - state: (args:get-arg ":state") - status: (args:get-arg ":status") - new-state-status: (args:get-arg "-set-state-status"))) - (set! *didsomething* #t)))) + (let* ((runrec (runs:runrec-make-record)) + (target (or (args:get-arg "-reqtarg") + (args:get-arg "-target")))) + (cond + ((not target) + (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify -target or -reqtarg") + (exit 1)) + ((not (args:get-arg ":runname")) + (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify the run name pattern with :runname patt") + (exit 2)) + ((not (args:get-arg "-testpatt")) + (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify the test pattern with -testpatt") + (exit 3)) + (else + (if (not (car *configinfo*)) + (begin + (debug:print 0 "ERROR: Attempted " action "on test(s) but run area config file not found") + (exit 1)) + ;; put test parameters into convenient variables + (runs:operate-on action + target + (args:get-arg ":runname") + (args:get-arg "-testpatt") + state: (args:get-arg ":state") + status: (args:get-arg ":status") + new-state-status: (args:get-arg "-set-state-status"))) + (set! *didsomething* #t))))) (if (args:get-arg "-remove-runs") (general-run-call "-remove-runs" "remove runs" - (lambda (target runname keys keynames keyvallst) + (lambda (target runname keys keyvals) (operate-on 'remove-runs)))) (if (args:get-arg "-set-state-status") (general-run-call "-set-state-status" "set state and status" - (lambda (target runname keys keynames keyvallst) + (lambda (target runname keys keyvals) (operate-on 'set-state-status)))) ;;====================================================================== ;; Query runs ;;====================================================================== @@ -506,28 +522,27 @@ "%")) (runsdat (cdb:remote-run db:get-runs #f runpatt #f #f '())) (runs (db:get-rows runsdat)) (header (db:get-header runsdat)) (keys (cdb:remote-run db:get-keys #f)) - (keynames (map key:get-fieldname keys)) (db-targets (args:get-arg "-list-db-targets")) (seen (make-hash-table))) ;; Each run (for-each (lambda (run) (let ((targetstr (string-intersperse (map (lambda (x) (db:get-value-by-header run header x)) - keynames) "/"))) + keys) "/"))) (if db-targets (if (not (hash-table-ref/default seen targetstr #f)) (begin (hash-table-set! seen targetstr #t) ;; (print "[" targetstr "]")))) (print targetstr)))) (if (not db-targets) (let* ((run-id (db:get-value-by-header run header "id")) - (tests (cdb:remote-run db:get-tests-for-run #f run-id testpatt '() '()))) + (tests (mt:get-tests-for-run run-id testpatt '() '()))) (print "Run: " targetstr "/" (db:get-value-by-header run header "runname") " status: " (db:get-value-by-header run header "state") " run-id: " run-id ", number tests: " (length tests)) (for-each (lambda (test) @@ -588,14 +603,13 @@ ;; run all tests are are Not COMPLETED and PASS or CHECK (if (args:get-arg "-runall") (general-run-call "-runall" "run all tests" - (lambda (target runname keys keynames keyvallst) + (lambda (target runname keys keyvals) (runs:run-tests target runname - "%" (args:get-arg "-testpatt") user args:arg-hash)))) ;;====================================================================== @@ -617,44 +631,40 @@ (if (args:get-arg "-runtests") (general-run-call "-runtests" "run a test" - (lambda (target runname keys keynames keyvallst) + (lambda (target runname keys keyvals) (runs:run-tests target runname (args:get-arg "-runtests") - (args:get-arg "-testpatt") user args:arg-hash)))) ;;====================================================================== ;; Rollup into a run ;;====================================================================== (if (args:get-arg "-rollup") - (begin - (debug:print 0 "ERROR: Rollup is currently not working. If you need it please submit a ticket at http://www.kiatoa.com/fossils/megatest") - (exit 4))) -;; (general-run-call -;; "-rollup" -;; "rollup tests" -;; (lambda (target runname keys keynames keyvallst) -;; (runs:rollup-run keys -;; (keys->alist keys "na") -;; (args:get-arg ":runname") -;; user)))) + (general-run-call + "-rollup" + "rollup tests" + (lambda (target runname keys keyvals) + (runs:rollup-run keys + keyvals + (args:get-arg ":runname") + user)))) ;;====================================================================== ;; Lock or unlock a run ;;====================================================================== (if (or (args:get-arg "-lock")(args:get-arg "-unlock")) (general-run-call (if (args:get-arg "-lock") "-lock" "-unlock") "lock/unlock tests" - (lambda (target runname keys keynames keyvallst) + (lambda (target runname keys keyvals) (runs:handle-locking target keys (args:get-arg ":runname") (args:get-arg "-lock") @@ -693,25 +703,24 @@ (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, giving up on -test-paths or -test-files, exiting") (exit 1))) (let* ((keys (cdb:remote-run db:get-keys db)) - (keynames (map key:get-fieldname keys)) ;; db:test-get-paths must not be run remote - (paths (db:test-get-paths-matching db keynames target (args:get-arg "-test-files")))) + (paths (db:test-get-paths-matching db keys target (args:get-arg "-test-files")))) (set! *didsomething* #t) (for-each (lambda (path) (print path)) paths))) ;; else do a general-run-call (general-run-call "-test-files" "Get paths to test" - (lambda (target runname keys keynames keyvallst) + (lambda (target runname keys keyvals) (let* ((db #f) ;; DO NOT run remote - (paths (db:test-get-paths-matching db keynames target (args:get-arg "-test-files")))) + (paths (db:test-get-paths-matching db keys target (args:get-arg "-test-files")))) (for-each (lambda (path) (print path)) paths)))))) ;;====================================================================== @@ -745,25 +754,24 @@ (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, giving up on -archive, exiting") (exit 1))) (let* ((keys (cdb:remote-run db:get-keys db)) - (keynames (map key:get-fieldname keys)) ;; DO NOT run remote - (paths (db:test-get-paths-matching db keynames target))) + (paths (db:test-get-paths-matching db keys target))) (set! *didsomething* #t) (for-each (lambda (path) (print path)) paths))) ;; else do a general-run-call (general-run-call "-test-paths" "Get paths to tests" - (lambda (target runname keys keynames keyvallst) + (lambda (target runname keys keyvals) (let* ((db #f) ;; DO NOT run remote - (paths (db:test-get-paths-matching db keynames target))) + (paths (db:test-get-paths-matching db keys target))) (for-each (lambda (path) (print path)) paths)))))) ;;====================================================================== @@ -772,17 +780,17 @@ (if (args:get-arg "-extract-ods") (general-run-call "-extract-ods" "Make ods spreadsheet" - (lambda (target runname keys keynames keyvallst) + (lambda (target runname keys keyvals) (let ((db #f) (outputfile (args:get-arg "-extract-ods")) (runspatt (args:get-arg ":runname")) - (pathmod (args:get-arg "-pathmod")) - (keyvalalist (keys->alist keys "%"))) - (debug:print 2 "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvalalist: " keyvalalist) + (pathmod (args:get-arg "-pathmod"))) + ;; (keyvalalist (keys->alist keys "%"))) + (debug:print 2 "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvalalist: " keyvals) (cdb:remote-run db:extract-ods-file db outputfile keyvalalist (if runspatt runspatt "%") pathmod))))) ;;====================================================================== ;; execute the test ;; - gets called on remote host @@ -840,12 +848,13 @@ (args:get-arg "-setlog") (args:get-arg "-m")) ;; (if db (sqlite3:finalize! db)) (set! *didsomething* #t))) -(if (or (and (args:get-arg "-setlog") ;; since setting up is so costly lets piggyback on -test-status - (not (args:get-arg "-step"))) ;; -setlog may have been processed already in the "-step" previous +(if (or (args:get-arg "-setlog") ;; since setting up is so costly lets piggyback on -test-status + ;; (not (args:get-arg "-step"))) ;; -setlog may have been processed already in the "-step" previous + ;; NEW POLICY - -setlog sets test overall log on every call. (args:get-arg "-set-toplog") (args:get-arg "-test-status") (args:get-arg "-set-values") (args:get-arg "-load-test-data") (args:get-arg "-runstep") @@ -968,19 +977,20 @@ ;;====================================================================== ;; Various helper commands can go below here ;;====================================================================== -(if (args:get-arg "-showkeys") +(if (or (args:get-arg "-showkeys") + (args:get-arg "-show-keys")) (let ((db #f) (keys #f)) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) - (set! keys (cbd:remote-run db:get-keys db)) - (debug:print 1 "Keys: " (string-intersperse (map key:get-fieldname keys) ", ")) + (set! keys (cdb:remote-run db:get-keys db)) + (debug:print 1 "Keys: " (string-intersperse keys ", ")) (if db (sqlite3:finalize! db)) (set! *didsomething* #t))) (if (args:get-arg "-gui") (begin @@ -1009,10 +1019,23 @@ (debug:print 0 "Failed to setup, exiting") (exit 1))) ;; keep this one local (open-run-close patch-db #f) (set! *didsomething* #t))) + +;;====================================================================== +;; Wait on a run to complete +;;====================================================================== + +(if (args:get-arg "-run-wait") + (begin + (if (not (setup-for-run)) + (begin + (debug:print 0 "Failed to setup, exiting") + (exit 1))) + (operate-on 'run-wait) + (set! *didsomething* #t))) ;;====================================================================== ;; Update the tests meta data from the testconfig files ;;====================================================================== @@ -1054,10 +1077,12 @@ (set! *didsomething* #t))) ;;====================================================================== ;; Exit and clean up ;;====================================================================== + +(if *runremote* (close-all-connections!)) ;; this is the socket if we are a client ;; (if (and *runremote* ;; (socket? *runremote*)) ;; (close-socket *runremote*)) ADDED mt.scm Index: mt.scm ================================================================== --- /dev/null +++ mt.scm @@ -0,0 +1,70 @@ +;; Copyright 2006-2013, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. + + +(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) posix-extras directory-utils) +(import (prefix sqlite3 sqlite3:)) + +(declare (unit mt)) +(declare (uses db)) +(declare (uses common)) +(declare (uses items)) +(declare (uses runconfig)) +(declare (uses tests)) +(declare (uses server)) +(declare (uses runs)) + +(include "common_records.scm") +(include "key_records.scm") +(include "db_records.scm") +(include "run_records.scm") +(include "test_records.scm") + +;; This is the Megatest API. All generally "useful" routines will be wrapped or extended +;; here. + +;;====================================================================== +;; R U N S +;;====================================================================== + +;; runs:get-runs-by-patt +;; get runs by list of criteria +;; register a test run with the db +;; +;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-row runinfo)) +;; to extract info from the structure returned +;; +(define (mt:get-runs-by-patt keys runnamepatt targpatt) + (cdb:remote-run db:get-runs-by-patt #f keys runnamepatt targpatt)) + +;;====================================================================== +;; T E S T S +;;====================================================================== + +(define (mt:get-tests-for-run run-id testpatt states status #!key (not-in #t) (sort-by #f) (qryvals #f)) + (let loop ((testsdat (cdb:remote-run db:get-tests-for-run #f run-id testpatt states status 0 500 not-in sort-by qryvals: qryvals)) + (res '()) + (offset 0) + (limit 500)) + (let* ((full-list (append res testsdat)) + (have-more (eq? (length testsdat) limit))) + (if have-more + (let ((new-offset (+ offset limit))) + (debug:print-info 4 "More than " limit " tests, have " (length full-list) " tests so far.") + (loop (cdb:remote-run db:get-tests-for-run #f run-id testpatt states status new-offset limit not-in sort-by qryvals: qryvals) + full-list + new-offset + limit)) + full-list)))) + +(define (mt:get-prereqs-not-met run-id waitons ref-item-path #!key (mode 'normal)) + (db:get-prereqs-not-met run-id waitons ref-item-path mode: mode)) + +(define (mt:get-run-stats) + (cdb:remote-run db:get-run-stats #f)) Index: newdashboard.scm ================================================================== --- newdashboard.scm +++ newdashboard.scm @@ -1,7 +1,7 @@ ;;====================================================================== -;; Copyright 2006-2012, Matthew Welland. +;; Copyright 2006-2013, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the @@ -22,10 +22,12 @@ (declare (uses megatest-version)) (declare (uses gutils)) (declare (uses db)) (declare (uses server)) (declare (uses synchash)) +(declare (uses dcommon)) +(declare (uses tree)) (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") @@ -82,42 +84,10 @@ (debug:setup) (define *tim* (iup:timer)) (define *ord* #f) -(define *data* (make-vector 10 #f)) -(define-inline (dboard:data-get-runs vec) (vector-ref vec 0)) -(define-inline (dboard:data-get-tests vec) (vector-ref vec 1)) -(define-inline (dboard:data-get-runs-matrix vec) (vector-ref vec 2)) -(define-inline (dboard:data-get-tests-tree vec) (vector-ref vec 3)) -(define-inline (dboard:data-get-run-keys vec) (vector-ref vec 4)) -(define-inline (dboard:data-get-curr-test-ids vec) (vector-ref vec 5)) -;; (define-inline (dboard:data-get-test-details vec) (vector-ref vec 6)) -(define-inline (dboard:data-get-path-test-ids vec) (vector-ref vec 7)) -(define-inline (dboard:data-get-updaters vec) (vector-ref vec 8)) - -(define-inline (dboard:data-set-runs! vec val)(vector-set! vec 0 val)) -(define-inline (dboard:data-set-tests! vec val)(vector-set! vec 1 val)) -(define-inline (dboard:data-set-runs-matrix! vec val)(vector-set! vec 2 val)) -(define-inline (dboard:data-set-tests-tree! vec val)(vector-set! vec 3 val)) -(define-inline (dboard:data-set-run-keys! vec val)(vector-set! vec 4 val)) -(define-inline (dboard:data-set-curr-test-ids! vec val)(vector-set! vec 5 val)) -;; (define-inline (dboard:data-set-test-details! vec val)(vector-set! vec 6 val)) -(define-inline (dboard:data-set-path-test-ids! vec val)(vector-set! vec 7 val)) -(define-inline (dboard:data-set-updaters! vec val)(vector-set! vec 8 val)) - -(dboard:data-set-run-keys! *data* (make-hash-table)) - -;; List of test ids being viewed in various panels -(dboard:data-set-curr-test-ids! *data* (make-hash-table)) - -;; Look up test-ids by (key1 key2 ... testname [itempath]) -(dboard:data-set-path-test-ids! *data* (make-hash-table)) - -;; Each test panel has an updater, only call when the tab is exposed -(dboard:data-set-updaters! *data* (make-hash-table)) - (iup:attribute-set! *tim* "TIME" 300) (iup:attribute-set! *tim* "RUN" "YES") (define (message-window msg) (iup:show @@ -145,49 +115,17 @@ (string-intersperse (map conc x) ",")) (define (update-search x val) (hash-table-set! *searchpatts* x val)) -(define (main-menu) - (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top) - (iup:menu-item "Files" (iup:menu ;; Note that you can use either #:action or action: for options - (iup:menu-item "Open" action: (lambda (obj) - (iup:show (iup:file-dialog)) - (print "File->open " obj))) - (iup:menu-item "Save" #:action (lambda (obj)(print "File->save " obj))) - (iup:menu-item "Exit" #:action (lambda (obj)(exit))))) - (iup:menu-item "Tools" (iup:menu - (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah"))) - ;; (iup:menu-item "Show dialog" #:action (lambda (obj) - ;; (show message-window - ;; #:modal? #t - ;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current - ;; ;; #:x 'mouse - ;; ;; #:y 'mouse - ;; ) - )))) - ;; mtest is actually the megatest.config file ;; (define (mtest window-id) (let* ((curr-row-num 0) (rawconfig (read-config (conc *toppath* "/megatest.config") #f 'return-string)) - (keys-matrix (iup:matrix - #:expand "VERTICAL" - ;; #:scrollbar "YES" - #:numcol 1 - #:numlin 20 - #:numcol-visible 1 - #:numlin-visible 5 - #:click-cb (lambda (obj lin col status) - (print "obj: " obj " lin: " lin " col: " col " status: " status)))) - (setup-matrix (iup:matrix - #:expand "YES" - #:numcol 1 - #:numlin 5 - #:numcol-visible 1 - #:numlin-visible 3)) + (keys-matrix (dcommon:keys-matrix rawconfig)) + (setup-matrix (dcommon:section-matrix rawconfig "setup" "Varname" "Value")) (jobtools-matrix (iup:matrix #:expand "YES" #:numcol 1 #:numlin 5 #:numcol-visible 1 @@ -209,28 +147,17 @@ #:numcol 1 #:numlin 20 #:numcol-visible 1 #:numlin-visible 8)) ) - (iup:attribute-set! keys-matrix "0:0" "Field Num") - (iup:attribute-set! keys-matrix "0:1" "Field Name") - (iup:attribute-set! keys-matrix "WIDTH1" "100") (iup:attribute-set! disks-matrix "0:0" "Disk Name") (iup:attribute-set! disks-matrix "0:1" "Disk Path") (iup:attribute-set! disks-matrix "WIDTH1" "120") (iup:attribute-set! disks-matrix "WIDTH0" "100") (iup:attribute-set! disks-matrix "ALIGNMENT1" "ALEFT") (iup:attribute-set! disks-matrix "FIXTOTEXT" "C1") (iup:attribute-set! disks-matrix "RESIZEMATRIX" "YES") - ;; fill in keys - (set! curr-row-num 1) - (for-each - (lambda (var) - (iup:attribute-set! keys-matrix (conc curr-row-num ":0") curr-row-num) - (iup:attribute-set! keys-matrix (conc curr-row-num ":1") var) - (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup *configdat* "fields" var))) - (configf:section-vars rawconfig "fields")) ;; fill in existing info (for-each (lambda (mat fname) (set! curr-row-num 1) @@ -316,108 +243,10 @@ ;; (define (rconfig window-id) (iup:vbox (iup:frame #:title "Default"))) -;;====================================================================== -;; T R E E S T U F F -;;====================================================================== - -;; path is a list of nodes, each the child of the previous -;; this routine returns the id so another node can be added -;; either as a leaf or as a branch -;; -;; BUG: This needs a stop sensor for when a branch is exhausted -;; -(define (tree-find-node obj path) - ;; start at the base of the tree - (if (null? path) - #f ;; or 0 ???? - (let loop ((hed (car path)) - (tal (cdr path)) - (depth 0) - (nodenum 0)) - ;; nodes in iup tree are 100% sequential so iterate over nodenum - (if (iup:attribute obj (conc "DEPTH" nodenum)) ;; end when no more nodes - (let ((node-depth (string->number (iup:attribute obj (conc "DEPTH" nodenum)))) - (node-title (iup:attribute obj (conc "TITLE" nodenum)))) - (if (and (equal? depth node-depth) - (equal? hed node-title)) ;; yep, this is the one! - (if (null? tal) ;; end of the line - nodenum - (loop (car tal)(cdr tal)(+ depth 1)(+ 1 nodenum))) - ;; this is the case where we found part of the hierarchy but not - ;; all of it, i.e. the node-depth went from deep to less deep - (if (> depth node-depth) ;; (+ 1 node-depth)) - #f - (loop hed tal depth (+ nodenum 1))))) - #f)))) - -;; top is the top node name zeroeth node VALUE=0 -(define (tree-add-node obj top nodelst #!key (userdata #f)) - (if (not (iup:attribute obj "TITLE0")) - (iup:attribute-set! obj "ADDBRANCH0" top)) - (cond - ((not (string=? top (iup:attribute obj "TITLE0"))) - (print "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0"))) - ((null? nodelst)) - (else - (let loop ((hed (car nodelst)) - (tal (cdr nodelst)) - (depth 1) - (pathl (list top))) - ;; Because the tree dialog changes node numbers when - ;; nodes are added or removed we must look up nodes - ;; each and every time. 0 is the top node so default - ;; to that. - (let* ((newpath (append pathl (list hed))) - (parentnode (tree-find-node obj pathl)) - (nodenum (tree-find-node obj newpath))) - ;; Add the branch under lastnode if not found - (if (not nodenum) - (begin - (iup:attribute-set! obj (conc "ADDBRANCH" parentnode) hed) - (if userdata - (iup:attribute-set! obj (conc "USERDATA" parentnode) userdata)) - (if (null? tal) - #t - ;; reset to top - (loop (car nodelst)(cdr nodelst) 1 (list top)))) - (if (null? tal) ;; if null here then this path has already been added - #t - (loop (car tal)(cdr tal)(+ depth 1) newpath)))))))) - -(define (tree-node->path obj nodenum) - ;; (print "\ncurrnode nodenum depth node-depth node-title path") - (let loop ((currnode 0) - (depth 0) - (path '())) - (let ((node-depth (iup:attribute obj (conc "DEPTH" currnode))) - (node-title (iup:attribute obj (conc "TITLE" currnode)))) - ;; (display (conc "\n "currnode " " nodenum " " depth " " node-depth " " node-title " " path)) - (if (> currnode nodenum) - path - (if (not node-depth) ;; #f if we are out of nodes - '() - (let ((ndepth (string->number node-depth))) - (if (eq? ndepth depth) - ;; This next is the match condition depth == node-depth - (if (eq? currnode nodenum) - (begin - ;; (display " ") - (append path (list node-title))) - (loop (+ currnode 1) - (+ depth 1) - (append path (list node-title)))) - ;; didn't match, reset to base path and keep looking - ;; due to more iup odditys we don't reset to base - (begin - ;; (display " ") - (loop (+ 1 currnode) - 2 - (append (take path ndepth)(list node-title))))))))))) - ;;====================================================================== ;; T E S T S ;;====================================================================== (define (tree-path->test-id path) @@ -589,16 +418,16 @@ (iup:hbox (let* ((tb (iup:treebox #:selection-cb (lambda (obj id state) ;; (print "obj: " obj ", id: " id ", state: " state) - (let* ((run-path (tree-node->path obj id)) + (let* ((run-path (tree:node->path obj id)) (test-id (tree-path->test-id (cdr run-path)))) (if test-id (hash-table-set! (dboard:data-get-curr-test-ids *data*) window-id test-id)) - (print "path: " (tree-node->path obj id) " test-id: " test-id)))))) + (print "path: " (tree:node->path obj id) " test-id: " test-id)))))) (iup:attribute-set! tb "VALUE" "0") (iup:attribute-set! tb "NAME" "Runs") ;;(iup:attribute-set! tb "ADDEXPANDED" "NO") (dboard:data-set-tests-tree! *data* tb) tb) @@ -714,172 +543,19 @@ ;; Browse and control a single run ;; (define (runcontrol window-id) (iup:hbox)) -;;====================================================================== -;; P R O C E S S R U N S -;;====================================================================== - -;; MOVE THIS INTO *data* -(define *cachedata* (make-hash-table)) -(hash-table-set! *cachedata* "runid-to-col" (make-hash-table)) -(hash-table-set! *cachedata* "testname-to-row" (make-hash-table)) - -;; TO-DO -;; 1. Make "data" hash-table hierarchial store of all displayed data -;; 2. Update synchash to understand "get-runs", "get-tests" etc. -;; 3. Add extraction of filters to synchash calls -;; -;; Mode is 'full or 'incremental for full refresh or incremental refresh -(define (run-update keys data runname keypatts testpatt states statuses mode window-id) - (let* (;; count and offset => #f so not used - ;; the synchash calls modify the "data" hash - (get-runs-sig (conc (client:get-signature) " get-runs")) - (get-tests-sig (conc (client:get-signature) " get-tests")) - (get-details-sig (conc (client:get-signature) " get-test-details")) - - ;; test-ids to get and display are indexed on window-id in curr-test-ids hash - (test-ids (hash-table-values (dboard:data-get-curr-test-ids *data*))) - - (run-changes (synchash:client-get 'db:get-runs get-runs-sig (length keypatts) data runname #f #f keypatts)) - (tests-detail-changes (if (not (null? test-ids)) - (synchash:client-get 'db:get-test-info-by-ids get-details-sig 0 data test-ids) - '())) - - ;; Now can calculate the run-ids - (run-hash (hash-table-ref/default data get-runs-sig #f)) - (run-ids (if run-hash (filter number? (hash-table-keys run-hash)) '())) - - (test-changes (synchash:client-get 'db:get-tests-for-runs-mindata get-tests-sig 0 data run-ids testpatt states statuses)) - (runs-hash (hash-table-ref/default data get-runs-sig #f)) - (header (hash-table-ref/default runs-hash "header" #f)) - (run-ids (sort (filter number? (hash-table-keys runs-hash)) - (lambda (a b) - (let* ((record-a (hash-table-ref runs-hash a)) - (record-b (hash-table-ref runs-hash b)) - (time-a (db:get-value-by-header record-a header "event_time")) - (time-b (db:get-value-by-header record-b header "event_time"))) - (> time-a time-b))) - )) - (runid-to-col (hash-table-ref *cachedata* "runid-to-col")) - (testname-to-row (hash-table-ref *cachedata* "testname-to-row")) - (colnum 1) - (rownum 0)) ;; rownum = 0 is the header -;; (debug:print 0 "test-ids " test-ids ", tests-detail-changes " tests-detail-changes) - - ;; tests related stuff - ;; (all-testnames (delete-duplicates (map db:test-get-testname test-changes)))) - - ;; Given a run-id and testname/item_path calculate a cell R:C - - ;; NOTE: Also build the test tree browser and look up table - ;; - ;; Each run is unique on its keys and runname or run-id, store in hash on colnum - (for-each (lambda (run-id) - (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) - (key-vals (map (lambda (key)(db:get-value-by-header run-record header key)) - (map key:get-fieldname keys))) - (run-name (db:get-value-by-header run-record header "runname")) - (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) - (run-path (append key-vals (list run-name)))) - (hash-table-set! (dboard:data-get-run-keys *data*) run-id run-path) - (iup:attribute-set! (dboard:data-get-runs-matrix *data*) - (conc rownum ":" colnum) col-name) - (hash-table-set! runid-to-col run-id (list colnum run-record)) - ;; Here we update the tests treebox and tree keys - (tree-add-node (dboard:data-get-tests-tree *data*) "Runs" (append key-vals (list run-name)) - userdata: (conc "run-id: " run-id)) - (set! colnum (+ colnum 1)))) - run-ids) - - ;; Scan all tests to be displayed and organise all the test names, respecting what is in the hash table - ;; Do this analysis in the order of the run-ids, the most recent run wins - (for-each (lambda (run-id) - (let* ((run-path (hash-table-ref (dboard:data-get-run-keys *data*) run-id)) - (new-test-dat (car test-changes)) - (removed-tests (cadr test-changes)) - (tests (sort (map cadr (filter (lambda (testrec) - (eq? run-id (db:mintest-get-run_id (cadr testrec)))) - new-test-dat)) - (lambda (a b) - (let ((time-a (db:mintest-get-event_time a)) - (time-b (db:mintest-get-event_time b))) - (> time-a time-b))))) - ;; test-changes is a list of (( id record ) ... ) - ;; Get list of test names sorted by time, remove tests - (test-names (delete-duplicates (map (lambda (t) - (let ((i (db:mintest-get-item_path t)) - (n (db:mintest-get-testname t))) - (if (string=? i "") - (conc " " i) - n))) - tests))) - (colnum (car (hash-table-ref runid-to-col run-id)))) - ;; for each test name get the slot if it exists and fill in the cell - ;; or take the next slot and fill in the cell, deal with items in the - ;; run view panel? The run view panel can have a tree selector for - ;; browsing the tests/items - - ;; SWITCH THIS TO USING CHANGED TESTS ONLY - (for-each (lambda (test) - (let* ((test-id (db:mintest-get-id test)) - (state (db:mintest-get-state test)) - (status (db:mintest-get-status test)) - (testname (db:mintest-get-testname test)) - (itempath (db:mintest-get-item_path test)) - (fullname (conc testname "/" itempath)) - (dispname (if (string=? itempath "") testname (conc " " itempath))) - (rownum (hash-table-ref/default testname-to-row fullname #f)) - (test-path (append run-path (if (equal? itempath "") - (list testname) - (list testname itempath))))) - (tree-add-node (dboard:data-get-tests-tree *data*) "Runs" - test-path - userdata: (conc "test-id: " test-id)) - (hash-table-set! (dboard:data-get-path-test-ids *data*) test-path test-id) - (if (not rownum) - (let ((rownums (hash-table-values testname-to-row))) - (set! rownum (if (null? rownums) - 1 - (+ 1 (apply max rownums)))) - (hash-table-set! testname-to-row fullname rownum) - ;; create the label - (iup:attribute-set! (dboard:data-get-runs-matrix *data*) - (conc rownum ":" 0) dispname) - )) - ;; set the cell text and color - ;; (debug:print 2 "rownum:colnum=" rownum ":" colnum ", state=" status) - (iup:attribute-set! (dboard:data-get-runs-matrix *data*) - (conc rownum ":" colnum) - (if (string=? state "COMPLETED") - status - state)) - (iup:attribute-set! (dboard:data-get-runs-matrix *data*) - (conc "BGCOLOR" rownum ":" colnum) - (gutils:get-color-for-state-status state status)) - )) - tests))) - run-ids) - - (let ((updater (hash-table-ref/default (dboard:data-get-updaters *data*) window-id #f))) - (if updater (updater (hash-table-ref/default data get-details-sig #f)))) - - (iup:attribute-set! (dboard:data-get-runs-matrix *data*) "REDRAW" "ALL") - ;; (debug:print 2 "run-changes: " run-changes) - ;; (debug:print 2 "test-changes: " test-changes) - (list run-changes test-changes))) - ;;====================================================================== ;; D A S H B O A R D ;;====================================================================== ;; Main Panel (define (main-panel window-id) (iup:dialog #:title "Megatest Control Panel" - #:menu (main-menu) + #:menu (dcommon:main-menu) (let ((tabtop (iup:tabs (runs window-id) (tests window-id) (runcontrol window-id) (mtest window-id) @@ -897,11 +573,11 @@ (define (newdashboard) (let* ((data (make-hash-table)) (keys (cdb:remote-run db:get-keys #f)) (runname "%") (testpatt "%") - (keypatts (map (lambda (k)(list (vector-ref k 0) "%")) keys)) + (keypatts (map (lambda (k)(list k "%")) keys)) (states '()) (statuses '()) (nextmintime (current-milliseconds)) (my-window-id *current-window-id*)) (set! *current-window-id* (+ 1 *current-window-id*)) DELETED run-tests-queue-classic.scm Index: run-tests-queue-classic.scm ================================================================== --- run-tests-queue-classic.scm +++ /dev/null @@ -1,298 +0,0 @@ - -;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... > -(define (runs:run-tests-queue-classic run-id runname test-records keyvallst flags test-patts) - ;; At this point the list of parent tests is expanded - ;; NB// Should expand items here and then insert into the run queue. - (debug:print 5 "test-records: " test-records ", keyvallst: " keyvallst " flags: " (hash-table->alist flags)) - (let ((run-info (cdb:remote-run db:get-run-info #f run-id)) - (key-vals (cdb:remote-run db:get-key-vals #f run-id)) - (sorted-test-names (tests:sort-by-priority-and-waiton test-records)) - (test-registry (make-hash-table)) - (registry-mutex (make-mutex)) - (num-retries 0) - (max-retries (config-lookup *configdat* "setup" "maxretries")) - (max-concurrent-jobs (let ((mcj (config-lookup *configdat* "setup" "max_concurrent_jobs"))) - (if (and mcj (string->number mcj)) - (string->number mcj) - 1)))) - (set! max-retries (if (and max-retries (string->number max-retries))(string->number max-retries) 100)) - (if (not (null? sorted-test-names)) - (let loop ((hed (car sorted-test-names)) - (tal (cdr sorted-test-names)) - (reruns '())) - (if (not (null? reruns))(debug:print-info 4 "reruns=" reruns)) - ;; (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)) - (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 - (items (tests:testqueue-get-items test-record)) - (item-path (item-list->path itemdat)) - (newtal (append tal (list hed)))) - - (debug:print 6 - "test-name: " test-name - "\n hed: " hed - "\n itemdat: " itemdat - "\n items: " items - "\n item-path: " item-path - "\n waitons: " waitons - "\n num-retries: " num-retries - "\n tal: " tal - "\n reruns: " reruns) - - ;; check for hed in waitons => this would be circular, remove it and issue an - ;; error - (if (member test-name waitons) - (begin - (debug:print 0 "ERROR: test " test-name " has listed itself as a waiton, please correct this!") - (set! waiton (filter (lambda (x)(not (equal? x hed))) waitons)))) - - (cond ;; OUTER COND - ((not items) ;; when false the test is ok to be handed off to launch (but not before) - (let* ((run-limits-info (runs:can-run-more-tests test-record max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running - (have-resources (car run-limits-info)) - (num-running (list-ref run-limits-info 1)) - (num-running-in-jobgroup (list-ref run-limits-info 2)) - (max-concurrent-jobs (list-ref run-limits-info 3)) - (job-group-limit (list-ref run-limits-info 4)) - (prereqs-not-met (db:get-prereqs-not-met run-id waitons item-path mode: testmode)) - (fails (runs:calc-fails prereqs-not-met)) - (non-completed (runs:calc-not-completed prereqs-not-met))) - (debug:print-info 8 "have-resources: " have-resources " prereqs-not-met: " - (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) - (debug:print-info 4 "hed=" hed "\n test-record=" test-record "\n test-name: " test-name "\n item-path: " item-path "\n test-patts: " test-patts) - - ;; Don't know at this time if the test have been launched at some time in the past - ;; i.e. is this a re-launch? - (debug:print-info 4 "run-limits-info = " run-limits-info) - (cond ;; INNER COND #1 for a launchable test - ;; Check item path against item-patts - ((not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path)) ;; This test/itempath is not to be run - ;; else the run is stuck, temporarily or permanently - ;; but should check if it is due to lack of resources vs. prerequisites - (debug:print-info 1 "Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " test-patts) - ;; (thread-sleep! *global-delta*) - (if (not (null? tal)) - (loop (car tal)(cdr tal) reruns))) - ;; Registry has been started for this test but has not yet completed - ;; this should be rare, the case where there are only a couple of tests and the db is slow - ;; delay a short while and continue - ;; ((eq? (hash-table-ref/default test-registry (runs:make-full-test-name test-name item-path) #f) 'start) - ;; (thread-sleep! 0.01) - ;; (loop (car newtal)(cdr newtal) reruns)) - ;; count number of 'done, if more than 100 then skip on through. - (;; (and (< (length (filter (lambda (x)(eq? x 'done))(hash-table-values test-registry))) 100) ;; why get more than 200 ahead? - (not (hash-table-ref/default test-registry (runs:make-full-test-name test-name item-path) #f)) ;; ) ;; too many changes required. Implement later. - (debug:print-info 4 "Pre-registering test " test-name "/" item-path " to create placeholder" ) - ;; NEED TO THREADIFY THIS - (let ((th (make-thread (lambda () - (mutex-lock! registry-mutex) - (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'start) - (mutex-unlock! registry-mutex) - ;; If haven't done it before register a top level test if this is an itemized test - (if (not (eq? (hash-table-ref/default test-registry (runs:make-full-test-name test-name "") #f) 'done)) - (cdb:tests-register-test *runremote* run-id test-name "")) - (cdb:tests-register-test *runremote* run-id test-name item-path) - (mutex-lock! registry-mutex) - (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'done) - (mutex-unlock! registry-mutex)) - (conc test-name "/" item-path)))) - (thread-start! th)) - ;; TRY (thread-sleep! *global-delta*) - (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) - (loop (car newtal)(cdr newtal) reruns)) - ;; At this point *all* test registrations must be completed. - ((not (null? (filter (lambda (x)(eq? 'start x))(hash-table-values test-registry)))) - (debug:print-info 0 "Waiting on test registrations: " (string-intersperse - (filter (lambda (x) - (eq? (hash-table-ref/default test-registry x #f) 'start)) - (hash-table-keys test-registry)) - ", ")) - (thread-sleep! 0.1) - (loop hed tal reruns)) - ((not have-resources) ;; simply try again after waiting a second - (debug:print-info 1 "no resources to run new tests, waiting ...") - ;; Have gone back and forth on this but db starvation is an issue. - ;; wait one second before looking again to run jobs. - (thread-sleep! 1) ;; (+ 2 *global-delta*)) - ;; could have done hed tal here but doing car/cdr of newtal to rotate tests - (loop (car newtal)(cdr newtal) reruns)) - ((and have-resources - (or (null? prereqs-not-met) - (and (eq? testmode 'toplevel) - (null? non-completed)))) - (run:test run-id run-info key-vals runname keyvallst test-record flags #f) - (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'running) - (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) - ;; (thread-sleep! *global-delta*) - (if (not (null? tal)) - (loop (car tal)(cdr tal) reruns))) - (else ;; must be we have unmet prerequisites - (debug:print 4 "FAILS: " fails) - ;; If one or more of the prereqs-not-met are FAIL then we can issue - ;; a message and drop hed from the items to be processed. - (if (null? fails) - (begin - ;; couldn't run, take a breather - (debug:print-info 4 "Shouldn't really get here, race condition? Unable to launch more tests at this moment, killing time ...") - ;; (thread-sleep! (+ 0.01 *global-delta*)) ;; long sleep here - no resources, may as well be patient - ;; we made new tal by sticking hed at the back of the list - (loop (car newtal)(cdr newtal) reruns)) - ;; the waiton is FAIL so no point in trying to run hed ever again - (if (not (null? tal)) - (if (vector? hed) - (begin - (debug:print 1 "WARN: Dropping test " (db:test-get-testname hed) "/" (db:test-get-item-path hed) - " from the launch list as it has prerequistes that are FAIL") - (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) - ;; (thread-sleep! *global-delta*) - (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'removed) - (loop (car tal)(cdr tal) (cons hed reruns))) - (begin - (debug:print 1 "WARN: Test not processed correctly. Could be a race condition in your test implementation? " hed) ;; " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)") - (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) - ;; (thread-sleep! (+ 0.01 *global-delta*)) - (loop hed tal reruns))))))))) ;; END OF INNER COND - - ;; case where an items came in as a list been processed - ((and (list? items) ;; thus we know our items are already calculated - (not itemdat)) ;; and not yet expanded into the list of things to be done - (if (and (debug:debug-mode 1) ;; (>= *verbosity* 1) - (> (length items) 0) - (> (length (car items)) 0)) - (pp items)) - (for-each - (lambda (my-itemdat) - (let* ((new-test-record (let ((newrec (make-tests:testqueue))) - (vector-copy! test-record newrec) - newrec)) - (my-item-path (item-list->path my-itemdat))) - (if (tests:match test-patts hed my-item-path) ;; (patt-list-match my-item-path item-patts) ;; yes, we want to process this item, NOTE: Should not need this check here! - (let ((newtestname (runs:make-full-test-name hed my-item-path))) ;; test names are unique on testname/item-path - (tests:testqueue-set-items! new-test-record #f) - (tests:testqueue-set-itemdat! new-test-record my-itemdat) - (tests:testqueue-set-item_path! new-test-record my-item-path) - (hash-table-set! test-records newtestname new-test-record) - (set! tal (cons newtestname tal)))))) ;; since these are itemized create new test names testname/itempath - items) - (if (not (null? tal)) - (begin - (debug:print-info 4 "End of items list, looping with next after short delay") - ;; (thread-sleep! (+ 0.01 *global-delta*)) - (loop (car tal)(cdr tal) reruns)))) - - ;; if items is a proc then need to run items:get-items-from-config, get the list and loop - ;; - but only do that if resources exist to kick off the job - ((or (procedure? items)(eq? items 'have-procedure)) - (let ((can-run-more (runs:can-run-more-tests test-record max-concurrent-jobs))) - (if (and (list? can-run-more) - (car can-run-more)) - (let* ((prereqs-not-met (db:get-prereqs-not-met run-id waitons item-path mode: testmode)) - (fails (runs:calc-fails prereqs-not-met)) - (non-completed (runs:calc-not-completed prereqs-not-met))) - (debug:print-info 8 "can-run-more: " can-run-more - "\n testname: " hed - "\n prereqs-not-met: " (runs:pretty-string prereqs-not-met) - "\n non-completed: " (runs:pretty-string non-completed) - "\n fails: " (runs:pretty-string fails) - "\n testmode: " testmode - "\n num-retries: " num-retries - "\n (eq? testmode 'toplevel): " (eq? testmode 'toplevel) - "\n (null? non-completed): " (null? non-completed) - "\n reruns: " reruns - "\n items: " items - "\n can-run-more: " can-run-more) - ;; (thread-sleep! (+ 0.01 *global-delta*)) - (cond ;; INNER COND #2 - ((or (null? prereqs-not-met) ;; all prereqs met, fire off the test - ;; or, if it is a 'toplevel test and all prereqs not met are COMPLETED then launch - (and (eq? testmode 'toplevel) - (null? non-completed))) - (let ((test-name (tests:testqueue-get-testname test-record))) - (setenv "MT_TEST_NAME" test-name) ;; - (setenv "MT_RUNNAME" runname) - (set-megatest-env-vars run-id) ;; these may be needed by the launching process - (let ((items-list (items:get-items-from-config tconfig))) - (if (list? items-list) - (begin - (tests:testqueue-set-items! test-record items-list) - ;; (thread-sleep! *global-delta*) - (loop hed tal reruns)) - (begin - (debug:print 0 "ERROR: The proc from reading the setup did not yield a list - please report this") - (exit 1)))))) - ((null? fails) - (debug:print-info 4 "fails is null, moving on in the queue but keeping " hed " for now") - ;; only increment num-retries when there are no tests runing - (if (eq? 0 (list-ref can-run-more 1)) - (begin - ;; TRY (if (> num-retries 100) ;; first 100 retries are low time cost - ;; TRY (thread-sleep! (+ 2 *global-delta*)) - ;; TRY (thread-sleep! (+ 0.01 *global-delta*))) - (set! num-retries (+ num-retries 1)))) - (if (> num-retries max-retries) - (if (not (null? tal)) - (loop (car tal)(cdr tal) reruns)) - (loop (car newtal)(cdr newtal) reruns))) ;; an issue with prereqs not yet met? - ((and (not (null? fails))(eq? testmode 'normal)) - (debug:print-info 1 "test " hed " (mode=" testmode ") has failed prerequisite(s); " - (string-intersperse (map (lambda (t)(conc (db:test-get-testname t) ":" (db:test-get-state t)"/"(db:test-get-status t))) fails) ", ") - ", removing it from to-do list") - (if (not (null? tal)) - (begin - ;; (thread-sleep! *global-delta*) - (loop (car tal)(cdr tal)(cons hed reruns))))) - (else - (debug:print 8 "ERROR: No handler for this condition.") - ;; TRY (thread-sleep! (+ 1 *global-delta*)) - (loop (car newtal)(cdr newtal) reruns)))) ;; END OF IF CAN RUN MORE - - ;; if can't run more just loop with next possible test - (begin - (debug:print-info 4 "processing the case with a lambda for items or 'have-procedure. Moving through the queue without dropping " hed) - ;; (thread-sleep! (+ 2 *global-delta*)) - (loop (car newtal)(cdr newtal) reruns))))) ;; END OF (or (procedure? items)(eq? items 'have-procedure)) - - ;; this case should not happen, added to help catch any bugs - ((and (list? items) itemdat) - (debug:print 0 "ERROR: Should not have a list of items in a test and the itemspath set - please report this") - (exit 1)) - ((not (null? reruns)) - (let* ((newlst (tests:filter-non-runnable run-id tal test-records)) ;; i.e. not FAIL, WAIVED, INCOMPLETE, PASS, KILLED, - (junked (lset-difference equal? tal newlst))) - (debug:print-info 4 "full drop through, if reruns is less than 100 we will force retry them, reruns=" reruns ", tal=" tal) - (if (< num-retries max-retries) - (set! newlst (append reruns newlst))) - (set! num-retries (+ num-retries 1)) - ;; (thread-sleep! (+ 1 *global-delta*)) - (if (not (null? newlst)) - ;; since reruns have been tacked on to newlst create new reruns from junked - (loop (car newlst)(cdr newlst)(delete-duplicates junked))))) - ((not (null? tal)) - (debug:print-info 4 "I'm pretty sure I shouldn't get here.")) - (else - (debug:print-info 4 "Exiting loop with...\n hed=" hed "\n tal=" tal "\n reruns=" reruns)) - )))) ;; LET* ((test-record - - ;; we get here on "drop through" - loop for next test in queue - ;; FIXME!!!! THIS SHOULD NOT REQUIRE AN EXIT!!!!!!! - - (debug:print-info 1 "All tests launched") - (thread-sleep! 0.5) - ;; FIXME! This harsh exit should not be necessary.... - ;; (if (not *runremote*)(exit)) ;; - #f)) ;; return a #f as a hint that we are done - ;; Here we need to check that all the tests remaining to be run are eligible to run - ;; and are not blocked by failed - - Index: run-tests-queue-new.scm ================================================================== --- run-tests-queue-new.scm +++ run-tests-queue-new.scm @@ -1,337 +0,0 @@ -;; (use trace) -;; (trace -;; runs:queue-next-hed -;; runs:queue-next-tal -;; runs:queue-next-reg -;; ) - -;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... > -(define (runs:run-tests-queue-new run-id runname test-records keyvallst flags test-patts reglen) - ;; At this point the list of parent tests is expanded - ;; NB// Should expand items here and then insert into the run queue. - (debug:print 5 "test-records: " test-records ", keyvallst: " keyvallst " flags: " (hash-table->alist flags)) - (let ((run-info (cdb:remote-run db:get-run-info #f run-id)) - (key-vals (cdb:remote-run db:get-key-vals #f run-id)) - (sorted-test-names (tests:sort-by-priority-and-waiton test-records)) - (test-registry (make-hash-table)) - (registry-mutex (make-mutex)) - (num-retries 0) - (max-retries (config-lookup *configdat* "setup" "maxretries")) - (max-concurrent-jobs (let ((mcj (config-lookup *configdat* "setup" "max_concurrent_jobs"))) - (if (and mcj (string->number mcj)) - (string->number mcj) - 1)))) ;; length of the register queue ahead - (set! max-retries (if (and max-retries (string->number max-retries))(string->number max-retries) 100)) - (if (not (null? sorted-test-names)) - (let loop ((hed (car sorted-test-names)) - (tal (cdr sorted-test-names)) - (reg '()) ;; registered, put these at the head of tal - (reruns '())) - (if (not (null? reruns))(debug:print-info 4 "reruns=" reruns)) - ;; (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)) - (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 - (items (tests:testqueue-get-items test-record)) - (item-path (item-list->path itemdat)) - (newtal (append tal (list hed))) - (regfull (> (length reg) reglen))) - ;; (if (> (length reg) 10) - ;; (begin - ;; (set! tal (cons hed tal)) - ;; (set! hed (car reg)) - ;; (set! reg (cdr reg)) - ;; (set! newtal tal))) - (debug:print 6 - "test-name: " test-name - "\n hed: " hed - "\n itemdat: " itemdat - "\n items: " items - "\n item-path: " item-path - "\n waitons: " waitons - "\n num-retries: " num-retries - "\n tal: " tal - "\n reruns: " reruns) - - ;; check for hed in waitons => this would be circular, remove it and issue an - ;; error - (if (member test-name waitons) - (begin - (debug:print 0 "ERROR: test " test-name " has listed itself as a waiton, please correct this!") - (set! waiton (filter (lambda (x)(not (equal? x hed))) waitons)))) - - (cond ;; OUTER COND - ((not items) ;; when false the test is ok to be handed off to launch (but not before) - (let* ((run-limits-info (runs:can-run-more-tests test-record max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running - (have-resources (car run-limits-info)) - (num-running (list-ref run-limits-info 1)) - (num-running-in-jobgroup (list-ref run-limits-info 2)) - (max-concurrent-jobs (list-ref run-limits-info 3)) - (job-group-limit (list-ref run-limits-info 4)) - (prereqs-not-met (db:get-prereqs-not-met run-id waitons item-path mode: testmode)) - (fails (runs:calc-fails prereqs-not-met)) - (non-completed (runs:calc-not-completed prereqs-not-met))) - (debug:print-info 8 "have-resources: " have-resources " prereqs-not-met: " - (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) - (debug:print-info 4 "hed=" hed "\n test-record=" test-record "\n test-name: " test-name "\n item-path: " item-path "\n test-patts: " test-patts) - - ;; Don't know at this time if the test have been launched at some time in the past - ;; i.e. is this a re-launch? - (debug:print-info 4 "run-limits-info = " run-limits-info) - (cond ;; INNER COND #1 for a launchable test - ;; Check item path against item-patts - ((not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path)) ;; This test/itempath is not to be run - ;; else the run is stuck, temporarily or permanently - ;; but should check if it is due to lack of resources vs. prerequisites - (debug:print-info 1 "Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " test-patts) - ;; (thread-sleep! *global-delta*) - (if (not (null? tal)) - (loop (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - (runs:queue-next-reg tal reg reglen regfull) - reruns))) - ;; Registry has been started for this test but has not yet completed - ;; this should be rare, the case where there are only a couple of tests and the db is slow - ;; delay a short while and continue - ;; ((eq? (hash-table-ref/default test-registry (runs:make-full-test-name test-name item-path) #f) 'start) - ;; (thread-sleep! 0.01) - ;; (loop (car newtal)(cdr newtal) reruns)) - ;; count number of 'done, if more than 100 then skip on through. - ((not (hash-table-ref/default test-registry (runs:make-full-test-name test-name item-path) #f)) ;; ) ;; too many changes required. Implement later. - (debug:print-info 4 "Pre-registering test " test-name "/" item-path " to create placeholder" ) - (let ((th (make-thread (lambda () - (mutex-lock! registry-mutex) - (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'start) - (mutex-unlock! registry-mutex) - ;; If haven't done it before register a top level test if this is an itemized test - (if (not (eq? (hash-table-ref/default test-registry (runs:make-full-test-name test-name "") #f) 'done)) - (cdb:tests-register-test *runremote* run-id test-name "")) - (cdb:tests-register-test *runremote* run-id test-name item-path) - (mutex-lock! registry-mutex) - (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'done) - (mutex-unlock! registry-mutex)) - (conc test-name "/" item-path)))) - (thread-start! th)) - (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) - (if (and (null? tal)(null? reg)) - (loop hed tal reg reruns) - (loop (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - (let ((newl (append reg (list hed)))) - (if regfull - (cdr newl) - newl)) - reruns))) - ;; At this point hed test registration must be completed. - ((eq? (hash-table-ref/default test-registry (runs:make-full-test-name test-name item-path) #f) - 'start) - (debug:print-info 0 "Waiting on test registration(s): " (string-intersperse - (filter (lambda (x) - (eq? (hash-table-ref/default test-registry x #f) 'start)) - (hash-table-keys test-registry)) - ", ")) - (thread-sleep! 0.1) - (loop hed tal reg reruns)) - ((not have-resources) ;; simply try again after waiting a second - (debug:print-info 1 "no resources to run new tests, waiting ...") - ;; Have gone back and forth on this but db starvation is an issue. - ;; wait one second before looking again to run jobs. - (thread-sleep! 1) ;; (+ 2 *global-delta*)) - ;; could have done hed tal here but doing car/cdr of newtal to rotate tests - (loop (car newtal)(cdr newtal) reg reruns)) - ((and have-resources - (or (null? prereqs-not-met) - (and (eq? testmode 'toplevel) - (null? non-completed)))) - (run:test run-id run-info key-vals runname keyvallst test-record flags #f) - (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'running) - (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) - ;; (thread-sleep! *global-delta*) - (if (not (null? tal)) - (loop (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - (runs:queue-next-reg tal reg reglen regfull) - reruns))) - (else ;; must be we have unmet prerequisites - (debug:print 4 "FAILS: " fails) - ;; If one or more of the prereqs-not-met are FAIL then we can issue - ;; a message and drop hed from the items to be processed. - (if (null? fails) - (begin - ;; couldn't run, take a breather - (debug:print-info 4 "Shouldn't really get here, race condition? Unable to launch more tests at this moment, killing time ...") - ;; (thread-sleep! (+ 0.01 *global-delta*)) ;; long sleep here - no resources, may as well be patient - ;; we made new tal by sticking hed at the back of the list - (loop (car newtal)(cdr newtal) reg reruns)) - ;; the waiton is FAIL so no point in trying to run hed ever again - (if (not (null? tal)) - (if (vector? hed) - (begin - (debug:print 1 "WARN: Dropping test " (db:test-get-testname hed) "/" (db:test-get-item-path hed) - " from the launch list as it has prerequistes that are FAIL") - (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) - ;; (thread-sleep! *global-delta*) - (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'removed) - (loop (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - (runs:queue-next-reg tal reg reglen regfull) - (cons hed reruns))) - (begin - (debug:print 1 "WARN: Test not processed correctly. Could be a race condition in your test implementation? " hed) ;; " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)") - (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) - ;; (thread-sleep! (+ 0.01 *global-delta*)) - (loop hed tal reg reruns))))))))) ;; END OF INNER COND - - ;; case where an items came in as a list been processed - ((and (list? items) ;; thus we know our items are already calculated - (not itemdat)) ;; and not yet expanded into the list of things to be done - (if (and (debug:debug-mode 1) ;; (>= *verbosity* 1) - (> (length items) 0) - (> (length (car items)) 0)) - (pp items)) - (for-each - (lambda (my-itemdat) - (let* ((new-test-record (let ((newrec (make-tests:testqueue))) - (vector-copy! test-record newrec) - newrec)) - (my-item-path (item-list->path my-itemdat))) - (if (tests:match test-patts hed my-item-path) ;; (patt-list-match my-item-path item-patts) ;; yes, we want to process this item, NOTE: Should not need this check here! - (let ((newtestname (runs:make-full-test-name hed my-item-path))) ;; test names are unique on testname/item-path - (tests:testqueue-set-items! new-test-record #f) - (tests:testqueue-set-itemdat! new-test-record my-itemdat) - (tests:testqueue-set-item_path! new-test-record my-item-path) - (hash-table-set! test-records newtestname new-test-record) - (set! tal (cons newtestname tal)))))) ;; since these are itemized create new test names testname/itempath - items) - (if (not (null? tal)) - (begin - (debug:print-info 4 "End of items list, looping with next after short delay") - ;; (thread-sleep! (+ 0.01 *global-delta*)) - (loop (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - (runs:queue-next-reg tal reg reglen regfull) - reruns)))) - - ;; if items is a proc then need to run items:get-items-from-config, get the list and loop - ;; - but only do that if resources exist to kick off the job - ((or (procedure? items)(eq? items 'have-procedure)) - (let ((can-run-more (runs:can-run-more-tests test-record max-concurrent-jobs))) - (if (and (list? can-run-more) - (car can-run-more)) - (let* ((prereqs-not-met (db:get-prereqs-not-met run-id waitons item-path mode: testmode)) - (fails (runs:calc-fails prereqs-not-met)) - (non-completed (runs:calc-not-completed prereqs-not-met))) - (debug:print-info 8 "can-run-more: " can-run-more - "\n testname: " hed - "\n prereqs-not-met: " (runs:pretty-string prereqs-not-met) - "\n non-completed: " (runs:pretty-string non-completed) - "\n fails: " (runs:pretty-string fails) - "\n testmode: " testmode - "\n num-retries: " num-retries - "\n (eq? testmode 'toplevel): " (eq? testmode 'toplevel) - "\n (null? non-completed): " (null? non-completed) - "\n reruns: " reruns - "\n items: " items - "\n can-run-more: " can-run-more) - ;; (thread-sleep! (+ 0.01 *global-delta*)) - (cond ;; INNER COND #2 - ((or (null? prereqs-not-met) ;; all prereqs met, fire off the test - ;; or, if it is a 'toplevel test and all prereqs not met are COMPLETED then launch - (and (eq? testmode 'toplevel) - (null? non-completed))) - (let ((test-name (tests:testqueue-get-testname test-record))) - (setenv "MT_TEST_NAME" test-name) ;; - (setenv "MT_RUNNAME" runname) - (set-megatest-env-vars run-id) ;; these may be needed by the launching process - (let ((items-list (items:get-items-from-config tconfig))) - (if (list? items-list) - (begin - (tests:testqueue-set-items! test-record items-list) - ;; (thread-sleep! *global-delta*) - (loop hed tal reg reruns)) - (begin - (debug:print 0 "ERROR: The proc from reading the setup did not yield a list - please report this") - (exit 1)))))) - ((null? fails) - (debug:print-info 4 "fails is null, moving on in the queue but keeping " hed " for now") - ;; only increment num-retries when there are no tests runing - (if (eq? 0 (list-ref can-run-more 1)) - (begin - ;; TRY (if (> num-retries 100) ;; first 100 retries are low time cost - ;; TRY (thread-sleep! (+ 2 *global-delta*)) - ;; TRY (thread-sleep! (+ 0.01 *global-delta*))) - (set! num-retries (+ num-retries 1)))) - (if (> num-retries max-retries) - (if (not (null? tal)) - (loop (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - (runs:queue-next-reg tal reg reglen regfull) - reruns)) - (loop (car newtal)(cdr newtal) reg reruns))) ;; an issue with prereqs not yet met? - ((and (not (null? fails))(eq? testmode 'normal)) - (debug:print-info 1 "test " hed " (mode=" testmode ") has failed prerequisite(s); " - (string-intersperse (map (lambda (t)(conc (db:test-get-testname t) ":" (db:test-get-state t)"/"(db:test-get-status t))) fails) ", ") - ", removing it from to-do list") - (if (not (null? tal)) - (begin - ;; (thread-sleep! *global-delta*) - (loop (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - (runs:queue-next-reg tal reg reglen regfull) - (cons hed reruns))))) - (else - (debug:print 8 "ERROR: No handler for this condition.") - ;; TRY (thread-sleep! (+ 1 *global-delta*)) - (loop (car newtal)(cdr newtal) reg reruns)))) ;; END OF IF CAN RUN MORE - - ;; if can't run more just loop with next possible test - (begin - (debug:print-info 4 "processing the case with a lambda for items or 'have-procedure. Moving through the queue without dropping " hed) - ;; (thread-sleep! (+ 2 *global-delta*)) - (loop (car newtal)(cdr newtal) reg reruns))))) ;; END OF (or (procedure? items)(eq? items 'have-procedure)) - - ;; this case should not happen, added to help catch any bugs - ((and (list? items) itemdat) - (debug:print 0 "ERROR: Should not have a list of items in a test and the itemspath set - please report this") - (exit 1)) - ((not (null? reruns)) - (let* ((newlst (tests:filter-non-runnable run-id tal test-records)) ;; i.e. not FAIL, WAIVED, INCOMPLETE, PASS, KILLED, - (junked (lset-difference equal? tal newlst))) - (debug:print-info 4 "full drop through, if reruns is less than 100 we will force retry them, reruns=" reruns ", tal=" tal) - (if (< num-retries max-retries) - (set! newlst (append reruns newlst))) - (set! num-retries (+ num-retries 1)) - ;; (thread-sleep! (+ 1 *global-delta*)) - (if (not (null? newlst)) - ;; since reruns have been tacked on to newlst create new reruns from junked - (loop (car newlst)(cdr newlst) reg (delete-duplicates junked))))) - ((not (null? tal)) - (debug:print-info 4 "I'm pretty sure I shouldn't get here.")) - ((not (null? reg)) ;; could we get here with leftovers? - (debug:print-info 0 "Have leftovers!") - (loop (car reg)(cdr reg) '() reruns)) - (else - (debug:print-info 4 "Exiting loop with...\n hed=" hed "\n tal=" tal "\n reruns=" reruns)) - )))) ;; LET* ((test-record - - ;; we get here on "drop through" - loop for next test in queue - ;; FIXME!!!! THIS SHOULD NOT REQUIRE AN EXIT!!!!!!! - - (debug:print-info 1 "All tests launched") - (thread-sleep! 0.5) - ;; FIXME! This harsh exit should not be necessary.... - ;; (if (not *runremote*)(exit)) ;; - #f)) ;; return a #f as a hint that we are done - ;; Here we need to check that all the tests remaining to be run are eligible to run - ;; and are not blocked by failed - Index: run_records.scm ================================================================== --- run_records.scm +++ run_records.scm @@ -7,10 +7,25 @@ ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== +(define-inline (runs:runrec-make-record) (make-vector 13)) +(define-inline (runs:runrec-get-target vec)(vector-ref vec 0)) ;; a/b/c +(define-inline (runs:runrec-get-runname vec)(vector-ref vec 1)) ;; string +(define-inline (runs:runrec-testpatt vec)(vector-ref vec 2)) ;; a,b/c,d% +(define-inline (runs:runrec-keys vec)(vector-ref vec 3)) ;; (key1 key2 ...) +(define-inline (runs:runrec-keyvals vec)(vector-ref vec 4)) ;; ((key1 val1)(key2 val2) ...) +(define-inline (runs:runrec-environment vec)(vector-ref vec 5)) ;; environment, alist key val +(define-inline (runs:runrec-mconfig vec)(vector-ref vec 6)) ;; megatest.config +(define-inline (runs:runrec-runconfig vec)(vector-ref vec 7)) ;; runconfigs.config +(define-inline (runs:runrec-serverdat vec)(vector-ref vec 8)) ;; (host port) +(define-inline (runs:runrec-transport vec)(vector-ref vec 9)) ;; 'http +(define-inline (runs:runrec-db vec)(vector-ref vec 10)) ;; (if 'fs) +(define-inline (runs:runrec-top-path vec)(vector-ref vec 11)) ;; *toppath* +(define-inline (runs:runrec-run_id vec)(vector-ref vec 12)) ;; run-id + (define-inline (test:get-id vec) (vector-ref vec 0)) (define-inline (test:get-run_id vec) (vector-ref vec 1)) (define-inline (test:get-test-name vec)(vector-ref vec 2)) (define-inline (test:get-state vec) (vector-ref vec 3)) (define-inline (test:get-status vec) (vector-ref vec 4)) Index: runconfig.scm ================================================================== --- runconfig.scm +++ runconfig.scm @@ -8,24 +8,19 @@ (declare (unit runconfig)) (declare (uses common)) (include "common_records.scm") - - -;; (define (setup-env-defaults db fname run-id already-seen #!key (environ-patt #f)(change-env #t)) -(define (setup-env-defaults fname run-id already-seen keys keyvals #!key (environ-patt #f)(change-env #t)) - (let* (;; (keys (db:get-keys db)) - ;; (keyvals (if run-id (db:get-key-vals db run-id) #f)) - (thekey (if keyvals (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/") - (if (args:get-arg "-reqtarg") - (args:get-arg "-reqtarg") - (if (args:get-arg "-target") - (args:get-arg "-target") - (begin - (debug:print 0 "ERROR: setup-env-defaults called with no run-id or -target or -reqtarg") - "nothing matches this I hope"))))) +(define (setup-env-defaults fname run-id already-seen keyvals #!key (environ-patt #f)(change-env #t)) + (let* ((keys (map car keyvals)) + (thekey (if keyvals (string-intersperse (map (lambda (x)(if x x "-na-")) (map cadr keyvals)) "/") + (or (args:get-arg "-reqtarg") + (args:get-arg "-target") + (get-environment-variable "MT_TARGET") + (begin + (debug:print 0 "ERROR: setup-env-defaults called with no run-id or -target or -reqtarg") + "nothing matches this I hope")))) ;; Why was system disallowed in the reading of the runconfigs file? ;; NOTE: Should be setting env vars based on (target|default) (confdat (read-config fname #f #t environ-patt: environ-patt sections: (list "default" thekey))) (whatfound (make-hash-table)) (finaldat (make-hash-table)) @@ -32,14 +27,14 @@ (sections (list "default" thekey))) (if (not *target*)(set! *target* thekey)) ;; may save a db access or two but repeats db:get-target code (debug:print 4 "Using key=\"" thekey "\"") (if change-env - (for-each - (lambda (key val) - (setenv (vector-ref key 0) val)) - keys keyvals)) + (for-each ;; NB// This can be simplified with new content of keyvals having all that is needed. + (lambda (keyval) + (setenv (car keyval)(cadr keyval))) + keyvals)) (for-each (lambda (section) (let ((section-dat (hash-table-ref/default confdat section #f))) (if section-dat @@ -59,20 +54,21 @@ sections) (debug:print 2 "---") (set! *already-seen-runconfig-info* #t))) finaldat)) -(define (set-run-config-vars run-id keys keyvals targ-from-db) - (push-directory *toppath*) +(define (set-run-config-vars run-id keyvals targ-from-db) + (push-directory *toppath*) ;; the push/pop doesn't appear to do anything ... (let ((runconfigf (conc *toppath* "/runconfigs.config")) (targ (or (args:get-arg "-target") (args:get-arg "-reqtarg") - targ-from-db))) + targ-from-db + (get-environment-variable "MT_TARGET")))) (pop-directory) (if (file-exists? runconfigf) - (setup-env-defaults runconfigf run-id #t keys keyvals + (setup-env-defaults runconfigf run-id #t keyvals environ-patt: (conc "(default" (if targ (conc "|" targ ")") ")"))) (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)))) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -1,7 +1,7 @@ -;; Copyright 2006-2012, Matthew Welland. +;; Copyright 2006-2013, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the @@ -18,124 +18,133 @@ (declare (uses common)) (declare (uses items)) (declare (uses runconfig)) (declare (uses tests)) (declare (uses server)) +(declare (uses mt)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") -;; runs:get-runs-by-patt -;; get runs by list of criteria -;; register a test run with the db -;; -;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-row runinfo)) -;; to extract info from the structure returned -;; -(define (runs:get-runs-by-patt db keys runnamepatt) ;; test-name) - (let* ((keyvallst (keys->vallist keys)) - (tmp (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time"))) - (keystr (car tmp)) - (header (cadr tmp)) - (res '()) - (key-patt "") - (runwildtype (if (substring-index "%" runnamepatt) "like" "glob")) - (qry-str #f)) - (for-each (lambda (keyval) - (let* ((key (vector-ref keyval 0)) - (fulkey (conc ":" key)) - (patt (args:get-arg fulkey)) - (wildtype (if (substring-index "%" patt) "like" "glob"))) - (if patt - (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'")) - (begin - (debug:print 0 "ERROR: searching for runs with no pattern set for " fulkey) - (exit 6))))) - keys) - (set! qry-str (conc "SELECT " keystr " FROM runs WHERE runname " runwildtype " ? " key-patt ";")) - (debug:print-info 4 "runs:get-runs-by-patt qry=" qry-str " " runnamepatt) - (sqlite3:for-each-row - (lambda (a . r) - (set! res (cons (list->vector (cons a r)) res))) - db - qry-str - runnamepatt) - (vector header res))) - (define (runs:test-get-full-path test) (let* ((testname (db:test-get-testname test)) (itempath (db:test-get-item-path test))) (conc testname (if (equal? itempath "") "" (conc "(" itempath ")"))))) -(define (db:get-run-key-val db run-id key) - (let ((res #f)) - (sqlite3:for-each-row - (lambda (val) - (set! res val)) - db - (conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;") - run-id) - res)) - -(define (db:get-run-name-from-id db run-id) - (let ((res #f)) - (sqlite3:for-each-row - (lambda (runname) - (set! res runname)) - db - "SELECT runname FROM runs WHERE id=?;" - run-id) - res)) - -(define (set-megatest-env-vars run-id) - (let ((keys (cdb:remote-run db:get-keys #f)) - (vals (hash-table-ref/default *env-vars-by-run-id* run-id #f))) +;; This is the *new* methodology. One record to inform them and in the chaos, organise them. +;; +(define (runs:create-run-record) + (let* ((mconfig (if *configdat* + *configdat* + (if (setup-for-run) + *configdat* + (begin + (debug:print 0 "ERROR: Called setup in a non-megatest area, exiting") + (exit 1))))) + (runrec (runs:runrec-make-record)) + (target (or (args:get-arg "-reqtarg") + (args:get-arg "-target"))) + (runname (or (args:get-arg ":runname") + (args:get-arg "-runname"))) + (testpatt (or (args:get-arg "-testpatt") + (args:get-arg "-runtests"))) + (keys (keys:config-get-fields mconfig)) + (keyvals (keys:target->keyval keys target)) + (toppath *toppath*) + (envdat keyvals) ;; initial values start with keyvals + (runconfig #f) + (serverdat (if (args:get-arg "-server") + *runremote* + #f)) ;; to be used later + (transport (or (args:get-arg "-transport") 'http)) + (db (if (and mconfig + (or (args:get-arg "-server") + (eq? transport 'fs))) + (open-db) + #f)) + (run-id #f)) + ;; Set all the environment vars we know so far, start with keys + (for-each (lambda (keyval) + (setenv (car keyval)(cadr keyval))) + keyvals) + ;; Set up various and sundry known vars here + (setenv "MT_RUN_AREA_HOME" toppath) + (setenv "MT_RUNNAME" runname) + (setenv "MT_TARGET" target) + (set! envdat (append + envdat + (list (list "MT_RUN_AREA_HOME" toppath) + (list "MT_RUNNAME" runname) + (list "MT_TARGET" target)))) + ;; Now can read the runconfigs file + ;; + (set! runconfig (read-config (conc *toppath* "/runconfigs.config") #f #t sections: (list "default" target))) + (if (not (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f)) + (begin + (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf) + (if db (sqlite3:finalize! db)) + (exit 1))) + ;; Now have runconfigs data loaded, set environment vars + (for-each (lambda (section) + (for-each (lambda (varval) + (set! envdat (append envdat (list varval))) + (setenv (car varval)(cadr varval))) + (configf:get-section runconfig section))) + (list "default" target)) + (vector target runname testpatt keys keyvals envdat mconfig runconfig serverdat transport db toppath run-id))) + +(define (set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)) + (let* ((target (or (args:get-arg "-reqtarg") + (args:get-arg "-target") + (get-environment-variable "MT_TARGET"))) + (keys (if inkeys inkeys (cdb:remote-run db:get-keys #f))) + (keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target))) + (vals (hash-table-ref/default *env-vars-by-run-id* run-id #f))) ;; get the info from the db and put it in the cache (if (not vals) (let ((ht (make-hash-table))) (hash-table-set! *env-vars-by-run-id* run-id ht) (set! vals ht) (for-each (lambda (key) - (hash-table-set! vals key (cdb:remote-run db:get-run-key-val #f run-id key))) - keys))) + (hash-table-set! vals (car key) (cadr key))) ;; (cdb:remote-run db:get-run-key-val #f run-id (car key)))) + keyvals))) ;; from the cached data set the vars (hash-table-for-each vals (lambda (key val) - (debug:print 2 "setenv " (key:get-fieldname key) " " val) - (setenv (key:get-fieldname key) val))) + (debug:print 2 "setenv " key " " val) + (setenv key val))) + (if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target)) (alist->env-vars (hash-table-ref/default *configdat* "env-override" '())) ;; Lets use this as an opportunity to put MT_RUNNAME in the environment - (setenv "MT_RUNNAME" (cdb:remote-run db:get-run-name-from-id #f run-id)) - (setenv "MT_RUN_AREA_HOME" *toppath*) - )) + (setenv "MT_RUNNAME" (if inrunname inrunname (cdb:remote-run db:get-run-name-from-id #f run-id))) + (setenv "MT_RUN_AREA_HOME" *toppath*))) (define (set-item-env-vars itemdat) (for-each (lambda (item) (debug:print 2 "setenv " (car item) " " (cadr item)) (setenv (car item) (cadr item))) itemdat)) -(define *last-num-running-tests* 0) - ;; Every time can-run-more-tests is called increment the delay -;; if the cou +;; +;; NOTE: We run this server-side!! Do not use this global except in the runs:can-run-more-tests routine +;; +(define *last-num-running-tests* 0) (define *runs:can-run-more-tests-count* 0) -(define (runs:shrink-can-run-more-tests-count) +(define (runs:shrink-can-run-more-tests-count) ;; the db is a dummy var so we can use cdb:remote-run (set! *runs:can-run-more-tests-count* 0)) ;; (/ *runs:can-run-more-tests-count* 2))) -(define (runs:can-run-more-tests test-record max-concurrent-jobs) +(define (runs:can-run-more-tests jobgroup max-concurrent-jobs) (thread-sleep! (cond ((> *runs:can-run-more-tests-count* 20) 2);; obviously haven't had any work to do for a while (else 0))) - (let* ((tconfig (tests:testqueue-get-testconfig test-record)) - (jobgroup (config-lookup tconfig "requirements" "jobgroup")) - (num-running (cdb:remote-run db:get-count-tests-running #f)) + (let* ((num-running (cdb:remote-run db:get-count-tests-running #f)) (num-running-in-jobgroup (cdb:remote-run db:get-count-tests-running-in-jobgroup #f jobgroup)) (job-group-limit (config-lookup *configdat* "jobgroups" jobgroup))) (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)) @@ -159,50 +168,33 @@ " in " jobgroup " exceeded, will not run " (tests:testqueue-get-testname test-record)) #t) (else #f)))) (list (not can-not-run-more) num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit))))) -;;====================================================================== -;; New methodology. These routines will replace the above in time. For -;; now the code is duplicated. This stuff is initially used in the monitor -;; based code. -;;====================================================================== - - -;; This is a duplicate of run-tests (which has been deprecated). Use this one instead of run tests. -;; keyvals. -;; ;; test-names: Comma separated patterns same as test-patts but used in selection ;; of tests to run. The item portions are not respected. ;; FIXME: error out if /patt specified ;; -(define (runs:run-tests target runname test-names test-patts user flags) +(define (runs:run-tests target runname test-patts user flags) ;; test-names (common:clear-caches) ;; clear all caches - (let* ((db #f) - (keys (cdb:remote-run db:get-keys #f)) - (keyvallst (keys:target->keyval keys target)) - (run-id (cdb:remote-run db:register-run #f keys keyvallst runname "new" "n/a" user)) ;; test-name))) - (keyvals (if run-id (cdb:remote-run db:get-key-vals #f run-id) #f)) + (let* ((keys (keys:config-get-fields *configdat*)) + (keyvals (keys:target->keyval keys target)) + (run-id (cdb:remote-run db:register-run #f keyvals runname "new" "n/a" user)) ;; test-name))) (deferred '()) ;; delay running these since they have a waiton clause - ;; keepgoing is the defacto modality now, will add hit-n-run a bit later - ;; (keepgoing (hash-table-ref/default flags "-keepgoing" #f)) (runconfigf (conc *toppath* "/runconfigs.config")) (required-tests '()) - (test-records (make-hash-table))) - - (set-megatest-env-vars run-id) ;; these may be needed by the launching process - + (test-records (make-hash-table)) + (all-test-names (tests:get-valid-tests *toppath* "%"))) ;; we need a list of all valid tests to check waiton names + (set-megatest-env-vars run-id inkeys: keys) ;; these may be needed by the launching process (if (file-exists? runconfigf) - (setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keys keyvals "pre-launch-env-vars") + (setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals "pre-launch-env-vars") (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)) ;; look up all tests matching the comma separated list of globs in ;; test-patts (using % as wildcard) - (set! test-names (tests:get-valid-tests *toppath* test-names)) - (set! test-names (delete-duplicates test-names)) - + (set! test-names (delete-duplicates (tests:get-valid-tests *toppath* test-patts))) (debug:print-info 0 "test names " test-names) ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if ;; -keepgoing is specified (if (eq? *passnum* 0) @@ -212,34 +204,42 @@ ;; on test A but test B reached the point on being registered as NOT_STARTED and test ;; A failed for some reason then on re-run using -keepgoing the run can never complete. (cdb:delete-tests-in-state *runremote* run-id "NOT_STARTED") (cdb:remote-run db:set-tests-state-status #f run-id test-names #f "FAIL" "NOT_STARTED" "FAIL"))) - ;; from here on out the db will be opened and closed on every call runs:run-tests-queue - ;; (sqlite3:finalize! db) ;; now add non-directly referenced dependencies (i.e. waiton) + ;;====================================================================== + ;; refactoring this block into tests:get-full-data + ;;====================================================================== (if (not (null? test-names)) (let loop ((hed (car test-names)) (tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc - (debug:print-info 4 "hed=" hed " at top of loop") + (change-directory *toppath*) ;; PLEASE OPTIMIZE ME!!! I think this should be a no-op but there are several places where change-directories could be happening. (let* ((config (tests:get-testconfig hed 'return-procs)) (waitons (let ((instr (if config (config-lookup config "requirements" "waiton") (begin ;; No config means this is a non-existant test (debug:print 0 "ERROR: non-existent required test \"" hed "\"") - (if db (sqlite3:finalize! db)) (exit 1))))) (debug:print-info 8 "waitons string is " instr) - (string-split (cond - ((procedure? instr) - (let ((res (instr))) - (debug:print-info 8 "waiton procedure results in string " res " for test " hed) - res)) - ((string? instr) instr) - (else - ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 "ERROR: something went wrong in processing waitons for test " hed) - "")))))) + (let ((newwaitons + (string-split (cond + ((procedure? instr) + (let ((res (instr))) + (debug:print-info 8 "waiton procedure results in string " res " for test " hed) + res)) + ((string? instr) instr) + (else + ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 "ERROR: something went wrong in processing waitons for test " hed) + ""))))) + (filter (lambda (x) + (if (member x all-test-names) + #t + (begin + (debug:print 0 "ERROR: test " hed " has unrecognised waiton testname " x) + #f))) + newwaitons))))) (debug:print-info 8 "waitons: " waitons) ;; check for hed in waitons => this would be circular, remove it and issue an ;; error (if (member hed waitons) (begin @@ -272,11 +272,11 @@ (append (if (list? items) items '()) (if (list? itemstable) itemstable '()))) 'have-procedure) ((or (list? items)(list? itemstable)) ;; calc now (debug:print-info 4 "items and itemstable are lists, calc now\n" - " items: " items " itemstable: " itemstable) + " items: " items " itemstable: " itemstable) (items:get-items-from-config config)) (else #f))) ;; not iterated #f ;; itemsdat 5 #f ;; spare - used for item-path ))) @@ -293,16 +293,428 @@ (if (not (null? required-tests)) (debug:print-info 1 "Adding " required-tests " to the run queue")) ;; NOTE: these are all parent tests, items are not expanded yet. (debug:print-info 4 "test-records=" (hash-table->alist test-records)) - (let ((reglen (any->number (configf:lookup *configdat* "setup" "runqueue")))) - (if reglen - (runs:run-tests-queue-new run-id runname test-records keyvallst flags test-patts reglen) - (runs:run-tests-queue-classic run-id runname test-records keyvallst flags test-patts))) + (let ((reglen (configf:lookup *configdat* "setup" "runqueue"))) + (if (> (length (hash-table-keys test-records)) 0) + (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen)) + (debug:print-info 0 "No tests to run"))) (debug:print-info 4 "All done by here"))) + +;; loop logic. These are used in runs:run-tests-queue to make it a bit more readable. +;; +;; If reg not full and have items in tal then loop with (car tal)(cdr tal) reg reruns +;; If reg is full (i.e. length >= n +;; loop with (car reg) tal (cdr reg) reruns +;; If tal is empty +;; but have items in reg; loop with (car reg)(cdr reg) '() reruns +;; If reg is empty => all done + +(define (runs:queue-next-hed tal reg n regfull) + (if regfull + (car reg) + (if (null? tal) ;; tal is used up, pop from reg + (car reg) + (car tal)))) + +;; (cond +;; ((and regfull (null? reg)(not (null? tal))) (car tal)) +;; ((and regfull (not (null? reg))) (car reg)) +;; ((and (not regfull)(null? tal)(not (null? reg))) (car reg)) +;; ((and (not regfull)(not (null? tal))) (car tal)) +;; (else +;; (debug:print 0 "ERROR: runs:queue-next-hed, tal=" tal ", reg=" reg ", n=" n ", regfull=" regfull) +;; #f))) + +(define (runs:queue-next-tal tal reg n regfull) + (if regfull + tal + (if (null? tal) ;; must transfer from reg + (cdr reg) + (cdr tal)))) + +(define (runs:queue-next-reg tal reg n regfull) + (if regfull + (cdr reg) + (if (null? tal) ;; if tal is null and reg not full then '() as reg contents moved to tal + '() + reg))) + +(define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen) + (let* ((loop-list (list hed tal reg reruns)) + (prereqs-not-met (mt:get-prereqs-not-met run-id waitons item-path mode: testmode)) + (fails (runs:calc-fails prereqs-not-met)) + (non-completed (runs:calc-not-completed prereqs-not-met))) + (debug:print-info 4 "START OF INNER COND #2 " + "\n can-run-more: " can-run-more + "\n testname: " hed + "\n prereqs-not-met: " (runs:pretty-string prereqs-not-met) + "\n non-completed: " (runs:pretty-string non-completed) + "\n fails: " (runs:pretty-string fails) + "\n testmode: " testmode + "\n (eq? testmode 'toplevel): " (eq? testmode 'toplevel) + "\n (null? non-completed): " (null? non-completed) + "\n reruns: " reruns + "\n items: " items + "\n can-run-more: " can-run-more) + (cond + ;; all prereqs met, fire off the test + ;; or, if it is a 'toplevel test and all prereqs not met are COMPLETED then launch + ((or (null? prereqs-not-met) + (and (eq? testmode 'toplevel) + (null? non-completed))) + (debug:print-info 4 "runs:expand-items: (or (null? prereqs-not-met) (and (eq? testmode 'toplevel)(null? non-completed)))") + (let ((test-name (tests:testqueue-get-testname test-record))) + (setenv "MT_TEST_NAME" test-name) ;; + (setenv "MT_RUNNAME" runname) + (set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process + (let ((items-list (items:get-items-from-config tconfig))) + (if (list? items-list) + (begin + (tests:testqueue-set-items! test-record items-list) + (list hed tal reg reruns)) + (begin + (debug:print 0 "ERROR: The proc from reading the setup did not yield a list - please report this") + (exit 1)))))) + + ((null? fails) + (debug:print-info 4 "fails is null, moving on in the queue but keeping " hed " for now") + ;; num-retries code was here + ;; we use this opportunity to move contents of reg to tal + (list (car newtal)(append (cdr newtal) reg) '() reruns)) ;; an issue with prereqs not yet met? + + ((and (not (null? fails))(eq? testmode 'normal)) + (debug:print-info 1 "test " hed " (mode=" testmode ") has failed prerequisite(s); " + (string-intersperse (map (lambda (t)(conc (db:test-get-testname t) ":" (db:test-get-state t)"/"(db:test-get-status t))) fails) ", ") + ", removing it from to-do list") + (if (or (not (null? reg))(not (null? tal))) + (list (runs:queue-next-hed tal reg reglen regfull) + (runs:queue-next-tal tal reg reglen regfull) + (runs:queue-next-reg tal reg reglen regfull) + (cons hed reruns)) + #f)) ;; #f flags do not loop + + (else + (debug:print 4 "ERROR: No handler for this condition.") + (list (car newtal)(cdr newtal) reg reruns))))) + +(define (runs:process-expanded-tests hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal) + (let* ((run-limits-info (runs:can-run-more-tests jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running + (have-resources (car run-limits-info)) + (num-running (list-ref run-limits-info 1)) + (num-running-in-jobgroup (list-ref run-limits-info 2)) + (max-concurrent-jobs (list-ref run-limits-info 3)) + (job-group-limit (list-ref run-limits-info 4)) + (prereqs-not-met (mt:get-prereqs-not-met run-id waitons item-path mode: testmode)) + (fails (runs:calc-fails prereqs-not-met)) + (non-completed (runs:calc-not-completed prereqs-not-met)) + (loop-list (list hed tal reg reruns))) + (debug:print-info 4 "have-resources: " have-resources " prereqs-not-met: (" + (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) + + ;; Don't know at this time if the test have been launched at some time in the past + ;; i.e. is this a re-launch? + (debug:print-info 4 "run-limits-info = " run-limits-info) + + (cond + + ;; Check item path against item-patts, + ;; + ((not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests)) ;; This test/itempath is not to be run + ;; else the run is stuck, temporarily or permanently + ;; but should check if it is due to lack of resources vs. prerequisites + (debug:print-info 1 "Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " test-patts) + (if (or (not (null? tal))(not (null? reg))) + (list (runs:queue-next-hed tal reg reglen regfull) + (runs:queue-next-tal tal reg reglen regfull) + (runs:queue-next-reg tal reg reglen regfull) + reruns) + #f)) + + ;; Register tests + ;; + ((not (hash-table-ref/default test-registry (runs:make-full-test-name test-name item-path) #f)) + (debug:print-info 4 "Pre-registering test " test-name "/" item-path " to create placeholder" ) + (let ((th (make-thread (lambda () + (mutex-lock! registry-mutex) + (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'start) + (mutex-unlock! registry-mutex) + ;; If haven't done it before register a top level test if this is an itemized test + (if (not (eq? (hash-table-ref/default test-registry (runs:make-full-test-name test-name "") #f) 'done)) + (cdb:tests-register-test *runremote* run-id test-name "")) + (cdb:tests-register-test *runremote* run-id test-name item-path) + (mutex-lock! registry-mutex) + (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'done) + (mutex-unlock! registry-mutex)) + (conc test-name "/" item-path)))) + (thread-start! th)) + (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) + (if (and (null? tal)(null? reg)) + (list hed tal (append reg (list hed)) reruns) + (list (runs:queue-next-hed tal reg reglen regfull) + (runs:queue-next-tal tal reg reglen regfull) + ;; NB// Here we are building reg as we register tests + ;; if regfull we must pop the front item off reg + (if regfull + (append (cdr reg) (list hed)) + (append reg (list hed))) + reruns))) + + ;; At this point hed test registration must be completed. + ;; + ((eq? (hash-table-ref/default test-registry (runs:make-full-test-name test-name item-path) #f) + 'start) + (debug:print-info 0 "Waiting on test registration(s): " + (string-intersperse + (filter (lambda (x) + (eq? (hash-table-ref/default test-registry x #f) 'start)) + (hash-table-keys test-registry)) + ", ")) + (thread-sleep! 0.1) + (list hed tal reg reruns)) + + ;; If no resources are available just kill time and loop again + ;; + ((not have-resources) ;; simply try again after waiting a second + (debug:print-info 1 "no resources to run new tests, waiting ...") + ;; Have gone back and forth on this but db starvation is an issue. + ;; wait one second before looking again to run jobs. + (thread-sleep! 1) + ;; could have done hed tal here but doing car/cdr of newtal to rotate tests + (list (car newtal)(cdr newtal) reg reruns)) + + ;; 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) + (null? non-completed)))) + (run:test run-id run-info keyvals runname test-record flags #f test-registry) + (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'running) + (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) + ;; (thread-sleep! *global-delta*) + (if (or (not (null? tal))(not (null? reg))) + (list (runs:queue-next-hed tal reg reglen regfull) + (runs:queue-next-tal tal reg reglen regfull) + (runs:queue-next-reg tal reg reglen regfull) + reruns) + #f)) + + ;; must be we have unmet prerequisites + ;; + (else + (debug:print 4 "FAILS: " fails) + ;; If one or more of the prereqs-not-met are FAIL then we can issue + ;; a message and drop hed from the items to be processed. + (if (null? fails) + (begin + ;; couldn't run, take a breather + (debug:print-info 4 "Shouldn't really get here, race condition? Unable to launch more tests at this moment, killing time ...") + ;; (thread-sleep! (+ 0.01 *global-delta*)) ;; long sleep here - no resources, may as well be patient + ;; we made new tal by sticking hed at the back of the list + (list (car newtal)(cdr newtal) reg reruns)) + ;; the waiton is FAIL so no point in trying to run hed ever again + (if (or (not (null? reg))(not (null? tal))) + (if (vector? hed) + (begin + (debug:print 1 "WARN: Dropping test " (db:test-get-testname hed) "/" (db:test-get-item-path hed) + " from the launch list as it has prerequistes that are FAIL") + (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) + ;; (thread-sleep! *global-delta*) + (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'removed) + (list (runs:queue-next-hed tal reg reglen regfull) + (runs:queue-next-tal tal reg reglen regfull) + (runs:queue-next-reg tal reg reglen regfull) + (cons hed reruns))) + (begin + (debug:print 1 "WARN: Test not processed correctly. Could be a race condition in your test implementation? " hed) ;; " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)") + (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) + (list hed tal reg reruns))))))))) + +;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... > +(define (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests reglen-in) + ;; At this point the list of parent tests is expanded + ;; NB// Should expand items here and then insert into the run queue. + (debug:print 5 "test-records: " test-records ", flags: " (hash-table->alist flags)) + (let ((run-info (cdb:remote-run db:get-run-info #f run-id)) + (tests-info (mt:get-tests-for-run run-id #f '() '())) ;; qryvals: "id,testname,item_path")) + (sorted-test-names (tests:sort-by-priority-and-waiton test-records)) + (test-registry (make-hash-table)) + (registry-mutex (make-mutex)) + (num-retries 0) + (max-retries (config-lookup *configdat* "setup" "maxretries")) + (max-concurrent-jobs (let ((mcj (config-lookup *configdat* "setup" "max_concurrent_jobs"))) + (if (and mcj (string->number mcj)) + (string->number mcj) + 1))) ;; length of the register queue ahead + (reglen (if (number? reglen-in) reglen-in 1))) + + ;; Initialize the test-registery hash with tests that already have a record + ;; convert state to symbol and use that as the hash value + (for-each (lambda (trec) + (let ((id (db:test-get-id trec)) + (tn (db:test-get-testname trec)) + (ip (db:test-get-item-path trec)) + (st (db:test-get-state trec))) + (hash-table-set! test-registry (runs:make-full-test-name tn ip) (string->symbol st)))) + tests-info) + (set! max-retries (if (and max-retries (string->number max-retries))(string->number max-retries) 100)) + + (let loop ((hed (car sorted-test-names)) + (tal (cdr sorted-test-names)) + (reg '()) ;; registered, put these at the head of tal + (reruns '())) + (if (not (null? reruns))(debug:print-info 4 "reruns=" reruns)) + ;; (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")) + (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 + (items (tests:testqueue-get-items test-record)) + (item-path (item-list->path itemdat)) + (tfullname (runs:make-full-test-name test-name item-path)) + (newtal (append tal (list hed))) + (regfull (>= (length reg) reglen))) + + ;; Fast skip of tests that are already "COMPLETED" + ;; + (if (equal? (hash-table-ref/default test-registry tfullname #f) 'COMPLETED) + (begin + (debug:print-info 0 "Skipping COMPLETED test " tfullname) + (if (or (not (null? tal))(not (null? reg))) + (loop (runs:queue-next-hed tal reg reglen regfull) + (runs:queue-next-tal tal reg reglen regfull) + (runs:queue-next-reg tal reg reglen regfull) + reruns)))) + ;; (loop (car tal)(cdr tal) reg reruns)))) + + (debug:print 4 "TOP OF LOOP => " + "test-name: " test-name + "\n test-record " test-record + "\n hed: " hed + "\n itemdat: " itemdat + "\n items: " items + "\n item-path: " item-path + "\n waitons: " waitons + "\n num-retries: " num-retries + "\n tal: " tal + "\n reruns: " reruns + "\n regfull: " regfull + "\n reglen: " reglen + "\n length reg: " (length reg) + "\n reg: " reg) + + ;; check for hed in waitons => this would be circular, remove it and issue an + ;; error + (if (member test-name waitons) + (begin + (debug:print 0 "ERROR: test " test-name " has listed itself as a waiton, please correct this!") + (set! waiton (filter (lambda (x)(not (equal? x hed))) waitons)))) + + (cond + + ;; items is #f then the test is ok to be handed off to launch (but not before) + ;; + ((not items) + (debug:print-info 4 "OUTER COND: (not items)") + (if (and (not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests)) + (not (null? tal))) + (loop (car tal)(cdr tal) reg reruns)) + (let ((loop-list (runs:process-expanded-tests hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal))) + (if loop-list (apply loop loop-list)))) + + ;; items processed into a list but not came in as a list been processed + ;; + ((and (list? items) ;; thus we know our items are already calculated + (not itemdat)) ;; and not yet expanded into the list of things to be done + (debug:print-info 4 "OUTER COND: (and (list? items)(not itemdat))") + ;; Must determine if the items list is valid. Discard the test if it is not. + (if (and (list? items) + (> (length items) 0) + (and (list? (car items)) + (> (length (car items)) 0)) + (debug:debug-mode 1)) + (pp items)) + + (for-each + (lambda (my-itemdat) + (let* ((new-test-record (let ((newrec (make-tests:testqueue))) + (vector-copy! test-record newrec) + newrec)) + (my-item-path (item-list->path my-itemdat))) + (if (tests:match test-patts hed my-item-path required: required-tests) ;; (patt-list-match my-item-path item-patts) ;; yes, we want to process this item, NOTE: Should not need this check here! + (let ((newtestname (runs:make-full-test-name hed my-item-path))) ;; test names are unique on testname/item-path + (tests:testqueue-set-items! new-test-record #f) + (tests:testqueue-set-itemdat! new-test-record my-itemdat) + (tests:testqueue-set-item_path! new-test-record my-item-path) + (hash-table-set! test-records newtestname new-test-record) + (set! tal (append tal (list newtestname))))))) ;; since these are itemized create new test names testname/itempath + items) + + ;; (debug:print-info 0 "Test " (tests:testqueue-get-testname test-record) " is itemized but has no items") + + ;; At this point we have possibly added items to tal but all must be handed off to + ;; INNER COND logic. I think loop without rotating the queue + ;; (loop hed tal reg reruns)) + ;; (let ((newtal (append tal (list hed)))) ;; We should discard hed as it has been expanded into it's items? Yes, but only if this *is* an itemized test + ;; (loop (car newtal)(cdr newtal) reg reruns) + (if (null? tal) + #f + (loop (car tal)(cdr tal) reg reruns))) + + ;; if items is a proc then need to run items:get-items-from-config, get the list and loop + ;; - but only do that if resources exist to kick off the job + ;; EXPAND ITEMS + ((or (procedure? items)(eq? items 'have-procedure)) + (let ((can-run-more (runs:can-run-more-tests jobgroup max-concurrent-jobs))) + (if (and (list? can-run-more) + (car can-run-more)) + (let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen))) + (if loop-list + (apply loop loop-list))) + ;; if can't run more just loop with next possible test + (loop (car newtal)(cdr newtal) reg reruns)))) + + ;; this case should not happen, added to help catch any bugs + ((and (list? items) itemdat) + (debug:print 0 "ERROR: Should not have a list of items in a test and the itemspath set - please report this") + (exit 1)) + ((not (null? reruns)) + (let* ((newlst (tests:filter-non-runnable run-id tal test-records)) ;; i.e. not FAIL, WAIVED, INCOMPLETE, PASS, KILLED, + (junked (lset-difference equal? tal newlst))) + (debug:print-info 4 "full drop through, if reruns is less than 100 we will force retry them, reruns=" reruns ", tal=" tal) + (if (< num-retries max-retries) + (set! newlst (append reruns newlst))) + (set! num-retries (+ num-retries 1)) + ;; (thread-sleep! (+ 1 *global-delta*)) + (if (not (null? newlst)) + ;; since reruns have been tacked on to newlst create new reruns from junked + (loop (car newlst)(cdr newlst) reg (delete-duplicates junked))))) + ((not (null? tal)) + (debug:print-info 4 "I'm pretty sure I shouldn't get here.")) + ((not (null? reg)) ;; could we get here with leftovers? + (debug:print-info 0 "Have leftovers!") + (loop (car reg)(cdr reg) '() reruns)) + (else + (debug:print-info 4 "Exiting loop with...\n hed=" hed "\n tal=" tal "\n reruns=" reruns)) + ))) ;; LET* ((test-record + + ;; we get here on "drop through". All done! + (debug:print-info 1 "All tests launched"))) + (define (runs:calc-fails prereqs-not-met) (filter (lambda (test) (and (vector? test) ;; not (string? test)) (equal? (db:test-get-state test) "COMPLETED") (not (member (db:test-get-status test) @@ -324,38 +736,12 @@ lst)) (define (runs:make-full-test-name testname itempath) (if (equal? itempath "") testname (conc testname "/" itempath))) -(define (runs:queue-next-hed tal reg n regful) - (if regful - (if (null? reg) ;; doesn't make sense, this is probably NOT the problem of the car - (car tal) - (car reg)) - (car tal))) - -(define (runs:queue-next-tal tal reg n regful) - (if regful - tal - (let ((newtal (cdr tal))) - (if (null? newtal) - reg - newtal - )))) - -(define (runs:queue-next-reg tal reg n regful) - (if regful - (cdr reg) - (if (eq? (length tal) 1) - '() - reg))) - -(include "run-tests-queue-classic.scm") -(include "run-tests-queue-new.scm") - ;; parent-test is there as a placeholder for when parent-tests can be run as a setup step -(define (run:test run-id run-info key-vals runname keyvallst test-record flags parent-test) +(define (run:test run-id run-info keyvals runname test-record flags parent-test test-registry) ;; All these vars might be referenced by the testconfig file reader (let* ((test-name (tests:testqueue-get-testname test-record)) (test-waitons (tests:testqueue-get-waitons test-record)) (test-conf (tests:testqueue-get-testconfig test-record)) (itemdat (tests:testqueue-get-itemdat test-record)) @@ -362,34 +748,37 @@ (test-path (conc *toppath* "/tests/" test-name)) ;; could use tests:get-testconfig here ... (force (hash-table-ref/default flags "-force" #f)) (rerun (hash-table-ref/default flags "-rerun" #f)) (keepgoing (hash-table-ref/default flags "-keepgoing" #f)) (item-path "") - (db #f)) - (debug:print 4 - "test-config: " (hash-table->alist test-conf) - "\n itemdat: " itemdat - ) + (db #f) + (full-test-name #f)) + ;; setting itemdat to a list if it is #f (if (not itemdat)(set! itemdat '())) (set! item-path (item-list->path itemdat)) - (debug:print 2 "Attempting to launch test " test-name (if (equal? item-path "/") "/" item-path)) + (set! full-test-name (runs:make-full-test-name test-name item-path)) + (debug:print-info 4 + "\nTESTNAME: " full-test-name + "\n test-config: " (hash-table->alist test-conf) + "\n itemdat: " itemdat + ) + (debug:print 2 "Attempting to launch test " full-test-name) (setenv "MT_TEST_NAME" test-name) ;; (setenv "MT_RUNNAME" runname) - (set-megatest-env-vars run-id) ;; these may be needed by the launching process + (set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process (change-directory *toppath*) ;; Here is where the test_meta table is best updated ;; Yes, another use of a global for caching. Need a better way? (if (not (hash-table-ref/default *test-meta-updated* test-name #f)) (begin (hash-table-set! *test-meta-updated* test-name #t) (runs:update-test_meta test-name test-conf))) - ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer")) + ;; itemdat => ((ripeness "overripe") (temperature "cool") (season "summer")) (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/")) - (new-test-name (if (equal? item-path "") test-name (conc test-name "/" item-path))) ;; just need it to be unique (test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path)) (testdat (cdb:get-test-info-by-id *runremote* test-id))) (if (not testdat) (begin ;; ensure that the path exists before registering the test @@ -398,18 +787,20 @@ ;; ;; (open-run-close tests:register-test db run-id test-name item-path) ;; ;; NB// for the above line. I want the test to be registered long before this routine gets called! ;; - (set! test-id (open-run-close db:get-test-id db run-id test-name item-path)) + (set! test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path)) (if (not test-id) (begin (debug:print 2 "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id) (cdb:tests-register-test *runremote* run-id test-name item-path) - (set! test-id (open-run-close db:get-test-id db run-id test-name item-path)))) + (set! test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path)))) (debug:print-info 4 "test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"") (set! testdat (cdb:get-test-info-by-id *runremote* test-id)))) + (if (not testdat) ;; should NOT happen + (debug:print 0 "ERROR: failed to get test record for test-id " test-id)) (set! test-id (db:test-get-id testdat)) (change-directory test-path) (case (if force ;; (args:get-arg "-force") 'NOT_STARTED (if testdat @@ -429,10 +820,11 @@ keepgoing) ;; Require to force re-run for COMPLETED or *anything* + PASS,WARN or CHECK (or (member (test:get-status testdat) '("PASS" "WARN" "CHECK" "SKIP")) (member (test:get-state testdat) '("COMPLETED")))) (debug:print-info 2 "running test " test-name "/" item-path " suppressed as it is " (test:get-state testdat) " and " (test:get-status testdat)) + (hash-table-set! test-registry full-test-name 'COMPLETED) (set! runflag #f)) ;; -rerun and status is one of the specifed, run it ((and rerun (let* ((rerunlst (string-split rerun ",")) (must-rerun (member (test:get-status testdat) rerunlst))) @@ -446,35 +838,54 @@ (set! runflag #f)) ((and (not rerun) (member (test:get-status testdat) '("FAIL" "n/a"))) (set! runflag #t)) (else (set! runflag #f))) - (debug:print 6 "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat)) + (debug:print 4 "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat)) (if (not runflag) (if (not parent-test) - (debug:print 1 "NOTE: Not starting test " new-test-name " as it is state \"" (test:get-state testdat) + (debug:print 1 "NOTE: Not starting test " full-test-name " as it is state \"" (test:get-state testdat) "\" and status \"" (test:get-status testdat) "\", use -rerun \"" (test:get-status testdat) "\" or -force to override")) ;; NOTE: No longer be checking prerequisites here! Will never get here unless prereqs are ;; already met. ;; This would be a great place to do the process-fork - (if (not (launch-test test-id run-id run-info key-vals runname test-conf keyvallst test-name test-path itemdat flags)) - (begin - (print "ERROR: Failed to launch the test. Exiting as soon as possible") - (set! *globalexitstatus* 1) ;; - (process-signal (current-process-id) signal/kill)))))) + ;; + (let ((skip-test #f) + (skip-check (configf:get-section test-conf "skip"))) + (cond + ;; Have to check for skip conditions. This one skips if there are same-named tests + ;; currently running + ((and skip-check + (configf:lookup test-conf "skip" "prevrunning")) + (let ((running-tests (cdb:remote-run db:get-tests-for-runs-mindata #f #f full-test-name '("RUNNING") '() #f))) + (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")))))) + (if skip-test + (begin + (cdb:remote-run db:test-set-state-status-by-id #f 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)) + (begin + (print "ERROR: Failed to launch the test. Exiting as soon as possible") + (set! *globalexitstatus* 1) ;; + (process-signal (current-process-id) signal/kill)))))))) ((KILLED) - (debug:print 1 "NOTE: " new-test-name " is already running or was explictly killed, use -force to launch it.")) + (debug:print 1 "NOTE: " full-test-name " is already running or was explictly killed, use -force to launch it.")) ((LAUNCHED REMOTEHOSTSTART RUNNING) (if (> (- (current-seconds)(+ (db:test-get-event_time testdat) (db:test-get-run_duration testdat))) 600) ;; i.e. no update for more than 600 seconds (begin (debug:print 0 "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD") (tests:test-set-status! test-id "INCOMPLETE" "STUCK/DEAD" "Test is stuck or dead" #f)) (debug:print 2 "NOTE: " test-name " is already running"))) - (else (debug:print 0 "ERROR: Failed to launch test " new-test-name ". Unrecognised state " (test:get-state testdat))))))) + (else (debug:print 0 "ERROR: Failed to launch test " full-test-name ". Unrecognised state " (test:get-state testdat))))))) ;;====================================================================== ;; END OF NEW STUFF ;;====================================================================== @@ -490,15 +901,15 @@ ;; 'remove-runs ;; 'set-state-status ;; ;; NB// should pass in keys? ;; -(define (runs:operate-on action runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f)) +(define (runs:operate-on action target runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f)) (common:clear-caches) ;; clear all caches (let* ((db #f) - (keys (open-run-close db:get-keys db)) - (rundat (open-run-close runs:get-runs-by-patt db keys runnamepatt)) + (keys (cdb:remote-run db:get-keys db)) + (rundat (mt:get-runs-by-patt keys runnamepatt target)) (header (vector-ref rundat 0)) (runs (vector-ref rundat 1)) (states (if state (string-split state ",") '())) (statuses (if status (string-split status ",") '())) (state-status (if (string? new-state-status) (string-split new-state-status ",") '(#f #f)))) @@ -508,21 +919,23 @@ (debug:print 0 "ERROR: the parameter to -set-state-status is a comma delimited string. E.g. COMPLETED,FAIL") (exit))) (for-each (lambda (run) (let ((runkey (string-intersperse (map (lambda (k) - (db:get-value-by-header run header (vector-ref k 0))) keys) "/")) - (dirs-to-remove (make-hash-table))) + (db:get-value-by-header run header k)) keys) "/")) + (dirs-to-remove (make-hash-table)) + (proc-get-tests (lambda (run-id) + (mt:get-tests-for-run run-id + testpatt states statuses + not-in: #f + sort-by: (case action + ((remove-runs) 'rundir) + (else 'event_time)))))) (let* ((run-id (db:get-value-by-header run header "id")) (run-state (db:get-value-by-header run header "state")) (tests (if (not (equal? run-state "locked")) - (open-run-close db:get-tests-for-run db run-id - testpatt states statuses - not-in: #f - sort-by: (case action - ((remove-runs) 'rundir) - (else 'event_time))) + (proc-get-tests run-id) '())) (lasttpath "/does/not/exist/I/hope")) (debug:print-info 4 "runs:operate-on run=" run ", header=" header) (if (not (null? tests)) (begin @@ -532,79 +945,117 @@ ((set-state-status) (debug:print 1 "Modifying state and staus for tests for run: " runkey " " (db:get-value-by-header run header "runname"))) ((print-run) (debug:print 1 "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header) action) + ((run-wait) + (debug:print 1 "Waiting for run " runkey ", run=" runnamepatt " to complete")) (else (debug:print-info 0 "action not recognised " action))) - (for-each - (lambda (test) - (let* ((item-path (db:test-get-item-path test)) - (test-name (db:test-get-testname test)) - (run-dir (db:test-get-rundir test)) ;; run dir is from the link tree - (real-dir (if (file-exists? run-dir) - (resolve-pathname run-dir) - #f)) - (test-id (db:test-get-id test))) - ;; (tdb (db:open-test-db run-dir))) - (debug:print-info 4 "test=" test) ;; " (db:test-get-testname test) " id: " (db:test-get-id test) " " item-path " action: " action) - (case action - ((remove-runs) ;; the tdb is for future possible. - (open-run-close db:delete-test-records db #f (db:test-get-id test)) - (debug:print-info 1 "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir) - (if (and real-dir - (> (string-length real-dir) 5) - (file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc. - (begin ;; let* ((realpath (resolve-pathname run-dir))) - (debug:print-info 1 "Recursively removing " real-dir) - (if (file-exists? real-dir) - (if (> (system (conc "rm -rf " real-dir)) 0) - (debug:print 0 "ERROR: There was a problem removing " real-dir " with rm -f")) - (debug:print 0 "WARNING: test dir " real-dir " appears to not exist or is not readable"))) - (if real-dir - (debug:print 0 "WARNING: directory " real-dir " does not exist") - (debug:print 0 "WARNING: no real directory corrosponding to link " run-dir ", nothing done"))) - (if (symbolic-link? run-dir) - (begin - (debug:print-info 1 "Removing symlink " run-dir) - (handle-exceptions - exn - (debug:print 0 "ERROR: Failed to remove symlink " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue") - (delete-file run-dir))) - (if (directory? run-dir) - (if (> (directory-fold (lambda (f x)(+ 1 x)) 0 run-dir) 0) - (debug:print 0 "WARNING: refusing to remove " run-dir " as it is not empty") - (handle-exceptions - exn - (debug:print 0 "ERROR: Failed to remove directory " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue") - (delete-directory run-dir))) - (if run-dir - (debug:print 0 "WARNING: not removing " run-dir " as it either doesn't exist or is not a symlink") - (debug:print 0 "NOTE: the run dir for this test is undefined. Test may have already been deleted.")) - ))) - ((set-state-status) - (debug:print-info 2 "new state " (car state-status) ", new status " (cadr state-status)) - (open-run-close db:test-set-state-status-by-id db (db:test-get-id test) (car state-status)(cadr state-status) #f))))) - (sort tests (lambda (a b)(let ((dira (db:test-get-rundir a)) - (dirb (db:test-get-rundir b))) - (if (and (string? dira)(string? dirb)) - (> (string-length dira)(string-length dirb)) - #f))))))) + (let ((sorted-tests (sort tests (lambda (a b)(let ((dira (db:test-get-rundir a)) + (dirb (db:test-get-rundir b))) + (if (and (string? dira)(string? dirb)) + (> (string-length dira)(string-length dirb)) + #f))))) + (test-retry-time (make-hash-table)) + (allow-run-time 10)) ;; seconds to allow for killing tests before just brutally killing 'em + (let loop ((test (car sorted-tests)) + (tal (cdr sorted-tests))) + (let* ((test-id (db:test-get-id test)) + (new-test-dat (cdb:remote-run db:get-test-info-by-id #f test-id)) + (item-path (db:test-get-item-path new-test-dat)) + (test-name (db:test-get-testname new-test-dat)) + (run-dir (db:test-get-rundir new-test-dat)) ;; run dir is from the link tree + (real-dir (if (file-exists? run-dir) + (resolve-pathname run-dir) + #f)) + (test-state (db:test-get-state new-test-dat)) + (test-fulln (db:test-get-fullname new-test-dat))) + (case action + ((remove-runs) + (debug:print-info 0 "test: " test-name " itest-state: " test-state) + (if (member test-state (list "RUNNING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ")) + (begin + (if (not (hash-table-ref/default test-retry-time test-fulln #f)) + (hash-table-set! test-retry-time test-fulln (current-seconds))) + (if (> (- (current-seconds)(hash-table-ref test-retry-time test-fulln)) allow-run-time) + ;; This test is not in a correct state for cleaning up. Let's try some graceful shutdown steps first + ;; Set the test to "KILLREQ" and wait five seconds then try again. Repeat up to five times then give + ;; up and blow it away. + (begin + (debug:print 0 "WARNING: could not gracefully remove test " test-fulln ", tried to kill it to no avail. Forcing state to FAILEDKILL and continuing") + (cdb:remote-run db:test-set-state-status-by-id db (db:test-get-id test) "FAILEDKILL" "n/a" #f) + (thread-sleep! 1)) + (begin + (cdb:remote-run db:test-set-state-status-by-id db (db:test-get-id test) "KILLREQ" "n/a" #f) + (thread-sleep! 1))) + ;; NOTE: This is suboptimal as the testdata will be used later and the state/status may have changed ... + (if (null? tal) + (loop new-test-dat tal) + (loop (car tal)(append tal (list new-test-dat))))) + (begin + (cdb:remote-run db:delete-test-records db #f (db:test-get-id test)) + (debug:print-info 1 "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir) + (if (and real-dir + (> (string-length real-dir) 5) + (file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc. + (begin ;; let* ((realpath (resolve-pathname run-dir))) + (debug:print-info 1 "Recursively removing " real-dir) + (if (file-exists? real-dir) + (if (> (system (conc "rm -rf " real-dir)) 0) + (debug:print 0 "ERROR: There was a problem removing " real-dir " with rm -f")) + (debug:print 0 "WARNING: test dir " real-dir " appears to not exist or is not readable"))) + (if real-dir + (debug:print 0 "WARNING: directory " real-dir " does not exist") + (debug:print 0 "WARNING: no real directory corrosponding to link " run-dir ", nothing done"))) + (if (symbolic-link? run-dir) + (begin + (debug:print-info 1 "Removing symlink " run-dir) + (handle-exceptions + exn + (debug:print 0 "ERROR: Failed to remove symlink " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue") + (delete-file run-dir))) + (if (directory? run-dir) + (if (> (directory-fold (lambda (f x)(+ 1 x)) 0 run-dir) 0) + (debug:print 0 "WARNING: refusing to remove " run-dir " as it is not empty") + (handle-exceptions + exn + (debug:print 0 "ERROR: Failed to remove directory " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue") + (delete-directory run-dir))) + (if run-dir + (debug:print 0 "WARNING: not removing " run-dir " as it either doesn't exist or is not a symlink") + (debug:print 0 "NOTE: the run dir for this test is undefined. Test may have already been deleted.")) + )) + (if (not (null? tal)) + (loop (car tal)(cdr tal)))))) + ((set-state-status) + (debug:print-info 2 "new state " (car state-status) ", new status " (cadr state-status)) + (cdb:remote-run db:test-set-state-status-by-id db (db:test-get-id test) (car state-status)(cadr state-status) #f) + (if (not (null? tal)) + (loop (car tal)(cdr tal)))) + ((run-wait) + (debug:print-info 2 "still waiting, " (length tests) " tests still running") + (thread-sleep! 10) + (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)))))))) + ))) ;; remove the run if zero tests remain (if (eq? action 'remove-runs) - (let ((remtests (open-run-close db:get-tests-for-run db (db:get-value-by-header run header "id") #f '("DELETED") '("n/a") not-in: #t))) + (let ((remtests (mt:get-tests-for-run (db:get-value-by-header run header "id") #f '("DELETED") '("n/a") not-in: #t))) (if (null? remtests) ;; no more tests remaining (let* ((dparts (string-split lasttpath "/")) (runpath (conc "/" (string-intersperse (take dparts (- (length dparts) 1)) "/")))) (debug:print 1 "Removing run: " runkey " " (db:get-value-by-header run header "runname") " and related record") - (open-run-close db:delete-run db run-id) + (cdb:remote-run db:delete-run db run-id) ;; This is a pretty good place to purge old DELETED tests - (open-run-close db:delete-tests-for-run db run-id) - (open-run-close db:delete-old-deleted-test-records db) - (open-run-close db:set-var db "DELETED_TESTS" (current-seconds)) + (cdb:remote-run db:delete-tests-for-run db run-id) + (cdb:remote-run db:delete-old-deleted-test-records db) + (cdb:remote-run db:set-var db "DELETED_TESTS" (current-seconds)) ;; need to figure out the path to the run dir and remove it if empty ;; (if (null? (glob (conc runpath "/*"))) ;; (begin ;; (debug:print 1 "Removing run dir " runpath) ;; (system (conc "rmdir -p " runpath)))) @@ -621,39 +1072,38 @@ ;; this wrapper is used to reduce the replication of code (define (general-run-call switchname action-desc proc) (let ((runname (args:get-arg ":runname")) (target (if (args:get-arg "-target") (args:get-arg "-target") - (args:get-arg "-reqtarg"))) - (th1 #f)) + (args:get-arg "-reqtarg")))) + ;; (th1 #f)) (cond ((not target) (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the target with -target") (exit 3)) ((not runname) (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the run name with :runname runname") (exit 3)) (else (let ((db #f) - (keys #f)) + (keys #f) + (target (or (args:get-arg "-reqtarg") + (args:get-arg "-target")))) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) - (if (args:get-arg "-server") - (open-run-close server:start db (args:get-arg "-server"))) - ;; (if (not (or (args:get-arg "-runall") ;; runall and runtests are allowed to be servers - ;; (args:get-arg "-runtests"))) - ;; (client:setup) ;; This is a duplicate startup!!!??? BUG? - ;; )) - (set! keys (open-run-close db:get-keys db)) + ;; (if (args:get-arg "-server") + ;; (cdb:remote-run server:start db (args:get-arg "-server"))) + (set! keys (keys:config-get-fields *configdat*)) ;; have enough to process -target or -reqtarg here (if (args:get-arg "-reqtarg") (let* ((runconfigf (conc *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL - (runconfig (read-config runconfigf #f #t environ-patt: #f))) + (runconfig (read-config runconfigf #f #t environ-patt: #f))) (if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f) (keys:target-set-args keys (args:get-arg "-reqtarg") args:arg-hash) + (begin (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf) (if db (sqlite3:finalize! db)) (exit 1)))) (if (args:get-arg "-target") @@ -662,34 +1112,32 @@ (begin (debug:print 0 "ERROR: Attempted to " action-desc " but run area config file not found") (exit 1)) ;; Extract out stuff needed in most or many calls ;; here then call proc - (let* ((keynames (map key:get-fieldname keys)) - (keyvallst (keys->vallist keys #t))) - (proc target runname keys keynames keyvallst))) - (if th1 (thread-join! th1)) + (let* ((keyvals (keys:target->keyval keys target))) + (proc target runname keys keyvals))) (if db (sqlite3:finalize! db)) (set! *didsomething* #t)))))) ;;====================================================================== ;; Lock/unlock runs ;;====================================================================== (define (runs:handle-locking target keys runname lock unlock user) (let* ((db #f) - (rundat (open-run-close runs:get-runs-by-patt db keys runname)) + (rundat (mt:get-runs-by-patt keys runname target)) (header (vector-ref rundat 0)) (runs (vector-ref rundat 1))) (for-each (lambda (run) (let ((run-id (db:get-value-by-header run header "id"))) (if (or lock (and unlock (begin (print "Do you really wish to unlock run " run-id "?\n y/n: ") (equal? "y" (read-line))))) - (open-run-close db:lock/unlock-run db run-id lock unlock user) + (cdb:remote-run db:lock/unlock-run db run-id lock unlock user) (debug:print-info 0 "Skipping lock/unlock on " run-id)))) runs))) ;;====================================================================== ;; Rollup runs ;;====================================================================== @@ -713,31 +1161,31 @@ (cdb:remote-run db:testmeta-update-field #f test-name fld val))))) '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9))))) ;; Update test_meta for all tests (define (runs:update-all-test_meta db) - (let ((test-names (get-all-legal-tests))) + (let ((test-names (tests:get-valid-tests))) (for-each (lambda (test-name) (let* ((test-path (conc *toppath* "/tests/" test-name)) (test-configf (conc test-path "/testconfig")) (testexists (and (file-exists? test-configf)(file-read-access? test-configf))) ;; read configs with tricks turned off (i.e. no system) (test-conf (if testexists (read-config test-configf #f #f)(make-hash-table)))) - ;; use the open-run-close instead of passing in db + ;; use the cdb:remote-run instead of passing in db (runs:update-test_meta test-name test-conf))) test-names))) ;; This could probably be refactored into one complex query ... -(define (runs:rollup-run keys keyvallst runname user) ;; was target, now keyvallst - (debug:print 4 "runs:rollup-run, keys: " keys " keyvallst: " keyvallst " :runname " runname " user: " user) - (let* ((db #f) ;; (keyvalllst (keys:target->keyval keys target)) - (new-run-id (cdb:remote-run db:register-run #f keys keyvallst runname "new" "n/a" user)) - (prev-tests (open-run-close test:get-matching-previous-test-run-records db new-run-id "%" "%")) - (curr-tests (open-run-close db:get-tests-for-run db new-run-id "%/%" '() '())) +(define (runs:rollup-run keys runname user keyvals) + (debug:print 4 "runs:rollup-run, keys: " keys " :runname " runname " user: " user) + (let* ((db #f) + (new-run-id (cdb:remote-run db:register-run #f keyvals runname "new" "n/a" user)) + (prev-tests (cdb:remote-run test:get-matching-previous-test-run-records db new-run-id "%" "%")) + (curr-tests (mt:get-tests-for-run new-run-id "%/%" '() '())) (curr-tests-hash (make-hash-table))) - (open-run-close db:update-run-event_time db new-run-id) + (cdb:remote-run db:update-run-event_time db new-run-id) ;; index the already saved tests by testname and itemdat in curr-tests-hash (for-each (lambda (testdat) (let* ((testname (db:test-get-testname testdat)) (item-path (db:test-get-item-path testdat)) @@ -751,23 +1199,23 @@ (lambda (testdat) (let* ((testname (db:test-get-testname testdat)) (item-path (db:test-get-item-path testdat)) (full-name (conc testname "/" item-path)) (prev-test-dat (hash-table-ref/default curr-tests-hash full-name #f)) - (test-steps (open-run-close db:get-steps-for-test db (db:test-get-id testdat))) + (test-steps (cdb:remote-run db:get-steps-for-test db (db:test-get-id testdat))) (new-test-record #f)) ;; replace these with insert ... select (apply sqlite3:execute db (conc "INSERT OR REPLACE INTO tests (run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment) " "VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?);") new-run-id (cddr (vector->list testdat))) - (set! new-testdat (car (open-run-close db:get-tests-for-run db new-run-id (conc testname "/" item-path) '() '()))) + (set! new-testdat (car (mt:get-tests-for-run new-run-id (conc testname "/" item-path) '() '()))) (hash-table-set! curr-tests-hash full-name new-testdat) ;; this could be confusing, which record should go into the lookup table? ;; Now duplicate the test steps (debug:print 4 "Copying records in test_steps from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat)) - (open-run-close + (cdb:remote-run (lambda () (sqlite3:execute db (conc "INSERT OR REPLACE INTO test_steps (test_id,stepname,state,status,event_time,comment) " "SELECT " (db:test-get-id new-testdat) ",stepname,state,status,event_time,comment FROM test_steps WHERE test_id=?;") Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -21,16 +21,20 @@ ;;====================================================================== ;; Tasks db ;;====================================================================== (define (tasks:open-db) - (let* ((dbpath (conc *toppath* "/monitor.db")) - (exists (file-exists? dbpath)) - (mdb (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath)) - (handler (make-busy-timeout 36000))) + (let* ((dbpath (conc *toppath* "/monitor.db")) + (exists (file-exists? dbpath)) + (write-access (file-write-access? dbpath)) + (mdb (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath)) + (handler (make-busy-timeout 36000))) + (if (and exists + (not write-access)) + (set! *db-write-access* write-access)) ;; only unset so other db's also can use this control (sqlite3:set-busy-handler! mdb handler) - (sqlite3:execute mdb (conc "PRAGMA synchronous = 1;")) + (sqlite3:execute mdb (conc "PRAGMA synchronous = 0;")) (if (not exists) (begin (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY, action TEXT DEFAULT '', owner TEXT, @@ -93,31 +97,35 @@ (debug:print-info 11 "tasks:server-register " pid " " interface " " port " " priority " " state) (sqlite3:execute mdb "INSERT OR REPLACE INTO servers (pid,hostname,port,pubport,start_time,priority,state,mt_version,heartbeat,interface,transport) VALUES(?, ?, ?, ?, strftime('%s','now'), ?, ?, ?, strftime('%s','now'),?,?);" - pid (get-host-name) port pubport priority (conc state) megatest-version interface (conc transport)) + pid (get-host-name) port pubport priority (conc state) + (common:version-signature) + interface + (conc transport)) (vector (tasks:server-get-server-id mdb (get-host-name) interface port pid) interface port pubport transport )) ;; NB// two servers with same pid on different hosts will be removed from the list if pid: is used! -(define (tasks:server-deregister mdb hostname #!key (port #f)(pid #f)(action 'markdead)) +(define (tasks:server-deregister mdb hostname #!key (port #f)(pid #f)(action 'delete)) (debug:print-info 11 "server-deregister " hostname ", port " port ", pid " pid) - (if pid - (case action - ((delete)(sqlite3:execute mdb "DELETE FROM servers WHERE pid=?;" pid)) - (else (sqlite3:execute mdb "UPDATE servers SET state='dead' WHERE pid=?;" pid))) - (if port - (case action - ((delete)(sqlite3:execute mdb "DELETE FROM servers WHERE hostname=? AND port=?;" hostname port)) - (else (sqlite3:execute mdb "UPDATE servers SET state='dead' WHERE hostname=? AND port=?;" hostname port))) - (debug:print 0 "ERROR: tasks:server-deregister called with neither pid nor port specified")))) + (if *db-write-access* + (if pid + (case action + ((delete)(sqlite3:execute mdb "DELETE FROM servers WHERE pid=?;" pid)) + (else (sqlite3:execute mdb "UPDATE servers SET state='dead' WHERE pid=?;" pid))) + (if port + (case action + ((delete)(sqlite3:execute mdb "DELETE FROM servers WHERE (interface=? or hostname=?) AND port=?;" hostname hostname port)) + (else (sqlite3:execute mdb "UPDATE servers SET state='dead' WHERE (interface=? or hostname=?) AND port=?;" hostname hostname port))) + (debug:print 0 "ERROR: tasks:server-deregister called with neither pid nor port specified"))))) (define (tasks:server-deregister-self mdb hostname) (tasks:server-deregister mdb hostname pid: (current-process-id))) ;; need a simple call for robustly removing records given host and port @@ -141,12 +149,18 @@ "SELECT id FROM servers WHERE pid=-999;"))) (if hostname hostname iface)(if pid pid port)) res)) (define (tasks:server-update-heartbeat mdb server-id) - (debug:print-info 0 "Heart beat update of server id=" server-id) - (sqlite3:execute mdb "UPDATE servers SET heartbeat=strftime('%s','now') WHERE id=?;" server-id)) + (debug:print-info 1 "Heart beat update of server id=" server-id) + (handle-exceptions + exn + (begin + (debug:print 0 "WARNING: probable timeout on monitor.db access") + (thread-sleep! 1) + (tasks:server-update-heartbeat mdb server-id)) + (sqlite3:execute mdb "UPDATE servers SET heartbeat=strftime('%s','now') WHERE id=?;" server-id))) ;; alive servers keep the heartbeat field upto date with seconds every 6 or so seconds (define (tasks:server-alive? mdb server-id #!key (iface #f)(hostname #f)(port #f)(pid #f)) (let* ((server-id (if server-id server-id @@ -195,11 +209,11 @@ ) mdb "SELECT id,interface,port,pubport,transport,pid,hostname FROM servers WHERE strftime('%s','now')-heartbeat < 10 - AND mt_version=? ORDER BY start_time DESC LIMIT 1;" megatest-version) + AND mt_version=? ORDER BY start_time DESC LIMIT 1;" (common:version-signature)) ;; for now we are keeping only one server registered in the db, return #f or first server found (if (null? res) #f (car res)))) ;; BUG: This logic is probably needed unless methodology changes completely... ;; @@ -250,17 +264,17 @@ (process-signal pid signal/term) (thread-sleep! 5) ;; give it five seconds to die peacefully then do a brutal kill ;;(process-signal pid signal/kill) ) ;; local machine, send sig term (begin - (debug:print-info 1 "Stopping remote servers not yet supported.")))) - ;; (debug:print-info 1 "Telling alive server on " hostname ":" port " to commit servercide") - ;; (let ((serverdat (list hostname port))) - ;; (case (string->symbol transport) - ;; ((http)(http-transport:client-connect hostname port)) - ;; (else (debug:print "ERROR: remote stopping servers of type " transport " not supported yet"))) - ;; (cdb:kill-server serverdat))))) ;; remote machine, try telling server to commit suicide + ;;(debug:print-info 1 "Stopping remote servers not yet supported.")))) + (debug:print-info 1 "Telling alive server on " hostname ":" port " to commit servercide") + (let ((serverdat (list hostname port))) + (case (if (string? transport) (string->symbol transport) transport) + ((http)(http-transport:client-connect hostname port)) + (else (debug:print "ERROR: remote stopping servers of type " transport " not supported yet"))) + (cdb:kill-server serverdat pid))))) ;; remote machine, try telling server to commit suicide (begin (if status (if (equal? hostname (get-host-name)) (begin (debug:print-info 1 "Sending signal/term to " pid " on " hostname) @@ -531,15 +545,15 @@ (tasks:set-state mdb (tasks:task-get-id task) "waiting"))) (define (tasks:rollup-runs db mdb task) (let* ((flags (make-hash-table)) (keys (db:get-keys db)) - (keyvallst (keys:target->keyval keys (tasks:task-get-target task)))) + (keyvals (keys:target-keyval keys (tasks:task-get-target task)))) ;; (hash-table-set! flags "-rerun" "NOT_STARTED") (print "Starting rollup " task) ;; sillyness, just call the damn routine with the task vector and be done with it. FIXME SOMEDAY (runs:rollup-run db keys - keyvallst + keyvals (tasks:task-get-name task) (tasks:task-get-owner task)) (tasks:set-state mdb (tasks:task-get-id task) "waiting"))) Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -1,7 +1,7 @@ ;;====================================================================== -;; Copyright 2006-2012, Matthew Welland. +;; Copyright 2006-2013, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the @@ -51,13 +51,13 @@ (set! res (string-match (regexp finpatt (if like #t #f)) str)) (if notpatt (not res) res)))) ;; if itempath is #f then look only at the testname part ;; -(define (tests:match patterns testname itempath) +(define (tests:match patterns testname itempath #!key (required '())) (if (string? patterns) - (let ((patts (string-split patterns ","))) + (let ((patts (append (string-split patterns ",") required))) (if (null? patts) ;;; no pattern(s) means no match #f (let loop ((patt (car patts)) (tal (cdr patts))) ;; (print "loop: patt: " patt ", tal " tal) @@ -105,14 +105,17 @@ (loop (car tal)(cdr tal)(cons qry res))))))) #f)) ;; get the previous record for when this test was run where all keys match but runname ;; returns #f if no such test found, returns a single test record if found +;; +;; Run this server-side +;; (define (test:get-previous-test-run-record db run-id test-name item-path) - (let* ((keys (cdb:remote-run db:get-keys #f)) - (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ",")) - (qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND ")) + (let* ((keys (db:get-keys db)) + (selstr (string-intersperse keys ",")) + (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND ")) (keyvals #f)) ;; first look up the key values from the run selected by run-id (sqlite3:for-each-row (lambda (a . b) (set! keyvals (cons a b))) @@ -130,11 +133,11 @@ ;; if found then return that matching test record (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) (if (null? prev-run-ids) #f (let loop ((hed (car prev-run-ids)) (tal (cdr prev-run-ids))) - (let ((results (cdb:remote-run db:get-tests-for-run #f hed (conc test-name "/" item-path)'() '()))) + (let ((results (db:get-tests-for-run db hed (conc test-name "/" item-path)'() '() #f #f #f #f))) (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results) (if (and (null? results) (not (null? tal))) (loop (car tal)(cdr tal)) (if (null? results) #f @@ -141,12 +144,15 @@ (car results)))))))))) ;; get the previous records for when these tests were run where all keys match but runname ;; NB// Merge this with test:get-previous-test-run-records? This one looks for all matching tests ;; can use wildcards. Also can likely be factored in with get test paths? +;; +;; Run this remotely!! +;; (define (test:get-matching-previous-test-run-records db run-id test-name item-path) - (let* ((keys (cdb:remote-run db:get-keys #f)) + (let* ((keys (db:get-keys db)) (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ",")) (qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND ")) (keyvals #f) (tests-hash (make-hash-table))) ;; first look up the key values from the run selected by run-id @@ -168,11 +174,11 @@ (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) (if (null? prev-run-ids) '() ;; no previous runs? return null (let loop ((hed (car prev-run-ids)) (tal (cdr prev-run-ids))) - (let ((results (cdb:remote-run db:get-tests-for-run #f hed (conc test-name "/" item-path) '() '()))) + (let ((results (db:get-tests-for-run db hed (conc test-name "/" item-path) '() '() #f #f #f #f))) (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path " results: " (intersperse results "\n")) ;; Keep only the youngest of any test/item combination (for-each (lambda (testdat) @@ -261,11 +267,11 @@ ;; NOTES: ;; 1. Is the call to test:get-previous-run-record remotified? ;; 2. Add test for testconfig waiver propagation control here ;; (prev-test (if (equal? status "FAIL") - (open-run-close test:get-previous-test-run-record db run-id test-name item-path) + (cdb:remote-run test:get-previous-test-run-record #f run-id test-name item-path) #f)) (waived (if prev-test (if prev-test ;; true if we found a previous test in this run series (let ((prev-status (db:test-get-status prev-test)) (prev-state (db:test-get-state prev-test)) @@ -364,85 +370,90 @@ (debug:print 4 "summarize-items with logf " logf ", outputfilename " outputfilename " and force " force) (if (or (equal? logf "logs/final.log") (equal? logf outputfilename) force) (begin - (if (obtain-dot-lock outputfilename 1 20 30) ;; retry every second for 20 seconds, call it dead after 30 seconds and steal the lock - (print "Obtained lock for " outputfilename) - (print "Failed to obtain lock for " outputfilename)) - (let ((oup (open-output-file outputfilename)) - (counts (make-hash-table)) - (statecounts (make-hash-table)) - (outtxt "") - (tot 0) - (testdat (cdb:remote-run db:test-get-records-for-index-file #f run-id test-name))) - (with-output-to-port - oup - (lambda () - (set! outtxt (conc outtxt "Summary: " test-name - "

Summary for " test-name "

")) - (for-each - (lambda (testrecord) - (let ((id (vector-ref testrecord 0)) - (itempath (vector-ref testrecord 1)) - (state (vector-ref testrecord 2)) - (status (vector-ref testrecord 3)) - (run_duration (vector-ref testrecord 4)) - (logf (vector-ref testrecord 5)) - (comment (vector-ref testrecord 6))) - (hash-table-set! counts status (+ 1 (hash-table-ref/default counts status 0))) - (hash-table-set! statecounts state (+ 1 (hash-table-ref/default statecounts state 0))) - (set! outtxt (conc outtxt "" - " " itempath "" - "" state "" - "" status "" - "" (if (equal? comment "") - " " - comment) "" - "")))) - testdat) - (print "
") - ;; Print out stats for status - (set! tot 0) - (print "") - (for-each (lambda (state) - (set! tot (+ tot (hash-table-ref statecounts state))) - (print "")) - (hash-table-keys statecounts)) - (print "

State stats

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

Status stats

" status - "" (hash-table-ref counts status) "
Total" tot "
") - (print "
") - - (print "" - "" - outtxt "
ItemStateStatusComment
") - (release-dot-lock outputfilename))) - (close-output-port oup) - (change-directory orig-dir) - ;; NB// tests:test-set-toplog! is remote internal... - (tests:test-set-toplog! db run-id test-name outputfilename) - ))))) - -(define (get-all-legal-tests) - (let* ((tests (glob (conc *toppath* "/tests/*"))) - (res '())) - (debug:print-info 4 "Looking at tests " (string-intersperse tests ",")) - (for-each (lambda (testpath) - (if (file-exists? (conc testpath "/testconfig")) - (set! res (cons (last (string-split testpath "/")) res)))) - tests) - res)) + (if (not (obtain-dot-lock outputfilename 1 5 7)) ;; retry every second for 20 seconds, call it dead after 30 seconds and steal the lock + (print "Failed to obtain lock for " outputfilename) + (begin + (print "Obtained lock for " outputfilename) + (let ((oup (open-output-file outputfilename)) + (counts (make-hash-table)) + (statecounts (make-hash-table)) + (outtxt "") + (tot 0) + (testdat (cdb:remote-run db:test-get-records-for-index-file #f run-id test-name))) + (with-output-to-port + oup + (lambda () + (set! outtxt (conc outtxt "Summary: " test-name + "

Summary for " test-name "

")) + (for-each + (lambda (testrecord) + (let ((id (vector-ref testrecord 0)) + (itempath (vector-ref testrecord 1)) + (state (vector-ref testrecord 2)) + (status (vector-ref testrecord 3)) + (run_duration (vector-ref testrecord 4)) + (logf (vector-ref testrecord 5)) + (comment (vector-ref testrecord 6))) + (hash-table-set! counts status (+ 1 (hash-table-ref/default counts status 0))) + (hash-table-set! statecounts state (+ 1 (hash-table-ref/default statecounts state 0))) + (set! outtxt (conc outtxt "" + " " itempath "" + "" state "" + "" status "" + "" (if (equal? comment "") + " " + comment) "" + "")))) + testdat) + (print "
") + ;; Print out stats for status + (set! tot 0) + (print "") + (for-each (lambda (state) + (set! tot (+ tot (hash-table-ref statecounts state))) + (print "")) + (hash-table-keys statecounts)) + (print "

State stats

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

Status stats

" status + "" (hash-table-ref counts status) "
Total" tot "
") + (print "
") + + (print "" + "" + outtxt "
ItemStateStatusComment
") + (release-dot-lock outputfilename))) + (close-output-port oup) + (change-directory orig-dir) + ;; NB// tests:test-set-toplog! is remote internal... + (tests:test-set-toplog! db run-id test-name outputfilename) + ))))))) + +;;====================================================================== +;; Gather data from test/task specifications +;;====================================================================== + +(define (tests:get-valid-tests testsdir test-patts) ;; #!key (test-names '())) + (let ((tests (glob (conc testsdir "/tests/*")))) ;; " (string-translate patt "%" "*"))))) + (set! tests (filter (lambda (test)(file-exists? (conc test "/testconfig"))) tests)) + (delete-duplicates + (filter (lambda (testname) + (tests:match test-patts testname #f)) + (map (lambda (testp) + (last (string-split testp "/"))) + tests))))) (define (tests:get-testconfig test-name system-allowed) (let* ((test-path (conc *toppath* "/tests/" test-name)) (test-configf (conc test-path "/testconfig")) (testexists (and (file-exists? test-configf)(file-read-access? test-configf)))) @@ -531,21 +542,106 @@ (set! keep-test #f)))) ;; no point in running this one again waitons)))) (if keep-test (set! runnables (cons testkeyname runnables))))) testkeynames) runnables)) + +;;====================================================================== +;; refactoring this block into tests:get-full-data from line 263 of runs.scm +;;====================================================================== +;; hed is the test name +;; test-records is a hash of test-name => test record +(define (tests:get-full-data test-names test-records required-tests) + (if (not (null? test-names)) + (let loop ((hed (car test-names)) + (tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc + (debug:print-info 4 "hed=" hed " at top of loop") + (let* ((config (tests:get-testconfig hed 'return-procs)) + (waitons (let ((instr (if config + (config-lookup config "requirements" "waiton") + (begin ;; No config means this is a non-existant test + (debug:print 0 "ERROR: non-existent required test \"" hed "\", grep through your testconfigs to find and remove or create the test. Discarding and continuing.") + "")))) + (debug:print-info 8 "waitons string is " instr) + (string-split (cond + ((procedure? instr) + (let ((res (instr))) + (debug:print-info 8 "waiton procedure results in string " res " for test " hed) + res)) + ((string? instr) instr) + (else + ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 "ERROR: something went wrong in processing waitons for test " hed) + "")))))) + (if (not config) ;; this is a non-existant test called in a waiton. + (if (null? tal) + test-records + (loop (car tal)(cdr tal))) + (begin + (debug:print-info 8 "waitons: " waitons) + ;; check for hed in waitons => this would be circular, remove it and issue an + ;; error + (if (member hed waitons) + (begin + (debug:print 0 "ERROR: test " hed " has listed itself as a waiton, please correct this!") + (set! waitons (filter (lambda (x)(not (equal? x hed))) waitons)))) + + ;; (items (items:get-items-from-config config))) + (if (not (hash-table-ref/default test-records hed #f)) + (hash-table-set! test-records + hed (vector hed ;; 0 + config ;; 1 + waitons ;; 2 + (config-lookup config "requirements" "priority") ;; priority 3 + (let ((items (hash-table-ref/default config "items" #f)) ;; items 4 + (itemstable (hash-table-ref/default config "itemstable" #f))) + ;; if either items or items table is a proc return it so test running + ;; process can know to call items:get-items-from-config + ;; if either is a list and none is a proc go ahead and call get-items + ;; otherwise return #f - this is not an iterated test + (cond + ((procedure? items) + (debug:print-info 4 "items is a procedure, will calc later") + items) ;; calc later + ((procedure? itemstable) + (debug:print-info 4 "itemstable is a procedure, will calc later") + itemstable) ;; calc later + ((filter (lambda (x) + (let ((val (car x))) + (if (procedure? val) val #f))) + (append (if (list? items) items '()) + (if (list? itemstable) itemstable '()))) + 'have-procedure) + ((or (list? items)(list? itemstable)) ;; calc now + (debug:print-info 4 "items and itemstable are lists, calc now\n" + " items: " items " itemstable: " itemstable) + (items:get-items-from-config config)) + (else #f))) ;; not iterated + #f ;; itemsdat 5 + #f ;; spare - used for item-path + ))) + (for-each + (lambda (waiton) + (if (and waiton (not (member waiton test-names))) + (begin + (set! required-tests (cons waiton required-tests)) + (set! test-names (cons waiton test-names))))) ;; was an append, now a cons + waitons) + (let ((remtests (delete-duplicates (append waitons tal)))) + (if (not (null? remtests)) + (loop (car remtests)(cdr remtests)) + test-records)))))))) ;;====================================================================== ;; test steps ;;====================================================================== ;; teststep-set-status! used to be here (define (test-get-kill-request test-id) ;; run-id test-name itemdat) - (let* (;; (item-path (item-list->path itemdat)) - (testdat (cdb:get-test-info-by-id *runremote* test-id))) ;; run-id test-name item-path))) - (equal? (test:get-state testdat) "KILLREQ"))) + (let* ((testdat (cdb:get-test-info-by-id *runremote* test-id))) ;; run-id test-name item-path))) + (and testdat + (equal? (test:get-state testdat) "KILLREQ")))) (define (test:tdb-get-rundat-count tdb) (if tdb (let ((res 0)) (sqlite3:for-each-row Index: tests/Makefile ================================================================== --- tests/Makefile +++ tests/Makefile @@ -1,8 +1,8 @@ # run some tests -BINPATH=$(PWD)/../bin +BINPATH=$(shell readlink -m $(PWD)/../bin) MEGATEST=$(BINPATH)/megatest PATH := $(BINPATH):$(PATH) RUNNAME := $(shell date +w%V.%u.%H.%M) IPADDR := "-" # Set SERVER to "-server -" @@ -16,15 +16,23 @@ # The NEWTARGET causes some tests to fail. Do not use until this is fixed. NEWTARGET = "$(OS)/$(FS)/$(VER)" TARGET = "ubuntu/nfs/none" -all : test1 test2 test3 test4 test5 +all : test1 test2 test3 test4 test5 test6 test7 test8 test9 server : - (cd ..;make;make install) && \ - (cd fullrun;../../bin/megatest -server - -debug 22) + cd ..;make;make install + cd fullrun;../../bin/megatest -server - -debug 22 & + +stopserver : + cd ..;make && make install + cd fullrun;$(MEGATEST) -stop-server 0 + +repl : + cd ..;make && make install + cd fullrun;$(MEGATEST) -repl test0 : cleanprep cd simplerun ; $(MEGATEST) -server - -debug $(DEBUG) test1 : cleanprep @@ -53,20 +61,84 @@ # NOTE: Only one instance can be a server test5 : cleanprep @echo "WARNING: No longer running fullprep, test converage may be lessened" cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_aa -debug $(DEBUG) $(LOGGING) > aa.log 2> aa.log & cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ab -debug $(DEBUG) $(LOGGING) > ab.log 2> ab.log & - cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ac -debug $(DEBUG) $(LOGGING) > ac.log 2> ac.log & - cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ad -debug $(DEBUG) $(LOGGING) > ad.log 2> ad.log & + cd fullrun;sleep 5;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ac -debug $(DEBUG) $(LOGGING) > ac.log 2> ac.log & + cd fullrun;sleep 8;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ad -debug $(DEBUG) $(LOGGING) > ad.log 2> ad.log & # cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ae -debug $(DEBUG) $(LOGGING) > ae.log 2> ae.log & -# cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_af -debug $(DEBUG) $(LOGGING) > af.log 2> af.log & +# cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_af -debug $(DEBUG) $(LOGGING) > af.log 2> af.log & a + +# MUST ADD THIS BACK IN ASAP!!!! + # cd fullrun;sleep 10;$(MEGATEST) -run-wait -target $(TARGET) :runname % -testpatt % :state RUNNING,LAUNCHED,NOT_STARTED,REMOTEHOSTSTART;echo ALL DONE test6: fullprep cd fullrun;$(MEGATEST) -runtests runfirst -testpatt %/1 -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_itempatt -v cd fullrun;$(MEGATEST) -runtests runfirst -testpatt %blahha% -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_itempatt -debug 10 cd fullrun;$(MEGATEST) -rollup :runname newrun -target ubuntu/nfs/none -debug 10 +test7: + @echo Only a/c testname c should remain. If there is a run a/b/c then there is a cache issue. + (cd simplerun; \ + $(MEGATEST) -server - -daemonize; \ + $(MEGATEST) -remove-runs -target %/% :runname % -testpatt %; \ + $(MEGATEST) -runtests % -target a/b :runname c; sleep 5; \ + $(MEGATEST) -remove-runs -target a/c :runname c; \ + $(MEGATEST) -runtests % -target a/c :runname c; \ + $(MEGATEST) -remove-runs -target a/b :runname c -testpatt % ; \ + $(MEGATEST) -runtests % -target a/d :runname c;$(MEGATEST) -list-runs %|egrep ^Run:) > test7.log 2> test7.log + logpro test7.logpro test7.html < test7.log + @echo + @echo Run \"firefox test7.html\" to see the results. + +# This one failed with v1.55 +test8a : + cd fullrun;$(MEGATEST) -runtests priority_10_waiton_1 -target ubuntu/nfs/none :runname $(RUNNAME)_waiton_single + +test8 : test8a + cd fullrun;$(MEGATEST) -runtests lineitem_fail 1 -target ubuntu/nfs/none :runname $(RUNNAME)_singletest + cd fullrun;$(MEGATEST) -runtests runfirst/fall 1 -target ubuntu/nfs/none :runname $(RUNNAME)_singleitem + cd fullrun;$(MEGATEST) -runtests test_mt_vars/2 -target ubuntu/nfs/none :runname $(RUNNAME)_singleitem_waiton + +# Some simple checks for bootstrapping and run loop logic + +test9 : minsetup test9a test9b test9c test9d + +test9a : + @echo Run super-simple mintest e, no waitons. + cd mintest;megatest -runtests e -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) + +test9b : + @echo Run simple mintest d with one waiton c + cd mintest;megatest -runtests d -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) + +test9c : + @echo Run mintest a with full waiton chain a -> b -> c -> d -> e + cd mintest;megatest -runtests a -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) + +test9d : + @echo Run an itemized test with no items + cd mintest;megatest -runtests g -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) + +test10 : + @echo Run a bunch of different targets simultaneously + (cd fullrun;$(MEGATEST) -server - ;sleep 2)& + for targ in mint/btrfs/mintdir sunos/sshfs/loc; do \ + (cd fullrun;$(MEGATEST) -runtests priority_10_waiton_1 -target $$targ :runname $(RUNNAME) &); done + for sys in ubuntu suse redhat debian;do \ + for fs in afs nfs zfs; do \ + for dpath in none tmp; do \ + (cd fullrun;$(MEGATEST) -runtests priority_10_waiton_1 -target $$sys/$$fs/$$dpath :runname $(RUNNAME) &);\ + done;done;done + +minsetup : + cd ..;make && make install + mkdir -p mintest/runs mintest/links + cd mintest;megatest -stop-server 0 + cd mintest;megatest -server - -debug $(DEBUG) > server.log 2> server.log & + sleep 3 + cd mintest;dashboard -rows 20 & cleanprep : ../*.scm Makefile */*.config mkdir -p fullrun/tmp/mt_runs fullrun/tmp/mt_links cd ..;make;make install rm -f */logging.db @@ -92,9 +164,9 @@ hardkill : kill sleep 5;killall -v mtest main.sh dboard -9 listservers : - cd fullrun;$(MEGATEST) -listservers + cd fullrun;$(MEGATEST) -list-servers runforever : while(ls); do runname=`date +%F-%R:%S`;(cd fullrun;$(MEGATEST) -runall -target ubuntu/nfs/none :runname $$runname;/home/matt/data/megatest/megatest -runall -target ubuntu/nfs/none :runname $$runname;/home/matt/data/megatest/megatest -runall -target ubuntu/nfs/none :runname $$runname);done Index: tests/fdktestqa/testqa/Makefile ================================================================== --- tests/fdktestqa/testqa/Makefile +++ tests/fdktestqa/testqa/Makefile @@ -1,3 +1,27 @@ - +BINDIR = $(PWD)/../../../bin +PATH := $(BINDIR):$(PATH) +MEGATEST = $(BINDIR)/megatest +DASHBOARD = $(BINDIR)/dashboard all : - megatest -runtests % -target a/b :runname c + $(MEGATEST) -remove-runs -target a/b :runname c -testpatt %/% + $(MEGATEST) -runtests % -target a/b :runname c + +bigbig : + for tn in a b c d;do \ + ($(MEGATEST) -runtests % -target a/b :runname $tn & ) ; \ + done + +bigrun : + $(MEGATEST) -runtests bigrun -target a/bigrun :runname a + +bigrun2 : + $(MEGATEST) -runtests bigrun2 -target a/bigrun2 :runname a + +dashboard : + $(DASHBOARD) -rows 20 & + +compile : + (cd ../../..;make && make install) + +clean : + rm -rf ../simple*/*/* megatest.db Index: tests/fdktestqa/testqa/megatest.config ================================================================== --- tests/fdktestqa/testqa/megatest.config +++ tests/fdktestqa/testqa/megatest.config @@ -1,8 +1,8 @@ [setup] testcopycmd cp --remove-destination -rlv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log -# runqueue 2 +runqueue 2 [include ../fdk.config] [server] -timeout 0.01 +timeout 0.05 Index: tests/fdktestqa/testqa/tests/bigrun/step1.sh ================================================================== --- tests/fdktestqa/testqa/tests/bigrun/step1.sh +++ tests/fdktestqa/testqa/tests/bigrun/step1.sh @@ -1,7 +1,8 @@ #!/bin/sh if [ $NUMBER -lt 200 ];then + sleep 20 sleep $NUMBER else sleep 200 fi Index: tests/fdktestqa/testqa/tests/bigrun/testconfig ================================================================== --- tests/fdktestqa/testqa/tests/bigrun/testconfig +++ tests/fdktestqa/testqa/tests/bigrun/testconfig @@ -7,11 +7,11 @@ # waiton setup priority 0 # Iteration for your tests are controlled by the items section [items] -NUMBER #{scheme (string-intersperse (map number->string (sort (let loop ((a 0)(res '()))(if (< a (or (any->number (get-environment-variable "NUMTESTS")) 1100))(loop (+ a 1)(cons a res)) res)) >)) " ")} +NUMBER #{scheme (string-intersperse (map number->string (sort (let loop ((a 0)(res '()))(if (<= a (or (any->number (get-environment-variable "NUMTESTS")) 2500))(loop (+ a 1)(cons a res)) res)) <)) " ")} # test_meta is a section for storing additional data on your test [test_meta] author matt owner matt Index: tests/fdktestqa/testqa/tests/bigrun2/step1.sh ================================================================== --- tests/fdktestqa/testqa/tests/bigrun2/step1.sh +++ tests/fdktestqa/testqa/tests/bigrun2/step1.sh @@ -1,7 +1,9 @@ #!/bin/sh -prev_test=`$MT_MEGATEST -test-paths -target $MT_TARGET :runname $MT_RUNNAME -testpatt bigrun/$NUMBER` -if [ -e $prev_test/testconfig ]; then - exit 0 -else - exit 1 -fi +# prev_test=`$MT_MEGATEST -test-paths -target $MT_TARGET :runname $MT_RUNNAME -testpatt bigrun/$NUMBER` +# if [ -e $prev_test/testconfig ]; then +# exit 0 +# else +# exit 1 +# fi + +exit 0 Index: tests/fdktestqa/testqa/tests/bigrun2/testconfig ================================================================== --- tests/fdktestqa/testqa/tests/bigrun2/testconfig +++ tests/fdktestqa/testqa/tests/bigrun2/testconfig @@ -9,11 +9,11 @@ mode itemmatch # Iteration for your tests are controlled by the items section [items] -NUMBER #{scheme (string-intersperse (map number->string (sort (let loop ((a 0)(res '()))(if (< a 150)(loop (+ a 1)(cons a res)) res)) >)) " ")} +NUMBER #{scheme (string-intersperse (map number->string (sort (let loop ((a 0)(res '()))(if (<= a (or (any->number (get-environment-variable "NUMTESTS")) 2500))(loop (+ a 1)(cons a res)) res)) <)) " ")} # test_meta is a section for storing additional data on your test [test_meta] author matt owner matt ADDED tests/fullrun/afs.config Index: tests/fullrun/afs.config ================================================================== --- /dev/null +++ tests/fullrun/afs.config @@ -0,0 +1,1 @@ +TESTSTORUN priority_6 sqlitespeed/ag Index: tests/fullrun/megatest.config ================================================================== --- tests/fullrun/megatest.config +++ tests/fullrun/megatest.config @@ -13,14 +13,14 @@ [setup] # Set launchwait to yes to use the old launch run code that waits for the launch process to return before # proceeding. # launchwait yes -# If defined the runs:run-tests-queue-new queue code is used with the register test depth -# given. Otherwise the old code is used. The old code will be removed in the future and -# a default of 10 used. -# runqueue 2 +# If set to "default" the old code is used. Otherwise defaults to 200 or uses +# numeric value given. +# +runqueue 20 # It is possible (but not recommended) to override the rsync command used # to populate the test directories. For test development the following # example can be useful # @@ -57,10 +57,14 @@ WACKYVAR6 #{scheme (args:get-arg "-target")} PREDICTABLE the_ans MRAH MT_RUN_AREA_HOME=#{getenv MT_RUN_AREA_HOME} # The empty var should have a definition with null string EMPTY_VAR + +WRAPPEDVAR This var should have the work blah thrice: \ +blah \ +blah # XTERM [system xterm] # RUNDEAD [system exit 56] [server] ADDED tests/fullrun/nfs.config Index: tests/fullrun/nfs.config ================================================================== --- /dev/null +++ tests/fullrun/nfs.config @@ -0,0 +1,1 @@ +TESTSTORUN priority_4 test_mt_vars Index: tests/fullrun/runconfigs.config ================================================================== --- tests/fullrun/runconfigs.config +++ tests/fullrun/runconfigs.config @@ -1,13 +1,29 @@ +[default] +SOMEVAR This should show up in SOMEVAR3 + +# target based getting of config file, look at afs.config and nfs.config +[include #{getenv fsname}.config] + [include #{getenv MT_RUN_AREA_HOME}/common_runconfigs.config] # #{system echo 'VACKYVAR #{shell pwd}' > $MT_RUN_AREA_HOME/config/$USER.config} [include ./config/#{getenv USER}.config] + WACKYVAR0 #{get ubuntu/nfs/none CURRENT} WACKYVAR1 #{scheme (args:get-arg "-target")} [default/ubuntu/nfs] WACKYVAR2 #{runconfigs-get CURRENT} [ubuntu/nfs/none] WACKYVAR2 #{runconfigs-get CURRENT} +SOMEVAR2 This should show up in SOMEVAR4 if the target is ubuntu/nfs/none + +[default] +SOMEVAR3 #{rget SOMEVAR} +SOMEVAR4 #{rget SOMEVAR2} +SOMEVAR5 #{runconfigs-get SOMEVAR2} + +[this/a/test] +BLAHFOO 123 Index: tests/fullrun/tests/priority_2/testconfig ================================================================== --- tests/fullrun/tests/priority_2/testconfig +++ tests/fullrun/tests/priority_2/testconfig @@ -1,10 +1,12 @@ [setup] runscript main.sh [requirements] priority 2 +# runtimelim 1d 1h 1m 10s +runtimelim 10s [test_meta] author matt owner bob description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS Index: tests/fullrun/tests/priority_3/main.sh ================================================================== --- tests/fullrun/tests/priority_3/main.sh +++ tests/fullrun/tests/priority_3/main.sh @@ -2,10 +2,11 @@ # a bunch of steps in 2 second increments for i in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17;do $MT_MEGATEST -step step$i :state start :status running -setlog results$i.html sleep 2 + echo "
Results$i
Nothing but faux results here!" > results$i.html $MT_MEGATEST -step step$i :state end :status 0 done # get a previous test export EZFAILPATH=`$MT_MEGATEST -test-files lookithome.log -target $MT_TARGET :runname $MT_RUNNAME -testpatt ez_fail` Index: tests/fullrun/tests/priority_5/testconfig ================================================================== --- tests/fullrun/tests/priority_5/testconfig +++ tests/fullrun/tests/priority_5/testconfig @@ -2,10 +2,13 @@ runscript main.sh [requirements] priority 5 +[skip] +prevrunning #t + [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 ADDED tests/fullrun/tests/special/testconfig Index: tests/fullrun/tests/special/testconfig ================================================================== --- /dev/null +++ tests/fullrun/tests/special/testconfig @@ -0,0 +1,8 @@ +[ezsteps] +# calcresults megatest -list-runs $MT_RUNNAME -target $MT_TARGET + +[requirements] +waiton #{rget TESTSTORUN} + +# This is a "toplevel" test, it does not require waitons to be non-FAIL to run +mode toplevel ADDED tests/mintest/megatest.config Index: tests/mintest/megatest.config ================================================================== --- /dev/null +++ tests/mintest/megatest.config @@ -0,0 +1,16 @@ +[fields] +X TEXT + +[setup] +max_concurrent_jobs 50 +linktree #{getenv PWD}/linktree + +[server] +port 8090 + +[jobtools] +useshell yes +launcher nbfind + +[disks] +disk0 #{getenv PWD}/runs ADDED tests/mintest/runconfigs.config Index: tests/mintest/runconfigs.config ================================================================== --- /dev/null +++ tests/mintest/runconfigs.config @@ -0,0 +1,6 @@ +[default] +ALLTESTS see this variable + +# Your variables here are grouped by targets [SYSTEM/RELEASE] +[a] +ANOTHERVAR only defined if target is "a" ADDED tests/mintest/tests/a/testconfig Index: tests/mintest/tests/a/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/a/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton b ADDED tests/mintest/tests/b/testconfig Index: tests/mintest/tests/b/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/b/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton c ADDED tests/mintest/tests/c/testconfig Index: tests/mintest/tests/c/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/c/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton d ADDED tests/mintest/tests/d/testconfig Index: tests/mintest/tests/d/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/d/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton e ADDED tests/mintest/tests/e/testconfig Index: tests/mintest/tests/e/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/e/testconfig @@ -0,0 +1,4 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + ADDED tests/mintest/tests/f/testconfig Index: tests/mintest/tests/f/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/f/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton ADDED tests/mintest/tests/g/testconfig Index: tests/mintest/tests/g/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/g/testconfig @@ -0,0 +1,9 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton b + +[items] +NADA ADDED tests/mintest/tests/h/testconfig Index: tests/mintest/tests/h/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/h/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton b ADDED tests/mintest/tests/i/testconfig Index: tests/mintest/tests/i/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/i/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton b ADDED tests/mintest/tests/j/testconfig Index: tests/mintest/tests/j/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/j/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton b ADDED tests/mintest/tests/k/testconfig Index: tests/mintest/tests/k/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/k/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton b ADDED tests/mintest/tests/l/testconfig Index: tests/mintest/tests/l/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/l/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton b Index: tests/simplerun/tests/test1/step1.logpro ================================================================== --- tests/simplerun/tests/test1/step1.logpro +++ tests/simplerun/tests/test1/step1.logpro @@ -1,7 +1,7 @@ ;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) +;; (expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) ;; You may need ignores to suppress false error or warning hits from the later expects ;; NOTE: Order is important here! (expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) (expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) Index: tests/simplerun/tests/test1/step1.sh ================================================================== --- tests/simplerun/tests/test1/step1.sh +++ tests/simplerun/tests/test1/step1.sh @@ -1,4 +1,5 @@ #!/usr/bin/env bash # Run your step here echo Got here! + Index: tests/simplerun/tests/test1/step2.logpro ================================================================== --- tests/simplerun/tests/test1/step2.logpro +++ tests/simplerun/tests/test1/step2.logpro @@ -1,7 +1,7 @@ ;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) +;; (expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) ;; You may need ignores to suppress false error or warning hits from the later expects ;; NOTE: Order is important here! (expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) (expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) Index: tests/simplerun/tests/test1/step2.sh ================================================================== --- tests/simplerun/tests/test1/step2.sh +++ tests/simplerun/tests/test1/step2.sh @@ -1,5 +1,6 @@ #!/usr/bin/env bash # Run your step here echo Got here eh! + Index: tests/simplerun/tests/test2/step1.logpro ================================================================== --- tests/simplerun/tests/test2/step1.logpro +++ tests/simplerun/tests/test2/step1.logpro @@ -1,7 +1,7 @@ ;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) +;; (expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) ;; You may need ignores to suppress false error or warning hits from the later expects ;; NOTE: Order is important here! (expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) (expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) Index: tests/simplerun/tests/test2/step2.logpro ================================================================== --- tests/simplerun/tests/test2/step2.logpro +++ tests/simplerun/tests/test2/step2.logpro @@ -1,7 +1,7 @@ ;; You should have at least one expect:required. This ensures that your process ran -(expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) +;; (expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/) ;; You may need ignores to suppress false error or warning hits from the later expects ;; NOTE: Order is important here! (expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) (expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) ADDED tests/test7.logpro Index: tests/test7.logpro ================================================================== --- /dev/null +++ tests/test7.logpro @@ -0,0 +1,8 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "All tests launched" #/INFO:.*All tests launched/) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/)) ;; but disallow any other errors Index: tests/tests.scm ================================================================== --- tests/tests.scm +++ tests/tests.scm @@ -79,36 +79,35 @@ (test "setup for run" #t (begin (setup-for-run) (string? (getenv "MT_RUN_AREA_HOME")))) (test "server-register, get-best-server" #t (let ((res #f)) - (open-run-close tasks:server-register tasks:open-db 1 "bob" 1234 100 'live) + (open-run-close tasks:server-register tasks:open-db 1 "bob" 1234 100 'live 'http) (set! res (open-run-close tasks:get-best-server tasks:open-db)) - (number? (cadddr res)))) + (number? (vector-ref res 3)))) (test "de-register server" #t (let ((res #f)) - (open-run-close tasks:server-deregister tasks:open-db "bob" pullport: 1234) - (list? (open-run-close tasks:get-best-server tasks:open-db)))) + (open-run-close tasks:server-deregister tasks:open-db "bob" port: 1234) + (vector? (open-run-close tasks:get-best-server tasks:open-db)))) -(define hostinfo #f) +(define server-pid #f) +(test "launch server" #t (let ((pid (process-fork (lambda () + ;; (daemon:ize) + (server:launch 'http))))) + (set! server-pid pid) + (number? pid))) + +(thread-sleep! 3) ;; need to wait for server to start. Yes, a better way is needed. (test "get-best-server" #t (let ((dat (open-run-close tasks:get-best-server tasks:open-db))) - (set! hostinfo dat) ;; host ip pullport pubport - (and (string? (car dat)) - (number? (caddr dat))))) - -(test #f #t (let ((zmq-socket (server:client-connect - (cadr hostinfo) - (caddr hostinfo) - ;; (cadddr hostinfo) - ))) - (set! *runremote* zmq-socket) - (string? (car *runremote*)))) - -(test #f #t (let ((res (server:client-login *runremote*))) + (set! *runremote* (list (vector-ref dat 1)(vector-ref dat 2))) ;; host ip pullport pubport + (and (string? (car *runremote*)) + (number? (cadr *runremote*))))) + +(test #f #t (car (cdb:login *runremote* *toppath* *my-client-signature*))) +(test #f #t (let ((res (client:login *runremote*))) (car res))) -(test #f #t (car (cdb:login *runremote* *toppath* *my-client-signature*))) ;;====================================================================== ;; C O N F I G F I L E S ;;====================================================================== @@ -169,26 +168,26 @@ ;; (cdb:set-verbosity *runremote* *verbosity*) (test "get all legal tests" (list "test1" "test2") (sort (get-all-legal-tests) string<=?)) -(test "get-keys" "SYSTEM" (vector-ref (car (db:get-keys *db*)) 0));; (key:get-fieldname (car (sort (db-get-keys *db*)(lambda (a b)(string>=? (vector-ref a 0)(vector-ref b 0))))))) +(test "get-keys" "SYSTEM" (car (db:get-keys *db*))) (define remargs (args:get-args '("bar" "foo" ":runname" "bob" ":SYSTEM" "ubuntu" ":RELEASE" "v1.2" ":datapath" "blah/foo" "nada") (list ":runname" ":state" ":status") (list "-h") args:arg-hash 0)) -(test "register-run" #t (number? (runs:register-run *db* - (db:get-keys *db*) - '(("SYSTEM" "key1")("RELEASE" "key2")) - "myrun" - "new" - "n/a" - "bob"))) +(test "register-run" #t (number? + (db:register-run *db* + '(("SYSTEM" "key1")("RELEASE" "key2")) + "myrun" + "new" + "n/a" + "bob"))) (test #f #t (cdb:tests-register-test *runremote* 1 "nada" "")) (test #f 1 (cdb:remote-run db:get-test-id #f 1 "nada" "")) (test #f "NOT_STARTED" (vector-ref (open-run-close db:get-test-info #f 1 "nada" "") 3)) (test #f "NOT_STARTED" (vector-ref (cdb:get-test-info *runremote* 1 "nada" "") 3)) @@ -198,12 +197,12 @@ ;;====================================================================== ;; D B ;;====================================================================== (test #f "FOO LIKE 'abc%def'" (db:patt->like "FOO" "abc%def")) -(test #f (vector '("SYSTEM" "RELEASE" "id" "runname" "state" "status" "owner" "event_time") '()) - (runs:get-runs-by-patt db keys "%")) +(test #f "key2" (vector-ref (car (vector-ref (runs:get-runs-by-patt *db* '("SYSTEM" "RELEASE") "%" "key1/key2") 1)) 1)) + (test #f "SYSTEM,RELEASE,id,runname,state,status,owner,event_time" (car (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time")))) (test #f #t (runs:operate-on 'print "%" "%" "%")) ;;(test "update-test-info" #t (test-update-meta-info *db* 1 "nada" (setenv "BLAHFOO" "1234") @@ -236,10 +235,13 @@ (hash-table-set! args:arg-hash "-testpatt" "%") (hash-table-set! args:arg-hash "-target" "ubuntu/r1.2") (test "Setup for a run" #t (begin (setup-for-run) #t)) (define *tdb* #f) +(define keyvals #f) +(test "target->keyval" #t (let ((kv (keys:target->keyval keys (args:get-arg "-target")))) + (set! keyvals kv)(list? keyvals))) (define testdbpath (conc "/tmp/" (getenv "USER") "/megatest_testing")) (system (conc "rm -f " testdbpath "/testdat.db;mkdir -p " testdbpath)) (print "Using " testdbpath " for test db") @@ -252,37 +254,88 @@ (define tconfig #f) (test "get a testconfig" #t (let ((tconf (tests:get-testconfig "test1" 'return-procs))) (set! tconfig tconf) (hash-table? tconf))) (db:clean-all-caches) -;; (set! *verbosity* 20) + +(test "set-megatest-env-vars" + "ubuntu" + (begin + (set-megatest-env-vars 1 inkeys: keys) + (get-environment-variable "SYSTEM"))) +(test "setup-env-defaults" + "see this variable" + (begin + (setup-env-defaults "runconfigs.config" 1 *already-seen-runconfig-info* keys keyvals "pre-launch-env-vars") + (get-environment-variable "ALLTESTS"))) + +(test #f "ubuntu" (car (keys:target-set-args keys (args:get-arg "-target") args:arg-hash))) + +(define rinfo #f) +(test "get-run-info" #f (vector? (vector-ref (let ((rinf (cdb:remote-run db:get-run-info #f 1))) + (set! rinfo rinf) + rinf) 0))) +(test "get-key-vals" "key1" (car (cdb:remote-run db:get-key-vals #f 1))) +(test "tests:sort-by" '() (tests:sort-by-priority-and-waiton (make-hash-table))) + +(test "update-test_meta" "test1" (begin + (runs:update-test_meta "test1" tconfig) + (let ((dat (cdb:remote-run db:testmeta-get-record #f "test1"))) + (vector-ref dat 1)))) + +(define test-path "tests/test1") +(define disk-path #f) +(test "get-best-disk" #t (string? (file-exists? (let ((d (get-best-disk *configdat*))) + (set! disk-path d) + d)))) +(test "create-work-area" #t (symbolic-link? (car (create-work-area 1 rinfo keyvals 1 test-path disk-path "test1" '())))) +(test #f "" (item-list->path '())) + +(test "launch-test" #t (string? (file-exists? (launch-test 1 1 rinfo keyvals "run1" tconfig "test1" test-path '() (make-hash-table))))) + + (test "Run a test" #t (general-run-call "-runtests" "run a test" - (lambda (target runname keys keynames keyvallst) + (lambda (target runname keys keyvallst) (let ((test-patts "test%")) ;; (runs:run-tests target runname test-patts user (make-hash-table)) + ;; (run:test run-id run-info key-vals runname test-record flags parent-test) + ;; (set! *verbosity* 22) ;; (list 0 1 2)) (run:test 1 ;; run-id - (args:get-arg ":runname") - (keys:target->keyval keys target) - (vector + #f ;; run-info is yet only a dream + keyvallst ;; (keys:target->keyval keys target) + "run1" ;; runname + (vector ;; test_records.scm tests:testqueue "test1" ;; testname tconfig ;; testconfig '() ;; waitons 0 ;; priority #f ;; items #f ;; itemsdat - #f ;; spare + "" ;; itempath ) args:arg-hash ;; flags (e.g. -itemspatt) - #f))))) + #f) + ;; (set! *verbosity* 0) + )))) + + + + + +(test "server stop" #f (let ((hostname (car *runremote*)) + (port (cadr *runremote*))) + (tasks:kill-server #t hostname port server-pid 'http) + (open-run-close tasks:get-best-server tasks:open-db))) -(test "cache is coherent" #t (let ((cached-info (db:get-test-info-cached-by-id db 2)) - (non-cached (db:get-test-info-not-cached-by-id db 2))) - (print "\nCached: " cached-info) - (print "Noncached: " non-cached) - (equal? cached-info non-cached))) +(exit 1) +;; (test "cache is coherent" #t (let ((cached-info (db:get-test-info-cached-by-id db 2)) +;; (non-cached (db:get-test-info-not-cached-by-id db 2))) +;; (print "\nCached: " cached-info) +;; (print "Noncached: " non-cached) +;; (equal? cached-info non-cached))) (change-directory test-work-dir) (test "Add a step" #t (begin (db:teststep-set-status! db 2 "step1" "start" 0 "This is a comment" "mylogfile.html") @@ -390,11 +443,16 @@ (hash-table-set! args:arg-hash ":runname" "%") (test "Remove the rollup run" #t (begin (operate-on 'remove-runs))) (print "Waiting for server to be done, should be about 20 seconds") -(cdb:kill-server *runremote*) +(test "server stop" #f (let ((hostname (car *runremote*)) + (port (cadr *runremote*))) + (tasks:kill-server #t hostname port server-pid 'http) + (open-run-close tasks:get-best-server tasks:open-db))) + +;; (cdb:kill-server *runremote*) ;; (thread-join! th1 th2 th3) ;; ADD ME!!!! (db:get-prereqs-not-met *db* 1 '("runfirst") "" mode: 'normal) ;; ADD ME!!!! (rdb:get-tests-for-run *db* 1 "runfirst" #f '() '()) ADDED tree.scm Index: tree.scm ================================================================== --- /dev/null +++ tree.scm @@ -0,0 +1,116 @@ +;;====================================================================== +;; Copyright 2006-2013, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. +;;====================================================================== + +(use format) +(require-library iup) +(import (prefix iup iup:)) +(use canvas-draw) + +(use sqlite3 srfi-1 posix regex regex-case srfi-69) +(import (prefix sqlite3 sqlite3:)) + +(declare (unit tree)) +(declare (uses margs)) +(declare (uses launch)) +(declare (uses megatest-version)) +(declare (uses gutils)) +(declare (uses db)) +(declare (uses server)) +(declare (uses synchash)) +(declare (uses dcommon)) + +(include "common_records.scm") +(include "db_records.scm") +(include "key_records.scm") + +;;====================================================================== +;; T R E E S T U F F +;;====================================================================== + +;; path is a list of nodes, each the child of the previous +;; this routine returns the id so another node can be added +;; either as a leaf or as a branch +;; +;; BUG: This needs a stop sensor for when a branch is exhausted +;; +(define (tree:find-node obj path) + ;; start at the base of the tree + (if (null? path) + #f ;; or 0 ???? + (let loop ((hed (car path)) + (tal (cdr path)) + (depth 0) + (nodenum 0)) + ;; nodes in iup tree are 100% sequential so iterate over nodenum + (if (iup:attribute obj (conc "DEPTH" nodenum)) ;; end when no more nodes + (let ((node-depth (string->number (iup:attribute obj (conc "DEPTH" nodenum)))) + (node-title (iup:attribute obj (conc "TITLE" nodenum)))) + (if (and (equal? depth node-depth) + (equal? hed node-title)) ;; yep, this is the one! + (if (null? tal) ;; end of the line + nodenum + (loop (car tal)(cdr tal)(+ depth 1)(+ 1 nodenum))) + ;; this is the case where we found part of the hierarchy but not + ;; all of it, i.e. the node-depth went from deep to less deep + (if (> depth node-depth) ;; (+ 1 node-depth)) + #f + (loop hed tal depth (+ nodenum 1))))) + #f)))) + +;; top is the top node name zeroeth node VALUE=0 +(define (tree:add-node obj top nodelst #!key (userdata #f)) + (if (not (iup:attribute obj "TITLE0")) + (iup:attribute-set! obj "ADDBRANCH0" top)) + (cond + ((not (string=? top (iup:attribute obj "TITLE0"))) + (print "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0"))) + ((null? nodelst)) + (else + (let loop ((hed (car nodelst)) + (tal (cdr nodelst)) + (depth 1) + (pathl (list top))) + ;; Because the tree dialog changes node numbers when + ;; nodes are added or removed we must look up nodes + ;; each and every time. 0 is the top node so default + ;; to that. + (let* ((newpath (append pathl (list hed))) + (parentnode (tree:find-node obj pathl)) + (nodenum (tree:find-node obj newpath))) + ;; Add the branch under lastnode if not found + (if (not nodenum) + (begin + (iup:attribute-set! obj (conc "ADDBRANCH" parentnode) hed) + (if userdata + (iup:attribute-set! obj (conc "USERDATA" parentnode) userdata)) + (if (null? tal) + #t + ;; reset to top + (loop (car nodelst)(cdr nodelst) 1 (list top)))) + (if (null? tal) ;; if null here then this path has already been added + #t + (loop (car tal)(cdr tal)(+ depth 1) newpath)))))))) + +(define (tree:node->path obj nodenum) + (let loop ((currnode 0) + (path '())) + (let* ((node-depth (string->number (iup:attribute obj (conc "DEPTH" currnode)))) + (node-title (iup:attribute obj (conc "TITLE" currnode))) + (trimpath (if (and (not (null? path)) + (> (length path) node-depth)) + (take path node-depth) + path)) + (newpath (append trimpath (list node-title)))) + (if (>= currnode nodenum) + newpath + (loop (+ currnode 1) + newpath))))) +