Index: .fossil-settings/ignore-glob ================================================================== --- .fossil-settings/ignore-glob +++ .fossil-settings/ignore-glob @@ -1,5 +1,6 @@ +altdb.scm utils/build/* *~ *.o bin/* megatest.db Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -61,10 +61,11 @@ db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm tests.o tasks.o dashboard-tasks.o : task_records.scm runs.o : test_records.scm megatest.o : megatest-fossil-hash.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm rpc-transport.scm +common_records.scm : altdb.scm # Temporary while transitioning to new routine # runs.o : run-tests-queue-classic.scm run-tests-queue-new.scm megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm @@ -164,11 +165,11 @@ $(MTQA_FOSSIL) : fossil clone https://www.kiatoa.com/fossils/megatest_qa $(MTQA_FOSSIL) clean : - rm -f $(OFILES) $(GOFILES) megatest dboard dboard.o megatest.o dashboard.o + rm -f $(OFILES) $(GOFILES) megatest dboard dboard.o megatest.o dashboard.o megatest-fossil-hash.* altdb.scm # Deploy section (not complete yet) # $(DEPLOYHELPERS) : utils/mt_* $(INSTALL) $< $@ @@ -233,8 +234,18 @@ 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; \ else \ echo "" > readline-fix.scm;\ fi + +altdb.scm : + echo ";; optional alternate db setup" > altdb.scm + echo "(define *available-db* (make-hash-table))" >> altdb.scm + if csi -ne '(use mysql-client)';then \ + echo "(use mysql-client)(hash-table-set! *available-db* 'mysql #t)" >> altdb.scm; \ + fi + if csi -ne '(use postgresql)';then \ + echo "(use postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\ + fi portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o daemon.o dashboard-tests.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o nmsg-transport.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o csc portlogger-example.scm api.o archive.o client.o common.o configf.o daemon.o dashboard-tests.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o nmsg-transport.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -47,10 +47,11 @@ get-prev-run-ids get-run-ids-matching-target get-runs-by-patt get-steps-data get-steps-for-test + read-test-data login testmeta-get-record have-incompletes? synchash-get )) @@ -226,10 +227,13 @@ ;; STEPS ((get-steps-data) (apply db:get-steps-data dbstruct params)) ((get-steps-for-test) (apply db:get-steps-for-test dbstruct params)) + ;; TEST DATA + ((read-test-data) (apply db:read-test-data dbstruct params)) + ;; MISC ((have-incompletes?) (apply db:have-incompletes? dbstruct params)) ((login) (apply db:login dbstruct params)) ((general-call) (let ((stmtname (car params)) (run-id (cadr params)) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -129,10 +129,78 @@ ;; Generic string database (define sdb:qry #f) ;; (make-sdb:qry)) ;; 'init #f) ;; Generic path database (define *fdb* #f) + +;;====================================================================== +;; V E R S I O N +;;====================================================================== + +(define (common:get-full-version) + (conc megatest-version "-" megatest-fossil-hash)) + +(define (common:version-signature) + (conc megatest-version "-" (substring megatest-fossil-hash 0 4))) + +;; from metadat lookup MEGATEST_VERSION +;; +(define (common:get-last-run-version) + (rmt:get-var "MEGATEST_VERSION")) + +(define (common:set-last-run-version) + (rmt:set-var "MEGATEST_VERSION" (common:version-signature))) + +(define (common:version-changed?) + (not (equal? (common:get-last-run-version) + (common:version-signature)))) + +(define (common:exit-on-version-changed) + (if (common:version-changed?) + (begin + (debug:print 0 + "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)))) + +;;====================================================================== +;; S P A R S E A R R A Y S +;;====================================================================== + +(define (make-sparse-array) + (let ((a (make-sparse-vector))) + (sparse-vector-set! a 0 (make-sparse-vector)) + a)) + +(define (sparse-array? a) + (and (sparse-vector? a) + (sparse-vector? (sparse-vector-ref a 0)))) + +(define (sparse-array-ref a x y) + (let ((row (sparse-vector-ref a x))) + (if row + (sparse-vector-ref row y) + #f))) + +(define (sparse-array-set! a x y val) + (let ((row (sparse-vector-ref a x))) + (if row + (sparse-vector-set! row y val) + (let ((new-row (make-sparse-vector))) + (sparse-vector-set! a x new-row) + (sparse-vector-set! new-row y val))))) ;;====================================================================== ;; L O C K E R S A N D B L O C K E R S ;;====================================================================== @@ -334,11 +402,11 @@ ;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway (exit)) (set-signal-handler! signal/int std-signal-handler) ;; ^C (set-signal-handler! signal/term std-signal-handler) -(set-signal-handler! signal/stop std-signal-handler) ;; ^Z +;; (set-signal-handler! signal/stop std-signal-handler) ;; ^Z NO, do NOT handle ^Z! ;;====================================================================== ;; M I S C U T I L S ;;====================================================================== @@ -362,13 +430,10 @@ ((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) @@ -525,11 +590,11 @@ (cdr tal)) (max hed max-val)))) ;;====================================================================== -;; Munge data into nice forms +;; M U N G E D A T A I N T O N I C E F O R M S ;;====================================================================== ;; Generate an index for a sparse list of key values ;; ( (rowname1 colname1 val1)(rowname2 colname2 val2) ) ;; @@ -568,18 +633,35 @@ (if (> curr-rownum rownum) curr-rownum rownum) (if (> curr-colnum colnum) curr-colnum colnum) )))))) ;;====================================================================== -;; System stuff +;; S Y S T E M S T U F F ;;====================================================================== ;; return a nice clean pathname made absolute -(define (nice-path dir) - (normalize-pathname (if (absolute-pathname? dir) - dir - (conc (current-directory) "/" dir)))) +(define (common:nice-path dir) + (let ((match (string-match "^(~[^\\/]*)(\\/.*|)$" dir))) + (if match ;; using ~ for home? + (common:nice-path (conc (common:read-link-f (cadr match)) "/" (caddr match))) + (normalize-pathname (if (absolute-pathname? dir) + dir + (conc (current-directory) "/" dir)))))) + +;; make "nice-path" available in config files and the repl +(define nice-path common:nice-path) + +(define (common:read-link-f path) + (handle-exceptions + exn + (begin + (debug:print 0 "ERROR: command \"/bin/readlink -f " path "\" failed.") + path) ;; just give up + (with-input-from-pipe + (conc "/bin/readlink -f " path) + (lambda () + (read-line))))) (define (get-cpu-load) (car (common:get-cpu-load))) ;; (let* ((load-res (process:cmd-run->list "uptime")) ;; (load-rx (regexp "load average:\\s+(\\d+)")) @@ -733,19 +815,19 @@ (for-each (lambda (disk-num) (let* ((dirpath (cadr (assoc disk-num disks))) (freespc (cond ((not (directory? dirpath)) - (if (common:low-noise-print 50 "disks not a dir " disk-num) + (if (common:low-noise-print 300 "disks not a dir " disk-num) (debug:print 0 "WARNING: disk " disk-num " at path \"" dirpath "\" is not a directory - ignoring it.")) -1) ((not (file-write-access? dirpath)) - (if (common:low-noise-print 50 "disks not writeable " disk-num) + (if (common:low-noise-print 300 "disks not writeable " disk-num) (debug:print 0 "WARNING: disk " disk-num " at path \"" dirpath "\" is not writeable - ignoring it.")) -1) ((not (eq? (string-ref dirpath 0) #\/)) - (if (common:low-noise-print 50 "disks not a proper path " disk-num) + (if (common:low-noise-print 300 "disks not a proper path " disk-num) (debug:print 0 "WARNING: disk " disk-num " at path \"" dirpath "\" is not a fully qualified path - ignoring it.")) -1) (else (get-df dirpath))))) (if (> freespc bestsize) @@ -838,11 +920,11 @@ (lambda (var val) (setenv var val))) vars)) ;;====================================================================== -;; time and date nice to have stuff +;; T I M E A N D D A T E ;;====================================================================== (define (seconds->hr-min-sec secs) (let* ((hrs (quotient secs 3600)) (min (quotient (- secs (* hrs 3600)) 60)) @@ -881,11 +963,11 @@ ((7 8 9) 3) ((10 11 12) 4) (else #f))) ;;====================================================================== -;; Colors +;; C O L O R S ;;====================================================================== (define (common:name->iup-color name) (case (string->symbol (string-downcase name)) ((red) "223 33 49") @@ -1130,11 +1212,11 @@ (tal (cdr launchers))) (let ((patt (car hed)) (host-type (cadr hed))) (if (tests:match patt testname itempath) (begin - (debug:print-info 0 "Have flexi-launcher match for " testname "/" itempath " = " host-type) + (debug:print-info 2 "Have flexi-launcher match for " testname "/" itempath " = " host-type) (let ((launcher (configf:lookup configdat "host-types" host-type))) (if launcher launcher (begin (debug:print-info 0 "WARNING: no launcher found for host-type " host-type) Index: common_records.scm ================================================================== --- common_records.scm +++ common_records.scm @@ -8,10 +8,12 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== ;; (use trace) + +(include "altdb.scm") ;; Some of these routines use: ;; ;; http://www.cs.toronto.edu/~gfb/scheme/simple-macros.html ;; @@ -94,17 +96,17 @@ (define (debug:print-info n . params) (if (debug:debug-mode n) (with-output-to-port (current-error-port) (lambda () - (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params)))) - (if *logging* - (db:log-event res) - ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res) - (apply print "INFO: (" n ") " params) ;; res) - )))))) + (if *logging* + (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params)))) + (db:log-event res)) + ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; 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 @@ -218,11 +218,11 @@ (hash-table-set! settings setting val) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))) (configf:include-rx ( x include-file ) (let* ((curr-conf-dir (pathname-directory path)) (full-conf (if (absolute-pathname? include-file) include-file - (nice-path + (common:nice-path (conc (if curr-conf-dir curr-conf-dir ".") "/" include-file))))) (if (file-exists? full-conf) Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -441,11 +441,11 @@ (logfile "/this/dir/better/not/exist") (rundir (if testdat (db:test-get-rundir testdat) logfile)) ;; (testdat-path (conc rundir "/testdat.db")) ;; this gets recalculated until found - (teststeps (if testdat (tests:get-compressed-steps #f run-id test-id) '())) + (teststeps (if testdat (tests:get-compressed-steps run-id test-id) '())) (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ...")) (testname (if testdat (db:test-get-testname testdat) "n/a")) ;; (tests:get-testconfig testdat testname 'return-procs)) (testmeta (if testdat (let ((tm (rmt:testmeta-get-record testname))) @@ -517,11 +517,11 @@ (rmt:get-test-info-by-id run-id test-id ))))) ;; (debug:print-info 0 "need-update= " need-update " curr-mod-time = " curr-mod-time) (cond ((and need-update newtestdat) (set! testdat newtestdat) - (set! teststeps (tests:get-compressed-steps #f run-id test-id)) + (set! teststeps (tests:get-compressed-steps run-id test-id)) (set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat))) (set! rundir ;; (filedb:get-path *fdb* (db:test-get-rundir testdat)) ;; ) (set! testfullname (db:test-get-fullname testdat)) ;; (debug:print 0 "INFO: teststeps=" (intersperse teststeps "\n ")) @@ -611,10 +611,11 @@ command-text-box "VALUE" (conc "megatest -target " keystring " -runname " runname " -run -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) + " -clean-cache" )))) (remove-test (lambda (x) (iup:attribute-set! command-text-box "VALUE" (conc "megatest -remove-runs -target " keystring " -runname " runname @@ -629,10 +630,11 @@ item-path)) ";megatest -target " keystring " -runname " runname " -run -preclean -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) + " -clean-cache" ))) (common:without-vars (conc (dtests:get-pre-command) cmd (dtests:get-post-command)) @@ -691,13 +693,13 @@ ;; Replace here with matrix (let ((steps-matrix (iup:matrix #:font "Courier New, -8" #:expand "YES" #:scrollbar "YES" - #:numcol 6 - #:numlin 30 - #:numcol-visible 6 + #:numcol 7 + #:numlin 100 + #:numcol-visible 7 #:numlin-visible 5 #:click-cb (lambda (obj lin col status) ;; (if (equal? col 6) (let* ((mtrx-rc (conc lin ":" 6)) (fname (iup:attribute obj mtrx-rc))) ;; col)))) @@ -718,10 +720,11 @@ (iup:attribute-set! steps-matrix "WIDTH3" "50") (iup:attribute-set! steps-matrix "0:4" "Status") (iup:attribute-set! steps-matrix "WIDTH4" "50") (iup:attribute-set! steps-matrix "0:5" "Duration") (iup:attribute-set! steps-matrix "0:6" "Log File") + (iup:attribute-set! steps-matrix "0:7" "Comment") (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) @@ -740,11 +743,11 @@ #:font "Courier New, -10" #:size "100x100"))) (hash-table-set! widgets "Test Data" (lambda (testdat) ;; (let* ((currval (iup:attribute test-data "VALUE")) ;; "TITLE")) - (fmtstr "~10a~10a~10a~10a~7a~7a~6a~6a~a") ;; category,variable,value,expected,tol,units,type,comment + (fmtstr "~10a~10a~10a~10a~7a~7a~6a~7a~a") ;; category,variable,value,expected,tol,units,type,comment (newval (string-intersperse (append (list (format #f fmtstr "Category" "Variable" "Value" "Expected" "Tol" "Status" "Units" "Type" "Comment") (format #f fmtstr "========" "========" "=====" "========" "===" "======" "=====" "====" "=======")) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -148,35 +148,10 @@ curr-tab-num: 0 updaters: (make-hash-table) filters-changed: #f )) -;; simple two dimentional sparse array -;; -(define (make-sparse-array) - (let ((a (make-sparse-vector))) - (sparse-vector-set! a 0 (make-sparse-vector)) - a)) - -(define (sparse-array? a) - (and (sparse-vector? a) - (sparse-vector? (sparse-vector-ref a 0)))) - -(define (sparse-array-ref a x y) - (let ((row (sparse-vector-ref a x))) - (if row - (sparse-vector-ref row y) - #f))) - -(define (sparse-array-set! a x y val) - (let ((row (sparse-vector-ref a x))) - (if row - (sparse-vector-set! row y val) - (let ((new-row (make-sparse-vector))) - (sparse-vector-set! a x new-row) - (sparse-vector-set! new-row y val))))) - ;; data for runs, tests etc ;; (defstruct d:rundat ;; new system runs-index ;; target/runname => colnum @@ -240,10 +215,11 @@ ((args:get-arg "-use-local") #f) ((configf:lookup *configdat* "dashboard" "use-server") (let ((ans (config:lookup *configdat* "dashboard" "use-server"))) (if (equal? ans "yes") #t #f))) (else #t))) +(define *dashboard-mode* (string->symbol (or (configf:lookup *configdat* "dashboard" "mode") "dashboard"))) (d:alldat-dbdir-set! *alldat* (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) (d:alldat-dblocal-set! *alldat* (make-dbr:dbstruct path: (d:alldat-dbdir *alldat*) local: #t)) (d:alldat-dbfpath-set! *alldat* (db:dbfile-path 0)) @@ -374,20 +350,22 @@ sort-by sort-order 'shortlist (if (d:alldat-filters-changed data) 0 - last-update)) + last-update) + *dashboard-mode*) ;; use dashboard mode (db:get-tests-for-run (d:alldat-dblocal data) run-id testnamepatt states statuses #f #f (d:alldat-hide-not-hide data) sort-by sort-order 'shortlist (if (d:alldat-filters-changed data) 0 - last-update)))) + last-update) + *dashboard-mode*))) (tests (let ((newdat (filter (lambda (x) (not (equal? (db:test-get-state x) "DELETED"))) ;; remove deleted tests but do it after merging (delete-duplicates (if (d:alldat-filters-changed data) tmptests @@ -395,11 +373,12 @@ (lambda (a b) (eq? (db:test-get-id a)(db:test-get-id b))))))) (if (eq? *tests-sort-reverse* 3) ;; +event_time (sort newdat dboard:compare-tests) newdat)))) - (debug:print 0 "(dboard:get-tests-for-run-duplicate: got " (length tests) " test records for run " run-id) + (vector-set! prev-dat 3 (- (current-seconds) 2)) ;; go back two seconds in time to ensure all changes are captured. + ;; (debug:print 0 "(dboard:get-tests-for-run-duplicate: filters-changed=" (d:alldat-filters-changed data) " last-update=" last-update " got " (length tmptests) " test records for run " run-id) tests)) ;; create a virtual table of all the tests ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) (define (update-rundat data runnamepatt numruns testnamepatt keypatts) @@ -425,18 +404,20 @@ ;; NOTE: bubble-up also sets the global (d:alldat-item-test-names data) ;; (tests (bubble-up tmptests priority: bubble-type)) ;; 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 (d:alldat-hide-empty-runs data)) ;; this reduces the data burden when set - (not (null? tests))) - (let ((dstruct (vector run tests key-vals (- (current-seconds) 10)))) - (hash-table-set! (d:alldat-allruns-by-id data) run-id dstruct) - (set! result (cons dstruct result)))))) + (if (not (null? tests)) + (begin + (set! referenced-run-ids (cons run-id referenced-run-ids)) + (if (> (length tests) maxtests) + (set! maxtests (length tests))) + (if (or (not (d:alldat-hide-empty-runs data)) ;; this reduces the data burden when set + (not (null? tests))) + (let ((dstruct (vector run tests key-vals (- (current-seconds) 10)))) + (hash-table-set! (d:alldat-allruns-by-id data) run-id dstruct) + (set! result (cons dstruct result)))))))) runs) (d:alldat-header-set! data header) (d:alldat-allruns-set! data result) (debug:print-info 6 "(d:alldat-allruns data) has " (length (d:alldat-allruns data)) " runs") @@ -704,10 +685,11 @@ (hash-table-set! (d:alldat-searchpatts *alldat*) x val) (d:alldat-filters-changed-set! *alldat* #t) (set-bg-on-filter)) (define (mark-for-update) + (d:alldat-filters-changed-set! *alldat* #t) (d:alldat-last-db-update-set! *alldat* 0)) ;;====================================================================== ;; R U N C O N T R O L ;;====================================================================== @@ -836,26 +818,27 @@ (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 ",")))) + (conc " -state " (string-intersperse states ",")))) (statuses-str (if (or (not statuses) (null? statuses)) "" - (conc " :status " (string-intersperse statuses ",")))) + (conc " -status " (string-intersperse statuses ",")))) (full-cmd "megatest")) (case (string->symbol cmd) - ((runtests) + ((run) (set! full-cmd (conc full-cmd " -run" " -testpatt " test-patt " -target " target " -runname " run-name + " -clean-cache" ))) ((remove-runs) (set! full-cmd (conc full-cmd " -remove-runs -runname " run-name @@ -899,11 +882,11 @@ (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") + (action "-run") (cmdln "") (runlogs (make-hash-table)) (key-listboxes #f) (updater-for-runs #f) (update-keyvals (lambda () @@ -962,11 +945,11 @@ ;; 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")) + (let* ((cmds-list '("run" "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) @@ -1230,11 +1213,12 @@ (d:alldat-hide-not-hide data) #f #f "id,testname,item_path,state,status" (if (d:alldat-filters-changed data) 0 - last-update)) ;; get 'em all + last-update) + *dashboard-mode*) ;; get 'em all (db:get-tests-for-run db run-id (hash-table-ref/default (d:alldat-searchpatts data) "test-name" "%/%") (hash-table-keys (d:alldat-state-ignore-hash data)) ;; '() (hash-table-keys (d:alldat-status-ignore-hash data)) ;; '() #f #f @@ -1241,11 +1225,12 @@ (d:alldat-hide-not-hide data) #f #f "id,testname,item_path,state,status" (if (d:alldat-filters-changed data) 0 - last-update))) + last-update) + *dashboard-mode*)) '()))) ;; get 'em all (debug:print 0 "dboard:get-tests-dat: got " (length tdat) " test records for run " run-id) (sort tdat (lambda (a b) (let* ((aval (vector-ref a 2)) (bval (vector-ref b 2)) @@ -1556,88 +1541,108 @@ (iup:hbox (iup:vbox (iup:frame #:title "filter test and items" (iup:hbox - (iup:textbox #:size "120x15" #:fontsize "10" #:value "%" - #:action (lambda (obj unk val) - (mark-for-update) - (update-search "test-name" val))) - ;;(iup:textbox #:size "60x15" #:fontsize "10" #:value "%" - ;; #:action (lambda (obj unk val) - ;; (mark-for-update) - ;; (update-search "item-name" val)) - )) - (iup:vbox - (iup:hbox - (let* ((cmds-list '("+testname" "-testname" "+event_time" "-event_time" "+statestatus" "-statestatus")) - (lb (iup:listbox #:expand "HORIZONTAL" - #:dropdown "YES" - #:action (lambda (obj val index lbstate) - (set! *tests-sort-reverse* index) + (iup:vbox + (iup:textbox #:size "120x15" #:fontsize "10" #:value "%" + #:action (lambda (obj unk val) + (mark-for-update) + (update-search "test-name" val))) + (iup:hbox + (iup:button "Quit" #:action (lambda (obj) + ;; (if (d:alldat-dblocal data) (db:close-all (d:alldat-dblocal data))) + (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)) + (d:alldat-item-test-names data)) + (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:vbox + ;; (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))) + + (let* ((hide #f) + (show #f) + (hide-empty #f) + (sel-color "180 100 100") + (nonsel-color "170 170 170") + (cmds-list '("+testname" "-testname" "+event_time" "-event_time" "+statestatus" "-statestatus")) + (sort-lb (iup:listbox #:expand "HORIZONTAL" + #:dropdown "YES" + #:action (lambda (obj val index lbstate) + (set! *tests-sort-reverse* index) + (mark-for-update)))) + (default-cmd (car (list-ref *tests-sort-type-index* *tests-sort-reverse*)))) + (iuplistbox-fill-list sort-lb cmds-list selected-item: default-cmd) + + (set! hide-empty (iup:button "HideEmpty" + #:expand "YES" + #:action (lambda (obj) + (d:alldat-hide-empty-runs-set! data (not (d:alldat-hide-empty-runs data))) + (iup:attribute-set! obj "TITLE" (if (d:alldat-hide-empty-runs data) "+HideE" "-HideE")) (mark-for-update)))) - (default-cmd (car (list-ref *tests-sort-type-index* *tests-sort-reverse*)))) - (iuplistbox-fill-list lb cmds-list selected-item: default-cmd) - (mark-for-update) - ;; (set! *tests-sort-reverse* *tests-sort-reverse*0) - lb) - ;; (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) - (d:alldat-hide-empty-runs-set! data (not (d:alldat-hide-empty-runs data))) - (iup:attribute-set! obj "TITLE" (if (d:alldat-hide-empty-runs data) "+HideE" "-HideE")) - (mark-for-update))) - (let ((hideit (iup:button "HideTests" #:action (lambda (obj) - (d:alldat-hide-not-hide-set! data (not (d:alldat-hide-not-hide data))) - (iup:attribute-set! obj "TITLE" (if (d:alldat-hide-not-hide data) "HideTests" "NotHide")) - (mark-for-update))))) - (d:alldat-hide-not-hide-button-set! data hideit) ;; never used, can eliminate ... - hideit)) - (iup:hbox - (iup:button "Quit" #:action (lambda (obj) - ;; (if (d:alldat-dblocal data) (db:close-all (d:alldat-dblocal data))) - (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)) - (d:alldat-item-test-names data)) - (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)))))) + (set! hide (iup:button "Hide" + #:expand "YES" + #:action (lambda (obj) + (d:alldat-hide-not-hide-set! data #t) ;; (not (d:alldat-hide-not-hide data))) + ;; (iup:attribute-set! obj "TITLE" (if (d:alldat-hide-not-hide data) "HideTests" "NotHide")) + (iup:attribute-set! hide "BGCOLOR" sel-color) + (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))) + (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) + ;; (d:alldat-hide-not-hide-button-set! data hideit) ;; never used, can eliminate ... + (iup:vbox + (iup:hbox hide show) + hide-empty sort-lb))) + ))) (iup:frame #: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! (d:alldat-status-ignore-hash data) status #t) - (hash-table-delete! (d:alldat-status-ignore-hash data) status)) - (set-bg-on-filter)))) + (iup:toggle (conc status " ") + #:action (lambda (obj val) + (mark-for-update) + (if (eq? val 1) + (hash-table-set! (d:alldat-status-ignore-hash data) status #t) + (hash-table-delete! (d:alldat-status-ignore-hash data) status)) + (set-bg-on-filter)))) (map cadr *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! (d:alldat-state-ignore-hash data) state #t) - (hash-table-delete! (d:alldat-state-ignore-hash data) state)) - (set-bg-on-filter)))) + (iup:toggle (conc state " ") + #:action (lambda (obj val) + (mark-for-update) + (if (eq? val 1) + (hash-table-set! (d:alldat-state-ignore-hash data) state #t) + (hash-table-delete! (d:alldat-state-ignore-hash data) state)) + (set-bg-on-filter)))) (map cadr *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 (d:alldat-tot-runs data))) @@ -1782,19 +1787,20 @@ (d:alldat-please-update-set! *alldat* #t) (d:alldat-curr-tab-num-set! *alldat* curr)) (dashboard:summary *alldat*) runs-view (dashboard:one-run db data runs-sum-dat) - (dashboard:new-view db data new-view-dat) + ;; (dashboard:new-view db data new-view-dat) (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" "New View") - (iup:attribute-set! tabs "TABTITLE4" "Run Control") + (iup:attribute-set! tabs "TABTITLE3" "Run Control") + ;; (iup:attribute-set! tabs "TABTITLE3" "New View") + ;; (iup:attribute-set! tabs "TABTITLE4" "Run Control") (iup:attribute-set! tabs "BGCOLOR" "190 190 190") (d:alldat-hide-not-hide-tabs-set! *alldat* tabs) (iup:vbox tabs controls)))) @@ -1897,10 +1903,11 @@ (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) (if (file-exists? debugcontrolf) (load debugcontrolf))) (define (main) + (common:exit-on-version-changed) (let* ((runs-sum-dat (d:data-init (make-d:data))) ;; data for run-summary tab (new-view-dat (d:data-init (make-d:data))) (data *alldat*)) (cond ((args:get-arg "-run") Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -386,39 +386,11 @@ (let ((locdbs (dbr:dbstruct-get-locdbs dbstruct))) (if (hash-table? locdbs) (for-each (lambda (run-id) (db:close-run-db dbstruct run-id)) - (hash-table-keys locdbs)))) - - ;; (let* ((local (dbr:dbstruct-get-local dbstruct)) - ;; (rundb (db:dbdat-get-db (dbr:dbstruct-get-rundb dbstruct)))) - ;; (if local - ;; (for-each - ;; (lambda (dbdat) - ;; (let ((db (db:dbdat-get-db dbdat))) - ;; (if (sqlite3:database? db) - ;; (begin - ;; (sqlite3:interrupt! db) - ;; (sqlite3:finalize! db #t))))) - ;; ;; TODO: Come back to this and rework to delete from hashtable when finalized - ;; (hash-table-values (dbr:dbstruct-get-locdbs dbstruct)))) - ;; (thread-sleep! 3) - ;; (if (and rundb - ;; (sqlite3:database? rundb)) - ;; (handle-exceptions - ;; exn - ;; (begin - ;; (debug:print 0 "WARNING: database files may not have been closed correctly. Consider running -cleanup-db") - ;; (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) - ;; (debug:print 0 " db: " rundb) - ;; (print-call-chain (current-error-port)) - ;; #f) - ;; (sqlite3:interrupt! rundb) - ;; (sqlite3:finalize! rundb #t)))) - ;; ;; (mutex-unlock! *db-sync-mutex*) - ) + (hash-table-keys locdbs))))) (define (db:open-inmem-db) (let* ((db (sqlite3:open-database ":memory:")) (handler (make-busy-timeout 3600))) (sqlite3:set-busy-handler! db handler) @@ -844,30 +816,37 @@ (begin ;; NB// must sync first to ensure deleted tests get marked as such in megatest.db (db:sync-tables db:sync-tests-only (db:get-db fromdb run-id) mtdb) (db:clean-up-rundb (db:get-db fromdb run-id)) ;; - ;; Feb 18, 2016: add field last_update to tests + ;; Feb 18, 2016: add field last_update to tests, test_steps and test_data ;; ;; remove this some time after September 2016 (added in version v1.6031 ;; - (handle-exceptions - exn - (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn)) - (debug:print 0 "Column last_update already added to tests table") - (db:general-sqlite-error-dump exn "alter table tests ..." #f "none")) - (sqlite3:execute - frundb - "ALTER TABLE tests ADD COLUMN last_update INTEGER DEFAULT 0")) - (sqlite3:execute - frundb - "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests + (for-each + (lambda (table-name) + (handle-exceptions + exn + (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 "Column last_update already added to " table-name " table") + (db:general-sqlite-error-dump exn "alter table " table-name " ..." #f "none")) + (sqlite3:execute + frundb + (conc "ALTER TABLE " table-name " ADD COLUMN last_update INTEGER DEFAULT 0"))) + (sqlite3:execute + frundb + (conc "DROP TRIGGER IF EXISTS update_" table-name "_trigger;")) + (sqlite3:execute + frundb + (conc "CREATE TRIGGER IF NOT EXISTS update_" table-name "_trigger AFTER UPDATE ON " table-name " FOR EACH ROW BEGIN - UPDATE tests SET last_update=(strftime('%s','now')); - END;") - )))) + UPDATE " table-name " SET last_update=(strftime('%s','now')) + WHERE id=old.id; + END;")) + ) + '("tests" "test_steps" "test_data")))))) all-run-ids) ;; removed deleted runs (let ((dbdir (tasks:get-task-db-path))) (for-each (lambda (run-id) (let ((fullname (conc dbdir "/" run-id ".db"))) @@ -1036,11 +1015,11 @@ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, CONSTRAINT metadat_constraint UNIQUE (var));") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);") ;; Must do this *after* running patch db !! No more. ;; cannot use db:set-var since it will deadlock, hardwire the code here - (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" megatest-version) + (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" (common:version-signature)) (debug:print-info 11 "db:initialize END"))))) ;;====================================================================== ;; R U N S P E C I F I C D B ;;====================================================================== @@ -1087,20 +1066,19 @@ state TEXT DEFAULT 'NOT_STARTED', status TEXT DEFAULT 'n/a', event_time TIMESTAMP, comment TEXT DEFAULT '', logfile TEXT DEFAULT '', + last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));") - ;; (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data - ;; (id INTEGER PRIMARY KEY, - ;; reviewed TIMESTAMP DEFAULT (strftime('%s','now')), - ;; iterated TEXT DEFAULT '', - ;; avg_runtime REAL DEFAULT -1, - ;; avg_disk REAL DEFAULT -1, - ;; tags TEXT DEFAULT '', - ;; jobgroup TEXT DEFAULT 'default', - ;; CONSTRAINT test_meta_constraint UNIQUE (testname));") + (sqlite3:execute db "CREATE INDEX IF NOT EXISTS teststeps_index ON tests (run_id, testname, item_path);") + (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps + FOR EACH ROW + BEGIN + UPDATE test_steps SET last_update=(strftime('%s','now')) + WHERE id=old.id; + END;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, test_id INTEGER, category TEXT DEFAULT '', variable TEXT, value REAL, @@ -1108,13 +1086,19 @@ tol REAL, units TEXT, comment TEXT DEFAULT '', status TEXT DEFAULT 'n/a', type TEXT DEFAULT '', + last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));") - ;; Why use FULL here? This data is not that critical - ;; (sqlite3:execute db "PRAGMA synchronous = FULL;") + (sqlite3:execute db "CREATE INDEX IF NOT EXISTS test_data_index ON test_data (test_id);") + (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data + FOR EACH ROW + BEGIN + UPDATE test_data SET last_update=(strftime('%s','now')) + WHERE id=old.id; + END;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_rundat ( id INTEGER PRIMARY KEY, test_id INTEGER, update_time TIMESTAMP, cpuload INTEGER DEFAULT -1, @@ -1583,35 +1567,36 @@ ;;====================================================================== ;; returns number if string->number is successful, string otherwise ;; also updates *global-delta* ;; -;; Operates on megatestdb -;; (define (db:get-var dbstruct var) (let* ((res #f) (dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) - ;; (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (val) (set! res val)) db "SELECT val FROM metadat WHERE var=?;" var) ;; convert to number if can (if (string? res) (let ((valnum (string->number res))) (if valnum (set! res valnum)))) - ;; scale by 10, average with current value. + res)) + +;; This was part of db:get-var. It was used to estimate the load on +;; the database files. +;; +;; scale by 10, average with current value. ;; (set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms) ;; (if throttle throttle 0.01))) ;; 2)) ;; (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit ;; (begin ;; (debug:print-info 4 "launch throttle factor=" *global-delta*) ;; (set! *last-global-delta-printed* *global-delta*))) - res)) (define (db:set-var dbstruct var val) (let* ((dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val))) @@ -1808,55 +1793,10 @@ (begin (debug:print 2 "WARNING: Failed to process " dbfile " for run-id") 0)))) changed)))) -;; 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-rows runinfo)) -;; to extract info from the structure returned -;; -;; NOTE: THIS IS COMPLETELY UNFINISHED. IT GOES WITH rmt:get-get-paths-matching-keynames -;; -;; (define (db:get-run-ids-matching dbstruct keynames target res) -;; ;; (define (db:get-runs-by-patt dbstruct 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) -;; (db:with-db dbstruct #f #f ;; reads db, does not write to it. -;; (lambda (db) -;; (sqlite3:for-each-row -;; (lambda (a . r) -;; (set! res (cons (list->vector (cons a r)) res))) -;; (db:get-db dbstruct #f) -;; qry-str -;; runnamepatt))) -;; (vector header res))) - ;; Get all targets from the db ;; (define (db:get-targets dbstruct) (let* ((res '()) (keys (db:get-keys dbstruct)) @@ -2222,11 +2162,14 @@ ;; 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 dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update) +;; mode: +;; 'dashboard - use state = 'COMPLETED' AND status in ( statuses ) OR state in ( states ) +;; +(define (db:get-tests-for-run dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode) (if (not (number? run-id)) (begin ;; no need to treat this as an error by default (debug:print 4 "WARNING: call to db:get-tests-for-run with bad run-id=" run-id) ;; (print-call-chain (current-error-port)) '()) @@ -2237,27 +2180,33 @@ (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 ('" - " IN ('") + (if (eq? mode 'dashboard) + " IN ('" + (if not-in + " NOT IN ('" + " IN ('")) (string-intersperse states "','") "')"))) (statuses-qry (if (null? statuses) #f (conc " status " - (if not-in - " NOT IN ('" - " IN ('") + (if (eq? mode 'dashboard) + " 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 " ) ")) + (case mode + ((dashboard)(conc " AND " (if not-in "NOT " "") "( ( state='COMPLETED' AND " statuses-qry " ) OR " states-qry " ) ")) + (else (conc " AND ( " states-qry " AND " statuses-qry " ) ")))) (states-qry (conc " AND " states-qry)) (statuses-qry (conc " AND " statuses-qry)) (else ""))) @@ -2265,11 +2214,11 @@ (qry (conc "SELECT " qryvalstr " FROM tests WHERE run_id=? " (if last-update " " " AND state != 'DELETED' ") ;; if using last-update we want deleted tests? states-statuses-qry (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") - (if last-update (conc " AND last_update > " last-update " ") "") + (if last-update (conc " AND last_update >= " last-update " ") "") (case sort-by ((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 ") @@ -2358,11 +2307,11 @@ (let ((res '())) (for-each (lambda (run-id) (set! res (append res - (db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f qryvals)))) + (db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f qryvals #f 'normal)))) (if run-ids run-ids (db:get-all-run-ids dbstruct))) res)) @@ -2763,14 +2712,14 @@ run-id #f (lambda (db) (let* ((res '())) (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))) + (lambda (id test-id stepname state status event-time logfile comment) + (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment) res))) db - "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; + "SELECT id,test_id,stepname,state,status,event_time,logfile,comment FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; test-id) (reverse res))))) (define (db:get-steps-data dbstruct run-id test-id) (db:with-db @@ -2813,21 +2762,100 @@ ;; Now rollup the counts to the central megatest.db (db:general-call dbdat 'pass-fail-counts (list pass-count fail-count test-id)) ;; if the test is not FAIL then set status based on the fail and pass counts. (db:general-call dbdat 'test_data-pf-rollup (list test-id test-id test-id test-id)))) -;; NOT USED!? +;; each section is a rule except "final" which is the final result +;; +;; [rule-5] +;; operator in +;; section LogFileBody +;; desc Output voltage +;; status OK +;; expected 1.9 +;; measured 1.8 +;; type +/- +;; tolerance 0.1 +;; pass 1 +;; fail 0 +;; +;; [final] +;; exit-code 6 +;; exit-status SKIP +;; message If flagged we are asking for this to exit with code 6 ;; +;; recorded in steps table: +;; category: stepname +;; variable: rule-N +;; value: measured +;; expected: expected +;; tol: tolerance +;; units: - +;; comment: desc or message +;; status: status +;; type: type +;; +(define (db:logpro-dat->csv dat stepname) + (let ((res '())) + (for-each + (lambda (entry-name) + (if (equal? entry-name "final") + (set! res (append + res + (list + (list stepname + entry-name + (configf:lookup dat entry-name "exit-code") ;; 0 ;; Value + 0 ;; 1 ;; Expected + 0 ;; 2 ;; Tolerance + "n/a" ;; 3 ;; Units + (configf:lookup dat entry-name "message") ;; 4 ;; Comment + (configf:lookup dat entry-name "exit-status") ;; 5 ;; Status + "logpro" ;; 6 ;; Type + )))) + (let* ((value (or (configf:lookup dat entry-name "measured") "n/a")) + (expected (or (configf:lookup dat entry-name "expected") "n/a")) + (tolerance (or (configf:lookup dat entry-name "tolerance") "n/a")) + (comment (or (configf:lookup dat entry-name "comment") + (configf:lookup dat entry-name "desc") "n/a")) + (status (or (configf:lookup dat entry-name "status") "n/a")) + (type (or (configf:lookup dat entry-name "expected") "n/a"))) + (set! res (append + res + (list (list stepname + entry-name + value ;; 0 + expected ;; 1 + tolerance ;; 2 + "n/a" ;; 3 Units + comment ;; 4 + status ;; 5 + type ;; 6 + ))))))) + (hash-table-keys dat)) + res)) + +;; $MT_MEGATEST -load-test-data << EOF +;; foo,bar, 1.2, 1.9, > +;; foo,rab, 1.0e9, 10e9, 1e9 +;; foo,bla, 1.2, 1.9, < +;; foo,bal, 1.2, 1.2, < , ,Check for overload +;; foo,alb, 1.2, 1.2, <= , Amps,This is the high power circuit test +;; foo,abl, 1.2, 1.3, 0.1 +;; foo,bra, 1.2, pass, silly stuff +;; faz,bar, 10, 8mA, , ,"this is a comment" +;; EOF + (define (db:csv->test-data dbstruct run-id test-id csvdata) (debug:print 4 "test-id " test-id ", csvdata: " csvdata) (let* ((dbdat (db:get-db dbstruct run-id)) (db (db:dbdat-get-db dbdat)) (csvlist (csv->list (make-csv-reader (open-input-string csvdata) '((strip-leading-whitespace? #t) (strip-trailing-whitespace? #t)))))) ;; (csv->list csvdata))) - (for-each + (for-each (lambda (csvrow) (let* ((padded-row (take (append csvrow (list #f #f #f #f #f #f #f #f #f)) 9)) (category (list-ref padded-row 0)) (variable (list-ref padded-row 1)) (value (any->number-if-possible (list-ref padded-row 2))) @@ -3292,11 +3320,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 (db:get-tests-for-run dbstruct hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f #f))) + (let ((results (db:get-tests-for-run dbstruct hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f #f 'normal))) (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) @@ -3670,27 +3698,6 @@ ;; 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:testmeta-add-record -;; db:csv->test-data -;; )) Index: db_records.scm ================================================================== --- db_records.scm +++ db_records.scm @@ -186,17 +186,19 @@ (define-inline (tdb:step-get-stepname vec) (vector-ref vec 2)) (define-inline (tdb:step-get-state vec) (vector-ref vec 3)) (define-inline (tdb:step-get-status vec) (vector-ref vec 4)) (define-inline (tdb:step-get-event_time vec) (vector-ref vec 5)) (define-inline (tdb:step-get-logfile vec) (vector-ref vec 6)) +(define-inline (tdb:step-get-comment vec) (vector-ref vec 7)) (define-inline (tdb:step-set-id! vec val)(vector-set! vec 0 val)) (define-inline (tdb:step-set-test_id! vec val)(vector-set! vec 1 val)) (define-inline (tdb:step-set-stepname! vec val)(vector-set! vec 2 val)) (define-inline (tdb:step-set-state! vec val)(vector-set! vec 3 val)) (define-inline (tdb:step-set-status! vec val)(vector-set! vec 4 val)) (define-inline (tdb:step-set-event_time! vec val)(vector-set! vec 5 val)) (define-inline (tdb:step-set-logfile! vec val)(vector-set! vec 6 val)) +(define-inline (tdb:step-set-comment! vec vak)(vector-set! vec 7 val)) ;; The steps table (define (make-db:steps-table)(make-vector 5)) (define-inline (tdb:steps-table-get-stepname vec) (vector-ref vec 0)) Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -363,11 +363,11 @@ #:alignment1 "ALEFT" #:expand "YES" ;; "HORIZONTAL" #:numcol 1 #:numlin (length key-vals) #:numcol-visible 1 - #:numlin-visible (length key-vals) + #:numlin-visible (min 10 (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 @@ -880,11 +880,12 @@ ;;====================================================================== ;; S T E P S ;;====================================================================== (define (dcommon:populate-steps teststeps steps-matrix) - (let ((max-row 0)) + (let ((max-row 0) + (max-col 7)) (if (null? teststeps) (iup:attribute-set! steps-matrix "CLEARVALUE" "CONTENTS") (let loop ((hed (car teststeps)) (tal (cdr teststeps)) (rownum 1) @@ -891,11 +892,11 @@ (colnum 1)) (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) + (if (< colnum max-col) (loop hed tal rownum (+ colnum 1)) (if (not (null? tal)) (loop (car tal)(cdr tal)(+ rownum 1) 1)))))) (if (> max-row 0) (begin @@ -902,19 +903,19 @@ ;; 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))) + (let* ((next-row (if (eq? colnum max-col) (+ rownum 1) rownum)) + (next-col (if (eq? colnum max-col) 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 (eq? colnum max-col) ;; 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"))))) ADDED debugger.scm Index: debugger.scm ================================================================== --- /dev/null +++ debugger.scm @@ -0,0 +1,73 @@ +(use iup) + +(define *debugger-control* #f) +(define *debugger-rownum* 0) +(define *debugger-matrix* #f) +(define *debugger* #f) + +(define (debugger) + (if (not *debugger*) + (set! *debugger* + (thread-start! + (make-thread + (lambda () + (show + (dialog + (let ((pause #f) + (mtrx (matrix + #:expand "YES" + #:numlin 30 + #:numcol 3 + #:numlin-visible 20 + #:numcol-visible 2 + #:alignment1 "ALEFT" + ))) + (set! pause (button "Pause" + #:action (lambda (obj) + (set! *debugger-control* (not *debugger-control*)) + (attribute-set! pause "BGCOLOR" (if *debugger-control* + "200 0 0" + "0 0 200"))))) + (set! *debugger-matrix* mtrx) + (attribute-set! mtrx "WIDTH1" "300") + (vbox + mtrx + (hbox + pause))))) + (main-loop))))))) + +(define (debugger-start #!key (start 2)) + (set! *debugger-rownum* start)) + +(define (debugger-trace-var varname varval) + (let ((oldval (attribute *debugger-matrix* (conc *debugger-rownum* ":1"))) + (newval (conc varval))) + (if (not (equal? oldval newval)) + (begin + ;; (print "DEBUG: " varname " = " newval) + (attribute-set! *debugger-matrix* (conc *debugger-rownum* ":0") varname) + (attribute-set! *debugger-matrix* (conc *debugger-rownum* ":1") (conc varval)) + ;; (attribute-set! *debugger-matrix* "FITTOTEXT" "C1") + )) + (set! *debugger-rownum* (+ *debugger-rownum* 1)))) + + +(define (debugger-pauser) + (debugger) + (attribute-set! *debugger-matrix* "REDRAW" "ALL") + (let loop () + (if *debugger-control* + (begin + (print "PAUSED!") + (thread-sleep! 1) + (loop)) + ;;(thread-sleep! 0.01) + ))) + +;; ;; lets use the debugger eh? +;; (debugger-start) +;; (debugger-trace-var "can-run-more" can-run-more) +;; (debugger-trace-var "hed" hed) +;; (debugger-trace-var "prereqs-not-met" (runs:pretty-string prereqs-not-met)) +;; (debugger-pauser) + Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -11,12 +11,12 @@ ;;====================================================================== ;; launch a task - this runs on the originating host, tests themselves ;; ;;====================================================================== -(use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3 call-with-environment-variables) -(use defstruct) +(use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3 call-with-environment-variables csv) +(use defstruct pathname-expand) (import (prefix base64 base64:)) (import (prefix sqlite3 sqlite3:)) (declare (unit launch)) @@ -55,10 +55,29 @@ (common:read-encoded-string enccmd) '()))) ;; 0 1 2 3 (defstruct launch:einf (pid #t)(exit-status #t)(exit-code #t)(rollup-status 0)) + +;; return (conc status ": " comment) from the final section so that +;; the comment can be set in the step record in launch.scm +;; +(define (launch:load-logpro-dat run-id test-id stepname) + (let ((cname (conc stepname ".dat"))) + (if (file-exists? cname) + (let* ((dat (read-config cname #f #f)) + (csvr (db:logpro-dat->csv dat stepname)) + (csvt (let-values (( (fmt-cell fmt-record fmt-csv) (make-format ","))) + (fmt-csv (map list->csv-record csvr)))) + (status (configf:lookup dat "final" "exit-status")) + (msg (configf:lookup dat "final" "message"))) + (rmt:csv->test-data run-id test-id csvt) + (cond + ((equal? status "PASS") "PASS") ;; skip the message part if status is pass + (status (conc (configf:lookup dat "final" "exit-status") ": " (if msg msg "no message"))) + (else #f))) + #f))) (define (launch:runstep ezstep run-id test-id exit-info m tal testconfig) (let* ((stepname (car ezstep)) ;; do stuff to run the step (stepinfo (cadr ezstep)) (stepparts (string-match (regexp "^(\\{([^\\}]*)\\}\\s*|)(.*)$") stepinfo)) @@ -65,10 +84,11 @@ (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-file (conc stepname ".logpro")) (html-file (conc stepname ".html")) + (dat-file (conc stepname ".dat")) (tconfig-logpro (configf:lookup testconfig "logpro" stepname)) (logpro-used (file-exists? logpro-file))) (if (and tconfig-logpro (not logpro-used)) ;; no logpro file found but have a defn in the testconfig @@ -131,14 +151,19 @@ (thread-sleep! 2) (processloop (+ i 1))))) (debug:print-info 0 "logpro for step " stepname " exited with code " (launch:einf-exit-code exit-info))))) ;; (vector-ref exit-info 2))))) (let ((exinfo (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2)) - (logfna (if logpro-used (conc stepname ".html") ""))) - (rmt:teststep-set-status! run-id test-id stepname "end" exinfo #f logfna)) - (if logpro-used - (rmt:test-set-log! run-id test-id (conc stepname ".html"))) + (logfna (if logpro-used (conc stepname ".html") "")) + (comment #f)) + (if logpro-used + (let ((datfile (conc stepname ".dat"))) + ;; load the .dat file into the test_data table if it exists + (if (file-exists? datfile) + (set! comment (launch:load-logpro-dat run-id test-id stepname))) + (rmt:test-set-log! run-id test-id (conc stepname ".html")))) + (rmt:teststep-set-status! run-id test-id stepname "end" exinfo comment logfna)) ;; set the test final status (let* ((process-exit-status (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2)) (this-step-status (cond ((and (eq? process-exit-status 2) logpro-used) 'warn) ;; logpro 2 = warnings ((and (eq? process-exit-status 3) logpro-used) 'check) ;; logpro 3 = check @@ -202,13 +227,169 @@ (launch:einf-rollup-status-set! exit-info 1) ;; (vector-set! exit-info 3 1) ;; force fail, this used to be next-state but that doesn't make sense. should always be "COMPLETED" (tests:test-set-status! run-id test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f) ))) logpro-used)) +(define (launch:manage-steps run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m) + ;; (let-values + ;; (((pid exit-status exit-code) + ;; (run-n-wait fullrunscript))) + ;; (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! run-id test-id "RUNNING" "n/a") + (rmt:roll-up-pass-fail-counts run-id test-name item-path #f "RUNNING") + ;; (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))) + (rmt:test-set-top-process-pid run-id test-id pid) + (let loop ((i 0)) + (let-values + (((pid-val exit-status exit-code) (process-wait pid #t))) + (mutex-lock! m) + (launch:einf-pid-set! exit-info pid) ;; (vector-set! exit-info 0 pid) + (launch:einf-exit-status-set! exit-info exit-status) ;; (vector-set! exit-info 1 exit-status) + (launch:einf-exit-code-set! exit-info exit-code) ;; (vector-set! exit-info 2 exit-code) + (launch:einf-rollup-status-set! exit-info exit-code) ;; (vector-set! exit-info 3 exit-code) ;; rollup status + (mutex-unlock! m) + (if (eq? pid-val 0) + (begin + (thread-sleep! 2) + (loop (+ i 1))) + ))))) + ;; 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? + ;; NOTE: it is tempting to turn off force-create of testconfig but dynamic + ;; ezstep names need a full re-eval here. + (tests:get-testconfig test-name tconfigreg #t force-create: #t)) ;; 'return-procs))) + (ezstepslst (if (hash-table? testconfig) + (hash-table-ref/default testconfig "ezsteps" '()) + #f))) + (if testconfig + (hash-table-set! *testconfigs* test-name testconfig) ;; cached for lazy reads later ... + (begin + (launch:setup) + (debug:print 0 "WARNING: no testconfig found for " test-name " in search path:\n " + (string-intersperse (tests:get-tests-search-path *configdat*) "\n ")))) + ;; after all that, still no testconfig? Time to abort + (if (not testconfig) + (begin + (debug:print 0 "ERROR: Failed to resolve megatest.config, runconfigs.config and testconfig issues. Giving up now") + (exit 1))) + (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)) + (tal (cdr ezstepslst)) + (prevstep #f)) + ;; check exit-info (vector-ref exit-info 1) + (if (launch:einf-exit-status exit-info) ;; (vector-ref exit-info 1) + (let ((logpro-used (launch:runstep ezstep run-id test-id exit-info m tal testconfig)) + (stepname (car ezstep))) + ;; if logpro-used read in the stepname.dat file + (if (and logpro-used (file-exists? (conc stepname ".dat"))) + (launch:load-logpro-dat run-id test-id stepname)) + (if (steprun-good? logpro-used (launch:einf-exit-code exit-info)) + (if (not (null? tal)) + (loop (car tal) (cdr tal) stepname)) + (debug:print 4 "WARNING: step " (car ezstep) " failed. Stopping"))) + (debug:print 4 "WARNING: a prior step failed, stopping at " ezstep))))))) + +(define (launch:monitor-job run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m work-area runtlim misc-flags) + (let* ((start-seconds (current-seconds)) + (calc-minutes (lambda () + (inexact->exact + (round + (- + (current-seconds) + start-seconds))))) + (kill-tries 0)) + ;; (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area) + ;; (tests:set-full-meta-info test-id run-id (calc-minutes) work-area) + (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area 10) + (let loop ((minutes (calc-minutes)) + (cpu-load (get-cpu-load)) + (disk-free (get-df (current-directory)))) + (let ((new-cpu-load (let* ((load (get-cpu-load)) + (delta (abs (- load cpu-load)))) + (if (> delta 0.6) ;; don't bother updating with small changes + load + #f))) + (new-disk-free (let* ((df (get-df (current-directory))) + (delta (abs (- df disk-free)))) + (if (> delta 200) ;; ignore changes under 200 Meg + df + #f)))) + (set! kill-job? (or (test-get-kill-request run-id 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))))) + (tests:update-central-meta-info run-id test-id new-cpu-load new-disk-free (calc-minutes) #f #f) + (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* ((pid1 (launch:einf-pid exit-info)) ;; (vector-ref exit-info 0)) + (pid2 (rmt:test-get-top-process-pid run-id test-id)) + (pids (delete-duplicates (filter number? (list pid1 pid2))))) + (if (not (null? pids)) + (begin + (for-each + (lambda (pid) + (handle-exceptions + exn + (begin + (debug:print-info 0 "Unable to kill process with pid " pid ", possibly already killed.") + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))) + (debug:print 0 "WARNING: Request received to kill job " pid) ;; " (attempt # " kill-tries ")") + (debug:print-info 0 "Signal mask=" (signal-mask)) + ;; (if (process:alive? pid) + ;; (begin + (map (lambda (pid-num) + (process-signal pid-num signal/term)) + (process:get-sub-pids pid)) + (thread-sleep! 5) + ;; (if (process:process-alive? pid) + (map (lambda (pid-num) + (handle-exceptions + exn + #f + (process-signal pid-num signal/kill))) + (process:get-sub-pids pid)))) + ;; (debug:print-info 0 "not killing process " pid " as it is not alive")))) + pids) + (tests:test-set-status! run-id test-id "KILLED" "KILLED" (args:get-arg "-m") #f)) + (begin + (debug:print 0 "ERROR: Nothing to kill, pid1=" pid1 ", pid2=" pid2) + (tests:test-set-status! run-id test-id "KILLED" "FAILED TO KILL" (args:get-arg "-m") #f) + ))) + (mutex-unlock! m) + ;; no point in sticking around. Exit now. + (exit))) + (if (hash-table-ref/default misc-flags 'keep-going #f) + (begin + (thread-sleep! 3) ;; (+ 3 (random 6))) ;; add some jitter to the call home time to spread out the db accesses + (if (hash-table-ref/default misc-flags 'keep-going #f) ;; keep originals for cpu-load and disk-free unless they change more than the allowed delta + (loop (calc-minutes) (or new-cpu-load cpu-load) (or new-disk-free disk-free))))))) + (tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f))) ;; NOTE: Checking twice for keep-going is intentional + (define (launch:execute encoded-cmd) - - (let* ((cmdinfo (common:read-encoded-string encoded-cmd)) + (let* ((cmdinfo (common:read-encoded-string encoded-cmd)) (tconfigreg (tests:get-all))) (setenv "MT_CMDINFO" encoded-cmd) (if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed) ;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1)) (let* ((testpath (assoc/default 'testpath cmdinfo)) ;; testpath is the test spec area @@ -241,12 +422,11 @@ (let ((fulln (conc testpath "/" runscript))) (if (and (file-exists? fulln) (file-execute-access? fulln)) fulln runscript))))) ;; assume it is on the path - ;; (rollup-status 0) - ) + ) ;; (rollup-status 0) ;; NFS might not have propagated the directory meta data to the run host - give it time if needed (let loop ((count 0)) (if (or (file-exists? top-path) (> count 10)) @@ -274,14 +454,12 @@ (thread-start! th2) (thread-start! th1) (thread-join! th2))))) (set-signal-handler! signal/int sighand) (set-signal-handler! signal/term sighand) - (set-signal-handler! signal/stop sighand)) + ) ;; (set-signal-handler! signal/stop sighand) - ;; (set-signal-handler! signal/int (lambda () - ;; Do not run the test if it is REMOVING, RUNNING, KILLREQ or REMOTEHOSTSTART, ;; Mark the test as REMOTEHOSTSTART *IMMEDIATELY* ;; (let* ((test-info (rmt:get-test-info-by-id run-id test-id)) (test-host (db:test-get-host test-info)) @@ -390,11 +568,11 @@ ;; open-run-close not needed for test-set-meta-info ;; (tests:set-full-meta-info #f test-id run-id 0 work-area) ;; (tests:set-full-meta-info test-id run-id 0 work-area) (tests:set-full-meta-info #f test-id run-id 0 work-area 10) - (thread-sleep! 0.3) ;; NFS slowness has caused grief here + ;; (thread-sleep! 0.3) ;; NFS slowness has caused grief here (if (args:get-arg "-xterm") (set! fullrunscript "xterm") (if (and fullrunscript (file-exists? fullrunscript) @@ -403,176 +581,31 @@ ;; We are about to actually kick off the test ;; so this is a good place to remove the records for ;; any previous runs ;; (db:test-remove-steps db run-id testname itemdat) - + ;; (let* ((m (make-mutex)) (kill-job? #f) (exit-info (make-launch:einf pid: #t exit-status: #t exit-code: #t rollup-status: 0)) ;; pid exit-status exit-code (i.e. process was successfully run) rollup-status (job-thread #f) - (keep-going #t) + ;; (keep-going #t) + (misc-flags (let ((ht (make-hash-table))) + (hash-table-set! ht 'keep-going #t) + ht)) (runit (lambda () - ;; (let-values - ;; (((pid exit-status exit-code) - ;; (run-n-wait fullrunscript))) - ;; (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! run-id test-id "RUNNING" "n/a") - (rmt:roll-up-pass-fail-counts run-id test-name item-path #f "RUNNING") - ;; (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))) - (rmt:test-set-top-process-pid run-id test-id pid) - (let loop ((i 0)) - (let-values - (((pid-val exit-status exit-code) (process-wait pid #t))) - (mutex-lock! m) - (launch:einf-pid-set! exit-info pid) ;; (vector-set! exit-info 0 pid) - (launch:einf-exit-status-set! exit-info exit-status) ;; (vector-set! exit-info 1 exit-status) - (launch:einf-exit-code-set! exit-info exit-code) ;; (vector-set! exit-info 2 exit-code) - (launch:einf-rollup-status-set! exit-info exit-code) ;; (vector-set! exit-info 3 exit-code) ;; rollup status - (mutex-unlock! m) - (if (eq? pid-val 0) - (begin - (thread-sleep! 2) - (loop (+ i 1))) - ))))) - ;; 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? - ;; NOTE: it is tempting to turn off force-create of testconfig but dynamic - ;; ezstep names need a full re-eval here. - (tests:get-testconfig test-name tconfigreg #t force-create: #t)) ;; 'return-procs))) - (ezstepslst (if (hash-table? testconfig) - (hash-table-ref/default testconfig "ezsteps" '()) - #f))) - (if testconfig - (hash-table-set! *testconfigs* test-name testconfig) ;; cached for lazy reads later ... - (begin - (launch:setup) - (debug:print 0 "WARNING: no testconfig found for " test-name " in search path:\n " - (string-intersperse (tests:get-tests-search-path *configdat*) "\n ")))) - ;; after all that, still no testconfig? Time to abort - (if (not testconfig) - (begin - (debug:print 0 "ERROR: Failed to resolve megatest.config, runconfigs.config and testconfig issues. Giving up now") - (exit 1))) - (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)) - (tal (cdr ezstepslst)) - (prevstep #f)) - ;; check exit-info (vector-ref exit-info 1) - (if (launch:einf-exit-status exit-info) ;; (vector-ref exit-info 1) - (let ((logpro-used (launch:runstep ezstep run-id test-id exit-info m tal testconfig))) - (if (steprun-good? logpro-used (launch:einf-exit-code exit-info)) - (if (not (null? tal)) - (loop (car tal) (cdr tal) stepname)) - (debug:print 4 "WARNING: step " (car ezstep) " failed. Stopping"))) - (debug:print 4 "WARNING: a prior step failed, stopping at " ezstep)))))))) + (launch:manage-steps run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m))) (monitorjob (lambda () - (let* ((start-seconds (current-seconds)) - (calc-minutes (lambda () - (inexact->exact - (round - (- - (current-seconds) - start-seconds))))) - (kill-tries 0)) - ;; (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area) - ;; (tests:set-full-meta-info test-id run-id (calc-minutes) work-area) - (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area 10) - (let loop ((minutes (calc-minutes)) - (cpu-load (get-cpu-load)) - (disk-free (get-df (current-directory)))) - (let ((new-cpu-load (let* ((load (get-cpu-load)) - (delta (abs (- load cpu-load)))) - (if (> delta 0.6) ;; don't bother updating with small changes - load - #f))) - (new-disk-free (let* ((df (get-df (current-directory))) - (delta (abs (- df disk-free)))) - (if (> delta 200) ;; ignore changes under 200 Meg - df - #f)))) - (set! kill-job? (or (test-get-kill-request run-id 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))))) - (tests:update-central-meta-info run-id test-id new-cpu-load new-disk-free (calc-minutes) #f #f) - (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* ((pid1 (launch:einf-pid exit-info)) ;; (vector-ref exit-info 0)) - (pid2 (rmt:test-get-top-process-pid run-id test-id)) - (pids (delete-duplicates (filter number? (list pid1 pid2))))) - (if (not (null? pids)) - (begin - (for-each - (lambda (pid) - (handle-exceptions - exn - (begin - (debug:print-info 0 "Unable to kill process with pid " pid ", possibly already killed.") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))) - (debug:print 0 "WARNING: Request received to kill job " pid) ;; " (attempt # " kill-tries ")") - (debug:print-info 0 "Signal mask=" (signal-mask)) - ;; (if (process:alive? pid) - ;; (begin - (map (lambda (pid-num) - (process-signal pid-num signal/term)) - (process:get-sub-pids pid)) - (thread-sleep! 5) - ;; (if (process:process-alive? pid) - (map (lambda (pid-num) - (handle-exceptions - exn - #f - (process-signal pid-num signal/kill))) - (process:get-sub-pids pid)))) - ;; (debug:print-info 0 "not killing process " pid " as it is not alive")))) - pids) - (tests:test-set-status! run-id test-id "KILLED" "KILLED" (args:get-arg "-m") #f)) - (begin - (debug:print 0 "ERROR: Nothing to kill, pid1=" pid1 ", pid2=" pid2) - (tests:test-set-status! run-id test-id "KILLED" "FAILED TO KILL" (args:get-arg "-m") #f) - ))) - (mutex-unlock! m) - ;; no point in sticking around. Exit now. - (exit))) - (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 ;; keep originals for cpu-load and disk-free unless they change more than the allowed delta - (loop (calc-minutes) (or new-cpu-load cpu-load) (or new-disk-free disk-free))))))) - (tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f)))) ;; NOTE: Checking twice for keep-going is intentional + (launch:monitor-job run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m work-area runtlim misc-flags))) (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) (debug:print-info 0 "Megatest exectute of test " test-name ", item path " item-path " complete. Notifying the db ...") - (set! keep-going #f) + (hash-table-set! misc-flags 'keep-going #f) (thread-join! th1) (thread-sleep! 1) ;; givbe 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. (mutex-lock! m) (let* ((item-path (item-list->path itemdat)) ;; only state and status needed - use lazy routine @@ -630,13 +663,13 @@ (args:get-arg ":runname") (getenv "MT_RUNNAME"))) (fulldir (conc linktree "/" target "/" runname))) - (debug:print-info 0 "Have -runtests with target=" target ", runname=" runname ", fulldir=" fulldir ", testpatt=" (or (args:get-arg "-testpatt") "%")) (if (and linktree (file-exists? linktree)) ;; can't proceed without linktree (begin + (debug:print-info 0 "Have -run with target=" target ", runname=" runname ", fulldir=" fulldir ", testpatt=" (or (args:get-arg "-testpatt") "%")) (if (not (file-exists? fulldir)) (create-directory fulldir #t)) ;; need to protect with exception handler (if (and target runname (file-exists? fulldir)) @@ -643,84 +676,16 @@ (let ((tmpfile (conc fulldir "/.megatest.cfg." (current-seconds))) (targfile (conc fulldir "/.megatest.cfg-" megatest-version "-" megatest-fossil-hash)) (rconfig (conc fulldir "/.runconfig." megatest-version "-" megatest-fossil-hash))) (if (file-exists? rconfig) ;; only cache megatest.config AFTER runconfigs has been cached (begin - (debug:print-info 0 "Caching megatest.config in " fulldir "/.megatest.cfg") + (debug:print-info 0 "Caching megatest.config in " tmpfile) (configf:write-alist *configdat* tmpfile) (system (conc "ln -sf " tmpfile " " targfile)))) - ))))))) - -;; set up the very basics needed for doing anything here. -;; -(define (launch:setup-old #!key (force #f)) - ;; 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 - (if (or force (not (hash-table? *configdat*))) ;; no need to re-open on every call - (begin - (set! *configinfo* (or (if (get-environment-variable "MT_CMDINFO") ;; we are inside a test - do not reprocess configs - (let ((alistconfig (conc (get-environment-variable "MT_LINKTREE") "/" - (get-environment-variable "MT_TARGET") "/" - (get-environment-variable "MT_RUNNAME") "/" - ".megatest.cfg-" megatest-version "-" megatest-fossil-hash))) - (if (file-exists? alistconfig) - (list (configf:read-alist alistconfig) - (get-environment-variable "MT_RUN_AREA_HOME")) - #f)) - #f) ;; no config cached - give up - (let ((runname (or (args:get-arg "-runname")(args:get-arg ":runname")))) - (if runname (setenv "MT_RUNNAME" runname)) - (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)) - (let* ((tmptransport (configf:lookup *configdat* "server" "transport")) - (transport (if tmptransport (string->symbol tmptransport) 'http))) - (if (member transport '(http rpc nmsg)) - (set! *transport-type* transport) - (begin - (debug:print 0 "ERROR: Unrecognised transport " transport) - (exit)))) - (let ((linktree (configf:lookup *configdat* "setup" "linktree"))) ;; link tree is critical - (if linktree - (if (not (file-exists? linktree)) - (begin - (handle-exceptions - exn - (begin - (debug:print 0 "ERROR: Something went wrong when trying to create linktree dir at " linktree) - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) - (exit 1)) - (create-directory linktree #t)))) - (begin - (debug:print 0 "ERROR: linktree not defined in [setup] section of megatest.config") - (exit 1))) - (if linktree - (let ((dbdir (conc linktree "/.db"))) - (handle-exceptions - exn - (begin - (debug:print 0 "ERROR: failed to create the " dbdir " area for your database files") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))) - (if (not (directory-exists? dbdir))(create-directory dbdir))) - (setenv "MT_LINKTREE" linktree)) - (begin - (debug:print 0 "ERROR: linktree is required in your megatest.config [setup] section") - (exit 1))) - (if (and *toppath* - (directory-exists? *toppath*)) - (setenv "MT_RUN_AREA_HOME" *toppath*) - (begin - (debug:print 0 "ERROR: failed to find the top path to your Megatest area.") - (exit 1))) - ))) - *toppath*) + ))) + (debug:print-info 1 "No linktree yet, no caching configs."))))) + ;; gather available information, if legit read configs in this order: ;; ;; if have cache; ;; read it a return it @@ -768,19 +733,28 @@ given-toppath: toppath pathenvvar: "MT_RUN_AREA_HOME")) (first-rundat (let ((toppath (if toppath toppath (car first-pass)))) - (read-config (conc toppath "/runconfigs.config") *runconfigdat* #t - sections: sections)))) + (read-config ;; (conc toppath "/runconfigs.config") + (conc (if (string? toppath) + toppath + (get-environment-variable "MT_RUN_AREA_HOME")) + "/runconfigs.config") + *runconfigdat* #t + sections: sections)))) (set! *runconfigdat* first-rundat) (if first-pass ;; (begin (set! *configdat* (car first-pass)) (set! *configinfo* first-pass) (set! *toppath* (or toppath (cadr first-pass))) ;; use the gathered data unless already have it (set! toppath *toppath*) + (if (not *toppath*) + (begin + (debug:print "ERROR: you are not in a megatest area!") + (exit 1))) (setenv "MT_RUN_AREA_HOME" *toppath*) ;; the seed read is done, now read runconfigs, cache it then read megatest.config one more time and cache it (let* ((keys (rmt:get-keys)) (key-vals (keys:target->keyval keys target)) (linktree (or (getenv "MT_LINKTREE") @@ -976,11 +950,12 @@ #f))) (hash-table-set! *toptest-paths* testname curr-test-path) ;; NB// Was this for the test or for the parent in an iterated test? (rmt:general-call 'test-set-rundir-shortdir run-id lnkpath (if (file-exists? lnkpath) - (resolve-pathname lnkpath) + ;; (resolve-pathname lnkpath) + (common:nice-path lnkpath) lnkpath) testname "") ;; (rmt:general-call 'test-set-rundir run-id lnkpath testname "") ;; toptest-path) (if (or (not curr-test-path) (not (directory-exists? toptest-path))) Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -1,7 +1,7 @@ ;; Always use two or four digit decimal -;; 1.01, 1.02...1.10,1.11,1,1101 ... 1.99,2.00.. +;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00.. (declare (unit megatest-version)) -(define megatest-version 1.6101) +(define megatest-version 1.6102) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -82,10 +82,11 @@ -unlock : unlock run specified by target and runname -set-run-status status : sets status for run to status, requires -target and -runname -get-run-status : gets status for run specified by target and runname -run-wait : wait on run specified by target and runname -preclean : remove the existing test directory before running the test + -clean-cache : remove the cached megatest.config and runconfig.config files 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 @@ -270,10 +271,11 @@ "-summarize-items" "-gui" "-daemonize" "-preclean" "-rerun-clean" + "-clean-cache" ;; misc "-repl" "-lock" "-unlock" @@ -385,10 +387,11 @@ (if (common:low-noise-print 30) (debug:print-info 0 "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*))))) "Watchdog thread"))) (thread-start! *watchdog*) + (if (args:get-arg "-log") (let ((oup (open-output-file (args:get-arg "-log")))) (debug:print-info 0 "Sending log output to " (args:get-arg "-log")) (current-error-port oup) @@ -408,11 +411,11 @@ (debug:print 0 "ERROR: non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.") (exit 1)))) (if (args:get-arg "-version") (begin - (print megatest-version) + (print (common:version-signature)) ;; (print megatest-version) (exit))) (define *didsomething* #f) ;; Overall exit handling setup immediately @@ -454,18 +457,48 @@ (let ((newval (conc (args:get-arg "-testpatt") "/" (args:get-arg "-itempatt")))) (debug:print 0 "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval) (hash-table-set! args:arg-hash "-testpatt" newval) (hash-table-delete! args:arg-hash "-itempatt"))) - +(if (args:get-arg "-runtests") + (debug:print 0 "WARNING: \"-runtests\" is deprecated. Use \"-run\" with \"-testpatt\" instead")) (on-exit std-exit-procedure) ;;====================================================================== ;; Misc general calls ;;====================================================================== +;; handle a clean-cache request as early as possible +;; +(if (args:get-arg "-clean-cache") + (begin + (set! *didsomething* #t) ;; suppress the help output. + (if (getenv "MT_TARGET") ;; no point in trying if no target + (if (args:get-arg "-runname") + (let* ((toppath (launch:setup)) + (linktree (if toppath (configf:lookup *configdat* "setup" "linktree"))) + (runtop (conc linktree "/" (getenv "MT_TARGET") "/" (args:get-arg "-runname"))) + (files (if (file-exists? runtop) + (append (glob (conc runtop "/.megatest*")) + (glob (conc runtop "/.runconfig*"))) + '()))) + (if (null? files) + (debug:print-info 0 "No cached megatest or runconfigs files found. None removed.") + (begin + (debug:print-info 0 "Removing cached files:\n " (string-intersperse files "\n ")) + (for-each + (lambda (f) + (handle-exceptions + exn + (debug:print 0 "WARNING: Failed to remove file " f) + (delete-file f))) + files)))) + (debug:print 0 "ERROR: -clean-cache requires -runname.")) + (debug:print 0 "ERROR: -clean-cache requires -target or -reqtarg")))) + + (if (args:get-arg "-env2file") (begin (save-environment-as-files (args:get-arg "-env2file")) (set! *didsomething* #t))) @@ -479,33 +512,10 @@ " => ")) (common:get-disks *configdat*)) "\n")) (set! *didsomething* #t))) -(define (make-sparse-array) - (let ((a (make-sparse-vector))) - (sparse-vector-set! a 0 (make-sparse-vector)) - a)) - -(define (sparse-array? a) - (and (sparse-vector? a) - (sparse-vector? (sparse-vector-ref a 0)))) - -(define (sparse-array-ref a x y) - (let ((row (sparse-vector-ref a x))) - (if row - (sparse-vector-ref row y) - #f))) - -(define (sparse-array-set! a x y val) - (let ((row (sparse-vector-ref a x))) - (if row - (sparse-vector-set! row y val) - (let ((new-row (make-sparse-vector))) - (sparse-vector-set! a x new-row) - (sparse-vector-set! new-row y val))))) - ;; csv processing record (define (make-refdb:csv) (vector (make-sparse-array) (make-hash-table) @@ -660,18 +670,10 @@ (if (args:get-arg "-ping") (let* ((run-id (string->number (args:get-arg "-run-id"))) (host:port (args:get-arg "-ping"))) (server:ping run-id host:port))) -;; (set! *did-something* #t) -;; (begin -;; (print ((rpc:procedure 'testing (car host-port)(cadr host-port)))) -;; (case (server:get-transport) -;; ((http)(http:ping run-id host-port)) -;; ((rpc) (rpc:procedure 'server:login (car host-port)(cadr host-port));; *toppath*)) ;; (rpc-transport:ping run-id (car host-port)(cadr host-port))) -;; (else (debug:print 0 "ERROR: No transport set")(exit))))) - ;;====================================================================== ;; Capture, save and manipulate environments ;;====================================================================== ;; NOTE: Keep these above the section where the server or client code is setup @@ -708,12 +710,10 @@ (env:print added removed changed))) (env:print added removed changed)) (env:close-database db) (set! *didsomething* #t)) (debug:print 0 "ERROR: Parameter to -envdelta should be new=star-end"))))) - - ;;====================================================================== ;; 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 ;;====================================================================== @@ -947,19 +947,22 @@ (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 - (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) - (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") - state: (common:args-get-state) - status: (common:args-get-status) - new-state-status: (args:get-arg "-set-state-status"))) + (begin + ;; check for correct version, exit with message if not correct + (common:exit-on-version-changed) + (runs:operate-on action + target + (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) + (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") + state: (common:args-get-state) + status: (common:args-get-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 keyvals) @@ -1112,11 +1115,12 @@ ;; use qryvals if test-spec provided (if tests-spec (string-intersperse adj-tests-spec ",") ;; db:test-record-fields #f) - #f) + #f + 'normal) '()))) (case dmode ((json ods) (if runs-spec (for-each @@ -1626,11 +1630,13 @@ (if (not (launch:setup)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (if (and state status) - (rmt:teststep-set-status! run-id test-id step state status msg logfile) + (let ((comment (launch:load-logpro-dat run-id test-id step))) + ;; (rmt:test-set-log! run-id test-id (conc stepname ".html")))) + (rmt:teststep-set-status! run-id test-id step state status (or comment msg) logfile)) (begin (debug:print 0 "ERROR: You must specify :state and :status with every call to -step") (exit 6)))))) (if (args:get-arg "-step") @@ -1668,11 +1674,12 @@ (test-id (assoc/default 'test-id cmdinfo)) (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"))) + (status (args:get-arg ":status")) + (stepname (args:get-arg "-step"))) (if (not (launch:setup)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) @@ -1830,17 +1837,19 @@ 'dejunk ;; 'adj-testids ;; 'old2new 'new2old ) + (if (common:version-changed?) + (common:set-last-run-version)) (set! *didsomething* #t))) (if (args:get-arg "-mark-incompletes") (begin (if (not (launch:setup)) (begin - (debug:print 0 "Failed to setup, exiting") b + (debug:print 0 "Failed to setup, exiting") (exit 1))) (open-run-close db:find-and-mark-incomplete #f) (set! *didsomething* #t))) ;;====================================================================== Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -67,20 +67,20 @@ ;;====================================================================== ;; 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)(last-update #f)) - (let loop ((testsdat (rmt:get-tests-for-run run-id testpatt states status 0 500 not-in sort-by sort-order qryvals last-update)) + (let loop ((testsdat (rmt:get-tests-for-run run-id testpatt states status 0 500 not-in sort-by sort-order qryvals last-update 'normal)) (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 (rmt:get-tests-for-run run-id testpatt states status new-offset limit not-in sort-by sort-order qryvals last-update) + (loop (rmt:get-tests-for-run run-id testpatt states status new-offset limit not-in sort-by sort-order qryvals last-update 'normal) full-list new-offset limit)) full-list)))) @@ -137,11 +137,12 @@ (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 test-rundir ;; #f means no dir set yet + (if (and test-name + test-rundir ;; #f means no dir set yet (file-exists? test-rundir) (directory? test-rundir)) (call-with-environment-variables (list (cons "MT_TEST_NAME" test-name) (cons "MT_TEST_RUN_DIR" test-rundir) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -73,11 +73,11 @@ #f)))) (define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id (define (rmt:send-receive cmd rid params #!key (attemptnum 1)) ;; start attemptnum at 1 so the modulo below works as expected ;; clean out old connections - (mutex-lock! *db-multi-sync-mutex*) + ;; (mutex-lock! *db-multi-sync-mutex*) (let ((expire-time (- (current-seconds) (server:get-timeout) 10))) ;; don't forget the 10 second margin (for-each (lambda (run-id) (let ((connection (hash-table-ref/default *runremote* run-id #f))) (if (and (vector? connection) @@ -88,11 +88,11 @@ (case *transport-type* ((nmsg)(nn-close (http-transport:server-dat-get-socket (hash-table-ref *runremote* run-id))))) (hash-table-delete! *runremote* run-id))))) (hash-table-keys *runremote*))) - (mutex-unlock! *db-multi-sync-mutex*) + ;; (mutex-unlock! *db-multi-sync-mutex*) ;; (mutex-lock! *send-receive-mutex*) (let* ((run-id (if rid rid 0)) (connection-info (rmt:get-connection-info run-id))) ;; the nmsg method does the encoding under the hood (the http method should be changed to do this also) (if connection-info @@ -386,13 +386,13 @@ (rmt:send-receive 'test-set-state-status-by-id run-id (list run-id test-id newstate newstatus newcomment))) (define (rmt:set-tests-state-status run-id testnames currstate currstatus newstate newstatus) (rmt:send-receive 'set-tests-state-status run-id (list run-id testnames currstate currstatus newstate newstatus))) -(define (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update) +(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)) + (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) (print-call-chain (current-error-port)) '()))) @@ -619,11 +619,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 (rmt:get-tests-for-run hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f #f))) + (let ((results (rmt:get-tests-for-run hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f #f 'normal))) (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 @@ -659,14 +659,15 @@ ;;====================================================================== ;; T E S T D A T A ;;====================================================================== (define (rmt:read-test-data run-id test-id categorypatt #!key (work-area #f)) - (let ((tdb (rmt:open-test-db-by-test-id run-id test-id work-area: work-area))) - (if tdb - (tdb:read-test-data tdb test-id categorypatt) - '()))) + (rmt:send-receive 'read-test-data run-id (list run-id test-id categorypatt))) +;; (let ((tdb (rmt:open-test-db-by-test-id run-id test-id work-area: work-area))) +;; (if tdb +;; (tdb:read-test-data tdb test-id categorypatt) +;; '()))) (define (rmt:testmeta-add-record testname) (rmt:send-receive 'testmeta-add-record #f (list testname))) (define (rmt:testmeta-get-record testname) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -8,11 +8,12 @@ ;; 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 (srfi 18) posix-extras directory-utils) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) + posix-extras directory-utils pathname-expand) (import (prefix sqlite3 sqlite3:)) (declare (unit runs)) (declare (uses db)) (declare (uses common)) @@ -27,10 +28,12 @@ (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") + +;; (include "debugger.scm") (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 ")"))))) @@ -159,10 +162,18 @@ (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)))) +;; ;; lets use the debugger eh? +;; (debugger-start start: 15) +;; (debugger-trace-var "runs:can-run-more-tests" "") +;; (debugger-trace-var "can-not-run-more" can-not-run-more) +;; (debugger-trace-var "num-running" num-running) +;; (debugger-trace-var "num-running-in-jobgroup" num-running-in-jobgroup) +;; (debugger-trace-var "job-group-limit" job-group-limit) +;; (debugger-pauser) (list (not can-not-run-more) num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit))))) ;; test-names: Comma separated patterns same as test-patts but used in selection ;; of tests to run. The item portions are not respected. @@ -195,11 +206,11 @@ (set! run-count config-reruns)) (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) (let ((sighand (lambda (signum) - y ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting + ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting (set! *time-to-exit* #t) (print "Received signal " signum ", cleaning up before exit. Please wait...") (let ((th1 (make-thread (lambda () (let ((tdbdat (tasks:open-db))) (rmt:tasks-set-state-given-param-key task-key "killed")) @@ -373,20 +384,21 @@ (let ((reglen (configf:lookup *configdat* "setup" "runqueue"))) (if (> (length (hash-table-keys test-records)) 0) (let* ((keep-going #t) (run-queue-retries 5) (th1 (make-thread (lambda () - (handle-exceptions - exn - (begin - (print-call-chain (current-error-port)) - (debug:print 0 "ERROR: failure in runs:run-tests-queue thread, error: " ((condition-property-accessor 'exn 'message) exn)) - (if (> run-queue-retries 0) - (begin - (set! run-queue-retries (- run-queue-retries 1)) - (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry)))) - (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry))) + (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry)) + ;; (handle-exceptions + ;; exn + ;; (begin + ;; (print-call-chain (current-error-port)) + ;; (debug:print 0 "ERROR: failure in runs:run-tests-queue thread, error: " ((condition-property-accessor 'exn 'message) exn)) + ;; (if (> run-queue-retries 0) + ;; (begin + ;; (set! run-queue-retries (- run-queue-retries 1)) + ;; (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry)))) + ;; (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry))) "runs:run-tests-queue")) (th2 (make-thread (lambda () ;; (rmt:find-and-mark-incomplete-all-runs))))) CAN'T INTERRUPT IT ... (let ((run-ids (rmt:get-all-run-ids))) (for-each (lambda (run-id) @@ -459,11 +471,18 @@ (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 itemmaps) (let* ((loop-list (list hed tal reg reruns)) - (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps)) + (prereqs-not-met (let ((res (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps))) + (if (list? res) + res + (begin + (debug:print 0 + "ERROR: rmt:get-prereqs-not-met returned non-list!\n" + " res=" res " run-id=" run-id " waitons=" waitons " hed=" hed " item-path=" item-path " testmode=" testmode " itemmaps=" itemmaps) + '())))) ;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap)) (fails (runs:calc-fails prereqs-not-met)) (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))) @@ -478,10 +497,18 @@ "\n (member 'toplevel testmode): " (member 'toplevel testmode) "\n (null? non-completed): " (null? non-completed) "\n reruns: " reruns "\n items: " items "\n can-run-more: " can-run-more) + + ;; lets use the debugger eh? +;; (debugger-start start: 2) +;; (debugger-trace-var "runs:expand-items" "") +;; (debugger-trace-var "can-run-more" can-run-more) +;; (debugger-trace-var "hed" hed) +;; (debugger-trace-var "prereqs-not-met" (runs:pretty-string prereqs-not-met)) +;; (debugger-pauser) (cond ;; all prereqs met, fire off the test ;; or, if it is a 'toplevel test and all prereqs not met are COMPLETED then launch @@ -652,11 +679,15 @@ (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 (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps)) ;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap)) - (fails (runs:calc-fails prereqs-not-met)) + (fails (if (list? prereqs-not-met) + (runs:calc-fails prereqs-not-met) + (begin + (debug:print 0 "ERROR: prereqs-not-met is not a list! " prereqs-not-met) + '()))) (non-completed (filter (lambda (x) ;; remove hed from not completed list, duh, of course it is not completed! (not (equal? x hed))) (runs:calc-not-completed prereqs-not-met))) (loop-list (list hed tal reg reruns)) ;; configure the load runner @@ -1018,10 +1049,21 @@ "\n reruns: " reruns "\n regfull: " regfull "\n reglen: " reglen "\n length reg: " (length reg) "\n reg: " reg) + + ;; lets use the debugger eh? +;; (debugger-start start: 7) +;; (debugger-trace-var "runs:run-tests-queue" "") +;; (debugger-trace-var "hed" hed) +;; (debugger-trace-var "tal" tal) +;; (debugger-trace-var "items" items) +;; (debugger-trace-var "item-path" item-path) +;; (debugger-trace-var "waitons" waitons) +;; (debugger-pauser) + ;; check for hed in waitons => this would be circular, remove it and issue an ;; error (if (member test-name waitons) (begin @@ -1636,11 +1678,12 @@ #t) (define (runs:remove-test-directory test mode) ;; remove-data-only) (let* ((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) + ;; (resolve-pathname run-dir) + (common:nice-path run-dir) #f))) (case mode ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "CLEANING" "LOCKED" #f)) ((remove-all) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "REMOVING" "LOCKED" #f)) ((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVE_REMOVING" #f #f))) Index: tdb.scm ================================================================== --- tdb.scm +++ tdb.scm @@ -208,10 +208,22 @@ ;; NOTE: Run this local with #f for db !!! (define (tdb:load-test-data run-id test-id) (let loop ((lin (read-line))) (if (not (eof-object? lin)) (begin + (debug:print 4 lin) + (rmt:csv->test-data run-id test-id lin) + (loop (read-line))))) + ;; roll up the current results. + ;; FIXME: Add the status too + (rmt:test-data-rollup run-id test-id #f)) + +;; NOTE: Run this local with #f for db !!! +(define (tdb:load-logpro-data run-id test-id) + (let loop ((lin (read-line))) + (if (not (eof-object? lin)) + (begin (debug:print 4 lin) (rmt:csv->test-data run-id test-id lin) (loop (read-line))))) ;; roll up the current results. ;; FIXME: Add the status too Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -583,12 +583,12 @@ (lambda (step) (debug:print 6 "step=" step) (let ((record (hash-table-ref/default res (tdb:step-get-stepname step) - ;; stepname start end status Duration Logfile - (vector (tdb:step-get-stepname step) "" "" "" "" "")))) + ;; stepname start end status Duration Logfile Comment + (vector (tdb:step-get-stepname step) "" "" "" "" "" "")))) (debug:print 6 "record(before) = " record "\nid: " (tdb:step-get-id step) "\nstepname: " (tdb:step-get-stepname step) "\nstate: " (tdb:step-get-state step) "\nstatus: " (tdb:step-get-status step) @@ -610,15 +610,19 @@ ", get-status: " (tdb:step-get-status step)) (if (and (number? startt)(number? endt)) (seconds->hr-min-sec (- endt startt)) "-1"))) (if (> (string-length (tdb:step-get-logfile step)) 0) - (vector-set! record 5 (tdb:step-get-logfile step)))) + (vector-set! record 5 (tdb:step-get-logfile step))) + (if (> (string-length (tdb:step-get-comment step)) + 0) + (vector-set! record 6 (tdb:step-get-comment step)))) (else (vector-set! record 2 (tdb:step-get-state step)) (vector-set! record 3 (tdb:step-get-status step)) - (vector-set! record 4 (tdb:step-get-event_time step)))) + (vector-set! record 4 (tdb:step-get-event_time step)) + (vector-set! record 6 (tdb:step-get-comment step)))) (hash-table-set! res (tdb:step-get-stepname step) record) (debug:print 6 "record(after) = " record "\nid: " (tdb:step-get-id step) "\nstepname: " (tdb:step-get-stepname step) "\nstate: " (tdb:step-get-state step) @@ -631,17 +635,14 @@ ((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b)) (< (tdb:step-get-id a) (tdb:step-get-id b))) (else #f))))) res)) - -;; temporarily passing in dbstruct to support direct access (i.e. bypassing servers) +;; ;; -(define (tests:get-compressed-steps dbstruct run-id test-id) - (let* ((steps-data (if dbstruct - (db:get-steps-for-test dbstruct run-id test-id) - (rmt:get-steps-for-test run-id test-id))) +(define (tests:get-compressed-steps run-id test-id) + (let* ((steps-data (rmt:get-steps-for-test run-id test-id)) (comprsteps (tests:process-steps-table steps-data))) ;; (open-run-close db:get-steps-table #f test-id work-area: work-area))) (map (lambda (x) ;; take advantage of the \n on time->string (vector (vector-ref x 0) @@ -649,11 +650,12 @@ (if (number? s)(seconds->time-string s) s)) (let ((s (vector-ref x 2))) (if (number? s)(seconds->time-string s) s)) (vector-ref x 3) ;; status (vector-ref x 4) - (vector-ref x 5))) ;; time delta + (vector-ref x 5) ;; time delta + (vector-ref x 6))) (sort (hash-table-values comprsteps) (lambda (a b) (let ((time-a (vector-ref a 1)) (time-b (vector-ref b 1))) (if (and (number? time-a)(number? time-b)) @@ -675,11 +677,11 @@ (full-name (db:test-make-full-name test-name item-path)) (oup (open-output-file (conc (db:test-get-rundir test-dat) "/test-summary.html"))) (status (db:test-get-status test-dat)) (color (common:get-color-from-status status)) (logf (db:test-get-final_logf test-dat)) - (steps-dat (tests:get-compressed-steps #f run-id test-id))) + (steps-dat (tests:get-compressed-steps run-id test-id))) ;; (dcommon:get-compressed-steps #f 1 30045) ;; (#("wasting_time" "23:36:13" "23:36:21" "0" "8.0s" "wasting_time.log")) (s:output-new oup @@ -753,22 +755,23 @@ ;; (map (lambda (testp) ;; (last (string-split testp "/"))) ;; tests))))) (define (tests:get-test-path-from-environment) - (and (getenv "MT_LINKTREE") - (getenv "MT_TARGET") - (getenv "MT_RUNNAME") - (getenv "MT_TEST_NAME") - (getenv "MT_ITEMPATH") - (conc (getenv "MT_LINKTREE") "/" - (getenv "MT_TARGET") "/" - (getenv "MT_RUNNAME") "/" - (getenv "MT_TEST_NAME") "/" - (if (or (getenv "MT_ITEMPATH") - (not (string=? "" (getenv "MT_ITEMPATH")))) - (conc "/" (getenv "MT_ITEMPATH")))))) + (if (and (getenv "MT_LINKTREE") + (getenv "MT_TARGET") + (getenv "MT_RUNNAME") + (getenv "MT_TEST_NAME") + (getenv "MT_ITEMPATH")) + (conc (getenv "MT_LINKTREE") "/" + (getenv "MT_TARGET") "/" + (getenv "MT_RUNNAME") "/" + (getenv "MT_TEST_NAME") "/" + (if (or (getenv "MT_ITEMPATH") + (not (string=? "" (getenv "MT_ITEMPATH")))) + (conc "/" (getenv "MT_ITEMPATH")))) + #f)) ;; if .testconfig exists in test directory read and return it ;; else if have cached copy in *testconfigs* return it IFF there is a section "have fulldata" ;; else read the testconfig file ;; if have path to test directory save the config as .testconfig and return it @@ -803,11 +806,11 @@ (read-config test-configf #f system-allowed environ-patt: (if system-allowed "pre-launch-env-vars" #f)) #f))) - (if cache-file (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data + (if (and tcfg cache-file) (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data (if tcfg (hash-table-set! *testconfigs* test-name tcfg)) (if (and testexists cache-file (file-write-access? cache-path)) (let ((tpath (conc cache-path "/.testconfig"))) Index: tests/rununittest.sh ================================================================== --- tests/rununittest.sh +++ tests/rununittest.sh @@ -13,8 +13,9 @@ dbdir=$(cd simplerun;megatest -show-config -section setup -var linktree)/.db rm -f simplerun/megatest.db simplerun/monitor.db simplerun/db/monitor.db $dbdir/*.db rm -rf simplelinks/ simpleruns/ simplerun/db/ $dbdir mkdir -p simplelinks simpleruns (cd simplerun;cp ../../*_records.scm .;perl -pi.bak -e 's/define-inline/define/' *_records.scm) +(cd simplerun;cp ../../altdb.scm .) # Run the test $1 is the unit test to run cd simplerun;echo '(load "../tests.scm")' | ../../bin/megatest -repl -debug $2 $1 Index: utils/Makefile.installall ================================================================== --- utils/Makefile.installall +++ utils/Makefile.installall @@ -57,11 +57,11 @@ # iup-3.15 # 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 \ + json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars pathname-expand \ spiffy-directory-listing ssax sxml-serializer sxml-modifications sql-de-lite \ srfi-19 refdb ini-file sparse-vectors z3 call-with-environment-variables hahn linenoise \ crypt parley # @@ -277,19 +277,35 @@ #====================================================================== # I U P #====================================================================== iuplib.fossil : - #fossil clone http://www.kiatoa.com/fossils/iuplib iuplib.fossil - touch iuplib.fossil -iup/installall.sh : iuplib.fossil $(PREFIX)/lib/libiup.so + fossil clone http://www.kiatoa.com/fossils/iuplib iuplib.fossil + +cd-5.9_Linux26g4_64_lib.tar.gz : + wget -c http://sourceforge.net/projects/canvasdraw/files/5.9/Linux%20Libraries/cd-5.9_Linux26g4_64_lib.tar.gz/download + mv download cd-5.9_Linux26g4_64_lib.tar.gz + +iup-3.17_Linux26g4_64_lib.tar.gz : + wget -c http://sourceforge.net/projects/iup/files/3.17/Linux%20Libraries/iup-3.17_Linux26g4_64_lib.tar.gz/download + mv download iup-3.17_Linux26g4_64_lib.tar.gz + +im-3.10_Linux26g4_64_lib.tar.gz : + wget -c http://sourceforge.net/projects/imtoolkit/files/3.10/Linux%20Libraries/im-3.10_Linux26g4_64_lib.tar.gz/download + mv download im-3.10_Linux26g4_64_lib.tar.gz + +lua-5.3.2_Linux26g4_64_lib.tar.gz : + wget -c http://sourceforge.net/projects/luabinaries/files/5.3.2/Linux%20Libraries/lua-5.3.2_Linux26g4_64_lib.tar.gz/download + mv download lua-5.3.2_Linux26g4_64_lib.tar.gz + +iup/installall.sh : $(PREFIX)/lib/libiup.so \ + cd-5.9_Linux26g4_64_lib.tar.gz \ + iup-3.17_Linux26g4_64_lib.tar.gz \ + im-3.10_Linux26g4_64_lib.tar.gz \ + lua-5.3.2_Linux26g4_64_lib.tar.gz # iuplib.fossil mkdir -p iup pwd - #wget -c http://sourceforge.net/projects/canvasdraw/files/5.9/Linux%20Libraries/cd-5.9_Linux26g4_64_lib.tar.gz/download - #wget -c http://sourceforge.net/projects/iup/files/3.17/Linux%20Libraries/iup-3.17_Linux26g4_64_lib.tar.gz/download - #wget -c http://sourceforge.net/projects/imtoolkit/files/3.10/Linux%20Libraries/im-3.10_Linux26g4_64_lib.tar.gz/download - #wget -c http://sourceforge.net/projects/luabinaries/files/5.3.2/Linux%20Libraries/lua-5.3.2_Linux26g4_64_lib.tar.gz/download tar -xzvf cd-5.9_Linux26g4_64_lib.tar.gz -C iup/ tar -xzvf im-3.10_Linux26g4_64_lib.tar.gz -C iup/ tar -xzvf iup-3.17_Linux26g4_64_lib.tar.gz -C iup/ mkdir -p $(PREFIX)/include/ $(PREFIX)/lib/ cp iup/include/* $(PREFIX)/include/ @@ -296,11 +312,11 @@ cp iup/*.so $(PREFIX)/lib/ cp iup/*.a $(PREFIX)/lib/ # cd iup && if [ -e makeall.sh ];then fossil update $(IUPBRANCH); else fossil open ../iuplib.fossil;fossil update $(IUPBRANCH); fi -iup/alldone : iup/makeall.sh $(PREFIX)/include/iup.h $(PREFIX)/lib/libiup.so +iup/alldone : $(PREFIX)/include/iup.h $(PREFIX)/lib/libiup.so # iup/makeall.sh # cd iup && ./makeall.sh $(IUPCONFIG) $(PREFIX)/lib/libiup.so $(PREFIX)/include/iup.h : iup/installall.sh iup/alldone # cd iup && ./makeall.sh $(IUPCONFIG)