;;======================================================================
;; Copyright 2017, Matthew Welland.
;;
;; This file is part of Megatest.
;;
;; Megatest is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; Megatest is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; 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))
(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)
;; (import processmod)
(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)
;; 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
((number? vstr) vstr)
((not (string? vstr)) 1)
;; ((string-match "^\\s*$" vstr) 1)
(vstr (let ((debugvals (filter number? (map string->number (string-split vstr ",")))))
(cond
((> (length debugvals) 1) debugvals)
((> (length debugvals) 0)(car debugvals))
(else 1))))
(verbose 2) ;; ((args:get-arg "-v") 2)
(quiet 0) ;; ((args:get-arg "-q") 0)
(else 1))))
(hash-table-set! *verbosity-cache* vstr res)
res)))
;; check verbosity, #t is ok
(define (debug:check-verbosity verbosity vstr)
(if (not (or (number? verbosity)
(list? verbosity)))
(begin
(print "ERROR: Invalid debug value \"" vstr "\"")
#f)
#t))
(define (debug:debug-mode n)
(cond
((and (number? *verbosity*) ;; number number
(number? n))
(<= n *verbosity*))
((and (list? *verbosity*) ;; list number
(number? n))
(member n *verbosity*))
((and (list? *verbosity*) ;; list list
(list? n))
(not (null? (lset-intersection! eq? *verbosity* n))))
((and (number? *verbosity*)
(list? n))
(member *verbosity* n))))
(define (debug:setup dmode verbose quiet)
(let ((debugstr (or dmode ;; (args:get-arg "-debug")
(get-environment-variable "MT_DEBUG_MODE"))))
(set! *verbosity* (debug:calc-verbosity debugstr verbose quiet))
(debug:check-verbosity *verbosity* debugstr)
;; if we were handed a bad verbosity rule then we will override it with 1 and continue
(if (not *verbosity*)(set! *verbosity* 1))
(if (or dmode ;; (args:get-arg "-debug")
(not (get-environment-variable "MT_DEBUG_MODE")))
(setenv "MT_DEBUG_MODE" (if (list? *verbosity*)
(string-intersperse (map conc *verbosity*) ",")
(conc *verbosity*))))))
(define (debug:print n e . params)
(if (debug:debug-mode n)
(with-output-to-port (or e (current-error-port))
(lambda ()
;; (if *logging*
;; (exec-fn 'db:log-event (apply conc params))
(apply print params)
)))) ;; )
(define (debug:print-error n e . params)
;; normal print
(if (debug:debug-mode n)
(with-output-to-port (if (port? e) e (current-error-port))
(lambda ()
;; (if *logging*
;; (exec-fn 'db:log-event (apply conc params))
;; (apply print "pid:" (current-process-id) " " params)
(apply print "ERROR: " params)
))) ;; )
;; pass important messages to stderr
(if (and (eq? n 0)(not (eq? e (current-error-port))))
(with-output-to-port (current-error-port)
(lambda ()
(apply print "ERROR: " params)
))))
(define (debug:print-info n e . params)
(if (debug:debug-mode n)
(with-output-to-port (if (port? e) e (current-error-port))
(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)
)))) ;; )
;;======================================================================
;; 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 *common:std-states* ;; for toggle buttons in dashboard
'(
(0 "ARCHIVED")
(1 "STUCK")
(2 "KILLREQ")
(3 "KILLED")
(4 "NOT_STARTED")
(5 "COMPLETED")
(6 "LAUNCHED")
(7 "REMOTEHOSTSTART")
(8 "RUNNING")
))
(define *common:dont-roll-up-states*
'("DELETED"
"REMOVING"
"CLEANING"
"ARCHIVE_REMOVING"
))
;; BBnote: *common:std-statuses* dashboard filter control and test control status buttons defined here; used in set-fields-panel and dboard:make-controls
;; note these statuses are sorted from better to worse.
;; This sort order is important to dcommon:status-compare3 and db:set-state-status-and-roll-up-items
(define *common:std-statuses*
'(;; (0 "DELETED")
(1 "n/a")
(2 "PASS")
(3 "SKIP")
(4 "WARN")
(5 "WAIVED")
(6 "CHECK")
(7 "STUCK/DEAD")
(8 "DEAD")
(9 "FAIL")
(10 "PREQ_FAIL")
(11 "PREQ_DISCARDED")
(12 "ABORT")))
(define *common:ended-states* ;; states which indicate the test is stopped and will not proceed
'("COMPLETED" "ARCHIVED" "KILLED" "KILLREQ" "STUCK" "INCOMPLETE" ))
(define *common:badly-ended-states* ;; these roll up as CHECK, i.e. results need to be checked
'("KILLED" "KILLREQ" "STUCK" "INCOMPLETE" "DEAD"))
(define *common:well-ended-states* ;; an item's prereq in this state allows item to proceed
'("PASS" "WARN" "CHECK" "WAIVED" "SKIP"))
;; BBnote: *common:running-states* used from db:set-state-status-and-roll-up-items
(define *common:running-states* ;; test is either running or can be run
'("RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "STARTED"))
(define *common:cant-run-states* ;; These are stopping conditions that prevent a test from being run
'("COMPLETED" "KILLED" "UNKNOWN" "INCOMPLETE" "ARCHIVED"))
(define *common:not-started-ok-statuses* ;; if not one of these statuses when in not_started state treat as dead
'("n/a" "na" "PASS" "FAIL" "WARN" "CHECK" "WAIVED" "DEAD" "SKIP"))
;; group tests into buckets corresponding to rollup
;;; Running, completed-pass, completed-non-pass + worst status, not started.
;; filter out
;(define (common:categorize-items-for-rollup in-tests)
; (
(define (common:special-sort items order comp)
(let ((items-order (map reverse order))
(acomp (or comp >)))
(sort items
(lambda (a b)
(let ((a-num (cadr (or (assoc a items-order) '(0 0))))
(b-num (cadr (or (assoc b items-order) '(0 0)))))
(acomp a-num b-num))))))
;; ;; given a toplevel with currstate, currstatus apply state and status
;; ;; => (newstate . newstatus)
;; (define (common:apply-state-status currstate currstatus state status)
;; (let* ((cstate (string->symbol (string-downcase currstate)))
;; (cstatus (string->symbol (string-downcase currstatus)))
;; (sstate (string->symbol (string-downcase state)))
;; (sstatus (string->symbol (string-downcase status)))
;; (nstate #f)
;; (nstatus #f))
;; (set! nstate
;; (case cstate
;; ((completed not_started killed killreq stuck archived)
;; (case sstate ;; completed -> sstate
;; ((completed killed killreq stuck archived) completed)
;; ((running remotehoststart launched) running)
;; (else unknown-error-1)))
;; ((running remotehoststart launched)
;; (case sstate
;; ((completed killed killreq stuck archived) #f) ;; need to look at all items
;; ((running remotehoststart launched) running)
;; (else unknown-error-2)))
;; (else unknown-error-3)))
;; (set! nstatus
;; (case sstatus
;; ((pass)
;; (case nstate
;; ((pass n/a deleted) pass)
;; ((warn) warn)
;; ((fail) fail)
;; ((check) check)
;; ((waived) waived)
;; ((skip) skip)
;; ((stuck/dead) stuck)
;; ((abort) abort)
;; (else unknown-error-4)))
;; ((warn)
;; (case nstate
;; ((pass warn n/a skip deleted) warn)
;; ((fail) fail)
;; ((check) check)
;; ((waived) waived)
;; ((stuck/dead) stuck)
;; (else unknown-error-5)))
;; ((fail)
;; (case nstate
;; ((pass warn fail check n/a waived skip deleted stuck/dead stuck) fail)
;; ((abort) abort)
;; (else unknown-error-6)))
;; (else unknown-error-7)))
;; (cons
;; (if nstate (symbol->string nstate) nstate)
;; (if nstatus (symbol->string nstatus) nstatus))))
;; (define *wdnum* 0)
;; (define *wdnum*mutex (make-mutex))
(define (common:human-time)
(time->string (seconds->local-time (current-seconds)) "%Y-%m-%d %H:%M:%S"))
(define *time-zero* (current-seconds)) ;; for the watchdog
;;======================================================================
;; M I S C U T I L S
;;======================================================================
;; convert stuff to a number if possible
(define (any->number val)
(cond
((number? val) val)
((string? val) (string->number val))
((symbol? val) (any->number (symbol->string val)))
(else #f)))
(define (any->number-if-possible val)
(let ((num (any->number val)))
(if num num val)))
(define (patt-list-match item patts)
(debug:print-info 8 *default-log-port* "patt-list-match item=" item " patts=" patts)
(if (and item patts) ;; here we are filtering for matches with item patterns
(let ((res #f)) ;; look through all the item-patts if defined, format is patt1,patt2,patt3 ... wildcard is %
(for-each
(lambda (patt)
(let ((modpatt (string-substitute "%" ".*" patt #t)))
(debug:print-info 10 *default-log-port* "patt " patt " modpatt " modpatt)
(if (string-match (regexp modpatt) item)
(set! res #t))))
(string-split patts ","))
res)
#t))
;; return first command that exists, else #f
;;
(define (common:which cmds)
(if (null? cmds)
#f
(let loop ((hed (car cmds))
(tal (cdr cmds)))
(let ((res (with-input-from-pipe (conc "which " hed) read-line)))
(if (and (string? res)
(common:file-exists? res))
res
(if (null? tal)
#f
(loop (car tal)(cdr tal))))))))
(define (common:get-install-area)
(let ((exe-path (car (argv))))
(if (common:file-exists? exe-path)
(handle-exceptions
exn
#f
(pathname-directory
(pathname-directory
(pathname-directory exe-path))))
#f)))
;; return first path that can be created or already exists and is writable
;;
(define (common:get-create-writeable-dir dirs)
(if (null? dirs)
#f
(let loop ((hed (car dirs))
(tal (cdr dirs)))
(let ((res (or (and (directory? hed)
(file-write-access? hed)
hed)
(handle-exceptions
exn
(begin
(debug:print-info 0 *default-log-port* "could not create " hed ", this might cause problems down the road.")
#f)
(create-directory hed #t)))))
(if (and (string? res)
(directory? res))
res
(if (null? tal)
#f
(loop (car tal)(cdr tal))))))))
;; return the youngest timestamp . filename
;;
(define (common:get-youngest glob-list)
(let ((all-files (apply append
(map (lambda (patt)
(handle-exceptions
exn
'()
(glob patt)))
glob-list))))
(fold (lambda (fname res)
(let ((last-mod (car res))
(curmod (handle-exceptions
exn
0
(file-modification-time fname))))
(if (> curmod last-mod)
(list curmod fname)
res)))
'(0 "n/a")
all-files)))
;; use bash to expand a glob. Does NOT handle paths with spaces!
;;
(define (common:bash-glob instr)
(string-split
(with-input-from-pipe
(conc "/bin/bash -c \"echo " instr "\"")
read-line)))
(define (common:file-exists? path-string #!key (silent #f))
;; this avoids stack dumps in the case where
;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg: system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q...
(common:false-on-exception (lambda () (file-exists? path-string))
message: (if (not silent)
(conc "Unable to access path: " path-string)
#f)
))
(define (common:false-on-exception thunk #!key (message #f))
(handle-exceptions exn
(begin
(if message
(debug:print-info 0 *default-log-port* message))
#f) (thunk) ))
(define (common:directory-exists? path-string)
;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg: system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q...
(common:false-on-exception (lambda () (directory-exists? path-string))
message: (conc "Unable to access path: " path-string)
))
;; does the directory exist and do we have write access?
;;
;; returns the directory or #f
;;
(define (common:directory-writable? path-string)
(handle-exceptions
exn
#f
(if (and (directory-exists? path-string)
(file-write-access? path-string))
path-string
#f)))
;;======================================================================
;; M I S C L I S T S
;;======================================================================
;; items in lista are matched value and position in listb
;; return the remaining items in listb or #f
;;
(define (common:list-is-sublist lista listb)
(if (null? lista)
listb ;; all items in listb are "remaining"
(if (> (length lista)(length listb))
#f
(let loop ((heda (car lista))
(tala (cdr lista))
(hedb (car listb))
(talb (cdr listb)))
(if (equal? heda hedb)
(if (null? tala) ;; we are done
talb
(loop (car tala)
(cdr tala)
(car talb)
(cdr talb)))
#f)))))
;; Needed for long lists to be sorted where (apply max ... ) dies
;;
(define (common:max inlst)
(let loop ((max-val (car inlst))
(hed (car inlst))
(tal (cdr inlst)))
(if (not (null? tal))
(loop (max hed max-val)
(car tal)
(cdr tal))
(max hed max-val))))
;; get min or max, use > for max and < for min, this works around the limits on apply
;;
(define (common:min-max comp lst)
(if (null? lst)
#f ;; better than an exception for my needs
(fold (lambda (a b)
(if (comp a b) a b))
(car lst)
lst)))
;; get min or max, use > for max and < for min, this works around the limits on apply
;;
(define (common:sum lst)
(if (null? lst)
0
(fold (lambda (a b)
(+ a b))
(car lst)
lst)))
;; path list to hash-table tree
;; ((a b c)(a b d)(e b c)) => ((a (b (d) (c))) (e (b (c))))
;;
(define (common:list->htree lst)
(let ((resh (make-hash-table)))
(for-each
(lambda (inlst)
(let loop ((ht resh)
(hed (car inlst))
(tal (cdr inlst)))
(if (hash-table-ref/default ht hed #f)
(if (not (null? tal))
(loop (hash-table-ref ht hed)
(car tal)
(cdr tal)))
(begin
(hash-table-set! ht hed (make-hash-table))
(loop ht hed tal)))))
lst)
resh))
(define *host-loads* (make-hash-table))
;; cache environment vars for each run here
(define *env-vars-by-run-id* (make-hash-table))
;; Testconfig and runconfig caches.
(define *testconfigs* (make-hash-table)) ;; test-name => testconfig
(define *runconfigs* (make-hash-table)) ;; target => runconfig
;; This is a cache of pre-reqs met, don't re-calc in cases where called with same params less than
;; five seconds ago
(define *pre-reqs-met-cache* (make-hash-table))
;; cache of verbosity given string
;;
(define *verbosity-cache* (make-hash-table))
;; 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
(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 ()
(print-error-message exn) ))))
(debug:print-info 0 *default-log-port* " -- continuing after nonfatal condition...")
#f)
(thunk)))
(define getenv get-environment-variable)
(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))
(handle-exceptions
exn
(debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val)
(setenv key val))
(debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val))))
(define home (getenv "HOME"))
(define user (getenv "USER"))
;; put any changed environment variables back to how they were - TODO - turn this into some sort of with-
(define (common:set-vars-back all-vars)
(for-each
(lambda (vardat)
(let ((var (car vardat))
(val (cdr vardat)))
(if (not (equal? (get-environment-variable var) val))
(handle-exceptions
exn
(debug:print-error 0 *default-log-port* "Failed to set " var " to " val)
(setenv var val)))))
all-vars))
;; 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/*")))))
)
)
;; 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
;; (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)))
;;
;; ;;======================================================================
;; ;; 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)
;; ((m) 60) ;; minutes
;; ((h) 3600)
;; ((d) 86400)
;; ((w) 604800)
;; ((M) 2628000) ;; aproximately one month
;; ((y) 31536000)
;; (else #f))))))))))
;; parts)
;; 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
;; (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)
;; (time->string
;; (seconds->local-time sec) "ww%V.%u"))
;;
;; (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
;; (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)))
;;
;; ;; 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")))
;;
;; ;; 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)
;; (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))
;; )))))
;; (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)
;; (let loop ((curr x)
;; (res `()))
;; (if (< curr lim)
;; (loop (+ curr y) (cons curr res))
;; (reverse res))))
;;
;; ;; expand a complex cron string to a list of cron strings
;; ;;
;; ;; 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))
;; (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)))
;; (new-list-crons (fold (lambda (x myres)
;; (cons (conc (if (null? res)
;; ""
;; (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)))
;; ;; (append x newres))
;; ;; (cons x res)))
;; ;; '()
;; (flatten (map common:cron-expand new-list-crons))))
;; ;; (map common:cron-expand (map common:cron-expand new-list-crons))))
;; (else (if (null? tal)
;; 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
;; ;; 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.
;; (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))
;; ((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
;; ;; no => #t ok to run the command
;; (for-each ;; month
;; (lambda (month)
;; (for-each ;; dayofmonth
;; (lambda (dom)
;; (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
;; (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)
;; (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))))))
;; (if cmin
;; `(,cmin) ;; if given cmin, have to use it
;; (list (- nmin 1) nmin (+ nmin 1))))) ;; minute
;; (if chour
;; `(,chour)
;; (list (- nhour 1) nhour (+ nhour 1))))) ;; hour
;; (if cdayofmonth
;; `(,cdayofmonth)
;; (list (- ndayofmonth 1) ndayofmonth (+ ndayofmonth 1)))))
;; (if cmonth
;; `(,cmonth)
;; (list (- nmonth 1) nmonth (+ nmonth 1))))
;; (let ((before #f)
;; (is-in #f))
;; (for-each
;; (lambda (moment)
;; (if (and before
;; (<= before now-seconds)
;; (>= moment now-seconds))
;; (begin
;; ;; (print)
;; ;; (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)
;; (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)
;; ;; (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 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
;; (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)))
;; (thread-sleep! 0.25)
;; (if (file-exists? fname)
;; (handle-exceptions exn
;; #f
;; (with-input-from-file fname
;; (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))
;; (begin
;; (thread-sleep! 3)
;; (loop (common:simple-file-lock fname expire-time: expire-time)))
;; #f)))))
;;
;; (define (common:simple-file-release-lock fname)
;; (handle-exceptions
;; 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)
;; (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
;; `(,(conc "/no/such/file, message: " ((condition-property-accessor 'exn 'message) exn)))
;; (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))))
;;
;;
;; ;; 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
;; (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 ()
;; (print-error-message exn) ))))
;; (debug:print-info 0 *default-log-port* " -- continuing after nonfatal condition...")
;; #f)
;; (thunk)))
;;
;; (define getenv get-environment-variable)
;; (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))
;; (handle-exceptions
;; exn
;; (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val)
;; (setenv key val))
;; (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/*")))))
;; )
;; )
;;
;; 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)
(define *transport-type* 'http)
#;(define (exec-fn fn . params)
(if (hash-table-exists? *functions* fn)
(apply (hash-table-ref *functions* fn) params)
(begin
(debug:print-error 0 "exec-fn " fn " not found")
#f)))
#;(define (set-fn fn-name fn)
(hash-table-set! *functions* fn-name fn))
(include "altdb.scm")
;; Pulled from http-transport.scm
(define (make-http-transport:server-dat)(make-vector 6))
(define (http-transport:server-dat-get-iface vec) (vector-ref vec 0))
(define (http-transport:server-dat-get-port vec) (vector-ref vec 1))
(define (http-transport:server-dat-get-api-uri vec) (vector-ref vec 2))
(define (http-transport:server-dat-get-api-url vec) (vector-ref vec 3))
(define (http-transport:server-dat-get-api-req vec) (vector-ref vec 4))
(define (http-transport:server-dat-get-last-access vec) (vector-ref vec 5))
(define (http-transport:server-dat-get-socket vec) (vector-ref vec 6))
(define (http-transport:server-dat-make-url vec)
(if (and (http-transport:server-dat-get-iface vec)
(http-transport:server-dat-get-port vec))
(conc "http://"
(http-transport:server-dat-get-iface vec)
":"
(http-transport:server-dat-get-port vec))
#f))
(define (http-transport:server-dat-update-last-access vec)
(if (vector? vec)
(vector-set! vec 5 (current-seconds))
(begin
(print-call-chain (current-error-port))
(debug:print-error 0 (current-error-port) "call to http-transport:server-dat-update-last-access with non-vector!!"))))
;;======================================================================
;;
;;======================================================================
;; allow these queries through without starting a server
;;
(define api:read-only-queries
'(get-key-val-pairs
get-var
get-keys
get-key-vals
test-toplevel-num-items
get-test-info-by-id
get-steps-info-by-id
get-data-info-by-id
test-get-rundir-from-test-id
get-count-tests-running-for-testname
get-count-tests-running
get-count-tests-running-in-jobgroup
get-previous-test-run-record
get-matching-previous-test-run-records
test-get-logfile-info
test-get-records-for-index-file
get-testinfo-state-status
test-get-top-process-pid
test-get-paths-matching-keynames-target-new
get-prereqs-not-met
get-count-tests-running-for-run-id
get-run-info
get-run-status
get-run-state
get-run-stats
get-run-times
get-targets
get-target
;; register-run
get-tests-tags
get-test-times
get-tests-for-run
get-test-id
get-tests-for-runs-mindata
get-tests-for-run-mindata
get-run-name-from-id
get-runs
simple-get-runs
get-num-runs
get-runs-cnt-by-patt
get-all-run-ids
get-prev-run-ids
get-run-ids-matching-target
get-runs-by-patt
get-steps-data
get-steps-for-test
read-test-data
read-test-data*
login
tasks-get-last
testmeta-get-record
have-incompletes?
synchash-get
get-changed-record-ids
get-run-record-ids
get-not-completed-cnt))
(define api:write-queries
'(
get-keys-write ;; dummy "write" query to force server start
;; SERVERS
start-server
kill-server
;; TESTS
test-set-state-status-by-id
delete-test-records
delete-old-deleted-test-records
test-set-state-status
test-set-top-process-pid
set-state-status-and-roll-up-items
update-pass-fail-counts
top-test-set-per-pf-counts ;; (db:top-test-set-per-pf-counts (db:get-db *db* 5) 5 "runfirst")
;; RUNS
register-run
set-tests-state-status
delete-run
lock/unlock-run
update-run-event_time
mark-incomplete
set-state-status-and-roll-up-run
;; STEPS
teststep-set-status!
delete-steps-for-test
;; TEST DATA
test-data-rollup
csv->test-data
;; MISC
sync-inmem->db
;; TESTMETA
testmeta-add-record
testmeta-update-field
;; TASKS
tasks-add
tasks-set-state-given-param-key
))
;;======================================================================
;; ALLDATA
;;======================================================================
;;
;; attempt to consolidate a bunch of global information into one struct to toss around
(defstruct alldat
;; misc
(denoise (make-hash-table))
(areapath #f) ;; i.e. toppath
(mtconfig #f)
(log-port #f)
(areadat #f) ;; i.e. runremote
(rmt-mutex (make-mutex))
(db-sync-mutex (make-mutex))
(db-with-db-mutex (make-mutex))
(read-only-queries api:read-only-queries)
(write-queries api:write-queries)
(max-api-process-requests 0)
(api-process-request-count 0)
(db-keys #f)
(megatest-version "1.6536")
(megatest-fossil-hash #f)
;; database related
(tmppath #f) ;; tmp path for dbs
;; runremote fields
(hh-dat #f) ;; (exec-fn 'common:get-homehost)) ;; homehost record ( addr . hhflag )
(server-url #f) ;; (if *toppath* (exec-fn 'server:check-if-running *toppath*))) ;; (server:check-if-running *toppath*) #f))
(last-server-check 0) ;; last time we checked to see if the server was alive
(conndat #f)
(transport *transport-type*)
(server-timeout #f) ;; (exec-fn 'server:expiration-timeout))
(force-server #f)
(ro-mode #f)
(ro-mode-checked #f) ;; flag that indicates we have checked for ro-mode
(ulex:conn #f) ;; ulex db conn is not exactly a db connector, more like a network connector
;; dbstruct
(tmpdb #f)
(dbstack #f) ;; stack for tmp db handles, do not initialize with a stack
(mtdb #f)
(refndb #f)
(homehost #f) ;; not used yet
(on-homehost #f) ;; not used yet
(read-only #f)
)
(define *alldat* (make-alldat))
;; Some of these routines use:
;;
;; http://www.cs.toronto.edu/~gfb/scheme/simple-macros.html
;;
;; Syntax for defining macros in a simple style similar to function definiton,
;; when there is a single pattern for the argument list and there are no keywords.
;;
;; (define-simple-syntax (name arg ...) body ...)
;;
(define-syntax define-simple-syntax
(syntax-rules ()
((_ (name arg ...) body ...)
(define-syntax name (syntax-rules () ((name arg ...) (begin body ...)))))))
;; (define-syntax common:handle-exceptions
;; (syntax-rules ()
;; ((_ exn-in errstmt ...)(handle-exceptions exn-in errstmt ...))))
(define-syntax common:debug-handle-exceptions
(syntax-rules ()
((_ debug exn errstmt body ...)
(if debug
(begin body ...)
(handle-exceptions exn errstmt body ...)))))
(define-syntax common:handle-exceptions
(syntax-rules ()
((_ exn errstmt body ...)
(begin body ...))))
;; (define handle-exceptions common:handle-exceptions)
;; iup callbacks are not dumping the stack, this is a work-around
;;
(define-simple-syntax (debug:catch-and-dump proc procname)
(handle-exceptions
exn
(begin
(print-call-chain (current-error-port))
(with-output-to-port (current-error-port)
(lambda ()
(print ((condition-property-accessor 'exn 'message) exn))
(print "Callback error in " procname)
(print "Full condition info:\n" (condition->list exn)))))
(proc)))
;; Need a mutex protected way to get and set values
;; or use (define-simple-syntax ??
;;
(define-inline (with-mutex mtx accessor record . val)
(mutex-lock! mtx)
(let ((res (apply accessor record val)))
(mutex-unlock! mtx)
res))
;; Brandon's debug printer shortcut (indulge me :)
;; (define *BB-process-starttime* (current-milliseconds))
#;(define (BB> . in-args)
(let* ((stack (get-call-chain))
(location "??"))
(for-each
(lambda (frame)
(let* ((this-loc (vector-ref frame 0))
(temp (string-split (->string this-loc) " "))
(this-func (if (and (list? temp) (> (length temp) 1)) (cadr temp) "???")))
(if (equal? this-func "BB>")
(set! location this-loc))))
stack)
(let* ((color-on "\x1b[1m")
(color-off "\x1b[0m")
(dp-args
(append
(list 0 *default-log-port*
(conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off " ") )
in-args)))
(apply debug:print dp-args))))
;; (define *BBpp_custom_expanders_list* (make-hash-table))
;; register hash tables with BBpp.
#;(hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE:
(cons hash-table? hash-table->alist))
;; test name converter
#;(define (BBpp_custom_converter arg)
(let ((res #f))
(for-each
(lambda (custom-type-name)
(let* ((custom-type-info (hash-table-ref *BBpp_custom_expanders_list* custom-type-name))
(custom-type-test (car custom-type-info))
(custom-type-converter (cdr custom-type-info)))
(when (and (not res) (custom-type-test arg))
(set! res (custom-type-converter arg)))))
(hash-table-keys *BBpp_custom_expanders_list*))
(if res (BBpp_ res) arg)))
#;(define (BBpp_ arg)
(cond
;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg)))
;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg)))
((hash-table? arg)
(let ((al (hash-table->alist arg)))
(BBpp_ (cons HASH_TABLE: al))))
((null? arg) '())
;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
(else (BBpp_custom_converter arg))))
;; Brandon's pretty printer. It expands hashes and custom types in addition to regular pp
#;(define (BBpp arg)
(pp (BBpp_ arg)))
;(use define-macro)
#;(define-syntax inspect
(syntax-rules ()
[(_ x)
;; (with-output-to-port (current-error-port)
(printf "~a is: ~a\n" 'x (with-output-to-string (lambda () (BBpp x))))
;; )
]
[(_ x y ...) (begin (inspect x) (inspect y ...))]))
;; 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 ""))
(define (common:get-area-path-signature)
(message-digest-string (md5-primitive) *toppath*))
(define (common:get-signature str)
(message-digest-string (md5-primitive) str))
)