Megatest

(define (common:args-get-status)
  (or (args:get-arg "-status")(args:get-arg ":status")))

(define (common:args-get-testpatt rconf)
  (let* ((tagexpr (args:get-arg "-tagexpr"))
         (tags-testpatt (if tagexpr (string-join (runs:get-tests-matching-tags tagexpr) ",") #f))
         (testpatt-key  (if (args:get-arg "--modepatt") (args:get-arg "--modepatt") "TESTPATT"))
         (args-testpatt (or (args:get-arg "-testpatt") (args:get-arg "-runtests") "%"))
         (rtestpatt     (if rconf (runconfigs-get rconf testpatt-key) #f)))
    (cond
     (tags-testpatt
      (debug:print-info 0 *default-log-port* "-tagexpr "tagexpr" selects testpatt "tags-testpatt)
      tags-testpatt)
     ((and (equal? args-testpatt "%") rtestpatt)

;; lazy-safe get file mod time. on any error (file not existing etc.) return 0
;;
(define (common:lazy-modification-time fpath)
  (handle-exceptions
   exn
   0
   (file-modification-time fpath)))

;; find timestamp of newest file associated with a sqlite db file
(define (common:lazy-sqlite-db-modification-time fpath)
  (let* ((glob-list (handle-exceptions
                    exn
                    '("/no/such/file")
                    (glob (conc fpath "*"))))
         (file-list (if (eq? 0 (length glob-list))
                        '("/no/such/file")
                        glob-list)))
  (apply max
   (map
    common:lazy-modification-time 
    file-list))))

;; return a nice clean pathname made absolute
(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)

  tests-drawn    ;; list of id's already drawn on screen
  tests-notdrawn ;; list of id's NOT already drawn
  rowsused       ;; hash of lists covering what areas used - replace with quadtree
  hierdat        ;; put hierarchial sorted list here
  tests          ;; hash of id => testdat
  ((tests-by-name (make-hash-table)) : hash-table) ;; hash of testfullname => testdat
  key-vals
  ((last-update   0)                 : number)    ;; last query to db got records from before last-update
  ((last-db-time  0)                 : number)    ;; last timestamp on megatest.db
  ((data-changed  #f)                : boolean)   
  ((run-data-offset  0)              : number)      ;; get only 100 items per call, set back to zero when received less than 100 items
  (db-path #f))


;; register dboard:rundat with BBpp
;; this is used by BBpp (Brandon's pretty printer) to convert dboard:rundat into a composition of lists that pp will handle
(hash-table-set! *BBpp_custom_expanders_list* RUNDAT:
                 (cons dboard:rundat?
                       (lambda (tabdat-item)
                         (filter

;; This is roughly the same as dboard:get-tests-dat, should merge them if possible
;;
;; gets all the tests for run-id that match testnamepatt and key-vals, merges them
;;
;;    NOTE: Yes, this is used
;;
(define (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)
  (let* ((start-time   (current-seconds))
	 (access-mode  (dboard:tabdat-access-mode tabdat))

         (num-to-get   (string->number (or (configf:lookup *configdat* "setup" "num-tests-to-get")




                                           "200")))
	 (states       (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)))
	 (statuses     (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)))
         (do-not-use-db-file-timestamps #f) ;; (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps")) ;; this still hosts runs-summary-tab
         (do-not-use-query-timestamps   #f) ;; (configf:lookup *configdat* "setup" "do-not-use-query-timestamps")) ;; this no longer troubles runs-summary-tab
	 (sort-info    (get-curr-sort))
	 (sort-by      (vector-ref sort-info 1))
	 (sort-order   (vector-ref sort-info 2))
	 (bubble-type  (if (member sort-order '(testname))
			   'testname
			   'itempath))
	 ;; note: the rundat is normally created in "update-rundat". 
	 (run-dat      (or (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)
			   (let ((rd (dboard:rundat-make-init run: run key-vals: key-vals)))
			     (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id rd)
			     rd)))
	 ;; (prev-tests  (dboard:rundat-tests prev-dat)) ;; (vector-ref prev-dat 1))
         (last-update  (if (or do-not-use-query-timestamps
			       (dboard:tabdat-filters-changed tabdat))
			   0
			   (dboard:rundat-last-update run-dat)))
	 (last-db-time (if do-not-use-db-file-timestamps

			   0
			   (dboard:rundat-last-db-time run-dat)))
	 (db-path      (or (dboard:rundat-db-path run-dat)
			   (let* ((db-dir (common:get-db-tmp-area))
				  (db-pth (conc db-dir "/megatest.db")))
			     (dboard:rundat-db-path-set! run-dat db-pth)
			     db-pth)))
	 (db-mod-time  (common:lazy-sqlite-db-modification-time db-path))
	 (db-modified  (>= db-mod-time last-db-time))
	 (multi-get    (> (dboard:rundat-run-data-offset run-dat) 0))  ;; multi-get in progress
	 (tmptests     (if (or do-not-use-db-file-timestamps
			       (dboard:tabdat-filters-changed tabdat)
			       db-modified)
			   (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run
					      run-id testnamepatt states statuses     ;; run-id testpatt states statuses
					      (dboard:rundat-run-data-offset run-dat) ;; query offset
					      num-to-get
					      (dboard:tabdat-hide-not-hide tabdat) ;; no-in
					      sort-by                              ;; sort-by
					      sort-order                           ;; sort-order
					      #f ;; 'shortlist                     ;; qrytype


					      last-update                          ;; last-update
					      *dashboard-mode*)                    ;; use dashboard mode
			   '()))
	 (use-new    (dboard:tabdat-hide-not-hide tabdat))
	 (tests-ht   (if (dboard:tabdat-filters-changed tabdat)
			 (let ((ht (make-hash-table)))
			   (dboard:rundat-tests-set! run-dat ht)
			   ht)
			 (dboard:rundat-tests run-dat)))
	 (got-all      (< (length tmptests) num-to-get))               ;; got all for this round  
	 )

    ;; if we saw the db modified, reset it (the signal has already been used)
    (if (and got-all ;; (not multi-get)
	     db-modified)
	(dboard:rundat-last-db-time-set!    run-dat (- start-time 2)))

    ;; to limit the amount of data transferred each cycle use limit of num-to-get and offset
    ;; DO NOT bump time indexes last-update and last-db-time until all the first pass of the
    ;; data has been read
    ;; set last-update to 0 if still getting data incrementally ;; NO NEED, handled above
    ;;
    ;; (debug:print 0 *default-log-port* "got-all: " got-all " multi-get: " multi-get " num-to-get: " num-to-get " (length tmptests): " (length tmptests) " db-modified: " db-modified " db-mod-time: " db-mod-time " db-path: " db-path)
    (if got-all
	(begin
	  (dboard:rundat-last-update-set!     run-dat (- start-time 2))
	  (dboard:rundat-run-data-offset-set! run-dat 0))
	(begin
	  (dboard:rundat-run-data-offset-set! run-dat


					      (+ num-to-get (dboard:rundat-run-data-offset run-dat)))))



    (for-each 
     (lambda (tdat)
       (let ((test-id (db:test-get-id tdat))
	     (state   (db:test-get-state tdat)))
	 (dboard:rundat-data-changed-set! run-dat #t)
	 (if (equal? state "DELETED")
	     (hash-table-delete! tests-ht test-id)
	     (hash-table-set! tests-ht test-id tdat))))
     tmptests)
    












    tests-ht))

;; tmptests   - new tests data
;; prev-tests - old tests data
;;
;; (define (dashboard:merge-changed-tests tabdat tests tmptests) ;;  use-new prev-tests) 
;;   (let* ((newdat     (filter

  (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" 300 )
(iup:attribute-set! *tim* "RUN" "YES")

(define *last-recalc-ended-time* 0)

(define (dashboard:recalc modtime please-update-buttons last-db-update-time)
  (or please-update-buttons
      (and ;; (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) ;; can't use this - it needs to be tab specific

	 (db    (if have-struct
		    (db:dbdat-get-db dbdat)
		    dbstruct))
	 (use-mutex (> *api-process-request-count* 25)))
    (if (and use-mutex
	     (common:low-noise-print 120 "over-50-parallel-api-requests"))
	(debug:print-info 0 *default-log-port* *api-process-request-count* " parallel api requests being processed in process " (current-process-id) ", throttling access"))
    (if (common:low-noise-print 600 (conc "parallel-api-requests" *max-api-process-requests*))
	(debug:print-info 0 *default-log-port* "Parallel api request count: " *api-process-request-count* " max parallel requests: " *max-api-process-requests*))
    (handle-exceptions
     exn
     (begin
       (print-call-chain (current-error-port))
       (debug:print-error 0 *default-log-port* "sqlite3 issue in db:with-db, dbstruct=" dbstruct ", run-id=" run-id ", proc=" proc ", params=" params " error: " ((condition-property-accessor 'exn 'message) exn))
       ;; there is no recovering at this time. exit

;; Always use two or four digit decimal
;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00..

(declare (unit megatest-version))

(define megatest-version 1.6305)

(define help (conc "
Megatest, documentation at http://www.kiatoa.com/fossils/megatest
  version " megatest-version "
  license GPL, Copyright Matt Welland 2006-2015

Usage: megatest [options]
  -h                      : this help
  -manual                 : show the Megatest user manual
  -version                : print megatest version (currently " megatest-version ")

Launching and managing runs
  -runall                 : run all tests or as specified by -testpatt
  -remove-runs            : remove the data for a run, requires -runname and -testpatt
                            Optionally use :state and :status
  -set-state-status X,Y   : set state to X and status to Y, requires controls per -remove-runs

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
  -runname                : required, name for this particular test run
  -state                  : Applies to runs, tests or steps depending on context
  -status                 : Applies to runs, tests or steps depending on context
  --modepatt key          : load testpatt from <key> in runconfigs instead of default TESTPATT if -testpatt and -tagexpr are not specified
  -tagexpr tag1,tag2%,..  : select tests with tags matching expression

Test helpers (for use inside tests)
  -step stepname
  -test-status            : set the state and status of a test (use :state and :status)
  -setlog logfname        : set the path/filename to the final log relative to the test
                            directory. may be used with -test-status

			"-runname"
			":state"  
			"-state"
			":status"
			"-status"
			"-list-runs"
			"-testpatt"
                        "--modepatt"
                        "-tagexpr"
			"-itempatt"
			"-setlog"
			"-set-toplog"
			"-runstep"
			"-logpro"
			"-m"

#! /bin/bash

#exits 1 when current host is not homehost.

if [[ ! -e .homehost ]]; then
    exit 0
fi

#   echo "source $prefix/bin/.\$(lsb_release -sr)/cfg.sh" >> $target
# fi
# echo "exec $prefix/bin/.\$(lsb_release -sr)/$cmd \"\$@\"" >> $target
echo "#!/bin/bash" > $target

if [[ $cmd =~ dboard ]]; then
    cat >> $target <<'EOF'

# disable if not running on homehost
if [[ -e .homehost ]]; then
  homehostname=$( host `cat .homehost` | awk '{print $NF}' | sed 's/\.$//' )
  hostname=$( hostname -f )

  if [[ ! ($homehostname == $hostname) ]]; then
    echo "ERROR: this host ($hostname) is not the homehost ($homehostname) for this megatest run area.  Cannot start dashboard."
    echo "       Please log into homehost before launching dashboard."
    exit 1
  fi
fi

# check that $DISPLAY is set
if [[ -z $DISPLAY ]]; then
   echo 'ERROR: $DISPLAY environment variable is not set; megatest dashboard requires X display address to be set in $DISPLAY.'
   exit 1
fi