Megatest

;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;;======================================================================

(declare (unit commonmod))
;; (declare (uses processmod))
(declare (uses mtargs))
(declare (uses stml2))
(declare (uses mtargs))

	 
(module commonmod
	*
	
(import scheme chicken data-structures extras)
	
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18
	srfi-1 files format srfi-13 matchable 
	srfi-69 ports
	regex-case regex hostinfo srfi-4
	pkts (prefix dbi dbi:)
	stack
	md5
	message-digest
	(prefix mtconfigf configf:)
	stml2
	;; (prefix margs args:)
	z3 (prefix base64 base64:)
	(prefix mtargs args:))
(import stml2)

(include "common_records.scm")
(include "megatest-fossil-hash.scm")
(include "megatest-version.scm")

 ;; no need to export this
(define *verbosity-cache* (make-hash-table))
(define *verbosity* 0)



;; GLOBALS

;; CONTEXTS
#;(defstruct cxt
  (taskdb #f)
  (cmutex (make-mutex)))
;; (define *contexts* (make-hash-table))
;; (define *context-mutex* (make-mutex))

;; ;; safe method for accessing a context given a toppath
;; ;;
;; (define (common:with-cxt toppath proc)
;;   (mutex-lock! *context-mutex*)
;;   (let ((cxt (hash-table-ref/default *contexts* toppath #f)))
;;     (if (not cxt)
;;         (set! cxt (let ((x (make-cxt)))(hash-table-set! *contexts* toppath x) x)))
;;     (let ((cxt-mutex (cxt-mutex cxt)))
;;       (mutex-unlock! *context-mutex*)
;;       (mutex-lock! cxt-mutex)
;;       (let ((res (proc cxt)))
;;         (mutex-unlock! cxt-mutex)
;;         res))))
        
;; A hash table that can be accessed by #{scheme ...} calls in
;; config files. Allows communicating between confgs
;;
(define *user-hash-data* (make-hash-table))

(define *db-keys* #f)

(define *pkts-info*    (make-hash-table)) ;; store stuff like the last parent here
(define *configinfo*   #f)   ;; raw results from setup, includes toppath and table from megatest.config
(define *runconfigdat* #f)   ;; run configs data
(define *configdat*    #f)   ;; megatest.config data
(define *configstatus* #f)   ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done
(define *toppath*      #f)
(define *already-seen-runconfig-info* #f)

(define *test-meta-updated* (make-hash-table))
(define *globalexitstatus*  0) ;; attempt to work around possible thread issues
(define *passnum*           0) ;; when running track calls to run-tests or similar
;; (define *alt-log-file* #f)  ;; used by -log
(define *common:denoise*    (make-hash-table)) ;; for low noise printing
(define *default-log-port*  (current-error-port))
(define *default-area-tag* "local")

;; DATABASE
(define *dbstruct-db*         #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this.
;; db access
(define *db-last-access*      (current-seconds)) ;; last db access, used in server
(define *db-write-access*     #t)
;; db sync
(define *db-last-sync*        0)                 ;; last time the sync to megatest.db happened
(define *db-sync-in-progress* #f)                ;; if there is a sync in progress do not try to start another
(define *db-multi-sync-mutex* (make-mutex))      ;; protect access to *db-sync-in-progress*, *db-last-sync*
;; task db
(define *task-db*             #f) ;; (vector db path-to-db)
(define *db-access-allowed*   #t) ;; flag to allow access
(define *db-access-mutex*     (make-mutex))
(define *db-transaction-mutex* (make-mutex))
(define *db-cache-path*       #f)
(define *db-with-db-mutex*    (make-mutex))
(define *db-api-call-time*    (make-hash-table)) ;; hash of command => (list of times)
;; no sync db
(define *no-sync-db*          #f)

;; SERVER
(define *my-client-signature* #f)
(define *transport-type*    'http)             ;; override with [server] transport http|rpc|nmsg
(define *runremote*         #f)                ;; if set up for server communication this will hold <host port>
;; (define *max-cache-size*    0)
(define *logged-in-clients* (make-hash-table))
(define *server-id*         #f)
(define *server-info*       #f)  ;; good candidate for easily convert to non-global
(define *time-to-exit*      #f)
(define *server-run*        #t)
(define *run-id*            #f)
(define *server-kind-run*   (make-hash-table))
(define *home-host*         #f)
;; (define *total-non-write-delay* 0)
(define *heartbeat-mutex*   (make-mutex))
(define *api-process-request-count* 0)
(define *max-api-process-requests* 0)
(define *server-overloaded*  #f)

;; client
(define *rmt-mutex*         (make-mutex))     ;; remote access calls mutex 

;; RPC transport
(define *rpc:listener*      #f)

;; KEY info
(define *target*            (make-hash-table)) ;; cache the target here; target is keyval1/keyval2/.../keyvalN
(define *keys*              (make-hash-table)) ;; cache the keys here
(define *keyvals*           (make-hash-table))
(define *toptest-paths*     (make-hash-table)) ;; cache toptest path settings here
(define *test-paths*        (make-hash-table)) ;; cache test-id to test run paths here
(define *test-ids*          (make-hash-table)) ;; cache run-id, testname, and item-path => test-id
(define *test-info*         (make-hash-table)) ;; cache the test info records, update the state, status, run_duration etc. from testdat.db

(define *run-info-cache*     (make-hash-table)) ;; run info is stable, no need to reget
(define *launch-setup-mutex* (make-mutex))     ;; need to be able to call launch:setup often so mutex it and re-call the real deal only if *toppath* not set
(define *homehost-mutex*     (make-mutex))

;; Miscellaneous
(define *triggers-mutex*     (make-mutex))     ;; block overlapping processing of triggers

;; this was cached based on results from profiling but it turned out the profiling
;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching
;; in for now but can probably take it out later.
;;
(define (debug:calc-verbosity vstr verbose quiet) ;; verbose and quiet are #f or enabled
  (or (hash-table-ref/default *verbosity-cache* vstr #f)
      (let ((res (cond

	(lambda ()
	  ;; (if *logging*
	  ;;    (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params))))
		;; (exec-fn 'db:log-event res))
	      ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res)
	  (apply print "INFO: (" n ") " params) ;; res)
	  )))) ;; )

;; Lookup a value in runconfigs based on -reqtarg or -target
;; 
(define (runconfigs-get config var)
  (let ((targ (common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET"))))
    (if targ
	(or (configf:lookup config targ var)
	    (configf:lookup config "default" var))
	(configf:lookup config "default" var))))

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

(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  (or (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
     ((or (args:get-arg "--modepatt") (args:get-arg "-modepatt")) ;; modepatt is a forced setting, when set it MUST refer to an existing PATT in the runconfig
      (if rconf
	  (let* ((patts-from-mode-patt	  (runconfigs-get rconf testpatt-key)))
	    (debug:print-info 0 *default-log-port* "modepatt defined is: "testpatt-key" runconfigs values for  " testpatt-key " "  patts-from-mode-patt)
	    patts-from-mode-patt)
	  (begin
	    (debug:print-info 0 *default-log-port* " modepatt defined is: "testpatt-key" runconfigs values for  " testpatt-key) ;;  " " patts-from-mode-patt)
	    #f)))     ;; We do NOT fall back to "%"
     ;; (tags-testpatt
     ;;  (debug:print-info 0 *default-log-port* "-tagexpr "tagexpr" selects testpatt "tags-testpatt)
     ;;  tags-testpatt)
     ((and (equal? args-testpatt "%") rtestpatt)
      (debug:print-info 0 *default-log-port* "testpatt defined in "testpatt-key" from runconfigs: " rtestpatt)
      rtestpatt)
     (else 
      (debug:print-info 0 *default-log-port* "using testpatt " args-testpatt " rtestpatt:" rtestpatt)
      args-testpatt))))



(define (common:get-linktree)
  (or (getenv "MT_LINKTREE")
      (if *configdat*
	  (configf:lookup *configdat* "setup" "linktree")
	  (if *toppath*
	      (conc *toppath* "/lt")
	      #f))))

(define (common:args-get-runname)
  (let ((res (or (args:get-arg "-runname")
		 (args:get-arg ":runname")
		 (getenv "MT_RUNNAME"))))
    ;; (if res (set-environment-variable "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ...
    res))

(define (common:get-fields cfgdat)
  (let ((fields (hash-table-ref/default cfgdat "fields" '())))
    (map car fields)))

(define (common:args-get-target #!key (split #f)(exit-if-bad #f))
  (let* ((keys    (if (hash-table? *configdat*) (common:get-fields *configdat*) '()))
	 (numkeys (length keys))
	 (target  (or (args:get-arg "-reqtarg")
		      (args:get-arg "-target")
		      (getenv "MT_TARGET")))
	 (tlist   (if target (string-split target "/" #t) '()))
	 (valid   (if target
		      (or (null? keys) ;; probably don't know our keys yet
			  (and (not (null? tlist))
			       (eq? numkeys (length tlist))
			       (null? (filter string-null? tlist))))
		      #f)))
    (if valid
	(if split
	    tlist
	    target)
	(if target
	    (begin
	      (debug:print-error 0 *default-log-port* "Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements")
	      (if exit-if-bad (exit 1))
	      #f)
	    #f))))

;; looking only (at least for now) at the MT_ variables craft the full testname
;;
(define (common:get-full-test-name)
  (if (getenv "MT_TEST_NAME")
      (if (and (getenv "MT_ITEMPATH")
               (not (equal? (getenv "MT_ITEMPATH") "")))
          (getenv "MT_TEST_NAME")
          (conc (getenv "MT_TEST_NAME") "/" (getenv "MT_ITEMPATH")))
      #f))


;;======================================================================
;; S T A T E S   A N D   S T A T U S E S
;;======================================================================

;; BBnote: *common:std-states* - dashboard filter control and test control state buttons defined here; used in set-fields-panel and dboard:make-controls

(define (get-file-descriptor-count #!key  (pid (current-process-id )))
  (list
    (length (glob (conc "/proc/" pid "/fd/*")))
    (length  (filter identity (map socket? (glob (conc "/proc/" pid "/fd/*")))))
  )
)

  

;; GLOBALS

(define *common:logpro-exit-code->status-sym-alist*
  '( ( 0 . pass )
     ( 1 . fail )
     ( 2 . warn )
;; CONTEXTS
#;(defstruct cxt
     ( 3 . check )
  (taskdb #f)
  (cmutex (make-mutex)))
;; (define *contexts* (make-hash-table))
;; (define *context-mutex* (make-mutex))

     ( 4 . waived )
;; ;; safe method for accessing a context given a toppath
;; ;;
;; (define (common:with-cxt toppath proc)
;;   (mutex-lock! *context-mutex*)
;;   (let ((cxt (hash-table-ref/default *contexts* toppath #f)))
;;     (if (not cxt)
     ( 5 . abort )
;;         (set! cxt (let ((x (make-cxt)))(hash-table-set! *contexts* toppath x) x)))
;;     (let ((cxt-mutex (cxt-mutex cxt)))
;;       (mutex-unlock! *context-mutex*)
;;       (mutex-lock! cxt-mutex)
;;       (let ((res (proc cxt)))
;;         (mutex-unlock! cxt-mutex)
;;         res))))
        
     ( 6 . skip )))
;; A hash table that can be accessed by #{scheme ...} calls in
;; config files. Allows communicating between confgs
;;
(define *user-hash-data* (make-hash-table))

(define *db-keys* #f)

(define (common:logpro-exit-code->status-sym exit-code)
  (or (alist-ref exit-code *common:logpro-exit-code->status-sym-alist*) 'fail))
(define *pkts-info*    (make-hash-table)) ;; store stuff like the last parent here
(define *configinfo*   #f)   ;; raw results from setup, includes toppath and table from megatest.config
(define *runconfigdat* #f)   ;; run configs data
(define *configdat*    #f)   ;; megatest.config data
(define *configstatus* #f)   ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done
(define *toppath*      #f)
(define *already-seen-runconfig-info* #f)

(define *test-meta-updated* (make-hash-table))
(define *globalexitstatus*  0) ;; attempt to work around possible thread issues
(define (common:worse-status-sym ss1 ss2)
  (let loop ((status-syms-remaining '(abort fail check skip warn waived pass)))
    (cond
     ((null? status-syms-remaining)
(define *passnum*           0) ;; when running track calls to run-tests or similar
;; (define *alt-log-file* #f)  ;; used by -log
(define *common:denoise*    (make-hash-table)) ;; for low noise printing
(define *default-log-port*  (current-error-port))
(define *default-area-tag* "local")

      'fail)
     ((eq? (car status-syms-remaining) ss1)
;; DATABASE
(define *dbstruct-db*         #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this.
;; db access
      ss1)
(define *db-last-access*      (current-seconds)) ;; last db access, used in server
(define *db-write-access*     #t)
;; db sync
     ((eq? (car status-syms-remaining) ss2)
      ss2)
(define *db-last-sync*        0)                 ;; last time the sync to megatest.db happened
(define *db-sync-in-progress* #f)                ;; if there is a sync in progress do not try to start another
(define *db-multi-sync-mutex* (make-mutex))      ;; protect access to *db-sync-in-progress*, *db-last-sync*
;; task db
     (else
(define *task-db*             #f) ;; (vector db path-to-db)
(define *db-access-allowed*   #t) ;; flag to allow access
(define *db-access-mutex*     (make-mutex))
(define *db-transaction-mutex* (make-mutex))
(define *db-cache-path*       #f)
(define *db-with-db-mutex*    (make-mutex))
(define *db-api-call-time*    (make-hash-table)) ;; hash of command => (list of times)
;; no sync db
(define *no-sync-db*          #f)

      (loop (cdr status-syms-remaining))))))
;; SERVER
(define *my-client-signature* #f)
(define *transport-type*    'http)             ;; override with [server] transport http|rpc|nmsg
(define *runremote*         #f)                ;; if set up for server communication this will hold <host port>
;; (define *max-cache-size*    0)
(define *logged-in-clients* (make-hash-table))
(define *server-id*         #f)
(define *server-info*       #f)  ;; good candidate for easily convert to non-global
(define *time-to-exit*      #f)
(define *server-run*        #t)
(define *run-id*            #f)
(define *server-kind-run*   (make-hash-table))
(define *home-host*         #f)
;; (define *total-non-write-delay* 0)
(define *heartbeat-mutex*   (make-mutex))
(define *api-process-request-count* 0)
(define *max-api-process-requests* 0)
(define *server-overloaded*  #f)

;; client
(define *rmt-mutex*         (make-mutex))     ;; remote access calls mutex 

(define (common:steps-can-proceed-given-status-sym status-sym)
  (if (member status-sym '(warn waived pass))
;; RPC transport
(define *rpc:listener*      #f)

      #t
;; KEY info
(define *target*            (make-hash-table)) ;; cache the target here; target is keyval1/keyval2/.../keyvalN
(define *keys*              (make-hash-table)) ;; cache the keys here
(define *keyvals*           (make-hash-table))
(define *toptest-paths*     (make-hash-table)) ;; cache toptest path settings here
(define *test-paths*        (make-hash-table)) ;; cache test-id to test run paths here
(define *test-ids*          (make-hash-table)) ;; cache run-id, testname, and item-path => test-id
(define *test-info*         (make-hash-table)) ;; cache the test info records, update the state, status, run_duration etc. from testdat.db

      #f))
(define *run-info-cache*     (make-hash-table)) ;; run info is stable, no need to reget
(define *launch-setup-mutex* (make-mutex))     ;; need to be able to call launch:setup often so mutex it and re-call the real deal only if *toppath* not set
(define *homehost-mutex*     (make-mutex))

;; Miscellaneous
(define *triggers-mutex*     (make-mutex))     ;; block overlapping processing of triggers










(define (status-sym->string status-sym)
  (case status-sym
      ((pass) "PASS")
    ((fail) "FAIL")
    ((warn) "WARN")
    ((check) "CHECK")
    ((waived) "WAIVED")
    ((abort) "ABORT")
    ((skip) "SKIP")
    (else "FAIL")))



(define (common:logpro-exit-code->test-status exit-code)
  (status-sym->string (common:logpro-exit-code->status-sym exit-code)))




;; (define (common:low-noise-print alldat waitval . keys)
;;   (let* ((key      (string-intersperse (map conc keys) "-" ))
;; 	 (lasttime (hash-table-ref/default (alldat-denoise alldat) key 0))
;; 	 (currtime (current-seconds)))
;;     (if (> (- currtime lasttime) waitval)
;; 	(begin
;; 	  (hash-table-set! (alldat-denoise alldat) key currtime)
;; 	  #t)
;; 	#f)))
;; 
;; (define (common:version-signature alldat)
;;   (conc (alldat-megatest-version alldat)
;; 	"-" (substring (alldat-megatest-fossil-hash alldat) 0 4)))
;; 
;; (define (common:get-fields cfgdat)
;;   (let ((fields (hash-table-ref/default cfgdat "fields" '())))
;;     (map car fields)))
(define (common:clear-caches)
  (set! *target*             (make-hash-table))
  (set! *keys*               (make-hash-table))
;; 
;; ;;======================================================================
;; ;; T I M E   A N D   D A T E
;; ;;======================================================================
;; 
;; ;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5
;; (define (common:hms-string->seconds tstr)
;;   (let ((parts     (string-split-fields "\\w+" tstr))
;; 	(time-secs 0)
;; 	;; s=seconds, m=minutes, h=hours, d=days, M=months, y=years, w=weeks
;; 	(trx       (regexp "(\\d+)([smhdMyw])")))
;;     (for-each (lambda (part)
;; 		(let ((match  (string-match trx part)))
;; 		  (if match
;; 		      (let ((val (string->number (cadr match)))
;; 			    (unt (caddr match)))
;; 			(if val 
;; 			    (set! time-secs (+ time-secs (* val
;; 							    (case (string->symbol unt)
;; 							      ((s) 1)
  (set! *keyvals*            (make-hash-table))
;; 							      ((m) 60) ;; minutes
;; 							      ((h) 3600)
;; 							      ((d) 86400)
;; 							      ((w) 604800)
  (set! *toptest-paths*      (make-hash-table))
  (set! *test-paths*         (make-hash-table))
  (set! *test-ids*           (make-hash-table))
;; 							      ((M) 2628000) ;; aproximately one month
;; 							      ((y) 31536000)
;; 							      (else #f))))))))))
;; 	      parts)
  (set! *test-info*          (make-hash-table))
  (set! *run-info-cache*     (make-hash-table))
  (set! *env-vars-by-run-id* (make-hash-table))
  (set! *test-id-cache*      (make-hash-table)))
;;     time-secs))
;; 		       
;; (define (seconds->hr-min-sec secs)
;;   (let* ((hrs (quotient secs 3600))
;; 	 (min (quotient (- secs (* hrs 3600)) 60))

;; 	 (sec (- secs (* hrs 3600)(* min 60))))
;;     (conc (if (> hrs 0)(conc hrs "hr ") "")
;; 	  (if (> min 0)(conc min "m ")  "")
;; 	  sec "s")))
;; 
;; (define (seconds->time-string sec)
;;   (time->string 
;; Generic string database
;;    (seconds->local-time sec) "%H:%M:%S"))
;; 
;; (define (seconds->work-week/day-time sec)
;;   (time->string
;;    (seconds->local-time sec) "ww%V.%u %H:%M"))
;; 
;; (define (seconds->work-week/day sec)
(define sdb:qry #f) ;; (make-sdb:qry)) ;;  'init #f)
;;   (time->string
;;    (seconds->local-time sec) "ww%V.%u"))
;; 
;; Generic path database
;; (define (seconds->year-work-week/day sec)
;;   (time->string
;;    (seconds->local-time sec) "%yww%V.%w"))
;; 
;; (define (seconds->year-work-week/day-time sec)
;;   (time->string
;;    (seconds->local-time sec) "%Yww%V.%w %H:%M"))
;; 
;; (define (seconds->year-week/day-time sec)
;;   (time->string
;;    (seconds->local-time sec) "%Yw%V.%w %H:%M"))
;; 
;; (define (seconds->quarter sec)
;;   (case (string->number
(define *fdb* #f)

;; 	 (time->string 
;; 	  (seconds->local-time sec)
;; 	  "%m"))
;;     ((1 2 3) 1)
;;     ((4 5 6) 2)
;;     ((7 8 9) 3)
;;     ((10 11 12) 4)
;;     (else #f)))
(define *last-launch* (current-seconds)) ;; use for throttling the launch rate. Would be better to use the db and last time of a test in LAUNCHED state.

;;======================================================================
;; V E R S I O N
;;======================================================================

;; 
;; ;; basic ISO8601 format (e.g. "2017-02-28 06:02:54") date time => Unix epoch
;; ;;
;; (define (common:date-time->seconds datetime)
;;   (local-time->seconds (string->time datetime "%Y-%m-%d %H:%M:%S")))
(define (common:get-full-version)
  (conc megatest-version "-" megatest-fossil-hash))

;; 
;; ;; given span of seconds tstart to tend
;; ;; find start time to mark and mark delta
;; ;;
;; (define (common:find-start-mark-and-mark-delta tstart tend)
(define (common:version-signature)
;;   (let* ((deltat   (- (max tend (+ tend 10)) tstart)) ;; can't handle runs of less than 4 seconds. Pad it to 10 seconds ...
;; 	 (result   #f)
;; 	 (min      60)
;; 	 (hr       (* 60 60))
;; 	 (day      (* 24 hr))
;; 	 (yr       (* 365 day)) ;; year
;; 	 (mo       (/ yr 12))
;; 	 (wk       (* day 7)))
;;     (for-each
;;      (lambda (max-blks)
;;        (for-each
;; 	(lambda (span) ;; 5 2 1
;; 	  (if (not result)
;; 	      (for-each 
;; 	       (lambda (timeunit timesym) ;; year month day hr min sec
;; 		 (if (not result)
;; 		     (let* ((time-blk (* span timeunit))
;; 			    (num-blks (quotient deltat time-blk)))
;; 		       (if (and (> num-blks 4)(< num-blks max-blks))
;; 			   (let ((first (* (quotient tstart time-blk) time-blk)))
;; 			     (set! result (list span timeunit time-blk first timesym))
;; 			     )))))
  (conc megatest-version "-" (substring megatest-fossil-hash 0 4)))


;; 	       (list yr mo wk day hr min 1)
;; 	       '(     y  mo w  d   h  m   s))))
;; 	(list 8 6 5 2 1)))
;;      '(5 10 15 20 30 40 50 500))
;;     (if values
;; 	(apply values result)
;; 	(values 0 day 1 0 'd))))
;; 
;; ;; given x y lim return the cron expansion
;; ;;
;; (define (common:expand-cron-slash x y lim)
(define (common:get-sync-lock-filepath)
;;   (let loop ((curr x)
;; 	     (res  `()))
;;     (if (< curr lim)
;; 	(loop (+ curr y) (cons curr res))
  (let* ((tmp-area     (common:get-db-tmp-area))
         (lockfile     (conc tmp-area "/megatest.db.sync-lock")))
    lockfile))
    
;; 	(reverse res))))
;; 
;; ;; expand a complex cron string to a list of cron strings
;; ;;
;;======================================================================
;; U S E F U L   S T U F F
;; ;;  x/y   => x, x+y, x+2y, x+3y while x+Ny<max_for_field
;; ;;  a,b,c => a, b ,c
;; ;;
;; ;;   NOTE: with flatten a lot of the crud below can be factored down.
;; ;;
;; (define (common:cron-expand cron-str)
;;   (if (list? cron-str)
;;       (flatten
;;        (fold (lambda (x res)
;; 	       (if (list? x)
;; 		   (let ((newres (map common:cron-expand x)))
;; 		     (append x newres))
;; 		   (cons x res)))
;; 	     '()
;; 	     cron-str)) ;; (map common:cron-expand cron-str))
;;       (let ((cron-items (string-split cron-str))
;;======================================================================

;; convert things to an alist or assoc list, #f gets converted to ""
;; 	    (slash-rx   (regexp "(\\d+)/(\\d+)"))
;; 	    (comma-rx   (regexp ".*,.*"))
;; 	    (max-vals   '((min        . 60)
;; 			  (hour       . 24)
;; 			  (dayofmonth . 28) ;;; BUG!!!! This will be a bug for some combinations
;; 			  (month      . 12)
;; 			  (dayofweek  . 7))))
;; 	(if (< (length cron-items) 5) ;; bad spec
;; 	    cron-str ;; `(,cron-str)              ;; just return the string, something downstream will fix it
;; 	    (let loop ((hed  (car cron-items))
;; 		       (tal  (cdr cron-items))
;; 		       (type 'min)
;; 		       (type-tal '(hour dayofmonth month dayofweek))
;; 		       (res  '()))
;; 	      (regex-case
;; 		  hed
;;
;; 		(slash-rx ( _ base incr ) (let* ((basen          (string->number base))
;; 						 (incrn          (string->number incr))
;; 						 (expanded-vals  (common:expand-cron-slash basen incrn (alist-ref type max-vals)))
(define (common:to-alist dat)
;; 						 (new-list-crons (fold (lambda (x myres)
;; 									 (cons (conc (if (null? res)
  (cond
;; 											 ""
;; 											 (conc (string-intersperse res " ") " "))
;; 										     x " " (string-intersperse tal " "))
;; 									       myres))
;; 								       '() expanded-vals)))
;; 					    ;; (print "new-list-crons: " new-list-crons)
;; 					    ;; (fold (lambda (x res)
;; 					    ;; 	    (if (list? x)
;; 					    ;; 		(let ((newres (map common:cron-expand x)))
   ((list? dat)   (map common:to-alist dat))
   ((vector? dat)
    (map common:to-alist (vector->list dat)))
;; 					    ;; 		  (append x newres))
;; 					    ;; 		(cons x res)))
   ((pair? dat)
    (cons (common:to-alist (car dat))
;; 					    ;; 	  '()
;; 					    (flatten (map common:cron-expand new-list-crons))))
	  (common:to-alist (cdr dat))))
   ((hash-table? dat)
    (map common:to-alist (hash-table->alist dat)))
;; 		;;					    (map common:cron-expand (map common:cron-expand new-list-crons))))
;; 		(else (if (null? tal)
   (else
;; 			  cron-str
;; 			  (loop (car tal)(cdr tal)(car type-tal)(cdr type-tal)(append res (list hed)))))))))))
;; 		      
;; 	    
;; ;; given a cron string and the last time event was processed return #t to run or #f to not run
;; ;;
;; ;;  min    hour   dayofmonth month  dayofweek
    (if dat
	dat
	""))))

;; ;; 0-59    0-23   1-31       1-12   0-6          ### NOTE: dayofweek does not include 7
;; ;;
;; ;;  #t => yes, run the job
;; ;;  #f => no, do not run the job
;; ;;
;; (define (common:cron-event cron-str now-seconds-in last-done) ;; ref-seconds = #f is NOW.
(define (common:alist-ref/default key alist default)
;;   (let* ((cron-items     (map string->number (string-split cron-str)))
;; 	 (now-seconds    (or now-seconds-in (current-seconds)))
;; 	 (now-time       (seconds->local-time now-seconds))
;; 	 (last-done-time (seconds->local-time last-done))
;; 	 (all-times      (make-hash-table)))
;;     ;; (print "cron-items: " cron-items "(length cron-items): " (length cron-items))
;;     (if (not (eq? (length cron-items) 5)) ;; don't even try to figure out junk strings
;; 	#f
;; 	(match-let (((     cmin chour cdayofmonth cmonth    cdayofweek)
;; 		     cron-items)
;; 		    ;; 0     1    2        3         4    5      6
;; 		    ((nsec nmin nhour ndayofmonth nmonth nyr ndayofweek n7 n8 n9)
;; 		     (vector->list now-time))
  (or (alist-ref key alist) default))
;; 		    ((lsec lmin lhour ldayofmonth lmonth lyr ldayofweek l7 l8 l9)
;; 		     (vector->list last-done-time)))
;; 	  ;; create all possible time slots
;; 	  ;; remove invalid slots due to (for example) day of week
;; 	  ;; get the start and end entries for the ref-seconds (current) time
;; 	  ;; if last-done > ref-seconds => this is an ERROR!
;; 	  ;; does the last-done time fall in the legit region?
;; 	  ;;    yes => #f  do not run again this command

(define (common:low-noise-print waitval . keys)
;; 	  ;;    no  => #t  ok to run the command
;; 	  (for-each ;; month
;; 	   (lambda (month)
;; 	     (for-each ;; dayofmonth
;; 	      (lambda (dom)
  (let* ((key      (string-intersperse (map conc keys) "-" ))
;; 		(for-each
;; 		 (lambda (hr) ;; hour
;; 		   (for-each
;; 		    (lambda (minute) ;; minute
;; 		      (let ((copy-now (apply vector (vector->list now-time))))
;; 			(vector-set! copy-now 0 0) ;; force seconds to zero
	 (lasttime (hash-table-ref/default *common:denoise* key 0))
	 (currtime (current-seconds)))
;; 			(vector-set! copy-now 1 minute)
;; 			(vector-set! copy-now 2 hr)
;; 			(vector-set! copy-now 3 dom)  ;; dom is already corrected for zero referenced
;; 			(vector-set! copy-now 4 month)
;; 			(let* ((copy-now-secs (local-time->seconds copy-now))
;; 			       (new-copy      (seconds->local-time copy-now-secs))) ;; remake the time vector
;; 			  (if (or (not cdayofweek)
    (if (> (- currtime lasttime) waitval)
;; 				  (equal? (vector-ref new-copy 6)
;; 					  cdayofweek)) ;; if the day is specified and a match OR if the day is NOT specified
;; 			      (if (or (not cdayofmonth)
;; 				      (equal? (vector-ref new-copy 3)
;; 					      (+ 1 cdayofmonth))) ;; if the month is specified and a match OR if the month is NOT specified
;; 				  (hash-table-set! all-times copy-now-secs new-copy))))))
	(begin
	  (hash-table-set! *common:denoise* key currtime)
;; 		    (if cmin
;; 			`(,cmin)  ;; if given cmin, have to use it
;; 			(list (- nmin 1) nmin (+ nmin 1))))) ;; minute
;; 		 (if chour
	  #t)
	#f)))

;; 		     `(,chour)
;; 		     (list (- nhour 1) nhour (+ nhour 1))))) ;; hour
;; 	      (if cdayofmonth
;; 		  `(,cdayofmonth)
(define (common:get-megatest-exe)
;; 		  (list (- ndayofmonth 1) ndayofmonth (+ ndayofmonth 1)))))
;; 	   (if cmonth
;; 	       `(,cmonth)
  (or (getenv "MT_MEGATEST") "megatest"))

(define (common:read-encoded-string instr)
;; 	       (list (- nmonth 1) nmonth (+ nmonth 1))))
;; 	  (let ((before #f)
  (handle-exceptions
;; 		(is-in  #f))
;; 	    (for-each
   exn
;; 	     (lambda (moment)
;; 	       (if (and before
   (handle-exceptions
;; 			(<= before now-seconds)
;; 			(>= moment now-seconds))
;; 		   (begin
;; 		     ;; (print)
    exn
    (begin
      (debug:print-error 0 *default-log-port* "received bad encoded string \"" instr "\", message: " ((condition-property-accessor 'exn 'message) exn))
      (print-call-chain (current-error-port))
;; 		     ;; (print "Before: " (time->string (seconds->local-time before)))
;; 		     ;; (print "Now:    " (time->string (seconds->local-time now-seconds)))
;; 		     ;; (print "After:  " (time->string (seconds->local-time moment)))
;; 		     ;; (print "Last:   " (time->string (seconds->local-time last-done)))
;; 		     (if (<  last-done before)
;; 			 (set! is-in before))
;; 		     ))
;; 	       (set! before moment))
;; 	     (sort (hash-table-keys all-times) <))
;; 	    is-in)))))
;; 
;; (define (common:extended-cron  cron-str now-seconds-in last-done)
;;   (let ((expanded-cron (common:cron-expand cron-str)))
;;     (if (string? expanded-cron)
;; 	(common:cron-event expanded-cron now-seconds-in last-done)
;; 	(let loop ((hed (car expanded-cron))
;; 		   (tal (cdr expanded-cron)))
;; 	  (if (common:cron-event hed now-seconds-in last-done)
;; 	      #t
;; 	      (if (null? tal)
;; 		  #f
;; 		  (loop (car tal)(cdr tal))))))))
;; 
;; ;;======================================================================
;; ;; C O L O R S
;; ;;======================================================================
;;       
;; (define (common:name->iup-color name)
      #f)
    (read (open-input-string (base64:base64-decode instr))))
   (read (open-input-string (z3:decode-buffer (base64:base64-decode instr))))))

;;======================================================================
;; Configf extentions
;;======================================================================

(define (get-with-default val default)
;;   (case (string->symbol (string-downcase name))
;;     ((red)    "223 33 49")
;;     ((grey)   "192 192 192")
;;     ((orange) "255 172 13")
;;     ((purple) "This is unfinished ...")))
;; 
;; ;; (define (common:get-color-for-state-status state status)
  (let ((val (args:get-arg val)))
;; ;;   (case (string->symbol state)
;; ;;     ((COMPLETED)
;; ;;      (case (string->symbol status)
;; ;;        ((PASS)        "70  249 73")
;; ;;        ((WARN WAIVED) "255 172 13")
;; ;;        ((SKIP)        "230 230 0")
;; ;;        (else "223 33 49")))
;; ;;     ((LAUNCHED)         "101 123 142")
;; ;;     ((CHECK)            "255 100 50")
;; ;;     ((REMOTEHOSTSTART)  "50  130 195")
;; ;;     ((RUNNING)          "9   131 232")
;; ;;     ((KILLREQ)          "39  82  206")
;; ;;     ((KILLED)           "234 101 17")
;; ;;     ((NOT_STARTED)      "240 240 240")
;; ;;     (else               "192 192 192")))
;; 
;; (define (common:iup-color->rgb-hex instr)
;;   (string-intersperse 
;;    (map (lambda (x)
;;           (number->string x 16))
;;         (map string->number
;;              (string-split instr)))
;;    "/"))
;; 
;; ;; dot-locking egg seems not to work, using this for now
    (if val val default)))

(define (assoc/default key lst . default)
;; ;; if lock is older than expire-time then remove it and try again
;; ;; to get the lock
;; ;;
;; (define (common:simple-file-lock fname #!key (expire-time 300))
;;     (if (file-exists? fname)
;; 	(if (> (- (current-seconds)(file-modification-time fname)) expire-time)
;; 	    (begin
  (let ((res (assoc key lst)))
    (if res (cadr res)(if (null? default) #f (car default)))))

(define (common:get-testsuite-name)
  (or (configf:lookup *configdat* "setup" "area-name") ;; megatest is a flexible tool, testsuite is too limiting a description.
      (configf:lookup *configdat* "setup" "testsuite" )
      (getenv "MT_TESTSUITE_NAME")
;;               (handle-exceptions exn #f (delete-file* fname))	
;; 	      (common:simple-file-lock fname expire-time: expire-time))
;; 	    #f)
;; 	(let ((key-string (conc (get-host-name) "-" (current-process-id))))
;; 	  (with-output-to-file fname
;; 	    (lambda ()
;; 	      (print key-string)))
      (if (string? *toppath* )
;; 	  (thread-sleep! 0.25)
;; 	  (if (file-exists? fname)
;; 	      (handle-exceptions exn
;;                 #f 
;;                 (with-input-from-file fname
          (pathname-file *toppath*)
;; 	  	  (lambda ()
;; 		    (equal? key-string (read-line)))))
;; 	      #f))))
;; 
;; (define (common:simple-file-lock-and-wait fname #!key (expire-time 300))
;;   (let ((end-time (+ expire-time (current-seconds))))
;;     (let loop ((got-lock (common:simple-file-lock fname expire-time: expire-time)))
;;       (if got-lock
;; 	  #t
;; 	  (if (> end-time (current-seconds))
          #f))) ;; (pathname-file (current-directory)))))
;; 	      (begin
;; 		(thread-sleep! 3)
;; 		(loop (common:simple-file-lock fname expire-time: expire-time)))
;; 	      #f)))))
;; 
;; (define (common:simple-file-release-lock fname)
;;   (handle-exceptions

(define common:get-area-name common:get-testsuite-name)

;;       exn
;;       #f ;; I don't really care why this failed (at least for now)
;;     (delete-file* fname)))
;; 
;; ;; lazy-safe get file mod time. on any error (file not existing etc.) return 0
;; ;;
;; (define (common:lazy-modification-time fpath)
(define (common:get-db-tmp-area . junk)
;;   (handle-exceptions
;;       exn
;;       0
;;       (file-modification-time fpath)))
  (if *db-cache-path*
;; 
;; ;; 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
;; 			`(,(conc "/no/such/file, message: " ((condition-property-accessor 'exn 'message) exn)))
;; 		      (glob (conc fpath "*"))))
      *db-cache-path*
;;          (file-list (if (eq? 0 (length glob-list))
;; 			'("/no/such/file")
;; 			glob-list)))
;;   (apply max
;;    (map
;;     common:lazy-modification-time 
      (if *toppath* ;; common:get-create-writeable-dir
;;     file-list))))
;; 
;; 
;; ;; execute thunk, return value.  If exception thrown, trap exception, return #f, and emit nonfatal condition note to *default-log-port* .
;; ;; arguments - thunk, message
;; (define (common:fail-safe thunk warning-message-on-exception)
;;   (handle-exceptions
;;    exn
;;    (begin
	  (handle-exceptions
	      exn
	      (begin
;;      (debug:print-info 0 *default-log-port* "notable but nonfatal condition - "warning-message-on-exception)
;;      (debug:print-info 0 *default-log-port*
;;                        (string-substitute "\n?Error:" "nonfatal condition:"
;;                                           (with-output-to-string
;;                                             (lambda ()
		(debug:print-error 0 *default-log-port* "Couldn't create path to " *db-cache-path*)
		(exit 1))
	    (let ((dbpath (common:get-create-writeable-dir
			   (list (conc "/tmp/" (current-user-name)
				       "/megatest_localdb/"
;;                                               (print-error-message exn) ))))
;;      (debug:print-info 0 *default-log-port* "    -- continuing after nonfatal condition...")
;;      #f)
;;    (thunk)))
;; 
;; (define getenv get-environment-variable)
				       (common:get-testsuite-name) "/"
;; (define (safe-setenv key val)
;;   (if (or (substring-index "!" key) (substring-index ":" key)) ;; variables containing : are for internal use and cannot be environment variables.
;;       (debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\" or starting with \"!\"")
;;       (if (and (string? val)
;; 	       (string? key))
				       (string-translate *toppath* "/" ".")))))) ;;  #t))))
;; 	  (handle-exceptions
;; 	      exn
;; 	      (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val)
;; 	    (setenv key val))
	      (set! *db-cache-path* dbpath)
;; 	  (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val))))
;; 
;; (define home (getenv "HOME"))
;; (define user (getenv "USER"))
;; 
;; 
;; ;; returns list of fd count, socket count
;; (define (get-file-descriptor-count #!key  (pid (current-process-id )))
;;   (list
;;     (length (glob (conc "/proc/" pid "/fd/*")))
;;     (length  (filter identity (map socket? (glob (conc "/proc/" pid "/fd/*")))))
;;   )
;; )
;;
	      dbpath))
	  #f)))


;; pulled from common_records.scm

;; globals - modules that include this need these here
(define *logging* #f)
(define *functions* (make-hash-table)) ;; symbol => fn ### TEMPORARY!!!
;; (define *toppath* #f)