Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -156,10 +156,11 @@
megatest.o : megatest-fossil-hash.scm
rmt.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm
common_records.scm : altdb.scm
vg.o dashboard.o : vg_records.scm
dcommon.o : run_records.scm
+
# Temporary while transitioning to new routine
# runs.o : run-tests-queue-classic.scm run-tests-queue-new.scm
megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm
echo "(define megatest-fossil-hash \"$(MTESTHASH)\")" > megatest-fossil-hash.new
Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -16,23 +16,35 @@
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;======================================================================
+(declare (unit common))
+
+;;======================================================================
+;; MODULE STARTS HERE
+;;======================================================================
+
+(module common
+ *
+
+(import chicken scheme data-structures extras srfi-13 ports )
+
(use srfi-1 data-structures posix regex-case (prefix base64 base64:)
format dot-locking csv-xml z3 ;; sql-de-lite
hostinfo md5 message-digest typed-records directory-utils stack
matchable regex posix (srfi 18) extras ;; tcp
- (prefix nanomsg nmsg:)
+ nanomsg
(prefix sqlite3 sqlite3:)
pkts (prefix dbi dbi:)
+ srfi-69
)
-(declare (unit common))
-
(include "common_records.scm")
+(require-library stml)
+;; (import stml)
;; (require-library margs)
;; (include "margs.scm")
;; (define old-exit exit)
@@ -293,22 +305,14 @@
(conc megatest-version "-" megatest-fossil-hash))
(define (common:version-signature)
(conc megatest-version "-" (substring megatest-fossil-hash 0 4)))
-;; from metadat lookup MEGATEST_VERSION
-;;
-(define (common:get-last-run-version) ;; RADT => How does this work in send-receive function??; assume it is the value saved in some DB
- (rmt:get-var "MEGATEST_VERSION"))
-
(define (common:get-last-run-version-number)
(string->number
(substring (common:get-last-run-version) 0 6)))
-(define (common:set-last-run-version)
- (rmt:set-var "MEGATEST_VERSION" (common:version-signature)))
-
;; postive number if megatest version > db version
;; negative number if megatest version < db version
(define (common:version-db-delta)
(- megatest-version (common:get-last-run-version-number)))
@@ -800,57 +804,10 @@
(server:writable-watchdog dbstruct)))
(debug:print-info 13 *default-log-port* "watchdog done."))
(debug:print-info 13 *default-log-port* "no need for watchdog on non-homehost"))))
-(define (std-exit-procedure)
- (on-exit (lambda () 0))
- ;;(debug:print-info 13 *default-log-port* "std-exit-procedure called; *time-to-exit*="*time-to-exit*)
- (let ((no-hurry (if *time-to-exit* ;; hurry up
- #f
- (begin
- (set! *time-to-exit* #t)
- #t))))
- (debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.")
- (if (and no-hurry (debug:debug-mode 18))
- (rmt:print-db-stats))
- (let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds
- (if *dbstruct-db* (db:close-all *dbstruct-db*)) ;; one second allocated
- (if *task-db*
- (let ((db (cdr *task-db*)))
- (if (sqlite3:database? db)
- (begin
- (sqlite3:interrupt! db)
- (sqlite3:finalize! db #t)
- ;; (vector-set! *task-db* 0 #f)
- (set! *task-db* #f)))))
- (http-client#close-all-connections!)
- ;; (if (and *runremote*
- ;; (remote-conndat *runremote*))
- ;; (begin
- ;; (http-client#close-all-connections!))) ;; for http-client
- (if (not (eq? *default-log-port* (current-error-port)))
- (close-output-port *default-log-port*))
- (set! *default-log-port* (current-error-port))) "Cleanup db exit thread"))
- (th2 (make-thread (lambda ()
- (debug:print 4 *default-log-port* "Attempting clean exit. Please be patient and wait a few seconds...")
- (if no-hurry
- (begin
- (thread-sleep! 5)) ;; give the clean up few seconds to do it's stuff
- (begin
- (thread-sleep! 2)))
- (debug:print 4 *default-log-port* " ... done")
- )
- "clean exit")))
- (thread-start! th1)
- (thread-start! th2)
- (thread-join! th1)
- )
- )
-
- 0)
-
(define (std-signal-handler signum)
;; (signal-mask! signum)
(set! *time-to-exit* #t)
;;(debug:print-info 13 *default-log-port* "got signal "signum)
(debug:print-error 0 *default-log-port* "Received signal " signum " aaa exiting promptly")
@@ -1601,196 +1558,10 @@
(define (common:unix-ping hostname)
(let ((res (system (conc "ping -c 1 " hostname " > /dev/null"))))
(eq? res 0)))
-;; ideally put all this info into the db, no need to preserve it across moving homehost
-;;
-;; return list of
-;; ( reachable? cpuload update-time )
-(define (common:get-host-info hostname)
- (let* ((loadinfo (rmt:get-latest-host-load hostname)) ;; if this host happens to have been recently used by a test reuse the load data
- (load (car loadinfo))
- (load-sample-time (cdr loadinfo))
- (load-sample-age (- (current-seconds) load-sample-time))
- (loadinfo-timeout-seconds 6) ;; this was 20 seconds, seems way too lax. Switch to 6 seconds
- (host-last-update-timeout-seconds 4)
- (host-rec (hash-table-ref/default *host-loads* hostname #f))
- )
- (cond
- ((< load-sample-age loadinfo-timeout-seconds)
- (list #t
- load-sample-time
- load))
- ((and host-rec
- (< (current-seconds) (+ (host-last-update host-rec) host-last-update-timeout-seconds)))
- (list #t
- (host-last-update host-rec)
- (host-last-cpuload host-rec )))
- ((common:unix-ping hostname)
- (list #t
- (current-seconds)
- (alist-ref 'adj-core-load (common:get-normalized-cpu-load hostname)))) ;; this is cheaper than you might think. get-normalized-cpu-load is cached for up to 5 seconds
- (else
- (list #f 0 -1) ;; bad host, don't use!
- ))))
-
-;; see defstruct host at top of file.
-;; host: reachable last-update last-used last-cpuload
-;;
-(define (common:update-host-loads-table hosts-raw)
- (let* ((hosts (filter (lambda (x)
- (string-match (regexp "^\\S+$") x))
- hosts-raw)))
- (for-each
- (lambda (hostname)
- (let* ((rec (let ((h (hash-table-ref/default *host-loads* hostname #f)))
- (if h
- h
- (let ((h (make-host)))
- (hash-table-set! *host-loads* hostname h)
- h))))
- (host-info (common:get-host-info hostname))
- (is-reachable (car host-info))
- (last-reached-time (cadr host-info))
- (load (caddr host-info)))
- (host-reachable-set! rec is-reachable)
- (host-last-update-set! rec last-reached-time)
- (host-last-cpuload-set! rec load)))
- hosts)))
-
-;; go through the hosts from least recently used to most recently used, pick the first that meets the load criteral from the
-;; [host-rules] section.
-;;
-(define (common:get-least-loaded-host hosts-raw host-type configdat)
- (let* ((rdat (configf:lookup configdat "host-rules" host-type))
- (rules (common:val->alist (or rdat "") convert: #t)) ;; maxnload, maxnjobs, maxjobrate
- (maxnload (common:alist-ref/default 'maxnload rules 1.5)) ;; max normalized load
- (maxnjobs (common:alist-ref/default 'maxnjobs rules 1.5)) ;; max normalized number of jobs
- (maxjobrate (common:alist-ref/default 'maxjobrate rules (/ 1 6))) ;; max rate of submitting jobs to a given host in jobs/second
- (hosts (filter (lambda (x)
- (string-match (regexp "^\\S+$") x))
- hosts-raw))
- ;; (best-host #f)
- (get-rec (lambda (hostname)
- ;; (print "get-rec hostname=" hostname)
- (let ((h (hash-table-ref/default *host-loads* hostname #f)))
- (if h
- h
- (let ((h (make-host)))
- (hash-table-set! *host-loads* hostname h)
- h)))))
- (best-load 99999)
- (curr-time (current-seconds))
- (get-hosts-sorted (lambda (hosts)
- (sort hosts (lambda (a b)
- (let ((a-rec (get-rec a))
- (b-rec (get-rec b)))
- ;; (print "a=" a " a-rec=" a-rec " host-last-used=" (host-last-used a-rec))
- ;; (print "b=" b " b-rec=" b-rec " host-last-used=" (host-last-used b-rec))
- (< (host-last-used a-rec)
- (host-last-used b-rec))))))))
- (debug:print 0 *default-log-port* "INFO: hosts-sorted=" (get-hosts-sorted hosts))
- (if (null? hosts)
- #f ;; no hosts to select from. All done and giving up now.
- (let ((hosts-sorted (get-hosts-sorted hosts)))
- (common:update-host-loads-table hosts)
- (let loop ((hostname (car hosts-sorted))
- (tal (cdr hosts-sorted))
- (best-host #f))
- (let* ((rec (get-rec hostname))
- (reachable (host-reachable rec))
- (load (host-last-cpuload rec))
- (last-used (host-last-used rec))
- (delta (- curr-time last-used))
- (job-rate (if (> delta 0)
- (/ 1 delta)
- 999)) ;; jobs per second
- (new-best
- (cond
- ((not reachable)
- (debug:print 0 *default-log-port* "Skipping host " hostname " as it cannot be reached.")
- best-host)
- ((and (< load maxnload) ;; load is acceptable
- (< job-rate maxjobrate)) ;; job rate is acceptable
- (set! best-load load)
- hostname)
- (else best-host))))
- (debug:print 0 *default-log-port* "INFO: Trying host " hostname " with load " load ", last used " delta " seconds ago, with job-rate " job-rate " for running a test." )
- (if new-best
- (begin ;; found a host, return it
- (debug:print 0 *default-log-port* "INFO: Found host: " new-best " load: " load " last-used: " delta " seconds ago, with job-rate: " job-rate)
- (host-last-used-set! rec curr-time)
- new-best)
- (if (null? tal) #f (loop (car tal)(cdr tal) best-host)))))))))
-
-(define (common:wait-for-cpuload maxload-in numcpus-in waitdelay #!key (count 1000) (msg #f)(remote-host #f))
- (let* ((loadavg (common:get-cpu-load remote-host))
- (numcpus (if (< 1 numcpus-in) ;; not possible
- (common:get-num-cpus remote-host)
- numcpus-in))
- (maxload (max maxload-in 0.5)) ;; so maxload must be greater than 0.5 for now BUG - FIXME?
- (first (car loadavg))
- (next (cadr loadavg))
- (adjload (* maxload (max 1 numcpus))) ;; possible bug where numcpus (or could be maxload) is zero, crude fallback is to at least use 1
- (loadjmp (- first next))
- (adjwait (+ (random 10)(/ (- 1000 count) 10) waitdelay))) ;; add some randomness to the time to break any alignment where netbatch dumps many jobs to machines simultaneously
- (cond
- ((and (> first adjload)
- (> count 0))
- (debug:print-info 0 *default-log-port* "server start delayed " adjwait " seconds due to load " first " exceeding max of " adjload " on server " (or remote-host (get-host-name)) " (normalized load-limit: " maxload ") " (if msg msg ""))
- (thread-sleep! adjwait)
- (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host))
- ((and (> loadjmp numcpus)
- (> count 0))
- (debug:print-info 0 *default-log-port* "waiting " adjwait " seconds due to load jump " loadjmp " > numcpus " numcpus (if msg msg ""))
- (thread-sleep! adjwait)
- (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host)))))
-
-(define (common:wait-for-homehost-load maxload msg)
- (let* ((hh-dat (if (common:on-homehost?) ;; if we are on the homehost then pass in #f so the calls are local.
- #f
- (common:get-homehost)))
- (hh (if hh-dat (car hh-dat) #f))
- (numcpus (common:get-num-cpus hh)))
- (common:wait-for-normalized-load maxload msg hh)))
-
-(define (common:get-num-cpus remote-host)
- (let* ((actual-host (or remote-host (get-host-name))))
- (or (common:get-cached-info actual-host "num-cpus" age: 86400) ;; hosts had better not be changing the number of cpus too often!
- (let* ((proc (lambda ()
- (let loop ((numcpu 0)
- (inl (read-line)))
- (if (eof-object? inl)
- (begin
- (common:write-cached-info remote-host "num-cpus" numcpu)
- numcpu)
- (loop (if (string-match "^processor\\s+:\\s+\\d+$" inl)
- (+ numcpu 1)
- numcpu)
- (read-line))))))
- (result (if remote-host
- (with-input-from-pipe
- (conc "ssh " remote-host " cat /proc/cpuinfo")
- proc)
- (with-input-from-file "/proc/cpuinfo" proc))))
- (common:write-cached-info actual-host "num-cpus" result)
- result))))
-
-;; wait for normalized cpu load to drop below maxload
-;;
-(define (common:wait-for-normalized-load maxload msg remote-host)
- (let ((num-cpus (common:get-num-cpus remote-host)))
- (common:wait-for-cpuload maxload num-cpus 15 msg: msg remote-host: remote-host)))
-
-(define (get-uname . params)
- (let* ((uname-res (process:cmd-run->list (conc "uname " (if (null? params) "-a" (car params)))))
- (uname #f))
- (if (null? (car uname-res))
- "unknown"
- (caar uname-res))))
-
;; for reasons I don't understand multiple calls to real-path in parallel threads
;; must be protected by mutexes
;;
(define (common:real-path inpath)
;; (process:cmd-run-with-stderr->list "readlink" "-f" inpath)) ;; cmd . params)
@@ -1807,111 +1578,10 @@
;; ;; (process-wait pid)
;; res)
;; (loop (read-line) inl))))))
(with-input-from-pipe (conc "readlink -f " inpath) read-line))
-;;======================================================================
-;; D I S K S P A C E
-;;======================================================================
-
-(define (common:get-disk-space-used fpath)
- (with-input-from-pipe (conc "/usr/bin/du -s " fpath) read))
-
-;; given path get free space, allows override in [setup]
-;; with free-space-script /path/to/some/script.sh
-;;
-(define (get-df path)
- (if (configf:lookup *configdat* "setup" "free-space-script")
- (with-input-from-pipe
- (conc (configf:lookup *configdat* "setup" "free-space-script") " " path)
- (lambda ()
- (let ((res (read-line)))
- (if (string? res)
- (string->number res)))))
- (get-unix-df path)))
-
-(define (get-unix-df path)
- (let* ((df-results (process:cmd-run->list (conc "df " path)))
- (space-rx (regexp "([0-9]+)\\s+([0-9]+)%"))
- (freespc #f))
- ;; (write df-results)
- (for-each (lambda (l)
- (let ((match (string-search space-rx l)))
- (if match
- (let ((newval (string->number (cadr match))))
- (if (number? newval)
- (set! freespc newval))))))
- (car df-results))
- freespc))
-
-(define (common:check-space-in-dir dirpath required)
- (let* ((dbspace (if (directory? dirpath)
- (get-df dirpath)
- 0)))
- (list (> dbspace required)
- dbspace
- required
- dirpath)))
-
-;; check space in dbdir and in megatest dir
-;; returns: ok/not dbspace required-space
-;;
-(define (common:check-db-dir-space)
- (let* ((required (string->number
- (or (configf:lookup *configdat* "setup" "dbdir-space-required")
- "100000")))
- (dbdir (common:get-db-tmp-area)) ;; (db:get-dbdir))
- (tdbspace (common:check-space-in-dir dbdir required))
- (mdbspace (common:check-space-in-dir *toppath* required)))
- (sort (list tdbspace mdbspace) (lambda (a b)
- (< (cadr a)(cadr b))))))
-
-;; check available space in dbdir, exit if insufficient
-;;
-(define (common:check-db-dir-and-exit-if-insufficient)
- (let* ((spacedat (car (common:check-db-dir-space))) ;; look only at worst for now
- (is-ok (car spacedat))
- (dbspace (cadr spacedat))
- (required (caddr spacedat))
- (dbdir (cadddr spacedat)))
- (if (not is-ok)
- (begin
- (debug:print-error 0 *default-log-port* "Insufficient space in " dbdir ", require " required ", have " dbspace ", exiting now.")
- (exit 1)))))
-
-;; paths is list of lists ((name path) ... )
-;;
-(define (common:get-disk-with-most-free-space disks minsize)
- (let ((best #f)
- (bestsize 0))
- (for-each
- (lambda (disk-num)
- (let* ((dirpath (cadr (assoc disk-num disks)))
- (freespc (cond
- ((not (directory? dirpath))
- (if (common:low-noise-print 300 "disks not a dir " disk-num)
- (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a directory - ignoring it."))
- -1)
- ((not (file-write-access? dirpath))
- (if (common:low-noise-print 300 "disks not writeable " disk-num)
- (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not writeable - ignoring it."))
- -1)
- ((not (eq? (string-ref dirpath 0) #\/))
- (if (common:low-noise-print 300 "disks not a proper path " disk-num)
- (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a fully qualified path - ignoring it."))
- -1)
- (else
- (get-df dirpath)))))
- (if (> freespc bestsize)
- (begin
- (set! best (cons disk-num dirpath))
- (set! bestsize freespc)))))
- (map car disks))
- (if (and best (> bestsize minsize))
- best
- #f))) ;; #f means no disk candidate found
-
;; convert a spec string to a list of vectors #( rx action rx-string )
(define (common:spec-string->list-of-specs spec-string actions)
(let ((spec-strings (string-split-fields "\\s*;\\s*" spec-string #:infix))
(actions-regex (regexp (conc "^(.*)\\s+(" (string-intersperse (map conc actions) "|") ")"))))
(filter
@@ -2099,22 +1769,10 @@
vars
(lambda (var val)
(setenv var val)))
vars))
-
-(define (common:run-a-command cmd #!key (with-vars #f))
- (let* ((pre-cmd (dtests:get-pre-command))
- (post-cmd (dtests:get-post-command))
- (fullcmd (if (or pre-cmd post-cmd)
- (conc pre-cmd cmd post-cmd)
- (conc "viewscreen " cmd))))
- (debug:print-info 02 *default-log-port* "Running command: " fullcmd)
- (if with-vars
- (common:without-vars cmd)
- (common:without-vars fullcmd "MT_.*"))))
-
;;======================================================================
;; T I M E A N D D A T E
;;======================================================================
;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5
@@ -2423,43 +2081,10 @@
(number->string x 16))
(map string->number
(string-split instr)))
"/"))
-;;======================================================================
-;; L O C K I N G M E C H A N I S M S
-;;======================================================================
-
-;; faux-lock is deprecated. Please use simple-lock below
-;;
-(define (common:faux-lock keyname #!key (wait-time 8)(allow-lock-steal #t))
- (if (rmt:no-sync-get/default keyname #f) ;; do not be tempted to compare to pid. locking is a one-shot action, if already locked for this pid it doesn't actually count
- (if (> wait-time 0)
- (begin
- (thread-sleep! 1)
- (if (eq? wait-time 1) ;; only one second left, steal the lock
- (begin
- (debug:print-info 0 *default-log-port* "stealing lock for " keyname)
- (common:faux-unlock keyname force: #t)))
- (common:faux-lock keyname wait-time: (- wait-time 1)))
- #f)
- (begin
- (rmt:no-sync-set keyname (conc (current-process-id)))
- (equal? (conc (current-process-id)) (conc (rmt:no-sync-get/default keyname #f))))))
-
-(define (common:faux-unlock keyname #!key (force #f))
- (if (or force (equal? (conc (current-process-id)) (conc (rmt:no-sync-get/default keyname #f))))
- (begin
- (if (rmt:no-sync-get/default keyname #f) (rmt:no-sync-del! keyname))
- #t)
- #f))
-
-;; simple lock. improve and converge on this one.
-;;
-(define (common:simple-lock keyname)
- (rmt:no-sync-get-lock keyname))
-
;;======================================================================
;;
;;======================================================================
(define (common:in-running-test?)
@@ -2546,91 +2171,17 @@
;; (define (mddb:get-dashboards)
;; (let ((db (mddb:open-db)))
;; (query fetch-column
;; (sql db "SELECT ipaddr || ':' || portnum FROM dashboards;"))))
-;;======================================================================
-;; T E S T L A U N C H I N G P E R I T E M W I T H H O S T T Y P E S
-;;======================================================================
-;;
-;; [hosts]
-;; arm cubie01 cubie02
-;; x86_64 zeus xena myth01
-;; allhosts #{g hosts arm} #{g hosts x86_64}
-;;
-;; [host-types]
-;; general #MTLOWESTLOAD #{g hosts allhosts}
-;; arm #MTLOWESTLOAD #{g hosts arm}
-;; nbgeneral nbjob run JOBCOMMAND -log $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME.$MT_TESTNAME-$MT_ITEM_PATH.lgo
-;;
-;; [host-rules]
-;; # maxnload => max normalized load
-;; # maxnjobs => max jobs per cpu
-;; # maxjobrate => max jobs per second
-;; general maxnload=1.1; maxnjobs=1.2; maxjobrate=0.1
-;;
-;; [launchers]
-;; envsetup general
-;; xor/%/n 4C16G
-;; % nbgeneral
-;;
-;; [jobtools]
-;; # if defined and not "no" flexi-launcher will bypass "launcher" unless no match.
-;; flexi-launcher yes
-;; launcher nbfake
-;;
-(define (common:get-launcher configdat testname itempath)
- (let ((fallback-launcher (configf:lookup configdat "jobtools" "launcher")))
- (if (and (configf:lookup configdat "jobtools" "flexi-launcher") ;; overrides launcher
- (not (equal? (configf:lookup configdat "jobtools" "flexi-launcher") "no")))
- (let* ((launchers (hash-table-ref/default configdat "launchers" '())))
- (if (null? launchers)
- fallback-launcher
- (let loop ((hed (car launchers))
- (tal (cdr launchers)))
- (let ((patt (car hed))
- (host-type (cadr hed)))
- (if (tests:match patt testname itempath)
- (begin
- (debug:print-info 2 *default-log-port* "Have flexi-launcher match for " testname "/" itempath " = " host-type)
- (let ((launcher (configf:lookup configdat "host-types" host-type)))
- (if launcher
- (let* ((launcher-parts (string-split launcher))
- (launcher-exe (car launcher-parts)))
- (if (equal? launcher-exe "#MTLOWESTLOAD") ;; this is our special case, we will find the lowest load and craft a nbfake commandline
- (let host-loop ((targ-host (common:get-least-loaded-host (cdr launcher-parts) host-type configdat))
- (count 100))
- (if targ-host
- (conc "remrun " targ-host)
- (if (> count 0)
- (begin
- (debug:print 0 *default-log-port* "INFO: Waiting for a host for host-type " host-type)
- (thread-sleep! (- 101 count))
- (host-loop (common:get-least-loaded-host (cdr launcher-parts) host-type configdat)
- (- count 1)))
- (begin
- (debug:print 0 *default-log-port* "FATAL: Failed to find a host from #MTLOWESTLOAD for host-type " host-type)
- (exit)))))
- launcher))
- (begin
- (debug:print-info 0 *default-log-port* "WARNING: no launcher found for host-type " host-type)
- (if (null? tal)
- fallback-launcher
- (loop (car tal)(cdr tal)))))))
- ;; no match, try again
- (if (null? tal)
- fallback-launcher
- (loop (car tal)(cdr tal))))))))
- fallback-launcher)))
-
;;======================================================================
;; NMSG AND NEW API
;;======================================================================
;; nm based server experiment, keep around for now.
;;
-(define (nm:start-server dbconn #!key (given-host-name #f))
+#;(define (nm:start-server dbconn #!key (given-host-name #f))
(let* ((srvdat (start-raw-server given-host-name: given-host-name))
(host-name (srvdat-host srvdat))
(soc (srvdat-soc srvdat)))
;; start the queue processor (save for second round of development)
@@ -2931,5 +2482,7 @@
exn
#t ;; just ignore it, it might have died in the meantime so joining it will throw an exception
(thread-join! thread))
)))
(hash-table-keys *common:thread-punchlist*)))
+
+)
Index: dashboard-tests.scm
==================================================================
--- dashboard-tests.scm
+++ dashboard-tests.scm
@@ -600,11 +600,11 @@
(command-text-box (iup:textbox
#:expand "HORIZONTAL"
#:font "Courier New, -10"
#:action (lambda (obj cnum val)
;; (print "cnum=" cnum)
- (if (eq? cnum 13)
+ (if (eq? cnum 13) ;; carriage return?
(command-prox obj)))
))
(command-launch-button (iup:button "Execute!" #:action (lambda (x)
(command-proc command-text-box))))
;; (lambda (x)
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -1,6 +1,6 @@
-;======================================================================
+;;======================================================================
;; Copyright 2006-2016, Matthew Welland.
;;
;; This file is part of Megatest.
;;
;; Megatest is free software: you can redistribute it and/or modify
@@ -21,23 +21,29 @@
;;======================================================================
;; Database access
;;======================================================================
;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc
-
-(use (srfi 18) extras tcp stack)
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records matchable)
-(import (prefix sqlite3 sqlite3:))
-(import (prefix base64 base64:))
-
(declare (unit db))
(declare (uses common))
(declare (uses keys))
(declare (uses ods))
(declare (uses client))
(declare (uses mt))
+(module db
+ *
+
+(import chicken scheme data-structures extras srfi-13 ports)
+
+(import common ods)
+
+(use (srfi 18) extras tcp stack)
+(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records matchable)
+(import (prefix sqlite3 sqlite3:))
+(import (prefix base64 base64:))
+
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")
@@ -4618,5 +4624,6 @@
(system "rm -rf tempdir")))
;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%")
+)
Index: launch.scm
==================================================================
--- launch.scm
+++ launch.scm
@@ -1406,11 +1406,11 @@
(case (string->symbol exe)
((dboard) "../megatest")
((mtest) "../megatest")
((dashboard) "megatest")
(else exe)))))
- (launcher (common:get-launcher *configdat* test-name item-path)) ;; (config-lookup *configdat* "jobtools" "launcher"))
+ (launcher (launch:get-launcher *configdat* test-name item-path)) ;; (config-lookup *configdat* "jobtools" "launcher"))
(test-sig (conc (common:get-testsuite-name) ":" test-name ":" item-path)) ;; (item-list->path itemdat))) ;; test-path is the full path including the item-path
(work-area #f)
(toptest-work-area #f) ;; for iterated tests the top test contains data relevant for all
(diskpath #f)
(cmdparms #f)
@@ -1586,5 +1586,80 @@
;; now wait on that process if all is correct
;; periodically update the db with runtime
;; when the process exits look at the db, if still RUNNING after 10 seconds set
;; state/status appropriately
(process-wait pid)))
+
+;;======================================================================
+;; T E S T L A U N C H I N G P E R I T E M W I T H H O S T T Y P E S
+;;======================================================================
+;;
+;; [hosts]
+;; arm cubie01 cubie02
+;; x86_64 zeus xena myth01
+;; allhosts #{g hosts arm} #{g hosts x86_64}
+;;
+;; [host-types]
+;; general #MTLOWESTLOAD #{g hosts allhosts}
+;; arm #MTLOWESTLOAD #{g hosts arm}
+;; nbgeneral nbjob run JOBCOMMAND -log $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME.$MT_TESTNAME-$MT_ITEM_PATH.lgo
+;;
+;; [host-rules]
+;; # maxnload => max normalized load
+;; # maxnjobs => max jobs per cpu
+;; # maxjobrate => max jobs per second
+;; general maxnload=1.1; maxnjobs=1.2; maxjobrate=0.1
+;;
+;; [launchers]
+;; envsetup general
+;; xor/%/n 4C16G
+;; % nbgeneral
+;;
+;; [jobtools]
+;; # if defined and not "no" flexi-launcher will bypass "launcher" unless no match.
+;; flexi-launcher yes
+;; launcher nbfake
+;;
+(define (launch:get-launcher configdat testname itempath)
+ (let ((fallback-launcher (configf:lookup configdat "jobtools" "launcher")))
+ (if (and (configf:lookup configdat "jobtools" "flexi-launcher") ;; overrides launcher
+ (not (equal? (configf:lookup configdat "jobtools" "flexi-launcher") "no")))
+ (let* ((launchers (hash-table-ref/default configdat "launchers" '())))
+ (if (null? launchers)
+ fallback-launcher
+ (let loop ((hed (car launchers))
+ (tal (cdr launchers)))
+ (let ((patt (car hed))
+ (host-type (cadr hed)))
+ (if (tests:match patt testname itempath)
+ (begin
+ (debug:print-info 2 *default-log-port* "Have flexi-launcher match for " testname "/" itempath " = " host-type)
+ (let ((launcher (configf:lookup configdat "host-types" host-type)))
+ (if launcher
+ (let* ((launcher-parts (string-split launcher))
+ (launcher-exe (car launcher-parts)))
+ (if (equal? launcher-exe "#MTLOWESTLOAD") ;; this is our special case, we will find the lowest load and craft a nbfake commandline
+ (let host-loop ((targ-host (common:get-least-loaded-host (cdr launcher-parts) host-type configdat))
+ (count 100))
+ (if targ-host
+ (conc "remrun " targ-host)
+ (if (> count 0)
+ (begin
+ (debug:print 0 *default-log-port* "INFO: Waiting for a host for host-type " host-type)
+ (thread-sleep! (- 101 count))
+ (host-loop (common:get-least-loaded-host (cdr launcher-parts) host-type configdat)
+ (- count 1)))
+ (begin
+ (debug:print 0 *default-log-port* "FATAL: Failed to find a host from #MTLOWESTLOAD for host-type " host-type)
+ (exit)))))
+ launcher))
+ (begin
+ (debug:print-info 0 *default-log-port* "WARNING: no launcher found for host-type " host-type)
+ (if (null? tal)
+ fallback-launcher
+ (loop (car tal)(cdr tal)))))))
+ ;; no match, try again
+ (if (null? tal)
+ fallback-launcher
+ (loop (car tal)(cdr tal))))))))
+ fallback-launcher)))
+
Index: ods.scm
==================================================================
--- ods.scm
+++ ods.scm
@@ -14,14 +14,20 @@
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
-(use csv-xml regex)
(declare (unit ods))
(declare (uses common))
+(module ods
+ *
+
+(import chicken scheme data-structures extras srfi-13 ports)
+
+(use csv-xml regex)
+
(define ods:dirs
'("Configurations2"
"Configurations2/toolpanel"
"Configurations2/menubar"
"Configurations2/toolbar"
@@ -221,5 +227,6 @@
(map print
(map ods:sheet data))
(map display ods:content-footer)))
(system (conc "cd " path "; zip " fname " -n mimetype mimetype `find . |grep -v mimetype` > /dev/null")))))
+)
Index: process.scm
==================================================================
--- process.scm
+++ process.scm
@@ -20,12 +20,21 @@
;;======================================================================
;; Process convience utils
;;======================================================================
-(use regex directory-utils)
(declare (unit process))
+(declare (uses common))
+
+(module process
+ *
+
+(import chicken scheme data-structures extras srfi-13 ports )
+
+(import common)
+
+(use regex directory-utils)
(define (process:conservative-read port)
(let loop ((res ""))
(if (not (eof-object? (peek-char port)))
(loop (conc res (read-char port)))
@@ -221,5 +230,6 @@
(reverse res)
(let ((nums (map string->number
(string-split-fields "\\d+" inl))))
(loop (read-line)
(append res nums))))))))
+)
Index: tests.scm
==================================================================
--- tests.scm
+++ tests.scm
@@ -20,14 +20,10 @@
;;======================================================================
;; Tests
;;======================================================================
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils)
-(import (prefix sqlite3 sqlite3:))
-(require-library stml)
-
(declare (unit tests))
(declare (uses lock-queue))
(declare (uses db))
(declare (uses tdb))
(declare (uses common))
@@ -34,10 +30,22 @@
;; (declare (uses dcommon)) ;; needed for the steps processing
(declare (uses items))
(declare (uses runconfig))
;; (declare (uses sdb))
(declare (uses server))
+
+(module tests
+ *
+
+(import chicken scheme data-structures extras srfi-13 ports )
+
+(import common)
+
+(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils)
+(import (prefix sqlite3 sqlite3:))
+(require-library stml)
+
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
@@ -1936,5 +1944,6 @@
#f)
(define (test:archive-tests db keynames target)
#f)
+)