@@ -21,28 +21,10 @@ (import format) (declare (uses ducttape-lib)) (declare (uses bigmod)) (declare (uses debugprint)) - -(import (prefix iup iup:)) -(import canvas-draw) - -;; (import canvas-draw-iup) - -(import ducttape-lib - bigmod) - -(import (prefix sqlite3 sqlite3:) - srfi-1 - chicken.file.posix - chicken.string - chicken.process-context - regex regex-case srfi-69 - typed-records - sparse-vectors) - (declare (uses commonmod)) (declare (uses configfmod)) (declare (uses dashboard-context-menu)) (declare (uses dashboard-guimonitor)) (declare (uses dashboard-tests)) @@ -59,35 +41,53 @@ (declare (uses tree)) (declare (uses vgmod)) (declare (uses bigmod.import)) (declare (uses debugprint.import)) ;; (declare (uses dashboard-main)) + +(import (prefix iup iup:)) +(import canvas-draw) + +;; (import canvas-draw-iup) + +(import ducttape-lib + bigmod) + +(import (prefix sqlite3 sqlite3:) + srfi-1 + chicken.file.posix + chicken.string + chicken.process-context + regex regex-case srfi-69 + typed-records + sparse-vectors) + ;; (include "common_records.scm") -(include "db_records.scm") -(include "run_records.scm") -(include "task_records.scm") +;; (include "db_records.scm") +;; (include "run_records.scm") +;; (include "task_records.scm") ;; (include "megatest-version.scm") (include "megatest-fossil-hash.scm") -(include "vg_records.scm") - -(import - commonmod - configfmod - dbmod - debugprint - itemsmod - launchmod - (prefix mtargs args:) - mtmod - mtver - processmod - runsmod - subrunmod - vgmod - dcommon - dashboard-context-menu) +;; (include "vg_records.scm") + +(import commonmod + configfmod + dbmod + debugprint + itemsmod + launchmod + (prefix mtargs args:) + mtmod + mtver + processmod + runsmod + subrunmod + vgmod + dcommon + dashboard-context-menu + dashboard-tests) (define help (conc "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " license GPL, Copyright (C) Matt Welland 2012-2017 @@ -304,21 +304,10 @@ (lambda (updater) ;; (debug:print 3 *default-log-port* "Running " updater) (updater)) updaters)))) -;; if tab-num passed in then use it, otherwise look in commondat at curr-tab-num -;; adds the updater passed in the updaters list at that hashkey -;; -(define (dboard:commondat-add-updater commondat updater #!key (tab-num #f)) - (let* ((tnum (or tab-num - (dboard:commondat-curr-tab-num commondat))) - (curr-updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '()))) - (hash-table-set! (dboard:commondat-updaters commondat) - tnum - (cons updater curr-updaters)))) - ;; register tabdat with BBpp ;; this is used by BBpp (Brandon's pretty printer) to convert dboard:tabdat into a composition of lists that pp will handle (hash-table-set! *BBpp_custom_expanders_list* TABDAT: (cons dboard:tabdat? (lambda (tabdat-item) @@ -332,26 +321,19 @@ (define (dboard:tabdat-target-string vec) (let ((targ (dboard:tabdat-target vec))) (if (list? targ)(string-intersperse targ "/") "no-target-specified"))) -(define (dboard:tabdat-test-patts-use vec) - (let ((val (dboard:tabdat-test-patts vec)))(if val val ""))) ;;RADT => What is the if for? - -;; additional setters for dboard:data -(define (dboard:tabdat-test-patts-set!-use vec val) - (dboard:tabdat-test-patts-set! vec (if (equal? val "") #f val))) - (define (dboard:tabdat-make-data) (let ((dat (make-dboard:tabdat))) (dboard:setup-tabdat dat) (dboard:setup-num-rows dat) dat)) (define (dboard:setup-tabdat tabdat) - (dboard:tabdat-dbdir-set! tabdat (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) - (dboard:tabdat-dbfpath-set! tabdat (db:dbfile-path)) + (dboard:tabdat-dbdir-set! tabdat (common:get-db-tmp-area)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) + (dboard:tabdat-dbfpath-set! tabdat (common:get-db-tmp-area)) (dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db")) ;; HACK ALERT: this is a hack, please fix. (dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat)))) @@ -509,12 +491,10 @@ #f))) (define *dashboard-mode* (string->symbol (or (configf:lookup *configdat* "dashboard" "mode") "dashboard"))) -(define *exit-started* #f) - ;; sorting global data (would apply to many testsuites so leave it global for now) ;; (define *tests-sort-options* (vector (vector "Sort +a" 'testname "ASC") (vector "Sort -a" 'testname "DESC") (vector "Sort +t" 'event_time "ASC") @@ -557,28 +537,10 @@ (define-inline (dboard:uidat-get-header vec)(vector-ref vec 2)) (define-inline (dboard:uidat-get-runsvec vec)(vector-ref vec 3)) (if (get-environment-variable "MT_RUN_AREA_HOME")(change-directory (get-environment-variable "MT_RUN_AREA_HOME"))) -(define (message-window msg) - (iup:show - (iup:dialog - (iup:vbox - (iup:label msg #:margin "40x40"))))) - -(define (iuplistbox-fill-list lb items #!key (selected-item #f)) - (let ((i 1)) - (for-each (lambda (item) - (iup:attribute-set! lb (number->string i) item) - (if selected-item - (if (equal? selected-item item) - (iup:attribute-set! lb "VALUE" i))) ;; (number->string i)))) - (set! i (+ i 1))) - items) - ;; (iup:attribute-set! lb "VALUE" (if selected-item selected-item "")) - i)) - (define (pad-list l n)(append l (make-list (- n (length l))))) (define (colors-similar? color1 color2) (let* ((c1 (map string->number (string-split color1))) (c2 (map string->number (string-split color2))) @@ -1311,60 +1273,10 @@ (let ((all (hash-table-keys alltgls))) (proc all))) "text-list-toggle-box")))) items)))) -;; Extract the various bits of data from tabdat and create the command line equivalent that will be displayed -;; -(define (dashboard:update-run-command tabdat) - (let* ((cmd-tb (dboard:tabdat-command-tb tabdat)) - (cmd (dboard:tabdat-command tabdat)) - (test-patt (let ((tp (dboard:tabdat-test-patts tabdat))) - (if (or (not tp) - (equal? tp "")) - "%" - tp))) - (states (dboard:tabdat-states tabdat)) - (statuses (dboard:tabdat-statuses tabdat)) - (target (let ((targ-list (dboard:tabdat-target tabdat))) - (if targ-list (string-intersperse targ-list "/") "no-target-selected"))) - (run-name (dboard:tabdat-run-name tabdat)) - (states-str (if (or (not states) - (null? states)) - "" - (conc " -state " (string-intersperse states ",")))) - (statuses-str (if (or (not statuses) - (null? statuses)) - "" - (conc " -status " (string-intersperse statuses ",")))) - (full-cmd "megatest")) - (case (string->symbol cmd) - ((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 - " -target " - target - " -testpatt " - test-patt - states-str - statuses-str - ))) - (else (set! full-cmd " no valid command "))) - (iup:attribute-set! cmd-tb "VALUE" full-cmd))) - ;;====================================================================== ;; R U N C O N T R O L S ;;====================================================================== ;; ;; A gui for launching tests @@ -2976,11 +2888,10 @@ (dboard:tabdat-num-tests-set! tabdat (string->number (or (args:get-arg "-rows") (get-environment-variable "DASHBOARDROWS") "15")))) -(define *tim* (iup:timer)) (define *ord* #f) (iup:attribute-set! *tim* "TIME" (or (configf:lookup *configdat* "dashboard" "poll-interval") "1000")) (iup:attribute-set! *tim* "RUN" "YES") (define *last-recalc-ended-time* 0)