Index: api.scm
==================================================================
--- api.scm
+++ api.scm
@@ -23,10 +23,12 @@
get-var
get-keys
get-key-vals
test-toplevel-num-items
get-test-info-by-id
+ get-steps-info-by-id
+ get-data-info-by-id
test-get-rundir-from-test-id
get-count-tests-running-for-testname
get-count-tests-running
get-count-tests-running-in-jobgroup
get-previous-test-run-record
@@ -66,10 +68,11 @@
login
tasks-get-last
testmeta-get-record
have-incompletes?
synchash-get
+ get-changed-record-ids
))
(define api:write-queries
'(
get-keys-write ;; dummy "write" query to force server start
Index: cgisetup/models/pgdb.scm
==================================================================
--- cgisetup/models/pgdb.scm
+++ cgisetup/models/pgdb.scm
@@ -193,10 +193,23 @@
dbh
"SELECT id FROM test_data WHERE test_id=? AND category=? and variable = ? ;"
test-id category variable))
(define (pgdb:insert-test-data dbh test-id category variable value expected tol units comment status type)
+ ; (print "INSERT INTO test_data (test_id, category, variable, value, expected, tol, units, comment, status, type)
+ ; VALUES (?,?,?,?,?,?,?,?,?,?) " test-id " " category " " variable " " value " " expected " " tol " " units " " comment " " status " " type)
+ (if (not (string? units))
+ (set! units "" ))
+ (if (not (string? variable))
+ (set! variable "" ))
+ (if (not (real? value))
+ (set! value 0 ))
+ (if (not (real? expected))
+ (set! expected 0 ))
+(if (not (real? tol))
+ (set! tol 0 ))
+
(dbi:exec
dbh
"INSERT INTO test_data (test_id, category, variable, value, expected, tol, units, comment, status, type)
VALUES (?,?,?,?,?,?,?,?,?,?);"
test-id category variable value expected tol units comment status type))
Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -801,16 +801,26 @@
(define (std-signal-handler signum)
;; (signal-mask! signum)
(set! *time-to-exit* #t)
;;(debug:print-info 13 *default-log-port* "got signal "signum)
- (debug:print-error 0 *default-log-port* "Received signal " signum " exiting promptly")
+ (debug:print-error 0 *default-log-port* "Received signal " signum " aaa exiting promptly")
+ ;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway
+ (exit))
+
+(define (special-signal-handler signum)
+ ;; (signal-mask! signum)
+ (set! *time-to-exit* #t)
+ ;;(debug:print-info 13 *default-log-port* "got signal "signum)
+ (debug:print-error 0 *default-log-port* "Received signal " signum " sending email befor exiting!!")
;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway
(exit))
+
(set-signal-handler! signal/int std-signal-handler) ;; ^C
(set-signal-handler! signal/term std-signal-handler)
+
;; (set-signal-handler! signal/stop std-signal-handler) ;; ^Z NO, do NOT handle ^Z!
;;======================================================================
;; M I S C U T I L S
;;======================================================================
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -214,11 +214,12 @@
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
- -generate-html : create a simple html tree for browsing your runs
+ -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 <patt> -target-patt <patt> -dumpmode <csv,json,plain-text>
-list-test-time : list time requered to complete each test in a run. It following following arguments
-runname <patt> -target <patt> -dumpmode <csv,json,plain-text>
@@ -374,11 +375,12 @@
"-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"
+ "-generate-html-structure"
"-list-run-time"
"-list-test-time"
;; misc queries
"-list-disks"
"-list-targets"
@@ -2255,11 +2257,17 @@
(let* ((toppath (launch:setup)))
(if (tests:create-html-tree #f)
(debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/page#.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)))
;;======================================================================
;; Exit and clean up
;;======================================================================
(if (not *didsomething*)
Index: mt-pg.sql
==================================================================
--- mt-pg.sql
+++ mt-pg.sql
@@ -1,11 +1,11 @@
-- CREATE TABLE IF NOT EXISTS keys (
-- id SERIAL PRIMARY KEY,
-- fieldname TEXT,
-- fieldtype TEXT,
-- CONSTRAINT keyconstraint UNIQUE (fieldname));
-
+DROP VIEW IF EXISTS area_tag_view;
DROP TABLE IF EXISTS areas;
DROP TABLE IF EXISTS ttype;
DROP TABLE IF EXISTS runs;
DROP TABLE IF EXISTS run_stats;
DROP TABLE IF EXISTS test_meta;
@@ -25,10 +25,14 @@
DROP TABLE IF EXISTS sessions;
DROP TABLE IF EXISTS tags;
DROP TABLE IF EXISTS users;
DROP TABLE IF EXISTS webviews;
DROP TABLE IF EXISTS area_tags;
+
+DROP TABLE IF EXISTS users_webviews;
+
+
CREATE TABLE IF NOT EXISTS session_vars (
id SERIAL PRIMARY KEY,
session_id INTEGER,
page TEXT,
@@ -56,10 +60,14 @@
id SERIAL PRIMARY KEY,
tag_id INTEGER DEFAULT 0,
area_id INTEGER DEFAULT 0,
CONSTRAINT areatagconstraint UNIQUE (tag_id, area_id));
+CREATE VIEW area_tag_view as
+select a.id as aid, t.id as tid,area_name,tag_name from areas as a inner join area_tags as at on at.area_id = a.id
+inner join tags as t on t.id = at.tag_id ;
+
INSERT INTO areas (id,area_name,area_path) VALUES (0,'local','.');
CREATE TABLE IF NOT EXISTS ttype (
id SERIAL PRIMARY KEY,
target_spec TEXT DEFAULT '');
@@ -225,13 +233,14 @@
du INTEGER,
archive_path TEXT);
CREATE TABLE IF NOT EXISTS users(
id SERIAL PRIMARY KEY ,
- usename TEXT NOT NULL,
+ username TEXT NOT NULL,
fullname TEXT NOT NULL,
email TEXT NOT NULL,
+ default_view TEXT default '',
deleted INTEGER default 0
);
CREATE TABLE IF NOT EXISTS webviews(
id SERIAL PRIMARY KEY ,
@@ -239,11 +248,23 @@
name TEXT NOT NULL,
ttype_id INTEGER DEFAULT 0,
view_specifics TEXT ,
col TEXT NOT NULL,
row TEXT NOT NULL,
+ public INTEGER DEFAULT 0,
deleted INTEGER default 0
);
+
+
+
+CREATE TABLE IF NOT EXISTS users_webviews(
+ id SERIAL PRIMARY KEY ,
+ user_id INTEGER NOT NULL,
+ webview_id INTEGER NOT NULL,
+ deleted INTEGER default 0,
+ searchpattern TEXT Default ''
+);
+
-- TRUNCATE archive_blocks, archive_allocations, extradat, metadat,
-- access_log, tests, test_steps, test_data, test_rundat, archives, runs,
-- run_stats, test_meta, tasks_queue, archive_disks;
Index: mtut.scm
==================================================================
--- mtut.scm
+++ mtut.scm
@@ -1226,11 +1226,14 @@
(let* ((rep (start-nn-server portnum))
(mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
(script (configf:lookup mtconf "listener" "script")))
(print "Listening on port " portnum " for messages")
- (let loop ((instr (nn-recv rep)))
+ (set-signal-handler! signal/int special-signal-handler)
+ (set-signal-handler! signal/term special-signal-handler)
+
+ (let loop ((instr (nn-recv rep)))
(print "received " instr ", running \"" script " " instr "\"")
(system (conc script " '" instr "'"))
(nn-send rep "ok")
(loop (nn-recv rep))))
(print "ERROR: Port " portnum " already in use. Try another port")))))))
Index: tasks.scm
==================================================================
--- tasks.scm
+++ tasks.scm
@@ -849,16 +849,26 @@
(begin
(if pgdb-test-id
(begin
(if pgdb-data-id
(begin
- (print "Updating existing test-data with test-id: " test-id " and data-id " data-id " pgdb test id: " pgdb-test-id)
+ (print "Updating existing test-data with test-id: " test-id " and data-id " data-id " pgdb test id: " pgdb-test-id)
(pgdb:update-test-data dbh pgdb-data-id pgdb-test-id category variable value expected tol units comment status type))
(begin
(print "Inserting test-data with test-id: " test-id " and data-id " data-id " pgdb test id: " pgdb-test-id)
- (pgdb:insert-test-data dbh pgdb-test-id category variable value expected tol units comment status type )
- (set! pgdb-data-id (pgdb:get-test-data-id dbh pgdb-test-id category variable))))
+ (if (handle-exceptions
+ exn
+ (begin (print-call-chain)
+ (print ((condition-property-accessor 'exn 'message) exn))
+ #f)
+
+ (pgdb:insert-test-data dbh pgdb-test-id category variable value expected tol units comment status type ))
+ ;(tasks:run-id->mtpg-run-id dbh cached-info run-id area-info)
+ (begin
+ ;(pgdb:insert-test-data dbh pgdb-test-id category variable value expected tol units comment status type )
+ (set! pgdb-data-id (pgdb:get-test-data-id dbh pgdb-test-id category variable)))
+ (exit))))
(hash-table-set! data-ht data-id pgdb-data-id ))
(begin
(print "Error: Test not in pgdb"))))
(print "Error: Could not get test data info for data id " test-data-id )))) ;; this is a wierd senario need to debug
Index: tests.scm
==================================================================
--- tests.scm
+++ tests.scm
@@ -937,10 +937,177 @@
link)))
(html-body (tests:dashboard-body pg pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links #t)))
;(print (tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name))
html-body))
+(define (tests:create-html-summary outf)
+ (let* ((lockfile (conc outf ".lock"))
+ (linktree (common:get-linktree))
+ (keys (rmt:get-keys))
+ (area-name (common:get-testsuite-name)))
+ (if (common:simple-file-lock lockfile)
+ (begin
+ (let* ((runsdat (rmt:get-runs "%" #f #f (map (lambda (x)(list x "%")) keys)))
+ (runs (vector-ref runsdat 1))
+ (header (vector-ref runsdat 0))
+ (oup (open-output-file (or outf (conc linktree "/targets.html"))))
+ (target-hash (test:create-target-hash runs header (length keys))))
+ (test:create-target-html target-hash oup area-name linktree)
+ (test:create-run-html runs area-name linktree (length keys) header))
+ (common:simple-file-release-lock lockfile))
+ #f)))
+
+(define (test:get-test-hash test-data)
+ (let ((resh (make-hash-table)))
+ (map (lambda (test)
+ (let* ((test-name (vector-ref test 2))
+ (test-html-path (if (file-exists? (conc (vector-ref test 10) "/test-summary.html"))
+ (conc (vector-ref test 10) "/test-summary.html" )
+ (conc (vector-ref test 10) "/" (vector-ref test 13))))
+ (test-item (vector-ref test 11))
+ (test-status (vector-ref test 4)))
+ (if (not (hash-table-ref/default resh test-item #f))
+ (hash-table-set! resh test-item (make-hash-table)))
+ (hash-table-set! (hash-table-ref/default resh test-item #f) test-name (list test-status test-html-path))))
+ test-data)
+resh))
+
+(define (test:get-data->b-keys ordered-data a-keys)
+ (delete-duplicates
+ (sort (apply
+ append
+ (map (lambda (sub-key)
+ (let ((subdat (hash-table-ref ordered-data sub-key)))
+ (hash-table-keys subdat)))
+ a-keys))
+ string>=?)))
+
+
+(define (test:create-run-html runs area-name linktree numkeys header)
+ (map (lambda (run)
+ (let* ((target (string-join (take (vector->list run) numkeys) "/"))
+ (run-name (db:get-value-by-header run header "runname"))
+ (oup (open-output-file (conc linktree "/" target "/" run-name "/run.html")))
+ (run-id (db:get-value-by-header run header "id"))
+ (test-data (rmt:get-tests-for-run
+ run-id
+ "%" ;; testnamepatt
+ '() ;; states
+ '() ;; statuses
+ #f ;; offset
+ #f ;; num-to-get
+ #f ;; hide/not-hide
+ #f ;; sort-by
+ #f ;; sort-order
+ #f ;; 'shortlist ;; qrytype
+ 0 ;; last update
+ #f))
+ (item-test-hash (test:get-test-hash test-data))
+ (items (hash-table-keys item-test-hash))
+ (test-names (test:get-data->b-keys item-test-hash items)))
+ (s:output-new
+ oup
+ (s:html tests:css-jscript-block (tests:css-jscript-block-cond #f)
+
+ (s:title "Runs View " run-name)
+ (s:body
+ (s:h1 "Runs View " )
+ (s:h2 "Target" target)
+ (s:h2 "Run name" run-name)
+ (s:table 'border 1
+ (s:tr
+ (s:td "Items")
+ (map (lambda (test)
+ (s:td test))
+ test-names))
+ (map (lambda (item)
+ (let* ((test-hash (hash-table-ref/default item-test-hash item #f)))
+ (if test-hash
+ (begin
+ (s:tr
+ (s:td item)
+ (map (lambda (test)
+ (let* ((test-details (hash-table-ref/default test-hash test #f))
+ (status (if test-details
+ (car test-details)))
+ (link (if test-details
+ (cadr test-details))))
+ (if test-details
+ (s:td 'class status
+ (s:a 'href link status ))
+ (s:td ""))))
+ test-names))))))
+ (sort items string<=?))))))
+ (close-output-port oup)))
+runs))
+
+(define (test:create-target-hash runs header numkeys)
+ (let ((resh (make-hash-table)))
+ (for-each
+ (lambda (run)
+ (let* ((run-name (db:get-value-by-header run header "runname"))
+ (target (string-join (take (vector->list run) numkeys) "/"))
+ (run-list (hash-table-ref/default resh target #f)))
+
+ (if (not run-list)
+ (hash-table-set! resh target (list run-name))
+ (hash-table-set! resh target (cons run-name run-list)))))
+ runs)
+ resh))
+
+(define (test:get-max-run-cnt target-hash targets)
+ (let* ((cnt 0 ))
+ (map (lambda (target)
+ (let* ((runs (hash-table-ref/default target-hash target #f))
+ (run-length (if runs
+ (length runs)
+ 0)))
+
+ (if (< cnt run-length)
+ (set! cnt run-length))))
+ targets)
+cnt))
+
+(define (test:pad-runs target-hash targets max-row-length)
+ (map (lambda (target)
+ (let loop ((run-list (hash-table-ref/default target-hash target #f)))
+ (if (< (length run-list) max-row-length)
+ (begin
+ (hash-table-set! target-hash target (cons "" run-list))
+ (loop (hash-table-ref/default target-hash target #f) )))))
+ targets)
+ target-hash)
+
+(define (test:create-target-html target-hash oup area-name linktree)
+ (let* ((targets (hash-table-keys target-hash))
+ (max-row-length (test:get-max-run-cnt target-hash targets))
+ (pad-runs-hash (test:pad-runs target-hash targets max-row-length)))
+ (s:output-new
+ oup
+ (s:html tests:css-jscript-block (tests:css-jscript-block-cond #f)
+
+ (s:title "Target View " area-name)
+ (s:body
+ (s:h1 "Target View " area-name)
+ (s:table 'id "LinkedList1" 'border "1"
+ (s:tr 'class "something"
+ (s:td "Target")
+ (s:td 'colspan max-row-length "Runs"))
+ (let* ((tbl (map (lambda (target)
+ (s:tr
+ (s:td target)
+ (let* ((runs (hash-table-ref/default target-hash target #f))
+ (rest-row (map (lambda (run)
+ (if (equal? run "")
+ (s:td run)
+ (s:td
+ (s:a 'href (conc linktree "/" target "/" run "/run.html") run))))
+ (reverse runs))))
+ rest-row)))
+ targets)))
+ tbl)))))
+ (close-output-port oup)))
(define (tests:create-html-tree-old outf)
(let* ((lockfile (conc outf ".lock"))
(runs-to-process '()))