Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -228,15 +228,17 @@ # base64 dot-locking \ # csv-xml z3 # "(define (toplevel-command . a) #f)" +# if egrep 'version.*3.0' $(shell dirname $(shell dirname $(shell which csi)))/lib/chicken/7/readline.setup-info;then \ + readline-fix.scm : - if egrep 'version.*3.0' $(shell dirname $(shell dirname $(shell which csi)))/lib/chicken/7/readline.setup-info;then \ - echo "(use-legacy-bindings)" > readline-fix.scm; \ + if [[ $(shell chicken-status | grep readline | awk '{print $4}' | cut -d. -f1) -gt 3 ]];then \ + echo "(define *use-new-readline* #f)" > readline-fix.scm; \ else \ - echo "" > readline-fix.scm;\ + echo "(define *use-new-readline* #t)" > readline-fix.scm;\ fi altdb.scm : echo ";; optional alternate db setup" > altdb.scm echo "(define *available-db* (make-hash-table))" >> altdb.scm Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -152,28 +152,46 @@ (define (common:version-changed?) (not (equal? (common:get-last-run-version) (common:version-signature)))) +;; Move me elsewhere ... +;; +(define (common:cleanup-db) + (db:multi-db-sync + #f ;; do all run-ids + ;; 'new2old + 'killservers + 'dejunk + ;; 'adj-testids + ;; 'old2new + 'new2old) + (if (common:version-changed?) + (common:set-last-run-version))) + (define (common:exit-on-version-changed) (if (common:version-changed?) - (begin + (let ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config"))) (debug:print 0 #f "ERROR: Version mismatch!\n" " expected: " (common:version-signature) "\n" - " got: " (common:get-last-run-version) "\n" - " to switch versions you can run: \"megatest -cleanup-db\"") - ;; megatest -cleanup-db IS NOT correcting the dbver. Let's force it for now. - ;; Matt: please review this! - (db:multi-db-sync - #f - 'killservers - 'dejunk - 'new2old) - (rmt:set-var "MEGATEST_VERSION" (common:version-signature)) - - (exit 1)))) + " got: " (common:get-last-run-version)) + (if (and (file-exists? mtconf) + (eq? (current-user-id)(file-owner mtconf))) ;; safe to run -cleanup-db + (begin + (debug:print 0 #f " I see you are the owner of megatest.config, attempting to cleanup and reset to new version") + (handle-exceptions + exn + (begin + (debug:print 0 #f "Failed to switch versions.") + (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) + (print-call-chain (current-error-port)) + (exit 1)) + (common:cleanup-db))) + (begin + (debug:print 0 #f " to switch versions you can run: \"megatest -cleanup-db\"") + (exit 1)))))) ;;====================================================================== ;; S P A R S E A R R A Y S ;;====================================================================== Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -388,12 +388,11 @@ (db:get-runs (d:alldat-dblocal data) runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) (d:alldat-start-run-offset data) keypatts))) (header (db:get-header allruns)) (runs (db:get-rows allruns)) (result '()) - (maxtests 0) -) + (maxtests 0)) ;; ;; 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")) @@ -1604,11 +1603,11 @@ (iup:attribute-set! show "BGCOLOR" nonsel-color) (mark-for-update)))) (set! show (iup:button "Show" #:expand "YES" #:action (lambda (obj) - (d:alldat-hide-not-hide-set! data (not (d:alldat-hide-not-hide data))) + (d:alldat-hide-not-hide-set! data #f) ;; (not (d:alldat-hide-not-hide data))) (iup:attribute-set! show "BGCOLOR" sel-color) (iup:attribute-set! hide "BGCOLOR" nonsel-color) (mark-for-update)))) (iup:attribute-set! hide "BGCOLOR" sel-color) (iup:attribute-set! show "BGCOLOR" nonsel-color) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -2197,20 +2197,33 @@ (if not-in " NOT IN ('" " IN ('") ) (string-intersperse statuses "','") "')"))) + (interim-qry (conc " AND " (if not-in "NOT " "") "( state='COMPLETED' " (if statuses-qry (conc " AND " statuses-qry " ) ") " ) ") + (if states-qry + (conc (if not-in " AND " " OR ") states-qry ) ;; " ) ") + ""))) (states-statuses-qry (cond ((and states-qry statuses-qry) (case mode - ((dashboard)(conc " AND " (if not-in "NOT " "") "( ( state='COMPLETED' AND " statuses-qry " ) OR " states-qry " ) ")) + ((dashboard) + (if not-in + (conc " AND (state='COMPLETED' AND status NOT IN ('" (string-intersperse statuses "','") "')) " + " OR (state != 'COMPLETED' AND state NOT IN ('" (string-intersperse states "','") "')) ") + (conc " AND (state='COMPLETED' AND status IN ('" (string-intersperse statuses "','") "')) " + " OR (state NOT IN ('COMPLETED','DELETED') AND state IN ('" (string-intersperse states "','") "')) "))) (else (conc " AND ( " states-qry " AND " statuses-qry " ) ")))) (states-qry - (conc " AND " states-qry)) + (case mode + ((dashboard) (conc " AND " (if not-in "NOT " "") " state IN ('" (string-intersperse states "','") "') ")) ;; interim-qry) + (else (conc " AND " states-qry)))) (statuses-qry - (conc " AND " statuses-qry)) + (case mode + ((dashboard) (conc " AND " (if not-in "NOT " "") " status IN ('" (string-intersperse statuses "','") "') ")) ;; interim-qry) + (else (conc " AND " statuses-qry)))) (else ""))) (tests-match-qry (tests:match->sqlqry testpatt)) (qry (conc "SELECT " qryvalstr " FROM tests WHERE run_id=? " (if last-update " " " AND state != 'DELETED' ") ;; if using last-update we want deleted tests? @@ -2287,17 +2300,10 @@ test-id))) res)) ;; get a useful subset of the tests data (used in dashboard ;; use db:mintest-get-{id ,run_id,testname ...} -;; -(define (db:get-tests-for-runs-mindata dbstruct run-ids testpatt states statuses not-in) - (debug:print 0 #f "ERROR: BROKN!") - ;; (db:get-tests-for-runs dbstruct run-ids testpatt states statuses not-in: not-in qryvals: "id,run_id,testname,state,status,event_time,item_path")) -) - -;; get a useful subset of the tests data (used in dashboard ;; (define (db:get-tests-for-run-mindata dbstruct run-id testpatt states statuses not-in) (db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f "id,run_id,testname,state,status,event_time,item_path" #f)) ;; do not use. Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -1826,23 +1826,11 @@ (begin (if (not (launch:setup)) (begin (debug:print 0 #f "Failed to setup, exiting") (exit 1))) - ;; keep this one local - ;; (open-run-close db:clean-up #f) - (db:multi-db-sync - #f ;; do all run-ids - ;; 'new2old - 'killservers - 'dejunk - ;; 'adj-testids - ;; 'old2new - 'new2old - ) - (if (common:version-changed?) - (common:set-last-run-version)) + (common:cleanup-db) (set! *didsomething* #t))) (if (args:get-arg "-mark-incompletes") (begin (if (not (launch:setup)) @@ -1900,14 +1888,19 @@ ;; (import csi) (import readline) (import apropos) ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ... (include "readline-fix.scm") - (gnu-history-install-file-manager - (string-append - (or (get-environment-variable "HOME") ".") "/.megatest_history")) - (current-input-port (make-gnu-readline-port "megatest> ")) + (if *use-new-readline* + (begin + (install-history-file (get-environment-variable "HOME") ".megatest_history") ;; [homedir] [filename] [nlines]) + (current-input-port (make-readline-port "megatest> "))) + (begin + (gnu-history-install-file-manager + (string-append + (or (get-environment-variable "HOME") ".") "/.megatest_history")) + (current-input-port (make-gnu-readline-port "megatest> ")))) (if (args:get-arg "-repl") (repl) (load (args:get-arg "-load"))) (db:close-all dbstruct)) (exit))) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -390,11 +390,11 @@ (define (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode) (if (number? run-id) (rmt:send-receive 'get-tests-for-run run-id (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode)) (begin - (debug:print "ERROR: rmt:get-tests-for-run called with bad run-id=" run-id) + (debug:print 0 #f "ERROR: rmt:get-tests-for-run called with bad run-id=" run-id) (print-call-chain (current-error-port)) '()))) ;; get stuff via synchash (define (rmt:synchash-get run-id proc synckey keynum params) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -1326,11 +1326,11 @@ (debug:print 0 #f "ERROR: failed to get test record for test-id " test-id)) (set! test-id (db:test-get-id testdat)) (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?") + (debug:print 0 #f "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)) Index: sretrieve.scm ================================================================== --- sretrieve.scm +++ sretrieve.scm @@ -56,10 +56,11 @@ ls : list contents of target area get : retrieve data for release -m \"message\" : why retrieved? cp : copy file to current directory log : get listing of recent downloads + shell : start a shell-like interface Part of the Megatest tool suite. Learn more at http://www.kiatoa.com/fossils/megatest Version: " megatest-fossil-hash)) ;; " @@ -411,10 +412,55 @@ (define (sretrieve:stderr-print . args) (with-output-to-port (current-error-port) (lambda () (apply print args)))) + +;;====================================================================== +;; SHELL +;;====================================================================== + +(define (toplevel-command . args) #f) +(define (sretrieve:shell) + (use readline) + (let* ((path '()) + (prompt "> ") + (top-areas '("mrwellan" "pjhatwal" "bjbarcla" "ritikaag" "jmoon18")) + (iport (make-readline-port prompt))) + (install-history-file) ;; [homedir] [filename] [nlines]) + (with-input-from-port iport + (lambda () + (let loop ((inl (read-line))) + (if (not (or (eof-object? inl) + (equal? inl "exit"))) + (let* ((parts (string-split inl)) + (cmd (if (null? parts) #f (car parts)))) + (if (not cmd) + (loop (read-line)) + (case (string->symbol cmd) + ((cd) + (if (> (length parts) 1) ;; have a parameter + (set! path (append path (string-split (cadr parts)))) ;; not correct for relative paths + (set! path '()))) + ((ls) + (let* ((thepath (if (> (length parts) 1) ;; have a parameter + (cdr parts) + path)) + (plen (length thepath))) + (cond + ((null? thepath) + (print (string-intersperse top-areas " "))) + ((and (< plen 2) + (member (car thepath) top-areas)) + (system (conc "ls /p/fdk/gwa/" (car thepath)))) + (else ;; have a long path + ;; check for access rights here + (system (conc "ls /p/fdk/gwa/" (string-intersperse thepath "/"))))))) + (else + (print "Got command: " inl)))) + (loop (read-line))))))))) + ;;====================================================================== ;; MAIN ;;====================================================================== @@ -558,14 +604,16 @@ (print "Logs : ") (query (for-each-row (lambda (row) (apply print (intersperse row " | ")))) (sql db "SELECT * FROM actions"))))) + ((shell) + (sretrieve:shell)) (else (print "ERROR: Unrecognised command. Try \"sretrieve help\"")))) ;; multi-word commands ((null? rema)(print sretrieve:help)) ((>= (length rema) 2) (apply sretrieve:process-action configdat (car rema)(cdr rema))) (else (debug:print 0 #f "ERROR: Unrecognised command. Try \"sretrieve help\""))))) (main) Index: tests/unittests/basicserver.scm ================================================================== --- tests/unittests/basicserver.scm +++ tests/unittests/basicserver.scm @@ -7,11 +7,11 @@ ;; ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0) (delete-file* "logs/1.log") (define run-id 1) -(test "setup for run" #t (begin (launch:setup-for-run) +(test "setup for run" #t (begin (launch:setup) (string? (getenv "MT_RUN_AREA_HOME")))) ;; NON Server tests go here (test #f #f (db:dbdat-get-path *db*)) @@ -179,11 +179,11 @@ ;; ;; (test "launch server" #t (let ((pid (process-fork (lambda () ;; ;; ;; (daemon:ize) ;; ;; (server:launch 'http))))) ;; ;; (set! server-pid pid) ;; ;; (number? pid))) -;; (system "../../bin/megatest -server - -debug 22 > server.log 2> server.log &") +;; (system "../../bin/megatest -server - -debugbcom 22 > server.log 2> server.log &") ;; ;; (let loop ((n 10)) ;; (thread-sleep! 1) ;; need to wait for server to start. ;; (let ((res (open-run-close tasks:get-best-server tasks:open-db))) ;; (print "tasks:get-best-server returned " res) Index: tests/unittests/tests.scm ================================================================== --- tests/unittests/tests.scm +++ tests/unittests/tests.scm @@ -1,13 +1,80 @@ -;;====================================================================== -;; itemwait, itemmatch - -(db:compare-itempaths ref-item-path item-path itemmap) - -;; prereqs-not-met - -(rmt:get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap)) - - (fails (runs:calc-fails prereqs-not-met)) - (prereq-fails (runs:calc-prereq-fail prereqs-not-met)) - (non-completed (runs:calc-not-completed prereqs-not-met)) - (runnables (runs:calc-runnable prereqs-not-met))) +;; ;;====================================================================== +;; ;; itemwait, itemmatch +;; +;; (db:compare-itempaths ref-item-path item-path itemmap) +;; +;; ;; prereqs-not-met +;; +;; (rmt:get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap)) +;; +;; (fails (runs:calc-fails prereqs-not-met)) +;; (prereq-fails (runs:calc-prereq-fail prereqs-not-met)) +;; (non-completed (runs:calc-not-completed prereqs-not-met)) +;; (runnables (runs:calc-runnable prereqs-not-met))) +;; +;; +;; + +(define user (current-user-name)) +(define runname "mytestrun") +(define keys (rmt:get-keys)) +(define runinfo #f) +(define keyvals '(("SYSTEM" "abc")("RELEASE" "def"))) +(define header (list "SYSTEM" "RELEASE" "id" "runname" "state" "status" "owner" "event_time")) +(define run-id 1) + +;; Create a run +(test #f 1 (rmt:register-run keyvals runname "new" "n/a" user)) +(test #f #t (rmt:general-call 'register-test run-id run-id "test-one" "")) +(test #f #t (rmt:general-call 'register-test run-id run-id "test-two" "")) +(test #f #t (rmt:general-call 'register-test run-id run-id "test-three" "")) +(test #f #t (rmt:general-call 'register-test run-id run-id "test-four" "")) + +(rmt:test-set-state-status-by-id run-id (rmt:get-test-id run-id "test-one" "") "COMPLETED" "FAIL" "") +(rmt:test-set-state-status-by-id run-id (rmt:get-test-id run-id "test-two" "") "COMPLETED" "PASS" "") +(rmt:test-set-state-status-by-id run-id (rmt:get-test-id run-id "test-three" "") "RUNNING" "n/a" "") +(rmt:test-set-state-status-by-id run-id (rmt:get-test-id run-id "test-four" "") "COMPLETED" "WARN" "") + +(print "MODE=not in") +(test #f '() + (filter + (lambda (y) + (equal? y "FAIL")) ;; any FAIL in the output list? + (map + (lambda (x)(vector-ref x 4)) + (rmt:get-tests-for-run run-id "%/%" '() '("FAIL") #f #f #t 'event_time "DESC" 'shortlist 0 'dashboard)))) + +(print "MODE=in") +(test #f '("FAIL") + (map + (lambda (x)(vector-ref x 4)) + (rmt:get-tests-for-run run-id "%/%" '() '("FAIL") #f #f #f 'event_time "DESC" 'shortlist 0 'dashboard))) +(set! *verbosity* 1) + +(print "MODE=in, state in RUNNING") +;; (set! *verbosity* 8) +(test #f '("RUNNING") + (map + (lambda (x)(vector-ref x 3)) + (rmt:get-tests-for-run run-id "%/%" '("RUNNING") '() #f #f #f 'event_time "DESC" 'shortlist 0 'dashboard))) +(set! *verbosity* 1) + +(print "MODE=in, state in RUNNING and status IN WARN") +;; (set! *verbosity* 8) +(test #f '(("RUNNING" . "n/a") ("COMPLETED" . "WARN")) + (map + (lambda (x) + (cons (vector-ref x 3)(vector-ref x 4))) + (rmt:get-tests-for-run run-id "%/%" '("RUNNING") '("WARN") #f #f #f 'event_time "DESC" 'shortlist 0 'dashboard))) +(set! *verbosity* 1) + +(print "MODE=not in, state in RUNNING and status IN WARN") +(set! *verbosity* 8) +(test #f '(("RUNNING" . "n/a") ("COMPLETED" . "WARN")) + (map + (lambda (x) + (cons (vector-ref x 3)(vector-ref x 4))) + (rmt:get-tests-for-run run-id "%/%" '("RUNNING") '("WARN") #f #f #t 'event_time "DESC" 'shortlist 0 'dashboard))) +(set! *verbosity* 1) + +(exit)