"))
- running-color)
-
- ((member (conc status) '("0" 0))
- white)
- (else test-status-color)))
- ; (else failcolor)))
- (mtrx-rc (conc rownum ":" colnum)))
- ;;(print "BB> status=>"status"< bgcolor="bgcolor)
- (iup:attribute-set! steps-matrix mtrx-rc (if val (conc val) ""))
- (if (< colnum 5)
- (iup:attribute-set! steps-matrix (conc "BGCOLOR" mtrx-rc) bgcolor))
- (if (< colnum max-col)
- (loop hed tal rownum (+ colnum 1))
- (if (not (null? tal))
- (loop (car tal) (cdr tal) (+ rownum 1) 1))))))
- (if (> max-row 0)
- (begin
- ;; we are going to speculatively clear rows until we find a row that is already cleared
- (let loop ((rownum (+ max-row 1))
- (colnum 0)
- (deleted #f))
- ;; (debug:print-info 0 *default-log-port* "cleaning " rownum ":" colnum)
- (let* ((next-row (if (eq? colnum max-col) (+ rownum 1) rownum))
- (next-col (if (eq? colnum max-col) 1 (+ colnum 1)))
- (mtrx-rc (conc rownum ":" colnum))
- (curr-val (iup:attribute steps-matrix mtrx-rc)))
- ;; (debug:print-info 0 *default-log-port* "cleaning " rownum ":" colnum " currval= " curr-val)
- (if (and (string? curr-val)
- (not (equal? curr-val "")))
- (begin
- (iup:attribute-set! steps-matrix mtrx-rc "")
- (loop next-row next-col #t))
- (if (eq? colnum max-col) ;; not done, didn't get a full blank row
- (if deleted (loop next-row next-col #f)) ;; exit on this not met
- (loop next-row next-col deleted)))))
- (iup:attribute-set! steps-matrix "REDRAW" "ALL")))))
-
-;;======================================================================
-;; U T I L I T I E S
-;;======================================================================
-
-(define (dcommon:run-html-viewer lfilename)
- (let ((htmlviewercmd (configf:lookup *configdat* "setup" "htmlviewercmd")))
- (if htmlviewercmd
- (system (conc "(" htmlviewercmd " " lfilename " ) &"))
- (iup:send-url lfilename))))
-
-(define (dashboard:monitor-changed? commondat tabdat)
- (let* ((run-update-time (current-seconds))
- (monitor-db-path (dboard:tabdat-monitor-db-path tabdat))
- (monitor-modtime (if (and monitor-db-path (common:file-exists? monitor-db-path))
- (file-modification-time monitor-db-path)
- -1)))
- (if (and (eq? (dboard:commondat-curr-tab-num commondat) 0)
- (or (> monitor-modtime *last-monitor-update-time*)
- (> (- run-update-time *last-monitor-update-time*) 5))) ;; update every 1/2 minute just in case
- (begin
- (set! *last-monitor-update-time* run-update-time) ;; monitor-modtime)
- #t)
- #f)))
-
-;; DOES NOT WORK RELIABLY WITH /tmp WAL mode files. Timestamps only change when the db
-;; is closed (I think). If db dir starts with /tmp always return true
-;;
-(define (dashboard:database-changed? commondat tabdat #!key (context-key 'default))
- (let* ((run-update-time (current-seconds))
- (dbdir (dboard:tabdat-dbdir tabdat))
- (modtime (dashboard:get-youngest-run-db-mod-time dbdir))
- (recalc (dashboard:recalc modtime
- (dboard:commondat-please-update commondat)
- (dboard:get-last-db-update tabdat context-key))))
- ;; (dboard:tabdat-last-db-update tabdat))))
- (if recalc
- (dboard:set-last-db-update! tabdat context-key run-update-time))
- (dboard:commondat-please-update-set! commondat #f)
- recalc))
-
-(define (dashboard:get-youngest-run-db-mod-time dbdir)
- (handle-exceptions
- exn
- (begin
- (debug:print 2 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn)
- " db-dir="dbdir ", exn=" exn)
- (current-seconds)) ;; something went wrong - just print an error and return current-seconds
- (common:max (map (lambda (filen)
- (file-modification-time filen))
- (glob (conc dbdir "/*.db*"))))))
-
-(define (dboard:get-last-db-update tabdat context)
- (hash-table-ref/default (dboard:tabdat-last-db-update tabdat) context 0))
-
-(define (dboard:set-last-db-update! tabdat context newtime)
- (hash-table-set! (dboard:tabdat-last-db-update tabdat) context newtime))
-
-;; point inside line
-;;
-(define-inline (dashboard:px-between px lx1 lx2)
- (and (< lx1 px)(> lx2 px)))
-
-(define (dashboard:recalc modtime please-update-buttons last-db-update-time)
- (or please-update-buttons
- (and ;; (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) ;; can't use this - it needs to be tab specific
- (> modtime (- last-db-update-time 3)) ;; add three seconds of margin
- (> (current-seconds)(+ last-db-update-time 1)))))
-
DELETED diff-report.scm
Index: diff-report.scm
==================================================================
--- diff-report.scm
+++ /dev/null
@@ -1,425 +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 .
-;;
-
-(declare (unit diff-report))
-(declare (uses common))
-(declare (uses rmt))
-
-(include "common_records.scm")
-(use matchable)
-(use fmt)
-(use ducttape-lib)
-(define css "")
-
-(define (diff:tests-mindat->hash tests-mindat)
- (let* ((res (make-hash-table)))
- (for-each
- (lambda (item)
- (let* ((test-name+item-path (cons (list-ref item 0) (list-ref item 1)))
- (value (list-ref item 2)))
- (hash-table-set! res test-name+item-path value)))
- tests-mindat)
- res))
-
-;; return 1 if status1 is better
-;; return 0 if status1 and 2 are equally good
-;; return -1 if status2 is better
-(define (diff:status-compare3 status1 status2)
- (let*
- ((status-goodness-ranking (list "PASS" "WARN" "WAIVED" "SKIP" "FAIL" "ABORT" #f))
- (mem1 (member status1 status-goodness-ranking))
- (mem2 (member status2 status-goodness-ranking))
- )
- (cond
- ((and (not mem1) (not mem2)) 0)
- ((not mem1) -1)
- ((not mem2) 1)
- ((= (length mem1) (length mem2)) 0)
- ((> (length mem1) (length mem2)) 1)
- (else -1))))
-
-
-(define (diff:xor-tests-mindat src-tests-mindat dest-tests-mindat #!key (hide-clean #f) (consistent-fail-not-clean #f))
- (let* ((src-hash (diff:tests-mindat->hash src-tests-mindat))
- (dest-hash (diff:tests-mindat->hash dest-tests-mindat))
- (all-keys
- (reverse (sort
- (delete-duplicates
- (append (hash-table-keys src-hash) (hash-table-keys dest-hash)))
-
- (lambda (a b)
- (cond
- ((< 0 (string-compare3 (car a) (car b))) #t)
- ((> 0 (string-compare3 (car a) (car b))) #f)
- ((< 0 (string-compare3 (cdr a) (cdr b))) #t)
- (else #f)))
-
- ))))
- (let ((res
- (map ;; TODO: rename xor to delta globally in dcommon and dashboard
- (lambda (key)
- (let* ((test-name (car key))
- (item-path (cdr key))
-
- (dest-value (hash-table-ref/default dest-hash key (list 0 "NULL" "NULL"))) ;; (list test-id state status)
- (dest-test-id (list-ref dest-value 0))
- (dest-state (list-ref dest-value 1))
- (dest-status (list-ref dest-value 2))
-
- (src-value (hash-table-ref/default src-hash key (list 0 "NULL" "NULL"))) ;; (list test-id state status)
- (src-test-id (list-ref src-value 0))
- (src-state (list-ref src-value 1))
- (src-status (list-ref src-value 2))
-
- (incomplete-statuses '("DELETED" "INCOMPLETE" "STUCK/DEAD" "N/A")) ;; if any of these statuses apply, treat test as incomplete
-
- (dest-complete
- (and dest-value dest-state dest-status
- (equal? dest-state "COMPLETED")
- (not (member dest-status incomplete-statuses))))
- (src-complete
- (and src-value src-state src-status
- (equal? src-state "COMPLETED")
- (not (member src-status incomplete-statuses))))
- (status-compare-result (diff:status-compare3 src-status dest-status))
- (xor-new-item
- (cond
- ;; complete, for this case means: state=compelte AND status not in ( deleted uncomplete stuck/dead n/a )
- ;; neither complete -> bad
-
- ;; src !complete, dest complete -> better
- ((and (not dest-complete) (not src-complete))
- (list dest-test-id "BOTH-BAD" "BOTH-INCOMPLETE") src-value dest-value)
- ((not dest-complete)
- (list src-test-id "NOT-IN-DEST" "DEST-INCOMPLETE") src-value dest-value)
- ((not src-complete)
- (list dest-test-id "NOT-IN-SRC" "SRC-INCOMPLETE") src-value dest-value)
- ((and
- (equal? src-state dest-state)
- (equal? src-status dest-status))
- (if (and consistent-fail-not-clean (not (member dest-status '("PASS" "SKIP" "WAIVED" "WARN"))))
- (list dest-test-id (conc "BOTH-BAD") (conc "CLEAN-" dest-status) src-value dest-value)
- (list dest-test-id (conc "CLEAN") (conc "CLEAN-" dest-status) src-value dest-value)))
- ;; better or worse: pass > warn > waived > skip > fail > abort
- ;; pass > warn > waived > skip > fail > abort
-
- ((= 1 status-compare-result) ;; src is better, dest is worse
- (list dest-test-id "WORSE" (conc src-status "->" dest-status) src-value dest-value))
- (else
- (list dest-test-id "BETTER" (conc src-status "->" dest-status) src-value dest-value)))))
- (list test-name item-path xor-new-item)))
- all-keys)))
-
- (if hide-clean
- (filter
- (lambda (item)
- (not
- (equal?
- "CLEAN"
- (list-ref (list-ref item 2) 1))))
- res)
- res))))
-
-(define (diff:run-name->run-id run-name)
- (if (number? run-name)
- run-name
- (let* ((qry-res (rmt:get-runs run-name 1 0 '())))
- (if (eq? 2 (vector-length qry-res))
- (vector-ref (car (vector-ref qry-res 1)) 1)
- #f))))
-
-(define (diff:target+run-name->run-id target run-name)
- (let* ((keys (rmt:get-keys))
- (target-parts (if target (string-split target "/") (map (lambda (x) "%") keys))))
- (if (not (eq? (length keys) (length keys)))
- (begin
- (print "Error: Target ("target") item count does not match fields count target tokens="target-parts" fields="keys)
- #f)
- (let* ((target-map (zip keys target-parts))
- (qry-res (rmt:get-runs run-name 1 0 target-map)))
-
- (if (eq? 2 (vector-length qry-res))
- (let ((first-ent (vector-ref qry-res 1)))
- (if (> (length first-ent) 0)
- (vector-ref (car first-ent) 1)
- #f))
- #f)))))
-
-(define (diff:run-id->tests-mindat run-id #!key (testpatt "%/%"))
- (let* ((states '())
- (statuses '())
- (offset #f)
- (limit #f)
- (not-in #t)
- (sort-by #f)
- (sort-order #f)
- (qryvals "id,testname,item_path,state,status")
- (qryvals "id,testname,item_path,state,status")
- (last-update 0)
- (mode #f)
- )
- (map
- ;; (lambda (row)
- ;; (match row
- ;; ((#(id test-name item-path state status)
- ;; (list test-name item-path (list id state status))))
- ;; (else #f)))
- (lambda (row)
- (let* ((id (vector-ref row 0))
- (test-name (vector-ref row 1))
- (item-path (vector-ref row 2))
- (state (vector-ref row 3))
- (status (vector-ref row 4)))
- (list test-name item-path (list id state status))))
-
- (rmt:get-tests-for-run run-id
- testpatt states statuses
- offset limit
- not-in sort-by sort-order
- qryvals
- last-update
- mode))))
-
-
-(define (diff:diff-runs src-run-id dest-run-id)
- (let* ((src-tests-mindat (diff:run-id->tests-mindat src-run-id))
- (dest-tests-mindat (diff:run-id->tests-mindat dest-run-id)))
- (diff:xor-tests-mindat src-tests-mindat dest-tests-mindat consistent-fail-not-clean: #t)))
-
-
-(define (diff:rundiff-find-by-state run-diff state)
- (filter
- (lambda (x)
- (equal? (list-ref (caddr x) 1) state))
- run-diff))
-
-(define (diff:rundiff-clean-breakdown run-diff)
- (map
- (lambda (run-diff-item)
- (match run-diff-item
- ((test-name item-path (junk-id diff-state diff-status (src-test-id src-state src-status) (dest-test-id dest-state dest-status)))
- (list test-name item-path "CLEAN" src-status))
- (else "")))
- (diff:rundiff-find-by-state run-diff "CLEAN")))
-
-(define (diff:summarize-run-diff run-diff)
-
- (let* ((diff-states (list "CLEAN" "BETTER" "WORSE" "BOTH-BAD" "NOT-IN-DEST" "NOT-IN-SRC" )))
- (map
- (lambda (state)
- (list state
- (length (diff:rundiff-find-by-state run-diff state))))
- diff-states)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Presentation code below, business logic above ;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (diff:stml->string in-stml)
- (with-output-to-string
- (lambda ()
- (s:output-new
- (current-output-port)
- in-stml))))
-
-(define (diff:state-status->bgcolor state status)
- (match (list state status)
- (("CLEAN" _) "#88ff88")
- (("BETTER" _) "#33ff33")
- (("WORSE" _) "#ff3333")
- (("BOTH-BAD" _) "#ff3333")
- ((_ "WARN") "#ffff88")
- ((_ "FAIL") "#ff8888")
- ((_ "ABORT") "#ff0000")
- ((_ "PASS") "#88ff88")
- ((_ "SKIP") "#ffff00")
- (else "#ffffff")))
-
-(define (diff:test-state-status->diff-report-cell state status)
- (s:td 'bgcolor (diff:state-status->bgcolor state status) status))
-
-(define (diff:diff-state-status->diff-report-cell state status)
- (s:td state 'bgcolor (diff:state-status->bgcolor state status)))
-
-
-(define (diff:megatest-html-logo)
-
- "
-___ ___ _ _
-| \\/ | ___ __ _ __ _| |_ ___ ___| |_
-| |\\/| |/ _ \\/ _` |/ _` | __/ _ \\/ __| __|
-| | | | __/ (_| | (_| | || __/\\__ \\ |_
-|_| |_|\\___|\\__, |\\__,_|\\__\\___||___/\\__|
- |___/
-
")
-
-(define (diff:megatest-html-diff-logo)
- "
-___ ___ _ _
-| \\/ | ___ __ _ __ _| |_ ___ ___| |_ | _ \\(_)/ _|/ _|
-| |\\/| |/ _ \\/ _` |/ _` | __/ _ \\/ __| __| | | | | | |_| |_
-| | | | __/ (_| | (_| | || __/\\__ \\ |_ | |_| | | _| _|
-|_| |_|\\___|\\__, |\\__,_|\\__\\___||___/\\__| |____/|_|_| |_|
- |___/
-
")
-
-
-(define (diff:run-id->target+run-name+starttime run-id)
- (let* ((target (rmt:get-target run-id))
- (runinfo (rmt:get-run-info run-id)) ; vector of header (list) and result (vector)
- (info-hash (alist->hash-table
- (map (lambda (x) (cons (car x) (cadr x))) ; make it a useful hash
- (zip (vector-ref runinfo 0) (vector->list (vector-ref runinfo 1))))))
- (run-name (hash-table-ref/default info-hash "runname" "N/A"))
- (start-time (hash-table-ref/default info-hash "event_time" 0)))
- (list target run-name start-time)))
-
-(define (diff:deliver-diff-report src-run-id dest-run-id
- #!key
- (html-output-file #f)
- (email-subject-prefix "[MEGATEST DIFF]")
- (email-recipients-list '()) )
- (let* ((src-info (diff:run-id->target+run-name+starttime src-run-id))
- (src-target (car src-info))
- (src-run-name (cadr src-info))
- (src-start (conc (seconds->string (caddr src-info)) " " (local-timezone-abbreviation)))
- (dest-info (diff:run-id->target+run-name+starttime dest-run-id))
- (dest-target (car dest-info))
- (dest-run-name (cadr dest-info))
- (dest-start (conc (seconds->string (caddr dest-info)) " " (local-timezone-abbreviation)))
-
-
- (run-diff (diff:diff-runs src-run-id dest-run-id ))
- (test-count (length run-diff))
- (summary-table
- (apply s:table 'cellspacing "0" 'border "1"
- (s:tr
- (s:th "Diff type")
- (s:th "% share")
- (s:th "Count"))
-
- (map
- (lambda (state-count)
- (s:tr
- (diff:diff-state-status->diff-report-cell (car state-count) #f)
- (s:td 'align "right" (fmt #f
- (decimal-align 3
- (fix 2
- (num/fit 6
- (* 100 (/ (cadr state-count) test-count)))))))
- (s:td 'align "right" (cadr state-count))))
- (diff:summarize-run-diff run-diff))))
- (meta-table
- (s:table 'cellspacing "0" 'border "1"
-
- (s:tr
- (s:td 'colspan "2"
- (s:table 'cellspacing "0" 'border "1"
- (s:tr
- (s:th 'align "LEFT" "") (s:th "SOURCE RUN") (s:th "DESTINATION RUN"))
- (s:tr
- (s:th 'align "LEFT" "Started") (s:td src-start) (s:td dest-start))
- (s:tr
- (s:th 'align "LEFT" "TARGET") (s:td src-target) (s:td dest-target))
- (s:tr
- (s:th 'align "LEFT" "RUN NAME") (s:td src-run-name) (s:td dest-run-name)))))))
-
- (main-table
- (apply s:table 'cellspacing "0" 'border "1"
- (s:tr
- (s:th "Test name")
- (s:th "Item Path")
- (s:th (conc "SOURCE"))
- (s:th (conc "DEST"))
- (s:th "Diff"))
- (map
- (lambda (run-diff-item)
- (match run-diff-item
- ((test-name item-path (junk-id diff-state diff-status (src-test-id src-state src-status) (dest-test-id dest-state dest-status)))
- (s:tr
- (s:td test-name)
- (s:td item-path)
- (diff:test-state-status->diff-report-cell src-state src-status)
- (diff:test-state-status->diff-report-cell dest-state dest-status)
- (diff:diff-state-status->diff-report-cell diff-state diff-status)))
- (else "")))
- (filter (lambda (run-diff-item)
- (match run-diff-item
- ((test-name item-path (junk-id diff-state diff-status (src-test-id src-state src-status) (dest-test-id dest-state dest-status)))
- (not (equal? diff-state "CLEAN")))
- (else #f)))
- run-diff))))
- (email-subject (conc email-subject-prefix " " src-target "/" src-run-name" vs. "dest-target"/"dest-run-name))
- (html-body (diff:stml->string (s:body
- (diff:megatest-html-diff-logo)
- (s:h2 "Summary")
- (s:table 'border "0"
- (s:tr
- (s:td "Diff calculated at")
- (s:td (conc (seconds->string) " " (local-timezone-abbreviation))))
- (s:tr
- (s:td "MT_RUN_AREA_HOME" ) (s:td *toppath*))
- (s:tr 'valign "TOP"
- (s:td summary-table)
- (s:td meta-table)))
- (s:h2 "Diffs + consistently failing tests")
- main-table)))
-
- )
- (if html-output-file
- (with-output-to-file html-output-file (lambda () (print html-body))))
- (when (and email-recipients-list (> (length email-recipients-list) 0))
- (sendmail (string-join email-recipients-list ",") email-subject html-body use_html: #t))
- html-body))
-
-
-
-
-
-;; (let* ((src-run-name "all57")
-;; (dest-run-name "all60")
-;; (src-run-id (diff:run-name->run-id src-run-name))
-;; (dest-run-id (diff:run-name->run-id dest-run-name))
-;; (to-list (list "bjbarcla")))
-;; (diff:deliver-diff-report src-run-id dest-run-id email-recipients-list: to-list html-output-file: "/tmp/bjbarcla/zippy.html")
-;; )
-
-(define (do-diff-report src-target src-runname dest-target dest-runname html-file to-list-raw)
- (let* (;;(src-target "nope%")
- ;;(src-runname "all57")
- ;;(dest-target "%")
- ;;(dest-runname "all60")
- (src-run-id (diff:target+run-name->run-id src-target src-runname))
- (dest-run-id (diff:target+run-name->run-id dest-target dest-runname))
- ;(html-file "/tmp/bjbarcla/zippy.html")
- (to-list (if (string? to-list-raw) (string-split to-list-raw ",:") #f))
- )
-
- (cond
- ((not src-run-id)
- (print "No match for source target/runname="src-target"/"src-runname)
- (print "Cannot proceed.")
- #f)
- ((not dest-run-id)
- (print "No match for source target/runname="dest-target"/"dest-runname)
- (print "Cannot proceed.")
- #f)
- (else
- (diff:deliver-diff-report src-run-id dest-run-id email-recipients-list: to-list html-output-file: html-file)))))
-
-
DELETED ducttape-lib.scm
Index: ducttape-lib.scm
==================================================================
--- ducttape-lib.scm
+++ /dev/null
@@ -1,23 +0,0 @@
-;;======================================================================
-;; Copyright 2019, 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 ducttape-lib))
-
-(include "ducttape/ducttape-lib.scm")
DELETED env.scm
Index: env.scm
==================================================================
--- env.scm
+++ /dev/null
@@ -1,252 +0,0 @@
-;;======================================================================
-;; Copyright 2006-2013, 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 env))
-
-(use sql-de-lite) ;; srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables)
-
-(define (env:open-db fname)
- (let* ((db-exists (common:file-exists? fname))
- (db (open-database fname)))
- (if (not db-exists)
- (begin
- (exec (sql db "CREATE TABLE envvars (
- id INTEGER PRIMARY KEY,
- context TEXT NOT NULL,
- var TEXT NOT NULL,
- val TEXT NOT NULL,
- CONSTRAINT envvars_constraint UNIQUE (context,var))"))))
- (set-busy-handler! db (busy-timeout 10000))
- db))
-
-;; save vars in given context, this is NOT incremental by default
-;;
-(define (env:save-env-vars db context #!key (incremental #f)(vardat #f))
- (with-transaction
- db
- (lambda ()
- ;; first clear out any vars for this context
- (if (not incremental)(exec (sql db "DELETE FROM envvars WHERE context=?") context))
- (for-each
- (lambda (varval)
- (let ((var (car varval))
- (val (cdr varval)))
- (if incremental (exec (sql db "DELETE FROM envvars WHERE context=? AND var=?") context var))
- (exec (sql db "INSERT INTO envvars (context,var,val) VALUES (?,?,?)") context var val)))
- (if vardat
- (hash-table->alist vardat)
- (get-environment-variables))))))
-
-;; merge contexts in the order given
-;; - each context is applied in the given order
-;; - variables in the paths list are split on the separator and the components
-;; merged using simple delta addition
-;; returns a hash of the merged vars
-;;
-(define (env:merge-contexts db basecontext contexts paths)
- (let ((result (make-hash-table)))
- (for-each
- (lambda (context)
- (query
- (for-each-row
- (lambda (row)
- (let ((var (car row))
- (val (cadr row)))
- (hash-table-set! result var
- (if (and (hash-table-ref/default result var #f)
- (assoc var paths)) ;; this var is a path and there is a previous path
- (let ((sep (cadr (assoc var paths))))
- (env:merge-path-envvar sep (hash-table-ref result var) val))
- val)))))
- (sql db "SELECT var,val FROM envvars WHERE context=?")
- context))
- contexts)
- result))
-
-;; get list of removed variables between two contexts
-;;
-(define (env:get-removed db contexta contextb)
- (let ((result (make-hash-table)))
- (query
- (for-each-row
- (lambda (row)
- (let ((var (car row))
- (val (cadr row)))
- (hash-table-set! result var val))))
- (sql db "SELECT var,val FROM envvars WHERE context=? AND var NOT IN (SELECT var FROM envvars WHERE context=?)")
- contexta contextb)
- result))
-
-;; get list of variables added to contextb from contexta
-;;
-(define (env:get-added db contexta contextb)
- (let ((result (make-hash-table)))
- (query
- (for-each-row
- (lambda (row)
- (let ((var (car row))
- (val (cadr row)))
- (hash-table-set! result var val))))
- (sql db "SELECT var,val FROM envvars WHERE context=? AND var NOT IN (SELECT var FROM envvars WHERE context=?)")
- contextb contexta)
- result))
-
-;; get list of variables in both contexta and contexb that have been changed
-;;
-(define (env:get-changed db contexta contextb)
- (let ((result (make-hash-table)))
- (query
- (for-each-row
- (lambda (row)
- (let ((var (car row))
- (val (cadr row)))
- (hash-table-set! result var val))))
- (sql db "SELECT var,val FROM envvars AS a WHERE context=? AND val != (SELECT val FROM envvars WHERE var=a.var AND context=?)")
- contextb contexta)
- result))
-
-;;
-(define (env:blind-merge l1 l2)
- (if (null? l1) l2
- (if (null? l2) l1
- (cons (car l1) (cons (car l2) (env:blind-merge (cdr l1) (cdr l2)))))))
-
-;; given a before and an after envvar calculate a new merged path
-;;
-(define (env:merge-path-envvar separator patha pathb)
- (let* ((patha-parts (string-split patha separator))
- (pathb-parts (string-split pathb separator))
- (common-parts (lset-intersection equal? patha-parts pathb-parts))
- (final (delete-duplicates ;; env:blind-merge
- (append pathb-parts common-parts patha-parts))))
-;; (print "BEFORE: " (string-intersperse patha-parts "\n "))
-;; (print "AFTER: " (string-intersperse pathb-parts "\n "))
-;; (print "COMMON: " (string-intersperse common-parts "\n "))
- (string-intersperse final separator)))
-
-(define (env:process-path-envvar varname separator patha pathb)
- (let ((newpath (env:merge-path-envvar separator patha pathb)))
- (setenv varname newpath)))
-
-(define (env:have-context db context)
- (> (query fetch-value (sql db "SELECT count(id) FROM envvars WHERE context=?") context)
- 0))
-
-;; this is so the calling block does not need to import sql-de-lite
-(define (env:close-database db)
- (close-database db))
-
-(define (env:lazy-hash-table->alist indat)
- (if (hash-table? indat)
- (let ((dat (hash-table->alist indat)))
- (if (null? dat)
- #f
- dat))
- #f))
-
-(define (env:inc-path path)
- (print "PATH "
- (conc "#{scheme (env:min-path \"" path "\" \"#{getenv PATH}\")}")))
-;; (conc
-;; "#{scheme (string-intersperse "
-;; "(delete-duplicates "
-;; "(append (string-split \"" path "\" \":\") "
-;; "(string-split \"#{getenv PATH}\" \":\")))"
-;; " \":\")}")))
-
-(define (env:min-path path1 path2)
- (string-intersperse
- (delete-duplicates
- (append
- (string-split path1 ":")
- (string-split path2 ":")))
- ":"))
-
-;; inc path will set a PATH that is incrementally modified when read - config mode only
-;;
-(define (env:print added removed changed #!key (inc-path #t))
- (let ((a (env:lazy-hash-table->alist added))
- (r (env:lazy-hash-table->alist removed))
- (c (env:lazy-hash-table->alist changed)))
- (case (if (args:get-arg "-dumpmode")
- (string->symbol (args:get-arg "-dumpmode"))
- 'bash)
- ((bash)
- (if a
- (begin
- (print "# Added vars")
- (map (lambda (dat)(print "export " (car dat) "=" (cdr dat)))
- (hash-table->alist added))))
- (if r
- (begin
- (print "# Removed vars")
- (map (lambda (dat)(print "unset " (car dat)))
- (hash-table->alist removed))))
- (if c
- (begin
- (print "# Changed vars")
- (map (lambda (dat)(print "export " (car dat) "=" (cdr dat)))
- (hash-table->alist changed)))))
- ((csh)
- (if a
- (begin
- (print "# Added vars")
- (map (lambda (dat)(print "setenv " (car dat) " " (cdr dat)))
- (hash-table->alist added))))
- (if r
- (begin
- (print "# Removed vars")
- (map (lambda (dat)(print "unsetenv " (car dat)))
- (hash-table->alist removed))))
- (if c
- (begin
- (print "# Changed vars")
- (map (lambda (dat)(print "setenv " (car dat) " " (cdr dat)))
- (hash-table->alist changed)))))
- ((config ini)
- (if a
- (begin
- (print "# Added vars")
- (map (lambda (dat)
- (let ((var (car dat))
- (val (cdr dat)))
- (if (and inc-path
- (equal? var "PATH"))
- (env:inc-path val)
- (print var " " val))))
- (hash-table->alist added))))
- (if r
- (begin
- (print "# Removed vars")
- (map (lambda (dat)(print "#{scheme (unsetenv \"" (car dat) "\")}"))
- (hash-table->alist removed))))
- (if c
- (begin
- (print "# Changed vars")
- (map (lambda (dat)
- (let ((var (car dat))
- (val (cdr dat)))
- (if (and inc-path
- (equal? var "PATH"))
- (env:inc-path val)
- (print var " " val))))
- (hash-table->alist changed)))))
- (else
- (debug:print-error 0 *default-log-port* "No dumpmode specified, use -dumpmode [bash|csh|config]")))))
DELETED ezsteps.scm
Index: ezsteps.scm
==================================================================
--- ezsteps.scm
+++ /dev/null
@@ -1,393 +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 .
-;;
-
-;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
-
-(use srfi-1 posix regex srfi-69 directory-utils call-with-environment-variables posix-extras
- z3 csv typed-records pathname-expand matchable)
-
-(declare (unit ezsteps))
-(declare (uses db))
-(declare (uses common))
-(declare (uses items))
-(declare (uses runconfig))
-;; (declare (uses sdb))
-;; (declare (uses filedb))
-
-(include "common_records.scm")
-(include "key_records.scm")
-(include "db_records.scm")
-(include "run_records.scm")
-
-
-;;(rmt:get-test-info-by-id run-id test-id) -> testdat
-
-;; TODO: deprecate me in favor of ezsteps.scm
-;;
-(define (launch:runstep ezstep run-id test-id exit-info m tal testconfig all-steps-dat)
- (let* ((stepname (car ezstep)) ;; do stuff to run the step
- (stepinfo (cadr ezstep))
- ;; (let ((info (cadr ezstep)))
- ;; (if (proc? info) "" info)))
- ;; (stepproc (let ((info (cadr ezstep)))
- ;; (if (proc? info) info #f)))
- (stepparts (string-match (regexp "^(\\{([^\\}\\{]*)\\}\\s*|)(.*)$") stepinfo))
- (stepparams (if (and (list? stepparts)
- (> (length stepparts) 1))
- (list-ref stepparts 2)
- #f)) ;; for future use, {VAR=1,2,3}, run step for each
- (paramparts (if (string? stepparams)
- (map (lambda (x)(string-split x "=")) (string-split-fields "[^;]*=[^;]*" stepparams))
- '()))
- (subrun (alist-ref "subrun" paramparts equal?))
- (stepcmd (if (and (list? stepparts)
- (> (length stepparts) 2))
- (list-ref stepparts 3)
- (conc "# error, no command for step "stepname)))
- (script "") ; "#!/bin/bash\n") ;; yep, we depend on bin/bash FIXME!!!\
- (logpro-file (conc stepname ".logpro"))
- (html-file (conc stepname ".html"))
- (dat-file (conc stepname ".dat"))
- (tconfig-logpro (configf:lookup testconfig "logpro" stepname))
- (logpro-used (common:file-exists? logpro-file)))
- (setenv "MT_STEP_NAME" stepname)
- (hash-table-set! all-steps-dat stepname `((params . ,paramparts)))
- (debug:print 0 *default-log-port* "stepparts: " stepparts ", stepparams: " stepparams
- ", paramparts: " paramparts ", subrun: " subrun ", stepcmd: " stepcmd)
-
- (if (and tconfig-logpro
- (not logpro-used)) ;; no logpro file found but have a defn in the testconfig
- (begin
- (with-output-to-file logpro-file
- (lambda ()
- (print ";; logpro file extracted from testconfig\n"
- ";;")
- (print tconfig-logpro)))
- (set! logpro-used #t)))
-
- ;; NB// can safely assume we are in test-area directory
- (debug:print 4 *default-log-port* "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts
- " stepparams: " stepparams " stepcmd: " stepcmd)
-
- ;; ;; first source the previous environment
- ;; (let ((prev-env (conc ".ezsteps/" prevstep (if (string-search (regexp "csh")
- ;; (get-environment-variable "SHELL")) ".csh" ".sh"))))
- ;; (if (and prevstep (common:file-exists? prev-env))
- ;; (set! script (conc script "source " prev-env))))
-
- ;; call the command using mt_ezstep
- ;; (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "x") " " stepcmd))
-
- (debug:print 4 *default-log-port* "script: " script)
- (rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f)
- ;; now launch the actual process
- (call-with-environment-variables
- (list (cons "PATH" (conc (get-environment-variable "PATH") ":.")))
- (lambda () ;; (process-run "/bin/bash" "-c" "exec ls -l /tmp/foobar > /tmp/delme-more.log 2>&1")
- (let* ((cmd (conc stepcmd " > " stepname ".log 2>&1")) ;; >outfile 2>&1
- (pid #f))
- (let ((proc (lambda ()
- (set! pid (process-run "/bin/bash" (list "-c" cmd))))))
- (if subrun
- (begin
- (debug:print-info 0 *default-log-port* "Running without MT_.* environment variables.")
- (common:without-vars proc "^MT_.*"))
- (proc)))
-
- (with-output-to-file "Makefile.ezsteps"
- (lambda ()
- (print stepname ".log :")
- (print "\t" cmd)
- (if (common:file-exists? (conc stepname ".logpro"))
- (print "\tlogpro " stepname ".logpro " stepname ".html < " stepname ".log"))
- (print)
- (print stepname " : " stepname ".log")
- (print))
- #:append)
-
- (rmt:test-set-top-process-pid run-id test-id pid)
- (let processloop ((i 0))
- (let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
- (mutex-lock! m)
- (launch:einf-pid-set! exit-info pid) ;; (vector-set! exit-info 0 pid)
- (launch:einf-exit-status-set! exit-info exit-status) ;; (vector-set! exit-info 1 exit-status)
- (launch:einf-exit-code-set! exit-info exit-code) ;; (vector-set! exit-info 2 exit-code)
- (mutex-unlock! m)
- (if (eq? pid-val 0)
- (begin
- (thread-sleep! 2)
- (processloop (+ i 1))))
- )))))
- (debug:print-info 0 *default-log-port* "step " stepname " completed with exit code " (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2))
- ;; now run logpro if needed
- (if logpro-used
- (let* ((logpro-exe (or (getenv "LOGPRO_EXE") "logpro"))
- (pid (process-run (conc "/bin/sh -c '"logpro-exe" "logpro-file " " (conc stepname ".html") " < " stepname ".log > /dev/null'"))))
- (let processloop ((i 0))
- (let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
- (mutex-lock! m)
- ;; (make-launch:einf pid: pid exit-status: exit-status exit-code: exit-code)
- (launch:einf-pid-set! exit-info pid) ;; (vector-set! exit-info 0 pid)
- (launch:einf-exit-status-set! exit-info exit-status) ;; (vector-set! exit-info 1 exit-status)
- (launch:einf-exit-code-set! exit-info exit-code) ;; (vector-set! exit-info 2 exit-code)
- (mutex-unlock! m)
- (if (eq? pid-val 0)
- (begin
- (thread-sleep! 2)
- (processloop (+ i 1)))))
- (debug:print-info 0 *default-log-port* "logpro for step " stepname " exited with code " (launch:einf-exit-code exit-info))))) ;; (vector-ref exit-info 2)))))
-
- (let ((exinfo (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2))
- (logfna (if logpro-used (conc stepname ".html") ""))
- (comment #f))
- (if logpro-used
- (let ((datfile (conc stepname ".dat")))
- ;; load the .dat file into the test_data table if it exists
- (if (common:file-exists? datfile)
- (set! comment (launch:load-logpro-dat run-id test-id stepname)))
- (rmt:test-set-log! run-id test-id (conc stepname ".html"))))
- (rmt:teststep-set-status! run-id test-id stepname "end" exinfo comment logfna))
- ;; set the test final status
- (let* ((process-exit-status (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2))
- (this-step-status (cond
- ((and (eq? process-exit-status 2) logpro-used) 'warn) ;; logpro 2 = warnings
- ((and (eq? process-exit-status 3) logpro-used) 'check) ;; logpro 3 = check
- ((and (eq? process-exit-status 4) logpro-used) 'waived) ;; logpro 4 = waived
- ((and (eq? process-exit-status 5) logpro-used) 'abort) ;; logpro 5 = abort
- ((and (eq? process-exit-status 6) logpro-used) 'skip) ;; logpro 6 = skip
- ((eq? process-exit-status 0) 'pass) ;; logpro 0 = pass
- (else 'fail)))
- (overall-status (cond
- ((eq? (launch:einf-rollup-status exit-info) 2) 'warn) ;; rollup-status (vector-ref exit-info 3)
- ((eq? (launch:einf-rollup-status exit-info) 0) 'pass) ;; (vector-ref exit-info 3)
- (else 'fail)))
- (next-status (cond
- ((eq? overall-status 'pass) this-step-status)
- ((eq? overall-status 'warn)
- (if (eq? this-step-status 'fail) 'fail 'warn))
- ((eq? overall-status 'abort) 'abort)
- (else 'fail)))
- (next-state ;; "RUNNING") ;; WHY WAS THIS CHANGED TO NOT USE (null? tal) ??
- (cond
- ((null? tal) ;; more to run?
- "COMPLETED")
- (else "RUNNING"))))
- (debug:print 4 *default-log-port* "Exit value received: " (launch:einf-exit-code exit-info) " logpro-used: " logpro-used
- " this-step-status: " this-step-status " overall-status: " overall-status
- " next-status: " next-status " rollup-status: " (launch:einf-rollup-status exit-info)) ;; (vector-ref exit-info 3))
- (case next-status
- ((warn)
- (launch:einf-rollup-status-set! exit-info 2) ;; (vector-set! exit-info 3 2) ;; rollup-status
- ;; NB// test-set-status! does rdb calls under the hood
- (tests:test-set-status! run-id test-id next-state "WARN"
- (if (eq? this-step-status 'warn) "Logpro warning found" #f)
- #f))
- ((check)
- (launch:einf-rollup-status-set! exit-info 3) ;; (vector-set! exit-info 3 3) ;; rollup-status
- ;; NB// test-set-status! does rdb calls under the hood
- (tests:test-set-status! run-id test-id next-state "CHECK"
- (if (eq? this-step-status 'check) "Logpro check found" #f)
- #f))
- ((waived)
- (launch:einf-rollup-status-set! exit-info 4) ;; (vector-set! exit-info 3 3) ;; rollup-status
- ;; NB// test-set-status! does rdb calls under the hood
- (tests:test-set-status! run-id test-id next-state "WAIVED"
- (if (eq? this-step-status 'check) "Logpro waived found" #f)
- #f))
- ((abort)
- (launch:einf-rollup-status-set! exit-info 5) ;; (vector-set! exit-info 3 4) ;; rollup-status
- ;; NB// test-set-status! does rdb calls under the hood
- (tests:test-set-status! run-id test-id next-state "ABORT"
- (if (eq? this-step-status 'abort) "Logpro abort found" #f)
- #f))
- ((skip)
- (launch:einf-rollup-status-set! exit-info 6) ;; (vector-set! exit-info 3 4) ;; rollup-status
- ;; NB// test-set-status! does rdb calls under the hood
- (tests:test-set-status! run-id test-id next-state "SKIP"
- (if (eq? this-step-status 'skip) "Logpro skip found" #f)
- #f))
- ((pass)
- (tests:test-set-status! run-id test-id next-state "PASS" #f #f))
- (else ;; 'fail
- (launch:einf-rollup-status-set! exit-info 1) ;; (vector-set! exit-info 3 1) ;; force fail, this used to be next-state but that doesn't make sense. should always be "COMPLETED"
- (tests:test-set-status! run-id test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f)
- )))
- logpro-used))
-
-(define (ezsteps:run-from testdat start-step-name run-one)
- ;;# TODO - recapture item variables, debug repeated step eval; regen logpro from test
- (let* ((do-update-test-state-status #f)
- (test-run-dir ;; (filedb:get-path *fdb*
- (db:test-get-rundir testdat)) ;; )
- (testconfig (read-config (conc test-run-dir "/testconfig") #f #t environ-patt: "pre-launch-env-vars"))
- (ezstepslst (hash-table-ref/default testconfig "ezsteps" '()))
- (run-mutex (make-mutex))
- (rollup-status 0)
- (rollup-status-string #f)
- (rollup-status-sym #f)
- (exit-info (vector #t #t #t))
- (test-id (db:test-get-id testdat))
- (run-id (db:test-get-run_id testdat))
- (test-name (db:test-get-testname testdat))
- (orig-test-state (db:test-get-state testdat))
- (orig-test-status (db:test-get-status testdat))
- (kill-job #f) ;; for future use (on re-factoring with launch.scm code
- (the-step-params '())) ;; not exactly "functional"
-
- ;; keep trying till NFS deigns to populate test run dir on this host
- (let loop ((count 5))
- (if (not (common:file-exists? test-run-dir))
- ;;(push-directory test-run-dir)
- (if (> count 0)
- (begin
- (debug:print 0 *default-log-port* "WARNING: ezsteps attempting to run but test run directory " test-run-dir " is not there. Waiting and trying again " count " more times")
- (sleep 3)
- (loop (- count 1))))))
-
- (debug:print-info 0 *default-log-port* "Running in directory " test-run-dir)
- (if (not (common:file-exists? ".ezsteps"))(create-directory ".ezsteps"))
- ;; if ezsteps was defined then we are sure to have at least one step but check anyway
-
- (if (not (> (length ezstepslst) 0))
- (message-window "ERROR: You can only re-run steps defined via ezsteps")
- (begin
- (let loop ((ezstep (car ezstepslst))
- (tal (cdr ezstepslst))
- (status-sym-so-far 'pass)
- ;;(runflag #f)
- (saw-start-step-name #f)) ;; flag used to skip steps when not starting at the beginning
- (if (or (vector-ref exit-info 1)
- (equal? (alist-ref 'keep-going prev-step-params) 'yes))
- (let* ((prev-step-params the-step-params) ;; need to snag this now
- (stepname (car ezstep)) ;; do stuff to run the step
- (logpro-used (common:file-exists? (conc test-run-dir "/" stepname ".logpro")))
- (stepinfo (cadr ezstep))
- (stepparts (string-match (regexp "^(\\{([^\\}]*)\\}\\s*|)(.*)$") stepinfo))
- (stepparms (list-ref stepparts 2)) ;; for future use, {VAR=1,2,3}, run step for each
- (stepcmd (list-ref stepparts 3))
- (script (conc "mt_ezstep '"test-run-dir"' '"stepname"' '"stepcmd"'")) ;; call the command using mt_ezstep
- (saw-start-step-name-next (or saw-start-step-name (equal? stepname start-step-name)))
- (proceed-with-this-step
- (or (not start-step-name)
- (equal? stepname start-step-name)
- (and saw-start-step-name (not run-one))
- saw-start-step-name-next
- (and start-step-name (equal? stepname start-step-name))))
- )
- (debug:print 0 *default-log-port* "NOTE: stepparms=" stepparms)
- (set! prev-step-params stepparms)
- (set! do-update-test-state-status (and proceed-with-this-step (null? tal)))
- ;;(BB> "stepname="stepname" proceed-with-this-step="proceed-with-this-step " do-update-test-state-status="do-update-test-state-status " orig-test-state="orig-test-state" orig-test-status="orig-test-status)
- (cond
- ((and (not proceed-with-this-step) (null? tal))
- 'done)
- ((not proceed-with-this-step)
- (loop (car tal)
- (cdr tal)
- status-sym-so-far
- saw-start-step-name-next))
- (else
- (debug:print 4 *default-log-port* "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts
- " stepparms: " stepparms " stepcmd: " stepcmd)
- (debug:print 4 *default-log-port* "script: " script)
- (rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f)
-
- ;; now launch the script
- (let ((pid (process-run script)))
- (let processloop ((i 0))
- (let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
- (mutex-lock! run-mutex)
- (vector-set! exit-info 0 pid)
- (vector-set! exit-info 1 exit-status)
- (vector-set! exit-info 2 exit-code)
- (mutex-unlock! run-mutex)
- (if (eq? pid-val 0)
- (begin
- (thread-sleep! 1)
- (processloop (+ i 1))))
- ))
- (let ((exinfo (vector-ref exit-info 2))
- (logfna (if logpro-used (conc stepname ".html") "")))
- (rmt:teststep-set-status! run-id test-id stepname "end" exinfo #f logfna))
-
- (if logpro-used
- (rmt:test-set-log! run-id test-id (conc stepname ".html")))
-
- ;; set the test final status
- (let* ((this-step-status (cond
- (logpro-used
- (common:logpro-exit-code->status-sym (vector-ref exit-info 2)))
- ((eq? (vector-ref exit-info 2) 0)
- 'pass)
- (else
- 'fail)))
- (overall-status-sym (common:worse-status-sym this-step-status status-sym-so-far))
- (overall-status-string (status-sym->string overall-status-sym)))
- (debug:print 4 *default-log-port* "Exit value received: " (vector-ref exit-info 2) " logpro-used: " logpro-used
- " this-step-status: " this-step-status " overall-status: " overall-status-sym)
- ;;" next-status: " next-status " rollup-status: " rollup-status)
- (set! rollup-status-string overall-status-string)
- (set! rollup-status-sym overall-status-sym)
- (tests:test-set-status! run-id test-id "RUNNING" overall-status-string #f #f)))
-
- (if (and
- (not run-one)
- (common:steps-can-proceed-given-status-sym rollup-status-sym)
- (not (null? tal)))
- (loop (car tal)
- (cdr tal)
- rollup-status-sym
- saw-start-step-name-next)))))
- (debug:print 4 *default-log-port* "WARNING: a prior step failed, stopping at " ezstep)))
-
- ;; Once done with step/steps update the test record
- ;;
- (let* ((item-path (db:test-get-item-path testdat)) ;; (item-list->path itemdat))
- (testinfo (rmt:get-testinfo-state-status run-id test-id))) ;; refresh the testdat, call it iteminfo in case need prev/curr
- ;; Am I completed?
- (if (equal? (db:test-get-state testinfo) "RUNNING") ;; (not (equal? (db:test-get-state testinfo) "COMPLETED"))
- (let ((new-state (if kill-job "KILLED" "COMPLETED") ;; (if (eq? (vector-ref exit-info 2) 0) ;; exited with "good" status
- ;; "COMPLETED"
- ;; (db:test-get-state testinfo))) ;; else preseve the state as set within the test
- )
- (new-status rollup-status-string)
- ) ;; (db:test-get-status testinfo)))
- (debug:print-info 2 *default-log-port* "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result, rollup-status is " rollup-status)
- (tests:test-set-status! run-id test-id
- (if do-update-test-state-status new-state orig-test-state)
- (if do-update-test-state-status new-status orig-test-status)
- (args:get-arg "-m") #f)
- ;; need to update the top test record if PASS or FAIL and this is a subtest
- (if (and (not (equal? item-path "")) do-update-test-state-status)
- (rmt:set-state-status-and-roll-up-items run-id test-name item-path new-state new-status #f))))
- ;; for automated creation of the rollup html file this is a good place...
- (if (not (equal? item-path ""))
- (tests:summarize-items run-id test-id test-name #f)) ;; don't force - just update if no
- )))
- ;;(pop-directory)
- rollup-status-string))
-
-(define (ezsteps:spawn-run-from testdat start-step-name run-one)
- (thread-start!
- (make-thread
- (lambda ()
- (ezsteps:run-from testdat start-step-name run-one))
- (conc "ezstep run single step " start-step-name " run-one="run-one)))
- )
-
DELETED fdb_records.scm
Index: fdb_records.scm
==================================================================
--- fdb_records.scm
+++ /dev/null
@@ -1,36 +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 .
-
-;; Single record for managing a filedb
-;; make-vector-record "Filedb record" filedb fdb db dbpath pathcache idcache partcache
-;; Filedb record
-(define (make-filedb:fdb)(make-vector 5))
-(define-inline (filedb:fdb-get-db vec) (vector-ref vec 0))
-(define-inline (filedb:fdb-get-dbpath vec) (vector-ref vec 1))
-(define-inline (filedb:fdb-get-pathcache vec) (vector-ref vec 2))
-(define-inline (filedb:fdb-get-idcache vec) (vector-ref vec 3))
-(define-inline (filedb:fdb-get-partcache vec) (vector-ref vec 4))
-(define-inline (filedb:fdb-set-db! vec val)(vector-set! vec 0 val))
-(define-inline (filedb:fdb-set-dbpath! vec val)(vector-set! vec 1 val))
-(define-inline (filedb:fdb-set-pathcache! vec val)(vector-set! vec 2 val))
-(define-inline (filedb:fdb-set-idcache! vec val)(vector-set! vec 3 val))
-(define-inline (filedb:fdb-set-partcache! vec val)(vector-set! vec 4 val))
-
-;; children records, should have use something other than "child"
-(define-inline (filedb:child-get-id vec) (vector-ref vec 0))
-(define-inline (filedb:child-get-path vec) (vector-ref vec 1))
-(define-inline (filedb:child-get-parent_id vec)(vector-ref vec 2))
DELETED filedb.scm
Index: filedb.scm
==================================================================
--- filedb.scm
+++ /dev/null
@@ -1,255 +0,0 @@
-;; Copyright 2006-2011, 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 .
-;;
-
-;; (require-extension synch sqlite3 posix srfi-13 srfi-1 utils regex)
-(use sqlite3 srfi-1 posix regex srfi-69 srfi-13 posix-extras)
-(import (prefix sqlite3 sqlite3:))
-
-(declare (unit filedb))
-
-(include "fdb_records.scm")
-;; (include "settings.scm")
-
-(define (filedb:open-db dbpath)
- (let* ((fdb (make-filedb:fdb))
- (dbexists (common:file-exists? dbpath))
- (db (sqlite3:open-database dbpath)))
- (filedb:fdb-set-db! fdb db)
- (filedb:fdb-set-dbpath! fdb dbpath)
- (filedb:fdb-set-pathcache! fdb (make-hash-table))
- (filedb:fdb-set-idcache! fdb (make-hash-table))
- (filedb:fdb-set-partcache! fdb (make-hash-table))
- (sqlite3:set-busy-handler! db (make-busy-timeout 136000))
- (if (not dbexists)
- (begin
- (sqlite3:execute db "PRAGMA synchronous = OFF;")
- (sqlite3:execute db "CREATE TABLE names (id INTEGER PRIMARY KEY,name TEST);") ;; for future use - change path in paths table to path_id
- (sqlite3:execute db "CREATE INDEX name_index ON names (name);")
- ;; NB// We store a useful subset of file attributes but do not attempt to store all
- (sqlite3:execute db "CREATE TABLE paths (id INTEGER PRIMARY KEY,
- path TEXT,
- parent_id INTEGER,
- mode INTEGER DEFAULT -1,
- uid INTEGER DEFAULT -1,
- gid INTEGER DEFAULT -1,
- size INTEGER DEFAULT -1,
- mtime INTEGER DEFAULT -1);")
- (sqlite3:execute db "CREATE INDEX path_index ON paths (path,parent_id);")
- (sqlite3:execute db "CREATE TABLE bases (id INTEGER PRIMARY KEY,base TEXT, updated TIMESTAMP);")))
- ;; close the sqlite3 db and open it as needed
- (filedb:finalize-db! fdb)
- (filedb:fdb-set-db! fdb #f)
- fdb))
-
-(define (filedb:reopen-db fdb)
- (let ((db (sqlite3:open-database (filedb:fdb-get-dbpath fdb))))
- (filedb:fdb-set-db! fdb db)
- (sqlite3:set-busy-handler! db (make-busy-timeout 136000))))
-
-(define (filedb:finalize-db! fdb)
- (sqlite3:finalize! (filedb:fdb-get-db fdb)))
-
-(define (filedb:get-current-time-string)
- (string-chomp (time->string (seconds->local-time (current-seconds)))))
-
-(define (filedb:get-base-id db path)
- (let ((stmt (sqlite3:prepare db "SELECT id FROM bases WHERE base=?;"))
- (id-num #f))
- (sqlite3:for-each-row
- (lambda (num) (set! id-num num)) stmt path)
- (sqlite3:finalize! stmt)
- id-num))
-
-(define (filedb:get-path-id db path parent)
- (let ((stmt (sqlite3:prepare db "SELECT id FROM paths WHERE path=? AND parent_id=?;"))
- (id-num #f))
- (sqlite3:for-each-row
- (lambda (num) (set! id-num num)) stmt path parent)
- (sqlite3:finalize! stmt)
- id-num))
-
-(define (filedb:add-base db path)
- (let ((existing (filedb:get-base-id db path)))
- (if existing #f
- (begin
- (sqlite3:execute db "INSERT INTO bases (base,updated) VALUES (?,?);" path (filedb:get-current-time-string))))))
-
-;; index value field notes
-;; 0 inode number st_ino
-;; 1 mode st_mode bitfield combining file permissions and file type
-;; 2 number of hard links st_nlink
-;; 3 UID of owner st_uid as with file-owner
-;; 4 GID of owner st_gid
-;; 5 size st_size as with file-size
-;; 6 access time st_atime as with file-access-time
-;; 7 change time st_ctime as with file-change-time
-;; 8 modification time st_mtime as with file-modification-time
-;; 9 parent device ID st_dev ID of device on which this file resides
-;; 10 device ID st_rdev device ID for special files (i.e. the raw major/minor number)
-;; 11 block size st_blksize
-;; 12 number of blocks allocated st_blocks
-
-(define (filedb:add-path-stat db path parent statinfo)
- (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id,mode,uid,gid,size,mtime) VALUES (?,?,?,?,?,?,?);")))
- (sqlite3:execute stmt
- path
- parent
- (vector-ref statinfo 1) ;; mode
- (vector-ref statinfo 3) ;; uid
- (vector-ref statinfo 4) ;; gid
- (vector-ref statinfo 5) ;; size
- (vector-ref statinfo 8) ;; mtime
- )
- (sqlite3:finalize! stmt))) ;; (filedb:get-current-time-string))))
-
-(define (filedb:add-path db path parent)
- (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id) VALUES (?,?);")))
- (sqlite3:execute stmt path parent)
- (sqlite3:finalize! stmt)))
-
-(define (filedb:register-path fdb path #!key (save-stat #f))
- (let* ((db (filedb:fdb-get-db fdb))
- (pathcache (filedb:fdb-get-pathcache fdb))
- (stat (if save-stat (file-stat path #t)))
- (id (hash-table-ref/default pathcache path #f)))
- (if (not db)(filedb:reopen-db fdb))
- (if id id
- (let ((plist (string-split path "/")))
- (let loop ((head (car plist))
- (tail (cdr plist))
- (parent 0))
- (let ((id (filedb:get-path-id db head parent))
- (done (null? tail)))
- (if id ;; we'll have a id if the path is already registered
- (if done
- (begin
- (hash-table-set! pathcache path id)
- id) ;; return the last path id for a result
- (loop (car tail)(cdr tail) id))
- (begin ;; add the path and then repeat the loop with the same data
- (if save-stat
- (filedb:add-path-stat db head parent stat)
- (filedb:add-path db head parent))
- (loop head tail parent)))))))))
-
-(define (filedb:update-recursively fdb path #!key (save-stat #f))
- (let ((p (open-input-pipe (string-append "find -L " path)))) ;; (resolve-pathname path)))) ;; (string-append "find " path))))
- (print "processed 0 files...")
- (let loop ((l (read-line p))
- (lc 0)) ;; line count
- (if (eof-object? l)
- (begin
- (print " " lc " files")
- (close-input-port p))
- (begin
- (filedb:register-path fdb l save-stat: save-stat) ;; (get-real-path l)) ;; don't like losing the original path info
- (if (= (modulo lc 100) 0)
- (print " " lc " files"))
- (loop (read-line p)(+ lc 1)))))))
-
-(define (filedb:update fdb path #!key (save-stat #f))
- ;; first get the realpath and add it to the bases table
- (let ((real-path path) ;; (filedb:get-real-path path))
- (db (filedb:fdb-get-db fdb)))
- (filedb:add-base db real-path)
- (filedb:update-recursively fdb path save-stat: save-stat)))
-
-;; not used and broken
-;;
-(define (filedb:get-real-path path)
- (let* ((p (open-input-pipe (string-append real-path " " (regexp-escape path))))
- (pth (read-line p)))
- (if (eof-object? pth) path
- (begin
- (close-input-port p)
- pth))))
-
-(define (filedb:drop-base fdb path)
- (print "Sorry, I don't do anything yet"))
-
-(define (filedb:find-all fdb pattern action)
- (let* ((db (filedb:fdb-get-db fdb))
- (stmt (sqlite3:prepare db "SELECT id FROM paths WHERE path like ?;"))
- (result '()))
- (sqlite3:for-each-row
- (lambda (num)
- (action num)
- (set! result (cons num result))) stmt pattern)
- (sqlite3:finalize! stmt)
- result))
-
-(define (filedb:get-path-record fdb id)
- (let* ((db (filedb:fdb-get-db fdb))
- (partcache (filedb:fdb-get-partcache fdb))
- (dat (hash-table-ref/default partcache id #f)))
- (if dat dat
- (let ((stmt (sqlite3:prepare db "SELECT path,parent_id FROM paths WHERE id=?;"))
- (result #f))
- (sqlite3:for-each-row
- (lambda (path parent_id)(set! result (list path parent_id))) stmt id)
- (hash-table-set! partcache id result)
- (sqlite3:finalize! stmt)
- result))))
-
-(define (filedb:get-children fdb parent-id)
- (let* ((db (filedb:fdb-get-db fdb))
- (res '()))
- (sqlite3:for-each-row
- (lambda (id path parent-id)
- (set! res (cons (vector id path parent-id) res)))
- db "SELECT id,path,parent_id FROM paths WHERE parent_id=?;"
- parent-id)
- res))
-
-;; retrieve all that have children and those without
-;; children that match patt
-(define (filedb:get-children-patt fdb parent-id search-patt)
- (let* ((db (filedb:fdb-get-db fdb))
- (res '()))
- ;; first get the children that have no children
- (sqlite3:for-each-row
- (lambda (id path parent-id)
- (set! res (cons (vector id path parent-id) res)))
- db "SELECT id,path,parent_id FROM paths WHERE parent_id=? AND
- (id IN (SELECT parent_id FROM paths) OR path LIKE ?);"
- parent-id search-patt)
- res))
-
-(define (filedb:get-path fdb id)
- (let* ((db (filedb:fdb-get-db fdb))
- (idcache (filedb:fdb-get-idcache fdb))
- (path (hash-table-ref/default idcache id #f)))
- (if (not db)(filedb:reopen-db fdb))
- (if path path
- (let loop ((curr-id id)
- (path ""))
- (let ((path-record (filedb:get-path-record fdb curr-id)))
- (if (not path-record) #f ;; this id has no path
- (let* ((parent-id (list-ref path-record 1))
- (pname (list-ref path-record 0))
- (newpath (string-append "/" pname path)))
- (if (= parent-id 0) ;; fields 0=path, 1=parent. root parent=0
- (begin
- (hash-table-set! idcache id newpath)
- newpath)
- (loop parent-id newpath)))))))))
-
-(define (filedb:search db pattern)
- (let ((action (lambda (id)(print (filedb:get-path db id)))))
- (filedb:find-all db pattern action)))
-
DELETED fs-transport.scm
Index: fs-transport.scm
==================================================================
--- fs-transport.scm
+++ /dev/null
@@ -1,52 +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 .
-
-(require-extension (srfi 18) extras tcp s11n)
-
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)
-(import (prefix sqlite3 sqlite3:))
-
-(use spiffy uri-common intarweb http-client spiffy-request-vars)
-
-(tcp-buffer-size 2048)
-
-(declare (unit fs-transport))
-
-(declare (uses common))
-(declare (uses db))
-(declare (uses tests))
-(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
-
-(include "common_records.scm")
-(include "db_records.scm")
-
-
-;;======================================================================
-;; F S T R A N S P O R T S E R V E R
-;;======================================================================
-
-;; There is no "server" per se but a convience routine to make it non
-;; necessary to be reopening the db over and over again.
-;;
-
-(define (fs:process-queue-item packet)
- (if (not *dbstruct-db*) ;; we will require that (setup-for-run) has already been called
- (set! *dbstruct-db* (db:setup-db)))
- (debug:print-info 11 *default-log-port* "fs:process-queue-item called with packet=" packet)
- (db:process-queue-item *dbstruct-db* packet))
-
DELETED ftail.scm
Index: ftail.scm
==================================================================
--- ftail.scm
+++ /dev/null
@@ -1,108 +0,0 @@
-;;======================================================================
-;; Copyright 2017, Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see .
-
-;;======================================================================
-
-(declare (unit ftail))
-
-(module ftail
- (
- open-tail-db
- tail-write
- tail-get-fid
- file-tail
- )
-
-(import scheme chicken data-structures extras)
-(use (prefix sqlite3 sqlite3:) posix typed-records)
-
-(define (open-tail-db )
- (let* ((basedir (create-directory (conc "/tmp/" (current-user-name))))
- (dbpath (conc basedir "/megatest_logs.db"))
- (dbexists (file-exists? dbpath))
- (db (sqlite3:open-database dbpath))
- (handler (sqlite3:make-busy-timeout 136000)))
- (sqlite3:set-busy-handler! db handler)
- (sqlite3:execute db "PRAGMA synchronous = 0;")
- (if (not dbexists)
- (begin
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_files (id INTEGER PRIMARY KEY,filename TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_data (id INTEGER PRIMARY KEY,fid INTEGER,line TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));")
- ))
- db))
-
-(define (tail-write db fid lines)
- (sqlite3:with-transaction
- db
- (lambda ()
- (for-each
- (lambda (line)
- (sqlite3:execute db "INSERT INTO log_data (fid,line) VALUES (?,?);" fid line))
- lines))))
-
-(define (tail-get-fid db fname)
- (let ((fid (handle-exceptions
- exn
- #f
- (sqlite3:first-result db "SELECT id FROM log_files WHERE filename=?;" fname))))
- (if fid
- fid
- (begin
- (sqlite3:execute db "INSERT INTO log_files (filename) VALUES (?);" fname)
- (tail-get-fid db fname)))))
-
-(define (file-tail fname #!key (db-in #f))
- (let* ((inp (open-input-file fname))
- (db (or db-in (open-tail-db)))
- (fid (tail-get-fid db fname)))
- (let loop ((inl (read-line inp))
- (lines '())
- (lastwr (current-seconds)))
- (if (eof-object? inl)
- (let ((timed-out (> (- (current-seconds) lastwr) 60)))
- (if timed-out (tail-write db fid (reverse lines)))
- (sleep 1)
- (if timed-out
- (loop (read-line inp) '() (current-seconds))
- (loop (read-line inp) lines lastwr)))
- (let* ((savelines (> (length lines) 19)))
- ;; (print inl)
- (if savelines (tail-write db fid (reverse lines)))
- (loop (read-line inp)
- (if savelines
- '()
- (cons inl lines))
- (if savelines
- (current-seconds)
- lastwr)))))))
-
-;; offset -20 means get last 20 lines
-;;
-(define (tail-get-lines db fid offset count)
- (if (> offset 0)
- (sqlite3:map-row (lambda (id line)
- (vector id line))
- db
- "SELECT id,line FROM log_data WHERE fid=? OFFSET ? LIMIT ?;" fid offset count)
- (reverse ;; get N from the end
- (sqlite3:map-row (lambda (id line)
- (vector id line))
- db
- "SELECT id,line FROM log_data WHERE fid=? ORDER BY id DESC LIMIT ?;" fid (abs offset)))))
-
-)
DELETED gen-data-for-graph.scm
Index: gen-data-for-graph.scm
==================================================================
--- gen-data-for-graph.scm
+++ /dev/null
@@ -1,72 +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 .
-;;
-(use foof-loop sql-de-lite posix)
-
-(define beginning-2016 1451636435.0)
-(define now (current-seconds))
-(define one-year-ago (- now (* 365 24 60 60)))
-
-(define db (open-database "example.db"))
-
-(exec (sql db "CREATE TABLE IF NOT EXISTS alldat (event_time,var,val)"))
-
-;; sin(time)
-(with-transaction
- db
- (lambda ()
- (loop ((for m (up-from (/ one-year-ago 60) (to (/ now 60))))) ;; days of the year
- (let ((thetime (* m 60))
- (thehour (round (/ m 60))))
- (let loop ((lastsec -1)
- (sec (random 60))
- (count 0))
- (if (> sec lastsec)
- (exec (sql db "INSERT INTO alldat (event_time,var,val) VALUES (?,?,?)")
- (+ thetime sec) ;; (* sec 60))
- "stuff"
- (if (even? thehour)
- (random 1000)
- (random 6))))
- (if (< count 20)
- (loop (max sec lastsec)(random 60)(+ count 1))))))))
-
-(close-database db)
-
-
-;; (with-transaction
-;; db
-;; (lambda ()
-;; (loop ((for d (up-from 0 (to 365)))) ;; days of the year
-;; (print "Day: " d)
-;; (loop ((for h (up-from 1 (to 24))))
-;; (loop ((for m (up-from 1 (to 60))))
-;; (let ((thetime (+ beginning-2016 (* 365 24 60 60)(* h 60 60)(* m 60))))
-;; (let loop ((lastsec -1)
-;; (sec (random 60))
-;; (count 0))
-;; (if (> sec lastsec)
-;; (exec (sql db "INSERT INTO alldat (event_time,var,val) VALUES (?,?,?)")
-;; (+ thetime sec) ;; (* sec 60))
-;; "stuff"
-;; (if (even? h)
-;; (random 100)
-;; (random 6))))
-;; (if (< count 20)
-;; (loop (max sec lastsec)(random 60)(+ count 1))))))))))
-;;
-;; (close-database db)
DELETED genexample.scm
Index: genexample.scm
==================================================================
--- genexample.scm
+++ /dev/null
@@ -1,518 +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 genexample))
-(use posix regex matchable)
-
-(include "db_records.scm")
-
-(define genexample:example-logpro
-#< 0 "Put description here" #/put pattern here/)
- ;;
- ;; You may need ignores to suppress false error or warning hits from the later expects
- ;; NOTE: Order is important here!
- (expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/)
- (expect:warning in "LogFileBody" = 0 "Any warning" #/warn/)
- (expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/)) ;; but disallow any other errors
-EOF
-)
-
-(define genexample:example-script
-#<\" to create a test.
-
-Thank you for using Megatest.
-
-You can edit your config files and create tests in the " path " directory
-
-")))
-
-
-;;======================================================================
-;; create skeleton files for a test
-;;======================================================================
-
-(define (genexample:mk-megatest-test testname)
- ;; Gather needed data
- (let ((waiton #f)
- (priority #f)
- (description #f)
- (steps '())
- (scripts '())
- (items '())
- (rel-path #f))
-
- (cond
- ((common:file-exists? "megatest.config") (set! rel-path "./"))
- ((common:file-exists? "../megatest.config") (set! rel-path "../"))
- ((common:file-exists? "../../megatest.config") (set! rel-path "../../"))
- ((common:file-exists? "../../../megatest.config")(set! rel-path "../../../"))) ;; good enough dang it.
-
- ;; Don't gather data or continue if a) megatest.config can't be found or b) testconfig already exists
- (if (not rel-path)
- (begin
- (print "ERROR: I could not find megatest.config, please run -create-test in the top dir of your megatest area")
- (exit 1)))
-
- (if (common:file-exists? (conc rel-path "tests/" testname "/testconfig"))
- (begin
- (print "WARNING: You already have a testconfig in " rel-path "tests/" testname ", do you want to clobber your files?")
- (display "Enter y/n: ")
- (if (not (equal? "y" (read-line)))
- (begin
- (print "INFO: user abort of creation of test " testname)
- (exit 1)))))
-
- (print "We are going to generate a skeleton set of files for your test " testname "\n"
- " *** Note: do not worry too much about typos, you can edit the files created when you are done.")
-
- (print "\n==================\nPlease describe this test. The description will be visible in various dialogs and reports")
- (display "Enter one line description for this test: ")
- (set! description (read-line))
-
- (print "\n\n==================\nDoes this test, " testname ", require any other test be run prior to launch?")
- (display (conc "Enter space delimited list of tests which " testname " must wait for (default is no waiton): "))
- (set! waiton (read-line))
-
- (print "\n\n==================\nDo you wish to prioritize the running of this test over other tests? If so")
- (print "enter a number greater than zero here")
- (display "Enter a priority of 0 (default) or higher: ")
- (set! priority (read-line))
-
- ;; Get the steps
- (print "\n==================\nNow to enter the one or more steps that make up your test, note; you can add more later")
- (print "Hint; use .sh extension on the script names and we'll create a placeholder script."
-
- (let ((stepname #f)
- (scriptname #f))
- (let loop ((done #f))
- (display "Enter the name for this step (blank to stop): ")
- (set! stepname (read-line))
- (if (not (equal? stepname ""))
- (begin
- (display "Enter the script or progam to run: ")
- (set! scriptname (read-line))
- (set! steps (append steps (list (list stepname scriptname))))))
- (if (not (equal? stepname ""))
- (begin
- (print "Added step " stepname " to list of steps.\n")
- (loop #f)))))
-
- ;; Get the items
- (print "\n\n==================\nNext we need to get the variables and values you wish to iterate this test over (blank for none)")
- (let ((varname #f)
- (values #f))
- (let loop ((done #f))
- (display "Enter the variable name: ")
- (set! varname (read-line))
- (if (not (equal? varname ""))
- (begin
- (display (conc "Enter the space separated list of values for " varname ": "))
- (set! values (read-line))
- (set! items (append items (list (conc varname " " values))))))
- (if (not (equal? varname ""))
- (loop #f))))
-
- ;; Now create the test
- (if (not rel-path)
- (begin
- (print "ERROR: You must run this command in a megatest area under where the megatest.config file exists.")
- (exit 1))
- (let ((testdir (conc rel-path "tests/" testname)))
- (create-directory testdir #t)
- (with-output-to-file (conc testdir "/testconfig")
- (lambda ()
- (print "# Add additional steps here. Format is \"stepname script\"\n[ezsteps]")
- (map (lambda (stp)(print (string-intersperse stp " "))) steps)
- (print "")
- (print "# Test requirements are specified here\n[requirements]")
- (print (if (string-null? waiton) "# " "") "waiton " waiton)
- (print "priority " (if (string-null? priority) 0 priority) "\n")
- (print "# Iteration for your test is controlled by the items section\n[items]")
- (map print items)
- (print "")
- (print "# Alternatively you could use a [itemstable] section")
- (print "# [itemstable]")
- (print "# ITEMVAR1 a b c")
- (print "# ITEMVAR2 d e f")
- (print "#\n# would result in items: a/d b/e c/f\n#\n")
- (print "# Logpro rules for each step can be captured here in the testconfig")
- (print "# note: The ;; after the stepname and the leading whitespace are required")
- (print "#\n[logpro]\n")
- (for-each (lambda (step)
- (let ((stepname (car step))
- (scriptname (cadr step)))
- (print stepname " ;; rules for checking output from running step " step " with command " scriptname)
- (print genexample:example-logpro "\n")))
- steps)
- (print "# test_meta is a section for storing additional data on your test\n[test_meta]")
- (print "author " (get-environment-variable "USER"))
- (print "owner " (get-environment-variable "USER"))
- (print "description " description)
- (print "tags tagone,tagtwo")
- (print "reviewed never")))
- ;; Now create shell scripts (if extension is .sh) and logpro files
- (for-each (lambda (stp)
- (let ((stepname (car stp))
- (script (cadr stp)))
- (if (string-match ".*\\.sh$" script)
- (begin
- (with-output-to-file (conc testdir "/" script)
- (lambda ()
- (print genexample:example-script)))
- (system (conc "chmod ug+r,a+x " (conc testdir "/" script)))))))
- steps))))))
-
-;; easier to work backwards than change the upstream code
-;;
-(define (hrs-min-sec->seconds str)
- (let* ((parts (string-split str))
- (res 0))
- (for-each
- (lambda (part)
- (set! res
- (+ res
- (match (string-match "(\\d+)([a-z])" part)
- ((_ val units)(* (string->number val)(case (string->symbol units)
- ((s) 1)
- ((m) 60)
- ((h) 3600))))
- (else 0)))))
- parts)
- res))
-
-;; generate a skeleton Megatest area from a current area with runs
-;;
-;; specify target, runname etc to use specific runs for the template
-;;
-(define (genexample:extract-skeleton-area dest-path)
- (let* ((target (args:get-arg "-target"))
- (runname (args:get-arg "-runname"))
- (obtuse (make-hash-table))
- (obtusef (args:get-arg "-obfuscate"))
- (letters (string-split-fields "\\S" "abcdefghijklmnopqrstuvwxyz"))
- (maxletter (- (length letters) 1))
- (lastlet 0)
- (lastnum 1)
- (obfuscate (lambda (instr)
- (or (hash-table-ref/default obtuse instr #f)
- (if obtusef
- (let* ((letter (list-ref letters lastlet))
- (val (conc letter lastnum)))
- (if (>= lastlet maxletter)
- (begin
- (set! lastlet 0)
- (set! lastnum (+ lastnum 1)))
- (set! lastlet (+ lastlet 1)))
- (hash-table-set! obtuse instr val)
- val)
- instr)))))
- (if (not (and target runname))
- (debug:print 0 *default-log-port* "WARNING: For best results please specifiy -target and -runname for a good run to use as a template."))
- (if (not (and (file-exists? "megatest.config")
- (file-exists? "megatest.db")))
- (begin
- (debug:print 0 *default-log-port* "ERROR: this command must be run at the top level of a megatest area where runs have been completed")
- (exit)))
-
- ;; first create the dest path and needed subdirectories
- (if (not (file-exists? dest-path))
- (begin
- (create-directory dest-path)
- (create-directory (conc dest-path "/tests")))
- (if (file-exists? (conc dest-path "/megatest.config"))
- (begin
- (debug:print 0 *default-log-port* "ERROR: destination path already has megatest.config, stopping now.")
- (exit))))
-
- ;; dump the config files from this area to the dest area
- (if (args:get-arg "-obfuscate")
- (debug:print 0 *default-log-port* "WARNING: obfuscation is NOT done on megatest.config and runconfigs.config. Please edit those files to remove any sensitive information!"))
- (system (conc "megatest -show-config > " dest-path "/megatest.config"))
- (system (conc "megatest -show-runconfig > " dest-path "/runconfigs.config"))
-
- ;; create stepsinfo and items refdbs, some stuff has to be done due to refdb not initing area
- ;;
- ;; sheet row col value
- ;; stepsinfo testname itempath stepname steptime
- ;; miscinfo "itemsinfo" testname itempath "x"
- ;;
- (for-each
- (lambda (rdbname)
- (if (not (file-exists? (conc dest-path "/" rdbname)))
- (begin
- (create-directory (conc dest-path "/" rdbname "/sxml") #t)
- (with-output-to-file (conc dest-path "/" rdbname "/sheet-names.cfg")
- (lambda ()(print))))))
- '("stepsinfo" "miscinfo"))
-
- (let* ((runs (rmt:simple-get-runs (or runname "%") #f #f (or target "%") #f))
- (tests (make-hash-table)) ;; just tests
- (fullt (make-hash-table)) ;; all test/items
- (testreg (make-hash-table)) ;; for the testconfigs
- (stepsrdb (conc dest-path "/stepsinfo"))
- (miscrdb (conc dest-path "/miscinfo")))
- (if (> (length runs) 1)
- (debug:print-info 0 *default-log-port* "More than one run matches, first found data will be used."))
- ;; get all testnames
- (for-each
- (lambda (run-id)
- (let* ((tests-data (rmt:get-tests-for-run run-id "%" '() '() #f #f #f #f #f #f #f #f)))
- (for-each
- (lambda (testdat)
- (let* ((test-id (db:test-get-id testdat))
- (testname (db:test-get-testname testdat))
- (item-path (db:test-get-item-path testdat))
- (tlevel (db:test-get-is-toplevel testdat))
- (tfullname (db:test-get-fullname testdat))
- ;; now get steps info
- (test-steps (tests:get-compressed-steps run-id test-id))
- (testconfig (tests:get-testconfig testname item-path testreg #f)))
-
-
- (if (not (hash-table-exists? fullt tfullname))
- ;; do the work for this test if not previously done
- (let* ((new-test-dir (conc dest-path "/tests/" (obfuscate testname)))
- (tconfigf (conc new-test-dir "/testconfig")))
- (print "Analyzing and extracting info for " tfullname " as " (obfuscate testname))
- (print " toplevel: " (if tlevel "yes" "no"))
- (hash-table-set! fullt tfullname #t) ;; track that this one has been seen
- (if (not (directory-exists? new-test-dir))
- (create-directory new-test-dir #t))
-
- ;; create the testconfig IIF we are a toplevel or an item AND the testconfig has not been previously created
- (if (and (or (not tlevel)
- (not (equal? item-path "")))
- (not (file-exists? tconfigf)))
- (with-output-to-file tconfigf
- (lambda ()
- ;; first the ezsteps
- (print "[ezsteps]")
- (for-each
- (lambda (teststep)
- (let* ((step-name (vector-ref teststep 0)))
- (print (obfuscate step-name)
- " sleep $(refdb lookup #{getenv MT_RUN_AREA_HOME}/stepsinfo "
- (obfuscate testname) " $MT_ITEMPATH "
- (obfuscate step-name) ")")))
- test-steps)
-
- ;; now the requirements section
- (if testconfig
- (begin
- (print "\n[requirements]")
- (for-each
- (lambda (entry)
- (let* ((key (car entry))
- (val (cadr entry)))
- (case (string->symbol key)
- ((waiton) (print "waiton " (obfuscate val)))
- (else (print key " " val)))))
- (configf:get-section testconfig "requirements")))
- #;(print "WARNING: No testconfig data for " testname ", " item-path))
-
- (print "\n[items]")
- (print "THE_ITEM [system refdb getrow #{getenv MT_RUN_AREA_HOME}/miscinfo itemsinfo " (obfuscate testname)" | awk '{print $1}']")
- )))
-
- ;; fill the stepsrdb
- (for-each
- (lambda (teststep)
- (let* ((step-name (vector-ref teststep 0))
- (step-duration (hrs-min-sec->seconds (vector-ref teststep 4))))
-
- (system (conc "refdb set " stepsrdb " " (obfuscate testname)
- " '" (if (equal? item-path "")
- "no-item-path"
- (obfuscate item-path))
- "' " (obfuscate step-name) " " step-duration))))
- test-steps)
-
- ;; miscinfo "itemsinfo" testname itempath "x"
- (if (not (equal? item-path ""))
- (system (conc "refdb set " miscrdb " itemsinfo " (obfuscate testname) " " (obfuscate item-path) " x")))
-
- ))))
- tests-data)))
- (map (lambda (runrec)(simple-run-id runrec)) runs)))
- ))
DELETED gentargets.sh
Index: gentargets.sh
==================================================================
--- gentargets.sh
+++ /dev/null
@@ -1,23 +0,0 @@
-#!/bin/bash
-
-# 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 .
-
-echo '[all/v1.65/tip/dev]'
-echo 'x 1'
-echo '[all/v1.64/tip/dev]'
-echo 'x 1'
DELETED get-config-settings.sh
Index: get-config-settings.sh
==================================================================
--- get-config-settings.sh
+++ /dev/null
@@ -1,19 +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 .
-
- grep configf:lookup *.scm | sed 's/^.*:lookup//; s/^-number//; s/^ //' | grep -v '^\(section\|test-conf\|tconfig\|testconfig\|dat\|config\|views-cfgdat\)' | perl -pe 's/^\s*(\*configdat\*|configdat|mtconf)//; s/^\s+//; s/\).*$//; s/"//g' | awk '{print $1,$2}' | sort | grep -v section | sort | uniq
-
DELETED gutils.scm
Index: gutils.scm
==================================================================
--- gutils.scm
+++ /dev/null
@@ -1,89 +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 .
-;;
-;;======================================================================
-
-(require-library iup)
-(import (prefix iup iup:))
-(use canvas-draw)
-
-(use srfi-1 regex regex-case srfi-69)
-(declare (unit gutils))
-
-;; NOTE: These functions will move to iuputils
-
-(define (gutils:colors-similar? color1 color2)
- (let* ((c1 (map string->number (string-split color1)))
- (c2 (map string->number (string-split color2)))
- (delta (map (lambda (a b)(abs (- a b))) c1 c2)))
- (null? (filter (lambda (x)(> x 3)) delta))))
-
-(define gutils:colors
- '((PASS . "70 249 73")
- (FAIL . "253 33 49")
- (SKIP . "230 230 0")))
-
-(define (gutils:get-color-spec effective-state)
- (or (alist-ref effective-state gutils:colors)
- (alist-ref 'FAIL gutils:colors)))
-
-;; BBnote - state status dashboard button color / text defined here
-(define (gutils:get-color-for-state-status state status);; #!key (get-label #f))
- ;; ((if get-label cadr car)
- (case (string->symbol state)
- ((COMPLETED) ;; ARCHIVED)
- (case (string->symbol status)
- ((PASS) (list "70 249 73" status))
- ((PREQ_FAIL PREQ_DISCARDED) (list "255 127 127" status))
- ((WARN WAIVED) (list "255 172 13" status))
- ((SKIP) (list (gutils:get-color-spec 'SKIP) status))
- ((ABORT) (list "198 36 166" status))
- (else (list "253 33 49" status))))
- ((ARCHIVED)
- (case (string->symbol status)
- ((PASS) (list "70 170 73" status))
- ((WARN WAIVED) (list "200 130 13" status))
- ((SKIP) (list (gutils:get-color-spec 'SKIP) status))
- (else (list "180 33 49" status))))
- ;; (if (equal? status "PASS")
- ;; '("70 249 73" "PASS")
- ;; (if (or (equal? status "WARN")
- ;; (equal? status "WAIVED"))
- ;; (list "255 172 13" status)
- ;; (list "223 33 49" status)))) ;; greenish orangeish redish
- ((LAUNCHED) (list "101 123 142" state))
- ((CHECK) (list "255 100 50" state))
- ((REMOTEHOSTSTART) (list "50 130 195" state))
- ((RUNNING STARTED) (list "9 131 232" state))
- ((KILLREQ) (list "39 82 206" state))
- ((KILLED) (list "234 101 17" state))
- ((NOT_STARTED) (case (string->symbol status)
- ((CHECK STARTED)(list (gutils:get-color-spec 'SKIP) state))
- (else (list "240 240 240" state))))
- ;; for xor mode below
- ;;
- ((CLEAN)
- (case (string->symbol status)
- ((CLEAN-FAIL CLEAN-CHECK CLEAN-ABORT) (list "200 130 13" status)) ;; orange requested for these
- (else (list "60 235 63" status))))
- ((DIRTY-BETTER) (list "160 255 153" status))
- ((DIRTY-WORSE) (list "165 42 42" status))
- ((BOTH-BAD) (list "180 33 49" status))
-
- (else (list "192 192 192" state))))
-
DELETED http-transport.scm
Index: http-transport.scm
==================================================================
--- http-transport.scm
+++ /dev/null
@@ -1,732 +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 .
-
-(require-extension (srfi 18) extras tcp s11n)
-
-
-(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest posix-extras)
-
-(use spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing)
-
-;; Configurations for server
-(tcp-buffer-size 2048)
-(max-connections 2048)
-
-(declare (unit http-transport))
-
-(declare (uses common))
-(declare (uses db))
-(declare (uses tests))
-(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
-(declare (uses server))
-;; (declare (uses daemon))
-(declare (uses portlogger))
-(declare (uses rmt))
-
-(include "common_records.scm")
-(include "db_records.scm")
-(include "js-path.scm")
-
-(require-library stml)
-(define (http-transport:make-server-url hostport)
- (if (not hostport)
- #f
- (conc "http://" (car hostport) ":" (cadr hostport))))
-
-(define *server-loop-heart-beat* (current-seconds))
-
-;;======================================================================
-;; S E R V E R
-;; ======================================================================
-
-;; Call this to start the actual server
-;;
-
-(define *db:process-queue-mutex* (make-mutex))
-
-(define (http-transport:run hostn)
- ;; Configurations for server
- (tcp-buffer-size 2048)
- (max-connections 2048)
- (debug:print 2 *default-log-port* "Attempting to start the server ...")
- (let* ((db #f) ;; (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily
- (hostname (get-host-name))
- (ipaddrstr (let ((ipstr (if (string=? "-" hostn)
- ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
- (server:get-best-guess-address hostname)
- #f)))
- (if ipstr ipstr hostn))) ;; hostname)))
- (start-port (portlogger:open-run-close portlogger:find-port))
- (link-tree-path (common:get-linktree))
- (tmp-area (common:get-db-tmp-area))
- (start-file (conc tmp-area "/.server-start")))
- (debug:print-info 0 *default-log-port* "portlogger recommended port: " start-port)
- ;; set some parameters for the server
- (root-path (if link-tree-path
- link-tree-path
- (current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP!
- (handle-directory spiffy-directory-listing)
- (handle-exception (lambda (exn chain)
- (signal (make-composite-condition
- (make-property-condition
- 'server
- 'message "server error")))))
-
- ;; http-transport:handle-directory) ;; simple-directory-handler)
- ;; Setup the web server and a /ctrl interface
- ;;
- (vhost-map `(((* any) . ,(lambda (continue)
- ;; open the db on the first call
- ;; This is were we set up the database connections
- (let* (($ (request-vars source: 'both))
- (dat ($ 'dat))
- (res #f))
- (cond
- ((equal? (uri-path (request-uri (current-request)))
- '(/ "api"))
- (send-response body: (api:process-request *dbstruct-db* $) ;; the $ is the request vars proc
- headers: '((content-type text/plain)))
- (mutex-lock! *heartbeat-mutex*)
- (set! *db-last-access* (current-seconds))
- (mutex-unlock! *heartbeat-mutex*))
- ((equal? (uri-path (request-uri (current-request)))
- '(/ ""))
- (send-response body: (http-transport:main-page)))
- ((equal? (uri-path (request-uri (current-request)))
- '(/ "json_api"))
- (send-response body: (http-transport:main-page)))
- ((equal? (uri-path (request-uri (current-request)))
- '(/ "runs"))
- (send-response body: (http-transport:main-page)))
- ((equal? (uri-path (request-uri (current-request)))
- '(/ any))
- (send-response body: "hey there!\n"
- headers: '((content-type text/plain))))
- ((equal? (uri-path (request-uri (current-request)))
- '(/ "hey"))
- (send-response body: "hey there!\n"
- headers: '((content-type text/plain))))
- ((equal? (uri-path (request-uri (current-request)))
- '(/ "jquery3.1.0.js"))
- (send-response body: (http-transport:show-jquery)
- headers: '((content-type application/javascript))))
- ((equal? (uri-path (request-uri (current-request)))
- '(/ "test_log"))
- (send-response body: (http-transport:html-test-log $)
- headers: '((content-type text/HTML))))
- ((equal? (uri-path (request-uri (current-request)))
- '(/ "dashboard"))
- (send-response body: (http-transport:html-dboard $)
- headers: '((content-type text/HTML))))
- (else (continue))))))))
- (handle-exceptions
- exn
- (debug:print 0 *default-log-port* "Failed to create file " start-file ", exn=" exn)
- (with-output-to-file start-file (lambda ()(print (current-process-id)))))
- (http-transport:try-start-server ipaddrstr start-port)))
-
-;; This is recursively run by http-transport:run until sucessful
-;;
-(define (http-transport:try-start-server ipaddrstr portnum)
- (let ((config-hostname (configf:lookup *configdat* "server" "hostname"))
- (config-use-proxy (equal? (configf:lookup *configdat* "client" "use-http_proxy") "yes")))
- (if (not config-use-proxy)
- (determine-proxy (constantly #f)))
- (debug:print-info 0 *default-log-port* "http-transport:try-start-server time=" (seconds->time-string (current-seconds)) " ipaddrsstr=" ipaddrstr " portnum=" portnum " config-hostname=" config-hostname)
- (handle-exceptions
- exn
- (begin
- (print-error-message exn)
- (if (< portnum 64000)
- (begin
- (debug:print 0 *default-log-port* "WARNING: attempt to start server failed. Trying again ...")
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (debug:print 5 *default-log-port* "exn=" (condition->list exn))
- (portlogger:open-run-close portlogger:set-failed portnum)
- (debug:print 0 *default-log-port* "WARNING: failed to start on portnum: " portnum ", trying next port")
- (thread-sleep! 0.1)
-
- ;; get_next_port goes here
- (http-transport:try-start-server ipaddrstr
- (portlogger:open-run-close portlogger:find-port)))
- (begin
- (print "ERROR: Tried and tried but could not start the server"))))
- ;; any error in following steps will result in a retry
- (set! *server-info* (list ipaddrstr portnum))
- (debug:print 0 *default-log-port* "INFO: Trying to start server on " ipaddrstr ":" portnum)
- ;; This starts the spiffy server
- ;; NEED WAY TO SET IP TO #f TO BIND ALL
- ;; (start-server bind-address: ipaddrstr port: portnum)
- (if config-hostname ;; this is a hint to bind directly
- (start-server port: portnum bind-address: (if (equal? config-hostname "-")
- ipaddrstr
- config-hostname))
- (start-server port: portnum))
- (portlogger:open-run-close portlogger:set-port portnum "released")
- (debug:print 1 *default-log-port* "INFO: server has been stopped"))))
-
-;;======================================================================
-;; S E R V E R U T I L I T I E S
-;;======================================================================
-
-;;======================================================================
-;; C L I E N T S
-;;======================================================================
-
-(define *http-mutex* (make-mutex))
-
-;; NOTE: Large block of code from 32436b426188080f72fceb6894af541fbad9921e removed here
-;; I'm pretty sure it is defunct.
-
-;; This next block all imported en-mass from the api branch
-(define *http-requests-in-progress* 0)
-(define *http-connections-next-cleanup* (current-seconds))
-
-(define (http-transport:get-time-to-cleanup)
- (let ((res #f))
- (mutex-lock! *http-mutex*)
- (set! res (> (current-seconds) *http-connections-next-cleanup*))
- (mutex-unlock! *http-mutex*)
- res))
-
-(define (http-transport:inc-requests-count)
- (mutex-lock! *http-mutex*)
- (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*))
- ;; Use this opportunity to slow things down iff there are too many requests in flight
- (if (> *http-requests-in-progress* 5)
- (begin
- (debug:print-info 0 *default-log-port* "Whoa there buddy, ease up...")
- (thread-sleep! 1)))
- (mutex-unlock! *http-mutex*))
-
-(define (http-transport:dec-requests-count proc)
- (mutex-lock! *http-mutex*)
- (proc)
- (set! *http-requests-in-progress* (- *http-requests-in-progress* 1))
- (mutex-unlock! *http-mutex*))
-
-(define (http-transport:dec-requests-count-and-close-all-connections)
- (set! *http-requests-in-progress* (- *http-requests-in-progress* 1))
- (let loop ((etime (+ (current-seconds) 5))) ;; give up in five seconds
- (if (> *http-requests-in-progress* 0)
- (if (> etime (current-seconds))
- (begin
- (thread-sleep! 0.05)
- (loop etime))
- (debug:print-error 0 *default-log-port* "requests still in progress after 5 seconds of waiting. I'm going to pass on cleaning up http connections"))
- (close-all-connections!)))
- (set! *http-connections-next-cleanup* (+ (current-seconds) 10))
- (mutex-unlock! *http-mutex*))
-
-(define (http-transport:inc-requests-and-prep-to-close-all-connections)
- (mutex-lock! *http-mutex*)
- (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*)))
-
-;; Send "cmd" with json payload "params" to serverdat and receive result
-;;
-(define (http-transport:client-api-send-receive run-id serverdat cmd params #!key (numretries 3)(area-dat #f))
- (let* ((fullurl (if (vector? serverdat)
- (http-transport:server-dat-get-api-req serverdat)
- (begin
- (debug:print 0 *default-log-port* "FATAL ERROR: http-transport:client-api-send-receive called with no server info")
- (exit 1))))
- (res (vector #f "uninitialized"))
- (success #t)
- (sparams (db:obj->string params transport: 'http))
- (runremote (or area-dat *runremote*))
- (server-id (if (vector? serverdat)
- (http-transport:server-dat-get-server-id serverdat)
- (begin
- (debug:print 0 *default-log-port* "FATAL ERROR: http-transport:client-api-send-receive called with no server info")
- (exit 1)))))
- (debug:print-info 11 *default-log-port* "cmd=" cmd " fullurl=" fullurl " server-id=" server-id " current time:" (current-seconds))
-
- ;; set up the http-client here
- (max-retry-attempts 1)
- ;; consider all requests indempotent
- (retry-request? (lambda (request)
- #f))
- ;; send the data and get the response
- ;; extract the needed info from the http data and
- ;; process and return it.
- (let* ((send-recieve (lambda ()
- (mutex-lock! *http-mutex*)
- ;; (condition-case (with-input-from-request "http://localhost"; #f read-lines)
- ;; ((exn http client-error) e (print e)))
- (set! res (vector ;;; DON'T FORGET - THIS IS THE CLIENT SIDE! NOTE: consider moving this to client.scm since we are only supporting http transport at this time.
- success
- (db:string->obj
- (handle-exceptions
- exn
- (let ((call-chain (get-call-chain))
- (msg ((condition-property-accessor 'exn 'message) exn)))
- (set! success #f)
- (if (debug:debug-mode 1)
- (debug:print-info 0 *default-log-port* "couldn't talk to server, trying again ...")
- (begin
- (debug:print 0 *default-log-port* "WARNING: failure in with-input-from-request to " fullurl ".")
- (debug:print 0 *default-log-port* " message: " msg ", exn=" exn)
- (debug:print 0 *default-log-port* " cmd: " cmd " params: " params " key:" (or server-id "thekey"))
- (debug:print 0 *default-log-port* " call-chain: " call-chain)))
- (if runremote
- (remote-conndat-set! runremote #f))
- ;; Killing associated server to allow clean retry.")
- ;; (tasks:kill-server-run-id run-id) ;; better to kill the server in the logic that called this routine?
- (mutex-unlock! *http-mutex*)
- ;;; (signal (make-composite-condition
- ;;; (make-property-condition 'commfail 'message "failed to connect to server")))
- ;;; "communications failed"
- (db:obj->string #f))
- (with-input-from-request ;; was dat
- fullurl
- (list (cons 'key (or server-id "thekey"))
- (cons 'cmd cmd)
- (cons 'params sparams))
- read-string))
- transport: 'http)
- 0)) ;; added this speculatively
- ;; Shouldn't this be a call to the managed call-all-connections stuff above?
- (close-all-connections!)
- (mutex-unlock! *http-mutex*)
- ))
- (time-out (lambda ()
- (thread-sleep! 45)
- (debug:print 0 *default-log-port* "WARNING: send-receive took more than 45 seconds!!")
- #f))
- (th1 (make-thread send-recieve "with-input-from-request"))
- (th2 (make-thread time-out "time out")))
- (thread-start! th1)
- (thread-start! th2)
- (thread-join! th1)
- (vector-set! res 0 success)
- (thread-terminate! th2)
- (if (vector? res)
- (if (vector-ref res 0) ;; this is the first flag or the second flag?
- (let* ((res-dat (vector-ref res 1)))
- (if (and (string? res-dat) (string-contains res-dat "server-id mismatch"))
- (signal (make-composite-condition
- (make-property-condition
- 'servermismatch
- 'message (vector-ref res 1))))
- res)) ;; this is the *inner* vector? seriously? why?
- (if (debug:debug-mode 11)
- (let ((call-chain (get-call-chain))) ;; note: this code also called in nmsg-transport - consider consolidating it
- (print-call-chain (current-error-port))
- (debug:print-error 11 *default-log-port* "error above occured at server, res=" res) ;; " message: " ((condition-property-accessor 'exn 'message) exn))
- (debug:print 11 *default-log-port* " server call chain:")
- (pp (vector-ref res 1) (current-error-port))
- (signal (vector-ref res 0)))
- res))
- (signal (make-composite-condition
- (make-property-condition
- 'timeout
- 'message "nmsg-transport:client-api-send-receive-raw timed out talking to server")))))))
-
-;; careful closing of connections stored in *runremote*
-;;
-(define (http-transport:close-connections #!key (area-dat #f))
- (let* ((runremote (or area-dat *runremote*))
- (server-dat (if runremote
- (remote-conndat runremote)
- #f))) ;; (hash-table-ref/default *runremote* run-id #f)))
- (if (vector? server-dat)
- (let ((api-dat (http-transport:server-dat-get-api-uri server-dat)))
- (handle-exceptions
- exn
- (begin
- (print-call-chain *default-log-port*)
- (debug:print-error 0 *default-log-port* " closing connection failed with error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn))
- (close-connection! api-dat)
- ;;(close-idle-connections!)
- #t))
- #f)))
-
-
-(define (make-http-transport:server-dat)(make-vector 6))
-(define (http-transport:server-dat-get-iface vec) (vector-ref vec 0))
-(define (http-transport:server-dat-get-port vec) (vector-ref vec 1))
-(define (http-transport:server-dat-get-api-uri vec) (vector-ref vec 2))
-(define (http-transport:server-dat-get-api-url vec) (vector-ref vec 3))
-(define (http-transport:server-dat-get-api-req vec) (vector-ref vec 4))
-(define (http-transport:server-dat-get-last-access vec) (vector-ref vec 5))
-;(define (http-transport:server-dat-get-socket vec) (vector-ref vec 6))
-(define (http-transport:server-dat-get-server-id vec) (vector-ref vec 6))
-
-(define (http-transport:server-dat-make-url vec)
- (if (and (http-transport:server-dat-get-iface vec)
- (http-transport:server-dat-get-port vec))
- (conc "http://"
- (http-transport:server-dat-get-iface vec)
- ":"
- (http-transport:server-dat-get-port vec))
- #f))
-
-(define (http-transport:server-dat-update-last-access vec)
- (if (vector? vec)
- (vector-set! vec 5 (current-seconds))
- (begin
- (print-call-chain (current-error-port))
- (debug:print-error 0 *default-log-port* "call to http-transport:server-dat-update-last-access with non-vector!!"))))
-
-;;
-;; connect
-;;
-(define (http-transport:client-connect iface port server-id)
- (let* ((api-url (conc "http://" iface ":" port "/api"))
- (api-uri (uri-reference (conc "http://" iface ":" port "/api")))
- (api-req (make-request method: 'POST uri: api-uri))
- (server-dat (vector iface port api-uri api-url api-req (current-seconds) server-id)))
- server-dat))
-
-;; run http-transport:keep-running in a parallel thread to monitor that the db is being
-;; used and to shutdown after sometime if it is not.
-;;
-(define (http-transport:keep-running)
- ;; if none running or if > 20 seconds since
- ;; server last used then start shutdown
- ;; This thread waits for the server to come alive
- (debug:print-info 0 *default-log-port* "Starting the sync-back, keep alive thread in server")
- (let* ((sdat #f)
- (tmp-area (common:get-db-tmp-area))
- (started-file (conc tmp-area "/.server-started"))
- (server-start-time (current-seconds))
- (server-info (let loop ((start-time (current-seconds))
- (changed #t)
- (last-sdat "not this"))
- (begin ;; let ((sdat #f))
- (thread-sleep! 0.01)
- (debug:print-info 0 *default-log-port* "Waiting for server alive signature")
- (mutex-lock! *heartbeat-mutex*)
- (set! sdat *server-info*)
- (mutex-unlock! *heartbeat-mutex*)
- (if (and sdat
- (not changed)
- (> (- (current-seconds) start-time) 2))
- (begin
- (debug:print-info 0 *default-log-port* "Received server alive signature")
- (common:save-pkt `((action . alive)
- (T . server)
- (pid . ,(current-process-id))
- (ipaddr . ,(car sdat))
- (port . ,(cadr sdat)))
- *configdat* #t)
- sdat)
- (begin
- (debug:print-info 0 *default-log-port* "Still waiting, last-sdat=" last-sdat)
- (sleep 4)
- (if (> (- (current-seconds) start-time) 120) ;; been waiting for two minutes
- (begin
- (debug:print-error 0 *default-log-port* "transport appears to have died, exiting server")
- (common:save-pkt `((action . died)
- (T . server)
- (pid . ,(current-process-id))
- (ipaddr . ,(car sdat))
- (port . ,(cadr sdat))
- (msg . "Transport died?"))
- *configdat* #t)
- (exit))
- (loop start-time
- (equal? sdat last-sdat)
- sdat)))))))
- (iface (car server-info))
- (port (cadr server-info))
- (last-access 0)
- (server-timeout (server:expiration-timeout))
- (server-going #f)
- (server-log-file (args:get-arg "-log"))) ;; always set when we are a server
-
- (handle-exceptions
- exn
- (debug:print 0 *default-log-port* "Failed to create " started-file ", exn=" exn)
- (with-output-to-file started-file (lambda ()(print (current-process-id)))))
-
- (let loop ((count 0)
- (server-state 'available)
- (bad-sync-count 0)
- (start-time (current-milliseconds)))
- ;; Use this opportunity to sync the tmp db to megatest.db
- (if (not server-going) ;; *dbstruct-db*
- (begin
- (debug:print 0 *default-log-port* "SERVER: dbprep")
- (set! *dbstruct-db* (db:setup #t)) ;; run-id))
- (set! server-going #t)
- (debug:print 0 *default-log-port* "SERVER: running, megatest version: " (common:get-full-version)) ;; NOTE: the server is NOT yet marked as running in the log. We do that in the keep-running routine.
- (thread-start! *watchdog*)))
-
- ;; when things go wrong we don't want to be doing the various queries too often
- ;; so we strive to run this stuff only every four seconds or so.
- (let* ((sync-time (- (current-milliseconds) start-time))
- (rem-time (quotient (- 4000 sync-time) 1000)))
- (if (and (<= rem-time 4)
- (> rem-time 0))
- (thread-sleep! rem-time)))
-
- (if (< count 1) ;; 3x3 = 9 secs aprox
- (loop (+ count 1) 'running bad-sync-count (current-milliseconds)))
-
- ;; Check that iface and port have not changed (can happen if server port collides)
- (mutex-lock! *heartbeat-mutex*)
- (set! sdat *server-info*)
- (mutex-unlock! *heartbeat-mutex*)
-
- (if (not (equal? sdat (list iface port)))
- (let ((new-iface (car sdat))
- (new-port (cadr sdat)))
- (debug:print-info 0 *default-log-port* "WARNING: interface changed, refreshing iface and port info")
- (set! iface new-iface)
- (set! port new-port)
- (if (not *server-id*)
- (set! *server-id* (server:mk-signature)))
- (debug:print 0 *default-log-port* (current-seconds) (current-directory) (current-process-id) (argv))
- (debug:print 0 *default-log-port* "SERVER STARTED: " iface ":" port " AT " (current-seconds) " server-id: " *server-id*)
- (flush-output *default-log-port*)))
-
- ;; Transfer *db-last-access* to last-access to use in checking that we are still alive
- (mutex-lock! *heartbeat-mutex*)
- (set! last-access *db-last-access*)
- (mutex-unlock! *heartbeat-mutex*)
-
- (if (common:low-noise-print 120 (conc "server running on " iface ":" port))
- (begin
- (if (not *server-id*)
- (set! *server-id* (server:mk-signature)))
- (debug:print 0 *default-log-port* (current-seconds) (current-directory) (current-process-id) (argv))
- (debug:print 0 *default-log-port* "SERVER STARTED: " iface ":" port " AT " (current-seconds) " server-id: " *server-id*)
- (flush-output *default-log-port*)))
- (if (common:low-noise-print 60 "dbstats")
- (begin
- (debug:print 0 *default-log-port* "Server stats:")
- (db:print-current-query-stats)))
- (let* ((hrs-since-start (/ (- (current-seconds) server-start-time) 3600)))
- (cond
- ((and *server-run*
- (> (+ last-access server-timeout)
- (current-seconds)))
- (if (common:low-noise-print 120 "server continuing")
- (debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access))
- (let ((curr-time (current-seconds)))
- (handle-exceptions
- exn
- (debug:print 0 *default-log-port* "ERROR: Failed to change timestamp on log file " server-log-file ". Are you out of space on that disk? exn=" exn)
- (if (not *server-overloaded*)
- (change-file-times server-log-file curr-time curr-time)))))
- (loop 0 server-state bad-sync-count (current-milliseconds)))
- (else
- (debug:print-info 0 *default-log-port* "Server timed out. seconds since last db access: " (- (current-seconds) last-access))
- (http-transport:server-shutdown port)))))))
-
-(define (http-transport:server-shutdown port)
- (begin
- ;;(BB> "http-transport:server-shutdown called")
- (debug:print-info 0 *default-log-port* "Starting to shutdown the server. pid="(current-process-id))
- ;;
- ;; start_shutdown
- ;;
- (set! *time-to-exit* #t) ;; tell on-exit to be fast as we've already cleaned up
- (portlogger:open-run-close portlogger:set-port port "released")
- (thread-sleep! 1)
-
- ;; (debug:print-info 0 *default-log-port* "Max cached queries was " *max-cache-size*)
- ;; (debug:print-info 0 *default-log-port* "Number of cached writes " *number-of-writes*)
- ;; (debug:print-info 0 *default-log-port* "Average cached write time "
- ;; (if (eq? *number-of-writes* 0)
- ;; "n/a (no writes)"
- ;; (/ *writes-total-delay*
- ;; *number-of-writes*))
- ;; " ms")
- ;; (debug:print-info 0 *default-log-port* "Number non-cached queries " *number-non-write-queries*)
- ;; (debug:print-info 0 *default-log-port* "Average non-cached time "
- ;; (if (eq? *number-non-write-queries* 0)
- ;; "n/a (no queries)"
- ;; (/ *total-non-write-delay*
- ;; *number-non-write-queries*))
- ;; " ms")
-
- (db:print-current-query-stats)
- (common:save-pkt `((action . exit)
- (T . server)
- (pid . ,(current-process-id)))
- *configdat* #t)
- (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting")
- (exit)))
-
-;; all routes though here end in exit ...
-;;
-;; start_server?
-;;
-(define (http-transport:launch)
- ;; check that a server start is in progress, pause or exit if so
- (let* ((tmp-area (common:get-db-tmp-area))
- (server-start (conc tmp-area "/.server-start"))
- (server-started (conc tmp-area "/.server-started"))
- (start-time (common:lazy-modification-time server-start))
- (started-time (common:lazy-modification-time server-started))
- (server-starting (< start-time started-time)) ;; if start-time is less than started-time then a server is still starting
- (start-time-old (> (- (current-seconds) start-time) 5))
- (cleanup-proc (lambda (msg)
- (let* ((serv-fname (conc "server-" (current-process-id) "-" (get-host-name) ".log"))
- (full-serv-fname (conc *toppath* "/logs/" serv-fname))
- (new-serv-fname (conc *toppath* "/logs/" "defunct-" serv-fname)))
- (debug:print 0 *default-log-port* msg)
- (if (common:file-exists? full-serv-fname)
- (system (conc "sleep 1;mv -f " full-serv-fname " " new-serv-fname))
- (debug:print 0 *default-log-port* "INFO: cannot move " full-serv-fname " to " new-serv-fname))
- (exit)))))
- #;(if (and (not start-time-old) ;; last server start try was less than five seconds ago
- (not server-starting))
- (begin
- (cleanup-proc "NOT starting server, there is either a recently started server or a server in process of starting")
- (exit)))
- ;; lets not even bother to start if there are already three or more server files ready to go
- #;(let* ((num-alive (server:get-num-alive (server:get-list *toppath*))))
- (if (> num-alive 3)
- (begin
- (cleanup-proc (conc "ERROR: Aborting server start because there are already " num-alive " possible servers either running or starting up"))
- (exit))))
- (common:save-pkt `((action . start)
- (T . server)
- (pid . ,(current-process-id)))
- *configdat* #t)
- (let* ((th2 (make-thread (lambda ()
- (debug:print-info 0 *default-log-port* "Server run thread started")
- (http-transport:run
- (if (args:get-arg "-server")
- (args:get-arg "-server")
- "-")
- )) "Server run"))
- (th3 (make-thread (lambda ()
- (debug:print-info 0 *default-log-port* "Server monitor thread started")
- (http-transport:keep-running)
- "Keep running"))))
- (thread-start! th2)
- (thread-sleep! 0.25) ;; give the server time to settle before starting the keep-running monitor.
- (thread-start! th3)
- (set! *didsomething* #t)
- (thread-join! th2)
- (exit))))
-
-;; (define (http-transport:server-signal-handler signum)
-;; (signal-mask! signum)
-;; (handle-exceptions
-;; exn
-;; (debug:print 0 *default-log-port* " ... exiting ...")
-;; (let ((th1 (make-thread (lambda ()
-;; (thread-sleep! 1))
-;; "eat response"))
-;; (th2 (make-thread (lambda ()
-;; (debug:print-error 0 *default-log-port* "Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.")
-;; (thread-sleep! 3) ;; give the flush three seconds to do it's stuff
-;; (debug:print 0 *default-log-port* " Done.")
-;; (exit 4))
-;; "exit on ^C timer")))
-;; (thread-start! th2)
-;; (thread-start! th1)
-;; (thread-join! th2))))
-
-;;===============================================
-;; Java script
-;;===============================================
-(define (http-transport:show-jquery)
- (let* ((data (tests:readlines *java-script-lib*)))
-(string-join data "\n")))
-
-
-
-;;======================================================================
-;; web pages
-;;======================================================================
-
-(define (http-transport:html-test-log $)
- (let* ((run-id ($ 'runid))
- (test-item ($ 'testname))
- (parts (string-split test-item ":"))
- (test-name (car parts))
-
- (item-name (if (equal? (length parts) 1)
- ""
- (cadr parts))))
- ;(print $)
-(tests:get-test-log run-id test-name item-name)))
-
-
-(define (http-transport:html-dboard $)
- (let* ((page ($ 'page))
- (oup (open-output-string))
- (bdy "--------------------------")
-
- (ret (tests:dynamic-dboard page)))
- (s:output-new oup ret)
- (close-output-port oup)
-
- (set! bdy (get-output-string oup))
- (conc "Dashboard
" bdy "
" )))
-
-(define (http-transport:main-page)
- (let ((linkpath (root-path)))
- (conc "" (pathname-strip-directory *toppath*) "
"
- ""
- "Run area: " *toppath*
- "Server Stats
"
- (http-transport:stats-table)
- "
"
- (http-transport:runs linkpath)
- "
"
- ;; (http-transport:run-stats)
- ""
- )))
-
-(define (http-transport:stats-table)
- (mutex-lock! *heartbeat-mutex*)
- (let ((res
- (conc ""
- ;; "| Max cached queries | " *max-cache-size* " |
"
- "| Number of cached writes | " *number-of-writes* " |
"
- "| Average cached write time | " (if (eq? *number-of-writes* 0)
- "n/a (no writes)"
- (/ *writes-total-delay*
- *number-of-writes*))
- " ms |
"
- "| Number non-cached queries | " *number-non-write-queries* " |
"
- ;; "| Average non-cached time | " (if (eq? *number-non-write-queries* 0)
- ;; "n/a (no queries)"
- ;; (/ *total-non-write-delay*
- ;; *number-non-write-queries*))
- " ms |
"
- "| Last access | " (seconds->time-string *db-last-access*) " |
"
- "
")))
- (mutex-unlock! *heartbeat-mutex*)
- res))
-
-(define (http-transport:runs linkpath)
- (conc "Runs
"
- (string-intersperse
- (let ((files (map pathname-strip-directory (glob (conc linkpath "/*")))))
- (map (lambda (p)
- (conc "" p "
"))
- files))
- " ")))
-
-#;(define (http-transport:run-stats)
- (let ((stats (open-run-close db:get-running-stats #f)))
- (conc ""
- (string-intersperse
- (map (lambda (stat)
- (conc "| " (car stat) " | " (cadr stat) " |
"))
- stats)
- " ")
- "
")))
DELETED index-tree.scm
Index: index-tree.scm
==================================================================
--- index-tree.scm
+++ /dev/null
@@ -1,59 +0,0 @@
-;;======================================================================
-;; Copyright 2006-2013, 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 .
-;;
-;;======================================================================
-
-;;======================================================================
-;; Tests
-;;======================================================================
-
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils)
-(import (prefix sqlite3 sqlite3:))
-
-(declare (unit tests))
-(declare (uses lock-queue))
-(declare (uses db))
-(declare (uses common))
-(declare (uses items))
-(declare (uses runconfig))
-
-(include "common_records.scm")
-(include "key_records.scm")
-(include "db_records.scm")
-(include "run_records.scm")
-(include "test_records.scm")
-
-;; Populate the links tree with index.html files
-;;
-;; - start from most recent tests and work towards oldest -OR-
-;; start from deepest hierarchy and work way up
-;; - look up tests in megatest.db
-;; - cross-reference the tests to stats.db
-;; - if newer than event_time in stats.db or not registered in stats.db regenerate
-;; - run du and store in stats.db
-;; - when all tests at that level done generate next level up index.html
-;;
-;; include in rollup html index.html:
-;; sum of du
-;; counts of PASS, FAIL, RUNNING, REMOTEHOSTSTART, LAUNCHED, CHECK etc.
-;; overall status
-;;
-;; include in test specific index.html:
-;; host, uname, cpu graph, disk avail graph, steps, data
-;; meta data, state, status, du
-;;
DELETED items.scm
Index: items.scm
==================================================================
--- items.scm
+++ /dev/null
@@ -1,212 +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 .
-
-
-;; (define itemdat '((ripeness "green ripe overripe")
-;; (temperature "cool medium hot")
-;; (season "summer winter fall spring")))
-
-(declare (unit items))
-(declare (uses common))
-
-(include "common_records.scm")
-
-;; Puts out all combinations
-(define (process-itemlist hierdepth curritemkey itemlist)
- (let ((res '()))
- (if (not hierdepth)
- (set! hierdepth (length itemlist)))
- (let loop ((hed (car itemlist))
- (tal (cdr itemlist)))
- (if (null? tal)
- (for-each (lambda (item)
- (if (> (length curritemkey) (- hierdepth 2))
- (set! res (append res (list (append curritemkey (list (list (car hed) item))))))))
- (cadr hed))
- (begin
- (for-each (lambda (item)
- (set! res (append res (process-itemlist hierdepth (append curritemkey (list (list (car hed) item))) tal))))
- (cadr hed))
- (loop (car tal)(cdr tal)))))
- res))
-
-;; (item-assoc->item-list '(("ANIMAL" "Elephant Lion")("SEASON" "Spring Fall")))
-;; => ((("ANIMAL" "Elephant") ("SEASON" "Spring"))
-;; (("ANIMAL" "Elephant") ("SEASON" "Fall"))
-;; (("ANIMAL" "Lion") ("SEASON" "Spring"))
-;; (("ANIMAL" "Lion") ("SEASON" "Fall")))
-(define (item-assoc->item-list itemsdat)
- (if (and itemsdat (not (null? itemsdat)))
- (let ((itemlst (filter (lambda (x)
- (list? x))
- (map (lambda (x)
- (debug:print 6 *default-log-port* "item-assoc->item-list x: " x)
- (if (< (length x) 2)
- (begin
- (debug:print-error 0 *default-log-port* "malformed items spec " (string-intersperse x " "))
- (list (car x)'()))
- (let* ((name (car x))
- (items (cadr x))
- (ilist (list name (if (string? items)
- (string-split items)
- '()))))
- (if (null? ilist)
- (debug:print-error 0 *default-log-port* "No items specified for " name))
- ilist)))
- itemsdat))))
- (let ((debuglevel 5))
- (debug:print 5 *default-log-port* "item-assoc->item-list: itemsdat => itemlst ")
- (if (debug:debug-mode 5)
- (begin
- (pp itemsdat)
- (print " => ")
- (pp itemlst))))
- (if (> (length itemlst) 0)
- (process-itemlist #f '() itemlst)
- '()))
- '())) ;; return a list consisting on a single null list for non-item runs
- ;; Nope, not now, return null as of 6/6/2011
-
-;; (item-table->item-list '(("ANIMAL" "Elephant Lion")("SEASON" "Spring Winter")))
-;; => ((("ANIMAL" "Elephant")("SEASON" "Spring"))
-;; (("ANIMAL" "Lion") ("SEASON" "Winter")))
-(define (item-table->item-list itemtable)
- (let ((newlst (map (lambda (x)
- (if (> (length x) 1)
- (list (car x)
- (string-split (cadr x)))
- (list x '())))
- itemtable))
- (res '())) ;; a list of items
- (let loop ((indx 0)
- (item '()) ;; an item will be ((KEYNAME1 VAL1)(KEYNAME2 VAL2) ...)
- (elflag #f))
- (for-each (lambda (row)
- (let ((rowname (car row))
- (rowdat (cadr row)))
- (set! item (append item
- (list
- (if (< indx (length rowdat))
- (let ((new (list rowname (list-ref rowdat indx))))
- ;; (debug:print 0 *default-log-port* "New: " new)
- (set! elflag #t)
- new
- ) ;; i.e. had at least on legit value to use
- (list rowname "-")))))))
- newlst)
- (if elflag
- (begin
- (set! res (append res (list item)))
- (loop (+ indx 1)
- '()
- #f)))
- res)))
- ;; Nope, not now, return null as of 6/6/2011
-
-(define (items:check-valid-items class item)
- (let ((valid-values (let ((s (configf:lookup *configdat* "validvalues" class)))
- (if s (string-split s) #f))))
- (if valid-values
- (if (member item valid-values)
- item #f)
- item)))
-
-;; '(("k1" "k2" "k3")
-;; ("a" "b" "c")
-;; ("d" "e" "f"))
-;;
-;; => '((("k1" "a")("k2" "b")("k3" "c"))
-;; (("k1" "d")("k2" "e")("k3" "f")))
-;;
-(define (items:first-row-intersperse data)
- (if (< (length data) 2)
- '()
- (let ((header (car data))
- (rows (cdr data)))
- (map (lambda (row)
- (map list header row))
- rows))))
-
-;; k1/k2/k3
-;; a/b/c
-;; d/e/f
-;; => '(("k1" "k2" "k3")
-;; ("a" "b" "c")
-;; ("d" "e" "f"))
-;;
-;; => '((("k1" "a")("k2" "b")("k3" "c"))
-;; (("k1" "d")("k2" "e")("k3" "f")))
-;;
-(define (items:read-items-file fname ftype) ;; 'sxml 'slash 'space
- (if (and fname (file-exists? fname))
- (items:first-row-intersperse (case ftype
- ((slash space)
- (let ((splitter (case ftype
- ((slash) (lambda (x)(string-split x "/")))
- (else string-split))))
- (debug:print 0 *default-log-port* "Reading " fname " of type " ftype)
- (with-input-from-file fname
- (lambda ()
- (let loop ((inl (read-line))
- (res '()))
- (if (eof-object? inl)
- res
- (loop (read-line)(cons (splitter inl) res))))))))
- ((sxml)(with-input-from-file fname read))
- (else (debug:print 0 *default-log-port* "items file type " ftype " not recognised"))))
- (begin
- (if fname (debug:print 0 *default-log-port* "no items file " fname " found"))
- '())))
-
-(define (items:get-items-from-config tconfig)
- (let* ((slashf (configf:lookup tconfig "itemopts" "slash")) ;; a/b/c\nd/e/f\n ...
- (sxmlf (configf:lookup tconfig "itemopts" "sxml")) ;; '(("a" "b" "c")("d" "e" "f") ...)
- (spacef (configf:lookup tconfig "itemopts" "space")) ;; a b c\nd e f\n ...
- (have-items (hash-table-ref/default tconfig "items" #f))
- (have-itable (hash-table-ref/default tconfig "itemstable" #f))
- (items (hash-table-ref/default tconfig "items" '()))
- (itemstable (hash-table-ref/default tconfig "itemstable" '())))
- (debug:print 5 *default-log-port* "items: " items " itemstable: " itemstable)
- (set! items (map (lambda (item)
- (if (procedure? (cadr item))
- (list (car item)((cadr item))) ;; evaluate the proc
- item))
- items))
- (set! itemstable (map (lambda (item)
- (if (procedure? (cadr item))
- (list (car item)((cadr item))) ;; evaluate the proc
- item))
- itemstable))
- (if (and have-items (null? items)) (debug:print 0 *default-log-port* "WARNING:[items] section in testconfig but no entries defined"))
- (if (and have-itable (null? itemstable))(debug:print 0 *default-log-port* "WARNNG:[itemstable] section in testconfig but no entries defined"))
- (if (or (not (null? items))
- (not (null? itemstable))
- slashf
- sxmlf
- spacef)
- (append (item-assoc->item-list items)
- (item-table->item-list itemstable)
- (items:read-items-file slashf 'slash)
- (items:read-items-file sxmlf 'sxml)
- (items:read-items-file spacef 'space))
- '(()))))
-
-;; (pp (item-assoc->item-list itemdat))
-
-
-
DELETED js-path.scm
Index: js-path.scm
==================================================================
--- js-path.scm
+++ /dev/null
@@ -1,18 +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 .
-;;
-(define *java-script-lib* (conc (common:get-install-area) "/share/js/jquery-3.1.0.slim.min.js"))
DELETED key_records.scm
Index: key_records.scm
==================================================================
--- key_records.scm
+++ /dev/null
@@ -1,32 +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 .
-
-;;======================================================================
-
-(define-inline (keys->valslots keys) ;; => ?,?,? ....
- (string-intersperse (map (lambda (x) "?") keys) ","))
-
-;; (define-inline (keys->key/field keys . additional)
-;; (string-join (map (lambda (k)(conc k " TEXT"))
-;; (append keys additional)) ","))
-
-(define-inline (item-list->path itemdat)
- (if (list? itemdat)
- (string-intersperse (map cadr itemdat) "/")
- ""))
-
DELETED keys.scm
Index: keys.scm
==================================================================
--- keys.scm
+++ /dev/null
@@ -1,85 +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 .
-;;
-
-;;======================================================================
-;; Run keys, these are used to hierarchially organise tests and run areas
-;;======================================================================
-
-(use sqlite3 srfi-1 posix regex regex-case srfi-69)
-(import (prefix sqlite3 sqlite3:))
-
-(declare (unit keys))
-(declare (uses common))
-
-(include "key_records.scm")
-(include "common_records.scm")
-
-(define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ...
- (string-intersperse keys ","))
-
-(define (args:usage . a) #f)
-
-;;======================================================================
-;; key <=> target routines
-;;======================================================================
-
-;; This invalidates using "/" in item names. Every key will be
-;; available via args:get-arg as :keyfield. Since this only needs to
-;; be called once let's use it to set the environment vars
-;;
-;; The setting of :keyfield in args should be turned off ASAP
-;;
-(define (keys:target-set-args keys target ht)
- (if target
- (let ((vals (string-split target "/")))
- (if (eq? (length vals)(length keys))
- (for-each (lambda (key val)
- (setenv key val)
- (if ht (hash-table-set! ht (conc ":" key) val)))
- keys
- vals)
- (debug:print-error 0 *default-log-port* "wrong number of values in " target ", should match " keys))
- vals)
- (debug:print 4 *default-log-port* "ERROR: keys:target-set-args called with no target.")))
-
-;; given the keys (a list of vectors or a list of keys) and a target return a keyval list
-;; keyval list ( (key1 val1) (key2 val2) ...)
-(define (keys:target->keyval keys target)
- (let* ((targlist (string-split target "/"))
- (numkeys (length keys))
- (numtarg (length targlist))
- (targtweaked (if (> numkeys numtarg)
- (append targlist (make-list (- numkeys numtarg) ""))
- targlist)))
- (map (lambda (key targ)
- (list key targ))
- keys targtweaked)))
-
-;;======================================================================
-;; config file related routines
-;;======================================================================
-
-(define keys:config-get-fields common:get-fields)
-(define (keys:make-key/field-string confdat)
- (let ((fields (configf:get-section confdat "fields")))
- (string-join
- (map (lambda (field)(conc (car field) " " (cadr field)))
- fields)
- ",")))
-
DELETED launch.scm
Index: launch.scm
==================================================================
--- launch.scm
+++ /dev/null
@@ -1,1625 +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 .
-
-;;======================================================================
-;; launch a task - this runs on the originating host, tests themselves
-;;
-;;======================================================================
-
-(use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3
- call-with-environment-variables csv)
-(use typed-records pathname-expand matchable)
-
-(import (prefix base64 base64:))
-(import (prefix sqlite3 sqlite3:))
-
-(declare (unit launch))
-(declare (uses subrun))
-(declare (uses common))
-(declare (uses configf))
-(declare (uses db))
-(declare (uses ezsteps))
-
-(include "common_records.scm")
-(include "key_records.scm")
-(include "db_records.scm")
-(include "megatest-fossil-hash.scm")
-
-;;======================================================================
-;; ezsteps
-;;======================================================================
-
-;; ezsteps were going to be coded as
-;; stepname[,predstep1,predstep2 ...] [{VAR1=first,second,third}] command to execute
-;; BUT
-;; now are
-;; stepname {VAR=first,second,third ...} command ...
-;; where the {VAR=first,second,third ...} is optional.
-
-;; given an exit code and whether or not logpro was used calculate OK/BAD
-;; return #t if we are ok, #f otherwise
-(define (steprun-good? logpro exitcode stepparms)
- (or (eq? exitcode 0)
- (and logpro (eq? exitcode 2)) ;; shouldn't this be (member exitcode 2 ...) with the other ok codes?
- (let* ((params (alist-ref 'params stepparms)) ;; get the params section
- (keep-going (if params
- (alist-ref "keep-going" params equal?)
- #f)))
- (debug:print 0 *default-log-port* "keep-going=" keep-going)
- (and keep-going (equal? (car keep-going) "yes")))))
-
-;; if handed a string, process it, else look for MT_CMDINFO
-(define (launch:get-cmdinfo-assoc-list #!key (encoded-cmd #f))
- (let ((enccmd (if encoded-cmd encoded-cmd (getenv "MT_CMDINFO"))))
- (if enccmd
- (common:read-encoded-string enccmd)
- '())))
-
-;; 0 1 2 3
-(defstruct launch:einf (pid #t)(exit-status #t)(exit-code #t)(rollup-status 0))
-
-;; return (conc status ": " comment) from the final section so that
-;; the comment can be set in the step record in launch.scm
-;;
-(define (launch:load-logpro-dat run-id test-id stepname)
- (let ((cname (conc stepname ".dat")))
- (if (common:file-exists? cname)
- (let* ((dat (read-config cname #f #f))
- (csvr (db:logpro-dat->csv dat stepname))
- (csvt (let-values (((fmt-cell fmt-record fmt-csv) (make-format ",")))
- (fmt-csv (map list->csv-record csvr))))
- (status (configf:lookup dat "final" "exit-status"))
- (msg (configf:lookup dat "final" "message")))
- (if csvt ;; this if blocked stack dump caused by .dat file from logpro being 0-byte. fixed by upgrading logpro
- (rmt:csv->test-data run-id test-id csvt)
- (debug:print 0 *default-log-port* "ERROR: no csvdat exists for run-id: " run-id " test-id: " test-id " stepname: " stepname ", check that logpro version is 1.15 or newer"))
- ;; (debug:print-info 13 *default-log-port* "Error: run-id/test-id/stepname="run-id"/"test-id"/"stepname" => bad csvr="csvr)
- ;; )
- (cond
- ((equal? status "PASS") "PASS") ;; skip the message part if status is pass
- (status (conc (configf:lookup dat "final" "exit-status") ": " (if msg msg "no message")))
- (else #f)))
- #f)))
-
-(define (launch:manage-steps run-id test-id item-path fullrunscript ezsteps subrun test-name tconfigreg exit-info m)
- ;; (let-values
- ;; (((pid exit-status exit-code)
- ;; (run-n-wait fullrunscript)))
- ;; (tests:test-set-status! test-id "RUNNING" "n/a" #f #f)
- ;; Since we should have a clean slate at this time there is no need to do
- ;; any of the other stuff that tests:test-set-status! does. Let's just
- ;; force RUNNING/n/a
-
- ;; (thread-sleep! 0.3)
- ;; (tests:test-force-state-status! run-id test-id "RUNNING" "n/a")
- (rmt:set-state-status-and-roll-up-items run-id test-name item-path "RUNNING" #f #f)
- ;; (thread-sleep! 0.3) ;; NFS slowness has caused grief here
-
- ;; if there is a runscript do it first
- (if fullrunscript
- (let ((pid (process-run fullrunscript)))
- (rmt:test-set-top-process-pid run-id test-id pid)
- (let loop ((i 0))
- (let-values
- (((pid-val exit-status exit-code) (process-wait pid #t)))
- (mutex-lock! m)
- (launch:einf-pid-set! exit-info pid) ;; (vector-set! exit-info 0 pid)
- (launch:einf-exit-status-set! exit-info exit-status) ;; (vector-set! exit-info 1 exit-status)
- (launch:einf-exit-code-set! exit-info exit-code) ;; (vector-set! exit-info 2 exit-code)
- (launch:einf-rollup-status-set! exit-info exit-code) ;; (vector-set! exit-info 3 exit-code) ;; rollup status
- (mutex-unlock! m)
- (if (eq? pid-val 0)
- (begin
- (thread-sleep! 2)
- (loop (+ i 1)))
- )))))
- ;; then, if runscript ran ok (or did not get called)
- ;; do all the ezsteps (if any)
- (if (or ezsteps subrun)
- (let* ((test-run-dir (tests:get-test-path-from-environment))
- (testconfig ;; (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here?
- ;; NOTE: it is tempting to turn off force-create of testconfig but dynamic
- ;; ezstep names need a full re-eval here.
- (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t)) ;; 'return-procs)))
- (ezstepslst (if (hash-table? testconfig)
- (hash-table-ref/default testconfig "ezsteps" '())
- #f)))
- (if testconfig
- (hash-table-set! *testconfigs* test-name testconfig) ;; cached for lazy reads later ...
- (begin
- (launch:setup)
- (debug:print 0 *default-log-port* "WARNING: no testconfig found for " test-name " in search path:\n "
- (string-intersperse (tests:get-tests-search-path *configdat*) "\n "))))
- ;; after all that, still no testconfig? Time to abort
- (if (not testconfig)
- (begin
- (debug:print-error 0 *default-log-port* "Failed to resolve megatest.config, runconfigs.config and testconfig issues. Giving up now")
- (exit 1)))
-
- ;; create a proc for the subrun if requested, save that proc in the ezsteps table as the last entry
- ;; 1. get section [runarun]
- ;; 2. unset MT_* vars
- ;; 3. fix target
- ;; 4. fix runname
- ;; 5. fix testpatt or calculate it from contour
- ;; 6. launch the run
- ;; 7. roll up the run result and or roll up the logpro processed result
- (when (configf:lookup testconfig "subrun" "runwait") ;; we use runwait as the flag that a subrun is requested
- (subrun:initialize-toprun-test testconfig test-run-dir)
- (let* ((mt-cmd (subrun:launch-cmd test-run-dir)))
- (debug:print-info 0 *default-log-port* "Subrun command is \"" mt-cmd "\"")
- (set! ezsteps #t) ;; set the needed flag
- (set! ezstepslst
- (append (or ezstepslst '())
- (list (list "subrun" (conc "{subrun=true} " mt-cmd)))))))
-
- ;; process the ezsteps
- (if ezsteps
- (let* ((all-steps-dat (make-hash-table))) ;; keep all the info around as stepname ==> alist; where 'params is the params list (add other stuff as needed)
- (if (not (common:file-exists? ".ezsteps"))(create-directory ".ezsteps"))
- ;; if ezsteps was defined then we are sure to have at least one step but check anyway
- (if (not (> (length ezstepslst) 0))
- (debug:print-error 0 *default-log-port* "ezsteps defined but ezstepslst is zero length")
- (let loop ((ezstep (car ezstepslst))
- (tal (cdr ezstepslst))
- (prevstep #f))
- (debug:print-info 0 *default-log-port* "Processing ezstep \"" (string-intersperse ezstep " ") "\"")
- ;; check exit-info (vector-ref exit-info 1)
- (if (launch:einf-exit-status exit-info) ;; (vector-ref exit-info 1)
- (let* ((logpro-used (launch:runstep ezstep run-id test-id exit-info m tal testconfig all-steps-dat))
- (stepname (car ezstep))
- (stepparms (hash-table-ref all-steps-dat stepname)))
- (setenv "MT_STEP_NAME" stepname)
- (pp (hash-table->alist all-steps-dat))
- ;; if logpro-used read in the stepname.dat file
- (if (and logpro-used (common:file-exists? (conc stepname ".dat")))
- (launch:load-logpro-dat run-id test-id stepname))
- (if (steprun-good? logpro-used (launch:einf-exit-code exit-info) stepparms)
- (if (not (null? tal))
- (loop (car tal) (cdr tal) stepname))
- (debug:print 0 *default-log-port* "WARNING: step " (car ezstep) " failed. Stopping")))
- (debug:print 0 *default-log-port* "WARNING: a prior step failed, stopping at " ezstep)))))))))
-
-(define (launch:monitor-job run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m work-area runtlim misc-flags)
- (let* ((update-period (string->number (or (configf:lookup *configdat* "setup" "test-stats-update-period") "30")))
- (start-seconds (current-seconds))
- (calc-minutes (lambda ()
- (inexact->exact
- (round
- (-
- (current-seconds)
- start-seconds)))))
- (kill-tries 0))
- ;; (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area)
- ;; (tests:set-full-meta-info test-id run-id (calc-minutes) work-area)
- (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area 10)
-
- (let loop ((minutes (calc-minutes))
- (cpu-load (alist-ref 'adj-core-load (common:get-normalized-cpu-load #f)))
- (disk-free (get-df (current-directory)))
- (last-sync (current-seconds)))
- ;; (common:telemetry-log "zombie" (conc "launch:monitor-job - top of loop encountered at "(current-seconds)" with last-sync="last-sync))
- (let* ((over-time (> (current-seconds) (+ last-sync update-period)))
- (new-cpu-load (let* ((load (alist-ref 'adj-core-load (common:get-normalized-cpu-load #f)))
- (delta (abs (- load cpu-load))))
- (if (> delta 0.1) ;; don't bother updating with small changes
- load
- #f)))
- (new-disk-free (let* ((df (if over-time ;; only get df every 30 seconds
- (get-df (current-directory))
- disk-free))
- (delta (abs (- df disk-free))))
- (if (and (> df 0)
- (> (/ delta df) 0.1)) ;; (> delta 200) ;; ignore changes under 200 Meg
- df
- #f)))
- (do-sync (or new-cpu-load new-disk-free over-time))
-
- (test-info (rmt:get-test-info-by-id run-id test-id))
- (state (db:test-get-state test-info))
- (status (db:test-get-status test-info))
- (kill-reason "no kill reason specified")
- (kill-job? #f))
- ;; (common:telemetry-log "zombie" (conc "launch:monitor-job - decision time encountered at "(current-seconds)" with last-sync="last-sync" do-sync="do-sync" over-time="over-time" update-period="update-period))
- (cond
- ((test-get-kill-request run-id test-id)
- (set! kill-reason "KILLING TEST since received kill request (KILLREQ)")
- (set! kill-job? #t))
- ((and runtlim (> (- (current-seconds) start-seconds) runtlim))
- (set! kill-reason (conc "KILLING TEST DUE TO TIME LIMIT EXCEEDED! Runtime=" (- (current-seconds) start-seconds) " seconds, limit=" runtlim))
- (set! kill-job? #t))
- ((equal? status "DEAD")
- (tests:update-central-meta-info run-id test-id new-cpu-load new-disk-free (calc-minutes) #f #f)
- (rmt:set-state-status-and-roll-up-items run-id test-id 'foo "RUNNING" "n/a" "was marked dead; really still running.")
- ;;(set! kill-reason "KILLING TEST because it was marked as DEAD by launch:handle-zombie-tests (might indicate really overloaded server or else overzealous setup.deadtime)") ;; MARK RUNNING
- (set! kill-job? #f)))
-
- (debug:print 4 *default-log-port* "cpu: " new-cpu-load " disk: " new-disk-free " last-sync: " last-sync " do-sync: " do-sync)
- (launch:handle-zombie-tests run-id)
- (when do-sync
- ;;(with-output-to-file (conc (getenv "MT_TEST_RUN_DIR") "/last-loadinfo.log" #:append)
- ;; (lambda () (pp (list (current-seconds) new-cpu-load new-disk-free (calc-minutes)))))
- ;; (common:telemetry-log "zombie" (conc "launch:monitor-job - dosync started at "(current-seconds)))
- (tests:update-central-meta-info run-id test-id new-cpu-load new-disk-free (calc-minutes) #f #f)
- ;; (common:telemetry-log "zombie" (conc "launch:monitor-job - dosync finished at "(current-seconds)))
- )
-
- (if kill-job?
- (begin
- (debug:print-info 0 *default-log-port* "proceeding to kill test: "kill-reason)
- (mutex-lock! m)
- ;; NOTE: The pid can change as different steps are run. Do we need handshaking between this
- ;; section and the runit section? Or add a loop that tries three times with a 1/4 second
- ;; between tries?
- (let* ((pid1 (launch:einf-pid exit-info)) ;; (vector-ref exit-info 0))
- (pid2 (rmt:test-get-top-process-pid run-id test-id))
- (pids (delete-duplicates (filter number? (list pid1 pid2)))))
- (if (not (null? pids))
- (begin
- (for-each
- (lambda (pid)
- (handle-exceptions
- exn
- (begin
- (debug:print-info 0 *default-log-port* "Unable to kill process with pid " pid ", possibly already killed.")
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn))
- (debug:print 0 *default-log-port* "WARNING: Request received to kill job " pid) ;; " (attempt # " kill-tries ")")
- (debug:print-info 0 *default-log-port* "Signal mask=" (signal-mask))
- ;; (if (process:alive? pid)
- ;; (begin
- (map (lambda (pid-num)
- (process-signal pid-num signal/term))
- (process:get-sub-pids pid))
- (thread-sleep! 5)
- ;; (if (process:process-alive? pid)
- (map (lambda (pid-num)
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port* " .... had trouble sending kill to " pid-num ", exn=" exn)
- #f)
- (process-signal pid-num signal/kill)))
- (process:get-sub-pids pid))))
- ;; (debug:print-info 0 *default-log-port* "not killing process " pid " as it is not alive"))))
- pids)
- ;; BB: question to Matt -- does the tests:test-state-status! encompass rollup to toplevel? If not, should it?
- (tests:test-set-status! run-id test-id "KILLED" "KILLED" (conc (args:get-arg "-m")" "kill-reason) #f)) ;; BB ADDED kill-reason -- confirm OK with Matt
- (begin
- (debug:print-error 0 *default-log-port* "Nothing to kill, pid1=" pid1 ", pid2=" pid2)
- (tests:test-set-status! run-id test-id "KILLED" "FAILED TO KILL" (conc (args:get-arg "-m")" "kill-reason) #f) ;; BB ADDED kill-reason -- confirm OK with Matt
- )))
- (mutex-unlock! m)
- ;; no point in sticking around. Exit now. But run end of run before exiting?
- (launch:end-of-run-check run-id)
- (exit)))
- (if (hash-table-ref/default misc-flags 'keep-going #f)
- (begin
- (thread-sleep! 3) ;; (+ 3 (random 6))) ;; add some jitter to the call home time to spread out the db accesses
- (if (hash-table-ref/default misc-flags 'keep-going #f) ;; keep originals for cpu-load and disk-free unless they change more than the allowed delta
- (loop (calc-minutes)
- (or new-cpu-load cpu-load)
- (or new-disk-free disk-free)
- (if do-sync (current-seconds) last-sync)))))))
- (tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f))) ;; NOTE: Checking twice for keep-going is intentional
-
-
-(define (launch:execute encoded-cmd)
- (let* ((cmdinfo (common:read-encoded-string encoded-cmd))
- (tconfigreg #f))
- (setenv "MT_CMDINFO" encoded-cmd)
- ;;(bb-check-path msg: "launch:execute incoming")
- (if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed)
- ;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1))
- (let* ((testpath (assoc/default 'testpath cmdinfo)) ;; testpath is the test spec area
- (top-path (assoc/default 'toppath cmdinfo))
- (work-area (assoc/default 'work-area cmdinfo)) ;; work-area is the test run area
- (test-name (assoc/default 'test-name cmdinfo))
- (runscript (assoc/default 'runscript cmdinfo))
- (ezsteps (assoc/default 'ezsteps cmdinfo))
- (subrun (assoc/default 'subrun cmdinfo))
- ;; (runremote (assoc/default 'runremote cmdinfo))
- ;; (transport (assoc/default 'transport cmdinfo)) ;; not used
- ;; (serverinf (assoc/default 'serverinf cmdinfo))
- ;; (port (assoc/default 'port cmdinfo))
- (serverurl (assoc/default 'serverurl cmdinfo))
- (homehost (assoc/default 'homehost cmdinfo))
- (run-id (assoc/default 'run-id cmdinfo))
- (test-id (assoc/default 'test-id cmdinfo))
- (target (assoc/default 'target cmdinfo))
- (areaname (assoc/default 'areaname cmdinfo))
- (itemdat (assoc/default 'itemdat cmdinfo))
- (env-ovrd (assoc/default 'env-ovrd cmdinfo))
- (set-vars (assoc/default 'set-vars cmdinfo)) ;; pre-overrides from -setvar
- (runname (assoc/default 'runname cmdinfo))
- (megatest (assoc/default 'megatest cmdinfo))
- (runtlim (assoc/default 'runtlim cmdinfo))
- (contour (assoc/default 'contour cmdinfo))
- (item-path (item-list->path itemdat))
- (mt-bindir-path (assoc/default 'mt-bindir-path cmdinfo))
- (keys #f)
- (keyvals #f)
- (fullrunscript (if (not runscript)
- #f
- (if (substring-index "/" runscript)
- runscript ;; use unadultered if contains slashes
- (let ((fulln (conc work-area "/" runscript)))
- (if (and (common:file-exists? fulln)
- (file-execute-access? fulln))
- fulln
- runscript))))) ;; assume it is on the path
- (check-work-area (lambda ()
- ;; NFS might not have propagated the directory meta data to the run host - give it time if needed
- (let loop ((count 0))
- (if (or (common:directory-exists? work-area)
- (> count 10))
- (change-directory work-area)
- (begin
- (debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " work-area " not found")
- (thread-sleep! 10)
- (loop (+ count 1)))))
-
- (if (not (string=? (common:real-path work-area)(common:real-path (current-directory))))
- (begin
- (debug:print 0 *default-log-port*
- "INFO: we are expecting to be in directory " work-area "\n"
- " but we are actually in the directory " (current-directory) "\n"
- " doing another change dir.")
- (change-directory work-area)))
-
- ;; spot check that the files in testpath are available. Too often NFS delays cause problems here.
- (let ((files (glob (conc testpath "/*")))
- (bad-files '()))
- (for-each
- (lambda (fullname)
- (let* ((fname (pathname-strip-directory fullname))
- (targn (conc work-area "/" fname)))
- (if (not (file-exists? targn))
- (set! bad-files (cons fname bad-files)))))
- files)
- (if (not (null? bad-files))
- (begin
- (debug:print 0 *default-log-port* "INFO: test data from " testpath " not copied properly or filesystem problems causing data to not be found. Re-running the copy command.")
- (debug:print 0 *default-log-port* "INFO: missing files from " work-area ": " (string-intersperse bad-files ", "))
- (launch:test-copy testpath work-area))))
- ;; one more time, change to the work-area directory
- (change-directory work-area)))
- ) ;; let*
-
- (if contour (setenv "MT_CONTOUR" contour))
-
- ;; immediated set some key variables from CMDINFO data, yes, these will be set again below ...
- ;;
- (setenv "MT_TESTSUITENAME" areaname)
- (setenv "MT_RUN_AREA_HOME" top-path)
- (set! *toppath* top-path)
- (change-directory *toppath*) ;; temporarily switch to the run area home
- (setenv "MT_TEST_RUN_DIR" work-area)
-
- (launch:setup) ;; should be properly in the run area home now
-
- (if contour (setenv "MT_CONTOUR" contour))
-
- ;; immediated set some key variables from CMDINFO data, yes, these will be set again below ...
- ;;
- (setenv "MT_TESTSUITENAME" areaname)
- (setenv "MT_RUN_AREA_HOME" top-path)
- (set! *toppath* top-path)
- (change-directory *toppath*) ;; temporarily switch to the run area home
- (setenv "MT_TEST_RUN_DIR" work-area)
-
- (launch:setup) ;; should be properly in the run area home now
-
- (set! tconfigreg (tests:get-all)) ;; mapping of testname => test source path
- (let ((sighand (lambda (signum)
- ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting
- (if (eq? signum signal/stop)
- (debug:print-error 0 *default-log-port* "attempt to STOP process. Exiting."))
- (set! *time-to-exit* #t)
- (print "Received signal " signum ", cleaning up before exit (set this test to COMPLETED/ABORT) . Please wait...")
- (let ((th1 (make-thread (lambda ()
- (print "set test to COMPLETED/ABORT begin.")
- (rmt:test-set-state-status run-id test-id "COMPLETED" "ABORT" "received kill signal")
- (print "set test to COMPLETED/ABORT complete.")
- (print "Killed by signal " signum ". Exiting")
- (exit 1))))
- (th2 (make-thread (lambda ()
- (thread-sleep! 20)
- (debug:print 0 *default-log-port* "Done")
- (exit 4)))))
- (thread-start! th2)
- (thread-start! th1)
- (thread-join! th2)))))
- (set-signal-handler! signal/int sighand)
- (set-signal-handler! signal/term sighand)
- ) ;; (set-signal-handler! signal/stop sighand)
-
- ;; Do not run the test if it is REMOVING, RUNNING, KILLREQ or REMOTEHOSTSTART,
- ;; Mark the test as REMOTEHOSTSTART *IMMEDIATELY*
- ;;
- (let* ((test-info (let loop ((tries 0))
- (let ((tinfo (rmt:get-test-info-by-id run-id test-id)))
- (if tinfo
- tinfo
- (if (> tries 5)
- #f
- (begin
- (thread-sleep! (+ 1 (* tries 10)))
- (loop (+ tries 1))))))))
- (test-host (if test-info
- (db:test-get-host test-info)
- (begin
- (debug:print 0 *default-log-port* "ERROR: failed to find a record for test-id " test-id ", exiting.")
- (exit))))
- (test-pid (db:test-get-process_id test-info)))
- (cond
- ;; -mrw- I'm removing KILLREQ from this list so that a test in KILLREQ state is treated as a "do not run" flag.
- ((member (db:test-get-state test-info) '("INCOMPLETE" "KILLED" "UNKNOWN" "STUCK")) ;; prior run of this test didn't complete, go ahead and try to rerun
- (debug:print 0 *default-log-port* "INFO: test is INCOMPLETE or KILLED, treat this execute call as a rerun request")
- ;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")
-
- (rmt:general-call 'set-test-start-time #f test-id)
- (rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f)
- ) ;; prime it for running
- ((member (db:test-get-state test-info) '("RUNNING" "REMOTEHOSTSTART"))
- (if (process:alive-on-host? test-host test-pid)
- (debug:print-error 0 *default-log-port* "test state is " (db:test-get-state test-info) " and process " test-pid " is still running on host " test-host ", cannot proceed")
- (exit)))
- ((member (db:test-get-state test-info) '("COMPLETED")) ;; we do NOT want to re-run COMPLETED jobs. Mark as NOT_STARTED to run!
- (debug:print-error 0 *default-log-port* "test state is " (db:test-get-state test-info) ", cannot proceed")
- (exit))
- ((not (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ")))
- ;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")
- (rmt:general-call 'set-test-start-time #f test-id)
- (rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f))
- (else ;; (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ"))
- (debug:print-error 0 *default-log-port* "test state is " (db:test-get-state test-info) ", cannot proceed")
- (exit))))
-
- ;; cleanup prior execution's steps
- (rmt:delete-steps-for-test! run-id test-id)
-
- (debug:print 2 *default-log-port* "Executing " test-name " (id: " test-id ") on " (get-host-name))
- (set! keys (rmt:get-keys))
- ;; (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process
- ;; one of these is defunct/redundant ...
- (if (not (launch:setup force-reread: #t))
- (begin
- (debug:print 0 *default-log-port* "Failed to setup, exiting")
- ;; (sqlite3:finalize! db)
- ;; (sqlite3:finalize! tdb)
- (exit 1)))
- ;; validate that the test run area is available
- (check-work-area)
-
- ;; still need to go back to run area home for next couple steps
- (change-directory *toppath*)
-
- ;; NOTE: Current order is to process runconfigs *before* setting the MT_ vars. This
- ;; seems non-ideal but could well break stuff
- ;; BUG? BUG? BUG?
-
- (let ((rconfig (full-runconfigs-read)) ;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: (list "default" target))))
- (wconfig (read-config "waivers.config" #f #t sections: `( "default" ,target )))) ;; read the waivers config if it exists
- ;; (setup-env-defaults (conc *toppath* "/runconfigs.config") run-id (make-hash-table) keyvals target)
- ;; (set-run-config-vars run-id keyvals target) ;; (db:get-target db run-id))
- ;; Now have runconfigs data loaded, set environment vars
- (for-each
- (lambda (section)
- (for-each
- (lambda (varval)
- (let ((var (car varval))
- (val (cadr varval)))
- (if (and (string? var)(string? val))
- (begin
- (safe-setenv var (configf:eval-string-in-environment val))) ;; val)
- (debug:print-error 0 *default-log-port* "bad variable spec, " var "=" val))))
- (configf:get-section rconfig section)))
- (list "default" target)))
- ;;(bb-check-path msg: "launch:execute post block 1")
-
- ;; NFS might not have propagated the directory meta data to the run host - give it time if needed
- (let loop ((count 0))
- (if (or (common:file-exists? work-area)
- (> count 10))
- (change-directory work-area)
- (begin
- (debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " work-area " not found")
- (thread-sleep! 10)
- (loop (+ count 1)))))
-
- ;; now we can switch to the work-area?
- (change-directory work-area)
- ;;(bb-check-path msg: "launch:execute post block 1.5")
- ;; (change-directory work-area)
- (set! keyvals (keys:target->keyval keys target))
- ;; apply pre-overrides before other variables. The pre-override vars must not
- ;; clobbers things from the official sources such as megatest.config and runconfigs.config
- (if (string? set-vars)
- (let ((varpairs (string-split set-vars ",")))
- (debug:print 4 *default-log-port* "varpairs: " varpairs)
- (map (lambda (varpair)
- (let ((varval (string-split varpair "=")))
- (if (eq? (length varval) 2)
- (let ((var (car varval))
- (val (cadr varval)))
- (debug:print 1 *default-log-port* "Adding pre-var/val " var " = " val " to the environment")
- (setenv var val)))))
- varpairs)))
- ;;(bb-check-path msg: "launch:execute post block 2")
- (for-each
- (lambda (varval)
- (let ((var (car varval))
- (val (cadr varval)))
- (if val
- (setenv var val)
- (begin
- (debug:print-error 0 *default-log-port* "required variable " var " does not have a valid value. Exiting")
- (exit)))))
- (list
- (list "MT_TEST_RUN_DIR" work-area)
- (list "MT_TEST_NAME" test-name)
- (list "MT_ITEM_INFO" (conc itemdat))
- (list "MT_ITEMPATH" item-path)
- (list "MT_RUNNAME" runname)
- (list "MT_MEGATEST" megatest)
- (list "MT_TARGET" target)
- (list "MT_LINKTREE" (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree"))
- (list "MT_TESTSUITENAME" (common:get-testsuite-name))))
- ;;(bb-check-path msg: "launch:execute post block 3")
-
- (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path)))
- ;;(bb-check-path msg: "launch:execute post block 4")
- ;; (change-directory top-path)
- ;; Can setup as client for server mode now
- ;; (client:setup)
-
-
- ;; environment overrides are done *before* the remaining critical envars.
- (alist->env-vars env-ovrd)
- ;;(bb-check-path msg: "launch:execute post block 41")
- (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals)
- ;;(bb-check-path msg: "launch:execute post block 42")
- (set-item-env-vars itemdat)
- ;;(bb-check-path msg: "launch:execute post block 43")
- (let ((blacklist (configf:lookup *configdat* "setup" "blacklistvars")))
- (if blacklist
- (let ((vars (string-split blacklist)))
- (save-environment-as-files "megatest" ignorevars: vars)
- (for-each (lambda (var)
- (unsetenv var))
- vars))
- (save-environment-as-files "megatest")))
- ;;(bb-check-path msg: "launch:execute post block 44")
- ;; open-run-close not needed for test-set-meta-info
- ;; (tests:set-full-meta-info #f test-id run-id 0 work-area)
- ;; (tests:set-full-meta-info test-id run-id 0 work-area)
- (tests:set-full-meta-info #f test-id run-id 0 work-area 10)
-
- ;; (thread-sleep! 0.3) ;; NFS slowness has caused grief here
-
- (if (args:get-arg "-xterm")
- (set! fullrunscript "xterm")
- (if (and fullrunscript
- (common:file-exists? fullrunscript)
- (not (file-execute-access? fullrunscript)))
- (system (conc "chmod ug+x " fullrunscript))))
-
- ;; We are about to actually kick off the test
- ;; so this is a good place to remove the records for
- ;; any previous runs
- ;; (db:test-remove-steps db run-id testname itemdat)
- ;; now is also a good time to write the .testconfig file
- (let* ((tconfig-fname (conc work-area "/.testconfig"))
- (tconfig-tmpfile (conc tconfig-fname ".tmp"))
- (tconfig (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t)) ;; 'return-procs)))
- (scripts (configf:get-section tconfig "scripts")))
- ;; create .testconfig file
- (configf:write-alist tconfig tconfig-tmpfile)
- (file-move tconfig-tmpfile tconfig-fname #t)
- (delete-file* ".final-status")
-
- ;; extract scripts from testconfig and write them to files in test run dir
- (for-each
- (lambda (scriptdat)
- (match scriptdat
- ((name content)
- (with-output-to-file name
- (lambda ()
- (print content)
- (change-file-mode name (bitwise-ior perm/irwxg perm/irwxu)))))
- (else
- (debug:print-info 0 "Invalid script definiton found in [scripts] section of testconfig. \"" scriptdat "\""))))
- scripts))
- ;;
- (let* ((m (make-mutex))
- (kill-job? #f)
- (exit-info (make-launch:einf pid: #t exit-status: #t exit-code: #t rollup-status: 0)) ;; pid exit-status exit-code (i.e. process was successfully run) rollup-status
- (job-thread #f)
- ;; (keep-going #t)
- (misc-flags (let ((ht (make-hash-table)))
- (hash-table-set! ht 'keep-going #t)
- ht))
- (runit (lambda ()
- (launch:manage-steps run-id test-id item-path fullrunscript ezsteps subrun test-name tconfigreg exit-info m)))
- (monitorjob (lambda ()
- (launch:monitor-job run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m work-area runtlim misc-flags)))
- (th1 (make-thread monitorjob "monitor job"))
- (th2 (make-thread runit "run job")))
- (set! job-thread th2)
- (thread-start! th1)
- (thread-start! th2)
- (thread-join! th2)
- (debug:print-info 0 *default-log-port* "Megatest exectute of test " test-name ", item path " item-path " complete. Notifying the db ...")
- (hash-table-set! misc-flags 'keep-going #f)
- (thread-join! th1)
- (thread-sleep! 1) ;; givbe thread th1 a chance to be done TODO: Verify this is needed. At 0.1 I was getting fail to stop, increased to total of 1.1 sec.
- (mutex-lock! m)
- (let* ((item-path (item-list->path itemdat))
- ;; only state and status needed - use lazy routine
- (testinfo (rmt:get-testinfo-state-status run-id test-id)))
- ;; Am I completed?
- (if (member (db:test-get-state testinfo) '("REMOTEHOSTSTART" "RUNNING")) ;; NOTE: It should *not* be REMOTEHOSTSTART but for reasons I don't yet understand it sometimes gets stuck in that state ;; (not (equal? (db:test-get-state testinfo) "COMPLETED"))
- (let ((new-state (if kill-job? "KILLED" "COMPLETED") ;; (if (eq? (vector-ref exit-info 2) 0) ;; exited with "good" status
- ;; "COMPLETED" ;; (db:test-get-state testinfo))) ;; else preseve the state as set within the test
- )
- (new-status (cond
- ((not (launch:einf-exit-status exit-info)) "FAIL") ;; job failed to run ... (vector-ref exit-info 1)
- ((eq? (launch:einf-rollup-status exit-info) 0) ;; (vector-ref exit-info 3)
- ;; if the current status is AUTO then defer to the calculated value (i.e. leave this AUTO)
- (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO" "PASS"))
- ((eq? (launch:einf-rollup-status exit-info) 1) "FAIL") ;; (vector-ref exit-info 3)
- ((eq? (launch:einf-rollup-status exit-info) 2) ;; (vector-ref exit-info 3)
- ;; if the current status is AUTO the defer to the calculated value but qualify (i.e. make this AUTO-WARN)
- (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO-WARN" "WARN"))
- ((eq? (launch:einf-rollup-status exit-info) 3) "CHECK")
- ((eq? (launch:einf-rollup-status exit-info) 4) "WAIVED")
- ((eq? (launch:einf-rollup-status exit-info) 5) "ABORT")
- ((eq? (launch:einf-rollup-status exit-info) 6) "SKIP")
- (else "FAIL")))) ;; (db:test-get-status testinfo)))
- (debug:print-info 1 *default-log-port* "Test exited in state=" (db:test-get-state testinfo) ", setting state/status based on exit code of " (launch:einf-exit-status exit-info) " and rollup-status of " (launch:einf-rollup-status exit-info))
-
- ;; Leave a .final-status file for each sub-test
- (tests:save-final-status run-id test-id)
-
- (tests:test-set-status! run-id
- test-id
- new-state
- new-status
- (args:get-arg "-m") #f)
- ;; need to update the top test record if PASS or FAIL and this is a subtest
- ;; NO NEED TO CALL set-state-status-and-roll-up-items HERE, THIS IS DONE IN set-state-status-and-roll-up-items called by tests:test-set-status!
- ))
- ;; for automated creation of the rollup html file this is a good place...
- (if (not (equal? item-path ""))
- (tests:summarize-items run-id test-id test-name #f))
- (tests:summarize-test run-id test-id) ;; don't force - just update if no
- ;; Leave a .final-status file for the top level test
- (tests:save-final-status run-id test-id)
- (rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id)))
- (mutex-unlock! m)
- (launch:end-of-run-check run-id )
- (debug:print 2 *default-log-port* "Output from running " fullrunscript ", pid " (launch:einf-pid exit-info) " in work area "
- work-area ":\n====\n exit code " (launch:einf-exit-code exit-info) "\n" "====\n")
- (if (not (launch:einf-exit-status exit-info))
- (exit 4))))
- )))
-
-;; Spec for End of test
-;; At end of each test call, after marking self as COMPLETED do run-state-status-rollup
-;; At transition to run COMPLETED/X do hooks
-;; Definition: test_dead if event_time + duration + 1 minute? < current_time AND
-;; we can prove the process is not alive (ssh host pstree -A pid)
-;; if dead safe to mark the test as killed in the db
-;; State/status table
-;; new
-;; 100% COMPLETED/ (PASS,FAIL,ABORT etc.) ==> COMPLETED / X where X is same as itemized rollup
-;; > 3 RUNNING with not test_dead do nothing (run should already be RUNNING/ na
-;; > 0 RUNNING and test_dead then send KILLREQ ==> COMPLETED
-;; 0 RUNNING ==> this is actually the first condition, should not get here
-
-(define (launch:end-of-run-check run-id )
- (let* ((not-completed-cnt (rmt:get-not-completed-cnt run-id))
- (running-cnt (rmt:get-count-tests-running-for-run-id run-id))
- (all-test-launched (rmt:get-var (conc "lunch-complete-" run-id)))
- (current-state (rmt:get-run-state run-id))
- (current-status (rmt:get-run-status run-id)))
- ;;get-vars run-id to query metadata table to check if all completed. if all-test-launched = yes then only not-completed-cnt = 0 means everyting is completed if no entry found in the table do nothing
- (debug:print 0 *default-log-port* "Running test cnt :" running-cnt)
- (rmt:set-state-status-and-roll-up-run run-id current-state current-status)
- (runs:update-junit-test-reporter-xml run-id)
- (cond
- ((and all-test-launched (eq? not-completed-cnt 0) (equal? all-test-launched "yes" ))
- (if (and (equal? (rmt:get-var (conc "end-of-run-" run-id)) "no") (common:simple-lock (conc "endOfRun" run-id)))
- (begin
- (debug:print 4 *default-log-port* "look for post hook. currseconds: " (current-seconds) " EOR " (rmt:get-var (conc "end-of-run-" run-id)))
- (debug:print 0 *default-log-port* "End of Run Detected.")
- (rmt:set-var (conc "end-of-run-" run-id) "yes")
- ;(thread-sleep! 10)
- (runs:run-post-hook run-id)
- (debug:print 4 *default-log-port* "currseconds: " (current-seconds)" eor: " (rmt:get-var (conc "end-of-run-" run-id)))
- (common:simple-unlock (conc "endOfRun" run-id)))
- (debug:print 0 *default-log-port* "End of Run Detected but not running post hook. This should happen when eor is set to yes. This will happen only when 2 tests exit at smae time. eor= " (rmt:get-var (conc "end-of-run-" run-id)))))
- ((> running-cnt 3)
- (debug:print 0 *default-log-port* "There are " running-cnt " tests running." ))
- ((> running-cnt 0)
- (debug:print 0 *default-log-port* "running cnt > 0 but <= 3 kill-running-tests-if-dead" )
- (let ((kill-cnt (launch:kill-tests-if-dead run-id)))
- (if (and all-test-launched (equal? all-test-launched "yes") (eq? kill-cnt running-cnt))
- (launch:end-of-run-check run-id)))) ;;todo
- (else (debug:print 0 *default-log-port* "Should it get here?? May be everything is not launched yet. Running test cnt:" running-cnt " Not completed test cnt:" not-completed-cnt)
- (let* ((not-completed-tests (rmt:get-tests-for-run run-id "%" `("NOT_STARTED" "RUNNING" "LAUNCHED" "REMOTEHOSTSTART") `() #f #f #f #f #f #f #f #f)))
- (if (> (length not-completed-tests) 0)
- (let loop ((running-test (car not-completed-tests))
- (tal (cdr not-completed-tests)))
- (let* ((test-name (vector-ref running-test 2))
- (item-path (vector-ref running-test 11)))
- (debug:print 0 *default-log-port* "test " test-name "/" item-path " not completed")
- (if (not (null? tal))
- (loop (car tal) (cdr tal)))))))))))
-
-(define (launch:is-test-alive host pid)
- (if (and host pid (not (equal? host "n/a")))
- (let* ((cmd (conc "ssh " host " pstree -A " pid))
- (output (with-input-from-pipe cmd read-lines)))
- (debug:print 2 *default-log-port* "Running " cmd " received " output)
- (if (eq? (length output) 0)
- #f
- #t))
- #t))
-
-(define (launch:kill-tests-if-dead run-id)
- (let* ((running-tests (rmt:get-tests-for-run run-id "%" `("RUNNING" "LAUNCHED" "REMOTEHOSTSTART") `() #f #f #f #f #f #f #f #f)))
- (let loop ((running-test (car running-tests))
- (tal (cdr running-tests))
- (kill-cnt 0))
- (let* ((test-name (vector-ref running-test 2))
- (item-path (vector-ref running-test 11))
- (test-id (vector-ref running-test 0))
- (host (vector-ref running-test 6))
- (pid (rmt:test-get-top-process-pid run-id test-id))
- (event-time (vector-ref running-test 5))
- (duration (vector-ref running-test 12))
- (flag 0)
- (curr-time (current-seconds)))
- (if (and (< (+ event-time duration 600) curr-time) (not (launch:is-test-alive host pid))) ;;test has not updated duration in last 10 min then likely its not running but confirm before marking it as killed
- (begin
- (debug:print 0 *default-log-port* "test " test-name "/" item-path " needs to be killed")
- (set! flag 1)
- (rmt:set-state-status-and-roll-up-items run-id test-name item-path "KILLREQ" "n/a" #f)))
- (if (not (null? tal))
- (loop (car tal) (cdr tal) (+ kill-cnt flag))
- (+ kill-cnt flag))))))
-
-;; DO NOT USE - caching of configs is handled in launch:setup now.
-;;
-(define (launch:cache-config)
- ;; if we have a linktree and -runtests and -target and the directory exists dump the config
- ;; to megatest-(current-seconds).cfg and symlink it to megatest.cfg
- (if (and *configdat*
- (or (args:get-arg "-run")
- (args:get-arg "-runtests")
- (args:get-arg "-execute")))
- (let* ((linktree (common:get-linktree)) ;; (get-environment-variable "MT_LINKTREE"))
- (target (common:args-get-target exit-if-bad: #t))
- (runname (or (args:get-arg "-runname")
- (args:get-arg ":runname")
- (getenv "MT_RUNNAME")))
- (fulldir (conc linktree "/"
- target "/"
- runname)))
- (if (and linktree (common:file-exists? linktree)) ;; can't proceed without linktree
- (begin
- (debug:print-info 0 *default-log-port* "Have -run with target=" target ", runname=" runname ", fulldir=" fulldir ", testpatt=" (or (args:get-arg "-testpatt") "%"))
- (if (not (common:file-exists? fulldir))
- (create-directory fulldir #t)) ;; need to protect with exception handler
- (if (and target
- runname
- (common:file-exists? fulldir))
- (let ((tmpfile (conc fulldir "/.megatest.cfg." (current-seconds)))
- (targfile (conc fulldir "/.megatest.cfg-" megatest-version "-" megatest-fossil-hash))
- (rconfig (conc fulldir "/.runconfig." megatest-version "-" megatest-fossil-hash)))
- (if (common:file-exists? rconfig) ;; only cache megatest.config AFTER runconfigs has been cached
- (begin
- (debug:print-info 0 *default-log-port* "Caching megatest.config in " tmpfile)
- (if (not (common:in-running-test?))
- (configf:write-alist *configdat* tmpfile))
- (system (conc "ln -sf " tmpfile " " targfile))))
- )))
- (debug:print-info 1 *default-log-port* "No linktree yet, no caching configs.")))))
-
-
-;; gather available information, if legit read configs in this order:
-;;
-;; if have cache;
-;; read it a return it
-;; else
-;; megatest.config (do not cache)
-;; runconfigs.config (cache if all vars avail)
-;; megatest.config (cache if all vars avail)
-;; returns:
-;; *toppath*
-;; side effects:
-;; sets; *configdat* (megatest.config info)
-;; *runconfigdat* (runconfigs.config info)
-;; *configstatus* (status of the read data)
-;;
-(define (launch:setup #!key (force-reread #f) (areapath #f))
- (mutex-lock! *launch-setup-mutex*)
- (if (and *toppath*
- (eq? *configstatus* 'fulldata) (not force-reread)) ;; got it all
- (begin
- (debug:print 2 *default-log-port* "NOTE: skipping launch:setup-body call since we have fulldata")
- (mutex-unlock! *launch-setup-mutex*)
- *toppath*)
- (let ((res (launch:setup-body force-reread: force-reread areapath: areapath)))
- (mutex-unlock! *launch-setup-mutex*)
- res)))
-
-;; return paths depending on what info is available.
-;;
-(define (launch:get-cache-file-paths areapath toppath target mtconfig)
- (let* ((use-cache (common:use-cache?))
- (runname (common:args-get-runname))
- (linktree (common:get-linktree))
- (testname (common:get-full-test-name))
- (rundir (if (and runname target linktree)
- (common:directory-writable? (conc linktree "/" target "/" runname))
- #f))
- (testdir (if (and rundir testname)
- (common:directory-writable? (conc rundir "/" testname))
- #f))
- (cachedir (or testdir rundir))
- (mtcachef (and cachedir (conc cachedir "/" ".megatest.cfg-" megatest-version "-" megatest-fossil-hash)))
- (rccachef (and cachedir (conc cachedir "/" ".runconfigs.cfg-" megatest-version "-" megatest-fossil-hash))))
- (debug:print-info 6 *default-log-port*
- "runname=" runname
- "\n linktree=" linktree
- "\n testname=" testname
- "\n rundir=" rundir
- "\n testdir=" testdir
- "\n cachedir=" cachedir
- "\n mtcachef=" mtcachef
- "\n rccachef=" rccachef)
- (cons mtcachef rccachef)))
-
-(define (launch:setup-body #!key (force-reread #f) (areapath #f))
- (if (and (eq? *configstatus* 'fulldata)
- *toppath*
- (not force-reread)) ;; no need to reprocess
- *toppath* ;; return toppath
- (let* ((use-cache (common:use-cache?)) ;; BB- use-cache checks *configdat* for use-cache setting. We do not have *configdat*. Bootstrapping problem here.
- (toppath (common:get-toppath areapath))
- (target (common:args-get-target))
- (sections (if target (list "default" target) #f)) ;; for runconfigs
- (mtconfig (or (args:get-arg "-config") "megatest.config")) ;; allow overriding megatest.config
- (cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig))
- ;; checking for null cachefiles should not be necessary, I was seeing error car of '(), might be a chicken bug or a red herring ...
- (mtcachef (if (null? cachefiles)
- #f
- (car cachefiles))) ;; (and cachedir (conc cachedir "/" ".megatest.cfg-" megatest-version "-" megatest-fossil-hash)))
- (rccachef (if (null? cachefiles)
- #f
- (cdr cachefiles)))) ;; (and cachedir (conc cachedir "/" ".runconfigs.cfg-" megatest-version "-" megatest-fossil-hash)))
- ;; (cancreate (and cachedir (common:file-exists? cachedir)(file-write-access? cachedir) (not (common:in-running-test?)))))
- (set! *toppath* toppath) ;; This is needed when we are running as a test using CMDINFO as a datasource
- ;;(BB> "launch:setup-body -- cachefiles="cachefiles)
- (cond
- ;; if mtcachef exists just read it, however we need to assume toppath is available in $MT_RUN_AREA_HOME
- ((and (not force-reread)
- mtcachef rccachef
- use-cache
- (get-environment-variable "MT_RUN_AREA_HOME")
- (common:file-exists? mtcachef)
- (common:file-exists? rccachef))
- ;;(BB> "launch:setup-body -- cond branch 1 - use-cache")
- (set! *configdat* (configf:read-alist mtcachef))
- ;;(BB> "launch:setup-body -- 1 set! *configdat*="*configdat*)
- (set! *runconfigdat* (configf:read-alist rccachef))
- (set! *configinfo* (list *configdat* (get-environment-variable "MT_RUN_AREA_HOME")))
- (set! *configstatus* 'fulldata)
- (set! *toppath* (get-environment-variable "MT_RUN_AREA_HOME"))
- *toppath*)
- ;; there are no existing cached configs, do full reads of the configs and cache them
- ;; we have all the info needed to fully process runconfigs and megatest.config
- ((and ;; (not force-reread) ;; force-reread is irrelevant in the AND, could however OR it?
- mtcachef
- rccachef) ;; BB- why are we doing this without asking if caching is desired?
- ;;(BB> "launch:setup-body -- cond branch 2")
- (let* ((first-pass (find-and-read-config ;; NB// sets MT_RUN_AREA_HOME as side effect
- mtconfig
- environ-patt: "env-override"
- given-toppath: toppath
- pathenvvar: "MT_RUN_AREA_HOME"))
- (first-rundat (let ((toppath (if toppath
- toppath
- (car first-pass))))
- (read-config ;; (conc toppath "/runconfigs.config") ;; this should be converted to runconfig:read but it is non-trivial, leaving it for now.
- (conc (if (string? toppath)
- toppath
- (get-environment-variable "MT_RUN_AREA_HOME"))
- "/runconfigs.config")
- *runconfigdat* #t
- sections: sections))))
- (set! *runconfigdat* first-rundat)
- (if first-pass ;;
- (begin
- ;;(BB> "launch:setup-body -- \"first-pass\"=first-pass")
- (set! *configdat* (car first-pass))
- ;;(BB> "launch:setup-body -- 2 set! *configdat*="*configdat*)
- (set! *configinfo* first-pass)
- (set! *toppath* (or toppath (cadr first-pass))) ;; use the gathered data unless already have it
- (set! toppath *toppath*)
- (if (not *toppath*)
- (begin
- (debug:print-error 0 *default-log-port* "you are not in a megatest area!")
- (exit 1)))
- (setenv "MT_RUN_AREA_HOME" *toppath*)
- ;; the seed read is done, now read runconfigs, cache it then read megatest.config one more time and cache it
- (let* ((keys (common:list-or-null (rmt:get-keys)
- message: "Failed to retrieve keys in launch.scm. Please report this to the developers."))
- (key-vals (keys:target->keyval keys target))
- (linktree (common:get-linktree)) ;; (or (getenv "MT_LINKTREE")(if *configdat* (configf:lookup *configdat* "setup" "linktree") #f)))
- ; (if *configdat*
- ; (configf:lookup *configdat* "setup" "linktree")
- ; (conc *toppath* "/lt"))))
- (second-pass (find-and-read-config
- mtconfig
- environ-patt: "env-override"
- given-toppath: toppath
- pathenvvar: "MT_RUN_AREA_HOME"))
- (runconfigdat (begin ;; this read of the runconfigs will see any adjustments made by re-reading megatest.config
- (for-each (lambda (kt)
- (setenv (car kt) (cadr kt)))
- key-vals)
- (read-config (conc toppath "/runconfigs.config") *runconfigdat* #t ;; consider using runconfig:read some day ...
- sections: sections)))
- (cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig))
- (mtcachef (car cachefiles))
- (rccachef (cdr cachefiles)))
- ;; trap exception due to stale NFS handle -- Error: (open-output-file) cannot open file - Stale NFS file handle: "/p/fdk/gwa/lefkowit/mtTesting/qa/primbeqa/links/p1222/11/PDK_r1.1.1/prim/clean/pcell_testgen/.runconfigs.cfg-1.6427-7d1e789cb3f62f9cde719a4865bb51b3c17ea853" - ticket 220546342
- ;; TODO - consider 1) using simple-lock to bracket cache write
- ;; 2) cache in hash on server, since need to do rmt: anyway to lock.
-
- (if rccachef
- (common:fail-safe
- (lambda ()
- (configf:write-alist runconfigdat rccachef))
- (conc "Could not write cache file - "rccachef)))
- (if mtcachef
- (common:fail-safe
- (lambda ()
- (configf:write-alist *configdat* mtcachef))
- (conc "Could not write cache file - "mtcachef)))
- (set! *runconfigdat* runconfigdat)
- (if (and rccachef mtcachef) (set! *configstatus* 'fulldata))))
- ;; no configs found? should not happen but let's try to recover gracefully, return an empty hash-table
- (set! *configdat* (make-hash-table))
- )))
-
- ;; else read what you can and set the flag accordingly
- ;; here we don't have either mtconfig or rccachef
- (else
- ;;(BB> "launch:setup-body -- cond branch 3 - else")
- (let* ((cfgdat (find-and-read-config
- (or (args:get-arg "-config") "megatest.config")
- environ-patt: "env-override"
- given-toppath: (get-environment-variable "MT_RUN_AREA_HOME")
- pathenvvar: "MT_RUN_AREA_HOME")))
-
- (if (and cfgdat (list? cfgdat) (> (length cfgdat) 0) (hash-table? (car cfgdat)))
- (let* ((toppath (or (get-environment-variable "MT_RUN_AREA_HOME")(cadr cfgdat)))
- (rdat (read-config (conc toppath ;; convert this to use runconfig:read!
- "/runconfigs.config") *runconfigdat* #t sections: sections)))
- (set! *configinfo* cfgdat)
- (set! *configdat* (car cfgdat))
- (set! *runconfigdat* rdat)
- (set! *toppath* toppath)
- (set! *configstatus* 'partial))
- (begin
- (debug:print-error 0 *default-log-port* "No " mtconfig " file found. Giving up.")
- (exit 2))))))
- ;; COND ends here.
-
- ;; additional house keeping
- (let* ((linktree (or (common:get-linktree)
- (conc *toppath* "/lt"))))
- (if linktree
- (begin
- (if (not (common:file-exists? linktree))
- (begin
- (handle-exceptions
- exn
- (begin
- (debug:print-error 0 *default-log-port* "Something went wrong when trying to create linktree dir at " linktree)
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
- (exit 1))
- (create-directory linktree #t))))
- (handle-exceptions
- exn
- (begin
- (debug:print-error 0 *default-log-port* "Something went wrong when trying to create link to linktree at " *toppath*)
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn))
- (let ((tlink (conc *toppath* "/lt")))
- (if (not (common:file-exists? tlink))
- (create-symbolic-link linktree tlink)))))
- (begin
- (debug:print-error 0 *default-log-port* "linktree not defined in [setup] section of megatest.config")
- )))
- (if (and *toppath*
- (directory-exists? *toppath*))
- (begin
- (setenv "MT_RUN_AREA_HOME" *toppath*)
- (setenv "MT_TESTSUITENAME" (common:get-testsuite-name)))
- (begin
- (debug:print-error 0 *default-log-port* "failed to find the top path to your Megatest area.")
- (set! *toppath* #f) ;; force it to be false so we return #f
- #f))
-
- ;; one more attempt to cache the configs for future reading
- (let* ((cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig))
- (mtcachef (car cachefiles))
- (rccachef (cdr cachefiles)))
-
- ;; trap exception due to stale NFS handle -- Error: (open-output-file) cannot open file - Stale NFS file handle: "...somepath.../.runconfigs.cfg-1.6427-7d1e789cb3f62f9cde719a4865bb51b3c17ea853" - ticket 220546342
- ;; TODO - consider 1) using simple-lock to bracket cache write
- ;; 2) cache in hash on server, since need to do rmt: anyway to lock.
- (if (and rccachef *runconfigdat* (not (common:file-exists? rccachef)))
- (common:fail-safe
- (lambda ()
- (configf:write-alist *runconfigdat* rccachef))
- (conc "Could not write cache file - "rccachef))
- )
- (if (and mtcachef *configdat* (not (common:file-exists? mtcachef)))
- (common:fail-safe
- (lambda ()
- (configf:write-alist *configdat* mtcachef))
- (conc "Could not write cache file - "mtcachef))
- )
- (if (and rccachef mtcachef *runconfigdat* *configdat*)
- (set! *configstatus* 'fulldata)))
-
- ;; if have -append-config then read and append here
- (let ((cfname (args:get-arg "-append-config")))
- (if (and cfname
- (file-read-access? cfname))
- (read-config cfname *configdat* #t))) ;; values are added to the hash, no need to do anything special.
- *toppath*)))
-
-
-(define (get-best-disk confdat testconfig)
- (let* ((disks (or (and testconfig (hash-table-ref/default testconfig "disks" #f))
- (hash-table-ref/default confdat "disks" #f)))
- (minspace (let ((m (configf:lookup confdat "setup" "minspace")))
- (string->number (or m "10000")))))
- (if disks
- (let ((res (common:get-disk-with-most-free-space disks minspace))) ;; min size of 1000, seems tad dumb
- (if res
- (cdr res)
- (begin ;; DEAD CODE PATH - REVISIT!
-;; (if (common:low-noise-print 20 "No valid disks or no disk with enough space")
-;; (debug:print-error 0 *default-log-port* "No valid disks found in megatest.config. Please add some to your [disks] section and ensure the directory exists and has enough space!\n You can change minspace in the [setup] section of megatest.config. Current setting is: " minspace))
- ;;(exit 1)
- (if (null? disks)
- (cons 1 (conc *toppath* "/runs"))
- (let ((paths (sort disks (lambda (x y) (> (string-length (cadr x)) (string-length (cadr y)))))))
- (let loop ((head (car paths)) (tail (cdr paths)))
- (let ((result (handle-exceptions exn
- (begin
- (debug:print 0 *default-log-port* "failed to create dir " (cadr head) ", exn=" exn)
- #f)
- (create-directory (cadr head) #t))))
- (if result
- result
- (if (null? tail)
- (cons 1 (conc *toppath* "/runs"))
- (loop (car tail) (cdr tail)))))))))))
- ;; no disks definition - use mtrah/runs, fall back to currdir/runs
- (let* ((toppath (or *toppath*
- (common:get-toppath *toppath*)
- (begin
- (debug:print-error 0 *default-log-port* "Creating runs dir in current directory, this is probably not what you wanted. Please check your setup.")
- (current-directory))))
- (runsdir (conc toppath "/runs")))
- (if (not (file-exists? runsdir))(create-directory runsdir))
- runsdir)
- ))) ;; the code creates the necessary directories if it does not exist and returns the path.
-
-(define (launch:test-copy test-src-path test-path)
- (let* ((ovrcmd (let ((cmd (configf:lookup *configdat* "setup" "testcopycmd")))
- (if cmd
- ;; substitute the TEST_SRC_PATH and TEST_TARG_PATH
- (string-substitute "TEST_TARG_PATH" test-path
- (string-substitute "TEST_SRC_PATH" test-src-path cmd #t) #t)
- #f)))
- (cmd (if ovrcmd
- ovrcmd
- (conc "rsync -av" (if (debug:debug-mode 1) "" "q") " " test-src-path "/ " test-path "/"
- " >> " test-path "/mt_launch.log 2>> " test-path "/mt_launch.log")))
- (status (system cmd)))
- (if (not (eq? status 0))
- (debug:print 2 *default-log-port* "ERROR: problem with running \"" cmd "\""))))
-
-
-;; Desired directory structure:
-;;
-;; - - -.
-;; |
-;; v
-;; - - -|-
-;;
-;; dir stored in test is:
-;;
-;; - - [ - ]
-;;
-;; All log file links should be stored relative to the top of link path
-;;
-;; - [ - ]
-;;
-(define (create-work-area run-id run-info keyvals test-id test-src-path disk-path testname itemdat #!key (remtries 2))
- (let* ((item-path (if (string? itemdat) itemdat (item-list->path itemdat))) ;; if pass in string - just use it
- (runname (if (string? run-info) ;; if we pass in a string as run-info use it as run-name.
- run-info
- (db:get-value-by-header (db:get-rows run-info)
- (db:get-header run-info)
- "runname")))
- (contour #f) ;; NOT READY FOR THIS (args:get-arg "-contour"))
- ;; convert back to db: from rdb: - this is always run at server end
- (target (string-intersperse (map cadr keyvals) "/"))
-
- (not-iterated (equal? "" item-path))
-
- ;; all tests are found at /test-base or /test-base
- (testtop-base (conc target "/" runname "/" testname))
- (test-base (conc testtop-base (if not-iterated "" "/") item-path))
-
- ;; nb// if itempath is not "" then it is prefixed with "/"
- (toptest-path (conc disk-path (if contour (conc "/" contour) "") "/" testtop-base))
- (test-path (conc disk-path (if contour (conc "/" contour) "") "/" test-base))
-
- ;; ensure this exists first as links to subtests must be created there
- (linktree (common:get-linktree))
- ;; WAS: (let ((rd (configf:lookup *configdat* "setup" "linktree")))
- ;; (if rd rd (conc *toppath* "/runs"))))
- ;; which seems wrong ...
-
- (lnkbase (conc linktree (if contour (conc "/" contour) "") "/" target "/" runname))
- (lnkpath (conc lnkbase "/" testname))
- (lnkpathf (conc lnkpath (if not-iterated "" "/") item-path))
- (lnktarget (conc lnkpath "/" item-path)))
-
- ;; Update the rundir path in the test record for all, rundir=physical, shortdir=logical
- ;; rundir shortdir
- (rmt:general-call 'test-set-rundir-shortdir run-id lnkpathf test-path testname item-path run-id)
-
- (debug:print 2 *default-log-port* "INFO:\n lnkbase=" lnkbase "\n lnkpath=" lnkpath "\n toptest-path=" toptest-path "\n test-path=" test-path)
- (if (not (common:file-exists? linktree))
- (begin
- (debug:print 0 *default-log-port* "WARNING: linktree did not exist! Creating it now at " linktree)
- (create-directory linktree #t))) ;; (system (conc "mkdir -p " linktree))))
- ;; create the directory for the tests dir links, this is needed no matter what... try up to three times
- (let loop ((done 3))
- (let ((success (if (and (not (common:directory-exists? lnkbase))
- (not (common:file-exists? lnkbase)))
- (handle-exceptions
- exn
- (begin
- (debug:print-error 0 *default-log-port* "Problem creating linktree base at " lnkbase ", exn=" exn)
- (print-error-message exn (current-error-port))
- #t)
- (create-directory lnkbase #t)
- #f))))
- (if (and (not success)(> done 0))
- (loop (- done 1)))))
-
- ;; update the toptest record with its location rundir, cache the path
- ;; This wass highly inefficient, one db write for every subtest, potentially
- ;; thousands of unnecessary updates, cache the fact it was set and don't set it
- ;; again.
-
- ;; Now create the link from the test path to the link tree, however
- ;; if the test is iterated it is necessary to create the parent path
- ;; to the iteration. use pathname-directory to trim the path by one
- ;; level
- (if (not not-iterated) ;; i.e. iterated
- (let ((iterated-parent (pathname-directory (conc lnkpath "/" item-path))))
- (debug:print-info 2 *default-log-port* "Creating iterated parent " iterated-parent)
- (handle-exceptions
- exn
- (begin
- (debug:print-error 0 *default-log-port* " Failed to create directory " iterated-parent ((condition-property-accessor 'exn 'message) exn)
- ", continuing but link tree may be corrupted, exn=" exn)
- #;(exit 1))
- (create-directory iterated-parent #t))))
-
- (if (symbolic-link? lnkpath)
- (handle-exceptions
- exn
- (begin
- (debug:print-error 0 *default-log-port* " Failed to remove symlink " lnkpath ((condition-property-accessor 'exn 'message) exn)
- ", continuing but link tree may be corrupted. exn=" exn)
- #;(exit 1))
- (delete-file lnkpath)))
-
- (if (not (or (common:file-exists? lnkpath)
- (symbolic-link? lnkpath)))
- (handle-exceptions
- exn
- (begin
- (debug:print-error 0 *default-log-port* " Failed to create symlink " lnkpath ((condition-property-accessor 'exn 'message) exn)
- ", continuing but link tree may be corrupted. exn=" exn)
- #;(exit 1))
- (create-symbolic-link toptest-path lnkpath)))
-
- ;; NB - This was not working right - some top tests are not getting the path set!!!
- ;;
- ;; Do the setting of this record after the paths are created so that the shortdir can
- ;; be set to the real directory location. This is safer for future clean up if the link
- ;; tree is damaged or lost.
- ;;
- (if (not (hash-table-ref/default *toptest-paths* testname #f))
- (let* ((testinfo (rmt:get-test-info-by-id run-id test-id)) ;; run-id testname item-path))
- (curr-test-path (if testinfo ;; (filedb:get-path *fdb*
- ;; (db:get-path dbstruct
- ;; (rmt:sdb-qry 'getstr
- (db:test-get-rundir testinfo) ;; ) ;; )
- #f)))
- (hash-table-set! *toptest-paths* testname curr-test-path)
- ;; NB// Was this for the test or for the parent in an iterated test?
- (rmt:general-call 'test-set-rundir-shortdir run-id lnkpath
- (if (common:file-exists? lnkpath)
- ;; (resolve-pathname lnkpath)
- (common:nice-path lnkpath)
- lnkpath)
- testname "" run-id)
- ;; (rmt:general-call 'test-set-rundir run-id lnkpath testname "") ;; toptest-path)
- (if (or (not curr-test-path)
- (not (directory-exists? toptest-path)))
- (begin
- (debug:print-info 2 *default-log-port* "Creating " toptest-path " and link " lnkpath)
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port* "failed to create directory " toptest-path ", exn=" exn)
- #f)
- (create-directory toptest-path #t))
- (hash-table-set! *toptest-paths* testname toptest-path)))))
-
- ;; The toptest path has been created, the link to the test in the linktree has
- ;; been created. Now, if this is an iterated test the real test dir must be created
- (if (not not-iterated) ;; this is an iterated test
- (begin ;; (let ((lnktarget (conc lnkpath "/" item-path)))
- (debug:print 2 *default-log-port* "Setting up sub test run area")
- (debug:print 2 *default-log-port* " - creating run area in " test-path)
- (handle-exceptions
- exn
- (begin
- (debug:print-error 0 *default-log-port* " Failed to create directory " test-path ((condition-property-accessor 'exn 'message) exn)
- ", exiting, exn=" exn)
- (exit 1))
- (create-directory test-path #t))
- (debug:print 2 *default-log-port*
- " - creating link from: " test-path "\n"
- " to: " lnktarget)
-
- ;; If there is already a symlink delete it and recreate it.
- (handle-exceptions
- exn
- (begin
- (debug:print-error 0 *default-log-port* " Failed to re-create link " lnktarget ((condition-property-accessor 'exn 'message) exn) ", exiting, exn=" exn)
- (exit))
- (if (symbolic-link? lnktarget) (delete-file lnktarget))
- (if (not (common:file-exists? lnktarget)) (create-symbolic-link test-path lnktarget)))))
-
- (if (not (directory? test-path))
- (create-directory test-path #t)) ;; this is a hack, I don't know why out of the blue this path does not exist sometimes
-
- (if (and test-src-path (directory? test-path))
- (begin
- (launch:test-copy test-src-path test-path)
- (list lnkpathf lnkpath ))
- (if (and test-src-path (> remtries 0))
- (begin
- (debug:print-error 0 *default-log-port* "Failed to create work area at " test-path " with link at " lnktarget ", remaining attempts " remtries)
- ;;
- (create-work-area run-id run-info keyvals test-id test-src-path disk-path testname itemdat remtries: (- remtries 1)))
- (list #f #f)))))
-
-
-(define (launch:handle-zombie-tests run-id)
- (let* ((key (conc "zombiescan-runid-"run-id))
- (now (current-seconds))
- (threshold (- (current-seconds) (* 2 (or (configf:lookup-number *configdat* "setup" "deadtime") 120))))
- (val (rmt:get-var key))
- (do-scan?
- (cond
- ((not val)
- #t)
- ((< val threshold)
- #t)
- (else #f))))
- (when do-scan?
- (debug:print 1 *default-log-port* "INFO: search and mark zombie tests")
- (rmt:set-var key (current-seconds))
- (rmt:find-and-mark-incomplete run-id #f))))
-
-
-
-
-
-;; 1. look though disks list for disk with most space
-;; 2. create run dir on disk, path name is meaningful
-;; 3. create link from run dir to megatest runs area
-;; 4. remotely run the test on allocated host
-;; - could be ssh to host from hosts table (update regularly with load)
-;; - could be netbatch
-;; (launch-test db (cadr status) test-conf))
-(define (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat params)
- (mutex-lock! *launch-setup-mutex*) ;; setting variables and processing the testconfig is NOT thread-safe, reuse the launch-setup mutex
- (let* ( ;; (lock-key (conc "test-" test-id))
- ;; (got-lock (let loop ((lock (rmt:no-sync-get-lock lock-key))
- ;; (expire-time (+ (current-seconds) 15))) ;; give up on getting the lock and steal it after 15 seconds
- ;; (if (car lock)
- ;; #t
- ;; (if (> (current-seconds) expire-time)
- ;; (begin
- ;; (debug:print-info 0 *default-log-port* "Timed out waiting for a lock to launch test " keyvals " " runname " " test-name " " test-path)
- ;; (rmt:no-sync-del! lock-key) ;; destroy the lock
- ;; (loop (rmt:no-sync-get-lock lock-key) expire-time)) ;;
- ;; (begin
- ;; (thread-sleep! 1)
- ;; (loop (rmt:no-sync-get-lock lock-key) expire-time))))))
- (item-path (item-list->path itemdat))
- (contour #f)) ;; NOT READY FOR THIS (args:get-arg "-contour")))
- (let loop ((delta (- (current-seconds) *last-launch*))
- (launch-delay (configf:lookup-number *configdat* "setup" "launch-delay" default: 0)))
- (if (> launch-delay delta)
- (begin
- (if (common:low-noise-print 1200 "test launch delay") ;; every two hours or so remind the user about launch delay.
- (debug:print-info 0 *default-log-port* "NOTE: test launches are delayed by " launch-delay " seconds. See megatest.config launch-delay setting to adjust.")) ;; launch of " test-name " for " (- launch-delay delta) " seconds"))
- (thread-sleep! (- launch-delay delta))
- (loop (- (current-seconds) *last-launch*) launch-delay))))
- (change-directory *toppath*)
- (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute", *maybe* - the longer they are set the longer each launch takes (must be non-overlapping with the vars)
- (append
- (list
- (list "MT_RUN_AREA_HOME" *toppath*)
- (list "MT_TEST_NAME" test-name)
- (list "MT_RUNNAME" runname)
- (list "MT_ITEMPATH" item-path)
- (list "MT_CONTOUR" contour)
- )
- itemdat))
- (let* ((tregistry (tests:get-all)) ;; third param (below) is system-allowed
- ;; for tconfig, why do we allow fallback to test-conf?
- (tconfig (or (tests:get-testconfig test-name item-path tregistry #t force-create: #t)
- (begin
- (debug:print 0 *default-log-port* "WARNING: falling back to pre-calculated testconfig. This is likely not desired.")
- test-conf))) ;; force re-read now that all vars are set
- (useshell (let ((ush (configf:lookup *configdat* "jobtools" "useshell")))
- (if ush
- (if (equal? ush "no") ;; must use "no" to NOT use shell
- #f
- ush)
- #t))) ;; default is yes
- (runscript (configf:lookup tconfig "setup" "runscript"))
- (ezsteps (> (length (hash-table-ref/default tconfig "ezsteps" '())) 0)) ;; don't send all the steps, could be big, just send a flag
- (subrun (> (length (hash-table-ref/default tconfig "subrun" '())) 0)) ;; send a flag to process a subrun
- ;; (diskspace (configf:lookup tconfig "requirements" "diskspace"))
- ;; (memory (configf:lookup tconfig "requirements" "memory"))
- ;; (hosts (configf:lookup *configdat* "jobtools" "workhosts")) ;; I'm pretty sure this was never completed
- (remote-megatest (configf:lookup *configdat* "setup" "executable"))
- (run-time-limit (or (configf:lookup tconfig "requirements" "runtimelim")
- (configf:lookup *configdat* "setup" "runtimelim")))
- ;; FIXME SOMEDAY: not good how this is so obtuse, this hack is to
- ;; allow running from dashboard. Extract the path
- ;; from the called megatest and convert dashboard
- ;; or dboard to megatest
- (local-megatest (common:find-local-megatest))
- #;(local-megatest (let* ((lm (car (argv)))
- (dir (pathname-directory lm))
- (exe (pathname-strip-directory lm)))
- (conc (if dir (conc dir "/") "")
- (case (string->symbol exe)
- ((dboard) "../megatest")
- ((mtest) "../megatest")
- ((dashboard) "megatest")
- (else exe)))))
- (launcher (common:get-launcher *configdat* test-name item-path)) ;; (configf: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)
- (fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x))))
- (mt-bindir-path #f)
- (testinfo (rmt:get-test-info-by-id run-id test-id))
- (mt_target (string-intersperse (map cadr keyvals) "/"))
- (debug-param (append (if (args:get-arg "-debug") (list "-debug" (args:get-arg "-debug")) '())
- (if (args:get-arg "-logging")(list "-logging") '())
- (if (configf:lookup *configdat* "misc" "profilesw")
- (list (configf:lookup *configdat* "misc" "profilesw"))
- '()))))
- ;; (if hosts (set! hosts (string-split hosts)))
- ;; set the megatest to be called on the remote host
- (if (not remote-megatest)(set! remote-megatest local-megatest)) ;; "megatest"))
- (set! mt-bindir-path (pathname-directory remote-megatest))
- (if launcher (set! launcher (string-split launcher)))
- ;; set up the run work area for this test
- (if (and (args:get-arg "-preclean") ;; user has requested to preclean for this run
- (not (member (db:test-get-rundir testinfo)(list "n/a" "/tmp/badname")))) ;; n/a is a placeholder and thus not a read dir
- (begin
- (debug:print-info 0 *default-log-port* "attempting to preclean directory " (db:test-get-rundir testinfo) " for test " test-name "/" item-path)
- (runs:remove-test-directory testinfo 'remove-data-only))) ;; remove data only, do not perturb the record
-
- ;; prevent overlapping actions - set to LAUNCHED as early as possible
- ;;
- ;; the following call handles waiver propogation. cannot yet condense into roll-up-pass-fail
- (tests:test-set-status! run-id test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED"))
- (rmt:set-state-status-and-roll-up-items run-id test-name item-path #f "LAUNCHED" #f)
- ;; (pp (hash-table->alist tconfig))
- (set! diskpath (get-best-disk *configdat* tconfig))
- (if diskpath
- (let ((dat (create-work-area run-id run-info keyvals test-id test-path diskpath test-name itemdat)))
- (set! work-area (car dat))
- (set! toptest-work-area (cadr dat))
- (debug:print-info 2 *default-log-port* "Using work area " work-area))
- (begin
- (set! work-area (conc test-path "/tmp_run"))
- (create-directory work-area #t)
- (debug:print 0 *default-log-port* "WARNING: No disk work area specified - running in the test directory under tmp_run")))
- (set! cmdparms (base64:base64-encode
- (z3:encode-buffer
- (with-output-to-string
- (lambda () ;; (list 'hosts hosts)
- (write (list (list 'testpath test-path)
- ;; (list 'transport (conc *transport-type*))
- ;; (list 'serverinf *server-info*)
- (list 'homehost (let* ((hhdat (common:get-homehost)))
- (if hhdat
- (car hhdat)
- #f)))
- (list 'serverurl (if *runremote*
- (remote-server-url *runremote*)
- #f)) ;;
- (list 'areaname (common:get-testsuite-name))
- (list 'toppath *toppath*)
- (list 'work-area work-area)
- (list 'test-name test-name)
- (list 'runscript runscript)
- (list 'run-id run-id )
- (list 'test-id test-id )
- ;; (list 'item-path item-path )
- (list 'itemdat itemdat )
- (list 'megatest remote-megatest)
- (list 'ezsteps ezsteps)
- (list 'subrun subrun)
- (list 'target mt_target)
- (list 'contour contour)
- (list 'runtlim (if run-time-limit (common:hms-string->seconds run-time-limit) #f))
- (list 'env-ovrd (hash-table-ref/default *configdat* "env-override" '()))
- (list 'set-vars (if params (hash-table-ref/default params "-setvars" #f)))
- (list 'runname runname)
- (list 'mt-bindir-path mt-bindir-path))))))))
-
- ;; clean out step records from previous run if they exist
- ;; (rmt:delete-test-step-records run-id test-id)
- ;; if the dir does not exist we may have a itempath where individual variables are a path, launch anyway
- (if (common:file-exists? work-area)
- (change-directory work-area)) ;; so that log files from the launch process don't clutter the test dir
- (cond
- ;; ((and launcher hosts) ;; must be using ssh hostname
- ;; (set! fullcmd (append launcher (car hosts)(list remote-megatest "-m" test-sig "-execute" cmdparms) debug-param)))
- ;; (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms))))
- (launcher
- (set! fullcmd (append launcher (list remote-megatest "-m" test-sig "-execute" cmdparms) debug-param)))
- ;; (set! fullcmd (append launcher (list remote-megatest test-sig "-execute" cmdparms))))
- (else
- (if (not useshell)(debug:print 0 *default-log-port* "WARNING: internal launching will not work well without \"useshell yes\" in your [jobtools] section"))
- (set! fullcmd (append (list remote-megatest "-m" test-sig "-execute" cmdparms) debug-param (list (if useshell "&" ""))))))
- ;; (set! fullcmd (list remote-megatest test-sig "-execute" cmdparms (if useshell "&" "")))))
- (if (args:get-arg "-xterm")(set! fullcmd (append fullcmd (list "-xterm"))))
- (debug:print 1 *default-log-port* "Launching " work-area)
- ;; set pre-launch-env-vars before launching, keep the vars in prevvals and put the envionment back when done
- (debug:print 4 *default-log-port* "fullcmd: " fullcmd)
- (set! *last-launch* (current-seconds)) ;; all that junk above takes time, set this as late as possible.
- (let* ((commonprevvals (alist->env-vars
- (hash-table-ref/default *configdat* "env-override" '())))
- (miscprevvals (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute"
- (append (list (list "MT_TEST_RUN_DIR" work-area)
- (list "MT_TEST_NAME" test-name)
- (list "MT_ITEM_INFO" (conc itemdat))
- (list "MT_RUNNAME" runname)
- (list "MT_TARGET" mt_target)
- (list "MT_ITEMPATH" item-path)
- )
- itemdat)))
- (testprevvals (alist->env-vars
- (hash-table-ref/default tconfig "pre-launch-env-overrides" '())))
- ;; Launchwait defaults to true, must override it to turn off wait
- (launchwait (if (equal? (configf:lookup *configdat* "setup" "launchwait") "no") #f #t))
- (launch-results-prev (apply (if launchwait ;; BB: TODO: refactor this to examine return code of launcher, if nonzero, set state to launch failed.
- process:cmd-run-with-stderr-and-exitcode->list
- process-run)
- (if useshell
- (let ((cmdstr (string-intersperse fullcmd " ")))
- (if launchwait
- cmdstr
- (conc cmdstr " >> mt_launch.log 2>&1 &")))
- (car fullcmd))
- (if useshell
- '()
- (cdr fullcmd))))
- (success (if launchwait (equal? 0 (cadr launch-results-prev)) #t))
- (launch-results (if launchwait (car launch-results-prev) launch-results-prev)))
- (if (not success)
- (tests:test-set-status! run-id test-id "COMPLETED" "DEAD" "launcher failed; exited non-zero; check mt_launch.log" #f)) ;; (if launch-results launch-results "FAILED"))
- (mutex-unlock! *launch-setup-mutex*) ;; yes, really should mutex all the way to here. Need to put this entire process into a fork.
- ;; (rmt:no-sync-del! lock-key) ;; release the lock for starting this test
- (if (not launchwait) ;; give the OS a little time to allow the process to start
- (thread-sleep! 0.01))
- (with-output-to-file "mt_launch.log"
- (lambda ()
- (print "LAUNCHCMD: " (string-intersperse fullcmd " "))
- (if (list? launch-results)
- (apply print launch-results)
- (print "NOTE: launched \"" fullcmd "\"\n but did not wait for it to proceed. Add the following to megatest.config \n[setup]\nlaunchwait yes\n if you have problems with this"))
- #:append))
- (debug:print 2 *default-log-port* "Launching completed, updating db")
- (debug:print 2 *default-log-port* "Launch results: " launch-results)
- (if (not launch-results)
- (begin
- (print "ERROR: Failed to run " (string-intersperse fullcmd " ") ", exiting now")
- ;; (sqlite3:finalize! db)
- ;; good ole "exit" seems not to work
- ;; (_exit 9)
- ;; but this hack will work! Thanks go to Alan Post of the Chicken email list
- ;; NB// Is this still needed? Should be safe to go back to "exit" now?
- (process-signal (current-process-id) signal/kill)
- ))
- (alist->env-vars miscprevvals)
- (alist->env-vars testprevvals)
- (alist->env-vars commonprevvals)
- launch-results))
- (change-directory *toppath*)
- (thread-sleep! (configf:lookup-number *configdat* "setup" "inter-test-delay" default: 0.0))))
-
-;; recover a test where the top controlling mtest may have died
-;;
-(define (launch:recover-test run-id test-id)
- ;; this function is called on the test run host via ssh
- ;;
- ;; 1. look at the process from pid
- ;; - is it owned by calling user
- ;; - it it's run directory correct for the test
- ;; - is there a controlling mtest (maybe stuck)
- ;; 2. if recovery is needed watch pid
- ;; - when it exits take the exit code and do the needful
- ;;
- (let* ((pid (rmt:test-get-top-process-pid run-id test-id))
- (psres (with-input-from-pipe
- (conc "ps -F -u " (current-user-name) " | grep -E '" pid " ' | grep -v 'grep -E " pid "'")
- (lambda ()
- (read-line))))
- (rundir (if (string? psres) ;; real process owned by user
- (read-symbolic-link (conc "/proc/" pid "/cwd"))
- #f)))
- ;; 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)))
DELETED lock-queue.scm
Index: lock-queue.scm
==================================================================
--- lock-queue.scm
+++ /dev/null
@@ -1,253 +0,0 @@
-;; Copyright 2006-2013, 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 .
-;;
-
-(use (prefix sqlite3 sqlite3:) srfi-18)
-
-(declare (unit lock-queue))
-(declare (uses common))
-(declare (uses tasks))
-
-;;======================================================================
-;; attempt to prevent overlapping updates of rollup files by queueing
-;; update requests in an sqlite db
-;;======================================================================
-
-;;======================================================================
-;; db record,
-;;======================================================================
-
-(define (make-lock-queue:db-dat)(make-vector 3))
-(define-inline (lock-queue:db-dat-get-db vec) (vector-ref vec 0))
-(define-inline (lock-queue:db-dat-get-path vec) (vector-ref vec 1))
-(define-inline (lock-queue:db-dat-set-db! vec val)(vector-set! vec 0 val))
-(define-inline (lock-queue:db-dat-set-path! vec val)(vector-set! vec 1 val))
-
-(define (lock-queue:delete-lock-db dbdat)
- (let ((fname (lock-queue:db-dat-get-path dbdat)))
- (system (conc "rm -f " fname "*"))))
-
-(define (lock-queue:open-db fname #!key (count 10))
- (let* ((actualfname (conc fname ".lockdb"))
- (dbexists (common:file-exists? actualfname))
- (db (sqlite3:open-database actualfname))
- (handler (make-busy-timeout 136000)))
- (if dbexists
- (vector db actualfname)
- (begin
- (handle-exceptions
- exn
- (begin
- (thread-sleep! 10)
- (if (> count 0)
- (lock-queue:open-db fname count: (- count 1))
- (vector db actualfname)))
- (sqlite3:with-transaction
- db
- (lambda ()
- (sqlite3:execute
- db
- "CREATE TABLE IF NOT EXISTS queue (
- id INTEGER PRIMARY KEY,
- test_id INTEGER,
- start_time INTEGER,
- state TEXT,
- CONSTRAINT queue_constraint UNIQUE (test_id));")
- (sqlite3:execute
- db
- "CREATE TABLE IF NOT EXISTS runlocks (
- id INTEGER PRIMARY KEY,
- test_id INTEGER,
- run_lock TEXT,
- CONSTRAINT runlock_constraint UNIQUE (run_lock));"))))))
- (sqlite3:set-busy-handler! db handler)
- (vector db actualfname)))
-
-(define (lock-queue:set-state dbdat test-id newstate #!key (remtries 10))
- (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200)
- (handle-exceptions
- exn
- (if (> remtries 0)
- (begin
- (debug:print 0 *default-log-port* "WARNING: exception on lock-queue:set-state. Trying again in 30 seconds.")
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (thread-sleep! 30)
- (lock-queue:set-state dbdat test-id newstate remtries: (- remtries 1)))
- (begin
- (debug:print-error 0 *default-log-port* " Failed to set lock state for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.")
- #f))
- (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "UPDATE queue SET state=? WHERE test_id=?;"
- newstate
- test-id)))
-
-(define (lock-queue:any-younger? dbdat mystart test-id #!key (remtries 10))
- ;; no need to wait on journal on read only queries
- ;; (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200)
- (handle-exceptions
- exn
- (if (> remtries 0)
- (begin
- (debug:print 0 *default-log-port* "WARNING: exception on lock-queue:any-younger. Removing lockdb and trying again in 5 seconds.")
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (thread-sleep! 5)
- (lock-queue:delete-lock-db dbdat)
- (lock-queue:any-younger? dbdat mystart test-id remtries: (- remtries 1)))
- (begin
- (debug:print-error 0 *default-log-port* " Failed to find younger locks for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.")
- #f))
- (let ((res #f))
- (sqlite3:for-each-row
- (lambda (tid)
- ;; Actually this should not be needed as mystart cannot be simultaneously less than and test-id same as
- (if (not (equal? tid test-id))
- (set! res tid)))
- (lock-queue:db-dat-get-db dbdat)
- "SELECT test_id FROM queue WHERE start_time > ?;" mystart)
- res)))
-
-(define (lock-queue:get-lock dbdat test-id #!key (count 10)(waiting-msg #f))
- (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 remove: #t waiting-msg: "lock-queue:get-lock, waiting on journal")
- (let* ((res #f)
- (db (lock-queue:db-dat-get-db dbdat))
- (lckqry (sqlite3:prepare db "SELECT test_id,run_lock FROM runlocks WHERE run_lock='locked';"))
- (mklckqry (sqlite3:prepare db "INSERT INTO runlocks (test_id,run_lock) VALUES (?,'locked');")))
- (let ((result
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port* "WARNING: failed to get queue lock. Removing lock db and returning fail") ;; Will try again in a few seconds")
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (thread-sleep! 10)
- ;; (if (> count 0)
- ;; #f ;; (lock-queue:get-lock dbdat test-id count: (- count 1)) - give up on retries
- ;; (begin ;; never recovered, remote the lock file and return #f, no lock obtained
- (lock-queue:delete-lock-db dbdat)
- #f)
- (sqlite3:with-transaction
- db
- (lambda ()
- (sqlite3:for-each-row (lambda (tid lockstate)
- (set! res (list tid lockstate)))
- lckqry)
- (if res
- (if (equal? (car res) test-id)
- #t ;; already have the lock
- #f)
- (begin
- (sqlite3:execute mklckqry test-id)
- ;; if no error handled then return #t for got the lock
- #t)))))))
- (sqlite3:finalize! lckqry)
- (sqlite3:finalize! mklckqry)
- result)))
-
-(define (lock-queue:release-lock fname test-id #!key (count 10))
- (let* ((dbdat (lock-queue:open-db fname)))
- (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 "lock-queue:release-lock; waiting on journal")
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port* "WARNING: Failed to release queue lock. Will try again in few seconds")
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (thread-sleep! (/ count 10))
- (if (> count 0)
- (begin
- (sqlite3:finalize! (lock-queue:db-dat-get-db dbdat))
- (lock-queue:release-lock fname test-id count: (- count 1)))
- (let ((journal (conc fname "-journal")))
- ;; If we've tried ten times and failed there is a serious problem
- ;; try to remove the lock db and allow it to be recreated
- (handle-exceptions
- exn
- #f
- (if (common:file-exists? journal)(delete-file journal))
- (if (common:file-exists? fname) (delete-file fname))
- #f))))
- (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "DELETE FROM runlocks WHERE test_id=?;" test-id)
- (sqlite3:finalize! (lock-queue:db-dat-get-db dbdat)))))
-
-(define (lock-queue:steal-lock dbdat test-id #!key (count 10))
- (debug:print-info 0 *default-log-port* "Attempting to steal lock at " (lock-queue:db-dat-get-path dbdat))
- (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 "lock-queue:steal-lock; waiting on journal")
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port* "WARNING: Failed to steal queue lock. Will try again in few seconds")
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (thread-sleep! 10)
- (if (> count 0)
- (lock-queue:steal-lock dbdat test-id count: (- count 1))
- #f))
- (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "DELETE FROM runlocks WHERE run_lock='locked';"))
- (lock-queue:get-lock dbdat test-it))
-
-;; returns #f if ok to skip the task
-;; returns #t if ok to proceed with task
-;; otherwise waits
-;;
-(define (lock-queue:wait-turn fname test-id #!key (count 10)(waiting-msg #f))
- (let* ((dbdat (lock-queue:open-db fname))
- (mystart (current-seconds))
- (db (lock-queue:db-dat-get-db dbdat)))
- ;; (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 waiting-msg: "lock-queue:wait-turn; waiting on journal file")
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port* "WARNING: Failed to find out if it is ok to skip the wait queue. Will try again in few seconds")
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (print-call-chain (current-error-port))
- (thread-sleep! 10)
- (if (> count 0)
- (begin
- (sqlite3:finalize! db)
- (lock-queue:wait-turn fname test-id count: (- count 1)))
- (begin
- (debug:print 0 *default-log-port* "Giving up calls to lock-queue:wait-turn for test-id " test-id " at path " fname ", printing call chain")
- (print-call-chain (current-error-port))
- #f)))
- ;; wait 10 seconds and then check to see if someone is already updating the html
- (thread-sleep! 10)
- (if (not (lock-queue:any-younger? dbdat mystart test-id)) ;; no processing in flight, must try to start processing
- (begin
- (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 waiting-msg: "lock-queue:wait-turn; waiting on journal file")
- (sqlite3:execute
- db
- "INSERT OR REPLACE INTO queue (test_id,start_time,state) VALUES (?,?,'waiting');"
- test-id mystart)
- ;; (thread-sleep! 1) ;; give other tests a chance to register
- (let ((result
- (let loop ((younger-waiting (lock-queue:any-younger? dbdat mystart test-id)))
- (if younger-waiting
- (begin
- ;; no need for us to wait. mark in the lock queue db as skipping
- ;; no point in marking anything in the queue - simply never register this
- ;; test as it is *covered* by a previously started update to the html file
- ;; (lock-queue:set-state dbdat test-id "skipping")
- #f) ;; let the calling process know that nothing needs to be done
- (if (lock-queue:get-lock dbdat test-id)
- #t
- (if (> (- (current-seconds) mystart) 36000) ;; waited too long, steal the lock
- (lock-queue:steal-lock dbdat test-id)
- (begin
- (thread-sleep! 1)
- (loop (lock-queue:any-younger? dbdat mystart test-id)))))))))
- (sqlite3:finalize! db)
- result))))))
-
-
-;; (use trace)
-;; (trace lock-queue:get-lock lock-queue:release-lock lock-queue:wait-turn lock-queue:any-younger? lock-queue:set-state)
DELETED margs.scm
Index: margs.scm
==================================================================
--- margs.scm
+++ /dev/null
@@ -1,88 +0,0 @@
-;; Copyright 2007-2010, 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 margs))
-;; (declare (uses common))
-
-(define args:arg-hash (make-hash-table))
-
-(define (args:get-arg arg . default)
- (if (null? default)
- (hash-table-ref/default args:arg-hash arg #f)
- (hash-table-ref/default args:arg-hash arg (car default))))
-
-(define (args:any? . args)
- (not (null? (filter (lambda (x) x)
- (map args:get-arg args)))))
-
-(define (args:get-arg-from ht arg . default)
- (if (null? default)
- (hash-table-ref/default ht arg #f)
- (hash-table-ref/default ht arg (car default))))
-
-(define (args:usage . args)
- (if (> (length args) 0)
- (apply print "ERROR: " args))
- (if (string? help)
- (print help)
- (print "Usage: " (car (argv)) " ... "))
- (exit 0))
-
- ;; one-of args defined
-(define (args:any-defined? . param)
- (let ((res #f))
- (for-each
- (lambda (arg)
- (if (args:get-arg arg)(set! res #t)))
- param)
- res))
-
-;; args:
-(define (args:get-args args params switches arg-hash num-needed)
- (let* ((numargs (length args))
- (adj-num-needed (if num-needed (+ num-needed 2) #f)))
- (if (< numargs (if adj-num-needed adj-num-needed 2))
- (if (>= num-needed 1)
- (args:usage "No arguments provided")
- '())
- (let loop ((arg (cadr args))
- (tail (cddr args))
- (remargs '()))
- (cond
- ((member arg params) ;; args with params
- (if (< (length tail) 1)
- (args:usage "param given without argument " arg)
- (let ((val (car tail))
- (newtail (cdr tail)))
- (hash-table-set! arg-hash arg val)
- (if (null? newtail) remargs
- (loop (car newtail)(cdr newtail) remargs)))))
- ((member arg switches) ;; args with no params (i.e. switches)
- (hash-table-set! arg-hash arg #t)
- (if (null? tail) remargs
- (loop (car tail)(cdr tail) remargs)))
- (else
- (if (null? tail)(append remargs (list arg)) ;; return the non-used args
- (loop (car tail)(cdr tail)(append remargs (list arg))))))))
- ))
-
-(define (args:print-args remargs arg-hash)
- (print "ARGS: " remargs)
- (for-each (lambda (arg)
- (print " " arg " " (hash-table-ref/default arg-hash arg #f)))
- (hash-table-keys arg-hash)))
DELETED megatest-version.scm
Index: megatest-version.scm
==================================================================
--- megatest-version.scm
+++ /dev/null
@@ -1,23 +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 .
-
-;; Always use two or four digit decimal
-;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00..
-
-;; (declare (unit megatest-version))
-
-(define megatest-version 1.6583)
DELETED megatest.config
Index: megatest.config
==================================================================
--- megatest.config
+++ /dev/null
@@ -1,74 +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 .
-
-## commented out due to a bug in v1.6501 in mtutil
-## [fields]
-## a text
-## b text
-## c text
-usercode .mtutil.scm
-areafilter area-to-run
-targtrans generic-target-translator
-runtrans generic-runname-translator
-
-[setup]
-pktsdirs /tmp/mt_pkts /some/other/source
-
-[areas]
-# path-to-area map-target-script(future, optional)
-# someqa path=../megatestqa/someqa; targtrans=somefunc; areafilter=area-to-run
-fullrun path=tests/fullrun;
-# targtrans is name of scheme proc stored in .mtutil.scm, which lives in PWD where mtutil is run
-# the target translator can return: a/target OR (list/of targets/to apply/run) OR #f i.e. run nothing
-# ext-tests path=ext-tests; targtrans=prefix-contour;
-ext path=ext-tests
-
-[contours]
-# selector=tag-expr/mode-patt
-quick areas=ext; selector=/QUICKPATT
-quick2 areafn=check-area; selector=/QUICKPATT
-# quick areas=fullrun,ext-tests; selector=QUICKPATT/quick
-# full areas=fullrun,ext-tests; selector=MAXPATT/
-# short areas=fullrun,ext-tests; selector=MAXPATT/
-# all areas=fullrun,ext-tests
-# snazy selector=QUICKPATT/
-
-[nopurpose]
-
-[access]
-ext #{getenv USER}:admin matt:admin mattw:owner
-
-[accesstypes]
-admin run rerun resume remove set-ss rerun-clean
-owner run rerun resume remove rerun-all
-badguy set-ss
-
-[setup]
-maxload 1.2
-
-[listeners]
-localhost:12345 contact=matt@kiatoa.com
-localhost:54321 contact=matt@kiatoa.com
-
-[listener]
-script nbfake echo
-
-
-[server]
-timeout 1
-
-[include local.config]
DELETED megatest.scm
Index: megatest.scm
==================================================================
--- megatest.scm
+++ /dev/null
@@ -1,2554 +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 .
-;;
-
-;; (include "common.scm")
-(include "megatest-version.scm")
-
-;; fake out readline usage of toplevel-command
-(define (toplevel-command . a) #f)
-
-(declare (uses common))
-;; (declare (uses megatest-version))
-(declare (uses margs))
-(declare (uses runs))
-(declare (uses launch))
-(declare (uses server))
-(declare (uses client))
-(declare (uses tests))
-(declare (uses genexample))
-;; (declare (uses daemon))
-(declare (uses db))
-;; (declare (uses dcommon))
-
-(declare (uses tdb))
-(declare (uses mt))
-(declare (uses api))
-(declare (uses tasks)) ;; only used for debugging.
-(declare (uses env))
-(declare (uses diff-report))
-;; (declare (uses ftail))
-;; (import ftail)
-
-(define *db* #f) ;; this is only for the repl, do not use in general!!!!
-
-(include "common_records.scm")
-(include "key_records.scm")
-(include "db_records.scm")
-(include "run_records.scm")
-(include "megatest-fossil-hash.scm")
-
-(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:)
- readline apropos json http-client directory-utils typed-records
- http-client srfi-18 extras format)
-
-;; Added for csv stuff - will be removed
-;;
-(use sparse-vectors)
-
-(require-library mutils)
-
-(define *usage-log-file* #f) ;; put path to file for logging usage in this var in the ~/.megatestrc file
-(define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file
-
-;; load the ~/.megatestrc file, put (use trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file
-;;
-(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc")))
- (if (common:file-exists? debugcontrolf)
- (load debugcontrolf)))
-
-;; usage logging, careful with this, it is not designed to deal with all real world challenges!
-;;
-(if (and *usage-log-file*
- (file-write-access? *usage-log-file*))
- (with-output-to-file
- *usage-log-file*
- (lambda ()
- (print
- (if *usage-use-seconds*
- (current-seconds)
- (time->string
- (seconds->local-time (current-seconds))
- "%Yww%V.%w %H:%M:%S"))
- " "
- (current-user-name) " "
- (current-directory) " "
- "\"" (string-intersperse (argv) " ") "\""))
- #:append))
-
-;; Disabled help items
-;; -rollup : (currently disabled) fill run (set by :runname) with latest test(s)
-;; from prior runs with same keys
-;; -daemonize : fork into background and disconnect from stdin/out
-
-(define help (conc "
-Megatest, documentation at http://www.kiatoa.com/fossils/megatest
- version " megatest-version "
- license GPL, Copyright Matt Welland 2006-2017
-
-Usage: megatest [options]
- -h : this help
- -manual : show the Megatest user manual
- -version : print megatest version (currently " megatest-version ")
-
-Launching and managing runs
- -run : run all tests or as specified by -testpatt
- -remove-runs : remove the data for a run, requires -runname and -testpatt
- Optionally use :state and :status, use -keep-records to remove only
- the run data. Use -kill-wait to override the 10 second
- per test wait after kill delay (e.g. -kill-wait 0).
- -kill-runs : kill existing run(s) (all incomplete tests killed)
- -kill-rerun : kill an existing run (all incomplete tests killed and run is rerun)
- -set-state-status X,Y : set state to X and status to Y, requires controls per -remove-runs
- -rerun FAIL,WARN... : force re-run for tests with specificed status(s)
- -rerun-clean : set all tests not COMPLETED+PASS,WARN,WAIVED to NOT_STARTED,n/a
- and then run the specified testpatt with -preclean
- -rerun-all : set all tests to NOT_STARTED,n/a and run with -preclean
- -lock : lock run specified by target and runname
- -unlock : unlock run specified by target and runname
- -set-run-status status : sets status for run to status, requires -target and -runname
- -get-run-status : gets status for run specified by target and runname
- -run-wait : wait on run specified by target and runname
- -preclean : remove the existing test directory before running the test
- -clean-cache : remove the cached megatest.config and runconfigs.config files
- -no-cache : do not use the cached config files.
- -one-pass : launch as many tests as you can but do not wait for more to be ready
- -remove-keep N : remove all but N most recent runs per target; use '-actions, -age, -precmd'
- -age : 120d,3h,20m to apply only to runs older than the
- specified age. NB// M=month, m=minute
- -actions [,...] : actions to take; print,remove-runs,archive,kill-runs
- -precmd : insert a wrapper command in front of the commands run
-
-Selectors (e.g. use for -runtests, -remove-runs, -set-state-status, -list-runs etc.)
- -target key1/key2/... : run for key1, key2, etc.
- -reqtarg key1/key2/... : run for key1, key2, etc. but key1/key2 must be in runconfigs
- -testpatt patt1/patt2,patt3/... : % is wildcard
- -runname : required, name for this particular test run
- -state : Applies to runs, tests or steps depending on context
- -status : Applies to runs, tests or steps depending on context
- -modepatt key : load testpatt from in runconfigs instead of default TESTPATT if -testpatt and -tagexpr are not specified
- -tagexpr tag1,tag2%,.. : select tests with tags matching expression
-
-
-Test helpers (for use inside tests)
- -step stepname
- -test-status : set the state and status of a test (use :state and :status)
- -setlog logfname : set the path/filename to the final log relative to the test
- directory. may be used with -test-status
- -set-toplog logfname : set the overall log for a suite of sub-tests
- -summarize-items : for an itemized test create a summary html
- -m comment : insert a comment for this test
-
-Test data capture
- -set-values : update or set values in the testdata table
- :category : set the category field (optional)
- :variable : set the variable name (optional)
- :value : value measured (required)
- :expected : value expected (required)
- :tol : |value-expect| <= tol (required, can be <, >, >=, <= or number)
- :units : name of the units for value, expected_value etc. (optional)
- -load-test-data : read test specific data for storage in the test_data table
- from standard in. Each line is comma delimited with four
- fields category,variable,value,comment
-
-Queries
- -list-runs patt : list runs matching pattern \"patt\", % is the wildcard
- -show-keys : show the keys used in this megatest setup
- -test-files targpatt : get the most recent test path/file matching targpatt e.g. %/% or '*.log'
- returns list sorted by age ascending, see examples below
- -test-paths : get the test paths matching target, runname, item and test
- patterns.
- -list-disks : list the disks available for storing runs
- -list-targets : list the targets in runconfigs.config
- -list-db-targets : list the target combinations used in the db
- -show-config : dump the internal representation of the megatest.config file
- -show-runconfig : dump the internal representation of the runconfigs.config file
- -dumpmode MODE : dump in MODE format instead of sexpr, MODE=json,ini,sexp etc. (add -debug 0,9 to see which file contributes each line)
- -show-cmdinfo : dump the command info for a test (run in test environment)
- -section sectionName
- -var varName : for config and runconfig lookup value for sectionName varName
- -since N : get list of runs changed since time N (Unix seconds)
- -fields fieldspec : fields to include in json dump; runs:id,runame+tests:testname+steps
- -sort fieldname : in -list-runs sort tests by this field
- -testdata-csv [categorypatt/]varpatt : dump testdata for given category
-
-Misc
- -start-dir path : switch to this directory before running megatest
- -contour cname : add a level of hierarcy to the linktree and run paths
- -area-tag tagname : add a tag to an area while syncing to pgdb
- -run-tag tagname : add a tag to a run while syncing to pgdb
- -rebuild-db : bring the database schema up to date
- -cleanup-db : remove any orphan records, vacuum the db
- -import-megatest.db : push data from megatest.db to cache db files in /tmp/$USER
- -sync-to-megatest.db : pull data from cache files in /tmp/$USER to megatest.db
- -sync-to dest : sync to new postgresql central style database
- -update-meta : update the tests metadata for all tests
- -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are
- overwritten by values set in config files.
- -server -|hostname : start the server (reduces contention on megatest.db), use
- - to automatically figure out hostname
- -adjutant C,M : start the server/adjutant with allocated cores C and Mem M (Gig),
- use 0,0 to auto use full machine
- -transport http|rpc : use http or rpc for transport (default is http)
- -log logfile : send stdout and stderr to logfile
- -list-servers : list the servers
- -kill-servers : kill all servers
- -repl : start a repl (useful for extending megatest)
- -load file.scm : load and run file.scm
- -mark-incompletes : find and mark incomplete tests
- -ping run-id|host:port : ping server, exit with 0 if found
- -debug N|N,M,O... : enable debug 0-N or N and M and O ...
- -debug-noprop N|M,M,O...: enable debug but do not propagate to subprocesses via MT_DEBUG
- -config fname : override the megatest.config file with fname
- -append-config fname : append fname to the megatest.config file
-
-Utilities
- -env2file fname : write the environment to fname.csh and fname.sh
- -envcap a : save current variables labeled as context 'a' in file envdat.db
- -envdelta a-b : output enviroment delta from context a to context b to -o fname
- set the output mode with -dumpmode csh, bash or ini
- note: ini format will use calls to use curr and minimize path
- -refdb2dat refdb : convert refdb to sexp or to format specified by s-dumpmode
- formats: perl, ruby, sqlite3, csv (for csv the -o param
- will substitute %s for the sheet name in generating
- multiple sheets)
- -o : output file for refdb2dat (defaults to stdout)
- -archive cmd : archive runs specified by selectors to one of disks specified
- in the [archive-disks] section.
- cmd: keep-html, restore, save, save-remove, get, replicate-db (use
- -dest to set destination), -include path1,path2... to get or save specific files
- -generate-html : create a simple html dashboard for browsing your runs
- -generate-html-structure : create a top level html veiw to list targets/runs and a Run view within each run directory.
- -list-run-time : list time requered to complete runs. It supports following switches
- -run-patt -target-patt -dumpmode
- -list-test-time : list time requered to complete each test in a run. It following following arguments
- -runname -target -dumpmode
- -syscheck : do some very basic checks; write access and space in tmp, home, runs, links and
- is $DISPLAY valid
- -list-waivers : dump waivers for specified target, runname, testpatt to stdout
-
-Diff report
- -diff-rep : generate diff report (must include -src-target, -src-runname, -target, -runname
- and either -diff-email or -diff-html)
- -src-target
- -src-runname
- -diff-email : comma separated list of email addresses to send diff report
- -diff-html : path to html file to generate
-
-Spreadsheet generation
- -extract-ods fname.ods : extract an open document spreadsheet from the database
- -pathmod path : insert path, i.e. path/runame/itempath/logfile.html
- will clear the field if no rundir/testname/itempath/logfile
- if it contains forward slashes the path will be converted
- to windows style
-Getting started
- -create-megatest-area : create a skeleton megatest area. You will be prompted for paths
- -create-test testname : create a skeleton megatest test. You will be prompted for info
-
-Examples
-
-# Get test path, use '.' to get a single path or a specific path/file pattern
-megatest -test-files 'logs/*.log' -target ubuntu/n%/no% -runname w49% -testpatt test_mt%
-
-Called as " (string-intersperse (argv) " ") "
-Version " megatest-version ", built from " megatest-fossil-hash ))
-
-;; -gui : start a gui interface
-;; -config fname : override the runconfigs file with fname
-
-;; process args
-(define remargs (args:get-args
- (argv)
- (list "-runtests" ;; run a specific test
- "-config" ;; override the config file name
- "-append-config"
- "-execute" ;; run the command encoded in the base64 parameter
- "-step"
- "-target"
- "-reqtarg"
- ":runname"
- "-runname"
- ":state"
- "-state"
- ":status"
- "-status"
- "-list-runs"
- "-testdata-csv"
- "-testpatt"
- "--modepatt"
- "-modepatt"
- "-tagexpr"
- "-itempatt"
- "-setlog"
- "-set-toplog"
- "-runstep"
- "-logpro"
- "-m"
- "-rerun"
-
- "-days"
- "-rename-run"
- "-to"
- "-dest"
- "-source"
- "-time-stamp"
- ;; values and messages
- ":category"
- ":variable"
- ":value"
- ":expected"
- ":tol"
- ":units"
-
- ;; misc
- "-start-dir"
- "-run-patt"
- "-target-patt"
- "-contour"
- "-area-tag"
- "-area"
- "-run-tag"
- "-server"
- "-adjutant"
- "-transport"
- "-port"
- "-extract-ods"
- "-pathmod"
- "-env2file"
- "-envcap"
- "-envdelta"
- "-setvars"
- "-set-state-status"
-
- ;; move runs stuff here
- "-remove-keep"
- "-set-run-status"
- "-age"
-
- ;; archive
- "-archive"
- "-actions"
- "-precmd"
- "-include"
- "-exclude-rx"
- "-exclude-rx-from"
-
- "-debug" ;; for *verbosity* > 2
- "-debug-noprop"
- "-create-test"
- "-override-timeout"
- "-test-files" ;; -test-paths is for listing all
- "-load" ;; load and exectute a scheme file
- "-section"
- "-var"
- "-dumpmode"
- "-run-id"
- "-ping"
- "-refdb2dat"
- "-o"
- "-log"
- "-sync-log"
- "-since"
- "-fields"
- "-recover-test" ;; run-id,test-id - used internally to recover a test stuck in RUNNING state
- "-sort"
- "-target-db"
- "-source-db"
- "-prefix-target"
-
- "-src-target"
- "-src-runname"
- "-diff-email"
- "-sync-to"
- "-pgsync"
- "-kill-wait" ;; wait this long before removing test (default is 10 sec)
- "-diff-html"
-
- ;; wizards, area capture, setup new ...
- "-extract-skeleton"
- )
- (list "-h" "-help" "--help"
- "-manual"
- "-version"
- "-force"
- "-xterm"
- "-showkeys"
- "-show-keys"
- "-test-status"
- "-set-values"
- "-load-test-data"
- "-summarize-items"
- "-gui"
- "-daemonize"
- "-preclean"
- "-rerun-clean"
- "-rerun-all"
- "-clean-cache"
- "-no-cache"
- "-cache-db"
- "-cp-eventtime-to-publishtime"
- "-use-db-cache"
- "-prepend-contour"
-
-
- ;; misc
- "-repl"
- "-lock"
- "-unlock"
- "-list-servers"
- "-kill-servers"
- "-run-wait" ;; wait on a run to complete (i.e. no RUNNING)
- "-one-pass" ;;
- "-local" ;; run some commands using local db access
- "-generate-html"
- "-generate-html-structure"
- "-list-run-time"
- "-list-test-time"
-
- ;; misc queries
- "-list-disks"
- "-list-targets"
- "-list-db-targets"
- "-show-runconfig"
- "-show-config"
- "-show-cmdinfo"
- "-get-run-status"
- "-list-waivers"
-
- ;; queries
- "-test-paths" ;; get path(s) to a test, ordered by youngest first
-
- "-runall" ;; run all tests, respects -testpatt, defaults to %
- "-run" ;; alias for -runall
- "-remove-runs"
- "-kill-runs"
- "-kill-rerun"
- "-keep-records" ;; use with -remove-runs to remove only the run data
- "-rebuild-db"
- "-cleanup-db"
- "-rollup"
- "-update-meta"
- "-create-megatest-area"
- "-mark-incompletes"
-
- "-convert-to-norm"
- "-convert-to-old"
- "-import-megatest.db"
- "-sync-to-megatest.db"
- "-sync-brute-force"
- "-logging"
- "-v" ;; verbose 2, more than normal (normal is 1)
- "-q" ;; quiet 0, errors/warnings only
-
- "-diff-rep"
-
- "-syscheck"
- "-obfuscate"
- ;; junk placeholder
- ;; "-:p"
-
- )
- args:arg-hash
- 0))
-
-;; Add args that use remargs here
-;;
-(if (and (not (null? remargs))
- (not (or
- (args:get-arg "-runstep")
- (args:get-arg "-envcap")
- (args:get-arg "-envdelta")
- )
- ))
- (debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " ")))
-
-;; before doing anything else change to the start-dir if provided
-;;
-(if (args:get-arg "-start-dir")
- (if (common:file-exists? (args:get-arg "-start-dir"))
- (let ((fullpath (common:real-path (args:get-arg "-start-dir"))))
- (setenv "PWD" fullpath)
- (change-directory fullpath))
- (begin
- (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.")
- (exit 1))))
-
-;; immediately set MT_TARGET if -reqtarg or -target are available
-;;
-(let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target"))))
- (if targ (setenv "MT_TARGET" targ)))
-
-;; The watchdog is to keep an eye on things like db sync etc.
-;;
-
-;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
-(define *watchdog* (make-thread
- (lambda ()
- (handle-exceptions
- exn
- (begin
- (print-call-chain)
- (print " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn))
- (common:watchdog)))
- "Watchdog thread"))
-
-;;(if (not (args:get-arg "-server"))
-;; (thread-start! *watchdog*)) ;; if starting a server; wait till we get to running state before kicking off watchdog
-(let* ((no-watchdog-args
- '("-list-runs"
- "-testdata-csv"
- "-list-servers"
- "-server"
- "-adjutant"
- "-list-disks"
- "-list-targets"
- "-show-runconfig"
- ;;"-list-db-targets"
- "-show-runconfig"
- "-show-config"
- "-show-cmdinfo"
- "-cleanup-db"
- ))
- (no-watchdog-argvals (list '("-archive" . "replicate-db")))
- (start-watchdog-specail-arg-val (let loop ((hed (car no-watchdog-argvals))
- (tail (cdr no-watchdog-argvals)))
- ;; (print "hed" hed " arg " (args:get-arg (car hed)) " val:" (cdr hed) " eql" (equal? (args:get-arg (car hed)) (cdr hed)))
- (if (equal? (args:get-arg (car hed)) (cdr hed))
- #f
- (if (null? tail)
- #t
- (loop (car tail) (cdr tail))))))
- (no-watchdog-args-vals (filter (lambda (x) x)
- (map args:get-arg no-watchdog-args)))
- (start-watchdog (and (null? no-watchdog-args-vals) start-watchdog-specail-arg-val)))
- ;(print "no-watchdog-args="no-watchdog-args "no-watchdog-args-vals="no-watchdog-args-vals " start-watchdog-specail-arg-val:" start-watchdog-specail-arg-val " start-watchdog:" start-watchdog)
- (if start-watchdog
- (thread-start! *watchdog*)))
-
-
-;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions
-(define (open-logfile logpath-in)
- (condition-case
- (let* ((log-dir (or (pathname-directory logpath-in) "."))
- (fname (pathname-strip-directory logpath-in))
- (logpath (if (> (string-length fname) 250)
- (let ((newlogf (conc log-dir "/" (common:get-signature fname) ".log")))
- (debug:print 0 *default-log-port* "WARNING: log file " logpath-in " path too long, converted to " newlogf)
- newlogf)
- logpath-in)))
- (if (not (directory-exists? log-dir))
- (system (conc "mkdir -p " log-dir)))
- (open-output-file logpath))
- (exn ()
- (debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath)
- (define *didsomething* #t)
- (exit 1))))
-
-;; this segment will run launch:setup only if -log is not set. This is fairly safe as servers are not
-;; manually started and thus should never be started in a non-megatest area. Thus no need to handle situation
-;; where (launch:setup) returns #f?
-;;
-(if (or (args:get-arg "-log")(args:get-arg "-server")) ;; redirect the log always when a server
- (handle-exceptions
- exn
- (begin
- (print "ERROR: Failed to switch to log output. " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
- )
- (let* ((tl (or (args:get-arg "-log")(launch:setup))) ;; run launch:setup if -server, ensure we do NOT run launch:setup if -log specified
- (logf (or (args:get-arg "-log") ;; use -log unless we are a server, then craft a logfile name
- (conc tl "/logs/server-" (current-process-id) "-" (get-host-name) ".log")))
- (oup (open-logfile logf)))
- (if (not (args:get-arg "-log"))
- (hash-table-set! args:arg-hash "-log" logf)) ;; fake out future queries of -log
- (debug:print-info 0 *default-log-port* "Sending log output to " logf)
- (set! *default-log-port* oup))))
-
-(if (or (args:get-arg "-h")
- (args:get-arg "-help")
- (args:get-arg "--help"))
- (begin
- (print help)
- (exit)))
-
-(if (args:get-arg "-manual")
- (let* ((htmlviewercmd (or (configf:lookup *configdat* "setup" "htmlviewercmd")
- (common:which '("firefox" "arora"))))
- (install-home (common:get-install-area))
- (manual-html (conc install-home "/share/docs/megatest_manual.html")))
- (if (and install-home
- (common:file-exists? manual-html))
- (system (conc "(" htmlviewercmd " " manual-html " ) &"))
- (system (conc "(" htmlviewercmd " http://www.kiatoa.com/cgi-bin/fossils/megatest/doc/tip/docs/manual/megatest_manual.html ) &")))
- (exit)))
-
-(if (args:get-arg "-version")
- (begin
- (print (common:version-signature)) ;; (print megatest-version)
- (exit)))
-
-(define *didsomething* #f)
-
-;; Overall exit handling setup immediately
-;;
-(if (or (args:get-arg "-process-reap"))
- ;; (args:get-arg "-runtests")
- ;; (args:get-arg "-execute")
- ;; (args:get-arg "-remove-runs")
- ;; (args:get-arg "-runstep"))
- (let ((original-exit (exit-handler)))
- (exit-handler (lambda (#!optional (exit-code 0))
- (printf "Preparing to exit with exit code ~A ...\n" exit-code)
- (for-each
-
- (lambda (pid)
- (handle-exceptions
- exn
- (begin
- (printf "process reap failed. exn=~A\n" exn)
- #t)
- (let-values (((pid-val exit-status exit-code) (process-wait pid #t)))
- (if (or (eq? pid-val pid)
- (eq? pid-val 0))
- (begin
- (printf "Sending signal/term to ~A\n" pid)
- (process-signal pid signal/term))))))
- (process:children #f))
- (original-exit exit-code)))))
-
-;; for some switches always print the command to stderr
-;;
-(if (args:any? "-run" "-runall" "-remove-runs" "-set-state-status" "-kill-runs" "-kill-rerun")
- (debug:print 0 *default-log-port* (string-intersperse (argv) " ")))
-
-;; some switches imply homehost. Exit here if not on homehost
-;;
-(let ((homehost-required (list "-cleanup-db" "-server")))
- (if (apply args:any? homehost-required)
- (if (not (common:on-homehost?))
- (for-each
- (lambda (switch)
- (if (args:get-arg switch)
- (begin
- (debug:print 0 *default-log-port* "ERROR: you must be on the homehost to run with " switch
- ", you can move homehost by removing the .homehost file but this will disrupt any runs in progress.")
- (exit 1))))
- homehost-required))))
-
-;;======================================================================
-;; Misc setup stuff
-;;======================================================================
-
-(debug:setup)
-
-(if (args:get-arg "-logging")(set! *logging* #t))
-
-;;(if (debug:debug-mode 3) ;; we are obviously debugging
-;; (set! open-run-close open-run-close-no-exception-handling))
-
-(if (args:get-arg "-itempatt")
- (let ((newval (conc (args:get-arg "-testpatt") "/" (args:get-arg "-itempatt"))))
- (debug:print 0 *default-log-port* "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval)
- (hash-table-set! args:arg-hash "-testpatt" newval)
- (hash-table-delete! args:arg-hash "-itempatt")))
-
-(if (args:get-arg "-runtests")
- (debug:print 0 *default-log-port* "WARNING: \"-runtests\" is deprecated. Use \"-run\" with \"-testpatt\" instead"))
-
-(on-exit std-exit-procedure)
-
-;;======================================================================
-;; Misc general calls
-;;======================================================================
-
-(if (and (args:get-arg "-cache-db")
- (args:get-arg "-source-db"))
- (let* ((temp-dir (or (args:get-arg "-target-db") (create-directory (conc "/tmp/" (getenv "USER") "/" (string-translate (current-directory) "/" "_")))))
- (target-db (conc temp-dir "/cached.db"))
- (source-db (args:get-arg "-source-db")))
- (db:cache-for-read-only source-db target-db)
- (set! *didsomething* #t)))
-
-;; handle a clean-cache request as early as possible
-;;
-(if (args:get-arg "-clean-cache")
- (let ((toppath (launch:setup)))
- (set! *didsomething* #t) ;; suppress the help output.
- (runs:clean-cache (common:args-get-target)
- (args:get-arg "-runname")
- toppath)))
-
-(if (args:get-arg "-env2file")
- (begin
- (save-environment-as-files (args:get-arg "-env2file"))
- (set! *didsomething* #t)))
-
-(if (args:get-arg "-list-disks")
- (let ((toppath (launch:setup)))
- (print
- (string-intersperse
- (map (lambda (x)
- (string-intersperse
- x
- " => "))
- (common:get-disks *configdat*))
- "\n"))
- (set! *didsomething* #t)))
-
-;; csv processing record
-(define (make-refdb:csv)
- (vector
- (make-sparse-array)
- (make-hash-table)
- (make-hash-table)
- 0
- 0))
-(define-inline (refdb:csv-get-svec vec) (vector-ref vec 0))
-(define-inline (refdb:csv-get-rows vec) (vector-ref vec 1))
-(define-inline (refdb:csv-get-cols vec) (vector-ref vec 2))
-(define-inline (refdb:csv-get-maxrow vec) (vector-ref vec 3))
-(define-inline (refdb:csv-get-maxcol vec) (vector-ref vec 4))
-(define-inline (refdb:csv-set-svec! vec val)(vector-set! vec 0 val))
-(define-inline (refdb:csv-set-rows! vec val)(vector-set! vec 1 val))
-(define-inline (refdb:csv-set-cols! vec val)(vector-set! vec 2 val))
-(define-inline (refdb:csv-set-maxrow! vec val)(vector-set! vec 3 val))
-(define-inline (refdb:csv-set-maxcol! vec val)(vector-set! vec 4 val))
-
-(define (get-dat results sheetname)
- (or (hash-table-ref/default results sheetname #f)
- (let ((tmp-vec (make-refdb:csv)))
- (hash-table-set! results sheetname tmp-vec)
- tmp-vec)))
-
-(if (args:get-arg "-refdb2dat")
- (let* ((input-db (args:get-arg "-refdb2dat"))
- (out-file (args:get-arg "-o"))
- (out-fmt (or (args:get-arg "-dumpmode") "scheme"))
- (out-port (if (and out-file
- (not (member out-fmt '("sqlite3" "csv"))))
- (open-output-file out-file)
- (current-output-port)))
- (res-data (configf:read-refdb input-db))
- (data (car res-data))
- (msg (cadr res-data)))
- (if (not data)
- (debug:print 0 *default-log-port* "Bad input? data=" data) ;; some error occurred
- (with-output-to-port out-port
- (lambda ()
- (case (string->symbol out-fmt)
- ((scheme)(pp data))
- ((perl)
- ;; (print "%hash = (")
- ;; key1 => 'value1',
- ;; key2 => 'value2',
- ;; key3 => 'value3',
- ;; );
- (configf:map-all-hier-alist
- data
- (lambda (sheetname sectionname varname val)
- (print "$data{\"" sheetname "\"}{\"" sectionname "\"}{\"" varname "\"} = \"" val "\";"))))
- ((python ruby)
- (print "data={}")
- (configf:map-all-hier-alist
- data
- (lambda (sheetname sectionname varname val)
- (print "data[\"" sheetname "\"][\"" sectionname "\"][\"" varname "\"] = \"" val "\""))
- initproc1:
- (lambda (sheetname)
- (print "data[\"" sheetname "\"] = {}"))
- initproc2:
- (lambda (sheetname sectionname)
- (print "data[\"" sheetname "\"][\"" sectionname "\"] = {}"))))
- ((csv)
- (let* ((results (make-hash-table)) ;; (make-sparse-array)))
- (row-cols (make-hash-table))) ;; hash of hashes where section => ht { row- => num or col- => num
- ;; (print "data=")
- ;; (pp data)
- (configf:map-all-hier-alist
- data
- (lambda (sheetname sectionname varname val)
- ;; (print "sheetname: " sheetname ", sectionname: " sectionname ", varname: " varname ", val: " val)
- (let* ((dat (get-dat results sheetname))
- (vec (refdb:csv-get-svec dat))
- (rownames (refdb:csv-get-rows dat))
- (colnames (refdb:csv-get-cols dat))
- (currrown (hash-table-ref/default rownames varname #f))
- (currcoln (hash-table-ref/default colnames sectionname #f))
- (rown (or currrown
- (let* ((lastn (refdb:csv-get-maxrow dat))
- (newrown (+ lastn 1)))
- (refdb:csv-set-maxrow! dat newrown)
- newrown)))
- (coln (or currcoln
- (let* ((lastn (refdb:csv-get-maxcol dat))
- (newcoln (+ lastn 1)))
- (refdb:csv-set-maxcol! dat newcoln)
- newcoln))))
- (if (not (sparse-array-ref vec 0 coln)) ;; (eq? rown 0)
- (begin
- (sparse-array-set! vec 0 coln sectionname)
- ;; (print "sparse-array-ref " 0 "," coln "=" (sparse-array-ref vec 0 coln))
- ))
- (if (not (sparse-array-ref vec rown 0)) ;; (eq? coln 0)
- (begin
- (sparse-array-set! vec rown 0 varname)
- ;; (print "sparse-array-ref " rown "," 0 "=" (sparse-array-ref vec rown 0))
- ))
- (if (not currrown)(hash-table-set! rownames varname rown))
- (if (not currcoln)(hash-table-set! colnames sectionname coln))
- ;; (print "dat=" dat ", rown=" rown ", coln=" coln)
- (sparse-array-set! vec rown coln val)
- ;; (print "sparse-array-ref " rown "," coln "=" (sparse-array-ref vec rown coln))
- )))
- (for-each
- (lambda (sheetname)
- (let* ((sheetdat (get-dat results sheetname))
- (svec (refdb:csv-get-svec sheetdat))
- (maxrow (refdb:csv-get-maxrow sheetdat))
- (maxcol (refdb:csv-get-maxcol sheetdat))
- (fname (if out-file
- (string-substitute "%s" sheetname out-file) ;; "/foo/bar/%s.csv")
- (conc sheetname ".csv"))))
- (with-output-to-file fname
- (lambda ()
- ;; (print "Sheetname: " sheetname)
- (let loop ((row 0)
- (col 0)
- (curr-row '())
- (result '()))
- (let* ((val (sparse-array-ref svec row col))
- (disp-val (if val
- (conc "\"" val "\"")
- "")))
- (if (> col 0)(display ","))
- (display disp-val)
- (cond
- ((> row maxrow)(display "\n") result)
- ((>= col maxcol)
- (display "\n")
- (loop (+ row 1) 0 '() (append result (list curr-row))))
- (else
- (loop row (+ col 1) (append curr-row (list val)) result)))))))))
- (hash-table-keys results))))
- ((sqlite3)
- (let* ((db-file (or out-file (pathname-file input-db)))
- (db-exists (common:file-exists? db-file))
- (db (sqlite3:open-database db-file)))
- (if (not db-exists)(sqlite3:execute db "CREATE TABLE data (sheet,section,var,val);"))
- (configf:map-all-hier-alist
- data
- (lambda (sheetname sectionname varname val)
- (sqlite3:execute db
- "INSERT OR REPLACE INTO data (sheet,section,var,val) VALUES (?,?,?,?);"
- sheetname sectionname varname val)))
- (sqlite3:finalize! db)))
- (else
- (pp data))))))
- (if out-file (close-output-port out-port))
- (exit) ;; yes, bending the rules here - need to exit since this is a utility
- ))
-
-(if (args:get-arg "-ping")
- (let* ((server-id (string->number (args:get-arg "-ping"))) ;; extract run-id (i.e. no ":"
- (host:port (args:get-arg "-ping")))
- (server:ping (or server-id host:port) #f do-exit: #t)))
-
-;;======================================================================
-;; Capture, save and manipulate environments
-;;======================================================================
-
-;; NOTE: Keep these above the section where the server or client code is setup
-
-(let ((envcap (args:get-arg "-envcap")))
- (if envcap
- (let* ((db (env:open-db (if (null? remargs) "envdat.db" (car remargs)))))
- (env:save-env-vars db envcap)
- (env:close-database db)
- (set! *didsomething* #t))))
-
-;; delta "language" will eventually be res=a+b-c but for now it is just res=a-b
-;;
-(let ((envdelta (args:get-arg "-envdelta")))
- (if envdelta
- (let ((match (string-split envdelta "-")));; (string-match "([a-z0-9_]+)=([a-z0-9_\\-,]+)" envdelta)))
- (if (not (null? match))
- (let* ((db (env:open-db (if (null? remargs) "envdat.db" (car remargs))))
- ;; (resctx (cadr match))
- ;; (equn (caddr match))
- (parts match) ;; (string-split equn "-"))
- (minuend (car parts))
- (subtraend (cadr parts))
- (added (env:get-added db minuend subtraend))
- (removed (env:get-removed db minuend subtraend))
- (changed (env:get-changed db minuend subtraend)))
- ;; (pp (hash-table->alist added))
- ;; (pp (hash-table->alist removed))
- ;; (pp (hash-table->alist changed))
- (if (args:get-arg "-o")
- (with-output-to-file
- (args:get-arg "-o")
- (lambda ()
- (env:print added removed changed)))
- (env:print added removed changed))
- (env:close-database db)
- (set! *didsomething* #t))
- (debug:print-error 0 *default-log-port* "Parameter to -envdelta should be new=start-end")))))
-
-;;======================================================================
-;; Start the server - can be done in conjunction with -runall or -runtests (one day...)
-;; we start the server if not running else start the client thread
-;;======================================================================
-
-;; Server? Start up here.
-;;
-(if (args:get-arg "-server")
- (let ((tl (launch:setup))
- (transport-type (string->symbol (or (args:get-arg "-transport") "http"))))
- (server:launch 0 transport-type)
- (set! *didsomething* #t)))
-
-;; The adjutant is a bit different, it does NOT run (launch:setup) as it is not necessarily tied to
-;; a specific Megatest area. Detail are being hashed out and this may change.
-;;
-(if (args:get-arg "-adjutant")
- (begin
- (adjutant-run)
- (set! *didsomething* #t)))
-
-(if (or (args:get-arg "-list-servers")
- (args:get-arg "-kill-servers"))
- (let ((tl (launch:setup)))
- (if tl ;; all roads from here exit
- (let* ((servers (server:get-list *toppath*))
- (fmtstr "~8a~22a~20a~20a~8a\n"))
- (format #t fmtstr "pid" "Interface:port" "age (hms)" "Last mod" "State")
- (format #t fmtstr "===" "==============" "=========" "========" "=====")
- (for-each ;; ( mod-time host port start-time pid )
- (lambda (server)
- (let* ((mtm (any->number (car server)))
- (mod (if mtm (- (current-seconds) mtm) "unk"))
- (age (- (current-seconds)(or (any->number (list-ref server 3)) (current-seconds))))
- (url (conc (cadr server) ":" (caddr server)))
- (pid (list-ref server 4))
- (alv (if (number? mod)(< mod 10) #f)))
- (format #t
- fmtstr
- pid
- url
- (seconds->hr-min-sec age)
- (seconds->hr-min-sec mod)
- (if alv "alive" "dead"))
- (if (and alv
- (args:get-arg "-kill-servers"))
- (begin
- (debug:print-info 0 *default-log-port* "Attempting to kill server with pid " pid)
- (server:kill server)))))
- (sort servers (lambda (a b)
- (let ((ma (or (any->number (car a)) 9e9))
- (mb (or (any->number (car b)) 9e9)))
- (> ma mb)))))
- ;; (debug:print-info 1 *default-log-port* "Done with listservers")
- (set! *didsomething* #t)
- (exit))
- (exit))))
- ;; must do, would have to add checks to many/all calls below
-
-;;======================================================================
-;; Weird special calls that need to run *after* the server has started?
-;;======================================================================
-
-(if (args:get-arg "-list-targets")
- (if (launch:setup)
- (let ((targets (common:get-runconfig-targets)))
- ;; (debug:print 1 *default-log-port* "Found "(length targets) " targets")
- (case (string->symbol (or (args:get-arg "-dumpmode") "alist"))
- ((alist)
- (for-each (lambda (x)
- ;; (print "[" x "]"))
- (print x))
- targets))
- ((json)
- (json-write targets))
- (else
- (debug:print-error 0 *default-log-port* "dump output format " (args:get-arg "-dumpmode") " not supported for -list-targets")))
- (set! *didsomething* #t))))
-
-;; cache the runconfigs in $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME/.runconfig
-;;
-(define (full-runconfigs-read)
-;; in the envprocessing branch the below code replaces the further below code
-;; (if (eq? *configstatus* 'fulldata)
-;; *runconfigdat*
-;; (begin
-;; (launch:setup)
-;; *runconfigdat*)))
-
- (let* ((rundir (if (and (getenv "MT_LINKTREE")(getenv "MT_TARGET")(getenv "MT_RUNNAME"))
- (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME"))
- #f))
- (cfgf (if rundir (conc rundir "/.runconfig." megatest-version "-" megatest-fossil-hash) #f)))
- (if (and cfgf
- (common:file-exists? cfgf)
- (file-write-access? cfgf)
- (common:use-cache?))
- (configf:read-alist cfgf)
- (let* ((keys (rmt:get-keys))
- (target (common:args-get-target))
- (key-vals (if target (keys:target->keyval keys target) #f))
- (sections (if target (list "default" target) #f))
- (data (begin
- (setenv "MT_RUN_AREA_HOME" *toppath*)
- (if key-vals
- (for-each (lambda (kt)
- (setenv (car kt) (cadr kt)))
- key-vals))
- ;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections))))
- (runconfig:read (conc *toppath* "/runconfigs.config") target #f))))
- (if (and rundir ;; have all needed variabless
- (directory-exists? rundir)
- (file-write-access? rundir))
- (begin
- (if (not (common:in-running-test?))
- (configf:write-alist data cfgf))
- ;; force re-read of megatest.config - this resolves circular references between megatest.config
- (launch:setup force-reread: #t)
- ;; (launch:cache-config) ;; there are two independent config cache locations, turning this one off for now. MRW.
- )) ;; we can safely cache megatest.config since we have a valid runconfig
- data))))
-
-(if (args:get-arg "-show-runconfig")
- (let ((tl (launch:setup)))
- (push-directory *toppath*)
- (let ((data (full-runconfigs-read)))
- ;; keep this one local
- (cond
- ((and (args:get-arg "-section")
- (args:get-arg "-var"))
- (let ((val (or (configf:lookup data (args:get-arg "-section")(args:get-arg "-var"))
- (configf:lookup data "default" (args:get-arg "-var")))))
- (if val (print val))))
- ((or (not (args:get-arg "-dumpmode"))
- (string=? (args:get-arg "-dumpmode") "ini"))
- (configf:config->ini data))
- ((string=? (args:get-arg "-dumpmode") "sexp")
- (pp (hash-table->alist data)))
- ((string=? (args:get-arg "-dumpmode") "json")
- (json-write data))
- (else
- (debug:print-error 0 *default-log-port* "-dumpmode of " (args:get-arg "-dumpmode") " not recognised")))
- (set! *didsomething* #t))
- (pop-directory)))
-
-(if (args:get-arg "-show-config")
- (let ((tl (launch:setup))
- (data *configdat*)) ;; (read-config "megatest.config" #f #t)))
- (push-directory *toppath*)
- ;; keep this one local
- (cond
- ((and (args:get-arg "-section")
- (args:get-arg "-var"))
- (let ((val (configf:lookup data (args:get-arg "-section")(args:get-arg "-var"))))
- (if val (print val))))
-
- ;; print just a section if only -section
-
- ((equal? (args:get-arg "-dumpmode") "sexp")
- (pp (hash-table->alist data)))
- ((equal? (args:get-arg "-dumpmode") "json")
- (json-write data))
- ((or (not (args:get-arg "-dumpmode"))
- (string=? (args:get-arg "-dumpmode") "ini"))
- (configf:config->ini data))
- (else
- (debug:print-error 0 *default-log-port* "-dumpmode of " (args:get-arg "-dumpmode") " not recognised")))
- (set! *didsomething* #t)
- (pop-directory)
- (set! *time-to-exit* #t)))
-
-(if (args:get-arg "-show-cmdinfo")
- (if (or (args:get-arg ":value")(getenv "MT_CMDINFO"))
- (let ((data (common:read-encoded-string (or (args:get-arg ":value")(getenv "MT_CMDINFO")))))
- (if (equal? (args:get-arg "-dumpmode") "json")
- (json-write data)
- (pp data))
- (set! *didsomething* #t))
- (debug:print-info 0 *default-log-port* "environment variable MT_CMDINFO is not set")))
-
-;;======================================================================
-;; Remove old run(s)
-;;======================================================================
-
-;; since several actions can be specified on the command line the removal
-;; is done first
-(define (operate-on action #!key (mode #f)(target-in #f)(runname-in #f)(keys-in #f)(keyvals-in #f)) ;; #f is "use default"
- (let* ((runrec (runs:runrec-make-record))
- (target (or target-in (common:args-get-target))) ;; eventually get rid of the call to common:args-get-target
- (runname (or runname-in
- (args:get-arg "-runname"))) ;; eventually get rid of the get-arg calls
- (testpatt (or (args:get-arg "-testpatt")
- (and (eq? action 'archive) ;; if it is an archive command fallback to MT_TEST_NAME and MT_ITEMPATH
- (common:get-full-test-name))
- (and (eq? action 'kill-runs)
- "%/%") ;; I'm just guessing that this is correct :(
- (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")))
- ))) ;;
- (cond
- ((not target)
- (debug:print-error 0 *default-log-port* "Missing required parameter for "
- action ", you must specify -target or -reqtarg")
- (exit 1))
- ((not runname)
- (debug:print-error 0 *default-log-port* "Missing required parameter for "
- action ", you must specify the run name pattern with -runname patt")
- (exit 2))
- ((not testpatt)
- (debug:print-error 0 *default-log-port* "Missing required parameter for "
- action ", you must specify the test pattern with -testpatt")
- (exit 3))
- (else
- (if (not (car *configinfo*))
- (begin
- (debug:print-error 0 *default-log-port* "Attempted " action "on test(s) but run area config file not found")
- (exit 1))
- ;; put test parameters into convenient variables
- (begin
- ;; check for correct version, exit with message if not correct
- (common:exit-on-version-changed)
- (runs:operate-on action
- target
- runname
- testpatt
- state: (common:args-get-state)
- status: (common:args-get-status)
- new-state-status: (args:get-arg "-set-state-status")
- mode: mode)))
- (set! *didsomething* #t)))))
-
-(if (args:get-arg "-kill-runs")
- (general-run-call
- "-kill-runs"
- "kill runs"
- (lambda (target runname keys keyvals)
- (operate-on 'kill-runs mode: #f)
- )))
-
-(if (args:get-arg "-kill-rerun")
- (let* ((target-patt (common:args-get-target))
- (runname-patt (args:get-arg "-runname")))
- (cond ((not target-patt)
- (debug:print-error 0 *default-log-port* "Missing target, must specify target for -kill-rerun with -target ")
- (exit 1))
- ((not runname-patt)
- (debug:print-error 0 *default-log-port* "Missing runname, must specify runname for -kill-rerun with -runname ")
- (exit 1))
- ((string-search "[ ,%]" target-patt)
- (debug:print-error 0 *default-log-port* "Invalid target ["target-patt"], must specify exact target (no wildcards) for -kill-rerun with -target ")
- (exit 1))
- ((string-search "[ ,%]" runname-patt)
- (debug:print-error 0 *default-log-port* "Invalid runname ["runname-patt"], must specify exact runname (no wildcards) for -kill-rerun with -runname ")
- (exit 1))
- (else
- (general-run-call
- "-kill-runs"
- "kill runs"
- (lambda (target runname keys keyvals)
- (operate-on 'kill-runs mode: #f)
- ))
-
- (thread-sleep! 15))
- ;; fall thru and let "-run" loop fire
- )))
-
-
-(if (args:get-arg "-remove-runs")
- (general-run-call
- "-remove-runs"
- "remove runs"
- (lambda (target runname keys keyvals)
- (operate-on 'remove-runs mode: (if (args:get-arg "-keep-records")
- 'remove-data-only
- 'remove-all)))))
-
-(if (args:get-arg "-remove-keep")
- (general-run-call
- "-remove-keep"
- "remove keep"
- (lambda (target runname keys keyvals)
- (let ((actions (map string->symbol
- (string-split
- (or (args:get-arg "-actions")
- "print")
- ",")))) ;; default to printing the output
- (runs:remove-all-but-last-n-runs-per-target target runname
- (string->number (args:get-arg "-remove-keep"))
- actions: actions)))))
-
-(if (args:get-arg "-set-state-status")
- (general-run-call
- "-set-state-status"
- "set state and status"
- (lambda (target runname keys keyvals)
- (operate-on 'set-state-status))))
-
-(if (or (args:get-arg "-set-run-status")
- (args:get-arg "-get-run-status"))
- (general-run-call
- "-set-run-status"
- "set run status"
- (lambda (target runname keys keyvals)
- (let* ((runsdat (rmt:get-runs-by-patt keys runname
- (common:args-get-target)
- #f #f #f #f))
- (header (vector-ref runsdat 0))
- (rows (vector-ref runsdat 1)))
- (if (null? rows)
- (begin
- (debug:print-info 0 *default-log-port* "No matching run found.")
- (exit 1))
- (let* ((row (car (vector-ref runsdat 1)))
- (run-id (db:get-value-by-header row header "id")))
- (if (args:get-arg "-set-run-status")
- (rmt:set-run-status run-id (args:get-arg "-set-run-status") msg: (args:get-arg "-m"))
- (print (rmt:get-run-status run-id))
- )))))))
-
-;;======================================================================
-;; Query runs
-;;======================================================================
-
-;; -fields runs:id,target,runname,comment+tests:id,testname,item_path+steps
-;;
-;; csi> (extract-fields-constraints "runs:id,target,runname,comment+tests:id,testname,item_path+steps")
-;; => (("runs" "id" "target" "runname" "comment") ("tests" "id" "testname" "item_path") ("steps"))
-;;
-;; NOTE: remember that the cdr will be the list you expect (cdr ("runs" "id" "target" "runname" "comment")) => ("id" "target" "runname" "comment")
-;; and so alist-ref will yield what you expect
-;;
-(define (extract-fields-constraints fields-spec)
- (map (lambda (table-spec) ;; runs:id,target,runname
- (let ((dat (string-split table-spec ":"))) ;; ("runs" "id,target,runname")
- (if (> (length dat) 1)
- (cons (car dat)(string-split (cadr dat) ",")) ;; "id,target,runname"
- dat)))
- (string-split fields-spec "+")))
-
-(define (get-value-by-fieldname datavec test-field-index fieldname)
- (let ((indx (hash-table-ref/default test-field-index fieldname #f)))
- (if indx
- (if (>= indx (vector-length datavec))
- #f ;; index too high, should raise an error I suppose
- (vector-ref datavec indx))
- #f)))
-
-
-
-
-
-(when (args:get-arg "-testdata-csv")
- (if (launch:setup)
- (let* ((keys (rmt:get-keys)) ;; (db:get-keys dbstruct))
- (runpatt (or (args:get-arg "-runname") "%"))
- (testpatt (common:args-get-testpatt #f))
- (datapatt (args:get-arg "-testdata-csv"))
- (match-data (string-match "^([^/]+)/(.*)" (args:get-arg "-testdata-csv")))
- (categorypatt (if match-data (list-ref match-data 1) "%"))
- (setvarpatt (if match-data
- (list-ref match-data 2)
- (args:get-arg "-testdata-csv")))
- (runsdat (rmt:get-runs-by-patt keys (or runpatt "%")
- (common:args-get-target) #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
- (header (db:get-header runsdat))
- (access-mode (db:get-access-mode))
- (testpatt (common:args-get-testpatt #f))
- (fields-spec (if (args:get-arg "-fields")
- (extract-fields-constraints (args:get-arg "-fields"))
- (list (cons "runs" (append keys (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count")))
- (cons "tests" db:test-record-fields) ;; "id" "testname" "test_path")
- (list "steps" "id" "stepname"))))
- (tests-spec (let ((t (alist-ref "tests" fields-spec equal?)))
- (if (and t (null? t)) ;; all fields
- db:test-record-fields
- t)))
- (adj-tests-spec (delete-duplicates (if tests-spec (cons "id" tests-spec) db:test-record-fields)))
- (test-field-index (make-hash-table))
- (runs (db:get-rows runsdat))
- )
- (if (and tests-spec (not (null? tests-spec))) ;; do some validation and processing of the test-spec
- (let ((invalid-tests-spec (filter (lambda (x)(not (member x db:test-record-fields))) tests-spec)))
- (if (null? invalid-tests-spec)
- ;; generate the lookup map test-field-name => index-number
- (let loop ((hed (car adj-tests-spec))
- (tal (cdr adj-tests-spec))
- (idx 0))
- (hash-table-set! test-field-index hed idx)
- (if (not (null? tal))(loop (car tal)(cdr tal)(+ idx 1))))
- (begin
- (debug:print-error 0 *default-log-port* "Invalid test fields specified: " (string-intersperse invalid-tests-spec ", "))
- (exit)))))
- (let* ((table-header (string-split "target,run,test,itempath,category,var,value,comment" ","))
- (table-rows
- (apply append (map
- (lambda (run)
- (let* ((target (string-intersperse (map (lambda (x)
- (db:get-value-by-header run header x))
- keys) "/"))
- (statuses (string-split (or (args:get-arg "-status") "") ","))
- (run-id (db:get-value-by-header run header "id"))
- (runname (db:get-value-by-header run header "runname"))
- (states (string-split (or (args:get-arg "-state") "") ","))
- (tests (if tests-spec
- (rmt:get-tests-for-run run-id testpatt states statuses #f #f #f 'testname 'asc ;; (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc
- ;; use qryvals if test-spec provided
- (if tests-spec
- (string-intersperse adj-tests-spec ",")
- ;; db:test-record-fields
- #f)
- #f
- 'normal)
- '())))
- (apply append
- (map
- (lambda (test)
- (let* (
- (test-id (if (member "id" tests-spec)(get-value-by-fieldname test test-field-index "id" ) #f)) ;; (db:test-get-id test))
- (testname (if (member "testname" tests-spec)(get-value-by-fieldname test test-field-index "testname" ) #f)) ;; (db:test-get-testname test))
- (itempath (if (member "item_path" tests-spec)(get-value-by-fieldname test test-field-index "item_path" ) #f)) ;; (db:test-get-item-path test))
- (fullname (conc testname
- (if (equal? itempath "")
- ""
- (conc "/" itempath ))))
- (testdat-raw (map vector->list (rmt:read-test-data-varpatt run-id test-id categorypatt setvarpatt)))
- (testdat (filter
- (lambda (x)
- (not (equal? "logpro"
- (list-ref x 10))))
- testdat-raw)))
- (map
- (lambda (item)
- (receive (id test_id category
- variable value expected
- tol units comment status type)
- (apply values item)
- (list target runname testname itempath category variable value comment)))
- testdat)))
- tests))))
- runs))))
- (print (string-join table-header ","))
- (for-each (lambda(table-row)
- (print (string-join (map ->string table-row) ",")))
-
-
- table-rows))))
- (set! *didsomething* #t)
- (set! *time-to-exit* #t))
-
-
-
-;; NOTE: list-runs and list-db-targets operate on local db!!!
-;;
-;; IDEA: megatest list -runname blah% ...
-;;
-(if (or (args:get-arg "-list-runs")
- (args:get-arg "-list-db-targets"))
- (if (launch:setup)
- (let* (;; (dbstruct (make-dbr:dbstruct path: *toppath* local: (args:get-arg "-local")))
- (runpatt (args:get-arg "-list-runs"))
- (access-mode (db:get-access-mode))
- (testpatt (common:args-get-testpatt #f))
- ;; (if (args:get-arg "-testpatt")
- ;; (args:get-arg "-testpatt")
- ;; "%"))
- (keys (rmt:get-keys)) ;; (db:get-keys dbstruct))
- ;; (runsdat (db:get-runs dbstruct runpatt #f #f '()))
- ;; (runsdat (rmt:get-runs-by-patt keys (or runpatt "%") (common:args-get-target) ;; (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target)
- ;; #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
- (runsdat (rmt:get-runs-by-patt keys (or runpatt "%")
- (common:args-get-target) #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
- (runstmp (db:get-rows runsdat))
- (header (db:get-header runsdat))
- ;; this is "-since" support. This looks at last mod times of .db files
- ;; and collects those modified since the -since time.
- (runs runstmp)
- ;; (if (and (not (null? runstmp))
- ;; (args:get-arg "-since"))
- ;; (let ((changed-ids (db:get-changed-run-ids (string->number (args:get-arg "-since")))))
- ;; (let loop ((hed (car runstmp))
- ;; (tal (cdr runstmp))
- ;; (res '()))
- ;; (let ((new-res (if (member (db:get-value-by-header hed header "id") changed-ids)
- ;; (cons hed res)
- ;; res)))
- ;; (if (null? tal)
- ;; (reverse new-res)
- ;; (loop (car tal)(cdr tal) new-res)))))
- ;; runstmp))
- (db-targets (args:get-arg "-list-db-targets"))
- (seen (make-hash-table))
- (dmode (let ((d (args:get-arg "-dumpmode"))) ;; json, sexpr
- (if d (string->symbol d) #f)))
- (data (make-hash-table))
- (fields-spec (if (args:get-arg "-fields")
- (extract-fields-constraints (args:get-arg "-fields"))
- (list (cons "runs" (append keys (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count")))
- (cons "tests" db:test-record-fields) ;; "id" "testname" "test_path")
- (list "steps" "id" "stepname"))))
- (runs-spec (let ((r (alist-ref "runs" fields-spec equal?))) ;; the check is now unnecessary
- (if (and r (not (null? r))) r (list "id" ))))
- (tests-spec (let ((t (alist-ref "tests" fields-spec equal?)))
- (if (and t (null? t)) ;; all fields
- db:test-record-fields
- t)))
- (adj-tests-spec (delete-duplicates (if tests-spec (cons "id" tests-spec) db:test-record-fields))) ;; '("id"))))
- (steps-spec (alist-ref "steps" fields-spec equal?))
- (test-field-index (make-hash-table)))
- (if (and tests-spec (not (null? tests-spec))) ;; do some validation and processing of the test-spec
- (let ((invalid-tests-spec (filter (lambda (x)(not (member x db:test-record-fields))) tests-spec)))
- (if (null? invalid-tests-spec)
- ;; generate the lookup map test-field-name => index-number
- (let loop ((hed (car adj-tests-spec))
- (tal (cdr adj-tests-spec))
- (idx 0))
- (hash-table-set! test-field-index hed idx)
- (if (not (null? tal))(loop (car tal)(cdr tal)(+ idx 1))))
- (begin
- (debug:print-error 0 *default-log-port* "Invalid test fields specified: " (string-intersperse invalid-tests-spec ", "))
- (exit)))))
- ;; Each run
- (for-each
- (lambda (run)
- (let ((targetstr (string-intersperse (map (lambda (x)
- (db:get-value-by-header run header x))
- keys) "/")))
- (if db-targets
- (if (not (hash-table-ref/default seen targetstr #f))
- (begin
- (hash-table-set! seen targetstr #t)
- ;; (print "[" targetstr "]"))))
- (if (not dmode)
- (print targetstr)
- (hash-table-set! data "targets" (cons targetstr (hash-table-ref/default data "targets" '())))
- )))
- (let* ((run-id (db:get-value-by-header run header "id"))
- (runname (db:get-value-by-header run header "runname"))
- (states (string-split (or (args:get-arg "-state") "") ","))
- (statuses (string-split (or (args:get-arg "-status") "") ","))
- (tests (if tests-spec
- (rmt:get-tests-for-run run-id testpatt states statuses #f #f #f 'testname 'asc ;; (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc
- ;; use qryvals if test-spec provided
- (if tests-spec
- (string-intersperse adj-tests-spec ",")
- ;; db:test-record-fields
- #f)
- #f
- 'normal)
- '())))
- (case dmode
- ((json ods sexpr)
- (if runs-spec
- (for-each
- (lambda (field-name)
- (mutils:hierhash-set! data (conc (db:get-value-by-header run header field-name)) targetstr runname "meta" field-name))
- runs-spec)))
- ;; (mutils:hierhash-set! data (db:get-value-by-header run header "status") targetstr runname "meta" "status" )
- ;; (mutils:hierhash-set! data (db:get-value-by-header run header "state") targetstr runname "meta" "state" )
- ;; (mutils:hierhash-set! data (conc (db:get-value-by-header run header "id")) targetstr runname "meta" "id" )
- ;; (mutils:hierhash-set! data (db:get-value-by-header run header "event_time") targetstr runname "meta" "event_time" )
- ;; (mutils:hierhash-set! data (db:get-value-by-header run header "comment") targetstr runname "meta" "comment" )
- ;; ;; add last entry twice - seems to be a bug in hierhash?
- ;; (mutils:hierhash-set! data (db:get-value-by-header run header "comment") targetstr runname "meta" "comment" )
- (else
- (if (null? runs-spec)
- (print "Run: " targetstr "/" runname
- " status: " (db:get-value-by-header run header "state")
- " run-id: " run-id ", number tests: " (length tests)
- " event_time: " (db:get-value-by-header run header "event_time"))
- (begin
- (if (not (member "target" runs-spec))
- ;; (display (conc "Target: " targetstr))
- (display (conc "Run: " targetstr "/" runname " ")))
- (for-each
- (lambda (field-name)
- (if (equal? field-name "target")
- (display (conc "target: " targetstr " "))
- (display (conc field-name ": " (db:get-value-by-header run header (conc field-name)) " "))))
- runs-spec)
- (newline)))))
-
- (for-each
- (lambda (test)
- (common:debug-handle-exceptions #f
- exn
- (begin
- (debug:print-error 0 *default-log-port* "Bad data in test record? " test)
- (debug:print-error 5 *default-log-port* "exn=" (condition->list exn))
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (print-call-chain (current-error-port)))
- (let* ((test-id (if (member "id" tests-spec)(get-value-by-fieldname test test-field-index "id" ) #f)) ;; (db:test-get-id test))
- (testname (if (member "testname" tests-spec)(get-value-by-fieldname test test-field-index "testname" ) #f)) ;; (db:test-get-testname test))
- (itempath (if (member "item_path" tests-spec)(get-value-by-fieldname test test-field-index "item_path" ) #f)) ;; (db:test-get-item-path test))
- (comment (if (member "comment" tests-spec)(get-value-by-fieldname test test-field-index "comment" ) #f)) ;; (db:test-get-comment test))
- (tstate (if (member "state" tests-spec)(get-value-by-fieldname test test-field-index "state" ) #f)) ;; (db:test-get-state test))
- (tstatus (if (member "status" tests-spec)(get-value-by-fieldname test test-field-index "status" ) #f)) ;; (db:test-get-status test))
- (event-time (if (member "event_time" tests-spec)(get-value-by-fieldname test test-field-index "event_time" ) #f)) ;; (db:test-get-event_time test))
- (rundir (if (member "rundir" tests-spec)(get-value-by-fieldname test test-field-index "rundir" ) #f)) ;; (db:test-get-rundir test))
- (final_logf (if (member "final_logf" tests-spec)(get-value-by-fieldname test test-field-index "final_logf" ) #f)) ;; (db:test-get-final_logf test))
- (run_duration (if (member "run_duration" tests-spec)(get-value-by-fieldname test test-field-index "run_duration") #f)) ;; (db:test-get-run_duration test))
- (fullname (conc testname
- (if (equal? itempath "")
- ""
- (conc "(" itempath ")")))))
- (case dmode
- ((json ods sexpr)
- (if tests-spec
- (for-each
- (lambda (field-name)
- (mutils:hierhash-set! data (get-value-by-fieldname test test-field-index field-name) targetstr runname "data" (conc test-id) field-name))
- tests-spec)))
- ;; ;; (mutils:hierhash-set! data fullname targetstr runname "data" (conc test-id) "tname" )
- ;; (mutils:hierhash-set! data testname targetstr runname "data" (conc test-id) "testname" )
- ;; (mutils:hierhash-set! data itempath targetstr runname "data" (conc test-id) "itempath" )
- ;; (mutils:hierhash-set! data comment targetstr runname "data" (conc test-id) "comment" )
- ;; (mutils:hierhash-set! data tstate targetstr runname "data" (conc test-id) "state" )
- ;; (mutils:hierhash-set! data tstatus targetstr runname "data" (conc test-id) "status" )
- ;; (mutils:hierhash-set! data rundir targetstr runname "data" (conc test-id) "rundir" )
- ;; (mutils:hierhash-set! data final_logf targetstr runname "data" (conc test-id) "final_logf")
- ;; (mutils:hierhash-set! data run_duration targetstr runname "data" (conc test-id) "run_duration")
- ;; (mutils:hierhash-set! data event-time targetstr runname "data" (conc test-id) "event_time")
- ;; ;; add last entry twice - seems to be a bug in hierhash?
- ;; (mutils:hierhash-set! data event-time targetstr runname "data" (conc test-id) "event_time")
- ;; )
- (else
- (if (and tstate tstatus event-time)
- (format #t
- " Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n"
- (if fullname fullname "")
- (if tstate tstate "")
- (if tstatus tstatus "")
- (get-value-by-fieldname test test-field-index "run_duration");;(if test (db:test-get-run_duration test) "")
- (if event-time event-time "")
- (get-value-by-fieldname test test-field-index "host")) ;;(if test (db:test-get-host test)) "")
- (print " Test: " fullname
- (if tstate (conc " State: " tstate) "")
- (if tstatus (conc " Status: " tstatus) "")
- (if (get-value-by-fieldname test test-field-index "run_duration")
- (conc " Runtime: " (get-value-by-fieldname test test-field-index "run_duration"))
- "")
- (if event-time (conc " Time: " event-time) "")
- (if (get-value-by-fieldname test test-field-index "host")
- (conc " Host: " (get-value-by-fieldname test test-field-index "host"))
- "")))
- (if (not (or (equal? (get-value-by-fieldname test test-field-index "status") "PASS")
- (equal? (get-value-by-fieldname test test-field-index "status") "WARN")
- (equal? (get-value-by-fieldname test test-field-index "state") "NOT_STARTED")))
- (begin
- (print (if (get-value-by-fieldname test test-field-index "cpuload")
- (conc " cpuload: " (get-value-by-fieldname test test-field-index "cpuload"))
- "") ;; (db:test-get-cpuload test)
- (if (get-value-by-fieldname test test-field-index "diskfree")
- (conc "\n diskfree: " (get-value-by-fieldname test test-field-index "diskfree")) ;; (db:test-get-diskfree test)
- "")
- (if (get-value-by-fieldname test test-field-index "uname")
- (conc "\n uname: " (get-value-by-fieldname test test-field-index "uname")) ;; (db:test-get-uname test)
- "")
- (if (get-value-by-fieldname test test-field-index "rundir")
- (conc "\n rundir: " (get-value-by-fieldname test test-field-index "rundir")) ;; (db:test-get-rundir test)
- "")
-;; "\n rundir: " (get-value-by-fieldname test test-field-index "") ;; (sdb:qry 'getstr ;; (filedb:get-path *fdb*
-;; (db:test-get-rundir test) ;; )
- )
- ;; Each test
- ;; DO NOT remote run
- (let ((steps (rmt:get-steps-for-test run-id (db:test-get-id test)))) ;; (db:get-steps-for-test dbstruct run-id (db:test-get-id test))))
- (for-each
- (lambda (step)
- (format #t
- " Step: ~20a State: ~10a Status: ~10a Time ~22a\n"
- (tdb:step-get-stepname step)
- (tdb:step-get-state step)
- (tdb:step-get-status step)
- (tdb:step-get-event_time step)))
- steps)))))))))
- (if (args:get-arg "-sort")
- (sort tests
- (lambda (a-test b-test)
- (let* ((key (args:get-arg "-sort"))
- (first (get-value-by-fieldname a-test test-field-index key))
- (second (get-value-by-fieldname b-test test-field-index key)))
- ((cond
- ((and (number? first)(number? second)) <)
- ((and (string? first)(string? second)) string<=?)
- (else equal?))
- first second))))
- tests))))))
- runs)
- (case dmode
- ((json) (json-write data))
- ((sexpr) (pp (common:to-alist data))))
- (let* ((metadat-fields (delete-duplicates
- (append keys '( "runname" "time" "owner" "pass_count" "fail_count" "state" "status" "comment" "id"))))
- (run-fields '(
- "testname"
- "item_path"
- "state"
- "status"
- "comment"
- "event_time"
- "host"
- "run_id"
- "run_duration"
- "attemptnum"
- "id"
- "archived"
- "diskfree"
- "cpuload"
- "final_logf"
- "shortdir"
- "rundir"
- "uname"
- )
- )
- (newdat (common:to-alist data))
- (allrundat (if (null? newdat)
- '()
- (car (map cdr newdat)))) ;; (car (map cdr (car (map cdr newdat)))))
- (runs (append
- (list "runs" ;; sheetname
- metadat-fields)
- (map (lambda (run)
- ;; (print "run: " run)
- (let* ((runname (car run))
- (rundat (cdr run))
- (metadat (let ((tmp (assoc "meta" rundat)))
- (if tmp (cdr tmp) #f))))
- ;; (print "runname: " runname "\n\nrundat: " )(pp rundat)(print "\n\nmetadat: ")(pp metadat)
- (if metadat
- (map (lambda (field)
- (let ((tmp (assoc field metadat)))
- (if tmp (cdr tmp) "")))
- metadat-fields)
- (begin
- (debug:print 0 *default-log-port* "WARNING: meta data for run " runname " not found")
- '()))))
- allrundat)))
- ;; '( ( "target" ( "runname" ( "data" ( "runid" ( "id . "37" ) ( ... ))))
- (run-pages (map (lambda (targdat)
- (let* ((target (car targdat))
- (runsdat (cdr targdat)))
- (if runsdat
- (map (lambda (rundat)
- (let* ((runname (car rundat))
- (rundat (cdr rundat))
- (testsdat (let ((tmp (assoc "data" rundat)))
- (if tmp (cdr tmp) #f))))
- (if testsdat
- (let ((tests (map (lambda (test)
- (let* ((test-id (car test))
- (test-dat (cdr test)))
- (map (lambda (field)
- (let ((tmp (assoc field test-dat)))
- (if tmp (cdr tmp) "")))
- run-fields)))
- testsdat)))
- ;; (print "Target: " target "/" runname " tests:")
- ;; (pp tests)
- (cons (conc target "/" runname)
- (cons (list (conc target "/" runname))
- (cons '()
- (cons run-fields tests)))))
- (begin
- (debug:print 4 *default-log-port* "WARNING: run " target "/" runname " appears to have no data")
- ;; (pp rundat)
- '()))))
- runsdat)
- '())))
- newdat)) ;; we use newdat to get target
- (sheets (filter (lambda (x)
- (not (null? x)))
- (cons runs (map car run-pages)))))
- ;; (print "allrundat:")
- ;; (pp allrundat)
- ;; (print "runs:")
- ;; (pp runs)
- ;(print "sheets: ")
- ;; (pp sheets)
- (if (eq? dmode 'ods)
- (let* ((tempdir (conc "/tmp/" (current-user-name) "/" (random 10000) "_" (current-process-id)))
- (outputfile (or (args:get-arg "-o") "out.ods"))
- (ouf (if (string-match (regexp "^[/~]+.*") outputfile) ;; full path?
- outputfile
- (begin
- (debug:print 0 *default-log-port* "WARNING: path given, " outputfile " is relative, prefixing with current directory")
- (conc (current-directory) "/" outputfile)))))
- (create-directory tempdir #t)
- (ods:list->ods tempdir ouf sheets))))
- ;; (system (conc "rm -rf " tempdir))
- (set! *didsomething* #t)
- (set! *time-to-exit* #t)
- ) ;; end if true branch (end of a let)
- ) ;; end if
- ) ;; end if -list-runs
-
-;; list-waivers
-(if (and (args:get-arg "-list-waivers")
- (launch:setup))
- (let* ((runpatt (or (args:get-arg "-runname") "%"))
- (testpatt (common:args-get-testpatt #f))
- (keys (rmt:get-keys))
- (runsdat (rmt:get-runs-by-patt
- keys runpatt
- (common:args-get-target) #f #f
- '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
- (runs (db:get-rows runsdat))
- (header (db:get-header runsdat))
- (results (make-hash-table)) ;; [target] ( (testname/itempath . "comment") ... )
- (addtest (lambda (target testname itempath comment)
- (hash-table-set! results target (cons (cons (conc testname "/" itempath) comment)
- (hash-table-ref/default results target '())))))
- (last-target #f))
- (for-each
- (lambda (run)
- (let* ((run-id (db:get-value-by-header run header "id"))
- (target (rmt:get-target run-id))
- (runname (db:get-value-by-header run header "runname"))
- (tests (rmt:get-tests-for-run
- run-id testpatt '("COMPLETED") '("WAIVED") #f #f #f 'testname 'asc ;; use qryvals if test-spec provided
- #f #f #f)))
- (if (not (equal? target last-target))
- (print "[" target "]"))
- (set! last-target target)
- (print "# " runname)
- (for-each
- (lambda (testdat)
- (let* ((testfullname (conc (db:test-get-testname testdat)
- (if (equal? "" (db:test-get-item-path testdat))
- ""
- (conc "/" (db:test-get-item-path testdat)))
- )))
- (print testfullname " " (db:test-get-comment testdat))))
- tests)))
- runs)
- (set! *didsomething* #t)))
-
-;;======================================================================
-;; full run
-;;======================================================================
-
-(define (handle-run-requests target runname keys keyvals need-clean)
- (if (or (args:get-arg "-kill-rerun") (args:get-arg "-rerun-clean")) ;; first set states/statuses correct
- ;; For rerun-clean do we or do we not support the testpatt?
- (let ((states (or (configf:lookup *configdat* "validvalues" "cleanrerun-states")
- "KILLREQ,KILLED,UNKNOWN,INCOMPLETE,STUCK,NOT_STARTED"))
- (statuses (or (configf:lookup *configdat* "validvalues" "cleanrerun-statuses")
- "FAIL,INCOMPLETE,ABORT,CHECK,DEAD,PREQ_FAIL,PREQ_DISCARDED")))
- (hash-table-set! args:arg-hash "-preclean" #t)
- (runs:operate-on 'set-state-status
- target
- (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
- ;; "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
- (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
- state: states
- ;; status: statuses
- new-state-status: "NOT_STARTED,n/a")
- (runs:clean-cache target runname *toppath*)
- (runs:operate-on 'set-state-status
- target
- (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
- ;; "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
- (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
- ;; state: states
- status: statuses
- new-state-status: "NOT_STARTED,n/a")))
- ;; RERUN ALL
- (if (args:get-arg "-rerun-all") ;; first set states/statuses correct
- (let* ((rconfig (full-runconfigs-read)))
- (hash-table-set! args:arg-hash "-preclean" #t)
- (runs:operate-on 'set-state-status
- target
- (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
- (common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt")
- state: #f
- ;; status: statuses
- new-state-status: "NOT_STARTED,n/a")
- (runs:clean-cache target runname *toppath*)
- (runs:operate-on 'set-state-status
- target
- (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
- (common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt")
- ;; state: states
- status: #f
- new-state-status: "NOT_STARTED,n/a")))
- (let* ((config-reruns (let ((x (configf:lookup *configdat* "setup" "reruns")))
- (if x (string->number x) #f)))
- (rerun-cnt (if config-reruns
- config-reruns
- 1)))
-
- (runs:run-tests target
- runname
- #f ;; (common:args-get-testpatt #f)
- ;; (or (args:get-arg "-testpatt")
- ;; "%")
- user
- args:arg-hash
- run-count: rerun-cnt)))
-
-;; get lock in db for full run for this directory
-;; for all tests with deps
-;; walk tree of tests to find head tasks
-;; add head tasks to task queue
-;; add dependant tasks to task queue
-;; add remaining tasks to task queue
-;; for each task in task queue
-;; if have adequate resources
-;; launch task
-;; else
-;; put task in deferred queue
-;; if still ok to run tasks
-;; process deferred tasks per above steps
-
-;; run all tests are are Not COMPLETED and PASS or CHECK
-(if (or (args:get-arg "-runall")
- (args:get-arg "-run")
- (args:get-arg "-rerun-clean")
- (args:get-arg "-rerun-all")
- (args:get-arg "-runtests")
- (args:get-arg "-kill-rerun"))
- (let ((need-clean (or (args:get-arg "-rerun-clean")
- (args:get-arg "-rerun-all")))
- (orig-cmdline (string-intersperse (argv) " ")))
- (general-run-call
- "-runall"
- "run all tests"
- (lambda (target runname keys keyvals)
- (if (or (string-search "%" target)
- (string-search "%" runname)) ;; we are being asked to re-run multiple runs
- (let* ((run-specs (rmt:simple-get-runs runname #f #f target #f))) ;; list of simple-run records
- (debug:print-info 0 *default-log-port* "Pattern supplied for target or runname with "
- (length run-specs) " matches round. Running each in turn.")
- (if (null? run-specs)
- (debug:print 0 *default-log-port* "WARNING: No runs match target " target " and runname " runname))
- (for-each (lambda (spec)
- (let* ((precmd (if (args:get-arg "-precmd")(conc (args:get-arg "-precmd") " ") ""))
- (newcmdline (conc
- precmd
- (string-substitute
- (conc "target " target)
- (conc "target " (simple-run-target spec))
- (string-substitute
- (conc "runname " runname)
- (conc "runname " (simple-run-runname spec))
- orig-cmdline)))))
- (debug:print 0 *default-log-port* "ORIG: " orig-cmdline)
- (debug:print 0 *default-log-port* "NEW: " newcmdline)
- (system newcmdline)))
- run-specs))
- (handle-run-requests target runname keys keyvals need-clean))))))
-
-;;======================================================================
-;; run one test
-;;======================================================================
-
-;; 1. find the config file
-;; 2. change to the test directory
-;; 3. update the db with "test started" status, set running host
-;; 4. process launch the test
-;; - monitor the process, update stats in the db every 2^n minutes
-;; 5. as the test proceeds internally it calls megatest as each step is
-;; started and completed
-;; - step started, timestamp
-;; - step completed, exit status, timestamp
-;; 6. test phone home
-;; - if test run time > allowed run time then kill job
-;; - if cannot access db > allowed disconnect time then kill job
-
-;; == duplicated == (if (or (args:get-arg "-run")(args:get-arg "-runtests"))
-;; == duplicated == (general-run-call
-;; == duplicated == "-runtests"
-;; == duplicated == "run a test"
-;; == duplicated == (lambda (target runname keys keyvals)
-;; == duplicated == ;;
-;; == duplicated == ;; May or may not implement it this way ...
-;; == duplicated == ;;
-;; == duplicated == ;; Insert this run into the tasks queue
-;; == duplicated == ;; (open-run-close tasks:add tasks:open-db
-;; == duplicated == ;; "runtests"
-;; == duplicated == ;; user
-;; == duplicated == ;; target
-;; == duplicated == ;; runname
-;; == duplicated == ;; (args:get-arg "-runtests")
-;; == duplicated == ;; #f))))
-;; == duplicated == (runs:run-tests target
-;; == duplicated == runname
-;; == duplicated == (common:args-get-testpatt #f) ;; (args:get-arg "-runtests")
-;; == duplicated == user
-;; == duplicated == args:arg-hash))))
-
-;;======================================================================
-;; Rollup into a run
-;;======================================================================
-
-(if (args:get-arg "-rollup")
- (general-run-call
- "-rollup"
- "rollup tests"
- (lambda (target runname keys keyvals)
- (runs:rollup-run keys
- keyvals
- (or (args:get-arg "-runname")(args:get-arg ":runname") )
- user))))
-
-;;======================================================================
-;; Lock or unlock a run
-;;======================================================================
-
-(if (or (args:get-arg "-lock")(args:get-arg "-unlock"))
- (general-run-call
- (if (args:get-arg "-lock") "-lock" "-unlock")
- "lock/unlock tests"
- (lambda (target runname keys keyvals)
- (runs:handle-locking
- target
- keys
- (or (args:get-arg "-runname")(args:get-arg ":runname") )
- (args:get-arg "-lock")
- (args:get-arg "-unlock")
- user))))
-
-;;======================================================================
-;; Get paths to tests
-;;======================================================================
-;; Get test paths matching target, runname, and testpatt
-(if (or (args:get-arg "-test-files")(args:get-arg "-test-paths"))
- ;; if we are in a test use the MT_CMDINFO data
- (if (getenv "MT_CMDINFO")
- (let* ((startingdir (current-directory))
- (cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO")))
- (transport (assoc/default 'transport cmdinfo))
- (testpath (assoc/default 'testpath cmdinfo))
- (test-name (assoc/default 'test-name cmdinfo))
- (runscript (assoc/default 'runscript cmdinfo))
- (db-host (assoc/default 'db-host cmdinfo))
- (run-id (assoc/default 'run-id cmdinfo))
- (itemdat (assoc/default 'itemdat cmdinfo))
- (state (args:get-arg ":state"))
- (status (args:get-arg ":status"))
- ;;(target (args:get-arg "-target"))
- (target (common:args-get-target))
- (toppath (assoc/default 'toppath cmdinfo)))
- (change-directory toppath)
- (if (not target)
- (begin
- (debug:print-error 0 *default-log-port* "-target is required.")
- (exit 1)))
- (if (not (launch:setup))
- (begin
- (debug:print 0 *default-log-port* "Failed to setup, giving up on -test-paths or -test-files, exiting")
- (exit 1)))
- (let* ((keys (rmt:get-keys))
- ;; db:test-get-paths must not be run remote
- (paths (tests:test-get-paths-matching keys target (args:get-arg "-test-files"))))
- (set! *didsomething* #t)
- (for-each (lambda (path)
- (if (common:file-exists? path)
- (print path)))
- paths)))
- ;; else do a general-run-call
- (general-run-call
- "-test-files"
- "Get paths to test"
- (lambda (target runname keys keyvals)
- (let* ((db #f)
- ;; DO NOT run remote
- (paths (tests:test-get-paths-matching keys target (args:get-arg "-test-files"))))
- (for-each (lambda (path)
- (print path))
- paths))))))
-
-;;======================================================================
-;; Archive tests
-;;======================================================================
-;; Archive tests matching target, runname, and testpatt
-(if (equal? (args:get-arg "-archive") "replicate-db")
- (begin
- ;; check if source
- ;; check if megatest.db exist
- (launch:setup)
- (if (not (args:get-arg "-source"))
- (begin
- (debug:print-info 1 *default-log-port* "Missing required argument -source ")
- (exit 1)))
- (if (common:file-exists? (conc *toppath* "/megatest.db"))
- (begin
- (debug:print-info 1 *default-log-port* "File " (conc *toppath* "/megatest.db") " already exists. Please remove it before trying to replicate db")
- (exit 1)))
- (if (and (common:get-db-tmp-area) (> (length (directory (common:get-db-tmp-area) #f)) 0))
- (begin
- (debug:print-info 1 *default-log-port* (common:get-db-tmp-area) " not empty. Please remove it before trying to replicate db")
- (exit 1)))
- ;; check if timestamp
- (let* ((source (args:get-arg "-source"))
- (src (if (not (equal? (substring source 0 1) "/"))
- (conc (current-directory) "/" source)
- source))
- (ts (if (args:get-arg "-time-stamp") (args:get-arg "-time-stamp") "latest")))
- (if (common:directory-exists? src)
- (begin
- (archive:restore-db src ts)
- (set! *didsomething* #t))
- (begin
- (debug:print-error 1 *default-log-port* "Path " source " not found")
- (exit 1))))))
- ;; else do a general-run-call
- (if (and (args:get-arg "-archive") (not (equal? (args:get-arg "-archive") "replicate-db")))
- (begin
- ;; for the archive get we need to preserve the starting dir as part of the target path
- (if (and (args:get-arg "-dest")
- (not (equal? (substring (args:get-arg "-dest") 0 1) "/")))
- (let ((newpath (conc (current-directory) "/" (args:get-arg "-dest"))))
- (debug:print-info 1 *default-log-port* "Preserving original path to destination, was " (args:get-arg "-dest") ", now " newpath)
- (hash-table-set! args:arg-hash "-dest" newpath)))
- (general-run-call
- "-archive"
- "Archive"
- (lambda (target runname keys keyvals)
- (operate-on 'archive target-in: target runname-in: runname )))))
-
-;;======================================================================
-;; Extract a spreadsheet from the runs database
-;;======================================================================
-
-(if (args:get-arg "-extract-ods")
- (general-run-call
- "-extract-ods"
- "Make ods spreadsheet"
- (lambda (target runname keys keyvals)
- (let ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t))
- (outputfile (args:get-arg "-extract-ods"))
- (runspatt (or (args:get-arg "-runname")(args:get-arg ":runname")))
- (pathmod (args:get-arg "-pathmod")))
- ;; (keyvalalist (keys->alist keys "%")))
- (debug:print 2 *default-log-port* "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvals: " keyvals)
- (db:extract-ods-file dbstruct outputfile keyvals (if runspatt runspatt "%") pathmod)
- (db:close-all dbstruct)
- (set! *didsomething* #t)))))
-
-;;======================================================================
-;; execute the test
-;; - gets called on remote host
-;; - receives info from the -execute param
-;; - passes info to steps via MT_CMDINFO env var (future is to use a dot file)
-;; - gathers host info and
-;;======================================================================
-
-(if (args:get-arg "-execute")
- (begin
- (launch:execute (args:get-arg "-execute"))
- (set! *didsomething* #t)))
-
-;;======================================================================
-;; recover from a test where the managing mtest was killed but the underlying
-;; process might still be salvageable
-;;======================================================================
-
-(if (args:get-arg "-recover-test")
- (let* ((params (string-split (args:get-arg "-recover-test") ",")))
- (if (> (length params) 1) ;; run-id and test-id
- (let ((run-id (string->number (car params)))
- (test-id (string->number (cadr params))))
- (if (and run-id test-id)
- (begin
- (launch:recover-test run-id test-id)
- (set! *didsomething* #t))
- (begin
- (debug:print-error 0 *default-log-port* "bad run-id or test-id, must be integers")
- (exit 1)))))))
-
-;;======================================================================
-;; Test commands (i.e. for use inside tests)
-;;======================================================================
-
-(define (megatest:step step state status logfile msg)
- (if (not (getenv "MT_CMDINFO"))
- (begin
- (debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!")
- (exit 5))
- (let* ((cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO")))
- (transport (assoc/default 'transport cmdinfo))
- (testpath (assoc/default 'testpath cmdinfo))
- (test-name (assoc/default 'test-name cmdinfo))
- (runscript (assoc/default 'runscript cmdinfo))
- (db-host (assoc/default 'db-host cmdinfo))
- (run-id (assoc/default 'run-id cmdinfo))
- (test-id (assoc/default 'test-id cmdinfo))
- (itemdat (assoc/default 'itemdat cmdinfo))
- (work-area (assoc/default 'work-area cmdinfo))
- (db #f))
- (change-directory testpath)
- (if (not (launch:setup))
- (begin
- (debug:print 0 *default-log-port* "Failed to setup, exiting")
- (exit 1)))
- (if (and state status)
- (let ((comment (launch:load-logpro-dat run-id test-id step)))
- ;; (rmt:test-set-log! run-id test-id (conc stepname ".html"))))
- (rmt:teststep-set-status! run-id test-id step state status (or comment msg) logfile))
- (begin
- (debug:print-error 0 *default-log-port* "You must specify :state and :status with every call to -step")
- (exit 6))))))
-
-(if (args:get-arg "-step")
- (begin
- (thread-sleep! 1.5)
- (megatest:step
- (args:get-arg "-step")
- (or (args:get-arg "-state")(args:get-arg ":state"))
- (or (args:get-arg "-status")(args:get-arg ":status"))
- (args:get-arg "-setlog")
- (args:get-arg "-m"))
- ;; (if db (sqlite3:finalize! db))
- (set! *didsomething* #t)
- (thread-sleep! 1.5)))
-
-(if (or (args:get-arg "-setlog") ;; since setting up is so costly lets piggyback on -test-status
- ;; (not (args:get-arg "-step"))) ;; -setlog may have been processed already in the "-step" previous
- ;; NEW POLICY - -setlog sets test overall log on every call.
- (args:get-arg "-set-toplog")
- (args:get-arg "-test-status")
- (args:get-arg "-set-values")
- (args:get-arg "-load-test-data")
- (args:get-arg "-runstep")
- (args:get-arg "-summarize-items"))
- (if (not (getenv "MT_CMDINFO"))
- (begin
- (debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!")
- (exit 5))
- (let* ((startingdir (current-directory))
- (cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO")))
- (transport (assoc/default 'transport cmdinfo))
- (testpath (assoc/default 'testpath cmdinfo))
- (test-name (assoc/default 'test-name cmdinfo))
- (runscript (assoc/default 'runscript cmdinfo))
- (db-host (assoc/default 'db-host cmdinfo))
- (run-id (assoc/default 'run-id cmdinfo))
- (test-id (assoc/default 'test-id cmdinfo))
- (itemdat (assoc/default 'itemdat cmdinfo))
- (work-area (assoc/default 'work-area cmdinfo))
- (db #f) ;; (open-db))
- (state (args:get-arg ":state"))
- (status (args:get-arg ":status"))
- (stepname (args:get-arg "-step")))
- (if (not (launch:setup))
- (begin
- (debug:print 0 *default-log-port* "Failed to setup, exiting")
- (exit 1)))
-
- (if (args:get-arg "-runstep")(debug:print-info 1 *default-log-port* "Running -runstep, first change to directory " work-area))
- (change-directory work-area)
- ;; can setup as client for server mode now
- ;; (client:setup)
-
- (if (args:get-arg "-load-test-data")
- ;; has sub commands that are rdb:
- ;; DO NOT put this one into either rmt: or open-run-close
- (tdb:load-test-data run-id test-id))
- (if (args:get-arg "-setlog")
- (let ((logfname (args:get-arg "-setlog")))
- (rmt:test-set-log! run-id test-id logfname)))
- (if (args:get-arg "-set-toplog")
- ;; DO NOT run remote
- (tests:test-set-toplog! run-id test-name (args:get-arg "-set-toplog")))
- (if (args:get-arg "-summarize-items")
- ;; DO NOT run remote
- (tests:summarize-items run-id test-id test-name #t)) ;; do force here
- (if (args:get-arg "-runstep")
- (if (null? remargs)
- (begin
- (debug:print-error 0 *default-log-port* "nothing specified to run!")
- (if db (sqlite3:finalize! db))
- (exit 6))
- (let* ((stepname (args:get-arg "-runstep"))
- (logprofile (args:get-arg "-logpro"))
- (logfile (conc stepname ".log"))
- (cmd (if (null? remargs) #f (car remargs)))
- (params (if cmd (cdr remargs) '()))
- (exitstat #f)
- (shell (let ((sh (get-environment-variable "SHELL") ))
- (if sh
- (last (string-split sh "/"))
- "bash")))
- (redir (case (string->symbol shell)
- ((tcsh csh ksh) ">&")
- ((zsh bash sh ash) "2>&1 >")
- (else ">&")))
- (fullcmd (conc "(" (string-intersperse
- (cons cmd params) " ")
- ") " redir " " logfile)))
- ;; mark the start of the test
- (rmt:teststep-set-status! run-id test-id stepname "start" "n/a" (args:get-arg "-m") logfile)
- ;; run the test step
- (debug:print-info 2 *default-log-port* "Running \"" fullcmd "\" in directory \"" startingdir)
- (change-directory startingdir)
- (set! exitstat (system fullcmd))
- (set! *globalexitstatus* exitstat)
- ;; (change-directory testpath)
- ;; run logpro if applicable ;; (process-run "ls" (list "/foo" "2>&1" "blah.log"))
- (if logprofile
- (let* ((htmllogfile (conc stepname ".html"))
- (oldexitstat exitstat)
- (cmd (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " ")))
- (debug:print-info 2 *default-log-port* "running \"" cmd "\"")
- (change-directory startingdir)
- (set! exitstat (system cmd))
- (set! *globalexitstatus* exitstat) ;; no necessary
- (change-directory testpath)
- (rmt:test-set-log! run-id test-id htmllogfile)))
- (let ((msg (args:get-arg "-m")))
- (rmt:teststep-set-status! run-id test-id stepname "end" exitstat msg logfile))
- )))
- (if (or (args:get-arg "-test-status")
- (args:get-arg "-set-values"))
- (let ((newstatus (cond
- ((number? status) (if (equal? status 0) "PASS" "FAIL"))
- ((and (string? status)
- (string->number status))(if (equal? (string->number status) 0) "PASS" "FAIL"))
- (else status)))
- ;; transfer relevant keys into a hash to be passed to test-set-status!
- ;; could use an assoc list I guess.
- (otherdata (let ((res (make-hash-table)))
- (for-each (lambda (key)
- (if (args:get-arg key)
- (hash-table-set! res key (args:get-arg key))))
- (list ":value" ":tol" ":expected" ":first_err" ":first_warn" ":units" ":category" ":variable"))
- res)))
- (if (and (args:get-arg "-test-status")
- (or (not state)
- (not status)))
- (begin
- (debug:print-error 0 *default-log-port* "You must specify :state and :status with every call to -test-status\n" help)
- (if (sqlite3:database? db)(sqlite3:finalize! db))
- (exit 6)))
- (let* ((msg (args:get-arg "-m"))
- (numoth (length (hash-table-keys otherdata))))
- ;; Convert to rpc inside the tests:test-set-status! call, not here
- (tests:test-set-status! run-id test-id state newstatus msg otherdata work-area: work-area))))
- (if (sqlite3:database? db)(sqlite3:finalize! db))
- (set! *didsomething* #t))))
-
-;;======================================================================
-;; Various helper commands can go below here
-;;======================================================================
-
-(if (or (args:get-arg "-showkeys")
- (args:get-arg "-show-keys"))
- (let ((db #f)
- (keys #f))
- (if (not (launch:setup))
- (begin
- (debug:print 0 *default-log-port* "Failed to setup, exiting")
- (exit 1)))
- (set! keys (rmt:get-keys)) ;; db))
- (debug:print 1 *default-log-port* "Keys: " (string-intersperse keys ", "))
- (if (sqlite3:database? db)(sqlite3:finalize! db))
- (set! *didsomething* #t)))
-
-(if (args:get-arg "-gui")
- (begin
- (debug:print 0 *default-log-port* "Look at the dashboard for now")
- ;; (megatest-gui)
- (set! *didsomething* #t)))
-
-(if (args:get-arg "-create-megatest-area")
- (begin
- (genexample:mk-megatest.config)
- (set! *didsomething* #t)))
-
-(if (args:get-arg "-create-test")
- (let ((testname (args:get-arg "-create-test")))
- (genexample:mk-megatest-test testname)
- (set! *didsomething* #t)))
-
-;;======================================================================
-;; Update the database schema, clean up the db
-;;======================================================================
-
-(if (args:get-arg "-rebuild-db")
- (begin
- (if (not (launch:setup))
- (begin
- (debug:print 0 *default-log-port* "Failed to setup, exiting")
- (exit 1)))
- ;; keep this one local
- ;; (open-run-close patch-db #f)
- (let ((dbstruct (db:setup #f areapath: *toppath*)))
- (common:cleanup-db dbstruct full: #t))
- (set! *didsomething* #t)))
-
-(if (args:get-arg "-cleanup-db")
- (begin
- (if (not (launch:setup))
- (begin
- (debug:print 0 *default-log-port* "Failed to setup, exiting")
- (exit 1)))
- (let ((dbstruct (db:setup #f areapath: *toppath*)))
- (common:cleanup-db dbstruct))
- (set! *didsomething* #t)))
-
-(if (args:get-arg "-mark-incompletes")
- (begin
- (if (not (launch:setup))
- (begin
- (debug:print 0 *default-log-port* "Failed to setup, exiting")
- (exit 1)))
- (open-run-close db:find-and-mark-incomplete #f)
- (set! *didsomething* #t)))
-
-;;======================================================================
-;; Update the tests meta data from the testconfig files
-;;======================================================================
-
-(if (args:get-arg "-update-meta")
- (begin
- (if (not (launch:setup))
- (begin
- (debug:print 0 *default-log-port* "Failed to setup, exiting")
- (exit 1)))
- (runs:update-all-test_meta #f)
- (set! *didsomething* #t)))
-
-;;======================================================================
-;; Start a repl
-;;======================================================================
-
-;; fakeout readline
-(include "readline-fix.scm")
-
-
-(when (args:get-arg "-diff-rep")
- (when (and
- (not (args:get-arg "-diff-html"))
- (not (args:get-arg "-diff-email")))
- (debug:print 0 *default-log-port* "Must specify -diff-html or -diff-email with -diff-rep")
- (set! *didsomething* 1)
- (exit 1))
-
- (let* ((toppath (launch:setup)))
- (do-diff-report
- (args:get-arg "-src-target")
- (args:get-arg "-src-runname")
- (args:get-arg "-target")
- (args:get-arg "-runname")
- (args:get-arg "-diff-html")
- (args:get-arg "-diff-email"))
- (set! *didsomething* #t)
- (exit 0)))
-
-(if (or (getenv "MT_RUNSCRIPT")
- (args:get-arg "-repl")
- (args:get-arg "-load"))
- (let* ((toppath (launch:setup))
- (dbstruct (if (and toppath
- (common:on-homehost?))
- (db:setup #t)
- #f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f)))
- (if *toppath*
- (cond
- ((getenv "MT_RUNSCRIPT")
- ;; How to run megatest scripts
- ;;
- ;; #!/bin/bash
- ;;
- ;; export MT_RUNSCRIPT=yes
- ;; megatest << EOF
- ;; (print "Hello world")
- ;; (exit)
- ;; EOF
-
- (repl))
- (else
- (begin
- (set! *db* dbstruct)
- (import extras) ;; might not be needed
- ;; (import csi)
- (import readline)
- (import apropos)
- ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
-
- (if *use-new-readline*
- (begin
- (install-history-file (get-environment-variable "HOME") ".megatest_history") ;; [homedir] [filename] [nlines])
- (current-input-port (make-readline-port "megatest> ")))
- (begin
- (gnu-history-install-file-manager
- (string-append
- (or (get-environment-variable "HOME") ".") "/.megatest_history"))
- (current-input-port (make-gnu-readline-port "megatest> "))))
- (if (args:get-arg "-repl")
- (repl)
- (load (args:get-arg "-load")))
- ;; (db:close-all dbstruct) <= taken care of by on-exit call
- )
- (exit)))
- (set! *didsomething* #t))))
-
-;;======================================================================
-;; Wait on a run to complete
-;;======================================================================
-
-(if (and (args:get-arg "-run-wait")
- (not (or (args:get-arg "-run")
- (args:get-arg "-runtests")))) ;; run-wait is built into runtests now
- (begin
- (if (not (launch:setup))
- (begin
- (debug:print 0 *default-log-port* "Failed to setup, exiting")
- (exit 1)))
- (operate-on 'run-wait)
- (set! *didsomething* #t)))
-
-;; ;; ;; redo me ;; Not converted to use dbstruct yet
-;; ;; ;; redo me ;;
-;; ;; ;; redo me (if (args:get-arg "-convert-to-norm")
-;; ;; ;; redo me (let* ((toppath (setup-for-run))
-;; ;; ;; redo me (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t))))
-;; ;; ;; redo me (for-each
-;; ;; ;; redo me (lambda (field)
-;; ;; ;; redo me (let ((dat '()))
-;; ;; ;; redo me (debug:print-info 0 *default-log-port* "Getting data for field " field)
-;; ;; ;; redo me (sqlite3:for-each-row
-;; ;; ;; redo me (lambda (id val)
-;; ;; ;; redo me (set! dat (cons (list id val) dat)))
-;; ;; ;; redo me (db:get-db db run-id)
-;; ;; ;; redo me (conc "SELECT id," field " FROM tests;"))
-;; ;; ;; redo me (debug:print-info 0 *default-log-port* "found " (length dat) " items for field " field)
-;; ;; ;; redo me (let ((qry (sqlite3:prepare db (conc "UPDATE tests SET " field "=? WHERE id=?;"))))
-;; ;; ;; redo me (for-each
-;; ;; ;; redo me (lambda (item)
-;; ;; ;; redo me (let ((newval ;; (sdb:qry 'getid
-;; ;; ;; redo me (cadr item))) ;; )
-;; ;; ;; redo me (if (not (equal? newval (cadr item)))
-;; ;; ;; redo me (debug:print-info 0 *default-log-port* "Converting " (cadr item) " to " newval " for test #" (car item)))
-;; ;; ;; redo me (sqlite3:execute qry newval (car item))))
-;; ;; ;; redo me dat)
-;; ;; ;; redo me (sqlite3:finalize! qry))))
-;; ;; ;; redo me (db:close-all dbstruct)
-;; ;; ;; redo me (list "uname" "rundir" "final_logf" "comment"))
-;; ;; ;; redo me (set! *didsomething* #t)))
-
-(if (args:get-arg "-import-megatest.db")
- (begin
- (db:multi-db-sync
- (db:setup #f)
- 'killservers
- 'dejunk
- 'adj-testids
- 'old2new
- ;; 'new2old
- )
- (set! *didsomething* #t)))
-
-(when (args:get-arg "-sync-brute-force")
- ((server:get-bruteforce-syncer (db:setup #t) persist-until-sync: #t))
- (set! *didsomething* #t))
-
-(if (args:get-arg "-sync-to-megatest.db")
- (let* ((dbstruct (db:setup #f))
- (tmpdbpth (cdr (dbr:dbstruct-tmpdb dbstruct)))
- (lockfile (conc tmpdbpth ".lock"))
- (locked (common:simple-file-lock lockfile))
- (res (if locked
- (db:multi-db-sync
- dbstruct
- 'new2old)
- #f)))
- (if res
- (begin
- (common:simple-file-release-lock lockfile)
- (print "Synced " res " records to megatest.db"))
- (print "Skipping sync, there is a sync in progress."))
- (set! *didsomething* #t)))
-
-(if (args:get-arg "-sync-to")
- (let ((toppath (launch:setup)))
- (tasks:sync-to-postgres *configdat* (args:get-arg "-sync-to"))
- (set! *didsomething* #t)))
-
-(if (args:get-arg "-list-test-time")
- (let* ((toppath (launch:setup)))
- (task:get-test-times)
- (set! *didsomething* #t)))
-
-(if (args:get-arg "-list-run-time")
- (let* ((toppath (launch:setup)))
- (task:get-run-times)
- (set! *didsomething* #t)))
-
-(if (args:get-arg "-generate-html")
- (let* ((toppath (launch:setup)))
- (if (tests:create-html-tree #f)
- (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/page0.html")
- (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html"))
- (set! *didsomething* #t)))
-
-(if (args:get-arg "-generate-html-structure")
- (let* ((toppath (launch:setup)))
- ;(if (tests:create-html-tree #f)
- (if (tests:create-html-summary #f)
- (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/targets.html")
- (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html"))
- (set! *didsomething* #t)))
-
-(if (args:get-arg "-syscheck")
- (begin
- (mutils:syscheck common:raw-get-remote-host-load
- server:get-best-guess-address
- read-config)
- (set! *didsomething* #t)))
-
-(if (args:get-arg "-extract-skeleton")
- (let* ((toppath (launch:setup)))
- (genexample:extract-skeleton-area (args:get-arg "-extract-skeleton"))
- (set! *didsomething* #t)))
-
-;;======================================================================
-;; Exit and clean up
-;;======================================================================
-
-(if (not *didsomething*)
- (debug:print 0 *default-log-port* help)
- (set! *time-to-exit* #t)
- )
-;;(debug:print-info 13 *default-log-port* "thread-join! watchdog")
-
-;; join the watchdog thread if it has been thread-start!ed (it may not have been started in the case of a server that never enters running state)
-;; (symbols returned by thread-state: created ready running blocked suspended sleeping terminated dead)
-;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
-(if (thread? *watchdog*)
- (case (thread-state *watchdog*)
- ((ready running blocked sleeping terminated dead)
- (thread-join! *watchdog*))))
-
-(set! *time-to-exit* #t)
-
-(if (not (eq? *globalexitstatus* 0))
- (if (or (args:get-arg "-run")(args:get-arg "-runtests")(args:get-arg "-runall"))
- (begin
- (debug:print 0 *default-log-port* "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*)
- (exit 0))
- (case *globalexitstatus*
- ((0)(exit 0))
- ((1)(exit 1))
- ((2)(exit 2))
- (else (exit 3)))))
DELETED mlaunch.scm
Index: mlaunch.scm
==================================================================
--- mlaunch.scm
+++ /dev/null
@@ -1,33 +0,0 @@
-;; Copyright 2006-2014, 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 .
-
-;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
-
-;;======================================================================
-;; MLAUNCH
-;;
-;; take jobs from the given queue and keep launching them keeping
-;; the cpu load at the targeted level
-;;
-;;======================================================================
-
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 format)
-
-(declare (unit mlaunch))
-(declare (uses db))
-(declare (uses common))
-
DELETED mockup-cached-writes.scm
Index: mockup-cached-writes.scm
==================================================================
--- mockup-cached-writes.scm
+++ /dev/null
@@ -1,48 +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 .
-;;
-
-
-(define (make-cached-writer the-db)
- (let ((db the-db)
- (queue '()))
- (lambda (cacheable . qry-params) ;; fn qry
- (if cacheable
- (begin
- (set! queue (cons qry-params queue))
- (call/cc))
- (begin
- (print "Starting transaction")
- (for-each
- (lambda (queue-item)
- (let ((fn (car queue-item))
- (qry (cdr queue-item)))
- (print "WRITE to " db ": " qry)
- )
- (reverse queue))
- (print "End transaction")
- (print "READ from " db ": " qry-params))))))
-
-(define *cw* (make-cached-writer "the db"))
-
-(define (dbcall cacheable query)
- (*cw* cacheable query))
-
-(dbcall #t "insert abc")
-(dbcall #t "insert def")
-(dbcall #t "insert hij")
-(dbcall #f "select foo")
DELETED monitor.scm
Index: monitor.scm
==================================================================
--- monitor.scm
+++ /dev/null
@@ -1,33 +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 .
-
-;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
-
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking)
-(import (prefix sqlite3 sqlite3:))
-
-(declare (unit runs))
-(declare (uses db))
-(declare (uses common))
-(declare (uses items))
-(declare (uses runconfig))
-
-(include "common_records.scm")
-(include "key_records.scm")
-(include "db_records.scm")
-(include "run_records.scm")
-
DELETED mt.scm
Index: mt.scm
==================================================================
--- mt.scm
+++ /dev/null
@@ -1,305 +0,0 @@
-;; Copyright 2006-2013, 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 .
-;;
-
-
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) posix-extras directory-utils call-with-environment-variables)
-(import (prefix sqlite3 sqlite3:))
-
-(declare (unit mt))
-(declare (uses db))
-(declare (uses common))
-(declare (uses items))
-(declare (uses runconfig))
-(declare (uses tests))
-(declare (uses server))
-(declare (uses runs))
-(declare (uses rmt))
-;; (declare (uses filedb))
-
-(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.
-
-;;======================================================================
-;; R U N S
-;;======================================================================
-
-;; runs:get-runs-by-patt
-;; get runs by list of criteria
-;; register a test run with the db
-;;
-;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
-;; to extract info from the structure returned
-;;
-(define (mt:get-runs-by-patt keys runnamepatt targpatt)
- (let loop ((runsdat (rmt:get-runs-by-patt keys runnamepatt targpatt 0 500 #f 0))
- (res '())
- (offset 0)
- (limit 500))
- ;; (print "runsdat: " runsdat)
- (let* ((header (vector-ref runsdat 0))
- (runslst (vector-ref runsdat 1))
- (full-list (append res runslst))
- (have-more (eq? (length runslst) limit)))
- ;; (debug:print 0 *default-log-port* "header: " header " runslst: " runslst " have-more: " have-more)
- (if have-more
- (let ((new-offset (+ offset limit))
- (next-batch (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit #f 0)))
- (debug:print-info 4 *default-log-port* "More than " limit " runs, have " (length full-list) " runs so far.")
- (debug:print-info 0 *default-log-port* "next-batch: " next-batch)
- (loop next-batch
- full-list
- new-offset
- limit))
- (vector header full-list)))))
-
-;;======================================================================
-;; T E S T S
-;;======================================================================
-
-(define (mt:get-tests-for-run run-id testpatt states status #!key (not-in #t) (sort-by 'event_time) (sort-order "ASC") (qryvals #f)(last-update #f))
- (let loop ((testsdat (rmt:get-tests-for-run run-id testpatt states status 0 500 not-in sort-by sort-order qryvals last-update 'normal))
- (res '())
- (offset 0)
- (limit 500))
- (let* ((full-list (append res testsdat))
- (have-more (eq? (length testsdat) limit)))
- (if have-more
- (let ((new-offset (+ offset limit)))
- (debug:print-info 4 *default-log-port* "More than " limit " tests, have " (length full-list) " tests so far.")
- (loop (rmt:get-tests-for-run run-id testpatt states status new-offset limit not-in sort-by sort-order qryvals last-update 'normal)
- full-list
- new-offset
- limit))
- full-list))))
-
-(define (mt:lazy-get-prereqs-not-met run-id waitons ref-item-path #!key (mode '(normal))(itemmaps #f) )
- (let* ((key (list run-id waitons ref-item-path mode))
- (res (hash-table-ref/default *pre-reqs-met-cache* key #f))
- (useres (let ((last-time (if (vector? res) (vector-ref res 0) #f)))
- (if last-time
- (< (current-seconds)(+ last-time 5))
- #f))))
- (if useres
- (let ((result (vector-ref res 1)))
- (debug:print 4 *default-log-port* "Using lazy value res: " result)
- result)
- (let ((newres (rmt:get-prereqs-not-met run-id waitons ref-item-path mode: mode itemmaps: itemmaps)))
- (hash-table-set! *pre-reqs-met-cache* key (vector (current-seconds) newres))
- newres))))
-
-(define (mt:get-run-stats dbstruct run-id)
-;; Get run stats from local access, move this ... but where?
- (db:get-run-stats dbstruct run-id))
-
-(define (mt:discard-blocked-tests run-id failed-test tests test-records)
- (if (null? tests)
- tests
- (begin
- (debug:print-info 1 *default-log-port* "Discarding tests from " tests " that are waiting on " failed-test)
- (let loop ((testn (car tests))
- (remt (cdr tests))
- (res '()))
- (let* ((test-dat (hash-table-ref/default test-records testn (vector #f #f '())))
- (waitons (vector-ref test-dat 2)))
- ;; (print "mt:discard-blocked-tests run-id: " run-id " failed-test: " failed-test " testn: " testn " with waitons: " waitons)
- (if (null? remt)
- (let ((new-res (reverse res)))
- ;; (print " new-res: " new-res)
- new-res)
- (loop (car remt)
- (cdr remt)
- (if (member failed-test waitons)
- (begin
- (debug:print 0 *default-log-port* "Discarding test " testn "(" test-dat ") due to " failed-test)
- res)
- (cons testn res)))))))))
-
-;;======================================================================
-;; T R I G G E R S
-;;======================================================================
-
-(define (mt:run-trigger cmd test-id test-rundir trigger logname test-name item-path event-time actual-state actual-status)
- ;; Putting the commandline into ( )'s means no control over the shell.
- ;; stdout and stderr will be caught in the NBFAKE or mt_launch.log files
- ;; or equivalent. No need to do this. Just run it?
- (let* ((fullcmd (conc "nbfake "
- cmd " "
- test-id " "
- test-rundir " "
- trigger " "
- test-name " "
- item-path " " ;; has / prepended to deal with toplevel tests
- actual-state " "
- actual-status " "
- event-time
- ))
- (prev-nbfake-log (get-environment-variable "NBFAKE_LOG")))
- (setenv "NBFAKE_LOG" (conc (cond
- ((and (directory-exists? test-rundir)
- (file-write-access? test-rundir))
- test-rundir)
- ((and (directory-exists? *toppath*)
- (file-write-access? *toppath*))
- *toppath*)
- (else (conc "/tmp/" (current-user-name))))
- "/" logname))
- (debug:print-info 0 *default-log-port* "TRIGGERED on " trigger ", running command " fullcmd " output at " (get-environment-variable "NBFAKE_LOG"))
- ;; (call-with-environment-variables
- ;; `(("NBFAKE_LOG" . ,(conc test-rundir "/" logname)))
- ;; (lambda ()
- (process-run fullcmd)
- (if prev-nbfake-log
- (setenv "NBFAKE_LOG" prev-nbfake-log)
- (unsetenv "NBFAKE_LOG"))
- )) ;; ))
-
-(define (mt:process-triggers dbstruct run-id test-id newstate newstatus)
- (if test-id
- (let* ((test-dat (db:get-test-info-by-id dbstruct run-id test-id)))
- (if test-dat
- (let* ((test-rundir (db:test-get-rundir test-dat)) ;; ) ;; )
- (test-name (db:test-get-testname test-dat))
- (item-path (db:test-get-item-path test-dat))
- (duration (db:test-get-run_duration test-dat))
- (comment (db:test-get-comment test-dat))
- (event-time (db:test-get-event_time test-dat))
- (tconfig #f)
- (state (if newstate newstate (db:test-get-state test-dat)))
- (status (if newstatus newstatus (db:test-get-status test-dat))))
- ;; (mutex-lock! *triggers-mutex*)
- (handle-exceptions
- exn
- (begin
- (debug:print-error 0 *default-log-port* " Exception in mt:process-triggers for run-id="run-id" test-id="test-id" newstate="newstate" newstatus="newstatus
- "\n error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn
- "\n test-rundir="test-rundir
- "\n test-name="test-name
- "\n item-path="item-path
- "\n state="state
- "\n status="status
- "\n")
- (print-call-chain (current-error-port))
- #f)
- (if (and test-name
- test-rundir) ;; #f means no dir set yet
- ;; (common:file-exists? test-rundir)
- ;; (directory? test-rundir))
- (call-with-environment-variables
- (list (cons "MT_TEST_NAME" (or test-name "no such test"))
- (cons "MT_TEST_RUN_DIR" (or test-rundir "no test directory yet"))
- (cons "MT_ITEMPATH" (or item-path "")))
- (lambda ()
- (if (directory-exists? test-rundir)
- (push-directory test-rundir)
- (push-directory *toppath*))
- (set! tconfig (mt:lazy-read-test-config test-name))
- (for-each (lambda (trigger)
- (let* ((munged-trigger (string-translate trigger "/ " "--"))
- (logname (conc "last-trigger-" munged-trigger ".log")))
- ;; first any triggers from the testconfig
- (let ((cmd (configf:lookup tconfig "triggers" trigger)))
- (if cmd (mt:run-trigger cmd test-id test-rundir trigger (conc "tconfig-" logname) test-name item-path event-time state status)))
- ;; next any triggers from megatest.config
- (let ((cmd (configf:lookup *configdat* "triggers" trigger)))
- (if cmd (mt:run-trigger cmd test-id test-rundir trigger (conc "mtconfig-" logname) test-name item-path event-time state status)))))
- (list
- (conc state "/" status)
- (conc state "/")
- (conc "/" status)))
- (pop-directory))
- )))
- ;; (mutex-unlock! *triggers-mutex*)
- )))))
-
-;;======================================================================
-;; S T A T E A N D S T A T U S F O R T E S T S
-;;======================================================================
-
-;; speed up for common cases with a little logic
-(define (mt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment)
- (if (not (and run-id test-id))
- (begin
- (debug:print-error 0 *default-log-port* "bad data handed to mt:test-set-state-status-by-id, run-id=" run-id ", test-id=" test-id ", newstate=" newstate)
- (print-call-chain (current-error-port))
- #f)
- (begin
- ;; cond
- ;; ((and newstate newstatus newcomment)
- ;; (rmt:general-call 'state-status-msg run-id newstate newstatus newcomment test-id))
- ;; ((and newstate newstatus)
- ;; (rmt:general-call 'state-status run-id newstate newstatus test-id))
- ;; (else
- ;; (if newstate (rmt:general-call 'set-test-state run-id newstate test-id))
- ;; (if newstatus (rmt:general-call 'set-test-status run-id newstatus test-id))
- ;; (if newcomment (rmt:general-call 'set-test-comment run-id newcomment test-id))))
- (rmt:set-state-status-and-roll-up-items run-id test-id #f newstate newstatus newcomment)
- ;; (mt:process-triggers run-id test-id newstate newstatus)
- #t)))
-
-
-(define (mt:test-set-state-status-by-id-unless-completed run-id test-id newstate newstatus newcomment)
- (let* ((test-vec (rmt:get-testinfo-state-status run-id test-id))
- (state (vector-ref test-vec 3)))
- (if (equal? state "COMPLETED")
- #t
- (rmt:set-state-status-and-roll-up-items run-id test-id #f newstate newstatus newcomment))))
-
-
-(define (mt:test-set-state-status-by-testname run-id test-name item-path new-state new-status new-comment)
- ;(let ((test-id (rmt:get-test-id run-id test-name item-path)))
- (rmt:set-state-status-and-roll-up-items run-id test-name item-path new-state new-status new-comment)
- ;; (mt:process-triggers run-id test-id new-state new-status)
- #t);)
- ;;(mt:test-set-state-status-by-id run-id test-id new-state new-status new-comment)))
-
-(define (mt:test-set-state-status-by-testname-unless-completed run-id test-name item-path new-state new-status new-comment)
- (let ((test-id (rmt:get-test-id run-id test-name item-path)))
- (mt:test-set-state-status-by-id-unless-completed run-id test-id new-state new-status new-comment)))
-
-(define (mt:lazy-read-test-config test-name)
- (let ((tconf (hash-table-ref/default *testconfigs* test-name #f)))
- (if tconf
- tconf
- (let ((test-dirs (tests:get-tests-search-path *configdat*)))
- (let loop ((hed (car test-dirs))
- (tal (cdr test-dirs)))
- ;; Setting MT_LINKTREE here is almost certainly unnecessary.
- (let ((tconfig-file (conc hed "/" test-name "/testconfig")))
- (if (and (common:file-exists? tconfig-file)
- (file-read-access? tconfig-file))
- (let ((link-tree-path (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree"))
- (old-link-tree (get-environment-variable "MT_LINKTREE")))
- (if link-tree-path (setenv "MT_LINKTREE" link-tree-path))
- (let ((newtcfg (read-config tconfig-file #f #f))) ;; NOTE: Does NOT run [system ...]
- (hash-table-set! *testconfigs* test-name newtcfg)
- (if old-link-tree
- (setenv "MT_LINKTREE" old-link-tree)
- (unsetenv "MT_LINKTREE"))
- newtcfg))
- (if (null? tal)
- (begin
- (debug:print-error 0 *default-log-port* "No readable testconfig found for " test-name)
- #f)
- (loop (car tal)(cdr tal))))))))))
-
DELETED mtargs.scm
Index: mtargs.scm
==================================================================
--- mtargs.scm
+++ /dev/null
@@ -1,23 +0,0 @@
-;;======================================================================
-;; Copyright 2019, 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 mtargs))
-
-(include "mtargs/mtargs.scm")
DELETED mtexec.scm
Index: mtexec.scm
==================================================================
--- mtexec.scm
+++ /dev/null
@@ -1,121 +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 .
-;;
-
-;; (include "common.scm")
-;; (include "megatest-version.scm")
-
-;; fake out readline usage of toplevel-command
-(define (toplevel-command . a) #f)
-
-(use srfi-1 posix srfi-69 readline ;; regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras)
- srfi-19 srfi-18 extras format pkts regex regex-case
- (prefix dbi dbi:)
- )
-
-;; (declare (uses common))
-(declare (uses margs))
-(declare (uses configf))
-;; (declare (uses rmt))
-
-;; (use ducttape-lib)
-(include "megatest-version.scm")
-(include "megatest-fossil-hash.scm")
-
-;; (require-library stml)
-
-(define help (conc "
-mtutil, part of the Megatest tool suite, documentation at http://www.kiatoa.com/fossils/megatest
- version " megatest-version "
- license GPL, Copyright Matt Welland 2006-2017
-
-Usage: mtutil action [options]
- -h : this help
- -manual : show the Megatest user manual
- -version : print megatest version (currently " megatest-version ")
-
-Queries:
- show [areas|contours... ] : show areas, contours or other section from megatest.config
- gendot : generate a graphviz dot file from pkts.
-
-Contour actions:
- process : runs import, rungen and dispatch
-
-Trigger propagation actions:
- tsend a=b,c=d... : send trigger info to all recpients in the [listeners] section
- tlisten -port N : listen for trigger info on port N
-
-Misc
- -start-dir path : switch to this directory before running mtutil
- -set-vars V1=1,V2=2 : Add environment variables to a run NB// these are
- overwritten by values set in config files.
- -log logfile : send stdout and stderr to logfile
- -repl : start a repl (useful for extending megatest)
- -load file.scm : load and run file.scm
- -debug N|N,M,O... : enable debug messages 0-N or N and M and O ...
- -list-pkt-keys : list all pkt keys
-
-Examples:
-
-# Start a megatest run in the area \"mytests\"
-mtutil run -area mytests -target v1.63/aa3e -mode-patt MYPATT -tag-expr quick
-
-# Start a contour
-mtutil run -contour quick -target v1.63/aa3e
-
-Called as " (string-intersperse (argv) " ") "
-Version " megatest-version ", built from " megatest-fossil-hash ))
- ;; first token is our action, but only if no leading dash
-
-(define *action* (if (and (> (length (argv)) 1)
- (not (string-match "^\\-.*" (cadr (argv)))))
- (cadr (argv))
- #f))
-
-(define *remargs*
- (args:get-args
- (if *action* (cdr (argv)) (argv))
- '("-log")
- '("-h")
- args:arg-hash
- 0))
-
-(if (args:get-arg "-h")
- (begin
- (print help)
- (exit)))
-
-(if (or (args:get-arg "-repl")
- (args:get-arg "-load"))
- (begin
- (import extras) ;; might not be needed
- ;; (import csi)
- (import readline)
- (import apropos)
- ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
-
- (install-history-file (get-environment-variable "HOME") ".mtutil_history") ;; [homedir] [filename] [nlines])
- (current-input-port (make-readline-port "mtutil> "))
- (if (args:get-arg "-repl")
- (repl)
- (load (args:get-arg "-load")))))
-
-#|
-(define mtconf (car (simple-setup #f)))
-(define dat (common:with-queue-db mtconf (lambda (conn)(get-pkts conn '()))))
-(pp (pkts#flatten-all dat '((cmd . ((parent . P)(url . M)))(runtype . ((parent . P)))) 'id 'group-id 'uuid 'parent 'pkt-type 'pkt 'processed))
-|#
DELETED mtut.scm
Index: mtut.scm
==================================================================
--- mtut.scm
+++ /dev/null
@@ -1,1918 +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 .
-;;
-
-;; (include "common.scm")
-(include "megatest-version.scm")
-
-;; fake out readline usage of toplevel-command
-(define (toplevel-command . a) #f)
-
-(use srfi-1 posix srfi-69 readline ;; regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras)
- srfi-19 srfi-18 extras format pkts regex regex-case
- (prefix dbi dbi:)
- (prefix sqlite3 sqlite3:)
- nanomsg)
-
-(declare (uses common))
-(declare (uses margs))
-(declare (uses configf))
-;; (declare (uses rmt))
-
-(use ducttape-lib)
-
-(include "megatest-fossil-hash.scm")
-
-(require-library stml)
-
-;; stuff for the mapper and checker functions
-;;
-(define *target-mappers* (make-hash-table))
-(define *runname-mappers* (make-hash-table))
-(define *area-checkers* (make-hash-table))
-
-(define (mtut:stml->string in-stml)
- (with-output-to-string
- (lambda ()
- (s:output-new
- (current-output-port)
- in-stml))))
-
-;; helpers for mappers/checkers
-(define (add-target-mapper name proc)
- (hash-table-set! *target-mappers* name proc))
-(define (add-runname-mapper name proc)
- (hash-table-set! *runname-mappers* name proc))
-(define (add-area-checker name proc)
- (hash-table-set! *area-checkers* name proc))
-
-;; given a runkey, xlatr-key and other info return one of the following:
-;; list of targets, null list to skip processing
-;;
-(define (map-targets mtconf aval-alist runkey area contour #!key (xlatr-key-in #f))
- (pp aval-alist)
- (print "In Map-targets")
- (let* ((xlatr-key (or xlatr-key-in
- (conf-get/default mtconf aval-alist 'targtrans)))
- (proc (hash-table-ref/default *target-mappers* xlatr-key #f)))
- (if proc
- (begin
- (print "Using target mapper: " xlatr-key)
- (handle-exceptions
- exn
- (begin
- (print "FAILED TO RUN TARGET MAPPER FOR " area ", called " xlatr-key)
- (print " function is: " (hash-table-ref/default *target-mappers* xlatr-key #f ) )
- (print " message: " ((condition-property-accessor 'exn 'message) exn))
- runkey)
- (proc runkey area contour)))
- (begin
- (if xlatr-key
- (print "ERROR: Failed to find named target translator " xlatr-key ", using original target."))
- `(,runkey))))) ;; no proc then use runkey
-
-;; given mtconf and areaconf extract a translator/filter, first look at areaconf
-;; then if not found look at default
-;;
-(define (conf-get/default mtconf areaconf keyname #!key (default #f))
- (let ((res (or (alist-ref keyname areaconf)
- (configf:lookup mtconf "default" (conc keyname))
- default)))
- (if res
- (string->symbol res)
- res)))
-
-;; this needs some thought regarding security implications.
-;;
-;; i. Check that owner of the file and calling user are same?
-;; ii. Check that we are in a legal megatest area?
-;; iii. Have some form of authentication or record of the md5sum or similar of the file?
-;; iv. Use compiled version in preference to .scm version. Thus there is a manual "blessing"
-;; required to use .mtutil.scm.
-;;
-(if (common:file-exists? "megatest.config")
- (if (common:file-exists? ".mtutil.so")
- (load ".mtutil.so")
- (if (common:file-exists? ".mtutil.scm")
- (load ".mtutil.scm"))))
-
-;; main three types of run
-;; "-run" => initiate a run
-;; "-rerun-clean" => set failed, aborted, killed, etc. (not pass/fail) to NOT_STARTED and kick off run
-;; "-rerun-all" => set all tests NOT_STARTED and kick off run again
-
-;; deprecated/do not use
-;; "-runall" => synonym for run, do not use
-;; "-runtests" => synonym for run, do not use
-
-;; Disabled help items
-;; -rollup : (currently disabled) fill run (set by :runname) with latest test(s)
-;; from prior runs with same keys
-;; Contour actions
-;; import : import pkts
-;; dispatch : dispatch queued run jobs from imported pkts
-;; rungen : look at input sense list in [rungen] and generate run pkts
-
-(define help (conc "
-mtutil, part of the Megatest tool suite, documentation at http://www.kiatoa.com/fossils/megatest
- version " megatest-version "
- license GPL, Copyright Matt Welland 2006-2017
-
-Usage: mtutil action [options]
- -h : this help
- -manual : show the Megatest user manual
- -version : print megatest version (currently " megatest-version ")
-
-Run management:
- run : initiate or resume a run, already completed and in-progress
- tests are not affected.
- rerun-clean : clean and rerun all not completed pass/fail tests
- rerun-all : clean and rerun entire run
- kill-run : kill all tests in run
- kill-rerun : kill all tests in run and restart non-completed tests
- remove : remove runs
- set-ss : set state/status
- archive : compress and move test data to archive disk
- kill : stop tests or entire runs
- db : database utilities
-
-Queries:
- show [areas|contours... ] : show areas, contours or other section from megatest.config
- gendot : generate a graphviz dot file from pkts.
-
-Contour actions:
- process : runs import, rungen and dispatch
-
-Trigger propagation actions:
- tsend a=b,c=d... : send trigger info to all recpients in the [listeners] section
- tlisten -port N : listen for trigger info on port N
-
-Selectors
- -immediate : apply this action immediately, default is to queue up actions
- -area areapatt1,area2... : apply this action only to the specified areas
- -target key1/key2/... : run for key1, key2, etc.
- -test-patt p1/p2,p3/... : % is wildcard
- -run-name : required, name for this particular test run
- -contour contourname : run all targets for contourname, requires -run-name, -target
- -state-status c/p,c/f : Specify a list of state and status patterns
- -tag-expr tag1,tag2%,.. : select tests with tags matching expression
- -mode-patt key : load testpatt from in runconfigs instead of default TESTPATT
- if -testpatt and -tagexpr are not specified
- -new state/status : specify new state/status for set-ss
-
-Misc
- -start-dir path : switch to this directory before running mtutil
- -set-vars V1=1,V2=2 : Add environment variables to a run NB// these are
- overwritten by values set in config files.
- -log logfile : send stdout and stderr to logfile
- -repl : start a repl (useful for extending megatest)
- -load file.scm : load and run file.scm
- -debug N|N,M,O... : enable debug messages 0-N or N and M and O ...
- -list-pkt-keys : list all pkt keys
-
-Utility
- db pgschema : emit postgresql schema; do \"mtutil db pgschema | psql -d mydb\"
- gatherdb [propagate] : gather dbs from all areas into /tmp/$USER_megatest/alldbs,
- optionally propagate the data to megatest2.0 format
-
-
-Examples:
-
-# Start a megatest run in the area \"mytests\"
-mtutil run -area mytests -target v1.63/aa3e -mode-patt MYPATT -tag-expr quick
-
-# Start a contour
-mtutil run -contour quick -target v1.63/aa3e
-
-Called as " (string-intersperse (argv) " ") "
-Version " megatest-version ", built from " megatest-fossil-hash ))
-
-;; args and pkt key specs
-;;
-(define *arg-keys*
- ;; used keys
- ;; a - action
- '(
- ("-area" . G) ;; maps to group
- ("-contour" . c)
- ("-append-config" . d)
- ("-state" . e)
- ("-item-patt" . i)
- ("-sync-to" . k)
- ("-new" . l) ;; l (see below) is new-ss
- ("-run-name" . n)
- ("-mode-patt" . o)
- ("-test-patt" . p) ;; idea, enhance margs ("-test-patt" "-testpatt") => yields one value in "-test-patt"
- ("-status" . s)
- ("-target" . t)
- ("-reqtarg" . R)
-
- ("-tag-expr" . x)
- ;; misc
- ("-debug" . #f) ;; for *verbosity* > 2
- ("-load" . #f) ;; load and exectute a scheme file
- ("-log" . #f)
- ("-override-user" . #f)
- ("-msg" . M)
- ("-start-dir" . S)
- ("-set-vars" . v)
- ("-config" . h)
- ("-time-out" . u)
- ("-archive" . b)
- ))
-(define *switch-keys*
- '(
- ("-h" . #f)
- ("-help" . #f)
- ("--help" . #f)
- ("-manual" . #f)
- ("-version" . #f)
- ;; misc
- ("-repl" . #f)
- ("-immediate" . I)
- ("-preclean" . r)
- ("-prepend-contour" . w)
- ("-force" . F)
- ("-list-pkt-keys" . #f)
- ))
-
-;; alist to map actions to old megatest commands
-(define *action-keys*
- '((run . "-run")
- (rerun-clean . "-rerun-clean")
- (rerun-all . "-rerun-all")
- (kill-run . "-kill-runs")
- (kill-rerun . "-kill-rerun")
- (lock . "-lock")
- (unlock . "-unlock")
- (sync . "")
- (archive . "")
- (set-ss . "-set-state-status")
- (remove . "-remove-runs")))
-
-;; manually keep this list updated from the keys to
-;; the case *action* near the end of this file.
-(define *other-actions*
- '(run remove rerun set-ss archive kill list
- dispatch import rungen process
- show gendot db tsend tlisten))
-
-;; Card types:
-;;
-;; A action
-;; U username (Unix)
-;; D timestamp
-;; T card type
-
-;; a summary list of used card types for helping to not accidentally re-use them
-;;
-;; ADGIMSTUZabcdefghiklnoprstuvwx
-
-;; utilitarian alist for standard cards
-;;
-(define *additional-cards*
- '(
- ;; Standard Cards
- (A . action )
- (D . timestamp )
- (T . cardtype )
- (U . user ) ;; username
- (Z . shar1sum )
-
- ;; Extras
- (a . runkey ) ;; needed for matching up pkts with target derived from runkey
- ;; (l . new-ss ) ;; new state/status
- (b . branch ) ;; repository branch or tag (fossil or git)
- (f . url ) ;; repository URL (e.g. fossil or git)
- (g . clone ) ;; existing clone area (cached in /tmp)
- ))
-
-;; inlst is an alternative input
-;;
-(define (lookup-param-by-key key #!key (inlst #f))
- (fold (lambda (a res)
- (if (eq? (cdr a) key)
- (car a)
- res))
- #f
- (or inlst *arg-keys*)))
-
-(define (lookup-action-by-key key)
- (alist-ref (string->symbol key) *action-keys*))
-
-(define (swizzle-alist lst)
- (map (lambda (x)(cons (cdr x)(car x))) lst))
-
-;;======================================================================
-;; U T I L S
-;;======================================================================
-
-;; given a mtutil param, return the old megatest equivalent
-;;
-(define (megatest-param->mtutil-param param)
- (let* ((mapping-alist (common:get-param-mapping flavor: 'switch-symbol)))
- (alist-ref (string->symbol param) mapping-alist eq? param)
- param))
-
-(define val->alist common:val->alist)
-
-(define (push-run-spec torun contour runkey spec)
- (configf:section-var-set! torun contour runkey
- (cons spec
- (or (configf:lookup torun contour runkey)
- '()))))
-
-(define (fossil:clone-or-sync url name dest-dir)
- (let ((targ-file (conc dest-dir "/" name))) ;; do not force usage of .fossil extension
- (handle-exceptions
- exn
- (print "ERROR: failed to create directory " dest-dir " message: " ((condition-property-accessor 'exn 'message) exn))
- (create-directory dest-dir #t))
- (handle-exceptions
- exn
- (print "ERROR: failed to clone or sync 1ossil " url " message: " ((condition-property-accessor 'exn 'message) exn))
- (if (common:file-exists? targ-file)
- (system (conc "fossil pull --once " url " -R " targ-file))
- (system (conc "fossil clone " url " " targ-file))
- ))))
-
-(define (fossil:last-change-node-and-time fossils-dir fossil-name branch)
- (let* ((fossil-file (conc fossils-dir "/" fossil-name))
- (timeline-port (if (file-read-access? fossil-file)
- (handle-exceptions
- exn
- (begin
- (print "ERROR: failed to get timeline from " fossil-file " message: " ((condition-property-accessor 'exn 'message) exn))
- #f)
- (open-input-pipe (conc "fossil timeline -t ci -W 0 -n 0 -R " fossil-file)))
- #f))
- (get-line (lambda ()
- (handle-exceptions
- exn
- (begin
- (print "ERROR: failed to read from file " fossil-file " message: " ((condition-property-accessor 'exn 'message) exn))
- #f)
- (read-line timeline-port))))
- (date-rx (regexp "^=== (\\S+) ===$"))
- (node-rx (regexp "^(\\S+) \\[(\\S+)\\].*\\(.*tags:\\s+([^\\)]+)\\)$")))
- (let loop ((inl (get-line))
- (date #f)
- (node #f)
- (time #f))
- (cond
- ((and date time node) ;; have all, return 'em
- (close-input-port timeline-port)
- (values (common:date-time->seconds (conc date " " time)) node))
- ((and inl (not (eof-object? inl))) ;; have a line to process
- (regex-case inl
- (date-rx ( _ newdate ) (loop (get-line) newdate node time))
- ;; 22:47:48 [a024d9e60f] Added *user-hash-data* - a global that can be used in -repl and #{scheme ...} calls by the end user (user: matt tags: v1.63)
- (node-rx ( _ newtime newnode alltags )
- (let ((tags (string-split-fields ",\\s*" alltags #:infix)))
- (print "tags: " tags)
- (if (member branch tags)
- (loop (get-line) date newnode newtime)
- (loop (get-line) date node time))))
- (else ;; have some unrecognised junk? spit out error message
- (print "ERROR: fossil timeline returned unrecognisable junk \"" inl "\"")
- (loop (get-line) date node time))))
- (else ;; no more datat and last node on branch not found
- (close-input-port timeline-port)
- (values (common:date-time->seconds (conc date " " time)) node))))))
-
-;;======================================================================
-;; GLOBALS
-;;======================================================================
-
-;; first token is our action, but only if no leading dash
-(define *action* (if (and (> (length (argv)) 1)
- (not (string-match "^\\-.*" (cadr (argv)))))
- (cadr (argv))
- #f))
-
-;; process arguments, extract switches and parameters first
-(define remargs (args:get-args
- (if *action* (cdr (argv)) (argv)) ;; args:get-args dumps first in argv list (the program name)
- (map car *arg-keys*)
- (map car *switch-keys*)
- args:arg-hash
- 0))
-
-;; handle requests for help
-;;
-(if (or (member *action* '("-h" "-help" "help" "--help"))
- (args:any-defined? "-h" "-help" "--help"))
- (begin
- (print help)
- (exit 1)))
-
-(define (print-pkt-keys inlst)
- (for-each
- (lambda (p)
- (let ((sw (car p))
- (c (cdr p)))
- (print (or c "n/a") "\t" sw)))
- inlst))
-
-(define (print-duplicate-keys . all)
- (let ((card-hash (make-hash-table)))
- (for-each
- (lambda (lst)
- (for-each
- (lambda (card-spec)
- (let ((k (cdr card-spec)))
- ;; (print "card-spec: " card-spec ", k: " k)
- (if k (hash-table-set! card-hash k (+ (hash-table-ref/default card-hash k 0) 1)))))
- lst))
- all)
- (for-each
- (lambda (k)
- (if (> (hash-table-ref card-hash k) 1)
- (print k "\t" (hash-table-ref card-hash k))))
- (sort (hash-table-keys card-hash) (lambda (a b)(>= (hash-table-ref card-hash a)(hash-table-ref card-hash b)))))
- ))
-
-(define (print-pkt-key-info)
- (print "Argument keys")
- (print-pkt-keys *arg-keys*)
- (print "\nSwitch keys")
- (print-pkt-keys *switch-keys*)
- (print "\nAction keys")
- (print-pkt-keys *action-keys*)
- (print "\nAdditional cards")
- (print-pkt-keys (swizzle-alist *additional-cards*))
- (print "\nDuplicate keys")
- (print-duplicate-keys *arg-keys* *switch-keys* *action-keys* (swizzle-alist *additional-cards*))
- (print "\nEnd of report.")
- )
-
-;; list packet keys
-;;
-(if (args:get-arg "-list-pkt-keys")
- (begin (print-pkt-key-info)(exit 0)))
-
-;; (print "*action*: " *action*)
-
-;; (let-values (((uuid pkt)
-;; (command-line->pkt #f args:arg-hash)))
-;; (print pkt))
-
-;; Add args that use remargs here
-;;
-(if (and (not (null? remargs))
- (not (or
- (args:get-arg "-runstep")
- (args:get-arg "-envcap")
- (args:get-arg "-envdelta")
- (member *action* '("db" "tsend" "tlisten")) ;; very loose checks on db and tsend/listen
- (equal? *action* "show") ;; just keep going if list
- )))
- (debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " ")))
-
-(if (or (args:any? "-h" "help" "-help" "--help")
- (member *action* '("-h" "-help" "--help" "help")))
- (begin
- (print help)
- (exit 1)))
-
-;;======================================================================
-;; Nanomsg transport
-;;======================================================================
-
-(define-inline (encode data)
- (with-output-to-string
- (lambda ()
- (write data))))
-
-(define-inline (decode data)
- (with-input-from-string
- data
- (lambda ()
- (read))))
-
-(define (is-port-in-use port-num)
- (let* ((ret #f))
- (let-values (((inp oup pid)
- (process "netstat" (list "-tulpn" ))))
- (let loop ((inl (read-line inp)))
- (if (not (eof-object? inl))
- (begin
- (if (string-search (regexp (conc ":" port-num)) inl)
- (begin
- ;(print "Output: " inl)
- (set! ret #t))
- (loop (read-line inp)))))))
-ret))
-
-;;start a server, returns the connection
-;;
-(define (start-nn-server portnum )
- (let ((rep (nn-socket 'rep)))
- (handle-exceptions
- exn
- (let ((emsg ((condition-property-accessor 'exn 'message) exn)))
- (print "ERROR: Failed to start server \"" emsg "\"")
- (exit 1))
-
- (nn-bind rep (conc "tcp://*:" portnum)))
- rep))
-
-(define (can-user-kill-listner user-info attrib)
- (let* ((contacts (alist-ref 'contact attrib))
- (user-id (cadddr (cdr user-info)))
- (ret #f)
- (contact-list (string-split contacts ",")))
- (for-each
- (lambda (admin)
- (if (string-contains user-id (car (string-split admin "@")))
- (set! ret #t)))
- contact-list)
- ret))
-
-;; open connection to server, send message, close connection
-;;
-(define (open-send-close-nn host-port msg attrib #!key (timeout 3) ) ;; default timeout is 3 seconds
- (let ((req (nn-socket 'req))
- (uri (conc "tcp://" host-port))
- (res #f)
- (contacts (alist-ref 'contact attrib))
- (mode (alist-ref 'mode attrib)))
- (handle-exceptions
- exn
- (let ((emsg ((condition-property-accessor 'exn 'message) exn)))
- ;; Send notification
- (print "ERROR: Failed to connect / send to " uri " message was \"" emsg "\"" )
- (if (equal? mode "production")
- (begin
- (print " Sending email to contacts : " contacts )
- (let ((email-body (mtut:stml->string (s:body
- (s:p (conc "We could not send messages to the server on " uri "." "Please check if the listner is running. It is possible that the host is overloaded due to which it may take too long to respond. \n Contact your system adminstrator if server load is high." (s:br)" Thank You ") )))))
- (sendmail (string-join (string-split contacts ";" )) (conc "[Listner Error] Filed to connect to listner on " uri) email-body use_html: #t)))
- (print " mode : " mode " Not sending any emails" ))
- #f)
- (nn-connect req uri)
- (print "Connected to the server " )
- (nn-send req msg)
- (print "Request Sent")
- (let* ((th1 (make-thread (lambda ()
- (let ((resp (nn-recv req)))
- (nn-close req)
- (set! res (if (equal? resp "ok")
- #t
- #f))))
- "recv thread"))
- (th2 (make-thread (lambda ()
- (thread-sleep! timeout)
- (thread-terminate! th1))
- "timer thread")))
- (thread-start! th1)
- (thread-start! th2)
- (thread-join! th1)
- res))))
-
-(define (open-send-receive-nn host-port msg attrib #!key (timeout 3) ) ;; default timeout is 3 seconds
- (let ((req (nn-socket 'req))
- (uri (conc "tcp://" host-port))
- (res #f)
- (contacts (alist-ref 'contact attrib))
- (mode (alist-ref 'mode attrib)))
- (handle-exceptions
- exn
- (let ((emsg ((condition-property-accessor 'exn 'message) exn)))
- ;; Send notification
- (print "ERROR: Failed to connect / send to " uri " message was \"" emsg "\"" )
- (if (equal? mode "production")
- (begin
- (print " Sending email to contacts : " contacts )
- (let ((email-body (mtut:stml->string (s:body
- (s:p (conc "We could not send messages to the server on " uri "." "Please check if the listner is running. It is possible that the host is overloaded due to which it may take too long to respond. \n Contact your system adminstrator if server load is high." (s:br)" Thank You ") )))))
- (sendmail (string-join (string-split contacts ";" )) (conc "[Listner Error] Filed to connect to listner on " uri) email-body use_html: #t)))
- (print " mode : " mode " Not sending any emails" ))
- #f)
- (nn-connect req uri)
- (print "Connected to the server " )
- (nn-send req msg)
- (print "Request Sent")
- ;; receive code here
- ;;(print (nn-recv req))
- (let* ((th1 (make-thread (lambda ()
- (let ((resp (nn-recv req)))
- (nn-close req)
- (print resp)
- (set! res (if (equal? resp "ok")
- #t
- #f))))
- "recv thread"))
- (th2 (make-thread (lambda ()
- (thread-sleep! timeout)
- (thread-terminate! th1))
- "timer thread")))
- (thread-start! th1)
- (thread-start! th2)
- (thread-join! th1)
- res))))
-
-;;======================================================================
-;; Runs
-;;======================================================================
-
-;; make a runname
-;;
-(define (make-runname pre post)
- (time->string
- (seconds->local-time (current-seconds)) "%Yw%V.%w-%H%M"))
-
-;; collect, translate, collate and assemble a pkt from the command-line
-;;
-;; sched => force the run start time to be recorded as sched Unix
-;; epoch. This aligns times properly for triggers in some cases.
-;;
-;; extra-dat format is ( 'x xval 'y yval .... )
-;;
-(define (command-line->pkt action args-alist sched-in #!key (extra-dat '())(area-path #f)(new-ss #f))
- (let* ((sched (cond
- ((vector? sched-in)(local-time->seconds sched-in)) ;; we recieved a time
- ((number? sched-in) sched-in)
- (else (current-seconds))))
- (user (if (and args-alist (hash-table? args-alist))
- (hash-table-ref/default args-alist "-override-user" (current-user-name))
- (current-user-name)))
-
- (args-data (if args-alist
- (if (hash-table? args-alist) ;; seriously?
- (hash-table->alist args-alist)
- args-alist)
- (hash-table->alist args:arg-hash))) ;; if no args-alist then we assume this is a call driven directly by commandline
- (alldat (apply append
- (list 'A action
- 'U user
- 'D sched)
- (if area-path
- (list 'S area-path) ;; the area-path is mapped to the start-dir
- '())
- (if (list? extra-dat)
- extra-dat
- (begin
- (debug:print 0 *default-log-port* "ERROR: command-line->pkt received bad extra-dat " extra-dat)
- '()))
- (map (lambda (x)
- (let* ((param (car x))
- (value (cdr x))
- (pmeta (assoc param *arg-keys*)) ;; translate the card key to a megatest switch or parameter
- (smeta (assoc param *switch-keys*)) ;; first lookup the key in arg-keys or switch-keys
- (meta (if (or pmeta smeta)
- (cdr (or pmeta smeta)) ;; found it?
- #f)))
- (if meta ;; construct the switch/param pair.
- (list meta value)
- '())))
-
- (filter cdr args-data)))))
- (print "Alldat: " alldat ) ;;Do not remove. This is uesed by other applications to calculate z card
- ;(exit)
- (add-z-card
- (apply construct-sdat alldat))))
-
-(define (simple-setup start-dir-in)
- (let* ((start-dir (or start-dir-in "."))
- (mtconfig (or (args:get-arg "-config") "megatest.config"))
- (mtconfdat (find-and-read-config ;; NB// sets MT_RUN_AREA_HOME as side effect
- mtconfig
- ;; environ-patt: "env-override"
- given-toppath: start-dir
- ;; pathenvvar: "MT_RUN_AREA_HOME"
- ))
- (mtconf (if mtconfdat (car mtconfdat) #f)))
- ;; we set some dynamic data in a section called "scratchdata"
- (if mtconf
- (begin
- (configf:section-var-set! mtconf "scratchdat" "toppath" start-dir)))
- ;; (print "TOPPATH: " (configf:lookup mtconf "scratchdat" "toppath"))
- mtconfdat))
-
-;;======================================================================
-;; Areas
-;;======================================================================
-
-;; look for areas=a1,a2,a3 OR areafn=somefuncname
-;;
-(define (val-alist->areas val-alist)
- (let ((areas-string (alist-ref 'areas val-alist))
- (areas-procname (alist-ref 'areafn val-alist)))
- (if areas-procname ;; areas-procname take precedence
- areas-procname
- (string-split (or areas-string "") ","))))
-
-;; area - the current area under consideration
-;; areas - the list of allowed areas from the contour spec -OR-
-;; if it is a string then it is the function to use to
-;; lookup in *area-checkers*
-;;
-(define (area-allowed? area areas runkey contour mode-patt)
- ;;(print "Areas: " areas)
- (cond
- ((not areas) #t) ;; no spec
- ((string? areas) ;;
- (let ((check-fn (hash-table-ref/default *area-checkers* (string->symbol areas) #f)))
- (if check-fn
- (check-fn area runkey contour mode-patt)
- #f)))
- ((list? areas)(member area areas))
- (else #f))) ;; shouldn't get here
-
-(define (get-area-names mtconf)
- (map car (configf:get-section mtconf "areas")))
-
-;;======================================================================
-;; Pkts for remote control
-;;======================================================================
-
-;; NEED TIMESTAMP ON PKTS for efficient loading of packets into db.
-
-
-;; make a run request pkt from basic data, this seriously needs to be refactored
-;; i. Take the code that builds the info to submit to create-run-pkt and have it
-;; generate the pkt keys directly.
-;; ii. Pass the pkt keys and values to this proc and go from there.
-;; iii. Maybe have an abstraction alist with meaningful names for the pkt keys
-;;
-;; Override the run start time record with sched. Usually #f is fine.
-;;
-(define (create-run-pkt mtconf action area runkey target runname mode-patt
- tag-expr pktsdir reason contour sched dbdest append-conf
- runtrans)
- (let* ((good-val (lambda (inval)(and inval (string? inval)(not (string-null? inval)))))
- (area-dat (common:val->alist (or (configf:lookup mtconf "areas" area) "")))
- (area-path (alist-ref 'path area-dat))
- ;; (area-xlatr (alist-ref 'targtrans area-dat))
- ;; (xlatr-key (if area-xlatr (string->symbol area-xlatr) #f))
- (new-runname (let* ((callname (if (string? runtrans)(string->symbol runtrans) #f))
- (mapper (if callname (hash-table-ref/default *runname-mappers* callname #f) #f)))
- ;; (print "callname=" callname " runtrans=" runtrans " mapper=" mapper)
- (if (and callname
- (not (equal? callname "auto"))
- (not mapper))
- (print "No mapper " callname " for area " area " using " callname " as the runname"))
- (if mapper
- (handle-exceptions
- exn
- (begin
- (print-call-chain)
- (print "FAILED TO RUN RUNNAME MAPPER " callname " FOR AREA " area)
- (print " message: " ((condition-property-accessor 'exn 'message) exn))
- runname)
- (print "(mapper " (string-intersperse (list runkey runname area area-path reason contour mode-patt) ", ") ")")
- (mapper runkey runname area area-path reason contour mode-patt))
- (case callname
- ((auto #f) runname)
- (else runtrans)))))
- (new-target target) ;; I believe we will want target manipulation here .. (map-targets xlatr-key runkey area contour))
- (actual-action (if action
- (if (equal? action "sync-prepend")
- "sync"
- action)
- "run"))) ;; this has gotten a bit ugly. Need a function to handle actions processing.
- ;; some hacks to remove switches not needed in certain cases
- (case (string->symbol (or action "run"))
- ((sync sync-prepend)
- (set! new-target #f)
- (set! runame #f)))
- ;; (print "area-path: " area-path " orig-target: " runkey " new-target: " new-target)
- (let-values (((uuid pkt)
- (command-line->pkt
- actual-action
- (append
- `(("-start-dir" . ,area-path)
- ;;("-msg" . ,reason)
- ("-msg" . ,"Script-triggered")
- ("-contour" . ,contour))
- (if (good-val new-runname) `(("-run-name" . ,new-runname)) '())
- (if (good-val new-target) `(("-target" . ,new-target)) '())
- (if (good-val area) `(("-area" . ,area)) '())
- (if (good-val mode-patt) `(("-mode-patt" . ,mode-patt)) '())
- (if (good-val tag-expr) `(("-tag-expr" . ,tag-expr)) '())
- (if (good-val dbdest) `(("-sync-to" . ,dbdest)) '())
- (if (good-val append-conf) `(("-append-config" . ,append-conf)) '())
- (if (equal? action "sync-prepend") '(("-prepend-contour" . " ")) '())
- (if (not (or mode-patt tag-expr))
- `(("-testpatt" . "%"))
- '())
- (if (or (not action)
- (equal? action "run"))
- `(("-preclean" . " ")
- ("-rerun-all" . " ")) ;; if run we *always* want preclean set, use single space as placeholder
- '())
- )
- sched
- extra-dat: `(a ,runkey) ;; we need the run key for marking the run as launched
- )))
- (with-output-to-file
- (conc pktsdir "/" uuid ".pkt")
- (lambda ()
- (print pkt))))))
-
-;; (use trace)(trace create-run-pkt)
-(define (contains list x) (cond ((null? list) #f) ((eq? (car list) x) #t) (else (contains (cdr list) x))))
-
-;; collect all needed data and create run pkts for contours with changed inputs
-;;
-(define (generate-run-pkts mtconf toppath)
- (let ((std-runname (conc "sched" (time->string (seconds->local-time (current-seconds)) "%M%H%d")))
- (packets-generated 0))
- (common:with-queue-db
- mtconf
- (lambda (pktsdirs pktsdir pdb)
- (let* ((rgconfdat (find-and-read-config (conc toppath "/runconfigs.config")))
- (rgconf (car rgconfdat))
- (all-areas (map car (configf:get-section mtconf "areas")))
- (contours (configf:get-section mtconf "contours"))
- (torun (make-hash-table)) ;; target => ( ... info ... )
- (rgentargs (hash-table-keys rgconf))) ;; these are the targets registered for automatically triggering
-
- ;;(print "rgentargs: " rgentargs)
- (for-each
- (lambda (runkey)
- (let* ((keydats (configf:get-section rgconf runkey)))
- (for-each
- (lambda (sense) ;; these are the sense rules
- (let* ((key (car sense))
- (val (cadr sense))
- (keyparts (string-split key ":")) ;; contour:ruletype:action:optional
- (contour (car keyparts))
- (len-key (length keyparts))
- (ruletype (if (> len-key 1)(cadr keyparts) #f))
- (action (if (> len-key 2)(caddr keyparts) #f))
- (optional (if (> len-key 3)(cadddr keyparts) #f))
- ;; (val-list (string-split-fields ";\\s*" val #:infix)) ;; (string-split val)) ;; runname-rule params
- (val-alist (common:val->alist val))
- (runname (make-runname "" ""))
- (runtrans (alist-ref 'runtrans val-alist))
-
- ;; these may or may not be defined and not all are used in each handler type in the case below
- (run-name (alist-ref 'run-name val-alist))
- (target (alist-ref 'target val-alist))
- (crontab (alist-ref 'cron val-alist))
- (areas (val-alist->areas val-alist)) ;; areas can be a single string (a reference to call an areas function), or a list of area names.
- (dbdest (alist-ref 'dbdest val-alist))
- (appendconf (alist-ref 'appendconf val-alist))
- (file-globs (alist-ref 'glob val-alist))
-
- (runstarts (find-pkts pdb '(runstart) `((c . ,contour)
- (t . ,runkey))))
- (rspkts (common:get-pkt-alists runstarts))
- ;; starttimes is for run start times and is used to know when the last run was launched
- (starttimes (common:get-pkt-times rspkts)) ;; sort by age (youngest first) and delete duplicates by target
- (last-run (if (null? starttimes) ;; if '() then it has never been run, else get the max
- 0
- (apply max (map cdr starttimes))))
- ;; synctimes is for figuring out the last time a sync was done
- (syncstarts (find-pkts pdb '(syncstart) '())) ;; no qualifiers, a sync does all tarets etc.
- (sspkts (common:get-pkt-alists syncstarts))
- (synctimes (common:get-pkt-times sspkts))
- (last-sync (if (null? synctimes) ;; if '() then it has never been run, else get the max
- 0
- (apply max (map cdr synctimes))))
- )
-
- (let ((delta (lambda (x)
- (round (/ (- (current-seconds) x) 60)))))
- (if (args:get-arg "-target")
- (if (string= (args:get-arg "-target") runkey)
- (begin (print "runkey: " runkey ", ruletype: " ruletype ", action: " action ", last-run: " last-run " time since; last-run: " (delta last-run) ", last-sync: " (delta last-sync))
- (print "val-alist=" val-alist " runtrans=" runtrans))
- (if #f (print "skipping: " runkey)))
- (begin (print "runkey: " runkey ", ruletype: " ruletype ", action: " action ", last-run: " last-run " time since; last-run: " (delta last-run) ", last-sync: " (delta last-sync))
- (print "val-alist=" val-alist " runtrans=" runtrans))
- ))
-
-
- ;; look in runstarts for matching runs by target and contour
- ;; get the timestamp for when that run started and pass it
- ;; to the rule logic here where "ruletype" will be applied
- ;; if it comes back "changed" then proceed to register the runs
-
- (case (string->symbol (or ruletype "no-such-rule"))
-
- ((no-such-rule) (print "ERROR: no such rule for " sense))
-
- ;; Handle crontab like rules
- ;;
- ((scheduled)
- (if (not (alist-ref 'cron val-alist)) ;; gotta have cron spec
- (print "ERROR: bad sense spec \"" (string-intersperse sense " ") "\" params: " val-alist)
- (let* (
- ;; (action (alist-ref 'action val-alist))
- (cron-safe-string (string-translate (string-intersperse (string-split crontab) "-") "*" "X"))
- (runname std-runname)) ;; (conc "sched" (time->string (seconds->local-time (current-seconds)) "%M%H%d")))))
- ;; (print "last-run: " last-run " need-run: " need-run)
- ;; (if need-run
- (case (string->symbol action)
- ((sync sync-prepend)
- (if (common:extended-cron crontab #f last-sync)
- (push-run-spec torun contour runkey
- `((message . ,(conc ruletype ":sync-" cron-safe-string))
- (action . ,action)
- (dbdest . ,dbdest)
- (append . ,appendconf)
- (areas . ,areas)))))
- ((run)
- (if (common:extended-cron crontab #f last-run)
- (push-run-spec torun contour runkey
- `((message . ,(conc ruletype ":" cron-safe-string))
- (runname . ,runname)
- (runtrans . ,runtrans)
- (action . ,action)
- (areas . ,areas)
- (target . ,target)))))
- ((remove)
- (push-run-spec torun contour runkey
- `((message . ,(conc ruletype ":" cron-safe-string))
- (runname . ,runname)
- (runtrans . ,runtrans)
- (action . ,action)
- (areas . ,areas)
- (target . ,target))))
- (else
- (print "ERROR: action \"" action "\" has no scheduled handler")
- )))))
-
-
- ;; script based sensors
- ;;
- ((script)
- ;; syntax is a little different here. It is a list of commands to run, "scriptname = extra_parameters;scriptname = ..."
- ;; where scriptname may be repeated multiple times. The script must return unix-epoch of last change, new-target-name and new-run-name
- ;; the script is called like this: scriptname contour runkey std-runname action extra_param1 extra_param2 ...
- (for-each
- (lambda (cmd)
- (print "cmd: " cmd)
- (let* ((script (car cmd))
- (params (cdr cmd))
- (cmd (conc script " " contour " " runkey " " std-runname " " action " " params))
- (res (handle-exceptions
- exn
- #f
- (print "Running " cmd)
- (with-input-from-pipe cmd read-lines))))
- (if (and res (not (null? res)))
- (let* ((parts (string-split (car res))) ;;
- (rem-lines (cdr res))
- (num-parts (length parts))
- (last-change (string->number (if (> num-parts 0)(car parts) "abc"))) ;; force no run if not a number returned
- (new-target (if (> num-parts 1)
- (cadr parts)
- runkey))
- (new-runname (if (> num-parts 2)
- (caddr parts)
- std-runname))
- (message (if (null? rem-lines)
- cmd
- (string-intersperse rem-lines "-")))
- (need-run (> last-change last-run)))
- (print "last-run: " last-run " need-run: " need-run)
- (if need-run
- (let* ((key-msg `((message . ,(conc ruletype ":" message))
- (runname . ,new-runname)
- (runtrans . ,runtrans)
- (action . ,action)
- (areas . ,areas)
- ;;(target . ,(list new-target)) ;; overriding with result from runing the script
- )))
- (print "key-msg: " key-msg)
- (push-run-spec torun contour
- (if optional ;; we need to be able to differentiate same contour, different behavior.
- (conc runkey ":" optional) ;; NOTE: NOT COMPLETELY IMPLEMENTED. DO NOT USE
- runkey)
- key-msg)))))))
- val-alist)) ;; iterate over the param split by ;\s*
-
- ;; script based sensors
- ;;
- ((area-script)
- ;; syntax is a little different here. It is a list of commands to run, "scriptname = extra_parameters;scriptname = ..."
- ;; where scriptname may be repeated multiple times. The script must return unix-epoch of last change, new-target-name and new-run-name
- ;; the script is called like this: scriptname contour runkey std-runname action extra_param1 extra_param2 ...
- (for-each
- (lambda (cmd)
- ;;(print "cmd: " cmd)
- ;;(print "Areas: " all-areas)
- (for-each
- (lambda (area)
- ;;(print "Area: " area)
- ;;(print "Target: " runkey)
- ;;(print "OR: " (or (string->number (if (configf:lookup mtconf "setup" "max_packets_per_run") (configf:lookup mtconf "setup" "max_packets_per_run") "10000" ))))
- ;;(print "Packets generated: " packets-generated)
- ;;(print "Comparison: " (< packets-generated 4))
- ;;(print "Full Comparison: "
- ;; (and (< packets-generated (or (string->number (if (configf:lookup mtconf "setup" "max_packets_per_run") (configf:lookup mtconf "setup" "max_packets_per_run") "10000" )) 10000))
- ;; (if (args:get-arg "-target")
- ;; (if (string= (args:get-arg "-target") runkey) (area-allowed? area "area-needs-to-be-run" runkey contour #f) #f)
- ;; (area-allowed? area "area-needs-to-be-run" runkey contour #f))))
- ;;(print "Area Allowed: " (area-allowed? area "area-needs-to-be-run" runkey contour #f))
-;Add code to check whether area is valid
- (if
- ;; This code checks whether the target has been passed in via argument, and only runs the specified target
- (and (< packets-generated (or (string->number (if (configf:lookup mtconf "setup" "max_packets_per_run") (configf:lookup mtconf "setup" "max_packets_per_run") "10000" )) 10000))
- (if (args:get-arg "-target")
- (if (string= (args:get-arg "-target") runkey) (area-allowed? area "area-needs-to-be-run" runkey contour #f) #f)
- (area-allowed? area "area-needs-to-be-run" runkey contour #f)))
-
- (let* ((script (car cmd))
- (params (cdr cmd))
- (cmd (conc script " " contour " " area " " runkey " " std-runname " " action " " params))
- (res (handle-exceptions
- exn
- #f
- (print "Running " cmd)
- (with-input-from-pipe cmd read-lines)))
- (cval (or (configf:lookup mtconf "contours" contour) ""))
- (cval-alist (common:val->alist cval)) ;; BEWARE ... NOT the same val-alist as above!
- ;;(areas (val-alist->areas cval-alist))
- (selector (alist-ref 'selector cval-alist))
- (mode-tag (and selector (string-split-fields "/" selector #:infix)))
- (mode-patt (and mode-tag (if (eq? (length mode-tag) 2)(cadr mode-tag) #f)))
- (tag-expr (and mode-tag (if (null? mode-tag) #f (car mode-tag))))
- )
- (if (and res (not (null? res)))
- (let* ((parts (string-split (car res))) ;;
- (rem-lines (cdr res))
- (num-parts (length parts))
- (last-change (string->number (if (> num-parts 0)(car parts) "abc"))) ;; force no run if not a number returned
- (new-target (if (> num-parts 1)
- (cadr parts)
- runkey))
- (new-runname (if (> num-parts 2)
- (caddr parts)
- std-runname))
- (area-pkts (find-pkts pdb '(runstart) `((c . ,contour)
- (t . ,runkey)
- (G . ,area ))))
- (runstarts (filter (lambda (my-pkt)
- ;;(print my-pkt)
- (not (contains (map
- (lambda (c)
- ;;(print "C: " c "PKT: " my-pkt)
- (let* ((ctype (car c))
- (rx (cdr c))
- ;;(foo2 (print "Ctype: " ctype " RX: " rx))
- (pkt (alist-ref 'pkt my-pkt))
- (apkt (pkt->alist pkt))
- (cdat (alist-ref ctype apkt)))
- (if rx
- (if (string-match "t" (symbol->string ctype) )
- (begin (if #f (print "RX: " rx " CDAT: " (string-join (take (string-split cdat "/") 3) "/"))) (if cdat (string-match rx (string-join (take (string-split cdat "/") 3) "/")) #f))
- (begin (if #f (print "RX: " rx " CDAT: " cdat)) (if cdat (string-match rx cdat) #f))) #f)
-
- ))
- `((c . ,contour) (t . ,runkey) (G . ,area))) #f)))
- area-pkts))
-
- ;;(test (pp runstarts))
- (rspkts (common:get-pkt-alists runstarts))
- ;; starttimes is for run start times and is used to know when the last run was launched
- (starttimes (common:get-pkt-times rspkts)) ;; sort by age (youngest first) and delete duplicates by target
- (last-run (if (null? starttimes) ;; if '() then it has never been run, else get the max
- 0
- (apply max (map cdr starttimes))))
-
- ;; (last-run 9) ;; I think we can do a more valid calculation for this based on the run started packets for this particular area and target
- (reason "Area-script-triggered")
- ;;(mode-patt #f)
- ;;(tag-expr #f)
- (sched #f)
- (message (if (null? rem-lines)
- cmd
- (string-intersperse rem-lines "-")))
- (need-run (> last-change last-run)))
- (print "last-change: " last-change " last-run: " last-run " need-run: " need-run)
- (if need-run
- (let* ((key-msg `((message . ,(conc ruletype ":" message))
- (runname . ,new-runname)
- (runtrans . ,runtrans)
- (action . ,action)
- (areas . ,area)
- ;;(target . ,(list new-target)) ;; overriding with result from runing the script
- ))
- (aval (or (configf:lookup mtconf "areas" area) ""))
- (aval-alist (common:val->alist aval))
-
- (targets (map-targets mtconf aval-alist runkey area contour)))
- (pp targets)
- (for-each (lambda (target)
- (create-run-pkt mtconf action area runkey target new-runname mode-patt
- tag-expr pktsdir reason contour sched dbdest append
- runtrans)
- (set! packets-generated (+ packets-generated 1))
- ) targets)
- ;; Add filter for targets
-
- ;;(create-run-pkt mtconf action area runkey target runname
- ;; pktsdir reason contour dbdest append
- ;; runtrans)
- (print "key-msg: " key-msg)
- ;;(push-run-spec torun contour
- ;; (if optional ;; we need to be able to differentiate same contour, different behavior.
- ;; (conc runkey ":" optional) ;; NOTE: NOT COMPLETELY IMPLEMENTED. DO NOT USE
- ;; runkey)
- ;; key-msg)
- )))))
- (if (>= packets-generated (string->number (configf:lookup mtconf "setup" "max_packets_per_run"))) (print "Skipping area: " area " and target: " runkey " due to packets-generated: " packets-generated " higher than " (configf:lookup mtconf "setup" "max_packets_per_run"))))
-
- ) (filter (lambda (x) (if (not (args:get-arg "-area")) #t (if (string= x (args:get-arg "-area")) #t #f))) all-areas))
- ) val-alist)) ;; iterate over the param split by ;\s*
-
- ;; fossil scm based triggers
- ;;
- ((fossil)
- (for-each
- (lambda (fspec)
- (print "fspec: " fspec)
- (let* ((url (symbol->string (car fspec))) ;; THIS COULD BE TROUBLE. Add option to reading line to return as string.
- (branch (cdr fspec))
- (url-is-file (string-match "^(/|file:).*$" url))
- (fname (conc (common:get-signature url) ".fossil"))
- (fdir (conc "/tmp/" (current-user-name) "/mtutil_cache")))
- ;; (if (not url-is-file) ;; need to sync first --- for now, clone 'em all.
- (fossil:clone-or-sync url fname fdir) ;; )
- (let-values (((datetime node)
- (fossil:last-change-node-and-time fdir fname branch)))
- (if (null? starttimes)
- (push-run-spec torun contour runkey
- `((message . ,(conc "fossil:" branch "-neverrun"))
- (runname . ,(conc runname "-" node))
- (runtrans . ,runtrans)
- (areas . ,areas)
- ;; (target . ,runkey)
- (action . ,action)
- ))
- (if (> datetime last-run) ;; change time is greater than last-run time
- (push-run-spec torun contour runkey
- `((message . ,(conc "fossil:" branch "-" node))
- (runname . ,(conc runname "-" node))
- (runtrans . ,runtrans)
- (areas . ,areas)
- ;; (target . ,runkey)
- (action . ,action)
- (branch . ,branch)
- (url . ,url)
- (clone . ,(conc fdir "/" fname))
- ))))
- (print "Got datetime=" datetime " node=" node))))
- val-alist))
-
- ;; sensor looking for one or more files newer than reference
- ;;
- ((file file-or) ;; one or more files must be newer than the reference
- (let* ((youngestdat (common:get-youngest (common:bash-glob file-globs)))
- (youngestmod (car youngestdat)))
- ;; (print "youngestmod: " youngestmod " starttimes: " starttimes)
- (if (null? starttimes) ;; this target has never been run
- (push-run-spec torun contour runkey
- `((message . "file:neverrun")
- (action . ,action)
- (runtrans . ,runtrans)
- ;; (target . ,runkey)
- (areas . ,areas)
- (runname . ,runname)))
- ;; (for-each
- ;; (lambda (starttime) ;; look at the time the last run was kicked off for this contour
- ;; (if (> youngestmod (cdr starttime))
- ;; (begin
- ;; (print "starttime younger than youngestmod: " starttime " Youngestmod: " youngestmod)
- (if (> youngestmod last-run)
- (push-run-spec torun contour runkey
- `((message . ,(conc ruletype ":" (cadr youngestdat)))
- (action . ,action)
- ;; (target . ,runkey)
- (runtrans . ,runtrans)
- (areas . ,areas)
- (runname . ,runname)
- ))))))
-
- ;; all globbed files must be newer than the reference
- ;;
- ((file-and) ;; all files must be newer than the reference
- (let* ((youngestdat (common:get-youngest file-globs))
- (youngestmod (car youngestdat))
- (success #t)) ;; any cases of not true, set flag to #f for AND
- ;; (print "youngestmod: " youngestmod " starttimes: " starttimes)
- (if (null? starttimes) ;; this target has never been run
- (push-run-spec torun contour runkey
- `((message . "file:neverrun")
- (runname . ,runname)
- (runtrans . ,runtrans)
- (areas . ,areas)
- ;; (target . ,runkey)
- (action . ,action)))
- ;; NB// I think this is wrong. It should be looking at last-run only.
- (if (> youngestmod last-run) ;; WAIT!! Shouldn't file-and be looking at the *oldest* file (thus all are younger than ...)
-
- ;; (for-each
- ;; (lambda (starttime) ;; look at the time the last run was kicked off for this contour
- ;; (if (< youngestmod (cdr starttime))
- ;; (set! success #f)))
- ;; starttimes))
- ;; (if success
- ;; (begin
- ;; (print "starttime younger than youngestmod: " starttime " Youngestmod: " youngestmod)
- (push-run-spec torun contour runkey
- `((message . ,(conc ruletype ":" (cadr youngestdat)))
- (runname . ,runname)
- (runtrans . ,runtrans)
- ;; (target . ,runkey)
- (areas . ,areas)
- (action . ,action)
- ))))))
- (else (print "ERROR: unrecognised rule \"" ruletype)))))
- keydats))) ;; sense rules
- (hash-table-keys rgconf))
-
- ;; now have to run populated
- (for-each
- (lambda (contour)
- (let* ((cval (or (configf:lookup mtconf "contours" contour) ""))
- (cval-alist (common:val->alist cval)) ;; BEWARE ... NOT the same val-alist as above!
- (areas (val-alist->areas cval-alist))
- (selector (alist-ref 'selector cval-alist))
- (mode-tag (and selector (string-split-fields "/" selector #:infix)))
- (mode-patt (and mode-tag (if (eq? (length mode-tag) 2)(cadr mode-tag) #f)))
- (tag-expr (and mode-tag (if (null? mode-tag) #f (car mode-tag)))))
- (print "contour: " contour " areas=" areas " cval=" cval)
- (for-each
- (lambda (runkeydatset)
- ;; (print "runkeydatset: ")(pp runkeydatset)
- (let ((runkey (car runkeydatset))
- (runkeydats (cadr runkeydatset))
- )
- (for-each
- (lambda (runkeydat)
- (for-each
- (lambda (area)
- (if (area-allowed? area areas runkey contour mode-patt) ;; is this area to be handled (from areas=a,b,c OR using areafn=abcfn and *area-checks* ...)
- (let* ((aval (or (configf:lookup mtconf "areas" area) ""))
- (aval-alist (common:val->alist aval))
- (runname (alist-ref 'runname runkeydat))
- (runtrans (alist-ref 'runtrans runkeydat))
-
- (reason (alist-ref 'message runkeydat))
- (sched (alist-ref 'sched runkeydat))
- (action (alist-ref 'action runkeydat))
- (dbdest (alist-ref 'dbdest runkeydat))
- (append (alist-ref 'append runkeydat))
- (targets ;;(or (alist-ref 'target runkeydat)
- (map-targets mtconf aval-alist runkey area contour))) ;; override with target if forced
- ;;(targets (or (alist-ref 'target runkeydat)
- ;; (map-targets mtconf aval-alist runkey area contour)))) ;; override with target if forced
- ;; NEED TO EXPAND RUNKEY => ALL TARGETS MAPPED AND THEN FOREACH ....
- ;;(print "Targets: " targets)
- ;;(print "alist: " (alist-ref 'target runkeydat))
- (for-each
- (lambda (target)
- (print "Creating pkt for runkey=" runkey " target=" target " contour=" contour " area=" area " action=" action " tag-expr=" tag-expr " mode-patt=" mode-patt)
- (if (case (or (and action (string->symbol action)) 'noaction) ;; ensure we have the needed data to run this action
- ((noaction) #f)
- ((run) (and runname reason))
- ((sync sync-prepend) (and reason dbdest))
- (else #f))
- ;; instead of unwrapping the runkeydat alist, pass it directly to create-run-pkt
- (create-run-pkt mtconf action area runkey target runname mode-patt
- tag-expr pktsdir reason contour sched dbdest append
- runtrans)
- (print "ERROR: Missing info to make a " action " call: runkey=" runkey " contour=" contour " area=" area " tag-expr=" tag-expr " mode-patt=" mode-patt " dbdest=" dbdest)
- ))
- targets))
- (print "NOTE: skipping " runkeydat " for area \"" area "\", not in " areas)))
- all-areas))
- runkeydats)))
- (let ((res (configf:get-section torun contour))) ;; each contour / target
- ;; (print "res=" res)
- res))))
- (hash-table-keys torun)))))))
-
-(define (pkt->cmdline pkta)
- (let* ((param-mapping-alist (common:get-param-mapping flavor: 'switch-symbol))
- (action (or (lookup-action-by-key (alist-ref 'A pkta)) "noaction"))
- (action-param (case (string->symbol action)
- ((-set-state-status) (conc (alist-ref 'l pkta) " "))
- (else ""))))
- (fold (lambda (a res)
- (let* ((key (car a)) ;; get the key name
- (val (cdr a))
- (par (or (lookup-param-by-key key) ;; need to check also if it is a switch
- (lookup-param-by-key key inlst: *switch-keys*))))
- (print "key: " key " val: " val " par: " par)
- ;;(if (and par (not (string= (symbol->string key) "G")))
- (if (and par)
- (conc res " " (alist-ref (string->symbol par) param-mapping-alist eq? par) " " val)
- (if (alist-ref key *additional-cards*) ;; these cards do not translate to parameters or switches
- res
- (begin
- (print "ERROR: Unknown key in packet \"" key "\" with value \"" val "\"")
- res)))))
- (conc "megatest " (if (not (member action '("sync")))
- (conc action " " action-param)
- "") (if (member action '("-run" "-rerun-clean" "-rerun-all" "-kill-rerun"))
- "-rerun DEAD,ABORT,KILLED"
- ""))
- pkta)))
-
-;; (use trace)(trace pkt->cmdline)
-
-(define (write-pkt pktsdir uuid pkt)
- (if pktsdir
- (with-output-to-file
- (conc pktsdir "/" uuid ".pkt")
- (lambda ()
- (print pkt)))
- (print "ERROR: cannot process commands without a pkts directory")))
-
-(define (check-if-modepatt-defined pkta notification-hook pktfile)
- (let* ((start-dir (alist-ref 'S pkta))
- (target (or (alist-ref 'R pkta) (alist-ref 't pkta)))
- (patt (alist-ref 'o pkta))
- (uuid (alist-ref 'Z pkta))
- (cmd (conc "megatest -show-runconfig -target " target " -start-dir " start-dir))
- (res (handle-exceptions
- exn
- #f
- (print "Running " cmd)
- (with-input-from-pipe cmd read-lines))))
- (let loop ((hed (car res))
- (tail (cdr res)))
- (if (string-contains hed patt)
- #t
- (if (null? tail)
- (begin
- (if notification-hook
- (let* ((notification-cmd (conc notification-hook " --pkt " pktfile " --msg INVALID_MODEPATT")))
- (print "Running " notification-cmd)
- (system notification-cmd)))
- #f)
- (loop (car tail) (cdr tail)))))))
-
-(define (check-if-target-defined pkta notification-hook pktfile)
- (let* ((start-dir (alist-ref 'S pkta))
- (target (alist-ref 'R pkta))
- (uuid (alist-ref 'Z pkta))
- (cmd (conc "megatest -list-targets -start-dir " start-dir))
- (res (handle-exceptions
- exn
- #f
- (print "Running " cmd)
- (with-input-from-pipe cmd read-lines))))
- (if (member target res)
- #t
- (begin
- (if notification-hook
- (let* ((notification-cmd (conc notification-hook " --pkt " pktfile " --msg INVALID_TARGET")))
- (print "Running " notification-cmd)
- (system notification-cmd)))
- #f))))
-
-
-(define (validate-cmd cmd pkta notification-hook pktfile)
- (let ((ret #t))
- (if (string-contains cmd "-reqtarg")
- (if (check-if-target-defined pkta notification-hook pktfile)
- (begin
- (print "Target is valid")
- (if (string-contains cmd "-modepatt")
- (if (check-if-modepatt-defined pkta notification-hook pktfile)
- (print "Modepatt is valid")
- (set! ret #f))))
- (set! ret #f))
- (if (string-contains cmd "-modepatt")
- (if (check-if-modepatt-defined pkta notification-hook pktfile)
- (print "Modepatt is valid")
- (set! ret #f))))
- ret))
-
-
-;; collect all needed data and create run pkts for contours with changed inputs
-;;
-(define (dispatch-commands mtconf toppath)
- ;; we are expecting a directory "logs", check and create it, create the log in /tmp if not able to create logs dir
- (let ((logdir
- (if (if (not (directory? "logs"))
- (handle-exceptions
- exn
- #f
- (create-directory "logs")
- #t)
- #t)
- "logs"
- "/tmp"))
- (cpuload (alist-ref 'adj-proc-load (common:get-normalized-cpu-load #f)))
- (maxload (string->number (or (configf:lookup mtconf "setup" "maxload")
- (configf:lookup mtconf "jobtools" "maxload") ;; respect value used by Megatest calls
- "1.1")))
- (notification-hook (if (configf:lookup mtconf "setup" "notification-hook")
- (configf:lookup mtconf "setup" "notification-hook")
- #f)))
- (common:with-queue-db
- mtconf
- (lambda (pktsdirs pktsdir pdb)
- (let* ((rgconfdat (find-and-read-config (conc toppath "/runconfigs.config")))
- (rgconf (car rgconfdat))
- (areas (configf:get-section mtconf "areas"))
- (contours (configf:get-section mtconf "contours"))
- (pkts (find-pkts pdb '(cmd) '()))
- (torun (make-hash-table)) ;; target => ( ... info ... )
- (rgentargs (hash-table-keys rgconf))) ;; these are the targets registered for automatically triggering
- (sqlite3:set-busy-handler! (dbi:db-conn pdb) (sqlite3:make-busy-timeout 10000))
- (for-each
- (lambda (pktdat)
- (let* ((pkta (alist-ref 'apkt pktdat))
- (action (alist-ref 'A pkta))
- (cmdline (pkt->cmdline pkta))
- (uuid (alist-ref 'Z pkta))
- (user (alist-ref 'U pkta))
- (area (alist-ref 'G pkta))
- (logf (conc logdir "/" uuid "-run.log"))
- (pktfile (conc pktsdir "/" uuid ".pkt"))
- (fullcmd (conc "NBFAKE_LOG=" logf " nbfake " cmdline)))
- (if (check-access user mtconf action area)
- (if (and (> cpuload maxload)
- (member action '("run" "archive"))) ;; do not run archive or run if load is over the specified limit
- (begin
- (print "WARNING: cpuload too high, skipping processing of " uuid " due to " cpuload " > " maxload)
- (if notification-hook
- (let* ((notification-cmd (conc notification-hook " --pkt " pktfile " --msg HIGH_LOAD")))
- (print "Running " notification-cmd)
- (system notification-cmd))))
- (begin
- ;; if modepatt used chek if it is defined for the target. If -reqtarg check if target exist.
- (if (validate-cmd fullcmd pkta notification-hook pktfile)
- (begin
- (print "RUNNING: " fullcmd)
- (system fullcmd) ;; replace with process ...
- (mark-processed pdb (list (alist-ref 'id pktdat)))
- (let-values (((ack-uuid ack-pkt)
- (add-z-card
- (construct-sdat 'P uuid
- 'T (case (string->symbol action)
- ((run) "runstart")
- ((sync) "syncstart") ;; example of translating run -> runstart
- (else action))
- 'G (alist-ref 'G pkta)
- 'c (alist-ref 'c pkta) ;; THIS IS WRONG! SHOULD BE 'c
- 't (alist-ref 't pkta)))))
- (write-pkt pktsdir ack-uuid ack-pkt))
- (if notification-hook
- (let* ((notification-cmd (conc notification-hook " --pkt " pktfile " --msg RUN_LAUNCHED --contour " (caar contours) " --log_path " logf )))
- (print "Running " notification-cmd)
- (system notification-cmd))))
- (begin
- (mark-processed pdb (list (alist-ref 'id pktdat)))
- (let-values (((ack-uuid ack-pkt)
- (add-z-card
- (construct-sdat 'P uuid
- 'T "invalid-input"
- 'c (alist-ref 'o pkta) ;; THIS IS WRONG! SHOULD BE 'c
- 't (alist-ref 't pkta)))))
- (write-pkt pktsdir ack-uuid ack-pkt))))))
- (begin ;; access denied! Mark as such
- (mark-processed pdb (list (alist-ref 'id pktdat)))
- (let-values (((ack-uuid ack-pkt)
- (add-z-card
- (construct-sdat 'P uuid
- 'T "access-denied"
- 'c (alist-ref 'o pkta) ;; THIS IS WRONG! SHOULD BE 'c
- 't (alist-ref 't pkta)))))
- (write-pkt pktsdir ack-uuid ack-pkt))
- (if notification-hook
- (let* ((notification-cmd (conc notification-hook " --pkt " pktfile " --msg ACCESS_DENIED")))
- (print "Running " notification-cmd)
- (system notification-cmd)))))))
- pkts))))))
-
-
-(define (check-access user mtconf action area)
- ;; NOTE: Need control over defaults. E.g. default might be no access
- (let* ((access-ctrl (hash-table-exists? mtconf "access")) ;; if there is an access section the default is to REQUIRE enablement/access
- (access-list (map (lambda (x)
- (string-split x ":"))
- (string-split (or (configf:lookup mtconf "access" area) ;; userid:rightstype userid2:rightstype2 ...
- (if access-ctrl
- "*:none" ;; nobody has access by default
- "*:all")))))
- (access-types-dat (configf:get-section mtconf "accesstypes")))
- (debug:print 2 *default-log-port* "Checking access in " access-list " with access-ctrl " access-ctrl " for area " area)
- (if access-ctrl
- (let* ((user-access (or (assoc user access-list)
- (assoc "*" access-list)))
- (access-type (if user-access
- (cadr user-access)
- #f))
- (access-types (let ((res (alist-ref access-type access-types-dat equal?)))
- (if res (car res) res)))
- (allowed-actions (string-split (or access-types ""))))
- (debug:print 2 *default-log-port* "Got " allowed-actions " for user " user " where access-types=" access-types " access-type=" access-type)
- (cond
- ((and access-types (member action allowed-actions))
- ;; (print "Access granted for " user " for " action)
- #t)
- (else
- ;; (print "Access denied for " user " for " action)
- #f))))))
-
-(define (open-logfile logpath)
- (condition-case
- (let* ((log-dir (or (pathname-directory logpath) ".")))
- (if (not (directory-exists? log-dir))
- (system (conc "mkdir -p " log-dir)))
- (open-output-file logpath))
- (exn ()
- (debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath)
- (define *didsomething* #t)
- (exit 1))))
-
-
-(define (get-pkts-dir mtconf)
- (let ((pktsdirs (configf:lookup mtconf "setup" "pktsdirs"))
- (pktsdir (if pktsdirs (car (string-split pktsdirs " ")) #f)))
- pktsdir))
-
-(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.mtutilrc")))
- (if (common:file-exists? debugcontrolf)
- (load debugcontrolf)))
-
-(if (args:get-arg "-log") ;; redirect the log always when a server
- (handle-exceptions
- exn
- (begin
- (print "ERROR: Failed to switch to log output. " ((condition-property-accessor 'exn 'message) exn))
- )
- (let* ((tl (args:get-arg "-log")) ;; run launch:setup if -server, ensure we do NOT run launch:setup if -log specified
- (logf (args:get-arg "-log")) ;; use -log unless we are a server, then craft a logfile name
- (oup (open-logfile logf)))
- ;(if (not (args:get-arg "-log"))
- ; (hash-table-set! args:arg-hash "-log" logf)) ;; fake out future queries of -log
- (print *default-log-port* "Sending log output to " logf)
- (set! *default-log-port* oup)
-)))
-
-(if *action*
- (case (string->symbol *action*)
- ((run remove rerun rerun-clean rerun-all set-ss archive kill list kill-run kill-rerun lock unlock)
-
- (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
- (mtconf (car mtconfdat))
- (area (args:get-arg "-area")) ;; look up the area to dispatch to from [areas] section
- (areasec (if area (configf:lookup mtconf "areas" area) #f))
- (areadat (if areasec (common:val->alist areasec) #f))
- (area-path (if areadat (alist-ref 'path areadat) #f))
- (pktsdirs (configf:lookup mtconf "setup" "pktsdirs"))
- (pktsdir (if pktsdirs (car (string-split pktsdirs " ")) #f))
- (adjargs (hash-table-copy args:arg-hash))
- (new-ss (args:get-arg "-new")))
- ;; check a few things
- (cond
- ((and area (not area-path))
- (print "ERROR: the specified area was not found in the [areas] table. Area name=" area)
- (exit 1))
- ((not area)
- (print "ERROR: no area specified. Use -area ")
- (exit 1))
- (else
- (let* ((usr-admin (check-access (current-user-name) mtconf "override" area))
- (user (if (and usr-admin (args:get-arg "-override-user"))
- (args:get-arg "-override-user")
- (current-user-name))))
- ; (print "user 123 " usr-admin )
- ;(exit 1)
- (if (and (not usr-admin) (args:get-arg "-override-user"))
- (begin
- (print user " does not have access to override user")
- (exit 1)))
- (if (check-access user mtconf *action* area);; check rights
- (print "Access granted for " *action* " action by " user)
- (begin
- (print "Access denied for " *action* " action by " user)
- (exit 1))))))
-
- ;; (for-each
- ;; (lambda (key)
- ;; (if (not (member key *legal-params*))
- ;; (hash-table-delete! adjargs key))) ;; we need to delete any params intended for mtutil
- ;; (hash-table-keys adjargs))
- (let-values (((uuid pkt)
- (command-line->pkt *action* adjargs #f area-path: area-path new-ss: new-ss)))
- (print "run log @ " (conc (current-directory) "/" uuid "-" *action* ".log"))
- (write-pkt pktsdir uuid pkt))))
- ((dispatch import rungen process)
- (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
- (mtconf (car mtconfdat))
- (toppath (configf:lookup mtconf "scratchdat" "toppath")))
- (case (string->symbol *action*)
- ((process) (begin
- (common:load-pkts-to-db mtconf)
- (generate-run-pkts mtconf toppath)
- (common:load-pkts-to-db mtconf)
- (dispatch-commands mtconf toppath)))
- ((import) (common:load-pkts-to-db mtconf)) ;; import pkts
- ((rungen) (generate-run-pkts mtconf toppath))
- ((dispatch) (dispatch-commands mtconf toppath)))))
- ;; misc
- ((show)
- (if (> (length remargs) 0)
- (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
- (mtconf (car mtconfdat))
- (sect-dat (configf:get-section mtconf (car remargs))))
- (if sect-dat
- (for-each
- (lambda (entry)
- (if (> (length entry) 1)
- (print (car entry) " " (cadr entry))
- (print (car entry))))
- sect-dat)
- (print "No section \"" (car remargs) "\" found")))
- (print "ERROR: list requires section parameter; areas, setup or contours")))
- ((gendot)
- (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
- (mtconf (car mtconfdat)))
- (common:load-pkts-to-db mtconf use-lt: #t) ;; need to NOT do this by default ...
- (common:with-queue-db
- mtconf
- (lambda (pktsdirs pktsdir conn)
- ;; pktspec display-fields
- (make-report "out.dot" conn
- '((cmd . ((parent . P)
- (user . M)
- (target . t)))
- (runstart . ((parent . P)
- (target . t)))
- (runtype . ((parent . P)))) ;; pktspec
- '(P U t) ;;
- ))))) ;; no ptypes listed (ptypes are strings of pkt types to read from db
- ((db)
- (if (null? remargs)
- (print "ERROR: missing sub command for db command")
- (let ((subcmd (car remargs)))
- (case (string->symbol subcmd)
- ((pgschema)
- (let* ((install-home (common:get-install-area))
- (schema-file (conc install-home "/share/db/mt-pg.sql")))
- (if (common:file-exists? schema-file)
- (system (conc "/bin/cat " schema-file)))))
- ((sqlite3schema)
- (let* ((install-home (common:get-install-area))
- (schema-file (conc install-home "/share/db/mt-sqlite3.sql")))
- (if (common:file-exists? schema-file)
- (system (conc "/bin/cat " schema-file)))))
- ((junk)
- (rmt:get-keys))))))
- ((tsend)
- (if (null? remargs)
- (print "ERROR: missing data to send to trigger listeners")
- (let* ((msg (car remargs))
- (mtconfdat (simple-setup (args:get-arg "-start-dir")))
- (mtconf (car mtconfdat))
- (time-out (if (args:get-arg "-time-out")
- (string->number (args:get-arg "-time-out"))
- 5))
- (listeners (configf:get-section mtconf "listeners"))
- (user-info (user-information (current-user-id)))
- (prev-seen (make-hash-table))) ;; catch duplicates
- (if user-info
- (begin
- (for-each
- (lambda (listener)
- (let ((host-port (car listener))
- (attrib (val->alist (cadr listener))))
- (if (and (equal? msg "time-to-die") (not (can-user-kill-listner user-info attrib)))
- (begin
- (debug:print-error 0 *default-log-port* "User " (car user-info) " is not allowed to send message '" msg"'")
- (exit 1)))
- (print "sending " msg " to " host-port )
- (open-send-close-nn host-port msg attrib timeout: time-out )))
- listeners))
- (begin
- (debug:print-error 0 *default-log-port* "Could not Identify executing user. Will not send any message")
- (exit 1))))))
- ((tquery)
- (if (null? remargs)
- (print "ERROR: missing data to send to trigger listeners")
- (let* ((msg (car remargs))
- (mtconfdat (simple-setup (args:get-arg "-start-dir")))
- (mtconf (car mtconfdat))
- (time-out (if (args:get-arg "-time-out")
- (string->number (args:get-arg "-time-out"))
- 5))
- (listeners (configf:get-section mtconf "listeners"))
- (user-info (user-information (current-user-id)))
- (prev-seen (make-hash-table))) ;; catch duplicates
- (if user-info
- (begin
- (for-each
- (lambda (listener)
- (let ((host-port (car listener))
- (attrib (val->alist (cadr listener))))
- (if (and (equal? msg "time-to-die") (not (can-user-kill-listner user-info attrib)))
- (begin
- (debug:print-error 0 *default-log-port* "User " (car user-info) " is not allowed to send message '" msg"'")
- (exit 1)))
- (print "sending " msg " to " host-port )
- (open-send-receive-nn host-port msg attrib timeout: time-out )))
- listeners))
- (begin
- (debug:print-error 0 *default-log-port* "Could not Identify executing user. Will not send any message")
- (exit 1))))))
-
- ((tquerylisten)
- (if (null? remargs)
- (print "ERROR: useage for tlisten is \"mtutil tlisten portnum\"")
- (let ((portnum (string->number (car remargs))))
-
- (if (not portnum)
- (print "ERROR: the portnumber parameter must be a number, you gave: " (car remargs))
- (begin
- (if (not (is-port-in-use portnum))
- (let* ((rep (start-nn-server portnum))
- (mtconfdat (simple-setup (args:get-arg "-start-dir")))
- (mtconf (car mtconfdat))
- (contact (configf:lookup mtconf "listener" "owner"))
- (script (configf:lookup mtconf "listener" "script")))
- (print "Listening on port " portnum " for messages.")
- (set-signal-handler! signal/int (lambda (signum)
- (set! *time-to-exit* #t)
- (debug:print-error 0 *default-log-port* "Received signal " signum " sending email befor exiting !!")
- (let ((email-body (mtut:stml->string (s:body
- (s:p (conc "Received signal " signum ". Lister has been terminated on host " (get-environment-variable "HOST") ". "))))))
- (sendmail contact "Listner has been terminated." email-body use_html: #t))
- (exit)))
- (set-signal-handler! signal/term (lambda (signum)
- (set! *time-to-exit* #t)
- (debug:print-error 0 *default-log-port* "Received signal " signum " sending email befor exiting !!")
- (let ((email-body (mtut:stml->string (s:body
- (s:p (conc "Received signal " signum ". Lister has been terminated on host " (get-environment-variable "HOST") ". "))))))
- (sendmail contact "Listner has been terminated." email-body use_html: #t))
- (exit)))
-
- ;(set-signal-handler! signal/term special-signal-handler)
-
- (let loop ((instr (nn-recv rep)))
- ;;(nn-send rep "3.9")
- (with-input-from-pipe (conc "/usr/bin/uptime | cut -d':' -f4 | awk '{print $1}' | cut -d',' -f1")
- (lambda()
- (let loop ((inl (read-line)))
- (if (not (eof-object? inl))
- (begin
- ;;(print "fdk73: " inl ":")
- ;;(set! current-list-ciaf (append! current-list-ciaf (list (string-substitute "\\s+$" "" inl))))
- (nn-send rep inl)
- (loop(read-line)))
- ))
-
- )
- )
- ;;(print (isys "/usr/bin/uptime" foreach-stdout-thunk: foreach-stdout))
- (let ((ctime (date->string (current-date))))
- (if (equal? instr "time-to-die")
- (begin
- (debug:print 0 *default-log-port* ctime " received '" instr "'. Time to sucide." )
- (let ((pid (current-process-id)))
- (debug:print 0 *default-log-port* "Killing current process (pid=" pid ")")
- (system (conc "kill " pid))))
- (begin
- (debug:print 0 *default-log-port* ctime " received " instr )
- ;(nn-send rep "ok")
- (if (not (equal? instr "ping"))
- (begin
- (debug:print 0 *default-log-port* ctime " running \"" script " " instr "\"")
- ;(system (conc script " '" instr "'"))
- (process-run script (list instr ))
- (debug:print 0 *default-log-port* ctime " done" ))
- (begin
- (if (not (equal? instr "load"))
- (print "Checking load")
-
- )
- )
-
- )
-
- )))
- (loop (nn-recv rep))))
- (print "ERROR: Port " portnum " already in use. Try another port")))))))
-
-
-
-
- ((tlisten)
- (if (null? remargs)
- (print "ERROR: useage for tlisten is \"mtutil tlisten portnum\"")
- (let ((portnum (string->number (car remargs))))
-
- (if (not portnum)
- (print "ERROR: the portnumber parameter must be a number, you gave: " (car remargs))
- (begin
- (if (not (is-port-in-use portnum))
- (let* ((rep (start-nn-server portnum))
- (mtconfdat (simple-setup (args:get-arg "-start-dir")))
- (mtconf (car mtconfdat))
- (contact (configf:lookup mtconf "listener" "owner"))
- (script (configf:lookup mtconf "listener" "script")))
- (print "Listening on port " portnum " for messages.")
- (set-signal-handler! signal/int (lambda (signum)
- (set! *time-to-exit* #t)
- (debug:print-error 0 *default-log-port* "Received signal " signum " sending email befor exiting !!")
- (let ((email-body (mtut:stml->string (s:body
- (s:p (conc "Received signal " signum ". Lister has been terminated on host " (get-environment-variable "HOST") ". "))))))
- (sendmail contact "Listner has been terminated." email-body use_html: #t))
- (exit)))
- (set-signal-handler! signal/term (lambda (signum)
- (set! *time-to-exit* #t)
- (debug:print-error 0 *default-log-port* "Received signal " signum " sending email befor exiting !!")
- (let ((email-body (mtut:stml->string (s:body
- (s:p (conc "Received signal " signum ". Lister has been terminated on host " (get-environment-variable "HOST") ". "))))))
- (sendmail contact "Listner has been terminated." email-body use_html: #t))
- (exit)))
-
- ;(set-signal-handler! signal/term special-signal-handler)
-
- (let loop ((instr (nn-recv rep)))
- (nn-send rep "ok")
- (let ((ctime (date->string (current-date))))
- (if (equal? instr "time-to-die")
- (begin
- (debug:print 0 *default-log-port* ctime " received '" instr "'. Time to sucide." )
- (let ((pid (current-process-id)))
- (debug:print 0 *default-log-port* "Killing current process (pid=" pid ")")
- (system (conc "kill " pid))))
- (begin
- (debug:print 0 *default-log-port* ctime " received " instr )
- ;(nn-send rep "ok")
- (if (not (equal? instr "ping"))
- (begin
- (debug:print 0 *default-log-port* ctime " running \"" script " " instr "\"")
- (system (conc script " '" instr "' &"))
- ;(process-run script (list instr ))
- (debug:print 0 *default-log-port* ctime " done" ))
- (begin
- (if (not (equal? instr "load"))
- (print "Checking load")
-
- )
- )
-
- )
-
- )))
- (loop (nn-recv rep))))
- (print "ERROR: Port " portnum " already in use. Try another port")))))))
- ((gather) ;; gather all area db's into /tmp/$USER_megatest/alldbs
- (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
- (mtconf (car mtconfdat))
- (areas (get-area-names mtconf)))
- (print "areas: " areas)))
-
- (else
- (let ((all-actions (sort (map conc (delete-duplicates (append *other-actions* (map car *action-keys*)))) string<=?)))
- (print "unrecognised action: \"" *action* "\", try one of; \"" (string-intersperse all-actions "\", \"") "\"")))
-
- )) ;; the end
-
-
-;; If HTTP_HOST is defined then we must be in the cgi environment
-;; so run stml and exit
-;;
-(if (get-environment-variable "HTTP_HOST")
- (begin
- (stml:main #f)
- (exit)))
-
-(if (or (args:get-arg "-repl")
- (args:get-arg "-load"))
- (begin
- (import extras) ;; might not be needed
- ;; (import csi)
- (import readline)
- (import apropos)
- ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
-
- (install-history-file (get-environment-variable "HOME") ".mtutil_history") ;; [homedir] [filename] [nlines])
- (current-input-port (make-readline-port "mtutil> "))
- (if (args:get-arg "-repl")
- (repl)
- (load (args:get-arg "-load")))))
-
-#|
-(define mtconf (car (simple-setup #f)))
-(define dat (common:with-queue-db mtconf (lambda (conn)(get-pkts conn '()))))
-(pp (pkts#flatten-all dat '((cmd . ((parent . P)(url . M)))(runtype . ((parent . P)))) 'id 'group-id 'uuid 'parent 'pkt-type 'pkt 'processed))
-|#
DELETED mutils.scm
Index: mutils.scm
==================================================================
--- mutils.scm
+++ /dev/null
@@ -1,23 +0,0 @@
-;;======================================================================
-;; Copyright 2019, 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 mutils))
-
-(include "mutils/mutils.scm")
DELETED newdashboard.scm
Index: newdashboard.scm
==================================================================
--- newdashboard.scm
+++ /dev/null
@@ -1,742 +0,0 @@
-;;======================================================================
-;; Copyright 2006-2016, 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 .
-
-;;======================================================================
-
-(use format)
-
-(use (prefix iup iup:))
-
-(use canvas-draw)
-(import canvas-draw-iup)
-
-(use sql-de-lite srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors ;; defstruct
- (prefix dbi dbi:))
-
-(declare (uses common))
-(declare (uses megatest-version))
-(declare (uses margs))
-
-;; (declare (uses launch))
-;; (declare (uses gutils))
-;; (declare (uses db))
-;; (declare (uses server))
-;; (declare (uses synchash))
-(declare (uses dcommon))
-;; (declare (uses tree))
-;;
-;; (include "common_records.scm")
-;; (include "db_records.scm")
-;; (include "key_records.scm")
-
-(define help (conc
-"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
- version " megatest-version "
- license GPL, Copyright (C) Matt Welland 2011
-
-Usage: dashboard [options]
- -h : this help
- -server host:port : connect to host:port instead of db access
- -test testid : control test identified by testid
- -guimonitor : control panel for runs
-
-Misc
- -rows N : set number of rows
-"))
-
-;; process args
-(define remargs (args:get-args
- (argv)
- (list "-rows"
- "-run"
- "-test"
- "-debug"
- "-host"
- )
- (list "-h"
- "-guimonitor"
- "-main"
- "-v"
- "-q"
- )
- args:arg-hash
- 0))
-
-(if (args:get-arg "-h")
- (begin
- (print help)
- (exit)))
-
-;; ease debugging by loading ~/.dashboardrc
-(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
- (if (common:file-exists? debugcontrolf)
- (load debugcontrolf)))
-
-(debug:setup)
-
-(define *tim* (iup:timer))
-(define *ord* #f)
-
-(iup:attribute-set! *tim* "TIME" 300)
-(iup:attribute-set! *tim* "RUN" "YES")
-
-(define (message-window msg)
- (iup:show
- (iup:dialog
- (iup:vbox
- (iup:label msg #:margin "40x40")))))
-
-(define (iuplistbox-fill-list lb items . default)
- (let ((i 1)
- (selected-item (if (null? default) #f (car default))))
- (iup:attribute-set! lb "VALUE" (if selected-item selected-item ""))
- (for-each (lambda (item)
- (iup:attribute-set! lb (number->string i) item)
- (if selected-item
- (if (equal? selected-item item)
- (iup:attribute-set! lb "VALUE" item))) ;; (number->string i))))
- (set! i (+ i 1)))
- items)
- i))
-
-(define (pad-list l n)(append l (make-list (- n (length l)))))
-
-
-(define (mkstr . x)
- (string-intersperse (map conc x) ","))
-
-(define (update-search x val)
- (hash-table-set! *searchpatts* x val))
-
-
-;; data for each specific tab goes here
-;;
-(defstruct dboard:tabdat
- ;; runs
- ((allruns '()) : list) ;; list of dboard:rundat records
- ((allruns-by-id (make-hash-table)) : hash-table) ;; hash of run-id -> dboard:rundat records
- ((done-runs '()) : list) ;; list of runs already drawn
- ((not-done-runs '()) : list) ;; list of runs not yet drawn
- (header #f) ;; header for decoding the run records
- (keys #f) ;; keys for this run (i.e. target components)
- ((numruns (string->number (or (args:get-arg "-cols") "10"))) : number) ;;
- ((tot-runs 0) : number)
- ((last-data-update 0) : number) ;; last time the data in allruns was updated
- ((last-runs-update 0) : number) ;; last time we pulled the runs info to update the tree
- (runs-mutex (make-mutex)) ;; use to prevent parallel access to draw objects
- ((run-update-times (make-hash-table)) : hash-table) ;; update times indexed by run-id
- ((last-test-dat (make-hash-table)) : hash-table) ;; cache last tests dat by run-id
- ((run-db-paths (make-hash-table)) : hash-table) ;; cache the paths to the run db files
-
- ;; Runs view
- ((buttondat (make-hash-table)) : hash-table) ;;
- ((item-test-names '()) : list) ;; list of itemized tests
- ((run-keys (make-hash-table)) : hash-table)
- (runs-matrix #f) ;; used in newdashboard
- ((start-run-offset 0) : number) ;; left-right slider value
- ((start-test-offset 0) : number) ;; up-down slider value
- ((runs-btn-height (or (configf:lookup *configdat* "dashboard" "btn-height") "x16")) : string) ;; was 12
- ((runs-btn-fontsz (or (configf:lookup *configdat* "dashboard" "btn-fontsz") "10")) : string) ;; was 8
- ((runs-cell-width (or (configf:lookup *configdat* "dashboard" "cell-width") "60")) : string) ;; was 50
- ((all-test-names '()) : list)
-
- ;; Canvas and drawing data
- (cnv #f)
- (cnv-obj #f)
- (drawing #f)
- ((run-start-row 0) : number)
- ((max-row 0) : number)
- ((running-layout #f) : boolean)
- (originx #f)
- (originy #f)
- ((layout-update-ok #t) : boolean)
- ((compact-layout #t) : boolean)
-
- ;; Run times layout
- ;; (graph-button-box #f) ;; RA => Think it is not referenced anywhere
- (graph-matrix #f)
- ((graph-matrix-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru graph name info
- ((graph-cell-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru matrix cell info
- ((graph-matrix-row 1) : number)
- ((graph-matrix-col 1) : number)
-
- ;; Controls used to launch runs etc.
- ((command "") : string) ;; for run control this is the command being built up
- (command-tb #f) ;; widget for the type of command; run, remove-runs etc.
- (test-patterns-textbox #f) ;; text box widget for editing a list of test patterns
- (key-listboxes #f)
- (key-lbs #f)
- run-name ;; from run name setting widget
- states ;; states for -state s1,s2 ...
- statuses ;; statuses for -status s1,s2 ...
-
- ;; Selector variables
- curr-run-id ;; current row to display in Run summary view
- prev-run-id ;; previous runid selected before current runid was selected (used in xor-two-runs runs summary mode
- curr-test-ids ;; used only in dcommon:run-update which is used in newdashboard
- ((filters-changed #t) : boolean) ;; to indicate that the user changed filters for this tab
- ((last-filter-str "") : string) ;; conc the target runname and testpatt for a signature of changed filters
- ((hide-empty-runs #f) : boolean)
- ((hide-not-hide #t) : boolean) ;; toggle for hide/not hide empty runs
- (hide-not-hide-button #f)
- ((searchpatts (make-hash-table)) : hash-table) ;;
- ((state-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATE => #t/#f for display control
- ((status-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATUS => #t/#f
- (target #f)
- (test-patts #f)
-
- ;; db info to file the .db files for the area
- (access-mode (db:get-access-mode)) ;; use cached db or not
- (dbdir #f)
- (dbfpath #f)
- (dbkeys #f)
- ((last-db-update (make-hash-table)) : hash-table) ;; last db file timestamp
- (monitor-db-path #f) ;; where to find monitor.db
- ro ;; is the database read-only?
-
- ;; tests data
- ((num-tests 10) : number) ;; total number of tests to show (used in the old runs display)
-
- ;; runs tree
- ((path-run-ids (make-hash-table)) : hash-table) ;; path (target / runname) => id
- (runs-tree #f)
- ((runs-tree-ht (make-hash-table)) : hash-table) ;; track which targets added to tree (merge functionality with path-run-ids?)
-
- ;; tab data
- ((view-changed #t) : boolean)
- ((xadj 0) : number) ;; x slider number (if using canvas)
- ((yadj 0) : number) ;; y slider number (if using canvas)
- ;; runs-summary tab state
- ((runs-summary-modes '((one-run . "Show One Run") (xor-two-runs . "XOR Two Runs") (xor-two-runs-hide-clean . "XOR; Hide Clean")) ) : list)
- ((runs-summary-mode-buttons '()) : list)
- ((runs-summary-mode 'one-run) : symbol)
- ((runs-summary-mode-change-callbacks '()) : list)
- (runs-summary-source-runname-label #f)
- (runs-summary-dest-runname-label #f)
- ;; runs summary view
-
- tests-tree ;; used in newdashboard
- )
-
-
-
-;; mtest is actually the megatest.config file
-;;
-(define (mtest toppath window-id)
- (let* ((curr-row-num 0)
- ;; (rawconfig (read-config (conc toppath "/megatest.config") #f 'return-string))
- (keys-matrix (iup:matrix)) ;; (dcommon:keys-matrix rawconfig))
- (setup-matrix (iup:matrix)) ;; (dcommon:section-matrix rawconfig "setup" "Varname" "Value"))
- (jobtools-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 5
- #:numcol-visible 1
- #:numlin-visible 3))
- (validvals-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 2
- #:numcol-visible 1
- #:numlin-visible 2))
- (envovrd-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 20
- #:numcol-visible 1
- #:numlin-visible 8))
- (disks-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 20
- #:numcol-visible 1
- #:numlin-visible 8))
- )
- (iup:attribute-set! disks-matrix "0:0" "Disk Name")
- (iup:attribute-set! disks-matrix "0:1" "Disk Path")
- (iup:attribute-set! disks-matrix "WIDTH1" "120")
- (iup:attribute-set! disks-matrix "WIDTH0" "100")
- (iup:attribute-set! disks-matrix "ALIGNMENT1" "ALEFT")
- (iup:attribute-set! disks-matrix "FIXTOTEXT" "C1")
- (iup:attribute-set! disks-matrix "RESIZEMATRIX" "YES")
-
- ;; fill in existing info
- (for-each
- (lambda (mat fname)
- (set! curr-row-num 1)
- (for-each
- (lambda (var)
- (iup:attribute-set! mat (conc curr-row-num ":0") var)
- ;; (iup:attribute-set! mat (conc curr-row-num ":1") (config-lookup rawconfig fname var))
- (set! curr-row-num (+ curr-row-num 1)))
- '()));; (configf:section-vars rawconfig fname)))
- (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix disks-matrix)
- (list "setup" "jobtools" "validvalues" "env-override" "disks"))
-
- (for-each
- (lambda (mat)
- (iup:attribute-set! mat "0:1" "Value")
- (iup:attribute-set! mat "0:0" "Var")
- (iup:attribute-set! mat "ALIGNMENT1" "ALEFT")
- (iup:attribute-set! mat "FIXTOTEXT" "C1")
- (iup:attribute-set! mat "RESIZEMATRIX" "YES")
- (iup:attribute-set! mat "WIDTH1" "120")
- (iup:attribute-set! mat "WIDTH0" "100")
- )
- (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix))
-
- (iup:attribute-set! validvals-matrix "WIDTH1" "290")
- (iup:attribute-set! envovrd-matrix "WIDTH1" "290")
-
- (iup:vbox
- (iup:hbox
-
- (iup:vbox
- (let ((tabs (iup:tabs
- ;; The required tab
- (iup:hbox
- ;; The keys
- (iup:frame
- #:title "Keys (required)"
- (iup:vbox
- (iup:label (conc "Set the fields for organising your runs\n"
- "here. Note: can only be changed before\n"
- "running the first run when megatest.db\n"
- "is created."))
- keys-matrix))
- (iup:vbox
- ;; The setup section
- (iup:frame
- #:title "Setup"
- (iup:vbox
- (iup:label (conc "max_concurrent_jobs : limits total concurrent jobs (optional)\n"
- "linktree : directory where linktree will be created."))
- setup-matrix))
- ;; The jobtools
- (iup:frame
- #:title "Jobtools"
- (iup:vbox
- (iup:label (conc "launcher : tool or script to run jobs (try nbfake)\n"
- "useshell : use system to run your launcher\n"
- "workhosts : spread jobs out on these hosts"))
- jobtools-matrix))
- ;; The disks
- (iup:frame
- #:title "Disks"
- (iup:vbox
- (iup:label (conc "Enter names and existing paths of locations to run tests"))
- disks-matrix))))
- ;; The optional tab
- (iup:vbox
- ;; The Environment Overrides
- (iup:frame
- #:title "Env override"
- envovrd-matrix)
- ;; The valid values
- (iup:frame
- #:title "Validvalues"
- validvals-matrix)
- ))))
- (iup:attribute-set! tabs "TABTITLE0" "Required settings")
- (iup:attribute-set! tabs "TABTITLE1" "Optional settings")
- tabs))
- ))))
-
-;; The runconfigs.config file
-;;
-(define (rconfig window-id)
- (iup:vbox
- (iup:frame #:title "Default")))
-
-;;======================================================================
-;; T E S T S
-;;======================================================================
-
-(define (tree-path->test-id path)
- (if (not (null? path))
- (hash-table-ref/default (dboard:data-path-test-ids *data*) path #f)
- #f))
-
-(define (test-panel window-id)
- (let* ((curr-row-num 0)
- (viewlog (lambda (x)
- (if (common:file-exists? logfile)
- ;(system (conc "firefox " logfile "&"))
- (iup:send-url logfile)
- (message-window (conc "File " logfile " not found")))))
- (xterm (lambda (x)
- (if (directory-exists? rundir)
- (let ((shell (if (get-environment-variable "SHELL")
- (conc "-e " (get-environment-variable "SHELL"))
- "")))
- (system (conc "cd " rundir
- ";xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&")))
- (message-window (conc "Directory " rundir " not found")))))
- (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -12"))
- (command-launch-button (iup:button "Execute!"
- ;; #:expand "HORIZONTAL"
- #:size "50x"
- #:action (lambda (x)
- (let ((cmd (iup:attribute command-text-box "VALUE")))
- (system (conc cmd " &"))))))
- (run-test (lambda (x)
- (iup:attribute-set!
- command-text-box "VALUE"
- (conc "xterm -geometry 180x20 -e \"megatest -target " keystring " :runname " runname
- " -runtests " (conc testname "/" (if (equal? item-path "")
- "%"
- item-path))
- ";echo Press any key to continue;bash -c 'read -n 1 -s'\""))))
- (remove-test (lambda (x)
- (iup:attribute-set!
- command-text-box "VALUE"
- (conc "xterm -geometry 180x20 -e \"megatest -remove-runs -target " keystring " :runname " runname
- " -testpatt " (conc testname "/" (if (equal? item-path "")
- "%"
- item-path))
- " -v;echo Press any key to continue;bash -c 'read -n 1 -s'\""))))
- (run-info-matrix (iup:matrix
- #:expand "YES"
- ;; #:scrollbar "YES"
- #:numcol 1
- #:numlin 4
- #:numcol-visible 1
- #:numlin-visible 4
- #:click-cb (lambda (obj lin col status)
- (print "obj: " obj " lin: " lin " col: " col " status: " status))))
- (test-info-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 7
- #:numcol-visible 1
- #:numlin-visible 7))
- (test-run-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 5
- #:numcol-visible 1
- #:numlin-visible 5))
- (meta-dat-matrix (iup:matrix
- #:expand "YES"
- #:numcol 1
- #:numlin 5
- #:numcol-visible 1
- #:numlin-visible 5))
- (steps-matrix (iup:matrix
- #:expand "YES"
- #:numcol 6
- #:numlin 50
- #:numcol-visible 6
- #:numlin-visible 8))
- (data-matrix (iup:matrix
- #:expand "YES"
- #:numcol 8
- #:numlin 50
- #:numcol-visible 8
- #:numlin-visible 8))
- (updater (lambda (testdat)
- (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix))))
-
- ;; Set the updater in updaters
- ;; (hash-table-set! (dboard:data-updaters *data*) window-id updater)
- ;;
- (for-each
- (lambda (mat)
- ;; (iup:attribute-set! mat "0:1" "Value")
- ;; (iup:attribute-set! mat "0:0" "Var")
- (iup:attribute-set! mat "HEIGHT0" 0)
- (iup:attribute-set! mat "ALIGNMENT1" "ALEFT")
- ;; (iup:attribute-set! mat "FIXTOTEXT" "C1")
- (iup:attribute-set! mat "RESIZEMATRIX" "YES"))
- ;; (iup:attribute-set! mat "WIDTH1" "120")
- ;; (iup:attribute-set! mat "WIDTH0" "100"))
- (list run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix))
-
- ;; Steps matrix
- (iup:attribute-set! steps-matrix "0:1" "Step Name")
- (iup:attribute-set! steps-matrix "0:2" "Start")
- (iup:attribute-set! steps-matrix "WIDTH2" "40")
- (iup:attribute-set! steps-matrix "0:3" "End")
- (iup:attribute-set! steps-matrix "WIDTH3" "40")
- (iup:attribute-set! steps-matrix "0:4" "Status")
- (iup:attribute-set! steps-matrix "WIDTH4" "40")
- (iup:attribute-set! steps-matrix "0:5" "Duration")
- (iup:attribute-set! steps-matrix "WIDTH5" "40")
- (iup:attribute-set! steps-matrix "0:6" "Log File")
- (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT")
- ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1")
- (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES")
- ;; (iup:attribute-set! steps-matrix "WIDTH1" "120")
- ;; (iup:attribute-set! steps-matrix "WIDTH0" "100")
-
- ;; Data matrix
- ;;
- (let ((rownum 1))
- (for-each
- (lambda (x)
- (iup:attribute-set! data-matrix (conc "0:" rownum) x)
- (iup:attribute-set! data-matrix (conc "WIDTH" rownum) "50")
- (set! rownum (+ rownum 1)))
- (list "Category" "Variable" "Value" "Expected" "Tolerance" "Status" "Units" "Type" "Comment")))
- (iup:attribute-set! data-matrix "REDRAW" "ALL")
-
- (for-each
- (lambda (data)
- (let ((mat (car data))
- (keys (cadr data))
- (rownum 1))
- (for-each
- (lambda (key)
- (iup:attribute-set! mat (conc rownum ":0") key)
- (set! rownum (+ rownum 1)))
- keys)
- (iup:attribute-set! mat "REDRAW" "ALL")))
- (list
- (list run-info-matrix '("Run Id" "Target" "Runname" "Run Start Time" ))
- (list test-info-matrix '("Test Id" "Testname" "Itempath" "State" "Status" "Test Start Time" "Comment"))
- (list test-run-matrix '("Hostname" "Host info" "Disk Free" "CPU Load" "Run Duration"))
- (list meta-dat-matrix '("Author" "Owner" "Last Reviewed" "Tags" "Description"))))
-
- (iup:split
- #:orientation "HORIZONTAL"
- (iup:vbox
- (iup:hbox
- (iup:vbox
- run-info-matrix
- test-info-matrix)
- ;; test-info-matrix)
- (iup:vbox
- test-run-matrix
- meta-dat-matrix))
- (iup:vbox
- (iup:vbox
- (iup:hbox
- (iup:button "View Log" #:action viewlog #:size "60x" ) ;; #:size "30x"
- (iup:button "Start Xterm" #:action xterm #:size "60x" )) ;; #:size "30x"
- (iup:hbox
- (iup:button "Run Test" #:action run-test #:size "60x" ) ;; #:size "30x"
- (iup:button "Clean Test" #:action remove-test #:size "60x" ))) ;; #:size "30x"
- (iup:hbox
- ;; hiup:split ;; hbox
- ;; #:orientation "HORIZONTAL"
- ;; #:value 300
- command-text-box
- command-launch-button)))
- (iup:vbox
- (let ((tabs (iup:tabs
- steps-matrix
- data-matrix)))
- (iup:attribute-set! tabs "TABTITLE0" "Test Steps")
- (iup:attribute-set! tabs "TABTITLE1" "Test Data")
- tabs)))))
-
-;; Test browser
-(define (tests window-id)
- (iup:split
- (let* ((tb (iup:treebox
- #:selection-cb
- (lambda (obj id state)
- ;; (print "obj: " obj ", id: " id ", state: " state)
- (let* ((run-path (tree:node->path obj id))
- (test-id (tree-path->test-id (cdr run-path))))
- ;; (if test-id
- ;; (hash-table-set! (dboard:data-curr-test-ids *data*)
- ;; window-id test-id))
- (print "path: " (tree:node->path obj id) " test-id: " test-id))))))
- (iup:attribute-set! tb "VALUE" "0")
- (iup:attribute-set! tb "NAME" "Runs")
- ;;(iup:attribute-set! tb "ADDEXPANDED" "NO")
- ;; (dboard:data-tests-tree-set! *data* tb)
- tb)
- (test-panel window-id)))
-
-;; The function to update the fields in the test view panel
-(define (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix)
- ;; get test-id
- ;; then get test record
- (if testdat
- (let* ((test-id 0) ;; (hash-table-ref/default (dboard:data-curr-test-ids *data*) window-id #f))
- (test-data (hash-table-ref/default testdat test-id #f))
- (run-id (db:test-get-run_id test-data))
- (targ/runname (hash-table-ref/default (dboard:data-run-keys *data*)
- run-id
- '()))
- (target (if (null? targ/runname) "" (string-intersperse (reverse (cdr (reverse targ/runname))) "/")))
- (runname (if (null? targ/runname) "" (car (cdr targ/runname))))
- (steps-dat (tests:get-compressed-steps *dbstruct-local* run-id test-id)))
-
- (if test-data
- (begin
- ;;
- (for-each
- (lambda (data)
- (let ((mat (car data))
- (vals (cadr data))
- (rownum 1))
- (for-each
- (lambda (key)
- (let ((cell (conc rownum ":1")))
- (if (not (equal? (iup:attribute mat cell)(conc key)))
- (begin
- ;; (print "setting cell " cell " in matrix " mat " to value " key)
- (iup:attribute-set! mat cell (conc key))
- (iup:attribute-set! mat "REDRAW" cell)))
- (set! rownum (+ rownum 1))))
- vals)))
- (list
- (list run-info-matrix
- (if test-id
- (list (db:test-get-run_id test-data)
- target
- runname
- "n/a")
- (make-list 4 "")))
- (list test-info-matrix
- (if test-id
- (list test-id
- (db:test-get-testname test-data)
- (db:test-get-item-path test-data)
- (db:test-get-state test-data)
- (db:test-get-status test-data)
- (seconds->string (db:test-get-event_time test-data))
- (db:test-get-comment test-data))
- (make-list 7 "")))
- (list test-run-matrix
- (if test-id
- (list (db:test-get-host test-data)
- (db:test-get-uname test-data)
- (db:test-get-diskfree test-data)
- (db:test-get-cpuload test-data)
- (seconds->hr-min-sec (db:test-get-run_duration test-data)))
- (make-list 5 "")))
- ))
- (dcommon:populate-steps steps-dat steps-matrix))))))
- ;;(list meta-dat-matrix
- ;; (if test-id
- ;; (list (
-
-
-;; db:test-get-id
-;; db:test-get-run_id
-;; db:test-get-testname
-;; db:test-get-state
-;; db:test-get-status
-;; db:test-get-event_time
-;; db:test-get-host
-;; db:test-get-cpuload
-;; db:test-get-diskfree
-;; db:test-get-uname
-;; db:test-get-rundir
-;; db:test-get-item-path
-;; db:test-get-run_duration
-;; db:test-get-final_logf
-;; db:test-get-comment
-;; db:test-get-fullname
-
-
-;;======================================================================
-;; R U N C O N T R O L
-;;======================================================================
-
-;; Overall runs browser
-;;
-(define (runs window-id)
- (let* ((runs-matrix (iup:matrix
- #:expand "YES"
- ;; #:fittosize "YES"
- #:scrollbar "YES"
- #:numcol 100
- #:numlin 100
- #:numcol-visible 7
- #:numlin-visible 7
- #:click-cb (lambda (obj lin col status)
- (print "obj: " obj " lin: " lin " col: " col " status: " status)))))
-
- (iup:attribute-set! runs-matrix "RESIZEMATRIX" "YES")
- (iup:attribute-set! runs-matrix "WIDTH0" "100")
-
- ;; (dboard:data-runs-matrix-set! *data* runs-matrix)
- (iup:hbox
- (iup:frame
- #:title "Runs browser"
- (iup:vbox
- runs-matrix)))))
-
-;; Browse and control a single run
-;;
-(define (runcontrol window-id)
- (iup:hbox))
-
-;;======================================================================
-;; D A S H B O A R D
-;;======================================================================
-
-;; Main Panel
-(define (main-panel window-id)
- (iup:dialog
- #:title "Megatest Control Panel"
- #:menu (dcommon:main-menu)
- #:shrink "YES"
- (let ((tabtop (iup:tabs
- (runs window-id)
- (tests window-id)
- (runcontrol window-id)
- (mtest *toppath* window-id)
- (rconfig window-id)
- )))
- (iup:attribute-set! tabtop "TABTITLE0" "Runs")
- (iup:attribute-set! tabtop "TABTITLE1" "Tests")
- (iup:attribute-set! tabtop "TABTITLE2" "Run Control")
- (iup:attribute-set! tabtop "TABTITLE3" "megatest.config")
- (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config")
- tabtop)))
-
-(define *current-window-id* 0)
-
-(define (newdashboard dbstruct)
- (let* ((data (make-hash-table))
- (keys '()) ;; (db:get-keys dbstruct))
- (runname "%")
- (testpatt "%")
- (keypatts '()) ;; (map (lambda (k)(list k "%")) keys))
- (states '())
- (statuses '())
- (nextmintime (current-milliseconds))
- (my-window-id *current-window-id*))
- (set! *current-window-id* (+ 1 *current-window-id*))
- ;; (dboard:data-runs-set! *data* data) ;; make this data available to the rest of the application
- (iup:show (main-panel my-window-id))
- ;; Yes, running iup:show will pop up a new panel
- ;; (iup:show (main-panel my-window-id))
- (iup:callback-set! *tim*
- "ACTION_CB"
- (lambda (x)
- ;; Want to dedicate no more than 50% of the time to this so skip if
- ;; 2x delta time has not passed since last query
- (if (< nextmintime (current-milliseconds))
- (let* ((starttime (current-milliseconds))
- ;; (changes (dcommon:run-update keys data runname keypatts testpatt states statuses 'full my-window-id))
- (endtime (current-milliseconds)))
- (set! nextmintime (+ endtime (* 2 (- endtime starttime))))
- ;; (debug:print 11 *default-log-port* "CHANGE(S): " (car changes) "..."))
- )
- (debug:print-info 11 *default-log-port* "Server overloaded"))))))
-
-;; (dboard:data-updaters-set! *data* (make-hash-table))
-(newdashboard #f) ;; *dbstruct-local*)
-(iup:main-loop)
DELETED ods.scm
Index: ods.scm
==================================================================
--- ods.scm
+++ /dev/null
@@ -1,225 +0,0 @@
-;; Copyright 2011, 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 .
-;;
-
-(use csv-xml regex)
-(declare (unit ods))
-(declare (uses common))
-
-(define ods:dirs
- '("Configurations2"
- "Configurations2/toolpanel"
- "Configurations2/menubar"
- "Configurations2/toolbar"
- "Configurations2/progressbar"
- "Configurations2/floater"
- "Configurations2/images"
- "Configurations2/images/Bitmaps"
- "Configurations2/statusbar"
- "Configurations2/popupmenu"
- "Configurations2/accelerator"
- "META-INF"
- "Thumbnails"))
-
-(define ods:0-len-files
- '("Configurations2/accelerator/current.xml"
- ;; "Thumbnails/thumbnail.png"
- "content.xml"
- ))
-
-(define ods:files
- '(("META-INF/manifest.xml"
- ("\n"
- "\n"
- "\n"
- "\n"
- "\n"
- "\n"
- "\n"
- "\n"
- "\n"
- "\n"
- "\n"
- "\n"
- "\n"
- "\n"
- "\n"
- "\n"
- "