Index: .fossil-settings/ignore-glob ================================================================== --- .fossil-settings/ignore-glob +++ .fossil-settings/ignore-glob @@ -1,13 +1,43 @@ 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 +deploytarg/* +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/* +tests/installall/stdrel/* +tests/installall/runs/* +tests/installall/links/* +tests/fdktestqa/simpleruns/* +tests/installall/megatest.db +tests/installall/monitor.db +tests/megatest.db +tests/fdktestqa/simplelinks/* +tests/fdktestqa/testqa/megatest.db +tests/fdktestqa/testqa/monitor.db +megatest-fossil-hash.scm 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 ezsteps.scm lock-queue.scm sdb.scm GUISRCF = dashboard-tests.scm dashboard-guimonitor.scm OFILES = $(SRCFILES:%.scm=%.o) GOFILES = $(GUISRCF:%.scm=%.o) @@ -20,11 +21,14 @@ MTESTHASH=$(shell fossil info|grep checkout:| awk '{print $$2}') CSIPATH=$(shell which csi) CKPATH=$(shell dirname $(shell dirname $(CSIPATH))) -all : mtest dboard newdboard +all : mtest dboard newdboard txtdb + +refdb : txtdb/txtdb.scm + csc -I txtdb txtdb/txtdb.scm -o refdb mtest: $(OFILES) megatest.o csc $(CSCOPTS) $(OFILES) megatest.o -o mtest dboard : $(OFILES) $(GOFILES) dashboard.scm @@ -31,10 +35,13 @@ csc $(OFILES) dashboard.scm $(GOFILES) -o dboard newdboard : newdashboard.scm $(OFILES) $(GOFILES) csc $(OFILES) $(GOFILES) newdashboard.scm -o newdboard +$(PREFIX)/bin/revtagfsl : utils/revtagfsl.scm + csc utils/revtagfsl.scm -o $(PREFIX)/bin/revtagfsl + deploytarg/libiupcd.so : $(CKPATH)/lib/libiupcd.so for i in iup im cd av call sqlite; do \ cp $(CKPATH)/lib/lib$$i* deploytarg/ ; \ done cp $(CKPATH)/include/*.h deploytarg @@ -56,11 +63,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 @@ -85,18 +92,26 @@ chmod a+x $@ $(DEPLOYHELPERS) : utils/mt_* $(INSTALL) $< $@ chmod a+X $@ + +$(PREFIX)/bin/mt_xterm : utils/mt_xterm + $(INSTALL) $< $@ + chmod a+x $@ $(PREFIX)/bin/nbfake : utils/nbfake $(INSTALL) $< $@ chmod a+x $@ $(PREFIX)/bin/nbfind : utils/nbfind $(INSTALL) $< $@ chmod a+x $@ + +$(PREFIX)/bin/refdb : refdb + $(INSTALL) $< $@ + chmod a+x $@ deploytarg/nbfake : utils/nbfake $(INSTALL) $< $@ chmod a+x $@ @@ -109,11 +124,12 @@ $(PREFIX)/bin/dboard : dboard $(FILES) $(INSTALL) dboard $(PREFIX)/bin/dboard utils/mk_wrapper $(PREFIX) dboard > $(PREFIX)/bin/dashboard chmod a+x $(PREFIX)/bin/dashboard -install : bin $(PREFIX)/bin/mtest $(PREFIX)/bin/megatest $(PREFIX)/bin/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake $(PREFIX)/bin/nbfind $(PREFIX)/bin/newdboard +install : bin $(PREFIX)/bin/mtest $(PREFIX)/bin/megatest $(PREFIX)/bin/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \ + $(PREFIX)/bin/nbfind $(PREFIX)/bin/newdboard $(PREFIX)/bin/refdb $(PREFIX)/bin/mt_xterm $(PREFIX)/bin/revtagfsl deploytarg/apropos.so : Makefile for i in apropos base64 canvas-draw csv-xml directory-utils dot-locking extras fmt format hostinfo http-client intarweb json md5 message-digest posix posix-extras readline regex regex-case s11n spiffy spiffy-request-vars sqlite3 srfi-1 srfi-18 srfi-69 tcp test uri-common check-errors synch matchable sql-null tcp-server rpc blob-utils string-utils variable-item defstruct uri-generic sendfile opensll openssl lookup-table list-utils stack; do \ chicken-install -prefix deploytarg -deploy $$i;done @@ -130,6 +146,6 @@ test: tests/tests.scm cd tests;csi -I .. -b -n tests.scm clean : - rm -f $(OFILES) $(GOFILES) megatest dboard dboard.o megatest.o + rm -f $(OFILES) $(GOFILES) megatest dboard dboard.o megatest.o dashboard.o Index: NOTES ================================================================== --- NOTES +++ NOTES @@ -1,13 +1,38 @@ + +[87cbe68f31] +[be405e8e2e] + +# FROM andyjpg on #chicken + +(let ((original-exit (exit-handler))) + (exit-handler (lambda (#!optional (exit-code 0)) + (printf "Preparing to exit...\n" exit-code) + (for-each (lambda (pid) + (printf "Sending signal/term to ~A\n" pid) + (process-signal pid signal/term)) (children)) + (original-exit exit-code)))) + + + 1. All run control access to db is direct. 2. All test machines must have megatest available 3. Tests may or may not have file system access to the originating 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 uri-common intarweb) +(use spiffy uri-common intarweb http-client spiffy-request-vars uri-common intarweb directory-utils) (declare (unit client)) (declare (uses common)) (declare (uses db)) @@ -50,45 +50,30 @@ ;; Do all the connection work, look up the transport type and set up the ;; connection if required. ;; ;; There are two scenarios. ;; 1. We are a test manager and we received *transport-type* and *runremote* via cmdline -;; 2. We are a run tests, list runs or other interactive process and we mush figure out +;; 2. We are a run tests, list runs or other interactive process and we must figure out ;; *transport-type* and *runremote* from the monitor.db ;; ;; client:setup -(define (client:setup #!key (numtries 50)) +(define (client:setup #!key (numtries 3)) (if (not *toppath*) (if (not (setup-for-run)) (begin (debug:print 0 "ERROR: failed to find megatest.config, exiting") (exit)))) + (push-directory *toppath*) ;; This is probably NOT needed (debug:print-info 11 "*transport-type* is " *transport-type* ", *runremote* is " *runremote*) - (let* ((hostinfo (if (not *transport-type*) ;; If we dont' already have transport type set then figure it out - (open-run-close tasks:get-best-server tasks:open-db) - #f))) - ;; if have hostinfo then extract the transport type - ;; else fall back to fs + (let* ((hostinfo (open-run-close tasks:get-best-server tasks:open-db))) (debug:print-info 11 "CLIENT SETUP, hostinfo=" hostinfo) (set! *transport-type* (if hostinfo (string->symbol (tasks:hostinfo-get-transport hostinfo)) 'fs)) - ;; ;; 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)))) - ;; 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)))))) + ((fs)(if (not *megatest-db*)(set! *megatest-db* (open-db)))) ((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) @@ -95,11 +80,12 @@ (tasks:hostinfo-get-port hostinfo) (tasks:hostinfo-get-pubport hostinfo))) (else ;; default to fs (debug:print 0 "ERROR: unrecognised transport type " *transport-type* " attempting to continue with fs") (set! *transport-type* 'fs) - (set! *megatest-db* (open-db)))))) + (set! *megatest-db* (open-db)))) + (pop-directory))) ;; client:signal-handler (define (client:signal-handler signum) (handle-exceptions exn Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -40,11 +40,11 @@ (define *globalexitstatus* 0) ;; attempt to work around possible thread issues (define *passnum* 0) ;; when running track calls to run-tests or similar ;; SERVER (define *my-client-signature* #f) -(define *transport-type* #f) +(define *transport-type* 'fs) (define *megatest-db* #f) (define *rpc:listener* #f) ;; if set up for server communication this will hold the tcp port (define *runremote* #f) ;; if set up for server communication this will hold (define *last-db-access* (current-seconds)) ;; update when db is accessed via server (define *max-cache-size* 0) @@ -53,36 +53,66 @@ (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 (define *test-paths* (make-hash-table)) ;; cache test-id to test run paths here (define *test-ids* (make-hash-table)) ;; cache run-id, testname, and item-path => test-id (define *test-info* (make-hash-table)) ;; cache the test info records, update the state, status, run_duration etc. from testdat.db +(define *run-info-cache* (make-hash-table)) ;; run info is stable, no need to reget + ;; Awful. Please FIXME (define *env-vars-by-run-id* (make-hash-table)) (define *current-run-name* #f) +;; Testconfig and runconfig caches. +(define *testconfigs* (make-hash-table)) ;; test-name => testconfig +(define *runconfigs* (make-hash-table)) ;; target => runconfig + +;; This is a cache of pre-reqs met, don't re-calc in cases where called with same params less than +;; five seconds ago +(define *pre-reqs-met-cache* (make-hash-table)) + (define (common:clear-caches) (set! *target* (make-hash-table)) (set! *keys* (make-hash-table)) (set! *keyvals* (make-hash-table)) (set! *toptest-paths* (make-hash-table)) (set! *test-paths* (make-hash-table)) (set! *test-ids* (make-hash-table)) (set! *test-info* (make-hash-table)) + (set! *run-info-cache* (make-hash-table)) (set! *env-vars-by-run-id* (make-hash-table)) (set! *test-id-cache* (make-hash-table))) -;; Debugging stuff +;;====================================================================== +;; S T A T E S A N D S T A T U S E S +;;====================================================================== + +(define *common:std-states* + (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ" "STUCK")) + +(define *common:std-statuses* + (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD")) + +;; These are stopping conditions that prevent a test from being run +(define *common:cant-run-states-sym* + '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE)) + +;;====================================================================== +;; D E B U G G I N G S T U F F +;;====================================================================== + (define *verbosity* 1) (define *logging* #f) (define (get-with-default val default) (let ((val (args:get-arg val))) @@ -94,10 +124,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) @@ -140,10 +195,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 ;;====================================================================== @@ -185,26 +321,28 @@ (uname #f)) (if (null? (car uname-res)) "unknown" (caar uname-res)))) -(define (save-environment-as-files fname) +(define (save-environment-as-files fname #!key (ignorevars (list "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR"))) (let ((envvars (get-environment-variables)) - (whitesp (regexp "[^a-zA-Z0-9_\\-:;,.\\/%$]"))) + (whitesp (regexp "[^a-zA-Z0-9_\\-:,.\\/%$]"))) (with-output-to-file (conc fname ".csh") (lambda () (for-each (lambda (key) - (let* ((val (cdr key)) - (sval (if (string-search whitesp val)(conc "\"" val "\"") val))) - (print "setenv " (car key) " " sval))) - envvars))) + (if (not (member key ignorevars)) + (let* ((val (cdr key)) + (sval (if (string-search whitesp val)(conc "\"" val "\"") val))) + (print "setenv " (car key) " " sval)))) + envvars))) (with-output-to-file (conc fname ".sh") (lambda () (for-each (lambda (key) - (let* ((val (cdr key)) - (sval (if (string-search whitesp val)(conc "\"" val "\"") val))) - (print "export " (car key) "=" sval))) + (if (not (member key ignorevars)) + (let* ((val (cdr key)) + (sval (if (string-search whitesp val)(conc "\"" val "\"") val))) + (print "export " (car key) "=" sval)))) envvars))))) ;; set some env vars from an alist, return an alist with original values ;; (("VAR" "value") ...) (define (alist->env-vars lst) @@ -236,10 +374,26 @@ (define (seconds->time-string sec) (time->string (seconds->local-time sec) "%H:%M:%S")) +(define (seconds->work-week/day-time sec) + (time->string + (seconds->local-time sec) "ww%V.%u %H:%M")) + +(define (seconds->work-week/day sec) + (time->string + (seconds->local-time sec) "ww%V.%u")) + +(define (seconds->year-work-week/day sec) + (time->string + (seconds->local-time sec) "%yww%V.%w")) + +(define (seconds->year-work-week/day-time sec) + (time->string + (seconds->local-time sec) "%yww%V.%w %H:%M")) + ;;====================================================================== ;; Colors ;;====================================================================== (define (common:name->iup-color name) @@ -247,26 +401,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: common_records.scm ================================================================== --- common_records.scm +++ common_records.scm @@ -49,20 +49,24 @@ (define (debug:print n . params) (if (debug:debug-mode n) (with-output-to-port (current-error-port) (lambda () - (apply print params) - (if *logging* (apply db:log-event params)))))) + (if *logging* + (db:log-event (apply conc params)) + (apply print params) + ))))) (define (debug:print-info n . params) (if (debug:debug-mode n) (with-output-to-port (current-error-port) (lambda () - (let ((res #f));; (format#format #f "INFO:~2d ~a" n (apply conc params)))) - (apply print "INFO: (" n ") " params) ;; res) - (if *logging* (db:log-event res))))))) + (let ((res (format#format #f "INFO: (~2d) ~a" n (apply conc params)))) + (if *logging* + (db:log-event res) + (apply print "INFO: (" n ") " params) ;; res) + )))))) ;; if a value is printable (i.e. string or number) return the value ;; else return an empty string (define-inline (printable val) (if (or (number? val)(string? val)) val "")) Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -54,10 +54,11 @@ (define configf:include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$")) (define configf:section-rx (regexp "^\\[(.*)\\]\\s*$")) (define configf:blank-l-rx (regexp "^\\s*$")) (define configf:key-sys-pr (regexp "^(\\S+)\\s+\\[system\\s+(\\S+.*)\\]\\s*$")) (define configf:key-val-pr (regexp "^(\\S+)(\\s+(.*)|())$")) +(define configf:key-no-val (regexp "^(\\S+)(\\s*)$")) (define configf:comment-rx (regexp "^\\s*#.*")) (define configf:cont-ln-rx (regexp "^(\\s+)(\\S+.*)$")) ;; read a line and process any #{ ... } constructs @@ -117,20 +118,24 @@ (configf:lookup config "default" var)) (configf:lookup config "default" var)))) (define-inline (configf:read-line p ht allow-processing) (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)))) + (let ((cont-line (and (string? inl) + (not (string-null? inl)) + (equal? "\\" (string-take-right inl 1))))) + (if cont-line ;; last character is \ + (let ((nextl (read-line p))) + (if (not (eof-object? nextl)) + (loop (string-append (if cont-line + (string-take inl (- (string-length inl) 1)) + 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) @@ -140,11 +145,12 @@ (define (read-config path ht allow-system #!key (environ-patt #f)(curr-section #f)(sections #f)) (debug:print-info 5 "read-config " path " allow-system " allow-system " environ-patt " environ-patt " curr-section: " curr-section " sections: " sections " pwd: " (current-directory)) (if (not (file-exists? path)) (begin (debug:print-info 1 "read-config - file not found " path " current path: " (current-directory)) - (if (not ht)(make-hash-table) ht)) + ;; WARNING: This is a risky change but really, we should not return an empty hash table if no file read? + #f) ;; (if (not ht)(make-hash-table) ht)) (let ((inp (open-input-file path)) (res (if (not ht)(make-hash-table) ht))) (let loop ((inl (configf:read-line inp res allow-system)) ;; (read-line inp)) (curr-section-name (if curr-section curr-section "default")) (var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere @@ -206,22 +212,26 @@ ((return-string) cmd) (else (val-proc))))) (loop (configf:read-line inp res allow-system) curr-section-name #f #f)) (loop (configf:read-line inp res allow-system) curr-section-name #f #f))) (configf:key-val-pr ( x key unk1 val unk2 ) (let* ((alist (hash-table-ref/default res curr-section-name '())) - (envar (and environ-patt (string-search (regexp environ-patt) curr-section-name))) - (realval (if envar - (config:eval-string-in-environment val) - val))) - (debug:print-info 6 "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name) - (if envar - (begin - ;; (debug:print-info 4 "read-config key=" key ", val=" val ", realval=" realval) - (setenv key realval))) - (hash-table-set! res curr-section-name - (config:assoc-safe-add alist key realval)) - (loop (configf:read-line inp res allow-system) curr-section-name key #f))) + (envar (and environ-patt (string-search (regexp environ-patt) curr-section-name))) + (realval (if envar + (config:eval-string-in-environment val) + val))) + (debug:print-info 6 "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name) + (if envar + (begin + ;; (debug:print-info 4 "read-config key=" key ", val=" val ", realval=" realval) + (setenv key realval))) + (hash-table-set! res curr-section-name + (config:assoc-safe-add alist key realval)) + (loop (configf:read-line inp res allow-system) curr-section-name key #f))) + (configf:key-no-val ( x key val) (let* ((alist (hash-table-ref/default res curr-section-name '()))) + (hash-table-set! res curr-section-name + (config:assoc-safe-add alist key #t)) + (loop (configf:read-line inp res allow-system) curr-section-name key #f))) ;; if a continued line (configf:cont-ln-rx ( x whsp val ) (let ((alist (hash-table-ref/default res curr-section-name '()))) (if var-flag ;; if set to a string then we have a continued var (let ((newval (conc (config-lookup res curr-section-name var-flag) "\n" @@ -269,11 +279,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,12 @@ (import (prefix sqlite3 sqlite3:)) (declare (unit dashboard-tests)) (declare (uses common)) (declare (uses db)) +(declare (uses gutils)) +(declare (uses ezsteps)) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") @@ -41,11 +43,12 @@ (list "Testname: " "Item path: " "Current state: " "Current status: " "Test comment: " - "Test id: ")) + "Test id: " + "Test date: ")) (list (iup:label "" #:expand "VERTICAL")))) (apply iup:vbox ; #:expand "YES" (list (store-label "testname" (iup:label (db:test-get-testname testdat) #:expand "HORIZONTAL") @@ -62,24 +65,36 @@ (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") (lambda (testdat) - (db:test-get-comment testdat))) + (let ((newcomment (db:test-get-comment testdat))) + (if *dashboard-comment-share-slot* + (if (not (equal? (iup:attribute *dashboard-comment-share-slot* "VALUE") + newcomment)) + (iup:attribute-set! *dashboard-comment-slot* + "VALUE" + newcomment))) + newcomment))) (store-label "testid" (iup:label "TestId " #:expand "HORIZONTAL") (lambda (testdat) (db:test-get-id testdat))) + (store-label "testdate" + (iup:label "TestDate " + #:expand "HORIZONTAL") + (lambda (testdat) + (seconds->work-week/day-time (db:test-get-event_time testdat)))) ))))) ;;====================================================================== ;; Test meta panel ;;====================================================================== @@ -125,26 +140,34 @@ ;;====================================================================== ;; Run info panel ;;====================================================================== (define (run-info-panel keydat testdat runname) - (iup:frame - #:title "Megatest Run Info" ; #:expand "YES" - (iup:hbox ; #:expand "YES" - (apply iup:vbox ; #:expand "YES" - (append (map (lambda (keyval) - (iup:label (conc (car keyval) " ") ; #:expand "HORIZONTAL" - )) - keydat) - (list (iup:label "runname ")(iup:label "run-id")))) - (apply iup:vbox - (append (map (lambda (keyval) - (iup:label (cadr keyval) #:expand "HORIZONTAL")) - keydat) - (list (iup:label runname) - (iup:label (conc (db:test-get-run_id testdat))) - (iup:label "" #:expand "VERTICAL"))))))) + (let* ((run-id (db:test-get-run_id testdat)) + (rundat (cdb:remote-run db:get-run-info #f run-id)) + (header (db:get-header rundat)) + (event_time (db:get-value-by-header (db:get-row rundat) + (db:get-header rundat) + "event_time"))) + (iup:frame + #:title "Megatest Run Info" ; #:expand "YES" + (iup:hbox ; #:expand "YES" + (apply iup:vbox ; #:expand "YES" + (append (map (lambda (keyval) + (iup:label (conc (car keyval) " "))) + keydat) + (list (iup:label "runname ") + (iup:label "run-id") + (iup:label "run-date")))) + (apply iup:vbox + (append (map (lambda (keyval) + (iup:label (cadr keyval) #:expand "HORIZONTAL")) + keydat) + (list (iup:label runname) + (iup:label (conc run-id)) + (iup:label (seconds->year-work-week/day-time event_time)) + (iup:label "" #:expand "VERTICAL")))))))) ;;====================================================================== ;; Host info panel ;;====================================================================== (define (host-info-panel testdat store-label) @@ -188,40 +211,48 @@ ;; 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))) +(define *dashboard-test-db* #t) +(define *dashboard-comment-share-slot* #f) + ;;====================================================================== ;; Set fields ;;====================================================================== -(define (set-fields-panel test-id testdat) +(define (set-fields-panel test-id testdat #!key (db #f)) (let ((newcomment #f) (newstatus #f) - (newstate #f)) + (newstate #f) + (wtxtbox #f)) (iup:frame #:title "Set fields" (iup:vbox (iup:hbox (iup:label "Comment:") - (iup:textbox #:action (lambda (val a b) - (open-run-close db:test-set-state-status-by-id #f test-id #f #f b) - (set! newcomment b)) - #:value (db:test-get-comment testdat) - #:expand "HORIZONTAL")) + (let ((txtbox (iup:textbox #:action (lambda (val a b) + ;; IDEA: Just set a variable with the proc to call? + (open-run-close db:test-set-state-status-by-id db test-id #f #f b) + (set! newcomment b)) + #:value (db:test-get-comment testdat) + #:expand "HORIZONTAL"))) + (set! wtxtbox txtbox) + txtbox)) + (apply iup:hbox (iup:label "STATE:" #:size "30x") (let* ((btns (map (lambda (state) (let ((btn (iup:button state #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" #:action (lambda (x) - (open-run-close db:test-set-state-status-by-id #f test-id state #f #f) + (open-run-close db:test-set-state-status-by-id db test-id state #f #f) (db:test-set-state! testdat state))))) btn)) - (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "KILLED" "KILLREQ")))) + *common:std-states*))) ;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ")))) (vector-set! *state-status* 0 (lambda (state color) (for-each (lambda (btn) (let* ((name (iup:attribute btn "TITLE")) @@ -234,14 +265,27 @@ (iup:label "STATUS:" #:size "30x") (let* ((btns (map (lambda (status) (let ((btn (iup:button status #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" #:action (lambda (x) - (open-run-close db:test-set-state-status-by-id #f test-id #f status #f) - (db:test-set-status! testdat status))))) + (let ((t (iup:attribute x "TITLE"))) + (if (equal? t "WAIVED") + (iup:show (dashboard-tests:waiver testdat + (if wtxtbox (iup:attribute wtxtbox "VALUE") #f) + (lambda (c) + (set! newcomment c) + (if wtxtbox + (begin + (iup:attribute-set! wtxtbox "VALUE" c) + (if (not *dashboard-comment-share-slot*) + (set! *dashboard-comment-share-slot* wtxtbox))) + )))) + (begin + (open-run-close db:test-set-state-status-by-id db test-id #f status #f) + (db:test-set-status! testdat status)))))))) btn)) - (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP")))) + *common:std-statuses*))) ;; (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP")))) (vector-set! *state-status* 1 (lambda (status color) (for-each (lambda (btn) (let* ((name (iup:attribute btn "TITLE")) @@ -249,38 +293,116 @@ (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR"))) (iup:attribute-set! btn "BGCOLOR" newcolor)))) btns))) btns)))))) +(define (dashboard-tests:run-html-viewer lfilename) + (let ((htmlviewercmd (configf:lookup *configdat* "setup" "htmlviewercmd"))) + (if htmlviewercmd + (system (conc "(" htmlviewercmd " " lfilename " ) &")) + (iup:send-url lfilename)))) + +(define (dashboard-tests:run-a-step info) + #t) + +(define (dashboard-tests:step-run-control testdat stepname testconfig) + (iup:dialog ;; #:close_cb (lambda (a)(exit)) ; #:expand "YES" + #:title stepname + (iup:vbox ; #:expand "YES" + (iup:label (conc "Step: " stepname "\nNB// These buttons only run the test step\nfor the purpose of debugging.\nNot all database updates are done.")) + (iup:button "Re-run" + #:expand "HORIZONTAL" + #:action (lambda (obj) + (thread-start! + (make-thread (lambda () + (ezsteps:run-from testdat stepname #t)) + (conc "ezstep run single step " stepname))))) + (iup:button "Re-run and continue" + #:expand "HORIZONTAL" + #:action (lambda (obj) + (thread-start! + (make-thread (lambda () + (ezsteps:run-from testdat stepname #f)) + (conc "ezstep run from step " stepname))))) + ;; (iup:button "Refresh test data" + ;; #:expand "HORIZONTAL" + ;; #:action (lambda (obj) + ;; (print "Refresh test data " stepname)) + ))) + +(define (dashboard-tests:waiver testdat ovrdval cmtcmd) + (let* ((wpatt (configf:lookup *configdat* "setup" "waivercommentpatt")) + (wregx (if (string? wpatt)(regexp wpatt) #f)) + (wmesg (iup:label (if wpatt (conc "Comment must match pattern " wpatt) ""))) + (comnt (iup:textbox #:action (lambda (val a b) + (if wpatt + (if (string-match wregx b) + (iup:attribute-set! wmesg "TITLE" (conc "Comment matches " wpatt)) + (iup:attribute-set! wmesg "TITLE" (conc "Comment does not match " wpatt)) + ))) + #:value (if ovrdval ovrdval (db:test-get-comment testdat)) + #:expand "HORIZONTAL")) + (dlog #f)) + (set! dlog (iup:dialog ;; #:close_cb (lambda (a)(exit)) ; #:expand "YES" + #:title "SET WAIVER" + (iup:vbox ; #:expand "YES" + (iup:label (conc "Enter justification for waiving test " + (db:test-get-testname testdat) + (if (equal? (db:test-get-item-path testdat) "") + "" + (conc "/" (db:test-get-item-path testdat))))) + wmesg ;; the informational msg on whether it matches + comnt + (iup:hbox + (iup:button "Apply and Close " + #:expand "HORIZONTAL" + #:action (lambda (obj) + (let ((comment (iup:attribute comnt "VALUE")) + (test-id (db:test-get-id testdat))) + (if (or (not wpatt) + (string-match wregx comment)) + (begin + (open-run-close db:test-set-state-status-by-id #f test-id #f "WAIVED" comment) + (db:test-set-status! testdat "WAIVED") + (cmtcmd comment) + (iup:destroy! dlog)))))) + (iup:button "Cancel" + #:expand "HORIZONTAL" + #:action (lambda (obj) + (iup:destroy! dlog))))))) + dlog)) ;;====================================================================== ;; ;;====================================================================== (define (examine-test test-id) ;; run-id run-key origtest) - (let* ((testdat (open-run-close db:get-test-info-by-id #f test-id)) - (db-path (conc *toppath* "/megatest.db")) + (let* ((db-path (conc *toppath* "/megatest.db")) + (db (open-db)) + (testdat (open-run-close db:get-test-info-by-id db test-id)) (db-mod-time 0) ;; (file-modification-time db-path)) (last-update 0) ;; (current-seconds)) - (request-update #t) - (db #f)) + (request-update #t)) (if (not testdat) (begin - (debug:print 0 "ERROR: No test data found for test " test-id ", exiting") + (debug:print 2 "ERROR: No test data found for test " test-id ", exiting") (exit 1)) (let* ((run-id (if testdat (db:test-get-run_id testdat) #f)) - (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)) + (keydat (if testdat (open-run-close db:get-key-val-pairs db run-id) #f)) + (rundat (if testdat (open-run-close db:get-run-info db 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) + (testdat-path (conc rundir "/testdat.db")) ;; this gets recalculated until found (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")) (testmeta (if testdat - (let ((tm (open-run-close db:testmeta-get-record #f testname))) + (let ((tm (open-run-close db:testmeta-get-record db testname))) (if tm tm (make-db:testmeta))) (make-db:testmeta))) (keystring (string-intersperse (map (lambda (keyval) @@ -290,42 +412,95 @@ "/")) (item-path (db:test-get-item-path testdat)) (viewlog (lambda (x) (if (file-exists? logfile) ;(system (conc "firefox " logfile "&")) - (iup:send-url logfile) + (dashboard-tests:run-html-viewer 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 "&")) + (dashboard-tests:run-html-viewer 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")) ""))) (system (conc "cd " rundir - ";xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&"))) + ";mt_xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&"))) (message-window (conc "Directory " rundir " not found"))))) + (widgets (make-hash-table)) (refreshdat (lambda () - (let* ((curr-mod-time (file-modification-time db-path)) + (let* ((curr-mod-time (max (file-modification-time db-path) + (if (file-exists? testdat-path) + (file-modification-time testdat-path) + (begin + (set! testdat-path (conc rundir "/testdat.db")) + 0)))) (need-update (or (and (> curr-mod-time db-mod-time) - (> (current-seconds) (+ last-update 2))) ;; every two seconds if db touched + (> (current-milliseconds)(+ last-update 250))) ;; every half seconds if db touched + (> (current-milliseconds)(+ last-update 10000)) ;; force update even 10 seconds request-update)) (newtestdat (if need-update + ;; NOTE: BUG HIDER, try to eliminate this exception handler (handle-exceptions exn - (debug:print-info 2 "test db access issue: " ((condition-property-accessor 'exn 'message) exn)) - (open-run-close db:get-test-info-by-id #f test-id ))))) + (debug:print-info 0 "WARNING: test db access issue for test " test-id ": " ((condition-property-accessor 'exn 'message) exn)) + (make-db:test) + (let* ((newdat (open-run-close db:get-test-info-by-id db test-id )) + (tstdat (if newdat + (open-run-close tests:testdat-get-testinfo db test-id #f) + '()))) + (if (and newdat + (not (null? tstdat))) ;; (update-time cpuload diskfree run-duration) + (let* ((rec (car tstdat)) + (cpuload (vector-ref rec 1)) + (diskfree (vector-ref rec 2)) + (run-dur (vector-ref rec 3))) + (db:test-set-run_duration! newdat run-dur) + (db:test-set-diskfree! newdat diskfree) + (db:test-set-cpuload! newdat cpuload))) + ;; (debug:print 0 "newdat=" newdat) + newdat) + ) + #f))) + ;; (debug:print 0 "newtestdat=" newtestdat) (cond ((and need-update newtestdat) (set! testdat newtestdat) (set! teststeps (db:get-compressed-steps test-id work-area: rundir)) (set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat))) (set! rundir (db:test-get-rundir testdat)) (set! testfullname (db:test-get-fullname testdat)) ;; (debug:print 0 "INFO: teststeps=" (intersperse teststeps "\n ")) + + ;; I don't see why this was implemented this way. Please comment it ... + ;; (if (eq? curr-mod-time db-mod-time) ;; do only once if same + ;; (set! db-mod-time (+ curr-mod-time 1)) + ;; (set! db-mod-time curr-mod-time)) + + (if (not (eq? curr-mod-time db-mod-time)) + (set! db-mod-time curr-mod-time)) + (set! last-update (current-milliseconds)) + (set! request-update #f) ;; met the need ... ) (need-update ;; if this was true and yet there is no data .... - (db:test-set-testname! testdat "DEAD OR DELETED TEST")))))) - (widgets (make-hash-table)) + (db:test-set-testname! testdat "DEAD OR DELETED TEST"))) + (if need-update + (begin + ;; update the gui elements here + (for-each + (lambda (key) + ;; (print "Updating " key) + ((hash-table-ref widgets key) testdat)) + (hash-table-keys widgets)) + (update-state-status-buttons testdat))) + ;; (iup:refresh self) + ))) (meta-widgets (make-hash-table)) (self #f) (store-label (lambda (name lbl cmd) (hash-table-set! widgets name (lambda (testdat) @@ -375,11 +550,32 @@ 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'\"")))) + (clean-run-execute (lambda (x) + (let ((cmd (conc "xterm -geometry 180x20 -e \"" + "megatest -remove-runs -target " keystring " :runname " runname + " -testpatt " (conc testname "/" (if (equal? item-path "") + "%" + item-path)) + ";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'\""))) + (system (conc cmd " &"))))) + (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'\"")) + ))) (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) @@ -399,10 +595,11 @@ (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 "CleanRunExecute!" #:action clean-run-execute #: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)))) @@ -417,15 +614,20 @@ #: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)))) + (if (eq? col 6) + (view-a-log fname) + (iup:show + (dashboard-tests:step-run-control + testdat + (iup:attribute obj (conc lin ":" 1)) + teststeps)))))))) ;; (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") @@ -439,22 +641,45 @@ (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT") ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1") (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES") (let ((proc (lambda (testdat) + (let ((max-row 0)) (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) "")) + (if (> rownum max-row)(set! max-row rownum)) + (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)))) - (iup:attribute-set! steps-matrix "REDRAW" "ALL")))))) + (loop (car tal)(cdr tal)(+ rownum 1) 1)))))) + (if (> max-row 0) + (begin + ;; we are going to speculatively clear rows until we find a row that is already cleared + (let loop ((rownum (+ max-row 1)) + (colnum 0) + (deleted #f)) + ;; (debug:print-info 0 "cleaning " rownum ":" colnum) + (let* ((next-row (if (eq? colnum 6) (+ rownum 1) rownum)) + (next-col (if (eq? colnum 6) 1 (+ colnum 1))) + (mtrx-rc (conc rownum ":" colnum)) + (curr-val (iup:attribute steps-matrix mtrx-rc))) + ;; (debug:print-info 0 "cleaning " rownum ":" colnum " currval= " curr-val) + (if (and (string? curr-val) + (not (equal? curr-val ""))) + (begin + (iup:attribute-set! steps-matrix mtrx-rc "") + (loop next-row next-col #t)) + (if (eq? colnum 6) ;; not done, didn't get a full blank row + (if deleted (loop next-row next-col #f)) ;; exit on this not met + (loop next-row next-col deleted))))) + (iup:attribute-set! steps-matrix "REDRAW" "ALL"))))))) (hash-table-set! widgets "StepsMatrix" proc) (proc testdat)) steps-matrix) ;; populate the Test Data panel (iup:frame @@ -484,30 +709,24 @@ (db:test-data-get-tol x) (db:test-data-get-status x) (db:test-data-get-units x) (db:test-data-get-type x) (db:test-data-get-comment x))) - (open-run-close db:read-test-data #f test-id "%"))) + (open-run-close db:read-test-data db 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" (lambda (x) ;; Now start keeping the gui updated from the db (refreshdat) ;; update from the db here ;(thread-suspend! other-thread) - ;; update the gui elements here - (for-each - (lambda (key) - ;; (print "Updating " key) - ((hash-table-ref widgets key) testdat)) - (hash-table-keys widgets)) - (update-state-status-buttons testdat) - ; (iup:refresh self) (if *exit-started* (set! *exit-started* 'ok)))))))))) 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)) @@ -111,27 +118,56 @@ (define *alltestnamelst* '()) (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* "%")) + +;; Update management +;; (define *last-update* (current-seconds)) +(define *last-db-update-time* 0) +(define *please-update-buttons* #t) +(define *delayed-update* 0) +(define *update-is-running* #f) +(define *update-mutex* (make-mutex)) + +(define *all-item-test-names* '()) (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 *tests-sort-options* (vector (vector "Sort +a" 'testname "ASC") + (vector "Sort -a" 'testname "DESC") + (vector "Sort +t" 'event_time "ASC") + (vector "Sort -t" 'event_time "DESC") + (vector "Sort +s" 'statestatus "ASC") + (vector "Sort -s" 'statestatus "DESC"))) + +;; Don't forget to adjust the >= below if you add to the sort-options above +(define (next-sort-option) + (if (>= *tests-sort-reverse* 5) + (set! *tests-sort-reverse* 0) + (set! *tests-sort-reverse* (+ *tests-sort-reverse* 1))) + *tests-sort-reverse*) + +(define (get-curr-sort) + (vector-ref *tests-sort-options* *tests-sort-reverse*)) + +(define *tests-sort-reverse* 3) (define *hide-empty-runs* #f) +(define *hide-not-hide* #t) ;; toggle for hide/not hide +(define *hide-not-hide-button* #f) +(define *hide-not-hide-tabs* #f) + +(define *current-tab-number* 0) +(define *updaters* (make-hash-table)) (debug:setup) (define uidat #f) @@ -138,106 +174,87 @@ (define-inline (dboard:uidat-get-keycol vec)(vector-ref vec 0)) (define-inline (dboard:uidat-get-lftcol vec)(vector-ref vec 1)) (define-inline (dboard:uidat-get-header vec)(vector-ref vec 2)) (define-inline (dboard:uidat-get-runsvec vec)(vector-ref vec 3)) - (define (message-window msg) (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) - (let* ((c1 (map string->number (string-split color1))) - (c2 (map string->number (string-split color2))) + (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)))) ;; 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*)) + (sort-info (get-curr-sort)) + (sort-by (vector-ref sort-info 1)) + (sort-order (vector-ref sort-info 2)) + (bubble-type (if (member sort-order '(testname)) + 'testname + 'itempath))) + ;; + ;; 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 (mt:get-tests-for-run run-id testnamepatt states statuses + not-in: *hide-not-hide* + sort-by: sort-by + sort-order: sort-order + qryvals: 'shortlist)) + ;; NOTE: bubble-up also sets the global *all-item-test-names* + ;; (tests (bubble-up tmptests priority: bubble-type)) + (key-vals (cdb:remote-run db:get-key-vals #f run-id))) + ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively. + ;; (debug:print 0 "Getting data for run " run-id " with key-vals=" key-vals) + ;; 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) @@ -265,36 +282,35 @@ (vector-set! res 1 (car (string-split (cadr splst) ")")))) res)) lst)) (define (collapse-rows inlst) - (let* ((newlst (filter (lambda (x) - (let* ((tparts (string-split x "(")) - (basetname (if (null? tparts) x (car tparts)))) + (let* ((sort-info (get-curr-sort)) + (sort-by (vector-ref sort-info 1)) + (sort-order (vector-ref sort-info 2)) + (bubble-type (if (member sort-order '(testname)) + 'testname + 'itempath)) + (newlst (filter (lambda (x) + (let* ((tparts (string-split x "(")) + (basetname (if (null? tparts) x (car tparts)))) ;(print "x " x " tparts: " tparts " basetname: " basetname) - (cond - ((string-match blank-line-rx x) #f) - ((equal? x basetname) #t) - ((hash-table-ref/default *collapsed* basetname #f) + (cond + ((string-match blank-line-rx x) #f) + ((equal? x basetname) #t) + ((hash-table-ref/default *collapsed* basetname #f) ;(print "Removing " basetname " from items") - #f) - (else #t)))) - inlst)) - (vlst (run-item-name->vectors newlst)) - ;; sort by second field - (vlst-s1 (sort vlst (lambda (a b) - (let ((astr (vector-ref a 1)) - (bstr (vector-ref b 1))) - (if (string=? astr "") #f #t))))) - ;; (>= (string-length (vector-ref a 1))(string-length (vector-ref b 1)))))) - (vlst-s2 (sort vlst-s1 (lambda (a b) - (string>= (vector-ref a 0)(vector-ref b 0)))))) + #f) + (else #t)))) + inlst)) + (vlst (run-item-name->vectors newlst)) + (vlst2 (bubble-up vlst priority: bubble-type))) (map (lambda (x) (if (equal? (vector-ref x 1) "") (vector-ref x 0) (conc (vector-ref x 0) "(" (vector-ref x 1) ")"))) - vlst-s2))) + vlst2))) (define (update-labels uidat) (let* ((rown 0) (keycol (dboard:uidat-get-keycol uidat)) (lftcol (dboard:uidat-get-lftcol uidat)) @@ -318,116 +334,842 @@ (iup:attribute-set! lbl "TITLE" munged-val))) (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 (get-itemized-tests test-dats) + (let ((tnames '())) + (for-each (lambda (tdat) + (let ((tname (vector-ref tdat 0)) ;; (db:test-get-testname tdat)) + (ipath (vector-ref tdat 1))) ;; (db:test-get-item-path tdat))) + (if (not (equal? ipath "")) + (if (not (member tname tnames)) + (set! tnames (append tnames (list tname))))))) + test-dats))) + +;; Bubble up the top tests to above the items, collect the items underneath +;; all while preserving the sort order from the SQL query as best as possible. +;; +(define (bubble-up test-dats #!key (priority 'itempath)) + (if (null? test-dats) + test-dats + (begin + (let* ((tnames '()) ;; list of names used to reserve order + (tests (make-hash-table)) ;; hash of lists, used to build as we go + (itemized (get-itemized-tests test-dats))) + (for-each + (lambda (testdat) + (let* ((tname (vector-ref testdat 0)) ;; db:test-get-testname testdat)) + (ipath (vector-ref testdat 1))) ;; db:test-get-item-path testdat))) + ;; (seen (hash-table-ref/default tests tname #f))) + (if (not (member tname tnames)) + (if (or (and (eq? priority 'itempath) + (not (equal? ipath ""))) + (and (eq? priority 'testname) + (equal? ipath "")) + (not (member tname itemized))) + (set! tnames (append tnames (list tname))))) + (if (equal? ipath "") + ;; This a top level, prepend it + (hash-table-set! tests tname (cons testdat (hash-table-ref/default tests tname '()))) + ;; This is item, append it + (hash-table-set! tests tname (append (hash-table-ref/default tests tname '())(list testdat)))))) + test-dats) + ;; Set all tests with items + (set! *all-item-test-names* (append (if (null? tnames) + '() + (filter (lambda (tname) + (let ((tlst (hash-table-ref tests tname))) + (and (list tlst) + (> (length tlst) 1)))) + tnames)) + *all-item-test-names*)) + (let loop ((hed (car tnames)) + (tal (cdr tnames)) + (res '())) + (let ((newres (append res (hash-table-ref tests hed)))) + (if (null? tal) + newres + (loop (car tal)(cdr tal) newres)))))))) + (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 (set-bg-on-filter) + (let ((search-changed (not (null? (filter (lambda (key) + (not (equal? (hash-table-ref *searchpatts* key) "%"))) + (hash-table-keys *searchpatts*))))) + (state-changed (not (null? (hash-table-keys *state-ignore-hash*)))) + (status-changed (not (null? (hash-table-keys *status-ignore-hash*))))) + (iup:attribute-set! *hide-not-hide-tabs* "BGCOLOR" + (if (or search-changed + state-changed + status-changed) + "190 180 190" + "190 190 190" + )))) (define (update-search x val) - ;; (print "Setting search for " x " to " val) - (hash-table-set! *searchpatts* x val)) + (hash-table-set! *searchpatts* x val) + (set-bg-on-filter)) (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 "45x50" + #: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)) + (all-tests-registry (tests:get-all)) ;; (tests:get-valid-tests *toppath* '())) + (test-names (hash-table-keys all-tests-registry)) + (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 '() all-tests-registry) + (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" + #:size "x50" + #: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! + *common:std-states* ;; '("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 + *common:std-statuses* ;; '("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 "50x50" + #: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 + (hash-table-ref/default *searchpatts* "test-name" "%/%") + (hash-table-keys *state-ignore-hash*) ;; '() + (hash-table-keys *status-ignore-hash*) ;; '() + not-in: *hide-not-hide* + 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))) + (existing (tree:find-node tb run-path))) + (if (not (hash-table-ref/default (dboard:data-get-path-run-ids *data*) run-path #f)) + (begin + (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" run-path ;; (append key-vals (list run-name)) + userdata: (conc "run-id: " run-id)) + (hash-table-set! (dboard:data-get-path-run-ids *data*) run-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)) @@ -455,103 +1197,123 @@ ;; (mark-for-update) ;; (update-search "item-name" val)) )) (iup:vbox (iup:hbox - (iup:button "Sort" #:action (lambda (obj) - (set! *tests-sort-reverse* (not *tests-sort-reverse*)) - (iup:attribute-set! obj "TITLE" (if *tests-sort-reverse* "+Sort" "-Sort")) - (mark-for-update))) + (iup:button "Sort -t" #:action (lambda (obj) + (next-sort-option) + (iup:attribute-set! obj "TITLE" (vector-ref (vector-ref *tests-sort-options* *tests-sort-reverse*) 0)) + (mark-for-update))) (iup:button "HideEmpty" #:action (lambda (obj) (set! *hide-empty-runs* (not *hide-empty-runs*)) - (iup:attribute-set! obj "TITLE" (if *hide-empty-runs* "+Hide" "-Hide")) + (iup:attribute-set! obj "TITLE" (if *hide-empty-runs* "+HideE" "-HideE")) (mark-for-update))) - (iup:button "Refresh" #:action (lambda (obj) - (mark-for-update)))) + (let ((hideit (iup:button "HideTests" #:action (lambda (obj) + (set! *hide-not-hide* (not *hide-not-hide*)) + (iup:attribute-set! obj "TITLE" (if *hide-not-hide* "HideTests" "NotHide")) + (mark-for-update))))) + (set! *hide-not-hide-button* hideit) + hideit)) (iup:hbox - (iup:button "Quit" #:action (lambda (obj)(if *db* (sqlite3:finalize! *db*))(exit))) - (iup:button "Monitor" #:action (lambda (obj)(system (conc (car (argv))" -guimonitor &"))))) - )) - ;; (iup:button "<- Left" #:action (lambda (obj)(set! *start-run-offset* (+ *start-run-offset* 1)))) - ;; (iup:button "Up ^" #:action (lambda (obj)(set! *start-test-offset* (if (> *start-test-offset* 0)(- *start-test-offset* 1) 0)))) - ;; (iup:button "Down v" #:action (lambda (obj)(set! *start-test-offset* (if (>= *start-test-offset* (length *alltestnamelst*))(length *alltestnamelst*)(+ *start-test-offset* 1))))) - ;; (iup:button "Right ->" #:action (lambda (obj)(set! *start-run-offset* (if (> *start-run-offset* 0)(- *start-run-offset* 1) 0)))) + (iup:button "Quit" #:action (lambda (obj)(if *db* (sqlite3:finalize! *db*))(exit))) + (iup:button "Refresh" #:action (lambda (obj) + (mark-for-update))) + (iup:button "Collapse" #:action (lambda (obj) + (let ((myname (iup:attribute obj "TITLE"))) + (if (equal? myname "Collapse") + (begin + (for-each (lambda (tname) + (hash-table-set! *collapsed* tname #t)) + *all-item-test-names*) + (iup:attribute-set! obj "TITLE" "Expand")) + (begin + (for-each (lambda (tname) + (hash-table-delete! *collapsed* tname)) + (hash-table-keys *collapsed*)) + (iup:attribute-set! obj "TITLE" "Collapse")))) + (mark-for-update)))))) (iup:frame - #:title "hide" + #:title "state/status filter" (iup:vbox (apply iup:hbox (map (lambda (status) (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"))) + (hash-table-delete! *status-ignore-hash* status)) + (set-bg-on-filter)))) + *common:std-statuses*)) ;; '("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) (if (eq? val 1) (hash-table-set! *state-ignore-hash* state #t) - (hash-table-delete! *state-ignore-hash* state))))) - '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED"))) + (hash-table-delete! *state-ignore-hash* state)) + (set-bg-on-filter)))) + *common:std-states*)) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED"))) (iup:valuator #:valuechanged_cb (lambda (obj) (let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10)))) (oldmax (string->number (iup:attribute obj "MAX"))) (maxruns *tot-run-count*)) (set! *start-run-offset* val) (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)))) + #:expand "HORIZONTAL" + #:max (* 10 (length *allruns*)) + #:min 0 + #:step 0.01))) + ;(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" + #:min 0 + #:step 0.01) + (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 +1355,130 @@ #: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") + (iup:attribute-set! tabs "BGCOLOR" "190 190 190") + (set! *hide-not-hide-tabs* tabs) + 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 *last-recalc-ended-time* 0) + +(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 (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) + (> 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) + +;; Force creation of the db in case it isn't already there. +(let ((db (tasks:open-db))) + (sqlite3:finalize! db)) + +(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) + (set! *last-recalc-ended-time* (current-milliseconds)))))) + +;;====================================================================== +;; The heavy lifting starts here +;;====================================================================== + +;; ease debugging by loading ~/.dashboardrc +(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) + (if (file-exists? debugcontrolf) + (load debugcontrolf))) (cond ((args:get-arg "-run") (let ((runid (string->number (args:get-arg "-run")))) (if runid @@ -664,22 +1489,34 @@ (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")))) - (if testid + (let ((testid (string->number (args:get-arg "-test")))) + (if (and (number? testid) + (>= testid 0)) (examine-test testid) (begin - (print "ERROR: testid is not a number " (args:get-arg "-test")) + (debug:print 3 "INFO: tried to open test with invalid test-id. " (args:get-arg "-test")) (exit 1))))) ((args:get-arg "-guimonitor") (gui-monitor *db*)) (else (set! uidat (make-dashboard-buttons *num-runs* *num-tests* *dbkeys*)) (iup:callback-set! *tim* "ACTION_CB" (lambda (x) - (run-update x))))) - ;(print x))))) + (let ((update-is-running #f)) + (mutex-lock! *update-mutex*) + (set! update-is-running *update-is-running*) + (if (not update-is-running) + (set! *update-is-running* #t)) + (mutex-unlock! *update-mutex*) + (if (not update-is-running) + (begin + (dashboard:run-update x) + (mutex-lock! *update-mutex*) + (set! *update-is-running* #f) + (mutex-unlock! *update-mutex*)))) + 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") @@ -77,35 +78,39 @@ 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 write-access (sqlite3:set-busy-handler! db handler)) (if (not dbexists) (db:initialize db)) - (db:set-sync db) + ;; Moving db:set-sync to a call in run.scm - it is a persistent value and only needs to be set once + ;; (db:set-sync db) db)) ;; keeping it around for debugging purposes only (define (open-run-close-no-exception-handling proc idb . params) (debug:print-info 11 "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params) - (let* ((db (if idb - (if (procedure? idb) - (idb) - idb) - (open-db))) - (res #f)) - (set! res (apply proc db params)) - (if (not idb)(sqlite3:finalize! db)) - (debug:print-info 11 "open-run-close-no-exception-handling END" ) - res)) + (if (or *db-write-access* + (not (member proc *db:all-write-procs*))) + (let* ((db (cond + ((sqlite3:database? idb) idb) + ((not idb) (open-db)) + ((procedure? idb) (idb)) + (else (open-db)))) + (res #f)) + (set! res (apply proc db params)) + (if (not idb)(sqlite3:finalize! db)) + (debug:print-info 11 "open-run-close-no-exception-handling END" ) + res) + #f)) (define (open-run-close-exception-handling proc idb . params) (handle-exceptions exn (begin - (debug:print 0 "EXCEPTION: database probably overloaded?") + (debug:print 0 "EXCEPTION: database probably overloaded or unreadable.") (debug:print 0 " " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain) (thread-sleep! (random 120)) (debug:print-info 0 "trying db call one more time....") (apply open-run-close-no-exception-handling proc idb params)) @@ -137,16 +142,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") @@ -155,11 +160,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," @@ -251,22 +256,23 @@ (debug:print-info 11 "open-test-db " work-area) (if (and work-area (directory? work-area) (file-read-access? work-area)) (let* ((dbpath (conc work-area "/testdat.db")) + (tdb-writeable (file-write-access? dbpath)) (dbexists (file-exists? dbpath)) (handler (make-busy-timeout (if (args:get-arg "-override-timeout") (string->number (args:get-arg "-override-timeout")) 136000)))) (handle-exceptions exn (begin - (debug:print 0 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test" + (debug:print 2 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test" ((condition-property-accessor 'exn 'message) exn)) - #f) + (set! db (sqlite3:open-database ":memory:"))) ;; open an in-memory db to allow readonly access (set! db (sqlite3:open-database dbpath))) - (sqlite3:set-busy-handler! db handler) + (if *db-write-access* (sqlite3:set-busy-handler! db handler)) (if (not dbexists) (begin (sqlite3:execute db "PRAGMA synchronous = FULL;") (debug:print-info 11 "Initialized test database " dbpath) (db:testdb-initialize db))) @@ -358,19 +364,23 @@ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log (id INTEGER PRIMARY KEY,event_time TIMESTAMP DEFAULT (strftime('%s','now')),logline TEXT,pwd TEXT,cmdline TEXT,pid INTEGER);") (sqlite3:execute db (conc "PRAGMA synchronous = 0;")))) db)) (define (db:log-local-event . loglst) - (let ((logline (apply conc loglst)) - (pwd (current-directory)) - (cmdline (string-intersperse (argv) " ")) - (pid (current-process-id))) - (db:log-event logline pwd cmdline pid))) + (let ((logline (apply conc loglst))) + ;; (pwd (current-directory)) + ;; (cmdline (string-intersperse (argv) " ")) + ;; (pid (current-process-id))) + (db:log-event logline))) -(define (db:log-event logline pwd cmdline pid) +(define (db:log-event logline) (let ((db (open-logging-db))) - (sqlite3:execute db "INSERT INTO log (logline,pwd,cmdline,pid) VALUES (?,?,?,?);" logline (current-directory)(string-intersperse (argv) " ")(current-process-id)) + (sqlite3:execute db "INSERT INTO log (logline,pwd,cmdline,pid) VALUES (?,?,?,?);" + logline + (current-directory) + (string-intersperse (argv) " ") + (current-process-id)) (sqlite3:finalize! db) logline)) ;;====================================================================== ;; TODO: @@ -454,10 +464,112 @@ ((< mver 1.37) (db:set-var db "MEGATEST_VERSION" 1.37) (sqlite3:execute db "ALTER TABLE tests ADD COLUMN archived INTEGER DEFAULT 0;")) ((< mver megatest-version) (db:set-var db "MEGATEST_VERSION" megatest-version)))))) + +;;====================================================================== +;; M A I N T E N A N C E +;;====================================================================== + +;; select end_time-now from +;; (select testname,item_path,event_time+run_duration as +;; end_time,strftime('%s','now') as now from tests where state in +;; ('RUNNING','REMOTEHOSTSTART','LAUNCED')); + + +(define (db:find-and-mark-incomplete db #!key (ovr-deadtime #f)) + (let* ((incompleted '()) + (deadtime-str (configf:lookup *configdat* "setup" "deadtime")) + (deadtime (if (and deadtime-str + (string->number deadtime-str)) + (string->number deadtime-str) + 7200)) ;; two hours + (run-ids (db:get-run-ids db))) ;; iterate over runs to divy up the calls + (if (number? ovr-deadtime)(set! deadtime ovr-deadtime)) + (for-each + (lambda (run-id) + + ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes + ;; + ;; THIS CANNOT WORK. The run_duration is not updated in the central db due to performance concerns. + ;; The testdat.db file must be consulted. + ;; + ;; HOWEVER: this code in run:test seems to work fine + ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) + ;; (db:test-get-run_duration testdat))) + ;; 600) + (sqlite3:for-each-row + (lambda (test-id) + (set! incompleted (cons test-id incompleted))) + db + "SELECT id FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time - run_duration) > ? AND state IN ('RUNNING','REMOTEHOSTSTART');" + run-id deadtime) + + ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config + ;; + (sqlite3:for-each-row + (lambda (test-id) + (set! incompleted (cons test-id incompleted))) + db + "SELECT id FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time - run_duration) > ? AND state IN ('LAUNCHED');" + run-id (* 60 60 24))) + run-ids) + + ;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE. + ;; + (if (> (length incompleted) 0) + (begin + (debug:print 0 "WARNING: Marking test(s); " (string-intersperse (map conc incompleted) ", ") " as INCOMPLETE") + (sqlite3:execute + db + (conc "UPDATE tests SET state='INCOMPLETE' WHERE id IN (" + (string-intersperse (map conc incompleted) ",") + ");")))))) + +;; Clean out old junk and vacuum the database +;; +;; Ultimately do something like this: +;; +;; 1. Look at test records either deleted or part of deleted run: +;; a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown' +;; b. If test dir gone, delete the test record +;; 2. Look at run records +;; a. If have tests that are not deleted, set state='unknown' +;; b. .... +;; +(define (db:clean-up db) + (let ((count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);")) + (statements + (map (lambda (stmt) + (sqlite3:prepare db stmt)) + (list + ;; delete all tests that belong to runs that are 'deleted' + "DELETE FROM tests WHERE run_id in (SELECT id FROM runs WHERE state='deleted');" + ;; delete all tests that are 'DELETED' + "DELETE FROM tests WHERE state='DELETED';" + ;; delete all tests that have no run + "DELETE FROM tests WHERE run_id NOT IN (SELECT DISTINCT id FROM runs);" + ;; delete all runs that are state='deleted' + "DELETE FROM runs WHERE state='deleted';" + ;; delete empty runs + "DELETE FROM runs WHERE id NOT IN (SELECT DISTINCT r.id FROM runs AS r INNER JOIN tests AS t ON t.run_id=r.id);" + )))) + (sqlite3:with-transaction + db + (lambda () + (sqlite3:for-each-row (lambda (tot) + (debug:print-info 0 "Records count before clean: " tot)) + count-stmt) + (map sqlite3:execute statements) + (sqlite3:for-each-row (lambda (tot) + (debug:print-info 0 "Records count after clean: " tot)) + count-stmt))) + (map sqlite3:finalize! statements) + (sqlite3:finalize! count-stmt) + (db:find-and-mark-incomplete db) + (sqlite3:execute db "VACUUM;"))) ;;====================================================================== ;; meta get and set vars ;;====================================================================== @@ -496,26 +608,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)) @@ -542,18 +657,17 @@ (let ((res #f)) (sqlite3:for-each-row (lambda (val) (set! res val)) db - (conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;") + (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 @@ -569,35 +683,35 @@ 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 - (lambda (id) - (set! res id)) - 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) + (lambda (id) + (set! res id)) + 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=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res) res) (begin (debug:print 0 "ERROR: Called without all necessary keys") #f)))) @@ -610,12 +724,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) "" @@ -625,11 +738,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) @@ -642,40 +755,124 @@ 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 offset limit) ;; 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" + (if limit (conc " LIMIT " limit) "") + (if offset (conc " OFFSET " offset) "") + ";")) + (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))) (define (db:set-comment-for-run db run-id comment) (debug:print-info 11 "db:set-comment-for-run START run-id: " run-id " comment: " comment) (sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" comment run-id) @@ -682,11 +879,20 @@ (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)) + ;; First set any related tests to DELETED + (let ((stmt1 (sqlite3:prepare db "UPDATE tests SET state='DELETED',comment='' WHERE run_id=?;")) + (stmt2 (sqlite3:prepare db "UPDATE runs SET state='deleted',comment='' WHERE id=?;"))) + (sqlite3:with-transaction + db (lambda () + (sqlite3:execute stmt1 run-id) + (sqlite3:execute stmt2 run-id))) + (sqlite3:finalize! stmt1) + (sqlite3:finalize! stmt2))) +;; (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)) @@ -699,27 +905,35 @@ (sqlite3:execute db "UPDATE runs SET state=? WHERE id=?;" newlockval run-id) (sqlite3:execute db "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);" user (conc newlockval " " run-id)) (debug:print-info 1 "" newlockval " run number " run-id))) +(define (db:get-run-ids db) + (let ((res '())) + (sqlite3:for-each-row + (lambda (id) + (set! res (cons id res))) + db + "SELECT id FROM runs;"))) + ;;====================================================================== ;; K E Y S ;;====================================================================== ;; 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))) @@ -726,16 +940,16 @@ ;; 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))) (if mykeyvals mykeyvals - (let* ((keys (get-keys db)) + (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: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 key-val res))) db qry run-id))) @@ -761,71 +975,129 @@ ;; 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") - ) - (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 '()) +(define (db:get-tests-for-run db run-id testpatt states statuses offset limit not-in sort-by sort-order + #!key + (qryvals #f)) + (let* ((qryvalstr (case qryvals + ((shortlist) "id,run_id,testname,item_path,state,status") + ((#f) "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment") + (else qryvals))) + (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) "") + (qry (conc "SELECT " qryvalstr + " 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) ") + ((testname) (conc " ORDER BY testname " (if sort-order (conc sort-order ",") "") " item_path ")) + ((statestatus) (conc " ORDER BY state " (if sort-order (conc sort-order ",") "") " status ")) + ((event_time) " ORDER BY event_time ") + (else (if (string? sort-by) + (conc " ORDER BY " sort-by) + ""))) + (if sort-order sort-order "") + (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))) db qry run-id ) - (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) + (case qryvals + ((shortlist)(map db:test-short-record->norm res)) + ((#f) res) + (else res)))) + +(define (db:test-short-record->norm inrec) + ;; "id,run_id,testname,item_path,state,status" + ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment + (vector (vector-ref inrec 0) ;; id + (vector-ref inrec 1) ;; run_id + (vector-ref inrec 2) ;; testname + (vector-ref inrec 4) ;; state + (vector-ref inrec 5) ;; status + -1 "" -1 -1 "" "-" + (vector-ref inrec 3) ;; item-path + -1 "-" "-")) + + +(define (db:get-tests-for-run-state-status db run-id testpatt) + (let ((res '()) + (tests-match-qry (tests:match->sqlqry testpatt))) + (sqlite3:for-each-row + (lambda (id testname item-path state status) + ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment + (set! res (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res))) + db + (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? " + (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")) + run-id) + res)) + +(define (db:get-testinfo-state-status db test-id) + (let ((res #f)) + (sqlite3:for-each-row + (lambda (run-id testname item-path state status) + ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment + (set! res (vector test-id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-"))) + db + "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=?;" + test-id) res)) ;; get a useful subset of the tests data (used in dashboard ;; use db:mintests-get-{id ,run_id,testname ...} -(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) + #!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 (let* ((res '()) ;; if states or statuses are null then assume match all when not-in is false (states-qry (if (null? states) #f (conc " state " @@ -840,40 +1112,39 @@ " 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 ((rundir) " ORDER BY length(rundir) DESC;") ((event_time) " ORDER BY event_time ASC;") (else ";")) - ))) - (debug:print-info 8 "db:get-tests-for-run qry=" qry) + ))) + (debug:print-info 8 "db:get-tests-for-runs 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))) db qry ) - (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) res)) ;; this one is a bit broken BUG FIXME (define (db:delete-test-step-records db test-id #!key (work-area #f)) ;; Breaking it into two queries for better file access interleaving (let* ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))) ;; test db's can go away - must check every time - (if tdb + (if (sqlite3:database? tdb) (begin (sqlite3:execute tdb "DELETE FROM test_steps;") (sqlite3:execute tdb "DELETE FROM test_data;") (sqlite3:finalize! tdb))))) @@ -889,11 +1160,11 @@ (begin (sqlite3:execute db "DELETE FROM test_steps WHERE test_id=?;" test-id) (sqlite3:execute db "DELETE FROM test_data WHERE test_id=?;" test-id) (if force (sqlite3:execute db "DELETE FROM tests WHERE id=?;" test-id) - (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a' WHERE id=?;" test-id))))) + (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id))))) (define (db:delete-tests-for-run db run-id) (common:clear-caches) (sqlite3:execute db "DELETE FROM tests WHERE run_id=?;" run-id)) @@ -946,35 +1217,48 @@ (define (cdb:tests-update-run-duration serverdat test-id minutes) (cdb:client-call serverdat 'update-run-duration #t *default-numtries* minutes test-id)) (define (cdb:tests-update-uname-host serverdat test-id uname hostname) - (cdb:client-call serverdat 'update-uname-host #t *default-numtries* test-id uname hostname)) + (cdb:client-call serverdat 'update-uname-host #t *default-numtries* uname hostname test-id)) ;; speed up for common cases with a little logic +;; NB// Ultimately this will be deprecated in deference to mt:test-set-state-status-by-id +;; (define (db:test-set-state-status-by-id db test-id newstate newstatus newcomment) (cond ((and newstate newstatus newcomment) - (sqlite3:exectute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus test-id)) + (sqlite3:execute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus newcomment test-id)) ((and newstate newstatus) (sqlite3:execute db "UPDATE tests SET state=?,status=? WHERE id=?;" newstate newstatus test-id)) (else (if newstate (sqlite3:execute db "UPDATE tests SET state=? WHERE id=?;" newstate test-id)) (if newstatus (sqlite3:execute db "UPDATE tests SET status=? WHERE id=?;" newstatus test-id)) - (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment test-id))))) + (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment test-id)))) + (mt:process-triggers test-id newstate newstatus)) +;; Never used, but should be? (define (db:test-set-state-status-by-run-id-testname db run-id test-name item-path status state) (sqlite3:execute db "UPDATE tests SET state=?,status=?,event_time=strftime('%s','now') WHERE run_id=? AND testname=? AND item_path=?;" - state status run-id test-name item-path)) + state status run-id test-name item-path)) (define (db:get-count-tests-running db) (let ((res 0)) (sqlite3:for-each-row (lambda (count) (set! res count)) db - "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART');") + "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id NOT IN (SELECT id FROM runs WHERE state='deleted');") + res)) + +(define (db:get-count-tests-running-for-run-id db run-id) + (let ((res 0)) + (sqlite3:for-each-row + (lambda (count) + (set! res count)) + db + "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=?;" run-id) res)) (define (db:get-running-stats db) (let ((res '())) (sqlite3:for-each-row @@ -990,12 +1274,12 @@ (let ((res 0)) (sqlite3:for-each-row (lambda (count) (set! res count)) db - "SELECT count(id) FROM tests WHERE state = 'RUNNING' OR state = 'LAUNCHED' OR state = 'REMOTEHOSTSTART' - AND testname in (SELECT testname FROM test_meta WHERE jobgroup=?;" + "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') + AND testname in (SELECT testname FROM test_meta WHERE jobgroup=?);" jobgroup) res))) ;; done with run when: ;; 0 tests in LAUNCHED, NOT_STARTED, REMOTEHOSTSTART, RUNNING @@ -1120,11 +1404,11 @@ (define (db:get-test-info db run-id testname item-path) (db:get-test-info-by-id db (db:get-test-id db run-id testname item-path))) (define (db:test-set-comment db test-id comment) (sqlite3:execute - db + db "UPDATE tests SET comment=? WHERE id=?;" comment test-id)) (define (cdb:test-set-rundir! serverdat run-id test-name item-path rundir) (cdb:client-call serverdat 'test-set-rundir #t *default-numtries* rundir run-id test-name item-path)) @@ -1158,11 +1442,11 @@ ;; BUG: Move the values derived from args to parameters and push to megatest.scm (let* ((testpatt (if (args:get-arg "-testpatt")(args:get-arg "-testpatt") "%")) (statepatt (if (args:get-arg ":state") (args:get-arg ":state") "%")) (statuspatt (if (args:get-arg ":status") (args:get-arg ":status") "%")) (runname (if (args:get-arg ":runname") (args:get-arg ":runname") "%")) - (paths-from-db (cdb:remote-run db:test-get-paths-matching-keynames-target db keynames target res + (paths-from-db (cdb:remote-run db:test-get-paths-matching-keynames-target-new db keynames target res testpatt: testpatt statepatt: statepatt statuspatt: statuspatt runname: runname))) (if fnamepatt @@ -1189,17 +1473,46 @@ (testqry (tests:match->sqlqry testpatt)) (qrystr (conc "SELECT t.rundir FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id WHERE " keystr " AND r.runname LIKE '" runname "' AND " testqry " AND t.state LIKE '" statepatt "' AND t.status LIKE '" statuspatt "' ORDER BY t.event_time ASC;"))) - (debug:print 3 "qrystr: " qrystr) (sqlite3:for-each-row (lambda (p) (set! res (cons p res))) db qrystr) res)) + +(define (db:test-get-paths-matching-keynames-target-new db keynames target res + #!key + (testpatt "%") + (statepatt "%") + (statuspatt "%") + (runname "%")) + (let* ((row-ids '()) + (keystr (string-intersperse + (map (lambda (key val) + (conc key " like '" val "'")) + keynames + (string-split target "/")) + " AND ")) + (testqry (tests:match->sqlqry testpatt)) + (runsqry (sqlite3:prepare db (conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';"))) + (tstsqry (sqlite3:prepare db (conc "SELECT rundir FROM tests WHERE run_id=? AND " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;")))) + (sqlite3:for-each-row + (lambda (rid) + (set! row-ids (cons rid row-ids))) + runsqry) + (for-each (lambda (rid) + (sqlite3:for-each-row + (lambda (p) + (set! res (cons p res))) + tstsqry rid)) + row-ids) + (sqlite3:finalize! tstsqry) + (sqlite3:finalize! runsqry) + res)) ;; look through tests from matching runs for a file (define (db:test-get-first-path-matching db keynames target fname) ;; [refpaths] is the section where references to other megatest databases are stored (let ((mt-paths (configf:get-section "refpaths")) @@ -1235,26 +1548,28 @@ ((zmq)(with-output-to-string (lambda ()(serialize obj)))) (else obj))) (define (db:string->obj msg) (case *transport-type* - ((fs) msg) - ((http) - (with-input-from-string - (base64:base64-decode - (string-substitute - (regexp "_") "=" msg #t)) - (lambda ()(deserialize)))) - ((zmq)(with-input-from-string msg (lambda ()(deserialize)))) - (else msg))) + ((fs) msg) + ((http) + (if (string? msg) + (with-input-from-string + (base64:base64-decode + (string-substitute + (regexp "_") "=" msg #t)) + (lambda ()(deserialize))) + (vector #f #f #f))) ;; crude reply for when things go awry + ((zmq)(with-input-from-string msg (lambda ()(deserialize)))) + (else msg))) (define (cdb:use-non-blocking-mode proc) (set! *client-non-blocking-mode* #t) (let ((res (proc))) (set! *client-non-blocking-mode* #f) res)) - + ;; params = 'target cached remparams ;; ;; make-vector-record cdb packet client-sig qtype immediate query-sig params qtime ;; ;; cdb:client-call is the unified interface to all the transports. It dispatches the @@ -1310,35 +1625,35 @@ ;; now get the actual message (let ((myres (db:string->obj (receive-message* sub-socket)))) (if (equal? query-sig (vector-ref myres 1)) (set! res (vector-ref myres 2)) (loop))))))) - ;; (timeout (lambda () - ;; (let loop ((n numretries)) - ;; (thread-sleep! 15) - ;; (if (not res) - ;; (if (> numretries 0) - ;; (begin - ;; (debug:print 2 "WARNING: no reply to query " params ", trying resend") - ;; (debug:print-info 11 "re-sending message") - ;; (send-message push-socket zdat) - ;; (debug:print-info 11 "message re-sent") - ;; (loop (- n 1))) - ;; ;; (apply cdb:client-call *runremote* qtype immediate (- numretries 1) params)) - ;; (begin - ;; (debug:print 0 "ERROR: cdb:client-call timed out " params ", exiting.") - ;; (exit 5)))))))) + ;; (timeout (lambda () + ;; (let loop ((n numretries)) + ;; (thread-sleep! 15) + ;; (if (not res) + ;; (if (> numretries 0) + ;; (begin + ;; (debug:print 2 "WARNING: no reply to query " params ", trying resend") + ;; (debug:print-info 11 "re-sending message") + ;; (send-message push-socket zdat) + ;; (debug:print-info 11 "message re-sent") + ;; (loop (- n 1))) + ;; ;; (apply cdb:client-call *runremote* qtype immediate (- numretries 1) params)) + ;; (begin + ;; (debug:print 0 "ERROR: cdb:client-call timed out " params ", exiting.") + ;; (exit 5)))))))) (debug:print-info 11 "Starting threads") (let ((th1 (make-thread send-receive "send receive")) ;; (th2 (make-thread timeout "timeout")) ) (thread-start! th1) ;; (thread-start! th2) (thread-join! th1) (debug:print-info 11 "cdb:client-call returning res=" res) res)))))) - + (define (cdb:set-verbosity serverdat val) (cdb:client-call serverdat 'set-verbosity #f *default-numtries* val)) (define (cdb:login serverdat keyval signature) (cdb:client-call serverdat 'login #t *default-numtries* keyval megatest-version signature)) @@ -1347,11 +1662,14 @@ (cdb:client-call serverdat 'logout #t *default-numtries* keyval signature)) (define (cdb:num-clients serverdat) (cdb:client-call serverdat 'numclients #t *default-numtries*)) +;; I think this would be more efficient if executed on client side FIXME??? (define (cdb:test-set-status-state serverdat test-id status state msg) + (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) + (cdb:client-call serverdat 'set-test-start-time #t *default-numtries* test-id)) (if msg (cdb:client-call serverdat 'state-status-msg #t *default-numtries* state status msg test-id) (cdb:client-call serverdat 'state-status #t *default-numtries* state status test-id))) ;; run-id test-name item-path minutes cpuload diskfree tmpfree) (define (cdb:test-rollup-test_data-pass-fail serverdat test-id) @@ -1360,29 +1678,54 @@ (define (cdb:pass-fail-counts serverdat test-id fail-count pass-count) (cdb:client-call serverdat 'pass-fail-counts #t *default-numtries* fail-count pass-count test-id)) (define (cdb:tests-register-test serverdat run-id test-name item-path) (cdb:client-call serverdat 'register-test #t *default-numtries* run-id test-name item-path)) + +;; more transactioned calls, these for roll-up-pass-fail stuff +(define (cdb:update-pass-fail-counts serverdat run-id test-name) + (cdb:client-call serverdat 'update-fail-pass-counts #t *default-numtries* run-id test-name run-id test-name run-id test-name)) + +(define (cdb:top-test-set-running serverdat run-id test-name) + (cdb:client-call serverdat 'top-test-set-running #t *default-numtries* run-id test-name)) + +(define (cdb:top-test-set-per-pf-counts serverdat run-id test-name) + (cdb:client-call serverdat 'top-test-set-per-pf-counts #t *default-numtries* run-id test-name run-id test-name run-id test-name)) + +;;= (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) (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:get-test-info #f run-id test-name item-path)) (define (cdb:get-test-info-by-id serverdat test-id) - (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:get-test-info-by-id #f test-id)) + (let ((test-dat (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:get-test-info-by-id #f test-id))) + (hash-table-set! *test-info* test-id (vector (current-seconds) test-dat)) ;; cached for use where up-to-date info is not needed + test-dat)) ;; db should be db open proc or #f (define (cdb:remote-run proc db . params) - (apply cdb:client-call *runremote* 'immediate #f *default-numtries* open-run-close proc #f params)) + (if (or *db-write-access* + (not (member proc *db:all-write-procs*))) + (handle-exceptions + exn + (begin + (debug:print 0 "Problem with call to cdb:remote-run, database may be locked and read-only, waiting and trying again ...") + (thread-sleep! 10) + (apply cdb:remote-run proc db params)) + (apply cdb:client-call *runremote* 'immediate #f *default-numtries* open-run-close proc #f params)) + (begin + (debug:print 0 "ERROR: Attempt to access read-only database") + #f))) (define (db:test-get-logfile-info db run-id test-name) (let ((res #f)) (sqlite3:for-each-row (lambda (path final_logf) @@ -1400,12 +1743,18 @@ ;; A G R E G A T E D T R A N S A C T I O N D B W R I T E S ;;====================================================================== (define db:queries (list '(register-test "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');") + ;; Test state and status + '(set-test-state "UPDATE tests SET state=? WHERE id=?;") + '(set-test-status "UPDATE tests SET state=? WHERE id=?;") '(state-status "UPDATE tests SET state=?,status=? WHERE id=?;") '(state-status-msg "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;") + ;; Test comment + '(set-test-comment "UPDATE tests SET comment=? WHERE id=?;") + '(set-test-start-time "UPDATE tests SET event_time=strftime('%s','now') WHERE id=?;") '(pass-fail-counts "UPDATE tests SET fail_count=?,pass_count=? WHERE id=?;") ;; test_data-pf-rollup is used to set a tests PASS/FAIL based on the pass/fail info from the steps '(test_data-pf-rollup "UPDATE tests SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0 THEN 'FAIL' @@ -1422,17 +1771,39 @@ '(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 != ''));") - )) + ;; stuff for roll-up-pass-fail-counts + '(update-fail-pass-counts "UPDATE tests + SET fail_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status IN ('FAIL','CHECK')), + pass_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED')) + WHERE run_id=? AND testname=? AND item_path='';") + '(top-test-set-running "UPDATE tests SET state='RUNNING' WHERE run_id=? AND testname=? AND item_path='';") + '(top-test-set-per-pf-counts "UPDATE tests + SET state=CASE + WHEN (SELECT count(id) FROM tests + WHERE run_id=? AND testname=? + AND item_path != '' + AND state in ('RUNNING','NOT_STARTED','LAUNCHED','REMOTEHOSTSTART')) > 0 THEN 'RUNNING' + ELSE 'COMPLETED' END, + status=CASE + WHEN fail_count > 0 THEN 'FAIL' + WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' + WHEN (SELECT count(id) FROM tests + WHERE run_id=? AND testname=? + AND item_path != '' + AND status = 'SKIP') > 0 THEN 'SKIP' + ELSE 'UNKNOWN' END + WHERE run_id=? AND 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 - login - immediate + ;; db:roll-up-pass-fail-counts ;; WHY NOT!? + login + immediate flush sync set-verbosity killserver )) @@ -1451,11 +1822,11 @@ (mutex-unlock! *incoming-mutex*) (if (> (length data) 0) ;; Process if we have data (begin (debug:print-info 7 "Writing cached data " data) - + ;; Prepare the needed sql statements ;; (for-each (lambda (request-item) (let ((stmt-key (vector-ref request-item 0)) (query (vector-ref request-item 1))) @@ -1543,11 +1914,11 @@ (thread-sleep! 0.01) (loop)))) (set! *number-of-writes* (+ *number-of-writes* 1)) (set! *writes-total-delay* (+ *writes-total-delay* (- (current-milliseconds) start-time))) got-it)) - + (define (db:process-queue-item db item) (let* ((stmt-key (cdb:packet-get-qtype item)) (qry-sig (cdb:packet-get-query-sig item)) (return-address (cdb:packet-get-client-sig item)) (params (cdb:packet-get-params item)) @@ -1558,11 +1929,11 @@ ;; hand queries off to the write queue (let ((response (case *transport-type* ((http) (debug:print-info 7 "Queuing item " item " for wrapped write") (db:queue-write-and-wait db qry-sig query params)) - (else + (else (apply sqlite3:execute db query params) #t)))) (debug:print-info 7 "Received " response " from wrapped write") (server:reply return-address qry-sig response response)) ;; otherwise if appropriate flush the queue (this is a read or complex query) @@ -1601,18 +1972,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) @@ -1627,60 +2004,21 @@ db "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE run_id=? AND testname=? AND item_path != '';" run-id test-name) res)) -;; Rollup the pass/fail counts from itemized tests into fail_count and pass_count -;; NOTE: Is this duplicating (db:test-data-rollup db test-id status) ???? -(define (db:roll-up-pass-fail-counts db run-id test-name item-path status) - ;; (cdb:flush-queue *runremote*) - (if (and (not (equal? item-path "")) - (member status '("PASS" "WARN" "FAIL" "WAIVED" "RUNNING" "CHECK" "SKIP"))) - (begin - (sqlite3:execute - db - "UPDATE tests - SET fail_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status IN ('FAIL','CHECK')), - pass_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED')) - WHERE run_id=? AND testname=? AND item_path='';" - run-id test-name run-id test-name run-id test-name) - ;; (thread-sleep! 0.1) ;; give other processes a chance here, no, better to be done ASAP? - (if (equal? status "RUNNING") ;; running takes priority over all other states, force the test state to RUNNING - (sqlite3:execute db "UPDATE tests SET state=? WHERE run_id=? AND testname=? AND item_path='';" "RUNNING" run-id test-name) - (sqlite3:execute - db - "UPDATE tests - SET state=CASE - WHEN (SELECT count(id) FROM tests - WHERE run_id=? AND testname=? - AND item_path != '' - AND state in ('RUNNING','NOT_STARTED')) > 0 THEN 'RUNNING' - ELSE 'COMPLETED' END, - status=CASE - WHEN fail_count > 0 THEN 'FAIL' - WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' - WHEN (SELECT count(id) FROM tests - WHERE run_id=? AND testname=? - AND item_path != '' - AND status = 'SKIP') > 0 THEN 'SKIP' - ELSE 'UNKNOWN' END - WHERE run_id=? AND testname=? AND item_path='';" - run-id test-name run-id test-name run-id test-name)) - #f) - #f)) - ;;====================================================================== ;; Tests meta data ;;====================================================================== ;; read the record given a testname (define (db:testmeta-get-record db testname) (let ((res #f)) (sqlite3:for-each-row - (lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags) - (set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags))) - db "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags FROM test_meta WHERE testname=?;" + (lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup) + (set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup))) + db "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta WHERE testname=?;" testname) res)) ;; create a new record for a given testname (define (db:testmeta-add-record db testname) @@ -1695,11 +2033,11 @@ ;;====================================================================== (define (db:csv->test-data db test-id csvdata #!key (work-area #f)) (debug:print 4 "test-id " test-id ", csvdata: " csvdata) (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))) - (if tdb + (if (sqlite3:database? tdb) (let ((csvlist (csv->list (make-csv-reader (open-input-string csvdata) '((strip-leading-whitespace? #t) (strip-trailing-whitespace? #t)) )))) ;; (csv->list csvdata))) (for-each @@ -1755,11 +2093,11 @@ (sqlite3:finalize! tdb))))) ;; get a list of test_data records matching categorypatt (define (db:read-test-data db test-id categorypatt #!key (work-area #f)) (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))) - (if tdb + (if (sqlite3:database? tdb) (let ((res '())) (sqlite3:for-each-row (lambda (id test_id category variable value expected tol units comment status type) (set! res (cons (vector id test_id category variable value expected tol units comment status type) res))) tdb @@ -1787,11 +2125,11 @@ ;; if one or more are fail (any case) then set test status to PASS, non "pass" or "fail" are ignored (define (db:test-data-rollup db test-id status #!key (work-area #f)) (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)) (fail-count 0) (pass-count 0)) - (if tdb + (if (sqlite3:database? tdb) (begin (sqlite3:for-each-row (lambda (fcount pcount) (set! fail-count fcount) (set! pass-count pcount)) @@ -1815,17 +2153,17 @@ ;; if the test is not FAIL then set status based on the fail and pass counts. (cdb:test-rollup-test_data-pass-fail *runremote* test-id) ;; (sqlite3:execute ;; db ;;; NOTE: Should this be WARN,FAIL? A WARN is not a FAIL????? BUG FIXME ;; "UPDATE tests - ;; SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0 - ;; THEN 'FAIL' - ;; WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND - ;; (SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL') - ;; THEN 'PASS' - ;; ELSE status - ;; END WHERE id=?;" + ;; SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0 + ;; THEN 'FAIL' + ;; WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND + ;; (SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL') + ;; THEN 'PASS' + ;; ELSE status + ;; END WHERE id=?;" ;; test-id test-id test-id test-id) )))) (define (db:get-prev-tol-for-test db test-id category variable) ;; Finish me? @@ -1840,20 +2178,25 @@ ;; db-get-test-steps-for-run (define (db:get-steps-for-test db test-id #!key (work-area #f)) (let* ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)) (res '())) - (if tdb - (begin - (sqlite3:for-each-row - (lambda (id test-id stepname state status event-time logfile) - (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res))) - tdb - "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; - test-id) - (sqlite3:finalize! tdb) - (reverse res)) + (if (sqlite3:database? tdb) + (handle-exceptions + exn + (begin + (debug:print 0 "ERROR: error on access to testdat for test with id " test-id) + '()) + (begin + (sqlite3:for-each-row + (lambda (id test-id stepname state status event-time logfile) + (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res))) + tdb + "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; + test-id) + (sqlite3:finalize! tdb) + (reverse res))) '()))) ;; get a pretty table to summarize steps ;; (define (db:get-steps-table db test-id #!key (work-area #f)) @@ -1972,14 +2315,14 @@ ((eq? (db:step-get-event_time a)(db:step-get-event_time b)) (< (db:step-get-id a) (db:step-get-id b))) (else #f))))) res))) -(define (db:get-compressed-steps test-id #!key (work-area #f)) +(define (db:get-compressed-steps test-id #!key (work-area #f)(tdb #f)) (if (or (not work-area) (file-exists? (conc work-area "/testdat.db"))) - (let* ((comprsteps (open-run-close db:get-steps-table #f test-id work-area: work-area))) + (let* ((comprsteps (open-run-close db:get-steps-table tdb test-id work-area: work-area))) (map (lambda (x) ;; take advantage of the \n on time->string (vector (vector-ref x 0) (let ((s (vector-ref x 1))) @@ -2012,11 +2355,11 @@ ;; if prereq test with itempath='' is COMPLETED and PASS, WARN, CHECK, or WAIVED then prereq is met ;; if prereq test with itempath=ref-item-path and COMPLETED with PASS, WARN, CHECK, or WAIVED then prereq is met ;; ;; Note: mode 'normal means that tests must be COMPLETED and ok (i.e. PASS, WARN, CHECK, SKIP or WAIVED) ;; mode 'toplevel means that tests must be COMPLETED only -;; mode 'itemmatch means that tests items must be COMPLETED and (PASS|WARN|WAIVED|CHECK) [[ NB// NOT IMPLEMENTED YET ]] +;; mode 'itemmatch or 'itemwait means that tests items must be COMPLETED and (PASS|WARN|WAIVED|CHECK) [[ NB// NOT IMPLEMENTED YET ]] ;; (define (db:get-prereqs-not-met run-id waitons ref-item-path #!key (mode 'normal)) (if (or (not waitons) (null? waitons)) '() @@ -2024,11 +2367,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 (cdb:remote-run db:get-tests-for-run-state-status #f run-id waitontest-name)) ;; (mt:get-tests-for-run run-id waitontest-name '() '())) (ever-seen #f) (parent-waiton-met #f) (item-waiton-met #f)) (for-each (lambda (test) @@ -2035,24 +2378,44 @@ ;; (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-running (equal? state "RUNNING")) + (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 itemwait)))) + (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))) + ;; For itemwait mode IFF the previous matching item is good the set parent-waiton-met + ((and (member mode '(itemmatch itemwait)) + ;; (not (equal? item-path "")) ;; this applies to both top level (to allow launching of next batch) and items + same-itempath) + (if (and is-completed is-ok) + (set! item-waiton-met #t)) + (if (and (equal? item-path "") + (or is-completed is-running));; this is the parent, set it to run if completed or running + (set! parent-waiton-met #t))) + ;; normal checking of parent items, any parent or parent item not ok blocks running + ((and 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) @@ -2059,19 +2422,18 @@ (set! result (append (if (null? tests)(list waitontest-name) tests) result))))) waitons) (delete-duplicates result)))) (define (db:teststep-set-status! db test-id teststep-name state-in status-in comment logfile #!key (work-area #f)) - (debug:print 4 "test-id: " test-id " teststep-name: " teststep-name) ;; db:open-test-db-by-test-id does cdb:remote-run (let* ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)) (state (items:check-valid-items "state" state-in)) (status (items:check-valid-items "status" status-in))) (if (or (not state)(not status)) (debug:print 3 "WARNING: Invalid " (if status "status" "state") " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) - (if tdb + (if (sqlite3:database? tdb) (begin (sqlite3:execute tdb "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);" test-id teststep-name state-in status-in (current-seconds) (if comment comment "") (if logfile logfile "")) @@ -2201,5 +2563,30 @@ results) ;; brutal clean up (system "rm -rf tempdir"))) ;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%") + +;; This is a list of all procs that write to the db +;; +(define *db:all-write-procs* + (list + db:set-var + db:del-var + db:register-run + db:set-comment-for-run + db:delete-run + db:update-run-event_time + db:lock/unlock-run + db:delete-test-step-records + db:delete-test-records + db:delete-tests-for-run + db:delete-old-deleted-test-records + db:set-tests-state-status + db:test-set-state-status-by-id + db:test-set-state-status-by-run-id-testname + db:test-set-comment + db:testmeta-add-record + db:csv->test-data + db:test-data-rollup + db:teststep-set-status! )) + Index: db_records.scm ================================================================== --- db_records.scm +++ db_records.scm @@ -1,6 +1,6 @@ -(define (make-db:test)(make-vector 6)) +(define (make-db:test)(make-vector 20)) (define-inline (db:test-get-id vec) (vector-ref vec 0)) (define-inline (db:test-get-run_id vec) (vector-ref vec 1)) (define-inline (db:test-get-testname vec) (vector-ref vec 2)) (define-inline (db:test-get-state vec) (vector-ref vec 3)) (define-inline (db:test-get-status vec) (vector-ref vec 4)) ADDED dcommon.scm Index: dcommon.scm ================================================================== --- /dev/null +++ dcommon.scm @@ -0,0 +1,546 @@ +;;====================================================================== +;; 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)) + (max-col-vis (if (> max-col 10) 10 max-col)) + (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-vis) + (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/Makefile ================================================================== --- docs/manual/Makefile +++ docs/manual/Makefile @@ -1,5 +1,7 @@ -megatest_manual.html : megatest_manual.txt getting_started.txt writing_tests.txt reference.txt +megatest_manual.html : megatest_manual.txt getting_started.txt writing_tests.txt reference.txt ../plan.txt asciidoc megatest_manual.txt dos2unix megatest_manual.html +clean: + rm -f megatest_manual.html ADDED docs/manual/howto.txt Index: docs/manual/howto.txt ================================================================== --- /dev/null +++ docs/manual/howto.txt @@ -0,0 +1,48 @@ + +How To Do Things +================ + +Tricks +------ + +This section is a compendium of a various useful tricks for debugging, +configuring and generally getting the most out of Megatest. + +Debugging Tricks +---------------- + +Examining The Environment +~~~~~~~~~~~~~~~~~~~~~~~~~ + +During Config File Processing +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +Organising Your Tests and Tasks +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +/nfs/ch/disks/ch_unienv_disk005/qa_mrwellan/interim/src/megatest/tests/fdktestqa/testqa +---------------------------- +[tests-paths] +1 #{get misc parent}/simplerun/tests +---------------------------- + +------------------- +[setup] +------------------- + +The runscript method is a brute force way to run scripts where the +user is responsible for setting STATE and STATUS + +------------------- +runscript main.csh +------------------- + + +ww30.2 +cellname/LVS/cellname.LAYOUT_ERRORS + +Error: text open + +ww31.3 +cellname/LVS/cellname.LAYOUT_ERRORS + +Error: text open Index: docs/manual/megatest_manual.html ================================================================== --- docs/manual/megatest_manual.html +++ docs/manual/megatest_manual.html @@ -742,46 +742,30 @@ <matt@kiatoa.com>
version 1.0, April 2012
-
-

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

This book is organised as three sub-books; getting started, writing tests and reference.

Why Megatest?

The Megatest project was started for two reasons, the first was an immediate and pressing need for a generalized tool to manage a suite -of regression tests and the second was the fact that I had written or -maintained several such tools at different companies over the years -and it seemed a good thing to have a single open source tool, flexible -enough to meet the needs of any team doing continuous integrating and -or running a complex suite of tests for release qualification.

+of regression tests and the second was the fact that the author had +written or maintained several such tools at different companies over +the years and it seemed a good thing to have a single open source +tool, flexible enough to meet the needs of any team doing continuous +integrating and or running a complex suite of tests for release +qualification.

Megatest Design Philosophy

Megatest is intended to provide the minimum needed resources to make -writing a suite of tests and implementing continuous build for -software, design engineering or process control (via owlfs for +writing a suite of tests and tasks for implementing continuous build +for software, design engineering or process control (via owlfs for example) without being specialized for any specific problem space. Megatest in of itself does not know what constitutes a PASS or FAIL of a test. In most cases megatest is best used in conjunction with logpro or a similar tool to parse, analyze and decide on the test outcome.

@@ -795,10 +779,324 @@ which can launch jobs on local and remote Linux hosts. Currently megatest uses the network filesystem to call home to your master sqlite3 database.

+ +

Road Map

+

Note: This road-map is tentative and subject to change without notice.

+
+

ww32

+
    +
  1. +

    +Rerun step and or subsequent steps from gui +

    +
    2. +
  2. +

    +Refresh test area files from gui +

    +
    3. +
  3. +

    +Clean and re-run button +

    +
    4. +
  4. +

    +Clean up STATE and STATUS handling. +

    +
      +
    1. +

      +Dashboard and Test control panel are reverse order - choose and fix +

      +
      2. +
    2. +

      +Move seldom used states and status to drop down selector +

      +
      3. +
    +
    5. +
  5. +

    +Access test control panel when clicking on Run Summary tests +

    +
    6. +
  6. +

    +Feature: -generate-index-tree +

    +
    7. +
  7. +

    +Change specifing of state and status to use STATE1/STATUS1,STATE2/STATUS2 +

    +
    8. +
+
+
+

ww33

+
    +
  1. +

    +http api available for use with Perl, Ruby etc. scripts +

    +
    2. +
  2. +

    +megatest.config setup entries for: +

    +
      +
    1. +

      +run launching (e.g. /bin/sh %CMD% > /dev/null) +

      +
      2. +
    2. +

      +browser "konqueror %FNAME% +

      +
      3. +
    +
    3. +
+
+
+

ww34

+
    +
  1. +

    +Mark dependent tests for clean/rerun -rerun-downstream +

    +
    2. +
  2. +

    +On run start check for defunct tests in RUNNING, LAUNCHED or REMOTEHOSTSTART and correct or notify +

    +
    3. +
  3. +

    +Fix: refresh of gui sometimes fails on last item (race condition?) +

    +
    4. +
+
+
+

ww35

+
    +
  1. +

    +refdb: Add export of csv, json and sexp +

    +
    2. +
  2. +

    +Convert to using call-with-environment-variables where possible. Should allow handling of parallel runs in same process. +

    +
    3. +
  3. +

    +Re-work text interface wizards. Several bugs on record. Possibly convert to gui based. +

    +
    4. +
  4. +

    +Add to testconfig requirements section; launchlimiter scriptname, calls scriptname to check if ok to launch test +

    +
    5. +
  5. +

    +Refactor Run Summary view, currently very clumsy +

    +
    6. +
  6. +

    +Add option to show steps in Run Summary view +

    +
    7. +
+
+
+

ww36

+
    +
  1. +

    +Refactor guis for resizeablity +

    +
    2. +
  2. +

    +Add filters to Run Summary view and Run Control view +

    +
    3. +
  3. +

    +Add to megatest.config or testconfig; rerunok STATE/STATUS,STATE/STATUS… +

    +
    4. +
  4. +

    +Launch gates for diskspace; /path/one>1G,/path/two>200M,/tmp>5G,#{scheme toppath}>1G +

    +
    5. +
+
+
+

Bin List

+
    +
  1. +

    +Quality improvements +

    +
      +
    1. +

      +Server stutters occasionally +

      +
      2. +
    2. +

      +Large number of items or tests still has some issues. +

      +
      3. +
    3. +

      +Code refactoring +

      +
      4. +
    4. +

      +Replace remote process with true API using json (supports Web app also) +

      +
      5. +
    +
    2. +
  2. +

    +Streamline the gui +

    +
      +
    1. +

      +Everything resizable +

      +
      2. +
    2. +

      +Less clutter +

      +
      3. +
    3. +

      +Tool tips +

      +
      4. +
    4. +

      +Filters on Run Summary, Summary and Run Control panel +

      +
      5. +
    5. +

      +Built in log viewer (partially implemented) +

      +
      6. +
    6. +

      +Refactor the test control panel +

      +
      7. +
    +
    3. +
  3. +

    +Help and documentation +

    +
      +
    1. +

      +Complete the user manual (I’ve been working on this lately). +

      +
      2. +
    2. +

      +Online help in the gui +

      +
      3. +
    +
    4. +
  4. +

    +Streamlined install +

    +
      +
    1. +

      +Deployed version (download a location independent ready to run binary bundle) +

      +
      2. +
    2. +

      +Install Makefile (in progress, needed for Mike to install on VMs) +

      +
      3. +
    3. +

      +Added option to compile IUP (needed for VMs) +

      +
      4. +
    +
    5. +
  5. +

    +Server side run launching +

    +
    6. +
  6. +

    +Support for re-running, cleaning etc. of individual steps (ezsteps makes this very easy to implement). +

    +
    7. +
  7. +

    +Launch process needs built in daemonizing (easy to do, just need to test it thoroughly). +

    +
    8. +
  8. +

    +Wizards for creating tests, regression areas (current ones are text only and limited). +

    +
    9. +
  9. +

    +Fully functional built in web service (currently you can browse runs but it is very simplistic). +

    +
    10. +
  10. +

    +Wildcards in runconfigs: e.g. [p1271/9/%/%] +

    +
    11. +
  11. +

    +Gui panels for editing megatest.config and runconfigs.config +

    +
    12. +
  12. +

    +Fully isolated tests (no use of NFS to see regression area files) +

    +
    13. +
  13. +

    +Windows version +

    +
    14. +

Getting Started

Getting started with Megatest
@@ -886,41 +1184,158 @@

An example link to anchor at start of the first sub-section.

An example link to a bibliography entry [taoup].

-

Reference

+

Writing Tests

The First Chapter of the Second Part

Chapters grouped into book parts are at level 1 and can contain sub-sections.

+
+

Reference

+
+

The First Chapter of the Second Part

+
+

Chapters grouped into book parts are at level 1 and can contain +sub-sections.

+

The testconfig File

+
+

Setup section

+
+

Header

+
+
+
[setup]
+
+

The runscript method is a brute force way to run scripts where the +user is responsible for setting STATE and STATUS

+
+
+
runscript main.csh
+
+
+
+
+

Requirements section

+
+

Header

+
+
+
[requirements]
+
+
+
+

Wait on Other Tests

-
# testconfig
-[requirements]
-
-# A normal waiton waits for the prior tests to be COMPLETED
+
# A normal waiton waits for the prior tests to be COMPLETED
 # and PASS, CHECK or WAIVED
-waiton test1 test2
-
-# A item based waiton will start items in a test when the
-# same-named item is COMPLETED and PASS, CHECK or WAIVED
-# in the prior test
-#
-mode   normal | toplevel
-
-# With a toplevel test you may wish to generate your list
+waiton test1 test2

+
+
+
+

Mode

+

The default (i.e. if mode is not specified) is normal. All pre-dependent tests +must be COMPLETED and PASS, CHECK or WAIVED before the test will start

+
+
+
mode   normal
+
+

The toplevel mode requires only that the prior tests are COMPLETED.

+
+
+
mode toplevel
+
+

A item based waiton will start items in a test when the +same-named item is COMPLETED and PASS, CHECK or WAIVED +in the prior test

+
+
+
mode itemmatch
+
+
+
+
# With a toplevel test you may wish to generate your list
 # of tests to run dynamically
 #
 # waiton #{shell get-valid-tests-to-run.sh}
+
+
+

Run time limit

+
+
+
runtimelim 1h 2m 3s  # this will automatically kill the test if it runs for more than 1h 2m and 3s
+
+
+
+

Skip

+
+
+

Header

+
+
+
[skip]
+
+
+
+

Skip on Still-running Tests

+
+
+
# NB// If the prevrunning line exists with *any* value the test will
+# automatically SKIP if the same-named test is currently RUNNING
+
+prevrunning x
+
+
+
+

Skip if a File Exists

+
+
+
fileexists /path/to/a/file # skip if /path/to/a/file exists
+
+
+
+

Controlled waiver propagation

+

If test is FAIL and previous test in run with same MT_TARGET is WAIVED then apply the following rules from the testconfig: +If a waiver check is specified in the testconfig apply the check and if it passes then set this FAIL to WAIVED

+

Waiver check has two parts, 1) a list of waiver, rulename, filepatterns and 2) the rulename script spec (note that "diff" and "logpro" are predefined)

+
+
+
###### EXAMPLE FROM testconfig #########
+# matching file(s) will be diff'd with previous run and logpro applied
+# if PASS or WARN result from logpro then WAIVER state is set
+#
+[waivers]
+# logpro_file    rulename      input_glob
+waiver_1         logpro        lookittmp.log
+
+[waiver_rules]
+
+# This builtin rule is the default if there is no <waivername>.logpro file
+# diff   diff %file1% %file2%
+
+# This builtin rule is applied if a <waivername>.logpro file exists
+# logpro diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html
+
+
+
+
+

Ezsteps

+

To transfer the environment to the next step you can do the following:

+
+
+
$MT_MEGATEST -env2file .ezsteps/${stepname}
+
+

Appendix A: Example Appendix

@@ -1000,10 +1415,10 @@
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. @@ -30,22 +13,23 @@ Why Megatest? ~~~~~~~~~~~~~ The Megatest project was started for two reasons, the first was an immediate and pressing need for a generalized tool to manage a suite -of regression tests and the second was the fact that I had written or -maintained several such tools at different companies over the years -and it seemed a good thing to have a single open source tool, flexible -enough to meet the needs of any team doing continuous integrating and -or running a complex suite of tests for release qualification. +of regression tests and the second was the fact that the author had +written or maintained several such tools at different companies over +the years and it seemed a good thing to have a single open source +tool, flexible enough to meet the needs of any team doing continuous +integrating and or running a complex suite of tests for release +qualification. Megatest Design Philosophy ~~~~~~~~~~~~~~~~~~~~~~~~~~ Megatest is intended to provide the minimum needed resources to make -writing a suite of tests and implementing continuous build for -software, design engineering or process control (via owlfs for +writing a suite of tests and tasks for implementing continuous build +for software, design engineering or process control (via owlfs for example) without being specialized for any specific problem space. Megatest in of itself does not know what constitutes a PASS or FAIL of a test. In most cases megatest is best used in conjunction with logpro or a similar tool to parse, analyze and decide on the test outcome. @@ -59,40 +43,15 @@ the distributed compute platform in use. A template script is provided which can launch jobs on local and remote Linux hosts. Currently megatest uses the network filesystem to call home to your master sqlite3 database. -include::getting_started.txt[] include::writing_tests.txt[] +include::../plan.txt[] +include::getting_started.txt[] +include::writing_tests.txt[] +include::howto.txt[] include::reference.txt[] - - -Controlled waiver propagation -============================= -If test is FAIL and previous test in run with same MT_TARGET is WAIVED then apply the following rules from the testconfig: -If a waiver check is specified in the testconfig apply the check and if it passes then set this FAIL to WAIVED - -Waiver check has two parts, 1) a list of waiver, rulename, filepatterns and 2) the rulename script spec (note that "diff" and "logpro" are predefined) - -========================================================= -###### EXAMPLE FROM testconfig ######### -# matching file(s) will be diff'd with previous run and logpro applied -# if PASS or WARN result from logpro then WAIVER state is set -# -[waivers] -# logpro_file rulename input_glob -waiver_1 logpro lookittmp.log - -[waiver_rules] - -# This builtin rule is the default if there is no .logpro file -# diff diff %file1% %file2% - -# This builtin rule is applied if a .logpro file exists -# logpro diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html -========================================================= - - [appendix] Example Appendix ================ One or more optional appendixes go here at section level zero. Index: docs/manual/reference.txt ================================================================== --- docs/manual/reference.txt +++ docs/manual/reference.txt @@ -8,27 +8,146 @@ sub-sections. The testconfig File ------------------- +Setup section +~~~~~~~~~~~~~ + +Header +^^^^^^ + +------------------- +[setup] +------------------- + +The runscript method is a brute force way to run scripts where the +user is responsible for setting STATE and STATUS + +------------------- +runscript main.csh ------------------- -# testconfig + +Requirements section +~~~~~~~~~~~~~~~~~~~~ + +Header +^^^^^^ + +------------------- [requirements] +------------------- + +Wait on Other Tests +^^^^^^^^^^^^^^^^^^^ +------------------- # A normal waiton waits for the prior tests to be COMPLETED # and PASS, CHECK or WAIVED waiton test1 test2 +------------------- + +Mode +^^^^ + +The default (i.e. if mode is not specified) is normal. All pre-dependent tests +must be COMPLETED and PASS, CHECK or WAIVED before the test will start + +------------------- +mode normal +------------------- + +The toplevel mode requires only that the prior tests are COMPLETED. + +------------------- +mode toplevel +------------------- + +A item based waiton will start items in a test when the +same-named item is COMPLETED and PASS, CHECK or WAIVED +in the prior test + +------------------- +mode itemmatch +------------------- -# A item based waiton will start items in a test when the -# same-named item is COMPLETED and PASS, CHECK or WAIVED -# in the prior test -# -mode normal | toplevel +------------------- # With a toplevel test you may wish to generate your list # of tests to run dynamically # # waiton #{shell get-valid-tests-to-run.sh} ------------------ + + +Run time limit +^^^^^^^^^^^^^^ + +----------------- +runtimelim 1h 2m 3s # this will automatically kill the test if it runs for more than 1h 2m and 3s +----------------- + +Skip +^^^^ + +Header +^^^^^^ + +----------------- +[skip] +----------------- + +Skip on Still-running Tests +^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +----------------- +# NB// If the prevrunning line exists with *any* value the test will +# automatically SKIP if the same-named test is currently RUNNING + +prevrunning x +----------------- + +Skip if a File Exists +^^^^^^^^^^^^^^^^^^^^^ + +----------------- +fileexists /path/to/a/file # skip if /path/to/a/file exists +----------------- + +Controlled waiver propagation +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +If test is FAIL and previous test in run with same MT_TARGET is WAIVED then apply the following rules from the testconfig: +If a waiver check is specified in the testconfig apply the check and if it passes then set this FAIL to WAIVED + +Waiver check has two parts, 1) a list of waiver, rulename, filepatterns and 2) the rulename script spec (note that "diff" and "logpro" are predefined) + +----------------- +###### EXAMPLE FROM testconfig ######### +# matching file(s) will be diff'd with previous run and logpro applied +# if PASS or WARN result from logpro then WAIVER state is set +# +[waivers] +# logpro_file rulename input_glob +waiver_1 logpro lookittmp.log + +[waiver_rules] + +# This builtin rule is the default if there is no .logpro file +# diff diff %file1% %file2% + +# This builtin rule is applied if a .logpro file exists +# logpro diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html +----------------- + +Ezsteps +~~~~~~~ + +To transfer the environment to the next step you can do the following: + +---------------------------- +$MT_MEGATEST -env2file .ezsteps/${stepname} +---------------------------- + :numbered!: ADDED docs/manual_running_of_tests.png Index: docs/manual_running_of_tests.png ================================================================== --- /dev/null +++ docs/manual_running_of_tests.png cannot compute difference between binary files ADDED docs/megatest-about.svg Index: docs/megatest-about.svg ================================================================== --- /dev/null +++ docs/megatest-about.svg @@ -0,0 +1,492 @@ + + + + + + + + + + + + + + + + image/svg+xml + + + + + + + + Megatest + Simple - but not TOO simple! + + Automation + Quality Assurance + Regression Testing + System Administration + + + + + + Write one task or test and iterateDistribute tasks over one or many hostsOrganize runs by any variables you wish - release - architecture - unit or partitionTasks or tests may depend on othersEach task or test runs in clean areaAdd disk space or partitions as neededRigorous results; error, pass, warn etc.Crontab friendly runs (skip if running)Easy debugging - easy to recreate environment for task - annotated HTML logs help find issuesSimplify scripts - eliminate for-each or while loops - parallel running handled by tool + + FAIL + + PASS + + WARN + + Index: docs/megatest-training.odp ================================================================== --- docs/megatest-training.odp +++ docs/megatest-training.odp cannot compute difference between binary files Index: docs/megatest-training.pdf ================================================================== --- docs/megatest-training.pdf +++ docs/megatest-training.pdf cannot compute difference between binary files Index: docs/plan.txt ================================================================== --- docs/plan.txt +++ docs/plan.txt @@ -1,13 +1,83 @@ - -Move test specific db to test dir -================================= - -. Create teststats.db -. Redirect test run stats to teststats.db -. Redirect test steps data to teststats.db -. Redirect test_data to teststats.db -. Direct dboard to get stats from teststats.db -. Redirect kill requests to teststats.db -. Kill requests need to kill all processes in the tree -. Roll up overall stats to megatest.db every five minutes or when test done -. Add any necessary tests +Road Map +======== + +Note: This road-map is tentative and subject to change without notice. + +ww32 +~~~~ + +. Rerun step and or subsequent steps from gui +. Refresh test area files from gui +. Clean and re-run button +. Clean up STATE and STATUS handling. +.. Dashboard and Test control panel are reverse order - choose and fix +.. Move seldom used states and status to drop down selector +. Access test control panel when clicking on Run Summary tests +. Feature: -generate-index-tree +. Change specifing of state and status to use STATE1/STATUS1,STATE2/STATUS2 + +ww33 +~~~~ + +. http api available for use with Perl, Ruby etc. scripts +. megatest.config setup entries for: +.. run launching (e.g. /bin/sh %CMD% > /dev/null) +.. browser "konqueror %FNAME% + +ww34 +~~~~ + +. Mark dependent tests for clean/rerun -rerun-downstream +. On run start check for defunct tests in RUNNING, LAUNCHED or REMOTEHOSTSTART and correct or notify +. Fix: refresh of gui sometimes fails on last item (race condition?) + +ww35 +~~~~ + +. refdb: Add export of csv, json and sexp +. Convert to using call-with-environment-variables where possible. Should allow handling of parallel runs in same process. +. Re-work text interface wizards. Several bugs on record. Possibly convert to gui based. +. Add to testconfig requirements section; launchlimiter scriptname, calls scriptname to check if ok to launch test +. Refactor Run Summary view, currently very clumsy +. Add option to show steps in Run Summary view + +ww36 +~~~~ + +. Refactor guis for resizeablity +. Add filters to Run Summary view and Run Control view +. Add to megatest.config or testconfig; rerunok STATE/STATUS,STATE/STATUS... +. Launch gates for diskspace; /path/one>1G,/path/two>200M,/tmp>5G,#{scheme *toppath*}>1G + +Bin List +~~~~~~~~ + +. Quality improvements +.. Server stutters occasionally +.. Large number of items or tests still has some issues. +.. Code refactoring +.. Replace remote process with true API using json (supports Web app also) +. Streamline the gui +.. Everything resizable +.. Less clutter +.. Tool tips +.. Filters on Run Summary, Summary and Run Control panel +.. Built in log viewer (partially implemented) +.. Refactor the test control panel +. Help and documentation +.. Complete the user manual (I’ve been working on this lately). +.. Online help in the gui +. Streamlined install +.. Deployed version (download a location independent ready to run binary bundle) +.. Install Makefile (in progress, needed for Mike to install on VMs) +.. Added option to compile IUP (needed for VMs) +. Server side run launching +. Support for re-running, cleaning etc. of individual steps (ezsteps makes this very easy to implement). +. Launch process needs built in daemonizing (easy to do, just need to test it thoroughly). +. Wizards for creating tests, regression areas (current ones are text only and limited). +. Fully functional built in web service (currently you can browse runs but it is very simplistic). +. Wildcards in runconfigs: e.g. [p1271/9/%/%] +. Gui panels for editing megatest.config and runconfigs.config +. Fully isolated tests (no use of NFS to see regression area files) +. Windows version + Index: ezsteps.scm ================================================================== --- ezsteps.scm +++ ezsteps.scm @@ -8,19 +8,166 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') -(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking directory-utils) (import (prefix sqlite3 sqlite3:)) (declare (unit ezsteps)) (declare (uses db)) (declare (uses common)) (declare (uses items)) (declare (uses runconfig)) (include "common_records.scm") -; (include "key_records.scm") -; (include "db_records.scm") -; (include "run_records.scm") +(include "key_records.scm") +(include "db_records.scm") +(include "run_records.scm") + +(define (ezsteps:run-from testdat start-step-name run-one) + (let* ((test-run-dir (db:test-get-rundir testdat)) + (testconfig (read-config (conc test-run-dir "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) + (ezstepslst (hash-table-ref/default testconfig "ezsteps" '())) + (run-mutex (make-mutex)) + (rollup-status 0) + (exit-info (vector #t #t #t)) + (test-id (db:test-get-id testdat)) + (test-name (db:test-get-testname testdat)) + (kill-job #f)) ;; for future use (on re-factoring with launch.scm code + (let loop ((count 5)) + (if (file-exists? test-run-dir) + (push-directory test-run-dir) + (if (> count 0) + (begin + (debug:print 0 "WARNING: ezsteps attempting to run but test run directory " test-run-dir " is not there. Waiting and trying again " count " more times") + (sleep 3) + (loop (- count 1)))))) + (debug:print-info 0 "Running in directory " test-run-dir) + (if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps")) + ;; if ezsteps was defined then we are sure to have at least one step but check anyway + (if (not (> (length ezstepslst) 0)) + (message-window "ERROR: You can only re-run steps defined via ezsteps") + (begin + (let loop ((ezstep (car ezstepslst)) + (tal (cdr ezstepslst)) + (prevstep #f) + (runflag #f)) ;; flag used to skip steps when not starting at the beginning + (if (vector-ref exit-info 1) + (let* ((stepname (car ezstep)) ;; do stuff to run the step + (stepinfo (cadr ezstep)) + (stepparts (string-match (regexp "^(\\{([^\\}]*)\\}\\s*|)(.*)$") stepinfo)) + (stepparms (list-ref stepparts 2)) ;; for future use, {VAR=1,2,3}, run step for each + (stepcmd (list-ref stepparts 3)) + (script "") ; "#!/bin/bash\n") ;; yep, we depend on bin/bash FIXME!!! + (logpro-used #f)) + + ;; Skip steps until hit start-step-name + ;; + (if (and start-step-name + (not runflag)) + (if (equal? stepname start-step-name) + (set! runflag #t) ;; and continue + (if (not (null? tal)) + (loop (car tal)(cdr tal) stepname #f)))) + (debug:print 4 "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts + " stepparms: " stepparms " stepcmd: " stepcmd) + + (if (file-exists? (conc stepname ".logpro"))(set! logpro-used #t)) + + ;; call the command using mt_ezstep + (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd)) + + (debug:print 4 "script: " script) + ;; DO NOT remote + (db:teststep-set-status! #f test-id stepname "start" "-" #f #f work-area: test-run-dir) + ;; now launch + (let ((pid (process-run script))) + (let processloop ((i 0)) + (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) + (mutex-lock! run-mutex) + (vector-set! exit-info 0 pid) + (vector-set! exit-info 1 exit-status) + (vector-set! exit-info 2 exit-code) + (mutex-unlock! run-mutex) + (if (eq? pid-val 0) + (begin + (thread-sleep! 1) + (processloop (+ i 1)))) + )) + (let ((exinfo (vector-ref exit-info 2)) + (logfna (if logpro-used (conc stepname ".html") ""))) + ;; testing if procedures called in a remote call cause problems (ans: no or so I suspect) + (db:teststep-set-status! #f test-id stepname "end" exinfo #f logfna work-area: test-run-dir)) + (if logpro-used + (cdb:test-set-log! *runremote* test-id (conc stepname ".html"))) + ;; set the test final status + (let* ((this-step-status (cond + ((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn) + ((eq? (vector-ref exit-info 2) 0) 'pass) + (else 'fail))) + (overall-status (cond + ((eq? rollup-status 2) 'warn) + ((eq? rollup-status 0) 'pass) + (else 'fail))) + (next-status (cond + ((eq? overall-status 'pass) this-step-status) + ((eq? overall-status 'warn) + (if (eq? this-step-status 'fail) 'fail 'warn)) + (else 'fail)))) + (debug:print 4 "Exit value received: " (vector-ref exit-info 2) " logpro-used: " logpro-used + " this-step-status: " this-step-status " overall-status: " overall-status + " next-status: " next-status " rollup-status: " rollup-status) + (case next-status + ((warn) + (set! rollup-status 2) + ;; NB// test-set-status! does rdb calls under the hood + (tests:test-set-status! test-id "RUNNING" "WARN" + (if (eq? this-step-status 'warn) "Logpro warning found" #f) + #f)) + ((pass) + (tests:test-set-status! test-id "RUNNING" "PASS" #f #f)) + (else ;; 'fail + (set! rollup-status 1) ;; force fail + (tests:test-set-status! test-id "RUNNING" "FAIL" (conc "Failed at step " stepname) #f) + )))) + (if (and (steprun-good? logpro-used (vector-ref exit-info 2)) + (not (null? tal))) + (if (not run-one) ;; if we got here we completed the step, if run-one is true, stop + (loop (car tal) (cdr tal) stepname runflag)))) + (debug:print 4 "WARNING: a prior step failed, stopping at " ezstep))) + + ;; Once done with step/steps update the test record + ;; + (let* ((item-path (db:test-get-item-path testdat)) ;; (item-list->path itemdat)) + (testinfo (cdb:get-test-info-by-id *runremote* test-id))) ;; refresh the testdat, call it iteminfo in case need prev/curr + ;; Am I completed? + (if (equal? (db:test-get-state testinfo) "RUNNING") ;; (not (equal? (db:test-get-state testinfo) "COMPLETED")) + (let ((new-state (if kill-job "KILLED" "COMPLETED") ;; (if (eq? (vector-ref exit-info 2) 0) ;; exited with "good" status + ;; "COMPLETED" + ;; (db:test-get-state testinfo))) ;; else preseve the state as set within the test + ) + (new-status (cond + ((not (vector-ref exit-info 1)) "FAIL") ;; job failed to run + ((eq? rollup-status 0) + ;; if the current status is AUTO the defer to the calculated value (i.e. leave this AUTO) + (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO" "PASS")) + ((eq? rollup-status 1) "FAIL") + ((eq? rollup-status 2) + ;; if the current status is AUTO the defer to the calculated value but qualify (i.e. make this AUTO-WARN) + (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO-WARN" "WARN")) + (else "FAIL")))) ;; (db:test-get-status testinfo))) + (debug:print-info 2 "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result, rollup-status is " rollup-status) + (tests:test-set-status! test-id + new-state + new-status + (args:get-arg "-m") #f) + ;; need to update the top test record if PASS or FAIL and this is a subtest + (if (not (equal? item-path "")) + (cdb:roll-up-pass-fail-counts *runremote* run-id test-name item-path new-status)))) + ;; for automated creation of the rollup html file this is a good place... + (if (not (equal? item-path "")) + (tests:summarize-items #f run-id test-id test-name #f)) ;; don't force - just update if no + ))) + (pop-directory) + rollup-status)) ADDED fdb_records.scm Index: fdb_records.scm ================================================================== --- /dev/null +++ fdb_records.scm @@ -0,0 +1,19 @@ +;; Single record for managing a filedb +;; make-vector-record "Filedb record" filedb fdb db dbpath pathcache idcache partcache +;; Filedb record +(define (make-filedb:fdb)(make-vector 5)) +(define-inline (filedb:fdb-get-db vec) (vector-ref vec 0)) +(define-inline (filedb:fdb-get-dbpath vec) (vector-ref vec 1)) +(define-inline (filedb:fdb-get-pathcache vec) (vector-ref vec 2)) +(define-inline (filedb:fdb-get-idcache vec) (vector-ref vec 3)) +(define-inline (filedb:fdb-get-partcache vec) (vector-ref vec 4)) +(define-inline (filedb:fdb-set-db! vec val)(vector-set! vec 0 val)) +(define-inline (filedb:fdb-set-dbpath! vec val)(vector-set! vec 1 val)) +(define-inline (filedb:fdb-set-pathcache! vec val)(vector-set! vec 2 val)) +(define-inline (filedb:fdb-set-idcache! vec val)(vector-set! vec 3 val)) +(define-inline (filedb:fdb-set-partcache! vec val)(vector-set! vec 4 val)) + +;; children records, should have use something other than "child" +(define-inline (filedb:child-get-id vec) (vector-ref vec 0)) +(define-inline (filedb:child-get-path vec) (vector-ref vec 1)) +(define-inline (filedb:child-get-parent_id vec)(vector-ref vec 2)) ADDED filedb.scm Index: filedb.scm ================================================================== --- /dev/null +++ filedb.scm @@ -0,0 +1,236 @@ +;; Copyright 2006-2011, 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. + +;; (require-extension synch sqlite3 posix srfi-13 srfi-1 utils regex) +(use sqlite3 srfi-1 posix regex srfi-69 srfi-13 posix-extras) +(import (prefix sqlite3 sqlite3:)) + +(declare (unit filedb)) + +(include "fdb_records.scm") +;; (include "settings.scm") + +(define (filedb:open-db dbpath) + (let* ((fdb (make-filedb:fdb)) + (dbexists (file-exists? dbpath)) + (db (sqlite3:open-database dbpath))) + (filedb:fdb-set-db! fdb db) + (filedb:fdb-set-dbpath! fdb dbpath) + (filedb:fdb-set-pathcache! fdb (make-hash-table)) + (filedb:fdb-set-idcache! fdb (make-hash-table)) + (filedb:fdb-set-partcache! fdb (make-hash-table)) + ;(sqlite3:set-busy-timeout! db 1000000) + (if (not dbexists) + (begin + (sqlite3:execute db "PRAGMA synchronous = OFF;") + (sqlite3:execute db "CREATE TABLE names (id INTEGER PRIMARY KEY,name TEST);") ;; for future use - change path in paths table to path_id + (sqlite3:execute db "CREATE INDEX name_index ON names (name);") + ;; NB// We store a useful subset of file attributes but do not attempt to store all + (sqlite3:execute db "CREATE TABLE paths (id INTEGER PRIMARY KEY, + path TEXT, + parent_id INTEGER, + mode INTEGER DEFAULT -1, + uid INTEGER DEFAULT -1, + gid INTEGER DEFAULT -1, + size INTEGER DEFAULT -1, + mtime INTEGER DEFAULT -1);") + (sqlite3:execute db "CREATE INDEX path_index ON paths (path,parent_id);") + (sqlite3:execute db "CREATE TABLE bases (id INTEGER PRIMARY KEY,base TEXT, updated TIMESTAMP);"))) + fdb)) + +(define (filedb:finalize-db! fdb) + (sqlite3:finalize! (filedb:fdb-get-db fdb))) + +(define (filedb:get-current-time-string) + (string-chomp (time->string (seconds->local-time (current-seconds))))) + +(define (filedb:get-base-id db path) + (let ((stmt (sqlite3:prepare db "SELECT id FROM bases WHERE base=?;")) + (id-num #f)) + (sqlite3:for-each-row + (lambda (num) (set! id-num num)) stmt path) + (sqlite3:finalize! stmt) + id-num)) + +(define (filedb:get-path-id db path parent) + (let ((stmt (sqlite3:prepare db "SELECT id FROM paths WHERE path=? AND parent_id=?;")) + (id-num #f)) + (sqlite3:for-each-row + (lambda (num) (set! id-num num)) stmt path parent) + (sqlite3:finalize! stmt) + id-num)) + +(define (filedb:add-base db path) + (let ((existing (filedb:get-base-id db path))) + (if existing #f + (begin + (sqlite3:execute db "INSERT INTO bases (base,updated) VALUES (?,?);" path (filedb:get-current-time-string)))))) + +;; index value field notes +;; 0 inode number st_ino +;; 1 mode st_mode bitfield combining file permissions and file type +;; 2 number of hard links st_nlink +;; 3 UID of owner st_uid as with file-owner +;; 4 GID of owner st_gid +;; 5 size st_size as with file-size +;; 6 access time st_atime as with file-access-time +;; 7 change time st_ctime as with file-change-time +;; 8 modification time st_mtime as with file-modification-time +;; 9 parent device ID st_dev ID of device on which this file resides +;; 10 device ID st_rdev device ID for special files (i.e. the raw major/minor number) +;; 11 block size st_blksize +;; 12 number of blocks allocated st_blocks + +(define (filedb:add-path-stat db path parent statinfo) + (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id,mode,uid,gid,size,mtime) VALUES (?,?,?,?,?,?,?);"))) + (sqlite3:execute stmt + path + parent + (vector-ref statinfo 1) ;; mode + (vector-ref statinfo 3) ;; uid + (vector-ref statinfo 4) ;; gid + (vector-ref statinfo 5) ;; size + (vector-ref statinfo 8) ;; mtime + ) + (sqlite3:finalize! stmt))) ;; (filedb:get-current-time-string)))) + +(define (filedb:add-path db path parent) + (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id) VALUES (?,?);"))) + (sqlite3:execute stmt path parent) + (sqlite3:finalize! stmt))) + +(define (filedb:register-path fdb path #!key (save-stat #f)) + (let* ((db (filedb:fdb-get-db fdb)) + (pathcache (filedb:fdb-get-pathcache fdb)) + (stat (if save-stat (file-stat path #t))) + (id (hash-table-ref/default pathcache path #f))) + (if id id + (let ((plist (string-split path "/"))) + (let loop ((head (car plist)) + (tail (cdr plist)) + (parent 0)) + (let ((id (filedb:get-path-id db head parent)) + (done (null? tail))) + (if id ;; we'll have a id if the path is already registered + (if done + (begin + (hash-table-set! pathcache path id) + id) ;; return the last path id for a result + (loop (car tail)(cdr tail) id)) + (begin ;; add the path and then repeat the loop with the same data + (if save-stat + (filedb:add-path-stat db head parent stat) + (filedb:add-path db head parent)) + (loop head tail parent))))))))) + +(define (filedb:update-recursively fdb path #!key (save-stat #f)) + (let ((p (open-input-pipe (string-append "find -L " path)))) ;; (resolve-pathname path)))) ;; (string-append "find " path)))) + (print "processed 0 files...") + (let loop ((l (read-line p)) + (lc 0)) ;; line count + (if (eof-object? l) + (begin + (print " " lc " files") + (close-input-port p)) + (begin + (filedb:register-path fdb l save-stat: save-stat) ;; (get-real-path l)) ;; don't like losing the original path info + (if (= (modulo lc 100) 0) + (print " " lc " files")) + (loop (read-line p)(+ lc 1))))))) + +(define (filedb:update fdb path #!key (save-stat #f)) + ;; first get the realpath and add it to the bases table + (let ((real-path path) ;; (filedb:get-real-path path)) + (db (filedb:fdb-get-db fdb))) + (filedb:add-base db real-path) + (filedb:update-recursively fdb path save-stat: save-stat))) + +;; not used and broken +;; +(define (filedb:get-real-path path) + (let* ((p (open-input-pipe (string-append real-path " " (regexp-escape path)))) + (pth (read-line p))) + (if (eof-object? pth) path + (begin + (close-input-port p) + pth)))) + +(define (filedb:drop-base fdb path) + (print "Sorry, I don't do anything yet")) + +(define (filedb:find-all fdb pattern action) + (let* ((db (filedb:fdb-get-db fdb)) + (stmt (sqlite3:prepare db "SELECT id FROM paths WHERE path like ?;")) + (result '())) + (sqlite3:for-each-row + (lambda (num) + (action num) + (set! result (cons num result))) stmt pattern) + (sqlite3:finalize! stmt) + result)) + +(define (filedb:get-path-record fdb id) + (let* ((db (filedb:fdb-get-db fdb)) + (partcache (filedb:fdb-get-partcache fdb)) + (dat (hash-table-ref/default partcache id #f))) + (if dat dat + (let ((stmt (sqlite3:prepare db "SELECT path,parent_id FROM paths WHERE id=?;")) + (result #f)) + (sqlite3:for-each-row + (lambda (path parent_id)(set! result (list path parent_id))) stmt id) + (hash-table-set! partcache id result) + (sqlite3:finalize! stmt) + result)))) + +(define (filedb:get-children fdb parent-id) + (let* ((db (filedb:fdb-get-db fdb)) + (res '())) + (sqlite3:for-each-row + (lambda (id path parent-id) + (set! res (cons (vector id path parent-id) res))) + db "SELECT id,path,parent_id FROM paths WHERE parent_id=?;" + parent-id) + res)) + +;; retrieve all that have children and those without +;; children that match patt +(define (filedb:get-children-patt fdb parent-id search-patt) + (let* ((db (filedb:fdb-get-db fdb)) + (res '())) + ;; first get the children that have no children + (sqlite3:for-each-row + (lambda (id path parent-id) + (set! res (cons (vector id path parent-id) res))) + db "SELECT id,path,parent_id FROM paths WHERE parent_id=? AND + (id IN (SELECT parent_id FROM paths) OR path LIKE ?);" + parent-id search-patt) + res)) + +(define (filedb:get-path fdb id) + (let* ((db (filedb:fdb-get-db fdb)) + (idcache (filedb:fdb-get-idcache fdb)) + (path (hash-table-ref/default idcache id #f))) + (if path path + (let loop ((curr-id id) + (path "")) + (let ((path-record (filedb:get-path-record fdb curr-id))) + (if (not path-record) #f ;; this id has no path + (let* ((parent-id (list-ref path-record 1)) + (pname (list-ref path-record 0)) + (newpath (string-append "/" pname path))) + (if (= parent-id 0) ;; fields 0=path, 1=parent. root parent=0 + (begin + (hash-table-set! idcache id newpath) + newpath) + (loop parent-id newpath))))))))) + +(define (filedb:search db pattern) + (let ((action (lambda (id)(print (filedb:get-path db id))))) + (filedb:find-all db pattern action))) + 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,11 +11,11 @@ (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 uri-common intarweb spiffy-directory-listing) +(use spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing) ;; Configurations for server (tcp-buffer-size 2048) (max-connections 2048) @@ -34,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 ;;====================================================================== @@ -183,11 +183,15 @@ ;; ;; 1 Hello, world! Goodbye Dolly ;; Send msg to serverdat and receive result (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))) + (fullurl (if (list? serverdat) + (caddr serverdat) + (begin + (debug:print 0 "FATAL ERROR: http-transport:client-send-receive called with no server info") + (exit 1)))) ;; (conc url "/ctrl")) ;; (conc url "/?dat=" msg))) (res #f)) (handle-exceptions exn (begin (print "ERROR IN http-transport:client-send-receive " ((condition-property-accessor 'exn 'message) exn)) @@ -213,11 +217,11 @@ (list (cons 'dat msg)) read-string)) (close-all-connections!) (mutex-unlock! *http-mutex*))) (time-out (lambda () - (thread-sleep! 5) + (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)) @@ -315,14 +319,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) ADDED index-tree.scm Index: index-tree.scm ================================================================== --- /dev/null +++ index-tree.scm @@ -0,0 +1,50 @@ +;;====================================================================== +;; 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. +;;====================================================================== + +;;====================================================================== +;; Tests +;;====================================================================== + +(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils) +(import (prefix sqlite3 sqlite3:)) + +(declare (unit tests)) +(declare (uses lock-queue)) +(declare (uses db)) +(declare (uses common)) +(declare (uses items)) +(declare (uses runconfig)) + +(include "common_records.scm") +(include "key_records.scm") +(include "db_records.scm") +(include "run_records.scm") +(include "test_records.scm") + +;; Populate the links tree with index.html files +;; +;; - start from most recent tests and work towards oldest -OR- +;; start from deepest hierarchy and work way up +;; - look up tests in megatest.db +;; - cross-reference the tests to stats.db +;; - if newer than event_time in stats.db or not registered in stats.db regenerate +;; - run du and store in stats.db +;; - when all tests at that level done generate next level up index.html +;; +;; include in rollup html index.html: +;; sum of du +;; counts of PASS, FAIL, RUNNING, REMOTEHOSTSTART, LAUNCHED, CHECK etc. +;; overall status +;; +;; include in test specific index.html: +;; host, uname, cpu graph, disk avail graph, steps, data +;; meta data, state, status, du +;; Index: items.scm ================================================================== --- items.scm +++ items.scm @@ -69,13 +69,18 @@ (debug:print 6 "item-assoc->item-list x: " x) (if (< (length x) 2) (begin (debug:print 0 "ERROR: malformed items spec " (string-intersperse x " ")) (list (car x)'())) - (let ((name (car x)) - (items (cadr x))) - (list name (string-split items))))) + (let* ((name (car x)) + (items (cadr x)) + (ilist (list name (if (string? items) + (string-split items) + '())))) + (if (null? ilist) + (debug:print 0 "ERROR: No items specified for " name)) + ilist))) itemsdat)))) (let ((debuglevel 5)) (debug:print 5 "item-assoc->item-list: itemsdat => itemlst ") (if (debug:debug-mode 5) (begin @@ -131,12 +136,13 @@ (if (member item valid-values) item #f) item))) (define (items:get-items-from-config tconfig) - (let* (;; db is always at *toppath*/db/megatest.db - (items (hash-table-ref/default tconfig "items" '())) + (let* ((have-items (hash-table-ref/default tconfig "items" #f)) + (have-itable (hash-table-ref/default tconfig "itemstable" #f)) + (items (hash-table-ref/default tconfig "items" '())) (itemstable (hash-table-ref/default tconfig "itemstable" '()))) (debug:print 5 "items: " items " itemstable: " itemstable) (set! items (map (lambda (item) (if (procedure? (cadr item)) (list (car item)((cadr item))) @@ -145,14 +151,16 @@ (set! itemstable (map (lambda (item) (if (procedure? (cadr item)) (list (car item)((cadr item))) item)) itemstable)) + (if (and have-items (null? items)) (debug:print 0 "ERROR: [items] section in testconfig but no entries defined")) + (if (and have-itable (null? itemstable))(debug:print 0 "ERROR: [itemstable] section in testconfig but no entries defined")) (if (or (not (null? items))(not (null? itemstable))) (append (item-assoc->item-list items) (item-table->item-list itemstable)) '(())))) ;; (pp (item-assoc->item-list itemdat)) 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 @@ -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 @@ -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 @@ -89,13 +90,13 @@ (change-directory top-path) (debug:print 2 "Exectuing " test-name " (id: " test-id ") on " (get-host-name)) ;; 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! *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) @@ -105,16 +106,27 @@ (let ((var (car varval)) (val (cadr varval))) (debug:print 1 "Adding pre-var/val " var " = " val " to the environment") (setenv var val))))) varpairs))) - (setenv "MT_TEST_RUN_DIR" work-area) - (setenv "MT_TEST_NAME" test-name) - (setenv "MT_ITEM_INFO" (conc itemdat)) - (setenv "MT_RUNNAME" runname) - (setenv "MT_MEGATEST" megatest) - (setenv "MT_TARGET" target) + (for-each + (lambda (varval) + (let ((var (car varval)) + (val (cadr varval))) + (if val + (setenv var val) + (begin + (debug:print 0 "ERROR: required variable " var " does not have a valid value. Exiting") + (exit))))) + (list + (list "MT_TEST_RUN_DIR" work-area) + (list "MT_TEST_NAME" test-name) + (list "MT_ITEM_INFO" (conc itemdat)) + (list "MT_RUNNAME" runname) + (list "MT_MEGATEST" megatest) + (list "MT_TARGET" target) + (list "MT_LINKTREE" (configf:lookup *configdat* "setup" "linktree")))) (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path))) ;; (change-directory top-path) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") @@ -123,22 +135,26 @@ (exit 1))) ;; Can setup as client for server mode now ;; (client:setup) (change-directory *toppath*) - (set-megatest-env-vars run-id) ;; these may be needed by the launching process + (set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; 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-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) (set-item-env-vars itemdat) (save-environment-as-files "megatest") ;; open-run-close not needed for test-set-meta-info - (tests:set-meta-info #f test-id run-id test-name itemdat 0 work-area) - (tests:test-set-status! test-id "REMOTEHOSTSTART" "n/a" (args:get-arg "-m") #f) + (tests:set-full-meta-info #f test-id run-id 0 work-area) + + ;; (tests:test-set-status! test-id "REMOTEHOSTSTART" "n/a" (args:get-arg "-m") #f) + (tests:test-force-state-status! test-id "REMOTEHOSTSTART" "n/a") + (thread-sleep! 0.3) ;; NFS slowness has caused grief here + (if (args:get-arg "-xterm") (set! fullrunscript "xterm") (if (and fullrunscript (not (file-execute-access? fullrunscript))) (system (conc "chmod ug+x " fullrunscript)))) ;; We are about to actually kick off the test @@ -148,15 +164,25 @@ (let* ((m (make-mutex)) (kill-job? #f) (exit-info (vector #t #t #t)) (job-thread #f) + (keep-going #t) (runit (lambda () ;; (let-values ;; (((pid exit-status exit-code) ;; (run-n-wait fullrunscript))) - (tests:test-set-status! test-id "RUNNING" "n/a" #f #f) + ;; (tests:test-set-status! test-id "RUNNING" "n/a" #f #f) + ;; Since we should have a clean slate at this time there is no need to do + ;; any of the other stuff that tests:test-set-status! does. Let's just + ;; force RUNNING/n/a + + + (thread-sleep! 0.3) + (tests:test-force-state-status! test-id "RUNNING" "n/a") + (thread-sleep! 0.3) ;; NFS slowness has caused grief here + ;; if there is a runscript do it first (if fullrunscript (let ((pid (process-run fullrunscript))) (let loop ((i 0)) (let-values @@ -175,10 +201,11 @@ ;; then, if runscript ran ok (or did not get called) ;; do all the ezsteps (if any) (if ezsteps (let* ((testconfig (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here? (ezstepslst (hash-table-ref/default testconfig "ezsteps" '()))) + (hash-table-set! *testconfigs* test-name testconfig) ;; cached for lazy reads later ... (if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps")) ;; if ezsteps was defined then we are sure to have at least one step but check anyway (if (not (> (length ezstepslst) 0)) (debug:print 0 "ERROR: ezsteps defined but ezstepslst is zero length") (let loop ((ezstep (car ezstepslst)) @@ -242,26 +269,32 @@ (else 'fail))) (next-status (cond ((eq? overall-status 'pass) this-step-status) ((eq? overall-status 'warn) (if (eq? this-step-status 'fail) 'fail 'warn)) - (else 'fail)))) + (else 'fail))) + (next-state ;; "RUNNING") ;; WHY WAS THIS CHANGED TO NOT USE (null? tal) ?? + (cond + ((null? tal) ;; more to run? + "COMPLETED") + (else "RUNNING"))) + ) (debug:print 4 "Exit value received: " (vector-ref exit-info 2) " logpro-used: " logpro-used " this-step-status: " this-step-status " overall-status: " overall-status " next-status: " next-status " rollup-status: " rollup-status) (case next-status ((warn) (set! rollup-status 2) ;; NB// test-set-status! does rdb calls under the hood - (tests:test-set-status! test-id "RUNNING" "WARN" + (tests:test-set-status! test-id next-state "WARN" (if (eq? this-step-status 'warn) "Logpro warning found" #f) #f)) ((pass) - (tests:test-set-status! test-id "RUNNING" "PASS" #f #f)) + (tests:test-set-status! test-id next-state "PASS" #f #f)) (else ;; 'fail - (set! rollup-status 1) ;; force fail - (tests:test-set-status! test-id "RUNNING" "FAIL" (conc "Failed at step " stepname) #f) + (set! rollup-status 1) ;; force fail, this used to be next-state but that doesn't make sense. should always be "COMPLETED" + (tests:test-set-status! test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f) )))) (if (and (steprun-good? logpro-used (vector-ref exit-info 2)) (not (null? tal))) (loop (car tal) (cdr tal) stepname))) (debug:print 4 "WARNING: a prior step failed, stopping at " ezstep)))))))) @@ -272,102 +305,134 @@ (round (- (current-seconds) start-seconds))))) (kill-tries 0)) + (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area) (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) + (tests:set-partial-meta-info #f test-id run-id minutes work-area) (if kill-job? (begin (mutex-lock! m) + ;; NOTE: The pid can change as different steps are run. Do we need handshaking between this + ;; section and the runit section? Or add a loop that tries three times with a 1/4 second + ;; between tries? (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) - (exit 1)))) + (exit 1) ;; IS THIS NECESSARY OR WISE??? + ))) (set! kill-tries (+ 1 kill-tries)) (mutex-unlock! m))) ;; (sqlite3:finalize! db) - (thread-sleep! (+ 10 (random 10))) ;; add some jitter to the call home time to spread out the db accesses - (loop (calc-minutes))))))) - (th1 (make-thread monitorjob)) - (th2 (make-thread runit))) + (if keep-going + (begin + (thread-sleep! 3) ;; (+ 3 (random 6))) ;; add some jitter to the call home time to spread out the db accesses + (if keep-going + (loop (calc-minutes))))))) + (tests:update-central-meta-info test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f)))) ;; NOTE: Checking twice for keep-going is intentional + (th1 (make-thread monitorjob "monitor job")) + (th2 (make-thread runit "run job"))) (set! job-thread th2) (thread-start! th1) (thread-start! th2) (thread-join! th2) + (set! keep-going #f) + (thread-join! th1) + ;; (thread-sleep! 1) + ;; (thread-terminate! th1) ;; Not sure if this is a good idea + (thread-sleep! 1) ;; give thread th1 a chance to be done TODO: Verify this is needed. At 0.1 I was getting fail to stop, increased to total of 1.1 sec. + ;; (tests:update-central-meta-info test-id cpuload diskfree minutes #f #f) (mutex-lock! m) (let* ((item-path (item-list->path itemdat)) - (testinfo (cdb:get-test-info-by-id *runremote* test-id))) ;; )) ;; run-id test-name item-path))) + ;; only state and status needed - use lazy routine + (testinfo (cdb:remote-run db:get-testinfo-state-status #f test-id))) ;;;(cdb:get-test-info-by-id *runremote* test-id))) ;; )) ;; run-id test-name item-path))) ;; Am I completed? - (if (not (equal? (db:test-get-state testinfo) "COMPLETED")) - (begin - (debug:print 2 "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result, rollup-status is " rollup-status) - (tests:test-set-status! test-id - (if kill-job? "KILLED" "COMPLETED") - (cond + (if (member (db:test-get-state testinfo) '("REMOTEHOSTSTART" "RUNNING")) ;; NOTE: It should *not* be REMOTEHOSTSTART but for reasons I don't yet understand it sometimes gets stuck in that state ;; (not (equal? (db:test-get-state testinfo) "COMPLETED")) + (let ((new-state (if kill-job? "KILLED" "COMPLETED") ;; (if (eq? (vector-ref exit-info 2) 0) ;; exited with "good" status + ;; "COMPLETED" + ;; (db:test-get-state testinfo))) ;; else preseve the state as set within the test + ) + (new-status (cond ((not (vector-ref exit-info 1)) "FAIL") ;; job failed to run ((eq? rollup-status 0) - ;; if the current status is AUTO the defer to the calculated value (i.e. leave this AUTO) + ;; if the current status is AUTO then defer to the calculated value (i.e. leave this AUTO) (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO" "PASS")) ((eq? rollup-status 1) "FAIL") ((eq? rollup-status 2) ;; if the current status is AUTO the defer to the calculated value but qualify (i.e. make this AUTO-WARN) (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO-WARN" "WARN")) - (else "FAIL")) - (args:get-arg "-m") #f))) + (else "FAIL")))) ;; (db:test-get-status testinfo))) + (debug:print-info 1 "Test exited in state=" (db:test-get-state testinfo) ", setting state/status based on exit code of " (vector-ref exit-info 1) " and rollup-status of " rollup-status) + (tests:test-set-status! test-id + new-state + new-status + (args:get-arg "-m") #f) + ;; need to update the top test record if PASS or FAIL and this is a subtest + ;; NO NEED TO CALL roll-up-pass-fail-counts HERE, THIS IS DONE IN roll-up-pass-fail-counts called by tests:test-set-status! + ;; (if (not (equal? item-path "")) + ;; (begin + ;; (thread-sleep! 0.1) ;; give other processes an opportunity to access the db as rollup is lower priority + ;; (cdb:roll-up-pass-fail-counts *runremote* run-id test-name item-path new-status))) + )) ;; for automated creation of the rollup html file this is a good place... (if (not (equal? item-path "")) - (tests:summarize-items #f run-id test-name #f)) ;; don't force - just update if no - ) + (tests:summarize-items #f run-id test-id test-name #f))) ;; don't force - just update if no (mutex-unlock! m) - ;; (exec-results (cmd-run->list fullrunscript)) ;; (list ">" (conc test-name "-run.log")))) - ;; (success exec-results)) ;; (eq? (cadr exec-results) 0))) (debug:print 2 "Output from running " fullrunscript ", pid " (vector-ref exit-info 0) " in work area " work-area ":\n====\n exit code " (vector-ref exit-info 2) "\n" "====\n") - ;; (sqlite3:finalize! db) - ;; (sqlite3:finalize! tdb) (if (not (vector-ref exit-info 1)) (exit 4))))))) ;; set up the very basics needed for doing anything here. (define (setup-for-run) ;; would set values for KEYS in the environment here for better support of env-override but ;; have chicken/egg scenario. need to read megatest.config then read it again. Going to ;; pass on that idea for now ;; special case - (set! *configinfo* (find-and-read-config - (if (args:get-arg "-config")(args:get-arg "-config") "megatest.config") - environ-patt: "env-override" - given-toppath: (get-environment-variable "MT_RUN_AREA_HOME") - pathenvvar: "MT_RUN_AREA_HOME")) - (set! *configdat* (if (car *configinfo*)(car *configinfo*) #f)) - (set! *toppath* (if (car *configinfo*)(cadr *configinfo*) #f)) - (if *toppath* - (setenv "MT_RUN_AREA_HOME" *toppath*) ;; to be deprecated - (debug:print 0 "ERROR: failed to find the top path to your run setup.")) + (if (not (hash-table? *configdat*)) ;; no need to re-open on every call + (begin + (set! *configinfo* (find-and-read-config + (if (args:get-arg "-config")(args:get-arg "-config") "megatest.config") + environ-patt: "env-override" + given-toppath: (get-environment-variable "MT_RUN_AREA_HOME") + pathenvvar: "MT_RUN_AREA_HOME")) + (set! *configdat* (if (car *configinfo*)(car *configinfo*) #f)) + (set! *toppath* (if (car *configinfo*)(cadr *configinfo*) #f)) + (if *toppath* + (setenv "MT_RUN_AREA_HOME" *toppath*) ;; to be deprecated + (debug:print 0 "ERROR: failed to find the top path to your Megatest area.")))) *toppath*) (define (get-best-disk confdat) (let* ((disks (hash-table-ref/default confdat "disks" #f)) (best #f) @@ -406,17 +471,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)) @@ -441,11 +506,12 @@ (if (not (file-exists? linktree)) (begin (debug:print 0 "WARNING: linktree did not exist! Creating it now at " linktree) (create-directory linktree #t))) ;; (system (conc "mkdir -p " linktree)))) ;; create the directory for the tests dir links, this is needed no matter what... - (if (not (directory-exists? lnkbase)) + (if (and (not (directory-exists? lnkbase)) + (not (file-exists? lnkbase))) (create-directory lnkbase #t)) ;; update the toptest record with its location rundir, cache the path ;; This wass highly inefficient, one db write for every subtest, potentially ;; thousands of unnecessary updates, cache the fact it was set and don't set it @@ -515,11 +581,11 @@ ;; If there is already a symlink delete it and recreate it. (handle-exceptions exn (begin - (debug:print 0 "ERROR: Failed to re-create link " linktarget ((condition-property-accessor 'exn 'message) exn) ", exiting") + (debug:print 0 "ERROR: Failed to re-create link " lnktarget ((condition-property-accessor 'exn 'message) exn) ", exiting") (exit)) (if (symbolic-link? lnktarget) (delete-file lnktarget)) (if (not (file-exists? lnktarget)) (create-symbolic-link test-path lnktarget))))) ;; I suspect this section was deleting test directories under some @@ -554,28 +620,35 @@ ;; 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 (let ((ush (config-lookup *configdat* "jobtools" "useshell"))) + (if ush + (if (equal? ush "no") ;; must use "no" to NOT use shell + #f + ush) + #t))) ;; default is yes + (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 (or (configf:lookup test-conf "requirements" "runtimelim") + (configf:lookup *configdat* "setup" "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,22 +668,23 @@ (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") '())))) + (setenv "MT_ITEMPATH" item-path) (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")) (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 +705,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")) @@ -665,26 +740,35 @@ (append (list (list "MT_TEST_RUN_DIR" work-area) (list "MT_TEST_NAME" test-name) (list "MT_ITEM_INFO" (conc itemdat)) (list "MT_RUNNAME" runname) (list "MT_TARGET" mt_target) + (list "MT_ITEMPATH" item-path) ) 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 " ") + (let ((cmdstr (string-intersperse fullcmd " "))) + (if launchwait + cmdstr + (conc cmdstr " >> mt_launch.log 2>&1"))) (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") ADDED lock-queue.scm Index: lock-queue.scm ================================================================== --- /dev/null +++ lock-queue.scm @@ -0,0 +1,134 @@ +;; 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. + +;;====================================================================== +;; launch a task - this runs on the originating host, tests themselves +;; +;;====================================================================== + +(use sqlite3 srfi-18) +(import (prefix sqlite3 sqlite3:)) + +(declare (unit lock-queue)) +(declare (uses common)) + +;;====================================================================== +;; attempt to prevent overlapping updates of rollup files by queueing +;; update requests in an sqlite db +;;====================================================================== + +(define (lock-queue:open-db fname) + (let* ((actualfname (conc fname ".lockdb")) + (dbexists (file-exists? actualfname)) + (db (sqlite3:open-database actualfname)) + (handler (make-busy-timeout 136000))) + (if dbexists + db + (begin + (sqlite3:execute + db + "CREATE TABLE IF NOT EXISTS queue ( + id INTEGER PRIMARY KEY, + test_id INTEGER, + start_time INTEGER, + state TEXT, + CONSTRAINT queue_constraint UNIQUE (test_id));") + (sqlite3:execute + db + "CREATE TABLE IF NOT EXISTS runlocks ( + id INTEGER PRIMARY KEY, + test_id INTEGER, + run_lock TEXT, + CONSTRAINT runlock_constraint UNIQUE (run_lock));"))) + (sqlite3:set-busy-handler! db handler) + db)) + +(define (lock-queue:set-state db test-id newstate) + (sqlite3:execute db "UPDATE queue SET state=? WHERE test_id=?;" + newstate + test-id)) + +(define (lock-queue:any-younger? db mystart test-id) + (let ((res #f)) + (sqlite3:for-each-row + (lambda (tid) + ;; Actually this should not be needed as mystart cannot be simultaneously less than and test-id same as + (if (not (equal? tid test-id)) + (set! res tid))) + db + "SELECT test_id FROM queue WHERE start_time > ?;" mystart) + res)) + +(define (lock-queue:get-lock db test-id) + (let ((res #f) + (lckqry (sqlite3:prepare db "SELECT test_id,run_lock FROM runlocks WHERE run_lock='locked';")) + (mklckqry (sqlite3:prepare db "INSERT INTO runlocks (test_id,run_lock) VALUES (?,'locked');"))) + (let ((result + (handle-exceptions + exn + #f + (sqlite3:with-transaction + db + (lambda () + (sqlite3:for-each-row (lambda (tid lockstate) + (set! res (list tid lockstate))) + lckqry) + (if res + (if (equal? (car res) test-id) + #t ;; already have the lock + #f) + (begin + (sqlite3:execute mklckqry test-id) + ;; if no error handled then return #t for got the lock + #t))))))) + (sqlite3:finalize! lckqry) + (sqlite3:finalize! mklckqry) + result))) + +(define (lock-queue:release-lock fname test-id) + (let ((db (lock-queue:open-db fname))) + (sqlite3:execute db "DELETE FROM runlocks WHERE test_id=?;" test-id) + (sqlite3:finalize! db))) + +(define (lock-queue:steal-lock db test-id) + (sqlite3:execute db "DELETE FROM runlocks WHERE run_lock='locked';") + (lock-queue:get-lock db test-it)) + +;; returns #f if ok to skip the task +;; returns #t if ok to proceed with task +;; otherwise waits +;; +(define (lock-queue:wait-turn fname test-id) + (let ((db (lock-queue:open-db fname)) + (mystart (current-seconds))) + (sqlite3:execute + db + "INSERT OR REPLACE INTO queue (test_id,start_time,state) VALUES (?,?,'waiting');" + test-id mystart) + (thread-sleep! 1) ;; give other tests a chance to register + (let ((result + (let loop ((younger-waiting (lock-queue:any-younger? db mystart test-id))) + (if younger-waiting + (begin + ;; no need for us to wait. mark in the lock queue db as skipping + (lock-queue:set-state db test-id "skipping") + #f) ;; let the calling process know that nothing needs to be done + (if (lock-queue:get-lock db test-id) + #t + (if (> (- (current-seconds) mystart) 36000) ;; waited too long, steal the lock + (lock-queue:steal-lock db test-id) + (begin + (thread-sleep! 1) + (loop (lock-queue:any-younger? db mystart test-id))))))))) + (sqlite3:finalize! db) + result))) + + +;; (use trace) +;; (trace lock-queue:get-lock lock-queue:release-lock lock-queue:wait-turn lock-queue:any-younger? lock-queue:set-state) Index: 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.5429) +(define megatest-version 1.5514) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -31,10 +31,11 @@ (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") (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc"))) (if (file-exists? debugcontrolf) (load debugcontrolf))) @@ -59,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 @@ -91,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 @@ -106,22 +108,25 @@ -dumpmode json : dump in json format instead of sexpr -show-cmdinfo : dump the command info for a test (run in test environment) Misc -rebuild-db : bring the database schema up to date + -cleanup-db : remove any orphan records, vacuum the db -update-meta : update the tests metadata for all tests -env2file fname : write the environment to fname.csh and fname.sh -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are overwritten by values set in config files. -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 + -mark-incompletes : find and mark incomplete tests Spreadsheet generation -extract-ods fname.ods : extract an open document spreadsheet from the database -pathmod path : insert path, i.e. path/runame/itempath/logfile.html will clear the field if no rundir/testname/itempath/logfile @@ -197,10 +202,11 @@ (list "-h" "-version" "-force" "-xterm" "-showkeys" + "-show-keys" "-test-status" "-set-values" "-load-test-data" "-summarize-items" "-gui" @@ -209,11 +215,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" @@ -222,13 +230,15 @@ "-test-paths" ;; get path(s) to a test, ordered by youngest first "-runall" ;; run all tests "-remove-runs" "-rebuild-db" + "-cleanup-db" "-rollup" "-update-meta" "-gen-megatest-area" + "-mark-incompletes" "-logging" "-v" ;; verbose 2, more than normal (normal is 1) "-q" ;; quiet 0, errors/warnings only ) @@ -245,14 +255,39 @@ (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")) +;; Overall exit handling setup immediately +;; +(if (or (args:get-arg "-process-reap")) + ;; (args:get-arg "-runtests") + ;; (args:get-arg "-execute") + ;; (args:get-arg "-remove-runs") + ;; (args:get-arg "-runstep")) + (let ((original-exit (exit-handler))) + (exit-handler (lambda (#!optional (exit-code 0)) + (printf "Preparing to exit with exit code ~A ...\n" exit-code) + (for-each + (lambda (pid) + (handle-exceptions + exn + #t + (let-values (((pid-val exit-status exit-code) (process-wait pid #t))) + (if (or (eq? pid-val pid) + (eq? pid-val 0)) + (begin + (printf "Sending signal/term to ~A\n" pid) + (process-signal pid signal/term)))))) + (process:children #f)) + (original-exit exit-code))))) + +;; Force default transport to fs +;; (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 ;;====================================================================== @@ -294,67 +329,102 @@ ;; Start the server - can be done in conjunction with -runall or -runtests (one day...) ;; we start the server if not running else start the client thread ;;====================================================================== (if (args:get-arg "-server") - (let ((transport (args:get-arg "-transport" "http"))) + + ;; Server? Start up here. + ;; + (let ((tl (setup-for-run)) + (transport (or (configf:lookup *configdat* "setup" "transport") + (args:get-arg "-transport" "http")))) (debug:print 2 "Launching server using transport " transport) (server:launch (string->symbol transport))) - (if (not (null? (lset-intersection + + ;; Not a server? This section will decide how to communicate + ;; + ;; Setup client for all expect listed here + (if (null? (lset-intersection equal? (hash-table-keys args:arg-hash) - '("-runtests" "-list-runs" "-rollup" - "-remove-runs" "-lock" "-unlock" - "-update-meta" "-extract-ods")))) + '("-list-servers" + "-stop-server" + "-show-cmdinfo"))) (if (setup-for-run) - (let loop ((servers (open-run-close tasks:get-best-server tasks:open-db)) - (trycount 0)) - (if (or (not servers) - (null? servers)) - (begin - (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"))) - ;; (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) - ))))) + (begin + + ;; if not list or kill then start a client (if appropriate) + (if (or (args-defined? "-h" "-version" "-gen-megatest-area" "-gen-megatest-test") + (eq? (length (hash-table-keys args:arg-hash)) 0)) + (debug:print-info 1 "Server connection not needed") + ;; ok, so lets connect to the server + (let* ((transport-from-config (configf:lookup *configdat* "setup" "transport")) + (transport-from-cmdln (args:get-arg "-transport")) + (transport-from-cmdinfo (if (getenv "MT_CMDINFO") + (let ((res (assoc 'transport + (read + (open-input-string + (base64:base64-decode + (getenv "MT_CMDINFO"))))))) + (if res (cadr res) #f)) + #f)) + (chosen-transport (string->symbol (or transport-from-cmdln + transport-from-cmdinfo + transport-from-config + "fs")))) + (debug:print 2 "chosen-transport: " chosen-transport " have; config=" transport-from-config ", cmdln=" transport-from-cmdln ", cmdinfo=" transport-from-cmdinfo) + (case chosen-transport + ((http) + (set! *transport-type 'http) + (server:ensure-running) + (client:launch)) + (else ;; (fs) + (set! *transport-type* 'fs) + (set! *megatest-db* (open-db)))))))))) +;; (cond +;; ;; command line overrides other mechanisms +;; (transport-from-cmdln +;; (if (equal? transport-from-cmdln "fs") +;; (set! *transport-type* 'fs) +;; (begin +;; (server:ensure-running) +;; (client:launch)))) +;; ;; cmdinfo is second priority +;; (transport-from-cmdinfo +;; (if (equal? transport-from-cmdinfo "fs") +;; (set! *transport-type* 'fs) +;; (begin +;; (server:ensure-running) +;; (client:launch)))) +;; ;; config file is next highest priority for determinining transport +;; (transport-from-config +;; (if (equal? transport-from-config "fs") +;; (set! *transport-type* 'fs) +;; (begin +;; (server:ensure-running) +;; (client:launch)))) +;; (else +;; (set! *transport-type* 'fs))))))))) (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)) @@ -369,27 +439,22 @@ (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") (set! *didsomething* #t) (exit)) ;; must do, would have to add checks to many/all calls below - (exit))) - ;; if not list or kill then start a client (if appropriate) - (if (or (args-defined? "-h" "-version" "-gen-megatest-area" "-gen-megatest-test") - (eq? (length (hash-table-keys args:arg-hash)) 0)) - (debug:print-info 1 "Server connection not needed") - ;; ok, so lets connect to the server - (client:launch))) + (exit)))) ;;====================================================================== ;; Weird special calls that need to run *after* the server has started? ;;====================================================================== @@ -401,11 +466,11 @@ (print x)) targets) (set! *didsomething* #t))) (define (full-runconfigs-read) - (let* ((keys (cdb:remote-run get-keys #f)) + (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))) @@ -432,11 +497,12 @@ (else (debug:print 0 "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) (set! *didsomething* #t))) (if (args:get-arg "-show-config") - (let ((data *configdat*)) ;; (read-config "megatest.config" #f #t))) + (let ((tl (setup-for-run)) + (data *configdat*)) ;; (read-config "megatest.config" #f #t))) ;; keep this one local (cond ((not (args:get-arg "-dumpmode")) (pp (hash-table->alist data))) ((string=? (args:get-arg "-dumpmode") "json") @@ -444,56 +510,65 @@ (else (debug:print 0 "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) (set! *didsomething* #t))) (if (args:get-arg "-show-cmdinfo") - (let ((data (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO")))))) - (if (equal? (args:get-arg "-dumpmode") "json") - (json-write data) - (pp data)) - (set! *didsomething* #t))) + (if (getenv "MT_CMDINFO") + (let ((data (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO")))))) + (if (equal? (args:get-arg "-dumpmode") "json") + (json-write data) + (pp data)) + (set! *didsomething* #t)) + (debug:print-info 0 "environment variable MT_CMDINFO is not set"))) ;;====================================================================== ;; Remove old run(s) ;;====================================================================== ;; 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 ;;====================================================================== @@ -504,32 +579,33 @@ (let* ((db #f) (runpatt (args:get-arg "-list-runs")) (testpatt (if (args:get-arg "-testpatt") (args:get-arg "-testpatt") "%")) - (runsdat (cdb:remote-run db:get-runs #f runpatt #f #f '())) + (keys (cdb:remote-run db:get-keys #f)) + (runsdat (cdb:remote-run db:get-runs-by-patt #f keys runpatt (or (args:get-arg "-target") + (args:get-arg "-reqtarg")) #f #f)) + ;; (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) @@ -590,14 +666,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)))) ;;====================================================================== @@ -619,44 +694,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 "-runtests") 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") @@ -685,35 +756,34 @@ (status (args:get-arg ":status")) (target (args:get-arg "-target")) (toppath (assoc/default 'toppath cmdinfo))) (change-directory toppath) ;; (set! *runremote* runremote) - (set! *transport-type* (string->symbol transport)) + ;; (set! *transport-type* (string->symbol transport)) (if (not target) (begin (debug:print 0 "ERROR: -target is required.") (exit 1))) (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)))))) ;;====================================================================== @@ -737,35 +807,34 @@ (state (args:get-arg ":state")) (status (args:get-arg ":status")) (target (args:get-arg "-target"))) (change-directory testpath) ;; (set! *runremote* runremote) - (set! *transport-type* (string->symbol transport)) + ;; (set! *transport-type* (string->symbol transport)) (if (not target) (begin (debug:print 0 "ERROR: -target is required.") (exit 1))) (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)))))) ;;====================================================================== @@ -774,18 +843,18 @@ (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) - (cdb:remote-run db:extract-ods-file db outputfile keyvalalist (if runspatt runspatt "%") pathmod))))) + (pathmod (args:get-arg "-pathmod"))) + ;; (keyvalalist (keys->alist keys "%"))) + (debug:print 2 "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvals: " keyvals) + (cdb:remote-run db:extract-ods-file db outputfile keyvals (if runspatt runspatt "%") pathmod))))) ;;====================================================================== ;; execute the test ;; - gets called on remote host ;; - receives info from the -execute param @@ -819,11 +888,12 @@ (itemdat (assoc/default 'itemdat cmdinfo)) (work-area (assoc/default 'work-area cmdinfo)) (db #f)) (change-directory testpath) ;; (set! *runremote* runremote) - (set! *transport-type* (string->symbol transport)) + ;; The transport is handled earlier in the loading process of megatest. + ;; (set! *transport-type* (string->symbol transport)) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (if (and state status) @@ -870,18 +940,19 @@ (itemdat (assoc/default 'itemdat cmdinfo)) (work-area (assoc/default 'work-area cmdinfo)) (db #f) ;; (open-db)) (state (args:get-arg ":state")) (status (args:get-arg ":status"))) - (change-directory testpath) ;; (set! *runremote* runremote) - (set! *transport-type* (string->symbol transport)) + ;; (set! *transport-type* (string->symbol transport)) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) + (if (args:get-arg "-runstep")(debug:print-info 1 "Running -runstep, first change to directory " work-area)) + (change-directory work-area) ;; can setup as client for server mode now ;; (client:setup) (if (args:get-arg "-load-test-data") ;; has sub commands that are rdb: @@ -893,11 +964,11 @@ (if (args:get-arg "-set-toplog") ;; DO NOT run remote (tests:test-set-toplog! db run-id test-name (args:get-arg "-set-toplog"))) (if (args:get-arg "-summarize-items") ;; DO NOT run remote - (tests:summarize-items db run-id test-name #t)) ;; do force here + (tests:summarize-items db run-id test-id test-name #t)) ;; do force here (if (args:get-arg "-runstep") (if (null? remargs) (begin (debug:print 0 "ERROR: nothing specified to run!") (if db (sqlite3:finalize! db)) @@ -918,15 +989,15 @@ ") " redir " " logfile))) ;; mark the start of the test ;; DO NOT run remote (db:teststep-set-status! db test-id stepname "start" "n/a" (args:get-arg "-m") logfile work-area: work-area) ;; run the test step - (debug:print-info 2 "Running \"" fullcmd "\"") + (debug:print-info 2 "Running \"" fullcmd "\" in directory \"" startingdir) (change-directory startingdir) (set! exitstat (system fullcmd)) ;; cmd params)) (set! *globalexitstatus* exitstat) - (change-directory testpath) + ;; (change-directory testpath) ;; run logpro if applicable ;; (process-run "ls" (list "/foo" "2>&1" "blah.log")) (if logprofile (let* ((htmllogfile (conc stepname ".html")) (oldexitstat exitstat) (cmd (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " "))) @@ -971,19 +1042,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 @@ -1000,11 +1072,11 @@ (let ((testname (args:get-arg "-gen-megatest-test"))) (genexample:mk-megatest-test testname) (set! *didsomething* #t))) ;;====================================================================== -;; Update the database schema on request +;; Update the database schema, clean up the db ;;====================================================================== (if (args:get-arg "-rebuild-db") (begin (if (not (setup-for-run)) @@ -1012,10 +1084,42 @@ (debug:print 0 "Failed to setup, exiting") (exit 1))) ;; keep this one local (open-run-close patch-db #f) (set! *didsomething* #t))) + +(if (args:get-arg "-cleanup-db") + (begin + (if (not (setup-for-run)) + (begin + (debug:print 0 "Failed to setup, exiting") + (exit 1))) + ;; keep this one local + (open-run-close db:clean-up #f) + (set! *didsomething* #t))) + +(if (args:get-arg "-mark-incompletes") + (begin + (if (not (setup-for-run)) + (begin + (debug:print 0 "Failed to setup, exiting") + (exit 1))) + (open-run-close db:find-and-mark-incomplete #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 ;;====================================================================== @@ -1025,11 +1129,11 @@ (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) ;; now can find our db ;; keep this one local - (open-run-close runs:update-all-test_meta db) + (open-run-close runs:update-all-test_meta #f) (set! *didsomething* #t))) ;;====================================================================== ;; Start a repl ;;====================================================================== @@ -1040,12 +1144,10 @@ (db (if toppath (open-db) #f))) (if db (begin (set! *db* db) (set! *client-non-blocking-mode* #t) - ;; (client:setup) - ;; (client:launch) (import readline) (import apropos) (gnu-history-install-file-manager (string-append (or (get-environment-variable "HOME") ".") "/.megatest_history")) ADDED mt.scm Index: mt.scm ================================================================== --- /dev/null +++ mt.scm @@ -0,0 +1,213 @@ +;; 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) + (let loop ((runsdat (cdb:remote-run db:get-runs-by-patt #f keys runnamepatt targpatt 0 500)) + (res '()) + (offset 0) + (limit 500)) + ;; (print "runsdat: " runsdat) + (let* ((header (vector-ref runsdat 0)) + (runslst (vector-ref runsdat 1)) + (full-list (append res runslst)) + (have-more (eq? (length runslst) limit))) + ;; (debug:print 0 "header: " header " runslst: " runslst " have-more: " have-more) + (if have-more + (let ((new-offset (+ offset limit)) + (next-batch (cdb:remote-run db:get-runs-by-patt #f keys runnamepatt targpatt offset limit))) + (debug:print-info 4 "More than " limit " runs, have " (length full-list) " runs so far.") + (debug:print-info 0 "next-batch: " next-batch) + (loop next-batch + full-list + new-offset + limit)) + (vector header full-list))))) + +;;====================================================================== +;; T E S T S +;;====================================================================== + +(define (mt:get-tests-for-run run-id testpatt states status #!key (not-in #t) (sort-by 'event_time) (sort-order "ASC") (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 sort-order 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 sort-order 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:lazy-get-prereqs-not-met run-id waitons ref-item-path #!key (mode 'normal)) + (let* ((key (list run-id waitons ref-item-path mode)) + (res (hash-table-ref/default *pre-reqs-met-cache* key #f)) + (useres (let ((last-time (if (vector? res) (vector-ref res 0) #f))) + (if last-time + (< (current-seconds)(+ last-time 5)) + #f)))) + (if useres + (let ((result (vector-ref res 1))) + (debug:print 4 "Using lazy value res: " result) + result) + (let ((newres (db:get-prereqs-not-met run-id waitons ref-item-path mode: mode))) + (hash-table-set! *pre-reqs-met-cache* key (vector (current-seconds) newres)) + newres)))) + +(define (mt:get-run-stats) + (cdb:remote-run db:get-run-stats #f)) + +(define (mt:discard-blocked-tests run-id failed-test tests test-records) + (if (null? tests) + tests + (begin + (debug:print-info 1 "Discarding tests from " tests " that are waiting on " failed-test) + (let loop ((testn (car tests)) + (remt (cdr tests)) + (res '())) + (let ((waitons (vector-ref (hash-table-ref/default test-records testn (vector #f #f '())) 2))) + ;; (print "mt:discard-blocked-tests run-id: " run-id " failed-test: " failed-test " testn: " testn " with waitons: " waitons) + (if (null? remt) + (let ((new-res (reverse res))) + ;; (print " new-res: " new-res) + new-res) + (loop (car remt) + (cdr remt) + (if (member failed-test waitons) + res + (cons testn res))))))))) + +;;====================================================================== +;; T R I G G E R S +;;====================================================================== + +(define (mt:process-triggers test-id newstate newstatus) + (let* ((test-dat (mt:lazy-get-test-info-by-id test-id)) + (test-rundir (db:test-get-rundir test-dat)) + (test-name (db:test-get-testname test-dat)) + (tconfig #f) + (state (if newstate newstate (db:test-get-state test-dat))) + (status (if newstatus newstatus (db:test-get-status test-dat)))) + (if (and (file-exists? test-rundir) + (directory? test-rundir)) + (begin + (push-directory test-rundir) + (set! tconfig (mt:lazy-read-test-config test-name)) + (pop-directory) + (for-each (lambda (trigger) + (let ((cmd (configf:lookup tconfig "triggers" trigger)) + (logf (conc test-rundir "/last-trigger.log"))) + (if cmd + ;; Putting the commandline into ( )'s means no control over the shell. + ;; stdout and stderr will be caught in the NBFAKE or mt_launch.log files + ;; or equivalent. No need to do this. Just run it? + (let ((fullcmd (conc cmd " " test-id " " test-rundir " " trigger "&"))) + (debug:print-info 0 "TRIGGERED on " trigger ", running command " fullcmd) + (process-run fullcmd))))) + (list + (conc state "/" status) + (conc state "/") + (conc "/" status))))))) + +;;====================================================================== +;; S T A T E A N D S T A T U S F O R T E S T S +;;====================================================================== + +(define (mt:roll-up-pass-fail-counts run-id test-name item-path status) + (if (and (not (equal? item-path "")) + (member status '("PASS" "WARN" "FAIL" "WAIVED" "RUNNING" "CHECK" "SKIP"))) + (begin + (cdb:update-pass-fail-counts *runremote* run-id test-name) + (if (equal? status "RUNNING") + (cdb:top-test-set-running *runremote* run-id test-name) + (cdb:top-test-set-per-pf-counts *runremote* run-id test-name)) + #f) + #f)) + +;; speed up for common cases with a little logic +(define (mt:test-set-state-status-by-id test-id newstate newstatus newcomment) + (cond + ((and newstate newstatus newcomment) + (cdb:client-call *runremote* 'state-status-msg #t *default-numtries* newstate newstatus newcomment test-id)) + ((and newstate newstatus) + (cdb:client-call *runremote* 'state-status #t *default-numtries* newstate newstatus test-id)) + (else + (if newstate (cdb:client-call *runremote* 'set-test-state #t *default-numtries* newstate test-id)) + (if newstatus (cdb:client-call *runremote* 'set-test-status #t *default-numtries* newstatus test-id)) + (if newcomment (cdb:client-call *runremote* 'set-test-comment #t *default-numtries* newcomment test-id)))) + (mt:process-triggers test-id newstate newstatus) + #t) + +(define (mt:lazy-get-test-info-by-id test-id) + (let* ((tdat (hash-table-ref/default *test-info* test-id #f))) + (if (and tdat + (< (current-seconds)(+ (vector-ref tdat 0) 10))) + (vector-ref tdat 1) + ;; no need to update *test-info* as that is done in cdb:get-test-info-by-id + (cdb:get-test-info-by-id *runremote* test-id)))) + +(define (mt:lazy-read-test-config test-name) + (let ((tconf (hash-table-ref/default *testconfigs* test-name #f))) + (if tconf + tconf + (let ((test-dirs (tests:get-tests-search-path *configdat*))) + (let loop ((hed (car test-dirs)) + (tal (cdr test-dirs))) + (let ((tconfig-file (conc hed "/" test-name "/testconfig"))) + (if (and (file-exists? tconfig-file) + (file-read-access? tconfig-file)) + (let ((newtcfg (read-config tconfig-file #f #f))) ;; NOTE: Does NOT run [system ...] + (hash-table-set! *testconfigs* test-name newtcfg) + newtcfg) + (if (null? tal) + (begin + (debug:print 0 "ERROR: No readable testconfig found for " test-name) + #f) + (loop (car tal)(cdr tal)))))))))) + 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*)) Index: process.scm ================================================================== --- process.scm +++ process.scm @@ -109,5 +109,21 @@ (begin (thread-sleep! 2) (loop (+ i 1))) (values pid-val exit-status exit-code)))))) +;;====================================================================== +;; MISC PROCESS RELATED STUFF +;;====================================================================== + +(define (process:children proc) + (with-input-from-pipe + (conc "ps h --ppid " (current-process-id) " -o pid") + (lambda () + (let loop ((inl (read-line)) + (res '())) + (if (eof-object? inl) + (reverse res) + (let ((pid (string->number inl))) + (if proc (proc pid)) + (loop (read-line) (cons pid res)))))))) + DELETED run-tests-queue-classic.scm Index: run-tests-queue-classic.scm ================================================================== --- run-tests-queue-classic.scm +++ /dev/null @@ -1,301 +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 required-tests) - ;; 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) - (if (and (not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests)) - (not (null? tal))) - (loop (car newtal)(cdr newtal) reruns)) - (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 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) - ;; (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 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 (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 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) - ;; (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,334 +0,0 @@ - -;; 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 required-tests 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) - (if (and (not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path)) - (not (null? tal))) - (loop (car tal)(cdr tal) reg reruns)) - (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,24 +27,27 @@ (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 (for-each (lambda (envvar) (let ((val (cadr (assoc envvar section-dat)))) (hash-table-set! whatfound section (+ (hash-table-ref/default whatfound section 0) 1)) - (if change-env (setenv envvar val)) + (if (and (string? envvar) + (string? val) + change-env) + (setenv envvar val)) (hash-table-set! finaldat envvar val))) (map car section-dat))))) sections) (if already-seen (begin @@ -59,20 +57,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,106 +18,161 @@ (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 (set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)) - (let ((keys (if inkeys inkeys (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) + (if (and (string? key) + (string? val)) + (setenv key val) + (debug:print 0 "ERROR: Malformed environment variable definition: var=" var ", val=" 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" (if inrunname inrunname (cdb:remote-run db:get-run-name-from-id #f run-id))) - (setenv "MT_RUN_AREA_HOME" *toppath*) - )) + (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) +;; Temporary globals. Move these into the logic or into common +;; +(define *seen-cant-run-tests* (make-hash-table)) ;; use to track tests that we suspect cannot be run +(define (runs:inc-cant-run-tests testname) + (hash-table-set! *seen-cant-run-tests* testname + (+ (hash-table-ref/default *seen-cant-run-tests* testname 0) 1))) +(define (runs:can-keep-running? testname n) + (< (hash-table-ref/default *seen-cant-run-tests* testname 0) n)) + +(define *runs:denoise* (make-hash-table)) ;; key => last-time-ran + +(define (runs:lownoise key waitval) + (let ((lasttime (hash-table-ref/default *runs:denoise* key 0)) + (currtime (current-seconds))) + (if (> (- currtime lasttime) waitval) + (begin + (hash-table-set! *runs:denoise* key currtime) + #t) + #f))) + +(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))) + (job-group-limit (let ((jobg-count (config-lookup *configdat* "jobgroups" jobgroup))) + (if (string? jobg-count) + (string->number jobg-count) + jobg-count)))) (if (> (+ num-running num-running-in-jobgroup) 0) (set! *runs:can-run-more-tests-count* (+ *runs:can-run-more-tests-count* 1))) (if (not (eq? *last-num-running-tests* num-running)) (begin (debug:print 2 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running) @@ -126,64 +181,55 @@ (list #f num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit) (let ((can-not-run-more (cond ;; if max-concurrent-jobs is set and the number running is greater ;; than it than cannot run more jobs ((and max-concurrent-jobs (>= num-running max-concurrent-jobs)) - (debug:print 0 "WARNING: Max running jobs exceeded, current number running: " num-running - ", max_concurrent_jobs: " max-concurrent-jobs) + (if (runs:lownoise "mcj msg" 60) + (debug:print 0 "WARNING: Max running jobs exceeded, current number running: " num-running + ", max_concurrent_jobs: " max-concurrent-jobs)) #t) ;; if job-group-limit is set and number of jobs in the group is greater ;; than the limit then cannot run more jobs of this kind ((and job-group-limit (>= num-running-in-jobgroup job-group-limit)) - (debug:print 1 "WARNING: number of jobs " num-running-in-jobgroup - " in " jobgroup " exceeded, will not run " (tests:testqueue-get-testname test-record)) + (if (runs:lownoise (conc "maxjobgroup " jobgroup) 60) + (debug:print 1 "WARNING: number of jobs " num-running-in-jobgroup + " in jobgroup \"" jobgroup "\" exceeds limit of " job-group-limit)) #t) (else #f)))) (list (not can-not-run-more) num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit))))) -;;====================================================================== -;; 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)) - (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)) - (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 - + (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 + (runconfigf (conc *toppath* "/runconfigs.config")) + (required-tests '()) + (test-records (make-hash-table)) + (all-tests-registry (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names + (all-test-names (hash-table-keys all-tests-registry)) + (test-names (tests:filter-test-names all-test-names test-patts))) + + ;; Update the synchronous setting in the db based on the default or what is set by the user + ;; This is done once here on a call to run tests rather than on every call to open-db + (cdb:remote-run db:set-sync #f) + + (set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; 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) @@ -193,23 +239,30 @@ ;; 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) + ;; Ensure all tests are registered in the test_meta table + (runs:update-all-test_meta #f) + ;; now add non-directly referenced dependencies (i.e. waiton) + ;;====================================================================== + ;; refactoring this block into tests:get-full-data + ;; + ;; What happended, this code is now duplicated in 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)) + (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. + (setenv "MT_TEST_NAME" hed) ;; + (let* ((config (tests:get-testconfig hed all-tests-registry '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) (let ((newwaitons (string-split (cond ((procedure? instr) @@ -219,11 +272,11 @@ ((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) + (if (hash-table-ref/default all-tests-registry x #f) #t (begin (debug:print 0 "ERROR: test " hed " has unrecognised waiton testname " x) #f))) newwaitons))))) @@ -261,11 +314,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 ))) @@ -282,16 +335,649 @@ (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 required-tests reglen) - (runs:run-tests-queue-classic run-id runname test-records keyvallst flags test-patts required-tests))) + (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) all-tests-registry) + (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:nothing-left-in-queue-count 0) + +(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 test-registry test-records) + (let* ((loop-list (list hed tal reg reruns)) + (prereqs-not-met (mt:lazy-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 + + ((member (hash-table-ref/default test-registry (runs:make-full-test-name hed item-path) 'n/a) + '(DONOTRUN removed)) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE)) ;; try to catch repeat processing of COMPLETED tests here + (debug:print-info 1 "Test " hed " set to \"" (hash-table-ref test-registry (runs:make-full-test-name hed item-path)) "\". Removing it from the queue") + (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) + (begin + (debug:print-info 0 "Nothing left in the queue!") + ;; If get here twice then we know we've tried to expand all items + ;; since there must be a logic issue with the handling of loops in the + ;; items expand phase we will brute force an exit here. + (if (> runs:nothing-left-in-queue-count 2) + (begin + (debug:print 0 "WARNING: this condition is triggered when there were no items to expand and nothing to run. Please check your run for completeness") + (exit 0)) + (set! runs:nothing-left-in-queue-count (+ runs:nothing-left-in-queue-count 1))) + #f))) + + ;; + ((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 items table did not yield a list - please report this") + (exit 1)))))) + + ((and (null? fails) + (not (null? non-completed))) + (let* ((allinqueue (map (lambda (x)(if (string? x) x (db:test-get-testname x))) + (append newtal reruns))) + ;; prereqstrs is a list of test names as strings that are prereqs for hed + (prereqstrs (delete-duplicates (map (lambda (x)(if (string? x) x (db:test-get-testname x))) + prereqs-not-met))) + ;; a prereq that is not found in allinqueue will be put in the notinqueue list + ;; + ;; (notinqueue (filter (lambda (x) + ;; (not (member x allinqueue))) + ;; prereqstrs)) + (give-up #f)) + + ;; We can get here when a prereq has not been run due to *it* having a prereq that failed. + ;; We need to use this to dequeue this item as CANNOTRUN + (for-each (lambda (prereq) + (if (eq? (hash-table-ref/default test-registry prereq 'justfine) 'CANNOTRUN) + (set! give-up #t))) + prereqstrs) + (if (and give-up + (not (and (null? tal)(null? reg)))) + (let ((trimmed-tal (mt:discard-blocked-tests run-id hed tal test-records)) + (trimmed-reg (mt:discard-blocked-tests run-id hed reg test-records))) + (debug:print 1 "WARNING: test " hed " has discarded prerequisites, removing it from the queue") + (if (and (null? trimmed-tal) + (null? trimmed-reg)) + #f + (list (runs:queue-next-hed trimmed-tal trimmed-reg reglen regfull) + (runs:queue-next-tal trimmed-tal trimmed-reg reglen regfull) + (runs:queue-next-reg trimmed-tal trimmed-reg reglen regfull) + reruns))) + (list (car newtal)(append (cdr newtal) reg) '() reruns)))) + + ;; (debug:print-info 1 "allinqueue: " allinqueue) + ;; (debug:print-info 1 "prereqstrs: " prereqstrs) + ;; (debug:print-info 1 "notinqueue: " notinqueue) + ;; (debug:print-info 1 "tal: " tal) + ;; (debug:print-info 1 "newtal: " newtal) + ;; (debug:print-info 1 "reg: " reg) + +;; == == ;; num-retries code was here +;; == == ;; we use this opportunity to move contents of reg to tal +;; == == ;; but also lets check that the prerequisites are all in the newtal or reruns lists +;; == == +;; == == (let* ((allinqueue (map (lambda (x)(if (string? x) x (db:test-get-testname x))) +;; == == (append newtal reruns))) +;; == == ;; prereqstrs is a list of test names as strings that are prereqs for hed +;; == == (prereqstrs (map (lambda (x)(if (string? x) x (db:test-get-testname x))) +;; == == prereqs-not-met)) +;; == == ;; a prereq that is not found in allinqueue will be put in the notinqueue list +;; == == ;; +;; == == (notinqueue (filter (lambda (x) +;; == == (not (member x allinqueue))) +;; == == prereqstrs))) +;; == == (if (not (null? notinqueue)) +;; == == (if (runs:can-keep-running? hed 5) ;; try five times +;; == == (begin +;; == == (debug:print-info 4 "increment cant-run-tests for " hed) +;; == == (runs:inc-cant-run-tests hed) +;; == == (list (car newtal)(append (cdr newtal) reg) '() reruns)) +;; == == (begin +;; == == +;; == == (if (runs:lownoise (conc "no fails prereq, null notinqueue " hed) 30) +;; == == (begin +;; == == (debug:print 1 "WARNING: test " hed " has no failed prerequisites but does have prerequistes that are NOT in the queue: " (string-intersperse notinqueue ", ")) +;; == == (debug:print-info 4 "allinqueue: " allinqueue) +;; == == (debug:print-info 4 "prereqstrs: " prereqstrs) +;; == == (debug:print-info 4 "notinqueue: " notinqueue))) +;; == == (if (and (null? tal)(null? reg)) +;; == == (list (car newtal)(append (cdr newtal) reg) '() reruns) +;; == == (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)))) +;; == == ;; have prereqs in queue, keep going. +;; == == (begin +;; == == (if (runs:lownoise (conc "no fails prereq " hed) 30) +;; == == (debug:print-info 1 "no fails in prerequisites for " hed ", waiting on tests; " +;; == == (string-intersperse (map (lambda (x) +;; == == (if (string? x) +;; == == x +;; == == (runs:make-full-test-name (db:test-get-testname x) +;; == == (db:test-get-item-path x)))) +;; == == non-completed) ", ") +;; == == ". Delaying launch of " hed ".")) +;; == == (list (car newtal)(append (cdr newtal) reg) '() reruns))))) ;; an issue with prereqs not yet met? + + ((and (null? fails) + (null? non-completed)) + (if (runs:can-keep-running? hed 5) + (begin + (runs:inc-cant-run-tests hed) + (debug:print-info 1 "no fails in prerequisites for " hed " but also none running, keeping " hed " for now. Try count: " (hash-table-ref/default *seen-cant-run-tests* hed 0)) + ;; 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? + (begin + (debug:print-info 1 "no fails in prerequisites for " hed " but nothing seen running in a while, dropping test " hed " from the run queue") + (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)))) + + ((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))) + (begin + (hash-table-set! test-registry hed 'CANNOTRUN) + (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 + + ((and (not (null? fails))(eq? testmode 'toplevel)) + (if (or (not (null? reg))(not (null? tal))) + (list (car newtal)(append (cdr newtal) reg) '() reruns) + #f)) + (else + (debug:print 1 "WARNING: FAILS or incomplete tests are preventing completion of this run. Dropping test " hed " from the run queue") + (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))))) ;; (list (car newtal)(cdr newtal) reg reruns))))) + +(define (runs:mixed-list-testname-and-testrec->list-of-strings inlst) + (map (lambda (t) + (cond + ((vector? t) + (conc (db:test-get-state t) "/" (db:test-get-status t))) + ((string? t) + t) + (else + (conc t)))) + inlst)) + +(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 all-tests-registry) + (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:lazy-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) + + (if (not (null? prereqs-not-met)) + (debug:print-info 1 "waiting on tests; " (string-intersperse (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) ", "))) + + ;; 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" ) + (if (eq? *transport-type* 'fs) ;; no point in parallel registration if use fs + (begin + (cdb:tests-register-test *runremote* run-id test-name item-path) + (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'done)) + (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 + (if (runs:lownoise "no resources" 60) + (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)))) + ;; (hash-table-delete! *max-tries-hash* (runs:make-full-test-name test-name item-path)) + ;; we are going to reset all the counters for test retries by setting a new hash table + ;; this means they will increment only when nothing can be run + (set! *max-tries-hash* (make-hash-table)) + (run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry) + (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'running) + (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. + ;; (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) + (if (not (null? prereqs-not-met)) + (debug:print-info 1 "waiting on tests; " (string-intersperse + (runs:mixed-list-testname-and-testrec->list-of-strings + prereqs-not-met) ", "))) + + (if (null? fails) + (begin + ;; couldn't run, take a breather + (debug:print-info 0 "Waiting for more work to do...") + (thread-sleep! 1) + (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 0 "WARNING: Test not processed correctly. Could be a race condition in your test implementation? Dropping test " 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) + (list (car newtal)(cdr newtal) reg reruns) + )))))))) + +;; every time though the loop increment the test/itempatt val. +;; when the min is > max-allowed and none running then force exit +;; +(define *max-tries-hash* (make-hash-table)) + +;; 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 all-tests-registry) + ;; 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)) + + ;; Do mark-and-find clean up of db before starting runing of quue + ;; + ;; (cdb:remote-run db:find-and-mark-incomplete #f) + + (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)) + (last-time-incomplete (current-seconds)) + (last-time-some-running (current-seconds))) + + ;; 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))) + (if (not (equal? st "DELETED")) + (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)) + + ;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes + ;; (if (> (current-seconds)(+ last-time-incomplete 900)) + ;; (begin + ;; (set! last-time-incomplete (current-seconds)) + ;; (cdb:remote-run db:find-and-mark-incomplete #f))) + + ;; (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 "test_meta" "jobgroup")) + (testmode (let ((m (config-lookup tconfig "requirements" "mode"))) + (if m (string->symbol m) 'normal))) + (waitons (tests:testqueue-get-waitons test-record)) + (priority (tests:testqueue-get-priority test-record)) + (itemdat (tests:testqueue-get-itemdat test-record)) ;; itemdat can be a string, list or #f + (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)) + (num-running (cdb:remote-run db:get-count-tests-running-for-run-id #f run-id))) + + (if (> num-running 0) + (set! last-time-some-running (current-seconds))) + + (if (> (current-seconds)(+ last-time-some-running 60)) + (hash-table-set! *max-tries-hash* tfullname (+ (hash-table-ref/default *max-tries-hash* tfullname 0) 1))) + ;; (debug:print 0 "max-tries-hash: " (hash-table->alist *max-tries-hash*)) + + ;; Ensure all top level tests get registered. This way they show up as "NOT_STARTED" on the dashboard + ;; and it is clear they *should* have run but did not. + (if (not (hash-table-ref/default test-registry (runs:make-full-test-name test-name "") #f)) + (begin + (cdb:tests-register-test *runremote* run-id test-name "") + (hash-table-set! test-registry (runs:make-full-test-name test-name "") 'done))) + + ;; Fast skip of tests that are already "COMPLETED" - NO! Cannot do that as the items may not have been expanded yet :( + ;; + (if (member (hash-table-ref/default test-registry tfullname #f) + '(DONOTRUN removed)) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE)) + (begin + (debug:print-info 0 "Skipping test " tfullname " as it has been marked do not run due to being completed or not runnable") + (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 + + ;; We want to catch tests that have waitons that are NOT in the queue and discard them IFF + ;; they have been through the wringer 10 or more times + ((and (list? waitons) + (not (null? waitons)) + (> (hash-table-ref/default *max-tries-hash* tfullname 0) 10) + (not (null? (filter + number? + (map (lambda (waiton) + (if (and (not (member waiton tal)) ;; this waiton is not in the list to be tried to run + (not (member waiton reruns))) + 1 + #f)) + waitons))))) ;; could do this more elegantly with a marker.... + (debug:print 0 "WARNING: Marking test " tfullname " as not runnable. It is waiting on tests that cannot be run. Giving up now.") + (hash-table-set! test-registry tfullname 'removed)) + + ;; 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 all-tests-registry))) + (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)) + (debug:print 2 (map (lambda (row) + (conc (string-intersperse + (map (lambda (varval) + (string-intersperse varval "=")) + row) + " ") + "\n")) + 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 test-registry test-records))) + (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) @@ -313,94 +999,88 @@ 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-tests-registry) ;; All these vars might be referenced by the testconfig file reader (let* ((test-name (tests:testqueue-get-testname test-record)) (test-waitons (tests:testqueue-get-waitons test-record)) (test-conf (tests:testqueue-get-testconfig test-record)) (itemdat (tests:testqueue-get-itemdat test-record)) - (test-path (conc *toppath* "/tests/" test-name)) ;; could use tests:get-testconfig here ... + (test-path (hash-table-ref all-tests-registry test-name)) ;; (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_ITEMPATH" item-path) (setenv "MT_RUNNAME" runname) (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? + ;; + ;; There is now a single call to runs:update-all-test_meta and this + ;; per-test call is not needed. Given the delicacy of the move to + ;; v1.55 this code is being left in place for the time being. + ;; (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))) + (test-id (cdb:remote-run db:get-test-id-cached #f run-id test-name item-path)) + (testdat (if test-id (cdb:get-test-info-by-id *runremote* test-id) #f))) (if (not testdat) - (begin + (let loop () ;; ensure that the path exists before registering the test ;; NOPE: Cannot! Don't know yet which disk area will be assigned.... ;; (system (conc "mkdir -p " new-test-path)) ;; ;; (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)) + (if (not test-id)(set! test-id (cdb:remote-run db:get-test-id-cached #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-cached #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)))) + (set! testdat (cdb:get-test-info-by-id *runremote* test-id)) + (if (not testdat) + (begin + (debug:print-info 0 "WARNING: server is overloaded, trying again in one second") + (thread-sleep! 1) + (loop))))) + (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) + (if (file-exists? test-path) + (change-directory test-path) + (begin + (debug:print "ERROR: test run path not created before attempting to run the test. Perhaps you are running -remove-runs at the same time?") + (change-directory *toppath*))) (case (if force ;; (args:get-arg "-force") 'NOT_STARTED (if testdat (string->symbol (test:get-state testdat)) 'failed-to-insert)) @@ -415,13 +1095,14 @@ ((member (test:get-state testdat) '("DELETED" "NOT_STARTED"))(set! runflag #t)) ;; not -rerun and PASS, WARN or CHECK, do no run ((and (or (not rerun) keepgoing) ;; Require to force re-run for COMPLETED or *anything* + PASS,WARN or CHECK - (or (member (test:get-status testdat) '("PASS" "WARN" "CHECK" "SKIP")) + (or (member (test:get-status testdat) '("PASS" "WARN" "CHECK" "SKIP" "WAIVED")) (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 'DONOTRUN) ;; 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))) @@ -435,35 +1116,61 @@ (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" "REMOTEHOSTSTART" "LAUNCHED") '() #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 + (mt:test-set-state-status-by-id test-id "COMPLETED" "SKIP" skip-test) + (debug:print-info 1 "SKIPPING Test " full-test-name " due to " skip-test)) + (if (not (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat flags)) + (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.") + (hash-table-set! test-registry (runs:make-full-test-name test-name test-path) 'DONOTRUN)) ;; KILLED)) ((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)) + (case (string->symbol (test:get-state testdat)) + ((COMPLETED INCOMPLETE) + (hash-table-set! test-registry (runs:make-full-test-name test-name test-path) 'DONOTRUN)) + (else + (hash-table-set! test-registry (runs:make-full-test-name test-name test-path) 'DONOTRUN)))))))) ;;====================================================================== ;; END OF NEW STUFF ;;====================================================================== @@ -471,23 +1178,47 @@ (let ((dparts (string-split dir "/")) (count (if (null? params) 1 (car params)))) (conc "/" (string-intersperse (take dparts (- (length dparts) count)) "/")))) + +(define (runs:recursive-delete-with-error-msg real-dir) + (if (> (system (conc "rm -rf " real-dir)) 0) + (debug:print 0 "ERROR: There was a problem removing " real-dir " with rm -f"))) + +(define (runs:safe-delete-test-dir real-dir) + ;; first delete all sub-directories + (directory-fold + (lambda (f x) + (let ((fullname (conc real-dir "/" f))) + (if (directory? fullname)(runs:recursive-delete-with-error-msg fullname))) + (+ 1 x)) + 0 real-dir) + ;; then files other than *testdat.db* + (directory-fold + (lambda (f x) + (let ((fullname (conc real-dir "/" f))) + (if (not (string-search (regexp "testdat.db") f)) + (runs:recursive-delete-with-error-msg fullname))) + (+ 1 x)) + 0 real-dir) + ;; then the entire directory + (runs:recursive-delete-with-error-msg real-dir)) + ;; Remove runs ;; fields are passing in through ;; action: ;; '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)))) @@ -497,21 +1228,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 @@ -521,79 +1254,125 @@ ((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:get-test-info-by-id *runremote* test-id))) + (if (not new-test-dat) + (begin + (debug:print 0 "ERROR: We have a test-id of " test-id " but no record was found. NOTE: No locking of records is done between processes, do not simultaneously remove the same run from two processes!") + (if (not (null? tal)) + (loop (car tal)(cdr tal)))) + (let* ((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)) + (begin + ;; want to set to REMOVING BUT CANNOT do it here? + (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") + (mt:test-set-state-status-by-id (db:test-get-id test) "FAILEDKILL" "n/a" #f) + (thread-sleep! 1)) + (begin + (mt:test-set-state-status-by-id (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 + (mt:test-set-state-status-by-id (db:test-get-id test) "REMOVING" "LOCKED" #f) + (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) + (runs:safe-delete-test-dir real-dir) + (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.")) + )) + ;; Only delete the records *after* removing the directory. If things fail we have a record + (cdb:remote-run db:delete-test-records db #f (db:test-get-id test)) + (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)) + (mt:test-set-state-status-by-id (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)))) @@ -610,39 +1389,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))) (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") @@ -651,34 +1429,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 ;;====================================================================== @@ -686,11 +1462,11 @@ ;; Update the test_meta table for this test (define (runs:update-test_meta test-name test-conf) (let ((currrecord (cdb:remote-run db:testmeta-get-record #f test-name))) (if (not currrecord) (begin - (set! currrecord (make-vector 10 #f)) + (set! currrecord (make-vector 11 #f)) (cdb:remote-run db:testmeta-add-record #f test-name))) (for-each (lambda (key) (let* ((idx (cadr key)) (fld (car key)) @@ -698,35 +1474,31 @@ ;; (debug:print 5 "idx: " idx " fld: " fld " val: " val) (if (and val (not (equal? (vector-ref currrecord idx) val))) (begin (print "Updating " test-name " " fld " to " val) (cdb:remote-run db:testmeta-update-field #f test-name fld val))))) - '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9))))) + '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)("jobgroup" 10))))) ;; Update test_meta for all tests (define (runs:update-all-test_meta db) - (let ((test-names (get-all-legal-tests))) + (let ((test-names (tests:get-all))) ;; (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 - (runs:update-test_meta test-name test-conf))) - test-names))) + (let* ((test-conf (mt:lazy-read-test-config test-name))) + ;; use the cdb:remote-run instead of passing in db + (if test-conf (runs:update-test_meta test-name test-conf)))) + (hash-table-keys 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)) @@ -740,23 +1512,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=?;") ADDED sdb.scm Index: sdb.scm ================================================================== --- /dev/null +++ sdb.scm @@ -0,0 +1,102 @@ +;;====================================================================== +;; 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. +;;====================================================================== + +;;====================================================================== +;; Simple persistant strings lookup table. Keep out of the main db +;; so writes/reads don't slow down central access. +;;====================================================================== + +(require-extension (srfi 18) extras) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64) +(import (prefix sqlite3 sqlite3:)) +(import (prefix base64 base64:)) + +(declare (unit sdb)) + +;; +(define (sdb:open) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) + (if (not *toppath*) + (if (not (setup-for-run)) + (begin + (debug:print 0 "ERROR: Attempted to open db when not in megatest area. Exiting.") + (exit)))) + (let* ((dbpath (conc *toppath* "/db/sdb.db")) ;; fname) + (dbexists (let ((fe (file-exists? dbpath))) + (if fe + fe + (begin + (create-directory (conc *toppath* "/db") #t) + #f)))) + (sdb (sqlite3:open-database dbpath)) + (handler (make-busy-timeout (if (args:get-arg "-override-timeout") + (string->number (args:get-arg "-override-timeout")) + 136000)))) + (sqlite3:set-busy-handler! sdb handler) + (if (not dbexists) + (sdb:initialize sdb)) + (sqlite3:execute sdb "PRAGMA synchronous = 1;") + sdb)) + +(define (sdb:initialize sdb) + (sqlite3:execute sdb "CREATE TABLE IF NOT EXISTS strs + (id INTEGER PRIMARY KEY, + str TEXT, + CONSTRAINT str UNIQUE (str));") + (sqlite3:execute sdb "CREATE INDEX strindx ON strs (str);")) + +;; (define sumup (let ((a 0))(lambda (x)(set! a (+ x a)) a))) + +(define (sdb:register-string sdb str) + (sqlite3:execute sdb "INSERT OR IGNORE INTO strs (str) VALUES (?);" str)) + +(define (sdb:string->id sdb str-cache str) + (let ((id (hash-table-ref/default str-cache str #f))) + (if (not id) + (sqlite3:for-each-row + (lambda (sid) + (set! id sid) + (hash-table-set! str-cache str id)) + sdb + "SELECT id FROM strs WHERE str=?;" str)) + id)) + +(define (sdb:id->string sdb id-cache id) + (let ((str (hash-table-ref/default id-cache id #f))) + (if (not str) + (sqlite3:for-each-row + (lambda (istr) + (set! str istr) + (hash-table-set! id-cache id str)) + sdb + "SELECT str FROM strs WHERE id=?;" id)) + str)) + +(define sdb:qry + (let ((sdb #f) + (scache (make-hash-table)) + (icache (make-hash-table))) + (lambda (cmd var) + (if (not sdb)(set! sdb (sdb:open))) + (case cmd + ((init) (if (not sdb)(set! sdb (sdb:open)))) + ((finalize!) (if sdb (sqlite3:finalize! sdb))) + ((getid) (let ((id (sdb:string->id sdb scache var))) + (if id + id + (begin + (sdb:register-string sdb var) + (sdb:string->id sdb scache var))))) + ((getstr) (if (or (number? var) + (string->number var)) + (sdb:id->string sdb icache var) + var)) + (else #f))))) + Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -51,11 +51,11 @@ (debug:print 0 "ERROR: cannot find megatest.config, exiting") (exit)))) (debug:print-info 2 "Starting server using " transport " transport") (set! *transport-type* transport) (case transport - ((fs) (exit)) ;; there is no "fs" transport + ((fs) (exit)) ;; there is no "fs" server transport ((http) (http-transport:launch)) ((zmq) (zmq-transport:launch)) (else (debug:print "WARNING: unrecognised transport " transport) (exit)))) @@ -117,5 +117,31 @@ (send-message pub-socket (db:obj->string (vector success/fail query-sig result))))) (else (debug:print 0 "ERROR: unrecognised transport type: " *transport-type*) result))) +(define (server:ensure-running) + (let loop ((servers (open-run-close tasks:get-best-server tasks:open-db)) + (trycount 0)) + (if (or (not servers) + (null? servers)) + (begin + (if (even? trycount) ;; just do the server start every other time through this loop (every 8 seconds) + (let ((cmdln (conc (if (getenv "MT_MEGATEST") (getenv "MT_MEGATEST") "megatest") + " -server - -daemonize"))) + (debug:print 0 "INFO: Starting server (" cmdln ") 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 cmdln) + (thread-sleep! 3) + ;; (process-run (car (argv)) (list "-server" "-" "-daemonize" "-transport" (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 2 "INFO: Server(s) running " servers) + ))) Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -97,31 +97,34 @@ (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 *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 hostname=? AND port=?;" hostname port)) - (else (sqlite3:execute mdb "UPDATE servers SET state='dead' WHERE hostname=? AND port=?;" hostname port))) + ((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))) @@ -146,11 +149,11 @@ "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) + (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) @@ -196,21 +199,26 @@ ;; ping each server in the db and return first found that responds. ;; remove any others. will not necessarily remove all! (define (tasks:get-best-server mdb) (let ((res '()) - (best #f)) + (best #f) + (transport (if (and *transport-type* + (not (eq? *transport-type* 'fs))) + (conc *transport-type*) + "%"))) (sqlite3:for-each-row (lambda (id interface port pubport transport pid hostname) (set! res (cons (vector id interface port pubport transport pid hostname) res)) ;;(debug:print-info 2 "Found existing server " hostname ":" port " registered in db")) ) 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=? AND transport LIKE ? + ORDER BY start_time DESC LIMIT 1;" (common:version-signature) transport) ;; 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... ;; @@ -261,17 +269,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) @@ -542,15 +550,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 @@ -15,10 +15,11 @@ (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils) (import (prefix sqlite3 sqlite3:)) (declare (unit tests)) +(declare (uses lock-queue)) (declare (uses db)) (declare (uses common)) (declare (uses items)) (declare (uses runconfig)) @@ -26,19 +27,42 @@ (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") -(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))))) +;; Call this one to do all the work and get a standardized list of tests +(define (tests:get-all) + (let* ((test-search-path (cons (conc *toppath* "/tests") ;; the default + (tests:get-tests-search-path *configdat*)))) + (tests:get-valid-tests (make-hash-table) test-search-path))) + +(define (tests:get-tests-search-path cfgdat) + (let ((paths (map cadr (configf:get-section cfgdat "tests-paths")))) + (cons (conc *toppath* "/tests") paths))) + +(define (tests:get-valid-tests test-registry tests-paths) + (if (null? tests-paths) + test-registry + (let loop ((hed (car tests-paths)) + (tal (cdr tests-paths))) + (if (file-exists? hed) + (for-each (lambda (test-path) + (let* ((tname (last (string-split test-path "/"))) + (tconfig (conc test-path "/testconfig"))) + (if (and (not (hash-table-ref/default test-registry tname #f)) + (file-exists? tconfig)) + (hash-table-set! test-registry tname test-path)))) + (glob (conc hed "/*")))) + (if (null? tal) + test-registry + (loop (car tal)(cdr tal)))))) + +(define (tests:filter-test-names test-names test-patts) + (delete-duplicates + (filter (lambda (testname) + (tests:match test-patts testname #f)) + test-names))) ;; tests:glob-like-match (define (tests:glob-like-match patt str) (let ((like (substring-index "%" patt))) (let* ((notpatt (equal? (substring-index "~" patt) 0)) @@ -105,14 +129,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 +157,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 #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 +168,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 +198,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 #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) @@ -189,63 +219,72 @@ (loop (car tal)(cdr tal)))))))))) ;; Check for waiver eligibility ;; (define (tests:check-waiver-eligibility testdat prev-testdat) - (let* ((testconfig (tests:get-testconfig (db:test-get-testname testdat) #f)) + (let* ((test-registry (make-hash-table)) + (testconfig (tests:get-testconfig (db:test-get-testname testdat) test-registry #f)) (test-rundir (db:test-get-rundir testdat)) (prev-rundir (db:test-get-rundir prev-testdat)) (waivers (configf:section-vars testconfig "waivers")) (waiver-rx (regexp "^(\\S+)\\s+(.*)$")) (diff-rule "diff %file1% %file2%") (logpro-rule "diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html")) - (push-directory test-rundir) - (let ((result (if (null? waivers) - #f - (let loop ((hed (car waivers)) - (tal (cdr waivers))) - (debug:print 0 "INFO: Applying waiver rule \"" hed "\"") - (let* ((waiver (configf:lookup testconfig "waivers" hed)) - (wparts (if waiver (string-match waiver-rx waiver) #f)) - (waiver-rule (if wparts (cadr wparts) #f)) - (waiver-glob (if wparts (caddr wparts) #f)) - (logpro-file (if waiver - (let ((fname (conc hed ".logpro"))) - (if (file-exists? fname) - fname - (begin - (debug:print 0 "INFO: No logpro file " fname " falling back to diff") - #f))) - #f)) - ;; if rule by name of waiver-rule is found in testconfig - use it - ;; else if waivername.logpro exists use logpro-rule - ;; else default to diff-rule - (rule-string (let ((rule (configf:lookup testconfig "waiver_rules" waiver-rule))) - (if rule - rule - (if logpro-file - logpro-rule - (begin - (debug:print 0 "INFO: No logpro file " logpro-file " found, using diff rule") - diff-rule))))) - ;; (string-substitute "%file1%" "foofoo.txt" "This is %file1% and so is this %file1%." #t) - (processed-cmd (string-substitute - "%file1%" (conc test-rundir "/" waiver-glob) - (string-substitute - "%file2%" (conc prev-rundir "/" waiver-glob) - (string-substitute - "%waivername%" hed rule-string #t) #t) #t)) - (res #f)) - (debug:print 0 "INFO: waiver command is \"" processed-cmd "\"") - (if (eq? (system processed-cmd) 0) - (if (null? tal) - #t - (loop (car tal)(cdr tal))) - #f)))))) - (pop-directory) - result))) - + (if (not (file-exists? test-rundir)) + (begin + (debug:print 0 "ERROR: test run directory is gone, cannot propagate waiver") + #f) + (begin + (push-directory test-rundir) + (let ((result (if (null? waivers) + #f + (let loop ((hed (car waivers)) + (tal (cdr waivers))) + (debug:print 0 "INFO: Applying waiver rule \"" hed "\"") + (let* ((waiver (configf:lookup testconfig "waivers" hed)) + (wparts (if waiver (string-match waiver-rx waiver) #f)) + (waiver-rule (if wparts (cadr wparts) #f)) + (waiver-glob (if wparts (caddr wparts) #f)) + (logpro-file (if waiver + (let ((fname (conc hed ".logpro"))) + (if (file-exists? fname) + fname + (begin + (debug:print 0 "INFO: No logpro file " fname " falling back to diff") + #f))) + #f)) + ;; if rule by name of waiver-rule is found in testconfig - use it + ;; else if waivername.logpro exists use logpro-rule + ;; else default to diff-rule + (rule-string (let ((rule (configf:lookup testconfig "waiver_rules" waiver-rule))) + (if rule + rule + (if logpro-file + logpro-rule + (begin + (debug:print 0 "INFO: No logpro file " logpro-file " found, using diff rule") + diff-rule))))) + ;; (string-substitute "%file1%" "foofoo.txt" "This is %file1% and so is this %file1%." #t) + (processed-cmd (string-substitute + "%file1%" (conc test-rundir "/" waiver-glob) + (string-substitute + "%file2%" (conc prev-rundir "/" waiver-glob) + (string-substitute + "%waivername%" hed rule-string #t) #t) #t)) + (res #f)) + (debug:print 0 "INFO: waiver command is \"" processed-cmd "\"") + (if (eq? (system processed-cmd) 0) + (if (null? tal) + #t + (loop (car tal)(cdr tal))) + #f)))))) + (pop-directory) + result))))) + +(define (tests:test-force-state-status! test-id state status) + (cdb:test-set-status-state *runremote* test-id status state #f) + (mt:process-triggers test-id state status)) ;; Do not rpc this one, do the underlying calls!!! (define (tests:test-set-status! test-id state status comment dat #!key (work-area #f)) (debug:print-info 4 "tests:test-set-status! test-id=" test-id ", state=" state ", status=" status ", dat=" dat) (let* ((db #f) @@ -261,11 +300,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)) @@ -285,11 +324,13 @@ (debug:print 4 "real-status " real-status ", waived " waived ", status " status) ;; update the primary record IF state AND status are defined (if (and state status) - (cdb:test-set-status-state *runremote* test-id real-status state (if waived waived comment))) + (begin + (cdb:test-set-status-state *runremote* test-id real-status state (if waived waived comment)) + (mt:process-triggers test-id state real-status))) ;; if status is "AUTO" then call rollup (note, this one modifies data in test ;; run area, it does remote calls under the hood. (if (and test-id state status (equal? status "AUTO")) (db:test-data-rollup #f test-id status work-area: work-area)) @@ -330,11 +371,11 @@ (db:csv->test-data #f test-id dat)))) ;; need to update the top test record if PASS or FAIL and this is a subtest (if (not (equal? item-path "")) - (cdb:roll-up-pass-fail-counts *runremote* run-id test-name item-path status)) + (mt:roll-up-pass-fail-counts run-id test-name item-path status)) (if (or (and (string? comment) (string-match (regexp "\\S+") comment)) waived) (let ((cmt (if waived waived comment))) @@ -343,21 +384,22 @@ (define (tests:test-set-toplog! db run-id test-name logf) (cdb:client-call *runremote* 'tests:test-set-toplog #t 2 logf run-id test-name)) -(define (tests:summarize-items db run-id test-name force) +(define (tests:summarize-items db run-id test-id test-name force) ;; if not force then only update the record if one of these is true: ;; 1. logf is "log/final.log ;; 2. logf is same as outputfilename (let* ((outputfilename (conc "megatest-rollup-" test-name ".html")) (orig-dir (current-directory)) (logf-info (cdb:remote-run db:test-get-logfile-info #f run-id test-name)) (logf (if logf-info (cadr logf-info) #f)) (path (if logf-info (car logf-info) #f))) ;; This query finds the path and changes the directory to it for the test - (if (directory? path) + (if (and (string? path) + (directory? path)) ;; can get #f here under some wierd conditions. why, unknown ... (begin (debug:print 4 "Found path: " path) (change-directory path)) ;; (set! outputfilename (conc path "/" outputfilename))) (print "No such path: " path)) @@ -364,95 +406,104 @@ (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)) - -(define (tests:get-testconfig test-name system-allowed) - (let* ((test-path (conc *toppath* "/tests/" test-name)) + (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 + (not (lock-queue:wait-turn outputfilename test-id)) + (print "Not updating " outputfilename " as another test item has signed up for the job") + (begin + (print "Obtained lock for " outputfilename) + (let ((oup (open-output-file outputfilename)) + (counts (make-hash-table)) + (statecounts (make-hash-table)) + (outtxt "") + (tot 0) + (testdat (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) + (lock-queue:release-lock outputfilename test-id) + (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 test-registry system-allowed) + (let* ((test-path (hash-table-ref/default test-registry test-name (conc *toppath* "/tests/" test-name))) (test-configf (conc test-path "/testconfig")) - (testexists (and (file-exists? test-configf)(file-read-access? test-configf)))) - (if testexists - (read-config test-configf #f system-allowed environ-patt: (if system-allowed - "pre-launch-env-vars" - #f)) - #f))) + (testexists (and (file-exists? test-configf)(file-read-access? test-configf))) + (tcfg (if testexists + (read-config test-configf #f system-allowed environ-patt: (if system-allowed + "pre-launch-env-vars" + #f)) + #f))) + (hash-table-set! *testconfigs* test-name tcfg) + tcfg)) ;; sort tests by priority and waiton ;; Move test specific stuff to a test unit FIXME one of these days (define (tests:sort-by-priority-and-waiton test-records) (let ((mungepriority (lambda (priority) @@ -504,48 +555,138 @@ (test-name (tests:testqueue-get-testname test-record)) (itemdat (tests:testqueue-get-itemdat test-record)) (item-path (tests:testqueue-get-item_path test-record)) (waitons (tests:testqueue-get-waitons test-record)) (keep-test #t) - (test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path)) - (tdat (cdb:get-test-info-by-id *runremote* test-id))) + (test-id (cdb:remote-run db:get-test-id-cached #f run-id test-name item-path)) + (tdat (cdb:remote-run db:get-testinfo-state-status #f test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id))) (if tdat (begin ;; Look at the test state and status - (if (or (member (db:test-get-status tdat) - '("PASS" "WARN" "WAIVED" "CHECK" "SKIP")) + (if (or (and (member (db:test-get-status tdat) + '("PASS" "WARN" "WAIVED" "CHECK" "SKIP")) + (equal? (db:test-get-state tdat) "COMPLETED")) (member (db:test-get-state tdat) - '("INCOMPLETE" "KILLED"))) + '("INCOMPLETE" "KILLED"))) (set! keep-test #f)) ;; examine waitons for any fails. If it is FAIL or INCOMPLETE then eliminate this test ;; from the runnable list (if keep-test (for-each (lambda (waiton) ;; for now we are waiting only on the parent test - (let* ((parent-test-id (cdb:remote-run db:get-test-id #f run-id waiton "")) - (wtdat (cdb:get-test-info-by-id *runremote* test-id))) - (if (or (member (db:test-get-status wtdat) - '("FAIL" "KILLED")) - (member (db:test-get-state wtdat) - '("INCOMPETE"))) + (let* ((parent-test-id (cdb:remote-run db:get-test-id-cached #f run-id waiton "")) + (wtdat (cdb:remote-run db:get-testinfo-state-status #f test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id))) + (if (or (and (equal? (db:test-get-state wtdat) "COMPLETED") + (member (db:test-get-status wtdat) '("FAIL"))) + (member (db:test-get-status wtdat) '("KILLED")) + (member (db:test-get-state wtdat) '("INCOMPETE"))) + ;; (if (or (member (db:test-get-status wtdat) + ;; '("FAIL" "KILLED")) + ;; (member (db:test-get-state wtdat) + ;; '("INCOMPETE"))) (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 all-tests-registry) + (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 all-tests-registry '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:remote-run db:get-testinfo-state-status #f test-id))) ;; (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 @@ -554,42 +695,61 @@ tdb "SELECT count(id) FROM test_rundat;") res)) 0) -(define (tests:update-central-meta-info test-id cpuload diskfree minutes num-records uname hostname) +(define (tests:update-central-meta-info test-id cpuload diskfree minutes uname hostname) ;; This is a good candidate for threading the requests to enable ;; transactionized write at the server (cdb:tests-update-cpuload-diskfree *runremote* test-id cpuload diskfree) - ;; (let ((db (open-db))) - ;; (sqlite3:execute db "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;" - ;; cpuload - ;; diskfree - ;; test-id) - (if minutes - (cdb:tests-update-run-duration *runremote* test-id minutes)) - ;; (sqlite3:execute db "UPDATE tests SET run_duration=? WHERE id=?;" minutes test-id)) - (if (eq? num-records 0) - (cdb:tests-update-uname-host *runremote* test-id uname hostname)) - ;;(sqlite3:execute db "UPDATE tests SET uname=?,host=? WHERE id=?;" uname hostname test-id)) - ;;(sqlite3:finalize! db)) - ) - -(define (tests:set-meta-info db test-id run-id testname itemdat minutes work-area) + (if minutes + (cdb:tests-update-run-duration *runremote* test-id minutes)) + (if (and uname hostname) + (cdb:tests-update-uname-host *runremote* test-id uname hostname))) + +(define (tests:set-full-meta-info db test-id run-id minutes work-area) + ;; DOES cdb:remote-run under the hood! + (let* ((num-records 0) ;; (test:tdb-get-rundat-count tdb)) + (cpuload (get-cpu-load)) + (diskfree (get-df (current-directory))) + (uname (get-uname "-srvpio")) + (hostname (get-host-name))) + (tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes) + (tests:update-central-meta-info test-id cpuload diskfree minutes uname hostname))) + +(define (tests:set-partial-meta-info db test-id run-id minutes work-area) ;; DOES cdb:remote-run under the hood! - (let* ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)) - (num-records (test:tdb-get-rundat-count tdb)) - (cpuload (get-cpu-load)) + (let* ((cpuload (get-cpu-load)) (diskfree (get-df (current-directory)))) - (if (eq? (modulo num-records 10) 0) ;; every ten records update central - (let ((uname (get-uname "-srvpio")) - (hostname (get-host-name))) - (tests:update-central-meta-info test-id cpuload diskfree minutes num-records uname hostname))) - (sqlite3:execute tdb "INSERT INTO test_rundat (update_time,cpuload,diskfree,run_duration) VALUES (strftime('%s','now'),?,?,?);" - cpuload diskfree minutes) - (sqlite3:finalize! tdb))) - + (tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes) + ;; Update central with uname and hostname = #f + ;; Is this one of the performance problems? This info should come from testdat-meta anyway + ;; (tests:update-central-meta-info test-id cpuload diskfree minutes #f #f) + )) + +(define (tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes) + (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))) + (if (sqlite3:database? tdb) + (begin + (sqlite3:execute tdb "INSERT INTO test_rundat (update_time,cpuload,diskfree,run_duration) VALUES (strftime('%s','now'),?,?,?);" + cpuload diskfree minutes) + (sqlite3:finalize! tdb)) + (debug:print 2 "Can't update testdat.db for test " test-id " read-only or non-existant")))) + +(define (tests:testdat-get-testinfo db test-id work-area) + (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)) + (res '())) + (if (sqlite3:database? tdb) + (begin + (sqlite3:for-each-row + (lambda (update-time cpuload diskfree run-duration) + (set! res (cons (vector update-time cpuload diskfree run-duration) res))) + tdb + "SELECT update_time,cpuload,diskfree,run_duration FROM test_rundat ORDER BY update_time ASC;") + (sqlite3:finalize! tdb))) + res)) + ;;====================================================================== ;; A R C H I V I N G ;;====================================================================== (define (test:archive db test-id) Index: tests/Makefile ================================================================== --- tests/Makefile +++ tests/Makefile @@ -1,8 +1,9 @@ +# # 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 +17,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 @@ -41,12 +50,19 @@ cd fullrun;megatest -runtests runfirst/%,%/ai -target ubuntu/nfs/none :runname $(RUNNAME)_02 -debug $(DEBUG) cd fullrun;megatest -runtests %/,%/winter -target ubuntu/nfs/none :runname $(RUNNAME)_03 -debug $(DEBUG) sleep 40;cd fullrun;megatest -target ubuntu/nfs/none :runname $(RUNNAME) -set-state-status COMPLETED,FORCED :state COMPLETED :status PASS -testpatt ez_p%s,runfirst/ -debug $(DEBUG) $(LOGGING) -test3 : fullprep - cd fullrun;$(MEGATEST) -runtests runfirst -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -debug 10 +test3 : fullprep test3a test3b + +test3a : + @echo Run runfirst and any waitons. + cd fullrun;$(MEGATEST) -runtests runfirst -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b + +test3b : + @echo Run all_toplevel and all waitons + cd fullrun;$(MEGATEST) -runtests all_toplevel -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_c test4 : cleanprep @echo "WARNING: No longer running fullprep, test converage may be lessened" cd fullrun;time $(MEGATEST) -debug $(DEBUG) -runtests % -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -m "This is a comment specific to a run" -v $(LOGGING) @@ -53,20 +69,91 @@ # 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 test9e + +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) + +test9e : + @echo Run mintest a1 with full waiton chain with d1fail: a1 -> b1 -> c1 -> d1fail -> e1 + cd mintest;megatest -runtests a1 -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 + +test11 : + cd fullrun;time (for a in 1 2 3 4 5 6 7 8 9 10 1 2 3 4 5 6 7 8 9 10 1 2 3 4 5 6 7 8 9 10 1 2 3 4 5 6 7 8 9 10 ;do (megatest -test-paths -target %/%/% > /dev/null ) & done; wait; ) + +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 18 & cleanprep : ../*.scm Makefile */*.config mkdir -p fullrun/tmp/mt_runs fullrun/tmp/mt_links cd ..;make;make install rm -f */logging.db @@ -75,11 +162,14 @@ fullprep : cleanprep cd fullrun;$(MEGATEST) -remove-runs :runname $(RUNNAME)% -target %/%/% -testpatt %/% cd fullrun;$(BINPATH)/dashboard -rows 15 & dashboard : cleanprep - cd fullrun && $(BINPATH)/dashboard -rows 25 & + cd fullrun && $(BINPATH)/dashboard -transport fs -rows 20 & + +dashboard-http : cleanprep + cd fullrun && $(BINPATH)/dashboard -transport http -rows 20 & remove : cd fullrun;$(MEGATEST) -remove-runs :runname $(RUN) -testpatt % -itempatt % :sysname % :fsname % :datapath % clean : @@ -92,9 +182,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/fdk.config ================================================================== --- tests/fdktestqa/fdk.config +++ tests/fdktestqa/fdk.config @@ -2,11 +2,11 @@ SYSTEM TEXT RELEASE TEXT [setup] # Adjust max_concurrent_jobs to limit how much you load your machines -max_concurrent_jobs 500 +max_concurrent_jobs 150 # This is your link path, you can move it but it is generally better to keep it stable linktree #{shell readlink -f #{getenv PWD}/../simplelinks} [include testqa/configs/megatest.abc.config] Index: tests/fdktestqa/testqa/Makefile ================================================================== --- tests/fdktestqa/testqa/Makefile +++ tests/fdktestqa/testqa/Makefile @@ -1,25 +1,29 @@ -BINDIR=$(PWD)/../../../bin -MEGATEST=$(BINDIR)/megatest -DASHBOARD=$(BINDIR)/dashboard +BINDIR = $(PWD)/../../../bin +PATH := $(BINDIR):$(PATH) +MEGATEST = $(BINDIR)/megatest +DASHBOARD = $(BINDIR)/dashboard all : + $(MEGATEST) -remove-runs -target a/b :runname c -testpatt %/% $(MEGATEST) -runtests % -target a/b :runname c bigbig : + $(MEGATEST) -server - -daemonize ; sleep 3 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 + $(MEGATEST) -runtests bigrun2 -target a/bigrun2 :runname a -transport http dashboard : $(DASHBOARD) -rows 20 & compile : + $(MEGATEST) -stop-server 0 (cd ../../..;make && make install) clean : rm -rf ../simple*/*/* megatest.db ADDED tests/fdktestqa/testqa/README Index: tests/fdktestqa/testqa/README ================================================================== --- /dev/null +++ tests/fdktestqa/testqa/README @@ -0,0 +1,1 @@ +set NUMTESTS to set the number of tests that will be run. A small number (say 20) illustrates itemwait well. Index: tests/fdktestqa/testqa/megatest.config ================================================================== --- tests/fdktestqa/testqa/megatest.config +++ tests/fdktestqa/testqa/megatest.config @@ -1,8 +1,10 @@ [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 20 +# transport http +launchwait no [include ../fdk.config] [server] -timeout 0.01 +port 9080 Index: tests/fdktestqa/testqa/tests/bigrun/step1.sh ================================================================== --- tests/fdktestqa/testqa/tests/bigrun/step1.sh +++ tests/fdktestqa/testqa/tests/bigrun/step1.sh @@ -1,8 +1,9 @@ #!/bin/sh -if [ $NUMBER -lt 200 ];then - sleep $NUMBER +if [ $NUMBER -lt 15 ];then + sleep 2 + sleep `echo 2 * $NUMBER | bc` else - sleep 200 + sleep 100 fi exit 0 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/testconfig ================================================================== --- tests/fdktestqa/testqa/tests/bigrun2/testconfig +++ tests/fdktestqa/testqa/tests/bigrun2/testconfig @@ -2,18 +2,18 @@ [ezsteps] step1 step1.sh # Test requirements are specified here [requirements] -# waiton bigrun +waiton bigrun priority 0 -mode itemmatch +mode itemwait # 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 1500)(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/fdktestqa/testqa/tests/bigrun3/step1.sh Index: tests/fdktestqa/testqa/tests/bigrun3/step1.sh ================================================================== --- /dev/null +++ tests/fdktestqa/testqa/tests/bigrun3/step1.sh @@ -0,0 +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 + +exit 0 ADDED tests/fdktestqa/testqa/tests/bigrun3/testconfig Index: tests/fdktestqa/testqa/tests/bigrun3/testconfig ================================================================== --- /dev/null +++ tests/fdktestqa/testqa/tests/bigrun3/testconfig @@ -0,0 +1,22 @@ +# Add additional steps here. Format is "stepname script" +[ezsteps] +step1 step1.sh + +# Test requirements are specified here +[requirements] +waiton bigrun2 +priority 0 +mode itemwait + + +# 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")) 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 +description An example test +tags tagone,tagtwo +reviewed never 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/config/mt_include_1.config ================================================================== --- tests/fullrun/config/mt_include_1.config +++ tests/fullrun/config/mt_include_1.config @@ -1,17 +1,22 @@ [setup] # exectutable /path/to/megatest -max_concurrent_jobs 150 +max_concurrent_jobs 50 linktree #{getenv MT_RUN_AREA_HOME}/tmp/mt_links [jobtools] useshell yes # ## launcher launches jobs, the job is managed on the target host ## by megatest, comment out launcher to run local # workhosts localhost hermes +# launcher exec nbfake + launcher nbfake +# launcher echo + +# launcher nbfind # launcher nodanggood ## use "xterm -e csi -- " as a launcher to examine the launch environment. ## exit with (exit) ## get a shell with (system "bash") Index: tests/fullrun/megatest.config ================================================================== --- tests/fullrun/megatest.config +++ tests/fullrun/megatest.config @@ -8,25 +8,47 @@ [refareas] area1 /tmp/oldarea/megatest [include config/mt_include_1.config] +[misc] +home #{shell readlink -f $MT_RUN_AREA_HOME} +parent #{shell readlink -f $MT_RUN_AREA_HOME/..} + +[tests-paths] +1 #{get misc parent}/simplerun/tests + [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 +# Set launchwait to no to use the more agressive code that does not wait for the launch to complete before proceeding +# this may save a few milliseconds on launching tests +# launchwait no +waivercommentpatt ^WW\d+ [a-z].* + +# Use http instead of direct filesystem access +# transport http +transport fs + +# If set to "default" the old code is used. Otherwise defaults to 200 or uses +# numeric value given. +# +runqueue 20 + +# Default runtimelim 1d 1h 1m 10s +# +runtimelim 20m + +# Deadtime - when to consider tests dead (i.e. haven't heard from them in too long) +# Number in seconds, set to 20 seconds here to trigger a little trouble. Default is +# 1800 +# +deadtime 600 # 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 # -# testcopycmd cp --remove-destination -rsv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log +testcopycmd cp --remove-destination -rsv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log # or for hard links # testcopycmd cp --remove-destination -rlv TEST_SRC_PATH/. TEST_TARG_PATH/. @@ -36,19 +58,34 @@ throttle 0.2 # Max retries allows megatest to re-check that a tests status has changed # as tests can have transient FAIL status occasionally maxretries 20 +# Setup continued. +[setup] + +# override the logview command +# +logviewer (%MTCMD%) 2> /dev/null > /dev/null + +# override the html viewer launch command +# +# htmlviewercmd firefox -new-window +htmlviewercmd konqueror + [validvalues] state start end 0 1 - 2 status pass fail n/a 0 1 running - 2 # These are set before all tests, override them # in the testconfig [pre-launch-env-overrides] section [env-override] +# MT_XTERM_CMD overrides the terminal command +# MT_XTERM_CMD xterm -bg lightgreen -fg black + SPECIAL_ENV_VARS overide them here - should be seen at launch and in the runs -TESTVAR [system realpath .] +TESTVAR [system echo $PWD] DEADVAR [system ls] VARWITHDOLLAR $HOME/.zshrc WACKYVAR #{system ls > /dev/null} WACKYVAR2 #{get validvalues state} WACKYVAR3 #{getenv USER} @@ -84,5 +121,9 @@ [disks] disk0 /foobarbazz [include config/mt_include_2.config] [include #{getenv USER}_testing.config] + +[jobgroups] +sqlite3 3 +blockz 5 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 ADDED tests/fullrun/run-each-proc.sh Index: tests/fullrun/run-each-proc.sh ================================================================== --- /dev/null +++ tests/fullrun/run-each-proc.sh @@ -0,0 +1,15 @@ +#!/bin/bash + +for x in `cat all-db-procs.txt`;do + cat > ~/.megatestrc <' '-_g'` + megatest -runtests sqlitespeed,test2,ez% -target ubuntu/nfs/none :runname $fname > $fname.log +done + + Index: tests/fullrun/runconfigs.config ================================================================== --- tests/fullrun/runconfigs.config +++ tests/fullrun/runconfigs.config @@ -1,12 +1,16 @@ [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] @@ -18,5 +22,8 @@ [default] SOMEVAR3 #{rget SOMEVAR} SOMEVAR4 #{rget SOMEVAR2} SOMEVAR5 #{runconfigs-get SOMEVAR2} + +[this/a/test] +BLAHFOO 123 ADDED tests/fullrun/tests/all_toplevel/calcresults.logpro Index: tests/fullrun/tests/all_toplevel/calcresults.logpro ================================================================== --- /dev/null +++ tests/fullrun/tests/all_toplevel/calcresults.logpro @@ -0,0 +1,133 @@ +;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com +;; +;; License GPL. + +(define logbody "LogFileBody") + +(define pass-specs '( ;; testname num-expected max-runtime + ("exit_0" 1 20) + ("ezlog_fail_then_pass" 1 20) + ("ezlog_pass" 1 20) + ("ez_pass" 1 20) + ("lineitem_pass" 1 20) + ("priority_1" 1 20) + ("priority_10" 1 20) + ("priority_10_waiton_1" 1 20) + ("priority_3" 1 20) + ("priority_4" 1 20) + ("priority_5" 1 20) + ("priority_6" 1 20) + ("priority_7" 1 20) + ("priority_8" 1 20) + ("priority_9" 1 20) + ("runfirst" 7 20) + ("singletest" 1 20) + ("singletest2" 1 20) + ("special" 1 20) + ("sqlitespeed" 10 20) + ("test1" 1 20) + ("test2" 6 20) + ("test_mt_vars" 6 20) + )) + +(define fail-specs '( ;; testname num-expected max-runtime + ("exit_1" 1 20) + ("ez_exit2_fail" 1 20) + ("ez_fail" 1 20) + ("ez_fail_quick" 1 20) + ("ezlog_fail" 1 20) + ("lineitem_fail" 1 20) + ("logpro_required_fail" 1 20) + ("manual_example" 1 20) + ("neverrun" 1 20))) + +(define warn-specs '(("ezlog_warn" 1 20))) +(define nost-specs '(("wait_no_items1" 1 20) + ("wait_no_items2" 1 20) + ("wait_no_items3" 1 20) + ("wait_no_items4" 1 20) + ("no_items" 1 20))) + +(define (check-one-test estate estatus testname count runtime) + (let* ((rxe (regexp (conc "^\\s+Test: " testname "(\\(.*|\\s+)\\s+State: " estate "\\s+Status: " estatus "\\s+Runtime:\\s+(\\d+)s"))) + (msg1 (conc testname " expecting count of " count)) + (msg2 (conc testname " expecting runtime less than " runtime))) + (expect:required in logbody = count msg1 rxe) + ;;(expect:value in logbody count < msg2 rxe) + )) + +;; Special cases +;; +(expect:ignore in logbody >= 0 "all_toplevel may not yet be done" #/Test: all_toplevel/) +(expect:error in logbody = 0 "tests left in RUNNING state" #/State: RUNNING/) +(expect:required in logbody = 1 "priority_2 is KILLED" #/Test: priority_2\s+State: KILLED\s+Status: FAIL/) +(expect:required in logbody = 1 "testxz has 1 NOT_STARTED test" #/Test: testxz\s+State: NOT_STARTED/) +(expect:required in logbody = 29 "blocktestxz has 29 tests" #/Test: blocktestxz/) + +;; General cases +;; +(for-each + (lambda (testdat) + (apply check-one-test "COMPLETED" "PASS" testdat)) + pass-specs) + +(for-each + (lambda (testdat) + (apply check-one-test "COMPLETED" "FAIL" testdat)) + fail-specs) + +(for-each + (lambda (testdat) + (apply check-one-test "COMPLETED" "WARN" testdat)) + warn-specs) + +(for-each + (lambda (testdat) + (apply check-one-test "NOT_STARTED" "n/a" testdat)) + nost-specs) + +;; Catch all. +;; +(expect:error in logbody = 0 "Tests not accounted for" #/Test: /) + + +;; ;; define your hooks +;; (hook:first-error "echo \"Error hook activated: #{escaped errmsg}\"") +;; (hook:first-warning "echo \"Got warning: #{escaped warnmsg}\"") +;; (hook:value "echo \"Value hook activated: expected=#{expected}, measured=#{measured}, tolerance=#{tolerance}, message=#{message}\"") +;; +;; ;; first ensure your run at least started +;; ;; +;; (trigger "Init" #/This is a header/) +;; (trigger "InitEnd" #/^\s*$/) +;; (section "Init" "Init" "InitEnd") +;; +;; (trigger "Body" #/^.*$/) ;; anything starts the body +;; ;; (trigger "EndBody" #/This had better never match/) +;; +;; (section "Body" "Body" "EndBody") +;; +;; (trigger "Blah2" #/^begin Blah2/) +;; (trigger "Blah2End" #/^end Blah2/) +;; (section "Blah2" "Blah2" "Blah2End") +;; +;; (expect:required in "Init" = 1 "Header" #/This is a header/) +;; (expect:required in "LogFileBody" > 0 "Something required but not found" #/This is required but not found/) +;; (expect:value in "LogFileBody" 1.9 0.1 "Output voltage" #/Measured voltage output:\s*([\d\.\+\-e]+)v/) +;; (expect:value in "LogFileBody" 0.5 0.1 "Output current" #/Measured output current:\s*([\d\.\+\-e]+)mA/) +;; (expect:value in "LogFileBody" 110e9 2e9 "A big number (first)" #/Freq:\s*([\d\.\+\-e]+)\s+Hz/) +;; (expect:value in "LogFileBody" 110e9 1e9 "A big number (second), hook not called" #/Freq:\s*([\d\.\+\-e]+)Hz/) +;; (expect:value in "LogFileBody" 110e9 1e9 "A big number (never activated)" #/Freq:\s*([\d\.\+\-e]+)zH/) +;; +;; ;; Using match number +;; (expect:value in "LogFileBody" 1.9 0.1 "Time Voltage" #/out: (\d+)\s+(\d+)/ match: 2) +;; +;; ;; Comparison instead of tolerance +;; (expect:value in "LogFileBody" 1.9 > "Time voltage" #/out: (\d+)\s+(\d+)/ match: 2) +;; +;; (expect:ignore in "Blah2" < 99 "FALSE ERROR" #/ERROR/) +;; (expect:ignore in "Body" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +;; (expect:warning in "Body" = 0 "Any warning" #/WARNING/) +;; (expect:error in "Body" = 0 "ERROR BLAH" (list #/ERROR/ #/error/)) ;; but disallow any other errors +;; +;; ;(expect in "Init" < 1 "Junk" #/This is bogus/) Index: tests/fullrun/tests/all_toplevel/testconfig ================================================================== --- tests/fullrun/tests/all_toplevel/testconfig +++ tests/fullrun/tests/all_toplevel/testconfig @@ -1,8 +1,13 @@ [ezsteps] calcresults megatest -list-runs $MT_RUNNAME -target $MT_TARGET [requirements] -waiton all_toplevel exit_0 exit_1 ez_exit2_fail ez_fail ez_pass ezlog_fail ezlog_fail_then_pass ezlog_pass ezlog_warn lineitem_fail lineitem_pass logpro_required_fail manual_example neverrun priority_1 priority_10 priority_10_waiton_1 priority_2 priority_3 priority_4 priority_5 priority_6 priority_7 priority_8 priority_9 runfirst singletest singletest2 sqlitespeed test_mt_vars +waiton all_toplevel exit_0 exit_1 ez_exit2_fail ez_fail ez_pass ezlog_fail \ + ezlog_fail_then_pass ezlog_pass ezlog_warn lineitem_fail lineitem_pass logpro_required_fail \ + manual_example neverrun priority_1 priority_10 priority_10_waiton_1 priority_2 \ + priority_3 priority_4 priority_5 priority_6 priority_7 priority_8 \ + priority_9 runfirst singletest singletest2 sqlitespeed test_mt_vars \ + ez_fail_quick test1 test2 special blocktestxz # This is a "toplevel" test, it does not require waitons to be non-FAIL to run mode toplevel ADDED tests/fullrun/tests/blocktestxz/main.sh Index: tests/fullrun/tests/blocktestxz/main.sh ================================================================== --- /dev/null +++ tests/fullrun/tests/blocktestxz/main.sh @@ -0,0 +1,6 @@ +#!/bin/bash + +$MT_MEGATEST -test-status :state $THESTATE :status $THESTATUS -setlog "nada.html" + +# By exiting with non-zero we tell Megatest to preseve the state and status +exit 1 ADDED tests/fullrun/tests/blocktestxz/testconfig Index: tests/fullrun/tests/blocktestxz/testconfig ================================================================== --- /dev/null +++ tests/fullrun/tests/blocktestxz/testconfig @@ -0,0 +1,22 @@ +[setup] +runscript main.sh + +[items] +THESTATE UNKNOWN INCOMPLETE KILLED KILLREQ STUCK BOZZLEBLONKED STUCK/DEAD +THESTATUS PASS FAIL STUCK/DEAD SKIP + +[requirements] +waiton sqlitespeed + +[test_meta] +author matt +owner bob +description This test will fail causing the dependent test "testxz"\ + to never run. This triggers the code that must determine\ + that a test will never be run and thus remove it from\ + the queue of tests to be run. + +tags first,single +reviewed 1/1/1965 + +jobgroup blockz Index: tests/fullrun/tests/ez_exit2_fail/testconfig ================================================================== --- tests/fullrun/tests/ez_exit2_fail/testconfig +++ tests/fullrun/tests/ez_exit2_fail/testconfig @@ -5,11 +5,11 @@ lookithome ls /home [test_meta] author matt owner bob -description This test runs two steps; the first exits with - code 2 (a fail because not using logpro) and the second - is a pass +description This test runs two steps; the first exits with\ + code 2 (a fail because not using logpro) and the second\ + is a pass tags first,single reviewed 09/10/2011, by Matt ADDED tests/fullrun/tests/ez_fail_quick/testconfig Index: tests/fullrun/tests/ez_fail_quick/testconfig ================================================================== --- /dev/null +++ tests/fullrun/tests/ez_fail_quick/testconfig @@ -0,0 +1,18 @@ +[requirements] +priority 10 + +[ezsteps] +# should fail on next step +lookitnada ls /nada + +[triggers] +# run like this: cmd test-id test-rundir trigger +COMPLETED/FAIL xterm;echo + +[test_meta] +author matt +owner bob +description This test runs a single ezstep which fails immediately. + +tags first,single +reviewed 09/10/2011, by Matt Index: tests/fullrun/tests/ezlog_fail_then_pass/testconfig ================================================================== --- tests/fullrun/tests/ezlog_fail_then_pass/testconfig +++ tests/fullrun/tests/ezlog_fail_then_pass/testconfig @@ -4,10 +4,10 @@ firststep main.sh [test_meta] author matt owner bob -description This test runs a single ezstep which is logpro clean - but fails based on -test-data loaded. +description This test runs a single ezstep which is logpro clean\ + but fails based on -test-data loaded. tags first,single reviewed 09/10/2011, by Matt Index: tests/fullrun/tests/manual_example/testconfig ================================================================== --- tests/fullrun/tests/manual_example/testconfig +++ tests/fullrun/tests/manual_example/testconfig @@ -5,9 +5,9 @@ # launch launchxterm [test_meta] author matt owner bob -description This test runs a single ezstep which is expected to pass - using a simple logpro file. +description This test runs a single ezstep which is expected to pass\ + using a simple logpro file. tags first,single reviewed 09/10/2011, by Matt ADDED tests/fullrun/tests/no_items/testconfig Index: tests/fullrun/tests/no_items/testconfig ================================================================== --- /dev/null +++ tests/fullrun/tests/no_items/testconfig @@ -0,0 +1,15 @@ +[ezsteps] +listfiles ls + +[items] +FOO + +[test_meta] +author matt +owner bob +description This test runs a single ezstep which is expected to pass \ +but there is an items definition with no items. This should evoke an \ +error. + +tags first,single +reviewed 09/10/2011, by Matt Index: tests/fullrun/tests/priority_1/testconfig ================================================================== --- tests/fullrun/tests/priority_1/testconfig +++ tests/fullrun/tests/priority_1/testconfig @@ -3,10 +3,11 @@ [requirements] priority 1 [test_meta] +jobgroup sqlite3 author matt owner bob description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS tags first,single Index: tests/fullrun/tests/priority_2/main.sh ================================================================== --- tests/fullrun/tests/priority_2/main.sh +++ tests/fullrun/tests/priority_2/main.sh @@ -1,10 +1,10 @@ #!/bin/bash # 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 + sleep 5 $MT_MEGATEST -step step$i :state end :status 0 done exit 0 Index: tests/fullrun/tests/priority_2/testconfig ================================================================== --- tests/fullrun/tests/priority_2/testconfig +++ tests/fullrun/tests/priority_2/testconfig @@ -1,12 +1,15 @@ [setup] runscript main.sh [requirements] priority 2 +# runtimelim 1d 1h 1m 10s +runtimelim 20s [test_meta] +jobgroup sqlite3 author matt owner bob description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS tags first,single Index: tests/fullrun/tests/priority_3/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_3/testconfig ================================================================== --- tests/fullrun/tests/priority_3/testconfig +++ tests/fullrun/tests/priority_3/testconfig @@ -4,10 +4,11 @@ [requirements] priority 3 [test_meta] +jobgroup sqlite3 author matt owner bob description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS tags first,single Index: tests/fullrun/tests/priority_4/testconfig ================================================================== --- tests/fullrun/tests/priority_4/testconfig +++ tests/fullrun/tests/priority_4/testconfig @@ -3,10 +3,11 @@ [requirements] priority 4 [test_meta] +jobgroup sqlite3 author matt owner bob description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS tags first,single Index: tests/fullrun/tests/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 Index: tests/fullrun/tests/runfirst/main.sh ================================================================== --- tests/fullrun/tests/runfirst/main.sh +++ tests/fullrun/tests/runfirst/main.sh @@ -23,9 +23,14 @@ $MT_MEGATEST -load-test-data << EOF cat, var, val, exp, comp, units, comment, status, type ameas,iout,1.2,1.9,>,Amps,Comment,,meas EOF +loadstatus=$? -$MT_MEGATEST -test-status :state COMPLETED :status $? -m "This is a test level comment" :value 10e6 :expected_value 1.1e6 :tol 100e3 :category nada :variable sillyvar :units mFarks :comment "This is the value/expected comment" +if [[ `basename $PWD` == "mustfail" ]];then + $MT_MEGATEST -test-status :state COMPLETED :status FAIL +else + $MT_MEGATEST -test-status :state COMPLETED :status $loadstatus -m "This is a test level comment" :value 10e6 :expected_value 1.1e6 :tol 100e3 :category nada :variable sillyvar :units mFarks :comment "This is the value/expected comment" +fi # $MT_MEGATEST -test-status :state COMPLETED :status FAIL Index: tests/fullrun/tests/runfirst/testconfig ================================================================== --- tests/fullrun/tests/runfirst/testconfig +++ tests/fullrun/tests/runfirst/testconfig @@ -6,19 +6,19 @@ # host. This can be used to control remote launch tools, e.g. to # to choose the target host, select the launch tool etc. SPECIAL_ENV_VAR override with everything after the first space. [items] -SEASON summer winter fall spring +SEASON summer winter fall spring [itemstable] BLOCK a b TOCK 1 2 [test_meta] author matt owner bob -description This test must +description This test must\ be run before the other tests tags first,single reviewed 1/1/1965 Index: tests/fullrun/tests/singletest/main.sh ================================================================== --- tests/fullrun/tests/singletest/main.sh +++ tests/fullrun/tests/singletest/main.sh @@ -2,8 +2,8 @@ # megatest -step wasting_time :state start :status n/a -m "This is a test step comment" # sleep 20 # megatest -step wasting_time :state end :status $? -$MT_MEGATEST -runstep wasting_time -logpro wasting_time.logpro "sleep 5;echo all done eh?" -m "This is a test step comment" +$MT_MEGATEST -runstep wasting_time -logpro wasting_time.logpro "sleep 5;echo alldone" -m "This is a test step comment" $MT_MEGATEST -test-status :state COMPLETED :status $? -m "This is a test level comment" -set-toplog the_top_log.html :first_err "This is the first error" 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 Index: tests/fullrun/tests/sqlitespeed/runscript.rb ================================================================== --- tests/fullrun/tests/sqlitespeed/runscript.rb +++ tests/fullrun/tests/sqlitespeed/runscript.rb @@ -1,8 +1,8 @@ #! /usr/bin/env ruby -require "#{ENV['MT_RUN_AREA_HOME']}/../supportfiles/ruby/librunscript.rb" +require "#{ENV['MT_RUN_AREA_HOME']}/../resources/ruby/librunscript.rb" # run_record(stepname, cmd) - will record in db if exit code of script was zero or not run_and_record('create db',"sqlite3 testing.db << EOF\ncreate table if not exists blah(id INTEGER PRIMARY KEY,name TEXT);\n.q\nEOF","") if (! File.exists?("../../runfirst/I_was_here")) Index: tests/fullrun/tests/sqlitespeed/testconfig ================================================================== --- tests/fullrun/tests/sqlitespeed/testconfig +++ tests/fullrun/tests/sqlitespeed/testconfig @@ -7,5 +7,7 @@ [items] MANYITEMS [system (env > envfile.txt;echo aa ab ac ad ae af ag ah ai)] # BORKED +[test_meta] +jobgroup sqlite3 ADDED tests/fullrun/tests/testxz/testconfig Index: tests/fullrun/tests/testxz/testconfig ================================================================== --- /dev/null +++ tests/fullrun/tests/testxz/testconfig @@ -0,0 +1,15 @@ +# Add additional steps here. Format is "stepname script" +[ezsteps] +listfiles ls + +# Test requirements are specified here +[requirements] +waiton blocktestxz + +# test_meta is a section for storing additional data on your test +[test_meta] +author mrwellan +owner mrwellan +description This test should never get run due to blocktestxz failing +tags tagone,tagtwo +reviewed never ADDED tests/fullrun/tests/wait_no_items1/testconfig Index: tests/fullrun/tests/wait_no_items1/testconfig ================================================================== --- /dev/null +++ tests/fullrun/tests/wait_no_items1/testconfig @@ -0,0 +1,17 @@ +[ezsteps] +listfiles ls + +[requirements] +waiton no_items + +[items] + +[test_meta] +author matt +owner bob +description This test runs a single ezstep which is expected to pass \ +but there is an items definition with no items. This should evoke an \ +error. + +tags first,single +reviewed 09/10/2011, by Matt ADDED tests/fullrun/tests/wait_no_items2/testconfig Index: tests/fullrun/tests/wait_no_items2/testconfig ================================================================== --- /dev/null +++ tests/fullrun/tests/wait_no_items2/testconfig @@ -0,0 +1,17 @@ +[ezsteps] +listfiles ls + +[requirements] +waiton wait_no_items1 + +[items] + +[test_meta] +author matt +owner bob +description This test runs a single ezstep which is expected to pass \ +but there is an items definition with no items. This should evoke an \ +error. + +tags first,single +reviewed 09/10/2011, by Matt ADDED tests/fullrun/tests/wait_no_items3/testconfig Index: tests/fullrun/tests/wait_no_items3/testconfig ================================================================== --- /dev/null +++ tests/fullrun/tests/wait_no_items3/testconfig @@ -0,0 +1,17 @@ +[ezsteps] +listfiles ls + +[requirements] +waiton wait_no_items2 + +[items] + +[test_meta] +author matt +owner bob +description This test runs a single ezstep which is expected to pass \ +but there is an items definition with no items. This should evoke an \ +error. + +tags first,single +reviewed 09/10/2011, by Matt ADDED tests/fullrun/tests/wait_no_items4/testconfig Index: tests/fullrun/tests/wait_no_items4/testconfig ================================================================== --- /dev/null +++ tests/fullrun/tests/wait_no_items4/testconfig @@ -0,0 +1,17 @@ +[ezsteps] +listfiles ls + +[requirements] +waiton wait_no_items3 + +[items] + +[test_meta] +author matt +owner bob +description This test runs a single ezstep which is expected to pass \ +but there is an items definition with no items. This should evoke an \ +error. + +tags first,single +reviewed 09/10/2011, by Matt ADDED tests/installall/config/megatest.config.dat Index: tests/installall/config/megatest.config.dat ================================================================== --- /dev/null +++ tests/installall/config/megatest.config.dat @@ -0,0 +1,1 @@ +../megatest.config ADDED tests/installall/config/runconfigs.config.dat Index: tests/installall/config/runconfigs.config.dat ================================================================== --- /dev/null +++ tests/installall/config/runconfigs.config.dat @@ -0,0 +1,1 @@ +../runconfigs.config ADDED tests/installall/config/sheet-names.cfg Index: tests/installall/config/sheet-names.cfg ================================================================== --- /dev/null +++ tests/installall/config/sheet-names.cfg @@ -0,0 +1,2 @@ +megatest.config +runconfigs.config ADDED tests/installall/config/sxml/_sheets.sxml Index: tests/installall/config/sxml/_sheets.sxml ================================================================== --- /dev/null +++ tests/installall/config/sxml/_sheets.sxml @@ -0,0 +1,51 @@ +((@ (http://www.w3.org/2001/XMLSchema-instance:schemaLocation + "http://www.gnumeric.org/v9.xsd")) + (http://www.gnumeric.org/v10.dtd:Version + (@ (Minor "17") (Major "10") (Full "1.10.17") (Epoch "1"))) + (http://www.gnumeric.org/v10.dtd:Attributes + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name + "WorkbookView::show_horizontal_scrollbar") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name + "WorkbookView::show_vertical_scrollbar") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name "WorkbookView::show_notebook_tabs") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name "WorkbookView::do_auto_completion") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name "WorkbookView::is_protected") + (http://www.gnumeric.org/v10.dtd:value "FALSE"))) + (urn:oasis:names:tc:opendocument:xmlns:office:1.0:document-meta + (@ (urn:oasis:names:tc:opendocument:xmlns:office:1.0:version "1.2")) + (urn:oasis:names:tc:opendocument:xmlns:office:1.0:meta + (http://purl.org/dc/elements/1.1/:date "2013-07-21T23:45:07Z") + (urn:oasis:names:tc:opendocument:xmlns:meta:1.0:creation-date + "2013-07-21T23:42:35Z"))) + (http://www.gnumeric.org/v10.dtd:Calculation + (@ (MaxIterations "100") + (ManualRecalc "0") + (IterationTolerance "0.001") + (FloatRadix "2") + (FloatDigits "53") + (EnableIteration "1"))) + (http://www.gnumeric.org/v10.dtd:SheetNameIndex + (http://www.gnumeric.org/v10.dtd:SheetName + (@ (http://www.gnumeric.org/v10.dtd:Rows "65536") + (http://www.gnumeric.org/v10.dtd:Cols "256")) + "megatest.config") + (http://www.gnumeric.org/v10.dtd:SheetName + (@ (http://www.gnumeric.org/v10.dtd:Rows "65536") + (http://www.gnumeric.org/v10.dtd:Cols "256")) + "runconfigs.config")) + (http://www.gnumeric.org/v10.dtd:Geometry (@ (Width "1440") (Height "647"))) + (http://www.gnumeric.org/v10.dtd:UIData (@ (SelectedTab "0")))) ADDED tests/installall/config/sxml/_workbook.sxml Index: tests/installall/config/sxml/_workbook.sxml ================================================================== --- /dev/null +++ tests/installall/config/sxml/_workbook.sxml @@ -0,0 +1,1 @@ +(*TOP* (*PI* xml "version=\"1.0\" encoding=\"UTF-8\"")) ADDED tests/installall/config/sxml/megatest.config.sxml Index: tests/installall/config/sxml/megatest.config.sxml ================================================================== --- /dev/null +++ tests/installall/config/sxml/megatest.config.sxml @@ -0,0 +1,108 @@ +(http://www.gnumeric.org/v10.dtd:Sheet + (@ (Visibility "GNM_SHEET_VISIBILITY_VISIBLE") + (OutlineSymbolsRight "1") + (OutlineSymbolsBelow "1") + (HideZero "0") + (HideRowHeader "0") + (HideGrid "0") + (HideColHeader "0") + (GridColor "0:0:0") + (DisplayOutlines "1") + (DisplayFormulas "0")) + (http://www.gnumeric.org/v10.dtd:MaxCol "5") + (http://www.gnumeric.org/v10.dtd:MaxRow "7") + (http://www.gnumeric.org/v10.dtd:Zoom "1") + (http://www.gnumeric.org/v10.dtd:Names + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Print_Area") + (http://www.gnumeric.org/v10.dtd:value "#REF!") + (http://www.gnumeric.org/v10.dtd:position "A1")) + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Sheet_Title") + (http://www.gnumeric.org/v10.dtd:value "\"megatest.config\"") + (http://www.gnumeric.org/v10.dtd:position "A1"))) + (http://www.gnumeric.org/v10.dtd:PrintInformation + (http://www.gnumeric.org/v10.dtd:Margins + (http://www.gnumeric.org/v10.dtd:top (@ (PrefUnit "mm") (Points "120"))) + (http://www.gnumeric.org/v10.dtd:bottom + (@ (PrefUnit "mm") (Points "120"))) + (http://www.gnumeric.org/v10.dtd:left (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:right (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:header + (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:footer + (@ (PrefUnit "mm") (Points "72")))) + (http://www.gnumeric.org/v10.dtd:Scale + (@ (type "percentage") (percentage "100"))) + (http://www.gnumeric.org/v10.dtd:vcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:hcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:grid (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:even_if_only_styles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:monochrome (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:draft (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:titles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:do_not_print (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:print_range (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:order "d_then_r") + (http://www.gnumeric.org/v10.dtd:orientation "portrait") + (http://www.gnumeric.org/v10.dtd:Header + (@ (Right "") (Middle "&[TAB]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:Footer + (@ (Right "") (Middle "Page &[PAGE]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:paper "na_letter") + (http://www.gnumeric.org/v10.dtd:comments "in_place") + (http://www.gnumeric.org/v10.dtd:errors "as_displayed")) + (http://www.gnumeric.org/v10.dtd:Styles + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "0") (endRow "65535") (endCol "255")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans")))) + (http://www.gnumeric.org/v10.dtd:Cols + (@ (DefaultSizePts "48")) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "112.5") (No "0") (HardSize "1"))) + (http://www.gnumeric.org/v10.dtd:ColInfo (@ (Unit "48") (No "1"))) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "63.75") (No "2") (HardSize "1"))) + (http://www.gnumeric.org/v10.dtd:ColInfo (@ (Unit "48") (No "3"))) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "86.25") (No "4") (HardSize "1"))) + (http://www.gnumeric.org/v10.dtd:ColInfo (@ (Unit "48") (No "5")))) + (http://www.gnumeric.org/v10.dtd:Rows + (@ (DefaultSizePts "12.75")) + (http://www.gnumeric.org/v10.dtd:RowInfo + (@ (Unit "12.75") (No "0") (Count "8")))) + (http://www.gnumeric.org/v10.dtd:Selections + (@ (CursorRow "0") (CursorCol "0")) + (http://www.gnumeric.org/v10.dtd:Selection + (@ (startRow "0") (startCol "0") (endRow "0") (endCol "0")))) + (http://www.gnumeric.org/v10.dtd:SheetLayout (@ (TopLeft "A1"))) + (http://www.gnumeric.org/v10.dtd:Solver + (@ (ProgramR "0") + (ProblemType "0") + (NonNeg "1") + (ModelType "0") + (MaxTime "60") + (MaxIter "1000") + (Discr "0") + (AutoScale "0")))) ADDED tests/installall/config/sxml/runconfigs.config.sxml Index: tests/installall/config/sxml/runconfigs.config.sxml ================================================================== --- /dev/null +++ tests/installall/config/sxml/runconfigs.config.sxml @@ -0,0 +1,111 @@ +(http://www.gnumeric.org/v10.dtd:Sheet + (@ (Visibility "GNM_SHEET_VISIBILITY_VISIBLE") + (OutlineSymbolsRight "1") + (OutlineSymbolsBelow "1") + (HideZero "0") + (HideRowHeader "0") + (HideGrid "0") + (HideColHeader "0") + (GridColor "0:0:0") + (DisplayOutlines "1") + (DisplayFormulas "0")) + (http://www.gnumeric.org/v10.dtd:MaxCol "3") + (http://www.gnumeric.org/v10.dtd:MaxRow "7") + (http://www.gnumeric.org/v10.dtd:Zoom "1") + (http://www.gnumeric.org/v10.dtd:Names + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Print_Area") + (http://www.gnumeric.org/v10.dtd:value "#REF!") + (http://www.gnumeric.org/v10.dtd:position "A1")) + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Sheet_Title") + (http://www.gnumeric.org/v10.dtd:value "\"runconfigs.config\"") + (http://www.gnumeric.org/v10.dtd:position "A1"))) + (http://www.gnumeric.org/v10.dtd:PrintInformation + (http://www.gnumeric.org/v10.dtd:Margins + (http://www.gnumeric.org/v10.dtd:top (@ (PrefUnit "mm") (Points "120"))) + (http://www.gnumeric.org/v10.dtd:bottom + (@ (PrefUnit "mm") (Points "120"))) + (http://www.gnumeric.org/v10.dtd:left (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:right (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:header + (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:footer + (@ (PrefUnit "mm") (Points "72")))) + (http://www.gnumeric.org/v10.dtd:Scale + (@ (type "percentage") (percentage "100"))) + (http://www.gnumeric.org/v10.dtd:vcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:hcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:grid (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:even_if_only_styles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:monochrome (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:draft (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:titles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:do_not_print (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:print_range (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:order "d_then_r") + (http://www.gnumeric.org/v10.dtd:orientation "portrait") + (http://www.gnumeric.org/v10.dtd:Header + (@ (Right "") (Middle "&[TAB]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:Footer + (@ (Right "") (Middle "Page &[PAGE]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:paper "na_letter") + (http://www.gnumeric.org/v10.dtd:comments "in_place") + (http://www.gnumeric.org/v10.dtd:errors "as_displayed")) + (http://www.gnumeric.org/v10.dtd:Styles + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "0") (endRow "65535") (endCol "255")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans")))) + (http://www.gnumeric.org/v10.dtd:Cols + (@ (DefaultSizePts "48")) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "108.8") (No "0") (HardSize "1"))) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "97.5") (No "1") (HardSize "1"))) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "100.5") (No "2") (HardSize "1") (Count "2")))) + (http://www.gnumeric.org/v10.dtd:Rows + (@ (DefaultSizePts "12.75")) + (http://www.gnumeric.org/v10.dtd:RowInfo + (@ (Unit "13.5") (No "0") (Count "2"))) + (http://www.gnumeric.org/v10.dtd:RowInfo (@ (Unit "12.75") (No "2"))) + (http://www.gnumeric.org/v10.dtd:RowInfo + (@ (Unit "13.5") (No "3") (Count "2"))) + (http://www.gnumeric.org/v10.dtd:RowInfo (@ (Unit "12.75") (No "5"))) + (http://www.gnumeric.org/v10.dtd:RowInfo (@ (Unit "13.5") (No "6"))) + (http://www.gnumeric.org/v10.dtd:RowInfo (@ (Unit "12.75") (No "7")))) + (http://www.gnumeric.org/v10.dtd:Selections + (@ (CursorRow "7") (CursorCol "3")) + (http://www.gnumeric.org/v10.dtd:Selection + (@ (startRow "7") (startCol "3") (endRow "7") (endCol "3")))) + (http://www.gnumeric.org/v10.dtd:SheetLayout (@ (TopLeft "A1"))) + (http://www.gnumeric.org/v10.dtd:Solver + (@ (ProgramR "0") + (ProblemType "0") + (NonNeg "1") + (ModelType "0") + (MaxTime "60") + (MaxIter "1000") + (Discr "0") + (AutoScale "0")))) ADDED tests/installall/configs/chicken-4.8.0.4.config Index: tests/installall/configs/chicken-4.8.0.4.config ================================================================== --- /dev/null +++ tests/installall/configs/chicken-4.8.0.4.config @@ -0,0 +1,1 @@ +CHICKEN_URL http://code.call-cc.org/releases/4.8.0/chicken-4.8.0.4.tar.gz ADDED tests/installall/configs/chicken-4.8.1.config Index: tests/installall/configs/chicken-4.8.1.config ================================================================== --- /dev/null +++ tests/installall/configs/chicken-4.8.1.config @@ -0,0 +1,1 @@ +CHICKEN_URL http://code.call-cc.org/dev-snapshots/2013/01/04/chicken-4.8.1.tar.gz ADDED tests/installall/megatest.config Index: tests/installall/megatest.config ================================================================== --- /dev/null +++ tests/installall/megatest.config @@ -0,0 +1,24 @@ +[fields] +CHICKEN_VERSION TEXT +MEGATEST_VERSION TEXT +IUPMODE TEXT +BUILD_TAG TEXT + +[setup] +max_concurrent_jobs 6 +linktree #{getenv MT_RUN_AREA_HOME}/links +testcopycmd cp --remove-destination -rsv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log + +[jobtools] +useshell yes +launcher nbfind + +[env-override] +EXAMPLE_VAR example value + +[server] +port 9080 + +[disks] +disk0 #{getenv MT_RUN_AREA_HOME}/runs + ADDED tests/installall/runconfigs.config Index: tests/installall/runconfigs.config ================================================================== --- /dev/null +++ tests/installall/runconfigs.config @@ -0,0 +1,38 @@ +[.............] +# +# [CHICKEN_VERSION/MEGATEST_VERSION/IUPMODE/PLATFORM/BUILD_TAG] +# + +[default] +ALLTESTS see this variable +PREFIX #{getenv MT_RUN_AREA_HOME}/#{getenv BUILD_TAG}/#{getenv MT_RUNNAME} +DOWNLOADS #{getenv MT_RUN_AREA_HOME}/downloads +IUPLIB 26g4 +PLATFORM linux +LOGPRO_VERSION v1.05 +BUILDSQLITE yes +SQLITE3_VERSION 3071401 +ZEROMQ_VERSION 2.2.0 +logpro_VERSION v1.08 +stml_VERSION v0.901 +megatest_VERSION v1.5511 + +[include configs/hicken-#{getenv CHICKEN_VERSION}.config] + +# Currently must have at least one variable in a section +[4.8.0/trunk/bin/std] +IUP_VERSION na + +[4.8.0.4/trunk/src/std] +CHICKEN_URL http://code.call-cc.org/releases/4.8.0/chicken-4.8.0.4.tar.gz +IUP_VERSION na + +[4.8.1/trunk/src/std] +IUP_VERSION na + +[4.8.0/v1.5508/opt] +IUP_VERSION na +PREFIX /opt/chicken/4.8.0 + +[4.8.0/trunk/centos5.7vm] +BUILDSQLITE no ADDED tests/installall/tests/canvas-draw/install.logpro Index: tests/installall/tests/canvas-draw/install.logpro ================================================================== --- /dev/null +++ tests/installall/tests/canvas-draw/install.logpro @@ -0,0 +1,8 @@ +;; 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/) + +;; 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/i)) ;; but disallow any other errors ADDED tests/installall/tests/canvas-draw/install.sh Index: tests/installall/tests/canvas-draw/install.sh ================================================================== --- /dev/null +++ tests/installall/tests/canvas-draw/install.sh @@ -0,0 +1,5 @@ +#!/usr/bin/env bash + +# Run your step here + +source $PREFIX/buildsetup.sh ADDED tests/installall/tests/canvas-draw/testconfig Index: tests/installall/tests/canvas-draw/testconfig ================================================================== --- /dev/null +++ tests/installall/tests/canvas-draw/testconfig @@ -0,0 +1,18 @@ +# Add additional steps here. Format is "stepname script" +[ezsteps] +install install.sh + +# Test requirements are specified here +[requirements] +waiton iuplib setup + +# Iteration for your tests are controlled by the items section +[items] + +# test_meta is a section for storing additional data on your test +[test_meta] +author matt +owner matt +description Install the canvas-draw egg +tags tagone,tagtwo +reviewed never ADDED tests/installall/tests/chicken/compile.logpro Index: tests/installall/tests/chicken/compile.logpro ================================================================== --- /dev/null +++ tests/installall/tests/chicken/compile.logpro @@ -0,0 +1,10 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "Leaving directory ..." #/Leaving directory/) + +;; 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:ignore in "LogFileBody" >= 0 "Ignore HAVE_STRERROR" #/HAVE_STRERROR/) + +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors ADDED tests/installall/tests/chicken/compile.sh Index: tests/installall/tests/chicken/compile.sh ================================================================== --- /dev/null +++ tests/installall/tests/chicken/compile.sh @@ -0,0 +1,8 @@ +#!/usr/bin/env bash + +# Run your step here + +source $PREFIX/buildsetup.sh + +cd chicken-${CHICKEN_VERSION} +make PLATFORM=${PLATFORM} PREFIX=${PREFIX} ADDED tests/installall/tests/chicken/download.logpro Index: tests/installall/tests/chicken/download.logpro ================================================================== --- /dev/null +++ tests/installall/tests/chicken/download.logpro @@ -0,0 +1,11 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "README file must be seen" #/README$/) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! + +(expect:ignore in "LogFileBody" >= 0 "Ignore error flagged by finalizer-error-test" #/\w+-error/) + +(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/i)) ;; but disallow any other errors ADDED tests/installall/tests/chicken/download.sh Index: tests/installall/tests/chicken/download.sh ================================================================== --- /dev/null +++ tests/installall/tests/chicken/download.sh @@ -0,0 +1,19 @@ +#!/usr/bin/env bash + +# Run your step here + +source $PREFIX/buildsetup.sh + +if [ ! -e ${DOWNLOADS}/chicken-${CHICKEN_VERSION}.tar.gz ]; then + if [ "${CHICKEN_URL}" == "" ]; then + CHICKEN_URL=http://code.call-cc.org/releases/${CHICKEN_VERSION}/chicken-${CHICKEN_VERSION}.tar.gz + fi + echo "Downloading $CHICKEN_URL" + (cd ${DOWNLOADS};wget ${CHICKEN_URL}) +fi + +ls -l ${DOWNLOADS}/chicken-${CHICKEN_VERSION}.tar.gz + +tar xfvz ${DOWNLOADS}/chicken-${CHICKEN_VERSION}.tar.gz + +ls -l chicken-${CHICKEN_VERSION} ADDED tests/installall/tests/chicken/install.logpro Index: tests/installall/tests/chicken/install.logpro ================================================================== --- /dev/null +++ tests/installall/tests/chicken/install.logpro @@ -0,0 +1,11 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "Leaving directory" #/Leaving directory/) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! + +(expect:ignore in "LogFileBody" >= 0 "Ignore error in some filenames" #/\w+-errors/) + +(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/i)) ;; but disallow any other errors ADDED tests/installall/tests/chicken/install.sh Index: tests/installall/tests/chicken/install.sh ================================================================== --- /dev/null +++ tests/installall/tests/chicken/install.sh @@ -0,0 +1,11 @@ +#!/usr/bin/env bash + +# Run your step here + +source $PREFIX/buildsetup.sh +# source $PREFIX + +cd chicken-${CHICKEN_VERSION} +make PLATFORM=${PLATFORM} PREFIX=${PREFIX} install + +ls -l ${PREFIX}/bin ADDED tests/installall/tests/chicken/testconfig Index: tests/installall/tests/chicken/testconfig ================================================================== --- /dev/null +++ tests/installall/tests/chicken/testconfig @@ -0,0 +1,22 @@ +# Add additional steps here. Format is "stepname script" +[ezsteps] +download download.sh +compile compile.sh +install install.sh + +# Test requirements are specified here +[requirements] +waiton setup +# priority 10 + +# Iteration for your tests are controlled by the items section +[items] +# CHICKEN_VERSION 4.8.0 + +# test_meta is a section for storing additional data on your test +[test_meta] +author matt +owner matt +description Download and install chicken scheme +tags tagone,tagtwo +reviewed never ADDED tests/installall/tests/eggs/install.logpro Index: tests/installall/tests/eggs/install.logpro ================================================================== --- /dev/null +++ tests/installall/tests/eggs/install.logpro @@ -0,0 +1,9 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "Last thing done is chmod ..." #/chmod /) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! +(expect:ignore in "LogFileBody" >= 0 "Ignore someword-errors" #/\w+-error/) +(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/i)) ;; but disallow any other errors ADDED tests/installall/tests/eggs/install.sh Index: tests/installall/tests/eggs/install.sh ================================================================== --- /dev/null +++ tests/installall/tests/eggs/install.sh @@ -0,0 +1,8 @@ +#!/usr/bin/env bash + +# Run your step here + +source $PREFIX/buildsetup.sh + +$PREFIX/bin/chicken-install $PROX $EGG_NAME + ADDED tests/installall/tests/eggs/testconfig Index: tests/installall/tests/eggs/testconfig ================================================================== --- /dev/null +++ tests/installall/tests/eggs/testconfig @@ -0,0 +1,20 @@ +# Add additional steps here. Format is "stepname script" +[ezsteps] +install install.sh + +# Test requirements are specified here +[requirements] +waiton chicken setup +priority 9 + +# Iteration for your tests are controlled by the items section +[items] +EGG_NAME matchable readline apropos base64 regex-literals format regex-case test coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt json md5 ssax sxml-serializer sxml-modifications salmonella sql-de-lite postgresql + +# test_meta is a section for storing additional data on your test +[test_meta] +author matt +owner matt +description Download and install eggs with no significant prerequisites +tags tagone,tagtwo +reviewed never ADDED tests/installall/tests/ffcall/compile.logpro Index: tests/installall/tests/ffcall/compile.logpro ================================================================== --- /dev/null +++ tests/installall/tests/ffcall/compile.logpro @@ -0,0 +1,8 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "Leaving directory" #/Leaving directory/) + +;; 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/i)) ;; but disallow any other errors ADDED tests/installall/tests/ffcall/compile.sh Index: tests/installall/tests/ffcall/compile.sh ================================================================== --- /dev/null +++ tests/installall/tests/ffcall/compile.sh @@ -0,0 +1,9 @@ +#!/usr/bin/env bash + +# Run your step here + +source $PREFIX/buildsetup.sh + +cd ffcall +./configure --prefix=${PREFIX} --enable-shared +make ADDED tests/installall/tests/ffcall/download.logpro Index: tests/installall/tests/ffcall/download.logpro ================================================================== --- /dev/null +++ tests/installall/tests/ffcall/download.logpro @@ -0,0 +1,8 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "VERSION" #/ VERSION/) + +;; 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/i)) ;; but disallow any other errors ADDED tests/installall/tests/ffcall/download.sh Index: tests/installall/tests/ffcall/download.sh ================================================================== --- /dev/null +++ tests/installall/tests/ffcall/download.sh @@ -0,0 +1,13 @@ +#!/usr/bin/env bash + +# Run your step here + +source $PREFIX/buildsetup.sh + +if ! [[ -e ${DOWNLOADS}/ffcall.tar.gz ]] ; then + (cd ${DOWNLOADS};wget http://www.kiatoa.com/matt/iup/ffcall.tar.gz ) +fi + +tar xfvz ${DOWNLOADS}/ffcall.tar.gz + +ls -l ffcall ADDED tests/installall/tests/ffcall/install.logpro Index: tests/installall/tests/ffcall/install.logpro ================================================================== --- /dev/null +++ tests/installall/tests/ffcall/install.logpro @@ -0,0 +1,8 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "Leaving directory" #/Leaving directory/) + +;; 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/i)) ;; but disallow any other errors ADDED tests/installall/tests/ffcall/install.sh Index: tests/installall/tests/ffcall/install.sh ================================================================== --- /dev/null +++ tests/installall/tests/ffcall/install.sh @@ -0,0 +1,8 @@ +#!/usr/bin/env bash + +# Run your step here + +source $PREFIX/buildsetup.sh + +cd ffcall +make install ADDED tests/installall/tests/ffcall/testconfig Index: tests/installall/tests/ffcall/testconfig ================================================================== --- /dev/null +++ tests/installall/tests/ffcall/testconfig @@ -0,0 +1,20 @@ +# Add additional steps here. Format is "stepname script" +[ezsteps] +download download.sh +compile compile.sh +install install.sh + +# Test requirements are specified here +[requirements] +waiton setup + +# Iteration for your tests are controlled by the items section +[items] + +# test_meta is a section for storing additional data on your test +[test_meta] +author matt +owner matt +description Install the ffcall library +tags tagone,tagtwo +reviewed never ADDED tests/installall/tests/iup/install.logpro Index: tests/installall/tests/iup/install.logpro ================================================================== --- /dev/null +++ tests/installall/tests/iup/install.logpro @@ -0,0 +1,9 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "chmod is roughly last thing that happens" #/chmod /) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! +(expect:ignore in "LogFileBody" >= 0 "Ignore setup-error-handling" #/\w+-error/) +(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/i)) ;; but disallow any other errors ADDED tests/installall/tests/iup/install.sh Index: tests/installall/tests/iup/install.sh ================================================================== --- /dev/null +++ tests/installall/tests/iup/install.sh @@ -0,0 +1,12 @@ +#!/usr/bin/env bash + +# Run your step here +source $PREFIX/buildsetup.sh +# source $PREFIX/setup-chicken4x.sh + +export CSCLIBS=`echo $LD_LIBRARY_PATH | sed 's/:/ -L/g'` +CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $PREFIX/bin/chicken-install $PROX -D no-library-checks -feature disable-iup-web iup +# CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -feature disable-iup-web -deploy -prefix $DEPLOYTARG iup +# iup:1.0.2 +CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $PREFIX/bin/chicken-install $PROX -D no-library-checks canvas-draw +# CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -deploy -prefix $DEPLOYTARG canvas-draw ADDED tests/installall/tests/iup/testconfig Index: tests/installall/tests/iup/testconfig ================================================================== --- /dev/null +++ tests/installall/tests/iup/testconfig @@ -0,0 +1,18 @@ +# Add additional steps here. Format is "stepname script" +[ezsteps] +install install.sh + +# Test requirements are specified here +[requirements] +waiton iup#{getenv IUPMODE}lib tougheggs + +# Iteration for your tests are controlled by the items section +[items] + +# test_meta is a section for storing additional data on your test +[test_meta] +author matt +owner matt +description Install iup egg +tags tagone,tagtwo +reviewed never ADDED tests/installall/tests/iupbinlib/compile.logpro Index: tests/installall/tests/iupbinlib/compile.logpro ================================================================== --- /dev/null +++ tests/installall/tests/iupbinlib/compile.logpro @@ -0,0 +1,8 @@ +;; 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/) + +;; 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/i)) ;; but disallow any other errors ADDED tests/installall/tests/iupbinlib/compile.sh Index: tests/installall/tests/iupbinlib/compile.sh ================================================================== --- /dev/null +++ tests/installall/tests/iupbinlib/compile.sh @@ -0,0 +1,5 @@ +#!/usr/bin/env bash + +# Run your step here + +source $PREFIX/buildsetup.sh ADDED tests/installall/tests/iupbinlib/download.logpro Index: tests/installall/tests/iupbinlib/download.logpro ================================================================== --- /dev/null +++ tests/installall/tests/iupbinlib/download.logpro @@ -0,0 +1,8 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "README file should show up" #/README/) + +;; 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/i)) ;; but disallow any other errors ADDED tests/installall/tests/iupbinlib/download.sh Index: tests/installall/tests/iupbinlib/download.sh ================================================================== --- /dev/null +++ tests/installall/tests/iupbinlib/download.sh @@ -0,0 +1,28 @@ +#!/usr/bin/env bash + +# Run your step here +source $PREFIX/buildsetup.sh +# source $PREFIX/setup-chicken4x.sh + +if [[ `uname -a | grep x86_64` == "" ]]; then + export ARCHSIZE='' +else + export ARCHSIZE=64_ +fi + # export files="cd-5.4.1_Linux${IUPLIB}_lib.tar.gz im-3.6.3_Linux${IUPLIB}_lib.tar.gz iup-3.5_Linux${IUPLIB}_lib.tar.gz" +if [[ x$USEOLDIUP == "x" ]];then + export files="cd-5.5.1_Linux${IUPLIB}_${ARCHSIZE}lib.tar.gz im-3.8_Linux${IUPLIB}_${ARCHSIZE}lib.tar.gz iup-3.6_Linux${IUPLIB}_${ARCHSIZE}lib.tar.gz" +else + echo WARNING: Using old IUP libraries + export files="cd-5.4.1_Linux${IUPLIB}_${ARCHSIZE}lib.tar.gz im-3.6.3_Linux${IUPLIB}_${ARCHSIZE}lib.tar.gz iup-3.5_Linux${IUPLIB}_${ARCHSIZE}lib.tar.gz" +fi + +mkdir -p $PREFIX/iuplib +for a in `echo $files` ; do + if ! [[ -e ${DOWNLOADS}/$a ]] ; then + (cd ${DOWNLOADS};wget http://www.kiatoa.com/matt/iup/$a) + fi + echo Untarring $a into $PREFIX/lib + (cd $PREFIX/lib;tar xfvz ${DOWNLOADS}/$a;mv include/* ../include) +done + ADDED tests/installall/tests/iupbinlib/install.logpro Index: tests/installall/tests/iupbinlib/install.logpro ================================================================== --- /dev/null +++ tests/installall/tests/iupbinlib/install.logpro @@ -0,0 +1,8 @@ +;; 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/) + +;; 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/i)) ;; but disallow any other errors ADDED tests/installall/tests/iupbinlib/install.sh Index: tests/installall/tests/iupbinlib/install.sh ================================================================== --- /dev/null +++ tests/installall/tests/iupbinlib/install.sh @@ -0,0 +1,4 @@ +#!/usr/bin/env bash + +# Run your step here +source $PREFIX/buildsetup.sh ADDED tests/installall/tests/iupbinlib/testconfig Index: tests/installall/tests/iupbinlib/testconfig ================================================================== --- /dev/null +++ tests/installall/tests/iupbinlib/testconfig @@ -0,0 +1,18 @@ +# Add additional steps here. Format is "stepname script" +[ezsteps] +download download.sh + +# Test requirements are specified here +[requirements] +waiton ffcall setup + +# Iteration for your tests are controlled by the items section +[items] + +# test_meta is a section for storing additional data on your test +[test_meta] +author matt +owner matt +description Install the iup library if it is not already installed +tags tagone,tagtwo +reviewed never ADDED tests/installall/tests/iupbinlib/untar.logpro Index: tests/installall/tests/iupbinlib/untar.logpro ================================================================== --- /dev/null +++ tests/installall/tests/iupbinlib/untar.logpro @@ -0,0 +1,8 @@ +;; 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/) + +;; 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/i)) ;; but disallow any other errors ADDED tests/installall/tests/iupbinlib/untar.sh Index: tests/installall/tests/iupbinlib/untar.sh ================================================================== --- /dev/null +++ tests/installall/tests/iupbinlib/untar.sh @@ -0,0 +1,4 @@ +#!/usr/bin/env bash + +# Run your step here +source $PREFIX/buildsetup.sh ADDED tests/installall/tests/iupsrclib/cd.logpro Index: tests/installall/tests/iupsrclib/cd.logpro ================================================================== --- /dev/null +++ tests/installall/tests/iupsrclib/cd.logpro @@ -0,0 +1,3 @@ +(expect:ignore in "LogFileBody" >= 0 "Ignore these binary operator errors for now" #/error: missing binary operator/) + +(load "compile.logpro") ADDED tests/installall/tests/iupsrclib/compile.logpro Index: tests/installall/tests/iupsrclib/compile.logpro ================================================================== --- /dev/null +++ tests/installall/tests/iupsrclib/compile.logpro @@ -0,0 +1,12 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "Completed signature" #/(Dynamic Library.*Done|Leaving directory|Nothing to be done)/) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! +(expect:ignore in "LogFileBody" >= 0 "Ignore files with error in name" #/error.[ch]/) +(expect:ignore in "LogFileBody" >= 0 "Ignore files with errors in name" #/errors.[ch]/) +(expect:ignore in "LogFileBody" >= 0 "Ignore files with warn in name" #/warning.[ch]/) + +(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/i)) ;; but disallow any other errors ADDED tests/installall/tests/iupsrclib/compile.sh Index: tests/installall/tests/iupsrclib/compile.sh ================================================================== --- /dev/null +++ tests/installall/tests/iupsrclib/compile.sh @@ -0,0 +1,17 @@ +#!/usr/bin/env bash + +# Run your step here + +pkg=$1 + +source $PREFIX/buildsetup.sh + +export LUA_SUFFIX= +export LUA_INC=$MT_TEST_RUN_DIR/lua52/include + +if [[ $pkg == "lua52" ]]; then + (cd $pkg/src;make $PLATFORM) +else + (cd $pkg/src;make) +fi + ADDED tests/installall/tests/iupsrclib/download.logpro Index: tests/installall/tests/iupsrclib/download.logpro ================================================================== --- /dev/null +++ tests/installall/tests/iupsrclib/download.logpro @@ -0,0 +1,13 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "README file should show up" #/README/) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! + +(expect:ignore in "LogFileBody" >= 0 "Ignore files with error in name" #/error.[ch]/) +(expect:ignore in "LogFileBody" >= 0 "Ignore files with errors in name" #/errors.[ch]/) +(expect:ignore in "LogFileBody" >= 0 "Ignore files with warn in name" #/warning.[ch]/) + +(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/i)) ;; but disallow any other errors ADDED tests/installall/tests/iupsrclib/download.sh Index: tests/installall/tests/iupsrclib/download.sh ================================================================== --- /dev/null +++ tests/installall/tests/iupsrclib/download.sh @@ -0,0 +1,14 @@ +#!/usr/bin/env bash + +# Run your step here +source $PREFIX/buildsetup.sh + +mkdir -p $PREFIX/iuplib +for a in cd-5.6.1_Sources.tar.gz im-3.8.1_Sources.tar.gz iup-3.8_Sources.tar.gz lua-5.2.1_Sources.tar.gz; do + if ! [[ -e ${DOWNLOADS}/$a ]] ; then + (cd ${DOWNLOADS};wget http://www.kiatoa.com/matt/iup/$a) + fi + tar xfvz ${DOWNLOADS}/$a +done + +find . -type d -exec chmod ug+x {} \; ADDED tests/installall/tests/iupsrclib/im.logpro Index: tests/installall/tests/iupsrclib/im.logpro ================================================================== --- /dev/null +++ tests/installall/tests/iupsrclib/im.logpro @@ -0,0 +1,1 @@ +(load "compile.logpro") ADDED tests/installall/tests/iupsrclib/install.logpro Index: tests/installall/tests/iupsrclib/install.logpro ================================================================== --- /dev/null +++ tests/installall/tests/iupsrclib/install.logpro @@ -0,0 +1,8 @@ +;; 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/) + +;; 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/i)) ;; but disallow any other errors ADDED tests/installall/tests/iupsrclib/install.sh Index: tests/installall/tests/iupsrclib/install.sh ================================================================== --- /dev/null +++ tests/installall/tests/iupsrclib/install.sh @@ -0,0 +1,22 @@ +#!/usr/bin/env bash + +# Run your step here +source $PREFIX/buildsetup.sh + +# The so files +cp -f im/lib/Linux26g4/*.so $PREFIX/lib +cp -f cd/lib/Linux26g4/*.so $PREFIX/lib +cp -f iup/lib/Linux26g4/*.so $PREFIX/lib + +# The development files +mkdir -p $PREFIX/include/im +cp -fR im/include/*.h $PREFIX/include/im +cp -f im/lib/Linux26g4/*.a $PREFIX/lib + +mkdir -p $PREFIX/include/cd +cp -f cd/include/*.h $PREFIX/include/cd +cp -f cd/lib/Linux26g4/*.a $PREFIX/lib + +mkdir -p /usr/include/iup +cp -f iup/include/*.h $PREFIX/include/iup +cp -f iup/lib/Linux26g4/*.a $PREFIX/lib ADDED tests/installall/tests/iupsrclib/iup.logpro Index: tests/installall/tests/iupsrclib/iup.logpro ================================================================== --- /dev/null +++ tests/installall/tests/iupsrclib/iup.logpro @@ -0,0 +1,3 @@ +(expect:ignore in "LogFileBody" >= 0 "Ignore these binary operator errors for now" #/error: missing binary operator/ expires: "10/10/2013") + +(load "compile.logpro") ADDED tests/installall/tests/iupsrclib/lua.logpro Index: tests/installall/tests/iupsrclib/lua.logpro ================================================================== --- /dev/null +++ tests/installall/tests/iupsrclib/lua.logpro @@ -0,0 +1,1 @@ +(load "compile.logpro") ADDED tests/installall/tests/iupsrclib/testconfig Index: tests/installall/tests/iupsrclib/testconfig ================================================================== --- /dev/null +++ tests/installall/tests/iupsrclib/testconfig @@ -0,0 +1,22 @@ +# Add additional steps here. Format is "stepname script" +[ezsteps] +download download.sh +lua compile.sh lua52 +im compile.sh im +cd compile.sh cd +iup compile.sh iup + +# Test requirements are specified here +[requirements] +waiton ffcall setup + +# Iteration for your tests are controlled by the items section +[items] + +# test_meta is a section for storing additional data on your test +[test_meta] +author matt +owner matt +description Install the iup library if it is not already installed +tags tagone,tagtwo +reviewed never ADDED tests/installall/tests/iupsrclib/untar.logpro Index: tests/installall/tests/iupsrclib/untar.logpro ================================================================== --- /dev/null +++ tests/installall/tests/iupsrclib/untar.logpro @@ -0,0 +1,8 @@ +;; 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/) + +;; 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/i)) ;; but disallow any other errors ADDED tests/installall/tests/iupsrclib/untar.sh Index: tests/installall/tests/iupsrclib/untar.sh ================================================================== --- /dev/null +++ tests/installall/tests/iupsrclib/untar.sh @@ -0,0 +1,4 @@ +#!/usr/bin/env bash + +# Run your step here +source $PREFIX/buildsetup.sh ADDED tests/installall/tests/mmisc/clone.logpro Index: tests/installall/tests/mmisc/clone.logpro ================================================================== --- /dev/null +++ tests/installall/tests/mmisc/clone.logpro @@ -0,0 +1,8 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "Output from fossil" #/^repository:\s+/) + +;; 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/i) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors ADDED tests/installall/tests/mmisc/clone.sh Index: tests/installall/tests/mmisc/clone.sh ================================================================== --- /dev/null +++ tests/installall/tests/mmisc/clone.sh @@ -0,0 +1,11 @@ +#!/usr/bin/env bash + +# Run your step here +source $PREFIX/buildsetup.sh + +fossil clone http://www.kiatoa.com/fossils/$FSLPKG $FSLPKG.fossil + +mkdir src +cd src +fossil open ../$FSLPKG.fossil --nested +fossil co ${$FSLPKG}_VERSION} ADDED tests/installall/tests/mmisc/install.logpro Index: tests/installall/tests/mmisc/install.logpro ================================================================== --- /dev/null +++ tests/installall/tests/mmisc/install.logpro @@ -0,0 +1,9 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "Always get a chmod at the end of install" #/chmod.*logpro.setup-info/) + +;; 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:ignore in "LogFileBody" < 99 "Ignore the word error in setup-error-handling" #/setup-error-handling/) +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/i) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors ADDED tests/installall/tests/mmisc/install.sh Index: tests/installall/tests/mmisc/install.sh ================================================================== --- /dev/null +++ tests/installall/tests/mmisc/install.sh @@ -0,0 +1,16 @@ +#!/usr/bin/env bash + +# Run your step here +source $PREFIX/buildsetup.sh +cd src +if [ $FSLPKG == "logpro" ];then + chicken-install +elif [ $FSLPKG == "stml" ];then + cp install.cfg.template install.cfg + cp requirements.scm.template requirements.scm + make + make install +else + make + make install PREFIX=$PREFIX +fi ADDED tests/installall/tests/mmisc/testconfig Index: tests/installall/tests/mmisc/testconfig ================================================================== --- /dev/null +++ tests/installall/tests/mmisc/testconfig @@ -0,0 +1,21 @@ +# Add additional steps here. Format is "stepname script" +[ezsteps] +clone clone.sh +install install.sh + +# Test requirements are specified here +[requirements] +waiton eggs setup + +# Iteration for your tests are controlled by the items section +[items] +FSLPKG logpro stml megatest + + +# test_meta is a section for storing additional data on your test +[test_meta] +author matt +owner matt +description Install the logpro tool +tags tagone,tagtwo +reviewed never ADDED tests/installall/tests/opensrc/clone.logpro Index: tests/installall/tests/opensrc/clone.logpro ================================================================== --- /dev/null +++ tests/installall/tests/opensrc/clone.logpro @@ -0,0 +1,8 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "Output from fossil" (list #/^repository:\s+/ #/comment:/)) + +;; 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/i) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors ADDED tests/installall/tests/opensrc/clone.sh Index: tests/installall/tests/opensrc/clone.sh ================================================================== --- /dev/null +++ tests/installall/tests/opensrc/clone.sh @@ -0,0 +1,22 @@ +#!/usr/bin/env bash + +# Run your step here +source $PREFIX/buildsetup.sh + +parentdir=$MT_LINKTREE/$MT_TARGET/$MT_RUNNAME + +lockfile $parentdir/clone.lock +if [ ! -e $parentdir/opensrc.fossil ];then + fossil clone http://www.kiatoa.com/fossils/opensrc $parentdir/opensrc.fossil +fi + +if [ ! -e $parentdir/src/dbi ];then + mkdir -p $parentdir/src + (cd $parentdir/src;fossil open $parentdir/opensrc.fossil --nested) +else + (cd $parentdir/src;fossil sync;fossil co trunk;fossil status) +fi +rm -f $parentdir/clone.lock + +ln -sf $parentdir/src $MT_TEST_RUN_DIR/src + ADDED tests/installall/tests/opensrc/install.logpro Index: tests/installall/tests/opensrc/install.logpro ================================================================== --- /dev/null +++ tests/installall/tests/opensrc/install.logpro @@ -0,0 +1,9 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "Always get a chmod at the end of install" #/chmod.*.setup-info/) + +;; 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:ignore in "LogFileBody" < 99 "Ignore the word error in setup-error-handling" #/setup-error-handling/) +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/i) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/i)) ;; but disallow any other errors ADDED tests/installall/tests/opensrc/install.sh Index: tests/installall/tests/opensrc/install.sh ================================================================== --- /dev/null +++ tests/installall/tests/opensrc/install.sh @@ -0,0 +1,6 @@ +#!/usr/bin/env bash + +# Run your step here +source $PREFIX/buildsetup.sh +cd src/$MODULE_NAME +chicken-install ADDED tests/installall/tests/opensrc/testconfig Index: tests/installall/tests/opensrc/testconfig ================================================================== --- /dev/null +++ tests/installall/tests/opensrc/testconfig @@ -0,0 +1,20 @@ +# Add additional steps here. Format is "stepname script" +[ezsteps] +clone clone.sh +install install.sh + +# Test requirements are specified here +[requirements] +waiton eggs setup sqlite3 + +# Iteration for your tests are controlled by the items section +[items] +MODULE_NAME dbi margs qtree vcd xfig mutils + +# test_meta is a section for storing additional data on your test +[test_meta] +author matt +owner matt +description Install the eggs from the opensrc fossil +tags tagone,tagtwo +reviewed never ADDED tests/installall/tests/setup/setup.logpro Index: tests/installall/tests/setup/setup.logpro ================================================================== --- /dev/null +++ tests/installall/tests/setup/setup.logpro @@ -0,0 +1,10 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "ALL DONE" #/ALL DONE$/) + +;; 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/i)) ;; but disallow any other errors ADDED tests/installall/tests/setup/setup.sh Index: tests/installall/tests/setup/setup.sh ================================================================== --- /dev/null +++ tests/installall/tests/setup/setup.sh @@ -0,0 +1,35 @@ +#!/usr/bin/env bash + +# Run your step here + +cksetupsh=$PREFIX/setup-chicken4x.sh +cksetupcsh=$PREFIX/setup-chicken4x.csh +setupsh=$PREFIX/buildsetup.sh + +# make a cache dir +mkdir -p $DOWNLOADS +mkdir -p $PREFIX + +# File for users to source to run chicken +echo "# Source me to setup to to run chicken" > $cksetupsh +echo "export PATH=$PREFIX/bin:\$PATH" > $cksetupsh +echo "export LD_LIBRARY_PATH=$PREFIX/lib" >> $cksetupsh + +# tcsh version +echo "setenv PATH $PREFIX/bin:\$PATH" > $cksetupcsh +echo "setenv LD_LIBRARY_PATH $PREFIX/lib" >> $cksetupcsh + +# File to source for build process +echo "export PATH=$PREFIX/bin:\$PATH" > $setupsh +echo "export LD_LIBRARY_PATH=$PREFIX/lib" >> $setupsh + +if [[ $proxy == "" ]]; then + echo 'Please set the environment variable "proxy" to host.com:port (e.g. foo.com:1234) to use a proxy' +else + echo "export http_proxy=http://$proxy" >> $setupsh + echo "export PROX=\"-proxy $proxy\"" >> $setupsh +fi + +echo "export PREFIX=$PREFIX" >> $setupsh + +echo ALL DONE ADDED tests/installall/tests/setup/testconfig Index: tests/installall/tests/setup/testconfig ================================================================== --- /dev/null +++ tests/installall/tests/setup/testconfig @@ -0,0 +1,18 @@ +# Add additional steps here. Format is "stepname script" +[ezsteps] +setup setup.sh + +# Test requirements are specified here +[requirements] +# priority 10 + +# Iteration for your tests are controlled by the items section +[items] + +# test_meta is a section for storing additional data on your test +[test_meta] +author matt +owner matt +description Download and install chicken scheme +tags tagone,tagtwo +reviewed never ADDED tests/installall/tests/sqlite3/compile.logpro Index: tests/installall/tests/sqlite3/compile.logpro ================================================================== --- /dev/null +++ tests/installall/tests/sqlite3/compile.logpro @@ -0,0 +1,9 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "Leaving directory" #/(Leaving directory|Nothing to be done for|creating sqlite3)/) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! +(expect:ignore in "LogFileBody" >= 0 "Ignore strerror_r" #/strerror_r/i) +(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/i)) ;; but disallow any other errors ADDED tests/installall/tests/sqlite3/compile.sh Index: tests/installall/tests/sqlite3/compile.sh ================================================================== --- /dev/null +++ tests/installall/tests/sqlite3/compile.sh @@ -0,0 +1,10 @@ +#!/usr/bin/env bash + +# Run your step here + +source $PREFIX/buildsetup.sh + +cd sqlite-autoconf-$SQLITE3_VERSION +./configure --prefix=$PREFIX + +make ADDED tests/installall/tests/sqlite3/download.logpro Index: tests/installall/tests/sqlite3/download.logpro ================================================================== --- /dev/null +++ tests/installall/tests/sqlite3/download.logpro @@ -0,0 +1,8 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "sqlite-autoconf" #/sqlite-autoconf/) + +;; 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/i)) ;; but disallow any other errors ADDED tests/installall/tests/sqlite3/download.sh Index: tests/installall/tests/sqlite3/download.sh ================================================================== --- /dev/null +++ tests/installall/tests/sqlite3/download.sh @@ -0,0 +1,14 @@ +#!/usr/bin/env bash + +# Run your step here + +source $PREFIX/buildsetup.sh + +echo Install sqlite3 +if ! [[ -e ${DOWNLOADS}/sqlite-autoconf-${SQLITE3_VERSION}.tar.gz ]]; then + (cd ${DOWNLOADS};wget http://www.sqlite.org/sqlite-autoconf-${SQLITE3_VERSION}.tar.gz) +fi + +tar xfz ${DOWNLOADS}/sqlite-autoconf-${SQLITE3_VERSION}.tar.gz + +ls -l sqlite-autoconf-${SQLITE3_VERSION}.tar.gz ADDED tests/installall/tests/sqlite3/install.logpro Index: tests/installall/tests/sqlite3/install.logpro ================================================================== --- /dev/null +++ tests/installall/tests/sqlite3/install.logpro @@ -0,0 +1,8 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "Leaving directory" #/Leaving directory/) + +;; 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/i)) ;; but disallow any other errors ADDED tests/installall/tests/sqlite3/install.sh Index: tests/installall/tests/sqlite3/install.sh ================================================================== --- /dev/null +++ tests/installall/tests/sqlite3/install.sh @@ -0,0 +1,9 @@ +#!/usr/bin/env bash + +# Run your step here + +source $PREFIX/buildsetup.sh + +cd sqlite-autoconf-$SQLITE3_VERSION +make install + ADDED tests/installall/tests/sqlite3/installegg.logpro Index: tests/installall/tests/sqlite3/installegg.logpro ================================================================== --- /dev/null +++ tests/installall/tests/sqlite3/installegg.logpro @@ -0,0 +1,9 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "chmod sqlite3" #/chmod.*sqlite3/) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! +(expect:ignore in "LogFileBody" >= 0 "Ignore setup-error-handling" #/setup-error-handling/) +(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/i)) ;; but disallow any other errors ADDED tests/installall/tests/sqlite3/installegg.sh Index: tests/installall/tests/sqlite3/installegg.sh ================================================================== --- /dev/null +++ tests/installall/tests/sqlite3/installegg.sh @@ -0,0 +1,7 @@ +#!/usr/bin/env bash + +# Run your step here + +source $PREFIX/buildsetup.sh + +CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib" $PREFIX/bin/chicken-install $PROX sqlite3 ADDED tests/installall/tests/sqlite3/testconfig Index: tests/installall/tests/sqlite3/testconfig ================================================================== --- /dev/null +++ tests/installall/tests/sqlite3/testconfig @@ -0,0 +1,24 @@ +# Add additional steps here. Format is "stepname script" +[ezsteps] +download download.sh +compile compile.sh +install install.sh +installegg installegg.sh + +# Test requirements are specified here +[requirements] +# We waiton chicken because this one installs the egg. It would behove us to split this +# into two tests ... +waiton tougheggs +priority 2 + +# Iteration for your tests are controlled by the items section +[items] + +# test_meta is a section for storing additional data on your test +[test_meta] +author matt +owner matt +description Install sqlite3 library for systems where it is not installed +tags tagone,tagtwo +reviewed never ADDED tests/installall/tests/tougheggs/install.logpro Index: tests/installall/tests/tougheggs/install.logpro ================================================================== --- /dev/null +++ tests/installall/tests/tougheggs/install.logpro @@ -0,0 +1,9 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "Last thing done is chmod ..." #/chmod /) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! +(expect:ignore in "LogFileBody" >= 0 "Ignore someword-errors" #/\w+-error/) +(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/i)) ;; but disallow any other errors ADDED tests/installall/tests/tougheggs/install.sh Index: tests/installall/tests/tougheggs/install.sh ================================================================== --- /dev/null +++ tests/installall/tests/tougheggs/install.sh @@ -0,0 +1,9 @@ +#!/usr/bin/env bash + +# Run your step here + +source $PREFIX/buildsetup.sh + +lockfile $PREFIX/eggs.lock +$PREFIX/bin/chicken-install $PROX $EGG_NAME +rm -f $PREFIX/eggs.lock ADDED tests/installall/tests/tougheggs/testconfig Index: tests/installall/tests/tougheggs/testconfig ================================================================== --- /dev/null +++ tests/installall/tests/tougheggs/testconfig @@ -0,0 +1,19 @@ +# Add additional steps here. Format is "stepname script" +[ezsteps] +install install.sh + +# Test requirements are specified here +[requirements] +waiton eggs + +# Iteration for your tests are controlled by the items section +[items] +EGG_NAME intarweb http-client awful uri-common spiffy-request-vars spiffy apropos spiffy-directory-listing + +# test_meta is a section for storing additional data on your test +[test_meta] +author matt +owner matt +description Download and install eggs with no significant prerequisites +tags tagone,tagtwo +reviewed never ADDED tests/installall/tests/zmq/install.logpro Index: tests/installall/tests/zmq/install.logpro ================================================================== --- /dev/null +++ tests/installall/tests/zmq/install.logpro @@ -0,0 +1,8 @@ +;; 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/) + +;; 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/i)) ;; but disallow any other errors ADDED tests/installall/tests/zmq/install.sh Index: tests/installall/tests/zmq/install.sh ================================================================== --- /dev/null +++ tests/installall/tests/zmq/install.sh @@ -0,0 +1,4 @@ +#!/usr/bin/env bash + +# Run your step here +source $PREFIX/buildsetup.sh ADDED tests/installall/tests/zmq/testconfig Index: tests/installall/tests/zmq/testconfig ================================================================== --- /dev/null +++ tests/installall/tests/zmq/testconfig @@ -0,0 +1,18 @@ +# Add additional steps here. Format is "stepname script" +[ezsteps] +install install.sh + +# Test requirements are specified here +[requirements] +waiton zmqlib chicken setup + +# Iteration for your tests are controlled by the items section +[items] + +# test_meta is a section for storing additional data on your test +[test_meta] +author matt +owner matt +description Install the zmq egg +tags tagone,tagtwo +reviewed never ADDED tests/installall/tests/zmqlib/compile.logpro Index: tests/installall/tests/zmqlib/compile.logpro ================================================================== --- /dev/null +++ tests/installall/tests/zmqlib/compile.logpro @@ -0,0 +1,8 @@ +;; 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/) + +;; 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/i)) ;; but disallow any other errors ADDED tests/installall/tests/zmqlib/compile.sh Index: tests/installall/tests/zmqlib/compile.sh ================================================================== --- /dev/null +++ tests/installall/tests/zmqlib/compile.sh @@ -0,0 +1,4 @@ +#!/usr/bin/env bash + +# Run your step here +source $PREFIX/buildsetup.sh ADDED tests/installall/tests/zmqlib/download.logpro Index: tests/installall/tests/zmqlib/download.logpro ================================================================== --- /dev/null +++ tests/installall/tests/zmqlib/download.logpro @@ -0,0 +1,8 @@ +;; 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/) + +;; 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/i)) ;; but disallow any other errors ADDED tests/installall/tests/zmqlib/download.sh Index: tests/installall/tests/zmqlib/download.sh ================================================================== --- /dev/null +++ tests/installall/tests/zmqlib/download.sh @@ -0,0 +1,4 @@ +#!/usr/bin/env bash + +# Run your step here +source $PREFIX/buildsetup.sh ADDED tests/installall/tests/zmqlib/install.logpro Index: tests/installall/tests/zmqlib/install.logpro ================================================================== --- /dev/null +++ tests/installall/tests/zmqlib/install.logpro @@ -0,0 +1,8 @@ +;; 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/) + +;; 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/i)) ;; but disallow any other errors ADDED tests/installall/tests/zmqlib/install.sh Index: tests/installall/tests/zmqlib/install.sh ================================================================== --- /dev/null +++ tests/installall/tests/zmqlib/install.sh @@ -0,0 +1,5 @@ +#!/usr/bin/env bash + +# Run your step here + +source $PREFIX/buildsetup.sh ADDED tests/installall/tests/zmqlib/testconfig Index: tests/installall/tests/zmqlib/testconfig ================================================================== --- /dev/null +++ tests/installall/tests/zmqlib/testconfig @@ -0,0 +1,21 @@ +# Add additional steps here. Format is "stepname script" +[ezsteps] +download download.sh +untar untar.sh +compile compile.sh +install install.sh + +# Test requirements are specified here +[requirements] +waiton setup + +# Iteration for your tests are controlled by the items section +[items] + +# test_meta is a section for storing additional data on your test +[test_meta] +author matt +owner matt +description Install the zmq library if it doesn't already exist +tags tagone,tagtwo +reviewed never ADDED tests/installall/tests/zmqlib/untar.logpro Index: tests/installall/tests/zmqlib/untar.logpro ================================================================== --- /dev/null +++ tests/installall/tests/zmqlib/untar.logpro @@ -0,0 +1,8 @@ +;; 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/) + +;; 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/i)) ;; but disallow any other errors ADDED tests/installall/tests/zmqlib/untar.sh Index: tests/installall/tests/zmqlib/untar.sh ================================================================== --- /dev/null +++ tests/installall/tests/zmqlib/untar.sh @@ -0,0 +1,4 @@ +#!/usr/bin/env bash + +# Run your step here +source $PREFIX/buildsetup.sh 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/a1/testconfig Index: tests/mintest/tests/a1/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/a1/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton b1 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/b1/testconfig Index: tests/mintest/tests/b1/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/b1/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton c1 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/c1/testconfig Index: tests/mintest/tests/c1/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/c1/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton d1fail 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/d1fail/testconfig Index: tests/mintest/tests/d1fail/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/d1fail/testconfig @@ -0,0 +1,7 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS +step2 exit 123 + +[requirements] +waiton e1 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/e1/testconfig Index: tests/mintest/tests/e1/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/e1/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 ADDED tests/resources/ruby/librunscript.rb Index: tests/resources/ruby/librunscript.rb ================================================================== --- /dev/null +++ tests/resources/ruby/librunscript.rb @@ -0,0 +1,37 @@ +# This is the library of stuff for megatest + +def run_and_record(stepname, cmd, checks) + system "megatest -step #{stepname} :state start :status n/a" + system cmd + exitcode=$? + if exitcode==0 + exitcode='pass' + else + exitcode='fail' + end + system "megatest -step #{stepname} :state end :status #{exitcode}" +end + +def record_step(stepname,state,status) + system "megatest -step #{stepname} :state #{state} :status #{status}" +end + +def test_status(state,status) + system "megatest -test-status :state #{state} :status #{status}" +end + + +# WARNING: This example is deprecated. Don't use the -test-status command +# unless you know for sure what you are doing. +def file_size_checker(stepname,filename,minsize,maxsize) + fsize=File.size(filename) + if fsize > maxsize or fsize < minsize + system "megatest -test-status :state COMPLETED :status fail" + else + system "megatest -test-status :state COMPLETED :status pass" + end +end + + +def wait_for_step(testname,stepname) +end 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/speedtest/megatest.config Index: tests/speedtest/megatest.config ================================================================== --- /dev/null +++ tests/speedtest/megatest.config @@ -0,0 +1,48 @@ +[fields] +sysname TEXT +fsname TEXT +datapath TEXT + +[setup] +transport #{scheme (if (getenv "USEHTTP") "http" "fs")} + +max_concurrent_jobs 50 + +# 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 +# +testcopycmd cp --remove-destination -rsv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log + +# FULL or 2, NORMAL or 1, OFF or 0 +synchronous OFF + +# override the logview command +# +logviewer (%MTCMD%) 2> /dev/null > /dev/null + +# override the html viewer launch command +# +# htmlviewercmd firefox -new-window +htmlviewercmd konqueror + +[jobtools] +launcher nbfake + +[server] + +# If the server can't be started on this port it will try the next port until +# it succeeds +port 8080 + +# This server will keep running this number of hours after last access. +# Three minutes is 0.05 hours +timeout 0.025 + +## disks are: +## name host:/path/to/area +## -or- +## name /path/to/area +[disks] +disk0 #{getenv MT_RUN_AREA_HOME}/tmp_run + ADDED tests/speedtest/runconfigs.config Index: tests/speedtest/runconfigs.config ================================================================== --- /dev/null +++ tests/speedtest/runconfigs.config @@ -0,0 +1,3 @@ +[default] +SOMEVAR This should show up in SOMEVAR3 + ADDED tests/speedtest/tests/speedtest/main.sh Index: tests/speedtest/tests/speedtest/main.sh ================================================================== --- /dev/null +++ tests/speedtest/tests/speedtest/main.sh @@ -0,0 +1,10 @@ +#!/bin/bash + +# 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 $TEST_DELAY + $MT_MEGATEST -step step$i :state end :status 0 +done + +exit 0 ADDED tests/speedtest/tests/speedtest/testconfig Index: tests/speedtest/tests/speedtest/testconfig ================================================================== --- /dev/null +++ tests/speedtest/tests/speedtest/testconfig @@ -0,0 +1,18 @@ +[setup] +runscript main.sh + +[requirements] +priority 1 + +[items] +SETLOG 0 1 +TEST_DELAY 0 1 2 3 4 5 6 7 8 9 10 +ITERATIONS 0 1 2 3 4 5 6 7 8 9 10 + +[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 + +tags first,single +reviewed 09/10/2011, by Matt 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))))) + ADDED txtdb/metadat.scm Index: txtdb/metadat.scm ================================================================== --- /dev/null +++ txtdb/metadat.scm @@ -0,0 +1,553 @@ +(define minimal-sxml + '(*TOP* (*PI* xml "version=\"1.0\" encoding=\"UTF-8\"") + (http://www.gnumeric.org/v10.dtd:Workbook + (@ (http://www.w3.org/2001/XMLSchema-instance:schemaLocation + "http://www.gnumeric.org/v9.xsd")) + (http://www.gnumeric.org/v10.dtd:Version + (@ (Minor "17") (Major "10") (Full "1.10.17") (Epoch "1"))) + (http://www.gnumeric.org/v10.dtd:Attributes + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name + "WorkbookView::show_horizontal_scrollbar") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name + "WorkbookView::show_vertical_scrollbar") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name + "WorkbookView::show_notebook_tabs") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name + "WorkbookView::do_auto_completion") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name + "WorkbookView::is_protected") + (http://www.gnumeric.org/v10.dtd:value "FALSE"))) + (urn:oasis:names:tc:opendocument:xmlns:office:1.0:document-meta + (@ (urn:oasis:names:tc:opendocument:xmlns:office:1.0:version "1.2")) + (urn:oasis:names:tc:opendocument:xmlns:office:1.0:meta + (http://purl.org/dc/elements/1.1/:date "2013-07-26T05:41:51Z") + (urn:oasis:names:tc:opendocument:xmlns:meta:1.0:creation-date + "2013-07-26T05:41:10Z"))) + (http://www.gnumeric.org/v10.dtd:Calculation + (@ (MaxIterations "100") + (ManualRecalc "0") + (IterationTolerance "0.001") + (FloatRadix "2") + (FloatDigits "53") + (EnableIteration "1"))) + (http://www.gnumeric.org/v10.dtd:SheetNameIndex + (http://www.gnumeric.org/v10.dtd:SheetName + (@ (http://www.gnumeric.org/v10.dtd:Rows "65536") + (http://www.gnumeric.org/v10.dtd:Cols "256")) + "Sheet1")) + (http://www.gnumeric.org/v10.dtd:Geometry + (@ (Width "1440") (Height "647"))) + (http://www.gnumeric.org/v10.dtd:Sheets + (http://www.gnumeric.org/v10.dtd:Sheet + (@ (Visibility "GNM_SHEET_VISIBILITY_VISIBLE") + (OutlineSymbolsRight "1") + (OutlineSymbolsBelow "1") + (HideZero "0") + (HideRowHeader "0") + (HideGrid "0") + (HideColHeader "0") + (GridColor "0:0:0") + (DisplayOutlines "1") + (DisplayFormulas "0")) + (http://www.gnumeric.org/v10.dtd:Name "Sheet1") + (http://www.gnumeric.org/v10.dtd:MaxCol "-1") + (http://www.gnumeric.org/v10.dtd:MaxRow "-1") + (http://www.gnumeric.org/v10.dtd:Zoom "1") + (http://www.gnumeric.org/v10.dtd:Names + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Print_Area") + (http://www.gnumeric.org/v10.dtd:value "#REF!") + (http://www.gnumeric.org/v10.dtd:position "A1")) + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Sheet_Title") + (http://www.gnumeric.org/v10.dtd:value "\"Sheet1\"") + (http://www.gnumeric.org/v10.dtd:position "A1"))) + (http://www.gnumeric.org/v10.dtd:PrintInformation + (http://www.gnumeric.org/v10.dtd:Margins + (http://www.gnumeric.org/v10.dtd:top + (@ (PrefUnit "mm") (Points "120"))) + (http://www.gnumeric.org/v10.dtd:bottom + (@ (PrefUnit "mm") (Points "120"))) + (http://www.gnumeric.org/v10.dtd:left + (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:right + (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:header + (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:footer + (@ (PrefUnit "mm") (Points "72")))) + (http://www.gnumeric.org/v10.dtd:Scale + (@ (type "percentage") (percentage "100"))) + (http://www.gnumeric.org/v10.dtd:vcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:hcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:grid (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:even_if_only_styles + (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:monochrome (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:draft (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:titles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:do_not_print (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:print_range (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:order "d_then_r") + (http://www.gnumeric.org/v10.dtd:orientation "portrait") + (http://www.gnumeric.org/v10.dtd:Header + (@ (Right "") (Middle "&[TAB]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:Footer + (@ (Right "") (Middle "Page &[PAGE]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:paper "na_letter") + (http://www.gnumeric.org/v10.dtd:comments "in_place") + (http://www.gnumeric.org/v10.dtd:errors "as_displayed")) + (http://www.gnumeric.org/v10.dtd:Styles + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") + (startCol "0") + (endRow "65535") + (endCol "255")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans")))) + (http://www.gnumeric.org/v10.dtd:Cols (@ (DefaultSizePts "48"))) + (http://www.gnumeric.org/v10.dtd:Rows + (@ (DefaultSizePts "12.75"))) + (http://www.gnumeric.org/v10.dtd:Selections + (@ (CursorRow "0") (CursorCol "0")) + (http://www.gnumeric.org/v10.dtd:Selection + (@ (startRow "0") (startCol "0") (endRow "0") (endCol "0")))) + (http://www.gnumeric.org/v10.dtd:Cells) + (http://www.gnumeric.org/v10.dtd:SheetLayout (@ (TopLeft "A1"))) + (http://www.gnumeric.org/v10.dtd:Solver + (@ (ProgramR "0") + (ProblemType "0") + (NonNeg "1") + (ModelType "0") + (MaxTime "60") + (MaxIter "1000") + (Discr "0") + (AutoScale "0"))))) + (http://www.gnumeric.org/v10.dtd:UIData (@ (SelectedTab "0")))))) + +(define sheet-meta + '(http://www.gnumeric.org/v10.dtd:Sheet + (@ (Visibility "GNM_SHEET_VISIBILITY_VISIBLE") + (OutlineSymbolsRight "1") + (OutlineSymbolsBelow "1") + (HideZero "0") + (HideRowHeader "0") + (HideGrid "0") + (HideColHeader "0") + (GridColor "0:0:0") + (DisplayOutlines "1") + (DisplayFormulas "0")) + (http://www.gnumeric.org/v10.dtd:MaxCol "8") + (http://www.gnumeric.org/v10.dtd:MaxRow "18") + (http://www.gnumeric.org/v10.dtd:Zoom "1") + (http://www.gnumeric.org/v10.dtd:Names + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Print_Area") + (http://www.gnumeric.org/v10.dtd:value "#REF!") + (http://www.gnumeric.org/v10.dtd:position "A1")) + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Sheet_Title") + (http://www.gnumeric.org/v10.dtd:value "\"First_Sheet\"") + (http://www.gnumeric.org/v10.dtd:position "A1"))) + (http://www.gnumeric.org/v10.dtd:PrintInformation + (http://www.gnumeric.org/v10.dtd:Margins + (http://www.gnumeric.org/v10.dtd:top + (@ (PrefUnit "mm") (Points "93.26"))) + (http://www.gnumeric.org/v10.dtd:bottom + (@ (PrefUnit "mm") (Points "93.26"))) + (http://www.gnumeric.org/v10.dtd:left (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:right (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:header + (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:footer + (@ (PrefUnit "mm") (Points "72")))) + (http://www.gnumeric.org/v10.dtd:Scale + (@ (type "percentage") (percentage "100"))) + (http://www.gnumeric.org/v10.dtd:vcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:hcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:grid (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:even_if_only_styles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:monochrome (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:draft (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:titles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:do_not_print (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:print_range (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:order "d_then_r") + (http://www.gnumeric.org/v10.dtd:orientation "portrait") + (http://www.gnumeric.org/v10.dtd:Header + (@ (Right "") (Middle "&[tab]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:Footer + (@ (Right "") (Middle "&[page]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:paper "na_letter") + (http://www.gnumeric.org/v10.dtd:comments "in_place") + (http://www.gnumeric.org/v10.dtd:errors "as_displayed")) + (http://www.gnumeric.org/v10.dtd:Styles + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "0") (endRow "0") (endCol "1")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans"))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "1") (startCol "0") (endRow "17") (endCol "1")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "hh\":\"mm\":\"ss AM/PM") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans"))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "18") (startCol "0") (endRow "31") (endCol "2")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans"))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "32") (startCol "0") (endRow "255") (endCol "7")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans"))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "256") (startCol "0") (endRow "65535") (endCol "63")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans"))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "2") (endRow "1") (endCol "2")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans"))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "2") (startCol "2") (endRow "17") (endCol "2")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "0") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans"))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "3") (endRow "31") (endCol "7")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans"))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "8") (endRow "255") (endCol "63")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans"))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "64") (endRow "65535") (endCol "255")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans")))) + (http://www.gnumeric.org/v10.dtd:Cols + (@ (DefaultSizePts "48")) + (http://www.gnumeric.org/v10.dtd:ColInfo (@ (Unit "48") (No "0"))) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "99") (No "1") (HardSize "1"))) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "64.01") (No "2") (Count "7")))) + (http://www.gnumeric.org/v10.dtd:Rows + (@ (DefaultSizePts "12.1")) + (http://www.gnumeric.org/v10.dtd:RowInfo (@ (Unit "12.64") (No "0"))) + (http://www.gnumeric.org/v10.dtd:RowInfo + (@ (Unit "13.5") (No "1") (Count "17"))) + (http://www.gnumeric.org/v10.dtd:RowInfo (@ (Unit "12.1") (No "18")))) + (http://www.gnumeric.org/v10.dtd:Selections + (@ (CursorRow "3") (CursorCol "1")) + (http://www.gnumeric.org/v10.dtd:Selection + (@ (startRow "3") (startCol "1") (endRow "3") (endCol "1")))) + (http://www.gnumeric.org/v10.dtd:SheetLayout + (@ (TopLeft "A2")) + (http://www.gnumeric.org/v10.dtd:FreezePanes + (@ (UnfrozenTopLeft "A2") (FrozenTopLeft "A1")))) + (http://www.gnumeric.org/v10.dtd:Solver + (@ (ProgramR "0") + (ProblemType "0") + (NonNeg "1") + (ModelType "0") + (MaxTime "60") + (MaxIter "1000") + (Discr "0") + (AutoScale "0"))))) + +(define sheets-meta + '((@ (http://www.w3.org/2001/XMLSchema-instance:schemaLocation + "http://www.gnumeric.org/v9.xsd")) + (http://www.gnumeric.org/v10.dtd:Version + (@ (Minor "17") (Major "10") (Full "1.10.17") (Epoch "1"))) + (http://www.gnumeric.org/v10.dtd:Attributes + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name + "WorkbookView::show_horizontal_scrollbar") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name + "WorkbookView::show_vertical_scrollbar") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name "WorkbookView::show_notebook_tabs") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name "WorkbookView::do_auto_completion") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name "WorkbookView::is_protected") + (http://www.gnumeric.org/v10.dtd:value "FALSE"))) + (urn:oasis:names:tc:opendocument:xmlns:office:1.0:document-meta + (@ (urn:oasis:names:tc:opendocument:xmlns:office:1.0:version "1.2")) + (urn:oasis:names:tc:opendocument:xmlns:office:1.0:meta + (http://purl.org/dc/elements/1.1/:date "2013-07-26T04:47:02Z") + (urn:oasis:names:tc:opendocument:xmlns:meta:1.0:creation-date + "2013-07-26T04:46:14Z"))) + (http://www.gnumeric.org/v10.dtd:Calculation + (@ (MaxIterations "100") + (ManualRecalc "0") + (IterationTolerance "0.001") + (FloatRadix "2") + (FloatDigits "53") + (EnableIteration "1"))) + (http://www.gnumeric.org/v10.dtd:SheetNameIndex + (http://www.gnumeric.org/v10.dtd:SheetName + (@ (http://www.gnumeric.org/v10.dtd:Rows "65536") + (http://www.gnumeric.org/v10.dtd:Cols "256")) + "First_Sheet") + (http://www.gnumeric.org/v10.dtd:SheetName + (@ (http://www.gnumeric.org/v10.dtd:Rows "65536") + (http://www.gnumeric.org/v10.dtd:Cols "256")) + "Second-sheet") + (http://www.gnumeric.org/v10.dtd:SheetName + (@ (http://www.gnumeric.org/v10.dtd:Rows "65536") + (http://www.gnumeric.org/v10.dtd:Cols "256")) + "RunsToDo") + (http://www.gnumeric.org/v10.dtd:SheetName + (@ (http://www.gnumeric.org/v10.dtd:Rows "65536") + (http://www.gnumeric.org/v10.dtd:Cols "256")) + "RunsToLock")) + (http://www.gnumeric.org/v10.dtd:Geometry (@ (Width "1440") (Height "647"))) + (http://www.gnumeric.org/v10.dtd:UIData (@ (SelectedTab "1"))))) + +(define workbook-meta + '(*TOP* (*PI* xml "version=\"1.0\" encoding=\"UTF-8\""))) + ADDED txtdb/nada3/First_Sheet.dat Index: txtdb/nada3/First_Sheet.dat ================================================================== --- /dev/null +++ txtdb/nada3/First_Sheet.dat @@ -0,0 +1,153 @@ +[Time] +BLANKVAL +A 0.324305555555556 +B 0.33125 +C 0.334722222222222 +D 0.336805555555556 +E 0.338888888888889 +F 0.340972222222222 +G 0.343055555555556 +H 0.345833333333333 +I 0.347916666666667 +J 0.351388888888889 +K 0.366666666666667 +L 0.379166666666667 +M 0.395833333333333 +N 0.422222222222222 +O 0.452083333333333 +P 0.491666666666667 +Q 0.570833333333333 + +[DeltaTime] +A 0 +B =days(B3,$B$2)*24*60 +C +D +E +F +G +H +I +J +K +L +M +N +O +P +Q + +[Ambient] +A 35.4 +B 35.4 +C 35 +D 35 +E 35 +F 35 +G 35 +H 36 +I 36 +J 37 +K 37 +L 38 +M 39 +N 40 +O 41 +P 41 +Q 41.5 + +[Firebox] +A 34.3 +B 72 +C 100 +D 130 +E 145 +F 150 +G 150 +H 158 +I 156 +J 152 +K 134 +L 117 +M 100 +N 91 +O 79 +P 68 +Q 51 + +[2nd_row] +A 34.3 +B 60 +C 90 +D 116 +E 121 +F 125 +G 128 +H 129 +I 128 +J 126 +K 117 +L 108 +M 100 +N 90 +O 78 +P 63 +Q 51 + +[3rd_row] +A 34.1 +B 42 +C 57 +D 69 +E 73 +F 78 +G 82 +H 86 +I 87 +J 89 +K 94 +L 96 +M 93 +N 88 +O 77 +P 64 +Q 51 + +[4th_row] +A 34 +B 39 +C 46 +D 52 +E 54 +F 56 +G 60 +H 62 +I 65 +J 67 +K 77 +L 82 +M 82 +N 81 +O 72 +P 62 +Q 51 + +[Exit] +A 34 +B 68 +C 68 +D 68 +E 68 +F 68 +G 69 +H 70 +I 72 +J 75 +K 107 +L 106 +M 106 +N 100 +O 79 +P 68 +Q 51 + ADDED txtdb/nada3/RunsToDo.dat Index: txtdb/nada3/RunsToDo.dat ================================================================== --- /dev/null +++ txtdb/nada3/RunsToDo.dat @@ -0,0 +1,15 @@ +[a/b/c] +123 a +456 b +789 c + +[d/e/f] +123 e +456 f +789 g + +[g/h/i] +123 h +456 i +789 j + ADDED txtdb/nada3/RunsToLock.dat Index: txtdb/nada3/RunsToLock.dat ================================================================== --- /dev/null +++ txtdb/nada3/RunsToLock.dat @@ -0,0 +1,11 @@ +[def] +ghi jkl +qrst +uvwx +yz12 + +[mno] +abc +def xyz +jkl +mnop ADDED txtdb/nada3/Second-sheet.dat Index: txtdb/nada3/Second-sheet.dat ================================================================== --- /dev/null +++ txtdb/nada3/Second-sheet.dat @@ -0,0 +1,34 @@ +[2] +V2 X +V6 Y +V8 Z +V12 E +V15 B +V17 + + +[A1] +V8 Z +V17 = + +# Just a test really +# +V1 X +V3 X +V5 Y +V7 Y +V10 Z +V11 E +V13 E +V14 B +V16 B +[3] +V2 John, +V6 Tom +V8 Fred +V17 ~ + +# a deeply held belief is a danger to sanity +# +V4 X +row-11 Z +row-18 B ADDED txtdb/nada3/Sheet3.dat Index: txtdb/nada3/Sheet3.dat ================================================================== --- /dev/null +++ txtdb/nada3/Sheet3.dat @@ -0,0 +1,8 @@ +[zeroth title] +row1name +row2name + +[col1title] +row1name row1value +row2nameNoValue +row3name row3value ADDED txtdb/nada3/sheet-names.cfg Index: txtdb/nada3/sheet-names.cfg ================================================================== --- /dev/null +++ txtdb/nada3/sheet-names.cfg @@ -0,0 +1,4 @@ +First_Sheet +Second-sheet +RunsToDo +RunsToLock ADDED txtdb/nada3/sxml/First_Sheet.sxml Index: txtdb/nada3/sxml/First_Sheet.sxml ================================================================== --- /dev/null +++ txtdb/nada3/sxml/First_Sheet.sxml @@ -0,0 +1,460 @@ +(http://www.gnumeric.org/v10.dtd:Sheet + (@ (Visibility "GNM_SHEET_VISIBILITY_VISIBLE") + (OutlineSymbolsRight "1") + (OutlineSymbolsBelow "1") + (HideZero "0") + (HideRowHeader "0") + (HideGrid "0") + (HideColHeader "0") + (DisplayOutlines "1") + (DisplayFormulas "0")) + (http://www.gnumeric.org/v10.dtd:MaxCol "8") + (http://www.gnumeric.org/v10.dtd:MaxRow "19") + (http://www.gnumeric.org/v10.dtd:Zoom "1") + (http://www.gnumeric.org/v10.dtd:Names + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Sheet_Title") + (http://www.gnumeric.org/v10.dtd:value "\"First_Sheet\"") + (http://www.gnumeric.org/v10.dtd:position "A1")) + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Print_Area") + (http://www.gnumeric.org/v10.dtd:value "#REF!") + (http://www.gnumeric.org/v10.dtd:position "A1"))) + (http://www.gnumeric.org/v10.dtd:PrintInformation + (http://www.gnumeric.org/v10.dtd:Margins + (http://www.gnumeric.org/v10.dtd:top + (@ (PrefUnit "mm") (Points "93.26"))) + (http://www.gnumeric.org/v10.dtd:bottom + (@ (PrefUnit "mm") (Points "93.26"))) + (http://www.gnumeric.org/v10.dtd:left (@ (PrefUnit "Pt") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:right (@ (PrefUnit "Pt") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:header + (@ (PrefUnit "Pt") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:footer + (@ (PrefUnit "Pt") (Points "72")))) + (http://www.gnumeric.org/v10.dtd:Scale + (@ (type "percentage") (percentage "100"))) + (http://www.gnumeric.org/v10.dtd:vcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:hcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:grid (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:even_if_only_styles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:monochrome (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:draft (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:titles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:order "d_then_r") + (http://www.gnumeric.org/v10.dtd:orientation "portrait") + (http://www.gnumeric.org/v10.dtd:Header + (@ (Right "") (Middle "&[tab]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:Footer + (@ (Right "") (Middle "&[page]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:paper "na_letter")) + (http://www.gnumeric.org/v10.dtd:Styles + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "4096") (startCol "0") (endRow "65535") (endCol "63")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "4") (endRow "255") (endCol "15")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "32") (startCol "0") (endRow "255") (endCol "3")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "2") (startCol "2") (endRow "17") (endCol "2")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "0") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "3") (endRow "31") (endCol "3")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "1") (startCol "0") (endRow "17") (endCol "1")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "hh\":\"mm\":\"ss AM/PM") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "18") (startCol "0") (endRow "31") (endCol "2")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "16") (endRow "4095") (endCol "63")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "2") (endRow "1") (endCol "2")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "64") (endRow "65535") (endCol "255")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "256") (startCol "0") (endRow "4095") (endCol "15")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "0") (endRow "0") (endCol "1")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0"))))))) + (http://www.gnumeric.org/v10.dtd:Cols + (@ (DefaultSizePts "48")) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "48") (No "0") (MarginB "2") (MarginA "2"))) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "99") (No "1") (MarginB "2") (MarginA "2") (HardSize "1"))) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "64.01") (No "2") (MarginB "2") (MarginA "2") (Count "7")))) + (http://www.gnumeric.org/v10.dtd:Rows + (@ (DefaultSizePts "12.1")) + (http://www.gnumeric.org/v10.dtd:RowInfo + (@ (Unit "12.64") (No "0") (MarginB "0") (MarginA "0"))) + (http://www.gnumeric.org/v10.dtd:RowInfo + (@ (Unit "13.5") (No "1") (MarginB "0") (MarginA "0") (Count "17"))) + (http://www.gnumeric.org/v10.dtd:RowInfo + (@ (Unit "12.1") (No "18") (MarginB "0") (MarginA "0") (Count "2")))) + (http://www.gnumeric.org/v10.dtd:Selections + (@ (CursorRow "3") (CursorCol "1")) + (http://www.gnumeric.org/v10.dtd:Selection + (@ (startRow "3") (startCol "1") (endRow "3") (endCol "1")))) + (http://www.gnumeric.org/v10.dtd:SheetLayout + (@ (TopLeft "A2")) + (http://www.gnumeric.org/v10.dtd:FreezePanes + (@ (UnfrozenTopLeft "A2") (FrozenTopLeft "A1")))) + (http://www.gnumeric.org/v10.dtd:Solver + (@ (ShowIter "0") + (SensitivityR "0") + (ProgramR "0") + (ProblemType "0") + (PerformR "0") + (NonNeg "1") + (MaxTime "60") + (MaxIter "1000") + (LimitsR "0") + (Discr "0") + (AutoScale "0") + (AnswerR "0")))) ADDED txtdb/nada3/sxml/RunsToDo.sxml Index: txtdb/nada3/sxml/RunsToDo.sxml ================================================================== --- /dev/null +++ txtdb/nada3/sxml/RunsToDo.sxml @@ -0,0 +1,109 @@ +(http://www.gnumeric.org/v10.dtd:Sheet + (@ (Visibility "GNM_SHEET_VISIBILITY_VISIBLE") + (OutlineSymbolsRight "1") + (OutlineSymbolsBelow "1") + (HideZero "0") + (HideRowHeader "0") + (HideGrid "0") + (HideColHeader "0") + (DisplayOutlines "1") + (DisplayFormulas "0")) + (http://www.gnumeric.org/v10.dtd:MaxCol "3") + (http://www.gnumeric.org/v10.dtd:MaxRow "4") + (http://www.gnumeric.org/v10.dtd:Zoom "1") + (http://www.gnumeric.org/v10.dtd:Names + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Sheet_Title") + (http://www.gnumeric.org/v10.dtd:value "\"RunsToDo\"") + (http://www.gnumeric.org/v10.dtd:position "A1")) + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Print_Area") + (http://www.gnumeric.org/v10.dtd:value "#REF!") + (http://www.gnumeric.org/v10.dtd:position "A1"))) + (http://www.gnumeric.org/v10.dtd:PrintInformation + (http://www.gnumeric.org/v10.dtd:Margins + (http://www.gnumeric.org/v10.dtd:top (@ (PrefUnit "mm") (Points "120"))) + (http://www.gnumeric.org/v10.dtd:bottom + (@ (PrefUnit "mm") (Points "120"))) + (http://www.gnumeric.org/v10.dtd:left (@ (PrefUnit "Pt") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:right (@ (PrefUnit "Pt") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:header + (@ (PrefUnit "Pt") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:footer + (@ (PrefUnit "Pt") (Points "72")))) + (http://www.gnumeric.org/v10.dtd:Scale + (@ (type "percentage") (percentage "100"))) + (http://www.gnumeric.org/v10.dtd:vcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:hcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:grid (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:even_if_only_styles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:monochrome (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:draft (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:titles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:order "d_then_r") + (http://www.gnumeric.org/v10.dtd:orientation "portrait") + (http://www.gnumeric.org/v10.dtd:Header + (@ (Right "") (Middle "&[TAB]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:Footer + (@ (Right "") (Middle "Page &[PAGE]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:paper "na_letter")) + (http://www.gnumeric.org/v10.dtd:Styles + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "0") (endRow "65535") (endCol "255")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0"))))))) + (http://www.gnumeric.org/v10.dtd:Cols + (@ (DefaultSizePts "48")) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "48") (No "0") (MarginB "2") (MarginA "2") (Count "4")))) + (http://www.gnumeric.org/v10.dtd:Rows + (@ (DefaultSizePts "12.75")) + (http://www.gnumeric.org/v10.dtd:RowInfo + (@ (Unit "13.5") (No "0") (MarginB "0") (MarginA "0") (Count "4"))) + (http://www.gnumeric.org/v10.dtd:RowInfo + (@ (Unit "12.75") (No "4") (MarginB "0") (MarginA "0")))) + (http://www.gnumeric.org/v10.dtd:Selections + (@ (CursorRow "3") (CursorCol "2")) + (http://www.gnumeric.org/v10.dtd:Selection + (@ (startRow "3") (startCol "2") (endRow "3") (endCol "2")))) + (http://www.gnumeric.org/v10.dtd:SheetLayout (@ (TopLeft "A1"))) + (http://www.gnumeric.org/v10.dtd:Solver + (@ (ShowIter "0") + (SensitivityR "0") + (ProgramR "0") + (ProblemType "0") + (PerformR "0") + (NonNeg "1") + (MaxTime "60") + (MaxIter "1000") + (LimitsR "0") + (Discr "0") + (AutoScale "0") + (AnswerR "0")))) ADDED txtdb/nada3/sxml/RunsToLock.sxml Index: txtdb/nada3/sxml/RunsToLock.sxml ================================================================== --- /dev/null +++ txtdb/nada3/sxml/RunsToLock.sxml @@ -0,0 +1,92 @@ +(http://www.gnumeric.org/v10.dtd:Sheet + (@ (Visibility "GNM_SHEET_VISIBILITY_VISIBLE") + (OutlineSymbolsRight "1") + (OutlineSymbolsBelow "1") + (HideZero "0") + (HideRowHeader "0") + (HideGrid "0") + (HideColHeader "0") + (DisplayOutlines "1") + (DisplayFormulas "0")) + (http://www.gnumeric.org/v10.dtd:MaxCol "1") + (http://www.gnumeric.org/v10.dtd:MaxRow "1") + (http://www.gnumeric.org/v10.dtd:Zoom "1") + (http://www.gnumeric.org/v10.dtd:PrintInformation + (http://www.gnumeric.org/v10.dtd:Margins + (http://www.gnumeric.org/v10.dtd:top (@ (PrefUnit "cm") (Points "120"))) + (http://www.gnumeric.org/v10.dtd:bottom + (@ (PrefUnit "cm") (Points "120")))) + (http://www.gnumeric.org/v10.dtd:Scale + (@ (type "percentage") (percentage "100"))) + (http://www.gnumeric.org/v10.dtd:vcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:hcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:grid (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:even_if_only_styles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:monochrome (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:draft (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:titles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:order "d_then_r") + (http://www.gnumeric.org/v10.dtd:orientation "portrait") + (http://www.gnumeric.org/v10.dtd:Header + (@ (Right "") (Middle "&[TAB]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:Footer + (@ (Right "") (Middle "Page &[PAGE]") (Left "")))) + (http://www.gnumeric.org/v10.dtd:Styles + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "0") (endRow "65535") (endCol "255")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0"))))))) + (http://www.gnumeric.org/v10.dtd:Cols + (@ (DefaultSizePts "48")) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "48") (No "0") (MarginB "2") (MarginA "2") (Count "2")))) + (http://www.gnumeric.org/v10.dtd:Rows + (@ (DefaultSizePts "12.75")) + (http://www.gnumeric.org/v10.dtd:RowInfo + (@ (Unit "12.75") (No "0") (MarginB "0") (MarginA "0") (Count "2")))) + (http://www.gnumeric.org/v10.dtd:Selections + (@ (CursorRow "0") (CursorCol "0")) + (http://www.gnumeric.org/v10.dtd:Selection + (@ (startRow "0") (startCol "0") (endRow "0") (endCol "0")))) + (http://www.gnumeric.org/v10.dtd:SheetLayout (@ (TopLeft "A1"))) + (http://www.gnumeric.org/v10.dtd:Solver + (@ (ShowIter "0") + (SensitivityR "0") + (ProgramR "0") + (ProblemType "1") + (PerformR "0") + (NonNeg "1") + (MaxTime "0") + (MaxIter "0") + (LimitsR "0") + (Inputs "") + (Discr "0") + (AutoScale "0") + (AnswerR "0")))) ADDED txtdb/nada3/sxml/Second-sheet.sxml Index: txtdb/nada3/sxml/Second-sheet.sxml ================================================================== --- /dev/null +++ txtdb/nada3/sxml/Second-sheet.sxml @@ -0,0 +1,428 @@ +(http://www.gnumeric.org/v10.dtd:Sheet + (@ (Visibility "GNM_SHEET_VISIBILITY_VISIBLE") + (OutlineSymbolsRight "1") + (OutlineSymbolsBelow "1") + (HideZero "0") + (HideRowHeader "0") + (HideGrid "0") + (HideColHeader "0") + (DisplayOutlines "1") + (DisplayFormulas "0")) + (http://www.gnumeric.org/v10.dtd:MaxCol "3") + (http://www.gnumeric.org/v10.dtd:MaxRow "21") + (http://www.gnumeric.org/v10.dtd:Zoom "1") + (http://www.gnumeric.org/v10.dtd:Names + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Sheet_Title") + (http://www.gnumeric.org/v10.dtd:value "\"Second-sheet\"") + (http://www.gnumeric.org/v10.dtd:position "A1")) + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Print_Area") + (http://www.gnumeric.org/v10.dtd:value "#REF!") + (http://www.gnumeric.org/v10.dtd:position "A1"))) + (http://www.gnumeric.org/v10.dtd:PrintInformation + (http://www.gnumeric.org/v10.dtd:Margins + (http://www.gnumeric.org/v10.dtd:top + (@ (PrefUnit "mm") (Points "93.26"))) + (http://www.gnumeric.org/v10.dtd:bottom + (@ (PrefUnit "mm") (Points "93.26"))) + (http://www.gnumeric.org/v10.dtd:left (@ (PrefUnit "Pt") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:right (@ (PrefUnit "Pt") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:header + (@ (PrefUnit "Pt") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:footer + (@ (PrefUnit "Pt") (Points "72")))) + (http://www.gnumeric.org/v10.dtd:Scale + (@ (type "percentage") (percentage "100"))) + (http://www.gnumeric.org/v10.dtd:vcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:hcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:grid (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:even_if_only_styles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:monochrome (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:draft (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:titles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:order "d_then_r") + (http://www.gnumeric.org/v10.dtd:orientation "portrait") + (http://www.gnumeric.org/v10.dtd:Header + (@ (Right "") (Middle "&[tab]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:Footer + (@ (Right "") (Middle "&[page]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:paper "na_letter")) + (http://www.gnumeric.org/v10.dtd:Styles + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "4096") (startCol "0") (endRow "65535") (endCol "63")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "4") (endRow "255") (endCol "15")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "32") (startCol "0") (endRow "255") (endCol "3")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "17") (startCol "3") (endRow "31") (endCol "3")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "0") (endRow "31") (endCol "2")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "16") (startCol "3") (endRow "16") (endCol "3")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "1") + (Rotation "0") + (PatternColor "FFFF:FFFF:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:CCCC:0")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "16") (endRow "4095") (endCol "63")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "64") (endRow "65535") (endCol "255")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "1") (startCol "3") (endRow "15") (endCol "3")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "3") (endRow "0") (endCol "3")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "28") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0")))))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "256") (startCol "0") (endRow "4095") (endCol "15")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans") + (http://www.gnumeric.org/v10.dtd:StyleBorder + (http://www.gnumeric.org/v10.dtd:Top (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Bottom (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Left (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Right (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Diagonal (@ (Style "0"))) + (http://www.gnumeric.org/v10.dtd:Rev-Diagonal (@ (Style "0"))))))) + (http://www.gnumeric.org/v10.dtd:Cols + (@ (DefaultSizePts "48")) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "64.01") (No "0") (MarginB "2") (MarginA "2"))) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "48") (No "1") (MarginB "2") (MarginA "2"))) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "99") (No "2") (MarginB "2") (MarginA "2") (HardSize "1"))) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "227.2") (No "3") (MarginB "2") (MarginA "2") (HardSize "1")))) + (http://www.gnumeric.org/v10.dtd:Rows + (@ (DefaultSizePts "12.1")) + (http://www.gnumeric.org/v10.dtd:RowInfo + (@ (Unit "60") (No "0") (MarginB "0") (MarginA "0") (HardSize "1"))) + (http://www.gnumeric.org/v10.dtd:RowInfo + (@ (Unit "13.5") (No "1") (MarginB "0") (MarginA "0") (Count "17"))) + (http://www.gnumeric.org/v10.dtd:RowInfo + (@ (Unit "12.1") (No "18") (MarginB "0") (MarginA "0") (Count "4")))) + (http://www.gnumeric.org/v10.dtd:Selections + (@ (CursorRow "0") (CursorCol "3")) + (http://www.gnumeric.org/v10.dtd:Selection + (@ (startRow "0") (startCol "3") (endRow "0") (endCol "3")))) + (http://www.gnumeric.org/v10.dtd:SheetLayout (@ (TopLeft "A1"))) + (http://www.gnumeric.org/v10.dtd:Solver + (@ (ShowIter "0") + (SensitivityR "0") + (ProgramR "0") + (ProblemType "0") + (PerformR "0") + (NonNeg "1") + (MaxTime "60") + (MaxIter "1000") + (LimitsR "0") + (Discr "0") + (AutoScale "0") + (AnswerR "0")))) ADDED txtdb/nada3/sxml/Sheet3.sxml Index: txtdb/nada3/sxml/Sheet3.sxml ================================================================== --- /dev/null +++ txtdb/nada3/sxml/Sheet3.sxml @@ -0,0 +1,100 @@ +(http://www.gnumeric.org/v10.dtd:Sheet + (@ (Visibility "GNM_SHEET_VISIBILITY_VISIBLE") + (OutlineSymbolsRight "1") + (OutlineSymbolsBelow "1") + (HideZero "0") + (HideRowHeader "0") + (HideGrid "0") + (HideColHeader "0") + (GridColor "0:0:0") + (DisplayOutlines "1") + (DisplayFormulas "0")) + (http://www.gnumeric.org/v10.dtd:MaxCol "0") + (http://www.gnumeric.org/v10.dtd:MaxRow "0") + (http://www.gnumeric.org/v10.dtd:Zoom "1") + (http://www.gnumeric.org/v10.dtd:Names + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Print_Area") + (http://www.gnumeric.org/v10.dtd:value "#REF!") + (http://www.gnumeric.org/v10.dtd:position "A1")) + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Sheet_Title") + (http://www.gnumeric.org/v10.dtd:value "\"Sheet3\"") + (http://www.gnumeric.org/v10.dtd:position "A1"))) + (http://www.gnumeric.org/v10.dtd:PrintInformation + (http://www.gnumeric.org/v10.dtd:Margins + (http://www.gnumeric.org/v10.dtd:top + (@ (PrefUnit "mm") (Points "93.26"))) + (http://www.gnumeric.org/v10.dtd:bottom + (@ (PrefUnit "mm") (Points "93.26"))) + (http://www.gnumeric.org/v10.dtd:left (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:right (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:header + (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:footer + (@ (PrefUnit "mm") (Points "72")))) + (http://www.gnumeric.org/v10.dtd:Scale + (@ (type "percentage") (percentage "100"))) + (http://www.gnumeric.org/v10.dtd:vcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:hcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:grid (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:even_if_only_styles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:monochrome (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:draft (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:titles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:do_not_print (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:print_range (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:order "d_then_r") + (http://www.gnumeric.org/v10.dtd:orientation "portrait") + (http://www.gnumeric.org/v10.dtd:Header + (@ (Right "") (Middle "&[tab]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:Footer + (@ (Right "") (Middle "&[page]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:paper "na_letter") + (http://www.gnumeric.org/v10.dtd:comments "in_place") + (http://www.gnumeric.org/v10.dtd:errors "as_displayed")) + (http://www.gnumeric.org/v10.dtd:Styles + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "0") (endRow "65535") (endCol "255")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans")))) + (http://www.gnumeric.org/v10.dtd:Cols + (@ (DefaultSizePts "48")) + (http://www.gnumeric.org/v10.dtd:ColInfo (@ (Unit "64.01") (No "0")))) + (http://www.gnumeric.org/v10.dtd:Rows + (@ (DefaultSizePts "12.1")) + (http://www.gnumeric.org/v10.dtd:RowInfo (@ (Unit "12.82") (No "0")))) + (http://www.gnumeric.org/v10.dtd:Selections + (@ (CursorRow "0") (CursorCol "0")) + (http://www.gnumeric.org/v10.dtd:Selection + (@ (startRow "0") (startCol "0") (endRow "0") (endCol "0")))) + (http://www.gnumeric.org/v10.dtd:SheetLayout (@ (TopLeft "A1"))) + (http://www.gnumeric.org/v10.dtd:Solver + (@ (ProgramR "0") + (ProblemType "0") + (NonNeg "1") + (ModelType "0") + (MaxTime "60") + (MaxIter "1000") + (Discr "0") + (AutoScale "0")))) ADDED txtdb/nada3/sxml/_sheets.sxml Index: txtdb/nada3/sxml/_sheets.sxml ================================================================== --- /dev/null +++ txtdb/nada3/sxml/_sheets.sxml @@ -0,0 +1,46 @@ +((@ (http://www.w3.org/2001/XMLSchema-instance:schemaLocation + "http://www.gnumeric.org/v8.xsd")) + (http://www.gnumeric.org/v10.dtd:Version + (@ (Minor "3") (Major "6") (Full "1.6.3") (Epoch "1"))) + (http://www.gnumeric.org/v10.dtd:Attributes + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name + "WorkbookView::show_horizontal_scrollbar") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name + "WorkbookView::show_vertical_scrollbar") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name "WorkbookView::show_notebook_tabs") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name "WorkbookView::do_auto_completion") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name "WorkbookView::is_protected") + (http://www.gnumeric.org/v10.dtd:value "FALSE"))) + (http://www.gnumeric.org/v10.dtd:Summary + (http://www.gnumeric.org/v10.dtd:Item + (http://www.gnumeric.org/v10.dtd:name "application") + (http://www.gnumeric.org/v10.dtd:val-string "gnumeric")) + (http://www.gnumeric.org/v10.dtd:Item + (http://www.gnumeric.org/v10.dtd:name "author") + (http://www.gnumeric.org/v10.dtd:val-string "matthew.r.welland"))) + (http://www.gnumeric.org/v10.dtd:SheetNameIndex + (http://www.gnumeric.org/v10.dtd:SheetName "First_Sheet") + (http://www.gnumeric.org/v10.dtd:SheetName "Second-sheet") + (http://www.gnumeric.org/v10.dtd:SheetName "RunsToDo") + (http://www.gnumeric.org/v10.dtd:SheetName "RunsToLock")) + (http://www.gnumeric.org/v10.dtd:Geometry (@ (Width "1440") (Height "647"))) + (http://www.gnumeric.org/v10.dtd:UIData (@ (SelectedTab "3"))) + (http://www.gnumeric.org/v10.dtd:Calculation + (@ (MaxIterations "100") + (ManualRecalc "0") + (IterationTolerance "0.001") + (EnableIteration "1")))) ADDED txtdb/nada3/sxml/_workbook.sxml Index: txtdb/nada3/sxml/_workbook.sxml ================================================================== --- /dev/null +++ txtdb/nada3/sxml/_workbook.sxml @@ -0,0 +1,1 @@ +(*TOP* (*PI* xml "version=\"1.0\" encoding=\"UTF-8\"")) ADDED txtdb/testdata.sxml Index: txtdb/testdata.sxml ================================================================== --- /dev/null +++ txtdb/testdata.sxml @@ -0,0 +1,1273 @@ +(*TOP* (*PI* xml "version=\"1.0\" encoding=\"UTF-8\"") + (http://www.gnumeric.org/v10.dtd:Workbook + (@ (http://www.w3.org/2001/XMLSchema-instance:schemaLocation + "http://www.gnumeric.org/v9.xsd")) + (http://www.gnumeric.org/v10.dtd:Version + (@ (Minor "17") (Major "10") (Full "1.10.17") (Epoch "1"))) + (http://www.gnumeric.org/v10.dtd:Attributes + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name + "WorkbookView::show_horizontal_scrollbar") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name + "WorkbookView::show_vertical_scrollbar") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name + "WorkbookView::show_notebook_tabs") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name + "WorkbookView::do_auto_completion") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name + "WorkbookView::is_protected") + (http://www.gnumeric.org/v10.dtd:value "FALSE"))) + (urn:oasis:names:tc:opendocument:xmlns:office:1.0:document-meta + (@ (urn:oasis:names:tc:opendocument:xmlns:office:1.0:version "1.2")) + (urn:oasis:names:tc:opendocument:xmlns:office:1.0:meta + (http://purl.org/dc/elements/1.1/:date "2013-07-14T22:32:27Z") + (urn:oasis:names:tc:opendocument:xmlns:meta:1.0:creation-date + "2013-07-13T04:38:00Z"))) + (http://www.gnumeric.org/v10.dtd:Calculation + (@ (MaxIterations "100") + (ManualRecalc "0") + (IterationTolerance "0.001") + (FloatRadix "2") + (FloatDigits "53") + (EnableIteration "1"))) + (http://www.gnumeric.org/v10.dtd:SheetNameIndex + (http://www.gnumeric.org/v10.dtd:SheetName + (@ (http://www.gnumeric.org/v10.dtd:Rows "65536") + (http://www.gnumeric.org/v10.dtd:Cols "256")) + "First_Sheet") + (http://www.gnumeric.org/v10.dtd:SheetName + (@ (http://www.gnumeric.org/v10.dtd:Rows "65536") + (http://www.gnumeric.org/v10.dtd:Cols "256")) + "Second-sheet") + (http://www.gnumeric.org/v10.dtd:SheetName + (@ (http://www.gnumeric.org/v10.dtd:Rows "65536") + (http://www.gnumeric.org/v10.dtd:Cols "256")) + "Sheet3")) + (http://www.gnumeric.org/v10.dtd:Geometry + (@ (Width "1440") (Height "647"))) + (http://www.gnumeric.org/v10.dtd:Sheets + (http://www.gnumeric.org/v10.dtd:Sheet + (@ (Visibility "GNM_SHEET_VISIBILITY_VISIBLE") + (OutlineSymbolsRight "1") + (OutlineSymbolsBelow "1") + (HideZero "0") + (HideRowHeader "0") + (HideGrid "0") + (HideColHeader "0") + (GridColor "0:0:0") + (DisplayOutlines "1") + (DisplayFormulas "0")) + (http://www.gnumeric.org/v10.dtd:Name "First_Sheet") + (http://www.gnumeric.org/v10.dtd:MaxCol "8") + (http://www.gnumeric.org/v10.dtd:MaxRow "17") + (http://www.gnumeric.org/v10.dtd:Zoom "1") + (http://www.gnumeric.org/v10.dtd:Names + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Print_Area") + (http://www.gnumeric.org/v10.dtd:value "#REF!") + (http://www.gnumeric.org/v10.dtd:position "A1")) + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Sheet_Title") + (http://www.gnumeric.org/v10.dtd:value "\"First_Sheet\"") + (http://www.gnumeric.org/v10.dtd:position "A1"))) + (http://www.gnumeric.org/v10.dtd:PrintInformation + (http://www.gnumeric.org/v10.dtd:Margins + (http://www.gnumeric.org/v10.dtd:top + (@ (PrefUnit "mm") (Points "93.26"))) + (http://www.gnumeric.org/v10.dtd:bottom + (@ (PrefUnit "mm") (Points "93.26"))) + (http://www.gnumeric.org/v10.dtd:left + (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:right + (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:header + (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:footer + (@ (PrefUnit "mm") (Points "72")))) + (http://www.gnumeric.org/v10.dtd:Scale + (@ (type "percentage") (percentage "100"))) + (http://www.gnumeric.org/v10.dtd:vcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:hcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:grid (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:even_if_only_styles + (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:monochrome (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:draft (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:titles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:do_not_print (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:print_range (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:order "d_then_r") + (http://www.gnumeric.org/v10.dtd:orientation "portrait") + (http://www.gnumeric.org/v10.dtd:Header + (@ (Right "") (Middle "&[tab]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:Footer + (@ (Right "") (Middle "&[page]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:paper "na_letter") + (http://www.gnumeric.org/v10.dtd:comments "in_place") + (http://www.gnumeric.org/v10.dtd:errors "as_displayed")) + (http://www.gnumeric.org/v10.dtd:Styles + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "0") (endRow "0") (endCol "1")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans"))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "1") (startCol "0") (endRow "17") (endCol "1")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "hh\":\"mm\":\"ss AM/PM") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans"))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "18") (startCol "0") (endRow "31") (endCol "2")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans"))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "32") (startCol "0") (endRow "255") (endCol "7")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans"))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "256") + (startCol "0") + (endRow "65535") + (endCol "63")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans"))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "2") (endRow "1") (endCol "2")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans"))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "2") (startCol "2") (endRow "17") (endCol "2")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "0") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans"))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "3") (endRow "31") (endCol "7")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans"))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "8") (endRow "255") (endCol "63")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans"))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") + (startCol "64") + (endRow "65535") + (endCol "255")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans")))) + (http://www.gnumeric.org/v10.dtd:Cols + (@ (DefaultSizePts "48")) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "48") (No "0"))) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "99") (No "1") (HardSize "1"))) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "64.01") (No "2") (Count "7")))) + (http://www.gnumeric.org/v10.dtd:Rows + (@ (DefaultSizePts "12.1")) + (http://www.gnumeric.org/v10.dtd:RowInfo + (@ (Unit "12.64") (No "0"))) + (http://www.gnumeric.org/v10.dtd:RowInfo + (@ (Unit "13.5") (No "1") (Count "17")))) + (http://www.gnumeric.org/v10.dtd:Selections + (@ (CursorRow "29") (CursorCol "1")) + (http://www.gnumeric.org/v10.dtd:Selection + (@ (startRow "29") + (startCol "1") + (endRow "29") + (endCol "1")))) + (http://www.gnumeric.org/v10.dtd:Cells + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "0") (Col "1")) + "Time") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "0") (Col "2")) + "DeltaTime") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "0") (Col "3")) + "Ambient") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "0") (Col "4")) + "Firebox") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "0") (Col "5")) + "2nd row") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "0") (Col "6")) + "3rd row") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "0") (Col "7")) + "4th row") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "0") (Col "8")) + "Exit ") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "1") (Col "0")) + "A") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "1") (Col "1")) + "0.32430555555555557") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "1") (Col "2")) + "0") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "1") (Col "3")) + "35.399999999999999") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "1") (Col "4")) + "34.299999999999997") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "1") (Col "5")) + "34.299999999999997") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "1") (Col "6")) + "34.100000000000001") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "1") (Col "7")) + "34") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "1") (Col "8")) + "34") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "2") (Col "0")) + "B") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "2") (Col "1")) + "0.33124999999999999") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (Row "2") (ExprID "1") (Col "2")) + "=days(B3,$B$2)*24*60") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "2") (Col "3")) + "35.399999999999999") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "2") (Col "4")) + "72") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "2") (Col "5")) + "60") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "2") (Col "6")) + "42") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "2") (Col "7")) + "39") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "2") (Col "8")) + "68") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "3") (Col "0")) + "C") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "3") (Col "1")) + "0.3347222222222222") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (Row "3") (ExprID "1") (Col "2"))) + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "3") (Col "3")) + "35") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "3") (Col "4")) + "100") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "3") (Col "5")) + "90") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "3") (Col "6")) + "57") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "3") (Col "7")) + "46") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "3") (Col "8")) + "68") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "4") (Col "0")) + "D") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "4") (Col "1")) + "0.33680555555555558") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (Row "4") (ExprID "1") (Col "2"))) + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "4") (Col "3")) + "35") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "4") (Col "4")) + "130") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "4") (Col "5")) + "116") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "4") (Col "6")) + "69") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "4") (Col "7")) + "52") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "4") (Col "8")) + "68") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "5") (Col "0")) + "E") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "5") (Col "1")) + "0.33888888888888891") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (Row "5") (ExprID "1") (Col "2"))) + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "5") (Col "3")) + "35") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "5") (Col "4")) + "145") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "5") (Col "5")) + "121") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "5") (Col "6")) + "73") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "5") (Col "7")) + "54") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "5") (Col "8")) + "68") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "6") (Col "0")) + "F") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "6") (Col "1")) + "0.34097222222222223") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (Row "6") (ExprID "1") (Col "2"))) + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "6") (Col "3")) + "35") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "6") (Col "4")) + "150") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "6") (Col "5")) + "125") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "6") (Col "6")) + "78") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "6") (Col "7")) + "56") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "6") (Col "8")) + "68") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "7") (Col "0")) + "G") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "7") (Col "1")) + "0.34305555555555556") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (Row "7") (ExprID "1") (Col "2"))) + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "7") (Col "3")) + "35") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "7") (Col "4")) + "150") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "7") (Col "5")) + "128") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "7") (Col "6")) + "82") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "7") (Col "7")) + "60") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "7") (Col "8")) + "69") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "8") (Col "0")) + "H") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "8") (Col "1")) + "0.34583333333333333") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (Row "8") (ExprID "1") (Col "2"))) + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "8") (Col "3")) + "36") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "8") (Col "4")) + "158") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "8") (Col "5")) + "129") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "8") (Col "6")) + "86") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "8") (Col "7")) + "62") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "8") (Col "8")) + "70") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "9") (Col "0")) + "I") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "9") (Col "1")) + "0.34791666666666665") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (Row "9") (ExprID "1") (Col "2"))) + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "9") (Col "3")) + "36") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "9") (Col "4")) + "156") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "9") (Col "5")) + "128") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "9") (Col "6")) + "87") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "9") (Col "7")) + "65") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "9") (Col "8")) + "72") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "10") (Col "0")) + "J") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "10") (Col "1")) + "0.35138888888888886") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (Row "10") (ExprID "1") (Col "2"))) + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "10") (Col "3")) + "37") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "10") (Col "4")) + "152") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "10") (Col "5")) + "126") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "10") (Col "6")) + "89") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "10") (Col "7")) + "67") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "10") (Col "8")) + "75") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "11") (Col "0")) + "K") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "11") (Col "1")) + "0.36666666666666664") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (Row "11") (ExprID "1") (Col "2"))) + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "11") (Col "3")) + "37") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "11") (Col "4")) + "134") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "11") (Col "5")) + "117") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "11") (Col "6")) + "94") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "11") (Col "7")) + "77") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "11") (Col "8")) + "107") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "12") (Col "0")) + "L") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "12") (Col "1")) + "0.37916666666666665") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (Row "12") (ExprID "1") (Col "2"))) + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "12") (Col "3")) + "38") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "12") (Col "4")) + "117") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "12") (Col "5")) + "108") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "12") (Col "6")) + "96") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "12") (Col "7")) + "82") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "12") (Col "8")) + "106") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "13") (Col "0")) + "M") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "13") (Col "1")) + "0.39583333333333331") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (Row "13") (ExprID "1") (Col "2"))) + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "13") (Col "3")) + "39") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "13") (Col "4")) + "100") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "13") (Col "5")) + "100") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "13") (Col "6")) + "93") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "13") (Col "7")) + "82") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "13") (Col "8")) + "106") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "14") (Col "0")) + "N") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "14") (Col "1")) + "0.42222222222222222") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (Row "14") (ExprID "1") (Col "2"))) + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "14") (Col "3")) + "40") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "14") (Col "4")) + "91") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "14") (Col "5")) + "90") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "14") (Col "6")) + "88") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "14") (Col "7")) + "81") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "14") (Col "8")) + "100") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "15") (Col "0")) + "O") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "15") (Col "1")) + "0.45208333333333334") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (Row "15") (ExprID "1") (Col "2"))) + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "15") (Col "3")) + "41") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "15") (Col "4")) + "79") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "15") (Col "5")) + "78") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "15") (Col "6")) + "77") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "15") (Col "7")) + "72") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "15") (Col "8")) + "79") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "16") (Col "0")) + "P") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "16") (Col "1")) + "0.49166666666666664") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (Row "16") (ExprID "1") (Col "2"))) + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "16") (Col "3")) + "41") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "16") (Col "4")) + "68") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "16") (Col "5")) + "63") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "16") (Col "6")) + "64") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "16") (Col "7")) + "62") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "16") (Col "8")) + "68") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "17") (Col "0")) + "Q") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "17") (Col "1")) + "0.5708333333333333") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (Row "17") (ExprID "1") (Col "2"))) + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "17") (Col "3")) + "41.5") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "17") (Col "4")) + "51") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "17") (Col "5")) + "51") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "17") (Col "6")) + "51") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "17") (Col "7")) + "51") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "17") (Col "8")) + "51")) + (http://www.gnumeric.org/v10.dtd:SheetLayout (@ (TopLeft "A1"))) + (http://www.gnumeric.org/v10.dtd:Solver + (@ (ProgramR "0") + (ProblemType "0") + (NonNeg "1") + (ModelType "0") + (MaxTime "60") + (MaxIter "1000") + (Discr "0") + (AutoScale "0")))) + (http://www.gnumeric.org/v10.dtd:Sheet + (@ (Visibility "GNM_SHEET_VISIBILITY_VISIBLE") + (OutlineSymbolsRight "1") + (OutlineSymbolsBelow "1") + (HideZero "0") + (HideRowHeader "0") + (HideGrid "0") + (HideColHeader "0") + (GridColor "0:0:0") + (DisplayOutlines "1") + (DisplayFormulas "0")) + (http://www.gnumeric.org/v10.dtd:Name "Second-sheet") + (http://www.gnumeric.org/v10.dtd:MaxCol "4") + (http://www.gnumeric.org/v10.dtd:MaxRow "20") + (http://www.gnumeric.org/v10.dtd:Zoom "1") + (http://www.gnumeric.org/v10.dtd:Names + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Print_Area") + (http://www.gnumeric.org/v10.dtd:value "#REF!") + (http://www.gnumeric.org/v10.dtd:position "A1")) + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Sheet_Title") + (http://www.gnumeric.org/v10.dtd:value "\"Second-sheet\"") + (http://www.gnumeric.org/v10.dtd:position "A1"))) + (http://www.gnumeric.org/v10.dtd:PrintInformation + (http://www.gnumeric.org/v10.dtd:Margins + (http://www.gnumeric.org/v10.dtd:top + (@ (PrefUnit "mm") (Points "93.26"))) + (http://www.gnumeric.org/v10.dtd:bottom + (@ (PrefUnit "mm") (Points "93.26"))) + (http://www.gnumeric.org/v10.dtd:left + (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:right + (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:header + (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:footer + (@ (PrefUnit "mm") (Points "72")))) + (http://www.gnumeric.org/v10.dtd:Scale + (@ (type "percentage") (percentage "100"))) + (http://www.gnumeric.org/v10.dtd:vcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:hcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:grid (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:even_if_only_styles + (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:monochrome (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:draft (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:titles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:do_not_print (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:print_range (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:order "d_then_r") + (http://www.gnumeric.org/v10.dtd:orientation "portrait") + (http://www.gnumeric.org/v10.dtd:Header + (@ (Right "") (Middle "&[tab]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:Footer + (@ (Right "") (Middle "&[page]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:paper "na_letter") + (http://www.gnumeric.org/v10.dtd:comments "in_place") + (http://www.gnumeric.org/v10.dtd:errors "as_displayed")) + (http://www.gnumeric.org/v10.dtd:Styles + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") + (startCol "0") + (endRow "65279") + (endCol "255")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans"))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "65280") + (startCol "0") + (endRow "65534") + (endCol "255")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans"))) + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "65535") + (startCol "0") + (endRow "65535") + (endCol "255")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans")))) + (http://www.gnumeric.org/v10.dtd:Cols + (@ (DefaultSizePts "48")) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "64.01") (No "0"))) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "48") (No "1") (Count "4")))) + (http://www.gnumeric.org/v10.dtd:Rows + (@ (DefaultSizePts "12.1")) + (http://www.gnumeric.org/v10.dtd:RowInfo + (@ (Unit "13.5") (No "0") (Count "20")))) + (http://www.gnumeric.org/v10.dtd:Selections + (@ (CursorRow "4") (CursorCol "4")) + (http://www.gnumeric.org/v10.dtd:Selection + (@ (startRow "4") (startCol "4") (endRow "4") (endCol "4")))) + (http://www.gnumeric.org/v10.dtd:Cells + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "0") (Col "1")) + "A1") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "0") (Col "2")) + "2") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "0") (Col "3")) + "A1") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "40") (Row "0") (Col "4")) + "3") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "1") (Col "0")) + "V1") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "1") (Col "1")) + "X") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "2") (Col "0")) + "V2") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "2") (Col "2")) + "X") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "3") (Col "0")) + "V3") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "3") (Col "3")) + "X") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "4") (Col "0")) + "V4") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "4") (Col "4")) + "X") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "5") (Col "0")) + "V5") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "5") (Col "3")) + "Y") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "6") (Col "0")) + "V6") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "6") (Col "2")) + "Y") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "7") (Col "0")) + "V7") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "7") (Col "1")) + "Y") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "8") (Col "0")) + "V8") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "8") (Col "1")) + "Z") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "9") (Col "0")) + "V8") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "9") (Col "2")) + "Z") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "10") (Col "0")) + "V10") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "10") (Col "3")) + "Z") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "11") (Col "4")) + "Z") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "12") (Col "0")) + "V11") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "12") (Col "3")) + "E") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "13") (Col "0")) + "V12") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "13") (Col "2")) + "E") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "14") (Col "0")) + "V13") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "14") (Col "1")) + "E") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "15") (Col "0")) + "V14") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "15") (Col "1")) + "B") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "16") (Col "0")) + "V15") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "16") (Col "2")) + "B") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "17") (Col "0")) + "V16") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "17") (Col "3")) + "B") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "18") (Col "4")) + "B") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "19") (Col "0")) + "V17") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "19") (Col "1")) + "-") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "19") (Col "2")) + "+") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "19") (Col "3")) + "=") + (http://www.gnumeric.org/v10.dtd:Cell + (@ (ValueType "60") (Row "19") (Col "4")) + "~")) + (http://www.gnumeric.org/v10.dtd:SheetLayout (@ (TopLeft "A1"))) + (http://www.gnumeric.org/v10.dtd:Solver + (@ (ProgramR "0") + (ProblemType "0") + (NonNeg "1") + (ModelType "0") + (MaxTime "60") + (MaxIter "1000") + (Discr "0") + (AutoScale "0")))) + (http://www.gnumeric.org/v10.dtd:Sheet + (@ (Visibility "GNM_SHEET_VISIBILITY_VISIBLE") + (OutlineSymbolsRight "1") + (OutlineSymbolsBelow "1") + (HideZero "0") + (HideRowHeader "0") + (HideGrid "0") + (HideColHeader "0") + (GridColor "0:0:0") + (DisplayOutlines "1") + (DisplayFormulas "0")) + (http://www.gnumeric.org/v10.dtd:Name "Sheet3") + (http://www.gnumeric.org/v10.dtd:MaxCol "0") + (http://www.gnumeric.org/v10.dtd:MaxRow "0") + (http://www.gnumeric.org/v10.dtd:Zoom "1") + (http://www.gnumeric.org/v10.dtd:Names + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Print_Area") + (http://www.gnumeric.org/v10.dtd:value "#REF!") + (http://www.gnumeric.org/v10.dtd:position "A1")) + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Sheet_Title") + (http://www.gnumeric.org/v10.dtd:value "\"Sheet3\"") + (http://www.gnumeric.org/v10.dtd:position "A1"))) + (http://www.gnumeric.org/v10.dtd:PrintInformation + (http://www.gnumeric.org/v10.dtd:Margins + (http://www.gnumeric.org/v10.dtd:top + (@ (PrefUnit "mm") (Points "93.26"))) + (http://www.gnumeric.org/v10.dtd:bottom + (@ (PrefUnit "mm") (Points "93.26"))) + (http://www.gnumeric.org/v10.dtd:left + (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:right + (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:header + (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:footer + (@ (PrefUnit "mm") (Points "72")))) + (http://www.gnumeric.org/v10.dtd:Scale + (@ (type "percentage") (percentage "100"))) + (http://www.gnumeric.org/v10.dtd:vcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:hcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:grid (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:even_if_only_styles + (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:monochrome (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:draft (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:titles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:do_not_print (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:print_range (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:order "d_then_r") + (http://www.gnumeric.org/v10.dtd:orientation "portrait") + (http://www.gnumeric.org/v10.dtd:Header + (@ (Right "") (Middle "&[tab]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:Footer + (@ (Right "") (Middle "&[page]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:paper "na_letter") + (http://www.gnumeric.org/v10.dtd:comments "in_place") + (http://www.gnumeric.org/v10.dtd:errors "as_displayed")) + (http://www.gnumeric.org/v10.dtd:Styles + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") + (startCol "0") + (endRow "65535") + (endCol "255")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans")))) + (http://www.gnumeric.org/v10.dtd:Cols + (@ (DefaultSizePts "48")) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "64.01") (No "0")))) + (http://www.gnumeric.org/v10.dtd:Rows + (@ (DefaultSizePts "12.1")) + (http://www.gnumeric.org/v10.dtd:RowInfo + (@ (Unit "12.82") (No "0")))) + (http://www.gnumeric.org/v10.dtd:Selections + (@ (CursorRow "0") (CursorCol "0")) + (http://www.gnumeric.org/v10.dtd:Selection + (@ (startRow "0") (startCol "0") (endRow "0") (endCol "0")))) + (http://www.gnumeric.org/v10.dtd:Cells) + (http://www.gnumeric.org/v10.dtd:SheetLayout (@ (TopLeft "A1"))) + (http://www.gnumeric.org/v10.dtd:Solver + (@ (ProgramR "0") + (ProblemType "0") + (NonNeg "1") + (ModelType "0") + (MaxTime "60") + (MaxIter "1000") + (Discr "0") + (AutoScale "0"))))) + (http://www.gnumeric.org/v10.dtd:UIData (@ (SelectedTab "0"))))) Index: txtdb/txtdb.scm ================================================================== --- txtdb/txtdb.scm +++ txtdb/txtdb.scm @@ -1,19 +1,611 @@ -;; 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 ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. (use ssax) +(use sxml-serializer) +(use sxml-modifications) +(use regex) +(use srfi-69) +(use regex-case) +(use posix) +(use json) +(use csv) + +(include "../megatest-fossil-hash.scm") ;; Read a non-compressed gnumeric file -(define (txtdb:read-gnumeric-xml fname) +(define (refdb:read-gnumeric-xml fname) (with-input-from-file fname (lambda () (ssax:xml->sxml (current-input-port) '())))) + +(define (find-section dat section #!key (depth 0)) + (let loop ((hed (car dat)) + (tal (cdr dat))) + (if (list? hed) + (let ((res (find-section hed section depth: (+ depth 1)))) + (if res + res + (if (null? tal) + #f + (loop (car tal)(cdr tal))))) + (if (eq? hed section) + tal + (if (null? tal) + #f + (loop (car tal)(cdr tal))))))) + +(define (remove-section dat section) + (if (null? dat) + '() + (let loop ((hed (car dat)) + (tal (cdr dat)) + (res '())) + (let ((newres (if (and (list? hed) + (not (null? hed)) + (equal? (car hed) section)) + res + (cons hed res)))) + (if (null? tal) + (reverse newres) + (loop (car tal)(cdr tal) newres)))))) + +(define (list-sections dat) + (filter (lambda (x)(and x)) + (map (lambda (section) + (if (and (list? section) + (not (null? section))) + (car section) + #f)) + dat))) + +(define (string->safe-filename str) + (string-substitute (regexp " ") "_" str #t)) + +(define (sheet->refdb dat targdir) + (let* ((comment-rx (regexp "^#CMNT\\d+\\s*")) + (blank-rx (regexp "^#BLNK\\d+\\s*")) + (sheet-name (car (find-section dat 'http://www.gnumeric.org/v10.dtd:Name))) + ;; (safe-name (string->safe-filename sheet-name)) + (cells (find-section dat 'http://www.gnumeric.org/v10.dtd:Cells)) + (remaining (remove-section (remove-section dat 'http://www.gnumeric.org/v10.dtd:Name) + 'http://www.gnumeric.org/v10.dtd:Cells)) + (rownums (make-hash-table)) ;; num -> name + (colnums (make-hash-table)) ;; num -> name + (cols (make-hash-table)) ;; name -> ( (name val) ... ) + (col0title "")) + (for-each (lambda (cell) + (let ((rownum (string->number (car (find-section cell 'Row)))) + (colnum (string->number (car (find-section cell 'Col)))) + (valtype (let ((res (find-section cell 'ValueType))) + (if res (car res) #f))) + (value (let ((res (cdr (filter (lambda (x)(not (list? x))) cell)))) + (if (null? res) "" (car res))))) + ;; If colnum is 0 Then this is a row name, if rownum is 0 then this is a col name + (cond + ((and (not (eq? 0 rownum)) + (eq? 0 colnum)) ;; a blank in column zero is handled with the special name "row-N" + (hash-table-set! rownums rownum (if (equal? value "") + (conc "row-" rownum) + value))) + ((and (not (eq? 0 colnum)) + (eq? 0 rownum)) + (hash-table-set! colnums colnum (if (equal? value "") + (conc "col-" colnum) + value))) + ((and (eq? 0 rownum) + (eq? 0 colnum)) + (set! col0title value)) + (else + (let ((colname (hash-table-ref/default colnums colnum (conc "col-" colnum))) + (rowname (hash-table-ref/default rownums rownum (conc "row-" rownum)))) + (hash-table-set! cols colname (cons (list rowname value) + (hash-table-ref/default cols colname '())))))))) + cells) + (let ((ref-colnums (map (lambda (c) + (list (cdr c)(car c))) + (hash-table->alist colnums)))) + (with-output-to-file (conc targdir "/" sheet-name ".dat") + (lambda () + (print "[" col0title "]") + (for-each (lambda (colname) + (print "[" colname "]") + (for-each (lambda (row) + (let ((key (car row)) + (val (cadr row))) + (if (string-search comment-rx key) + (print val) + (if (string-search blank-rx key) + (print) + (print key " " val))))) + (reverse (hash-table-ref cols colname))) + ;; (print) + ) + (sort (hash-table-keys cols)(lambda (a b) + (let ((colnum-a (assoc a ref-colnums)) + (colnum-b (assoc b ref-colnums))) + (if (and colnum-a colnum-b) + (< (cadr colnum-a)(cadr colnum-b)) + (if (and (string? a) + (string? b)) + (string< a b)))))))))) + (with-output-to-file (conc targdir "/sxml/" sheet-name ".sxml") + (lambda () + (pp remaining))) + sheet-name)) + +(define (sxml->file dat fname) + (with-output-to-file fname + (lambda () + ;; (print (sxml-serializer#serialize-sxml dat)) + (pp dat)))) + +(define (file->sxml fname) + (let ((res (read-file fname read))) + (if (null? res) + (begin + (print "ERROR: file " fname " is malformed for read") + #f) + (car res)))) + +(define (replace-sheet-name-index indat sheets) + (let* ((rem-dat (remove-section indat 'http://www.gnumeric.org/v10.dtd:SheetNameIndex)) + (one-sht (find-section rem-dat 'http://www.gnumeric.org/v10.dtd:SheetName)) ;; for the future if I ever decide to do this "right" + (mk-entry (lambda (sheet-name) + (append '(http://www.gnumeric.org/v10.dtd:SheetName + (@ (http://www.gnumeric.org/v10.dtd:Rows "65536") + (http://www.gnumeric.org/v10.dtd:Cols "256"))) + (list sheet-name)))) + (new-indx-values (map mk-entry sheets))) + (append rem-dat (list (cons 'http://www.gnumeric.org/v10.dtd:SheetNameIndex + new-indx-values))))) + + +;; Write an sxml gnumeric workbook to a refdb directory structure. +;; +(define (extract-refdb dat targdir) + (create-directory (conc targdir "/sxml") #t) + (let* ((wrkbk (find-section dat 'http://www.gnumeric.org/v10.dtd:Workbook)) + (wrk-rem (remove-section dat 'http://www.gnumeric.org/v10.dtd:Workbook)) + (sheets (find-section wrkbk 'http://www.gnumeric.org/v10.dtd:Sheets)) + (sht-rem (remove-section wrkbk 'http://www.gnumeric.org/v10.dtd:Sheets)) + (sheet-names (map (lambda (sheet) + (sheet->refdb sheet targdir)) + sheets))) + (sxml->file wrk-rem (conc targdir "/sxml/_workbook.sxml")) + (sxml->file sht-rem (conc targdir "/sxml/_sheets.sxml")) + (with-output-to-file (conc targdir "/sheet-names.cfg") + (lambda () + (map print sheet-names))))) + +(define (read-gnumeric-file fname) + (if (not (string-match (regexp ".*.gnumeric$") fname)) + (begin + (print "ERROR: Attempt to import gnumeric file with extention other than .gnumeric") + (exit)) + (let ((tmpf (create-temporary-file (pathname-strip-directory fname)))) + (system (conc " gunzip > " tmpf " < " fname)) + (let ((res (refdb:read-gnumeric-xml tmpf))) + (delete-file tmpf) + res)))) + +(define (import-gnumeric-file fname targdir) + (extract-refdb (read-gnumeric-file fname) targdir)) + +;; Write a gnumeric compressed xml spreadsheet from a refdb directory structure. +;; +(define (refdb-export dbdir fname) + (let* ((sxml-dat (refdb->sxml dbdir)) + (tmpf (create-temporary-file (pathname-strip-directory fname))) + (tmpgzf (conc tmpf ".gz"))) + (with-output-to-file tmpf + (lambda () + (print (sxml-serializer#serialize-sxml sxml-dat ns-prefixes: (list (cons 'gnm "http://www.gnumeric.org/v10.dtd")))))) + (system (conc "gzip " tmpf)) + (file-copy tmpgzf fname #t) + (delete-file tmpgzf))) + +(define (hash-table-reverse-lookup ht val) + (hash-table-fold ht (lambda (k v res)(if (equal? v val) k res)) #f)) + +(define (read-dat fname) + (let ((section-rx (regexp "^\\[(.*)\\]\\s*$")) + (comment-rx (regexp "^#.*")) ;; This means a cell name cannot start with # + (cell-rx (regexp "^(\\S+) (.*)$")) ;; One space only for the cellname content separator + (blank-rx (regexp "^\\s*$")) + (continue-rx (regexp ".*\\\\$")) + (var-no-val-rx (regexp "^(\\S+)\\s*$")) + (inp (open-input-file fname)) + (cmnt-indx (make-hash-table)) + (blnk-indx (make-hash-table)) + (first-section #f)) ;; used for zeroth title + (let loop ((inl (read-line inp)) + (section ".............") + (res '())) + (if (eof-object? inl) + (begin + (close-input-port inp) + (cons (list first-section first-section first-section) + (reverse res))) + (regex-case + inl + (continue-rx _ (loop (conc inl (read-line inp)) section res)) + (comment-rx _ (let ((curr-indx (+ 1 (hash-table-ref/default cmnt-indx section 0)))) + (hash-table-set! cmnt-indx section curr-indx) + (loop (read-line inp) + section + (cons (list (conc "#CMNT" curr-indx) section inl) res)))) + (blank-rx _ (let ((curr-indx (+ 1 (hash-table-ref/default blnk-indx section 0)))) + (hash-table-set! blnk-indx section curr-indx) + (loop (read-line inp) + section + (cons (list (conc "#BLNK" curr-indx) section " ") res)))) + (section-rx (x sname) (begin + (if (not first-section) + (set! first-section sname)) + (loop (read-line inp) + sname + res))) + (cell-rx (x k v) (loop (read-line inp) + section + (cons (list k section v) res))) + (var-no-val-rx (x k) (loop (read-line inp) + section + (cons (list k section "") res))) + (else (begin + (print "ERROR: Unrecognised line in input file " fname ", ignoring it") + (loop (read-line inp) section res)))))))) + +(define (get-value-type val expressions) + (cond + ((string->number val) '(ValueType "40")) + ((equal? val "") '(ValueType "60")) + ((equal? (substring val 0 1) "=") + (let ((exid (hash-table-ref/default expressions val #f))) + (if exid + (list 'ExprID exid) + (let* ((values (hash-table-keys expressions)) ;; note, values are the id numbers + (new-max (+ 1 (if (null? values) 0 (apply max values))))) + (hash-table-set! expressions val new-max) + (list 'ExprID new-max))))) + (else '(ValueType "60")))) + +(define (dat->cells dat) + (let* ((indx (common:sparse-list-generate-index (cdr dat))) + (row-indx (car indx)) + (col-indx (cadr indx)) + (rowdat (map (lambda (row)(list (car row) " " (car row))) row-indx)) + (coldat (map (lambda (col)(list " " (car col) (car col))) col-indx)) + (exprs (make-hash-table))) + (list (cons 'http://www.gnumeric.org/v10.dtd:Cells + (map (lambda (item) + (let* ((row-name (car item)) + (col-name (cadr item)) + (row-num (let ((i (assoc row-name row-indx))) + (if i (cadr i) 0))) ;; 0 for the title row/col + (col-num (let ((i (assoc col-name col-indx))) + (if i (cadr i) 0))) + (value (caddr item)) + (val-type (get-value-type value exprs))) + (list 'http://www.gnumeric.org/v10.dtd:Cell + (list '@ val-type (list 'Row (conc row-num)) (list 'Col (conc col-num))) + value))) + (append rowdat coldat dat)))))) + +(define (refdb->sxml dbdir) + (let* ((sht-names (read-file (conc dbdir "/sheet-names.cfg") read-line)) + (wrk-rem (file->sxml (conc dbdir "/sxml/_workbook.sxml"))) + (sht-rem (file->sxml (conc dbdir "/sxml/_sheets.sxml"))) + (sheets (fold (lambda (sheetname res) + (let* ((sheetdat (read-dat (conc dbdir "/" sheetname ".dat"))) + (cells (dat->cells sheetdat)) + (sht-meta (file->sxml (conc dbdir "/sxml/" sheetname ".sxml")))) + (cons (cons (car sht-meta) + (append (cons (list 'http://www.gnumeric.org/v10.dtd:Name sheetname) + (cdr sht-meta)) + cells)) + res))) + '() + (reverse sht-names)))) + (append wrk-rem (list (append + (cons 'http://www.gnumeric.org/v10.dtd:Workbook + sht-rem) + (list (cons 'http://www.gnumeric.org/v10.dtd:Sheets sheets))))))) + +;; (define ( + +;; +;; optional apply proc to rownum colnum value +;; +;; NB// If a change is made to this routine please look also at applying +;; it to the code in Megatest (http://www.kiatoa.com/fossils/megatest) +;; in the file common.scm +;; +(define (common:sparse-list-generate-index data #!key (proc #f)) + (if (null? data) + (list '() '()) + (let loop ((hed (car data)) + (tal (cdr data)) + (rownames '()) + (colnames '()) + (rownum 0) + (colnum 0)) + (let* ((rowkey (car hed)) + (colkey (cadr hed)) + (value (caddr hed)) + (existing-rowdat (assoc rowkey rownames)) + (existing-coldat (assoc colkey colnames)) + (curr-rownum (if existing-rowdat rownum (+ rownum 1))) + (curr-colnum (if existing-coldat colnum (+ colnum 1))) + (new-rownames (if existing-rowdat rownames (cons (list rowkey curr-rownum) rownames))) + (new-colnames (if existing-coldat colnames (cons (list colkey curr-colnum) colnames)))) + ;; (debug:print-info 0 "Processing record: " hed ) + (if proc (proc curr-rownum curr-colnum rowkey colkey value)) + (if (null? tal) + (list new-rownames new-colnames) + (loop (car tal) + (cdr tal) + new-rownames + new-colnames + (if (> curr-rownum rownum) curr-rownum rownum) + (if (> curr-colnum colnum) curr-colnum colnum) + )))))) +(define help + (conc "Usage: refdb action params ... + +Note: refdbdir is a path to the directory containg sheet-names.cfg + + import filename.gnumeric refdbdir : Import a gnumeric file into a txt db directory + export refdbdir filename.gnumeric : Export a refdb to a gnumeric file + edit refdbdir : Edit a refdbdir using gnumeric. + ls refdbdir : List the keys for specified level + lookup refdbdir sheetname row col : Look up a value in the text db + getrownames refdb sheetname : Get a list of row titles + getcolnames refdb sheetname : Get a list of column titles + +To export to other formats; first export to gnumeric then use ssconvert. + +e.g. + +refdb export mydata mydata.gnumeric +ssconvert -T Gnumeric_html:html40 mydata.gnumeric mydata.html + +Part of the Megatest tool suite. Learn more at http://www.kiatoa.com/fossils/megatest + +Version: " megatest-fossil-hash)) + +(define (list-sheets path) + ;; (cond + ;; ((and path (not sheet)(not row)(not col)) + (if (file-exists? path) + (read-file (conc path "/sheet-names.cfg") read-line) + '())) +;; ((and path sheet (not row)(not col)) + +(define (lookup path sheet row col) + (let ((fname (conc path "/" sheet ".dat"))) + (if (file-exists? fname) + (let ((dat (read-dat fname))) + (if (null? dat) + #f + (let loop ((hed (car dat)) + (tal (cdr dat))) + (if (and (equal? row (car hed)) + (equal? col (cadr hed))) + (caddr hed) + (if (null? tal) + #f + (loop (car tal)(cdr tal))))))) + #f))) + +;; call with proc = car to get row names +;; call with proc = cadr to get col names +(define (get-rowcol-names path sheet proc) + (let ((fname (conc path "/" sheet ".dat")) + (cmnt-rx (regexp "^#CMNT\\d+\\s*")) + (blnk-rx (regexp "^#BLNK\\d+\\s*"))) + (if (file-exists? fname) + (let ((dat (read-dat fname))) + (if (null? dat) + '() + (let loop ((hed (car dat)) + (tal (cdr dat)) + (res '())) + (let* ((row-name (proc hed)) + (newres (if (and (not (member row-name res)) + (not (string-search cmnt-rx row-name)) + (not (string-search blnk-rx row-name))) + (cons row-name res) + res))) + (if (null? tal) + (reverse newres) + (loop (car tal)(cdr tal) newres)))))) + '()))) + +;; (define (get-col-names path sheet) +;; (let ((fname (conc path "/" sheet ".dat"))) +;; (if (file-exists? fname) +;; (let ((dat (read-dat fname))) +;; (if (null? dat) +;; #f +;; (map cadr dat)))))) + +(define (edit-refdb path) + ;; TEMPORARY, REMOVE IN 2014 + (if (not (file-exists? path)) ;; Create new + (begin + (print "\nINFO: Creating new txtdb at " path "\n") + (create-new-db path))) + (if (not (file-exists? (conc path "/sxml/_sheets.sxml"))) + (begin + (print "ERROR: You appear to have the old file structure for txtdb. Please do the following and try again.") + (print) + (print "mv " path "/sxml/sheets.sxml " path "/sxml/_sheets.sxml") + (print "mv " path "/sxml/workbook.sxml " path "/sxml/_workbook.sxml") + (print) + (print "Don't forget to remove the old files from your revision control system and add the new.") + (exit))) + (let* ((dbname (pathname-strip-directory path)) + (tmpf (conc (create-temporary-file dbname) ".gnumeric"))) + (if (file-exists? (conc path "/sheet-names.cfg")) + (refdb-export path tmpf)) + (let ((pid (process-run "gnumeric" (list tmpf)))) + (process-wait pid) + (import-gnumeric-file tmpf path)))) + +;;====================================================================== +;; This routine dispaches or executes most of the commands for refdb +;;====================================================================== +;; +(define (process-action action-str . param) + (let ((num-params (length param)) + (action (string->symbol action-str))) + (cond + ((eq? num-params 1) + (case action + ((edit) + (edit-refdb (car param))) + ((ls) + (map print (list-sheets (car param)))))) + ((eq? num-params 2) + (let ((param1 (car param)) + (param2 (cadr param))) + (case action + ((getrownames) (print (string-intersperse (get-rowcol-names param1 param2 car) " "))) + ((getcolnames) (print (string-intersperse (get-rowcol-names param1 param2 cadr) " "))) + ((import) (import-gnumeric-file param1 param2)) ;; fname targname + ((export) (refdb-export param1 param2)) + (else (print "Unrecognised command " action)(print help))))) + ((eq? num-params 4) + (case action + ((lookup) ;; path section row col + (let ((res (lookup (car param)(cadr param)(caddr param)(cadddr param)))) + (if res + (print res) + (begin + (print "") + (exit 1)))))))))) + +(define (main) + (let* ((args (argv)) + (prog (car args)) + (rema (cdr args))) + (cond + ((null? rema)(print help)) + ((eq? (length rema) 1) + (case (string->symbol (car rema)) + ((mtedit) ;; Edit a Megatest area + (megatest->refdb)))) + ((>= (length rema) 2) + (apply process-action (car rema)(cdr rema))) + (else (print help))))) + +;;====================================================================== +;; C R E A T E N E W D B S +;;====================================================================== + +(include "metadat.scm") + +;; Creates a new db at path with one sheet +(define (create-new-db path) + (extract-refdb minimal-sxml path)) + +;;====================================================================== +;; M E G A T E S T S U P P O R T +;;====================================================================== + +;; Construct a temporary refdb area from the files in a Megatest area +;; +;; .refdb +;; megatest.dat (from megatest.config) +;; runconfigs.dat (from runconfigs.config) +;; tests_test1.dat (from tests/test1/testconfig) +;; etc. +;; + +(define (make-sheet-meta-if-needed fname) + (if (not (file-exists? fname)) + (sxml->file sheet-meta fname))) + +(define (megatest->refdb) + (if (not (file-exists? "megatest.config")) ;; must be at top of Megatest area + (begin + (print "ERROR: Must be at top of Megatest area to edit") + (exit))) + (create-directory ".refdb/sxml" #t) + (if (not (file-exists? ".refdb/sxml/_workbook.sxml")) + (sxml->file workbook-meta ".refdb/sxml/_workbook.sxml")) + (file-copy "megatest.config" ".refdb/megatest.dat" #t) + (make-sheet-meta-if-needed ".refdb/sxml/megatest.sxml") + (file-copy "runconfigs.config" ".refdb/runconfigs.dat" #t) + (make-sheet-meta-if-needed ".refdb/sxml/runconfigs.sxml") + (let ((testnames '())) + (for-each (lambda (tdir) + (let* ((testname (pathname-strip-directory tdir)) + (tconfig (conc tdir "/testconfig")) + (metafile (conc ".refdb/sxml/" testname ".sxml"))) + (if (file-exists? tconfig) + (begin + (set! testnames (append testnames (list testname))) + (file-copy tconfig (conc ".refdb/" testname ".dat") #t) + (make-sheet-meta-if-needed metafile))))) + (glob "tests/*")) + (let ((sheet-names (append (list "megatest" "runconfigs") testnames))) + (if (not (file-exists? ".refdb/sxml/_sheets.sxml")) + (sxml->file (replace-sheet-name-index sheets-meta sheet-names) ".refdb/sxml/_sheets.sxml")) + (with-output-to-file ".refdb/sheet-names.cfg" + (lambda () + (map print sheet-names)))))) + +(let ((dotfile (conc (get-environment-variable "HOME") "/.txtdbrc"))) + (if (file-exists? dotfile) + (load dotfile))) + +(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.refdbrc"))) + (if (file-exists? debugcontrolf) + (load debugcontrolf))) + +(main) + +#| + (define x (refdb:read-gnumeric-xml "testdata-stripped.xml")) + + + +;; Write out sxml +(with-output-to-file "testdata.sxml" (lambda()(pp x))) + ;; (serialize-sxml a output: "new.xml") +(with-output-to-file "testdata-stripped.xml" (lambda ()(print (sxml-serializer#serialize-sxml y)))) + +;; Read in sxml file +(with-input-from-file "testdata.sxml" (lambda ()(set! y (read)))) + +(find-section x 'http://www.gnumeric.org/v10.dtd:Workbook) + +(define sheets (find-section x 'http://www.gnumeric.org/v10.dtd:Sheets)) + +(define sheet1 (car sheets)) +(define cells-sheet1 (find-section sheet1 'http://www.gnumeric.org/v10.dtd:Cells)) +(map (lambda (c)(find-section c 'Row)) cells-sheet1) + +(for-each (lambda (cell) + (let* ((len (length cell)) + (row (car (find-section cell 'Row))) + (col (car (find-section cell 'Col))) + (val (let ((res (cdr (filter (lambda (x)(not (list? x))) cell)))) + (if (null? res) "" (car res))))) + (print "Row=" row " col=" col " val=" val))) + cells-sheet1) + + +(map (lambda (c)(filter (lambda (x)(not (list? x))) c)) cells-sheet1) +|# ADDED utils/Makefile.installall Index: utils/Makefile.installall ================================================================== --- /dev/null +++ utils/Makefile.installall @@ -0,0 +1,184 @@ + +# Copyright 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. + +help : + @echo You may need to do the following first: + @echo sudo apt-get install libreadline-dev + @echo sudo apt-get install libwebkitgtk-dev + @echo sudo apt-get install libmotif3 -OR- set KTYPE=26g4 + @echo KTYPE can be 26, 26g4, or 32 + @echo KTYPE=$KTYPE + @echo You are using PREFIX=$PREFIX + @echo You are using proxy="$(proxy)" + @echo If needed set proxy to host.dom:port + @echo + @echo "Set additional_libpath to help find gtk or other libraries, don't forget a leading :" + @echo ADDITIONAL_LIBPATH=$(ADDITIONAL_LIBPATH) + @echo + @echo To use previous IUP libraries set USEOLDIUP to yes + @echo USEOLDIUP=$(USEOLDIUP) + @echo + @echo To make all do: make all + +# Put the installation here +ifeq ($(PREFIX),) +PREFIX=$(PWD)/target +endif + +# Set this on the command line of your make call if needed: make PROXY=host.com:1234 +PROXY= + +# Select IUP library type +KTYPE=26g4 + +# Select version of chicken, sqlite3 etc +CHICKEN_VERSION=4.8.0 +SQLITE3_VERSION=3071401 + +# Eggs to install (straightforward ones) +EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars + +# +# Derived variables +# + +ifeq ($(PROXY),) +PROX= +else +http_proxy=http://$(PROXY) +PROX="-proxy $(PROXY)" +endif + +BUILDHOME=$(PWD) +PATH:=$(PREFIX)/bin:$(PATH) +LIBPATH=$(PREFIX)/lib$(ADDITIONAL_LIBPATH) +LD_LIBRARY_PATH=$(LIBPATH) +CHICKEN_INSTALL=$(PREFIX)/bin/chicken-install +CHICKEN_EGG_DIR=$(PREFIX)/lib/chicken/6 + +VPATH=$(CHICKEN_EGG_DIR):$(PWD)/eggflags + +vpath %.so $(CHICKEN_EGG_DIR) +vpath %.flag eggflags + +EGGSOFILES=$(addprefix $(CHICKEN_EGG_DIR)/,$(addsuffix .so,$(EGGS))) +EGGFLAGS=$(addprefix eggflags/,$(addsuffix .flag,$(EGGS))) + +# Stuff needed for IUP +ISARCHX86_64=$(shell uname -a | grep x86_64) +ifeq ($(ISARCHX86_64),) +ARCHSIZE= +else +ARCHSIZE=64_ +endif + +IUPFILES=cd-5.5.1_Linux$(KTYPE)_$(ARCHSIZE)lib.tar.gz im-3.8_Linux$(KTYPE)_$(ARCHSIZE)lib.tar.gz iup-3.6_Linux$(KTYPE)_$(ARCHSIZE)lib.tar.gz +CSCLIBS=$(shell echo $(LD_LIBRARY_PATH) | sed 's/:/ -L/g') +CSC_OPTIONS=-I$(PREFIX)/include -L$(CSCLIBS) + +all : chkn eggs iup + +chkn : $(CHICKEN_INSTALL) + +eggs : $(EGGSOFILES) + +sqlite3 : $(CHICKEN_EGG_DIR)/sqlite3.so + +iup : $(PREFIX)/lib/libavcall.a $(CHICKEN_EGG_DIR)/iup.so $(CHICKEN_EGG_DIR)/canvas-draw.so + +# Silly rule to make installing eggs more makeish, I don't understand why I need the basename +$(CHICKEN_EGG_DIR)/%.so : %.flag + $(CHICKEN_INSTALL) $(PROX) $(shell basename $*) + +$(EGGFLAGS) : # $(CHICKEN_INSTALL) + mkdir -p eggflags + touch $(EGGFLAGS) + +# some setup stuff +# +setup-chicken4x.sh : $(EGGFLAGS) + (echo "export PATH=$(PATH)" > setup-chicken4x.sh) + (echo "export LD_LIBRARY_PATH=$(LD_LIBRARY_PATH)" >> setup-chicken4x.sh) + mkdir -p $(PREFIX) + +# Download chicken source +chicken-$(CHICKEN_VERSION).tar.gz : + wget http://code.call-cc.org/releases/$(CHICKEN_VERSION)/chicken-$(CHICKEN_VERSION).tar.gz + +# NB// Must touch csi.scm since tar puts original date on it and deps are wrong then +chicken-$(CHICKEN_VERSION)/csi.scm : chicken-$(CHICKEN_VERSION).tar.gz + tar xfvz chicken-$(CHICKEN_VERSION).tar.gz + touch -c chicken-$(CHICKEN_VERSION)/csi.scm + +$(CHICKEN_INSTALL) : chicken-$(CHICKEN_VERSION)/csi.scm setup-chicken4x.sh + cd chicken-$(CHICKEN_VERSION);make PLATFORM=linux PREFIX=$(PREFIX) + cd chicken-$(CHICKEN_VERSION);make PLATFORM=linux PREFIX=$(PREFIX) install + +sqlite-autoconf-$(SQLITE3_VERSION).tar.gz : + wget http://www.sqlite.org/sqlite-autoconf-$(SQLITE3_VERSION).tar.gz + +sqlite-autoconf-$(SQLITE3_VERSION) : sqlite-autoconf-$(SQLITE3_VERSION).tar.gz + tar xfz sqlite-autoconf-$(SQLITE3_VERSION).tar.gz + +$(PREFIX)/bin/sqlite3 : sqlite-autoconf-$(SQLITE3_VERSION) + (cd sqlite-autoconf-$(SQLITE3_VERSION);./configure --prefix=$(PREFIX);make;make install) + +$(CHICKEN_EGG_DIR)/sqlite3.so : $(PREFIX)/bin/sqlite3 + CSC_OPTIONS="-I$(PREFIX)/include -L$(PREFIX)/lib" $(CHICKEN_INSTALL) $(PROX) sqlite3 + + +# Get and install my various utilities that haven't been eggified yet. +opensrc/margs/margs.scm opensrc/dbi/dbi.scm opensrc/qtree/qtree.scm : $(CHICKEN_INSTALL) $(CHICKEN_EGG_DIR)/sqlite3.so + mkdir -p opensrc + cd opensrc;if [ ! -e opensrc.fossil ]; then fossil clone http://www.kiatoa.com/fossils/opensrc opensrc.fossil; fi + cd opensrc;if [ -e dbi/dbi.scm ]; then fossil update; else fossil open opensrc.fossil; fi + +$(CHICKEN_EGG_DIR)/dbi.so : opensrc/dbi/dbi.scm + cd opensrc/dbi;chicken-install + +$(CHICKEN_EGG_DIR)/margs.so : opensrc/margs/margs.scm + cd opensrc/margs;chicken-install + +$(CHICKEN_EGG_DIR)/qtree.so : opensrc/qtree/qtree.scm + cd opensrc/qtree;chicken-install + +# $(CHICKEN_EGG_DIR)/dbi.so # Don't include as requires postgres +mattseggs : $(CHICKEN_EGG_DIR)/margs.so $(CHICKEN_EGG_DIR)/qtree.so + +# +# IUP +# + +ffcall.tar.gz : + wget http://www.kiatoa.com/matt/iup/ffcall.tar.gz + +ffcall/README : ffcall.tar.gz + tar xfvz ffcall.tar.gz + touch -c ffcall/README + +$(PREFIX)/lib/libavcall.a : ffcall/README + cd ffcall;./configure --prefix=$(PREFIX) --enable-shared && make && make install + +$(IUPFILES) : + wget http://www.kiatoa.com/matt/iup/$@ + cd $(PREFIX)/lib;tar xfvz $(BUILDHOME)/$@ + mv $(PREFIX)/lib/include/* $(PREFIX)/include + +$(PREFIX)/lib/libiup.so : $(IUPFILES) + touch -c $(PREFIX)/lib/libiup.so + +$(CHICKEN_EGG_DIR)/iup.so : $(PREFIX)/lib/libiup.so + $(CHICKEN_INSTALL) $(PROX) -D no-library-checks -feature disable-iup-web iup + +$(CHICKEN_EGG_DIR)/canvas-draw.so : $(PREFIX)/lib/libiup.so + $(CHICKEN_INSTALL) $(PROX) -D no-library-checks canvas-draw + +clean : + rm -rf chicken-4.8.0 eggflags ffcall sqlite-autoconf-$(SQLITE3_VERSION) Index: utils/installall.sh ================================================================== --- utils/installall.sh +++ utils/installall.sh @@ -19,10 +19,19 @@ echo KTYPE=$KTYPE echo You are using PREFIX=$PREFIX echo You are using proxy="$proxy" echo echo "Set additional_libpath to help find gtk or other libraries, don't forget a leading :" + +# NOTES: +# +# Centos with security setup may need to do commands such as following as root: +# +# NB// fix the paths first +# +# for a in /localdisk/chicken/4.8.0/lib/*.so;do chcon -t textrel_shlib_t $a; done + echo ADDITIONAL_LIBPATH=$ADDITIONAL_LIBPATH echo echo To use previous IUP libraries set USEOLDIUP to yes echo USEOLDIUP=$USEOLDIUP echo @@ -49,13 +58,14 @@ export KTYPE=26 else echo Using KTYPE=$KTYPE fi -export CHICKEN_VERSION=4.8.0 +export CHICKEN_VERSION=4.8.0.5 +export CHICKEN_BASEVER=4.8.0 if ! [[ -e chicken-${CHICKEN_VERSION}.tar.gz ]]; then - wget http://code.call-cc.org/releases/${CHICKEN_VERSION}/chicken-${CHICKEN_VERSION}.tar.gz + wget http://code.call-cc.org/releases/${CHICKEN_BASEVER}/chicken-${CHICKEN_VERSION}.tar.gz fi BUILDHOME=$PWD DEPLOYTARG=$BUILDHOME/deploy @@ -82,11 +92,11 @@ cd $BUILDHOME fi # Some eggs are quoted since they are reserved to Bash # for f in matchable readline apropos base64 regex-literals format "regex-case" "test" coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo tcp rpc csv-xml fmt json md5; do -$CHICKEN_INSTALL $PROX -keep-installed matchable readline apropos base64 regex-literals format "regex-case" "test" coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo tcp rpc csv-xml fmt json md5 awful http-client spiffy uri-common intarweb http-client spiffy-request-vars +$CHICKEN_INSTALL $PROX -keep-installed matchable readline apropos base64 regex-literals format "regex-case" "test" coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo tcp rpc csv-xml fmt json md5 awful http-client spiffy uri-common intarweb http-client spiffy-request-vars spiffy-directory-listing ssax sxml-serializer sxml-modifications logpro # if ! [[ -e $PREFIX/lib/chicken/6/$f.so ]];then # $CHICKEN_INSTALL $PROX $f # # $CHICKEN_INSTALL -deploy -prefix $DEPLOYTARG $PROX $f # else # echo Skipping install of egg $f as it is already installed @@ -292,10 +302,16 @@ # disabled zmq # # CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -deploy -prefix $DEPLOYTARG zmq # disabled zmq # fi # disabled zmq # fi # if zmq is in /usr/lib # disabled zmq # cd $BUILDHOME + +git clone https://bitbucket.org/DerGuteMoritz/zmq/commits/branch/3.2 zmq-3.2 +cd zmq-3.2 +chicken-install + +cd $BUILDHOME ## WEBKIT=WebKit-r131972 ## if ! [[ -e ${WEBKIT}.tar.bz2 ]] ; then ## # http://builds.nightly.webkit.org/files/trunk/src/WebKit-r131972.tar.bz2 ## wget http://builds.nightly.webkit.org/files/trunk/src/${WEBKIT}.tar.bz2 @@ -324,5 +340,8 @@ # cd "Canvas Draw-$CD_REL/chicken" # CSC_OPTIONS="-I$PREFIX/include -L$LIBPATH" $CHICKEN_INSTALL $PROX -D no-library-checks echo You may need to add $LD_LIBRARY_PATH to your LD_LIBRARY_PATH variable, a setup-chicken4x.sh echo file can be found in the current directory which should work for setting up to run chicken4x + +echo Testing iup +$PREFIX/bin/csi -b -eval '(use iup)(print "Success")' Index: utils/mk_wrapper ================================================================== --- utils/mk_wrapper +++ utils/mk_wrapper @@ -9,8 +9,8 @@ echo "export LD_LIBRARY_PATH=$LD_LIBRARY_PATH" else echo "INFO: LD_LIBRARY_PATH not set" >&2 fi -fullcmd="$prefix/bin/$cmd" +fullcmd="exec $prefix/bin/$cmd" echo "$fullcmd \"\$@\"" Index: utils/mt_ezstep ================================================================== --- utils/mt_ezstep +++ utils/mt_ezstep @@ -1,13 +1,17 @@ #!/bin/bash usage="mt_ezstep stepname prevstepname command [args ...]" if [ "$MT_CMDINFO" == "" ];then - echo "ERROR: $0 should be run within a megatest test environment" - echo "Usage: $usage" - exit + if [ -e megatest.sh ];then + source megatest.sh + else + echo "ERROR: $0 should be run within a megatest test environment" + echo "Usage: $usage" + exit + fi fi # Purpose: This is for the [ezsteps] secton in your testconfig file. # DO NOT USE IN YOUR SCRIPTS! # @@ -68,7 +72,7 @@ exitstatus=1 else exitstatus=0 fi -$MT_MEGATEST -env2file .ezsteps/${stepname} +# $MT_MEGATEST -env2file .ezsteps/${stepname} exit $exitstatus ADDED utils/mt_xterm Index: utils/mt_xterm ================================================================== --- /dev/null +++ utils/mt_xterm @@ -0,0 +1,14 @@ +#!/bin/bash + +MT_TMPDISPLAY=$DISPLAY +if [ -e megatest.sh ];then + source megatest.sh +fi +export DISPLAY=$MT_TMPDISPLAY + +if [ x"$MT_XTERM_CMD" == "x" ];then + exec xterm "$@" +else + exec $MT_XTERM_CMD +fi + ADDED utils/mtgetfile Index: utils/mtgetfile ================================================================== --- /dev/null +++ utils/mtgetfile @@ -0,0 +1,31 @@ +#!/bin/bash + +fullparams="$@" + +function findfile () { +megatest $fullparams -repl < numargs 0)(car remargs) #f)) + (scriptn (if (> numargs 1)(cadr remargs) #f)) + (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)) + (errmsg (cond + ((not key-vals) "missing -target") + ((not target) "missing -target") + ((not scriptn) "missing file name to find") + (else #f)))) + (if errmsg + (begin + (print "THEPATH: Missing required switch: " errmsg) + (print "THEPATH: Usage: mtgetfile -target target scriptname [searchpath]") + (exit))) + (print "THEPATH: key-vals=" key-vals " path=" path " scriptn=" scriptn)) +EOF +} + +findfile | egrep "^THEPATH: " | sed -e 's/^THEPATH: //' ADDED utils/mtrunscript Index: utils/mtrunscript ================================================================== --- /dev/null +++ utils/mtrunscript @@ -0,0 +1,203 @@ +#!/usr/bin/env bash + +# Copyright 2012, 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. +# +# VERSION: + +# set -e +# set -u +# set -x + +# Usage: mtrunscript scriptname params +# +# Look for scriptname in this order +# +# $MT_TEST_RUN_DIR/scripts => $MT_RUN_AREA_HOME/scripts +# => $MT_RUN_AREA_HOME/../scripts => $PATH +# +# In each area look for the script with the name like this: +# +# scriptname_$TARGET[1]_$TARGET[2]_...$TARGET[n]_$MT_TESTNAME_$MT_ITEMPATH(s#/#_) +# + +echo "NOT IMPLEMENTED YET!" +exit + +case "x$1" in + # repo + xrep*) + fsl_dbinit + case "x$2" in + xhelp) + fsl_help + exit + ;; + + # repo get + xget) + hook_pre_repo_get "$@" + fsl_repo_get $3 $4 + hook_post_repo_get "$@" + exit + ;; + + xaddarea) + fsl_add_area $3 $4 + exit + ;; + + xdroparea) + fsl_remove_area $3 + exit + ;; + + xdbinit) + fsl_dbinit + exit + ;; + + xls|xlist) + shift + shift + fsl_ls "$@" + exit + ;; + + xcreate) + hook_pre_repo_create + fsl_repo_create $3 $4 $5 $6 + hook_post_repo_create + exit + ;; + + ximport) + fsl_repo_import $3 $4 $5 + exit + ;; + + *) + fsl_help + exit + esac + ;; + + "xmv") + if [ "x$2" = "x-f" ];then + # echo "Force mode" + fsl_force=1 + shift + shift + # change this to exec when happy! + # fsl mv -f f1 [f2 f3...] targ + fsl_mv "$@" + # args=("$@") + # echo $@ -> echo $@ + # use $# variable to print out + # number of arguments passed to the bash script + # echo Number of arguments passed: $# -> echo Number of arguments passed: $# + exit + else + # echo No force + shift + fsl_mv "$@" + exit + fi + ;; + + xtim*) + fsl_fork_find + shift + $FOSSILEXE timeline "$@" | sed -e :a -e '$!N;s/\n / /;ta' -e 'P;D' + exit + ;; + + # leaves output needs to be niceified, no need for a function + xle*) + fsl_fork_find + shift + $FOSSILEXE leaves "$@" | sed -e :a -e '$!N;s/\n / /;ta' -e 'P;D' + exit + ;; + + # changes and status + xcha* | xstat*) + fsl_fork_find + fsl_conflicts "$@" + rm -f $CONFLICT_FLAG_FILE + exit + ;; + + # ci/commit + xci | xcom*) + fsl_conflicts changes "$@" + trap "$FOSSILUTIL releaselock $FSLUTIL_PARAMS" SIGINT + # Set up for remote locking + if [ ! -e $CONFLICT_FLAG_FILE ]; then + rm -f $CONFLICT_FLAG_FILE + read -p "ERROR: Conflicts detected. Type \"yes\" to continue: " -e ANSWER + if [ $ANSWER = "yes" ]; then + $FOSSILUTIL commitlock $FSLUTIL_PARAMS + $FOSSILEXE "$@" + $FOSSILUTIL releaselock $FSLUTIL_PARAMS + else + exit 1 + fi + else + $FOSSILUTIL commitlock $FSLUTIL_PARAMS + $FOSSILEXE "$@" + $FOSSILUTIL releaselock $FSLUTIL_PARAMS + fi + exit + ;; + + xtag) + case "x$2" in + xadd | xcancel) + $FOSSILEXE "$@" + $FOSSILEXE sync + exit + ;; + + *) + $FOSSILEXE "$@" + exit + ;; + esac + ;; + + # add mention of repo to help + "xhelp") + if [ $# -gt 1 ]; then + case "x$2" in + xrepo) + fsl_help + exit + ;; + + *) + $FOSSILEXE "$@" + ;; + + esac + else + $FOSSILEXE help | sed -e 's/sync/sync repo/' + fi + exit + ;; + + xup* | xco) + fsl_fork_find + $FOSSILEXE "$@" + exit + ;; + +esac + +exec $FOSSILEXE "$@" ADDED utils/nbload Index: utils/nbload ================================================================== --- /dev/null +++ utils/nbload @@ -0,0 +1,24 @@ +#!/bin/bash + +# load=`uptime|awk '{print $10}'|cut -d, -f1` +load=`uptime|perl -pe 's/.*: (\d+.\d+),.*/$1/'` +if which cpucheck > /dev/null;then + numcpu=`cpucheck|tail -1|awk '{print $6}'` +else + numcpu=`lscpu|grep "CPU.s.:"|awk '{print $2}'` +fi + +lperc=`echo "100 * $load / $numcpu"|bc` +if [[ "x$MAX_ALLOWED_LOAD" == "x" ]]; then + max_load=50 +else + max_load=$MAX_ALLOWED_LOAD +fi +if [[ $lperc -lt $max_load ]];then + echo "$@" | at now + 0 minutes +elif [[ "x$NBLAUNCHER" == "x" ]];then + echo "nbfind $@" | at now + 2 minutes +else + $NBLAUNCHER "$@" +fi + ADDED utils/revtagfsl.scm Index: utils/revtagfsl.scm ================================================================== --- /dev/null +++ utils/revtagfsl.scm @@ -0,0 +1,78 @@ + +;; 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 json regex posix) +(use srfi-69) + +;; Add tags with node nums: trunk(12) +(define fname #f) + +(let ((parms (argv))) + (if (> (length parms) 1) + (set! fname (cadr parms)))) + +(if (not (and fname (file-exists? fname))) + (begin + (print "Usage: revtagfsl /path/to/fossilfile.fossil") + (exit 1))) + +(define (revtag:get-timeline fslfname limit) + (let* ((cmd (if (file-exists? fslfname) + (conc "fossil json timeline checkin --limit " limit " -R " fslfname) + (conc "fossil json timeline checkin --limit " limit)))) + (with-input-from-pipe cmd json-read))) + + +(define mt (vector->list (revtag:get-timeline fname 10000))) +(define tl (map vector->list (cdr (assoc "timeline" (vector->list (cdr (assoc "payload" mt))))))) + +(define tagged (make-hash-table)) +(define usedtags (make-hash-table)) + +(for-each (lambda (node) + (let* ((uuid (cdr (assoc "uuid" node))) + (tags-dat (assoc "tags" node)) + (tags (if tags-dat (cdr tags-dat) '()))) + (for-each (lambda (tag) + (hash-table-set! usedtags tag #t)) + tags))) + tl) + +(define ord-tl (sort tl (lambda (a b)(let ((ta (cdr (assoc "timestamp" a)))(tb (cdr (assoc "timestamp" b))))(< ta tb))))) + +(define (make-tag branch) + (let* ((nextnum (+ 1 (hash-table-ref/default tagged branch 0)))) + (hash-table-set! tagged branch nextnum) + (conc branch "-r" nextnum))) + +(define (get-next-revtag branch) + (let loop ((tag (make-tag branch))) + (if (hash-table-ref/default usedtags tag #f) + (loop (make-tag branch)) + tag))) + +(print "branch, uuid, newtag") + +(let loop ((hed (car ord-tl)) + (tal (cdr ord-tl))) + (let* ((tags (let ((t (assoc "tags" hed))) + (if t (cdr t) '()))) + (uuid (cdr (assoc "uuid" hed))) + (branch (if (null? tags) "nobranch" (car tags))) + (tagpatt (regexp (conc "^" branch "-r\\d+$"))) + (currtag (filter (lambda (x)(string-match tagpatt x)) tags))) + (if (and (not (equal? branch "nobranch")) + (null? currtag)) + (let ((newtag (get-next-revtag branch))) + (print branch ", " uuid ", " newtag) + (system (conc "fossil tag add \"" newtag "\" " uuid " -R " fname)) ;; ?--raw? ?--propagate? TAGNAME CHECK-IN ?VALUE? + (hash-table-set! usedtags currtag #t))) + (if (not (null? tal)) + (loop (car tal)(cdr tal))))) Index: zmq-transport.scm ================================================================== --- zmq-transport.scm +++ zmq-transport.scm @@ -54,11 +54,11 @@ (define (zmq-transport:make-server-url hostport) (if (not hostport) #f (conc "tcp://" (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 ;;======================================================================