Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -26,11 +26,11 @@
SHELL=/bin/bash
PREFIX=$(PWD)
CSCOPTS=
INSTALL=install
-SRCFILES = common.scm launch.scm runconfig.scm \
+SRCFILES = launch.scm runconfig.scm \
server.scm configf.scm keys.scm \
process.scm runs.scm genexample.scm \
tdb.scm mt.scm \
ezsteps.scm api.scm \
subrun.scm archive.scm env.scm \
Index: apimod.scm
==================================================================
--- apimod.scm
+++ apimod.scm
@@ -25,11 +25,13 @@
(declare (uses dbfile))
(declare (uses tcp-transportmod))
(declare (uses megatestmod))
(module apimod
- *
+ (
+ api:dispatch-request
+ )
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix matchable typed-records srfi-1 srfi-18 srfi-69 )
(import commonmod)
(import debugprint)
Index: archive.scm
==================================================================
--- archive.scm
+++ archive.scm
@@ -19,11 +19,11 @@
;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
(declare (unit archive))
(declare (uses debugprint))
(declare (uses mtargs))
-(declare (uses common))
+;; (declare (uses common))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses rmtmod))
(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69
Index: archivemod.scm
==================================================================
--- archivemod.scm
+++ archivemod.scm
@@ -37,11 +37,19 @@
(declare (uses dbfile))
(use srfi-69)
(module archivemod
- *
+ (
+ archive:get-archive-disks
+ archive:allocate-new-archive-block
+ archive:get-timestamp-dir
+ archive:megatest-db
+ archive:bup-get-data
+
+
+ )
(import scheme)
(cond-expand
(chicken-4
@@ -121,11 +129,11 @@
srfi-69
typed-records
z3
)
-(include "common_records.scm")
+;; (include "common_records.scm")
;; (include "db_records.scm")
;;======================================================================
;;
;;======================================================================
ADDED attic/codescanlib.scm
Index: attic/codescanlib.scm
==================================================================
--- /dev/null
+++ attic/codescanlib.scm
@@ -0,0 +1,144 @@
+;; Copyright 2006-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 .
+;;
+
+;; gotta compile with csc, doesn't work with csi -s for whatever reason
+
+(use srfi-69)
+(use matchable)
+(use utils)
+(use ports)
+(use extras)
+(use srfi-1)
+(use posix)
+(use srfi-12)
+
+;; turn scheme file to a list of sexps, sexps of interest will be in the form of (define ( ) )
+(define (load-scm-file scm-file)
+ ;;(print "load "scm-file)
+ (handle-exceptions
+ exn
+ '()
+ (with-input-from-string
+ (conc "("
+ (with-input-from-file scm-file read-all)
+ ")" )
+ read)))
+
+;; extract a list of procname, filename, args and body of procedures defined in filename, input from load-scm-file
+;; -- be advised:
+;; * this may be fooled by macros, since this code does not take them into account.
+;; * this code does only checks for form (define ( ... ) )
+;; so it excludes from reckoning
+;; - generated functions, as in things like foo-set! from defstructs,
+;; - define-inline, (
+;; - define procname (lambda ..
+;; - etc...
+(define (get-toplevel-procs+file+args+body filename)
+ (let* ((scm-tree (load-scm-file filename))
+ (procs
+ (filter identity
+ (map
+ (match-lambda
+ [('define ('uses args ...) body ...) #f] ;; filter out (define (uses ...
+ [('define ('unit args ...) body ...) #f] ;; filter out (define (unit ...
+ [('define ('prefix args ...) body ...) #f] ;; filter out (define (prefix ...
+ [('define (defname args ...) body ...) ;; match (define (procname ) )
+ (if (atom? defname) ;; filter out things we dont understand (procname is a list, what??)
+ (list defname filename args body)
+ #f)]
+ [else #f] ) scm-tree))))
+ procs))
+
+
+;; given a sexp, return a flat list of atoms in that sexp
+(define (get-atoms-in-body body)
+ (cond
+ ((null? body) '())
+ ((atom? body) (list body))
+ (else
+ (apply append (map get-atoms-in-body body)))))
+
+;; given a file, return a list of procname, file, list of atoms in said procname
+(define (get-procs+file+atoms file)
+ (let* ((toplevel-proc-items (get-toplevel-procs+file+args+body file))
+ (res
+ (map
+ (lambda (item)
+ (let* ((proc (car item))
+ (file (cadr item))
+ (args (caddr item))
+ (body (cadddr item))
+ (atoms (append (get-atoms-in-body args) (get-atoms-in-body body))))
+ (list proc file atoms)))
+ toplevel-proc-items)))
+ res))
+
+;; uniquify a list of atoms
+(define (unique-atoms lst)
+ (let loop ((lst (flatten lst)) (res '()))
+ (if (null? lst)
+ (reverse res)
+ (let ((c (car lst)))
+ (loop (cdr lst) (if (member c res) res (cons c res)))))))
+
+;; given a list of procname, filename, list of procs called from procname, cross reference and reverse
+;; returning alist mapping procname to procname that calls said procname
+(define (get-callers-alist all-procs+file+calls)
+ (let* ((all-procs (map car all-procs+file+calls))
+ (caller-ht (make-hash-table)))
+ ;; let's cross reference with a hash table
+ (for-each (lambda (proc) (hash-table-set! caller-ht proc '())) all-procs)
+ (for-each (lambda (item)
+ (let* ((proc (car item))
+ (file (cadr item))
+ (calls (caddr item)))
+ (for-each (lambda (callee)
+ (hash-table-set! caller-ht callee
+ (cons proc
+ (hash-table-ref caller-ht callee))))
+ calls)))
+ all-procs+file+calls)
+ (map (lambda (x)
+ (let ((k (car x))
+ (r (unique-atoms (cdr x))))
+ (cons k r)))
+ (hash-table->alist caller-ht))))
+
+;; create a handy cross-reference of callees to callers in the form of an alist.
+(define (get-xref all-scm-files)
+ (let* ((all-procs+file+atoms
+ (apply append (map get-procs+file+atoms all-scm-files)))
+ (all-procs (map car all-procs+file+atoms))
+ (all-procs+file+calls ; proc calls things in calls list
+ (map (lambda (item)
+ (let* ((proc (car item))
+ (file (cadr item))
+ (atoms (caddr item))
+ (calls
+ (filter identity
+ (map
+ (lambda (x)
+ (if (and ;; (not (equal? x proc)) ;; uncomment to prevent listing self
+ (member x all-procs))
+ x
+ #f))
+ atoms))))
+ (list proc file calls)))
+ all-procs+file+atoms))
+ (callers (get-callers-alist all-procs+file+calls)))
+ callers))
DELETED codescanlib.scm
Index: codescanlib.scm
==================================================================
--- codescanlib.scm
+++ /dev/null
@@ -1,144 +0,0 @@
-;; Copyright 2006-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 .
-;;
-
-;; gotta compile with csc, doesn't work with csi -s for whatever reason
-
-(use srfi-69)
-(use matchable)
-(use utils)
-(use ports)
-(use extras)
-(use srfi-1)
-(use posix)
-(use srfi-12)
-
-;; turn scheme file to a list of sexps, sexps of interest will be in the form of (define ( ) )
-(define (load-scm-file scm-file)
- ;;(print "load "scm-file)
- (handle-exceptions
- exn
- '()
- (with-input-from-string
- (conc "("
- (with-input-from-file scm-file read-all)
- ")" )
- read)))
-
-;; extract a list of procname, filename, args and body of procedures defined in filename, input from load-scm-file
-;; -- be advised:
-;; * this may be fooled by macros, since this code does not take them into account.
-;; * this code does only checks for form (define ( ... ) )
-;; so it excludes from reckoning
-;; - generated functions, as in things like foo-set! from defstructs,
-;; - define-inline, (
-;; - define procname (lambda ..
-;; - etc...
-(define (get-toplevel-procs+file+args+body filename)
- (let* ((scm-tree (load-scm-file filename))
- (procs
- (filter identity
- (map
- (match-lambda
- [('define ('uses args ...) body ...) #f] ;; filter out (define (uses ...
- [('define ('unit args ...) body ...) #f] ;; filter out (define (unit ...
- [('define ('prefix args ...) body ...) #f] ;; filter out (define (prefix ...
- [('define (defname args ...) body ...) ;; match (define (procname ) )
- (if (atom? defname) ;; filter out things we dont understand (procname is a list, what??)
- (list defname filename args body)
- #f)]
- [else #f] ) scm-tree))))
- procs))
-
-
-;; given a sexp, return a flat list of atoms in that sexp
-(define (get-atoms-in-body body)
- (cond
- ((null? body) '())
- ((atom? body) (list body))
- (else
- (apply append (map get-atoms-in-body body)))))
-
-;; given a file, return a list of procname, file, list of atoms in said procname
-(define (get-procs+file+atoms file)
- (let* ((toplevel-proc-items (get-toplevel-procs+file+args+body file))
- (res
- (map
- (lambda (item)
- (let* ((proc (car item))
- (file (cadr item))
- (args (caddr item))
- (body (cadddr item))
- (atoms (append (get-atoms-in-body args) (get-atoms-in-body body))))
- (list proc file atoms)))
- toplevel-proc-items)))
- res))
-
-;; uniquify a list of atoms
-(define (unique-atoms lst)
- (let loop ((lst (flatten lst)) (res '()))
- (if (null? lst)
- (reverse res)
- (let ((c (car lst)))
- (loop (cdr lst) (if (member c res) res (cons c res)))))))
-
-;; given a list of procname, filename, list of procs called from procname, cross reference and reverse
-;; returning alist mapping procname to procname that calls said procname
-(define (get-callers-alist all-procs+file+calls)
- (let* ((all-procs (map car all-procs+file+calls))
- (caller-ht (make-hash-table)))
- ;; let's cross reference with a hash table
- (for-each (lambda (proc) (hash-table-set! caller-ht proc '())) all-procs)
- (for-each (lambda (item)
- (let* ((proc (car item))
- (file (cadr item))
- (calls (caddr item)))
- (for-each (lambda (callee)
- (hash-table-set! caller-ht callee
- (cons proc
- (hash-table-ref caller-ht callee))))
- calls)))
- all-procs+file+calls)
- (map (lambda (x)
- (let ((k (car x))
- (r (unique-atoms (cdr x))))
- (cons k r)))
- (hash-table->alist caller-ht))))
-
-;; create a handy cross-reference of callees to callers in the form of an alist.
-(define (get-xref all-scm-files)
- (let* ((all-procs+file+atoms
- (apply append (map get-procs+file+atoms all-scm-files)))
- (all-procs (map car all-procs+file+atoms))
- (all-procs+file+calls ; proc calls things in calls list
- (map (lambda (item)
- (let* ((proc (car item))
- (file (cadr item))
- (atoms (caddr item))
- (calls
- (filter identity
- (map
- (lambda (x)
- (if (and ;; (not (equal? x proc)) ;; uncomment to prevent listing self
- (member x all-procs))
- x
- #f))
- atoms))))
- (list proc file calls)))
- all-procs+file+atoms))
- (callers (get-callers-alist all-procs+file+calls)))
- callers))
DELETED common.scm
Index: common.scm
==================================================================
--- common.scm
+++ /dev/null
@@ -1,117 +0,0 @@
-;;======================================================================
-;; Copyright 2006-2012, 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 .
-
-;;======================================================================
-
-(declare (unit common))
-(declare (uses commonmod))
-(declare (uses processmod))
-(declare (uses configfmod))
-(declare (uses rmtmod))
-(declare (uses debugprint))
-(declare (uses mtargs))
-
-
-(use srfi-1 data-structures posix regex-case (prefix base64 base64:)
- format dot-locking csv-xml z3 udp ;; sql-de-lite
- hostinfo md5 message-digest typed-records directory-utils stack
- matchable regex posix (srfi 18) extras ;; tcp
- (prefix nanomsg nmsg:)
- (prefix sqlite3 sqlite3:)
- pkts (prefix dbi dbi:)
- )
-(use posix-extras pathname-expand files)
-
-
-(import commonmod
- processmod
- debugprint
- configfmod
- rmtmod
- (prefix mtargs args:))
-
-(include "common_records.scm")
-
-
-
-
-
-;;======================================================================
-;; (define *common:telemetry-log-state* 'startup)
-;; (define *common:telemetry-log-socket* #f)
-;;
-;; (define (common:telemetry-log-open)
-;; (if (eq? *common:telemetry-log-state* 'startup)
-;; (let* ((serverhost (configf:lookup *configdat* "telemetry" "host"))
-;; (serverport (configf:lookup-number *configdat* "telemetry" "port"))
-;; (user (or (get-environment-variable "USER") "unknown"))
-;; (host (or (get-environment-variable "HOST") "unknown")))
-;; (set! *common:telemetry-log-state*
-;; (handle-exceptions
-;; exn
-;; (begin
-;; (debug:print-info 0 *default-log-port* "common-telemetry-log open udp port failure")
-;; 'broken)
-;; (if (and serverhost serverport user host)
-;; (let* ((s (udp-open-socket)))
-;; ;;(udp-bind! s #f 0)
-;; (udp-connect! s serverhost serverport)
-;; (set! *common:telemetry-log-socket* s)
-;; 'open)
-;; 'not-needed))))))
-;;
-;; (define (common:telemetry-log event #!key (payload '()))
-;; (if (eq? *common:telemetry-log-state* 'startup)
-;; (common:telemetry-log-open))
-;;
-;; (if (eq? 'open *common:telemetry-log-state*)
-;; (handle-exceptions
-;; exn
-;; (begin
-;; (debug:print-info 0 *default-log-port* "common-telemetry-log comms failure ; disabled (no server?)")
-;; ;;(define *common:telemetry-log-state* 'broken-or-no-server-preclose)
-;; ;;(common:telemetry-log-close)
-;; (define *common:telemetry-log-state* 'broken-or-no-server)
-;; (set! *common:telemetry-log-socket* #f)
-;; )
-;; (if (and *common:telemetry-log-socket* event) ;; TODO - filter on event against telemetry.want-events
-;; (let* ((user (or (get-environment-variable "USER") "unknown"))
-;; (host (or (get-environment-variable "HOST") "unknown"))
-;; (start (conc "[megatest "event"]"))
-;; (toppath (or *toppath* "/dev/null"))
-;; (payload-serialized
-;; (base64:base64-encode
-;; (z3:encode-buffer
-;; (with-output-to-string (lambda () (pp payload))))))
-;; (msg (conc user":"host":"start":"(current-process-id)":"(car (argv))":"
-;; toppath":"payload-serialized)))
-;; (udp-send *common:telemetry-log-socket* msg))))))
-;;
-;; (define (common:telemetry-log-close)
-;; (when (or (member *common:telemetry-log-state* '(broken-or-no-server-preclose open)) *common:telemetry-log-socket*)
-;; (handle-exceptions
-;; exn
-;; (begin
-;; (define *common:telemetry-log-state* 'closed-fail)
-;; (debug:print-info 0 *default-log-port* "common-telemetry-log closure failure")
-;; )
-;; (begin
-;; (define *common:telemetry-log-state* 'closed)
-;; (udp-close-socket *common:telemetry-log-socket*)
-;; (set! *common:telemetry-log-socket* #f)))))
-
Index: commonmod.scm
==================================================================
--- commonmod.scm
+++ commonmod.scm
@@ -50,12 +50,253 @@
(import stml2
)
(module commonmod
- *
+ (
+ keys->valslots
+ item-list->path
+ common:human-time
+ number-of-processes-running
+ get-normalized-cpu-load
+ common:find-local-megatest
+ common:get-intercept
+ common:get-num-cpus
+ common:get-cpu-load
+ common:hms-string->seconds
+ seconds->time-string
+ common:get-megatest-exe
+
+ megatest-version
+ common:get-toppath
+ common:generic-ssh
+ common:file-exists?
+ common:with-env-vars
+ common:nice-path
+ common:get-fields
+
+ common:get-normalized-cpu-load
+ common:unix-ping
+ common:get-normalized-cpu-load
+
+ ;; globals
+ *common:badly-ended-states*
+ *common:dont-roll-up-states*
+ *common:ended-states*
+ *common:not-started-ok-statuses*
+ *common:running-states*
+ *common:std-states*
+ *common:std-statuses*
+ *common:well-ended-states*
+ *configdat*
+ *configinfo*
+ *db-access-allowed*
+ *db-api-call-time*
+ *db-cache-path*
+ *db-keys*
+ *default-area-tag*
+ *host-loads*
+ *keyvals*
+ *logged-in-clients*
+ *my-client-signature*
+ *on-exit-procs*
+ *pkts-info*
+ *pre-reqs-met-cache*
+ *runremote*
+ *server-id*
+ *server-info*
+ *target*
+ *task-db*
+ *testconfigs*
+ *time-to-exit*
+ *toppath*
+ *transport-type*
+
+ any->number-if-possible
+
+ common:special-sort
+ keys:target-set-args
+
+ getenv
+ setenv
+ safe-setenv
+
+ commonmod:get-cpu-load
+
+ get-area-path-signature
+ common:simple-file-lock
+ common:low-noise-print
+ common:get-create-writeable-dir
+ common:real-path
+ val->alist
+
+ client:get-signature
+
+ common:get-color-from-status
+
+ seconds->year-work-week/day-time
+ common:simple-file-release-lock
+ common:simple-file-lock-and-wait
+ tests:lookup-itemmap
+
+ tests:match->sqlqry
+ runs:get-std-run-fields
+ common:min-max
+ common:max
+ common:sum
+ keys:target->keyval
+ db:patt->like
+
+ rmt:transport-mode
+ common:version-signature
+
+ keys->keystr
+ keys:config-get-fields
+ common:make-tmpdir-name
+
+ db:test-get-status
+ db:test-get-state
+ db:test-get-event_time
+ db:test-get-item-path
+ db:test-get-testname
+ db:test-get-id
+ db:test-get-comment
+ db:test-get-run_duration
+ db:test-get-rundir
+
+ tests:match
+ patt-list-match
+ common:pkts-spec
+
+ sdb:qry
+ seconds->work-week/day-time
+
+ tdb:step-get-comment
+ seconds->hr-min-sec
+ any->number
+ tdb:step-get-logfile
+ tdb:step-get-event_time
+ tdb:step-get-status
+ tdb:step-get-state
+ tdb:step-get-id
+ tdb:step-get-stepname
+ db:test-make-full-name
+ common:htree->html
+ common:list->htree
+
+ tdb:steps-table-get-log-file
+ tdb:steps-table-get-runtime
+ tdb:steps-table-get-status
+ tdb:steps-table-get-end
+ tdb:steps-table-get-start
+ tdb:steps-table-get-stepname
+ tdb:step-get-last_update
+ tdb:step-get-test_id
+
+ db:test-get-run_id
+ db:test-get-final_logf
+
+ tests:testqueue-get-item_path
+ tests:testqueue-get-itemdat
+ tests:testqueue-get-testname
+ tests:testqueue-get-priority
+ tests:testqueue-set-priority!
+ tests:testqueue-get-testconfig
+ tests:testqueue-get-waitons
+
+ tasks:wait-on-journal
+ common:get-area-path-signature
+
+ db:test-get-last_update
+ db:test-get-archived
+ db:test-get-uname
+ db:test-get-diskfree
+ db:test-get-cpuload
+ db:test-get-process_id
+ db:test-get-host
+ db:test-data-get-last_update
+ db:test-data-get-type
+ db:test-data-get-status
+ db:test-data-get-comment
+ db:test-data-get-units
+ db:test-data-get-tol
+ db:test-data-get-expected
+ db:test-data-get-value
+ db:test-data-get-variable
+ db:test-data-get-category
+ db:test-data-get-test_id
+ db:test-data-get-id
+
+ host-last-cpuload
+ host-last-update
+ host-last-cpuload-set!
+ host-last-update-set!
+ host-reachable-set!
+ make-host
+ host-last-used-set!
+ host-reachable
+ host-last-used
+
+ common:alist-ref/default
+ common:val->alist
+ common:in-running-test?
+
+ common:without-vars
+ common:get-megatest-exe-path
+ common:get-megatest-exe-dir
+ common:get-param-mapping
+ common:get-mtexe
+
+ db:test-get-is-toplevel
+ seconds->quarter
+ *globalexitstatus*
+
+ tests:testqueue-set-items!
+ tests:testqueue-get-items
+ *runconfigdat*
+ *passnum*
+ *already-seen-runconfig-info*
+ common:directory-writable?
+ common:dir-clean-up
+ common:fail-safe
+ common:list-or-null
+ *toptest-paths*
+ common:directory-exists?
+ *configstatus*
+ *last-launch*
+ *launch-setup-mutex*
+ commonmod:is-test-alive
+ alist->env-vars
+ *env-vars-by-run-id*
+ common:get-signature
+ common:join-backgrounded-threads
+ tests:glob-like-match
+ common:send-thunk-to-background-thread
+ db:test-get-fullname
+ common:clear-caches
+ db:mintest-get-event_time
+ *test-meta-updated*
+ tests:testqueue-set-item_path!
+ tests:testqueue-set-itemdat!
+ make-tests:testqueue
+
+ megatest-fossil-hash
+
+ common:steps-can-proceed-given-status-sym
+ status-sym->string
+ common:worse-status-sym
+ common:logpro-exit-code->status-sym
+
+ save-environment-as-files
+ assoc/default
+ common:read-encoded-string
+ common:which
+
+ stop-the-train
+ )
+
(import scheme)
(cond-expand
(chicken-4
(import chicken
@@ -120,10 +361,12 @@
srfi-69
typed-records
system-information
debugprint
+ megatest-fossil-hash
+
)))
;;======================================================================
;; CONTENTS
;;
@@ -385,10 +628,11 @@
(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.
;; environment vars handy stuff from common.scm
;;
(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.
(substring-index "." key)) ;; periods are not allowed in environment variables
(debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\" or starting with \"!\"")
@@ -563,13 +807,10 @@
(if valstr
(val->alist valstr)
'()))) ;; should it return empty list or #f to indicate not set?
-(define (get-section cfgdat section)
- (hash-table-ref/default cfgdat section '()))
-
(define (common:make-tmpdir-name areapath tmpadj)
(let* ((area (pathname-file areapath))
(dname (conc "/tmp/"(current-user-name)"/megatest_localdb/" area "/" (string-translate areapath "/" ".") tmpadj "/.mtdb")))
(unless (directory-exists? dname)
(create-directory dname #t))
@@ -2736,8 +2977,228 @@
(let ((fields (hash-table-ref/default cfgdat "fields" '())))
(map car fields)))
(define keys:config-get-fields common:get-fields)
+;;======================================================================
+;; db_records.scm
+;;======================================================================
+
+;;======================================================================
+;; dbstruct
+;;======================================================================
+
+(define (make-db:test)(make-vector 20))
+(define (db:test-get-id vec) (vector-ref vec 0))
+(define (db:test-get-run_id vec) (vector-ref vec 1))
+(define (db:test-get-testname vec) (vector-ref vec 2))
+(define (db:test-get-state vec) (vector-ref vec 3))
+(define (db:test-get-status vec) (vector-ref vec 4))
+(define (db:test-get-event_time vec) (vector-ref vec 5))
+(define (db:test-get-host vec) (vector-ref vec 6))
+(define (db:test-get-cpuload vec) (vector-ref vec 7))
+(define (db:test-get-diskfree vec) (vector-ref vec 8))
+(define (db:test-get-uname vec) (vector-ref vec 9))
+;; (define (db:test-get-rundir vec) (sdb:qry 'getstr (vector-ref vec 10)))
+(define (db:test-get-rundir vec) (vector-ref vec 10))
+(define (db:test-get-item-path vec) (vector-ref vec 11))
+(define (db:test-get-run_duration vec) (vector-ref vec 12))
+(define (db:test-get-final_logf vec) (vector-ref vec 13))
+(define (db:test-get-comment vec) (vector-ref vec 14))
+(define (db:test-get-process_id vec) (vector-ref vec 16))
+(define (db:test-get-archived vec) (vector-ref vec 17))
+(define (db:test-get-last_update vec) (vector-ref vec 18))
+
+;; (define (db:test-get-pass_count vec) (vector-ref vec 15))
+;; (define (db:test-get-fail_count vec) (vector-ref vec 16))
+(define (db:test-get-fullname vec)
+ (conc (db:test-get-testname vec) "/" (db:test-get-item-path vec)))
+
+;; replace runs:make-full-test-name with this routine
+(define (db:test-make-full-name testname itempath)
+ (if (equal? itempath "") testname (conc testname "/" itempath)))
+
+;; (define (db:test-get-first_err vec) (printable (vector-ref vec 15)))
+;; (define (db:test-get-first_warn vec) (printable (vector-ref vec 16))) ;; RADT => reference 16 is repeated
+
+(define (db:test-set-cpuload! vec val)(vector-set! vec 7 val))
+(define (db:test-set-diskfree! vec val)(vector-set! vec 8 val))
+(define (db:test-set-testname! vec val)(vector-set! vec 2 val))
+(define (db:test-set-state! vec val)(vector-set! vec 3 val))
+(define (db:test-set-status! vec val)(vector-set! vec 4 val))
+(define (db:test-set-run_duration! vec val)(vector-set! vec 12 val))
+(define (db:test-set-final_logf! vec val)(vector-set! vec 13 val))
+
+;; Test record utility functions
+
+;; Is a test a toplevel?
+;;
+(define (db:test-get-is-toplevel vec)
+ (and (equal? (db:test-get-item-path vec) "") ;; test is not an item
+ (equal? (db:test-get-uname vec) "n/a"))) ;; test has never been run
+
+;; make-vector-record "" db mintest id run_id testname state status event_time item_path
+;; RADT => purpose of mintest??
+;;
+(define (make-db:mintest)(make-vector 7))
+(define (db:mintest-get-id vec) (vector-ref vec 0))
+(define (db:mintest-get-run_id vec) (vector-ref vec 1))
+(define (db:mintest-get-testname vec) (vector-ref vec 2))
+(define (db:mintest-get-state vec) (vector-ref vec 3))
+(define (db:mintest-get-status vec) (vector-ref vec 4))
+(define (db:mintest-get-event_time vec) (vector-ref vec 5))
+(define (db:mintest-get-item_path vec) (vector-ref vec 6))
+
+;; make-vector-record db testmeta id testname author owner description reviewed iterated avg_runtime avg_disk
+(define (make-db:testmeta)(make-vector 10 ""))
+(define (db:testmeta-get-id vec) (vector-ref vec 0))
+(define (db:testmeta-get-testname vec) (vector-ref vec 1))
+(define (db:testmeta-get-author vec) (vector-ref vec 2))
+(define (db:testmeta-get-owner vec) (vector-ref vec 3))
+(define (db:testmeta-get-description vec) (vector-ref vec 4))
+(define (db:testmeta-get-reviewed vec) (vector-ref vec 5))
+(define (db:testmeta-get-iterated vec) (vector-ref vec 6))
+(define (db:testmeta-get-avg_runtime vec) (vector-ref vec 7))
+(define (db:testmeta-get-avg_disk vec) (vector-ref vec 8))
+(define (db:testmeta-get-tags vec) (vector-ref vec 9))
+(define (db:testmeta-set-id! vec val)(vector-set! vec 0 val))
+(define (db:testmeta-set-testname! vec val)(vector-set! vec 1 val))
+(define (db:testmeta-set-author! vec val)(vector-set! vec 2 val))
+(define (db:testmeta-set-owner! vec val)(vector-set! vec 3 val))
+(define (db:testmeta-set-description! vec val)(vector-set! vec 4 val))
+(define (db:testmeta-set-reviewed! vec val)(vector-set! vec 5 val))
+(define (db:testmeta-set-iterated! vec val)(vector-set! vec 6 val))
+(define (db:testmeta-set-avg_runtime! vec val)(vector-set! vec 7 val))
+(define (db:testmeta-set-avg_disk! vec val)(vector-set! vec 8 val))
+
+;;======================================================================
+;; S I M P L E R U N
+;;======================================================================
+
+;; (defstruct id "runname" "state" "status" "owner" "event_time"
+
+;;======================================================================
+;; T E S T D A T A
+;;======================================================================
+(define (make-db:test-data)(make-vector 10))
+(define (db:test-data-get-id vec) (vector-ref vec 0))
+(define (db:test-data-get-test_id vec) (vector-ref vec 1))
+(define (db:test-data-get-category vec) (vector-ref vec 2))
+(define (db:test-data-get-variable vec) (vector-ref vec 3))
+(define (db:test-data-get-value vec) (vector-ref vec 4))
+(define (db:test-data-get-expected vec) (vector-ref vec 5))
+(define (db:test-data-get-tol vec) (vector-ref vec 6))
+(define (db:test-data-get-units vec) (vector-ref vec 7))
+(define (db:test-data-get-comment vec) (vector-ref vec 8))
+(define (db:test-data-get-status vec) (vector-ref vec 9))
+(define (db:test-data-get-type vec) (vector-ref vec 10))
+(define (db:test-data-get-last_update vec) (vector-ref vec 11))
+
+(define (db:test-data-set-id! vec val)(vector-set! vec 0 val))
+(define (db:test-data-set-test_id! vec val)(vector-set! vec 1 val))
+(define (db:test-data-set-category! vec val)(vector-set! vec 2 val))
+(define (db:test-data-set-variable! vec val)(vector-set! vec 3 val))
+(define (db:test-data-set-value! vec val)(vector-set! vec 4 val))
+(define (db:test-data-set-expected! vec val)(vector-set! vec 5 val))
+(define (db:test-data-set-tol! vec val)(vector-set! vec 6 val))
+(define (db:test-data-set-units! vec val)(vector-set! vec 7 val))
+(define (db:test-data-set-comment! vec val)(vector-set! vec 8 val))
+(define (db:test-data-set-status! vec val)(vector-set! vec 9 val))
+(define (db:test-data-set-type! vec val)(vector-set! vec 10 val))
+
+;;======================================================================
+;; S T E P S
+;;======================================================================
+;; Run steps
+;; make-vector-record "Run steps" db step id test_id stepname step_complete step_pass event_time
+(define (make-db:step)(make-vector 9))
+(define (tdb:step-get-id vec) (vector-ref vec 0))
+(define (tdb:step-get-test_id vec) (vector-ref vec 1))
+(define (tdb:step-get-stepname vec) (vector-ref vec 2))
+(define (tdb:step-get-state vec) (vector-ref vec 3))
+(define (tdb:step-get-status vec) (vector-ref vec 4))
+(define (tdb:step-get-event_time vec) (vector-ref vec 5))
+(define (tdb:step-get-logfile vec) (vector-ref vec 6))
+(define (tdb:step-get-comment vec) (vector-ref vec 7))
+(define (tdb:step-get-last_update vec) (vector-ref vec 8))
+(define (tdb:step-set-id! vec val)(vector-set! vec 0 val))
+(define (tdb:step-set-test_id! vec val)(vector-set! vec 1 val))
+(define (tdb:step-set-stepname! vec val)(vector-set! vec 2 val))
+(define (tdb:step-set-state! vec val)(vector-set! vec 3 val))
+(define (tdb:step-set-status! vec val)(vector-set! vec 4 val))
+(define (tdb:step-set-event_time! vec val)(vector-set! vec 5 val))
+(define (tdb:step-set-logfile! vec val)(vector-set! vec 6 val))
+(define (tdb:step-set-comment! vec val)(vector-set! vec 7 val))
+
+
+;; The steps table
+(define (make-db:steps-table)(make-vector 5))
+(define (tdb:steps-table-get-stepname vec) (vector-ref vec 0))
+(define (tdb:steps-table-get-start vec) (vector-ref vec 1))
+(define (tdb:steps-table-get-end vec) (vector-ref vec 2))
+(define (tdb:steps-table-get-status vec) (vector-ref vec 3))
+(define (tdb:steps-table-get-runtime vec) (vector-ref vec 4))
+(define (tdb:steps-table-get-log-file vec) (vector-ref vec 5))
+
+(define (tdb:step-stable-set-stepname! vec val)(vector-set! vec 0 val))
+(define (tdb:step-stable-set-start! vec val)(vector-set! vec 1 val))
+(define (tdb:step-stable-set-end! vec val)(vector-set! vec 2 val))
+(define (tdb:step-stable-set-status! vec val)(vector-set! vec 3 val))
+(define (tdb:step-stable-set-runtime! vec val)(vector-set! vec 4 val))
+
+;; ;; The data structure for handing off requests via wire
+;; (define (make-cdb:packet)(make-vector 6))
+;; (define (cdb:packet-get-client-sig vec) (vector-ref vec 0))
+;; (define (cdb:packet-get-qtype vec) (vector-ref vec 1))
+;; (define (cdb:packet-get-immediate vec) (vector-ref vec 2))
+;; (define (cdb:packet-get-query-sig vec) (vector-ref vec 3))
+;; (define (cdb:packet-get-params vec) (vector-ref vec 4))
+;; (define (cdb:packet-get-qtime vec) (vector-ref vec 5))
+;; (define (cdb:packet-set-client-sig! vec val)(vector-set! vec 0 val))
+;; (define (cdb:packet-set-qtype! vec val)(vector-set! vec 1 val))
+;; (define (cdb:packet-set-immediate! vec val)(vector-set! vec 2 val))
+;; (define (cdb:packet-set-query-sig! vec val)(vector-set! vec 3 val))
+;; (define (cdb:packet-set-params! vec val)(vector-set! vec 4 val))
+;; (define (cdb:packet-set-qtime! vec val)(vector-set! vec 5 val))
+
+;;======================================================================
+;; key_records
+;;======================================================================
+
+(define (keys->valslots keys) ;; => ?,?,? ....
+ (string-intersperse (map (lambda (x) "?") keys) ","))
+
+;; (define (keys->key/field keys . additional)
+;; (string-join (map (lambda (k)(conc k " TEXT"))
+;; (append keys additional)) ","))
+
+(define (item-list->path itemdat)
+ (if (list? itemdat)
+ (string-intersperse (map cadr itemdat) "/")
+ ""))
+
+
+;;======================================================================
+;; test_records
+;;======================================================================
+
+;; make-vector-record tests testqueue testname testconfig waitons priority items
+(define (make-tests:testqueue)(make-vector 7 #f))
+(define (tests:testqueue-get-testname vec) (vector-ref vec 0))
+(define (tests:testqueue-get-testconfig vec) (vector-ref vec 1))
+(define (tests:testqueue-get-waitons vec) (vector-ref vec 2))
+(define (tests:testqueue-get-priority vec) (vector-ref vec 3))
+;; items: #f=no items, list=list of items remaining, proc=need to call to get items
+(define (tests:testqueue-get-items vec) (vector-ref vec 4))
+(define (tests:testqueue-get-itemdat vec) (vector-ref vec 5))
+(define (tests:testqueue-get-item_path vec) (vector-ref vec 6))
+
+(define (tests:testqueue-set-testname! vec val)(vector-set! vec 0 val))
+(define (tests:testqueue-set-testconfig! vec val)(vector-set! vec 1 val))
+(define (tests:testqueue-set-waitons! vec val)(vector-set! vec 2 val))
+(define (tests:testqueue-set-priority! vec val)(vector-set! vec 3 val))
+(define (tests:testqueue-set-items! vec val)(vector-set! vec 4 val))
+(define (tests:testqueue-set-itemdat! vec val)(vector-set! vec 5 val))
+(define (tests:testqueue-set-item_path! vec val)(vector-set! vec 6 val))
)
Index: configf.scm
==================================================================
--- configf.scm
+++ configf.scm
@@ -28,11 +28,11 @@
(declare (uses env))
(declare (uses keys))
(declare (uses debugprint))
(declare (uses mtargs))
(declare (uses mtargs.import))
-(declare (uses common))
+;; (declare (uses common))
(declare (uses commonmod))
(declare (uses commonmod.import))
(declare (uses processmod))
(declare (uses processmod.import))
(declare (uses configfmod))
Index: configfmod.scm
==================================================================
--- configfmod.scm
+++ configfmod.scm
@@ -25,11 +25,34 @@
(declare (uses mtargs))
(use regex regex-case)
(module configfmod
-*
+ (
+ lookup
+ configf:lookup
+ get-section
+ configf:get-section
+ configf:lookup-number
+ read-config
+ runconfigs-get
+ configf:section-vars
+ configf:read-alist
+ configf:config->alist
+ configf:alist->config
+ configf:set-section-var
+
+ find-and-read-config
+ common:args-get-target
+ configf:eval-string-in-environment
+
+ read-config-set!
+ configf:read-file
+
+ configf:system
+ shell
+ )
(import scheme
chicken
extras
files
@@ -203,10 +226,12 @@
(if match ;; (and match (list? match)(> (length match) 1))
(cadr match)
#f))
))
#f))
+
+(define lookup configf:lookup)
;; use to have definitive setting:
;; [foo]
;; var yes
;;
@@ -234,10 +259,12 @@
'()
(map car sectdat))))
(define (configf:get-section cfgdat section)
(hash-table-ref/default cfgdat section '()))
+
+(define get-section configf:get-section)
(define (configf:set-section-var cfgdat section var val)
(let ((sectdat (configf:get-section cfgdat section)))
(hash-table-set! cfgdat section
(configf:assoc-safe-add sectdat var val))))
@@ -507,13 +534,10 @@
(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))))
-
-
-
(include "configf-guts.scm")
)
Index: cpumod.scm
==================================================================
--- cpumod.scm
+++ cpumod.scm
@@ -29,11 +29,12 @@
(declare (uses mtargs))
(use srfi-69)
(module cpumod
- *
+ ()
+
(import scheme)
(cond-expand
(chicken-4
Index: dashboard-context-menu.scm
==================================================================
--- dashboard-context-menu.scm
+++ dashboard-context-menu.scm
@@ -22,11 +22,11 @@
;; implementation of context menu that pops up on
;; right click on test cell in Runs & Runs Summary Tabs
;;======================================================================
(declare (unit dashboard-context-menu))
-(declare (uses common))
+;; (declare (uses common))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses gutils))
(declare (uses rmtmod))
(declare (uses ezsteps))
@@ -44,11 +44,11 @@
(use canvas-draw)
(use srfi-1 posix regex regex-case srfi-69)
(use (prefix sqlite3 sqlite3:))
-(include "common_records.scm")
+;; (include "common_records.scm")
;; (include "db_records.scm")
(include "run_records.scm")
(import commonmod
configfmod
Index: dashboard-guimonitor.scm
==================================================================
--- dashboard-guimonitor.scm
+++ dashboard-guimonitor.scm
@@ -30,16 +30,16 @@
(use sqlite3 srfi-1 posix regex regex-case srfi-69)
(import (prefix sqlite3 sqlite3:))
(declare (unit dashboard-guimonitor))
-(declare (uses common))
+;; (declare (uses common))
(declare (uses keys))
(declare (uses commonmod))
(import commonmod)
-(include "common_records.scm")
+;; (include "common_records.scm")
;; (include "db_records.scm")
(include "run_records.scm")
(include "task_records.scm")
(define (control-panel db tdb keys)
Index: dashboard-tests.scm
==================================================================
--- dashboard-tests.scm
+++ dashboard-tests.scm
@@ -21,11 +21,11 @@
;;======================================================================
;; Test info panel
;;======================================================================
(declare (unit dashboard-tests))
-(declare (uses common))
+;; (declare (uses common))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses debugprint))
(declare (uses rmtmod))
(declare (uses megatestmod))
@@ -61,11 +61,11 @@
testsmod
runsmod
subrunmod
)
-(include "common_records.scm")
+;; (include "common_records.scm")
;; (include "db_records.scm")
(include "run_records.scm")
;;======================================================================
;; C O M M O N
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -66,11 +66,11 @@
(declare (uses runsmod.import))
(declare (uses launchmod))
(declare (uses launchmod.import))
(declare (uses configf))
-(declare (uses common))
+;; (declare (uses common))
(declare (uses keys))
(declare (uses process))
(declare (uses launch))
(declare (uses runs))
@@ -107,15 +107,15 @@
tasksmod
runsmod
testsmod
)
-(include "common_records.scm")
+;; (include "common_records.scm")
;; (include "db_records.scm")
(include "run_records.scm")
(include "task_records.scm")
-(include "megatest-version.scm")
+;; (include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
(include "vg_records.scm")
;; set some parameters here - these need to be put in something that can be loaded from other
;; executables such as dashboard and mtutil
Index: db_records.scm
==================================================================
--- db_records.scm
+++ db_records.scm
@@ -13,181 +13,5 @@
;; 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 .
-;;======================================================================
-;; dbstruct
-;;======================================================================
-
-(define (make-db:test)(make-vector 20))
-(define (db:test-get-id vec) (vector-ref vec 0))
-(define (db:test-get-run_id vec) (vector-ref vec 1))
-(define (db:test-get-testname vec) (vector-ref vec 2))
-(define (db:test-get-state vec) (vector-ref vec 3))
-(define (db:test-get-status vec) (vector-ref vec 4))
-(define (db:test-get-event_time vec) (vector-ref vec 5))
-(define (db:test-get-host vec) (vector-ref vec 6))
-(define (db:test-get-cpuload vec) (vector-ref vec 7))
-(define (db:test-get-diskfree vec) (vector-ref vec 8))
-(define (db:test-get-uname vec) (vector-ref vec 9))
-;; (define (db:test-get-rundir vec) (sdb:qry 'getstr (vector-ref vec 10)))
-(define (db:test-get-rundir vec) (vector-ref vec 10))
-(define (db:test-get-item-path vec) (vector-ref vec 11))
-(define (db:test-get-run_duration vec) (vector-ref vec 12))
-(define (db:test-get-final_logf vec) (vector-ref vec 13))
-(define (db:test-get-comment vec) (vector-ref vec 14))
-(define (db:test-get-process_id vec) (vector-ref vec 16))
-(define (db:test-get-archived vec) (vector-ref vec 17))
-(define (db:test-get-last_update vec) (vector-ref vec 18))
-
-;; (define (db:test-get-pass_count vec) (vector-ref vec 15))
-;; (define (db:test-get-fail_count vec) (vector-ref vec 16))
-(define (db:test-get-fullname vec)
- (conc (db:test-get-testname vec) "/" (db:test-get-item-path vec)))
-
-;; replace runs:make-full-test-name with this routine
-(define (db:test-make-full-name testname itempath)
- (if (equal? itempath "") testname (conc testname "/" itempath)))
-
-;; (define (db:test-get-first_err vec) (printable (vector-ref vec 15)))
-;; (define (db:test-get-first_warn vec) (printable (vector-ref vec 16))) ;; RADT => reference 16 is repeated
-
-(define (db:test-set-cpuload! vec val)(vector-set! vec 7 val))
-(define (db:test-set-diskfree! vec val)(vector-set! vec 8 val))
-(define (db:test-set-testname! vec val)(vector-set! vec 2 val))
-(define (db:test-set-state! vec val)(vector-set! vec 3 val))
-(define (db:test-set-status! vec val)(vector-set! vec 4 val))
-(define (db:test-set-run_duration! vec val)(vector-set! vec 12 val))
-(define (db:test-set-final_logf! vec val)(vector-set! vec 13 val))
-
-;; Test record utility functions
-
-;; Is a test a toplevel?
-;;
-(define (db:test-get-is-toplevel vec)
- (and (equal? (db:test-get-item-path vec) "") ;; test is not an item
- (equal? (db:test-get-uname vec) "n/a"))) ;; test has never been run
-
-;; make-vector-record "" db mintest id run_id testname state status event_time item_path
-;; RADT => purpose of mintest??
-;;
-(define (make-db:mintest)(make-vector 7))
-(define (db:mintest-get-id vec) (vector-ref vec 0))
-(define (db:mintest-get-run_id vec) (vector-ref vec 1))
-(define (db:mintest-get-testname vec) (vector-ref vec 2))
-(define (db:mintest-get-state vec) (vector-ref vec 3))
-(define (db:mintest-get-status vec) (vector-ref vec 4))
-(define (db:mintest-get-event_time vec) (vector-ref vec 5))
-(define (db:mintest-get-item_path vec) (vector-ref vec 6))
-
-;; make-vector-record db testmeta id testname author owner description reviewed iterated avg_runtime avg_disk
-(define (make-db:testmeta)(make-vector 10 ""))
-(define (db:testmeta-get-id vec) (vector-ref vec 0))
-(define (db:testmeta-get-testname vec) (vector-ref vec 1))
-(define (db:testmeta-get-author vec) (vector-ref vec 2))
-(define (db:testmeta-get-owner vec) (vector-ref vec 3))
-(define (db:testmeta-get-description vec) (vector-ref vec 4))
-(define (db:testmeta-get-reviewed vec) (vector-ref vec 5))
-(define (db:testmeta-get-iterated vec) (vector-ref vec 6))
-(define (db:testmeta-get-avg_runtime vec) (vector-ref vec 7))
-(define (db:testmeta-get-avg_disk vec) (vector-ref vec 8))
-(define (db:testmeta-get-tags vec) (vector-ref vec 9))
-(define (db:testmeta-set-id! vec val)(vector-set! vec 0 val))
-(define (db:testmeta-set-testname! vec val)(vector-set! vec 1 val))
-(define (db:testmeta-set-author! vec val)(vector-set! vec 2 val))
-(define (db:testmeta-set-owner! vec val)(vector-set! vec 3 val))
-(define (db:testmeta-set-description! vec val)(vector-set! vec 4 val))
-(define (db:testmeta-set-reviewed! vec val)(vector-set! vec 5 val))
-(define (db:testmeta-set-iterated! vec val)(vector-set! vec 6 val))
-(define (db:testmeta-set-avg_runtime! vec val)(vector-set! vec 7 val))
-(define (db:testmeta-set-avg_disk! vec val)(vector-set! vec 8 val))
-
-;;======================================================================
-;; S I M P L E R U N
-;;======================================================================
-
-;; (defstruct id "runname" "state" "status" "owner" "event_time"
-
-;;======================================================================
-;; T E S T D A T A
-;;======================================================================
-(define (make-db:test-data)(make-vector 10))
-(define (db:test-data-get-id vec) (vector-ref vec 0))
-(define (db:test-data-get-test_id vec) (vector-ref vec 1))
-(define (db:test-data-get-category vec) (vector-ref vec 2))
-(define (db:test-data-get-variable vec) (vector-ref vec 3))
-(define (db:test-data-get-value vec) (vector-ref vec 4))
-(define (db:test-data-get-expected vec) (vector-ref vec 5))
-(define (db:test-data-get-tol vec) (vector-ref vec 6))
-(define (db:test-data-get-units vec) (vector-ref vec 7))
-(define (db:test-data-get-comment vec) (vector-ref vec 8))
-(define (db:test-data-get-status vec) (vector-ref vec 9))
-(define (db:test-data-get-type vec) (vector-ref vec 10))
-(define (db:test-data-get-last_update vec) (vector-ref vec 11))
-
-(define (db:test-data-set-id! vec val)(vector-set! vec 0 val))
-(define (db:test-data-set-test_id! vec val)(vector-set! vec 1 val))
-(define (db:test-data-set-category! vec val)(vector-set! vec 2 val))
-(define (db:test-data-set-variable! vec val)(vector-set! vec 3 val))
-(define (db:test-data-set-value! vec val)(vector-set! vec 4 val))
-(define (db:test-data-set-expected! vec val)(vector-set! vec 5 val))
-(define (db:test-data-set-tol! vec val)(vector-set! vec 6 val))
-(define (db:test-data-set-units! vec val)(vector-set! vec 7 val))
-(define (db:test-data-set-comment! vec val)(vector-set! vec 8 val))
-(define (db:test-data-set-status! vec val)(vector-set! vec 9 val))
-(define (db:test-data-set-type! vec val)(vector-set! vec 10 val))
-
-;;======================================================================
-;; S T E P S
-;;======================================================================
-;; Run steps
-;; make-vector-record "Run steps" db step id test_id stepname step_complete step_pass event_time
-(define (make-db:step)(make-vector 9))
-(define (tdb:step-get-id vec) (vector-ref vec 0))
-(define (tdb:step-get-test_id vec) (vector-ref vec 1))
-(define (tdb:step-get-stepname vec) (vector-ref vec 2))
-(define (tdb:step-get-state vec) (vector-ref vec 3))
-(define (tdb:step-get-status vec) (vector-ref vec 4))
-(define (tdb:step-get-event_time vec) (vector-ref vec 5))
-(define (tdb:step-get-logfile vec) (vector-ref vec 6))
-(define (tdb:step-get-comment vec) (vector-ref vec 7))
-(define (tdb:step-get-last_update vec) (vector-ref vec 8))
-(define (tdb:step-set-id! vec val)(vector-set! vec 0 val))
-(define (tdb:step-set-test_id! vec val)(vector-set! vec 1 val))
-(define (tdb:step-set-stepname! vec val)(vector-set! vec 2 val))
-(define (tdb:step-set-state! vec val)(vector-set! vec 3 val))
-(define (tdb:step-set-status! vec val)(vector-set! vec 4 val))
-(define (tdb:step-set-event_time! vec val)(vector-set! vec 5 val))
-(define (tdb:step-set-logfile! vec val)(vector-set! vec 6 val))
-(define (tdb:step-set-comment! vec val)(vector-set! vec 7 val))
-
-
-;; The steps table
-(define (make-db:steps-table)(make-vector 5))
-(define (tdb:steps-table-get-stepname vec) (vector-ref vec 0))
-(define (tdb:steps-table-get-start vec) (vector-ref vec 1))
-(define (tdb:steps-table-get-end vec) (vector-ref vec 2))
-(define (tdb:steps-table-get-status vec) (vector-ref vec 3))
-(define (tdb:steps-table-get-runtime vec) (vector-ref vec 4))
-(define (tdb:steps-table-get-log-file vec) (vector-ref vec 5))
-
-(define (tdb:step-stable-set-stepname! vec val)(vector-set! vec 0 val))
-(define (tdb:step-stable-set-start! vec val)(vector-set! vec 1 val))
-(define (tdb:step-stable-set-end! vec val)(vector-set! vec 2 val))
-(define (tdb:step-stable-set-status! vec val)(vector-set! vec 3 val))
-(define (tdb:step-stable-set-runtime! vec val)(vector-set! vec 4 val))
-
-;; ;; The data structure for handing off requests via wire
-;; (define (make-cdb:packet)(make-vector 6))
-;; (define (cdb:packet-get-client-sig vec) (vector-ref vec 0))
-;; (define (cdb:packet-get-qtype vec) (vector-ref vec 1))
-;; (define (cdb:packet-get-immediate vec) (vector-ref vec 2))
-;; (define (cdb:packet-get-query-sig vec) (vector-ref vec 3))
-;; (define (cdb:packet-get-params vec) (vector-ref vec 4))
-;; (define (cdb:packet-get-qtime vec) (vector-ref vec 5))
-;; (define (cdb:packet-set-client-sig! vec val)(vector-set! vec 0 val))
-;; (define (cdb:packet-set-qtype! vec val)(vector-set! vec 1 val))
-;; (define (cdb:packet-set-immediate! vec val)(vector-set! vec 2 val))
-;; (define (cdb:packet-set-query-sig! vec val)(vector-set! vec 3 val))
-;; (define (cdb:packet-set-params! vec val)(vector-set! vec 4 val))
-;; (define (cdb:packet-set-qtime! vec val)(vector-set! vec 5 val))
Index: dbmod.scm
==================================================================
--- dbmod.scm
+++ dbmod.scm
@@ -26,11 +26,154 @@
(declare (uses debugprint))
(declare (uses mtargs))
(declare (uses mtmod))
(module dbmod
- *
+ (
+ db:test-get-event_time
+ db:test-get-item-path
+ db:test-get-testname
+ db:get-value-by-header
+
+ db:get-subdb
+
+ db:multi-db-sync
+
+ dbmod:open-dbmoddb
+ dbmod:run-id->dbfname
+
+ db:roll-up-rules
+ db:get-all-state-status-counts-for-test
+ db:test-set-state-status-db
+ db:general-call
+ db:convert-test-itempath
+
+ db:test-data-rollup
+ db:keep-trying-until-true
+ db:get-test-info-by-id
+ db:with-db
+ db:get-test-id
+ db:get-test-info
+
+ dbmod:print-db-stats
+ db:get-keys
+ db:open-no-sync-db
+ db:add-stats
+
+ ;; dbr:counts record accessors
+ dbr:counts->alist
+
+ db:add-var
+ db:archive-register-block-name
+ db:archive-register-disk
+ db:create-all-triggers
+ db:csv->test-data
+ db:dec-var
+ db:del-var
+ db:delete-old-deleted-test-records
+ db:delete-run
+ db:delete-steps-for-test!
+ db:delete-test-records
+ db:drop-all-triggers
+ db:get-all-run-ids
+ db:get-all-runids
+ db:get-changed-record-ids
+ db:get-changed-record-run-ids
+ db:get-changed-record-test-ids
+ db:get-count-tests-running
+ db:get-count-tests-running-for-run-id
+ db:get-count-tests-running-for-testname
+ db:get-count-tests-running-in-jobgroup
+ db:get-data-info-by-id
+ db:get-key-val-pairs
+ db:get-key-vals
+ db:get-latest-host-load
+ db:get-main-run-stats
+ db:get-matching-previous-test-run-records
+ db:get-not-completed-cnt
+ db:get-num-runs
+ db:get-prereqs-not-met
+ db:get-prev-run-ids
+ db:get-raw-run-stats
+ db:get-run-ids-matching-target
+ db:get-run-info
+ db:get-run-name-from-id
+ db:get-run-record-ids
+ db:get-run-state
+ db:get-run-state-status
+ db:get-run-stats
+ db:get-run-status
+ db:get-run-times
+ db:get-runs
+ db:get-runs-by-patt
+ db:get-runs-cnt-by-patt
+ db:get-steps-data
+ db:get-steps-for-test
+ db:get-steps-info-by-id
+ db:get-target
+ db:get-targets
+ db:get-test-state-status-by-id
+ db:get-test-times
+ db:get-testinfo-state-status
+ db:get-tests-for-run
+ db:get-tests-for-run-mindata
+ db:get-tests-for-run-state-status
+ db:get-tests-tags
+ db:get-toplevels-and-incompletes
+ db:get-var
+ db:have-incompletes?
+ db:inc-var
+ db:initialize-main-db
+ db:insert-run
+ db:insert-test
+ db:lock/unlock-run
+ db:login
+ db:read-test-data
+ db:read-test-data-varpatt
+ db:register-run
+ db:set-run-state-status
+ db:set-run-status
+ db:set-state-status-and-roll-up-run
+ db:set-var
+ db:simple-get-runs
+ db:test-get-archive-block-info
+ db:test-get-logfile-info
+ db:test-get-paths-matching-keynames-target-new
+ db:test-get-records-for-index-file
+ db:test-get-rundir-from-test-id
+ db:test-get-top-process-pid
+ db:test-set-archive-block-id
+ db:test-set-state-status
+ db:test-set-top-process-pid
+ db:test-toplevel-num-items
+ db:testmeta-add-record
+ db:testmeta-get-record
+ db:testmeta-update-field
+ db:teststep-set-status!
+ db:top-test-set-per-pf-counts
+ db:update-run-event_time
+ db:update-run-stats
+ db:update-tesdata-on-repilcate-db
+ tasks:add
+ tasks:find-task-queue-records
+ tasks:get-last
+ tasks:set-state-given-param-key
+
+ *db-stats*
+ dbmod:nfs-get-dbstruct
+ *db-stats-mutex*
+
+ db:get-header
+ db:get-rows
+ db:get-changed-run-ids
+
+ db:set-sync
+ db:setup
+
+ db:logpro-dat->csv
+ std-exit-procedure
+ )
(import scheme)
(cond-expand
(chicken-4
@@ -79,11 +222,11 @@
dbfile
debugprint
mtmod
)
-(include "common_records.scm")
+;; (include "common_records.scm")
;; (include "db_records.scm")
;; (include "key_records.scm")
(include "run_records.scm")
(define *number-of-writes* 0)
Index: dcommon.scm
==================================================================
--- dcommon.scm
+++ dcommon.scm
@@ -40,11 +40,11 @@
testsmod
dbmod
debugprint)
(include "megatest-version.scm")
-(include "common_records.scm")
+;; (include "common_records.scm")
;; (include "db_records.scm")
;; (include "key_records.scm")
(include "run_records.scm")
;; yes, this is non-ideal
Index: diff-report.scm
==================================================================
--- diff-report.scm
+++ diff-report.scm
@@ -15,19 +15,19 @@
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
(declare (unit diff-report))
-(declare (uses common))
+;; (declare (uses common))
(declare (uses debugprint))
(declare (uses rmtmod))
(declare (uses commonmod))
(import commonmod
rmtmod
debugprint)
-(include "common_records.scm")
+;; (include "common_records.scm")
(use matchable)
(use fmt)
(use ducttape-lib)
(define css "")
Index: ezsteps.scm
==================================================================
--- ezsteps.scm
+++ ezsteps.scm
@@ -19,11 +19,11 @@
;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
(declare (unit ezsteps))
(declare (uses commonmod))
-(declare (uses common))
+;; (declare (uses common))
(declare (uses configfmod))
(declare (uses debugprint))
(declare (uses runconfig))
(declare (uses rmtmod))
Index: ezstepsmod.scm
==================================================================
--- ezstepsmod.scm
+++ ezstepsmod.scm
@@ -45,11 +45,11 @@
(declare (uses fsmod))
(use srfi-69)
(module ezstepsmod
- *
+ ()
(import scheme)
(cond-expand
(chicken-4
@@ -126,11 +126,11 @@
testsmod
runsmod
fsmod
)
-(include "common_records.scm")
+;; (include "common_records.scm")
;; (include "key_records.scm")
;; (include "db_records.scm")
(include "run_records.scm")
Index: fsmod.scm
==================================================================
--- fsmod.scm
+++ fsmod.scm
@@ -33,11 +33,18 @@
(declare (uses processmod))
(use srfi-69)
(module fsmod
- *
+ (
+ get-df
+ get-uname
+ common:get-disk-with-most-free-space
+ common:get-disk-space-used
+ common:check-db-dir-and-exit-if-insufficient
+
+ )
(import scheme)
(cond-expand
(chicken-4
Index: genexample.scm
==================================================================
--- genexample.scm
+++ genexample.scm
@@ -19,11 +19,11 @@
;;======================================================================
(declare (unit genexample))
(declare (uses mtargs))
(declare (uses debugprint))
-(declare (uses common))
+;; (declare (uses common))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses rmtmod))
(use posix regex matchable)
Index: key_records.scm
==================================================================
--- key_records.scm
+++ key_records.scm
@@ -16,17 +16,5 @@
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;======================================================================
-(define (keys->valslots keys) ;; => ?,?,? ....
- (string-intersperse (map (lambda (x) "?") keys) ","))
-
-;; (define (keys->key/field keys . additional)
-;; (string-join (map (lambda (k)(conc k " TEXT"))
-;; (append keys additional)) ","))
-
-(define (item-list->path itemdat)
- (if (list? itemdat)
- (string-intersperse (map cadr itemdat) "/")
- ""))
-
Index: keys.scm
==================================================================
--- keys.scm
+++ keys.scm
@@ -20,11 +20,11 @@
;;======================================================================
;; Run keys, these are used to hierarchially organise tests and run areas
;;======================================================================
(declare (unit keys))
-(declare (uses common))
+;; (declare (uses common))
(declare (uses debugprint))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses mtargs))
Index: launch.scm
==================================================================
--- launch.scm
+++ launch.scm
@@ -21,11 +21,11 @@
;;
;;======================================================================
(declare (unit launch))
(declare (uses subrun))
-(declare (uses common))
+;; (declare (uses common))
(declare (uses debugprint))
(declare (uses commonmod))
(declare (uses processmod))
(declare (uses configfmod))
(declare (uses configf))
@@ -46,11 +46,11 @@
(import (prefix base64 base64:)
(prefix sqlite3 sqlite3:)
(prefix mtargs args:)
)
-(include "common_records.scm")
+;; (include "common_records.scm")
;; (include "key_records.scm")
;; (include "db_records.scm")
(include "megatest-fossil-hash.scm")
(import commonmod
Index: launchmod.scm
==================================================================
--- launchmod.scm
+++ launchmod.scm
@@ -44,11 +44,12 @@
(declare (uses fsmod))
(use srfi-69)
(module launchmod
- *
+ (
+ )
(import scheme)
(cond-expand
(chicken-4
@@ -126,11 +127,11 @@
testsmod
runsmod
fsmod
)
-(include "common_records.scm")
+;; (include "common_records.scm")
;; (include "key_records.scm")
;; (include "db_records.scm")
(include "megatest-fossil-hash.scm")
;;======================================================================
@@ -979,96 +980,10 @@
;; 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)))
-;;======================================================================
-;; Maintenance
-;;======================================================================
-
-(define (rmt:find-and-mark-incomplete run-id ovr-deadtime)
- (let* ((cfg-deadtime (configf:lookup-number *configdat* "setup" "deadtime"))
- (test-stats-update-period (configf:lookup-number *configdat* "setup" "test-stats-update-period")))
- (rmt:find-and-mark-incomplete-engine run-id ovr-deadtime cfg-deadtime test-stats-update-period)
- ;;call end of eud of run detection for posthook
- (launch:end-of-run-check run-id)))
-
-;; select end_time-now from
-;; (select testname,item_path,event_time+run_duration as
-;; end_time,strftime('%s','now') as now from tests where state in
-;; ('RUNNING','REMOTEHOSTSTART','LAUNCHED'));
-;;
-;; NOT EASY TO MIGRATE TO db{file,mod}
-;;
-(define (rmt:find-and-mark-incomplete-engine run-id ovr-deadtime cfg-deadtime test-stats-update-period)
- (let* ((incompleted '())
- (oldlaunched '())
- (toplevels '())
- ;; The default running-deadtime is 720 seconds = 12 minutes.
- ;; "(running-deadtime-default (+ server-start-allowance (* 2 launch-monitor-period)))" = 200 + (2 * (200 + 30 + 30))
- (deadtime-trim (or ovr-deadtime cfg-deadtime))
- (server-start-allowance 200)
- (server-overloaded-budget 200)
- (launch-monitor-off-time (or test-stats-update-period 30))
- (launch-monitor-on-time-budget 30)
- (launch-monitor-period (+ launch-monitor-off-time launch-monitor-on-time-budget server-overloaded-budget))
- (remotehoststart-deadtime-default (+ server-start-allowance server-overloaded-budget 30))
- (remotehoststart-deadtime (or deadtime-trim remotehoststart-deadtime-default))
- (running-deadtime-default (+ server-start-allowance (* 2 launch-monitor-period)))
- (running-deadtime (or deadtime-trim running-deadtime-default))) ;; two minutes (30 seconds between updates, this leaves 3x grace period)
-
- (debug:print-info 4 *default-log-port* "running-deadtime = " running-deadtime)
- (debug:print-info 4 *default-log-port* "deadtime-trim = " deadtime-trim)
-
- (let* ((dat (rmt:get-toplevels-and-incompletes run-id running-deadtime remotehoststart-deadtime)))
- (set! oldlaunched (list-ref dat 1))
- (set! toplevels (list-ref dat 2))
- (set! incompleted (list-ref dat 0)))
-
- (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, "
- (length toplevels) " old LAUNCHED toplevel tests and "
- (length incompleted) " tests marked RUNNING but apparently dead.")
-
- ;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE.
- ;;
- ;; (db:delay-if-busy dbdat)
- (let* ((min-incompleted-ids (map car incompleted)) ;; do 'em all
- (all-ids (append min-incompleted-ids (map car oldlaunched))))
- (if (> (length all-ids) 0)
- (begin
- ;; (launch:is-test-alive "localhost" 435)
- (debug:print 0 *default-log-port* "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ")
- " as DEAD")
- (for-each
- (lambda (test-id)
- (let* ((tinfo (rmt:get-test-info-by-id run-id test-id))
- (run-dir (db:test-get-rundir tinfo))
- (host (db:test-get-host tinfo))
- (pid (db:test-get-process_id tinfo))
- (result (rmt:get-status-from-final-status-file run-dir)))
- (if (and (list? result) (> (length result) 1) (equal? "PASS" (cadr result)) (equal? "COMPLETED" (car result)))
- (begin
- (debug:print 0 *default-log-port* "INFO: test " test-id " actually passed, so marking PASS not DEAD")
- (rmt:set-state-status-and-roll-up-items
- run-id test-id 'foo "COMPLETED" "PASS"
- "Test stopped responding but it has PASSED; marking it PASS in the DB."))
- (let ((is-alive (and (not (eq? pid 0)) ;; 0 is default in re-used field "attemptnum" where pid stored.
- (commonmod:is-test-alive host pid))))
- (if is-alive
- (debug:print 0 *default-log-port* "INFO: test " test-id " on host " host
- " has a process on pid " pid ", NOT setting to DEAD.")
- (begin
- (debug:print 0 *default-log-port* "INFO: test " test-id
- " final state/status is not COMPLETED/PASS. It is " result)
- (rmt:set-state-status-and-roll-up-items
- run-id test-id 'foo "COMPLETED" "DEAD"
- "Test stopped responding while in RUNNING or REMOTEHOSTSTART; presumed dead.")))))))
- ;; call end of eud of run detection for posthook - from merge, is it needed?
- ;; (launch:end-of-run-check run-id)
- all-ids)
- )))))
-
;; TODO: deprecate me in favor of ezsteps.scm
;;
(define (ezsteps:runstep ezstep run-id test-id exit-info m tal testconfig all-steps-dat)
(let* ((stepname (car ezstep)) ;; do stuff to run the step
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -15,20 +15,20 @@
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
;; (include "common.scm")
-(include "megatest-version.scm")
+;; (include "megatest-version.scm")
;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)
-(declare (uses common))
+;; (declare (uses common))
;; (declare (uses megatest-version))
;; (declare (uses margs))
(declare (uses mtargs))
-;; (declare (uses mtargs.import))
+(declare (uses mtargs.import))
(declare (uses debugprint))
(declare (uses debugprint.import))
(declare (uses cookie))
(declare (uses cookie.import))
(declare (uses stml2))
@@ -121,11 +121,11 @@
fsmod
)
(define *db* #f) ;; this is only for the repl, do not use in general!!!!
-(include "common_records.scm")
+;; (include "common_records.scm")
;; (include "key_records.scm")
;; (include "db_records.scm")
(include "run_records.scm")
(include "megatest-fossil-hash.scm")
Index: megatestmod.scm
==================================================================
--- megatestmod.scm
+++ megatestmod.scm
@@ -38,11 +38,29 @@
(declare (uses fsmod))
(use srfi-69)
(module megatestmod
- *
+ (
+ db:set-tests-state-status
+ db:set-state-status-and-roll-up-items
+ common:get-install-area
+ tests:get-all
+ common:use-cache?
+
+mt:lazy-read-test-config
+common:get-full-test-name
+tests:extend-test-patts
+tests:get-itemmaps
+tests:get-items
+tests:get-global-waitons
+tests:get-tests-search-path
+tests:filter-test-names
+common:args-get-testpatt
+tests:filter-test-names-not-matched
+common:args-get-runname
+ )
(import scheme)
(cond-expand
(chicken-4
Index: monitor.scm
==================================================================
--- monitor.scm
+++ monitor.scm
@@ -19,16 +19,16 @@
(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking)
(import (prefix sqlite3 sqlite3:))
(declare (unit runs))
-(declare (uses common))
+;; (declare (uses common))
(declare (uses runconfig))
(declare (uses commonmod))
(import commonmod)
-(include "common_records.scm")
+;; (include "common_records.scm")
;; (include "key_records.scm")
;; (include "db_records.scm")
(include "run_records.scm")
Index: mt.scm
==================================================================
--- mt.scm
+++ mt.scm
@@ -22,11 +22,11 @@
(import (prefix sqlite3 sqlite3:))
(declare (unit mt))
(declare (uses debugprint))
-(declare (uses common))
+;; (declare (uses common))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses runconfig))
(declare (uses server))
@@ -41,14 +41,14 @@
megatestmod)
;; make mt: calls in megatestmod work
;; (read-config-set! read-config)
-(include "common_records.scm")
+;; (include "common_records.scm")
;; (include "key_records.scm")
;; (include "db_records.scm")
(include "run_records.scm")
;; (include "test_records.scm")
;; This is the Megatest API. All generally "useful" routines will be wrapped or extended
;; here.
Index: mtexec.scm
==================================================================
--- mtexec.scm
+++ mtexec.scm
@@ -36,11 +36,11 @@
(import commonmod
configfmod
(prefix mtargs args:))
;; (use ducttape-lib)
-(include "megatest-version.scm")
+;; (include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
;; (require-library stml)
(define help (conc "
Index: mtmod.scm
==================================================================
--- mtmod.scm
+++ mtmod.scm
@@ -32,11 +32,22 @@
;; (declare (uses tcp-transportmod)) ;; we don't want mtmod depending on tcp
(use srfi-69)
(module mtmod
- *
+ (
+ keys:make-key/field-string
+ common:get-testsuite-name
+ items:get-items-from-config
+ mt:run-trigger
+ common:get-linktree
+ common:get-area-name
+
+ items:check-valid-items
+ mt:discard-blocked-tests
+
+ )
(import scheme)
(cond-expand
(chicken-4
Index: mtut.scm
==================================================================
--- mtut.scm
+++ mtut.scm
@@ -14,11 +14,11 @@
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
;
-(declare (uses common))
+;; (declare (uses common))
(declare (uses mtargs))
(declare (uses mtargs.import))
(declare (uses debugprint))
(declare (uses debugprint.import))
(declare (uses commonmod))
Index: odsmod.scm
==================================================================
--- odsmod.scm
+++ odsmod.scm
@@ -16,18 +16,19 @@
;; along with Megatest. If not, see .
;;
(use csv-xml regex)
(declare (unit odsmod))
-(declare (uses common))
+;; (declare (uses common))
(declare (uses commonmod))
(declare (uses debugprint))
(declare (uses dbfile))
(declare (uses dbmod))
(module odsmod
- *
+ (
+ )
(import scheme
chicken
data-structures
extras
Index: processmod.scm
==================================================================
--- processmod.scm
+++ processmod.scm
@@ -23,11 +23,19 @@
(declare (uses commonmod))
(use srfi-69)
(module processmod
- *
+ (
+ process:cmd-run->list
+ process:alive?
+ run-n-wait
+ process:cmd-run-with-stderr-and-exitcode->list
+
+ process:alive-on-host?
+ process:get-sub-pids
+ )
(import scheme)
(cond-expand
(chicken-4
Index: rmtmod.scm
==================================================================
--- rmtmod.scm
+++ rmtmod.scm
@@ -28,11 +28,124 @@
(declare (uses tcp-transportmod))
(declare (uses apimod))
(declare (uses servermod))
(module rmtmod
- *
+ (
+ rmtmod:send-receive
+ rmt:send-receive
+ rmt:no-sync-get-lock
+ rmt:no-sync-del!
+ rmt:no-sync-set
+ rmt:no-sync-get/default
+
+ rmt:get-runs-by-patt
+ rmt:get-testinfo-state-status
+ rmt:get-test-id
+ rmt:set-state-status-and-roll-up-items
+
+ rmt:get-prereqs-not-met
+ rmt:get-tests-for-run
+
+ rmt:get-keys
+ rmt:test-get-records-for-index-file
+ tests:test-set-toplog!
+ rmt:test-get-logfile-info
+ rmt:general-call
+ rmt:test-get-paths-matching-keynames-target-new
+ rmt:get-test-info-by-id
+ rmt:get-steps-for-test
+ rmt:get-num-runs
+ rmt:get-runs-cnt-by-patt
+ rmt:get-runs
+
+ rmt:get-latest-host-load
+ rmt:get-changed-record-test-ids
+ rmt:get-all-runids
+ rmt:get-changed-record-run-ids
+ rmt:get-run-record-ids
+ rmt:get-data-info-by-id
+ rmt:get-steps-info-by-id
+ rmt:get-target
+
+ rmt:get-run-name-from-id
+ rmt:get-run-info
+ rmt:get-test-times
+ rmt:get-run-times
+
+ rmt:tasks-find-task-queue-records
+
+ common:api-changed?
+ rmt:on-homehost?
+
+ rmt:get-var
+ rmt:csv->test-data
+ rmt:get-previous-test-run-record
+
+ common:cleanup-db
+ common:get-last-run-version
+
+ rmt:get-key-val-pairs
+ rmt:create-all-triggers
+ rmt:update-tesdata-on-repilcate-db
+ rmt:drop-all-triggers
+ rmt:test-get-archive-block-info
+ rmt:test-toplevel-num-items
+ rmt:archive-get-allocations
+ rmt:archive-register-disk
+ rmt:archive-register-block-name
+
+ mt:get-runs-by-patt
+ rmt:simple-get-runs
+ rmt:get-tests-for-runs-mindata
+ rmt:test-get-top-process-pid
+ rmt:set-state-status-and-roll-up-run
+ rmt:get-run-state-status
+ rmt:get-not-completed-cnt
+ rmt:get-tests-tags
+ rmt:testmeta-update-field
+ rmt:testmeta-add-record
+ rmt:testmeta-get-record
+ rmt:lock/unlock-run
+ rmt:delete-old-deleted-test-records
+ rmt:delete-run
+ rmt:get-raw-run-stats
+ rmt:update-run-stats
+ rmt:delete-test-records
+ rmt:test-set-archive-block-id
+ mt:get-tests-for-run
+ mt:test-set-state-status-by-testname
+ mt:test-set-state-status-by-testname-unless-completed
+ rmt:register-test
+ mt:test-set-state-status-by-id-unless-completed
+ rmt:get-all-run-ids
+
+ rmt:set-run-state-status
+ rmt:set-var
+ rmt:set-tests-state-status
+ rmt:tasks-add
+ rmt:tasks-set-state-given-param-key
+ rmt:register-run
+ rmt:get-count-tests-running-in-jobgroup
+ rmt:get-count-tests-running-for-run-id
+
+ rmt:test-set-state-status-by-id
+ mt:test-set-state-status-by-id
+
+ rmt:get-status-from-final-status-file
+ rmt:get-toplevels-and-incompletes
+
+ rmt:test-set-log!
+ rmt:teststep-set-status!
+
+ rmt:delete-steps-for-test!
+ rmt:test-set-state-status
+ rmt:get-test-state-status-by-id
+ rmt:test-set-top-process-pid
+
+ )
+
(import scheme
chicken
data-structures
regex
@@ -705,14 +818,14 @@
(rmt:send-receive 'update-run-event_time #f (list run-id)))
(define (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit fields last-runs-update #!key (sort-order "asc")) ;; fields of #f uses default
(rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit fields last-runs-update sort-order)))
-(define (rmt:find-and-mark-incomplete run-id ovr-deadtime)
- (assert (number? run-id) "FATAL: Run id required.")
- ;; (if (rmt:send-receive 'have-incompletes? run-id (list run-id ovr-deadtime))
- (rmt:send-receive 'mark-incomplete run-id (list run-id ovr-deadtime))) ;; )
+;; (define (rmt:find-and-mark-incomplete run-id ovr-deadtime)
+;; (assert (number? run-id) "FATAL: Run id required.")
+;; ;; (if (rmt:send-receive 'have-incompletes? run-id (list run-id ovr-deadtime))
+;; (rmt:send-receive 'mark-incomplete run-id (list run-id ovr-deadtime))) ;; )
(define (rmt:get-main-run-stats run-id)
(assert (number? run-id) "FATAL: Run id required.")
(rmt:send-receive 'get-main-run-stats #f (list run-id)))
@@ -737,15 +850,15 @@
;;======================================================================
;; M U L T I R U N Q U E R I E S
;;======================================================================
;; Need to move this to multi-run section and make associated changes
-(define (rmt:find-and-mark-incomplete-all-runs #!key (ovr-deadtime #f))
- (let ((run-ids (rmt:get-all-run-ids)))
- (for-each (lambda (run-id)
- (rmt:find-and-mark-incomplete run-id ovr-deadtime))
- run-ids)))
+;; (define (rmt:find-and-mark-incomplete-all-runs #!key (ovr-deadtime #f))
+;; (let ((run-ids (rmt:get-all-run-ids)))
+;; (for-each (lambda (run-id)
+;; (rmt:find-and-mark-incomplete run-id ovr-deadtime))
+;; run-ids)))
;; get the previous record for when this test was run where all keys match but runname
;; returns #f if no such test found, returns a single test record if found
;;
;; Run this at the client end since we have to connect to multiple run-id dbs
Index: runconfig.scm
==================================================================
--- runconfig.scm
+++ runconfig.scm
@@ -21,14 +21,14 @@
;;======================================================================
(use format directory-utils)
(declare (unit runconfig))
-(declare (uses common))
+;; (declare (uses common))
(declare (uses debugprint))
(declare (uses commonmod))
(import commonmod
debugprint)
-(include "common_records.scm")
+;; (include "common_records.scm")
Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -29,11 +29,11 @@
(declare (uses megatestmod))
(declare (uses mtmod))
(declare (uses tasksmod))
(declare (uses servermod))
-(declare (uses common))
+;; (declare (uses common))
(declare (uses runconfig))
(declare (uses server))
(declare (uses mt))
(declare (uses archive))
@@ -42,11 +42,11 @@
posix-extras directory-utils pathname-expand typed-records format sxml-serializer
sxml-modifications matchable)
-(include "common_records.scm")
+;; (include "common_records.scm")
;; (include "key_records.scm")
;; (include "db_records.scm")
(include "run_records.scm")
;; (include "test_records.scm")
Index: runsmod.scm
==================================================================
--- runsmod.scm
+++ runsmod.scm
@@ -44,11 +44,20 @@
(declare (uses fsmod))
(use srfi-69)
(module runsmod
- *
+ (
+ rmt:find-and-mark-incomplete
+ launch:setup
+ launch:end-of-run-check
+ launch:test-copy
+
+ set-item-env-vars
+ runs:set-megatest-env-vars
+ full-runconfigs-read
+ )
(import scheme)
(cond-expand
(chicken-4
@@ -127,11 +136,11 @@
subrunmod
archivemod
fsmod
)
-(include "common_records.scm")
+;; (include "common_records.scm")
;; (include "key_records.scm")
;; (include "db_records.scm")
(include "run_records.scm")
;; (include "test_records.scm")
@@ -4540,7 +4549,95 @@
(debug:print-info 0 *default-log-port* "remove testdat")
(runs:remove-test-directory test-dat 'archive-remove)))))
(hash-table-ref test-groups test-base)))))
(hash-table-keys disk-groups))
#t))
+
+;;======================================================================
+;; Maintenance
+;;======================================================================
+
+(define (rmt:find-and-mark-incomplete run-id ovr-deadtime)
+ (let* ((cfg-deadtime (configf:lookup-number *configdat* "setup" "deadtime"))
+ (test-stats-update-period (configf:lookup-number *configdat* "setup" "test-stats-update-period")))
+ (rmt:find-and-mark-incomplete-engine run-id ovr-deadtime cfg-deadtime test-stats-update-period)
+ ;;call end of eud of run detection for posthook
+ (launch:end-of-run-check run-id)))
+
+;; select end_time-now from
+;; (select testname,item_path,event_time+run_duration as
+;; end_time,strftime('%s','now') as now from tests where state in
+;; ('RUNNING','REMOTEHOSTSTART','LAUNCHED'));
+;;
+;; NOT EASY TO MIGRATE TO db{file,mod}
+;;
+(define (rmt:find-and-mark-incomplete-engine run-id ovr-deadtime cfg-deadtime test-stats-update-period)
+ (let* ((incompleted '())
+ (oldlaunched '())
+ (toplevels '())
+ ;; The default running-deadtime is 720 seconds = 12 minutes.
+ ;; "(running-deadtime-default (+ server-start-allowance (* 2 launch-monitor-period)))" = 200 + (2 * (200 + 30 + 30))
+ (deadtime-trim (or ovr-deadtime cfg-deadtime))
+ (server-start-allowance 200)
+ (server-overloaded-budget 200)
+ (launch-monitor-off-time (or test-stats-update-period 30))
+ (launch-monitor-on-time-budget 30)
+ (launch-monitor-period (+ launch-monitor-off-time launch-monitor-on-time-budget server-overloaded-budget))
+ (remotehoststart-deadtime-default (+ server-start-allowance server-overloaded-budget 30))
+ (remotehoststart-deadtime (or deadtime-trim remotehoststart-deadtime-default))
+ (running-deadtime-default (+ server-start-allowance (* 2 launch-monitor-period)))
+ (running-deadtime (or deadtime-trim running-deadtime-default))) ;; two minutes (30 seconds between updates, this leaves 3x grace period)
+
+ (debug:print-info 4 *default-log-port* "running-deadtime = " running-deadtime)
+ (debug:print-info 4 *default-log-port* "deadtime-trim = " deadtime-trim)
+
+ (let* ((dat (rmt:get-toplevels-and-incompletes run-id running-deadtime remotehoststart-deadtime)))
+ (set! oldlaunched (list-ref dat 1))
+ (set! toplevels (list-ref dat 2))
+ (set! incompleted (list-ref dat 0)))
+
+ (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, "
+ (length toplevels) " old LAUNCHED toplevel tests and "
+ (length incompleted) " tests marked RUNNING but apparently dead.")
+
+ ;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE.
+ ;;
+ ;; (db:delay-if-busy dbdat)
+ (let* ((min-incompleted-ids (map car incompleted)) ;; do 'em all
+ (all-ids (append min-incompleted-ids (map car oldlaunched))))
+ (if (> (length all-ids) 0)
+ (begin
+ ;; (launch:is-test-alive "localhost" 435)
+ (debug:print 0 *default-log-port* "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ")
+ " as DEAD")
+ (for-each
+ (lambda (test-id)
+ (let* ((tinfo (rmt:get-test-info-by-id run-id test-id))
+ (run-dir (db:test-get-rundir tinfo))
+ (host (db:test-get-host tinfo))
+ (pid (db:test-get-process_id tinfo))
+ (result (rmt:get-status-from-final-status-file run-dir)))
+ (if (and (list? result) (> (length result) 1) (equal? "PASS" (cadr result)) (equal? "COMPLETED" (car result)))
+ (begin
+ (debug:print 0 *default-log-port* "INFO: test " test-id " actually passed, so marking PASS not DEAD")
+ (rmt:set-state-status-and-roll-up-items
+ run-id test-id 'foo "COMPLETED" "PASS"
+ "Test stopped responding but it has PASSED; marking it PASS in the DB."))
+ (let ((is-alive (and (not (eq? pid 0)) ;; 0 is default in re-used field "attemptnum" where pid stored.
+ (commonmod:is-test-alive host pid))))
+ (if is-alive
+ (debug:print 0 *default-log-port* "INFO: test " test-id " on host " host
+ " has a process on pid " pid ", NOT setting to DEAD.")
+ (begin
+ (debug:print 0 *default-log-port* "INFO: test " test-id
+ " final state/status is not COMPLETED/PASS. It is " result)
+ (rmt:set-state-status-and-roll-up-items
+ run-id test-id 'foo "COMPLETED" "DEAD"
+ "Test stopped responding while in RUNNING or REMOTEHOSTSTART; presumed dead.")))))))
+ ;; call end of eud of run detection for posthook - from merge, is it needed?
+ ;; (launch:end-of-run-check run-id)
+ all-ids)
+ )))))
+
+
)
Index: server.scm
==================================================================
--- server.scm
+++ server.scm
@@ -16,11 +16,11 @@
;; along with Megatest. If not, see .
;;
(declare (unit server))
-(declare (uses common))
+;; (declare (uses common))
(declare (uses debugprint))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses rmtmod))
(declare (uses launch))
@@ -34,11 +34,11 @@
(import commonmod
configfmod
debugprint
(prefix mtargs args:))
-(include "common_records.scm")
+;; (include "common_records.scm")
;; (include "db_records.scm")
(define (db:kill-servers)
(let* ((tl (launch:setup)) ;; need this to initialize *toppath*
(servdir (conc *toppath* "/.servinfo"))
Index: servermod.scm
==================================================================
--- servermod.scm
+++ servermod.scm
@@ -23,11 +23,16 @@
(declare (uses mtmod))
(declare (uses debugprint))
(declare (uses mtargs))
(module servermod
- *
+ (
+ remote-hh-dat
+ server:mk-signature
+ common:wait-for-normalized-load
+
+ )
(import scheme
chicken)
(use (srfi 18) extras s11n)
@@ -46,11 +51,11 @@
debugprint
(prefix mtargs args:)
mtmod
)
-(include "common_records.scm")
+;; (include "common_records.scm")
;; (include "db_records.scm")
(define (server:make-server-url hostport)
(if (not hostport)
#f
Index: subrun.scm
==================================================================
--- subrun.scm
+++ subrun.scm
@@ -24,11 +24,11 @@
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses tasksmod))
(declare (uses mt))
-(declare (uses common))
+;; (declare (uses common))
(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18)
posix-extras directory-utils pathname-expand typed-records format
call-with-environment-variables)
Index: subrunmod.scm
==================================================================
--- subrunmod.scm
+++ subrunmod.scm
@@ -40,11 +40,20 @@
(declare (uses tasksmod))
(use srfi-69)
(module subrunmod
- *
+ (
+ subrun:set-state-status
+ subrun:kill-subrun
+ subrun:get-log-path
+ subrun:remove-subrun
+ subrun:subrun-removed?
+ subrun:subrun-test-initialized?
+ subrun:launch-cmd
+ subrun:initialize-toprun-test
+ )
(import scheme)
(cond-expand
(chicken-4
Index: tasksmod.scm
==================================================================
--- tasksmod.scm
+++ tasksmod.scm
@@ -39,11 +39,23 @@
(declare (uses megatestmod))
(use srfi-69)
(module tasksmod
- *
+ (
+ configf:write-alist
+ common:simple-unlock
+ common:simple-lock
+ tests:test-set-status!
+ common:get-launcher
+ tasks:kill-runner
+ tests:get-testconfig
+ tests:get-waitons
+
+ tests:get-test-path-from-environment
+
+ )
(import scheme)
(cond-expand
(chicken-4
Index: tcmt.scm
==================================================================
--- tcmt.scm
+++ tcmt.scm
@@ -24,11 +24,11 @@
;;
(declare (uses mtargs))
(declare (uses rmt))
(declare (uses rmtmod))
-(declare (uses common))
+;; (declare (uses common))
;; (declare (uses megatest-version))
(declare (uses commonmod))
(use srfi-1 posix srfi-69 srfi-18 regex defstruct)
@@ -37,11 +37,11 @@
(import commonmod
rmtmod
(prefix mtargs args:))
-(include "megatest-version.scm")
+;; (include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
;; (include "db_records.scm")
(define origargs (cdr (argv)))
(define remargs (args:get-args
Index: tcp-transportmod.scm
==================================================================
--- tcp-transportmod.scm
+++ tcp-transportmod.scm
@@ -27,11 +27,22 @@
(declare (uses mtmod))
(use address-info tcp)
(module tcp-transportmod
- *
+ (
+ tt:mk-signature
+ tt-state
+ tt:server-process-run
+ tt:make-remote
+ tt-ro-mode-checked-set!
+ tt-ro-mode-set!
+ tt-ro-mode
+ tt-ro-mode-checked
+ tt:handler
+ tt:get-conn
+ )
(import scheme)
(cond-expand
(chicken-4
Index: tdb.scm
==================================================================
--- tdb.scm
+++ tdb.scm
@@ -22,11 +22,11 @@
;; Database access
;;======================================================================
(declare (unit tdb))
(declare (uses debugprint))
-(declare (uses common))
+;; (declare (uses common))
(declare (uses keys))
(declare (uses mt))
(declare (uses commonmod))
(declare (uses mtargs))
(declare (uses rmtmod))
@@ -39,11 +39,11 @@
(import commonmod
debugprint
rmtmod
(prefix mtargs args:))
-(include "common_records.scm")
+;; (include "common_records.scm")
;; (include "db_records.scm")
;; (include "key_records.scm")
(include "run_records.scm")
;;======================================================================
Index: test_records.scm
==================================================================
--- test_records.scm
+++ test_records.scm
@@ -13,24 +13,5 @@
;; 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 .
-;; make-vector-record tests testqueue testname testconfig waitons priority items
-(define (make-tests:testqueue)(make-vector 7 #f))
-(define (tests:testqueue-get-testname vec) (vector-ref vec 0))
-(define (tests:testqueue-get-testconfig vec) (vector-ref vec 1))
-(define (tests:testqueue-get-waitons vec) (vector-ref vec 2))
-(define (tests:testqueue-get-priority vec) (vector-ref vec 3))
-;; items: #f=no items, list=list of items remaining, proc=need to call to get items
-(define (tests:testqueue-get-items vec) (vector-ref vec 4))
-(define (tests:testqueue-get-itemdat vec) (vector-ref vec 5))
-(define (tests:testqueue-get-item_path vec) (vector-ref vec 6))
-
-(define (tests:testqueue-set-testname! vec val)(vector-set! vec 0 val))
-(define (tests:testqueue-set-testconfig! vec val)(vector-set! vec 1 val))
-(define (tests:testqueue-set-waitons! vec val)(vector-set! vec 2 val))
-(define (tests:testqueue-set-priority! vec val)(vector-set! vec 3 val))
-(define (tests:testqueue-set-items! vec val)(vector-set! vec 4 val))
-(define (tests:testqueue-set-itemdat! vec val)(vector-set! vec 5 val))
-(define (tests:testqueue-set-item_path! vec val)(vector-set! vec 6 val))
-
Index: testsmod.scm
==================================================================
--- testsmod.scm
+++ testsmod.scm
@@ -39,11 +39,20 @@
(declare (uses fsmod))
(use srfi-69)
(module testsmod
- *
+ (
+ tests:summarize-items
+ tests:filter-non-runnable
+ tests:sort-by-priority-and-waiton
+
+ tests:summarize-test
+ tests:save-final-status
+ tests:update-central-meta-info
+ tests:set-full-meta-info
+ )
(import scheme)
(cond-expand
(chicken-4
@@ -125,11 +134,11 @@
mtmod
servermod
fsmod
)
-(include "common_records.scm")
+;; (include "common_records.scm")
;; (include "key_records.scm")
;; (include "db_records.scm")
(include "run_records.scm")
;; (include "test_records.scm")
(include "js-path.scm")
Index: tree.scm
==================================================================
--- tree.scm
+++ tree.scm
@@ -35,12 +35,12 @@
(import (prefix sqlite3 sqlite3:))
(import (prefix mtargs args:)
debugprint)
-(include "megatest-version.scm")
-(include "common_records.scm")
+;; (include "megatest-version.scm")
+;; (include "common_records.scm")
;; (include "db_records.scm")
;; (include "key_records.scm")
;;======================================================================
;; T R E E S T U F F
ADDED utils/extract-export-list.sh
Index: utils/extract-export-list.sh
==================================================================
--- /dev/null
+++ utils/extract-export-list.sh
@@ -0,0 +1,13 @@
+#!/bin/bash
+
+LAST_PARENT=foobar
+
+for fn in $(grep 'Warning: refer' typescript |tr '`' ' '|tr "'" " "|awk '{print $7}');do
+ PARENT=$(grep $fn *mod.scm|grep define|cut -d: -f1)
+ if [[ $PARENT != $LAST_PARENT ]];then
+ echo
+ echo $PARENT
+ LAST_PARENT=$PARENT
+ fi
+ echo $fn
+done